int readDoubleComplexMatrix(int _iDatasetId, double *_pdblReal, double *_pdblImg)
{
hid_t compoundId;
herr_t status;
int iDims = 0;
int* piDims = NULL;
int iComplex = 0;
int iSize = 1;
doublecomplex* pData = NULL;
int i = 0;
/*define compound dataset*/
compoundId = H5Tcreate(H5T_COMPOUND, sizeof(doublecomplex));
H5Tinsert(compoundId, "real", HOFFSET(doublecomplex, r), H5T_NATIVE_DOUBLE);
H5Tinsert(compoundId, "imag", HOFFSET(doublecomplex, i), H5T_NATIVE_DOUBLE);
//get dimension from dataset
getDatasetInfo(_iDatasetId, &iComplex, &iDims, NULL);
piDims = (int*)MALLOC(sizeof(int) * iDims);
iSize = getDatasetInfo(_iDatasetId, &iComplex, &iDims, piDims);
if (iSize < 0)
{
FREE(piDims);
return -1;
}
FREE(piDims);
//alloc temp array
pData = (doublecomplex*)MALLOC(sizeof(doublecomplex) * iSize);
//Read the data.
status = H5Dread(_iDatasetId, compoundId, H5S_ALL, H5S_ALL, H5P_DEFAULT, pData);
if (status < 0)
{
FREE(pData);
return -1;
}
vGetPointerFromDoubleComplex(pData, iSize, _pdblReal, _pdblImg);
FREE(pData);
status = H5Dclose(_iDatasetId);
if (status < 0)
{
return -1;
}
return 0;
}
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 createNamedComplexZMatrixOfDouble(void* _pvCtx, const char* _pstName, int _iRows, int _iCols, const doublecomplex* _pdblData)
{
SciErr sciErr; sciErr.iErr = 0; sciErr.iMsgCount = 0;
int iVarID[nsiz];
int iSaveRhs = Rhs;
int iSaveTop = Top;
int iSize = _iRows * _iCols;
int *piAddr = NULL;
double *pdblReal = NULL;
double *pdblImg = NULL;
if (!checkNamedVarFormat(_pvCtx, _pstName))
{
addErrorMessage(&sciErr, API_ERROR_INVALID_NAME, _("%s: Invalid variable name."), "createNamedComplexZMatrixOfDouble");
return sciErr;
}
C2F(str2name)(_pstName, iVarID, (int)strlen(_pstName));
Top = Top + Nbvars + 1;
getNewVarAddressFromPosition(_pvCtx, Top, &piAddr);
//write matrix information
fillCommonMatrixOfDouble(_pvCtx, piAddr, 1, _iRows, _iCols, &pdblReal, &pdblImg);
vGetPointerFromDoubleComplex(_pdblData, _iRows * _iCols, pdblReal, pdblImg);
//update "variable index"
updateLstk(Top, *Lstk(Top) + sadr(4), iSize * (2) * 2);
Rhs = 0;
//Add name in stack reference list
createNamedVariable(iVarID);
Top = iSaveTop;
Rhs = iSaveRhs;
return sciErr;
}
types::Function::ReturnValue sci_spec(types::typed_list &in, int _iRetCount, types::typed_list &out)
{
double* pDataA = NULL;
double* pDataB = NULL;
bool symmetric = FALSE;
int iRet = 0;
if (in.size() != 1 && in.size() != 2)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), "spec", 1, 2);
return types::Function::Error;
}
if (_iRetCount > 2 * in.size())
{
Scierror(78, _("%s: Wrong number of output argument(s): %d to %d expected.\n"), "spec", 1, 2 * in.size());
return types::Function::Error;
}
if (in[0]->isDouble() == false)
{
std::wstring wstFuncName = L"%" + in[0]->getShortTypeStr() + L"_spec";
return Overload::call(wstFuncName, in, _iRetCount, out);
}
types::Double* in0 = in[0]->getAs<types::Double>();
if (in0->getCols() != in0->getRows())
{
Scierror(20, _("%s: Wrong type for input argument #%d: Square matrix expected.\n"), "spec", 1);
return types::Function::Error;
}
if (in0->getRows() == -1 || in0->getCols() == -1) // manage eye case
{
Scierror(271, _("%s: Size varying argument a*eye(), (arg %d) not allowed here.\n"), "spec", 1);
return types::Function::Error;
}
if (in0->getCols() == 0 || in0->getRows() == 0) // size null
{
out.push_back(types::Double::Empty());
for (int i = 1; i < _iRetCount; i++)
{
out.push_back(types::Double::Empty());
}
return types::Function::OK;
}
types::Double* pDblA = in0->clone()->getAs<types::Double>();
if (in.size() == 1)
{
types::Double* pDblEigenValues = NULL;
types::Double* pDblEigenVectors = NULL;
if (pDblA->isComplex())
{
pDataA = (double*)oGetDoubleComplexFromPointer(pDblA->getReal(), pDblA->getImg(), pDblA->getSize());
if (!pDataA)
{
pDblA->killMe();
Scierror(999, _("%s: Cannot allocate more memory.\n"), "spec");
return types::Function::Error;
}
}
else
{
pDataA = pDblA->getReal();
}
int totalSize = pDblA->getSize();
if ((pDblA->isComplex() ? C2F(vfiniteComplex)(&totalSize, (doublecomplex*)pDataA) : C2F(vfinite)(&totalSize, pDataA)) == false)
{
if (pDblA->isComplex())
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
}
pDblA->killMe();
Scierror(264, _("%s: Wrong value for input argument %d: Must not contain NaN or Inf.\n"), "spec", 1);
return types::Function::Error;
}
symmetric = isSymmetric(pDblA->getReal(), pDblA->getImg(), pDblA->isComplex(), pDblA->getRows(), pDblA->getCols()) == 1;
int eigenValuesCols = (_iRetCount == 1) ? 1 : pDblA->getCols();
if (symmetric)
{
pDblEigenValues = new types::Double(pDblA->getCols(), eigenValuesCols);
if (_iRetCount == 2)
{
pDblEigenVectors = new types::Double(pDblA->getCols(), pDblA->getCols(), pDblA->isComplex());
}
}
else
{
pDblEigenValues = new types::Double(pDblA->getCols(), eigenValuesCols, true);
if (_iRetCount == 2)
{
pDblEigenVectors = new types::Double(pDblA->getCols(), pDblA->getCols(), true);
}
}
if (pDblA->isComplex())
{
if (symmetric)
{
iRet = iEigen1ComplexSymmetricM((doublecomplex*)pDataA, pDblA->getCols(), (_iRetCount == 2), pDblEigenValues->getReal());
if (iRet < 0)
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
pDblA->killMe();
Scierror(998, _("%s: On entry to ZGEEV parameter number 3 had an illegal value (lapack library problem).\n"), "spec", iRet);
return types::Function::Error;
}
if (iRet > 0)
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
pDblA->killMe();
Scierror(24, _("%s: Convergence problem, %d off-diagonal elements of an intermediate tridiagonal form did not converge to zero.\n"), "spec", iRet);
return types::Function::Error;
}
if (_iRetCount == 2)
{
vGetPointerFromDoubleComplex((doublecomplex*)pDataA, pDblA->getSize() , pDblEigenVectors->getReal(), pDblEigenVectors->getImg());
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
expandToDiagonalOfMatrix(pDblEigenValues->getReal(), pDblA->getCols());
out.push_back(pDblEigenVectors);
}
out.push_back(pDblEigenValues);
}
else // not symmetric
{
doublecomplex* pEigenValues = (doublecomplex*)MALLOC(pDblA->getCols() * sizeof(doublecomplex));
doublecomplex* pEigenVectors = pDblEigenVectors ? (doublecomplex*)MALLOC(sizeof(doublecomplex) * pDblA->getSize()) : NULL;
iRet = iEigen1ComplexM((doublecomplex*)pDataA, pDblA->getCols(), pEigenValues, pEigenVectors);
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
if (iRet < 0)
{
pDblA->killMe();
Scierror(998, _("%s: On entry to ZHEEV parameter number 3 had an illegal value (lapack library problem).\n"), "spec", iRet);
return types::Function::Error;
}
if (iRet > 0)
{
pDblA->killMe();
Scierror(24, _("%s: The QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed. Elements and %d+1:N of W contain eigenvalues which have converged.\n"), "spec", iRet);
return types::Function::Error;
}
if (_iRetCount == 2)
{
expandZToDiagonalOfCMatrix(pEigenValues, pDblA->getCols(), pDblEigenValues->getReal(), pDblEigenValues->getImg());
vGetPointerFromDoubleComplex(pEigenVectors, pDblA->getSize(), pDblEigenVectors->getReal(), pDblEigenVectors->getImg());
FREE(pEigenVectors);
out.push_back(pDblEigenVectors);
}
else
{
vGetPointerFromDoubleComplex(pEigenValues, pDblA->getCols(), pDblEigenValues->getReal(), pDblEigenValues->getImg());
}
out.push_back(pDblEigenValues);
FREE(pEigenValues);
pDblA->killMe();
}
}
else // real
{
if (symmetric)
{
iRet = iEigen1RealSymmetricM(pDataA, pDblA->getCols(), (_iRetCount == 2), pDblEigenValues->getReal());
if (iRet < 0)
{
pDblA->killMe();
Scierror(998, _("%s: On entry to ZGEEV parameter number 3 had an illegal value (lapack library problem).\n"), "spec", iRet);
return types::Function::Error;
}
if (iRet > 0)
{
pDblA->killMe();
Scierror(24, _("%s: Convergence problem, %d off-diagonal elements of an intermediate tridiagonal form did not converge to zero.\n"), "spec", iRet);
return types::Function::Error;
}
if (_iRetCount == 2)
{
expandToDiagonalOfMatrix(pDblEigenValues->getReal(), pDblA->getCols());
out.push_back(pDblA);
}
else
{
pDblA->killMe();
}
out.push_back(pDblEigenValues);
}
else // not symmetric
{
iRet = iEigen1RealM(pDataA, pDblA->getCols(), pDblEigenValues->getReal(), pDblEigenValues->getImg(), pDblEigenVectors ? pDblEigenVectors->getReal() : NULL, pDblEigenVectors ? pDblEigenVectors->getImg() : NULL);
if (iRet < 0)
{
pDblA->killMe();
Scierror(998, _("%s: On entry to ZHEEV parameter number 3 had an illegal value (lapack library problem).\n"), "spec", iRet);
return types::Function::Error;
}
if (iRet > 0)
{
pDblA->killMe();
Scierror(24, _("%s: The QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed. Elements and %d+1:N of WR and WI contain eigenvalues which have converged.\n"), "spec", iRet);
return types::Function::Error;
}
if (_iRetCount == 2)
{
expandToDiagonalOfMatrix(pDblEigenValues->getReal(), pDblA->getCols());
expandToDiagonalOfMatrix(pDblEigenValues->getImg(), pDblA->getCols());
out.push_back(pDblEigenVectors);
}
out.push_back(pDblEigenValues);
pDblA->killMe();
}
}
return types::Function::OK;
}
if (in.size() == 2)
{
types::Double* pDblL = NULL;
types::Double* pDblR = NULL;
types::Double* pDblBeta = NULL;
types::Double* pDblAlpha = NULL;
doublecomplex* pL = NULL;
doublecomplex* pR = NULL;
doublecomplex* pBeta = NULL;
doublecomplex* pAlpha = NULL;
bool bIsComplex = false;
if (in[1]->isDouble() == false)
{
std::wstring wstFuncName = L"%" + in[1]->getShortTypeStr() + L"_spec";
return Overload::call(wstFuncName, in, _iRetCount, out);
}
types::Double* in1 = in[1]->getAs<types::Double>();
if (in1->getCols() != in1->getRows())
{
Scierror(20, _("%s: Wrong type for input argument #%d: Square matrix expected.\n"), "spec", 2);
return types::Function::Error;
}
if (pDblA->getRows() != in1->getRows() && pDblA->getCols() != in1->getCols())
{
pDblA->killMe();
Scierror(999, _("%s: Arguments %d and %d must have equal dimensions.\n"), "spec", 1, 2);
return types::Function::Error;
}
//chekc if A and B are real complex or with imag part at 0
if (isNoZeroImag(pDblA) == false && isNoZeroImag(in1) == false)
{
//view A and B as real matrix
bIsComplex = false;
}
else
{
bIsComplex = pDblA->isComplex() || in1->isComplex();
}
types::Double* pDblB = in1->clone()->getAs<types::Double>();
if (bIsComplex)
{
if (pDblA->isComplex() == false)
{
pDblA->setComplex(true);
}
if (pDblB->isComplex() == false)
{
pDblB->setComplex(true);
}
pDataA = (double*)oGetDoubleComplexFromPointer(pDblA->getReal(), pDblA->getImg(), pDblA->getSize());
pDataB = (double*)oGetDoubleComplexFromPointer(pDblB->getReal(), pDblB->getImg(), pDblB->getSize());
if (!pDataA || !pDataB)
{
delete pDataA;
delete pDataB;
Scierror(999, _("%s: Cannot allocate more memory.\n"), "spec");
return types::Function::Error;
}
}
else
{
pDataA = pDblA->getReal();
pDataB = pDblB->getReal();
}
int totalSize = pDblA->getSize();
if ((pDblA->isComplex() ? C2F(vfiniteComplex)(&totalSize, (doublecomplex*)pDataA) : C2F(vfinite)(&totalSize, pDataA)) == false)
{
pDblA->killMe();
pDblB->killMe();
Scierror(264, _("%s: Wrong value for input argument %d: Must not contain NaN or Inf.\n"), "spec", 1);
return types::Function::Error;
}
if ((pDblB->isComplex() ? C2F(vfiniteComplex)(&totalSize, (doublecomplex*)pDataB) : C2F(vfinite)(&totalSize, pDataB)) == false)
{
pDblA->killMe();
pDblB->killMe();
Scierror(264, _("%s: Wrong value for input argument %d: Must not contain NaN or Inf.\n"), "spec", 2);
return types::Function::Error;
}
switch (_iRetCount)
{
case 4:
{
pDblL = new types::Double(pDblA->getRows(), pDblA->getCols(), true);
if (bIsComplex)
{
pL = (doublecomplex*)MALLOC(pDblA->getSize() * sizeof(doublecomplex));
}
}
case 3:
{
pDblR = new types::Double(pDblA->getRows(), pDblA->getCols(), true);
if (bIsComplex)
{
pR = (doublecomplex*)MALLOC(pDblA->getSize() * sizeof(doublecomplex));
}
}
case 2:
{
if (bIsComplex)
{
pBeta = (doublecomplex*)MALLOC(pDblA->getCols() * sizeof(doublecomplex));
}
pDblBeta = new types::Double(pDblA->getCols(), 1, pBeta ? true : false);
}
default : // case 1:
{
if (bIsComplex)
{
pAlpha = (doublecomplex*)MALLOC(pDblA->getCols() * sizeof(doublecomplex));
}
pDblAlpha = new types::Double(pDblA->getCols(), 1, true);
}
}
if (bIsComplex)
{
iRet = iEigen2ComplexM((doublecomplex*)pDataA, (doublecomplex*)pDataB, pDblA->getCols(), pAlpha, pBeta, pR, pL);
}
else
{
iRet = iEigen2RealM( pDataA, pDataB, pDblA->getCols(),
pDblAlpha->getReal(), pDblAlpha->getImg(),
pDblBeta ? pDblBeta->getReal() : NULL,
pDblR ? pDblR->getReal() : NULL,
pDblR ? pDblR->getImg() : NULL,
pDblL ? pDblL->getReal() : NULL,
pDblL ? pDblL->getImg() : NULL);
}
if (iRet > 0)
{
sciprint(_("Warning :\n"));
sciprint(_("Non convergence in the QZ algorithm.\n"));
sciprint(_("The top %d x %d blocks may not be in generalized Schur form.\n"), iRet);
}
if (iRet < 0)
{
pDblA->killMe();
pDblB->killMe();
Scierror(998, _("%s: On entry to ZHEEV parameter number 3 had an illegal value (lapack library problem).\n"), "spec", iRet);
return types::Function::Error;
}
if (iRet > 0)
{
if (bIsComplex)
{
if (iRet <= pDblA->getCols())
{
Scierror(24, _("%s: The QZ iteration failed in DGGEV.\n"), "spec");
}
else
{
if (iRet == pDblA->getCols() + 1)
{
Scierror(999, _("%s: Other than QZ iteration failed in DHGEQZ.\n"), "spec");
}
if (iRet == pDblA->getCols() + 2)
{
Scierror(999, _("%s: Error return from DTGEVC.\n"), "spec");
}
}
}
else
{
Scierror(24, _("%s: The QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed. Elements and %d+1:N of W contain eigenvalues which have converged.\n"), "spec", iRet);
}
pDblA->killMe();
pDblB->killMe();
if (pDataA)
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
}
if (pDataB)
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataB);
}
return types::Function::Error;
}
if (bIsComplex)
{
switch (_iRetCount)
{
case 4:
vGetPointerFromDoubleComplex(pL, pDblA->getSize(), pDblL->getReal(), pDblL->getImg());
case 3:
vGetPointerFromDoubleComplex(pR, pDblA->getSize(), pDblR->getReal(), pDblR->getImg());
case 2:
vGetPointerFromDoubleComplex(pBeta, pDblA->getCols(), pDblBeta->getReal(), pDblBeta->getImg());
default : // case 1:
vGetPointerFromDoubleComplex(pAlpha, pDblA->getCols(), pDblAlpha->getReal(), pDblAlpha->getImg());
}
}
switch (_iRetCount)
{
case 1:
{
out.push_back(pDblAlpha);
break;
}
case 2:
{
out.push_back(pDblAlpha);
out.push_back(pDblBeta);
break;
}
case 3:
{
out.push_back(pDblAlpha);
out.push_back(pDblBeta);
out.push_back(pDblR);
break;
}
case 4:
{
out.push_back(pDblAlpha);
out.push_back(pDblBeta);
out.push_back(pDblL);
out.push_back(pDblR);
}
}
if (pAlpha)
{
vFreeDoubleComplexFromPointer(pAlpha);
}
if (pBeta)
{
vFreeDoubleComplexFromPointer(pBeta);
}
if (pL)
{
vFreeDoubleComplexFromPointer(pL);
}
if (pR)
{
vFreeDoubleComplexFromPointer(pR);
}
if (bIsComplex && pDblB->isComplex())
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataB);
}
pDblB->killMe();
} // if(in.size() == 2)
if (pDblA->isComplex())
{
vFreeDoubleComplexFromPointer((doublecomplex*)pDataA);
}
return types::Function::OK;
}
int iPowerComplexSquareMatrixByRealScalar(
double* _pdblReal1, double* _pdblImg1, int _iRows1, int _iCols1,
double _dblReal2,
double* _pdblRealOut, double* _pdblImgOut)
{
int iInv = 0;
int iExpRef = (int)_dblReal2;
if (iExpRef < 0)
{
//call matrix invetion
iInv = 1;
iExpRef = -iExpRef;
}
if ((int)_dblReal2 == _dblReal2) //integer exponent
{
if (iExpRef == 1)
{
int iSize = _iRows1 * _iCols1;
int iOne = 1;
C2F(dcopy)(&iSize, _pdblReal1, &iOne, _pdblRealOut, &iOne);
C2F(dcopy)(&iSize, _pdblImg1, &iOne, _pdblImgOut, &iOne);
}
else if (iExpRef == 0)
{
int iSize = _iRows1 * _iCols1;
int iOne = 1;
double dblOne = 1;
double dblZero = 0;
int iRowp1 = _iRows1 + 1;
if (C2F(dasum)(&iSize, _pdblReal1, &iOne) == 0)
{
//Invalid exponent
return 1;
}
C2F(dset)(&iSize, &dblZero, _pdblRealOut, &iOne);
C2F(dset)(&_iRows1, &dblOne, _pdblRealOut, &iRowp1);
}
else
{
int iSize = _iRows1 * _iCols1;
int iExp = 0;
int iRow = 0;
int iCol = 0;
int iOne = 1;
//temporary work space
double *pWorkReal2 = (double*)malloc(sizeof(double) * iSize);
double *pWorkImg2 = (double*)malloc(sizeof(double) * iSize);
double *pWorkReal3 = (double*)malloc(sizeof(double) * _iRows1);
double *pWorkImg3 = (double*)malloc(sizeof(double) * _iRows1);
//copy In to Out
C2F(dcopy)(&iSize, _pdblReal1, &iOne, _pdblRealOut, &iOne);
C2F(dcopy)(&iSize, _pdblImg1, &iOne, _pdblImgOut, &iOne);
C2F(dcopy)(&iSize, _pdblReal1, &iOne, pWorkReal2, &iOne);
C2F(dcopy)(&iSize, _pdblImg1, &iOne, pWorkImg2, &iOne);
//l1 -> l2
for (iExp = 1 ; iExp < iExpRef ; iExp++)
{
for (iCol = 0 ; iCol < _iCols1 ; iCol++)
{
double *pPtrReal = _pdblRealOut + iCol * _iCols1;
double *pPtrImg = _pdblImgOut + iCol * _iCols1;
C2F(dcopy)(&_iRows1, pPtrReal, &iOne, pWorkReal3, &iOne);
C2F(dcopy)(&_iRows1, pPtrImg, &iOne, pWorkImg3, &iOne);
//ls -> l3
for (iRow = 0 ; iRow < _iRows1 ; iRow++)
{
int iOffset = iRow + iCol * _iRows1;
pPtrReal = pWorkReal2 + iRow;
pPtrImg = pWorkImg2 + iRow;
_pdblRealOut[iOffset] = C2F(ddot)(&_iRows1, pPtrReal, &_iRows1, pWorkReal3, &iOne)
- C2F(ddot)(&_iRows1, pPtrImg, &_iRows1, pWorkImg3, &iOne);
_pdblImgOut[iOffset] = C2F(ddot)(&_iRows1, pPtrReal, &_iRows1, pWorkImg3, &iOne)
+ C2F(ddot)(&_iRows1, pPtrImg, &_iRows1, pWorkReal3, &iOne);
}//for
}//for
}//for
free(pWorkReal2);
free(pWorkImg2);
free(pWorkReal3);
free(pWorkImg3);
}//if(iExpRef != 1 && != 0)
}
else
{
//floating point exponent
return -1; // manage by overload
}
if (iInv)
{
double dblRcond;
double* pData = (double*)oGetDoubleComplexFromPointer(_pdblRealOut, _pdblImgOut, _iRows1 * _iCols1);
int ret = iInvertMatrixM(_iRows1, _iCols1, pData, 1/* is complex*/, &dblRcond);
if (ret == -1)
{
if (getWarningMode())
{
sciprint(_("Warning :\n"));
sciprint(_("matrix is close to singular or badly scaled. rcond = %1.4E\n"), dblRcond);
sciprint(_("computing least squares solution. (see lsq).\n"));
}
}
vGetPointerFromDoubleComplex((doublecomplex*)pData, _iRows1 * _iCols1, _pdblRealOut, _pdblImgOut);
vFreeDoubleComplexFromPointer((doublecomplex*)pData);
}
return 0;
}
types::Function::ReturnValue sci_inv(types::typed_list &in, int _iRetCount, types::typed_list &out)
{
types::Double* pDbl = NULL;
double* pData = NULL;
int ret = 0;
if (in.size() != 1)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d expected.\n"), "inv", 1);
return types::Function::Error;
}
if ((in[0]->isDouble() == false))
{
std::wstring wstFuncName = L"%" + in[0]->getShortTypeStr() + L"_inv";
return Overload::call(wstFuncName, in, _iRetCount, out);
}
pDbl = in[0]->getAs<types::Double>()->clone()->getAs<types::Double>(); // input data will be modified
if (pDbl->getRows() != pDbl->getCols())
{
Scierror(20, _("%s: Wrong type for argument %d: Square matrix expected.\n"), "inv", 1);
return types::Function::Error;
}
if (pDbl->getRows() == 0)
{
out.push_back(types::Double::Empty());
return types::Function::OK;
}
if (pDbl->isComplex())
{
/* c -> z */
pData = (double*)oGetDoubleComplexFromPointer( pDbl->getReal(), pDbl->getImg(), pDbl->getSize());
}
else
{
pData = pDbl->getReal();
}
if (pDbl->getCols() == -1)
{
pData[0] = 1. / pData[0];
}
else
{
double dblRcond;
ret = iInvertMatrixM(pDbl->getRows(), pDbl->getCols(), pData, pDbl->isComplex(), &dblRcond);
if (pDbl->isComplex())
{
/* z -> c */
vGetPointerFromDoubleComplex((doublecomplex*)pData, pDbl->getSize(), pDbl->getReal(), pDbl->getImg());
vFreeDoubleComplexFromPointer((doublecomplex*)pData);
}
if (ret == -1)
{
if (getWarningMode())
{
sciprint(_("Warning :\n"));
sciprint(_("matrix is close to singular or badly scaled. rcond = %1.4E\n"), dblRcond);
}
}
}
if (ret == 19)
{
Scierror(19, _("%s: Problem is singular.\n"), "inv");
return types::Function::Error;
}
out.push_back(pDbl);
return types::Function::OK;
}
types::Function::ReturnValue sci_lsq(types::typed_list &in, int _iRetCount, types::typed_list &out)
{
types::Double* pDbl[2] = {NULL, NULL};
types::Double* pDblResult = NULL;
double* pData[2] = {NULL, NULL};
double* pResult = NULL;
double* pdTol = NULL;
bool bComplexArgs = false;
int iRank = 0;
if (in.size() < 2 || in.size() > 3)
{
Scierror(77, _("%s: Wrong number of input argument(s): %d to %d expected.\n"), "lsq", 2, 3);
return types::Function::Error;
}
if (_iRetCount > 2)
{
Scierror(78, _("%s: Wrong number of output argument(s): %d to %d expected.\n"), "lsq", 1, 2);
return types::Function::Error;
}
if ((in[0]->isDouble() == false))
{
ast::ExecVisitor exec;
std::wstring wstFuncName = L"%" + in[0]->getShortTypeStr() + L"_lsq";
return Overload::call(wstFuncName, in, _iRetCount, out, &exec);
}
if (in.size() == 2)
{
if ((in[1]->isDouble() == false))
{
ast::ExecVisitor exec;
std::wstring wstFuncName = L"%" + in[1]->getShortTypeStr() + L"_lsq";
return Overload::call(wstFuncName, in, _iRetCount, out, &exec);
}
pDbl[1] = in[1]->getAs<types::Double>()->clone()->getAs<types::Double>();
}
if (in.size() == 3)
{
if ((in[2]->isDouble() == false) || (in[2]->getAs<types::Double>()->isComplex()) || (in[2]->getAs<types::Double>()->isScalar() == false))
{
Scierror(256, _("%s: Wrong type for input argument #%d: A Real expected.\n"), "lsq", 3);
return types::Function::Error;
}
*pdTol = in[2]->getAs<types::Double>()->get(0);
}
pDbl[0] = in[0]->getAs<types::Double>()->clone()->getAs<types::Double>();
if (pDbl[0]->getRows() != pDbl[1]->getRows())
{
Scierror(265, _("%s: %s and %s must have equal number of rows.\n"), "lsq", "A", "B");
return types::Function::Error;
}
if ((pDbl[0]->getCols() == 0) || (pDbl[1]->getCols() == 0))
{
out.push_back(types::Double::Empty());
if (_iRetCount == 2)
{
out.push_back(types::Double::Empty());
}
return types::Function::OK;
}
if (pDbl[0]->isComplex() || pDbl[1]->isComplex())
{
bComplexArgs = true;
}
for (int i = 0; i < 2; i++)
{
if (pDbl[i]->getCols() == -1)
{
Scierror(271, _("%s: Size varying argument a*eye(), (arg %d) not allowed here.\n"), "lsq", i + 1);
return types::Function::Error;
}
if (bComplexArgs)
{
pData[i] = (double*)oGetDoubleComplexFromPointer(pDbl[i]->getReal(), pDbl[i]->getImg(), pDbl[i]->getSize());
if (!pData[i])
{
Scierror(999, _("%s: Cannot allocate more memory.\n"), "lsq");
return types::Function::Error;
}
}
else
{
pData[i] = pDbl[i]->getReal();
}
}
pDblResult = new types::Double(pDbl[0]->getCols(), pDbl[1]->getCols(), bComplexArgs);
if (bComplexArgs)
{
pResult = (double*)MALLOC(pDbl[0]->getCols() * pDbl[1]->getCols() * sizeof(doublecomplex));
}
else
{
pResult = pDblResult->get();
}
int iRet = iLsqM(pData[0], pDbl[0]->getRows(), pDbl[0]->getCols(), pData[1], pDbl[1]->getCols(), bComplexArgs, pResult, pdTol, ((_iRetCount == 2) ? &iRank : NULL));
if (iRet != 0)
{
if (iRet == -1)
{
Scierror(999, _("%s: Allocation failed.\n"), "lsq");
}
else
{
Scierror(999, _("%s: LAPACK error n°%d.\n"), "lsq", iRet);
}
return types::Function::Error;
}
if (bComplexArgs)
{
vGetPointerFromDoubleComplex((doublecomplex*)(pResult), pDblResult->getSize(), pDblResult->getReal(), pDblResult->getImg());
vFreeDoubleComplexFromPointer((doublecomplex*)pResult);
vFreeDoubleComplexFromPointer((doublecomplex*)pData[0]);
vFreeDoubleComplexFromPointer((doublecomplex*)pData[1]);
}
out.push_back(pDblResult);
if (_iRetCount == 2)
{
types::Double* pDblRank = new types::Double(1, 1);
pDblRank->set(0, iRank);
out.push_back(pDblRank);
}
return types::Function::OK;
}
//
// intzgeev --
// Interface to LAPACK's ZGEEV
// Computes the eigenvalues and, if required, the eigenvectors of a complex asymmetric matrix.
// Possible uses :
// * With 1 LHS :
// eigenvalues=spec(A)
// where
// A : symmetric, square matrix of size NxN
// eigenvalues : matrix of size Nx1, type complex
// * With 2 LHS :
// [eigenvectors,eigenvalues]=spec(A)
// where
// A : square matrix of size NxN
// eigenvalues : matrix of size NxN with eigenvalues as diagonal terms, type complex
// eigenvectors : matrix of size NxN, type complex
//
int sci_zgeev(char *fname, unsigned long fname_len)
{
int totalsize;
int iRows = 0;
int iCols = 0;
int ONE = 1;
int iWorkSize;
int INFO;
char JOBVL;
char JOBVR;
double *pdblDataReal = NULL;
double *pdblDataImg = NULL;
double *pdblFinalEigenvaluesReal = NULL; //SCILAB return Var
double *pdblFinalEigenvaluesImg = NULL; //SCILAB return Var
double *pdblFinalEigenvectorsReal = NULL; //SCILAB return Var
double *pdblFinalEigenvectorsImg = NULL; //SCILAB return Var
doublecomplex *pdblData = NULL;
doublecomplex *pdblEigenValues = NULL; //return by LAPACK
doublecomplex *pdblWork = NULL; // Used by LAPACK
doublecomplex *pdblRWork = NULL; // Used by LAPACK
doublecomplex *pdblLeftvectors = NULL; // Used by LAPACK
doublecomplex *pdblRightvectors = NULL; // Used by LAPACK
CheckRhs(1, 1);
CheckLhs(1, 2);
GetRhsVarMatrixComplex(1, &iRows, &iCols, &pdblDataReal, &pdblDataImg);
totalsize = iRows * iCols;
pdblData = oGetDoubleComplexFromPointer(pdblDataReal, pdblDataImg, totalsize);
if (iRows != iCols)
{
Err = 1;
SciError(20);
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
if (iCols == 0)
{
if (Lhs == 1)
{
int lD;
CreateVar(2, MATRIX_OF_COMPLEX_DATATYPE, &iCols, &iCols, &lD);
LhsVar(1) = 2;
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
else if (Lhs == 2)
{
int lD;
int lV;
CreateVar(2, MATRIX_OF_COMPLEX_DATATYPE, &iCols, &iCols, &lD);
CreateVar(3, MATRIX_OF_DOUBLE_DATATYPE, &iCols, &iCols, &lV);
LhsVar(1) = 2;
LhsVar(2) = 3;
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
}
if (C2F(vfiniteComplex) (&totalsize, pdblData) == 0)
{
SciError(264);
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
if (Lhs == 1)
{
iAllocComplexMatrixOfDouble(2, iCols, ONE, &pdblFinalEigenvaluesReal, &pdblFinalEigenvaluesImg);
}
else
{
iAllocComplexMatrixOfDouble(2, iCols, iCols, &pdblFinalEigenvaluesReal, &pdblFinalEigenvaluesImg);
iAllocComplexMatrixOfDouble(3, iCols, iCols, &pdblFinalEigenvectorsReal, &pdblFinalEigenvectorsImg);
pdblRightvectors = (doublecomplex *) MALLOC(sizeof(doublecomplex) * totalsize);
}
pdblEigenValues = (doublecomplex *) MALLOC(sizeof(doublecomplex) * iCols);
iWorkSize = Max(1, 2 * iCols);
pdblWork = (doublecomplex *) MALLOC(sizeof(doublecomplex) * iWorkSize);
pdblRWork = (doublecomplex *) MALLOC(sizeof(doublecomplex) * 2 * iCols);
JOBVL = 'N';
if (Lhs == 1)
{
JOBVR = 'N'; // Compute eigenvalues only;
}
else
{
JOBVR = 'V'; // Compute eigenvalues and eigenvectors.
}
C2F(zgeev) (&JOBVL, &JOBVR, &iCols, pdblData, &iCols, pdblEigenValues,
pdblLeftvectors, &iCols, pdblRightvectors, &iCols, pdblWork, &iWorkSize, pdblRWork, &INFO);
// SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL,
// $ VR, LDVR, WORK, LWORK, RWORK, INFO )
FREE(pdblWork);
FREE(pdblRWork);
if (INFO != 0)
{
SciError(24);
}
if (Lhs == 2)
{
// Transfert eigenvalues
assembleComplexEigenvaluesFromDoubleComplexPointer(iRows, pdblEigenValues, pdblFinalEigenvaluesReal, pdblFinalEigenvaluesImg);
// Transfert eigenvectors from doublecomplex to real and imaginary parts
vGetPointerFromDoubleComplex(pdblRightvectors, totalsize, pdblFinalEigenvectorsReal, pdblFinalEigenvectorsImg);
}
else
{
// Transfert eigenvalues from doublecomplex to real and imaginary parts
vGetPointerFromDoubleComplex(pdblEigenValues, iCols, pdblFinalEigenvaluesReal, pdblFinalEigenvaluesImg);
}
if (Lhs == 1)
{
LhsVar(1) = 2;
}
else
{
LhsVar(1) = 3;
LhsVar(2) = 2;
}
FREE(pdblEigenValues);
if (Lhs == 2)
{
FREE(pdblRightvectors);
}
vFreeDoubleComplexFromPointer(pdblData);
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;
}
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;
}
//
// intzheev --
// Interface to LAPACK's ZHEEV
// Computes the eigenvalues and, if required, the eigenvectors of a complex symmetric matrix.
// Possible uses :
// * With 1 LHS :
// eigenvalues=spec(A)
// where
// A : symmetric, square matrix of size NxN
// eigenvalues : matrix of size Nx1, type real
// * With 2 LHS :
// [eigenvectors,eigenvalues]=spec(A)
// where
// A : square matrix of size NxN
// eigenvalues : matrix of size NxN with eigenvalues as diagonal terms, type real
// eigenvectors : matrix of size NxN, type complex
//
int sci_zheev(char *fname, unsigned long fname_len)
{
int totalsize;
int iRows = 0;
int iCols = 0;
int ONE = 1;
int iWorkSize;
int iRWorkSize;
int INFO;
char JOBZ;
char UPLO;
double *pdblDataReal = NULL;
double *pdblDataImg = NULL;
double *pdblFinalEigenvalues = NULL; //SCILAB return Var
double *pdblEigenValues = NULL; //return by LAPACK
double *pdblRWork = NULL; // Used by LAPACK
double *pdblFinalEigenvectorsReal; // returned by Scilab
double *pdblFinalEigenvectorsImg; // returned by Scilab
doublecomplex *pdblData = NULL;
doublecomplex *pdblWork = NULL; // Used by LAPACK
CheckRhs(1, 1);
CheckLhs(1, 2);
GetRhsVarMatrixComplex(1, &iRows, &iCols, &pdblDataReal, &pdblDataImg);
totalsize = iRows * iCols;
pdblData = oGetDoubleComplexFromPointer(pdblDataReal, pdblDataImg, totalsize);
if (iRows != iCols)
{
Err = 1;
SciError(20);
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
if (iCols == 0)
{
if (Lhs == 1)
{
LhsVar(1) = 1;
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
else if (Lhs == 2)
{
int lD;
CreateVar(2, MATRIX_OF_DOUBLE_DATATYPE, &iCols, &iCols, &lD);
LhsVar(1) = 1;
LhsVar(2) = 2;
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
}
if (C2F(vfiniteComplex) (&totalsize, pdblData) == 0)
{
SciError(264);
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}
if (Lhs == 1)
{
iAllocMatrixOfDouble(2, iCols, ONE, &pdblFinalEigenvalues);
}
else
{
iAllocMatrixOfDouble(2, iCols, iCols, &pdblFinalEigenvalues);
iAllocComplexMatrixOfDouble(3, iCols, iCols, &pdblFinalEigenvectorsReal, &pdblFinalEigenvectorsImg);
}
pdblEigenValues = (double *)MALLOC(sizeof(double) * iCols);
iWorkSize = Max(1, 2 * iCols - 1);
pdblWork = (doublecomplex *) MALLOC(sizeof(doublecomplex) * iWorkSize);
iRWorkSize = Max(1, 3 * iCols - 2);
pdblRWork = (double *)MALLOC(sizeof(double) * iRWorkSize);
if (Lhs == 1)
{
JOBZ = 'N'; // Compute eigenvalues only;
}
else
{
JOBZ = 'V'; // Compute eigenvalues and eigenvectors.
}
UPLO = 'U';
C2F(zheev) (&JOBZ, &UPLO, &iCols, pdblData, &iCols, pdblEigenValues, pdblWork, &iWorkSize, pdblRWork, &INFO);
// SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK,
// $ INFO )
FREE(pdblWork);
FREE(pdblRWork);
if (INFO != 0)
{
SciError(24);
}
if (Lhs == 1)
{
int INCX = 1;
int INCY = 1;
C2F(dcopy) (&iCols, pdblEigenValues, &INCX, pdblFinalEigenvalues, &INCY);
LhsVar(1) = 2;
}
else
{
assembleEigenvaluesFromDoublePointer(iRows, pdblEigenValues, pdblFinalEigenvalues);
vGetPointerFromDoubleComplex(pdblData, totalsize, pdblFinalEigenvectorsReal, pdblFinalEigenvectorsImg);
LhsVar(1) = 3; // Eigenvectors are stored in variable #3
LhsVar(2) = 2; // Eigenvalues are stored in variable #2
}
FREE(pdblEigenValues);
vFreeDoubleComplexFromPointer(pdblData);
return 0;
}