예제 #1
0
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;
}
예제 #2
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;
}
예제 #3
0
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;
}
예제 #4
0
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;
}
예제 #5
0
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;
}
예제 #6
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;
}
예제 #7
0
파일: sci_lsq.cpp 프로젝트: scitao/scilab
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;
}
예제 #8
0
//
// 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;
}
예제 #9
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;
}
예제 #10
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;
}
예제 #11
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;
}