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; }