SciErr createComplexZMatrixOfDouble(void* _pvCtx, int _iVar, int _iRows, int _iCols, const doublecomplex* _pdblData)
{
SciErr sciErr; sciErr.iErr = 0; sciErr.iMsgCount = 0;
double *pdblReal = NULL;
double *pdblImg = NULL;
sciErr = allocComplexMatrixOfDouble(_pvCtx, _iVar, _iRows, _iCols, &pdblReal, &pdblImg);
if(sciErr.iErr)
{
addErrorMessage(&sciErr, API_ERROR_CREATE_ZDOUBLE, _("%s: Unable to create variable in Scilab memory"), "allocComplexMatrixOfDouble");
return sciErr;
}
vGetPointerFromDoubleComplex(_pdblData, _iRows * _iCols, pdblReal, pdblImg);
return sciErr;
}
SciErr createComplexMatrixOfDouble(void* _pvCtx, int _iVar, int _iRows, int _iCols, const double* _pdblReal, const double* _pdblImg)
{
double *pdblReal = NULL;
double *pdblImg = NULL;
int iOne = 1;
int iSize = _iRows * _iCols;
SciErr sciErr = allocComplexMatrixOfDouble(_pvCtx, _iVar, _iRows, _iCols, &pdblReal, &pdblImg);
if (sciErr.iErr)
{
addErrorMessage(&sciErr, API_ERROR_CREATE_COMPLEX_DOUBLE, _("%s: Unable to create variable in Scilab memory"), "allocComplexMatrixOfDouble");
return sciErr;
}
C2F(dcopy)(&iSize, const_cast<double*>(_pdblReal), &iOne, pdblReal, &iOne);
C2F(dcopy)(&iSize, const_cast<double*>(_pdblImg), &iOne, pdblImg, &iOne);
return sciErr;
}
int sci_umfpack(char* fname, void* pvApiCtx)
{
SciErr sciErr;
int mb = 0;
int nb = 0;
int i = 0;
int num_A = 0;
int num_b = 0;
int mW = 0;
int Case = 0;
int stat = 0;
SciSparse AA;
CcsSparse A;
int* piAddrA = NULL;
int* piAddr2 = NULL;
int* piAddrB = NULL;
double* pdblBR = NULL;
double* pdblBI = NULL;
double* pdblXR = NULL;
double* pdblXI = NULL;
int iComplex = 0;
int freepdblBI = 0;
int mA = 0; // rows
int nA = 0; // cols
int iNbItem = 0;
int* piNbItemRow = NULL;
int* piColPos = NULL;
double* pdblSpReal = NULL;
double* pdblSpImg = NULL;
/* umfpack stuff */
double Info[UMFPACK_INFO];
double* Control = NULL;
void* Symbolic = NULL;
void* Numeric = NULL;
int* Wi = NULL;
double* W = NULL;
char* pStr = NULL;
int iType2 = 0;
int iTypeA = 0;
int iTypeB = 0;
/* Check numbers of input/output arguments */
CheckInputArgument(pvApiCtx, 3, 3);
CheckOutputArgument(pvApiCtx, 1, 1);
/* First get arg #2 : a string of length 1 */
sciErr = getVarAddressFromPosition(pvApiCtx, 2, &piAddr2);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getVarType(pvApiCtx, piAddr2, &iType2);
if (sciErr.iErr || iType2 != sci_strings)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Wrong type for input argument #%d: string expected.\n"), fname, 2);
return 1;
}
if (getAllocatedSingleString(pvApiCtx, piAddr2, &pStr))
{
return 1;
}
/* select Case 1 or 2 depending (of the first char of) the string ... */
if (pStr[0] == '\\') // compare pStr[0] with '\'
{
Case = 1;
num_A = 1;
num_b = 3;
}
else if (pStr[0] == '/')
{
Case = 2;
num_A = 3;
num_b = 1;
}
else
{
Scierror(999, _("%s: Wrong input argument #%d: '%s' or '%s' expected.\n"), fname, 2, "\\", "/");
FREE(pStr);
return 1;
}
FREE(pStr);
/* get A */
sciErr = getVarAddressFromPosition(pvApiCtx, num_A, &piAddrA);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getVarType(pvApiCtx, piAddrA, &iTypeA);
if (sciErr.iErr || iTypeA != sci_sparse)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Wrong type for input argument #%d: A sparse matrix expected.\n"), fname, 1);
return 1;
}
if (isVarComplex(pvApiCtx, piAddrA))
{
AA.it = 1;
iComplex = 1;
sciErr = getComplexSparseMatrix(pvApiCtx, piAddrA, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal, &pdblSpImg);
}
else
{
AA.it = 0;
sciErr = getSparseMatrix(pvApiCtx, piAddrA, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// fill struct sparse
AA.m = mA;
AA.n = nA;
AA.nel = iNbItem;
AA.mnel = piNbItemRow;
AA.icol = piColPos;
AA.R = pdblSpReal;
AA.I = pdblSpImg;
if ( mA != nA || mA < 1 )
{
Scierror(999, _("%s: Wrong size for input argument #%d.\n"), fname, num_A);
return 1;
}
/* get B*/
sciErr = getVarAddressFromPosition(pvApiCtx, num_b, &piAddrB);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getVarType(pvApiCtx, piAddrB, &iTypeB);
if (sciErr.iErr || iTypeB != sci_matrix)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Wrong type for input argument #%d: A matrix expected.\n"), fname, 3);
return 1;
}
if (isVarComplex(pvApiCtx, piAddrB))
{
iComplex = 1;
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddrB, &mb, &nb, &pdblBR, &pdblBI);
}
else
{
sciErr = getMatrixOfDouble(pvApiCtx, piAddrB, &mb, &nb, &pdblBR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if ( (Case == 1 && ( mb != mA || nb < 1 )) || (Case == 2 && ( nb != mA || mb < 1 )) )
{
Scierror(999, _("%s: Wrong size for input argument #%d.\n"), fname, num_b);
return 1;
}
SciSparseToCcsSparse(&AA, &A);
/* allocate memory for the solution x */
if (iComplex)
{
sciErr = allocComplexMatrixOfDouble(pvApiCtx, 4, mb, nb, &pdblXR, &pdblXI);
}
else
{
sciErr = allocMatrixOfDouble(pvApiCtx, 4, mb, nb, &pdblXR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
freeCcsSparse(A);
return 1;
}
if (A.it == 1)
{
mW = 10 * mA;
}
else
{
mW = 5 * mA;
}
if (A.it == 1 && pdblBI == NULL)
{
int iSize = mb * nb * sizeof(double);
pdblBI = (double*)MALLOC(iSize);
memset(pdblBI, 0x00, iSize);
freepdblBI = 1;
}
/* Now calling umfpack routines */
if (A.it == 1)
{
stat = umfpack_zi_symbolic(mA, nA, A.p, A.irow, A.R, A.I, &Symbolic, Control, Info);
}
else
{
stat = umfpack_di_symbolic(mA, nA, A.p, A.irow, A.R, &Symbolic, Control, Info);
}
if ( stat != UMFPACK_OK )
{
Scierror(999, _("%s: An error occurred: %s: %s\n"), fname, _("symbolic factorization"), UmfErrorMes(stat));
freeCcsSparse(A);
if (freepdblBI)
{
FREE(pdblBI);
}
return 1;
}
if (A.it == 1)
{
stat = umfpack_zi_numeric(A.p, A.irow, A.R, A.I, Symbolic, &Numeric, Control, Info);
}
else
{
stat = umfpack_di_numeric(A.p, A.irow, A.R, Symbolic, &Numeric, Control, Info);
}
if (A.it == 1)
{
umfpack_zi_free_symbolic(&Symbolic);
}
else
{
umfpack_di_free_symbolic(&Symbolic);
}
if ( stat != UMFPACK_OK )
{
Scierror(999, _("%s: An error occurred: %s: %s\n"), fname, _("numeric factorization"), UmfErrorMes(stat));
if (A.it == 1)
{
umfpack_zi_free_numeric(&Numeric);
}
else
{
umfpack_di_free_numeric(&Numeric);
}
freeCcsSparse(A);
if (freepdblBI)
{
FREE(pdblBI);
}
return 1;
}
/* allocate memory for umfpack_di_wsolve usage or umfpack_zi_wsolve usage*/
Wi = (int*)MALLOC(mA * sizeof(int));
W = (double*)MALLOC(mW * sizeof(double));
if ( Case == 1 ) /* x = A\b <=> Ax = b */
{
if (A.it == 0)
{
for ( i = 0 ; i < nb ; i++ )
{
umfpack_di_wsolve(UMFPACK_A, A.p, A.irow, A.R, &pdblXR[i * mb], &pdblBR[i * mb],
Numeric, Control, Info, Wi, W);
}
if (isVarComplex(pvApiCtx, piAddrB))
{
for ( i = 0 ; i < nb ; i++ )
{
umfpack_di_wsolve(UMFPACK_A, A.p, A.irow, A.R, &pdblXI[i * mb], &pdblBI[i * mb],
Numeric, Control, Info, Wi, W);
}
}
}
else /* A.it == 1 */
{
for ( i = 0 ; i < nb ; i++ )
{
umfpack_zi_wsolve(UMFPACK_A, A.p, A.irow, A.R, A.I, &pdblXR[i * mb], &pdblXI[i * mb],
&pdblBR[i * mb], &pdblBI[i * mb], Numeric, Control, Info, Wi, W);
}
}
}
else /* Case == 2, x = b/A <=> x A = b <=> A.'x.' = b.' */
{
if (A.it == 0)
{
TransposeMatrix(pdblBR, mb, nb, pdblXR); /* put b in x (with transposition) */
for ( i = 0 ; i < mb ; i++ )
{
umfpack_di_wsolve(UMFPACK_At, A.p, A.irow, A.R, &pdblBR[i * nb], &pdblXR[i * nb],
Numeric, Control, Info, Wi, W); /* the solutions are in br */
}
TransposeMatrix(pdblBR, nb, mb, pdblXR); /* put now br in xr with transposition */
if (isVarComplex(pvApiCtx, piAddrB))
{
TransposeMatrix(pdblBI, mb, nb, pdblXI); /* put b in x (with transposition) */
for ( i = 0 ; i < mb ; i++ )
{
umfpack_di_wsolve(UMFPACK_At, A.p, A.irow, A.R, &pdblBI[i * nb], &pdblXI[i * nb],
Numeric, Control, Info, Wi, W); /* the solutions are in bi */
}
TransposeMatrix(pdblBI, nb, mb, pdblXI); /* put now bi in xi with transposition */
}
}
else /* A.it==1 */
{
TransposeMatrix(pdblBR, mb, nb, pdblXR);
TransposeMatrix(pdblBI, mb, nb, pdblXI);
for ( i = 0 ; i < mb ; i++ )
{
umfpack_zi_wsolve(UMFPACK_Aat, A.p, A.irow, A.R, A.I, &pdblBR[i * nb], &pdblBI[i * nb],
&pdblXR[i * nb], &pdblXI[i * nb], Numeric, Control, Info, Wi, W);
}
TransposeMatrix(pdblBR, nb, mb, pdblXR);
TransposeMatrix(pdblBI, nb, mb, pdblXI);
}
}
if (A.it == 1)
{
umfpack_zi_free_numeric(&Numeric);
}
else
{
umfpack_di_free_numeric(&Numeric);
}
if (piNbItemRow != NULL)
{
FREE(piNbItemRow);
}
if (piColPos != NULL)
{
FREE(piColPos);
}
if (pdblSpReal != NULL)
{
FREE(pdblSpReal);
}
if (pdblSpImg != NULL)
{
FREE(pdblSpImg);
}
FREE(W);
FREE(Wi);
if (freepdblBI)
{
FREE(pdblBI);
}
freeCcsSparse(A);
AssignOutputVariable(pvApiCtx, 1) = 4;
ReturnArguments(pvApiCtx);
return 0;
}
int write_double(char *fname, void* pvApiCtx)
{
SciErr sciErr;
int i, j;
//first variable info : real matrix of double 3 x 4
int iRows1 = 3;
int iCols1 = 4;
double* pdblReal1 = NULL;
//second variable info : complex matrix of double 4 x 6
int iRows2 = 4;
int iCols2 = 6;
double* pdblReal2 = NULL;
double* pdblImg2 = NULL;
/************************
* First variable *
************************/
//alloc array of data in OS memory
pdblReal1 = (double*)MALLOC(sizeof(double) * iRows1 * iCols1);
//fill array with incremental values
//[ 0 1 2 3
// 4 5 6 7
// 8 9 10 11]
for (i = 0 ; i < iRows1 ; i++)
{
for (j = 0 ; j < iCols1 ; j++)
{
pdblReal1[i + iRows1 * j] = i * iCols1 + j;
}
}
//can be written in a single loop
//for(i = 0 ; i < iRows1 * iCols1; i++)
//{
// pdblReal1[i] = i;
//}
//create a variable from a existing data array
sciErr = createMatrixOfDouble(pvApiCtx, nbInputArgument(pvApiCtx) + 1, iRows1, iCols1, pdblReal1);
//after creation, we can free memory.
FREE(pdblReal1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
/*************************
* Second variable *
*************************/
//reserve space in scilab memory and fill it
sciErr = allocComplexMatrixOfDouble(pvApiCtx, nbInputArgument(pvApiCtx) + 2, iRows2, iCols2, &pdblReal2, &pdblImg2);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
//fill array with incremental values for real part and decremental for imaginary part
//[ 23i 1+22i 2+21i 3+20i 4+19i 5+18i
// 6+17i 7+16i 8+15i 9+14i 10+13i 11+12i
// 12+11i 13+10i 14+9i 15+8i 16+7i 17+6i
// 18+5i 19+4i 20+3i 21+2i 22+1i 23 ]
for (i = 0 ; i < iRows2 ; i++)
{
for (j = 0 ; j < iCols2 ; j++)
{
pdblReal2[i + iRows2 * j] = i * iCols2 + j;
pdblImg2 [i + iRows2 * j] = (iRows2 * iCols2 - 1) - (i * iCols2 + j);
}
}
//can be written in a single loop
//for(i = 0 ; i < iRows2 * iCols2; i++)
//{
// pdblReal2[i] = i;
// pdblImg2 [i] = (iRows2 * iCols2 - 1) - i;
//}
// /!\ DO NOT FREE MEMORY, in this case, it's the Scilab memory
//assign allocated variables to Lhs position
AssignOutputVariable(pvApiCtx, 1) = nbInputArgument(pvApiCtx) + 1;
AssignOutputVariable(pvApiCtx, 2) = nbInputArgument(pvApiCtx) + 2;
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_bessely(char *fname, unsigned long fname_len)
{
int m1 = 0, n1 = 0, m2 = 0, n2 = 0;
int mr = 0, nr = 0, itr = 0, nw = 0;
int r1 = 0, r2 = 0, na = 0, nx = 0, kode = 0;
int isint = 0, ispos = 0, i = 0, t = 0;
int un = 1, nl2 = 0, ierr = 0;
int nbInputArg = 0;
double zero = 0.0;
double* pdblXR = NULL;
double* pdblXI = NULL;
double* pdbl1 = NULL;
int* piAddr1 = NULL;
int* piAddr3 = NULL;
int* piAddrX = NULL;
double* lwr = NULL;
double* lwi = NULL;
double* lr = NULL;
double* li = NULL;
SciErr sciErr;
CheckInputArgument(pvApiCtx, 2, 3);
nbInputArg = nbInputArgument(pvApiCtx);
kode = 1; /* ignored for real cases */
if (nbInputArg == 3)
{
/* normalized bessel required */
//get variable address of the input argument
double* l1;
sciErr = getVarAddressFromPosition(pvApiCtx, 3, &piAddr3);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getMatrixOfDouble(pvApiCtx, piAddr3, &m1, &n1, &l1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (m1*n1 != 1)
{
Scierror(999, _("%s: Wrong size for input argument #%d.\n"), fname, 3);
return 1;
}
kode = (int)l1[0] + 1;
}
/* get alpha */
//get variable address of the input argument
sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddr1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getMatrixOfDouble(pvApiCtx, piAddr1, &m1, &n1, &pdbl1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (m1*n1 == 0)
{
/*bessely([],x) */
AssignOutputVariable(pvApiCtx, 1) = 1;
ReturnArguments(pvApiCtx);
return 0;
}
/* get x */
//get variable address of the input argument
sciErr = getVarAddressFromPosition(pvApiCtx, 2, &piAddrX);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddrX, &m2, &n2, &pdblXR, &pdblXI);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (m2*n2 == 0)
{
/*bessely(alpha,[]) */
AssignOutputVariable(pvApiCtx, 1) = 2;
ReturnArguments(pvApiCtx);
return 0;
}
/* determine if the result is real or complex */
if (pdblXI)
{
itr = 1;
}
else
{
ispos = 1;
for (i = 0; i < m2 * n2; i++)
{
if (pdblXR[i] < 0.0)
{
ispos = 0;
break;
}
}
if (ispos == 0)
{
itr = 1;
}
}
if (itr == 1 && pdblXI == NULL)
{
/* transform to complex */
double* l2r = NULL;
double* l2i = NULL;
int iSize = m2 * n2 * sizeof(double);
pdblXI = (double*)MALLOC(iSize);
memset(pdblXI, 0x00, iSize);
}
if (m1*n1 == 1)
{
/*bessely(scalar,matrix) */
double wr[2], wi[2];
double* lr = NULL;
double* li = NULL;
nx = m2 * n2;
na = 1;
if (itr == 0)
{
allocMatrixOfDouble(pvApiCtx, nbInputArg + 1, m2, n2, &lr);
C2F(dbesyv) (pdblXR, &nx, pdbl1, &na, &kode, lr, wr, &ierr);
}
else
{
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 1, m2, n2, &lr, &li);
C2F(zbesyv) (pdblXR, pdblXI, &nx, pdbl1, &na, &kode, lr, li, wr, wi, &ierr);
}
}
else if (m2*n2 == 1)
{
/* bessely(matrix,scalar) */
nx = 1;
na = m1 * n1;
nw = 3 * na;
if (itr == 0)
{
allocMatrixOfDouble(pvApiCtx, nbInputArg + 1, m1, n1, &lr);
allocMatrixOfDouble(pvApiCtx, nbInputArg + 2, nx, nw, &lwr);
C2F(dbesyv) (pdblXR, &nx, pdbl1, &na, &kode, lr, lwr, &ierr);
}
else
{
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 1, m1, n1, &lr, &li);
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 2, nx, nw, &lwr, &lwi);
C2F(zbesyv) (pdblXR, pdblXI, &nx, pdbl1, &na, &kode, lr, li, lwr, lwi, &ierr);
}
}
else if ((m1 == 1 && n2 == 1) || (n1 == 1 && m2 == 1))
{
/* bessely(row,col) or bessely(col,row) */
mr = m2 * n2;
nr = m1 * n1;
nx = m2 * n2;
na = m1 * n1;
nw = 3 * na;
if (itr == 0)
{
allocMatrixOfDouble(pvApiCtx, nbInputArg + 1, mr, nr, &lr);
allocMatrixOfDouble(pvApiCtx, nbInputArg + 2, 1, nw, &lwr);
C2F(dbesyv) (pdblXR, &nx, pdbl1, &na, &kode, lr, lwr, &ierr);
}
else
{
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 1, mr, nr, &lr, &li);
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 2, 1, nw, &lwr, &lwi);
C2F(zbesyv) (pdblXR, pdblXI, &nx, pdbl1, &na, &kode, lr, li, lwr, lwi, &ierr);
}
}
else
{
/* element wise case */
double wr[2], wi[2];
if (m1 * n1 != m2 * n2)
{
Scierror(999, _("%s: arguments #%d and #%d have incompatible dimensions.\n"), fname, 1, 2);
if (itr == 1 && isVarComplex(pvApiCtx, piAddrX) == 0)
{
FREE(pdblXI);
}
return 1;
}
nx = m2 * n2;
na = -1;
if (itr == 0)
{
allocMatrixOfDouble(pvApiCtx, nbInputArg + 1, m2, n2, &lr);
C2F(dbesyv) (pdblXR, &nx, pdbl1, &na, &kode, lr, wr, &ierr);
}
else
{
allocComplexMatrixOfDouble(pvApiCtx, nbInputArg + 1, m2, n2, &lr, &li);
C2F(zbesyv) (pdblXR, pdblXI, &nx, pdbl1, &na, &kode, lr, li, wr, wi, &ierr);
}
}
if (itr == 1 && isVarComplex(pvApiCtx, piAddrX) == 0)
{
FREE(pdblXI);
}
if (ierr == 2)
{
if ( C2F(errgst).ieee == 0)
{
ierr = 69;
SciError(ierr);
}
else if ( C2F(errgst).ieee == 1)
{
ierr = 63;
C2F(msgs)(&ierr, &un);
}
}
else if (ierr == 3)
{
/* inacurate result */
ierr = 4;
C2F(msgs)(&ierr, &un);
}
else if (ierr == 4 || ierr == 5)
{
if ( C2F(errgst).ieee == 0)
{
ierr = 69;
SciError(ierr);
}
else if ( C2F(errgst).ieee == 1)
{
ierr = 107;
C2F(msgs)(&ierr, &un);
}
}
AssignOutputVariable(pvApiCtx, 1) = nbInputArg + 1;
ReturnArguments(pvApiCtx);
return 0;
}
int sci_res_with_prec(char* fname, void* pvApiCtx)
{
SciErr sciErr;
int mx = 0, nx = 0, mb = 0, nb = 0, i = 0;
SciSparse A;
int mA = 0; // rows
int nA = 0; // cols
int iNbItem = 0;
int* piNbItemRow = NULL;
int* piColPos = NULL;
double* pdblSpReal = NULL;
double* pdblSpImg = NULL;
int iComplex = 0;
int* piAddr1 = NULL;
int* piAddr2 = NULL;
int* piAddr3 = NULL;
double* pdblXR = NULL;
double* pdblXI = NULL;
double* pdblBR = NULL;
double* pdblBI = NULL;
double* pdblNR = NULL;
double* pdblNI = NULL;
double* pdblRR = NULL;
double* pdblRI = NULL;
int nbInputArg = nbInputArgument(pvApiCtx);
/* Check numbers of input/output arguments */
CheckInputArgument(pvApiCtx, 3, 3);
CheckOutputArgument(pvApiCtx, 1, 2);
/* get A the sparse matrix */
sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddr1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (isVarComplex(pvApiCtx, piAddr1))
{
iComplex = 1;
sciErr = getComplexSparseMatrix(pvApiCtx, piAddr1, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal, &pdblSpImg);
}
else
{
sciErr = getSparseMatrix(pvApiCtx, piAddr1, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// fill struct sparse
A.m = mA;
A.n = nA;
A.it = iComplex;
A.nel = iNbItem;
A.mnel = piNbItemRow;
A.icol = piColPos;
A.R = pdblSpReal;
A.I = pdblSpImg;
/* get x */
sciErr = getVarAddressFromPosition(pvApiCtx, 2, &piAddr2);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (isVarComplex(pvApiCtx, piAddr2))
{
iComplex = 1;
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddr2, &mx, &nx, &pdblXR, &pdblXI);
}
else
{
sciErr = getMatrixOfDouble(pvApiCtx, piAddr2, &mx, &nx, &pdblXR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* get b */
sciErr = getVarAddressFromPosition(pvApiCtx, 3, &piAddr3);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (isVarComplex(pvApiCtx, piAddr3))
{
iComplex = 1;
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddr3, &mb, &nb, &pdblBR, &pdblBI);
}
else
{
sciErr = getMatrixOfDouble(pvApiCtx, piAddr3, &mb, &nb, &pdblBR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* check size of inputs */
if ( nx < 1 || nb != nx || mx != nA || mb != mA )
{
Scierror(999, _("%s: Wrong size for input arguments: Same sizes expected.\n"), fname);
return 1;
}
/* Create the matrix as return of the function */
if (iComplex)
{
sciErr = allocComplexMatrixOfDouble(pvApiCtx, 4, mb, nb, &pdblRR, &pdblRI);
}
else
{
sciErr = allocMatrixOfDouble(pvApiCtx, 4, mb, nb, &pdblRR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* Create the matrix as return of the function */
sciErr = allocMatrixOfDouble(pvApiCtx, 5, 1, nb, &pdblNR);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* perform operations */
if (iComplex == 0)
{
for ( i = 0 ; i < nb ; i++ )
{
residu_with_prec(&A, pdblXR + i * mx, pdblBR + i * mb, pdblRR + i * mb, pdblNR + i);
}
}
else
{
if (pdblXI == NULL)
{
int iSize = mx * nx * sizeof(double);
pdblXI = (double*)MALLOC(iSize);
memset(pdblXI, 0x00, iSize);
}
if (pdblBI == NULL)
{
int iSize = mb * nb * sizeof(double);
pdblBI = (double*)MALLOC(iSize);
memset(pdblBI, 0x00, iSize);
}
if (pdblSpImg == NULL)
{
/* Create the matrix as return of the function */
int iSize = nb * sizeof(double);
pdblNI = (double*)MALLOC(iSize);
memset(pdblNI, 0x00, iSize);
for ( i = 0 ; i < nb ; i++ )
{
residu_with_prec(&A, pdblXR + i * mx, pdblBR + i * mb, pdblRR + i * mb, pdblNR + i);
}
for ( i = 0 ; i < nb ; i++ )
{
residu_with_prec(&A, pdblXI + i * mx, pdblBI + i * mb, pdblRI + i * mb, pdblNI + i);
}
for ( i = 0 ; i < nb ; i++ )
{
pdblNR[i] = sqrt(pdblNR[i] * pdblNR[i] + pdblNI[i] * pdblNI[i]);
}
}
else
{
for ( i = 0 ; i < nb ; i++ )
{
cmplx_residu_with_prec(&A, pdblXR + i * mx, pdblXI + i * mx,
pdblBR + i * mb, pdblBI + i * mb,
pdblRR + i * mb, pdblRI + i * mb,
pdblNR + i);
}
}
}
if (isVarComplex(pvApiCtx, piAddr1) == 0)
{
FREE(pdblNI);
}
if (isVarComplex(pvApiCtx, piAddr2) == 0)
{
FREE(pdblXI);
}
if (isVarComplex(pvApiCtx, piAddr3) == 0)
{
FREE(pdblBI);
}
AssignOutputVariable(pvApiCtx, 1) = 4;
AssignOutputVariable(pvApiCtx, 2) = 5;
ReturnArguments(pvApiCtx);
return 0;
}
/*--------------------------------------------------------------------------*/
int sci_prod(char *fname, void* pvApiCtx)
{
SciErr sciErr;
int iRows = 0;
int iCols = 0;
int*piAddr = NULL;
double* pdblReal = NULL;
double* pdblImg = NULL;
int iRowsRet = 0;
int iColsRet = 0;
double* pdblRealRet = NULL;
double* pdblImgRet = NULL;
int iMode = 0;
CheckRhs(1, 2);
CheckLhs(1, 1);
sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddr);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
if (Rhs == 2)
{
sciErr = getProcessMode(pvApiCtx, 2, piAddr, &iMode);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
}
sciErr = getVarDimension(pvApiCtx, piAddr, &iRows, &iCols);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
if (iRows * iCols == 0)
{
double dblVal = 0;
if (iMode == 0)
{
iRows = 1;
iCols = 1;
dblVal = 1;
}
else
{
iRows = 0;
iCols = 0;
}
sciErr = createMatrixOfDouble(pvApiCtx, Rhs + 1, 1, 1, &dblVal);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
LhsVar(1) = Rhs + 1;
PutLhsVar();
return 0;
}
switch (iMode)
{
case BY_ROWS :
iRowsRet = 1;
iColsRet = iCols;
break;
case BY_COLS :
iRowsRet = iRows;
iColsRet = 1;
break;
default : //BY_ALL
iRowsRet = 1;
iColsRet = 1;
break;
}
if (isVarComplex(pvApiCtx, piAddr))
{
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddr, &iRows, &iCols, &pdblReal, &pdblImg);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
sciErr = allocComplexMatrixOfDouble(pvApiCtx, Rhs + 1, iRowsRet, iColsRet, &pdblRealRet, &pdblImgRet);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
vWDmProd(iMode, pdblReal, pdblImg, iRows, iRows, iCols, pdblRealRet, pdblImgRet, 1);
}
else
{
sciErr = getMatrixOfDouble(pvApiCtx, piAddr, &iRows, &iCols, &pdblReal);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
sciErr = allocMatrixOfDouble(pvApiCtx, Rhs + 1, iRowsRet, iColsRet, &pdblRealRet);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 0;
}
vDmProd(iMode, pdblReal, iRows, iRows, iCols, pdblRealRet, 1);
}
LhsVar(1) = Rhs + 1;
PutLhsVar();
return 0;
}
int sci_umf_lusolve(char* fname, unsigned long l)
{
SciErr sciErr;
int mb = 0;
int nb = 0;
int it_flag = 0;
int i = 0;
int j = 0;
int NoTranspose = 0;
int NoRaffinement = 0;
SciSparse AA;
CcsSparse A;
/* umfpack stuff */
double Info[UMFPACK_INFO]; // double *Info = (double *) NULL;
double Control[UMFPACK_CONTROL];
void* Numeric = NULL;
int lnz = 0, unz = 0, n = 0, n_col = 0, nz_udiag = 0, umf_flag = 0;
int* Wi = NULL;
int mW = 0;
double *W = NULL;
int iComplex = 0;
int* piAddr1 = NULL;
int* piAddr2 = NULL;
int* piAddr3 = NULL;
int* piAddr4 = NULL;
double* pdblBR = NULL;
double* pdblBI = NULL;
double* pdblXR = NULL;
double* pdblXI = NULL;
int mA = 0; // rows
int nA = 0; // cols
int iNbItem = 0;
int* piNbItemRow = NULL;
int* piColPos = NULL;
double* pdblSpReal = NULL;
double* pdblSpImg = NULL;
/* Check numbers of input/output arguments */
CheckInputArgument(pvApiCtx, 2, 4);
CheckOutputArgument(pvApiCtx, 1, 1);
/* First get arg #1 : the pointer to the LU factors */
sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddr1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
sciErr = getPointer(pvApiCtx, piAddr1, &Numeric);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* Check if this pointer is a valid ref to a umfpack LU numeric object */
if ( ! IsAdrInList(Numeric, ListNumeric, &it_flag) )
{
Scierror(999, _("%s: Wrong value for input argument #%d: Must be a valid reference to (umf) LU factors.\n"), fname, 1);
return 1;
}
/* get some parameters of the factorization (for some checking) */
if ( it_flag == 0 )
{
umfpack_di_get_lunz(&lnz, &unz, &n, &n_col, &nz_udiag, Numeric);
}
else
{
iComplex = 1;
umfpack_zi_get_lunz(&lnz, &unz, &n, &n_col, &nz_udiag, Numeric);
}
if ( n != n_col )
{
Scierror(999, _("%s: An error occurred: %s.\n"), fname, _("This is not a factorization of a square matrix"));
return 1;
}
if ( nz_udiag < n )
{
Scierror(999, _("%s: An error occurred: %s.\n"), fname, _("This is a factorization of a singular matrix"));
return 1;
}
/* Get now arg #2 : the vector b */
sciErr = getVarAddressFromPosition(pvApiCtx, 2, &piAddr2);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (isVarComplex(pvApiCtx, piAddr2))
{
iComplex = 1;
sciErr = getComplexMatrixOfDouble(pvApiCtx, piAddr2, &mb, &nb, &pdblBR, &pdblBI);
}
else
{
sciErr = getMatrixOfDouble(pvApiCtx, piAddr2, &mb, &nb, &pdblBR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (mb != n || nb < 1) /* test if the right hand side is compatible */
{
Scierror(999, _("%s: Wrong size for input argument #%d.\n"), fname, 2);
return 1;
}
/* allocate memory for the solution x */
if (iComplex)
{
sciErr = allocComplexMatrixOfDouble(pvApiCtx, nbInputArgument(pvApiCtx) + 1, mb, nb, &pdblXR, &pdblXI);
}
else
{
sciErr = allocMatrixOfDouble(pvApiCtx, nbInputArgument(pvApiCtx) + 1, mb, nb, &pdblXR);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
/* selection between the different options :
* -- solving Ax=b or A'x=b (Note: we could add A.'x=b)
* -- with or without raffinement
*/
if (nbInputArgument(pvApiCtx) == 2)
{
NoTranspose = 1;
NoRaffinement = 1;
}
else /* 3 or 4 input arguments but the third must be a string */
{
char* pStr = NULL;
sciErr = getVarAddressFromPosition(pvApiCtx, 3, &piAddr3);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
getAllocatedSingleString(pvApiCtx, piAddr3, &pStr);
if (strcmp(pStr, "Ax=b") == 0)
{
NoTranspose = 1;
}
else if ( strcmp(pStr, "A'x=b") == 0 )
{
NoTranspose = 0;
}
else
{
Scierror(999, _("%s: Wrong input argument #%d: '%s' or '%s' expected.\n"), fname, 3, "Ax=b", "A'x=b");
return 1;
}
if (nbInputArgument(pvApiCtx) == 4)
{
sciErr = getVarAddressFromPosition(pvApiCtx, 4, &piAddr4);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
if (isVarComplex(pvApiCtx, piAddr4))
{
AA.it = 1;
sciErr = getComplexSparseMatrix(pvApiCtx, piAddr4, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal, &pdblSpImg);
}
else
{
AA.it = 0;
sciErr = getSparseMatrix(pvApiCtx, piAddr4, &mA, &nA, &iNbItem, &piNbItemRow, &piColPos, &pdblSpReal);
}
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// fill struct sparse
AA.m = mA;
AA.n = nA;
AA.nel = iNbItem;
AA.mnel = piNbItemRow;
AA.icol = piColPos;
AA.R = pdblSpReal;
AA.I = pdblSpImg;
/* some check... but we can't be sure that the matrix corresponds to the LU factors */
if ( mA != nA || mA != n || AA.it != it_flag )
{
Scierror(999, _("%s: Wrong size for input argument #%d: %s.\n"), fname, 4, _("Matrix is not compatible with the given LU factors"));
return 1;
}
NoRaffinement = 0;
}
else
{
NoRaffinement = 1; /* only 3 input var => no raffinement */
}
}
/* allocate memory for umfpack_di_wsolve usage or umfpack_zi_wsolve usage*/
Wi = (int*)MALLOC(n * sizeof(int));
if (it_flag == 1)
{
if (NoRaffinement)
{
mW = 4 * n;
}
else
{
mW = 10 * n;
}
}
else
{
if (NoRaffinement)
{
mW = n;
}
else
{
mW = 5 * n;
}
}
W = (double*)MALLOC(mW * sizeof(double));
if (NoRaffinement == 0)
{
SciSparseToCcsSparse(&AA, &A);
}
else
{
A.p = NULL;
A.irow = NULL;
A.R = NULL;
A.I = NULL;
}
/* get the pointer for b */
if (it_flag == 1 && pdblBI == NULL)
{
int iSize = mb * nb * sizeof(double);
pdblBI = (double*)MALLOC(iSize);
memset(pdblBI, 0x00, iSize);
}
/* init Control */
if (it_flag == 0)
{
umfpack_di_defaults(Control);
}
else
{
umfpack_zi_defaults(Control);
}
if (NoRaffinement)
{
Control[UMFPACK_IRSTEP] = 0;
}
if (NoTranspose)
{
umf_flag = UMFPACK_A;
}
else
{
umf_flag = UMFPACK_At;
}
if (it_flag == 0)
{
for (j = 0; j < nb ; j++)
{
umfpack_di_wsolve(umf_flag, A.p, A.irow, A.R, &pdblXR[j * mb], &pdblBR[j * mb], Numeric, Control, Info, Wi, W);
}
if (iComplex == 1)
{
for (j = 0; j < nb ; j++)
{
umfpack_di_wsolve(umf_flag, A.p, A.irow, A.R, &pdblXI[j * mb], &pdblBI[j * mb], Numeric, Control, Info, Wi, W);
}
}
}
else
{
for (j = 0; j < nb ; j++)
{
umfpack_zi_wsolve(umf_flag, A.p, A.irow, A.R, A.I, &pdblXR[j * mb], &pdblXI[j * mb], &pdblBR[j * mb], &pdblBI[j * mb], Numeric, Control, Info, Wi, W);
}
}
if (isVarComplex(pvApiCtx, piAddr2) == 0)
{
FREE(pdblBI);
}
freeCcsSparse(A);
FREE(W);
FREE(Wi);
AssignOutputVariable(pvApiCtx, 1) = nbInputArgument(pvApiCtx) + 1;
ReturnArguments(pvApiCtx);
return 0;
}