//PROTOTYPE IMPL!!!!!!!!
//BUG BUG Result ought to be dense/sparse/diag according as M is....
matrix apply(RingHom phi, ConstMatrixView M)
{
CoCoA_ASSERT(domain(phi) == RingOf(M));
matrix NewM(NewDenseMat(codomain(phi), NumRows(M), NumCols(M)));
for (long i=0; i < NumRows(M); ++i)
for (long j=0; j < NumCols(M); ++j)
SetEntry(NewM, i, j, phi(M(i,j)));
return NewM;
}
// Simple rather than efficient (esp. the call to eval)
std::vector<RingElem> BM_generic(const SparsePolyRing& P, const ConstMatrixView& pts)
{
if (CoeffRing(P) != RingOf(pts)) CoCoA_ERROR(ERR::MixedRings, "Buchberger-Moeller");
if (NumIndets(P) < NumCols(pts)) CoCoA_ERROR(ERR::IncompatDims, "Buchberger-Moeller");
const long NumPts = NumRows(pts);
const long dim = NumCols(pts);
const ring k = CoeffRing(P);
vector<RingElem> GB;
const PPMonoid TT = PPM(P);
QBGenerator QBG(TT);
QBG.myCornerPPIntoQB(one(TT));
matrix M = NewDenseMat(k, 1, NumPts);
// Fill first row with 1:
for (int i=0; i<NumPts; ++i) SetEntry(M,0,i, 1);
// The next loop removes the last indets from consideration.
for (int i=dim; i < NumIndets(TT); ++i)
QBG.myCornerPPIntoAvoidSet(indet(TT,i));
while (!QBG.myCorners().empty())
{
const PPMonoidElem t = QBG.myCorners().front();
const vector<RingElem> v = eval(t, pts);
ConstMatrixView NewRow = RowMat(v);
const matrix a = LinSolve(transpose(M), transpose(NewRow));
if (IsValidSolution(a))
{
QBG.myCornerPPIntoAvoidSet(t);
RingElem NewGBElem = monomial(P, one(k), t);
const vector<PPMonoidElem>& QB = QBG.myQB();
for (int i=0; i < NumRows(M); ++i)
NewGBElem -= monomial(P, a(i,0), QB[i]);
GB.push_back(NewGBElem);
}
else
{
QBG.myCornerPPIntoQB(t);
M = NewDenseMat(ConcatVer(M, NewRow));
}
}
return GB;
}
matrix NewDenseMat(const ring& R, const std::vector< std::vector<RingElem> >& VV)
{
if (!IsRectangular(VV))
CoCoA_ERROR(ERR::BadMatrixSize, "NewDenseMat()");
const long NumRows = len(VV);
if (NumRows == 0) return NewDenseMat(R, 0, 0);
const long NumCols = len(VV[0]);
matrix ans(new DenseMatImpl(R, NumRows, NumCols));
for (long i=0; i < NumRows; ++i)
for (long j=0; j < NumCols; ++j)
SetEntry(ans, i, j, VV[i][j]);
return ans;
}
CAMLprim value c_densematrix_new_dense_mat(value vm, value vn)
{
CAMLparam2(vm, vn);
CAMLlocal1(vr);
int m = Long_val(vm);
int n = Long_val(vn);
DlsMat a = NewDenseMat(m, n);
if (a == NULL)
caml_failwith("Could not create Dense Matrix.");
CAMLreturn(c_dls_dense_wrap(a, 1));
}
int IDADense(void *ida_mem, long int Neq)
{
IDAMem IDA_mem;
IDADlsMem idadls_mem;
int flag;
/* Return immediately if ida_mem is NULL. */
if (ida_mem == NULL)
{
IDAProcessError(NULL, IDADLS_MEM_NULL, "IDADENSE", "IDADense", MSGD_IDAMEM_NULL);
return(IDADLS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the NVECTOR package is compatible with the DENSE solver */
if (vec_tmpl->ops->nvgetarraypointer == NULL ||
vec_tmpl->ops->nvsetarraypointer == NULL)
{
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDADENSE", "IDADense", MSGD_BAD_NVECTOR);
return(IDADLS_ILL_INPUT);
}
if (lfree != NULL)
{
flag = lfree(IDA_mem);
}
/* Set five main function fields in IDA_mem. */
linit = IDADenseInit;
lsetup = IDADenseSetup;
lsolve = IDADenseSolve;
lperf = NULL;
lfree = IDADenseFree;
/* Get memory for IDADlsMemRec. */
idadls_mem = NULL;
idadls_mem = (IDADlsMem) malloc(sizeof(struct IDADlsMemRec));
if (idadls_mem == NULL)
{
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDADENSE", "IDADense", MSGD_MEM_FAIL);
return(IDADLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_DENSE;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
djac = NULL;
jacdata = NULL;
last_flag = IDADLS_SUCCESS;
setupNonNull = TRUE;
/* Store problem size */
neq = Neq;
/* Allocate memory for JJ and pivot array. */
JJ = NULL;
JJ = NewDenseMat(Neq, Neq);
if (JJ == NULL)
{
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDADENSE", "IDADense", 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, "IDADENSE", "IDADense", 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 KINDense(void *kinmem, long int N)
{
KINMem kin_mem;
KINDlsMem kindls_mem;
/* Return immediately if kinmem is NULL */
if (kinmem == NULL) {
KINProcessError(NULL, KINDLS_MEM_NULL, "KINDENSE", "KINDense", MSGD_KINMEM_NULL);
return(KINDLS_MEM_NULL);
}
kin_mem = (KINMem) kinmem;
/* Test if the NVECTOR package is compatible with the DENSE solver */
if (vec_tmpl->ops->nvgetarraypointer == NULL ||
vec_tmpl->ops->nvsetarraypointer == NULL) {
KINProcessError(kin_mem, KINDLS_ILL_INPUT, "KINDENSE", "KINDense", MSGD_BAD_NVECTOR);
return(KINDLS_ILL_INPUT);
}
if (lfree !=NULL) lfree(kin_mem);
/* Set four main function fields in kin_mem */
linit = kinDenseInit;
lsetup = kinDenseSetup;
lsolve = kinDenseSolve;
lfree = kinDenseFree;
/* Get memory for KINDlsMemRec */
kindls_mem = NULL;
kindls_mem = (KINDlsMem) malloc(sizeof(struct KINDlsMemRec));
if (kindls_mem == NULL) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINDENSE", "KINDense", MSGD_MEM_FAIL);
return(KINDLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_DENSE;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
djac = NULL;
J_data = NULL;
last_flag = KINDLS_SUCCESS;
kinDlsInitializeCounters(kindls_mem);
setupNonNull = TRUE;
/* Set problem dimension */
n = N;
/* Allocate memory for J and pivot array */
J = NULL;
J = NewDenseMat(N, N);
if (J == NULL) {
KINProcessError(kin_mem, KINDLS_MEM_FAIL, "KINDENSE", "KINDense", 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, "KINDENSE", "KINDense", 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 CVDense(void *cvode_mem, long int N)
{
CVodeMem cv_mem;
CVDlsMem cvdls_mem;
/* Return immediately if cvode_mem is NULL */
if (cvode_mem == NULL) {
cvProcessError(NULL, CVDLS_MEM_NULL, "CVSDENSE", "CVDense", MSGD_CVMEM_NULL);
return(CVDLS_MEM_NULL);
}
cv_mem = (CVodeMem) cvode_mem;
/* Test if the NVECTOR package is compatible with the DENSE solver */
if (vec_tmpl->ops->nvgetarraypointer == NULL ||
vec_tmpl->ops->nvsetarraypointer == NULL) {
cvProcessError(cv_mem, CVDLS_ILL_INPUT, "CVSDENSE", "CVDense", MSGD_BAD_NVECTOR);
return(CVDLS_ILL_INPUT);
}
if (lfree !=NULL) lfree(cv_mem);
/* Set four main function fields in cv_mem */
linit = cvDenseInit;
lsetup = cvDenseSetup;
lsolve = cvDenseSolve;
lfree = cvDenseFree;
/* Get memory for CVDlsMemRec */
cvdls_mem = NULL;
cvdls_mem = (CVDlsMem) malloc(sizeof(struct CVDlsMemRec));
if (cvdls_mem == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSDENSE", "CVDense", MSGD_MEM_FAIL);
return(CVDLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_DENSE;
/* Initialize Jacobian-related data */
jacDQ = TRUE;
jac = NULL;
J_data = NULL;
last_flag = CVDLS_SUCCESS;
setupNonNull = TRUE;
/* Set problem dimension */
n = N;
/* Allocate memory for M, savedJ, and pivot array */
M = NULL;
M = NewDenseMat(N, N);
if (M == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSDENSE", "CVDense", MSGD_MEM_FAIL);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
savedJ = NULL;
savedJ = NewDenseMat(N, N);
if (savedJ == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSDENSE", "CVDense", MSGD_MEM_FAIL);
DestroyMat(M);
free(cvdls_mem); cvdls_mem = NULL;
return(CVDLS_MEM_FAIL);
}
lpivots = NULL;
lpivots = NewLintArray(N);
if (lpivots == NULL) {
cvProcessError(cv_mem, CVDLS_MEM_FAIL, "CVSDENSE", "CVDense", 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);
}
std::vector<RingElem> BM_QQ(const SparsePolyRing& P, const ConstMatrixView& pts_in)
{
const long NumPts = NumRows(pts_in);
const long dim = NumCols(pts_in);
matrix pts = NewDenseMat(RingQQ(), NumPts, dim);
for (long i=0; i < NumPts; ++i)
for (long j=0; j < dim; ++j)
{
BigRat q;
if (!IsRational(q, pts_in(i,j))) throw 999;
SetEntry(pts,i,j, q);
}
// Ensure input pts have integer coords by using
// scale factors for each indet.
vector<BigInt> ScaleFactor(dim, BigInt(1));
for (long j=0; j < dim; ++j)
for (long i=0; i < NumPts; ++i)
ScaleFactor[j] = lcm(ScaleFactor[j], ConvertTo<BigInt>(den(pts(i,j))));
mpz_t **points = (mpz_t**)malloc(NumPts*sizeof(mpz_t*));
for (long i=0; i < NumPts; ++i)
{
points[i] = (mpz_t*)malloc(dim*sizeof(mpz_t));
for (long j=0; j < dim; ++j) mpz_init(points[i][j]);
for (long j=0; j < dim; ++j)
{
mpz_set(points[i][j], mpzref(ConvertTo<BigInt>(ScaleFactor[j]*pts(i,j))));
}
}
BMGB char0; // these will be "filled in" by BM_affine below
BM modp; //
pp_cmp_PPM = &PPM(P); // not threadsafe!
BM_affine(&char0, &modp, dim, NumPts, points, pp_cmp); // THIS CALL DOES THE REAL WORK!!!
pp_cmp_PPM = NULL;
for (long i=NumPts-1; i >=0 ; --i)
{
for (long j=0; j < dim; ++j) mpz_clear(points[i][j]);
free(points[i]);
}
free(points);
if (modp == NULL) { if (char0 != NULL) BMGB_dtor(char0); CoCoA_ERROR("Something went wrong", "BM_QQ"); }
// Now extract the answer...
const int GBsize = char0->GBsize;
std::vector<RingElem> GB(GBsize);
const long NumVars = dim;
vector<long> expv(NumVars); // buffer for creating monomials
for (int i=0; i < GBsize; ++i)
{
BigInt denom(1); // scale factor needed to make GB elem monic.
for (int var = 0; var < NumVars; ++var)
{
expv[var] = modp->pp[modp->GB[i]][var];
denom *= power(ScaleFactor[var], expv[var]);
}
RingElem GBelem = monomial(P, 1, expv);
for (int j=0; j < NumPts; ++j)
{
if (mpq_sgn(char0->GB[i][j])==0) continue;
BigRat c(char0->GB[i][j]);
for (int var = 0; var < NumVars; ++var)
{
expv[var] = modp->pp[modp->sep[j]][var];
c *= power(ScaleFactor[var], expv[var]);
}
GBelem += monomial(P, c/denom, expv);
}
GB[i] = GBelem;
}
BMGB_dtor(char0);
BM_dtor(modp);
return GB;
// ignoring separators for the moment
}
/*
* -----------------------------------------------------------------
* IDALapackDense
* -----------------------------------------------------------------
* This routine initializes the memory record and sets various function
* fields specific to the linear solver module. IDALapackDense first
* calls the existing lfree routine if this is not NULL. Then it sets
* the ida_linit, ida_lsetup, ida_lsolve, ida_lfree fields in (*ida_mem)
* to be idaLapackDenseInit, idaLapackDenseSetup, idaLapackDenseSolve,
* and idaLapackDenseFree, respectively. It allocates memory for a
* structure of type IDADlsMemRec and sets the ida_lmem field in
* (*ida_mem) to the address of this structure. It sets setupNonNull
* in (*ida_mem) to TRUE, and the d_jac field to the default
* idaLapackDenseDQJac. Finally, it allocates memory for M, pivots.
*
* The return value is SUCCESS = 0, or LMEM_FAIL = -1.
*
* NOTE: The dense linear solver assumes a serial implementation
* of the NVECTOR package. Therefore, IDALapackDense will first
* test for a compatible N_Vector internal representation
* by checking that N_VGetArrayPointer and N_VSetArrayPointer
* exist.
* -----------------------------------------------------------------
*/
int IDALapackDense(void *ida_mem, int N)
{
IDAMem IDA_mem;
IDADlsMem idadls_mem;
/* Return immediately if ida_mem is NULL */
if (ida_mem == NULL) {
IDAProcessError(NULL, IDADLS_MEM_NULL, "IDALAPACK", "IDALapackDense", MSGD_IDAMEM_NULL);
return(IDADLS_MEM_NULL);
}
IDA_mem = (IDAMem) ida_mem;
/* Test if the NVECTOR package is compatible with the LAPACK solver */
if (tempv->ops->nvgetarraypointer == NULL ||
tempv->ops->nvsetarraypointer == NULL) {
IDAProcessError(IDA_mem, IDADLS_ILL_INPUT, "IDALAPACK", "IDALapackDense", MSGD_BAD_NVECTOR);
return(IDADLS_ILL_INPUT);
}
if (lfree !=NULL) lfree(IDA_mem);
/* Set four main function fields in IDA_mem */
linit = idaLapackDenseInit;
lsetup = idaLapackDenseSetup;
lsolve = idaLapackDenseSolve;
lperf = NULL;
lfree = idaLapackDenseFree;
/* 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", "IDALapackDense", MSGD_MEM_FAIL);
return(IDADLS_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_DENSE;
/* Set default Jacobian routine and Jacobian data */
jacDQ = TRUE;
djac = NULL;
J_data = NULL;
last_flag = IDADLS_SUCCESS;
setupNonNull = TRUE;
/* Set problem dimension */
n = (long int) N;
/* Allocate memory for JJ and pivot array */
JJ = NULL;
pivots = NULL;
JJ = NewDenseMat(n, n);
if (JJ == NULL) {
IDAProcessError(IDA_mem, IDADLS_MEM_FAIL, "IDALAPACK", "IDALapackDense", 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", "IDALapackDense", 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);
}
/*---------------------------------------------------------------
ARKMassLapackDense:
This routine initializes the memory record and sets various
function fields specific to the mass matrix solver module.
ARKMassLapackDense first calls the existing mfree routine if
this is not NULL. Then it sets the ark_minit, ark_msetup,
ark_msolve, ark_mfree fields in (*arkode_mem) to be
arkMassLapackDenseInit, arkMassLapackDenseSetup,
arkMassLapackDenseSolve, and arkMassLapackDenseFree,
respectively. It allocates memory for a structure of type
ARKDlsMassMemRec and sets the ark_mass_mem field in
(*arkode_mem) to the address of this structure. It sets
MassSetupNonNull in (*arkode_mem) to TRUE. Finally, it
allocates memory for M and pivots. The return value is
SUCCESS = 0, or LMEM_FAIL = -1.
NOTE: The dense linear solver assumes a serial implementation
of the NVECTOR package. Therefore, ARKMassLapackDense will
first test for a compatible N_Vector internal
representation by checking that N_VGetArrayPointer and
N_VSetArrayPointer exist. Of course, other vector
implementations may also have these functions set, so
this test is not sufficient to guarantee use of the
serial NVECTOR package.
---------------------------------------------------------------*/
int ARKMassLapackDense(void *arkode_mem, int N,
ARKDlsDenseMassFn dmass)
{
ARKodeMem ark_mem;
ARKDlsMassMem arkdls_mem;
/* Return immediately if arkode_mem is NULL */
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKDLS_MEM_NULL, "ARKLAPACK",
"ARKMassLapackDense", MSGD_ARKMEM_NULL);
return(ARKDLS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Test if the NVECTOR package is compatible with the LAPACK solver */
if (ark_mem->ark_tempv->ops->nvgetarraypointer == NULL ||
ark_mem->ark_tempv->ops->nvsetarraypointer == NULL) {
arkProcessError(ark_mem, ARKDLS_ILL_INPUT, "ARKLAPACK",
"ARKMassLapackDense", MSGD_BAD_NVECTOR);
return(ARKDLS_ILL_INPUT);
}
if (ark_mem->ark_mfree !=NULL) ark_mem->ark_mfree(ark_mem);
/* Set related function fields in ark_mem, enable mass matrix */
ark_mem->ark_mass_matrix = TRUE;
ark_mem->ark_minit = arkMassLapackDenseInit;
ark_mem->ark_msetup = arkMassLapackDenseSetup;
ark_mem->ark_msolve = arkMassLapackDenseSolve;
ark_mem->ark_mfree = arkMassLapackDenseFree;
ark_mem->ark_mtimes = arkMassLapackDenseMultiply;
ark_mem->ark_mtimes_data = (void *) ark_mem;
ark_mem->ark_msolve_type = 1;
/* 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",
"ARKMassLapackDense", MSGD_MEM_FAIL);
return(ARKDLS_MEM_FAIL);
}
/* Set matrix type */
arkdls_mem->d_type = SUNDIALS_DENSE;
/* Initialize mass-matrix-related data */
arkdls_mem->d_dmass = dmass;
arkdls_mem->d_M_data = NULL;
arkdls_mem->d_last_flag = ARKDLS_SUCCESS;
ark_mem->ark_MassSetupNonNull = TRUE;
/* Set problem dimension */
arkdls_mem->d_n = (long int) N;
/* Allocate memory for M and pivot array */
arkdls_mem->d_M = NULL;
arkdls_mem->d_pivots = NULL;
arkdls_mem->d_M = NewDenseMat(arkdls_mem->d_n, arkdls_mem->d_n);
if (arkdls_mem->d_M == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKMassLapackDense", 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",
"ARKMassLapackDense", 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);
}
/*---------------------------------------------------------------
ARKLapackDense:
This routine initializes the memory record and sets various
function fields specific to the linear solver module.
ARKLapackDense first calls the existing lfree routine if this is
not NULL. Then it sets the ark_linit, ark_lsetup, ark_lsolve,
ark_lfree fields in (*arkode_mem) to be arkLapackDenseInit,
arkLapackDenseSetup, arkLapackDenseSolve, and arkLapackDenseFree,
respectively. It allocates memory for a structure of type
ARKDlsMemRec and sets the ark_lmem field in (*arkode_mem) to the
address of this structure. It sets setupNonNull in (*arkode_mem)
to TRUE, and the d_jac field to the default arkDlsDenseDQJac.
Finally, it allocates memory for M, pivots, and savedJ.
The return value is SUCCESS = 0, or LMEM_FAIL = -1.
NOTE: The dense linear solver assumes a serial implementation
of the NVECTOR package. Therefore, ARKLapackDense will
first test for a compatible N_Vector internal
representation by checking that N_VGetArrayPointer and
N_VSetArrayPointer exist. Of course, other vector
implementations may also have these functions set, so
this test is not sufficient to guarantee use of the
serial NVECTOR package.
---------------------------------------------------------------*/
int ARKLapackDense(void *arkode_mem, int N)
{
ARKodeMem ark_mem;
ARKDlsMem arkdls_mem;
/* Return immediately if arkode_mem is NULL */
if (arkode_mem == NULL) {
arkProcessError(NULL, ARKDLS_MEM_NULL, "ARKLAPACK",
"ARKLapackDense", MSGD_ARKMEM_NULL);
return(ARKDLS_MEM_NULL);
}
ark_mem = (ARKodeMem) arkode_mem;
/* Test if the NVECTOR package is compatible with the LAPACK solver */
if (ark_mem->ark_tempv->ops->nvgetarraypointer == NULL ||
ark_mem->ark_tempv->ops->nvsetarraypointer == NULL) {
arkProcessError(ark_mem, ARKDLS_ILL_INPUT, "ARKLAPACK",
"ARKLapackDense", MSGD_BAD_NVECTOR);
return(ARKDLS_ILL_INPUT);
}
if (ark_mem->ark_lfree !=NULL) ark_mem->ark_lfree(ark_mem);
/* Set four main function fields in ark_mem */
ark_mem->ark_linit = arkLapackDenseInit;
ark_mem->ark_lsetup = arkLapackDenseSetup;
ark_mem->ark_lsolve = arkLapackDenseSolve;
ark_mem->ark_lfree = arkLapackDenseFree;
ark_mem->ark_lsolve_type = 1;
/* Get memory for ARKDlsMemRec */
arkdls_mem = NULL;
arkdls_mem = (ARKDlsMem) malloc(sizeof(struct ARKDlsMemRec));
if (arkdls_mem == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKLapackDense", MSGD_MEM_FAIL);
return(ARKDLS_MEM_FAIL);
}
/* Set matrix type */
arkdls_mem->d_type = SUNDIALS_DENSE;
/* Initialize Jacobian-related data */
arkdls_mem->d_jacDQ = TRUE;
arkdls_mem->d_djac = NULL;
arkdls_mem->d_J_data = NULL;
arkdls_mem->d_last_flag = ARKDLS_SUCCESS;
ark_mem->ark_setupNonNull = TRUE;
/* Set problem dimension */
arkdls_mem->d_n = (long int) N;
/* Allocate memory for M, pivot array, and savedJ */
arkdls_mem->d_M = NULL;
arkdls_mem->d_pivots = NULL;
arkdls_mem->d_savedJ = NULL;
arkdls_mem->d_M = NewDenseMat(arkdls_mem->d_n, arkdls_mem->d_n);
if (arkdls_mem->d_M == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKLapackDense", 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",
"ARKLapackDense", MSGD_MEM_FAIL);
DestroyMat(arkdls_mem->d_M);
free(arkdls_mem); arkdls_mem = NULL;
return(ARKDLS_MEM_FAIL);
}
arkdls_mem->d_savedJ = NewDenseMat(arkdls_mem->d_n, arkdls_mem->d_n);
if (arkdls_mem->d_savedJ == NULL) {
arkProcessError(ark_mem, ARKDLS_MEM_FAIL, "ARKLAPACK",
"ARKLapackDense", MSGD_MEM_FAIL);
DestroyMat(arkdls_mem->d_M);
DestroyArray(arkdls_mem->d_pivots);
free(arkdls_mem); arkdls_mem = NULL;
return(ARKDLS_MEM_FAIL);
}
/* Attach linear solver memory to integrator memory */
ark_mem->ark_lmem = arkdls_mem;
return(ARKDLS_SUCCESS);
}
int CPDenseProj(void *cpode_mem, int Nc, int Ny, int fact_type)
{
CPodeMem cp_mem;
CPDlsProjMem cpdlsP_mem;
/* Return immediately if cpode_mem is NULL */
if (cpode_mem == NULL) {
cpProcessError(NULL, CPDIRECT_MEM_NULL, "CPDENSE", "CPDenseProj", MSGD_CPMEM_NULL);
return(CPDIRECT_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Test if the NVECTOR package is compatible with the DENSE solver */
if (tempv->ops->nvgetarraypointer == NULL ||
tempv->ops->nvsetarraypointer == NULL) {
cpProcessError(cp_mem, CPDIRECT_ILL_INPUT, "CPDENSE", "CPDenseProj", MSGD_BAD_NVECTOR);
return(CPDIRECT_ILL_INPUT);
}
/* Check if fact_type has a legal value */
if ( (fact_type != CPDIRECT_LU) && (fact_type != CPDIRECT_QR) && (fact_type != CPDIRECT_SC) ) {
cpProcessError(cp_mem, CPDIRECT_ILL_INPUT, "CPDENSE", "CPDenseProj", MSGD_BAD_FACT);
return(CPDIRECT_ILL_INPUT);
}
if (lfreeP !=NULL) lfreeP(cp_mem);
/* Set the five function fields in cp_mem */
linitP = cpDenseProjInit;
lsetupP = cpDenseProjSetup;
lsolveP = cpDenseProjSolve;
lmultP = cpDenseProjMult;
lfreeP = cpDenseProjFree;
/* Get memory for CPDlsProjMemRec */
cpdlsP_mem = NULL;
cpdlsP_mem = (CPDlsProjMem) malloc(sizeof(CPDlsProjMemRec));
if (cpdlsP_mem == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
return(CPDIRECT_MEM_FAIL);
}
lsetupP_exists = TRUE;
/* Initialize all internal pointers to NULL */
G = NULL;
K = NULL;
pivotsP = NULL;
beta = NULL;
/* Allocate memory for G and other work space */
G = NewDenseMat(Ny, Nc);
if (G == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
savedG = NewDenseMat(Ny, Nc);
if (savedG == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
/* Allocate additional work space, depending on factorization */
switch(fact_type) {
case CPDIRECT_LU:
/* Allocate space for pivotsP and K */
pivotsP = NewIntArray(Nc);
if (pivotsP == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyMat(savedG);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
K = NewDenseMat(Ny-Nc, Ny-Nc);
if (K == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyArray(pivotsP);
DestroyMat(savedG);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
break;
case CPDIRECT_QR:
/* Allocate space for beta */
beta = NewRealArray(Nc);
if (beta == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyMat(savedG);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
/* If projecting in WRMS norm, allocate space for K=Q^T*D^(-1)*Q */
if (pnorm == CP_PROJ_ERRNORM) {
K = NewDenseMat(Nc, Nc);
if (K == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyArray(beta);
DestroyMat(savedG);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
}
break;
case CPDIRECT_SC:
/* Allocate space for K = G * D^(-1) * G^T */
K = NewDenseMat(Nc, Nc);
if (K == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDenseProj", MSGD_MEM_FAIL);
DestroyMat(savedG);
DestroyMat(G);
free(cpdlsP_mem);
return(CPDIRECT_MEM_FAIL);
}
break;
}
/* Set default Jacobian routine and Jacobian data */
jacP = NULL;
JP_data = NULL;
lsetupP_exists = TRUE;
/* Copy inputs into memory */
nc = Nc; /* number of constraints */
ny = Ny; /* number of states */
ftype = fact_type; /* factorization type */
/* Attach linear solver memory to integrator memory */
lmemP = cpdlsP_mem;
return(CPDIRECT_SUCCESS);
}
int CPDense(void *cpode_mem, int N)
{
CPodeMem cp_mem;
CPDlsMem cpdls_mem;
/* Return immediately if cpode_mem is NULL */
if (cpode_mem == NULL) {
cpProcessError(NULL, CPDIRECT_MEM_NULL, "CPDENSE", "CPDense", MSGD_CPMEM_NULL);
return(CPDIRECT_MEM_NULL);
}
cp_mem = (CPodeMem) cpode_mem;
/* Test if the NVECTOR package is compatible with the DENSE solver */
if (tempv->ops->nvgetarraypointer == NULL ||
tempv->ops->nvsetarraypointer == NULL) {
cpProcessError(cp_mem, CPDIRECT_ILL_INPUT, "CPDENSE", "CPDense", MSGD_BAD_NVECTOR);
return(CPDIRECT_ILL_INPUT);
}
if (lfree !=NULL) lfree(cp_mem);
/* Set four main function fields in cp_mem */
linit = cpDenseInit;
lsetup = cpDenseSetup;
lsolve = cpDenseSolve;
lfree = cpDenseFree;
/* Get memory for CPDlsMemRec */
cpdls_mem = NULL;
cpdls_mem = (CPDlsMem) malloc(sizeof(CPDlsMemRec));
if (cpdls_mem == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDense", MSGD_MEM_FAIL);
return(CPDIRECT_MEM_FAIL);
}
/* Set matrix type */
mtype = SUNDIALS_DENSE;
/* Set default Jacobian routine and Jacobian data */
jacE = NULL;
jacI = NULL;
J_data = NULL;
last_flag = CPDIRECT_SUCCESS;
lsetup_exists = TRUE;
/* Set problem dimension */
n = N;
/* Allocate memory for M, pivot array, and (if needed) savedJ */
M = NULL;
pivots = NULL;
savedJ = NULL;
M = NewDenseMat(N, N);
if (M == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDense", MSGD_MEM_FAIL);
free(cpdls_mem);
return(CPDIRECT_MEM_FAIL);
}
pivots = NewIntArray(N);
if (pivots == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDense", MSGD_MEM_FAIL);
DestroyMat(M);
free(cpdls_mem);
return(CPDIRECT_MEM_FAIL);
}
if (ode_type == CP_EXPL) {
savedJ = NewDenseMat(N, N);
if (savedJ == NULL) {
cpProcessError(cp_mem, CPDIRECT_MEM_FAIL, "CPDENSE", "CPDense", 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);
}
sdMatrix::sdMatrix(unsigned int n, unsigned int m)
{
alloc = true;
M = NewDenseMat(n,m);
}