/* SinglePoly + SinglePoly*/
int iAddScilabPolynomToScilabPolynom(double* _pCoef1R, int _iRank1, double* _pCoef2R, int _iRank2, double* _pCoefOutR, int _iRanOut)
{
int iRankMin = Min(_iRank1, _iRank2);
int iRankMax = Max(_iRank1, _iRank2);
int iRank = 0;
double dblSum = 0.0;
double* pCoefMaxR = (_iRank1 > _iRank2) ? _pCoef1R : _pCoef2R;
for (iRank = 0; iRank < iRankMin ; iRank++)
{
dblSum = _pCoef1R[iRank] + _pCoef2R[iRank];
if (fabs(dblSum) > Max(fabs(_pCoef1R[iRank]), fabs(_pCoef2R[iRank])) * 2 * nc_eps())
{
_pCoefOutR[iRank] = dblSum;
}
else
{
_pCoefOutR[iRank] = 0.0;
}
}
for (iRank = iRankMin ; iRank < iRankMax ; iRank++)
{
_pCoefOutR[iRank] = pCoefMaxR[iRank];
}
return 0;
}
/* part of API. cf lsq.h */
int iLsqM(double* pData1, int iRows, int iCols, double* pData2, int iNRhs, int complexArgs, double* pResult, double* pTreshold, int* piRank)
{
int ret = 0;
double* pRwork = NULL;
doublecomplex* pWork = NULL;
double* pXb = NULL;
int* pPivot = NULL;
int worksize = 0 ;
int unusedRank;
double const treshold = pTreshold ? *pTreshold : sqrt(nc_eps());
if ( (pRwork = (double*)( complexArgs ? (double*)MALLOC(2 * iCols * sizeof(double)) : allocDgelsyWorkspace(iRows, iCols, iNRhs, &worksize)))
&& (pXb = (double*)MALLOC(Max(iRows, iCols) * iNRhs * (complexArgs ? sizeof(doublecomplex) : sizeof(double))))
&& (pPivot = (int*)MALLOC(iCols * sizeof(int)))
&& (!complexArgs || (pWork = allocZgelsyWorkspace(iRows, iCols, iNRhs, &worksize))) )
{
int const maxRowsCols = Max(iRows, iCols);
memset(pPivot, 0, iCols * sizeof(int));
if (complexArgs)
{
/* cf supra : if(maxRowsCols == iRows){ memcpy(pXb, pData2, iRows * iNRhs) } else { zlacpy } */
C2F(zlacpy)("F", &iRows, &iNRhs, (doublecomplex*)pData2, &iRows, (doublecomplex*)pXb, &maxRowsCols );
C2F(zgelsy)(&iRows, &iCols, &iNRhs, (doublecomplex*)pData1, &iRows, (doublecomplex*)pXb, &maxRowsCols, pPivot
, &treshold, piRank ? piRank : &unusedRank, pWork, &worksize, pRwork, &ret);
if (!ret)
{
/* cf supra : if(maxRowsCols == iCols){ memcpy(pResult, pXb, iCols * iNRhs) } else { zlacpy } */
C2F(zlacpy)("F", &iCols, &iNRhs, (doublecomplex*)pXb, &maxRowsCols, (doublecomplex*)pResult, &iCols);
}
}
else
{
C2F(dlacpy)("F", &iRows, &iNRhs, pData2, &iRows, pXb, &maxRowsCols );
C2F(dgelsy)(&iRows, &iCols, &iNRhs, pData1, &iRows, pXb, &maxRowsCols, pPivot
, &treshold, piRank ? piRank : &unusedRank, pRwork, &worksize, &ret);
if (!ret)
{
C2F(dlacpy)("F", &iCols, &iNRhs, pXb, &maxRowsCols, pResult, &iCols);
}
}
}
else
{
ret = -1; /* report MALLOC failure */
}
FREE(pRwork);
FREE(pXb);
FREE(pPivot);
FREE(pWork);
return ret;
}
static void decompInf(double x, int *xk, int *xa, int b)
{
if (x == 0.0)
{
*xk = 0;
*xa = 1; /* jpc */
}
else
{
if (x > 0)
{
double xup;
static double epsilon;
static int first = 0;
if (first == 0)
{
epsilon = 10.0 * nc_eps();
first++;
}
*xa = (int) floor(log10(x)) - b + 1;
*xk = (int) floor(x / exp10((double) * xa));
/* if x is very near (k+1)10^a (epsilon machine)
* we increment xk
*/
xup = (*xk + 1) * exp10((double) * xa);
if (Abs((x - xup) / x) < epsilon)
{
*xk += 1;
}
}
else
{
decompSup(-x, xk, xa, b);
*xk = -(*xk);
}
}
}
/*--------------------------------------------------------------------------*/
int sci_qld(char *fname, void* pvApiCtx)
{
SciErr sciErr;
static int un = 1, zero = 0;
static int n = 0, nbis = 0;
static int unbis = 0;
static int mmax = 0, m = 0, mnn = 0;
static int mbis = 0;
static int pipo = 0;
static int ifail = 0;
int next = 0;
static int lwar = 0, iout = 0, k = 0, l = 0;
static double eps1 = 0;
int* piAddr1 = NULL;
int* piAddr2 = NULL;
int* piAddr3 = NULL;
int* piAddr4 = NULL;
int* piAddr5 = NULL;
int* piAddr6 = NULL;
int* piAddr7 = NULL;
double* Q = NULL;
double* p = NULL;
double* C = NULL;
double* b = NULL;
double* lb = NULL;
double* ub = NULL;
int* me = NULL;
double* x = NULL;
double* lambda = NULL;
int* inform = NULL;
double* war = NULL;
int* iwar = NULL;
/* Check rhs and lhs */
CheckInputArgument(pvApiCtx, 7, 8) ;
CheckOutputArgument(pvApiCtx, 1, 3) ;
/* RhsVar: qld(Q,p,C,b,lb,ub,me,eps) */
/* 1,2,3,4,5 ,6 ,7, 8 */
eps1 = nc_eps();
next = nbInputArgument(pvApiCtx) + 1;
/* Variable 1 (Q) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 1, &piAddr1);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 1.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr1, &n, &nbis, &Q);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 1);
printError(&sciErr, 0);
return 1;
}
//CheckSquare
if (n != nbis)
{
Scierror(999, _("%s: Wrong size for input argument #%d: A square matrix expected.\n"), fname, 1);
return 1;
}
/* Variable 2 (p) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 2, &piAddr2);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 2.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr2, &nbis, &unbis, &p);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 2);
printError(&sciErr, 0);
return 1;
}
//CheckLength
if (nbis * unbis != n)
{
Scierror(999, _("%s: Wrong size for input argument #%d: %d expected.\n"), fname, 2, nbis * unbis);
return 1;
}
/* Variable 3 (C) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 3, &piAddr3);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 3.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr3, &m, &nbis, &C);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 3);
printError(&sciErr, 0);
return 1;
}
if (( nbis != n ) && (m > 0))
{
Scierror(205, _("%s: Wrong size for input argument #%d: number of columns %d expected.\n"), fname, 3, n);
return 0;
}
mmax = m;
mnn = m + n + n;
/* Variable 4 (b) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 4, &piAddr4);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 4.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr4, &mbis, &unbis, &b);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 4);
printError(&sciErr, 0);
return 1;
}
//CheckLength
if (mbis * unbis != m)
{
Scierror(999, _("%s: Wrong size for input argument #%d: %d expected.\n"), fname, 4, mbis * unbis);
return 1;
}
/* Variable 5 (lb) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 5, &piAddr5);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 5.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr5, &nbis, &unbis, &lb);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 5);
printError(&sciErr, 0);
return 1;
}
if (nbis * unbis == 0)
{
sciErr = allocMatrixOfDouble(pvApiCtx, next, n, un, &lb);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
for (k = 0; k < n; k++)
{
(lb)[k] = -nc_double_max();
}
next = next + 1;
}
else if (nbis * unbis != n) //CheckLength
{
Scierror(999, _("%s: Wrong size for input argument #%d: %d expected.\n"), fname, 5, nbis * unbis);
return 1;
}
/* Variable 6 (ub) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 6, &piAddr6);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 6.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr6, &nbis, &unbis, &ub);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 6);
printError(&sciErr, 0);
return 1;
}
if (nbis * unbis == 0)
{
sciErr = allocMatrixOfDouble(pvApiCtx, next, n, un, &ub);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
for (k = 0; k < n; k++)
{
(ub)[k] = nc_double_max();
}
next = next + 1;
}
else if (nbis * unbis != n)//CheckLength
{
Scierror(999, _("%s: Wrong size for input argument #%d: %d expected.\n"), fname, 6, nbis * unbis);
return 1;
}
/* Variable 7 (me) */
//get variable address
sciErr = getVarAddressFromPosition(pvApiCtx, 7, &piAddr7);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 7.
sciErr = getMatrixOfDoubleAsInteger(pvApiCtx, piAddr7, &pipo, &unbis, &me);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 7);
printError(&sciErr, 0);
return 1;
}
//CheckScalar
if (pipo != 1 || unbis != 1)
{
Scierror(999, _("%s: Wrong size for input argument #%d: A real scalar expected.\n"), fname, 7);
return 1;
}
if ((*(me) < 0) || (*(me) > n))
{
// FIX ME
// Err = 7;
SciError(116);
return 0;
}
if (nbInputArgument(pvApiCtx) == 8)
{
/* Variable 8 (eps1) */
//get variable address
int* piAddr8 = NULL;
double* leps = NULL;
sciErr = getVarAddressFromPosition(pvApiCtx, 8, &piAddr8);
if (sciErr.iErr)
{
printError(&sciErr, 0);
return 1;
}
// Retrieve a matrix of double at position 8.
sciErr = getMatrixOfDouble(pvApiCtx, piAddr8, &pipo, &unbis, &leps);
if (sciErr.iErr)
{
Scierror(202, _("%s: Wrong type for argument #%d: A real expected.\n"), fname, 8);
printError(&sciErr, 0);
return 1;
}
//CheckScalar
if (pipo != 1 || unbis != 1)
{
Scierror(999, _("%s: Wrong size for input argument #%d: A real scalar expected.\n"), fname, 8);
return 1;
}
eps1 = Max(eps1, *leps);
}
/* Internal variables: x, lambda, inform, C_mmax, b_mmax */
sciErr = allocMatrixOfDouble(pvApiCtx, next, n, un, &x);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
sciErr = allocMatrixOfDouble(pvApiCtx, next + 1, mnn, un, &lambda);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
sciErr = allocMatrixOfDoubleAsInteger(pvApiCtx, next + 2, un, un, &inform);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
lwar = 3 * n * n / 2 + 10 * n + 2 * mmax + 2;
sciErr = allocMatrixOfDouble(pvApiCtx, next + 3, lwar, un, &war);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
sciErr = allocMatrixOfDoubleAsInteger(pvApiCtx, next + 4, n, un, &iwar);
if (sciErr.iErr)
{
printError(&sciErr, 0);
Scierror(999, _("%s: Memory allocation error.\n"), fname);
return 1;
}
(iwar)[0] = 1; /*Cholesky factorization required*/
/* Change the sign of C*/
for (k = 0; k < n; k++)
{
for (l = 0; l < m; l++)
{
(C)[k * m + l] = -(C)[k * m + l];
}
}
iout = 0;
ifail = 0;
C2F(ql0001)(&m, (me), &mmax, &n, &n, &mnn, (Q), (p), (C),
(b), (lb), (ub), (x), (lambda), &iout,
&ifail, &zero, (war), &lwar, (iwar), &n, &eps1);
/* LhsVar: [x, lambda, inform] = qld(...) */
if (ifail == 0)
{
AssignOutputVariable(pvApiCtx, 1) = next;
AssignOutputVariable(pvApiCtx, 2) = next + 1;
if (nbOutputArgument(pvApiCtx) == 3)
{
AssignOutputVariable(pvApiCtx, 3) = next + 2;
*(inform) = ifail;
}
ReturnArguments(pvApiCtx);
}
else if (ifail == 1)
{
Scierror(24, _("%s: Too many iterations (more than %d).\n"), fname, 40 * (n + m));
}
else if (ifail == 2)
{
Scierror(24, _("%s: Accuracy insufficient to satisfy convergence criterion.\n"), fname);
}
else if (ifail == 5)
{
Scierror(999, _("%s: Length of working array is too short.\n"), fname);
}
else if (ifail > 10)
{
Scierror(999, _("%s: The constraints are inconsistent.\n"), fname);
}
else
{
}
return 0;
}
/*Complex matrices left division*/
int iLeftDivisionOfComplexMatrix(
double *_pdblReal1, double *_pdblImg1, int _iRows1, int _iCols1,
double *_pdblReal2, double *_pdblImg2, int _iRows2, int _iCols2,
double *_pdblRealOut, double *_pdblImgOut, int _iRowsOut, int _iColsOut, double *_pdblRcond)
{
int iReturn = 0;
int iIndex = 0;
char cNorm = 0;
int iExit = 0;
/*temporary variables*/
int iWorkMin = 0;
int iInfo = 0;
int iMax = 0;
double dblRcond = 0;
double dblEps = 0;
double RCONDthresh = 0;
double dblAnorm = 0;
doublecomplex *pAf = NULL;
doublecomplex *pXb = NULL;
doublecomplex *pDwork = NULL;
doublecomplex *poVar1 = NULL;
doublecomplex *poVar2 = NULL;
doublecomplex *poOut = NULL;
double *pRwork = NULL;
int iRank = 0;
int *pIpiv = NULL;
int *pJpvt = NULL;
iWorkMin = Max(2 * _iCols1, Min(_iRows1, _iCols1) + Max(2 * Min(_iRows1, _iCols1), Max(_iCols1, Min(_iRows1, _iCols1) + _iCols2)));
/* Array allocations*/
poVar1 = oGetDoubleComplexFromPointer(_pdblReal1, _pdblImg1, _iRows1 * _iCols1);
poVar2 = oGetDoubleComplexFromPointer(_pdblReal2, _pdblImg2, _iRows2 * _iCols2);
pIpiv = (int*)malloc(sizeof(int) * _iCols1);
pJpvt = (int*)malloc(sizeof(int) * _iCols1);
pRwork = (double*)malloc(sizeof(double) * _iCols1 * 2);
cNorm = '1';
pDwork = (doublecomplex*)malloc(sizeof(doublecomplex) * iWorkMin);
dblEps = nc_eps();
RCONDthresh = 10 * dblEps;
dblAnorm = C2F(zlange)(&cNorm, &_iRows1, &_iCols1, (double*)poVar1, &_iRows1, (double*)pDwork);
if (_iRows1 == _iCols1)
{
C2F(zgetrf)(&_iCols1, &_iCols1, poVar1, &_iCols1, pIpiv, &iInfo);
if (iInfo == 0)
{
C2F(zgecon)(&cNorm, &_iCols1, poVar1, &_iCols1, &dblAnorm, &dblRcond, pDwork, pRwork, &iInfo);
if (dblRcond > RCONDthresh)
{
cNorm = 'N';
C2F(zgetrs)(&cNorm, &_iCols1, &_iCols2, poVar1, &_iCols1, pIpiv, poVar2, &_iCols1, &iInfo);
vGetPointerFromDoubleComplex(poVar2, _iRowsOut * _iColsOut, _pdblRealOut, _pdblImgOut);
iExit = 1;
}
else
{
//how to extract that ? Oo
iReturn = -1;
*_pdblRcond = dblRcond;
}
}
}
if (iExit == 0)
{
dblRcond = RCONDthresh;
iMax = Max(_iRows1, _iCols1);
memset(pJpvt, 0x00, sizeof(int) * _iCols1);
pXb = (doublecomplex*)malloc(sizeof(doublecomplex) * iMax * _iColsOut);
cNorm = 'F';
C2F(zlacpy)(&cNorm, &_iRows2, &_iCols2, (double*)poVar2, &_iRows2, (double*)pXb, &iMax);
// pXb : in input pXb is of size rows1 x col2
// in output pXp is of size col1 x col2
iInfo = 1;
C2F(zgelsy1)(&_iRows1, &_iCols1, &_iCols2, poVar1, &_iRows1, pXb, &iMax,
pJpvt, &dblRcond, &iRank, pDwork, &iWorkMin, pRwork, &iInfo);
if (iInfo == 0)
{
// In the case where "pXb" has more rows that the output,
// the output values are the first lines of pXb
// and not the size of output first elements of pXb.
double* tmpRealPart = (double*)malloc(iMax * _iColsOut * sizeof(double));
double* tmpImagPart = (double*)malloc(iMax * _iColsOut * sizeof(double));
vGetPointerFromDoubleComplex(pXb, iMax * _iColsOut, tmpRealPart, tmpImagPart);
if ( _iRows1 != _iCols1 && iRank < Min(_iRows1, _iCols1))
{
//how to extract that ? Oo
iReturn = -2;
*_pdblRcond = (double)iRank;
}
C2F(dlacpy)(&cNorm, &_iRowsOut, &_iColsOut, tmpRealPart, &iMax, _pdblRealOut, &_iRowsOut);
C2F(dlacpy)(&cNorm, &_iRowsOut, &_iColsOut, tmpImagPart, &iMax, _pdblImgOut, &_iRowsOut);
free(tmpRealPart);
free(tmpImagPart);
}
free(pXb);
}
vFreeDoubleComplexFromPointer(poVar1);
vFreeDoubleComplexFromPointer(poVar2);
free(pIpiv);
free(pJpvt);
free(pRwork);
free(pDwork);
return 0;
}
/*Matrix left division*/
int iLeftDivisionOfRealMatrix(
double *_pdblReal1, int _iRows1, int _iCols1,
double *_pdblReal2, int _iRows2, int _iCols2,
double *_pdblRealOut, int _iRowsOut, int _iColsOut, double *_pdblRcond)
{
int iReturn = 0;
int iIndex = 0;
char cNorm = 0;
int iExit = 0;
/*temporary variables*/
int iWorkMin = 0;
int iInfo = 0;
int iMax = 0;
double dblRcond = 0;
double dblEps = 0;
double RCONDthresh = 0;
double dblAnorm = 0;
double *pAf = NULL;
double *pXb = NULL;
double *pDwork = NULL;
double* dblTemp = NULL;
int iOne = 1;
int iSize = 0;
int *pRank = NULL;
int *pIpiv = NULL;
int *pJpvt = NULL;
int *pIwork = NULL;
iWorkMin = Max(4 * _iCols1, Max(Min(_iRows1, _iCols1) + 3 * _iCols1 + 1, 2 * Min(_iRows1, _iCols1) + _iCols2));
/* Array allocations*/
pAf = (double*)malloc(sizeof(double) * _iRows1 * _iCols1);
pXb = (double*)malloc(sizeof(double) * Max(_iRows1, _iCols1) * _iCols2);
pRank = (int*)malloc(sizeof(int));
pIpiv = (int*)malloc(sizeof(int) * _iCols1);
pJpvt = (int*)malloc(sizeof(int) * _iCols1);
pIwork = (int*)malloc(sizeof(int) * _iCols1);
cNorm = '1';
pDwork = (double*)malloc(sizeof(double) * iWorkMin);
dblEps = nc_eps();
RCONDthresh = 10 * dblEps;
dblAnorm = C2F(dlange)(&cNorm, &_iRows1, &_iCols1, _pdblReal1, &_iRows1, pDwork);
if (_iRows1 == _iCols1)
{
cNorm = 'F';
C2F(dlacpy)(&cNorm, &_iCols1, &_iCols1, _pdblReal1, &_iCols1, pAf, &_iCols1);
C2F(dgetrf)(&_iCols1, &_iCols1, pAf, &_iCols1, pIpiv, &iInfo);
if (iInfo == 0)
{
cNorm = '1';
C2F(dgecon)(&cNorm, &_iCols1, pAf, &_iCols1, &dblAnorm, &dblRcond, pDwork, pIwork, &iInfo);
if (dblRcond > RCONDthresh)
{
// _pdblReal2 will be overwrite by dgetrs
iSize = _iRows2 * _iCols2;
dblTemp = (double*)malloc(iSize * sizeof(double));
C2F(dcopy)(&iSize, _pdblReal2, &iOne, dblTemp, &iOne);
cNorm = 'N';
C2F(dgetrs)(&cNorm, &_iCols1, &_iCols2, pAf, &_iCols1, pIpiv, dblTemp, &_iCols1, &iInfo);
cNorm = 'F';
C2F(dlacpy)(&cNorm, &_iCols1, &_iCols2, dblTemp, &_iCols1, _pdblRealOut, &_iCols1);
iExit = 1;
free(dblTemp);
}
}
if (iExit == 0)
{
*_pdblRcond = dblRcond;
iReturn = -1;
}
}
if (iExit == 0)
{
dblRcond = RCONDthresh;
cNorm = 'F';
iMax = Max(_iRows1, _iCols1);
C2F(dlacpy)(&cNorm, &_iRows1, &_iCols2, _pdblReal2, &_iRows1, pXb, &iMax);
memset(pJpvt, 0x00, sizeof(int) * _iCols1);
// _pdblReal1 will be overwrite by dgelsy1
iSize = _iRows1 * _iCols1;
dblTemp = (double*)malloc(iSize * sizeof(double));
C2F(dcopy)(&iSize, _pdblReal1, &iOne, dblTemp, &iOne);
iInfo = 1;
C2F(dgelsy1)(&_iRows1, &_iCols1, &_iCols2, dblTemp, &_iRows1, pXb, &iMax,
pJpvt, &dblRcond, &pRank[0], pDwork, &iWorkMin, &iInfo);
free(dblTemp);
if (iInfo == 0)
{
if ( _iRows1 != _iCols1 && pRank[0] < Min(_iRows1, _iCols1))
{
iReturn = -2;
*_pdblRcond = pRank[0];
}
cNorm = 'F';
C2F(dlacpy)(&cNorm, &_iCols1, &_iCols2, pXb, &iMax, _pdblRealOut, &_iCols1);
}
}
free(pAf);
free(pXb);
free(pRank);
free(pIpiv);
free(pJpvt);
free(pIwork);
free(pDwork);
return 0;
}
int iRightDivisionOfComplexMatrix(
double *_pdblReal1, double *_pdblImg1, int _iRows1, int _iCols1,
double *_pdblReal2, double *_pdblImg2, int _iRows2, int _iCols2,
double *_pdblRealOut, double *_pdblImgOut, int _iRowsOut, int _iColsOut, double *_pdblRcond)
{
int iReturn = 0;
int iIndex1 = 0;
int iIndex2 = 0;
char cNorm = 0;
int iExit = 0;
/*temporary variables*/
int iWorkMin = 0;
int iInfo = 0;
int iMax = 0;
double dblRcond = 0;
double dblEps = 0;
double RCONDthresh = 0;
double dblAnorm = 0;
doublecomplex *poVar1 = NULL;
doublecomplex *poVar2 = NULL;
doublecomplex *poOut = NULL;
doublecomplex *poAf = NULL;
doublecomplex *poAt = NULL;
doublecomplex *poBt = NULL;
doublecomplex *poDwork = NULL;
int *pRank = NULL;
int *pIpiv = NULL;
int *pJpvt = NULL;
double *pRwork = NULL;
iWorkMin = Max(2 * _iCols2, Min(_iRows2, _iCols2) + Max(2 * Min(_iRows2, _iCols2), Max(_iRows2 + 1, Min(_iRows2, _iCols2) + _iRows1)));
/* Array allocations*/
poVar1 = oGetDoubleComplexFromPointer(_pdblReal1, _pdblImg1, _iRows1 * _iCols1);
poVar2 = oGetDoubleComplexFromPointer(_pdblReal2, _pdblImg2, _iRows2 * _iCols2);
poOut = oGetDoubleComplexFromPointer(_pdblRealOut, _pdblImgOut, _iRowsOut * _iColsOut);
poAf = (doublecomplex*)malloc(sizeof(doublecomplex) * _iRows2 * _iCols2);
poAt = (doublecomplex*)malloc(sizeof(doublecomplex) * _iRows2 * _iCols2);
poBt = (doublecomplex*)malloc(sizeof(doublecomplex) * Max(_iRows2, _iCols2) * _iRows1);
poDwork = (doublecomplex*)malloc(sizeof(doublecomplex) * iWorkMin);
pRank = (int*)malloc(sizeof(int));
pIpiv = (int*)malloc(sizeof(int) * _iCols2);
pJpvt = (int*)malloc(sizeof(int) * _iRows2);
pRwork = (double*)malloc(sizeof(double) * 2 * _iRows2);
dblEps = nc_eps();
RCONDthresh = 10 * dblEps;
cNorm = '1';
dblAnorm = C2F(zlange)(&cNorm, &_iRows2, &_iCols2, (double*)poVar2, &_iRows2, (double*)poDwork);
//tranpose A and B
vTransposeDoubleComplexMatrix(poVar2, _iRows2, _iCols2, poAt, 1);
{
int i, j, ij, ji;
for (j = 0 ; j < _iRows1 ; j++)
{
for (i = 0 ; i < _iCols2 ; i++)
{
ij = i + j * Max(_iRows2, _iCols2);
ji = j + i * _iRows1;
poBt[ij].r = poVar1[ji].r;
//Conjugate
poBt[ij].i = -poVar1[ji].i;
}//for(j = 0 ; j < _iRows1 ; j++)
}//for(i = 0 ; i < _iCols2 ; i++)
}//bloc esthetique
if (_iRows2 == _iCols2)
{
cNorm = 'F';
C2F(zlacpy)(&cNorm, &_iCols2, &_iCols2, (double*)poAt, &_iCols2, (double*)poAf, &_iCols2);
C2F(zgetrf)(&_iCols2, &_iCols2, poAf, &_iCols2, pIpiv, &iInfo);
if (iInfo == 0)
{
cNorm = '1';
C2F(zgecon)(&cNorm, &_iCols2, poAf, &_iCols2, &dblAnorm, &dblRcond, poDwork, pRwork, &iInfo);
if (dblRcond > RCONDthresh)
{
cNorm = 'N';
C2F(zgetrs)(&cNorm, &_iCols2, &_iRows1, poAf, &_iCols2, pIpiv, poBt, &_iCols2, &iInfo);
vTransposeDoubleComplexMatrix(poBt, _iCols2, _iRows1, poOut, 1);
vGetPointerFromDoubleComplex(poOut, _iRowsOut * _iColsOut, _pdblRealOut, _pdblImgOut);
iExit = 1;
}
}
if (iExit == 0)
{
//how to extract that ? Oo
*_pdblRcond = dblRcond;
iReturn = -1;
}
}
if (iExit == 0)
{
dblRcond = RCONDthresh;
cNorm = 'F';
iMax = Max(_iRows2, _iCols2);
memset(pJpvt, 0x00, sizeof(int) * _iRows2);
iInfo = 1;
C2F(zgelsy1)(&_iCols2, &_iRows2, &_iRows1, poAt, &_iCols2, poBt, &iMax,
pJpvt, &dblRcond, pRank, poDwork, &iWorkMin, pRwork, &iInfo);
if (iInfo == 0)
{
if ( _iRows2 != _iCols2 && pRank[0] < Min(_iRows2, _iCols2))
{
//how to extract that ? Oo
iReturn = -2;
*_pdblRcond = pRank[0];
}
// TransposeRealMatrix(pBt, _iRows1, _iRows2, _pdblRealOut, Max(_iRows1,_iCols1), _iRows2);
//Mega caca de la mort qui tue des ours a mains nues
//mais je ne sais pas comment le rendre "beau" :(
{
int i, j, ij, ji;
for (j = 0 ; j < _iRows2 ; j++)
{
for (i = 0 ; i < _iRows1 ; i++)
{
ij = i + j * _iRows1;
ji = j + i * Max(_iRows2, _iCols2);
_pdblRealOut[ij] = poBt[ji].r;
//Conjugate
_pdblImgOut[ij] = -poBt[ji].i;
}//for(i = 0 ; i < _iRows2 ; i++)
}//for(j = 0 ; j < _iRows1 ; j++)
}//bloc esthetique
}//if(iInfo == 0)
}//if(iExit == 0)
vFreeDoubleComplexFromPointer(poVar1);
vFreeDoubleComplexFromPointer(poVar2);
vFreeDoubleComplexFromPointer(poOut);
free(poAf);
free(poAt);
free(poBt);
free(pRank);
free(pIpiv);
free(pJpvt);
free(pRwork);
free(poDwork);
return 0;
}
int iRightDivisionOfRealMatrix(
double *_pdblReal1, int _iRows1, int _iCols1,
double *_pdblReal2, int _iRows2, int _iCols2,
double *_pdblRealOut, int _iRowsOut, int _iColsOut, double* _pdblRcond)
{
int iReturn = 0;
int iIndex = 0;
char cNorm = 0;
int iExit = 0;
/*temporary variables*/
int iWorkMin = 0;
int iInfo = 0;
int iMax = 0;
double dblRcond = 0;
double dblEps = 0;
double RCONDthresh = 0;
double dblAnorm = 0;
double *pAf = NULL;
double *pAt = NULL;
double *pBt = NULL;
double *pDwork = NULL;
int *pRank = NULL;
int *pIpiv = NULL;
int *pJpvt = NULL;
int *pIwork = NULL;
iWorkMin = Max(4 * _iCols2, Max(Min(_iRows2, _iCols2) + 3 * _iRows2 + 1, 2 * Min(_iRows2, _iCols2) + _iRows1));
/* Array allocations*/
pAf = (double*)malloc(sizeof(double) * _iCols2 * _iRows2);
pAt = (double*)malloc(sizeof(double) * _iCols2 * _iRows2);
pBt = (double*)malloc(sizeof(double) * Max(_iRows2, _iCols2) * _iRows1);
pRank = (int*)malloc(sizeof(int));
pIpiv = (int*)malloc(sizeof(int) * _iCols2);
pJpvt = (int*)malloc(sizeof(int) * _iRows2);
pIwork = (int*)malloc(sizeof(int) * _iCols2);
//C'est du grand nawak ca, on reserve toute la stack ! Oo
cNorm = '1';
pDwork = (double*)malloc(sizeof(double) * iWorkMin);
dblEps = nc_eps();
RCONDthresh = 10 * dblEps;
dblAnorm = C2F(dlange)(&cNorm, &_iRows2, &_iCols2, _pdblReal2, &_iRows2, pDwork);
//tranpose A and B
vTransposeRealMatrix(_pdblReal2, _iRows2, _iCols2, pAt);
{
int i, j, ij, ji;
for (j = 0 ; j < _iRows1 ; j++)
{
for (i = 0 ; i < _iCols2 ; i++)
{
ij = i + j * Max(_iRows2, _iCols2);
ji = j + i * _iRows1;
pBt[ij] = _pdblReal1[ji];
}//for(j = 0 ; j < _iRows1 ; j++)
}//for(i = 0 ; i < _iCols2 ; i++)
}//bloc esthetique
if (_iRows2 == _iCols2)
{
cNorm = 'F';
C2F(dlacpy)(&cNorm, &_iCols2, &_iCols2, pAt, &_iCols2, pAf, &_iCols2);
C2F(dgetrf)(&_iCols2, &_iCols2, pAf, &_iCols2, pIpiv, &iInfo);
if (iInfo == 0)
{
cNorm = '1';
C2F(dgecon)(&cNorm, &_iCols2, pAf, &_iCols2, &dblAnorm, &dblRcond, pDwork, pIwork, &iInfo);
if (dblRcond > RCONDthresh)
{
cNorm = 'N';
C2F(dgetrs)(&cNorm, &_iCols2, &_iRows1, pAf, &_iCols2, pIpiv, pBt, &_iCols2, &iInfo);
vTransposeRealMatrix(pBt, _iCols2, _iRows1, _pdblRealOut);
iExit = 1;
}
}
if (iExit == 0)
{
//how to extract that ? Oo
*_pdblRcond = dblRcond;
iReturn = -1;
}
}
if (iExit == 0)
{
dblRcond = RCONDthresh;
cNorm = 'F';
iMax = Max(_iRows2, _iCols2);
memset(pJpvt, 0x00, sizeof(int) * _iRows2);
iInfo = 1;
C2F(dgelsy1)(&_iCols2, &_iRows2, &_iRows1, pAt, &_iCols2, pBt, &iMax,
pJpvt, &dblRcond, &pRank[0], pDwork, &iWorkMin, &iInfo);
if (iInfo == 0)
{
if ( _iRows2 != _iCols2 && pRank[0] < Min(_iRows2, _iCols2))
{
//how to extract that ? Oo
iReturn = -2;
*_pdblRcond = pRank[0];
}
// TransposeRealMatrix(pBt, _iRows1, _iRows2, _pdblRealOut, Max(_iRows1,_iCols1), _iRows2);
//Mega caca de la mort qui tue des ours a mains nues
//mais je ne sais pas comment le rendre "beau" :(
{
int i, j, ij, ji;
for (j = 0 ; j < _iRows2 ; j++)
{
for (i = 0 ; i < _iRows1 ; i++)
{
ij = i + j * _iRows1;
ji = j + i * Max(_iRows2, _iCols2);
_pdblRealOut[ij] = pBt[ji];
}//for(i = 0 ; i < _iRows2 ; i++)
}//for(j = 0 ; j < _iRows1 ; j++)
}//bloc esthetique
}//if(iInfo == 0)
}//if(bExit == 0)
free(pAf);
free(pAt);
free(pBt);
free(pRank);
free(pIpiv);
free(pJpvt);
free(pIwork);
free(pDwork);
return iReturn;
}
/*--------------------------------------------------------------------------*/
SCICOS_BLOCKS_IMPEXP void matz_bksl(scicos_block *block, int flag)
{
double *u1r = NULL, *u1i = NULL;
double *u2r = NULL, *u2i = NULL;
double *yr = NULL, *yi = NULL;
int mu = 0, vu = 0, wu = 0;
int nu1 = 0;
int nu2 = 0;
int info = 0;
int i = 0, j = 0, l = 0, lw = 0, lu = 0, ij = 0, k = 0;
mat_bksl_struct** work = (mat_bksl_struct**) block->work;
mat_bksl_struct *ptr = NULL;
double rcond = 0., ANORM = 0., EPS = 0.;
vu = GetOutPortRows(block, 1);
wu = GetOutPortCols(block, 1);
mu = GetInPortRows(block, 1);
nu1 = GetInPortCols(block, 1);
nu2 = GetInPortCols(block, 2);
u1r = GetRealInPortPtrs(block, 1);
u1i = GetImagInPortPtrs(block, 1);
u2r = GetRealInPortPtrs(block, 2);
u2i = GetImagInPortPtrs(block, 2);
yr = GetRealOutPortPtrs(block, 1);
yi = GetImagOutPortPtrs(block, 1);
l = Max(mu, nu1);
lw = Max(2 * Min(mu, nu1), nu1 + 1);
lu = Max(lw, Min(mu, nu1) + nu2);
lw = Max(2 * nu1, Min(mu, nu1) + lu);
/*init : initialization*/
if (flag == 4)
{
if ((*work = (mat_bksl_struct*) scicos_malloc(sizeof(mat_bksl_struct))) == NULL)
{
set_block_error(-16);
return;
}
ptr = *work;
if ((ptr->ipiv = (int*) scicos_malloc(sizeof(int) * nu1)) == NULL)
{
set_block_error(-16);
scicos_free(ptr);
return;
}
if ((ptr->rank = (int*) scicos_malloc(sizeof(int))) == NULL)
{
set_block_error(-16);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->jpvt = (int*) scicos_malloc(sizeof(int) * nu1)) == NULL)
{
set_block_error(-16);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->iwork = (double*) scicos_malloc(sizeof(double) * 2 * nu1)) == NULL)
{
set_block_error(-16);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->dwork = (double*) scicos_malloc(sizeof(double) * 2 * lw)) == NULL)
{
set_block_error(-16);
scicos_free(ptr->iwork);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->IN1F = (double*) scicos_malloc(sizeof(double) * (2 * mu * nu1))) == NULL)
{
set_block_error(-16);
scicos_free(ptr->dwork);
scicos_free(ptr->iwork);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->IN1 = (double*) scicos_malloc(sizeof(double) * (2 * mu * nu1))) == NULL)
{
set_block_error(-16);
scicos_free(ptr->IN1F);
scicos_free(ptr->dwork);
scicos_free(ptr->iwork);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->IN2X = (double*) scicos_malloc(sizeof(double) * (2 * l * nu2))) == NULL)
{
set_block_error(-16);
scicos_free(ptr->IN1);
scicos_free(ptr->IN1F);
scicos_free(ptr->dwork);
scicos_free(ptr->iwork);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
if ((ptr->IN2 = (double*) scicos_malloc(sizeof(double) * (2 * mu * nu2))) == NULL)
{
set_block_error(-16);
scicos_free(ptr->IN2);
scicos_free(ptr->IN1);
scicos_free(ptr->IN1F);
scicos_free(ptr->dwork);
scicos_free(ptr->iwork);
scicos_free(ptr->jpvt);
scicos_free(ptr->rank);
scicos_free(ptr->ipiv);
scicos_free(ptr);
return;
}
}
/* Terminaison */
else if (flag == 5)
{
ptr = *work;
if ((ptr->IN2) != NULL)
{
scicos_free(ptr->ipiv);
scicos_free(ptr->rank);
scicos_free(ptr->jpvt);
scicos_free(ptr->iwork);
scicos_free(ptr->IN1F);
scicos_free(ptr->IN1);
scicos_free(ptr->IN2X);
scicos_free(ptr->IN2);
scicos_free(ptr->dwork);
scicos_free(ptr);
return;
}
}
else
{
ptr = *work;
for (i = 0; i < (mu * nu1); i++)
{
ptr->IN1[2 * i] = u1r[i];
ptr->IN1[2 * i + 1] = u1i[i];
}
for (i = 0; i < (mu * nu2); i++)
{
ptr->IN2[2 * i] = u2r[i];
ptr->IN2[2 * i + 1] = u2i[i];
}
EPS = nc_eps();
ANORM = C2F(zlange)("1", &mu, &nu1, ptr->IN1, &mu, ptr->dwork);
if (mu == nu1)
{
C2F(zlacpy)("F", &mu, &nu1, ptr->IN1, &mu, ptr->IN1F, &mu);
C2F(zgetrf)(&nu1, &nu1, ptr->IN1F, &nu1, ptr->ipiv, &info);
rcond = 0;
if (info == 0)
{
C2F(zgecon)("1", &nu1, ptr->IN1F, &nu1, &ANORM, &rcond, ptr->dwork, ptr->iwork, &info);
if (rcond > pow(EPS, 0.5))
{
C2F(zgetrs)("N", &nu1, &nu2, ptr->IN1F, &nu1, ptr->ipiv, ptr->IN2, &nu1, &info);
for (i = 0; i < (mu * nu2); i++)
{
*(yr + i) = *(ptr->IN2 + 2 * i);
*(yi + i) = *(ptr->IN2 + (2 * i) + 1);
}
return;
}
}
}
rcond = pow(EPS, 0.5);
for (i = 0; i < nu1; i++)
{
*(ptr->jpvt + i) = 0;
}
C2F(zlacpy)("F", &mu, &nu2, ptr->IN2, &mu, ptr->IN2X, &l);
C2F(zgelsy1)(&mu, &nu1, &nu2, ptr->IN1, &mu, ptr->IN2X, &l, ptr->jpvt, &rcond, ptr->rank, ptr->dwork, &lw, ptr->iwork, &info);
if (info != 0)
{
if (flag != 6)
{
set_block_error(-7);
return;
}
}
k = 0;
for (j = 0; j < wu; j++)
{
for (i = 0; i < vu; i++)
{
ij = i + j * l;
*(yr + k) = *(ptr->IN2X + 2 * ij);
*(yi + k) = *(ptr->IN2X + (2 * ij) + 1);
k++;
}
}
}
}
