//+------------------------------------------------------------------+ //| linalg.mqh | //| Copyright 2003-2022 Sergey Bochkanov (ALGLIB project) | //| Copyright 2012-2026, MetaQuotes Ltd. | //| www.mql5.com | //+------------------------------------------------------------------+ //| Implementation of ALGLIB library in MetaQuotes Language 5 | //| | //| The features of the library include: | //| - Linear algebra (direct algorithms, EVD, SVD) | //| - Solving systems of linear and non-linear equations | //| - Interpolation | //| - Optimization | //| - FFT (Fast Fourier Transform) | //| - Numerical integration | //| - Linear and nonlinear least-squares fitting | //| - Ordinary differential equations | //| - Computation of special functions | //| - Descriptive statistics and hypothesis testing | //| - Data analysis - classification, regression | //| - Implementing linear algebra algorithms, interpolation, etc. | //| in high-precision arithmetic (using MPFR) | //| | //| This file is free software; you can redistribute it and/or | //| modify it under the terms of the GNU General Public License as | //| published by the Free Software Foundation (www.fsf.org); either | //| version 2 of the License, or (at your option) any later version. | //| | //| This program is distributed in the hope that it will be useful, | //| but WITHOUT ANY WARRANTY;without even the implied warranty of | //| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | //| GNU General Public License for more details. | //+------------------------------------------------------------------+ #include "alglibinternal.mqh" #include "alglibmisc.mqh" //+------------------------------------------------------------------+ //| Work with matrix forms | //+------------------------------------------------------------------+ class CAblas { public: //--- size static int AblasBlockSize(void) { return(32);} static int AblasMicroBlockSize(void) { return(8); } static int AblasComplexBlockSize(void) { return(24);} static const int m_blas2minvendorkernelsize; //--- split lenght static void AblasSplitLength(const CMatrixDouble &a,const int n,int &n1,int &n2); static void AblasComplexSplitLength(const CMatrixComplex &a,const int n,int &n1,int &n2); //--- real numbers static void RMatrixSyrk(const int n,const int k,const double alpha,const CMatrixDouble &a,const int ia,const int ja,const int OpTypea,const double beta,CMatrixDouble &c,const int ic,const int jc,const bool IsUpper); static void RMatrixGemm(const int m,const int n,const int k,const double alpha,const CMatrixDouble &a,const int ia,const int ja,const int OpTypea,const CMatrixDouble &b,const int ib,const int jb,const int OpTypeb,const double beta,CMatrixDouble &c,const int ic,const int jc); static void RMatrixTranspose(const int m,const int n,const CMatrixDouble &a,const int ia,const int ja,CMatrixDouble &b,const int ib,const int jb); static void RMatrixEnforceSymmetricity(CMatrixDouble &a,int n,bool IsUpper=true); static void RMatrixCopy(const int m,const int n,const CMatrixDouble &a,const int ia,const int ja,CMatrixDouble &b,const int ib,const int jb); static void RVectorCopy(int n,CRowDouble &a,int ia,CRowDouble &b,int ib); static void RMatrixGenCopy(int m,int n,double alpha,CMatrixDouble &a,int ia,int ja,double beta,CMatrixDouble &b,int ib,int jb); static void RMatrixGer(int m,int n,CMatrixDouble &a,int ia,int ja,double alpha,CRowDouble &u,int iu,CRowDouble &v,int iv); static void RMatrixRank1(const int m,const int n,CMatrixDouble &a,const int ia,const int ja,const double &u[],const int iu,const double &v[],const int iv); static void RMatrixRank1(const int m,const int n,CMatrixDouble &a,const int ia,const int ja,const CRowDouble &u,const int iu,const CRowDouble &v,const int iv); static void RMatrixGemVect(int m,int n,double alpha,CMatrixDouble &a,int ia,int ja,int opa,CRowDouble &x,int ix,double beta,CRowDouble &y,int iy); static void RMatrixMVect(const int m,const int n,const CMatrixDouble &a,const int ia,const int ja,const int opa,const double &x[],const int ix,double &y[],const int iy); static void RMatrixMVect(const int m,const int n,const CMatrixDouble &a,const int ia,const int ja,const int opa,const CRowDouble &x,const int ix,CRowDouble &y,const int iy); static void RMatrixSymVect(int n,double alpha,CMatrixDouble &a,int ia,int ja,bool IsUpper,CRowDouble &x,int ix,double beta,CRowDouble &y,int iy); static double RMatrixSyvMVect(int n,CMatrixDouble &a,int ia,int ja,bool IsUpper,CRowDouble &x,int ix,CRowDouble &tmp); static void RMatrixTrsVect(int n,CMatrixDouble &a,int ia,int ja,bool IsUpper,bool IsUnit,int OpType,CRowDouble &x,int ix); static void RMatrixRightTrsM(const int m,const int n,CMatrixDouble &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixDouble &x,const int i2,const int j2); static void RMatrixLeftTrsM(const int m,const int n,CMatrixDouble &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixDouble &x,const int i2,const int j2); //--- complex numbers static void CMatrixHerk(int n,int k,complex alpha,CMatrixComplex &a,int ia,int ja,int OpTypea,complex beta,CMatrixComplex &c,int ic,int jc,bool IsUpper); static void CMatrixSyrk(const int n,const int k,const double alpha,CMatrixComplex &a,const int ia,const int ja,const int OpTypea,const double beta,CMatrixComplex &c,const int ic,const int jc,const bool IsUpper); static void CMatrixGemm(const int m,const int n,const int k,complex &alpha,CMatrixComplex &a,const int ia,const int ja,const int OpTypea,CMatrixComplex &b,const int ib,const int jb,const int OpTypeb,complex &beta,CMatrixComplex &c,const int ic,const int jc); static void CMatrixTranspose(const int m,const int n,const CMatrixComplex &a,const int ia,const int ja,CMatrixComplex &b,const int ib,const int jb); static void CMatrixCopy(const int m,const int n,const CMatrixComplex &a,const int ia,const int ja,CMatrixComplex &b,const int ib,const int jb); static void CMatrixRank1(const int m,const int n,CMatrixComplex &a,const int ia,const int ja,const complex &u[],const int iu,const complex &v[],const int iv); static void CMatrixRank1(const int m,const int n,CMatrixComplex &a,const int ia,const int ja,const CRowComplex &u,const int iu,const CRowComplex &v,const int iv); static void CMatrixMVect(const int m,const int n,const CMatrixComplex &a,const int ia,const int ja,const int opa,const complex &x[],const int ix,complex &y[],const int iy); static void CMatrixMVect(const int m,const int n,const CMatrixComplex &a,const int ia,const int ja,const int opa,const CRowComplex &x,const int ix,CRowComplex &y,const int iy); static void CMatrixRightTrsM(const int m,const int n,CMatrixComplex &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixComplex &x,const int i2,const int j2); static void CMatrixLeftTrsM(const int m,const int n,CMatrixComplex &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixComplex &x,const int i2,const int j2); //--- reflection static void GenerateReflection(CRowDouble &x,int n,double &tau); static void ApplyReflectionFromTheLeft(CMatrixDouble &c,double tau,CRowDouble &v,int m1,int m2,int n1,int n2,CRowDouble &work); static void ApplyReflectionFromTheRight(CMatrixDouble &c,double tau,CRowDouble &v,int m1,int m2,int n1,int n2,CRowDouble &work); //--- static void RowWiseGramSchmidt(CMatrixDouble &q,int m,int n,CRowDouble &x,CRowDouble &qx,bool needqx); private: //--- split lenght static void AblasInternalSplitLength(const int n,const int nb,int &n1,int &n2); //--- real numbers static void RMatrixSyrk2(const int n,const int k,const double alpha,const CMatrixDouble &a,const int ia,const int ja,const int OpTypea,const double beta,CMatrixDouble &c,const int ic,const int jc,const bool IsUpper); static void RMatrixGemmK(const int m,const int n,const int k,const double alpha,const CMatrixDouble &a,const int ia,const int ja,const int OpTypea,const CMatrixDouble &b,const int ib,const int jb,const int OpTypeb,const double beta,CMatrixDouble &c,const int ic,const int jc); static void RMatrixGemmRec(int m,int n,int k,double alpha,const CMatrixDouble &a,int ia,int ja,int OpTypea,const CMatrixDouble &b,int ib,int jb,int OpTypeb,double beta,CMatrixDouble &c,int ic,int jc); static void RMatrixRightTrsM2(const int m,const int n,CMatrixDouble &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixDouble &x,const int i2,const int j2); static void RMatrixLeftTrsM2(const int m,const int n,CMatrixDouble &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixDouble &x,const int i2,const int j2); //--- complex numbers static void CMatrixHerk2(int n,int k,complex alpha,CMatrixComplex &a,int ia,int ja,int OpTypea,complex beta,CMatrixComplex &c,int ic,int jc,bool IsUpper); static void CMatrixSyrk2(const int n,const int k,const complex alpha,const CMatrixComplex &a,const int ia,const int ja,const int OpTypea,const complex beta,CMatrixComplex &c,const int ic,const int jc,const bool IsUpper); static void CMatrixGemmk(const int m,const int n,const int k,complex &alpha,const CMatrixComplex &a,const int ia,const int ja,const int OpTypea,const CMatrixComplex &b,const int ib,const int jb,const int OpTypeb,complex &beta,CMatrixComplex &c,const int ic,const int jc); static void CMatrixGemmRec(int m,int n,int k,complex alpha,CMatrixComplex &a,int ia,int ja,int OpTypea,CMatrixComplex &b,int ib,int jb,int OpTypeb,complex beta,CMatrixComplex &c,int ic,int jc); static void CMatrixRightTrsM2(const int m,const int n,CMatrixComplex &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixComplex &x,const int i2,const int j2); static void CMatrixLeftTrsM2(const int m,const int n,CMatrixComplex &a,const int i1,const int j1,const bool IsUpper,const bool IsUnit,const int OpType,CMatrixComplex &x,const int i2,const int j2); }; //+------------------------------------------------------------------+ //| This subroutine calculates C=alpha*A*A^T+beta*C or | //| C=alpha*A^T*A+beta*C where: | //| * C is NxN symmetric matrix given by its upper/lower triangle | //| * A is NxK matrix when A*A^T is calculated, KxN matrix otherwise | //| Additional info: | //| * multiplication result replaces C. If Beta=0, C elements are not| //| used in calculations (not multiplied by zero - just not | //| referenced) | //| * if Alpha=0, A is not used (not multiplied by zero - just not | //| referenced) | //| * if both Beta and Alpha are zero, C is filled by zeros. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| K - matrix size, K>=0 | //| Alpha - coefficient | //| A - matrix | //| IA - submatrix offset (row index) | //| JA - submatrix offset (column index) | //| OpTypeA - multiplication type: | //| * 0 - A*A^T is calculated | //| * 2 - A^T*A is calculated | //| Beta - coefficient | //| C - preallocated input/output matrix | //| IC - submatrix offset (row index) | //| JC - submatrix offset (column index) | //| IsUpper - whether C is upper triangular or lower triangular | //+------------------------------------------------------------------+ void CAblas::RMatrixSyrk(const int n,const int k,const double alpha, const CMatrixDouble &a,const int ia,const int ja, const int OpTypea,const double beta,CMatrixDouble &c, const int ic,const int jc,const bool IsUpper) { //--- create variables int s1=0; int s2=0; int tsa=CApServ::MatrixTileSizeA(); int tsb=CApServ::MatrixTileSizeB(); int tscur=(MathMax(n,k)<=tsb?tsa:tsb); //--- check if(!CAp::Assert(tscur>=1,"RMatrixSYRK: integrity check failed")) return; //--- check if(MathMax(n,k)<=tsa) { RMatrixSyrk2(n,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); return; } //--- check if(k>=n) { //--- Split K CApServ::TiledSplit(k,tscur,s1,s2); //--- check if(OpTypea==0) { RMatrixSyrk(n,s1,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixSyrk(n,s2,alpha,a,ia,ja+s1,OpTypea,1.0,c,ic,jc,IsUpper); } else { RMatrixSyrk(n,s1,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixSyrk(n,s2,alpha,a,ia+s1,ja,OpTypea,1.0,c,ic,jc,IsUpper); } } else { //--- Split N CApServ::TiledSplit(n,tscur,s1,s2); //--- check switch(IsUpper) { case true: if(OpTypea==0) { RMatrixSyrk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixGemm(s1,s2,k,alpha,a,ia,ja,0,a,ia+s1,ja,1,beta,c,ic,jc+s1); RMatrixSyrk(s2,k,alpha,a,ia+s1,ja,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); } else { RMatrixSyrk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixGemm(s1,s2,k,alpha,a,ia,ja,1,a,ia,ja+s1,0,beta,c,ic,jc+s1); RMatrixSyrk(s2,k,alpha,a,ia,ja+s1,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); } break; case false: if(OpTypea==0) { RMatrixSyrk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixGemm(s2,s1,k,alpha,a,ia+s1,ja,0,a,ia,ja,1,beta,c,ic+s1,jc); RMatrixSyrk(s2,k,alpha,a,ia+s1,ja,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); } else { RMatrixSyrk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); RMatrixGemm(s2,s1,k,alpha,a,ia,ja+s1,1,a,ia,ja,0,beta,c,ic+s1,jc); RMatrixSyrk(s2,k,alpha,a,ia,ja+s1,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); } break; } } //--- exit the function return; } //+------------------------------------------------------------------+ //| Splits matrix length in two parts, left part should match ABLAS | //| block size | //| INPUT PARAMETERS: | //| A - real matrix, is passed to ensure that we didn't split| //| complex matrix using real splitting subroutine. | //| matrix itself is not changed. | //| N - length, N>0 | //| OUTPUT PARAMETERS: | //| N1 - length | //| N2 - length | //| N1+N2=N, N1>=N2, N2 may be zero | //+------------------------------------------------------------------+ void CAblas::AblasSplitLength(const CMatrixDouble &a,const int n, int &n1,int &n2) { //--- initialization n1=0; n2=0; //--- check if(n>AblasBlockSize()) AblasInternalSplitLength(n,AblasBlockSize(),n1,n2); else AblasInternalSplitLength(n,AblasMicroBlockSize(),n1,n2); //--- exit the function return; } //+------------------------------------------------------------------+ //| Complex ABLASSplitLength | //+------------------------------------------------------------------+ void CAblas::AblasComplexSplitLength(const CMatrixComplex &a,const int n, int &n1,int &n2) { //--- check if(n>AblasComplexBlockSize()) AblasInternalSplitLength(n,AblasComplexBlockSize(),n1,n2); else AblasInternalSplitLength(n,AblasMicroBlockSize(),n1,n2); } //+------------------------------------------------------------------+ //| This subroutine calculates C = alpha*op1(A)*op2(B) +beta*C where:| //| * C is MxN general matrix | //| * op1(A) is MxK matrix | //| * op2(B) is KxN matrix | //|*"op" may be identity transformation, transposition | //| Additional info: | //| * cache-oblivious algorithm is used. | //| * multiplication result replaces C. If Beta=0, C elements are not| //| used in calculations (not multiplied by zero - just not | //| referenced) | //| * if Alpha=0, A is not used (not multiplied by zero - just not | //| referenced) | //| * if both Beta and Alpha are zero, C is filled by zeros. | //| IMPORTANT: This function does NOT preallocate output matrix C, it| //| MUST be preallocated by caller prior to calling this | //| function. In case C does not have enough space to | //| store result, exception will be generated. | //| INPUT PARAMETERS: | //| M - matrix size, M>0 | //| N - matrix size, N>0 | //| K - matrix size, K>0 | //| Alpha - coefficient | //| A - matrix | //| IA - submatrix offset | //| JA - submatrix offset | //| OpTypeA - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| B - matrix | //| IB - submatrix offset | //| JB - submatrix offset | //| OpTypeB - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| Beta - coefficient | //| C - PREALLOCATED output matrix, large enough to store | //| result | //| IC - submatrix offset | //| JC - submatrix offset | //+------------------------------------------------------------------+ void CAblas::RMatrixGemm(const int m,const int n,const int k,const double alpha, const CMatrixDouble &a,const int ia,const int ja, const int OpTypea,const CMatrixDouble &b, const int ib,const int jb,const int OpTypeb, const double beta,CMatrixDouble &c,const int ic, const int jc) { //--- Check input sizes for correctness if(!CAp::Assert(OpTypea==0 || OpTypea==1,__FUNCTION__+": incorrect OpTypeA (must be 0 or 1)")) return; if(!CAp::Assert(OpTypeb==0 || OpTypeb==1,__FUNCTION__+": incorrect OpTypeB (must be 0 or 1)")) return; //--- check if(!CAp::Assert(ic+m<=c.Rows(),__FUNCTION__+": incorect size of output matrix C")) return; if(!CAp::Assert(jc+n<=c.Cols(),__FUNCTION__+": incorect size of output matrix C")) return; //--- Start actual work RMatrixGemmRec(m,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } //+------------------------------------------------------------------+ //| Level 2 subrotuine | //+------------------------------------------------------------------+ void CAblas::RMatrixSyrk2(const int n,const int k,const double alpha, const CMatrixDouble &a,const int ia,const int ja, const int OpTypea,const double beta,CMatrixDouble &c, const int ic,const int jc,const bool IsUpper) { //--- check if((alpha==0.0 || k==0.0) && beta==1.0) return; //--- create variables int i=0; int j=0; int j1=0; int j2=0; double v=0; int i_=0; int i1_=0; //--- SYRK if(OpTypea==0) { //--- C=alpha*A*A^H+beta*C for(i=0; i0) { v=0.0; for(i_=ja; i_0) for(i=0; i=1,__FUNCTION__+": integrity check failed")) return; if((m<=tsa && n<=tsa) && k<=tsa) { CAblasF::RMatrixGemmK(m,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); return; } //--- Recursive algorithm: split on M or N if(m>=n && m>=k) { //--- A*B = (A1 A2)^T*B CApServ::TiledSplit(m,tscur,s1,s2); if(OpTypea==0) { RMatrixGemmRec(s2,n,k,alpha,a,ia+s1,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic+s1,jc); RMatrixGemmRec(s1,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } else { RMatrixGemmRec(s2,n,k,alpha,a,ia,ja+s1,OpTypea,b,ib,jb,OpTypeb,beta,c,ic+s1,jc); RMatrixGemmRec(s1,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } return; } if(n>=m && n>=k) { //--- A*B = A*(B1 B2) CApServ::TiledSplit(n,tscur,s1,s2); if(OpTypeb==0) { RMatrixGemmRec(m,s2,k,alpha,a,ia,ja,OpTypea,b,ib,jb+s1,OpTypeb,beta,c,ic,jc+s1); RMatrixGemmRec(m,s1,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } else { RMatrixGemmRec(m,s2,k,alpha,a,ia,ja,OpTypea,b,ib+s1,jb,OpTypeb,beta,c,ic,jc+s1); RMatrixGemmRec(m,s1,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } return; } //--- Recursive algorithm: split on K //--- A*B = (A1 A2)*(B1 B2)^T CApServ::TiledSplit(k,tscur,s1,s2); switch(OpTypea) { case 0: if(OpTypeb==0) { RMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); RMatrixGemmRec(m,n,s2,alpha,a,ia,ja+s1,OpTypea,b,ib+s1,jb,OpTypeb,1.0,c,ic,jc); } else { RMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); RMatrixGemmRec(m,n,s2,alpha,a,ia,ja+s1,OpTypea,b,ib,jb+s1,OpTypeb,1.0,c,ic,jc); } break; default: if(OpTypeb==0) { RMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); RMatrixGemmRec(m,n,s2,alpha,a,ia+s1,ja,OpTypea,b,ib+s1,jb,OpTypeb,1.0,c,ic,jc); } else { RMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); RMatrixGemmRec(m,n,s2,alpha,a,ia+s1,ja,OpTypea,b,ib,jb+s1,OpTypeb,1.0,c,ic,jc); } break; } } //+------------------------------------------------------------------+ //| Cache-oblivous complex "copy-and-transpose" | //| Input parameters: | //| M - number of rows | //| N - number of columns | //| A - source matrix, MxN submatrix is copied and transposed| //| IA - submatrix offset (row index) | //| JA - submatrix offset (column index) | //| B - destination matrix | //| IB - submatrix offset (row index) | //| JB - submatrix offset (column index) | //+------------------------------------------------------------------+ void CAblas::CMatrixTranspose(const int m,const int n,const CMatrixComplex &a, const int ia,const int ja,CMatrixComplex &b, const int ib,const int jb) { //--- create variables int i=0; int s1=0; int s2=0; int i_=0; int i1_=0; //--- check if(m<=2*AblasComplexBlockSize() && n<=2*AblasComplexBlockSize()) { //--- base case for(i=0; in) { //--- split AblasComplexSplitLength(a,m,s1,s2); //--- function call CMatrixTranspose(s1,n,a,ia,ja,b,ib,jb); CMatrixTranspose(s2,n,a,ia+s1,ja,b,ib,jb+s1); } else { //--- split AblasComplexSplitLength(a,n,s1,s2); //--- function call CMatrixTranspose(m,s1,a,ia,ja,b,ib,jb); CMatrixTranspose(m,s2,a,ia,ja+s1,b,ib+s1,jb); } } } //+------------------------------------------------------------------+ //| Cache-oblivous real "copy-and-transpose" | //| Input parameters: | //| M - number of rows | //| N - number of columns | //| A - source matrix, MxN submatrix is copied and transposed| //| IA - submatrix offset (row index) | //| JA - submatrix offset (column index) | //| A - destination matrix | //| IB - submatrix offset (row index) | //| JB - submatrix offset (column index) | //+------------------------------------------------------------------+ void CAblas::RMatrixTranspose(const int m,const int n,const CMatrixDouble &a, const int ia,const int ja,CMatrixDouble &b, const int ib,const int jb) { //--- create variables int i=0; int s1=0; int s2=0; int i_=0; int i1_=0; //--- check if(m<=2*AblasBlockSize() && n<=2*AblasBlockSize()) { //--- base case for(i=0; in) { //--- split AblasSplitLength(a,m,s1,s2); //--- function call RMatrixTranspose(s1,n,a,ia,ja,b,ib,jb); RMatrixTranspose(s2,n,a,ia+s1,ja,b,ib,jb+s1); } else { //--- split AblasSplitLength(a,n,s1,s2); //--- function call RMatrixTranspose(m,s1,a,ia,ja,b,ib,jb); RMatrixTranspose(m,s2,a,ia,ja+s1,b,ib+s1,jb); } } } //+------------------------------------------------------------------+ //| This code enforces symmetricy of the matrix by copying Upper part| //| to lower one (or vice versa). | //| INPUT PARAMETERS: | //| A - matrix | //| N - number of rows/columns | //| IsUpper - whether we want to copy upper triangle to lower | //| one (True) or vice versa (False). | //+------------------------------------------------------------------+ void CAblas::RMatrixEnforceSymmetricity(CMatrixDouble &a, int n, bool IsUpper=true) { //--- create variables int i=0; int j=0; //--- check if(!CAp::Assert(a.Rows()>=n,__FUNCTION__+": N more then rows in matrix A")) return; //--- check if(!CAp::Assert(a.Cols()>=n,__FUNCTION__+": N more then columns in matrix A")) return; if(IsUpper) { for(i=0; i0, N>0, Alpha<>0. if(m<=0) return; if(n<=0 || alpha==0.0) { if((double)(beta)!=0.0) CAblasF::RMulVX(m,beta,y,iy); else CAblasF::RSetVX(m,0.0,y,iy); return; } if(ia+ja+ix+iy==0) CAblasF::RGemV(m,n,alpha,a,opa,x,beta,y); else CAblasF::RGemVX(m,n,alpha,a,ia,ja,opa,x,ix,beta,y,iy); } //+------------------------------------------------------------------+ //| Matrix-vector product: y := op(A)*x | //| INPUT PARAMETERS: | //| M - number of rows of op(A) | //| M>=0 | //| N - number of columns of op(A) | //| N>=0 | //| A - target matrix | //| IA - submatrix offset (row index) | //| JA - submatrix offset (column index) | //| OpA - operation type: | //| * OpA=0 => op(A) = A | //| * OpA=1 => op(A) = A^T | //| * OpA=2 => op(A) = A^H | //| X - input vector | //| IX - subvector offset | //| IY - subvector offset | //| OUTPUT PARAMETERS: | //| Y - vector which stores result | //| if M=0, then subroutine does nothing. | //| if N=0, Y is filled by zeros. | //+------------------------------------------------------------------+ void CAblas::CMatrixMVect(const int m,const int n,const CMatrixComplex &a, const int ia,const int ja,const int opa, const complex &x[],const int ix,complex &y[], const int iy) { CRowComplex X=x; CRowComplex Y=y; CMatrixMVect(m,n,a,ia,ja,opa,X,ix,Y,iy); Y.ToArray(y); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAblas::CMatrixMVect(const int m,const int n,const CMatrixComplex &a, const int ia,const int ja,const int opa, const CRowComplex &x,const int ix,CRowComplex &y, const int iy) { //--- check if(m==0) return; //--- create variables int i=0; complex v=0; int i_=0; int i1_=0; //--- check if(n==0) { for(i=0; i op(A) = A | //| * OpA=1 => op(A) = A^T | //| X - input vector | //| IX - subvector offset | //| IY - subvector offset | //| OUTPUT PARAMETERS: | //| Y - vector which stores result | //| if M=0, then subroutine does nothing. | //| if N=0, Y is filled by zeros. | //+------------------------------------------------------------------+ void CAblas::RMatrixMVect(const int m,const int n,const CMatrixDouble &a, const int ia,const int ja,const int opa, const double &x[],const int ix,double &y[], const int iy) { CRowDouble X=x; CRowDouble Y=y; RMatrixMVect(m,n,a,ia,ja,opa,X,ix,Y,iy); Y.ToArray(y); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAblas::RMatrixMVect(const int m,const int n,const CMatrixDouble &a, const int ia,const int ja,const int opa, const CRowDouble &x,const int ix,CRowDouble &y, const int iy) { //--- check if(m==0) return; //--- create variables int i=0; double v=0; int i_=0; int i1_=0; //--- check if(n==0) { for(i=0; i0, Alpha<>0. if(beta!=0.0) CAblasF::RMulV(n,beta,y); else CAblasF::RSetV(n,0,y); if(alpha==0.0) return; //--- Generic code if(IsUpper) { //--- Upper triangle of A is stored for(i=0; i=0 | //| A - matrix, actial matrix is stored in | //| A[IA:IA+N-1,JA:JA+N-1] | //| IA - submatrix offset | //| JA - submatrix offset | //| IsUpper - whether matrix is upper triangular | //| IsUnit - whether matrix is unitriangular | //| OpType - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| X - right part, actual vector is stored in X[IX:IX+N-1] | //| IX - offset | //| OUTPUT PARAMETERS: | //| X - solution replaces elements X[IX:IX+N-1] | //| (c) 2016 Reference BLAS level1 routine (LAPACK version 3.7.0) | //| Reference BLAS is a software package provided by Univ. of | //| Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver| //| and NAG Ltd. | //+------------------------------------------------------------------+ void CAblas::RMatrixTrsVect(int n,CMatrixDouble &a,int ia, int ja,bool IsUpper,bool IsUnit, int OpType,CRowDouble &x,int ix) { //--- Quick exit if(n<=0) return; //--- create variables int i=0; int j=0; double v=0; //--- Generic code switch(OpType) { case 0: if(IsUpper) { for(i=n-1; i>=0; i--) { v=x[ix+i]; for(j=i+1; j=0; i--) { v=x[ix+i]; if(!IsUnit) { v*=MathPow(a.Get(ia+i,ja+i),-1.0); x.Set(ix+i,v); } if(v==0) continue; for(j=0; j=0 | //| M - matrix size, N>=0 | //| A - matrix, actial matrix is stored in | //| A[I1:I1+N-1,J1:J1+N-1] | //| I1 - submatrix offset | //| J1 - submatrix offset | //| IsUpper - whether matrix is upper triangular | //| IsUnit - whether matrix is unitriangular | //| OpType - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| * 2 - conjugate transposition | //| X - matrix, actial matrix is stored in | //| X[I2:I2+M-1,J2:J2+N-1] | //| I2 - submatrix offset | //| J2 - submatrix offset | //+------------------------------------------------------------------+ void CAblas::CMatrixRightTrsM(const int m,const int n,CMatrixComplex &a, const int i1,const int j1,const bool IsUpper, const bool IsUnit,const int OpType, CMatrixComplex &x,const int i2,const int j2) { //--- create variables int s1=0; int s2=0; int tsa=CApServ::MatrixTileSizeA()/2; int tsb=CApServ::MatrixTileSizeB(); int tscur=(MathMax(m,n)<=tsb?tsa:tsb); complex One=1; complex mOne=-1; //--- check if(!CAp::Assert(tscur>=1,__FUNCTION__+": integrity check failed")) return; //--- Upper level parallelization: //--- * decide whether it is feasible to activate multithreading //--- * perform optionally parallelized splits on M if(m>=2*tsb) { //--- Split X: X*A = (X1 X2)^T*A CApServ::TiledSplit(m,tsb,s1,s2); CMatrixRightTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixRightTrsM(s2,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2+s1,j2); return; } //--- ALGLIB basecase code if(MathMax(m,n)<=tsa) { CMatrixRightTrsM2(m,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); return; } //--- Recursive subdivision if(m>=n) { //--- Split X: X*A = (X1 X2)^T*A CApServ::TiledSplit(m,tscur,s1,s2); CMatrixRightTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixRightTrsM(s2,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2+s1,j2); } else { //--- Split A: //--- (A1 A12) //--- X*op(A) = X*op( ) //--- ( A2) //--- //--- Different variants depending on //--- IsUpper/OpType combinations // CApServ::TiledSplit(n,tscur,s1,s2); switch(IsUpper) { case true: if(OpType==0) { //--- (A1 A12)-1 //--- X*A^-1 = (X1 X2)*( ) //--- ( A2) CMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixGemm(m,s2,s1,mOne,x,i2,j2,0,a,i1,j1+s1,0,One,x,i2,j2+s1); CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } else { //--- (A1' )-1 //--- X*A^-1 = (X1 X2)*( ) //--- (A12' A2') CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); CMatrixGemm(m,s1,s2,mOne,x,i2,j2+s1,0,a,i1,j1+s1,OpType,One,x,i2,j2); CMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } break; case false: if(OpType==0) { //--- (A1 )-1 //--- X*A^-1 = (X1 X2)*( ) //--- (A21 A2) CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); CMatrixGemm(m,s1,s2,mOne,x,i2,j2+s1,0,a,i1+s1,j1,0,One,x,i2,j2); CMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } else { //--- (A1' A21')-1 //--- X*A^-1 = (X1 X2)*( ) //--- ( A2') CMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixGemm(m,s2,s1,mOne,x,i2,j2,0,a,i1+s1,j1,OpType,One,x,i2,j2+s1); CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } break; } } } //+------------------------------------------------------------------+ //| This subroutine calculates op(A^-1)*X where: | //| * X is MxN general matrix | //| * A is MxM upper/lower triangular/unitriangular matrix | //|*"op" may be identity transformation, transposition, conjugate | //| transposition | //| Multiplication result replaces X. | //| Cache-oblivious algorithm is used. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| M - matrix size, N>=0 | //| A - matrix, actial matrix is stored in | //| A[I1:I1+M-1,J1:J1+M-1] | //| I1 - submatrix offset | //| J1 - submatrix offset | //| IsUpper - whether matrix is upper triangular | //| IsUnit - whether matrix is unitriangular | //| OpType - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| * 2 - conjugate transposition | //| C - matrix, actial matrix is stored in | //| C[I2:I2+M-1,J2:J2+N-1] | //| I2 - submatrix offset | //| J2 - submatrix offset | //+------------------------------------------------------------------+ void CAblas::CMatrixLeftTrsM(const int m,const int n,CMatrixComplex &a, const int i1,const int j1,const bool IsUpper, const bool IsUnit,const int OpType, CMatrixComplex &x,const int i2,const int j2) { //--- create variables int s1=0; int s2=0; int tsa=CApServ::MatrixTileSizeA()/2; int tsb=CApServ::MatrixTileSizeB(); int tscur=(MathMax(m,n)<=tsb?tsa:tsb); complex One=1; complex mOne=-1; //--- check if(!CAp::Assert(tscur>=1,__FUNCTION__+": integrity check failed")) return; //--- Upper level parallelization: //--- * decide whether it is feasible to activate multithreading //--- * perform optionally parallelized splits on N if(n>=2*tsb) { CApServ::TiledSplit(n,tscur,s1,s2); CMatrixLeftTrsM(m,s2,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2+s1); CMatrixLeftTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); return; } //--- ALGLIB basecase code if(MathMax(m,n)<=tsa) { CMatrixLeftTrsM2(m,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); return; } //--- Recursive subdivision if(n>=m) { //--- Split X: op(A)^-1*X = op(A)^-1*(X1 X2) CApServ::TiledSplit(n,tscur,s1,s2); CMatrixLeftTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixLeftTrsM(m,s2,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } else { //--- Split A CApServ::TiledSplit(m,tscur,s1,s2); switch(IsUpper) { case true: if(OpType==0) { //--- (A1 A12)-1 ( X1 ) //--- A^-1*X* = ( ) *( ) //--- ( A2) ( X2 ) CMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); CMatrixGemm(s1,n,s2,mOne,a,i1,j1+s1,0,x,i2+s1,j2,0,One,x,i2,j2); CMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } else { //--- (A1' )-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- (A12' A2') ( X2 ) CMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixGemm(s2,n,s1,mOne,a,i1,j1+s1,OpType,x,i2,j2,0,One,x,i2+s1,j2); CMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); } break; case false: if(OpType==0) { //--- (A1 )-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- (A21 A2) ( X2 ) CMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); CMatrixGemm(s2,n,s1,mOne,a,i1+s1,j1,0,x,i2,j2,0,One,x,i2+s1,j2); CMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); } else { //--- (A1' A21')-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- ( A2') ( X2 ) CMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); CMatrixGemm(s1,n,s2,mOne,a,i1+s1,j1,OpType,x,i2+s1,j2,0,One,x,i2,j2); CMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } break; } } } //+------------------------------------------------------------------+ //| This subroutine calculates X*op(A^-1) where: | //| * X is MxN general matrix | //| * A is NxN upper/lower triangular/unitriangular matrix | //|*"op" may be identity transformation, transposition | //| Multiplication result replaces X. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| M - matrix size, N>=0 | //| A - matrix, actial matrix is stored in | //| A[I1:I1+N-1,J1:J1+N-1] | //| I1 - submatrix offset | //| J1 - submatrix offset | //| IsUpper - whether matrix is upper triangular | //| IsUnit - whether matrix is unitriangular | //| OpType - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| X - matrix, actial matrix is stored in | //| X[I2:I2+M-1,J2:J2+N-1] | //| I2 - submatrix offset | //| J2 - submatrix offset | //+------------------------------------------------------------------+ void CAblas::RMatrixRightTrsM(const int m,const int n,CMatrixDouble &a, const int i1,const int j1,const bool IsUpper, const bool IsUnit,const int OpType, CMatrixDouble &x,const int i2,const int j2) { //--- create variables int s1=0; int s2=0; int tsa=CApServ::MatrixTileSizeA(); int tsb=CApServ::MatrixTileSizeB(); int tscur=(MathMax(m,n)<=tsb?tsa:tsb); //--- check if(!CAp::Assert(tscur>=1,__FUNCTION__+": integrity check failed")) return; //--- Upper level parallelization: //--- * decide whether it is feasible to activate multithreading //--- * perform optionally parallelized splits on M if(m>=2*tsb) { //--- Split X: X*A = (X1 X2)^T*A CApServ::TiledSplit(m,tsb,s1,s2); RMatrixRightTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixRightTrsM(s2,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2+s1,j2); return; } //--- Basecase ALGLIB code if(MathMax(m,n)<=tsa) { RMatrixRightTrsM2(m,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); return; } //--- Recursive subdivision if(m>=n) { //--- Split X: X*A = (X1 X2)^T*A CApServ::TiledSplit(m,tscur,s1,s2); RMatrixRightTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixRightTrsM(s2,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2+s1,j2); } else { //--- Split A: //--- (A1 A12) //--- X*op(A) = X*op( ) //--- ( A2) //--- Different variants depending on //--- IsUpper/OpType combinations CApServ::TiledSplit(n,tscur,s1,s2); switch(IsUpper) { case true: if(OpType==0) { //--- (A1 A12)-1 //--- X*A^-1 = (X1 X2)*( ) //--- ( A2) RMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixGemm(m,s2,s1,-1.0,x,i2,j2,0,a,i1,j1+s1,0,1.0,x,i2,j2+s1); RMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } else { //--- (A1' )-1 //--- X*A^-1 = (X1 X2)*( ) //--- (A12' A2') RMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); RMatrixGemm(m,s1,s2,-1.0,x,i2,j2+s1,0,a,i1,j1+s1,OpType,1.0,x,i2,j2); RMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } break; case false: if(OpType==0) { //--- (A1 )-1 //--- X*A^-1 = (X1 X2)*( ) //--- (A21 A2) RMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); RMatrixGemm(m,s1,s2,-1.0,x,i2,j2+s1,0,a,i1+s1,j1,0,1.0,x,i2,j2); RMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } else { //--- (A1' A21')-1 //--- X*A^-1 = (X1 X2)*( ) //--- ( A2') RMatrixRightTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixGemm(m,s2,s1,-1.0,x,i2,j2,0,a,i1+s1,j1,OpType,1.0,x,i2,j2+s1); RMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } break; } } } //+------------------------------------------------------------------+ //| This subroutine calculates op(A^-1)*X where: | //| * X is MxN general matrix | //| * A is MxM upper/lower triangular/unitriangular matrix | //|*"op" may be identity transformation, transposition | //| Multiplication result replaces X. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| M - matrix size, N>=0 | //| A - matrix, actial matrix is stored in | //| A[I1:I1+M-1,J1:J1+M-1] | //| I1 - submatrix offset | //| J1 - submatrix offset | //| IsUpper - whether matrix is upper triangular | //| IsUnit - whether matrix is unitriangular | //| OpType - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| X - matrix, actial matrix is stored in | //| X[I2:I2+M-1,J2:J2+N-1] | //| I2 - submatrix offset | //| J2 - submatrix offset | //+------------------------------------------------------------------+ void CAblas::RMatrixLeftTrsM(const int m,const int n,CMatrixDouble &a, const int i1,const int j1,const bool IsUpper, const bool IsUnit,const int OpType, CMatrixDouble &x,const int i2,const int j2) { //--- create variables int s1=0; int s2=0; int bs=AblasBlockSize(); //--- check if(m<=bs && n<=bs) { //--- basic algorithm RMatrixLeftTrsM2(m,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); //--- exit the function return; } //--- check if(n>=m) { //--- Split X: op(A)^-1*X = op(A)^-1*(X1 X2) AblasSplitLength(x,n,s1,s2); RMatrixLeftTrsM(m,s1,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixLeftTrsM(m,s2,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2+s1); } else { //--- Split A AblasSplitLength(a,m,s1,s2); //--- check if(IsUpper && OpType==0) { //--- (A1 A12)-1 ( X1 ) //--- A^-1*X* = ( ) *( ) //--- ( A2) ( X2 ) RMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); RMatrixGemm(s1,n,s2,-1.0,a,i1,j1+s1,0,x,i2+s1,j2,0,1.0,x,i2,j2); RMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); //--- exit the function return; } //--- check if(IsUpper && OpType!=0) { //--- (A1' )-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- (A12' A2') ( X2 ) RMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixGemm(s2,n,s1,-1.0,a,i1,j1+s1,OpType,x,i2,j2,0,1.0,x,i2+s1,j2); RMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); //--- exit the function return; } //--- check if(!IsUpper && OpType==0) { //--- (A1 )-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- (A21 A2) ( X2 ) RMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); RMatrixGemm(s2,n,s1,-1.0,a,i1+s1,j1,0,x,i2,j2,0,1.0,x,i2+s1,j2); RMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); //--- exit the function return; } //--- check if(!IsUpper && OpType!=0) { //--- (A1' A21')-1 ( X1 ) //--- A^-1*X = ( ) *( ) //--- ( A2') ( X2 ) RMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,IsUpper,IsUnit,OpType,x,i2+s1,j2); RMatrixGemm(s1,n,s2,-1.0,a,i1+s1,j1,OpType,x,i2+s1,j2,0,1.0,x,i2,j2); RMatrixLeftTrsM(s1,n,a,i1,j1,IsUpper,IsUnit,OpType,x,i2,j2); } } } //+------------------------------------------------------------------+ //| This subroutine calculates C=alpha*A*A^H+beta*C or | //| C=alpha*A^H*A+beta*C where: | //| * C is NxN Hermitian matrix given by its upper/lower triangle | //| * A is NxK matrix when A*A^H is calculated, KxN matrix otherwise | //| Additional info: | //| * multiplication result replaces C. If Beta=0, C elements are not| //| used in calculations (not multiplied by zero - just not | //| referenced) | //| * if Alpha=0, A is not used (not multiplied by zero - just not | //| referenced) | //| * if both Beta and Alpha are zero, C is filled by zeros. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| K - matrix size, K>=0 | //| Alpha - coefficient | //| A - matrix | //| IA - submatrix offset (row index) | //| JA - submatrix offset (column index) | //| OpTypeA - multiplication type: | //| * 0 - A*A^H is calculated | //| * 2 - A^H*A is calculated | //| Beta - coefficient | //| C - preallocated input/output matrix | //| IC - submatrix offset (row index) | //| JC - submatrix offset (column index) | //| IsUpper - whether upper or lower triangle of C is updated; | //| this function updates only one half of C, leaving | //| other half unchanged (not referenced at all). | //+------------------------------------------------------------------+ void CAblas::CMatrixHerk(int n,int k,complex alpha, CMatrixComplex &a,int ia,int ja, int OpTypea,complex beta, CMatrixComplex &c,int ic,int jc, bool IsUpper) { //--- create variables int s1=0; int s2=0; int tsa=CApServ::MatrixTileSizeA()/2; int tsb=CApServ::MatrixTileSizeB(); int tscur=(MathMax(n,k)<=tsb?tsa:tsb); //--- check if(!CAp::Assert(tscur>=1,__FUNCTION__+": integrity check failed")) return; //--- ALGLIB basecase code if(MathMax(n,k)<=tsa) { CMatrixHerk2(n,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); return; } //--- Recursive division of the problem if(k>=n) { //--- Split K CApServ::TiledSplit(k,tscur,s1,s2); if(OpTypea==0) { CMatrixHerk(n,s1,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(n,s2,alpha,a,ia,ja+s1,OpTypea,1.0,c,ic,jc,IsUpper); } else { CMatrixHerk(n,s1,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(n,s2,alpha,a,ia+s1,ja,OpTypea,1.0,c,ic,jc,IsUpper); } } else { //--- Split N CApServ::TiledSplit(n,tscur,s1,s2); switch(IsUpper) { case true: if(OpTypea==0) { CMatrixHerk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(s2,k,alpha,a,ia+s1,ja,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); CMatrixGemm(s1,s2,k,alpha,a,ia,ja,0,a,ia+s1,ja,2,beta,c,ic,jc+s1); } else { CMatrixHerk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(s2,k,alpha,a,ia,ja+s1,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); CMatrixGemm(s1,s2,k,alpha,a,ia,ja,2,a,ia,ja+s1,0,beta,c,ic,jc+s1); } break; case false: if(OpTypea==0) { CMatrixHerk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(s2,k,alpha,a,ia+s1,ja,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); CMatrixGemm(s2,s1,k,alpha,a,ia+s1,ja,0,a,ia,ja,2,beta,c,ic+s1,jc); } else { CMatrixHerk(s1,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); CMatrixHerk(s2,k,alpha,a,ia,ja+s1,OpTypea,beta,c,ic+s1,jc+s1,IsUpper); CMatrixGemm(s2,s1,k,alpha,a,ia,ja+s1,2,a,ia,ja,0,beta,c,ic+s1,jc); } break; } } } //+------------------------------------------------------------------+ //| This subroutine is an older version of CMatrixHERK(), one with | //| wrong name (it is HErmitian update, not SYmmetric). It is left | //| here for backward compatibility. | //| | //| This subroutine calculates C=alpha*A*A^H+beta*C or | //| C=alpha*A^H*A+beta*C where: | //| * C is NxN Hermitian matrix given by its upper/lower triangle | //| * A is NxK matrix when A*A^H is calculated, KxN matrix otherwise | //| Additional info: | //| * cache-oblivious algorithm is used. | //| * multiplication result replaces C. If Beta=0, C elements are not| //| used in calculations (not multiplied by zero - just not | //| referenced) | //| * if Alpha=0, A is not used (not multiplied by zero - just not | //| referenced) | //| * if both Beta and Alpha are zero, C is filled by zeros. | //| INPUT PARAMETERS: | //| N - matrix size, N>=0 | //| K - matrix size, K>=0 | //| Alpha - coefficient | //| A - matrix | //| IA - submatrix offset | //| JA - submatrix offset | //| OpTypeA - multiplication type: | //| * 0 - A*A^H is calculated | //| * 2 - A^H*A is calculated | //| Beta - coefficient | //| C - matrix | //| IC - submatrix offset | //| JC - submatrix offset | //| IsUpper - whether C is upper triangular or lower triangular| //+------------------------------------------------------------------+ void CAblas::CMatrixSyrk(const int n,const int k,const double alpha, CMatrixComplex &a,const int ia,const int ja, const int OpTypea,const double beta,CMatrixComplex &c, const int ic,const int jc,const bool IsUpper) { CMatrixHerk(n,k,alpha,a,ia,ja,OpTypea,beta,c,ic,jc,IsUpper); //--- exit the function return; } //+------------------------------------------------------------------+ //| Performs one step of stable Gram-Schmidt process on vector X[] | //| using set of orthonormal rows Q[]. | //| INPUT PARAMETERS: | //| Q - array[M,N], matrix with orthonormal rows | //| M, N - rows/cols | //| X - array[N], vector to process | //| NeedQX - whether we need QX or not | //| OUTPUT PARAMETERS: | //| X - stores X - Q'*(Q*X) | //| QX - if NeedQX is True, array[M] filled with elements of| //| Q*X, reallocated if length is less than M. | //| Ignored otherwise. | //| NOTE: this function silently exits when M=0, doing nothing | //+------------------------------------------------------------------+ void CAblas::RowWiseGramSchmidt(CMatrixDouble &q,int m,int n, CRowDouble &x,CRowDouble &qx, bool needqx) { //--- check if(m==0) return; //--- check if(needqx) CApServ::RVectorSetLengthAtLeast(qx,m); for(int i=0; i0 | //| M - matrix size, N>0 | //| K - matrix size, K>0 | //| Alpha - coefficient | //| A - matrix | //| IA - submatrix offset | //| JA - submatrix offset | //| OpTypeA - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| * 2 - conjugate transposition | //| B - matrix | //| IB - submatrix offset | //| JB - submatrix offset | //| OpTypeB - transformation type: | //| * 0 - no transformation | //| * 1 - transposition | //| * 2 - conjugate transposition | //| Beta - coefficient | //| C - matrix | //| IC - submatrix offset | //| JC - submatrix offset | //+------------------------------------------------------------------+ void CAblas::CMatrixGemm(const int m,const int n,const int k,complex &alpha, CMatrixComplex &a,const int ia,const int ja, const int OpTypea,CMatrixComplex &b,const int ib, const int jb,const int OpTypeb,complex &beta, CMatrixComplex &c,const int ic,const int jc) { //--- create variables complex Beta(1,0); int s1=0; int s2=0; int bs=AblasComplexBlockSize(); //--- Check input sizes for correctness if(!CAp::Assert((OpTypea==0 || OpTypea==1) || OpTypea==2,__FUNCTION__+": incorrect OpTypeA (must be 0 or 1 or 2)")) return; if(!CAp::Assert((OpTypeb==0 || OpTypeb==1) || OpTypeb==2,__FUNCTION__+": incorrect OpTypeB (must be 0 or 1 or 2)")) return; if(!CAp::Assert(ic+m<=c.Rows(),__FUNCTION__+": incorect size of output matrix C")) return; if(!CAp::Assert(jc+n<=c.Cols(),__FUNCTION__+": incorect size of output matrix C")) return; //--- Start actual work CMatrixGemmRec(m,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); } //+------------------------------------------------------------------+ //| Level 2 variant of CMatrixRightTRSM | //+------------------------------------------------------------------+ void CAblas::CMatrixRightTrsM2(const int m,const int n,CMatrixComplex &a, const int i1,const int j1,const bool IsUpper, const bool IsUnit,const int OpType, CMatrixComplex &x,const int i2,const int j2) { //--- check if(n*m==0) return; //--- create variables int i=0; int j=0; complex vc=0; complex vd=0; int i_=0; int i1_=0; //--- General case if(IsUpper) { //--- Upper triangular matrix switch(OpType) { case 0: //--- X*A^(-1) for(i=0; i=0; j--) { vc=0; vd=1; //--- check if(j=0; j--) { vc=0; vd=1; //--- check if(j=0; j--) { //--- check if(IsUnit) vd=1; else vd=a.Get(i1+j,j1+j); //--- change x x.Set(i2+i,j2+j,x.Get(i2+i,j2+j)/vd); //--- check if(j>0) { vc=x.Get(i2+i,j2+j); i1_=j1-j2; for(i_=j2; i_0) { i1_=j1-j2; vc=0.0; for(i_=j2; i_0) { i1_=j1-j2; vc=0.0; for(i_=j2; i_=0; i--) { for(j=i+1; j<=m-1; j++) { vc=a.Get(i1+i,j1+j); //--- change x for(i_=j2; i_=0; i--) { //--- check if(IsUnit) vd=1; else vd=1/a.Get(i1+i,j1+i); //--- change x for(i_=j2; i_=0; j--) { vc=a.Get(i1+i,j1+j); for(i_=j2; i_=0; i--) { //--- check if(IsUnit) vd=1; else vd=1/CMath::Conj(a.Get(i1+i,j1+i)); //--- change x for(i_=j2; i_=0; j--) { vc=CMath::Conj(a.Get(i1+i,j1+j)); for(i_=j2; i_=0; j--) { vr=0; vd=1; //--- check if(j=0; j--) { //--- check if(IsUnit) vd=1; else vd=a.Get(i1+j,j1+j); //--- change x x.Set(i2+i,j2+j,x.Get(i2+i,j2+j)/vd); //--- check if(j>0) { vr=x.Get(i2+i,j2+j); i1_=j1-j2; //--- change x for(i_=j2; i_0) { i1_=j1-j2; vr=0.0; for(i_=j2; i_=0; i--) { for(j=i+1; j=0; i--) { //--- check if(IsUnit) vd=1; else vd=1/a.Get(i1+i,j1+i); //--- change x for(i_=j2; i_=0; j--) { vr=a.Get(i1+i,j1+j); for(i_=j2; i_0) { v=0.0; for(i_=ja; i_0) { for(i=0; i0) { v=0.0; for(i_=ja; i_<=ja+k-1; i_++) v+=a.Get(ia+i,i_)*CMath::Conj(a.Get(ia+j,i_)); } else v=0; //--- check if(beta==0) c.Set(ic+i,jc+j,alpha*v); else c.Set(ic+i,jc+j,beta*c.Get(ic+i,jc+j)+alpha*v); } } //--- exit the function return; } else { //--- C = alpha*A^H*A+beta*C for(i=0; i=1,__FUNCTION__+": integrity check failed")) return; if(MathMax(m,MathMax(n,k))<=tsa) { CAblasF::CMatrixGemmK(m,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); return; } //--- Recursive algorithm: parallel splitting on M/N if(m>=n && m>=k) { //--- A*B = (A1 A2)^T*B CApServ::TiledSplit(m,tscur,s1,s2); CMatrixGemmRec(s1,n,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); if(OpTypea==0) CMatrixGemmRec(s2,n,k,alpha,a,ia+s1,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic+s1,jc); else CMatrixGemmRec(s2,n,k,alpha,a,ia,ja+s1,OpTypea,b,ib,jb,OpTypeb,beta,c,ic+s1,jc); return; } if(n>=m && n>=k) { //--- A*B = A*(B1 B2) CApServ::TiledSplit(n,tscur,s1,s2); if(OpTypeb==0) { CMatrixGemmRec(m,s1,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,s2,k,alpha,a,ia,ja,OpTypea,b,ib,jb+s1,OpTypeb,beta,c,ic,jc+s1); } else { CMatrixGemmRec(m,s1,k,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,s2,k,alpha,a,ia,ja,OpTypea,b,ib+s1,jb,OpTypeb,beta,c,ic,jc+s1); } return; } //--- Recursive algorithm: serial splitting on K //--- A*B = (A1 A2)*(B1 B2)^T CApServ::TiledSplit(k,tscur,s1,s2); switch(OpTypea) { case 0: if(OpTypeb==0) { CMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,n,s2,alpha,a,ia,ja+s1,OpTypea,b,ib+s1,jb,OpTypeb,1.0,c,ic,jc); } else { CMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,n,s2,alpha,a,ia,ja+s1,OpTypea,b,ib,jb+s1,OpTypeb,1.0,c,ic,jc); } break; default: if(OpTypeb==0) { CMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,n,s2,alpha,a,ia+s1,ja,OpTypea,b,ib+s1,jb,OpTypeb,1.0,c,ic,jc); } else { CMatrixGemmRec(m,n,s1,alpha,a,ia,ja,OpTypea,b,ib,jb,OpTypeb,beta,c,ic,jc); CMatrixGemmRec(m,n,s2,alpha,a,ia+s1,ja,OpTypea,b,ib,jb+s1,OpTypeb,1.0,c,ic,jc); } break; } } //+------------------------------------------------------------------+ //| Generation of an elementary reflection transformation | //| The subroutine generates elementary reflection H of order N, so | //| that, for a given X, the following equality holds true: | //| | //| ( X(1) ) ( Beta ) | //| H * ( .. ) = ( 0 ) | //| ( X(n) ) ( 0 ) | //| where | //| ( V(1) ) | //| H = 1 - Tau * ( .. ) * ( V(1), ..., V(n) ) | //| ( V(n) ) | //| where the first component of vector V equals 1. | //| Input parameters: | //| X - vector. Array whose index ranges within [1..N]. | //| N - reflection order. | //| Output parameters: | //| X - components from 2 to N are replaced with vector V. The | //| first component is replaced with parameter Beta. | //| Tau - scalar value Tau. If X is a null vector, Tau equals 0, | //| otherwise 1 <= Tau <= 2. | //| This subroutine is the modification of the DLARFG subroutines | //| from the LAPACK library. | //| MODIFICATIONS: | //| 24.12.2005 sign(Alpha) was replaced with an analogous to the | //| Fortran SIGN code. | //| -- LAPACK auxiliary routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University | //| September 30, 1994 | //+------------------------------------------------------------------+ void CAblas::GenerateReflection(CRowDouble &x, int n, double &tau) { //--- create variables int j=0; double alpha=0; double xnorm=0; double v=0; double beta=0; double mx=0; double s=0; int i_=0; tau=0; //--- check if(n<=1) { tau=0; return; } //--- check if(!CAp::Assert((int)x.Size()>n,__FUNCTION__+":N more then size of vector X")) return; //--- Scale if needed (to avoid overflow/underflow during //--- intermediate calculations). mx=0; for(j=1; j<=n; j++) mx=MathMax(MathAbs(x[j]),mx); s=1; if(mx!=0.0) { if(mx<=CMath::m_minrealnumber/CMath::m_machineepsilon) { s=CMath::m_minrealnumber/CMath::m_machineepsilon; v=1/s; for(i_=1; i_<=n; i_++) x.Mul(i_,v); mx*=v; } else { if(mx>=CMath::m_maxrealnumber*CMath::m_machineepsilon) { s=CMath::m_maxrealnumber*CMath::m_machineepsilon; v=1/s; for(i_=1; i_<=n; i_++) x.Mul(i_,v); mx*=v; } } } //--- XNORM = DNRM2( N-1, X, INCX ) alpha=x[1]; xnorm=0; if(mx!=0.0) { for(j=2; j<=n; j++) xnorm+=CMath::Sqr(x[j]/mx); xnorm=MathSqrt(xnorm)*mx; } if(xnorm==0.0) { //--- H = I tau=0; x.Mul(1,s); return; } //--- general case mx=MathMax(MathAbs(alpha),MathAbs(xnorm)); beta=-(mx*MathSqrt(CMath::Sqr(alpha/mx)+CMath::Sqr(xnorm/mx))); if(alpha<0.0) beta=-beta; tau=(beta-alpha)/beta; v=1/(alpha-beta); for(i_=2; i_<=n; i_++) x.Mul(i_,v); x.Set(1,beta); //--- Scale back outputs x.Mul(1,s); } //+------------------------------------------------------------------+ //| Application of an elementary reflection to a rectangular matrix | //| of size MxN | //| The algorithm pre-multiplies the matrix by an elementary | //| reflection transformation which is given by column V and scalar | //| Tau (see the description of the GenerateReflection procedure). | //| Not the whole matrix but only a part of it is transformed (rows | //| from M1 to M2, columns from N1 to N2). Only the elements of this | //| submatrix are changed. | //| Input parameters: | //| C - matrix to be transformed. | //| Tau - scalar defining the transformation. | //| V - column defining the transformation. Array whose index | //| ranges within [1..M2-M1+1]. | //| M1, M2 - range of rows to be transformed. | //| N1, N2 - range of columns to be transformed. | //| WORK - working array whose indexes goes from N1 to N2. | //| Output parameters: | //| C - the result of multiplying the input matrix C by the | //| transformation matrix which is given by Tau and V. | //| If N1>N2 or M1>M2, C is not modified. | //| -- LAPACK auxiliary routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University | //| September 30, 1994 | //+------------------------------------------------------------------+ void CAblas::ApplyReflectionFromTheLeft(CMatrixDouble &c, double tau, CRowDouble &v, int m1, int m2, int n1, int n2, CRowDouble &work) { //--- check if(((double)(tau)==0.0 || n1>n2) || m1>m2) return; CApServ::RVectorSetLengthAtLeast(work,n2-n1+1); RMatrixGemVect(n2-n1+1,m2-m1+1,1.0,c,m1,n1,1,v,1,0.0,work,0); RMatrixGer(m2-m1+1,n2-n1+1,c,m1,n1,-tau,v,1,work,0); } //+------------------------------------------------------------------+ //| Application of an elementary reflection to a rectangular matrix | //| of size MxN | //| The algorithm post-multiplies the matrix by an elementary | //| reflection transformation which is given by column V and scalar | //| Tau (see the description of the GenerateReflection procedure). | //| Not the whole matrix but only a part of it is transformed (rows | //| from M1 to M2, columns from N1 to N2). Only the elements of this | //| submatrix are changed. | //| Input parameters: | //| C - matrix to be transformed. | //| Tau - scalar defining the transformation. | //| V - column defining the transformation. Array whose index | //| ranges within [1..N2-N1+1]. | //| M1, M2 - range of rows to be transformed. | //| N1, N2 - range of columns to be transformed. | //| WORK - working array whose indexes goes from M1 to M2. | //| Output parameters: | //| C - the result of multiplying the input matrix C by the | //| transformation matrix which is given by Tau and V. | //| If N1>N2 or M1>M2, C is not modified. | //| -- LAPACK auxiliary routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University | //| September 30, 1994 | //+------------------------------------------------------------------+ void CAblas::ApplyReflectionFromTheRight(CMatrixDouble &c, double tau, CRowDouble &v, int m1, int m2, int n1, int n2, CRowDouble &work) { //--- check if(((double)(tau)==0.0 || n1>n2) || m1>m2) return; CApServ::RVectorSetLengthAtLeast(work,m2-m1+1); RMatrixGemVect(m2-m1+1,n2-n1+1,1.0,c,m1,n1,0,v,1,0.0,work,0); RMatrixGer(m2-m1+1,n2-n1+1,c,m1,n1,-tau,work,0,v,1); } //+------------------------------------------------------------------+ //| Orthogonal factorizations | //+------------------------------------------------------------------+ class COrtFac { public: //--- real matrix static void RMatrixQR(CMatrixDouble &a,const int m,const int n,double &tau[]); static void RMatrixQR(CMatrixDouble &a,const int m,const int n,CRowDouble &tau); static void RMatrixLQ(CMatrixDouble &a,const int m,const int n,double &tau[]); static void RMatrixLQ(CMatrixDouble &a,const int m,const int n,CRowDouble &tau); static void RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n,double &tau[],const int qcolumns,CMatrixDouble &q); static void RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n,CRowDouble &tau,const int qcolumns,CMatrixDouble &q); static void RMatrixQRUnpackR(CMatrixDouble &a,const int m,const int n,CMatrixDouble &r); static void RMatrixLQUnpackQ(CMatrixDouble &a,const int m,const int n,double &tau[],const int qrows,CMatrixDouble &q); static void RMatrixLQUnpackQ(CMatrixDouble &a,const int m,const int n,CRowDouble &tau,const int qrows,CMatrixDouble &q); static void RMatrixLQUnpackL(CMatrixDouble &a,const int m,const int n,CMatrixDouble &l); static void RMatrixQRBaseCase(CMatrixDouble &a,const int m,const int n,CRowDouble &work,CRowDouble &t,CRowDouble &tau); static void RMatrixLQBaseCase(CMatrixDouble &a,const int m,const int n,CRowDouble &work,CRowDouble&t,CRowDouble &tau); static void RMatrixBD(CMatrixDouble &a,const int m,const int n,double &tauq[],double &taup[]); static void RMatrixBD(CMatrixDouble &a,const int m,const int n,CRowDouble &tauq,CRowDouble &taup); static void RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n,double &tauq[],const int qcolumns,CMatrixDouble &q); static void RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n,CRowDouble &tauq,const int qcolumns,CMatrixDouble &q); static void RMatrixBDMultiplyByQ(CMatrixDouble &qp,const int m,const int n,double &tauq[],CMatrixDouble &z,const int zrows,const int zcolumns,const bool fromtheright,const bool dotranspose); static void RMatrixBDMultiplyByQ(CMatrixDouble &qp,const int m,const int n,CRowDouble &tauq,CMatrixDouble &z,const int zrows,const int zcolumns,const bool fromtheright,const bool dotranspose); static void RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n,double &taup[],const int ptrows,CMatrixDouble &pt); static void RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n,CRowDouble &taup,const int ptrows,CMatrixDouble &pt); static void RMatrixBDMultiplyByP(CMatrixDouble &qp,const int m,const int n,double &taup[],CMatrixDouble &z,const int zrows,const int zcolumns,const bool fromtheright,const bool dotranspose); static void RMatrixBDMultiplyByP(CMatrixDouble &qp,const int m,const int n,CRowDouble &taup,CMatrixDouble &z,const int zrows,const int zcolumns,const bool fromtheright,const bool dotranspose); static void RMatrixBDUnpackDiagonals(CMatrixDouble &b,const int m,const int n,bool &IsUpper,double &d[],double &e[]); static void RMatrixBDUnpackDiagonals(CMatrixDouble &b,const int m,const int n,bool &IsUpper,CRowDouble &d,CRowDouble &e); static void RMatrixHessenberg(CMatrixDouble &a,const int n,double &tau[]); static void RMatrixHessenberg(CMatrixDouble &a,const int n,CRowDouble &tau); static void RMatrixHessenbergUnpackQ(CMatrixDouble &a,const int n,double &tau[],CMatrixDouble &q); static void RMatrixHessenbergUnpackQ(CMatrixDouble &a,const int n,CRowDouble &tau,CMatrixDouble &q); static void RMatrixHessenbergUnpackH(CMatrixDouble &a,const int n,CMatrixDouble &h); static void SMatrixTD(CMatrixDouble &a,const int n,const bool IsUpper,double &tau[],double &d[],double &e[]); static void SMatrixTD(CMatrixDouble &a,const int n,const bool IsUpper,CRowDouble &tau,CRowDouble &d,CRowDouble &e); static void SMatrixTDUnpackQ(CMatrixDouble &a,const int n,const bool IsUpper,double &tau[],CMatrixDouble &q); static void SMatrixTDUnpackQ(CMatrixDouble &a,const int n,const bool IsUpper,CRowDouble &tau,CMatrixDouble &q); //--- complex matrix static void CMatrixQR(CMatrixComplex &a,const int m,const int n,complex &tau[]); static void CMatrixQR(CMatrixComplex &a,const int m,const int n,CRowComplex &tau); static void CMatrixLQ(CMatrixComplex &a,const int m,const int n,complex &tau[]); static void CMatrixLQ(CMatrixComplex &a,const int m,const int n,CRowComplex &tau); static void CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n,complex &tau[],const int qcolumns,CMatrixComplex &q); static void CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n,CRowComplex &tau,const int qcolumns,CMatrixComplex &q); static void CMatrixQRUnpackR(CMatrixComplex &a,const int m,const int n,CMatrixComplex &r); static void CMatrixLQUnpackQ(CMatrixComplex &a,const int m,const int n,complex &tau[],const int qrows,CMatrixComplex &q); static void CMatrixLQUnpackQ(CMatrixComplex &a,const int m,const int n,CRowComplex &tau,const int qrows,CMatrixComplex &q); static void CMatrixLQUnpackL(CMatrixComplex &a,const int m,const int n,CMatrixComplex &l); static void HMatrixTD(CMatrixComplex &a,const int n,const bool IsUpper,complex &tau[],double &d[],double &e[]); static void HMatrixTD(CMatrixComplex &a,const int n,const bool IsUpper,CRowComplex &tau,CRowDouble &d,CRowDouble &e); static void HMatrixTDUnpackQ(CMatrixComplex &a,const int n,const bool IsUpper,complex &tau[],CMatrixComplex &q); static void HMatrixTDUnpackQ(CMatrixComplex &a,const int n,const bool IsUpper,CRowComplex &tau,CMatrixComplex &q); private: static void CMatrixQRBaseCase(CMatrixComplex &a,const int m,const int n,CRowComplex &work,CRowComplex &t,CRowComplex &tau); static void CMatrixLQBaseCase(CMatrixComplex &a,const int m,const int n,CRowComplex &work,CRowComplex &t,CRowComplex &tau); static void RMatrixBlockReflector(CMatrixDouble &a,CRowDouble&tau,const bool columnwisea,const int lengtha,const int blocksize,CMatrixDouble &t,CRowDouble &work); static void CMatrixBlockReflector(CMatrixComplex &a,CRowComplex &tau,const bool columnwisea,const int lengtha,const int blocksize,CMatrixComplex &t,CRowComplex &work); }; //+------------------------------------------------------------------+ //| QR decomposition of a rectangular matrix of size MxN | //| Input parameters: | //| A - matrix A whose indexes range within [0..M-1, 0..N-1].| //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| Output parameters: | //| A - matrices Q and R in compact form (see below). | //| Tau - array of scalar factors which are used to form | //| matrix Q. Array whose index ranges within | //| [0.. Min(M-1,N-1)]. | //| Matrix A is represented as A = QR, where Q is an orthogonal | //| matrix of size MxM, R - upper triangular (or upper trapezoid) | //| matrix of size M x N. | //| The elements of matrix R are located on and above the main | //| diagonal of matrix A. The elements which are located in Tau | //| array and below the main diagonal of matrix A are used to form | //| matrix Q as follows: | //| Matrix Q is represented as a product of elementary reflections | //| Q = H(0)*H(2)*...*H(k-1), | //| where k = min(m,n), and each H(i) is in the form | //| H(i) = 1 - tau * v * (v^T) | //| where tau is a scalar stored in Tau[I]; v - real vector, | //| so that v(0:i-1) = 0, v(i) = 1, v(i+1:m-1) stored in | //| A(i+1:m-1,i). | //+------------------------------------------------------------------+ void COrtFac::RMatrixQR(CMatrixDouble &a,const int m,const int n,double &tau[]) { CRowDouble Tau=tau; RMatrixQR(a,m,n,Tau); Tau.ToArray(tau); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void COrtFac::RMatrixQR(CMatrixDouble &a,const int m,const int n,CRowDouble &tau) { //--- check if(m<=0 || n<=0) return; //--- create variables int minmn=MathMin(m,n); int blockstart=0; int blocksize=0; int rowscount=0; int i=0; int i_=0; int i1_=0; //--- create arrays CRowDouble work; CRowDouble t; CRowDouble taubuf; //--- create matrix CMatrixDouble tmpa; CMatrixDouble tmpt; CMatrixDouble tmpr; //--- allocation work=vector::Zeros(MathMax(m,n)+1); t=vector::Zeros(MathMax(m,n)+1); tau=vector::Zeros(minmn); taubuf=vector::Zeros(minmn); //--- allocation int ts=CApServ::MatrixTileSizeB(); tmpa=matrix::Zeros(m,ts); tmpt=matrix::Zeros(ts,2*ts); tmpr=matrix::Zeros(2*ts,n); //--- Blocked code while(blockstart!=minmn) { //--- Determine block size blocksize=minmn-blockstart; if(blocksize>ts) blocksize=ts; //--- change rowscount=m-blockstart; //--- QR decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::RMatrixCopy(rowscount,blocksize,a,blockstart,blockstart,tmpa,0,0); RMatrixQRBaseCase(tmpa,rowscount,blocksize,work,t,taubuf); CAblas::RMatrixCopy(rowscount,blocksize,tmpa,0,0,a,blockstart,blockstart); i1_=-blockstart; for(i_=blockstart; i_<=blockstart+blocksize-1; i_++) tau.Set(i_,taubuf[i_+i1_]); //--- check if(blockstart+blocksize=2*ts || rowscount>=4*ts) { //--- Prepare block reflector RMatrixBlockReflector(tmpa,taubuf,true,rowscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q'. //--- Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' //--- Q' = E + Y*T'*Y' = E + TmpA*TmpT'*TmpA' CAblas::RMatrixGemm(blocksize,n-blockstart-blocksize,rowscount,1.0,tmpa,0,0,1,a,blockstart,blockstart+blocksize,0,0.0,tmpr,0,0); CAblas::RMatrixGemm(blocksize,n-blockstart-blocksize,blocksize,1.0,tmpt,0,0,1,tmpr,0,0,0,0.0,tmpr,blocksize,0); CAblas::RMatrixGemm(rowscount,n-blockstart-blocksize,blocksize,1.0,tmpa,0,0,0,tmpr,blocksize,0,0,1.0,a,blockstart,blockstart+blocksize); } else { //--- Level 2 algorithm for(i=0; its) blocksize=ts; //--- change columnscount=n-blockstart; //--- LQ decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::RMatrixCopy(blocksize,columnscount,a,blockstart,blockstart,tmpa,0,0); RMatrixLQBaseCase(tmpa,blocksize,columnscount,work,t,taubuf); CAblas::RMatrixCopy(blocksize,columnscount,tmpa,0,0,a,blockstart,blockstart); i1_=-blockstart; for(i_=blockstart; i_<=blockstart+blocksize-1; i_++) tau.Set(i_,taubuf[i_+i1_]); //--- Update the rest, choose between: //--- a) Level 2 algorithm (when the rest of the matrix is small enough) //--- b) blocked algorithm, see algorithm 5 from 'A storage efficient WY //--- representation for products of Householder transformations', //--- by R. Schreiber and C. Van Loan. if(blockstart+blocksize<=m-1) { //--- check if(m-blockstart-blocksize>=2*CAblas::AblasBlockSize()) { //--- prepare RMatrixBlockReflector(tmpa,taubuf,false,columnscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q. //--- Q = E + Y*T*Y' = E + TmpA'*TmpT*TmpA CAblas::RMatrixGemm(m-blockstart-blocksize,blocksize,columnscount,1.0,a,blockstart+blocksize,blockstart,0,tmpa,0,0,1,0.0,tmpr,0,0); CAblas::RMatrixGemm(m-blockstart-blocksize,blocksize,blocksize,1.0,tmpr,0,0,0,tmpt,0,0,0,0.0,tmpr,0,blocksize); CAblas::RMatrixGemm(m-blockstart-blocksize,columnscount,blocksize,1.0,tmpr,0,blocksize,0,tmpa,0,0,0,1.0,a,blockstart+blocksize,blockstart); } else { //--- Level 2 algorithm for(i=0; its) blocksize=ts; rowscount=m-blockstart; //--- QR decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::CMatrixCopy(rowscount,blocksize,a,blockstart,blockstart,tmpa,0,0); CMatrixQRBaseCase(tmpa,rowscount,blocksize,work,t,taubuf); CAblas::CMatrixCopy(rowscount,blocksize,tmpa,0,0,a,blockstart,blockstart); i1_=-blockstart; for(i_=blockstart; i_=2*CAblas::AblasComplexBlockSize()) { //--- Prepare block reflector CMatrixBlockReflector(tmpa,taubuf,true,rowscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q'. //--- Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' //--- Q' = E + Y*T'*Y' = E + TmpA*TmpT'*TmpA' CAblas::CMatrixGemm(blocksize,n-blockstart-blocksize,rowscount,Alpha,tmpa,0,0,2,a,blockstart,blockstart+blocksize,0,Beta,tmpr,0,0); CAblas::CMatrixGemm(blocksize,n-blockstart-blocksize,blocksize,Alpha,tmpt,0,0,2,tmpr,0,0,0,Beta,tmpr,blocksize,0); CAblas::CMatrixGemm(rowscount,n-blockstart-blocksize,blocksize,Alpha,tmpa,0,0,0,tmpr,blocksize,0,0,Alpha,a,blockstart,blockstart+blocksize); } else { //--- Level 2 algorithm for(i=0; iCAblas::AblasComplexBlockSize()) blocksize=CAblas::AblasComplexBlockSize(); columnscount=n-blockstart; //--- LQ decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::CMatrixCopy(blocksize,columnscount,a,blockstart,blockstart,tmpa,0,0); CMatrixLQBaseCase(tmpa,blocksize,columnscount,work,t,taubuf); CAblas::CMatrixCopy(blocksize,columnscount,tmpa,0,0,a,blockstart,blockstart); i1_=-blockstart; for(i_=blockstart; i_<=blockstart+blocksize-1; i_++) tau.Set(i_,taubuf[i_+i1_]); //--- Update the rest, choose between: //--- a) Level 2 algorithm (when the rest of the matrix is small enough) //--- b) blocked algorithm, see algorithm 5 from 'A storage efficient WY //--- representation for products of Householder transformations', //--- by R. Schreiber and C. Van Loan. if(blockstart+blocksize<=m-1) { //--- check if(m-blockstart-blocksize>=2*ts) { //--- Prepare block reflector CMatrixBlockReflector(tmpa,taubuf,false,columnscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q. //--- Q = E + Y*T*Y' = E + TmpA'*TmpT*TmpA CAblas::CMatrixGemm(m-blockstart-blocksize,blocksize,columnscount,Alpha,a,blockstart+blocksize,blockstart,0,tmpa,0,0,2,Beta,tmpr,0,0); CAblas::CMatrixGemm(m-blockstart-blocksize,blocksize,blocksize,Alpha,tmpr,0,0,0,tmpt,0,0,0,Beta,tmpr,0,blocksize); CAblas::CMatrixGemm(m-blockstart-blocksize,columnscount,blocksize,Alpha,tmpr,0,blocksize,0,tmpa,0,0,0,Alpha,a,blockstart+blocksize,blockstart); } else { //--- Level 2 algorithm for(i=0; i=0. | //| N - number of columns in given matrix A. N>=0. | //| Tau - scalar factors which are used to form Q. | //| Output of the RMatrixQR subroutine. | //| QColumns - required number of columns of matrix Q. | //| M>=QColumns>=0. | //| Output parameters: | //| Q - first QColumns columns of matrix Q. | //| Array whose indexes range within | //| [0..M-1, 0..QColumns-1]. | //| If QColumns=0, the array remains unchanged. | //+------------------------------------------------------------------+ void COrtFac::RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n, double &tau[],const int qcolumns,CMatrixDouble &q) { CRowDouble Tau=tau; RMatrixQRUnpackQ(a,m,n,Tau,qcolumns,q); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n, CRowDouble &tau,const int qcolumns,CMatrixDouble &q) { //--- check if(!CAp::Assert(qcolumns<=m,__FUNCTION__+": QColumns>M!")) return; //--- check if(m<=0 || n<=0 || qcolumns<=0) return; //--- create arrays CRowDouble work; CRowDouble t; CRowDouble taubuf; //--- create matrix CMatrixDouble tmpa; CMatrixDouble tmpt; CMatrixDouble tmpr; //--- create variables int ts=CApServ::MatrixTileSizeB()/2; int minmn=MathMin(m,n); int refcnt=MathMin(minmn,qcolumns); int blockstart=ts*(refcnt/ts); int blocksize=refcnt-blockstart; int rowscount=0; int i=0; int j=0; int i_=0; int i1_=0; //--- identity matrix q=matrix::Identity(m,qcolumns); //--- allocation work=vector::Zeros(MathMax(m,qcolumns)+1); t=vector::Zeros(MathMax(m,qcolumns)+1); taubuf=vector::Zeros(minmn); //--- allocation tmpa=matrix::Zeros(m,ts); tmpt=matrix::Zeros(ts,2*ts); tmpr=matrix::Zeros(2*ts,qcolumns); //--- Blocked code while(blockstart>=0) { rowscount=m-blockstart; if(blocksize>0) { //--- Copy current block CAblas::RMatrixCopy(rowscount,blocksize,a,blockstart,blockstart,tmpa,0,0); i1_=blockstart; for(i_=0; i_=2*ts) { //--- Prepare block reflector RMatrixBlockReflector(tmpa,taubuf,true,rowscount,blocksize,tmpt,work); //--- Multiply matrix by Q. //--- Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' CAblas::RMatrixGemm(blocksize,qcolumns,rowscount,1.0,tmpa,0,0,1,q,blockstart,0,0,0.0,tmpr,0,0); CAblas::RMatrixGemm(blocksize,qcolumns,blocksize,1.0,tmpt,0,0,0,tmpr,0,0,0,0.0,tmpr,blocksize,0); CAblas::RMatrixGemm(rowscount,qcolumns,blocksize,1.0,tmpa,0,0,0,tmpr,blocksize,0,0,1.0,q,blockstart,0); } else { //--- Level 2 algorithm for(i=blocksize-1; i>=0; i--) { i1_=i-1; for(i_=2; i_<=rowscount-i; i_++) t.Set(i_,tmpa.Get(i_+i1_,i)); t.Set(1,1); //--- function call CAblas::ApplyReflectionFromTheLeft(q,taubuf[i],t,blockstart+i,m-1,0,qcolumns-1,work); } } } //--- change value blockstart-=ts; blocksize=ts; } } //+------------------------------------------------------------------+ //| Unpacking of matrix R from the QR decomposition of a matrix A | //| Input parameters: | //| A - matrices Q and R in compact form. | //| Output of RMatrixQR subroutine. | //| M - number of rows in given matrix A. M>=0. | //| N - number of columns in given matrix A. N>=0. | //| Output parameters: | //| R - matrix R, array[0..M-1, 0..N-1]. | //+------------------------------------------------------------------+ void COrtFac::RMatrixQRUnpackR(CMatrixDouble &a,const int m,const int n,CMatrixDouble &r) { //--- check if(m<=0 || n<=0) return; //--- create variables int i=0; int k=MathMin(m,n); int i_=0; //--- Prepare matrix r=matrix::Zeros(m,n); //--- get result r=a.TriU()+0; } //+------------------------------------------------------------------+ //| Partial unpacking of matrix Q from the LQ decomposition of a | //| matrix A | //| Input parameters: | //| A - matrices L and Q in compact form. | //| Output of RMatrixLQ subroutine. | //| M - number of rows in given matrix A. M>=0. | //| N - number of columns in given matrix A. N>=0. | //| Tau - scalar factors which are used to form Q. | //| Output of the RMatrixLQ subroutine. | //| QRows - required number of rows in matrix Q. N>=QRows>=0.| //| Output parameters: | //| Q - first QRows rows of matrix Q. Array whose indexes| //| range within [0..QRows-1, 0..N-1]. If QRows=0, | //| the array remains unchanged. | //+------------------------------------------------------------------+ void COrtFac::RMatrixLQUnpackQ(CMatrixDouble &a,const int m,const int n, double &tau[],const int qrows,CMatrixDouble &q) { CRowDouble Tau=tau; RMatrixLQUnpackQ(a,m,n,Tau,qrows,q); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixLQUnpackQ(CMatrixDouble &a,const int m,const int n, CRowDouble &tau,const int qrows,CMatrixDouble &q) { //--- check if(!CAp::Assert(qrows<=n,__FUNCTION__+": QRows>N!")) return; //--- check if(m<=0 || n<=0 || qrows<=0) return; //--- create arrays CRowDouble work; CRowDouble t; CRowDouble taubuf; //--- create matrix CMatrixDouble tmpa; CMatrixDouble tmpt; CMatrixDouble tmpr; //--- create variables int ts=CApServ::MatrixTileSizeB(); int minmn=MathMin(m,n); int refcnt=MathMin(minmn,qrows); int blockstart=ts*(refcnt/ts); int blocksize=refcnt-blockstart; int columnscount=0; int i=0; int j=0; int i_=0; int i1_=0; //--- allocation work.Resize(MathMax(m,n)+1); t.Resize(MathMax(m,n)+1); taubuf.Resize(minmn); //--- allocation tmpa.Resize(ts,n); tmpt.Resize(ts,2*ts); tmpr.Resize(qrows,2*ts); //--- identity matrix q=matrix::Identity(qrows,n); //--- Blocked code while(blockstart>=0) { columnscount=n-blockstart; //--- Copy submatrix CAblas::RMatrixCopy(blocksize,columnscount,a,blockstart,blockstart,tmpa,0,0); CAblasF::RCopyVX(blocksize,tau,blockstart,taubuf,0); //--- Update matrix, choose between: //--- a) Level 2 algorithm (when the rest of the matrix is small enough) //--- b) blocked algorithm, see algorithm 5 from 'A storage efficient WY //--- representation for products of Householder transformations', //--- by R. Schreiber and C. Van Loan. if(qrows>=2*ts) { //--- Prepare block reflector RMatrixBlockReflector(tmpa,taubuf,false,columnscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q'. //--- Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA CAblas::RMatrixGemm(qrows,blocksize,columnscount,1.0,q,0,blockstart,0,tmpa,0,0,1,0.0,tmpr,0,0); CAblas::RMatrixGemm(qrows,blocksize,blocksize,1.0,tmpr,0,0,0,tmpt,0,0,1,0.0,tmpr,0,blocksize); CAblas::RMatrixGemm(qrows,columnscount,blocksize,1.0,tmpr,0,blocksize,0,tmpa,0,0,0,1.0,q,0,blockstart); } else { //--- Level 2 algorithm for(i=blocksize-1; i>=0; i--) { i1_=i-1; for(i_=2; i_<=columnscount-i; i_++) t.Set(i_,tmpa.Get(i,i_+i1_)); t.Set(1,1); //--- function call CAblas::ApplyReflectionFromTheRight(q,taubuf[i],t,0,qrows-1,blockstart+i,n-1,work); } } //--- change value blockstart=blockstart-ts; blocksize=ts ; } } //+------------------------------------------------------------------+ //| Unpacking of matrix L from the LQ decomposition of a matrix A | //| Input parameters: | //| A -matrices Q and L in compact form. | //| Output of RMatrixLQ subroutine. | //| M -number of rows in given matrix A. M>=0. | //| N -number of columns in given matrix A. N>=0. | //| Output parameters: | //| L -matrix L, array[0..M-1,0..N-1]. | //+------------------------------------------------------------------+ void COrtFac::RMatrixLQUnpackL(CMatrixDouble &a,const int m,const int n,CMatrixDouble &l) { //--- check if(m<=0 || n<=0) return; //--- create variables int i=0; int k=0; int i_=0; //--- Prepare matrix l=matrix::Zeros(m,n); //--- get result for(i=0; i=0. | //| N - number of columns in matrix A. N>=0. | //| Tau - scalar factors which are used to form Q. | //| Output of CMatrixQR subroutine . | //| QColumns - required number of columns in matrix Q. | //| M>=QColumns>=0. | //| Output parameters: | //| Q - first QColumns columns of matrix Q. | //| Array whose index ranges within [0..M-1, | //| 0..QColumns-1]. | //| If QColumns=0, array isn't changed. | //+------------------------------------------------------------------+ void COrtFac::CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n, complex &tau[],const int qcolumns,CMatrixComplex &q) { CRowComplex Tau=tau; CMatrixQRUnpackQ(a,m,n,Tau,qcolumns,q); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n, CRowComplex &tau,const int qcolumns,CMatrixComplex &q) { //--- check if(!CAp::Assert(qcolumns<=m,__FUNCTION__+": QColumns>M!")) return; //--- check if(m<=0 || n<=0) return; //--- create arrays CRowComplex work; CRowComplex t; CRowComplex taubuf; //--- create matrix CMatrixComplex tmpa; CMatrixComplex tmpt; CMatrixComplex tmpr; //--- create variables int ts=CApServ::MatrixTileSizeB()/2; int minmn=MathMin(m,n); int refcnt=MathMin(minmn,qcolumns); int blockstart=ts*(refcnt/ts); int blocksize=refcnt-blockstart; int rowscount=0; int i=0; int j=0; int i_=0; int i1_=0; complex One(1,0); complex Zero(0,0); //--- allocation work.Resize(MathMax(m,n)+1); t.Resize(MathMax(m,n)+1); taubuf.Resize(minmn); //--- allocation tmpa.Resize(m,ts); tmpt.Resize(ts,ts); tmpr.Resize(2*ts,qcolumns); //--- identity matrix q=matrix::Identity(m,qcolumns); //--- Blocked code while(blockstart>=0) { rowscount=m-blockstart; if(blocksize>0) { //--- QR decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::CMatrixCopy(rowscount,blocksize,a,blockstart,blockstart,tmpa,0,0); i1_=blockstart; for(i_=0; i_=2*ts) { //--- Prepare block reflector CMatrixBlockReflector(tmpa,taubuf,true,rowscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q. //--- Q = E + Y*T*Y' = E + TmpA*TmpT*TmpA' CAblas::CMatrixGemm(blocksize,qcolumns,rowscount,One,tmpa,0,0,2,q,blockstart,0,0,Zero,tmpr,0,0); CAblas::CMatrixGemm(blocksize,qcolumns,blocksize,One,tmpt,0,0,0,tmpr,0,0,0,Zero,tmpr,blocksize,0); CAblas::CMatrixGemm(rowscount,qcolumns,blocksize,One,tmpa,0,0,0,tmpr,blocksize,0,0,One,q,blockstart,0); } else { //--- Level 2 algorithm for(i=blocksize-1; i>=0; i--) { i1_=i-1; for(i_=1; i_<=rowscount-i; i_++) t.Set(i_,tmpa.Get(i_+i1_,i)); t.Set(1,1.0); //--- function call CComplexReflections::ComplexApplyReflectionFromTheLeft(q,taubuf[i],t,blockstart+i,m-1,0,qcolumns-1,work); } } } //--- change value blockstart=blockstart-ts; blocksize=ts; } } //+------------------------------------------------------------------+ //| Unpacking of matrix R from the QR decomposition of a matrix A | //| Input parameters: | //| A - matrices Q and R in compact form. | //| Output of CMatrixQR subroutine. | //| M - number of rows in given matrix A. M>=0. | //| N - number of columns in given matrix A. N>=0. | //| Output parameters: | //| R - matrix R, array[0..M-1, 0..N-1]. | //+------------------------------------------------------------------+ void COrtFac::CMatrixQRUnpackR(CMatrixComplex &a,const int m,const int n,CMatrixComplex &r) { //--- check if(m<=0 || n<=0) return; //--- create variables int k=MathMin(m,n); //--- Prepare matrix r=matrix::Zeros(m,n); //--- get result for(int i=0; i=0. | //| N - number of columns in matrix A. N>=0. | //| Tau - scalar factors which are used to form Q. | //| Output of CMatrixLQ subroutine . | //| QRows - required number of rows in matrix Q. | //| N>=QColumns>=0. | //| Output parameters: | //| Q - first QRows rows of matrix Q. | //| Array whose index ranges within [0..QRows-1, | //| 0..N-1]. | //| If QRows=0, array isn't changed. | //+------------------------------------------------------------------+ void COrtFac::CMatrixLQUnpackQ(CMatrixComplex &a,const int m,const int n, complex &tau[],const int qrows,CMatrixComplex &q) { CRowComplex Tau=tau; CMatrixLQUnpackQ(a,m,n,Tau,qrows,q); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::CMatrixLQUnpackQ(CMatrixComplex &a,const int m,const int n, CRowComplex &tau,const int qrows,CMatrixComplex &q) { //--- check if(m<=0 || n<=0) return; //--- create arrays CRowComplex work; CRowComplex t; CRowComplex taubuf; //--- create matrix CMatrixComplex tmpa; CMatrixComplex tmpt; CMatrixComplex tmpr; //--- create variables int minmn=MathMin(m,n); int refcnt=MathMin(minmn,qrows); int ts=CApServ::MatrixTileSizeB()/2; int blockstart=ts*(refcnt/ts); int blocksize=refcnt-blockstart; int columnscount=0; int i=0; int j=0; int i_=0; int i1_=0; complex One(1,0); complex Zero(0,0); //--- allocation work.Resize(MathMax(m,n)+1); t.Resize(MathMax(m,n)+1); taubuf.Resize(minmn); //--- allocation tmpa.Resize(ts,n); tmpt.Resize(ts,ts); tmpr.Resize(qrows,2*ts); //--- identity matrix q=matrix::Identity(qrows,n); //--- Blocked code while(blockstart>=0) { columnscount=n-blockstart; if(blocksize>0) { //--- LQ decomposition of submatrix. //--- Matrix is copied to temporary storage to solve //--- some TLB issues arising from non-contiguous memory //--- access pattern. CAblas::CMatrixCopy(blocksize,columnscount,a,blockstart,blockstart,tmpa,0,0); i1_=blockstart; for(i_=0; i_=2*ts) { //--- Prepare block reflector CMatrixBlockReflector(tmpa,taubuf,false,columnscount,blocksize,tmpt,work); //--- Multiply the rest of A by Q'. //--- Q' = E + Y*T'*Y' = E + TmpA'*TmpT'*TmpA CAblas::CMatrixGemm(qrows,blocksize,columnscount,One,q,0,blockstart,0,tmpa,0,0,2,Zero,tmpr,0,0); CAblas::CMatrixGemm(qrows,blocksize,blocksize,One,tmpr,0,0,0,tmpt,0,0,2,Zero,tmpr,0,blocksize); CAblas::CMatrixGemm(qrows,columnscount,blocksize,One,tmpr,0,blocksize,0,tmpa,0,0,0,One,q,0,blockstart); } else { //--- Level 2 algorithm for(i=blocksize-1; i>=0; i--) { i1_=i-1; for(i_=2; i_<=columnscount-i; i_++) t.Set(i_,CMath::Conj(tmpa.Get(i,i_+i1_))); t.Set(1,1.0); //--- function call complex conj=CMath::Conj(taubuf[i]); CComplexReflections::ComplexApplyReflectionFromTheRight(q,conj,t,0,qrows-1,blockstart+i,n-1,work); } } } //--- change value blockstart=blockstart-ts; blocksize=ts; } } //+------------------------------------------------------------------+ //| Unpacking of matrix L from the LQ decomposition of a matrix A | //| Input parameters: | //| A - matrices Q and L in compact form. | //| Output of CMatrixLQ subroutine. | //| M - number of rows in given matrix A. M>=0. | //| N - number of columns in given matrix A. N>=0. | //| Output parameters: | //| L - matrix L, array[0..M-1, 0..N-1]. | //+------------------------------------------------------------------+ void COrtFac::CMatrixLQUnpackL(CMatrixComplex &a,const int m,const int n,CMatrixComplex &l) { //--- check if(m<=0 || n<=0) return; //--- Prepare matrix l=matrix::Zeros(m,n); //--- get result for(int i=0; i=N, B is the upper bidiagonal MxN matrix and is stored in | //| the corresponding elements of matrix A. Matrix Q is represented | //| as a product of elementary reflections Q = H(0)*H(1)*...*H(n-1), | //| where H(i) = 1-tau*v*v'. Here tau is a scalar which is stored in | //| TauQ[i], and vector v has the following structure: v(0:i-1)=0, | //| v(i)=1, v(i+1:m-1) is stored in elements A(i+1:m-1,i).Matrix P is| //| as follows: P = G(0)*G(1)*...*G(n-2), where G(i) = 1 - tau*u*u'. | //| Tau is stored in TauP[i], u(0:i)=0, u(i+1)=1, u(i+2:n-1) is | //| stored in elements A(i,i+2:n-1). | //| If M n): m=5, n=6 (m < n): | //| ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) | //| ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) | //| ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) | //| ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) | //| ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) | //| ( v1 v2 v3 v4 v5 ) | //| Here vi and ui are vectors which form H(i) and G(i), and d and | //| e - are the diagonal and off-diagonal elements of matrix B. | //+------------------------------------------------------------------+ void COrtFac::RMatrixBD(CMatrixDouble &a,const int m,const int n,double &tauq[],double &taup[]) { CRowDouble TauQ=tauq; CRowDouble TauP=taup; RMatrixBD(a,m,n,TauQ,TauP); TauQ.ToArray(tauq); TauP.ToArray(taup); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixBD(CMatrixDouble &a,const int m,const int n,CRowDouble &tauq,CRowDouble &taup) { //--- check if(n<=0 || m<=0) return; //--- create arrays CRowDouble work; CRowDouble t; //--- create variables int minmn=0; int maxmn=MathMax(m,n); int i=0; double ltau=0; int i_=0; int i1_=0; //--- allocation work.Resize(maxmn+1); t.Resize(maxmn+1); //--- initialization tauq=vector::Zeros(MathMin(m,n)); taup=tauq; //--- check if(m>=n) { //--- Reduce to upper bidiagonal form for(i=0; i=QColumns>=0. | //| Output parameters: | //| Q - first QColumns columns of matrix Q. | //| Array[0..M-1, 0..QColumns-1] | //| If QColumns=0, the array is not modified. | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n, double &tauq[],const int qcolumns,CMatrixDouble &q) { CRowDouble TauQ=tauq; RMatrixBDUnpackQ(qp,m,n,TauQ,qcolumns,q); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n, CRowDouble &tauq,const int qcolumns,CMatrixDouble &q) { //--- check if(!CAp::Assert(qcolumns<=m,__FUNCTION__+": QColumns>M!")) return; //--- check if(!CAp::Assert(qcolumns>=0,__FUNCTION__+": QColumns<0!")) return; //--- check if(m==0 || n==0 || qcolumns==0) return; //--- identity matrix q=matrix::Identity(m,qcolumns); //--- get result RMatrixBDMultiplyByQ(qp,m,n,tauq,q,m,qcolumns,false,false); } //+------------------------------------------------------------------+ //| Multiplication by matrix Q which reduces matrix A to bidiagonal | //| form. | //| The algorithm allows pre- or post-multiply by Q or Q'. | //| Input parameters: | //| QP - matrices Q and P in compact form. | //| Output of ToBidiagonal subroutine. | //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| TAUQ - scalar factors which are used to form Q. | //| Output of ToBidiagonal subroutine. | //| Z - multiplied matrix. | //| array[0..ZRows-1,0..ZColumns-1] | //| ZRows - number of rows in matrix Z. If FromTheRight= | //| =False, ZRows=M, otherwise ZRows can be | //| arbitrary. | //| ZColumns - number of columns in matrix Z. If | //| FromTheRight=True, ZColumns=M, otherwise | //| ZColumns can be arbitrary. | //| FromTheRight - pre- or post-multiply. | //| DoTranspose - multiply by Q or Q'. | //| Output parameters: | //| Z - product of Z and Q. | //| Array[0..ZRows-1,0..ZColumns-1] | //| If ZRows=0 or ZColumns=0, the array is not | //| modified. | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDMultiplyByQ(CMatrixDouble &qp,const int m,const int n, double &tauq[],CMatrixDouble &z,const int zrows, const int zcolumns,const bool fromtheright, const bool dotranspose) { CRowDouble TauQ=tauq; RMatrixBDMultiplyByQ(qp,m,n,TauQ,z,zrows,zcolumns,fromtheright,dotranspose); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDMultiplyByQ(CMatrixDouble &qp,const int m,const int n, CRowDouble &tauq,CMatrixDouble &z,const int zrows, const int zcolumns,const bool fromtheright, const bool dotranspose) { //--- check if(m<=0 || n<=0 || zrows<=0 || zcolumns<=0) return; //--- check if(!CAp::Assert((fromtheright && zcolumns==m) || (!fromtheright && zrows==m),__FUNCTION__+": incorrect Z size!")) return; //--- create variables int mx=0; int i_=0; int i1_=0; int i=0; int i1=0; int i2=0; int istep=0; //--- create arrays CRowDouble v; CRowDouble work; CRowDouble dummy; //--- initialization mx=MathMax(m,n); mx=MathMax(mx,zrows); mx=MathMax(mx,zcolumns); //--- allocation v.Resize(mx+1); work.Resize(mx+1); //--- check if(m>=n) { //--- setup if(fromtheright) { i1=0; i2=n-1; istep=1; } else { i1=n-1; i2=0; istep=-1; } //--- check if(dotranspose) { i=i1; i1=i2; i2=i; istep=-istep; } //--- Process i=i1; do { i1_=i-1; for(i_=2; i_<=m-i; i_++) v.Set(i_,qp.Get(i_+i1_,i)); v.Set(1,1); //--- check if(fromtheright) CAblas::ApplyReflectionFromTheRight(z,tauq[i],v,0,zrows-1,i,m-1,work); else CAblas::ApplyReflectionFromTheLeft(z,tauq[i],v,i,m-1,0,zcolumns-1,work); i=i+istep; } while(i!=i2+istep); } else { //--- setup if(fromtheright) { i1=0; i2=m-2; istep=1; } else { i1=m-2; i2=0; istep=-1; } //--- check if(dotranspose) { i=i1; i1=i2; i2=i; istep=-istep; } //--- Process if(m-1>0) { i=i1; do { i1_=i; for(i_=2; i_= PTRows >= 0. | //| Output parameters: | //| PT - first PTRows columns of matrix P^T | //| Array[0..PTRows-1, 0..N-1] | //| If PTRows=0, the array is not modified. | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n, double &taup[],const int ptrows,CMatrixDouble &pt) { CRowDouble TauP=taup; RMatrixBDUnpackPT(qp,m,n,TauP,ptrows,pt); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n, CRowDouble &taup,const int ptrows,CMatrixDouble &pt) { //--- check if(!CAp::Assert(ptrows<=n,__FUNCTION__+": PTRows>N!")) return; //--- check if(!CAp::Assert(ptrows>=0,__FUNCTION__+": PTRows<0!")) return; //--- check if(m==0 || n==0 || ptrows==0) return; //--- prepare pt=matrix::Identity(ptrows,n); //--- get result RMatrixBDMultiplyByP(qp,m,n,taup,pt,ptrows,n,true,true); } //+------------------------------------------------------------------+ //| Multiplication by matrix P which reduces matrix A to bidiagonal | //| form. | //| The algorithm allows pre- or post-multiply by P or P'. | //| Input parameters: | //| QP - matrices Q and P in compact form. | //| Output of RMatrixBD subroutine. | //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| TAUP - scalar factors which are used to form P. | //| Output of RMatrixBD subroutine. | //| Z - multiplied matrix. | //| Array whose indexes range within | //| [0..ZRows-1,0..ZColumns-1]. | //| ZRows - number of rows in matrix Z. If | //| FromTheRight=False, ZRows=N, otherwise ZRows | //| can be arbitrary. | //| ZColumns - number of columns in matrix Z. If | //| FromTheRight=True, ZColumns=N, otherwise | //| ZColumns can be arbitrary. | //| FromTheRight - pre- or post-multiply. | //| DoTranspose - multiply by P or P'. | //| Output parameters: | //| Z - product of Z and P. | //| Array whose indexes range within | //| [0..ZRows-1,0..ZColumns-1]. If ZRows=0 or | //| ZColumns=0, the array is not modified. | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDMultiplyByP(CMatrixDouble &qp,const int m,const int n, double &taup[],CMatrixDouble &z,const int zrows, const int zcolumns,const bool fromtheright, const bool dotranspose) { CRowDouble TauP=taup; RMatrixBDMultiplyByP(qp,m,n,TauP,z,zrows,zcolumns,fromtheright,dotranspose); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixBDMultiplyByP(CMatrixDouble &qp,const int m,const int n, CRowDouble &taup,CMatrixDouble &z,const int zrows, const int zcolumns,const bool fromtheright, const bool dotranspose) { //--- check if(m<=0 || n<=0 || zrows<=0 || zcolumns<=0) return; //--- check if(!CAp::Assert((fromtheright && zcolumns==n) || (!fromtheright && zrows==n),__FUNCTION__+": incorrect Z size!")) return; //--- create arrays CRowDouble v; CRowDouble work; //--- create variables int i=0; int mx=0; int i1=0; int i2=0; int istep=0; int i_=0; int i1_=0; //--- initialization mx=MathMax(m,n); mx=MathMax(mx,zrows); mx=MathMax(mx,zcolumns); //--- allocation v.Resize(mx+1); work.Resize(mx+1); //--- check if(m>=n) { //--- setup if(fromtheright) { i1=n-2; i2=0; istep=-1; } else { i1=0; i2=n-2; istep=1; } //--- check if(!dotranspose) { i=i1; i1=i2; i2=i; istep=-istep; } //--- Process if(n-1>0) { i=i1; do { i1_=i; for(i_=2; i_=n); d=b.Diag()+0; //--- check if(IsUpper) e=b.Diag(1)+0; else e=b.Diag(-1)+0; } //+------------------------------------------------------------------+ //| Reduction of a square matrix to upper Hessenberg form: | //| Q'*A*Q = H, where Q is an orthogonal matrix, H - Hessenberg | //| matrix. | //| Input parameters: | //| A - matrix A with elements [0..N-1, 0..N-1] | //| N - size of matrix A. | //| Output parameters: | //| A - matrices Q and P in compact form (see below). | //| Tau - array of scalar factors which are used to form | //| matrix Q. | //| Array whose index ranges within [0..N-2] | //| Matrix H is located on the main diagonal, on the lower secondary | //| diagonal and above the main diagonal of matrix A. The elements | //| which are used to form matrix Q are situated in array Tau and | //| below the lower secondary diagonal of matrix A as follows: | //| Matrix Q is represented as a product of elementary reflections | //| Q = H(0)*H(2)*...*H(n-2), | //| where each H(i) is given by | //| H(i) = 1 - tau * v * (v^T) | //| where tau is a scalar stored in Tau[I]; v - is a real vector, | //| so that v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) stored in | //| A(i+2:n-1,i). | //| -- LAPACK routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University| //| October 31, 1992 | //+------------------------------------------------------------------+ void COrtFac::RMatrixHessenberg(CMatrixDouble &a,const int n,double &tau[]) { CRowDouble Tau=tau; RMatrixHessenberg(a,n,Tau); Tau.ToArray(tau); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void COrtFac::RMatrixHessenberg(CMatrixDouble &a,const int n,CRowDouble &tau) { //--- check if(n<=1) return; //--- check if(!CAp::Assert(n>=0,__FUNCTION__+": incorrect N!")) return; //--- create arrays CRowDouble t; CRowDouble work; //--- create variables int i=0; double v=0; int i_=0; int i1_=0; //--- allocation tau.Resize(n-1); t.Resize(n+1); work.Resize(n); //--- ALGLIB version for(i=0; i::Identity(n,n); //--- unpack Q for(i=0; i::Identity(n,n); //--- unpack Q for(i=0; i1) tau.Resize(n-1); d.Resize(n); //--- check if(n>1) e.Resize(n-1); //---ALGLIB version //--- check if(IsUpper) { //--- Reduce the upper triangle of A for(i=n-2; i>=0; i--) { //--- Generate elementary reflector H() = E - tau * v * v' if(i>=1) { i1_=-2; for(i_=2; i_=1) { i1_=2; for(i_=0; i_::Zeros(n+1); CRowDouble work; //--- create variables int i=0; int j=0; int i_=0; int i1_=0; //--- allocation work.Resize(n); //--- identity matrix q=matrix::Identity(n,n); //--- ALGLIB version: unpack Q if(IsUpper) { for(i=0; i=0; i--) { //--- Apply H(i) for(i_=1; i_1) { tau=vector::Full(n-1,0); e=vector::Zeros(n-1); } d=vector::Zeros(n); t=vector::Full(n,0); t2=vector::Full(n,0); t3=vector::Full(n,0); //--- ALGLIB version //--- check if(IsUpper) { //--- Reduce the upper triangle of A a.Set(n-1,n-1,a.Get(n-1,n-1).real); for(i=n-2; i>=0; i--) { //--- Generate elementary reflector H = I+1 - tau * v * v' alpha=a.Get(i,i+1); t.Set(1,alpha); //--- check if(i>=1) { i1_=-2; for(i_=2; i_<=i+1; i_++) t.Set(i_,a.Get(i_+i1_,i+1)); } //--- function call CComplexReflections::ComplexGenerateReflection(t,i+1,taui); //--- check if(i>=1) { i1_=2; for(i_=0; i_::Identity(n,n); //--- ALGLIB version //--- unpack Q if(IsUpper) { for(i=0; i=0; i--) { //--- Apply H(i) i1_=i; for(i_=1; i_=1 | //| N - number of columns in a matrix, N>=1 | //| K - K>=0, expected number of non-zero elements in a | //| matrix. K can be inexact approximation, can be less| //| than actual number of elements (table will grow | //| when needed) or even zero). | //| It is important to understand that although hash-table may grow | //| automatically, it's better to provide good estimate of data size.| //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in Hash-Table representation. All| //| elements of the matrix are zero. | //| NOTE 1 | //| Hash-tables use memory inefficiently, and they have to keep some | //| amount of the "spare memory" in order to have good performance. | //| Hash table for matrix with K non-zero elements will need | //| C*K*(8+2*sizeof(int)) bytes, where C is a small constant, about | //| 1.5-2 in magnitude. | //| CRS storage, from the other side, is more memory-efficient, and | //| needs just K*(8+sizeof(int))+M*sizeof(int) bytes, where M is a | //| number of rows in a matrix. | //| When you convert from the Hash-Table to CRS representation, all | //| unneeded memory will be freed. | //| | //| NOTE 2 | //| Comments of SparseMatrix structure outline information about | //| different sparse storage formats. We recommend you to read them | //| before starting to use ALGLIB sparse matrices. | //| | //| NOTE 3 | //| This function completely overwrites S with new sparse matrix. | //| Previously allocated storage is NOT reused. If you want to reuse | //| already allocated memory, call SparseCreateBuf function. | //+------------------------------------------------------------------+ void CSparse::SparseCreate(int m, int n, int k, CSparseMatrix &s) { SparseCreateBuf(m,n,k,s); } //+------------------------------------------------------------------+ //| This version of SparseCreate function creates sparse matrix in | //| Hash-Table format, reusing previously allocated storage as much | //| as possible.Read comments for SparseCreate() for more information| //| INPUT PARAMETERS: | //| M - number of rows in a matrix, M>=1 | //| N - number of columns in a matrix, N>=1 | //| K - K>=0, expected number of non-zero elements in a matrix| //| K can be inexact approximation, can be less than | //| actual number of elements (table will grow when needed| //| or even zero). | //| It is important to understand that although hash-table may grow | //| automatically, it is better to provide good estimate of data size| //| S - SparseMatrix structure which MAY contain some already | //| allocated storage. | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in Hash-Table representation. All | //| elements of the matrix are zero. Previously allocated | //| storage is reused, if its size is compatible with | //| expected number of non-zeros K. | //+------------------------------------------------------------------+ void CSparse::SparseCreateBuf(int m, int n, int k, CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(k>=0,__FUNCTION__+": K<0")) return; //--- create variables int i=0; //--- Hash-table size is max(existing_size,requested_size) //--- NOTE: it is important to use ALL available memory for hash table //--- because it is impossible to efficiently reallocate table //--- without temporary storage. So, if we want table with up to //--- 1.000.000 elements, we have to create such table from the //--- very beginning. Otherwise, the very idea of memory reuse //--- will be compromised. s.m_TableSize=(int)MathRound(k/m_DesiredLoadFactor+m_Additional); s.m_Vals=vector::Zeros(s.m_TableSize); s.m_TableSize=CAp::Len(s.m_Vals); //--- Initialize other fields s.m_MatrixType=0; s.m_M=m; s.m_N=n; s.m_NFree=s.m_TableSize; CApServ::IVectorSetLengthAtLeast(s.m_Idx,2*s.m_TableSize); for(i=0; i=1 | //| N - number of columns in a matrix, N>=1 | //| NER - number of elements at each row, array[M], NER[I]>=0 | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in CRS representation. | //| You have to fill ALL non-zero elements by calling | //| SparseSet() BEFORE you try to use this matrix. | //| NOTE: this function completely overwrites S with new sparse | //| matrix. Previously allocated storage is NOT reused. If you | //| want to reuse already allocated memory, call | //| SparseCreateCRSBuf function. | //+------------------------------------------------------------------+ void CSparse::SparseCreateCRS(int m,int n,CRowInt &ner, CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(CAp::Len(ner)>=m,__FUNCTION__+": Length(NER)=0,__FUNCTION__+": NER[] contains negative elements")) return; } SparseCreateCRSBuf(m,n,ner,s); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSparse::SparseCreateCRS(int m,int n,int &ner[], CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(CAp::Len(ner)>=m,__FUNCTION__+": Length(NER)=0,__FUNCTION__+": NER[] contains negative elements")) return; } SparseCreateCRSBuf(m,n,ner,s); } //+------------------------------------------------------------------+ //| This function creates sparse matrix in a CRS format (expert | //| function for situations when you are running out of memory). This| //| version of CRS matrix creation function may reuse memory already | //| allocated in S. | //| This function creates CRS matrix. Typical usage scenario for a | //| CRS matrix is: | //| 1. creation (you have to tell number of non-zero elements at each| //| row at this moment) | //| 2. insertion of the matrix elements (row by row, from left to | //| right) | //| 3. matrix is passed to some linear algebra algorithm | //| This function is a memory-efficient alternative to SparseCreate()| //| but it is more complex because it requires you to know in advance| //| how large your matrix is. Some information about different matrix| //| formats can be found in comments on SparseMatrix structure. We | //| recommend you to read them before starting to use ALGLIB sparse | //| matrices.. | //| INPUT PARAMETERS: | //| M - number of rows in a matrix, M>=1 | //| N - number of columns in a matrix, N>=1 | //| NER - number of elements at each row, array[M], NER[I]>=0 | //| S - sparse matrix structure with possibly preallocated | //| memory. | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in CRS representation. You have to | //| fill ALL non-zero elements by calling SparseSet() | //| BEFORE you try to use this matrix. | //+------------------------------------------------------------------+ void CSparse::SparseCreateCRSBuf(int m, int n, int &ner[], CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(CAp::Len(ner)>=m,__FUNCTION__+": Length(NER)=0,__FUNCTION__+": NER[] contains negative elements")) return; noe=noe+ner[i]; s.m_RIdx.Set(i+1,s.m_RIdx[i]+ner[i]); } CApServ::RVectorSetLengthAtLeast(s.m_Vals,noe); CApServ::IVectorSetLengthAtLeast(s.m_Idx,noe); if(noe==0) SparseInitDUIdx(s); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSparse::SparseCreateCRSBuf(int m,int n,CRowInt &ner,CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(CAp::Len(ner)>=m,__FUNCTION__+": Length(NER)=0,__FUNCTION__+": NER[] contains negative elements")) return; noe+=ner[i]; s.m_RIdx.Set(i+1,s.m_RIdx[i]+ner[i]); } s.m_Vals=vector::Zeros(noe); CApServ::IVectorSetLengthAtLeast(s.m_Idx,noe); s.m_Idx.Fill(0); if(noe==0) SparseInitDUIdx(s); } //+------------------------------------------------------------------+ //| This function creates sparse matrix in a SKS format (skyline | //| storage format). In most cases you do not need this function -CRS| //| format better suits most use cases. | //| INPUT PARAMETERS: | //| M, N - number of rows(M) and columns(N) in a matrix: | //| * M=N (as for now, ALGLIB supports only square SKS)| //| * N>=1 | //| * M>=1 | //| D - "bottom" bandwidths, array[M],D[I]>=0. I-th element| //| stores number of non-zeros at I-th row, below the | //| diagonal (diagonal itself is not included) | //| U - "top" bandwidths, array[N], U[I]>=0. I-th element | //| stores number of non-zeros at I-th row, above the | //| diagonal (diagonal itself is not included) | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in SKS representation. All | //| elements are filled by zeros. You may use | //| SparseSet() to change their values. | //| NOTE: this function completely overwrites S with new sparse | //| matrix. Previously allocated storage is NOT reused. If you | //| want to reuse already allocated memory, call | //| SparseCreateSKSBuf function. | //+------------------------------------------------------------------+ void CSparse::SparseCreateSKS(int m,int n,int &d[],int &u[], CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M<>N")) return; //--- check if(!CAp::Assert(CAp::Len(d)>=m,__FUNCTION__+": Length(D)=n,__FUNCTION__+": Length(U)=0,__FUNCTION__+": D[] contains negative elements")) return; //--- check if(!CAp::Assert(d[i]<=i,__FUNCTION__+": D[I]>I for some I")) return; } for(int i=0; i=0,__FUNCTION__+": U[] contains negative elements")) return; //--- check if(!CAp::Assert(u[i]<=i,__FUNCTION__+": U[I]>I for some I")) return; } SparseCreateSKSBuf(m,n,d,u,s); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSparse::SparseCreateSKS(int m,int n,CRowInt &d, CRowInt &u,CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M<>N")) return; //--- check if(!CAp::Assert(CAp::Len(d)>=m,__FUNCTION__+": Length(D)=n,__FUNCTION__+": Length(U)=0,__FUNCTION__+": D[] contains negative elements")) return; //--- check if(!CAp::Assert(d[i]<=i,__FUNCTION__+": D[I]>I for some I")) return; } for(int i=0; i=0,__FUNCTION__+": U[] contains negative elements")) return; //--- check if(!CAp::Assert(u[i]<=i,__FUNCTION__+": U[I]>I for some I")) return; } SparseCreateSKSBuf(m,n,d,u,s); } //+------------------------------------------------------------------+ //| This is "buffered" version of SparseCreateSKS() which reuses | //| memory previously allocated in S (of course, memory is | //| reallocated if needed). | //| This function creates sparse matrix in a SKS format (skyline | //| storage format). In most cases you do not need this function - | //| CRS format better suits most use cases. | //| INPUT PARAMETERS: | //| M, N - number of rows(M) and columns (N) in a matrix: | //| * M=N (as for now, ALGLIB supports only square SKS)| //| * N>=1 | //| * M>=1 | //| D - "bottom" bandwidths, array[M], 0<=D[I]<=I. | //| I-th element stores number of non-zeros at I-th row,| //| below the diagonal (diagonal itself is not included)| //| U - "top" bandwidths, array[N], 0<=U[I]<=I. I-th | //| element stores number of non-zeros at I-th row,above| //| the diagonal (diagonal itself is not included) | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in SKS representation. All | //| elements are filled by zeros. You may use | //| SparseSet() to change their values. | //+------------------------------------------------------------------+ void CSparse::SparseCreateSKSBuf(int m,int n,int &d[],int &u[], CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M<>N")) return; //--- check if(!CAp::Assert(CAp::Len(d)>=m,__FUNCTION__+": Length(D)=n,__FUNCTION__+": Length(U)=0,__FUNCTION__+": D[] contains negative elements")) return; //--- check if(!CAp::Assert(d[i]<=i,__FUNCTION__+": D[I]>I for some I")) return; } for(i=0; i=0,__FUNCTION__+": U[] contains negative elements")) return; //--- check if(!CAp::Assert(u[i]<=i,__FUNCTION__+": U[I]>I for some I")) return; } minmn=MathMin(m,n); s.m_MatrixType=2; s.m_NInitialized=0; s.m_M=m; s.m_N=n; CApServ::IVectorSetLengthAtLeast(s.m_RIdx,minmn+1); s.m_RIdx.Set(0,0); nz=0; for(i=0; i0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M<>N")) return; //--- check if(!CAp::Assert(CAp::Len(d)>=m,__FUNCTION__+": Length(D)=n,__FUNCTION__+": Length(U)=0,__FUNCTION__+": D[] contains negative elements")) return; //--- check if(!CAp::Assert(d[i]<=i,__FUNCTION__+": D[I]>I for some I")) return; } for(i=0; i=0,__FUNCTION__+": U[] contains negative elements")) return; //--- check if(!CAp::Assert(u[i]<=i,__FUNCTION__+": U[I]>I for some I")) return; } minmn=MathMin(m,n); s.m_MatrixType=2; s.m_NInitialized=0; s.m_M=m; s.m_N=n; CApServ::IVectorSetLengthAtLeast(s.m_RIdx,minmn+1); s.m_RIdx.Set(0,0); nz=0; for(i=0; i=1 | //| * M>=1 | //| BW - matrix bandwidth, BW>=0 | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in SKS representation. All elements | //| are filled by zeros. You may use SparseSet() to change| //| their values. | //| NOTE: this function completely overwrites S with new sparse | //| matrix. Previously allocated storage is NOT reused. If you | //| want to reuse already allocated memory, call | //| SparseCreateSKSBandBuf function. | //+------------------------------------------------------------------+ void CSparse::SparseCreateSKSBand(int m,int n,int bw, CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(bw>=0,__FUNCTION__+": BW<0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M!=N")) return; SparseCreateSKSBandBuf(m,n,bw,s); } //+------------------------------------------------------------------+ //| This is "buffered" version of SparseCreateSKSBand() which reuses | //| memory previously allocated in S(of course, memory is reallocated| //| if needed). | //| You may want to use this function instead of SparseCreateSKSBuf()| //| when your matrix has constant or nearly-constant bandwidth, and | //| you want to simplify source code. | //| INPUT PARAMETERS: | //| M, N - number of rows(M) and columns (N) in a matrix: | //| * M=N (as for now, ALGLIB supports only square SKS) | //| * N>=1 | //| * M>=1 | //| BW - bandwidth, BW>=0 | //| OUTPUT PARAMETERS: | //| S - sparse M*N matrix in SKS representation. All elements | //| are filled by zeros. You may use SparseSet() to change| //| their values. | //+------------------------------------------------------------------+ void CSparse::SparseCreateSKSBandBuf(int m,int n,int bw, CSparseMatrix &s) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(m==n,__FUNCTION__+": M!=N")) return; //--- check if(!CAp::Assert(bw>=0,__FUNCTION__+": BW<0")) return; //--- create variables int i=0; int minmn=MathMin(m,n); int nz=0; int mxd=0; int mxu=0; int dui=0; s.m_MatrixType=2; s.m_NInitialized=0; s.m_M=m; s.m_N=n; CApServ::IVectorSetLengthAtLeast(s.m_RIdx,minmn+1); s.m_RIdx.Set(0,0.0); for(i=0; i=0,__FUNCTION__+": I<0")) return; //--- check if(!CAp::Assert(i=M")) return; //--- check if(!CAp::Assert(j>=0,__FUNCTION__+": J<0")) return; //--- check if(!CAp::Assert(j=N")) return; //--- check if(!CAp::Assert(CMath::IsFinite(v) || v==0.0,__FUNCTION__+": V is not finite number")) return; //--- create variables int hashcode=0; int tcode=-1; int k=s.m_TableSize; if((double)((1-m_MaxLoadFactor)*k)>=(double)(s.m_NFree)) { SparseResizeMatrix(s); k=s.m_TableSize; } hashcode=Hash(i,j,k); while(true) { if(s.m_Idx[2*hashcode]==-1) { if(tcode!=-1) hashcode=tcode; s.m_Vals.Set(hashcode,v); s.m_Idx.Set(2*hashcode,i); s.m_Idx.Set(2*hashcode+1,j); if(tcode==-1) s.m_NFree--; return; } else { if(s.m_Idx[2*hashcode]==i && s.m_Idx[2*hashcode+1]==j) { s.m_Vals.Set(hashcode,s.m_Vals[hashcode]+v); if(s.m_Vals[hashcode]==0.0) s.m_Idx.Set(2*hashcode,-2); return; } //--- Is it deleted element? if(tcode==-1 && s.m_Idx[2*hashcode]==-2) tcode=hashcode; //--- Next step hashcode=(hashcode+1)%k; } } } //+------------------------------------------------------------------+ //| This function modifies S[i,j] - element of the sparse matrix. | //| For Hash-based storage format: | //| * this function can be called at any moment - during matrix | //| initialization or later | //| * new value can be zero or non-zero. In case new value of S[i,j] | //| is zero, this element is deleted from the table. | //| * this function has no effect when called with zero V for | //| non-existent element. | //| For CRS-bases storage format: | //| * this function can be called ONLY DURING MATRIX INITIALIZATION | //| * zero values are stored in the matrix similarly to non-zero ones| //| * elements must be initialized in correct order - from top row | //| to bottom, within row - from left to right. | //| For SKS storage: | //| * this function can be called at any moment - during matrix | //| initialization or later | //| * zero values are stored in the matrix similarly to non-zero ones| //| * this function CAN NOT be called for non-existent (outside of | //| the band specified during SKS matrix creation) elements. Say, | //| if you created SKS matrix with bandwidth=2 and tried to call | //| SparseSet(s,0,10,VAL), an exception will be generated. | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in Hash-Table, SKS or CRS format. | //| I - row index of the element to modify, 0<=I=0,__FUNCTION__+": I<0")) return; //--- check if(!CAp::Assert(i=M")) return; //--- check if(!CAp::Assert(j>=0,__FUNCTION__+": J<0")) return; //--- check if(!CAp::Assert(j=N")) return; //--- check if(!CAp::Assert(CMath::IsFinite(v),__FUNCTION__+": V is not finite number")) return; //--- create variables int hashcode=0; int tcode=0; int k=0; bool b=false; //--- Hash-table matrix if(s.m_MatrixType==0) { tcode=-1; k=s.m_TableSize; if((double)((1-m_MaxLoadFactor)*k)>=(double)(s.m_NFree)) { SparseResizeMatrix(s); k=s.m_TableSize; } hashcode=Hash(i,j,k); while(true) { if(s.m_Idx[2*hashcode]==-1) { if((double)(v)!=0.0) { if(tcode!=-1) hashcode=tcode; s.m_Vals.Set(hashcode,v); s.m_Idx.Set(2*hashcode,i); s.m_Idx.Set(2*hashcode+1,j); if(tcode==-1) s.m_NFree--; } return; } else { if(s.m_Idx[2*hashcode]==i && s.m_Idx[2*hashcode+1]==j) { if(v==0.0) s.m_Idx.Set(2*hashcode,-2); else s.m_Vals.Set(hashcode,v); return; } if(tcode==-1 && s.m_Idx[2*hashcode]==-2) tcode=hashcode; //--- Next step hashcode=(hashcode+1)%k; } } } //--- CRS matrix if(s.m_MatrixType==1) { //--- check if(!CAp::Assert(s.m_RIdx[i]<=s.m_NInitialized,__FUNCTION__+": too few initialized elements at some row (you have promised more when called SparceCreateCRS)")) return; //--- check if(!CAp::Assert(s.m_RIdx[i+1]>s.m_NInitialized,__FUNCTION__+": too many initialized elements at some row (you have promised less when called SparceCreateCRS)")) return; //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[i] || s.m_Idx[s.m_NInitialized-1]=0,__FUNCTION__+": I<0")) return(0); //--- check if(!CAp::Assert(i=M")) return(0); //--- check if(!CAp::Assert(j>=0,__FUNCTION__+": J<0")) return(0); //--- check if(!CAp::Assert(j=N")) return(0); //--- create variables double result=0; int hashcode=0; int k=0; int k0=0; int k1=0; switch(s.m_MatrixType) { case 0: //--- Hash-based storage result=0; k=s.m_TableSize; hashcode=Hash(i,j,k); while(true) { if(s.m_Idx[2*hashcode]==-1) return(result); if(s.m_Idx[2*hashcode]==i && s.m_Idx[2*hashcode+1]==j) { result=s.m_Vals[hashcode]; break; } hashcode=(hashcode+1)%k; } break; case 1: //--- CRS //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return(-1); k0=s.m_RIdx[i]; k1=s.m_RIdx[i+1]-1; result=0; while(k0<=k1) { k=(k0+k1)/2; if(s.m_Idx[k]==j) { result=s.m_Vals[k]; break; } if(s.m_Idx[k]=0,__FUNCTION__+": I<0")) return(false); //--- check if(!CAp::Assert(i=M")) return(false); //--- check if(!CAp::Assert(j>=0,__FUNCTION__+": J<0")) return(false); //--- check if(!CAp::Assert(j=N")) return(false); //--- create variables bool result=false; int hashcode=0; int k=0; int k0=0; int k1=0; switch(s.m_MatrixType) { case 0: //--- Hash-based storage k=s.m_TableSize; hashcode=Hash(i,j,k); while(true) { if(s.m_Idx[2*hashcode]==-1) return(result); if(s.m_Idx[2*hashcode]==i && s.m_Idx[2*hashcode+1]==j) { result=true; break; } hashcode=(hashcode+1)%k; } break; case 1: //--- CRS //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return(false); k0=s.m_RIdx[i]; k1=s.m_RIdx[i+1]-1; while(k0<=k1) { k=(k0+k1)/2; if(s.m_Idx[k]==j) { result=true; break; } if(s.m_Idx[k]=0,__FUNCTION__+": I<0")) return(0); //--- check if(!CAp::Assert(i=M")) return(0); //--- check if(!CAp::Assert(i=N")) return(0); double result=0; switch(s.m_MatrixType) { case 0: result=SparseGet(s,i,i); break; case 1: if(s.m_DIdx[i]!=s.m_UIdx[i]) result=s.m_Vals[s.m_DIdx[i]]; break; case 2: //--- check if(!CAp::Assert(s.m_M==s.m_N,__FUNCTION__+": non-square SKS matrix not supported")) return(0); result=s.m_Vals[s.m_RIdx[i]+s.m_DIdx[i]]; break; default: if(!CAp::Assert(false,__FUNCTION__+": unexpected matrix type")) return(0); break; } return(result); } //+------------------------------------------------------------------+ //| This function calculates matrix-vector product S*x. Matrix S must| //| be stored in CRS or SKS format (exception will be thrown | //| otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in CRS or SKS format. | //| X - array[N], input vector. For performance reasons we | //| make only quick checks - we check that array size is | //| at least N, but we do not check for NAN's or INF's. | //| Y - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| OUTPUT PARAMETERS: | //| Y - array[M], S*x | //| NOTE: this function throws exception when called for | //| non-CRS/SKS matrix. You must convert your matrix with | //| SparseConvertToCRS/SKS() before using this function. | //+------------------------------------------------------------------+ void CSparse::SparseMV(CSparseMatrix &s,CRowDouble &x, CRowDouble &y) { //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_N,__FUNCTION__+": length(X)0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; v=v+vv; } y.Set(i,v); if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } } break; } } //+------------------------------------------------------------------+ //| This function calculates matrix-vector product S^T*x. Matrix S | //| must be stored in CRS or SKS format (exception will be thrown | //| otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in CRS or SKS format. | //| X - array[M], input vector. For performance reasons we | //| make only quick checks - we check that array size is | //| at least M, but we do not check for NAN's or INF's. | //| Y - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| OUTPUT PARAMETERS: | //| Y - array[N], S^T*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseMTV(CSparseMatrix &s,CRowDouble &x, CRowDouble &y) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_M,__FUNCTION__+": Length(X)0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } v=s.m_Vals[ri+d]*x[i]; if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; v=v+vv; } y.Set(i,v); } break; } } //+------------------------------------------------------------------+ //| This function calculates generalized sparse matrix-vector product| //| y := alpha*op(S)*x + beta*y | //| Matrix S must be stored in CRS or SKS format (exception will be | //| thrown otherwise). op(S) can be either S or S^T. | //| NOTE: this function expects Y to be large enough to store result.| //| No automatic preallocation happens for smaller arrays. | //| INPUT PARAMETERS: | //| S - sparse matrix in CRS or SKS format. | //| Alpha - source coefficient | //| OpS - operation type: | //| * OpS=0 => op(S) = S | //| * OpS=1 => op(S) = S^T | //| X - input vector, must have at least Cols(op(S))+IX | //| elements | //| IX - subvector offset | //| Beta - destination coefficient | //| Y - preallocated output array, must have at least | //| Rows(op(S))+IY elements | //| IY - subvector offset | //| OUTPUT PARAMETERS: | //| Y - elements [IY...IY+Rows(op(S))-1] are replaced by | //| result, other elements are not modified | //| HANDLING OF SPECIAL CASES: | //| * below M=Rows(op(S)) and N=Cols(op(S)). Although current | //| ALGLIB version does not allow you to create zero-sized sparse| //| matrices, internally ALGLIB can deal with such matrices. So, | //| comments for M or N equal to zero are for internal use only. | //| * if M=0, then subroutine does nothing. It does not even touch | //| arrays. | //| * if N=0 or Alpha=0.0, then: | //| * if Beta=0, then Y is filled by zeros. S and X are not | //| referenced at all. Initial values of Y are ignored (we do not| //| multiply Y by zero, we just rewrite it by zeros) | //| * if Beta<>0, then Y is replaced by Beta*Y | //| * if M>0, N>0, Alpha<>0, but Beta=0, then Y is areplaced by | //| alpha*op(S)*x initial state of Y is ignored (rewritten | //| without initial multiplication by zeros). | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseGemV(CSparseMatrix &s,double alpha,int ops, CRowDouble &x,int ix,double beta, CRowDouble &y,int iy) { //--- check if(!CAp::Assert(ops==0 || ops==1,__FUNCTION__+": incorrect OpS")) return; //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- create variables int opm=0; int opn=0; int rawm=0; int rawn=0; int i=0; int j=0; double tval=0; int lt=0; int rt=0; int ct=0; int d=0; int u=0; int ri=0; int ri1=0; double v=0; double vv=0; int lt1=0; int rt1=0; int i_=0; int i1_=0; if(ops==0) { opm=s.m_M; opn=s.m_N; } else { opm=s.m_N; opn=s.m_M; } //--- Quick exit strategies if(opm==0) return; //--- check if(!CAp::Assert(opm>=0 && opn>=0,__FUNCTION__+": op(S) has negative size")) return; //--- check if(!CAp::Assert(opn==0 || CAp::Len(x)+ix>=opn,__FUNCTION__+": X is too short")) return; //--- check if(!CAp::Assert(opm==0 || CAp::Len(y)+iy>=opm,__FUNCTION__+": X is too short")) return; rawm=s.m_M; rawn=s.m_N; if(beta!=0.0) { for(i=0; i=1, OpN>=1, Alpha<>0 if(ops==0) { //--- Compute generalized product y := alpha*S*x + beta*y //--- (with "beta*y" part already computed). switch(s.m_MatrixType) { case 1: //--- CRS format. //--- Perform integrity check. if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; //--- ALGLIB implementation for(i=0; i0) { lt=ri; rt=ri+d-1; lt1=i-d+ix; rt1=i-1+ix; i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; v=v+vv; } y.Set(i+iy,alpha*v+y[i+iy]); if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u+iy; rt1=i-1+iy; v=alpha*x[i+ix]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } } break; } } else { //--- Compute generalized product y := alpha*S^T*x + beta*y //--- (with "beta*y" part already computed). switch(s.m_MatrixType) { case 1: //--- CRS format //--- Perform integrity check. //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; //--- ALGLIB implementation for(i=0; i0) { lt=ri; rt=ri+d-1; lt1=i-d+iy; rt1=i-1+iy; v=alpha*x[i+ix]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } v=alpha*s.m_Vals[ri+d]*x[i+ix]; if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u+ix; rt1=i-1+ix; i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; v=v+alpha*vv; } y.Set(i+iy,v+y[i+iy]); } break; } } } //+------------------------------------------------------------------+ //| This function simultaneously calculates two matrix-vector | //| products: | //| S*x and S^T*x. | //| S must be square (non-rectangular) matrix stored in CRS or SKS | //| format (exception will be thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse N*N matrix in CRS or SKS format. | //| X - array[N], input vector. For performance reasons we | //| make only quick checks - we check that array size is | //| at least N, but we do not check for NAN's or INF's. | //| Y0 - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| Y1 - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| OUTPUT PARAMETERS: | //| Y0 - array[N], S*x | //| Y1 - array[N], S^T*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseMV2(CSparseMatrix &s,CRowDouble &x, CRowDouble &y0,CRowDouble &y1) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(s.m_M==s.m_N,__FUNCTION__+": matrix is non-square")) return; //--- create variables int l=CAp::Len(x); double tval=0; int i=0; int j=0; double vx=0; double vs=0; double v=0; double vv=0; double vd0=0; double vd1=0; int vi=0; int j0=0; int j1=0; int n=0; int ri=0; int ri1=0; int d=0; int u=0; int lt=0; int rt=0; int lt1=0; int rt1=0; int i_=0; int i1_=0; //--- check if(!CAp::Assert(l>=s.m_N,__FUNCTION__+": Length(X)0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y1.Set(i_,y1[i_]+v*s.m_Vals[i_+i1_]); i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; vd0=vd0+vv; } if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y0.Set(i_,y0[i_]+v*s.m_Vals[i_+i1_]); i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; vd1=vd1+vv; } y0.Set(i,vd0); y1.Set(i,vd1); } break; } } //+------------------------------------------------------------------+ //| This function calculates matrix-vector product S*x, when S is | //| symmetric matrix. Matrix S must be stored in CRS or SKS format | //| (exception will be thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*M matrix in CRS or SKS format. | //| IsUpper - whether upper or lower triangle of S is given: | //| * if upper triangle is given, only S[i,j] for j>=i | //| are used, and lower triangle is ignored (it can be | //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only S[i,j] for j<=i | //| are used, and upper triangle is ignored. | //| X - array[N], input vector. For performance reasons we | //| make only quick checks - we check that array size is| //| at least N, but we do not check for NAN's or INF's. | //| Y - output buffer, possibly preallocated.In case buffer| //| size is too small to store result, this buffer is| //| automatically resized. | //| OUTPUT PARAMETERS: | //| Y - array[M], S*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseSMV(CSparseMatrix &s,bool IsUpper, CRowDouble &x,CRowDouble &y) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_N,__FUNCTION__+": length(X)0 && !IsUpper) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; vd=vd+vv; } if(u>0 && IsUpper) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); i1_=(lt1)-(lt); vv=0.0; for(i_=lt; i_<=rt; i_++) vv+=s.m_Vals[i_]*x[i_+i1_]; vd=vd+vv; } y.Set(i,vd); } break; } } //+------------------------------------------------------------------+ //| This function calculates vector-matrix-vector product x'*S*x, | //| where S is symmetric matrix. Matrix S must be stored in CRS or | //| SKS format (exception will be thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*M matrix in CRS or SKS format. | //| IsUpper - whether upper or lower triangle of S is given: | //| * if upper triangle is given, only S[i,j] for j>=i | //| are used, and lower triangle is ignored (it can be | //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only S[i,j] for j<=i | //| are used, and upper triangle is ignored. | //| X - array[N], input vector. For performance reasons we | //| make only quick checks - we check that array size is| //| at least N, but we do not check for NAN's or INF's. | //| RESULT | //| x'*S*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ double CSparse::SparseVSMV(CSparseMatrix &s,bool IsUpper, CRowDouble &x) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return(0); //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_N,__FUNCTION__+": length(X)0 && !IsUpper) { lt=ri; rt=ri+d-1; lt1=i-d; k=d-1; v0=x[i]; v=0.0; for(j=0; j<=k; j++) v=v+x[lt1+j]*s.m_Vals[lt+j]; result=result+2*v0*v; } if(u>0 && IsUpper) { lt=ri1-u; rt=ri1-1; lt1=i-u; k=u-1; v0=x[i]; v=0.0; for(j=0; j<=k; j++) v=v+x[lt1+j]*s.m_Vals[lt+j]; result=result+2*v0*v; } } break; } return(result); } //+------------------------------------------------------------------+ //| This function calculates matrix-matrix product S*A. Matrix S must| //| be stored in CRS or SKS format (exception will be thrown | //| otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in CRS or SKS format. | //| A - array[N,K], input dense matrix. For performance | //| reasons we make only quick checks - we check that | //| array size is at least N, but we do not check for | //| NAN's or INF's. | //| K - number of columns of matrix (A). | //| B - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| OUTPUT PARAMETERS: | //| B - array[M,K], S*A | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseMM(CSparseMatrix &s,CMatrixDouble &a, int k,CMatrixDouble &b) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(a.Rows()>=s.m_N,__FUNCTION__+": Rows(A)0,__FUNCTION__+": K<=0")) return; //--- create variables double tval=0; double v=0; int id=0; int i=0; int j=0; int k0=0; int k1=k-1; int lt=0; int rt=0; int m=s.m_M; int n=s.m_N; int ri=0; int ri1=0; int lt1=0; int rt1=0; int d=0; int u=0; double vd=0; int i_=0; b=matrix::Zeros(m,k); switch(s.m_MatrixType) { case 1: //--- CRS format //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[m],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; if(k0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; if(k0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; if(k=s.m_M,__FUNCTION__+": Rows(A)0,__FUNCTION__+": K<=0")) return; //--- create variables int i=0; int j=0; int k0=0; int k1=k-1; int lt=0; int rt=0; int ct=0; double v=0; int m=s.m_M; int n=s.m_N; int ri=0; int ri1=0; int lt1=0; int rt1=0; int d=0; int u=0; int i_=0; b=matrix::Zeros(n,k); switch(s.m_MatrixType) { case 1: //--- CRS format //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[m],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; if(k0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,i,b,j); } } if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,j,b,i); } } v=s.m_Vals[ri+d]; CAblasF::RAddRR(k,v,a,i,b,i); } break; } } //+------------------------------------------------------------------+ //| This function simultaneously calculates two matrix-matrix | //| products: | //| S*A and S^T*A. | //| S must be square (non-rectangular) matrix stored in CRS or SKS | //| format (exception will be thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse N*N matrix in CRS or SKS format. | //| A - array[N,K], input dense matrix. For performance | //| reasons we make only quick checks - we check that | //| array size is at least N, but we do not check for | //| NAN's or INF's. | //| K - number of columns of matrix (A). | //| B0 - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| B1 - output buffer, possibly preallocated. In case buffer | //| size is too small to store result, this buffer is | //| automatically resized. | //| OUTPUT PARAMETERS: | //| B0 - array[N,K], S*A | //| B1 - array[N,K], S^T*A | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseMM2(CSparseMatrix &s,CMatrixDouble &a, int k,CMatrixDouble &b0,CMatrixDouble &b1) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(s.m_M==s.m_N,__FUNCTION__+": matrix is non-square")) return; //--- check if(!CAp::Assert(a.Rows()>=s.m_N,__FUNCTION__+": Rows(A)0,__FUNCTION__+": K<=0")) return; //--- create variables int i=0; int j=0; int k0=0; int lt=0; int rt=0; int ct=0; double v=0; double tval=0; int n=s.m_N; int k1=k-1; int ri=0; int ri1=0; int lt1=0; int rt1=0; int d=0; int u=0; int i_=0; b1=matrix::Zeros(n,k); b0=b1; switch(s.m_MatrixType) { case 1: //--- CRS format //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; //--- if(k0) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,j,b0,i); CAblasF::RAddRR(k,v,a,i,b1,j); } } if(u>0) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,i,b0,j); CAblasF::RAddRR(k,v,a,j,b1,i); } } v=s.m_Vals[ri+d]; CAblasF::RAddRR(k,v,a,i,b0,i); CAblasF::RAddRR(k,v,a,i,b1,i); } break; } } //+------------------------------------------------------------------+ //| This function calculates matrix-matrix product S*A, when S is | //| symmetric matrix. Matrix S must be stored in CRS or SKS format | //| (exception will be thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse M*M matrix in CRS or SKS format. | //| IsUpper - whether upper or lower triangle of S is given: | //| * if upper triangle is given, only S[i,j] for j>=i | //| are used, and lower triangle is ignored (it can be | //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only S[i,j] for j<=i | //| are used, and upper triangle is ignored. | //| A - array[N,K], input dense matrix. For performance | //| reasons we make only quick checks - we check that | //| array size is at least N, but we do not check for | //| NAN's or INF's. | //| K - number of columns of matrix (A). | //| B - output buffer, possibly preallocated. In case | //| buffer size is too small to store result, this | //| buffer is automatically resized. | //| OUTPUT PARAMETERS: | //| B - array[M,K], S*A | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseSMM(CSparseMatrix &s,bool IsUpper, CMatrixDouble &a,int k, CMatrixDouble &b) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(a.Rows()>=s.m_N,__FUNCTION__+": Rows(X)::Zeros(n,k); switch(s.m_MatrixType) { case 1: //--- CRS format //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; if(k>m_LinAlgSwitch) { for(i=0; i0 && !IsUpper) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,j,b,i); CAblasF::RAddRR(k,v,a,i,b,j); } } if(u>0 && IsUpper) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; for(j=lt1; j<=rt1; j++) { v=s.m_Vals[lt+(j-lt1)]; CAblasF::RAddRR(k,v,a,i,b,j); CAblasF::RAddRR(k,v,a,j,b,i); } } v=s.m_Vals[ri+d]; CAblasF::RAddRR(k,v,a,i,b,i); } break; } } //+------------------------------------------------------------------+ //| This function calculates matrix-vector product op(S)*x, when x is| //| vector, S is symmetric triangular matrix, op(S) is transposition | //| or no operation. | //| Matrix S must be stored in CRS or SKS format (exception will be | //| thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse square matrix in CRS or SKS format. | //| IsUpper - whether upper or lower triangle of S is used: | //| * if upper triangle is given, only S[i,j] for j>=i| //| are used, and lower triangle is ignored (it can be| //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only S[i,j] for j<=i| //| are used, and upper triangle is ignored. | //| IsUnit - unit or non-unit diagonal: | //| * if True, diagonal elements of triangular matrix are | //| considered equal to 1.0. Actual elements stored in| //| S are not referenced at all. | //| * if False, diagonal stored in S is used | //| OpType - operation type: | //| * if 0, S*x is calculated | //| * if 1, (S^T)*x is calculated (transposition) | //| X - array[N] which stores input vector. For performance| //| reasons we make only quick checks - we check that | //| array size is at least N, but we do not check for | //| NAN's or INF's. | //| Y - possibly preallocated input buffer. Automatically | //| resized if its size is too small. | //| OUTPUT PARAMETERS: | //| Y - array[N], op(S)*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //+------------------------------------------------------------------+ void CSparse::SparseTRMV(CSparseMatrix &s,bool IsUpper, bool IsUnit,int OpType,CRowDouble &x, CRowDouble &y) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(OpType==0 || OpType==1,__FUNCTION__+": incorrect operation type (must be 0 or 1)")) return; //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_N,__FUNCTION__+": Length(X)::Zeros(n); } switch(s.m_MatrixType) { case 1: //--- CRS format //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return; for(i=0; i0 && !IsUpper) { lt=ri; rt=ri+d-1; lt1=i-d; rt1=i-1; if(OpType==0) { i1_=(lt1)-(lt); v=0.0; for(i_=lt; i_<=rt; i_++) v+=s.m_Vals[i_]*x[i_+i1_]; y.Set(i,y[i]+v); } else { v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } } if(u>0 && IsUpper) { lt=ri1-u; rt=ri1-1; lt1=i-u; rt1=i-1; if(OpType==0) { v=x[i]; i1_=(lt)-(lt1); for(i_=lt1; i_<=rt1; i_++) y.Set(i_,y[i_]+v*s.m_Vals[i_+i1_]); } else { i1_=(lt1)-(lt); v=0.0; for(i_=lt; i_<=rt; i_++) v+=s.m_Vals[i_]*x[i_+i1_]; y.Set(i,y[i]+v); } } } break; } } //+------------------------------------------------------------------+ //| This function solves linear system op(S)*y=x where x is vector, S| //| is symmetric triangular matrix, op(S) is transposition or no | //| operation. | //| Matrix S must be stored in CRS or SKS format (exception will be | //| thrown otherwise). | //| INPUT PARAMETERS: | //| S - sparse square matrix in CRS or SKS format. | //| IsUpper - whether upper or lower triangle of S is used: | //| * if upper triangle is given, only S[i,j] for j>=i are| //| used, and lower triangle is ignored (it can be | //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only S[i,j] for j<=i are| //| used, and upper triangle is ignored. | //| IsUnit - unit or non-unit diagonal: | //| * if True, diagonal elements of triangular matrix are | //| considered equal to 1.0. Actual elements stored in S| //| are not referenced at all. | //| * if False, diagonal stored in S is used. It is your | //| responsibility to make sure that diagonal is non-zero| //| OpType - operation type: | //| * if 0, S*x is calculated | //| * if 1, (S^T)*x is calculated (transposition) | //| X - array[N] which stores input vector. For performance| //| reasons we make only quick checks - we check that | //| array size is at least N, but we do not check for | //| NAN's or INF's. | //| OUTPUT PARAMETERS: | //| X - array[N], inv(op(S))*x | //| NOTE: this function throws exception when called for non-CRS/SKS | //| matrix. | //| You must convert your matrix with SparseConvertToCRS/SKS() before| //| using this function. | //| NOTE: no assertion or tests are done during algorithm operation. | //| It is your responsibility to provide invertible matrix to | //| algorithm. | //+------------------------------------------------------------------+ void CSparse::SparseTRSV(CSparseMatrix &s,bool IsUpper, bool IsUnit,int OpType, CRowDouble &x) { //--- check if(!CAp::Assert(s.m_MatrixType==1 || s.m_MatrixType==2,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS/SKS)")) return; //--- check if(!CAp::Assert(OpType==0 || OpType==1,__FUNCTION__+": incorrect operation type (must be 0 or 1)")) return; //--- check if(!CAp::Assert(CAp::Len(x)>=s.m_N,__FUNCTION__+": Length(X)0 && i<=lst) || (stp<0 && i>=lst)) { //--- Select range of indexes to process if(IsUpper) { j0=s.m_UIdx[i]; j1=s.m_RIdx[i+1]-1; } else { j0=s.m_RIdx[i]; j1=s.m_DIdx[i]-1; } //--- Calculate X[I] v=0.0; for(j=j0; j<=j1; j++) v+=s.m_Vals[j]*x[s.m_Idx[j]]; if(!IsUnit) { if(s.m_DIdx[i]==s.m_UIdx[i]) vd=0; else vd=s.m_Vals[s.m_DIdx[i]]; } else vd=1.0; v=(x[i]-v)/vd; x.Set(i,v); v0=0.25*v0+v; //--- Next I i+=stp; } //--- check if(!CAp::Assert(CMath::IsFinite(v0),__FUNCTION__+": overflow or division by exact zero")) return; break; } if(OpType==1) { //--- Transposition. //--- (S^T)*x=y with upper or lower triangular S. if(IsUpper) { fst=0; lst=n-1; stp=1; } else { fst=n-1; lst=0; stp=-1; } i=fst; v0=0; while((stp>0 && i<=lst) || (stp<0 && i>=lst)) { v=x[i]; if(v!=0.0) { //--- X[i] already stores A[i,i]*Y[i], the only thing left //--- is to divide by diagonal element. if(!IsUnit) { if(s.m_DIdx[i]==s.m_UIdx[i]) vd=0; else vd=s.m_Vals[s.m_DIdx[i]]; } else vd=1.0; v=(vd!=0?v/vd:0); x.Set(i,v); v0=0.25*v0+v; //--- For upper triangular case: //--- subtract X[i]*Ai from X[i+1:N-1] //--- For lower triangular case: //--- subtract X[i]*Ai from X[0:i-1] //--- (here Ai is I-th row of original, untransposed A). if(IsUpper) { j0=s.m_UIdx[i]; j1=s.m_RIdx[i+1]-1; } else { j0=s.m_RIdx[i]; j1=s.m_DIdx[i]-1; } for(j=j0; j<=j1; j++) { k=s.m_Idx[j]; x.Set(k,x[k]-s.m_Vals[j]*v); } } //--- Next I i=i+stp; } //--- check if(!CAp::Assert(CMath::IsFinite(v0),__FUNCTION__+": overflow or division by exact zero")) return; break; } //--- check if(!CAp::Assert(false,__FUNCTION__+": internal error")) return; break; case 2: //--- SKS format //--- check if(!CAp::Assert(s.m_M==s.m_N,__FUNCTION__+": non-square SKS matrices are not supported")) return; if((OpType==0 && !IsUpper) || (OpType==1 && IsUpper)) { //--- Lower triangular op(S) (matrix itself can be upper triangular). v0=0; for(i=0; i=0; i--) { ri=s.m_RIdx[i]; ri1=s.m_RIdx[i+1]; d=s.m_DIdx[i]; u=s.m_UIdx[i]; //--- X[i] already stores A[i,i]*Y[i], the only thing left //--- is to divide by diagonal element. if(IsUnit) vd=1; else vd=s.m_Vals[ri+d]; v=x[i]/vd; x.Set(i,v); v0=0.25*v0+v; //--- Subtract product of X[i] and I-th column of "effective" A from //--- unprocessed variables. v=x[i]; if(IsUpper) { lt=i-u; lt1=ri1-u; k=u-1; } else { lt=i-d; lt1=ri; k=d-1; } for(j=0; j<=k; j++) x.Set(lt+j,x[lt+j]-v*s.m_Vals[lt1+j]); } //--- check if(!CAp::Assert(CMath::IsFinite(v0),__FUNCTION__+": overflow or division by exact zero")) return; break; } //--- check if(!CAp::Assert(false,__FUNCTION__+": internal error")) return; break; default: //--- check if(!CAp::Assert(false,__FUNCTION__+": internal error")) return; break; } } //+------------------------------------------------------------------+ //| This function applies permutation given by permutation table P | //| (as opposed to product form of permutation) to sparse symmetric | //| matrix A, given by either upper or lower triangle: B := P*A*P'| //| This function allocates completely new instance of B. Use | //| buffered version SparseSymmPermTblBuf() if you want to reuse | //| already allocated structure. | //| INPUT PARAMETERS: | //| A - sparse square matrix in CRS format. | //| IsUpper - whether upper or lower triangle of A is used: | //| * if upper triangle is given, only A[i,j] for j>=i| //| are used, and lower triangle is ignored (it can be| //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only A[i,j] for j<=i| //| are used, and upper triangle is ignored. | //| P - array[N] which stores permutation table; P[I]=J | //| means that I-th row/column of matrix A is moved to | //| J-th position. For performance reasons we do NOT | //| check that P[] is a correct permutation (that there| //| is no repetitions, just that all its elements are | //| in [0,N) range. | //| OUTPUT PARAMETERS: | //| B - permuted matrix. Permutation is applied to A from | //| the both sides, only upper or lower triangle | //| (depending on IsUpper) is stored. | //| NOTE: this function throws exception when called for non-CRS | //| matrix. You must convert your matrix with SparseConvertToCRS() | //| before using this function. | //+------------------------------------------------------------------+ void CSparse::SparseSymmPermTbl(CSparseMatrix &a,bool IsUpper, CRowInt &p,CSparseMatrix &b) { SparseSymmPermTblBuf(a,IsUpper,p,b); } //+------------------------------------------------------------------+ //| This function is a buffered version of SparseSymmPermTbl() that | //| reuses previously allocated storage in B as much as possible. | //| This function applies permutation given by permutation table P | //| (as opposed to product form of permutation) to sparse symmetric | //| matrix A, given by either upper or lower triangle: B := P*A*P'. | //| INPUT PARAMETERS: | //| A - sparse square matrix in CRS format. | //| IsUpper - whether upper or lower triangle of A is used: | //| * if upper triangle is given, only A[i,j] for j>=i| //| are used, and lower triangle is ignored (it can be| //| empty - these elements are not referenced at all). | //| * if lower triangle is given, only A[i,j] for j<=i| //| are used, and upper triangle is ignored. | //| P - array[N] which stores permutation table; P[I]=J | //| means that I-th row/column of matrix A is moved to | //| J-th position. For performance reasons we do NOT | //| check that P[] is a correct permutation (that there| //| is no repetitions, just that all its elements are | //| in [0,N) range. | //| B - sparse matrix object that will hold output. | //| Previously allocated memory will be reused as much | //| as possible. | //| OUTPUT PARAMETERS: | //| B - permuted matrix. Permutation is applied to A from | //| the both sides, only upper or lower triangle | //| (depending on IsUpper) is stored. | //| NOTE: this function throws exception when called for non-CRS | //| matrix. You must convert your matrix with SparseConvertToCRS() | //| before using this function. | //+------------------------------------------------------------------+ void CSparse::SparseSymmPermTblBuf(CSparseMatrix &a,bool IsUpper, CRowInt &p,CSparseMatrix &b) { //--- check if(!CAp::Assert(a.m_MatrixType==1,__FUNCTION__+": incorrect matrix type (convert your matrix to CRS)")) return; //--- check if(!CAp::Assert(CAp::Len(p)>=a.m_N,__FUNCTION__+": Length(P)=0) && p[i]k0) b.m_DIdx.Set(k1,b.m_DIdx[k1]+1); else b.m_DIdx.Set(k0,b.m_DIdx[k0]+1); } } } CApServ::IVectorSetLengthAtLeast(b.m_RIdx,n+1); b.m_RIdx.Set(0,0); for(i=0; ik0) { kk=k0; k0=k1; k1=kk; } dst=b.m_UIdx[k0]; b.m_Idx.Set(dst,k1); b.m_Vals.Set(dst,a.m_Vals[jj]); b.m_UIdx.Set(k0,dst+1); } } } //--- Finalize matrix for(i=0; i=0) k1=k1+1; } //--- Initialization value for free space s.m_TableSize=(int)MathRound(k1/m_DesiredLoadFactor*m_GrowFactor+m_Additional); s.m_NFree=s.m_TableSize-k1; tvals.Resize(s.m_TableSize); tidx.Resize(2*s.m_TableSize); CAp::Swap(s.m_Vals,tvals); CAp::Swap(s.m_Idx,tidx); for(i=0; i=0) SparseSet(s,tidx[2*i],tidx[2*i+1],tvals[i]); } //+------------------------------------------------------------------+ //| Procedure for initialization 'S.m_DIdx' and 'S.m_UIdx' | //+------------------------------------------------------------------+ void CSparse::SparseInitDUIdx(CSparseMatrix &s) { //--- check if(!CAp::Assert(s.m_MatrixType==1,__FUNCTION__+": internal error,incorrect matrix type")) return; //--- create variables int i=0; int j=0; int k=0; int lt=0; int rt=0; CApServ::IVectorSetLengthAtLeast(s.m_DIdx,s.m_M); CApServ::IVectorSetLengthAtLeast(s.m_UIdx,s.m_M); s.m_UIdx.Fill(-1,0,s.m_M); s.m_DIdx.Fill(-1,0,s.m_M); for(i=0; ii && s.m_UIdx[i]==-1) { s.m_UIdx.Set(i,j); break; } } if(s.m_UIdx[i]==-1) s.m_UIdx.Set(i,s.m_RIdx[i+1]); if(s.m_DIdx[i]==-1) s.m_DIdx.Set(i,s.m_UIdx[i]); } } //+------------------------------------------------------------------+ //| This function return average length of chain at hash-table. | //+------------------------------------------------------------------+ double CSparse::SparseGetAverageLengthofChain(CSparseMatrix &s) { //--- If matrix represent in CRS then return zero and exit if(s.m_MatrixType!=0) return(0); //--- create variables double result=0; int nchains=0; int talc=0; int l=s.m_TableSize; int i=0; int ind0=0; int ind1=0; int hashcode=0; for(i=0; i T0=0 | //| > T1=0 | //| > while SparseEnumerate(S,T0,T1,I,J,V) do | //| > ....do something with I,J,V | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in Hash-Table or CRS representation.| //| T0 - internal counter | //| T1 - internal counter | //| OUTPUT PARAMETERS: | //| T0 - new value of the internal counter | //| T1 - new value of the internal counter | //| I - row index of non-zero element, 0<=I=s.m_NInitialized) { t0=0; t1=0; result=false; break; } while(t0>s.m_RIdx[t1+1]-1 && t1=s.m_RIdx[s.m_M]) { t0=0; t1=0; result=false; break; } while(t0>s.m_RIdx[t1+1]-1 && t1=S.M)")) return(false); //--- check if(!CAp::Assert(0<=j && j=S.N)")) return(false); //--- check if(!CAp::Assert(CMath::IsFinite(v),__FUNCTION__+": invalid argument V(either V is infinite or V is NaN)")) return(false); //--- create variables bool result=false; int hashcode=0; int k=0; int k0=0; int k1=0; switch(s.m_MatrixType) { case 0: //--- Hash-table matrix k=s.m_TableSize; hashcode=Hash(i,j,k); while(true) { if(s.m_Idx[2*hashcode]==-1) return(result); if(s.m_Idx[2*hashcode]==i && s.m_Idx[2*hashcode+1]==j) { s.m_Vals.Set(hashcode,v); result=true; break; } hashcode=(hashcode+1)%k; } break; case 1: //--- CRS matrix //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return(false); k0=s.m_RIdx[i]; k1=s.m_RIdx[i+1]-1; while(k0<=k1) { k=(k0+k1)/2; if(s.m_Idx[k]==j) { s.m_Vals.Set(k,v); result=true; break; } if(s.m_Idx[k]=0 && i=M")) return; //--- create variables int i0=0; int j0=0; int j1=0; int j=0; int upperprofile=0; //--- Prepare output buffer irow=vector::Zeros(s.m_N); //--- Output switch(s.m_MatrixType) { case 1: for(i0=s.m_RIdx[i]; i0<=s.m_RIdx[i+1]-1; i0++) irow.Set(s.m_Idx[i0],s.m_Vals[i0]); break; case 2: //--- Copy subdiagonal and diagonal parts //--- check if(!CAp::Assert(s.m_N==s.m_M,__FUNCTION__+": non-square SKS matrices are not supported")) return; j0=i-s.m_DIdx[i]; i0=-j0+s.m_RIdx[i]; for(j=j0; j<=i; j++) irow.Set(j,s.m_Vals[j+i0]); //--- Copy superdiagonal part upperprofile=s.m_UIdx[s.m_N]; j0=i+1; j1=MathMin(s.m_N-1,i+upperprofile); for(j=j0; j<=j1; j++) if(j-i<=s.m_UIdx[j]) irow.Set(j,s.m_Vals[s.m_RIdx[j+1]-(j-i)]); break; } } //+------------------------------------------------------------------+ //| This function returns I-th row of the sparse matrix IN COMPRESSED| //| FORMAT - only non-zero elements are returned (with their indexes)| //| Matrix must be stored in CRS or SKS format. | //| INPUT PARAMETERS: | //| S - sparse M*N matrix in CRS format | //| I - row index, 0<=I=0 && i=M")) return; //--- create variables int k=0; int k0=0; int j=0; int j0=0; int j1=0; int i0=0; int upperprofile=0; //--- Initialize NZCnt NZCnt=0; switch(s.m_MatrixType) { case 1: //--- CRS matrix - just copy data NZCnt=s.m_RIdx[i+1]-s.m_RIdx[i]; CApServ::IVectorSetLengthAtLeast(ColIdx,NZCnt); CApServ::RVectorSetLengthAtLeast(Vals,NZCnt); k0=s.m_RIdx[i]; for(k=0; k<=NZCnt-1; k++) { ColIdx.Set(k,s.m_Idx[k0+k]); Vals.Set(k,s.m_Vals[k0+k]); } break; case 2: //--- SKS matrix - a bit more complex sequence //--- check if(!CAp::Assert(s.m_N==s.m_M,__FUNCTION__+": non-square SKS matrices are not supported")) return; //--- Allocate enough place for storage upperprofile=s.m_UIdx[s.m_N]; CApServ::IVectorSetLengthAtLeast(ColIdx,s.m_DIdx[i]+1+upperprofile); CApServ::RVectorSetLengthAtLeast(Vals,s.m_DIdx[i]+1+upperprofile); //--- Copy subdiagonal and diagonal parts j0=i-s.m_DIdx[i]; i0=-j0+s.m_RIdx[i]; for(j=j0; j<=i; j++) { ColIdx.Set(NZCnt,j); Vals.Set(NZCnt,s.m_Vals[j+i0]); NZCnt++; } //--- Copy superdiagonal part j0=i+1; j1=MathMin(s.m_N-1,i+upperprofile); for(j=j0; j<=j1; j++) { if(j-i<=s.m_UIdx[j]) { ColIdx.Set(NZCnt,j); Vals.Set(NZCnt,s.m_Vals[s.m_RIdx[j+1]-(j-i)]); NZCnt++; } } break; } } //+------------------------------------------------------------------+ //| This function performs efficient in-place transpose of SKS matrix| //| No additional memory is allocated during transposition. | //| This function supports only skyline storage format (SKS). | //| INPUT PARAMETERS: | //| S - sparse matrix in SKS format. | //| OUTPUT PARAMETERS: | //| S - sparse matrix, transposed. | //+------------------------------------------------------------------+ void CSparse::SparseTransposeSKS(CSparseMatrix &s) { //--- check if(!CAp::Assert(s.m_MatrixType==2,__FUNCTION__+": only SKS matrices are supported")) return; //--- check if(!CAp::Assert(s.m_M==s.m_N,__FUNCTION__+": non-square SKS matrices are not supported")) return; //--- create variables int n=s.m_N; int d=0; int u=0; int i=0; int k=0; int t0=0; int t1=0; double v=0; for(i=1; iu) { //--- Upper skyline height is less than lower skyline height. //--- Transposition becomes a bit tricky: we have to rearrange //--- "L0 L1 D U" to "U D L0 L1", where |L0|=|U|=u, |L1|=d-u. //--- In order to do this we perform a sequence of swaps and //--- in-place reversals: //---*swap(L0,U) => "U L1 D L0" //---*reverse("L1 D L0") => "U L0~ D L1~" (where X~ is a reverse of X) //---*reverse("L0~ D") => "U D L0 L1~" //---*reverse("L1") => "U D L0 L1" t0=s.m_RIdx[i]; t1=s.m_RIdx[i]+d+1; for(k=0; kt0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } t0=s.m_RIdx[i]+u; t1=t0+u; while(t1>t0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } t0=s.m_RIdx[i+1]-(d-u); t1=s.m_RIdx[i+1]-1; while(t1>t0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } } if(d "U1 D U0 L" //---*reverse("U1 D U0") => "U0~ D U1~ L" (where X~ is a reverse of X) //---*reverse("U0~") => "U0 D U1~ L" //---*reverse("D U1~") => "U0 U1 D L" t0=s.m_RIdx[i]; t1=s.m_RIdx[i+1]-d; for(k=0; kt0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } t0=s.m_RIdx[i]; t1=t0+u-d-1; while(t1>t0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } t0=s.m_RIdx[i]+u-d; t1=s.m_RIdx[i+1]-d-1; while(t1>t0) { v=s.m_Vals[t0]; s.m_Vals.Set(t0,s.m_Vals[t1]); s.m_Vals.Set(t1,v); t0=t0+1; t1=t1-1; } } } k=s.m_UIdx[n]; s.m_UIdx.Set(n,s.m_DIdx[n]); s.m_DIdx.Set(n,k); } //+------------------------------------------------------------------+ //| This function performs transpose of CRS matrix. | //| INPUT PARAMETERS: | //| S - sparse matrix in CRS format. | //| OUTPUT PARAMETERS: | //| S - sparse matrix, transposed. | //| NOTE: internal temporary copy is allocated for the purposes of | //| transposition. It is deallocated after transposition. | //+------------------------------------------------------------------+ void CSparse::SparseTransposeCRS(CSparseMatrix &s) { //--- check if(!CAp::Assert(s.m_MatrixType==1,"SparseTransposeCRS: only CRS matrices are supported")) return; //--- return result CRowDouble oldvals; CRowInt oldidx; CRowInt oldridx; int i=0; int j=0; int k=0; int nonne=0; int counts[]; int oldn=s.m_N; int oldm=s.m_M; int newn=oldm; int newm=oldn; CAp::Swap(s.m_Vals,oldvals); CAp::Swap(s.m_Idx,oldidx); CAp::Swap(s.m_RIdx,oldridx); //--- Update matrix size s.m_N=newn; s.m_M=newm; //--- Fill RIdx by number of elements per row: //--- RIdx[I+1] stores number of elements in I-th row. //--- Convert RIdx from row sizes to row offsets. //-- Set NInitialized nonne=0; CApServ::IVectorSetLengthAtLeast(s.m_RIdx,newm+1); s.m_RIdx.Fill(0,0,newm+1); for(i=0; i<=oldm-1; i++) { for(j=oldridx[i]; j<=oldridx[i+1]-1; j++) { k=oldidx[j]+1; s.m_RIdx.Set(k,s.m_RIdx[k]+1); nonne++; } } for(i=0; i<=newm-1; i++) s.m_RIdx.Set(i+1,s.m_RIdx[i+1]+s.m_RIdx[i]); s.m_NInitialized=s.m_RIdx[newm]; //--- Allocate memory and move elements to Vals/Idx. ArrayResize(counts,newm); ArrayFill(counts,0,newm,0); CApServ::RVectorSetLengthAtLeast(s.m_Vals,nonne); CApServ::IVectorSetLengthAtLeast(s.m_Idx,nonne); for(i=0; i=0) { s.m_RIdx.Set(tidx[2*i]+1,s.m_RIdx[tidx[2*i]+1]+1); nonne++; } for(i=0; i=0) { s.m_Vals.Set(s.m_RIdx[tidx[2*i]]+temp[tidx[2*i]],tvals[i]); s.m_Idx.Set(s.m_RIdx[tidx[2*i]]+temp[tidx[2*i]],tidx[2*i+1]); temp.Set(tidx[2*i],temp[tidx[2*i]]+1); } } for(i=0; i=0) { s1.m_RIdx.Set(s0.m_Idx[2*i]+1,s1.m_RIdx[s0.m_Idx[2*i]+1]+1); nonne=nonne+1; } //--- Fill RIdx (offsets of rows) for(i=0; i=0) { s1.m_Vals.Set(s1.m_RIdx[s0.m_Idx[2*i]]+temp[s0.m_Idx[2*i]],s0.m_Vals[i]); s1.m_Idx.Set(s1.m_RIdx[s0.m_Idx[2*i]]+temp[s0.m_Idx[2*i]],s0.m_Idx[2*i+1]); temp[s0.m_Idx[2*i]]=temp[s0.m_Idx[2*i]]+1; } //--- Set NInitialized s1.m_NInitialized=s1.m_RIdx[s1.m_M]; //--- Sorting of elements for(i=0; i::Zeros(tridx[n]); t0=0; t1=0; while(SparseEnumerate(s,t0,t1,i,j,v)) { if(j<=i) tvals.Set(tridx[i]+tdidx[i]-(i-j),v); else tvals.Set(tridx[j+1]-(j-i),v); } for(i=0; i::Zeros(s1.m_RIdx[n]); t0=0; t1=0; while(SparseEnumerate(s0,t0,t1,i,j,v)) { if(j<=i) s1.m_Vals.Set(s1.m_RIdx[i]+s1.m_DIdx[i]-(i-j),v); else s1.m_Vals.Set(s1.m_RIdx[j+1]-(j-i),v); } for(i=0; i=0,__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(s.m_N>=0,__FUNCTION__+": integrity check failed")) return; //--- create variables int i=0; int j=0; int j0=0; int j1=0; int m=s.m_M; int n=s.m_N; //--- Quick exit for M=0 or N=0 if(m==0 || n==0) { s.m_MatrixType=1; s.m_NInitialized=0; CApServ::IVectorSetLengthAtLeast(s.m_RIdx,s.m_M+1); CApServ::IVectorSetLengthAtLeast(s.m_DIdx,s.m_M); CApServ::IVectorSetLengthAtLeast(s.m_UIdx,s.m_M); s.m_RIdx.Fill(0,0,s.m_M+1); s.m_UIdx.Fill(0,0,s.m_M); s.m_DIdx.Fill(0,0,s.m_M); return; } //--- Perform integrity check //--- check if(!CAp::Assert(s.m_M>0,__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(s.m_N>0,__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(CAp::Len(s.m_RIdx)>=m+1,__FUNCTION__+": integrity check failed")) return; for(i=0; i=0 && s.m_RIdx[i]<=s.m_RIdx[i+1],__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(s.m_RIdx[m]<=CAp::Len(s.m_Idx),__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(s.m_RIdx[m]<=CAp::Len(s.m_Vals),__FUNCTION__+": integrity check failed")) return; for(i=0; i=0 && s.m_Idx[j]=0 && s.m_Idx[2*i0+1]>i) result=result+1; } break; case 1: //--- CRS matrix //--- check if(!CAp::Assert(s.m_NInitialized==s.m_RIdx[s.m_M],__FUNCTION__+": some rows/elements of the CRS matrix were not initialized (you must initialize everything you promised to SparseCreateCRS)")) return(-1); result=0; sz=s.m_M; for(i=0; i=0 && s.m_Idx[2*i0+1]=0) nused=nused+1; } s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); for(i=0; i=0) { s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); } } break; case 1: //--- Alloc CRS s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); CApServ::AllocIntegerArray(s,a.m_RIdx,a.m_M+1); CApServ::AllocIntegerArray(s,a.m_Idx,a.m_RIdx[a.m_M]); CApServ::AllocRealArray(s,a.m_Vals,a.m_RIdx[a.m_M]); break; case 2: //--- Alloc SKS //--- check if(!CAp::Assert(a.m_M==a.m_N,__FUNCTION__+": rectangular SKS serialization is not supported")) return; s.Alloc_Entry(); s.Alloc_Entry(); CApServ::AllocIntegerArray(s,a.m_RIdx,a.m_M+1); CApServ::AllocIntegerArray(s,a.m_DIdx,a.m_N+1); CApServ::AllocIntegerArray(s,a.m_UIdx,a.m_N+1); CApServ::AllocRealArray(s,a.m_Vals,a.m_RIdx[a.m_M]); break; } //--- End of stream s.Alloc_Entry(); } //+------------------------------------------------------------------+ //| Serializer: serialization | //| INTERNAL-ONLY FUNCTION, SUPPORTS ONLY CRS MATRICES | //+------------------------------------------------------------------+ void CSparse::SparseSerialize(CSerializer &s,CSparseMatrix &a) { if(a.m_MatrixType==-10082) return; //--- check if(!CAp::Assert((a.m_MatrixType==0 || a.m_MatrixType==1) || a.m_MatrixType==2,__FUNCTION__+": only CRS/SKS matrices are supported")) return; //--- create variables int i=0; int nused=0; //--- Header s.Serialize_Int(CSCodes::GetSparseMatrixSerializationCode()); s.Serialize_Int(a.m_MatrixType); s.Serialize_Int(0); //--- Serialize other parameters switch(a.m_MatrixType) { case 0: //--- Serialize Hash nused=0; for(i=0; i=0) nused=nused+1; } s.Serialize_Int(a.m_M); s.Serialize_Int(a.m_N); s.Serialize_Int(nused); for(i=0; i=0) { s.Serialize_Int(a.m_Idx[2*i+0]); s.Serialize_Int(a.m_Idx[2*i+1]); s.Serialize_Double(a.m_Vals[i]); } break; case 1: //--- Serialize CRS s.Serialize_Int(a.m_M); s.Serialize_Int(a.m_N); s.Serialize_Int(a.m_NInitialized); CApServ::SerializeIntegerArray(s,a.m_RIdx,a.m_M+1); CApServ::SerializeIntegerArray(s,a.m_Idx,a.m_RIdx[a.m_M]); CApServ::SerializeRealArray(s,a.m_Vals,a.m_RIdx[a.m_M]); break; case 2: //--- Serialize SKS //--- check if(!CAp::Assert(a.m_M==a.m_N,__FUNCTION__+": rectangular SKS serialization is not supported")) return; s.Serialize_Int(a.m_M); s.Serialize_Int(a.m_N); CApServ::SerializeIntegerArray(s,a.m_RIdx,a.m_M+1); CApServ::SerializeIntegerArray(s,a.m_DIdx,a.m_N+1); CApServ::SerializeIntegerArray(s,a.m_UIdx,a.m_N+1); CApServ::SerializeRealArray(s,a.m_Vals,a.m_RIdx[a.m_M]); break; } //--- End of stream s.Serialize_Int(117); } //+------------------------------------------------------------------+ //| Serializer: unserialization | //+------------------------------------------------------------------+ void CSparse::SparseUnserialize(CSerializer &s,CSparseMatrix &a) { //--- create variables int i=0; int i0=0; int i1=0; int m=0; int n=0; int nused=0; int k=0; double v=0; //--- Check stream header: scode, matrix type, version type k=s.Unserialize_Int(); //--- check if(!CAp::Assert(k==CSCodes::GetSparseMatrixSerializationCode(),__FUNCTION__+": stream header corrupted")) return; a.m_MatrixType=s.Unserialize_Int(); //--- check if(!CAp::Assert((a.m_MatrixType==0 || a.m_MatrixType==1) || a.m_MatrixType==2,__FUNCTION__+": unexpected matrix type")) return; k=s.Unserialize_Int(); //--- check if(!CAp::Assert(k==0,__FUNCTION__+": stream header corrupted")) return; //--- Unserialize other parameters switch(a.m_MatrixType) { case 0: //--- Unerialize Hash m=s.Unserialize_Int(); n=s.Unserialize_Int(); nused=s.Unserialize_Int(); SparseCreate(m,n,nused,a); for(i=0; i EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| N - problem dimensionality, N>0 | //| K - number of top eigenvector to calculate, 00,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(k>0,__FUNCTION__+": K<=0")) return; //--- check if(!CAp::Assert(k<=n,__FUNCTION__+": K>N")) return; EigSubSpaceCreateBuf(n,k,state); } //+------------------------------------------------------------------+ //| Buffered version of constructor which aims to reuse previously | //| allocated memory as much as possible. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceCreateBuf(int n,int k, CEigSubSpaceState &state) { //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; //--- check if(!CAp::Assert(k>0,__FUNCTION__+": K<=0")) return; //--- check if(!CAp::Assert(k<=n,__FUNCTION__+": K>N")) return; //--- Initialize algorithm parameters state.m_Running=false; state.m_N=n; state.m_K=k; state.m_NWork=MathMin(MathMax(2*k,8),n); state.m_EigenVectorsNeeded=1; state.m_UseWarmStart=false; state.m_FirstCall=true; EigSubSpaceSetCond(state,0.0,0); //--- Allocate temporaries CApServ::RMatrixSetLengthAtLeast(state.m_X,state.m_N,state.m_NWork); CApServ::RMatrixSetLengthAtLeast(state.m_AX,state.m_N,state.m_NWork); } //+------------------------------------------------------------------+ //| This function sets stopping critera for the solver: | //| * error in eigenvector/value allowed by solver | //| * maximum number of iterations to perform | //| INPUT PARAMETERS: | //| State - solver structure | //| Eps - eps>=0, with non-zero value used to tell solver | //| that it can stop after all eigenvalues converged | //| with error roughly proportional to | //| eps*MAX(LAMBDA_MAX), where LAMBDA_MAX is a maximum | //| eigenvalue. Zero value means that no check for | //| precision is performed. | //| MaxIts - maxits>=0, with non-zero value used to tell solver | //| that it can stop after maxits steps (no matter how | //| precise current estimate is) | //| NOTE: passing eps=0 and maxits=0 results in automatic selection | //| of moderate eps as stopping criteria (1.0E-6 in current | //| implementation, but it may change without notice). | //| NOTE: very small values of eps are possible (say, 1.0E-12), | //| although the larger problem you solve (N and/or K), the | //| harder it is to find precise eigenvectors because rounding | //| errors tend to accumulate. | //| NOTE: passing non-zero eps results in some performance penalty, | //| roughly equal to 2N*(2K)^2 FLOPs per iteration. These | //| additional computations are required in order to estimate | //| current error in eigenvalues via Rayleigh-Ritz process. | //| Most of this additional time is spent in construction of | //| ~2Kx2K symmetric subproblem whose eigenvalues are checked | //| with exact eigensolver. | //| This additional time is negligible if you search for | //| eigenvalues of the large dense matrix, but may become | //| noticeable on highly sparse EVD problems, where cost of | //| matrix-matrix product is low. | //| If you set eps to exactly zero, Rayleigh-Ritz phase is | //| completely turned off. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceSetCond(CEigSubSpaceState &state, double eps,int maxits) { //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is already running")) return; //--- check if(!CAp::Assert(CMath::IsFinite(eps) && (double)(eps)>=0.0,__FUNCTION__+": Eps<0 or NAN/INF")) return; //--- check if(!CAp::Assert(maxits>=0,__FUNCTION__+": MaxIts<0")) return; if((double)(eps)==0.0 && maxits==0) eps=1.0E-6; state.m_Eps=eps; state.m_MaxIts=maxits; } //+------------------------------------------------------------------+ //| This function sets warm-start mode of the solver: next call to | //| the solver will reuse previous subspace as warm-start point. It | //| can significantly speed-up convergence when you solve many | //| similar eigenproblems. | //| INPUT PARAMETERS: | //| State - solver structure | //| UseWarmStart - either True or False | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceSetWarmStart(CEigSubSpaceState &state, bool usewarmstart) { //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is already running")) return; state.m_UseWarmStart=usewarmstart; } //+------------------------------------------------------------------+ //| This function initiates out-of-core mode of subspace eigensolver.| //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| State - solver object | //| MType - matrix type: | //| * 0 for real symmetric matrix (solver assumes that matrix| //| being processed is symmetric; symmetric direct | //| eigensolver is used for smaller subproblems arising | //| during solution of larger "full" task) | //| Future versions of ALGLIB may introduce support for other| //| matrix types; for now, only symmetric eigenproblems are | //| supported. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceOOCStart(CEigSubSpaceState &state, int mtype) { //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is already running")) return; //--- check if(!CAp::Assert(mtype==0,__FUNCTION__+": incorrect mtype parameter")) return; state.m_RState.ia.Resize(7+1); state.m_RState.ra=vector::Zeros(1+1); state.m_RState.stage=-1; ClearRFields(state); state.m_Running=true; state.m_MatrixType=mtype; } //+------------------------------------------------------------------+ //| This function performs subspace iteration in the out-of-core mode| //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestdData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //+------------------------------------------------------------------+ bool CEigenVDetect::EigSubSpaceOOCContinue(CEigSubSpaceState &state) { //--- check if(!CAp::Assert(state.m_Running,__FUNCTION__+": solver is not running")) return(false); bool result=EigSubspaceIteration(state); state.m_Running=result; return(result); } //+------------------------------------------------------------------+ //| This function is used to retrieve information about out-of-core | //| request sent by solver to user code: request type (current | //| version of the solver sends only requests for matrix-matrix | //| products) and request size (size of the matrices being | //| multiplied). | //| This function returns just request metrics; in order to get | //| contents of the matrices being multiplied, use | //| EigSubSpaceOOCGetRequestData(). | //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| State - solver running in out-of-core mode | //| OUTPUT PARAMETERS: | //| RequestType - type of the request to process: | //| * 0 - for matrix-matrix product A*X, with A being | //| NxN matrix whose eigenvalues/vectors are needed,| //| and X being NxREQUESTSIZE one which is returned| //| by the eigsubspaceoocgetrequestdata(). | //| RequestSize - size of the X matrix (number of columns), | //| usually it is several times larger than number | //| of vectors K requested by user. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceOOCGetRequestInfo(CEigSubSpaceState &state, int &requesttype, int &requestsize) { //--- init variables requesttype=0; requestsize=0; //--- check if(!CAp::Assert(state.m_Running,__FUNCTION__+": solver is not running")) return; requesttype=state.m_RequestType; requestsize=state.m_RequestSize; } //+------------------------------------------------------------------+ //| This function is used to retrieve information about out-of-core | //| request sent by solver to user code: | //| matrix X(array[N,RequestSize]) | //| which have to be multiplied by out-of-core matrix A in a product | //| A*X. | //| This function returns just request data; in order to get size of | //| the data prior to processing requestm, use | //| EigSubSpaceOOCGetRequestInfo(). | //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| State - solver running in out-of-core mode | //| X - possibly preallocated storage; reallocated if | //| needed, left unchanged, if large enough to store| //| request data. | //| OUTPUT PARAMETERS: | //| X - array[N,RequestSize] or larger, leading | //| rectangle is filled with dense matrix X. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceOOCGetRequestData(CEigSubSpaceState &state, CMatrixDouble &x) { //--- check if(!CAp::Assert(state.m_Running,__FUNCTION__+": solver is not running")) return; x=state.m_X; } //+------------------------------------------------------------------+ //| This function is used to send user reply to out-of-core request | //| sent by solver. Usually it is product A*X for returned by solver | //| matrix X. | //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| State - solver running in out-of-core mode | //| AX - array[N,RequestSize] or larger, leading rectangle | //| is filled with product A*X. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceOOCSendResult(CEigSubSpaceState &state, CMatrixDouble &ax) { //--- check if(!CAp::Assert(state.m_Running,__FUNCTION__+": solver is not running")) return; state.m_AX=ax; } //+------------------------------------------------------------------+ //| This function finalizes out-of-core mode of subspace eigensolver.| //| It should be used in conjunction with other out-of-core-related | //| functions of this subspackage in a loop like below: | //| > EigSubSpaceOOCStart(state) | //| > while EigSubSpaceOOCContinue(state) do | //| > EigSubSpaceOOCGetRequestInfo(state, RequestType, M) | //| > EigSubSpaceOOCGetRequestData(state, X) | //| > [calculate Y=A*X, with X=R^NxM] | //| > EigSubSpaceOOCSendResult(state, Y) | //| > EigSubSpaceOOCStop(state, W, Z, Report) | //| INPUT PARAMETERS: | //| State - solver state | //| OUTPUT PARAMETERS: | //| W - array[K], depending on solver settings: | //| * top K eigenvalues ordered by descending - if | //| EigenVectors are returned in Z | //| * zeros - if invariant subspace is returned in Z | //| Z - array[N,K], depending on solver settings either: | //| * matrix of eigenvectors found | //| * orthogonal basis of K-dimensional invariant subspace| //| Rep - report with additional parameters | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceOOCStop(CEigSubSpaceState &state, CRowDouble &w, CMatrixDouble &z, CEigSubSpaceReport &rep) { w=vector::Zeros(0); z=matrix::Zeros(0,0); //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is still running")) return; w=state.m_RW; z=state.m_RQ; rep.m_IterationsCount=state.m_RepIterationsCount; } //+------------------------------------------------------------------+ //| This function runs subspace eigensolver for dense NxN symmetric | //| matrix A, given by its upper or lower triangle. | //| This function can not process nonsymmetric matrices. | //| INPUT PARAMETERS: | //| State - solver state | //| A - array[N,N], symmetric NxN matrix given by one of | //| its triangles | //| IsUpper - whether upper or lower triangle of A is given (the | //| other one is not referenced at all). | //| OUTPUT PARAMETERS: | //| W - array[K], top K EigenValues ordered by descending | //| of their absolute values | //| Z - array[N,K], matrix of eigenvectors found | //| Rep - report with additional parameters | //| NOTE: internally this function allocates a copy of NxN dense A. | //| You should take it into account when working with very large| //| matrices occupying almost all RAM. | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceSolveDenses(CEigSubSpaceState &state, CMatrixDouble &a, bool IsUpper, CRowDouble &w, CMatrixDouble &z, CEigSubSpaceReport &rep) { //--- create variables int n=0; int m=0; int i=0; int j=0; double v=0; CMatrixDouble acopy; w=vector::Zeros(0); z=matrix::Zeros(0,0); //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is still running")) return; n=state.m_N; //--- Allocate copy of A, copy one triangle to another acopy.Resize(n,n); for(i=0; i::Zeros(1+1); state.m_RState.stage=-1; ClearRFields(state); while(EigSubspaceIteration(state)) { //--- Calculate A*X with RMatrixGEMM //--- check if(!CAp::Assert(state.m_RequestType==0,__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(state.m_RequestSize>0,__FUNCTION__+": integrity check failed")) return; //--- m=state.m_RequestSize; CAblas::RMatrixGemm(n,m,n,1.0,acopy,0,0,0,state.m_X,0,0,0,0.0,state.m_AX,0,0); } w=state.m_RW; z=state.m_RQ; rep.m_IterationsCount=state.m_RepIterationsCount; } //+------------------------------------------------------------------+ //| This function runs EigenSolver for dense NxN symmetric matrix A, | //| given by upper or lower triangle. | //| This function can not process nonsymmetric matrices. | //| INPUT PARAMETERS: | //| State - solver state | //| A - NxN symmetric matrix given by one of its triangles | //| IsUpper - whether upper or lower triangle of A is given (the | //| other one is not referenced at all). | //| OUTPUT PARAMETERS: | //| W - array[K], top K eigenvalues ordered by descending | //| of their absolute values | //| Z - array[N,K], matrix of eigenvectors found | //| Rep - report with additional parameters | //+------------------------------------------------------------------+ void CEigenVDetect::EigSubSpaceSolveSparses(CEigSubSpaceState &state, CSparseMatrix &a, bool IsUpper, CRowDouble &w, CMatrixDouble &z, CEigSubSpaceReport &rep) { w=vector::Zeros(0); z=matrix::Zeros(0,0); //--- check if(!CAp::Assert(!state.m_Running,__FUNCTION__+": solver is still running")) return; state.m_MatrixType=0; state.m_RState.ia.Resize(7+1); state.m_RState.ra.Resize(1+1); state.m_RState.stage=-1; ClearRFields(state); while(EigSubspaceIteration(state)) { //--- check if(!CAp::Assert(state.m_RequestType==0,__FUNCTION__+": integrity check failed")) return; if(!CAp::Assert(state.m_RequestSize>0,__FUNCTION__+": integrity check failed")) return; CSparse::SparseSMM(a,IsUpper,state.m_X,state.m_RequestSize,state.m_AX); } w=state.m_RW; z=state.m_RQ; rep.m_IterationsCount=state.m_RepIterationsCount; } //+------------------------------------------------------------------+ //| Internal r-comm function. | //+------------------------------------------------------------------+ bool CEigenVDetect::EigSubspaceIteration(CEigSubSpaceState &state) { //--- create variables bool result; int n=0; int nwork=0; int k=0; int cnt=0; int i=0; int i1=0; int j=0; double vv=0; double v=0; int convcnt=0; //--- Reverse communication preparations //--- This code initializes locals by: //--- * random values determined during code //--- generation - on first subroutine call //--- * values from previous call - on subsequent calls if(state.m_RState.stage>=0) { n=state.m_RState.ia[0]; nwork=state.m_RState.ia[1]; k=state.m_RState.ia[2]; cnt=state.m_RState.ia[3]; i=state.m_RState.ia[4]; i1=state.m_RState.ia[5]; j=state.m_RState.ia[6]; convcnt=state.m_RState.ia[7]; vv=state.m_RState.ra[0]; v=state.m_RState.ra[1]; } else { n=359; nwork=-58; k=-919; cnt=-909; i=81; i1=255; j=74; convcnt=-788; vv=809; v=205; } if(state.m_RState.stage==0) { //--- Perform Rayleigh-Ritz step to estimate convergence of diagonal eigenvalues if(state.m_Eps>(double)0.0) { //--- check if(!CAp::Assert(state.m_MatrixType==0,__FUNCTION__+": integrity check failed")) return(false); CApServ::RMatrixSetLengthAtLeast(state.m_R,nwork,nwork); CAblas::RMatrixGemm(nwork,nwork,n,1.0,state.m_QCur,0,0,0,state.m_AX,0,0,0,0.0,state.m_R,0,0); if(!SMatrixEVD(state.m_R,nwork,0,true,state.m_WCur,state.m_Dummy)) { CAp::Assert(false,__FUNCTION__+": direct eigensolver failed to converge"); return(false); } state.m_WRank=state.m_WCur.Abs()+0; CBasicStatOps::RankXUntied(state.m_WRank,nwork,state.m_Buf); v=0; vv=0; for(j=0; j=(double)(nwork-k)) { v=MathMax(v,MathAbs(state.m_WCur[j]-state.m_WPrev[j])); vv=MathMax(vv,MathAbs(state.m_WCur[j])); } } if(vv==0.0) vv=1; if(v<=(state.m_Eps*vv)) convcnt++; else convcnt=0; state.m_WPrev=state.m_WCur; } //--- QR renormalization and update of QNew CAblas::RMatrixTranspose(n,nwork,state.m_AX,0,0,state.m_ZNew,0,0); COrtFac::RMatrixLQ(state.m_ZNew,nwork,n,state.m_Tau); COrtFac::RMatrixLQUnpackQ(state.m_ZNew,nwork,n,state.m_Tau,nwork,state.m_QNew); //--- Update iteration index state.m_RepIterationsCount++; } else { //--- Routine body n=state.m_N; k=state.m_K; nwork=state.m_NWork; //--- Initialize RNG. Deterministic initialization (with fixed //--- seed) is required because we need deterministic behavior //--- of the entire solver. CHighQualityRand::HQRndSeed(453,463664,state.m_RS); //--- Prepare iteration //--- Initialize QNew with random orthogonal matrix (or reuse its previous value). state.m_RepIterationsCount=0; CApServ::RMatrixSetLengthAtLeast(state.m_QCur,nwork,n); CApServ::RMatrixSetLengthAtLeast(state.m_QNew,nwork,n); CApServ::RMatrixSetLengthAtLeast(state.m_ZNew,nwork,n); CApServ::RVectorSetLengthAtLeast(state.m_WCur,nwork); CApServ::RVectorSetLengthAtLeast(state.m_WPrev,nwork); CApServ::RVectorSetLengthAtLeast(state.m_WRank,nwork); CApServ::RMatrixSetLengthAtLeast(state.m_X,n,nwork); CApServ::RMatrixSetLengthAtLeast(state.m_AX,n,nwork); CApServ::RMatrixSetLengthAtLeast(state.m_RQ,n,k); CApServ::RVectorSetLengthAtLeast(state.m_RW,k); CApServ::RMatrixSetLengthAtLeast(state.m_RZ,nwork,k); CApServ::RMatrixSetLengthAtLeast(state.m_R,nwork,nwork); state.m_WPrev.Fill(-1); if(!state.m_UseWarmStart || state.m_FirstCall) { //--- Use Q0 (either no warm start request, or warm start was //--- requested by user - but it is first call). if(state.m_FirstCall) { //--- First call, generate Q0 for(i=0; i=nwork-k; i--) { for(i1=0; i1=0). | //| W - array of the eigenvalues found. | //| Array whose index ranges within [0..M-1]. | //| Z - if ZNeeded is equal to: | //| * 0, Z hasn?t changed; | //| * 1, Z contains eigenvectors. | //| Array whose indexes range within | //| [0..N-1, 0..M-1]. | //| The eigenvectors are stored in the matrix | //| columns. | //| Result: | //| True, if successful. M contains the number of eigenvalues in | //| the given half-interval (could be equal to 0), W contains the| //| eigenvalues, Z contains the eigenvectors (if needed). | //| False, if the bisection method subroutine wasn't able to find| //| the eigenvalues in the given interval or if the inverse | //| iteration subroutine wasn't able to find all the | //| corresponding eigenvectors. In that case, the eigenvalues | //| and eigenvectors are not returned, M is equal to 0. | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixEVDR(CMatrixDouble &ca,const int n,const int zneeded, const bool IsUpper,const double b1,const double b2, int &m,double &w[],CMatrixDouble &z) { CRowDouble W; ArrayFree(w); if(!SMatrixEVDR(ca,n,zneeded,IsUpper,b1,b2,m,W,z)) return(false); return(W.ToArray(w)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixEVDR(CMatrixDouble &ca,const int n,const int zneeded, const bool IsUpper,const double b1,const double b2, int &m,CRowDouble &w,CMatrixDouble &z) { //--- create arrays CRowDouble tau; CRowDouble e; //--- create copy CMatrixDouble a=ca; //--- initialization m=0; //--- check if(!CAp::Assert(zneeded==0 || zneeded==1,__FUNCTION__+": incorrect ZNeeded")) return(false); //--- function call COrtFac::SMatrixTD(a,n,IsUpper,tau,w,e); //--- check if(zneeded==1) { //--- function call COrtFac::SMatrixTDUnpackQ(a,n,IsUpper,tau,z); } //--- return result return(SMatrixTdEVDR(w,e,n,zneeded,b1,b2,m,z)); } //+------------------------------------------------------------------+ //| Subroutine for finding the eigenvalues and eigenvectors of a | //| symmetric matrix with given indexes by using bisection and | //| inverse iteration methods. | //| Input parameters: | //| A - symmetric matrix which is given by its upper or | //| lower triangular part. Array whose indexes range | //| within [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| ZNeeded - flag controlling whether the eigenvectors are | //| needed or not. | //| If ZNeeded is equal to: | //| * 0, the eigenvectors are not returned; | //| * 1, the eigenvectors are returned. | //| isUpperA - storage format of matrix A. | //| I1, I2 - index interval for searching (from I1 to I2). | //| 0 <= I1 <= I2 <= N-1. | //| Output parameters: | //| W - array of the eigenvalues found. | //| Array whose index ranges within [0..I2-I1]. | //| Z - if ZNeeded is equal to: | //| * 0, Z hasn?t changed; | //| * 1, Z contains eigenvectors. | //| Array whose indexes range within | //| [0..N-1, 0..I2-I1]. | //| In that case, the eigenvectors are stored in the | //| matrix columns. | //| Result: | //| True, if successful. W contains the eigenvalues, Z contains | //| the eigenvectors (if needed). | //| False, if the bisection method subroutine wasn't able to find| //| the eigenvalues in the given interval or if the inverse | //| iteration subroutine wasn't able to find all the | //| corresponding eigenvectors. In that case, the eigenvalues | //| and eigenvectors are not returned. | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixEVDI(CMatrixDouble &ca,const int n,const int zneeded, const bool IsUpper,const int i1,const int i2, double &w[],CMatrixDouble &z) { CRowDouble W; ArrayFree(w); if(!SMatrixEVDI(ca,n,zneeded,IsUpper,i1,i2,W,z)) return(false); return (W.ToArray(w)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixEVDI(CMatrixDouble &ca,const int n,const int zneeded, const bool IsUpper,const int i1,const int i2, CRowDouble &w,CMatrixDouble &z) { //--- create arrays CRowDouble tau; CRowDouble e; //--- create copy CMatrixDouble a=ca; //--- check if(!CAp::Assert(zneeded==0 || zneeded==1,__FUNCTION__+": incorrect ZNeeded")) return(false); //--- function call COrtFac::SMatrixTD(a,n,IsUpper,tau,w,e); //--- check if(zneeded==1) { //--- function call COrtFac::SMatrixTDUnpackQ(a,n,IsUpper,tau,z); } //--- return result return(SMatrixTdEVDI(w,e,n,zneeded,i1,i2,z)); } //+------------------------------------------------------------------+ //| Finding the eigenvalues and eigenvectors of a Hermitian matrix | //| The algorithm finds eigen pairs of a Hermitian matrix by reducing| //| it to real tridiagonal form and using the QL/QR algorithm. | //| Input parameters: | //| A - Hermitian matrix which is given by its upper or | //| lower triangular part. | //| Array whose indexes range within | //| [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| IsUpper - storage format. | //| ZNeeded - flag controlling whether the eigenvectors are | //| needed or not. If ZNeeded is equal to: | //| * 0, the eigenvectors are not returned; | //| * 1, the eigenvectors are returned. | //| Output parameters: | //| D - eigenvalues in ascending order. | //| Array whose index ranges within [0..N-1]. | //| Z - if ZNeeded is equal to: | //| * 0, Z hasn?t changed; | //| * 1, Z contains the eigenvectors. | //| Array whose indexes range within | //| [0..N-1, 0..N-1]. | //| The eigenvectors are stored in the matrix | //| columns. | //| Result: | //| True, if the algorithm has converged. | //| False, if the algorithm hasn't converged (rare case). | //| Note: | //| eigenvectors of Hermitian matrix are defined up to | //| multiplication by a complex number L, such that |L|=1. | //+------------------------------------------------------------------+ bool CEigenVDetect::HMatrixEVD(CMatrixComplex &ca,const int n,int zneeded, const bool IsUpper,double &d[],CMatrixComplex &z) { CRowDouble D; ArrayFree(d); if(!HMatrixEVD(ca,n,zneeded,IsUpper,D,z)) return(false); return (D.ToArray(d)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::HMatrixEVD(CMatrixComplex &ca,const int n,int zneeded,const bool IsUpper,CRowDouble &d,CMatrixComplex &z) { //--- create variables int i=0; int j=0; bool result; //--- create arrays CRowComplex tau; CRowDouble e; //--- create matrix CMatrixDouble t; CMatrixDouble qz; CMatrixComplex q; //--- create copy CMatrixComplex a=ca; d=vector::Zeros(0); z=matrix::Zeros(0,0); //--- check if(!CAp::Assert(zneeded==0 || zneeded==1,__FUNCTION__+": incorrect ZNeeded")) return(false); //--- Reduce to tridiagonal form COrtFac::HMatrixTD(a,n,IsUpper,tau,d,e); //--- check if(zneeded==1) { //--- function call COrtFac::HMatrixTDUnpackQ(a,n,IsUpper,tau,q); zneeded=2; } //--- get result result=SMatrixTdEVD(d,e,n,zneeded,t); //--- Eigenvectors are needed //--- Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T if(result && zneeded!=0) { z.Resize(n,n); qz.Resize(n,2*n); //--- Calculate Re(Q)*T for(i=0; i=0 | //| W - array of the eigenvalues found. | //| Array whose index ranges within [0..M-1]. | //| Z - if ZNeeded is equal to: | //| * 0, Z hasn?t changed; | //| * 1, Z contains eigenvectors. | //| Array whose indexes range within | //| [0..N-1, 0..M-1]. | //| The eigenvectors are stored in the matrix | //| columns. | //| Result: | //| True, if successful. M contains the number of eigenvalues | //| in the given half-interval (could be equal to 0), W contains | //| the eigenvalues, Z contains the eigenvectors (if needed). | //| False, if the bisection method subroutine wasn't able to find| //| the eigenvalues in the given interval or if the inverse | //| iteration subroutine wasn't able to find all the | //| corresponding eigenvectors. In that case, the eigenvalues and| //| eigenvectors are not returned, M is equal to 0. | //| Note: | //| eigen vectors of Hermitian matrix are defined up to | //| multiplication by a complex number L, such as |L|=1. | //+------------------------------------------------------------------+ bool CEigenVDetect::HMatrixEVDR(CMatrixComplex &ca,const int n,int zneeded, bool IsUpper,const double b1,const double b2, int &m,double &w[],CMatrixComplex &z) { //--- create variables int i=0; int k=0; double v=0; int i_=0; bool result; //--- create arrays complex tau[]; double e[]; double work[]; //--- create matrix CMatrixComplex q; CMatrixDouble t; //--- create copy CMatrixComplex a; a=ca; //--- initialization m=0; //--- check if(!CAp::Assert(zneeded==0 || zneeded==1,__FUNCTION__+": incorrect ZNeeded")) return(false); //--- Reduce to tridiagonal form COrtFac::HMatrixTD(a,n,IsUpper,tau,w,e); //--- check if(zneeded==1) { //--- function call COrtFac::HMatrixTDUnpackQ(a,n,IsUpper,tau,q); zneeded=2; } //--- Bisection and inverse iteration result=SMatrixTdEVDR(w,e,n,zneeded,b1,b2,m,t); //--- Eigenvectors are needed //--- Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T if((result && zneeded!=0) && m!=0) { ArrayResize(work,m); z.Resize(n,m); for(i=0; i=1,__FUNCTION__+": N<=0")) return(false); if(!CAp::Assert(zneeded>=0 && zneeded<=3,__FUNCTION__+": incorrect ZNeeded")) return(false); result=false; //--- Preprocess Z: make ZNeeded equal to 0, 1 or 3. //--- Ensure that memory for Z is allocated. if(zneeded==2) { //--- Load identity to Z CApServ::RMatrixSetLengthAtLeast(z,n,n); z=matrix::Identity(n,n); zneeded=1; } if(zneeded==3) { //--- Allocate memory CApServ::RMatrixSetLengthAtLeast(z,1,n); } //--- Prepare 1-based task d1=vector::Zeros(n+1); e1=vector::Zeros(n+1); i1_=-1; for(i_=1; i_<=n; i_++) d1.Set(i_,d[i_+i1_]); if(n>1) { for(i_=1; i_=0. | //| ZNeeded - flag controlling whether the eigenvectors are | //| needed or not. If ZNeeded is equal to: | //| * 0, the eigenvectors are not needed; | //| * 1, the eigenvectors of a tridiagonal matrix | //| are multiplied by the square matrix Z. It is | //| used if the tridiagonal matrix is obtained by | //| the similarity transformation of a symmetric | //| matrix. | //| * 2, the eigenvectors of a tridiagonal matrix | //| replace matrix Z. | //| A, B - half-interval (A, B] to search eigenvalues in. | //| Z - if ZNeeded is equal to: | //| * 0, Z isn't used and remains unchanged; | //| * 1, Z contains the square matrix (array whose | //| indexes range within [0..N-1, 0..N-1]) which | //| reduces the given symmetric matrix to | //| tridiagonal form; | //| * 2, Z isn't used (but changed on the exit). | //| Output parameters: | //| D - array of the eigenvalues found. | //| Array whose index ranges within [0..M-1]. | //| M - number of eigenvalues found in the given | //| half-interval (M>=0). | //| Z - if ZNeeded is equal to: | //| * 0, doesn't contain any information; | //| * 1, contains the product of a given NxN matrix | //| Z (from the left) and NxM matrix of the | //| eigenvectors found (from the right). Array | //| whose indexes range within [0..N-1, 0..M-1]. | //| * 2, contains the matrix of the eigenvectors | //| found. Array whose indexes range within | //| [0..N-1, 0..M-1]. | //| Result: | //| True, if successful. In that case, M contains the number of | //| eigenvalues in the given half-interval (could be equal to 0),| //| D contains the eigenvalues, Z contains the eigenvectors (if | //| needed). It should be noted that the subroutine changes the | //| size of arrays D and Z. | //| False, if the bisection method subroutine wasn't able to find| //| the eigenvalues in the given interval or if the inverse | //| iteration subroutine wasn't able to find all the | //| corresponding eigenvectors. In that case, the eigenvalues and| //| eigenvectors are not returned, M is equal to 0. | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixTdEVDR(double &d[],double &e[],const int n, const int zneeded,const double a, const double b,int &m,CMatrixDouble &z) { CRowDouble D=d; CRowDouble E=e; if(!SMatrixTdEVDR(D,E,n,zneeded,a,b,m,z)) return(false); return(D.ToArray(d)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixTdEVDR(CRowDouble &d,CRowDouble &e,const int n, const int zneeded,const double a, const double b,int &m,CMatrixDouble &z) { //--- create variables bool result; int errorcode=0; int nsplit=0; int i=0; int j=0; int k=0; int cr=0; double v=0; int i_=0; int i1_=0; //--- create arrays CRowInt iblock; CRowInt isplit; CRowInt ifail; CRowDouble d1; CRowDouble e1; CRowDouble w; //--- create matrix CMatrixDouble z2; CMatrixDouble z3; //--- initialization m=0; //--- check if(!CAp::Assert(zneeded>=0 && zneeded<=2,__FUNCTION__+": incorrect ZNeeded!")) return(false); //--- check if(b<=a) { m=0; //--- return result return(true); } //--- check if(n<=0) { m=0; //--- return result return(true); } //--- Copy D,E to D1, E1 d1.Resize(n+1); i1_=-1; for(i_=1; i_<=n; i_++) d1.Set(i_,d[i_+i1_]); //--- check if(n>1) { e1.Resize(n); i1_=-1; for(i_=1; i_=0. | //| ZNeeded - flag controlling whether the eigenvectors are | //| needed or not. If ZNeeded is equal to: | //| * 0, the eigenvectors are not needed; | //| * 1, the eigenvectors of a tridiagonal matrix | //| are multiplied by the square matrix Z. It is | //| used if the tridiagonal matrix is obtained by | //| the similarity transformation of a symmetric | //| matrix. | //| * 2, the eigenvectors of a tridiagonal matrix | //| replace matrix Z. | //| I1, I2 - index interval for searching (from I1 to I2). | //| 0 <= I1 <= I2 <= N-1. | //| Z - if ZNeeded is equal to: | //| * 0, Z isn't used and remains unchanged; | //| * 1, Z contains the square matrix (array whose | //| indexes range within [0..N-1, 0..N-1]) which | //| reduces the given symmetric matrix to | //| tridiagonal form; | //| * 2, Z isn't used (but changed on the exit). | //| Output parameters: | //| D - array of the eigenvalues found. | //| Array whose index ranges within [0..I2-I1]. | //| Z - if ZNeeded is equal to: | //| * 0, doesn't contain any information; | //| * 1, contains the product of a given NxN matrix | //| Z (from the left) and Nx(I2-I1) matrix of the | //| eigenvectors found (from the right). Array | //| whose indexes range within [0..N-1, 0..I2-I1].| //| * 2, contains the matrix of the eigenvalues | //| found. Array whose indexes range within | //| [0..N-1, 0..I2-I1]. | //| Result: | //| True, if successful. In that case, D contains the | //| eigenvalues, Z contains the eigenvectors (if needed). | //| It should be noted that the subroutine changes the size of | //| arrays D and Z. | //| False, if the bisection method subroutine wasn't able to find| //| the eigenvalues in the given interval or if the inverse | //| iteration subroutine wasn't able to find all the | //| corresponding eigenvectors. In that case, the eigenvalues and| //| eigenvectors are not returned. | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixTdEVDI(double &d[],double &e[],const int n, const int zneeded,const int i1, const int i2,CMatrixDouble &z) { CRowDouble D=d; CRowDouble E=e; if(!SMatrixTdEVDI(D,E,n,zneeded,i1,i2,z)) return(false); return(D.ToArray(d)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::SMatrixTdEVDI(CRowDouble &d,CRowDouble &e,const int n, const int zneeded,const int i1, const int i2,CMatrixDouble &z) { //--- create variables bool result; int errorcode=0; int nsplit=0; int i=0; int j=0; int k=0; int m=0; int cr=0; double v=0; int i_=0; int i1_=0; //--- create arrays CRowInt iblock; CRowInt isplit; CRowInt ifail; CRowDouble w; CRowDouble d1; CRowDouble e1; //--- create matrix CMatrixDouble z2; CMatrixDouble z3; //--- check if(!CAp::Assert((0<=i1 && i1<=i2) && i21) { e1.Resize(n); for(i_=1; i_0, we have a pair of complex conjugate | //| numbers with positive and negative imaginary | //| parts: the first eigenvalue WR[i] + | //| + sqrt(-1)*WI[i]; the second eigenvalue | //| WR[i+1] + sqrt(-1)*WI[i+1]; | //| WI[i]>0 | //| WI[i+1] = -WI[i] < 0 | //| In that case, the eigenvector corresponding to | //| the first eigenvalue is located in i and i+1 | //| columns of matrices VL/VR (the column number i | //| contains the real part, and the column number | //| i+1 contains the imaginary part), and the vector | //| corresponding to the second eigenvalue is a | //| complex conjugate to the first vector. | //| Arrays whose indexes range within | //| [0..N-1, 0..N-1]. | //| Result: | //| True, if the algorithm has converged. | //| False, if the algorithm has not converged. | //| Note 1: | //| Some users may ask the following question: what if WI[N-1]>0?| //| WI[N] must contain an eigenvalue which is complex conjugate | //| to the N-th eigenvalue, but the array has only size N? | //| The answer is as follows: such a situation cannot occur | //| because the algorithm finds a pairs of eigenvalues, | //| therefore, if WI[i]>0, I is strictly less than N-1. | //| Note 2: | //| The algorithm performance depends on the value of the | //| internal parameter NS of the InternalSchurDecomposition | //| subroutine which defines the number of shifts in the QR | //| algorithm (similarly to the block width in block-matrix | //| algorithms of linear algebra). If you require maximum | //| performance on your machine, it is recommended to adjust | //| this parameter manually. | //| See also the InternalTREVC subroutine. | //| The algorithm is based on the LAPACK 3.0 library. | //+------------------------------------------------------------------+ bool CEigenVDetect::RMatrixEVD(CMatrixDouble &ca,const int n,const int vneeded, double &wr[],double &wi[], CMatrixDouble &vl,CMatrixDouble &vr) { CRowDouble WR=wr; CRowDouble WI=wi; if(!RMatrixEVD(ca,n,vneeded,WR,WI,vl,vr)) return(false); return (WR.ToArray(wr) && WI.ToArray(wi)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CEigenVDetect::RMatrixEVD(CMatrixDouble &ca,const int n,const int vneeded, CRowDouble &wr,CRowDouble &wi, CMatrixDouble &vl,CMatrixDouble &vr) { //--- create variables int i=0; int info=0; int i_=0; int m1=0; bool result; //--- create arrays CRowDouble wr1; CRowDouble wi1; CRowDouble tau; bool sel1[]; //--- create matrix CMatrixDouble a1; CMatrixDouble vl1; CMatrixDouble vr1; CMatrixDouble s1; CMatrixDouble s; CMatrixDouble dummy; //--- create copy CMatrixDouble a=ca; wr.Resize(0); wi.Resize(0); vl.Resize(0,0); vr.Resize(0,0); //--- check if(!CAp::Assert(vneeded>=0 && vneeded<=3,__FUNCTION__+": incorrect VNeeded!")) return(false); if(vneeded==0) { //--- Eigen values only COrtFac::RMatrixHessenberg(a,n,tau); CHsSchur::RMatrixInternalSchurDecomposition(a,n,0,0,wr,wi,dummy,info); result=info==0; return(result); } //--- Eigen values and vectors COrtFac::RMatrixHessenberg(a,n,tau); COrtFac::RMatrixHessenbergUnpackQ(a,n,tau,s); CHsSchur::RMatrixInternalSchurDecomposition(a,n,1,1,wr,wi,s,info); result=info==0; if(!result) return(result); if(vneeded==1 || vneeded==3) vr= s; if(vneeded==2 || vneeded==3) vl=s; RMatrixInternalTREVC(a,n,vneeded,1,sel1,vl,vr,m1,info); result=info==0; //--- return result return(result); } //+------------------------------------------------------------------+ //| Clears request fileds (to be sure that we don't forgot to clear | //| something) | //+------------------------------------------------------------------+ void CEigenVDetect::ClearRFields(CEigSubSpaceState &state) { state.m_RequestType=-1; state.m_RequestSize=-1; } //+------------------------------------------------------------------+ //| Eigenvalues and eigenvectors in tridiagonal matrix | //+------------------------------------------------------------------+ bool CEigenVDetect::TriDiagonalEVD(CRowDouble &d,CRowDouble &ce,const int n, const int zneeded,CMatrixDouble &z) { //--- create variables bool result=false; int maxit=0; int i=0; int ii=0; int iscale=0; int j=0; int jtot=0; int k=0; int t=0; int l=0; int l1=0; int lend=0; int lendm1=0; int lendp1=0; int lendsv=0; int lm1=0; int lsv=0; int m=0; int mm1=0; int nm1=0; int nmaxit=0; int tmpint=0; double anorm=0; double b=0; double c=0; double eps=0; double eps2=0; double f=0; double g=0; double p=0; double r=0; double rt1=0; double rt2=0; double s=0; double safmax=0; double safmin=0; double ssfmax=0; double ssfmin=0; double tst=0; double tmp=0; CRowDouble work1; CRowDouble work2; CRowDouble workc; CRowDouble works; CRowDouble wtemp; bool gotoflag=false; int zrows=0; bool wastranspose=false; int i_=0; //--- copy CRowDouble e=ce; //--- check if(!CAp::Assert(zneeded>=0 && zneeded<=3,"TridiagonalEVD: Incorrent ZNeeded")) return(false); //--- Quick return if possible if(zneeded<0 || zneeded>3) return(false); result=true; if(n==0) return(result); if(n==1) { if(zneeded==2 || zneeded==3) { z=matrix::Zeros(2,2); z.Set(1,1,1); } return(result); } maxit=30; //--- Initialize arrays wtemp=vector::Zeros(n+1); work1=vector::Zeros(n); work2=vector::Zeros(n); workc=vector::Zeros(n+1); works=vector::Zeros(n+1); //--- Determine the unit roundoff and over/underflow thresholds. eps=CMath::m_machineepsilon; eps2=CMath::Sqr(eps); safmin=CMath::m_minrealnumber; safmax=CMath::m_maxrealnumber; ssfmax=MathSqrt(safmax)/3; ssfmin=MathSqrt(safmin)/eps2; //--- Prepare Z //--- Here we are using transposition to get rid of column operations wastranspose=false; zrows=0; switch(zneeded) { case 1: zrows=n; wastranspose=true; CBlas::InplaceTranspose(z,1,n,1,n,wtemp); break; case 2: zrows=n; wastranspose=true; z=matrix::Identity(n+1,n+1); z.Set(0,0,0); break; case 3: zrows=1; wastranspose=false; z=matrix::Zeros(2,n+1); z.Set(1,1,1); break; } nmaxit=n*maxit; jtot=0; //--- Determine where the matrix splits and choose QL or QR iteration //--- for each block, according to whether top or bottom diagonal //--- element is smaller. l1=1; nm1=n-1; while(true) { if(l1>n) break; if(l1>1) e.Set(l1-1,0); gotoflag=false; m=l1; if(l1<=nm1) for(m=l1; m<=nm1; m++) { tst=MathAbs(e[m]); if(tst==0.0) { gotoflag=true; break; } if(tst<=(MathSqrt(MathAbs(d[m]))*MathSqrt(MathAbs(d[m+1]))*eps)) { e.Set(m,0); gotoflag=true; break; } } if(!gotoflag) m=n; //--- l=l1; lsv=l; lend=m; lendsv=lend; l1=m+1; if(lend==l) continue; //--- Scale submatrix in rows and columns L to LEND anorm=MathMax(MathAbs(d[l])+MathAbs(e[l]),MathAbs(e[lend-1])+MathAbs(d[lend])); for(i=l+1; issfmax) { iscale=1; tmp=ssfmax/anorm; tmpint=lend-1; for(i_=l; i_<=lend; i_++) d.Mul(i_,tmp); for(i_=l; i_<=tmpint; i_++) e.Mul(i_,tmp); } if(anorml) { //--- QL Iteration //--- Look for small subdiagonal element. while(true) { gotoflag=false; if(l!=lend) { lendm1=lend-1; for(m=l; m<=lendm1; m++) { tst=CMath::Sqr(e[m]); if(tst<=(eps2*MathAbs(d[m])*MathAbs(d[m+1])+safmin)) { gotoflag=true; break; } } } if(!gotoflag) m=lend; if(m0) { TdEVDEv2(d[l],e[l],d[l+1],rt1,rt2,c,s); work1.Set(l,c); work2.Set(l,s); workc.Set(1,c); works.Set(1,s); if(!wastranspose) CRotations::ApplyRotationsFromTheRight(false,1,zrows,l,l+1,workc,works,z,wtemp); else CRotations::ApplyRotationsFromTheLeft(false,l,l+1,1,zrows,workc,works,z,wtemp); } else TdEVDE2(d[l],e[l],d[l+1],rt1,rt2); d.Set(l,rt1); d.Set(l+1,rt2); e.Set(l,0); l+=2; if(l<=lend) continue; break; } if(jtot==nmaxit) break; jtot++; //--- Form shift. g=(d[l+1]-p)/(2*e[l]); r=TdEVDPythag(g,1); g=d[m]-p+e[l]/(g+TdEVDExtSign(r,g)); s=1; c=1; p=0; //--- Inner loop mm1=m-1; for(i=mm1; i>=l; i--) { f=s*e[i]; b=c*e[i]; CRotations::GenerateRotation(g,f,c,s,r); if(i!=m-1) e.Set(i+1,r); g=d[i+1]-p; r=(d[i]-g)*s+2*c*b; p=s*r; d.Set(i+1,g+p); g=c*r-b; //--- If eigenvectors are desired, then save CRotations:: if(zneeded>0) { work1.Set(i,c); work2.Set(i,-s); } } //--- If eigenvectors are desired, then apply saved CRotations:: if(zneeded>0) { for(i=l; i=lendp1; m--) { tst=CMath::Sqr(MathAbs(e[m-1])); if(tst<=(MathAbs(eps2*d[m]*d[m-1])+safmin)) { gotoflag=true; break; } } } if(!gotoflag) m=lend; if(m>lend) e.Set(m-1,0); p=d[l]; if(m!=l) { //--- If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 //--- to compute its eigensystem. if(m==l-1) { if(zneeded>0) { TdEVDEv2(d[l-1],e[l-1],d[l],rt1,rt2,c,s); work1.Set(m,c); work2.Set(m,s); workc.Set(1,c); works.Set(1,s); if(!wastranspose) CRotations::ApplyRotationsFromTheRight(true,1,zrows,l-1,l,workc,works,z,wtemp); else CRotations::ApplyRotationsFromTheLeft(true,l-1,l,1,zrows,workc,works,z,wtemp); } else TdEVDE2(d[l-1],e[l-1],d[l],rt1,rt2); d.Set(l-1,rt1); d.Set(l,rt2); e.Set(l-1,0); l-=2; if(l>=lend) continue; break; } if(jtot==nmaxit) break; jtot++; //--- Form shift. g=(d[l-1]-p)/(2*e[l-1]); r=TdEVDPythag(g,1); g=d[m]-p+e[l-1]/(g+TdEVDExtSign(r,g)); s=1; c=1; p=0; //--- Inner loop lm1=l-1; for(i=m; i<=lm1; i++) { f=s*e[i]; b=c*e[i]; CRotations::GenerateRotation(g,f,c,s,r); if(i!=m) e.Set(i-1,r); g=d[i]-p; r=(d[i+1]-g)*s+2*c*b; p=s*r; d.Set(i,g+p); g=c*r-b; //--- If eigenvectors are desired, then save CRotations:: if(zneeded>0) { work1.Set(i,c); work2.Set(i,s); } } //--- If eigenvectors are desired, then apply saved CRotations:: if(zneeded>0) { for(i=m; i=lend) continue; break; } } //--- Undo scaling if necessary if(iscale==1) { tmp=anorm/ssfmax; tmpint=lendsv-1; for(i_=lsv; i_<=lendsv; i_++) d.Mul(i_,tmp); for(i_=lsv; i_<=tmpint; i_++) e.Mul(i_,tmp); } if(iscale==2) { tmp=anorm/ssfmin; tmpint=lendsv-1; for(i_=lsv; i_<=lendsv; i_++) d.Mul(i_,tmp); for(i_=lsv; i_<=tmpint; i_++) e.Mul(i_,tmp); } //--- Check for no convergence to an eigenvalue after a total //--- of N*MAXIT iterations. if(jtot>=nmaxit) { result=false; if(wastranspose) CBlas::InplaceTranspose(z,1,n,1,n,wtemp); return(result); } } //--- Order eigenvalues and eigenvectors. if(zneeded==0) { //--- Sort if(n==1) return(result); if(n==2) { if(d[1]>d[2]) d.Swap(1,2); return(result); } i=2; do { t=i; while(t!=1) { k=t/2; if(d[k]>=d[t]) t=1; else { d.Swap(k,t); t=k; } } i++; } while(i<=n); i=n-1; do { d.Swap(i+1,1); t=1; while(t!=0) { k=2*t; if(k>i) t=0; else { if(kd[k]) k++; if(d[t]>=d[k]) t=0; else { d.Swap(k,t); t=k; } } } i--; } while(i>=1); } else { //--- Use Selection Sort to minimize swaps of eigenvectors for(ii=2; ii<=n; ii++) { i=ii-1; k=i; p=d[i]; for(j=ii; j<=n; j++) if(d[j]MathAbs(c)) { acmx=a; acmn=c; } else { acmx=c; acmn=a; } //--- check if(adf>ab) { rt=adf*MathSqrt(1+CMath::Sqr(ab/adf)); } else { //--- check if(adf0.0) { rt1=0.5*(sm+rt); //--- Order of execution important. //--- To get fully accurate smaller eigenvalue, //--- next line needs to be executed in higher precision. rt2=acmx/rt1*acmn-b/rt1*b; } else { //--- Includes case RT1 = RT2 = 0 rt1=0.5*rt; rt2=-(0.5*rt); } } } //+------------------------------------------------------------------+ //| DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric | //| matrix | //| [ A B ] | //| [ B C ]. | //| On return, RT1 is the eigenvalue of larger absolute value, RT2 is| //| the eigenvalue of smaller absolute value, and (CS1,SN1) is the | //| unit right eigenvector for RT1, giving the decomposition | //| [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] | //| [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. | //| -- LAPACK auxiliary routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University| //| October 31, 1992 | //+------------------------------------------------------------------+ void CEigenVDetect::TdEVDEv2(const double a,const double b,const double c, double &rt1,double &rt2,double &cs1,double &sn1) { //--- create variables double sm=a+c; double df=a-c; double adf=MathAbs(df); double tb=b+b; double ab=MathAbs(tb); int sgn1=0; int sgn2=0; double acmn=0; double acmx=0; double acs=0; double cs=0; double ct=0; double rt=0; double tn=0; //--- initialization rt1=0; rt2=0; cs1=0; sn1=0; //--- Compute the eigenvalues if(MathAbs(a)>MathAbs(c)) { acmx=a; acmn=c; } else { acmx=c; acmn=a; } //--- check if(adf>ab) rt=adf*MathSqrt(1+CMath::Sqr(ab/adf)); else { //--- check if(adf0.0) { rt1=0.5*(sm+rt); sgn1=1; //--- Order of execution important. //--- To get fully accurate smaller eigenvalue, //--- next line needs to be executed in higher precision. rt2=acmx/rt1*acmn-b/rt1*b; } else { //--- Includes case RT1 = RT2 = 0 rt1=0.5*rt; rt2=-(0.5*rt); sgn1=1; } } //--- Compute the eigenvector if(df>=0.0) { cs=df+rt; sgn2=1; } else { cs=df-rt; sgn2=-1; } acs=MathAbs(cs); //--- check if(acs>ab) { ct=-(tb/cs); sn1=1/MathSqrt(1+ct*ct); cs1=ct*sn1; } else { //--- check if(ab==0.0) { cs1=1; sn1=0; } else { tn=-(cs/tb); cs1=1/MathSqrt(1+tn*tn); sn1=tn*cs1; } } //--- check if(sgn1==sgn2) { tn=cs1; cs1=-sn1; sn1=tn; } } //+------------------------------------------------------------------+ //| Internal routine | //+------------------------------------------------------------------+ double CEigenVDetect::TdEVDPythag(const double a,const double b) { //--- create variables double result=0; //--- check if(MathAbs(a)=0.0) result=MathAbs(a); else result=-MathAbs(a); //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ bool CEigenVDetect::InternalBisectionEigenValues(CRowDouble &cd,CRowDouble &ce, const int n,int irange, const int iorder,const double vl, const double vu,const int il, const int iu,const double abstol, CRowDouble &w,int &m, int &nsplit,CRowInt &iblock, CRowInt &isplit,int &errorcode) { //--- create variables bool result; double fudge=0; double relfac=0; bool ncnvrg; bool toofew; int ib=0; int ibegin=0; int idiscl=0; int idiscu=0; int ie=0; int iend=0; int iinfo=0; int im=0; int iin=0; int ioff=0; int iout=0; int itmax=0; int iw=0; int iwoff=0; int j=0; int itmp1=0; int jb=0; int jdisc=0; int je=0; int nwl=0; int nwu=0; int tmpi=0; double atoli=0; double bnorm=0; double gl=0; double gu=0; double pivmin=0; double rtoli=0; double safemn=0; double tmp1=0; double tmp2=0; double tnorm=0; double ulp=0; double wkill=0; double wl=0; double wlu=0; double wu=0; double wul=0; double scalefactor=0; double t=0; //--- create arrays CRowInt idumma; CRowDouble work; CRowInt iwork; CRowInt ia1s2; CRowDouble ra1s2; CRowDouble ra1siin; CRowDouble ra2siin; CRowDouble ra3siin; CRowDouble ra4siin; CRowInt iworkspace; CRowDouble rworkspace; //--- create matrix CMatrixDouble ra1s2x2; CMatrixInt ia1s2x2; CMatrixDouble ra1siinx2; CMatrixInt ia1siinx2; //--- create copy CRowDouble d=cd; CRowDouble e=ce; //--- initialization m=0; nsplit=0; errorcode=0; //--- Quick return if possible if(n==0) { iblock.Resize(0); isplit.Resize(0); return(true); } //--- Get machine constants //--- NB is the minimum vector length for vector bisection, or 0 //--- if only scalar is to be done. fudge=2; relfac=2; safemn=CMath::m_minrealnumber; ulp=2*CMath::m_machineepsilon; rtoli=ulp*relfac; //--- allocation idumma.Resize(2); work.Resize(4*n+1); iwork.Resize(3*n+1); w.Resize(n+1); iblock.Resize(n+1); isplit.Resize(n+1); ia1s2.Resize(3); ra1s2.Resize(3); ra1siin.Resize(n+1); ra2siin.Resize(n+1); ra3siin.Resize(n+1); ra4siin.Resize(n+1); iworkspace.Resize(n+1); rworkspace.Resize(n+1); ra1siinx2.Resize(n+1,3); ia1siinx2.Resize(n+1,3); ra1s2x2.Resize(3,3); ia1s2x2.Resize(3,3); //--- initialization wlu=0; wul=0; //--- Check for Errors result=false; errorcode=0; //--- check if(irange<=0 || irange>=4) errorcode=-4; if(iorder<=0 || iorder>=3) errorcode=-5; if(n<0) errorcode=-3; if(irange==2 && vl>=vu) errorcode=-6; if(irange==3 && (il<1 || il>MathMax(1,n))) errorcode=-8; if(irange==3 && (iun)) errorcode=-9; if(errorcode!=0) return(result); //--- Initialize error flags ncnvrg=false; toofew=false; //--- Simplifications: if(irange==3 && il==1 && iu==n) irange=1; //--- Special Case when N=1 if(n==1) { nsplit=1; isplit.Set(1,1); //--- check if((irange==2 && vl>=d[1]) || vuMathSqrt(MathSqrt(CMath::m_minrealnumber))*MathSqrt(CMath::m_maxrealnumber)) scalefactor=t; //--- check if(ttmp1) { isplit.Set(nsplit,j-1); nsplit++; work.Set(j-1,0); } else { work.Set(j-1,tmp1); pivmin=MathMax(pivmin,tmp1); } } isplit.Set(nsplit,n); pivmin=pivmin*safemn; //--- Compute Interval and ATOLI if(irange==3) { //--- RANGE='I': Compute the interval containing eigenvalues //--- IL through IU. //--- Compute Gershgorin interval for entire (split) matrix //--- and use it as the initial interval gu=d[1]; gl=d[1]; tmp1=0; for(j=1; j=n || nwu<1 || nwu>n) { errorcode=4; return(false); } } else { //--- RANGE='A' or 'V' -- Set ATOLI tnorm=MathMax(MathAbs(d[1])+MathAbs(e[1]),MathAbs(d[n])+MathAbs(e[n-1])); for(j=2; j=d[ibegin]-pivmin) nwl=nwl+1; //--- check if(irange==1 || wu>=d[ibegin]-pivmin) nwu=nwu+1; //--- check if((irange==1 || wl=d[ibegin]-pivmin) { m=m+1; w.Set(m,d[ibegin]); iblock.Set(m,jb); } } else { //--- General Case -- IIN > 1 //--- Compute Gershgorin Interval //--- and use it as the initial interval gu=d[ibegin]; gl=d[ibegin]; tmp1=0; for(j=ibegin; j1) { //--- check if(gu=gu) continue; } //--- Set Up Initial Interval work.Set(n+1,gl); work.Set(n+iin+1,gu); //--- Calling DLAEBZ //--- CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, //--- D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), //--- IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, //--- IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) for(tmpi=1; tmpi<=iin; tmpi++) { ra1siin.Set(tmpi,d[ibegin-1+tmpi]); //--- check if(ibegin-1+tmpiiout-iinfo) { ncnvrg=true; ib=-jb; } else ib=jb; for(je=iwork[j]+1+iwoff; je<=iwork[j+iin]+iwoff; je++) { w.Set(je,tmp1); iblock.Set(je,ib); } } m=m+im; } } //--- If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU //--- If NWL+1 < IL or NWU > IU, discard extra eigenvalues. if(irange==3) { im=0; idiscl=il-1-nwl; idiscu=nwu-iu; //--- check if(idiscl>0 || idiscu>0) { for(je=1; je<=m; je++) { //--- check if(w[je]<=wlu && idiscl>0) { idiscl=idiscl-1; } else { //--- check if(w[je]>=wul && idiscu>0) idiscu=idiscu-1; else { im++; w.Set(im,w[je]); iblock.Set(im,iblock[je]); } } } m=im; } //--- check if(idiscl>0 || idiscu>0) { //--- Code to deal with effects of bad arithmetic: //--- Some low eigenvalues to be discarded are not in (WL,WLU], //--- or high eigenvalues to be discarded are not in (WUL,WU] //--- so just kill off the smallest IDISCL/largest IDISCU //--- eigenvalues, by simply finding the smallest/largest //--- eigenvalue(s). //--- (If N(w) is monotone non-decreasing, this should never //--- happen.) if(idiscl>0) { wkill=wu; for(jdisc=1; jdisc<=idiscl; jdisc++) { iw=0; for(je=1; je<=m; je++) { //--- check if(iblock[je]!=0 && (w[je]<(double)(wkill) || iw==0)) { iw=je; wkill=w[je]; } } iblock.Set(iw,0); } } //--- check if(idiscu>0) { wkill=wl; for(jdisc=1; jdisc<=idiscu; jdisc++) { iw=0; for(je=1; je<=m; je++) { //--- check if(iblock[je]!=0 && (w[je]>(double)(wkill) || iw==0)) { iw=je; wkill=w[je]; } } iblock.Set(iw,0); } } im=0; for(je=1; je<=m; je++) { //--- check if(iblock[je]!=0) { im++; w.Set(im,w[je]); iblock.Set(im,iblock[je]); } } m=im; } //--- check if(idiscl<0 || idiscu<0) toofew=true; } //--- If ORDER='B', do nothing -- the eigenvalues are already sorted //--- by block. //--- If ORDER='E', sort the eigenvalues from smallest to largest if(iorder==1 && nsplit>1) { for(je=1; je<=m-1; je++) { ie=0; tmp1=w[je]; for(j=je+1; j<=m; j++) { //--- check if(w[j]n) { info=-4; return; } for(j=2; j<=m; j++) { //--- check if(iblock[j]1) { eps1=MathAbs(eps*xj); pertol=10*eps1; sep=xj-xjm; //--- check if(sepmaxits) { //--- If stopping criterion was not satisfied, update info and //--- store eigenvector number in array ifail. info=info+1; ifail.Set(info,j); break; } //--- Normalize and scale the righthand side vector Pb. v=0; for(ti=1; ti<=blksiz; ti++) v=v+MathAbs(work1[ti]); scl=blksiz*onenrm*MathMax(eps,MathAbs(work4[blksiz]))/v; CAblasF::RMulVX(blksiz,scl,work1,1); //--- Solve the system LU = Pb. TdIninternalDLAGTS(blksiz,work4,work2,work3,work5,iwork,work1,tol,iinfo); //--- Reorthogonalize by modified Gram-Schmidt if eigenvalues are //--- close enough. if(jblk!=1) { //--- check if(MathAbs(xj-xjm)>ortol) gpind=j; //--- check if(gpind!=j) { for(i=gpind; i::Zeros(n+1)); for(i=1; i<=blksiz; i++) z.Set(b1+i-1,j,work1[i]); //--- Save the shift to check eigenvalue spacing at next iteration. xjm=xj; } } } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CEigenVDetect::TdIninternalDLAGTF(const int n,CRowDouble &a,const double lambdav, CRowDouble &b,CRowDouble &c,double tol, CRowDouble &d,CRowInt &iin,int &info) { //--- create variables int k=0; double eps=0; double mult=0; double piv1=0; double piv2=0; double scale1=0; double scale2=0; double temp=0; double tl=0; //--- initialization info=0; //--- check if(n<0) { info=-1; return; } //--- check if(n==0) return; a.Set(1,a[1]-lambdav); iin.Set(n,0); //--- check if(n==1) { //--- check if(a[1]==0.0) iin.Set(1,1); //--- exit the function return; } //--- initialization eps=CMath::m_machineepsilon; tl=MathMax(tol,eps); scale1=MathAbs(a[1])+MathAbs(b[1]); for(k=1; k1) tol=MathMax(tol,MathMax(MathAbs(a[2]),MathAbs(b[1]))); for(k=3; k<=n; k++) tol=MathMax(tol,MathMax(MathAbs(a[k]),MathMax(MathAbs(b[k-1]),MathAbs(d[k-2])))); //--- check if(tol==0.0) tol=eps; else tol=tol*eps; } for(k=2; k<=n; k++) { //--- check if(iin[k-1]==0) y.Set(k,y[k]-c[k-1]*y[k-1]); else { temp=y[k-1]; y.Set(k-1,y[k]); y.Set(k,temp-c[k-1]*y[k]); } } for(k=n; k>=1; k--) { //--- check if(k<=n-2) temp=y[k]-b[k]*y[k+1]-d[k]*y[k+2]; else { //--- check if(k==n-1) temp=y[k]-b[k]*y[k+1]; else temp=y[k]; } ak=a[k]; pert=MathAbs(tol); //--- check if(ak<0.0) pert=-pert; while(true) { absak=MathAbs(ak); //--- check if(absak<1.0) { //--- check if(absakabsak) { ak=ak+pert; pert=2*pert; continue; } else { temp=temp*bignum; ak=ak*bignum; } } else { //--- check if(MathAbs(temp)>absak*bignum) { ak=ak+pert; pert=2*pert; continue; } } } //--- break the cycle break; } y.Set(k,temp/ak); } } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CEigenVDetect::InternalDLAEBZ(const int ijob,const int nitmax, const int n,const int mmax,const int minp, const double abstol,const double reltol, const double pivmin,CRowDouble &d, CRowDouble &e,CRowDouble &e2,CRowInt &nval, CMatrixDouble &ab,CRowDouble &c,int &mout, CMatrixInt &nab,CRowDouble &work, CRowInt &iwork,int &info) { //--- create variables int itmp1=0; int itmp2=0; int j=0; int ji=0; int jit=0; int jp=0; int kf=0; int kfnew=0; int kl=0; int klnew=0; double tmp1=0; double tmp2=0; //--- initialization mout=0; info=0; //--- check if(ijob<1 || ijob>3) { info=-1; //--- exit the function return; } //--- Initialize NAB if(ijob==1) { //--- Compute the number of eigenvalues in the initial intervals. mout=0; //--- DIR$ NOVECTOR for(ji=1; ji<=minp; ji++) { for(jp=1; jp<=2; jp++) { tmp1=d[1]-ab.Get(ji,jp); //--- check if(MathAbs(tmp1)=nval[ji]) { ab.Set(ji,2,tmp1); nab.Set(ji,2,itmp1); } } } kl=klnew; //--- Check for convergence kfnew=kf; for(ji=kf; ji<=kl; ji++) { tmp1=MathAbs(ab.Get(ji,2)-ab.Get(ji,1)); tmp2=MathMax(MathAbs(ab.Get(ji,2)),MathAbs(ab.Get(ji,1))); //--- check if(tmp1<(double)(MathMax(abstol,MathMax(pivmin,reltol*tmp2))) || nab.Get(ji,1)>=nab.Get(ji,2)) { //--- Converged -- Swap with position KFNEW, //--- then increment KFNEW if(ji>kfnew) { tmp1=ab.Get(ji,1); tmp2=ab.Get(ji,2); itmp1=nab.Get(ji,1); itmp2=nab.Get(ji,2); //--- change values ab.Set(ji,1,ab.Get(kfnew,1)); ab.Set(ji,2,ab.Get(kfnew,2)); nab[ji].Set(1,nab.Get(kfnew,1)); nab[ji].Set(2,nab.Get(kfnew,2)); ab.Set(kfnew,1,tmp1); ab.Set(kfnew,2,tmp2); nab.Set(kfnew,1,itmp1); nab.Set(kfnew,2,itmp2); //--- check if(ijob==3) nval.Swap(ji,kfnew); } kfnew++; } } kf=kfnew; //--- Choose Midpoints for(ji=kf; ji<=kl; ji++) c.Set(ji,0.5*(ab.Get(ji,1)+ab.Get(ji,2))); //--- If no more intervals to refine, quit. if(kf>kl) break; } //--- Converged info=(int)MathMax(kl+1-kf,0); mout=kl; } //+------------------------------------------------------------------+ //| Internal subroutine | //| -- LAPACK routine (version 3.0) -- | //| Univ. of Tennessee,Univ. of California Berkeley,NAG Ltd., | //| Courant Institute,Argonne National Lab, and Rice University | //| June 30,1999 | //+------------------------------------------------------------------+ void CEigenVDetect::RMatrixInternalTREVC(CMatrixDouble &t, int n,int side,int howmny,bool &vselect[], CMatrixDouble &vl,CMatrixDouble &vr,int &m,int &info) { int i=0; int j=0; CMatrixDouble t1; CMatrixDouble vl1; CMatrixDouble vr1; bool vselect1[]; m=0; info=0; //--- Allocate VL/VR, if needed if(howmny==2 || howmny==3) { if(side==1 || side==3) CApServ::RMatrixSetLengthAtLeast(vr,n,n); if(side==2 || side==3) CApServ::RMatrixSetLengthAtLeast(vl,n,n); } //--- ALGLIB version t1.Resize(n+1,n+1); for(i=0; i=1; ki--) { skipflag=false; //--- check if(ip==1) skipflag=true; else { //--- check if(ki!=1) { //--- check if(t.Get(ki,ki-1)!=0.0) ip=-1; } //--- check if(somev) { //--- check if(ip==0) { //--- check if(!vselect[ki]) skipflag=true; } else { //--- check if(!vselect[ki-1]) skipflag=true; } } } //--- check if(!skipflag) { //--- Compute the KI-th eigenvalue (WR,WI). wr=t.Get(ki,ki); wi=0; //--- check if(ip!=0) wi=MathSqrt(MathAbs(t.Get(ki,ki-1)))*MathSqrt(MathAbs(t.Get(ki-1,ki))); smin=MathMax(ulp*(MathAbs(wr)+MathAbs(wi)),smlnum); //--- check if(ip==0) { //--- Real right eigenvector work.Set(ki+n,1); //--- Form right-hand side for(k=1; k=1; j--) { //--- check if(j>jnxt) continue; j1=j; j2=j; jnxt=j-1; //--- check if(j>1) { //--- check if(t.Get(j,j-1)!=0.0) { j1=j-1; jnxt=j-2; } } //--- check if(j1==j2) { //--- 1-by-1 diagonal block temp11.Set(1,1,t.Get(j,j)); temp11b.Set(1,1,work[j+n]); //--- function call InternalHsEVDLALN2(false,1,1,smin,1,temp11,1.0,1.0,temp11b,wr,0.0,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr); //--- Scale X(1,1) to avoid overflow when updating //--- the right-hand side. if(xnorm>1.0) { //--- check if(work[j]>bignum/xnorm) { x.Set(1,1,x.Get(1,1)/xnorm); scl=scl/xnorm; } } //--- Scale if necessary if(scl!=1.0) CAblasF::RMulVX(ki,scl,work,n+1); work.Set(j+n,x.Get(1,1)); //--- Update right-hand side k1=1+n; k2=j-1+n; k3=j-1; vt=-x.Get(1,1); i1_=1-k1; for(i_=k1; i_<=k2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); } else { //--- 2-by-2 diagonal block temp22.Set(1,1,t.Get(j-1,j-1)); temp22.Set(1,2,t.Get(j-1,j)); temp22.Set(2,1,t.Get(j,j-1)); temp22.Set(2,2,t.Get(j,j)); temp21b.Set(1,1,work[j-1+n]); temp21b.Set(2,1,work[j+n]); //--- function call InternalHsEVDLALN2(false,2,1,smin,1.0,temp22,1.0,1.0,temp21b,wr,0,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr); //--- Scale X(1,1) and X(2,1) to avoid overflow when //--- updating the right-hand side. if(xnorm>1.0) { beta=MathMax(work[j-1],work[j]); //--- check if(beta>bignum/xnorm) { x.Set(1,1,x.Get(1,1)/xnorm); x.Set(2,1,x.Get(2,1)/xnorm); scl=scl/xnorm; } } //--- Scale if necessary if(scl!=1.0) CAblasF::RMulVX(ki,scl,work,n+1); work.Set(j-1+n,x.Get(1,1)); work.Set(j+n,x.Get(2,1)); //--- Update right-hand side k1=1+n; k2=j-2+n; k3=j-2; k4=j-1; vt=-x.Get(1,1); i1_=1-k1; for(i_=k1; i_<=k2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,k4)); vt=-x.Get(2,1); for(i_=k1; i_<=k2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); } } //--- Copy the vector x or Q*x to VR and normalize. if(!over) { k1=1+n; k2=ki+n; i1_=k1-1; for(i_=1; i_<=ki; i_++) vr.Set(i_,iis,work[i_+i1_]); //--- function call ii=CBlas::ColumnIdxAbsMax(vr,1,ki,iis); remax=1/MathAbs(vr.Get(ii,iis)); for(i_=1; i_<=ki; i_++) vr.Set(i_,iis,remax*vr.Get(i_,iis)); for(k=ki+1; k<=n; k++) vr.Set(k,iis,0); } else { //--- check if(ki>1) { temp=vr.Col(ki)+0; //--- function call CBlas::MatrixVectorMultiply(vr,1,n,1,ki-1,false,work,1+n,ki-1+n,1.0,temp,1,n,work[ki+n]); vr.Col(ki,temp.ToVector()+0); } //--- function call ii=CBlas::ColumnIdxAbsMax(vr,1,n,ki); remax=1/MathAbs(vr.Get(ii,ki)); vr.Col(ki,vr.Col(ki)*remax); } } else { //--- Complex right eigenvector. //--- Initial solve //--- [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. //--- [ (T(KI,KI-1) T(KI,KI) ) ] if(MathAbs(t.Get(ki-1,ki))>=MathAbs(t.Get(ki,ki-1))) { work.Set(ki-1+n,1); work.Set(ki+n2,wi/t.Get(ki-1,ki)); } else { work.Set(ki-1+n,-(wi/t.Get(ki,ki-1))); work.Set(ki+n2,1); } work.Set(ki+n,0); work.Set(ki-1+n2,0); //--- Form right-hand side for(k=1; k<=ki-2; k++) { work.Set(k+n,-(work[ki-1+n]*t.Get(k,ki-1))); work.Set(k+n2,-(work[ki+n2]*t.Get(k,ki))); } //--- Solve upper quasi-triangular system: //--- (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) jnxt=ki-2; for(j=ki-2; j>=1; j--) { //--- check if(j>jnxt) continue; j1=j; j2=j; jnxt=j-1; //--- check if(j>1) { //--- check if(t.Get(j,j-1)!=0.0) { j1=j-1; jnxt=j-2; } } //--- check if(j1==j2) { //--- 1-by-1 diagonal block temp11.Set(1,1,t.Get(j,j)); temp12b.Set(1,1,work[j+n]); temp12b.Set(1,2,work[j+n+n]); //--- function call InternalHsEVDLALN2(false,1,2,smin,1.0,temp11,1.0,1.0,temp12b,wr,wi,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr); //--- Scale X(1,1) and X(1,2) to avoid overflow when //--- updating the right-hand side. if(xnorm>1.0) { //--- check if(work[j]>bignum/xnorm) { x.Set(1,1,x.Get(1,1)/xnorm); x.Set(1,2,x.Get(1,2)/xnorm); scl=scl/xnorm; } } //--- Scale if necessary if(scl!=1.0) { CAblasF::RMulVX(ki,scl,work,n+1); CAblasF::RMulVX(ki,scl,work,n2+1); } work.Set(j+n,x.Get(1,1)); work.Set(j+n2,x.Get(1,2)); //--- Update the right-hand side k1=1+n; k2=j-1+n; k3=1; k4=j-1; vt=-x.Get(1,1); i1_=k3-k1; for(i_=k1; i_<=k2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); //--- change values k1=1+n2; k2=j-1+n2; k3=1; k4=j-1; vt=-x.Get(1,2); i1_=k3-k1; for(i_=k1; i_<=k2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); } else { //--- 2-by-2 diagonal block temp22.Set(1,1,t.Get(j-1,j-1)); temp22.Set(1,2,t.Get(j-1,j)); temp22.Set(2,1,t.Get(j,j-1)); temp22.Set(2,2,t.Get(j,j)); temp22b.Set(1,1,work[j-1+n]); temp22b.Set(1,2,work[j-1+n+n]); temp22b.Set(2,1,work[j+n]); temp22b.Set(2,2,work[j+n+n]); //--- function call InternalHsEVDLALN2(false,2,2,smin,1.0,temp22,1.0,1.0,temp22b,wr,wi,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr); //--- Scale X to avoid overflow when updating //--- the right-hand side. if(xnorm>1.0) { beta=MathMax(work[j-1],work[j]); //--- check if(beta>bignum/xnorm) { rec=1/xnorm; x.Set(1,1,x.Get(1,1)*rec); x.Set(1,2,x.Get(1,2)*rec); x.Set(2,1,x.Get(2,1)*rec); x.Set(2,2,x.Get(2,2)*rec); scl=scl*rec; } } //--- Scale if necessary if(scl!=1.0) { CAblasF::RMulVX(ki,scl,work,n+1); CAblasF::RMulVX(ki,scl,work,n2+1); } //--- change values work.Set(j-1+n,x.Get(1,1)); work.Set(j+n,x.Get(2,1)); work.Set(j-1+n2,x.Get(1,2)); work.Set(j+n2,x.Get(2,2)); //--- Update the right-hand side vt=-x.Get(1,1); i1_=-n; for(i_=n+1; i_<=n+j-2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j-1)); vt=-x.Get(2,1); i1_=-n; for(i_=n+1; i_<=n+j-2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); vt=-x.Get(1,2); i1_=-n2; for(i_=n2+1; i_<=n2+j-2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j-1)); vt=-x.Get(2,2); i1_=-n2; for(i_=n2+1; i_<=n2+j-2; i_++) work.Set(i_,work[i_]+vt*t.Get(i_+i1_,j)); } } //--- Copy the vector x or Q*x to VR and normalize. if(!over) { i1_=n; for(i_=1; i_<=ki; i_++) vr.Set(i_,iis-1,work[i_+i1_]); i1_=n2; for(i_=1; i_<=ki; i_++) vr.Set(i_,iis,work[i_+i1_]); emax=0; for(k=1; k<=ki; k++) emax=MathMax(emax,MathAbs(vr.Get(k,iis-1))+MathAbs(vr.Get(k,iis))); remax=1/emax; //--- copy for(i_=1; i_<=ki; i_++) vr.Set(i_,iis-1,remax*vr.Get(i_,iis-1)); for(i_=1; i_<=ki; i_++) vr.Set(i_,iis,remax*vr.Get(i_,iis)); for(k=ki+1; k<=n; k++) { vr.Set(k,iis-1,0); vr.Set(k,iis,0); } } else { //--- check if(ki>2) { temp=vr.Col(ki-1)+0; //--- function call CBlas::MatrixVectorMultiply(vr,1,n,1,ki-2,false,work,1+n,ki-2+n,1.0,temp,1,n,work[ki-1+n]); vr.Col(ki-1,temp.ToVector()+0); temp=vr.Col(ki)+0; //--- function call CBlas::MatrixVectorMultiply(vr,1,n,1,ki-2,false,work,1+n2,ki-2+n2,1.0,temp,1,n,work[ki+n2]); vr.Col(ki,temp); } else { vt=work[ki-1+n]; //--- copy vr.Col(ki-1,vr.Col(ki-1)*vt); vt=work[ki+n2]; vr.Col(ki,vr.Col(ki)*vt); } emax=0; for(k=1; k<=n; k++) emax=MathMax(emax,MathAbs(vr.Get(k,ki-1))+MathAbs(vr.Get(k,ki))); remax=1/emax; //--- copy vr.Col(ki-1,vr.Col(ki-1)*remax); vr.Col(ki,vr.Col(ki)*remax); } } iis=iis-1; //--- check if(ip!=0) iis=iis-1; } //--- check if(ip==1) ip=0; //--- check if(ip==-1) ip=1; } } //--- check if(leftv) { //--- Compute left eigenvectors. ip=0; iis=1; for(ki=1; ki<=n; ki++) { skipflag=false; //--- check if(ip==-1) skipflag=true; else { //--- check if(ki!=n) { //--- check if(t.Get(ki+1,ki)!=0.0) ip=1; } //--- check if(somev) { //--- check if(!vselect[ki]) skipflag=true; } } //--- check if(!skipflag) { //--- Compute the KI-th eigenvalue (WR,WI). wr=t.Get(ki,ki); wi=0; //--- check if(ip!=0) wi=MathSqrt(MathAbs(t.Get(ki,ki+1)))*MathSqrt(MathAbs(t.Get(ki+1,ki))); smin=MathMax(ulp*(MathAbs(wr)+MathAbs(wi)),smlnum); //--- check if(ip==0) { //--- Real left eigenvector. work.Set(ki+n,1); //--- Form right-hand side for(k=ki+1; k<=n; k++) work.Set(k+n,-t.Get(ki,k)); //--- Solve the quasi-triangular system: //--- (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK vmax=1; vcrit=bignum; jnxt=ki+1; for(j=ki+1; j<=n; j++) { //--- check if(jvcrit) { rec=1/vmax; for(i_=ki+n; i_<=n+n; i_++) work.Set(i_,rec*work[i_]); vmax=1; vcrit=bignum; } i1_=n; vt=0.0; for(i_=ki+1; i_vcrit) { rec=1/vmax; CAblasF::RMulVX(n-ki+1,rec,work,n+ki); vmax=1; vcrit=bignum; } i1_=n; vt=0.0; for(i_=ki+1; i_=MathAbs(t.Get(ki+1,ki))) { work.Set(ki+n,wi/t.Get(ki,ki+1)); work.Set(ki+1+n2,1); } else { work.Set(ki+n,1); work.Set(ki+1+n2,-(wi/t.Get(ki+1,ki))); } work.Set(ki+1+n,0); work.Set(ki+n2,0); //--- Form right-hand side for(k=ki+2; k<=n; k++) { work.Set(k+n,-(work[ki+n]*t.Get(ki,k))); work.Set(k+n2,-(work[ki+1+n2]*t.Get(ki+1,k))); } //--- Solve complex quasi-triangular system: //--- ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 vmax=1; vcrit=bignum; jnxt=ki+2; for(j=ki+2; j<=n; j++) { //--- check if(jvcrit) { rec=1/vmax; CAblasF::RMulVX(n-ki+1,rec,work,n+ki); CAblasF::RMulVX(n-ki+1,rec,work,n2+ki); vmax=1; vcrit=bignum; } i1_=n; vt=0.0; for(i_=ki+2; i_vcrit) { rec=1/vmax; CAblasF::RMulVX(n-ki+1,rec,work,n+ki); CAblasF::RMulVX(n-ki+1,rec,work,n2+1); vmax=1; vcrit=bignum; } i1_=n; vt=0.0; for(i_=ki+2; i_1.0) { //--- check if(bnorm>bignum*cnorm) scl=1/bnorm; } //--- Compute X x.Set(1,1,b.Get(1,1)*scl/csr); xnorm=MathAbs(x.Get(1,1)); } else { //--- Complex 1x1 system (w is complex) //--- C = ca A - w D csr=ca*a.Get(1,1)-wr*d1; csi=-(wi*d1); cnorm=MathAbs(csr)+MathAbs(csi); //--- If | C | < SMINI, use C = SMINI if(cnorm1.0) { //--- check if(bnorm>bignum*cnorm) scl=1/bnorm; } //--- Compute X InternalHsEVDLADIV(scl*b.Get(1,1),scl*b.Get(1,2),csr,csi,tmp1,tmp2); x.Set(1,1,tmp1); x.Set(1,2,tmp2); xnorm=MathAbs(x.Get(1,1))+MathAbs(x.Get(1,2)); } } else { //--- 2x2 System //--- Compute the real part of C = ca A - w D (or ca A' - w D ) crv4.Set(1,ca*a.Get(1,1)-wr*d1); crv4.Set(2+2,ca*a.Get(2,2)-wr*d2); //--- check if(ltrans) { crv4.Set(1+2,ca*a.Get(2,1)); crv4.Set(2,ca*a.Get(1,2)); } else { crv4.Set(2,ca*a.Get(2,1)); crv4.Set(1+2,ca*a.Get(1,2)); } //--- check if(nw==1) { //--- Real 2x2 system (w is real) //--- Find the largest element in C cmax=0; icmax=0; for(j=1; j<=4; j++) { //--- check if(MathAbs(crv4[j])>cmax) { cmax=MathAbs(crv4[j]); icmax=j; } } //--- If norm(C) < SMINI, use SMINI*identity. if(cmax1.0) { //--- check if(bnorm>bignum*smini) scl=1/bnorm; } //--- change values temp=scl/smini; x.Set(1,1,temp*b.Get(1,1)); x.Set(2,1,temp*b.Get(2,1)); xnorm=temp*bnorm; info=1; //--- exit the function return; } //--- Gaussian elimination with complete pivoting. ur11=crv4[icmax]; cr21=crv4[ipivot44.Get(2,icmax)]; ur12=crv4[ipivot44.Get(3,icmax)]; cr22=crv4[ipivot44.Get(4,icmax)]; ur11r=1/ur11; lr21=ur11r*cr21; ur22=cr22-ur12*lr21; //--- If smaller pivot < SMINI, use SMINI if(MathAbs(ur22)1.0 && MathAbs(ur22)<1.0) { //--- check if(bbnd>=bignum*MathAbs(ur22)) scl=1/bbnd; } xr2=br2*scl/ur22; xr1=scl*br1*ur11r-xr2*(ur11r*ur12); //--- check if(zswap4[icmax]) { x.Set(1,1,xr2); x.Set(2,1,xr1); } else { x.Set(1,1,xr1); x.Set(2,1,xr2); } xnorm=MathMax(MathAbs(xr1),MathAbs(xr2)); //--- Further scaling if norm(A) norm(X) > overflow if(xnorm>1.0 && cmax>1.0) { //--- check if(xnorm>bignum/cmax) { temp=cmax/bignum; x.Set(1,1,temp*x.Get(1,1)); x.Set(2,1,temp*x.Get(2,1)); xnorm=temp*xnorm; scl=temp*scl; } } } else { //--- Complex 2x2 system (w is complex) //--- Find the largest element in C civ4.Set(1,-(wi*d1)); civ4.Set(2,0); civ4.Set(1+2,0); civ4.Set(2+2,-(wi*d2)); cmax=0; icmax=0; for(j=1; j<=4; j++) { //--- check if(MathAbs(crv4[j])+MathAbs(civ4[j])>cmax) { cmax=MathAbs(crv4[j])+MathAbs(civ4[j]); icmax=j; } } //--- If norm(C) < SMINI, use SMINI*identity. if(cmax1.0) { //--- check if(bnorm>bignum*smini) scl=1/bnorm; } //--- change values temp=scl/smini; x.Set(1,1,temp*b.Get(1,1)); x.Set(2,1,temp*b.Get(2,1)); x.Set(1,2,temp*b.Get(1,2)); x.Set(2,2,temp*b.Get(2,2)); xnorm=temp*bnorm; info=1; //--- exit the function return; } //--- Gaussian elimination with complete pivoting. ur11=crv4[icmax]; ui11=civ4[icmax]; cr21=crv4[ipivot44.Get(2,icmax)]; ci21=civ4[ipivot44.Get(2,icmax)]; ur12=crv4[ipivot44.Get(3,icmax)]; ui12=civ4[ipivot44.Get(3,icmax)]; cr22=crv4[ipivot44.Get(4,icmax)]; ci22=civ4[ipivot44.Get(4,icmax)]; //--- check if(icmax==1 || icmax==4) { //--- Code when off-diagonals of pivoted C are real if(MathAbs(ur11)>MathAbs(ui11)) { temp=ui11/ur11; ur11r=1/(ur11*(1+CMath::Sqr(temp))); ui11r=-(temp*ur11r); } else { temp=ur11/ui11; ui11r=-(1/(ui11*(1+CMath::Sqr(temp)))); ur11r=-(temp*ui11r); } //--- change values lr21=cr21*ur11r; li21=cr21*ui11r; ur12s=ur12*ur11r; ui12s=ur12*ui11r; ur22=cr22-ur12*lr21; ui22=ci22-ur12*li21; } else { //--- Code when diagonals of pivoted C are real ur11r=1/ur11; ui11r=0; lr21=cr21*ur11r; li21=ci21*ur11r; ur12s=ur12*ur11r; ui12s=ui12*ur11r; ur22=cr22-ur12*lr21+ui12*li21; ui22=-(ur12*li21)-ui12*lr21; } u22abs=MathAbs(ur22)+MathAbs(ui22); //--- If smaller pivot < SMINI, use SMINI if(u22abs1.0 && u22abs<1.0) { //--- check if(bbnd>=bignum*u22abs) { //--- change values scl=1/bbnd; br1=scl*br1; bi1=scl*bi1; br2=scl*br2; bi2=scl*bi2; } } //--- function call InternalHsEVDLADIV(br2,bi2,ur22,ui22,xr2,xi2); xr1=ur11r*br1-ui11r*bi1-ur12s*xr2+ui12s*xi2; xi1=ui11r*br1+ur11r*bi1-ui12s*xr2-ur12s*xi2; //--- check if(zswap4[icmax]) { x.Set(1,1,xr2); x.Set(2,1,xr1); x.Set(1,2,xi2); x.Set(2,2,xi1); } else { x.Set(1,1,xr1); x.Set(2,1,xr2); x.Set(1,2,xi1); x.Set(2,2,xi2); } xnorm=MathMax(MathAbs(xr1)+MathAbs(xi1),MathAbs(xr2)+MathAbs(xi2)); //--- Further scaling if norm(A) norm(X) > overflow if(xnorm>1.0 && cmax>1.0) { //--- check if(xnorm>bignum/cmax) { //--- change values temp=cmax/bignum; x.Set(1,1,temp*x.Get(1,1)); x.Set(2,1,temp*x.Get(2,1)); x.Set(1,2,temp*x.Get(1,2)); x.Set(2,2,temp*x.Get(2,2)); xnorm=temp*xnorm; scl=temp*scl; } } } } } //+------------------------------------------------------------------+ //| performs complex division in real arithmetic | //| a + i*b | //| p + i*q = --------- | //| c + i*d | //| The algorithm is due to Robert L. Smith and can be found | //| in D. Knuth, The art of Computer Programming, Vol.2, p.195 | //| -- LAPACK auxiliary routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University| //| October 31, 1992 | //+------------------------------------------------------------------+ void CEigenVDetect::InternalHsEVDLADIV(const double a,const double b, const double c,const double d, double &p,double &q) { //--- create variables double e=0; double f=0; //--- initialization p=0; q=0; //--- check if(MathAbs(d)=0 && vneeded<=3,__FUNCTION__+": incorrect VNeeded!")) return(false); //--- check if(vneeded==0) { //--- Eigen values only ToUpperHessenberg(a,n,tau); //--- function call CHsSchur::InternalSchurDecomposition(a,n,0,0,wr,wi,s,info); //--- get result result=info==0; //--- return result return(result); } //--- Eigen values and vectors ToUpperHessenberg(a,n,tau); //--- function call UnpackQFromUpperHessenberg(a,n,tau,s); //--- function call CHsSchur::InternalSchurDecomposition(a,n,1,1,wr,wi,s,info); //--- get result result=info==0; //--- check if(!result) return(result); //--- check if(vneeded==1 || vneeded==3) { vr.Resize(n+1,n+1); for(i=1; i<=n; i++) { for(i_=1; i_<=n; i_++) vr.Set(i,i_,s.Get(i,i_)); } } //--- check if(vneeded==2 || vneeded==3) { vl.Resize(n+1,n+1); for(i=1; i<=n; i++) { for(i_=1; i_<=n; i_++) vl.Set(i,i_,s.Get(i,i_)); } } //--- function call InternalTREVC(a,n,vneeded,1,sel,vl,vr,m,info); //--- get result result=info==0; //--- return result return(result); } //+------------------------------------------------------------------+ //| Upper Hessenberg form | //+------------------------------------------------------------------+ void CEigenVDetect::ToUpperHessenberg(CMatrixDouble &a,const int n,CRowDouble &tau) { //--- create variables int i=0; int ip1=0; int nmi=0; double v=0; int i_=0; int i1_=0; //--- create arrays CRowDouble t; CRowDouble work; //--- check if(!CAp::Assert(n>=0,__FUNCTION__+": incorrect N!")) return; //--- check if(n<=1) return; //--- allocation tau.Resize(n); t.Resize(n+1); work.Resize(n+1); //--- calculations for(i=1; i::Identity(n+1,n+1); v.Resize(n+1); work.Resize(n+1); //--- unpack Q for(i=1; i=1 | //| OUTPUT PARAMETERS: | //| A - orthogonal NxN matrix, array[0..N-1,0..N-1] | //+------------------------------------------------------------------+ void CMatGen::RMatrixRndOrthogonal(const int n,CMatrixDouble &a) { //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return; //--- allocation a=matrix::Identity(n,n); //--- get result RMatrixRndOrthogonalFromTheRight(a,n,n); } //+------------------------------------------------------------------+ //| Generation of random NxN matrix with given condition number and | //| norm2(A)=1 | //| INPUT PARAMETERS: | //| N - matrix size | //| C - condition number (in 2-norm) | //| OUTPUT PARAMETERS: | //| A - random matrix with norm2(A)=1 and cond(A)=C | //+------------------------------------------------------------------+ void CMatGen::RMatrixRndCond(const int n,const double c,CMatrixDouble &a) { //--- create variables int i=0; int j=0; double l1=0; double l2=0; //--- check if(!CAp::Assert(n>=1 && c>=1.0,__FUNCTION__+": N<1 or C<1!")) return; //--- allocation a.Resize(n,n); //--- check if(n==1) { a.Set(0,0,2*CMath::RandomInteger(2)-1); //--- exit the function return; } //--- initialization l1=0; l2=MathLog(1/c); for(i=0; i=1 | //| OUTPUT PARAMETERS: | //| A - orthogonal NxN matrix, array[0..N-1,0..N-1] | //+------------------------------------------------------------------+ void CMatGen::CMatrixRndOrthogonal(const int n,CMatrixComplex &a) { //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return; //--- allocation a=matrix::Identity(n,n); //--- get result CMatrixRndOrthogonalFromTheRight(a,n,n); } //+------------------------------------------------------------------+ //| Generation of random NxN complex matrix with given condition | //| number C and norm2(A)=1 | //| INPUT PARAMETERS: | //| N - matrix size | //| C - condition number (in 2-norm) | //| OUTPUT PARAMETERS: | //| A - random matrix with norm2(A)=1 and cond(A)=C | //+------------------------------------------------------------------+ void CMatGen::CMatrixRndCond(const int n,const double c,CMatrixComplex &a) { //--- create variables double l1=0; double l2=0; complex v=0; //--- object of class CHighQualityRandState state; //--- check if(!CAp::Assert(n>=1 && c>=1.0,__FUNCTION__+": N<1 or C<1!")) return; //--- allocation a=matrix::Zeros(n,n); //--- function call CHighQualityRand::HQRndRandomize(state); //--- check if(n==1) { //--- function call CHighQualityRand::HQRndUnit2(state,v.real,v.imag); a.Set(0,0,v); return; } //--- initialization l1=0; l2=MathLog(1/c); //--- change values a.Set(0,0,MathExp(l1)); for(int i=1; i<=n-2; i++) a.Set(i,i,MathExp(CMath::RandomReal()*(l2-l1)+l1)); a.Set(n-1,n-1,MathExp(l2)); //--- function call CMatrixRndOrthogonalFromTheLeft(a,n,n); //--- function call CMatrixRndOrthogonalFromTheRight(a,n,n); } //+------------------------------------------------------------------+ //| Generation of random NxN symmetric matrix with given condition | //| number and norm2(A)=1 | //| INPUT PARAMETERS: | //| N - matrix size | //| C - condition number (in 2-norm) | //| OUTPUT PARAMETERS: | //| A - random matrix with norm2(A)=1 and cond(A)=C | //+------------------------------------------------------------------+ void CMatGen::SMatrixRndCond(const int n,const double c,CMatrixDouble &a) { //--- check if(!CAp::Assert(n>=1 && c>=1.0,__FUNCTION__+": N<1 or C<1!")) return; //--- object of class CHighQualityRandState state; //--- allocation a=matrix::Zeros(n,n); //--- check if(n==1) { a.Set(0,0,2*CMath::RandomInteger(2)-1); return; } //--- Prepare matrix double l1=0; double l2=MathLog(1/c); //--- initialization a.Set(0,0,MathExp(l1)); //--- function call CHighQualityRand::HQRndRandomize(state); for(int i=1; i<=n-2; i++) a.Set(i,i,(2*CHighQualityRand::HQRndUniformI(state,2)-1)*MathExp(CHighQualityRand::HQRndUniformR(state)*(l2-l1)+l1)); a.Set(n-1,n-1,MathExp(l2)); //--- Multiply SMatrixRndMultiply(a,n); } //+------------------------------------------------------------------+ //| Generation of random NxN symmetric positive definite matrix with | //| given condition number and norm2(A)=1 | //| INPUT PARAMETERS: | //| N - matrix size | //| C - condition number (in 2-norm) | //| OUTPUT PARAMETERS: | //| A - random SPD matrix with norm2(A)=1 and cond(A)=C | //+------------------------------------------------------------------+ void CMatGen::SPDMatrixRndCond(const int n,const double c,CMatrixDouble &a) { //--- check if(n<=0 || c<1.0) return; //--- allocation a=matrix::Zeros(n,n); //--- check if(n==1) { a.Set(0,0,1); return; } //--- Prepare matrix double l1=0; double l2=MathLog(1/c); //--- initialization //--- object of class CHighQualityRandState state; //--- function call CHighQualityRand::HQRndRandomize(state); a.Set(0,0,MathExp(l1)); for(int i=1; i<=n-2; i++) a.Set(i,i,MathExp(CHighQualityRand::HQRndUniformR(state)*(l2-l1)+l1)); a.Set(n-1,n-1,MathExp(l2)); //--- Multiply SMatrixRndMultiply(a,n); } //+------------------------------------------------------------------+ //| Generation of random NxN Hermitian matrix with given condition | //| number and norm2(A)=1 | //| INPUT PARAMETERS: | //| N - matrix size | //| C - condition number (in 2-norm) | //| OUTPUT PARAMETERS: | //| A - random matrix with norm2(A)=1 and cond(A)=C | //+------------------------------------------------------------------+ void CMatGen::HMatrixRndCond(const int n,const double c,CMatrixComplex &a) { //--- check if(!CAp::Assert(n>=1 && c>=1.0,__FUNCTION__+": N<1 or C<1!")) return; //--- allocation a=matrix::Zeros(n,n); //--- check if(n==1) { a.Set(0,0,2.0*CMath::RandomInteger(2)-1.0); return; } //--- object of class CHighQualityRandState state; //--- function call CHighQualityRand::HQRndRandomize(state); //--- Prepare double l1=0; double l2=MathLog(1/c); //--- initialization a.Set(0,0,MathExp(l1)); for(int i=1; i<=n-2; i++) a.Set(i,i,(2*CHighQualityRand::HQRndUniformI(state,2)-1)*MathExp(CHighQualityRand::HQRndUniformR(state)*(l2-l1)+l1)); a.Set(n-1,n-1,MathExp(l2)); //--- Multiply HMatrixRndMultiply(a,n); //--- post-process to ensure that matrix diagonal is real for(int i=0; i::Zeros(n,n); //--- check if(n==1) { a.Set(0,0,1.0); return; } //--- object of class CHighQualityRandState state; //--- function call CHighQualityRand::HQRndRandomize(state); //--- Prepare matrix double l1=0; double l2=MathLog(1/c); //--- initialization a.Set(0,0,MathExp(l1)); for(int i=1; i<=n-2; i++) a.Set(i,i,MathExp(CHighQualityRand::HQRndUniformR(state)*(l2-l1)+l1)); a.Set(n-1,n-1,MathExp(l2)); //--- Multiply HMatrixRndMultiply(a,n); //--- post-process to ensure that matrix diagonal is real for(int i=0; i=1 && m>=1,__FUNCTION__+": N<1 or M<1!")) return; //--- object of class CHighQualityRandState state; //--- check if(n==1) { //--- Special case tau=2*CMath::RandomInteger(2)-1; for(i=0; i=1 && m>=1,__FUNCTION__+": N<1 or M<1!")) return; //--- check if(m==1) { tau=2*CMath::RandomInteger(2)-1; a.Row(0,(a[0]*tau)); //--- exit the function return; } //--- General case. //--- First pass. w.Resize(n); v.Resize(m+1); //--- function call CHighQualityRand::HQRndRandomize(state); for(s=2; s<=m; s++) { //--- Prepare random normal v do { i=1; while(i<=s) { //--- function call CHighQualityRand::HQRndNormal2(state,u1,u2); v.Set(i,u1); //--- check if(i+1<=s) v.Set(i+1,u2); i=i+2; } //--- change values lambdav=0.0; for(i_=1; i_<=s; i_++) lambdav+=v[i_]*v[i_]; } while(lambdav==0.0); //--- Prepare random normal v CAblas::GenerateReflection(v,s,tau); v.Set(1,1); //--- function call CAblas::ApplyReflectionFromTheLeft(a,tau,v,m-s,m-1,0,n-1,w); } //--- Second pass. for(i=0; i=1 && m>=1,__FUNCTION__+": N<1 or M<1!")) return; //--- check if(n==1) { //--- function call CHighQualityRand::HQRndRandomize(state); //--- function call CHighQualityRand::HQRndUnit2(state,tau.real,tau.imag); for(i=0; i=1 && m>=1,__FUNCTION__+": N<1 or M<1!")) return; //--- check if(m==1) { //--- function call CHighQualityRand::HQRndRandomize(state); //--- function call CHighQualityRand::HQRndUnit2(state,tau.real,tau.imag); for(j=0; j=0 | //| and stores position in Items[] of element I, | //| i.e. Items[LocationOf[I]]=I. | //| If item I is not present, LocationOf[I]<0. | //+------------------------------------------------------------------+ struct CAmdNSet { int m_N; int m_NStored; CRowInt m_Items; CRowInt m_LocationOf; int m_IterIdx; //--- CAmdNSet(void) { Init(); } ~CAmdNSet(void) {} //--- methods void Init(void); void Copy(const CAmdNSet &obj); //--- overloading void operator=(const CAmdNSet &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdNSet::Init(void) { m_N=0; m_NStored=0; m_IterIdx=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdNSet::Copy(const CAmdNSet &obj) { m_N=obj.m_N; m_NStored=obj.m_NStored; m_Items=obj.m_Items; m_LocationOf=obj.m_LocationOf; m_IterIdx=obj.m_IterIdx; } //+------------------------------------------------------------------+ //| This structure is used to store vertex degrees, with ability to| //| quickly (in O(1) time) select one with smallest degree | //+------------------------------------------------------------------+ struct CAmdVertexSet { int m_N; bool m_CheckExactDegrees; int m_SmallestDegree; CRowInt m_ApproxD; CRowInt m_OptionalExactD; bool m_IsVertex[]; CRowInt m_VBegin; CRowInt m_VPrev; CRowInt m_VNext; //--- CAmdVertexSet(void) { Init(); } void Init(void); void Copy(const CAmdVertexSet &obj); //--- overloading void operator=(const CAmdVertexSet &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdVertexSet::Init(void) { m_N=0; m_CheckExactDegrees=0; m_SmallestDegree=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdVertexSet::Copy(const CAmdVertexSet &obj) { m_N=obj.m_N; m_CheckExactDegrees=obj.m_CheckExactDegrees; m_SmallestDegree=obj.m_SmallestDegree; m_ApproxD=obj.m_ApproxD; m_OptionalExactD=obj.m_OptionalExactD; ArrayCopy(m_IsVertex,obj.m_IsVertex); m_VBegin=obj.m_VBegin; m_VPrev=obj.m_VPrev; m_VNext=obj.m_VNext; } //+------------------------------------------------------------------+ //| This structure is used to store linked list NxN matrix. | //| The fields are: | //| * VBegin - array[2*N+1], stores first entries in each row | //| (N values), col (N values), list of free entries| //| (1 value), 2*N+1 in total | //| * Entries - stores EntriesInitialized elements, each | //| occupying llmEntrySize elements of array. These | //| entries are organized into linked row and column| //| list, with each entry belonging to both row list| //| and column list. | //+------------------------------------------------------------------+ struct CAmdLLMatrix { int m_N; CRowInt m_VBegin; CRowInt m_VColCnt; CRowInt m_Entries; int m_EntriesInitialized; //--- constructor / destructor CAmdLLMatrix(void) { Init(); } ~CAmdLLMatrix(void) {} //--- methods void Init(void); void Copy(const CAmdLLMatrix &obj); //--- overloading void operator=(const CAmdLLMatrix &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdLLMatrix::Init(void) { m_N=0; m_EntriesInitialized=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdLLMatrix::Copy(const CAmdLLMatrix &obj) { m_N=obj.m_N; m_VBegin=obj.m_VBegin; m_VColCnt=obj.m_VColCnt; m_Entries=obj.m_Entries; m_EntriesInitialized=obj.m_EntriesInitialized; } //+------------------------------------------------------------------+ //| This structure is used to store temporaries for AMD ordering | //+------------------------------------------------------------------+ struct CAmdBuffer { int m_N; bool m_ExtendedDebug; bool m_CheckExactDegrees; bool m_IsEliminated[]; bool m_IsSuperNode[]; CAmdKNSet m_SetSuper; CAmdKNSet m_SetA; CAmdKNSet m_SetE; CAmdLLMatrix m_MtxL; CAmdVertexSet m_VertexDegrees; CAmdNSet m_SetQ; CRowInt m_Perm; CRowInt m_InvPerm; CRowInt m_ColumnSwaps; CAmdNSet m_SetP; CAmdNSet m_Lp; CAmdNSet m_SetRP; CAmdNSet m_Ep; CAmdNSet m_AdjI; CAmdNSet m_AdjJ; CRowInt m_Ls; int m_LSCnt; CAmdNSet m_SetQSuperCand; CAmdNSet m_ExactDegreeTmp0; CAmdKNSet m_HashBuckets; CAmdNSet m_NonEmptyBuckets; CRowInt m_SNCandidates; CRowInt m_Tmp0; CRowInt m_Arrwe; CMatrixDouble m_Dbga; //--- constructor / destructor CAmdBuffer(void) { Init(); } ~CAmdBuffer(void) {} //--- methods void Init(void); void Copy(const CAmdBuffer &obj); //--- overloading void operator=(const CAmdBuffer &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdBuffer::Init(void) { m_N=0; m_ExtendedDebug=false; m_CheckExactDegrees=false; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CAmdBuffer::Copy(const CAmdBuffer &obj) { m_N=obj.m_N; m_ExtendedDebug=obj.m_ExtendedDebug; m_CheckExactDegrees=obj.m_CheckExactDegrees; ArrayCopy(m_IsEliminated,obj.m_IsEliminated); ArrayCopy(m_IsSuperNode,obj.m_IsSuperNode); m_SetSuper=obj.m_SetSuper; m_SetA=obj.m_SetA; m_SetE=obj.m_SetE; m_MtxL=obj.m_MtxL; m_VertexDegrees=obj.m_VertexDegrees; m_SetQ=obj.m_SetQ; m_Perm=obj.m_Perm; m_InvPerm=obj.m_InvPerm; m_ColumnSwaps=obj.m_ColumnSwaps; m_SetP=obj.m_SetP; m_Lp=obj.m_Lp; m_SetRP=obj.m_SetRP; m_Ep=obj.m_Ep; m_AdjI=obj.m_AdjI; m_AdjJ=obj.m_AdjJ; m_Ls=obj.m_Ls; m_LSCnt=obj.m_LSCnt; m_SetQSuperCand=obj.m_SetQSuperCand; m_ExactDegreeTmp0=obj.m_ExactDegreeTmp0; m_HashBuckets=obj.m_HashBuckets; m_NonEmptyBuckets=obj.m_NonEmptyBuckets; m_SNCandidates=obj.m_SNCandidates; m_Tmp0=obj.m_Tmp0; m_Arrwe=obj.m_Arrwe; m_Dbga=obj.m_Dbga; } //+------------------------------------------------------------------+ //| This structure is used to store preliminary analysis results for | //| sparse Cholesky: elimination tree, factorization costs, etc. | //+------------------------------------------------------------------+ struct CSpCholAnalysis { int m_TaskType; int m_N; int m_PermType; bool m_UnitD; int m_ModType; double m_ModParam0; double m_ModParam1; double m_ModParam2; double m_ModParam3; bool m_ExtendedDebug; bool m_Dotrace; bool m_DotraceSupernodalStructure; CRowInt m_ReferenceRIdx; int m_NSuper; CRowInt m_ParentSupernode; CRowInt m_SuperColRange; CRowInt m_SuperRowRIdx; CRowInt m_SuperRowIdx; CRowInt m_FillinPerm; CRowInt m_InvFillinPerm; CRowInt m_SuperPerm; CRowInt m_InvSuperPerm; CRowInt m_EffectivePerm; CRowInt m_InvEffectivePerm; bool m_IsTopologicalOrdering; bool m_ApplyPermutationToOutput; CRowInt m_LAdjPlusR; CRowInt m_LAdjPlus; CRowInt m_OutRowCounts; CRowDouble m_InputStorage; CRowDouble m_OutputStorage; CRowInt m_RowStrides; CRowInt m_RowOffSets; CRowDouble m_DiagD; CRowInt m_WrkRows; bool m_FlagArray[]; bool m_Eligible[]; CRowInt m_CurPriorities; CRowInt m_TmpParent; CRowInt m_Node2Supernode; CRowInt m_U2Smap; CRowInt m_Raw2Smap; CAmdBuffer m_AmdTmp; CRowInt m_Tmp0; CRowInt m_Tmp1; CRowInt m_Tmp2; CRowInt m_Tmp3; CRowInt m_Tmp4; CSparseMatrix m_TmpA; CSparseMatrix m_TmpAt; CSparseMatrix m_TmpA2; CSparseMatrix m_TmpBottomT; CSparseMatrix m_TmpUpdate; CSparseMatrix m_TmpUpdateT; CSparseMatrix m_TmpNewTailT; CRowInt m_TmpPerm; CRowInt m_InvTmpPerm; CRowDouble m_TmpX; CRowDouble m_SimdBuf; //--- constructor / destructor CSpCholAnalysis(void) { Init(); } ~CSpCholAnalysis(void) {} //--- void Init(void); void Copy(const CSpCholAnalysis &obj); void Trace(void); void SpCholAlloc(CSerializer &s); void SpCholSerialize(CSerializer &s); //--- overloading void operator=(const CSpCholAnalysis &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Init | //+------------------------------------------------------------------+ void CSpCholAnalysis::Init(void) { m_TaskType=0; m_N=0; m_PermType=0; m_UnitD=false; m_ModType=0; m_ModParam0=0; m_ModParam1=0; m_ModParam2=0; m_ModParam3=0; m_ExtendedDebug=false; m_Dotrace=false; m_DotraceSupernodalStructure=false; m_IsTopologicalOrdering=false; m_ApplyPermutationToOutput=false; } //+------------------------------------------------------------------+ //| Copy | //+------------------------------------------------------------------+ void CSpCholAnalysis::Copy(const CSpCholAnalysis &obj) { m_TaskType=obj.m_TaskType; m_N=obj.m_N; m_PermType=obj.m_PermType; m_UnitD=obj.m_UnitD; m_ModType=obj.m_ModType; m_ModParam0=obj.m_ModParam0; m_ModParam1=obj.m_ModParam1; m_ModParam2=obj.m_ModParam2; m_ModParam3=obj.m_ModParam3; m_ExtendedDebug=obj.m_ExtendedDebug; m_Dotrace=obj.m_Dotrace; m_DotraceSupernodalStructure=obj.m_DotraceSupernodalStructure; m_ReferenceRIdx=obj.m_ReferenceRIdx; m_NSuper=obj.m_NSuper; m_ParentSupernode=obj.m_ParentSupernode; m_SuperColRange=obj.m_SuperColRange; m_SuperRowRIdx=obj.m_SuperRowRIdx; m_SuperRowIdx=obj.m_SuperRowIdx; m_FillinPerm=obj.m_FillinPerm; m_InvFillinPerm=obj.m_InvFillinPerm; m_SuperPerm=obj.m_SuperPerm; m_InvSuperPerm=obj.m_InvSuperPerm; m_EffectivePerm=obj.m_EffectivePerm; m_InvEffectivePerm=obj.m_InvEffectivePerm; m_IsTopologicalOrdering=obj.m_IsTopologicalOrdering; m_ApplyPermutationToOutput=obj.m_ApplyPermutationToOutput; m_LAdjPlusR=obj.m_LAdjPlusR; m_LAdjPlus=obj.m_LAdjPlus; m_OutRowCounts=obj.m_OutRowCounts; m_InputStorage=obj.m_InputStorage; m_OutputStorage=obj.m_OutputStorage; m_RowStrides=obj.m_RowStrides; m_RowOffSets=obj.m_RowOffSets; m_DiagD=obj.m_DiagD; m_WrkRows=obj.m_WrkRows; ArrayCopy(m_FlagArray,obj.m_FlagArray); ArrayCopy(m_Eligible,obj.m_Eligible); m_CurPriorities=obj.m_CurPriorities; m_TmpParent=obj.m_TmpParent; m_Node2Supernode=obj.m_Node2Supernode; m_U2Smap=obj.m_U2Smap; m_Raw2Smap=obj.m_Raw2Smap; m_AmdTmp=obj.m_AmdTmp; m_Tmp0=obj.m_Tmp0; m_Tmp1=obj.m_Tmp1; m_Tmp2=obj.m_Tmp2; m_Tmp3=obj.m_Tmp3; m_Tmp4=obj.m_Tmp4; m_TmpA=obj.m_TmpA; m_TmpAt=obj.m_TmpAt; m_TmpA2=obj.m_TmpA2; m_TmpBottomT=obj.m_TmpBottomT; m_TmpUpdate=obj.m_TmpUpdate; m_TmpUpdateT=obj.m_TmpUpdateT; m_TmpNewTailT=obj.m_TmpNewTailT; m_TmpPerm=obj.m_TmpPerm; m_InvTmpPerm=obj.m_InvTmpPerm; m_TmpX=obj.m_TmpX; m_SimdBuf=obj.m_SimdBuf; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSpCholAnalysis::Trace(void) { if(!m_Dotrace) return; //--- create a variable CSerializer s; //--- serialization start s.Alloc_Start(); //--- function call SpCholAlloc(s); s.Alloc_Entry(); //--- serialization s.SStart_Str(); SpCholSerialize(s); s.Stop(); CAp::Trace(s.Get_String()+"\n"); CAp::Trace("------\n"); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSpCholAnalysis::SpCholAlloc(CSerializer &s) { s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); s.Alloc_Entry(); CApServ::AllocIntegerArray(s,m_ReferenceRIdx); s.Alloc_Entry(); CApServ::AllocIntegerArray(s,m_ParentSupernode); CApServ::AllocIntegerArray(s,m_SuperColRange); CApServ::AllocIntegerArray(s,m_SuperRowRIdx); CApServ::AllocIntegerArray(s,m_SuperRowIdx); CApServ::AllocIntegerArray(s,m_FillinPerm); CApServ::AllocIntegerArray(s,m_InvFillinPerm); CApServ::AllocIntegerArray(s,m_SuperPerm); CApServ::AllocIntegerArray(s,m_InvSuperPerm); CApServ::AllocIntegerArray(s,m_EffectivePerm); CApServ::AllocIntegerArray(s,m_InvEffectivePerm); s.Alloc_Entry(); s.Alloc_Entry(); CApServ::AllocIntegerArray(s,m_LAdjPlusR); CApServ::AllocIntegerArray(s,m_LAdjPlus); CApServ::AllocIntegerArray(s,m_OutRowCounts); CApServ::AllocRealArray(s,m_InputStorage); CApServ::AllocRealArray(s,m_OutputStorage); CApServ::AllocIntegerArray(s,m_RowStrides); CApServ::AllocIntegerArray(s,m_RowOffSets); CApServ::AllocRealArray(s,m_DiagD); CApServ::AllocIntegerArray(s,m_WrkRows); CApServ::AllocBoolArray(s,m_FlagArray); CApServ::AllocBoolArray(s,m_Eligible); CApServ::AllocIntegerArray(s,m_CurPriorities); CApServ::AllocIntegerArray(s,m_TmpParent); CApServ::AllocIntegerArray(s,m_Node2Supernode); CApServ::AllocIntegerArray(s,m_U2Smap); CApServ::AllocIntegerArray(s,m_Raw2Smap); CApServ::AllocIntegerArray(s,m_Tmp0); CApServ::AllocIntegerArray(s,m_Tmp1); CApServ::AllocIntegerArray(s,m_Tmp2); CApServ::AllocIntegerArray(s,m_Tmp3); CApServ::AllocIntegerArray(s,m_Tmp4); CSparse::SparseAlloc(s,m_TmpA); CSparse::SparseAlloc(s,m_TmpAt); CSparse::SparseAlloc(s,m_TmpA2); CSparse::SparseAlloc(s,m_TmpBottomT); CSparse::SparseAlloc(s,m_TmpUpdate); CSparse::SparseAlloc(s,m_TmpUpdateT); CSparse::SparseAlloc(s,m_TmpNewTailT); CApServ::AllocIntegerArray(s,m_TmpPerm); CApServ::AllocIntegerArray(s,m_InvTmpPerm); CApServ::AllocRealArray(s,m_TmpX); CApServ::AllocRealArray(s,m_SimdBuf); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSpCholAnalysis::SpCholSerialize(CSerializer &s) { s.Serialize_Int(m_TaskType); s.Serialize_Int(m_N); s.Serialize_Int(m_PermType); s.Serialize_Bool(m_UnitD); s.Serialize_Int(m_ModType); s.Serialize_Double(m_ModParam0); s.Serialize_Double(m_ModParam1); s.Serialize_Double(m_ModParam2); s.Serialize_Double(m_ModParam3); s.Serialize_Bool(m_ExtendedDebug); s.Serialize_Bool(m_Dotrace); s.Serialize_Bool(m_DotraceSupernodalStructure); CApServ::SerializeIntegerArray(s,m_ReferenceRIdx); s.Serialize_Int(m_NSuper); CApServ::SerializeIntegerArray(s,m_ParentSupernode); CApServ::SerializeIntegerArray(s,m_SuperColRange); CApServ::SerializeIntegerArray(s,m_SuperRowRIdx); CApServ::SerializeIntegerArray(s,m_SuperRowIdx); CApServ::SerializeIntegerArray(s,m_FillinPerm); CApServ::SerializeIntegerArray(s,m_InvFillinPerm); CApServ::SerializeIntegerArray(s,m_SuperPerm); CApServ::SerializeIntegerArray(s,m_InvSuperPerm); CApServ::SerializeIntegerArray(s,m_EffectivePerm); CApServ::SerializeIntegerArray(s,m_InvEffectivePerm); s.Serialize_Bool(m_IsTopologicalOrdering); s.Serialize_Bool(m_ApplyPermutationToOutput); CApServ::SerializeIntegerArray(s,m_LAdjPlusR); CApServ::SerializeIntegerArray(s,m_LAdjPlus); CApServ::SerializeIntegerArray(s,m_OutRowCounts); CApServ::SerializeRealArray(s,m_InputStorage); CApServ::SerializeRealArray(s,m_OutputStorage); CApServ::SerializeIntegerArray(s,m_RowStrides); CApServ::SerializeIntegerArray(s,m_RowOffSets); CApServ::SerializeRealArray(s,m_DiagD); CApServ::SerializeIntegerArray(s,m_WrkRows); CApServ::SerializeBoolArray(s,m_FlagArray); CApServ::SerializeBoolArray(s,m_Eligible); CApServ::SerializeIntegerArray(s,m_CurPriorities); CApServ::SerializeIntegerArray(s,m_TmpParent); CApServ::SerializeIntegerArray(s,m_Node2Supernode); CApServ::SerializeIntegerArray(s,m_U2Smap); CApServ::SerializeIntegerArray(s,m_Raw2Smap); CApServ::SerializeIntegerArray(s,m_Tmp0); CApServ::SerializeIntegerArray(s,m_Tmp1); CApServ::SerializeIntegerArray(s,m_Tmp2); CApServ::SerializeIntegerArray(s,m_Tmp3); CApServ::SerializeIntegerArray(s,m_Tmp4); CSparse::SparseSerialize(s,m_TmpA); CSparse::SparseSerialize(s,m_TmpAt); CSparse::SparseSerialize(s,m_TmpA2); CSparse::SparseSerialize(s,m_TmpBottomT); CSparse::SparseSerialize(s,m_TmpUpdate); CSparse::SparseSerialize(s,m_TmpUpdateT); CSparse::SparseSerialize(s,m_TmpNewTailT); CApServ::SerializeIntegerArray(s,m_TmpPerm); CApServ::SerializeIntegerArray(s,m_InvTmpPerm); CApServ::SerializeRealArray(s,m_TmpX); CApServ::SerializeRealArray(s,m_SimdBuf); } //+------------------------------------------------------------------+ //| An analysis of the sparse matrix decomposition, performed prior | //| to actual numerical factorization. You should not directly access| //| fields of this object - use appropriate ALGLIB functions to work | //| with this object. | //+------------------------------------------------------------------+ struct CSparseDecompositionAnalysis { int m_N; int m_FactType; int m_PermType; CSpCholAnalysis m_Analysis; CSparseMatrix m_WrkA; CSparseMatrix m_WrkAT; CSparseMatrix m_CrsA; CSparseMatrix m_CrsAT; //--- constructor / destructor CSparseDecompositionAnalysis(void) { Init(); } ~CSparseDecompositionAnalysis(void) {} void Init(void); void Copy(const CSparseDecompositionAnalysis &obj); //--- overloading void operator=(const CSparseDecompositionAnalysis &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Init | //+------------------------------------------------------------------+ void CSparseDecompositionAnalysis::Init(void) { m_N=0; m_FactType=0; m_PermType=0; } //+------------------------------------------------------------------+ //| Copy | //+------------------------------------------------------------------+ void CSparseDecompositionAnalysis::Copy(const CSparseDecompositionAnalysis &obj) { m_N=obj.m_N; m_FactType=obj.m_FactType; m_PermType=obj.m_PermType; m_Analysis=obj.m_Analysis; m_WrkA=obj.m_WrkA; m_WrkAT=obj.m_WrkAT; m_CrsA=obj.m_CrsA; m_CrsAT=obj.m_CrsAT; } //+------------------------------------------------------------------+ //| Triangular factorizations | //+------------------------------------------------------------------+ class CTrFac { private: static bool HPDMatrixCholeskyRec(CMatrixComplex &A,const int Offs,const int n,const bool IsUpper,CRowComplex &tmp); static bool HPDMatrixCholesky2(CMatrixComplex &AAA,const int Offs,const int n,const bool IsUpper,CRowComplex &tmp); static bool SPDMatrixCholesky2(CMatrixDouble &AAA,const int Offs,const int n,const bool IsUpper,CRowDouble &tmp); public: static void RMatrixLU(CMatrixDouble &A,const int m,const int n,int &pivots[]); static void RMatrixLU(CMatrixDouble &A,const int m,const int n,CRowInt &pivots); static void CMatrixLU(CMatrixComplex &A,const int m,const int n,int &pivots[]); static void CMatrixLU(CMatrixComplex &A,const int m,const int n,CRowInt &pivots); static bool HPDMatrixCholesky(CMatrixComplex &A,const int n,const bool IsUpper); static bool SPDMatrixCholesky(CMatrixDouble &A,const int n,const bool IsUpper); static void SPDMatrixCholeskyUpdateAdd1(CMatrixDouble &A,int N,bool IsUpper,CRowDouble &U); static void SPDMatrixCholeskyUpdateFix(CMatrixDouble &A,int n,bool IsUpper,bool &Fix[]); static void SPDMatrixCholeskyUpdateAdd1Buf(CMatrixDouble &A,int n,bool IsUpper,CRowDouble &U,CRowDouble &BufR); static void SPDMatrixCholeskyUpdateFixBuf(CMatrixDouble &A,int n,bool IsUpper,bool &fix[],CRowDouble &BufR); static bool SparseLU(CSparseMatrix &A,int pivottype,CRowInt &P,CRowInt &Q); static bool SparseCholeskySkyLine(CSparseMatrix &A,int n,bool IsUpper); static bool SparseCholesky(CSparseMatrix &A,bool IsUpper); static bool SparseCholeskyP(CSparseMatrix &A,bool IsUpper,CRowInt &p); static bool SparseCholeskyAnalyze(CSparseMatrix &A,bool IsUpper,int facttype,int PermType,CSparseDecompositionAnalysis &Analysis); static void SparseCholeskySetModType(CSparseDecompositionAnalysis &Analysis,int modstrategy,double p0,double p1,double p2,double p3); static bool SparseCholeskyFactorize(CSparseDecompositionAnalysis &Analysis,bool NeedUpper,CSparseMatrix &A,CRowDouble &d,CRowInt &p); static void SparseCholeskyReload(CSparseDecompositionAnalysis &Analysis,CSparseMatrix &A,bool IsUpper); static void RMatrixLUP(CMatrixDouble &A,const int m,const int n,int &pivots[]); static void RMatrixLUP(CMatrixDouble &A,const int m,const int n,CRowInt &pivots); static void CMatrixLUP(CMatrixComplex &A,const int m,const int n,int &pivots[]); static void CMatrixLUP(CMatrixComplex &A,const int m,const int n,CRowInt &pivots); static void RMatrixPLU(CMatrixDouble &A,const int m,const int n,int &pivots[]); static void RMatrixPLU(CMatrixDouble &A,const int m,const int n,CRowInt &pivots); static void CMatrixPLU(CMatrixComplex &A,const int m,const int n,int &pivots[]); static void CMatrixPLU(CMatrixComplex &A,const int m,const int n,CRowInt &pivots); static bool SPDMatrixCholeskyRec(CMatrixDouble &A,const int Offs,const int n,const bool IsUpper,double &tmp[]); static bool SPDMatrixCholeskyRec(CMatrixDouble &A,const int Offs,const int n,const bool IsUpper,CRowDouble &tmp); }; //+------------------------------------------------------------------+ //| LU decomposition of a general real matrix with row pivoting | //| A is represented as A = P*L*U, where: | //| * L is lower unitriangular matrix | //| * U is upper triangular matrix | //| * P = P0*P1*...*PK, K=min(M,N)-1, | //| Pi - permutation matrix for I and Pivots[I] | //| This is cache-oblivous implementation of LU decomposition. | //| It is optimized for square matrices. As for rectangular matrices:| //| * best case - M>>N | //| * worst case - N>>M, small M, large N, matrix does not fit in CPU| //| cache | //| INPUT PARAMETERS: | //| A - array[0..M-1, 0..N-1]. | //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| OUTPUT PARAMETERS: | //| A - matrices L and U in compact form: | //| * L is stored under main diagonal | //| * U is stored on and above main diagonal | //| Pivots - permutation matrix in compact form. | //| array[0..Min(M-1,N-1)]. | //+------------------------------------------------------------------+ void CTrFac::RMatrixLU(CMatrixDouble &a,const int m,const int n,int &pivots[]) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- function call RMatrixPLU(a,m,n,pivots); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void CTrFac::RMatrixLU(CMatrixDouble &a,const int m,const int n,CRowInt &pivots) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- function call RMatrixPLU(a,m,n,pivots); } //+------------------------------------------------------------------+ //| LU decomposition of a general complex matrix with row pivoting | //| A is represented as A = P*L*U, where: | //| * L is lower unitriangular matrix | //| * U is upper triangular matrix | //| * P = P0*P1*...*PK, K=min(M,N)-1, | //| Pi - permutation matrix for I and Pivots[I] | //| This is cache-oblivous implementation of LU decomposition. It is | //| optimized for square matrices. As for rectangular matrices: | //| * best case - M>>N | //| * worst case - N>>M, small M, large N, matrix does not fit in CPU| //| cache | //| INPUT PARAMETERS: | //| A - array[0..M-1, 0..N-1]. | //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| OUTPUT PARAMETERS: | //| A - matrices L and U in compact form: | //| * L is stored under main diagonal | //| * U is stored on and above main diagonal | //| Pivots - permutation matrix in compact form. | //| array[0..Min(M-1,N-1)]. | //+------------------------------------------------------------------+ void CTrFac::CMatrixLU(CMatrixComplex &a,const int m,const int n,int &pivots[]) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- function call CMatrixPLU(a,m,n,pivots); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void CTrFac::CMatrixLU(CMatrixComplex &A,const int m,const int n,CRowInt &pivots) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- function call CMatrixPLU(A,m,n,pivots); } //+------------------------------------------------------------------+ //| Cache-oblivious Cholesky decomposition | //| The algorithm computes Cholesky decomposition of a Hermitian | //| positive - definite matrix. The result of an algorithm is a | //| representation of A as A=U'*U or A=L*L' (here X' detones | //| conj(X^T)). | //| INPUT PARAMETERS: | //| A - upper or lower triangle of a factorized matrix. | //| array with elements [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| IsUpper - if IsUpper=True, then A contains an upper | //| triangle of a symmetric matrix, otherwise A | //| contains a lower one. | //| OUTPUT PARAMETERS: | //| A - the result of factorization. If IsUpper=True, | //| then the upper triangle contains matrix U, so | //| that A = U'*U, and the elements below the main | //| diagonal are not modified. Similarly, if | //| IsUpper = False. | //| RESULT: | //| If the matrix is positive-definite, the function returns | //| True. Otherwise, the function returns False. Contents of A is| //| not determined in such case. | //+------------------------------------------------------------------+ bool CTrFac::HPDMatrixCholesky(CMatrixComplex &a,const int n,const bool IsUpper) { //--- check if(n<1) return(false); //--- create array CRowComplex tmp; //--- return result return(HPDMatrixCholeskyRec(a,0,n,IsUpper,tmp)); } //+------------------------------------------------------------------+ //| Cache-oblivious Cholesky decomposition | //| The algorithm computes Cholesky decomposition of a symmetric | //| positive - definite matrix. The result of an algorithm is a | //| representation of A as A=U^T*U or A=L*L^T | //| INPUT PARAMETERS: | //| A - upper or lower triangle of a factorized matrix. | //| array with elements [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| IsUpper - if IsUpper=True, then A contains an upper | //| triangle of a symmetric matrix, otherwise A | //| contains a lower one. | //| OUTPUT PARAMETERS: | //| A - the result of factorization. If IsUpper=True, | //| then the upper triangle contains matrix U, so | //| that A = U^T*U, and the elements below the main | //| diagonal are not modified. Similarly, if | //| IsUpper = False. | //| RESULT: | //| If the matrix is positive-definite, the function returns | //| True. Otherwise, the function returns False. Contents of A is| //| not determined in such case. | //+------------------------------------------------------------------+ bool CTrFac::SPDMatrixCholesky(CMatrixDouble &a,const int n,const bool IsUpper) { //--- check if(n<1) return(false); //--- create array CRowDouble tmp; //--- return result return(SPDMatrixCholeskyRec(a,0,n,IsUpper,tmp)); } //+------------------------------------------------------------------+ //| Update of Cholesky decomposition: rank-1 update to original A. | //| "Buffered" version which uses preallocated buffer which is saved | //| between subsequent function calls. | //| This function uses internally allocated buffer which is not saved| //| between subsequent calls. So, if you perform a lot of subsequent | //| updates, we recommend you to use "buffered" version of this | //| function: SPDMatrixCholeskyUpdateAdd1Buf(). | //| INPUT PARAMETERS: | //| A - upper or lower Cholesky factor. array with elements| //| [0..N-1, 0..N-1]. Exception is thrown if array size| //| is too small. | //| N - size of matrix A, N>0 | //| IsUpper - if IsUpper=True, then A contains upper Cholesky | //| factor; otherwise A contains a lower one. | //| U - array[N], rank-1 update to A: A_mod = A + u*u' | //| Exception is thrown if array size is too small. | //| BufR - possibly preallocated buffer; automatically resized| //| if needed. It is recommended to reuse this buffer | //| if you perform a lot of subsequent decompositions. | //| OUTPUT PARAMETERS: | //| A - updated factorization. If IsUpper=True, then the | //| upper triangle contains matrix U, and the elements | //| below the main diagonal are not modified. Similarly| //| if IsUpper = False. | //| NOTE: this function always succeeds, so it does not return | //| completion code | //| NOTE: this function checks sizes of input arrays, but it does NOT| //| checks for presence of infinities or NAN's. | //+------------------------------------------------------------------+ void CTrFac::SPDMatrixCholeskyUpdateAdd1(CMatrixDouble &A,int N, bool IsUpper, CRowDouble &U) { //--- check if(!CAp::Assert(N>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(A.Rows()>=N,__FUNCTION__+": Rows(A)=N,__FUNCTION__+": Cols(A)=N,__FUNCTION__+": Length(U) (Af20 0 Af22 Af23) | //| (A30 A31 A32 A33) (Af30 0 Af32 Af33) | //| If we have Cholesky decomposition of A, it must be recalculated| //| after variables were fixed. However, it is possible to use | //| efficient algorithm, which needs O(K*N^2) time to "fix" K | //| variables, given Cholesky decomposition of original, "unfixed" | //| A. | //| INPUT PARAMETERS: | //| A - upper or lower Cholesky factor. Array with elements| //| [0..N - 1, 0..N - 1]. Exception is thrown if array | //| size is too small. | //| N - size of matrix A, N > 0 | //| IsUpper - if IsUpper = True, then A contains upper Cholesky | //| factor; otherwise A contains a lower one. | //| Fix - array[N], I-th element is True if I-th variable | //| must be fixed. Exception is thrown if array size is| //| too small. | //| BufR - possibly preallocated buffer; automatically resized| //| if needed. It is recommended to reuse this buffer | //| if you perform a lot of subsequent decompositions. | //| OUTPUT PARAMETERS: | //| A - updated factorization. If IsUpper=True, then the | //| upper triangle contains matrix U, and the elements | //| below the main diagonal are not modified. | //| Similarly, if IsUpper=False. | //| NOTE: this function always succeeds, so it does not return | //| completion code | //| NOTE: this function checks sizes of input arrays, but it does NOT| //| checks for presence of infinities or NAN's. | //| NOTE: this function is efficient only for moderate amount of | //| updated variables - say, 0.1*N or 0.3*N. For larger amount | //| of variables it will still work, but you may get better | //| performance with straightforward Cholesky. | //+------------------------------------------------------------------+ void CTrFac::SPDMatrixCholeskyUpdateFix(CMatrixDouble &A,int n, bool IsUpper,bool &Fix[]) { //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(A.Rows()>=n,__FUNCTION__+": Rows(A)=n,__FUNCTION__+": Cols(A)=n,__FUNCTION__+": Length(Fix) 0 | //| IsUpper - if IsUpper = True, then A contains upper Cholesky | //| factor; otherwise A contains a lower one. | //| U - array[N], rank - 1 update to A: A_mod = A + u * u' | //| Exception is thrown if array size is too small. | //| BufR - possibly preallocated buffer; automatically resized| //| if needed. It is recommended to reuse this buffer | //| if you perform a lot of subsequent decompositions. | //| OUTPUT PARAMETERS: | //| A - updated factorization. If IsUpper=True, then the | //| upper triangle contains matrix U, and the elements | //| below the main diagonal are not modified. | //| Similarly, if IsUpper=False. | //+------------------------------------------------------------------+ void CTrFac::SPDMatrixCholeskyUpdateAdd1Buf(CMatrixDouble &A,int n, bool IsUpper,CRowDouble &U, CRowDouble &BufR) { //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(A.Rows()>=n,__FUNCTION__+": Rows(A)=n,__FUNCTION__+": Cols(A)=n,__FUNCTION__+": Length(U) 0 | //| IsUpper - if IsUpper = True, then A contains upper Cholesky | //| factor; otherwise A contains a lower one. | //| Fix - array[N], I-th element is True if I-th variable | //| must be fixed. Exception is thrown if array size is| //| too small. | //| BufR - possibly preallocated buffer; automatically resized| //| if needed. It is recommended to reuse this buffer | //| if you perform a lot of subsequent decompositions. | //| OUTPUT PARAMETERS: | //| A - updated factorization. If IsUpper=True, then the | //| upper triangle contains matrix U, and the elements | //| below the main diagonal are not modified. | //| Similarly, if IsUpper = False. | //+------------------------------------------------------------------+ void CTrFac::SPDMatrixCholeskyUpdateFixBuf(CMatrixDouble &A,int n, bool IsUpper,bool &Fix[], CRowDouble &BufR) { //--- create variables int i=0; int j=0; int k=0; int nfix=0; int idx=0; double cs=0; double sn=0; double v=0; double vv=0; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(A.Rows()>=n,__FUNCTION__+": Rows(A)=n,__FUNCTION__+": Cols(A)=n,__FUNCTION__+": Length(Fix)=0,__FUNCTION__+": N<0")) return(false); //--- check if(!CAp::Assert(CSparse::SparseGetNRows(A)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=BANDWIDTH(A1), I-th equation is reduced from //--- L[I,0]*A1[0] + L[I,1]*A1[1] + ... + L[I,I]*A1[I] = A[I] //--- to //--- L[I,JNZ]*A1[JNZ] + ... + L[I,I]*A1[I] = A[I] //--- where JNZ = max(NReady-BANDWIDTH(A1),I-BANDWIDTH(L[i])) //--- (JNZ is an index of the firts column where both A and L become //--- nonzero). //--- NOTE: we rely on details of SparseMatrix internal storage format. //--- This is allowed by SparseMatrix specification. a12=0; if(A.m_DIdx[nready]>0) { banda=A.m_DIdx[nready]; for(i=nready-banda; i= I). | //| If no permutation was requested during analysis phase, still | //| returned but filled with identity permutation. | //| The function returns True when factorization resulted in | //| nondegenerate matrix. False is returned when factorization fails | //| (Cholesky factorization of indefinite matrix) or LDLT | //| factorization has exactly zero elements at the diagonal. In the | //| latter case contents of A, D and P is undefined. | //| The analysis object is not changed during the factorization. | //| Subsequent calls to SparseCholeskyFactorize() will result in same| //| factorization being performed one more time. | //+------------------------------------------------------------------+ bool CTrFac::SparseCholeskyFactorize(CSparseDecompositionAnalysis &Analysis, bool NeedUpper, CSparseMatrix &A, CRowDouble &d, CRowInt &p) { //--- check if(!CSpChol::SpSymmFactorize(Analysis.m_Analysis)) return(false); if(NeedUpper) { CSpChol::SpSymmExtract(Analysis.m_Analysis,Analysis.m_WrkA,d,p); CSparse::SparseCopyTransposeCRSBuf(Analysis.m_WrkA,A); } else { CSpChol::SpSymmExtract(Analysis.m_Analysis,A,d,p); } //--- return result return(true); } //+------------------------------------------------------------------+ //| Sparse Cholesky decomposition: update internally stored matrix | //| with another one with exactly same sparsity pattern. | //| This function is a part of the 'expert' sparse Cholesky API: | //| * SparseCholeskyAnalyze(), that performs symbolic analysis | //| phase and loads matrix to be factorized into internal | //| storage | //| * SparseCholeskySetModType(), that allows to use modified | //| Cholesky/LDLT with lower bounds on pivot magnitudes and | //| additional overflow safeguards | //| * SparseCholeskyFactorize(), that performs numeric | //| factorization using precomputed symbolic analysis and | //| internally stored matrix - and outputs result | //| * SparseCholeskyReload(), that reloads one more matrix with | //| same sparsity pattern into internal storage so one may | //| reuse previously allocated temporaries and previously | //| performed symbolic analysis | //| This specific function replaces internally stored numerical | //| values with ones from another sparse matrix (but having exactly | //| same sparsity pattern as one that was used for initial | //| SparseCholeskyAnalyze() call). | //| NOTE: all internal processing is performed with lower triangular | //| matrices stored in CRS format. Any other storage formats | //| and/or upper triangular storage means that one format | //| conversion and/or one transposition will be performed | //| internally for the analysis and factorization phases. Thus,| //| highest performance is achieved when input is a lower | //| triangular CRS matrix. | //| INPUT PARAMETERS: | //| Analysis - analysis object | //| A - sparse square matrix in any sparse storage format. | //| It MUST have exactly same sparsity pattern as that | //| of the matrix that was passed to | //| SparseCholeskyAnalyze(). Any difference (missing | //| elements or additional elements) may result in | //| unpredictable and undefined behavior - an algorithm| //| may fail due to memory access violation. | //| IsUpper - whether upper or lower triangle is decomposed (the | //| other one is ignored). | //| OUTPUT PARAMETERS: | //| Analysis - contains: | //| * symbolic analysis of the matrix structure which will be | //| used later to guide numerical factorization. | //| * specific numeric values loaded into internal memory | //| waiting for the factorization to be performed | //+------------------------------------------------------------------+ void CTrFac::SparseCholeskyReload(CSparseDecompositionAnalysis &Analysis, CSparseMatrix &A, bool IsUpper) { //--- check if(!CAp::Assert(CSparse::SparseGetNRows(A)==CSparse::SparseGetNCols(A),__FUNCTION__+": A is not square")) return; if(!CAp::Assert(CSparse::SparseGetNRows(A)==Analysis.m_N,__FUNCTION__+": size of A does not match that stored in Analysis")) return; if(!CSparse::SparseIsCRS(A)) { //--- The matrix is stored in non-CRS format. First, we have to convert //--- it to CRS. Then we may need to transpose it in order to get lower //--- triangular one (as supported by SPSymmAnalyze). CSparse::SparseCopyToCRS(A,Analysis.m_CrsA); if(IsUpper) CSparse::SparseCopyTransposeCRSBuf(Analysis.m_CrsA,Analysis.m_CrsAT); CSpChol::SpSymmReload(Analysis.m_Analysis,Analysis.m_CrsA); } else { //--- The matrix is stored in CRS format. However we may need to //--- transpose it in order to get lower triangular one (as supported //--- by SPSymmAnalyze). if(IsUpper) { CSparse::SparseCopyTransposeCRSBuf(A,Analysis.m_CrsAT); CSpChol::SpSymmReload(Analysis.m_Analysis,Analysis.m_CrsAT); } else CSpChol::SpSymmReload(Analysis.m_Analysis,A); } } //+------------------------------------------------------------------+ //| LUP decomposition of general real matrix | //+------------------------------------------------------------------+ void CTrFac::RMatrixLUP(CMatrixDouble &A,const int m,const int n,int &pivots[]) { CRowInt Pivots; RMatrixLUP(A,m,n,Pivots); Pivots.ToArray(pivots); } //+------------------------------------------------------------------+ //| LUP decomposition of general real matrix | //+------------------------------------------------------------------+ void CTrFac::RMatrixLUP(CMatrixDouble &A,const int m,const int n,CRowInt &pivots) { //--- create variables int i=0; int j=0; double mx=0; double v=0; int i_=0; //--- create array CRowDouble tmp; //--- Internal LU decomposition subroutine. //--- Never call it directly. if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!")) return; if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- Scale matrix to avoid overflows, //--- decompose it, then scale back. mx=0; for(i=0; i0,__FUNCTION__+": incorrect M!")) return; if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- Scale matrix to avoid overflows, //--- decompose it, then scale back. mx=0; for(i=0; i0,__FUNCTION__+": incorrect M!")) return; if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- allocation tmp.Resize(2*MathMax(m,n)); pivots.Resize(MathMin(m,n)); //--- Scale matrix to avoid overflows, //--- decompose it, then scale back. mx=0; for(i=0; i0,__FUNCTION__+": incorrect M!")) return; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!")) return; //--- allocation tmp.Resize(2*MathMax(m,n)); pivots.Resize(MathMin(m,n)); //--- Scale matrix to avoid overflows, //--- decompose it, then scale back. mx=0; for(i=0; i0.0) { a.Set(Offs,Offs,MathSqrt(a.Get(Offs,Offs))); result=true; } //--- return result return(result); } if(n<=tsa) return(SPDMatrixCholesky2(a,Offs,n,IsUpper,tmp)); //--- Split task into smaller ones if(n>tsb) { //--- Split leading B-sized block from the beginning (block-matrix approach) n1=tsb; n2=n-n1; } else //--- Smaller than B-size, perform cache-oblivious split CApServ::TiledSplit(n,tsa,n1,n2); result=SPDMatrixCholeskyRec(a,Offs,n1,IsUpper,tmp); if(!result) return(result); if(n2>0) { if(IsUpper) { CAblas::RMatrixLeftTrsM(n1,n2,a,Offs,Offs,IsUpper,false,1,a,Offs,Offs+n1); CAblas::RMatrixSyrk(n2,n1,-1.0,a,Offs,Offs+n1,1,1.0,a,Offs+n1,Offs+n1,IsUpper); } else { CAblas::RMatrixRightTrsM(n2,n1,a,Offs,Offs,IsUpper,false,1,a,Offs+n1,Offs); CAblas::RMatrixSyrk(n2,n1,-1.0,a,Offs+n1,Offs,0,1.0,a,Offs+n1,Offs+n1,IsUpper); } result=SPDMatrixCholeskyRec(a,Offs+n1,n2,IsUpper,tmp); if(!result) return(result); } //--- return result return(result); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ class CDLU { public: static void CMatrixLUPRec(CMatrixComplex &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowComplex &tmp); static void RMatrixLUPRec(CMatrixDouble &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowDouble &tmp); static void CMatrixPLURec(CMatrixComplex &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowComplex &tmp); static void RMatrixPLURec(CMatrixDouble &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowDouble &tmp); private: static void CMatrixLUP2(CMatrixComplex &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowComplex &tmp); static void RMatrixLUP2(CMatrixDouble &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowDouble &tmp); static void CMatrixPLU2(CMatrixComplex &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowComplex &tmp); static void RMatrixPLU2(CMatrixDouble &a,const int Offs,const int m,const int n,CRowInt &pivots,CRowDouble &tmp); }; //+------------------------------------------------------------------+ //| Recurrent complex LU subroutine. | //| Never call it directly. | //+------------------------------------------------------------------+ void CDLU::CMatrixLUPRec(CMatrixComplex &a,const int Offs,const int m, const int n,CRowInt &pivots,CRowComplex &tmp) { //--- create variables int i=0; int m1=0; int m2=0; int i_=0; int i1_=0; complex One(1.0,0.0); complex _One(-1.0,0.0); //--- Kernel case if(MathMin(m,n)<=CAblas::AblasComplexBlockSize()) { CMatrixLUP2(a,Offs,m,n,pivots,tmp); //--- exit the function return; } //--- Preliminary step, make N>=M //--- ( A1 ) //--- A = ( ), where A1 is square //--- ( A2 ) //--- Factorize A1, update A2 if(m>n) { //--- function call CMatrixLUPRec(a,Offs,n,n,pivots,tmp); for(i=0; i0) { for(i=0; i=M //--- ( A1 ) //--- A = ( ), where A1 is square //--- ( A2 ) //--- Factorize A1, update A2 if(m>n) { //--- function call RMatrixLUPRec(a,Offs,n,n,pivots,tmp); for(i=0; i0) { for(i=0; i=N. //--- A = (A1 A2), where A1 is square //--- Factorize A1, update A2 if(n>m) { //--- function call CMatrixPLURec(a,Offs,m,m,pivots,tmp); for(i=0; itsb) { n1=tsb; n2=n-n1; } else { CApServ::TiledSplit(n,tsa,n1,n2); } //--- function call CMatrixPLURec(a,Offs,m,n1,pivots,tmp); //--- check if(n2>0) { for(i=0; i=N. //--- A = (A1 A2), where A1 is square //--- Factorize A1, update A2 if(n>m) { //--- function call RMatrixPLURec(a,Offs,m,m,pivots,tmp); for(i=0; itsb) { n1=tsb; n2=n-n1; } else { CApServ::TiledSplit(n,tsa,n1,n2); } //--- function call RMatrixPLURec(a,Offs,m,n1,pivots,tmp); //--- check if(n2>0) { for(i=0; iCMath::AbsComplex(a.Get(Offs+j,Offs+jp))) jp=i; } pivots.Set(Offs+j,Offs+jp); //--- check if(jp!=j) { i1_=Offs; for(i_=0; i_MathAbs(a.Get(Offs+j,Offs+jp))) jp=i; } pivots.Set(Offs+j,Offs+jp); //--- check if(jp!=j) { i1_=Offs; for(i_=0; i_CMath::AbsComplex(a.Get(Offs+jp,Offs+j))) jp=i; } pivots.Set(Offs+j,Offs+jp); if(a.Get(Offs+jp,Offs+j)!=zero) { //--- Apply the interchange to rows if(jp!=j) { for(i=0; iMathAbs(a.Get(Offs+jp,Offs+j))) jp=i; } pivots.Set(Offs+j,Offs+jp); //--- check if(a.Get(Offs+jp,Offs+j)!=0.0) { //--- Apply the interchange to rows if(jp!=j) { for(i=0; i256. if(n==1) { //--- check if(a.Get(Offs,Offs).real>0.0) { a.Set(Offs,Offs,MathSqrt(a.Get(Offs,Offs).real)); result=true; } //--- return result return(result); } //--- check if(n<=tsa) return(HPDMatrixCholesky2(a,Offs,n,IsUpper,tmp)); //--- Split task into smaller ones if(n>tsb) { //--- Split leading B-sized block from the beginning (block-matrix approach) n1=tsb; n2=n-n1; } else //--- Smaller than B-size, perform cache-oblivious split CApServ::TiledSplit(n,tsa,n1,n2); result=HPDMatrixCholeskyRec(a,Offs,n1,IsUpper,tmp); if(!result) return(result); if(n2>0) { if(IsUpper) { CAblas::CMatrixLeftTrsM(n1,n2,a,Offs,Offs,IsUpper,false,2,a,Offs,Offs+n1); CAblas::CMatrixHerk(n2,n1,-1.0,a,Offs,Offs+n1,2,1.0,a,Offs+n1,Offs+n1,IsUpper); } else { CAblas::CMatrixRightTrsM(n2,n1,a,Offs,Offs,IsUpper,false,2,a,Offs+n1,Offs); CAblas::CMatrixHerk(n2,n1,-1.0,a,Offs+n1,Offs,0,1.0,a,Offs+n1,Offs+n1,IsUpper); } result=HPDMatrixCholeskyRec(a,Offs+n1,n2,IsUpper,tmp); if(!result) return(result); } //--- return result return(result); } //+------------------------------------------------------------------+ //| Level-2 Hermitian Cholesky subroutine. | //| -- LAPACK routine (version 3.0) -- | //| Univ. of Tennessee,Univ. of California Berkeley,NAG Ltd., | //| Courant Institute,Argonne National Lab,and Rice University | //| February 29,1992 | //+------------------------------------------------------------------+ bool CTrFac::HPDMatrixCholesky2(CMatrixComplex &AAA,const int Offs, const int n,const bool IsUpper,CRowComplex &tmp) { //--- check if(n<0) return(false); //--- check if(n==0) return(true); //--- create variables bool result=true; int i=0; int j=0; double ajj=0; complex v=0; double r=0; int i_=0; int i1_=0; //--- check if(IsUpper) { //--- Compute the Cholesky factorization A = U'*U. for(j=0; j0) { i1_=Offs; for(i_=0; i_0) { i1_=Offs; for(i_=0; i_0) { i1_=Offs; for(i_=0; i_0) { i1_=Offs; for(i_=0; i_=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; //--- create arrays CRowInt pivots; CRowDouble t; //--- create copy CMatrixDouble a=ca; //--- fiiling array t=(a.Abs()+0).Sum(0); if(t.Size()>n) t.Resize(n); //--- change values nrm=t.Max(); //--- function call CTrFac::RMatrixLU(a,n,n,pivots); //--- function call RMatrixRCondLUInternal(a,n,true,true,nrm,v); //--- return result return(v); } //+------------------------------------------------------------------+ //| Estimate of a matrix condition number (infinity-norm). | //| The algorithm calculates a lower bound of the condition number. | //| In this case, the algorithm does not return a lower bound of the | //| condition number, but an inverse number (to avoid an overflow in | //| case of a singular matrix). | //| Input parameters: | //| A - matrix. Array whose indexes range within | //| [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| Result: 1/LowerBound(cond(A)) | //| NOTE: | //| if k(A) is very large, then matrix is assumed degenerate, | //| k(A)=INF, 0.0 is returned in such cases. | //+------------------------------------------------------------------+ double CRCond::RMatrixRCondInf(CMatrixDouble &ca,const int n) { //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; //--- create array CRowInt pivots; //--- create copy CMatrixDouble a=ca; a.Resize(n,n); //--- change values nrm=(a.Abs()+0).CumSum(1).Col(n-1).Max(); //--- function call CTrFac::RMatrixLU(a,n,n,pivots); //--- function call RMatrixRCondLUInternal(a,n,false,true,nrm,v); //--- return result return(v); } //+------------------------------------------------------------------+ //| Condition number estimate of a symmetric positive definite | //| matrix. | //| The algorithm calculates a lower bound of the condition number. | //| In this case, the algorithm does not return a lower bound of the | //| condition number, but an inverse number (to avoid an overflow in | //| case of a singular matrix). | //| It should be noted that 1-norm and inf-norm of condition numbers | //| of symmetric matrices are equal, so the algorithm doesn't take | //| into account the differences between these types of norms. | //| Input parameters: | //| A - symmetric positive definite matrix which is given| //| by its upper or lower triangle depending on the | //| value of IsUpper. Array with elements | //| [0..N-1, 0..N-1]. | //| N - size of matrix A. | //| IsUpper - storage format. | //| Result: | //| 1/LowerBound(cond(A)), if matrix A is positive definite, | //| -1, if matrix A is not positive definite, and its condition | //| number could not be found by this algorithm. | //| NOTE: | //| if k(A) is very large, then matrix is assumed degenerate, | //| k(A)=INF, 0.0 is returned in such cases. | //+------------------------------------------------------------------+ double CRCond::SPDMatrixRCond(CMatrixDouble &ca,const int n,const bool IsUpper) { //--- create variables double result=0; int i=0; int j=0; int j1=0; int j2=0; double v=0; double nrm=0; //--- create array CRowDouble t; //--- create copy CMatrixDouble a=ca; //--- allocation t=vector::Zeros(n); //--- fiiling array for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; int j1=0; int j2=0; //--- create arrays CRowInt pivots; CRowDouble t; //--- allocation t=vector::Zeros(n); //--- fiiling array for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; int j1=0; int j2=0; //--- create array CRowInt pivots; //--- change values for(i=0; i::Zeros(n); //--- fiiling array for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- allocation t=vector::Zeros(n); //--- fiiling array for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- change values nrm=0; for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- function call CMatrixRCondLUInternal(lua,n,true,false,0.0,v); //--- return result return(v); } //+------------------------------------------------------------------+ //| Estimate of the condition number of a matrix given by its LU | //| decomposition (infinity norm). | //| The algorithm calculates a lower bound of the condition number. | //| In this case, the algorithm does not return a lower bound of the | //| condition number, but an inverse number (to avoid an overflow in | //| case of a singular matrix). | //| Input parameters: | //| LUA - LU decomposition of a matrix in compact form. | //| Output of the CMatrixLU subroutine. | //| N - size of matrix A. | //| Result: 1/LowerBound(cond(A)) | //| NOTE: | //| if k(A) is very large, then matrix is assumed degenerate, | //| k(A)=INF, 0.0 is returned in such cases. | //+------------------------------------------------------------------+ double CRCond::CMatrixLURCondInf(CMatrixComplex &lua,const int n) { //--- create a variable double v=0; //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- function call CMatrixRCondLUInternal(lua,n,false,false,0.0,v); //--- return result return(v); } //+------------------------------------------------------------------+ //| Triangular matrix: estimate of a condition number (1-norm) | //| The algorithm calculates a lower bound of the condition number. | //| In this case, the algorithm does not return a lower bound of the | //| condition number, but an inverse number (to avoid an overflow in | //| case of a singular matrix). | //| Input parameters: | //| A - matrix. Array[0..N-1, 0..N-1]. | //| N - size of A. | //| IsUpper - True, if the matrix is upper triangular. | //| IsUnit - True, if the matrix has a unit diagonal. | //| Result: 1/LowerBound(cond(A)) | //| NOTE: | //| if k(A) is very large, then matrix is assumed degenerate, | //| k(A)=INF, 0.0 is returned in such cases. | //+------------------------------------------------------------------+ double CRCond::CMatrixTrRCond1(CMatrixComplex &a,const int n, const bool IsUpper,const bool IsUnit) { //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; int j1=0; int j2=0; //--- create arrays CRowInt pivots; CRowDouble t; //--- allocation t=vector::Zeros(n); //--- fiiling array for(i=0; i=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); //--- create variables int i=0; int j=0; double v=0; double nrm=0; int j1=0; int j2=0; //--- create array CRowInt pivots; //--- change values nrm=0; for(i=0; i0 after this block if(anorm==0.0) return; //--- check if(n==1) { rc=1; return; } //--- Estimate the norm of inv(A). while(true) { //--- function call RMatrixEstimateNorm(n,ev,ex,iwork,ainvnm,kase); //--- check if(kase==0) break; //--- from 1-based array to 0-based for(i=0; i=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { rc=1/ainvnm; rc=rc/anorm; //--- check if(rc=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { rc=1/ainvnm; rc=rc/anorm; //--- check if(rc=1,__FUNCTION__+": N<=0")) return; //--- create variables int i=0; int j=0; int kase=0; double ainvnm=0; double sa=0; double v=0; double maxgrowth=0; int i_=0; int i1_=0; //--- create arrays CRowDouble ex; CRowDouble ev; CRowDouble tmp; CRowInt iwork; //--- allocation tmp.Resize(n); //--- initialization rc=0; //--- prepare parameters for triangular solver maxgrowth=1/RCondThreshold(); //--- check if(IsUpper) { for(i=0; i::Zeros(n); for(i=0; i::Zeros(n); for(i=0; i=1; i--) { i1_=1; v=0.0; for(i_=0; i_=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { v=1/ainvnm; rc=v/anorm; //--- check if(rc=1,__FUNCTION__+": N<=0")) return; //--- create variables complex Csa; int kase=0; double ainvnm=0; complex v=0; int i=0; int j=0; double sa=0; double maxgrowth=0; int i_=0; int i1_=0; //--- create arrays CRowInt isave; CRowDouble rsave; CRowComplex ex; CRowComplex ev; CRowComplex tmp; //--- allocation tmp.Resize(n); //--- initialization rc=0; //--- prepare parameters for triangular solver maxgrowth=1/RCondThreshold(); //--- check if(IsUpper) { for(i=0; i::Full(n,0); for(i=0; i::Full(n,0); for(i=0; i=1; i--) { i1_=1; v=0.0; for(i_=0; i_0 if(anorm==0.0) return; //--- check if(n==1) { rc=1; return; } //--- Estimate the norm of inv(A). ainvnm=0; kase=0; while(true) { //--- function call CMatrixEstimateNorm(n,ev,ex,ainvnm,kase,isave,rsave); //--- check if(kase==0) break; for(i=0; i=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { rc=1/ainvnm; rc=rc/anorm; //--- check if(rc=1; i--) { //--- check if(i>1) { i1_=1; v=0.0; for(i_=0; i_<=i-2; i_++) v+=lua.Get(i-1,i_)*ex[i_+i1_]; } else continue; ex.Set(i,ex[i]+v); } } else { //--- Multiply by L' tmp=vector::Zeros(n); for(i=0; i=1) { for(i_=0; i_::Zeros(n); for(i=0; i0 after this block if(anorm==0.0) return; //--- check if(n==1) { rc=1; return; } //--- Estimate the norm of inv(A). ainvnm=0; kase=0; while(true) { //--- function call RMatrixEstimateNorm(n,ev,ex,iwork,ainvnm,kase); //--- check if(kase==0) break; //--- from 1-based array to 0-based for(i=0; i=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { rc=1/ainvnm; rc=rc/anorm; //--- check if(rc=1; i--) { v=0; //--- check if(i>1) { i1_=1; v=0.0; for(i_=0; i_<=i-2; i_++) v+=lua.Get(i-1,i_)*ex[i_+i1_]; } ex.Set(i,v+ex[i]); } } else { //--- Multiply by L' cwork2=vector::Full(n+1,0); for(i=1; i<=n; i++) { v=ex[i]; //--- check if(i>1) { i1_=-1; for(i_=1; i_::Full(n+1,0); for(i=1; i<=n; i++) { v=cwork2[i]; i1_=-1; for(i_=i; i_<=n; i_++) ex.Set(i_,ex[i_]+v*CMath::Conj(lua.Get(i-1,i_+i1_))); } } } } while(kase!=0); } //--- Scale according to SU/SL anorm*=su*sl; //--- check if(anorm==0.0) return; //--- Estimate the norm of inv(A). ainvnm=0; //--- check if(onenorm) kase1=1; else kase1=2; kase=0; while(true) { //--- function call CMatrixEstimateNorm(n,cwork4,ex,ainvnm,kase,isave,rsave); //--- check if(kase==0) break; //--- from 1-based array to 0-based for(i=0; i=0; i--) ex.Set(i+1,ex[i]); } //--- Compute the estimate of the reciprocal condition number. if(ainvnm!=0.0) { rc=1/ainvnm; rc=rc/anorm; //--- check if(rc::Zeros(n+4); isgn.Resize(n+5); isgn.Fill(0); //--- change values t=1.0/(double)n; x=vector::Full(n+1,t); x.Set(0,0); kase=1; isgn.Set(posjump,1); //--- exit the function return; } switch(isgn[posjump]) { case 1: //--- ................ entry (jump = 1) //--- first iteration. x has been overwritten by a*x. //--- check if(n==1) { v.Set(1,x[1]); est=MathAbs(v[1]); kase=0; //--- exit the function return; } //--- change value est=0; for(i=1; i<=n; i++) { est+=MathAbs(x[i]); //--- check if(x[i]>=0.0) x.Set(i,1); else x.Set(i,-1); isgn.Set(i,(int)x[i]); } kase=2; isgn.Set(posjump,2); break; case 2: //--- ................ entry (jump = 2) //--- first iteration. x has been overwritten by trandpose(a)*x. isgn.Set(posj,1); for(i=2; i<=n; i++) { //--- check if(MathAbs(x[i])>MathAbs(x[isgn[posj]])) isgn.Set(posj,i); } isgn.Set(positer,2); //--- main loop - iterations 2,3,...,itmax. x=vector::Zeros(n+1); x.Set(isgn[posj],1); kase=1; isgn.Set(posjump,3); break; case 3: //--- ................ entry (jump = 3) //--- x has been overwritten by a*x. for(i_=1; i_<=n; i_++) v.Set(i_,x[i_]); v.Set(posestold,est); //--- change value est=0; flg=false; for(i=1; i<=n; i++) { est+=MathAbs(v[i]); if(((x[i]>=0.0) && (isgn[i]<0)) || ((x[i]<0.0) && (isgn[i]>=0))) flg=true; } //--- repeated sign vector detected, hence algorithm has converged. //--- or may be cycling. if(!flg || est<=v[posestold]) { v.Set(posaltsgn,1); for(i=1; i<=n; i++) { x.Set(i,v[posaltsgn]*(1+(double)(i-1)/(double)(n-1))); v.Set(posaltsgn,-v[posaltsgn]); } kase=1; isgn.Set(posjump,5); //--- exit the function break; } for(i=1; i<=n; i++) { //--- check if(x[i]>=0.0) { x.Set(i,1); isgn.Set(i,1); } else { x.Set(i,-1); isgn.Set(i,-1); } } kase=2; isgn.Set(posjump,4); break; case 4: //--- ................ entry (jump = 4) //--- x has been overwritten by trandpose(a)*x. isgn.Set(posjlast,isgn[posj]); isgn.Set(posj,1); for(i=2; i<=n; i++) { //--- check if(MathAbs(x[i])>MathAbs(x[isgn[posj]])) isgn.Set(posj,i); } //--- check if(x[isgn[posjlast]]!=MathAbs(x[isgn[posj]]) && isgn[positer]::Zeros(n+1); x.Set(isgn[posj],1); kase=1; isgn.Set(posjump,3); //--- exit the function break; } //--- iteration complete. final stage. v.Set(posaltsgn,1); for(i=1; i<=n; i++) { x.Set(i,v[posaltsgn]*(1+(double)(i-1)/(double)(n-1))); v.Set(posaltsgn,-v[posaltsgn]); } kase=1; isgn.Set(posjump,5); //--- exit the function break; case 5: //--- ................ entry (jump = 5) //--- x has been overwritten by a*x. v.Set(postemp,0); for(i=1; i<=n; i++) v.Add(postemp,MathAbs(x[i])); v.Mul(postemp,2.0/(3.0*n)); //--- check if(v[postemp]>est) { for(i_=1; i_<=n; i_++) v.Set(i_,x[i_]); est=v[postemp]; } kase=0; //--- exit the function break; } } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CRCond::CMatrixEstimateNorm(const int n,CRowComplex &v,CRowComplex &x, double &est,int &kase,CRowInt &isave, CRowDouble &rsave) { //--- create variables int itmax=5; int i=0; int iter=0; int j=0; int jlast=0; int jump=0; double absxi=0; double altsgn=0; double estold=0; double safmin=CMath::m_minrealnumber; double temp=0; int i_=0; //--- check if(kase==0) { //--- allocation v.Resize(n+1); x=vector::Full(n+1,(1.0/(double)n)); x.Set(0,0.0); isave.Resize(5); rsave.Resize(4); kase=1; jump=1; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function return; } //--- function call InternalComplexRCondLoadAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); switch(jump) { case 1: //--- entry (jump = 1) //--- first iteration. x has been overwritten by a*x. //--- check if(n==1) { v.Set(1,x[1]); //--- function call est=CMath::AbsComplex(v[1]); kase=0; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function return; } //--- function call est=InternalComplexRCondScSum1(x,n); for(i=1; i<=n; i++) { //--- function call absxi=CMath::AbsComplex(x[i]); //--- check if(absxi>safmin) x.Set(i,x[i]/absxi); else x.Set(i,1.0); } kase=2; jump=2; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; case 2: //--- entry (jump = 2) //--- first iteration. x has been overwritten by ctrans(a)*x. j=InternalComplexRCondIcMax1(x,n); iter=2; //--- main loop - iterations 2,3,...,itmax. x=vector::Full(n+1,0); x.Set(j,1.0); kase=1; jump=3; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; case 3: //--- entry (jump = 3) //--- x has been overwritten by a*x. v=x; estold=est; //--- function call est=InternalComplexRCondScSum1(v,n); //--- test for cycling. if(est<=estold) { //--- iteration complete. final stage. altsgn=1; for(i=1; i<=n; i++) { x.Set(i,altsgn*(1+(double)(i-1)/(double)(n-1))); altsgn=-altsgn; } kase=1; jump=5; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; } for(i=1; i<=n; i++) { absxi=CMath::AbsComplex(x[i]); //--- check if(absxi>safmin) x.Set(i,x[i]/absxi); else x.Set(i,1.0); } kase=2; jump=4; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; case 4: //--- entry (jump = 4) //--- x has been overwritten by ctrans(a)*x. jlast=j; j=InternalComplexRCondIcMax1(x,n); //--- check if(CMath::AbsComplex(x[jlast])!=CMath::AbsComplex(x[j]) && iter::Full(n+1,0); x.Set(j,1.0); kase=1; jump=3; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; } //--- iteration complete. final stage. altsgn=1; for(i=1; i<=n; i++) { x.Set(i,altsgn*(1+(double)(i-1)/(double)(n-1))); altsgn=-altsgn; } kase=1; jump=5; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; case 5: //--- entry (jump = 5) //--- x has been overwritten by a*x. temp=2*(InternalComplexRCondScSum1(x,n)/(3*n)); //--- check if(temp>est) { v=x; est=temp; } kase=0; //--- function call InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp); //--- exit the function break; } } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ double CRCond::InternalComplexRCondScSum1(CRowComplex &x,const int n) { double result=0; //--- get result for(int i=1; i<=n; i++) result=result+CMath::AbsComplex(x[i]); //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ int CRCond::InternalComplexRCondIcMax1(CRowComplex &x,const int n) { //--- create variables int result=1; double m=CMath::AbsComplex(x[1]); //--- get result for(int i=2; i<=n; i++) { //--- check if(CMath::AbsComplex(x[i])>m) { result=i; m=CMath::AbsComplex(x[i]); } } //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CRCond::InternalComplexRCondSaveAll(CRowInt &isave,CRowDouble &rsave, int &i,int &iter,int &j, int &jlast,int &jump, double &absxi,double &altsgn, double &estold,double &temp) { //--- copy isave.Set(0,i); isave.Set(1,iter); isave.Set(2,j); isave.Set(3,jlast); isave.Set(4,jump); //--- copy rsave.Set(0,absxi); rsave.Set(1,altsgn); rsave.Set(2,estold); rsave.Set(3,temp); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CRCond::InternalComplexRCondLoadAll(CRowInt &isave, CRowDouble &rsave,int &i, int &iter,int &j,int &jlast, int &jump,double &absxi, double &altsgn,double &estold, double &temp) { //--- get i=isave[0]; iter=isave[1]; j=isave[2]; jlast=isave[3]; jump=isave[4]; //--- get absxi=rsave[0]; altsgn=rsave[1]; estold=rsave[2]; temp=rsave[3]; } //+------------------------------------------------------------------+ //| Matrix inverse report: | //| * R1 reciprocal of condition number in 1-norm | //| * RInf reciprocal of condition number in inf-norm | //+------------------------------------------------------------------+ class CMatInvReport { public: double m_r1; double m_rinf; //--- constructor, destructor CMatInvReport(void) { m_r1=0; m_rinf=0; } ~CMatInvReport(void) {} //--- void Copy(const CMatInvReport &obj); //--- overloading void operator=(const CMatInvReport &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Copy | //+------------------------------------------------------------------+ void CMatInvReport::Copy(const CMatInvReport &obj) { m_r1=obj.m_r1; m_rinf=obj.m_rinf; } //+------------------------------------------------------------------+ //| Matrix inverse report: | //| * R1 reciprocal of condition number in 1-norm | //| * RInf reciprocal of condition number in inf-norm | //+------------------------------------------------------------------+ class CMatInvReportShell { private: CMatInvReport m_innerobj; public: //--- constructors, destructor CMatInvReportShell(void) {} CMatInvReportShell(CMatInvReport &obj); ~CMatInvReportShell(void) {} //--- methods double GetR1(void); void SetR1(double r); double GetRInf(void); void SetRInf(double r); CMatInvReport *GetInnerObj(void); }; //+------------------------------------------------------------------+ //| Copy | //+------------------------------------------------------------------+ CMatInvReportShell::CMatInvReportShell(CMatInvReport &obj) { m_innerobj.m_r1=obj.m_r1; m_innerobj.m_rinf=obj.m_rinf; } //+------------------------------------------------------------------+ //| Returns the value of the variable r1 | //+------------------------------------------------------------------+ double CMatInvReportShell::GetR1(void) { return(m_innerobj.m_r1); } //+------------------------------------------------------------------+ //| Changing the value of the variable r1 | //+------------------------------------------------------------------+ void CMatInvReportShell::SetR1(double r) { m_innerobj.m_r1=r; } //+------------------------------------------------------------------+ //| Returns the value of the variable rinf | //+------------------------------------------------------------------+ double CMatInvReportShell::GetRInf(void) { return(m_innerobj.m_rinf); } //+------------------------------------------------------------------+ //| Changing the value of the variable rint | //+------------------------------------------------------------------+ void CMatInvReportShell::SetRInf(double r) { m_innerobj.m_rinf=r; } //+------------------------------------------------------------------+ //| Return object of class | //+------------------------------------------------------------------+ CMatInvReport *CMatInvReportShell::GetInnerObj(void) { return(GetPointer(m_innerobj)); } //+------------------------------------------------------------------+ //| Inverse matrix | //+------------------------------------------------------------------+ class CMatInv { public: static void RMatrixLUInverse(CMatrixDouble &a,int &pivots[],const int n,int &info,CMatInvReport &rep); static void RMatrixLUInverse(CMatrixDouble &a,CRowInt &pivots,const int n,int &info,CMatInvReport &rep); static void RMatrixInverse(CMatrixDouble &a,const int n,int &info,CMatInvReport &rep); static void SPDMatrixCholeskyInverse(CMatrixDouble &a,const int n,const bool IsUpper,int &info,CMatInvReport &rep); static void SPDMatrixInverse(CMatrixDouble &a,const int n,const bool IsUpper,int &info,CMatInvReport &rep); static void RMatrixTrInverse(CMatrixDouble &a,const int n,const bool IsUpper,const bool IsUnit,int &info,CMatInvReport &rep); static void CMatrixLUInverse(CMatrixComplex &a,int &pivots[],const int n,int &info,CMatInvReport &rep); static void CMatrixLUInverse(CMatrixComplex &a,CRowInt &pivots,const int n,int &info,CMatInvReport &rep); static void CMatrixInverse(CMatrixComplex &a,const int n,int &info,CMatInvReport &rep); static void HPDMatrixCholeskyInverse(CMatrixComplex &a,const int n,const bool IsUpper,int &info,CMatInvReport &rep); static void HPDMatrixInverse(CMatrixComplex &a,const int n,const bool IsUpper,int &info,CMatInvReport &rep); static void CMatrixTrInverse(CMatrixComplex &a,const int n,const bool IsUpper,const bool IsUnit,int &info,CMatInvReport &rep); static void SPDMatrixCholeskyInverseRec(CMatrixDouble &a,const int Offs,const int n,const bool IsUpper,CRowDouble &tmp); private: static void RMatrixTrInverseRec(CMatrixDouble &a,const int Offs,const int n,const bool IsUpper,const bool IsUnit,CRowDouble &tmp,int &info); static void CMatrixTrInverseRec(CMatrixComplex &a,const int Offs,const int n,const bool IsUpper,const bool IsUnit,CRowComplex &tmp,int &info); static void RMatrixLUInverseRec(CMatrixDouble &a,const int Offs,const int n,CRowDouble &work,int &info,CMatInvReport &rep); static void CMatrixLUInverseRec(CMatrixComplex &a,const int Offs,const int n,CRowComplex &work,int &info,CMatInvReport &rep); static void HPDMatrixCholeskyInverseRec(CMatrixComplex &a,const int Offs,const int n,const bool IsUpper,CRowComplex &tmp); }; //+------------------------------------------------------------------+ //| Inversion of a matrix given by its LU decomposition. | //| INPUT PARAMETERS: | //| A - LU decomposition of the matrix | //| (output of RMatrixLU subroutine). | //| Pivots - table of permutations | //| (the output of RMatrixLU subroutine). | //| N - size of matrix A (optional) : | //| * if given, only principal NxN submatrix is | //| processed and overwritten. other elements are | //| unchanged. | //| * if not given, size is automatically determined | //| from matrix size (A must be square matrix) | //| OUTPUT PARAMETERS: | //| Info - return code: | //| * -3 A is singular, or VERY close to singular.| //| it is filled by zeros in such cases. | //| * 1 task is solved (but matrix A may be | //| ill-conditioned, check R1/RInf parameters| //| for condition numbers). | //| Rep - solver report, see below for more info | //| A - inverse of matrix A. | //| Array whose indexes range within | //| [0..N-1, 0..N-1]. | //| SOLVER REPORT | //| Subroutine sets following fields of the Rep structure: | //| * R1 reciprocal of condition number: 1/cond(A), 1-norm. | //| * RInf reciprocal of condition number: 1/cond(A), inf-norm. | //+------------------------------------------------------------------+ void CMatInv::RMatrixLUInverse(CMatrixDouble &a,int &pivots[], const int n,int &info,CMatInvReport &rep) { //--- create variables CRowInt Pivots=pivots; RMatrixLUInverse(a,Pivots,n,info,rep); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void CMatInv::RMatrixLUInverse(CMatrixDouble &a,CRowInt &pivots, const int n,int &info,CMatInvReport &rep) { //--- create variables int i=0; int j=0; int k=0; double v=0; //--- create array CRowDouble work; //--- initialization info=0; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": len(Pivots)n-1 || pivots[i]0,__FUNCTION__+": incorrect Pivots array!")) return; //--- calculate condition numbers rep.m_r1=CRCond::RMatrixLURCond1(a,n); rep.m_rinf=CRCond::RMatrixLURCondInf(a,n); //--- check if(rep.m_r1=0; j--) { k=pivots[j]; v=a.Get(i,j); a.Set(i,j,a.Get(i,k)); a.Set(i,k,v); } } } //+------------------------------------------------------------------+ //| Inversion of a general matrix. | //| Input parameters: | //| A - matrix. | //| N - size of matrix A (optional) : | //| * if given, only principal NxN submatrix is | //| processed and overwritten. other elements are | //| unchanged. | //| * if not given, size is automatically determined | //| from matrix size (A must be square matrix) | //| Output parameters: | //| Info - return code, same as in RMatrixLUInverse | //| Rep - solver report, same as in RMatrixLUInverse | //| A - inverse of matrix A, same as in RMatrixLUInverse | //| Result: | //| True, if the matrix is not singular. | //| False, if the matrix is singular. | //+------------------------------------------------------------------+ void CMatInv::RMatrixInverse(CMatrixDouble &a,const int n,int &info, CMatInvReport &rep) { //--- create array CRowInt pivots; //--- initialization info=0; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!")) return; //--- check if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": len(Pivots)n-1 || pivots[i]0,__FUNCTION__+": incorrect Pivots array!")) return; //--- calculate condition numbers rep.m_r1=CRCond::CMatrixLURCond1(a,n); rep.m_rinf=CRCond::CMatrixLURCondInf(a,n); //--- check double check=CRCond::RCondThreshold(); if(rep.m_r1::Zeros(n,n); //--- change values rep.m_r1=0; rep.m_rinf=0; info=-3; //--- exit the function return; } //--- Call cache-oblivious code work.Resize(n); CMatrixLUInverseRec(a,0,n,work,info,rep); //--- apply permutations for(i=0; i=0; j--) { k=pivots[j]; v=a.Get(i,j); a.Set(i,j,a.Get(i,k)); a.Set(i,k,v); } } } //+------------------------------------------------------------------+ //| Inversion of a general matrix. | //| Input parameters: | //| A - matrix | //| N - size of matrix A (optional) : | //| * if given, only principal NxN submatrix is | //| processed and overwritten. other elements are | //| unchanged. | //| * if not given, size is automatically determined | //| from matrix size (A must be square matrix) | //| Output parameters: | //| Info - return code, same as in RMatrixLUInverse | //| Rep - solver report, same as in RMatrixLUInverse | //| A - inverse of matrix A, same as in RMatrixLUInverse | //+------------------------------------------------------------------+ void CMatInv::CMatrixInverse(CMatrixComplex &a,const int n,int &info, CMatInvReport &rep) { //--- create array CRowInt pivots; //--- initialization info=0; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; //--- check if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)0,__FUNCTION__+": N<=0!")) return; if(!CAp::Assert((int)CAp::Cols(a)>=n,__FUNCTION__+": cols(A)=n,__FUNCTION__+": rows(A)::Zeros(n,n); //--- change values rep.m_r1=0; rep.m_rinf=0; info=-3; //--- exit the function return; } //--- Inverse tmp.Resize(n); CMatrixTrInverseRec(a,0,n,IsUpper,IsUnit,tmp,info); } //+------------------------------------------------------------------+ //| Triangular matrix inversion, recursive subroutine | //+------------------------------------------------------------------+ void CMatInv::RMatrixTrInverseRec(CMatrixDouble &a,const int Offs, const int n,const bool IsUpper, const bool IsUnit,CRowDouble &tmp, int &info) { //--- check if(n<1) { info=-1; //--- exit the function return; } //--- create variables int n1=0; int n2=0; int i=0; int j=0; double v=0; double ajj=0; int i_=0; int i1_=0; int tsa=CApServ::MatrixTileSizeA(); int tsb=CApServ::MatrixTileSizeB(); int tscur=tsb; if(n<=tsb) tscur=tsa; //--- base case if(n<=tsa) { //--- check if(IsUpper) { //--- Compute inverse of upper triangular matrix. for(j=0; j0) { for(i_=Offs; i_<(Offs+j); i_++) tmp.Set(i_,a.Get(i_,Offs+j)); for(i=0; i=0; j--) { //--- check if(!IsUnit) { //--- check if(a.Get(Offs+j,Offs+j)==0.0) { info=-3; //--- exit the function return; } a.Set(Offs+j,Offs+j,(1.0/a.Get(Offs+j,Offs+j))); ajj=-a.Get(Offs+j,Offs+j); } else ajj=-1; //--- check if(jj+1) { for(i_=Offs+j+1; i_0) { //--- check if(IsUpper) { for(i=0; i0) { for(i_=Offs; i_<(Offs+j); i_++) tmp.Set(i_,a.Get(i_,Offs+j)); for(i=0; i=0; j--) { //--- check if(!IsUnit) { //--- check if(a.Get(Offs+j,Offs+j)==0) { info=-3; //--- exit the function return; } a.Set(Offs+j,Offs+j,One/a.Get(Offs+j,Offs+j)); ajj=-a.Get(Offs+j,Offs+j); } else ajj=-1; //--- check if(jj+1) { for(i_=Offs+j+1; i_0) { //--- check if(IsUpper) { for(i=0; i=0; j--) { //--- Copy current column of L to WORK and replace with zeros. for(i=j+1; i0,__FUNCTION__+": internal error!")) return; //--- X := inv(U1)*U12 //--- Y := L12*inv(L1) CAblas::RMatrixLeftTrsM(n1,n2,a,Offs,Offs,true,false,0,a,Offs,Offs+n1); CAblas::RMatrixRightTrsM(n2,n1,a,Offs,Offs,false,true,0,a,Offs+n1,Offs); //--- X := X*inv(U2) //--- Y := inv(L2)*Y //--- W := inv(L1*U1) CAblas::RMatrixRightTrsM(n1,n2,a,Offs+n1,Offs+n1,true,false,0,a,Offs,Offs+n1); CAblas::RMatrixLeftTrsM(n2,n1,a,Offs+n1,Offs+n1,false,true,0,a,Offs+n1,Offs); RMatrixLUInverseRec(a,Offs,n1,work,info,rep); //--- check if(info<=0) return; //--- W := W+X*Y CAblas::RMatrixGemm(n1,n1,n2,1.0,a,Offs,Offs+n1,0,a,Offs+n1,Offs,0,1.0,a,Offs,Offs); //--- X :=-X*inv(L2) //--- Y :=-inv(U2)*Y CAblas::RMatrixRightTrsM(n1,n2,a,Offs+n1,Offs+n1,false,true,0,a,Offs,Offs+n1); CAblas::RMatrixLeftTrsM(n2,n1,a,Offs+n1,Offs+n1,true,false,0,a,Offs+n1,Offs); for(i=0; i=0; j--) { //--- Copy current column of L to WORK and replace with zeros. for(i=j+1; i0,__FUNCTION__+": internal error!")) return; //--- X := inv(U1)*U12 //--- Y := L12*inv(L1) CAblas::CMatrixLeftTrsM(n1,n2,a,Offs,Offs,true,false,0,a,Offs,Offs+n1); CAblas::CMatrixRightTrsM(n2,n1,a,Offs,Offs,false,true,0,a,Offs+n1,Offs); //--- X := X*inv(U2) //--- Y := inv(L2)*Y //--- W := inv(L1*U1) CAblas::CMatrixRightTrsM(n1,n2,a,Offs+n1,Offs+n1,true,false,0,a,Offs,Offs+n1); CAblas::CMatrixLeftTrsM(n2,n1,a,Offs+n1,Offs+n1,false,true,0,a,Offs+n1,Offs); CMatrixLUInverseRec(a,Offs,n1,work,info,rep); //--- check if(info<=0) return; //--- W := W+X*Y CAblas::CMatrixGemm(n1,n1,n2,One,a,Offs,Offs+n1,0,a,Offs+n1,Offs,0,One,a,Offs,Offs); //--- X :=-X*inv(L2) //--- Y :=-inv(U2)*Y CAblas::CMatrixRightTrsM(n1,n2,a,Offs+n1,Offs+n1,false,true,0,a,Offs,Offs+n1); CAblas::CMatrixLeftTrsM(n2,n1,a,Offs+n1,Offs+n1,true,false,0,a,Offs+n1,Offs); for(i=0; i0,__FUNCTION__+": integrity check failed")) return; //--- check if(IsUpper) { //--- Compute the product U * U'. //--- NOTE: we never assume that diagonal of U is real for(i=0; i0,__FUNCTION__+": integrity check failed")) return; //--- check if(IsUpper) { //--- Compute the product U * U'. //--- NOTE: we never assume that diagonal of U is real for(i=0; i0, contains matrix U*Q. | //| VT - if NCVT>0, contains matrix (P^T)*VT. | //| C - if NCC>0, contains matrix Q'*C. | //| Result: | //| True, if the algorithm has converged. | //| False, if the algorithm hasn't converged (rare case). | //| Additional information: | //| The type of convergence is controlled by the internal | //| parameter TOL. If the parameter is greater than 0, the | //| singular values will have relative accuracy TOL. If TOL<0, | //| the singular values will have absolute accuracy | //| ABS(TOL)*norm(B). By default, |TOL| falls within the range of| //| 10*Epsilon and 100*Epsilon, where Epsilon is the machine | //| precision. It is not recommended to use TOL less than | //| 10*Epsilon since this will considerably slow down the | //| algorithm and may not lead to error decreasing. | //| History: | //| * 31 March, 2007. | //| changed MAXITR from 6 to 12. | //| -- LAPACK routine (version 3.0) -- | //| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., | //| Courant Institute, Argonne National Lab, and Rice University| //| October 31, 1999. | //+------------------------------------------------------------------+ bool CBdSingValueDecompose::RMatrixBdSVD(double &d[],double &e[], const int n,const bool IsUpper, const bool isfractionalaccuracyrequired, CMatrixDouble &u,const int nru, CMatrixDouble &c,const int ncc, CMatrixDouble &vt,const int ncvt) { //--- create variables bool result; int i_=0; int i1_=0; //--- create arrays CRowDouble d1; CRowDouble e1; //--- Use ALGLIB code //--- allocation d1=vector::Zeros(n+1); //--- change values i1_=-1; for(i_=1; i_<=n; i_++) d1.Set(i_,d[i_+i1_]); //--- check if(n>1) { //--- allocation e1=vector::Zeros(n); //--- change values i1_=-1; for(i_=1; i_::Zeros(n+1); //--- change values i1_=-1; for(i_=1; i_<=n; i_++) d1.Set(i_,d[i_+i1_]); //--- check if(n>1) { //--- allocation e1=vector::Zeros(n); //--- change values i1_=-1; for(i_=1; i_0) for(i_=vstart; i_::Zeros(n); work1=vector::Zeros(n); work2=vector::Zeros(n); work3=vector::Zeros(n); uend=ustart+(int)MathMax(nru-1,0); vend=vstart+(int)MathMax(ncvt-1,0); cend=cstart+(int)MathMax(ncc-1,0); utemp=vector::Zeros(uend+1); vttemp=vector::Zeros(vend+1); ctemp=vector::Zeros(cend+1); //--- resize E from N-1 to N e.Resize(n+1); e.Set(n,0); idir=0; //--- initialization eps=CMath::m_machineepsilon; unfl=CMath::m_minrealnumber; //--- If matrix lower bidiagonal, rotate to be upper bidiagonal //--- by applying Givens rotations on the left if(!IsUpper) { for(i=1; i0) //--- function call CRotations::ApplyRotationsFromTheRight(fwddir,ustart,uend,1+ustart-1,n+ustart-1,work0,work1,u,utemp); //--- check if(ncc>0) //--- function call CRotations::ApplyRotationsFromTheLeft(fwddir,cstart,n+cstart-1,cstart,cend,work0,work1,c,ctemp); } //--- Compute singular values to relative accuracy TOL //--- (By setting TOL to be negative, algorithm will compute //--- singular values to absolute accuracy ABS(TOL)*norm(input matrix)) tolmul=MathMax(10,MathMin(100,MathPow(eps,-0.125))); tol=tolmul*eps; //--- check if(!isfractionalaccuracyrequired) tol=-tol; sminl=0; //--- check if(tol>=0.0) { //--- Relative accuracy desired sminoa=MathAbs(d[1]); //--- check if(sminoa!=0.0) { mu=sminoa; for(i=2; i<=n; i++) { mu=MathAbs(d[i])*(mu/(mu+MathAbs(e[i-1]))); sminoa=MathMin(sminoa,mu); //--- check if(sminoa==0.0) break; } } //--- change values sminoa/=MathSqrt(n); thresh=MathMax(tol*sminoa,maxitr*n*n*unfl); } else { //--- Compute approximate maximum, minimum singular values smax=0; for(i=1; i1) { //--- check if(iter>maxit) return(false); //--- Find diagonal block of matrix to work on if(tol<0.0 && MathAbs(d[m])<=thresh) d.Set(m,0.0); //--- change values smax=MathAbs(d[m]); smin=smax; matrixsplitflag=false; for(lll=1; lll0) { mm0=m+(vstart-1); mm1=mm0-1; //--- swap for(i_=vstart; i_<=vend; i_++) { vttemp.Set(i_,cosr*vt.Get(mm1,i_)+sinr*vt.Get(mm0,i_)); vt.Set(mm0,i_,(cosr*vt.Get(mm0,i_)-sinr*vt.Get(mm1,i_))); vt.Set(mm1,i_,vttemp[i_]); } } //--- check if(nru>0) { mm0=m+ustart-1; mm1=m-1+ustart-1; //--- swap for(i_=ustart; i_<=uend; i_++) { utemp.Set(i_,cosl*u.Get(i_,mm1)+sinl*u.Get(i_,mm0)); u.Set(i_,mm0,(cosl*u.Get(i_,mm0)-sinl*u.Get(i_,mm1))); u.Set(i_,mm1,utemp[i_]); } } //--- check if(ncc>0) { mm0=m+cstart-1; mm1=m-1+cstart-1; //--- swap for(i_=cstart; i_<=cend; i_++) { ctemp.Set(i_,cosl*c.Get(mm1,i_)+sinl*c.Get(mm0,i_)); c.Set(mm0,i_,(cosl*c.Get(mm0,i_)-sinl*c.Get(mm1,i_))); c.Set(mm1,i_,ctemp[i_]); } } m-=2; continue; } //--- If working on new submatrix, choose shift direction //--- (from larger end diagonal element towards smaller) //--- Previously was //--- "if (LL>OLDM) or (M //--- Very strange that LAPACK still contains it. bchangedir=false; //--- check if(idir==1 && MathAbs(d[ll])<1.0E-3*MathAbs(d[m])) bchangedir=true; //--- check if(idir==2 && MathAbs(d[m])<1.0E-3*MathAbs(d[ll])) bchangedir=true; //--- check if(ll!=oldll || m!=oldm || bchangedir) { //--- check if(MathAbs(d[ll])>=MathAbs(d[m])) //--- Chase bulge from top(big end) to bottom(small end) idir=1; else //--- Chase bulge from bottom (big end) to top (small end) idir=2; } //--- Apply convergence tests if(idir==1) { //--- Run convergence test in forward direction //--- First apply standard test to bottom of matrix if(MathAbs(e[m-1])<=MathAbs(tol)*MathAbs(d[m]) || (tol<0.0 && MathAbs(e[m-1])<=thresh)) { e.Set(m-1,0.0); continue; } //--- check if(tol>=0.0) { //--- If relative accuracy desired, //--- apply convergence criterion forward mu=MathAbs(d[ll]); sminl=mu; iterflag=false; for(lll=ll; lll=0.0) { //--- If relative accuracy desired, //--- apply convergence criterion backward mu=MathAbs(d[m]); sminl=mu; iterflag=false; for(lll=m-1; lll>=ll; lll--) { //--- check if(MathAbs(e[lll])<=(double)(tol*mu)) { e.Set(lll,0.0); iterflag=true; //--- break the cycle break; } mu=MathAbs(d[lll])*(mu/(mu+MathAbs(e[lll]))); sminl=MathMin(sminl,mu); } //--- check if(iterflag) continue; } } //--- change values oldll=ll; oldm=m; //--- Compute shift. First, test if shifting would ruin relative //--- accuracy, and if so set the shift to zero. if(tol>=0.0 && n*tol*(sminl/smax)<=MathMax(eps,0.01*tol)) //--- Use a zero shift to avoid loss of relative accuracy shift=0; else { //--- Compute the shift from 2-by-2 block at end of matrix if(idir==1) { sll=MathAbs(d[ll]); SVD2x2(d[m-1],e[m-1],d[m],shift,r); } else { sll=MathAbs(d[m]); SVD2x2(d[ll],e[ll],d[ll+1],shift,r); } //--- Test if shift negligible, and if so set to zero if(sll>0.0) { //--- check if(CMath::Sqr(shift/sll)ll) e.Set(i-1,oldsn*r); //--- function call CRotations::GenerateRotation(oldcs*r,d[i+1]*sn,oldcs,oldsn,tmp); //--- change values d.Set(i,tmp); work0.Set(i-ll+1,cs); work1.Set(i-ll+1,sn); work2.Set(i-ll+1,oldcs); work3.Set(i-ll+1,oldsn); } //--- change values h=d[m]*cs; d.Set(m,h*oldcs); e.Set(m-1,h*oldsn); //--- Update singular vectors if(ncvt>0) { //--- function call CRotations::ApplyRotationsFromTheLeft(fwddir,ll+vstart-1,m+vstart-1,vstart,vend,work0,work1,vt,vttemp); } //--- check if(nru>0) { //--- function call CRotations::ApplyRotationsFromTheRight(fwddir,ustart,uend,ll+ustart-1,m+ustart-1,work2,work3,u,utemp); } //--- check if(ncc>0) { //--- function call CRotations::ApplyRotationsFromTheLeft(fwddir,ll+cstart-1,m+cstart-1,cstart,cend,work2,work3,c,ctemp); } //--- Check for convergence if(MathAbs(e[m-1])<=thresh) e.Set(m-1,0); } else { //--- Chase bulge from bottom to top //--- Save cosines and sines for later singular vector updates cs=1; oldcs=1; for(i=m; i>ll; i--) { //--- function call CRotations::GenerateRotation(d[i]*cs,e[i-1],cs,sn,r); //--- check if(i0) { //--- function call CRotations::ApplyRotationsFromTheLeft(!fwddir,ll+vstart-1,m+vstart-1,vstart,vend,work2,work3,vt,vttemp); } //--- check if(nru>0) { //--- function call CRotations::ApplyRotationsFromTheRight(!fwddir,ustart,uend,ll+ustart-1,m+ustart-1,work0,work1,u,utemp); } //--- check if(ncc>0) { //--- function call CRotations::ApplyRotationsFromTheLeft(!fwddir,ll+cstart-1,m+cstart-1,cstart,cend,work0,work1,c,ctemp); } //--- Check for convergence if(MathAbs(e[ll])<=thresh) e.Set(ll,0); } } else { //--- Use nonzero shift if(idir==1) { //--- Chase bulge from top to bottom //--- Save cosines and sines for later singular vector updates f=(MathAbs(d[ll])-shift)*(ExtSignBdSQR(1,d[ll])+shift/d[ll]); g=e[ll]; for(i=ll; ill) e.Set(i-1,r); //--- change values f=cosr*d[i]+sinr*e[i]; e.Set(i,cosr*e[i]-sinr*d[i]); g=sinr*d[i+1]; d.Set(i+1,cosr*d[i+1]); //--- function call CRotations::GenerateRotation(f,g,cosl,sinl,r); //--- change values d.Set(i,r); f=cosl*e[i]+sinl*d[i+1]; d.Set(i+1,cosl*d[i+1]-sinl*e[i]); //--- check if(i0) //--- function call CRotations::ApplyRotationsFromTheLeft(fwddir,ll+vstart-1,m+vstart-1,vstart,vend,work0,work1,vt,vttemp); if(nru>0) //--- function call CRotations::ApplyRotationsFromTheRight(fwddir,ustart,uend,ll+ustart-1,m+ustart-1,work2,work3,u,utemp); if(ncc>0) //--- function call CRotations::ApplyRotationsFromTheLeft(fwddir,ll+cstart-1,m+cstart-1,cstart,cend,work2,work3,c,ctemp); //--- Check for convergence if(MathAbs(e[m-1])<=thresh) e.Set(m-1,0.0); } else { //--- Chase bulge from bottom to top //--- Save cosines and sines for later singular vector updates f=(MathAbs(d[m])-shift)*(ExtSignBdSQR(1,d[m])+shift/d[m]); g=e[m-1]; for(i=m; i>ll; i--) { //--- function call CRotations::GenerateRotation(f,g,cosr,sinr,r); //--- check if(ill+1) { g=sinl*e[i-2]; e.Set(i-2,cosl*e[i-2]); } //--- change values work0.Set(i-ll,cosr); work1.Set(i-ll,-sinr); work2.Set(i-ll,cosl); work3.Set(i-ll,-sinl); } e.Set(ll,f); //--- Check for convergence if(MathAbs(e[ll])<=thresh) e.Set(ll,0); //--- Update singular vectors if desired if(ncvt>0) //--- function call CRotations::ApplyRotationsFromTheLeft(!fwddir,ll+vstart-1,m+vstart-1,vstart,vend,work2,work3,vt,vttemp); //--- check if(nru>0) //--- function call CRotations::ApplyRotationsFromTheRight(!fwddir,ustart,uend,ll+ustart-1,m+ustart-1,work0,work1,u,utemp); //--- check if(ncc>0) //--- function call CRotations::ApplyRotationsFromTheLeft(!fwddir,ll+cstart-1,m+cstart-1,cstart,cend,work0,work1,c,ctemp); } } //--- QR iteration finished, go back and check convergence continue; } //--- All singular values converged, so make them positive for(i=1; i<=n; i++) { //--- check if(d[i]<0.0) { d.Set(i,-d[i]); //--- Change sign of singular vectors, if desired if(ncvt>0) { for(i_=vstart; i_<=vend; i_++) vt.Mul(i+vstart-1,i_,-1); } } } //--- Sort the singular values into decreasing order (insertion sort on //--- singular values, but only one transposition per singular vector) for(i=1; i0) { j=n+1-i; //--- swap for(i_=vstart; i_<=vend; i_++) { vttemp.Set(i_,vt.Get(isub+vstart-1,i_)); vt.Set(isub+vstart-1,i_,vt.Get(j+vstart-1,i_)); vt.Set(j+vstart-1,i_,vttemp[i_]); } } if(nru>0) { j=n+1-i; //--- swap for(i_=ustart; i_<=uend; i_++) { utemp.Set(i_,u.Get(i_,isub+ustart-1)); u.Set(i_,isub+ustart-1,u.Get(i_,j+ustart-1)); u.Set(i_,j+ustart-1,utemp[i_]); } } //--- check if(ncc>0) { j=n+1-i; //--- swap for(i_=cstart; i_<=cend; i_++) { ctemp.Set(i_,c.Get(isub+cstart-1,i_)); c.Set(isub+cstart-1,i_,c.Get(j+cstart-1,i_)); c.Set(j+cstart-1,i_,ctemp[i_]); } } } } //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ double CBdSingValueDecompose::ExtSignBdSQR(const double a, const double b) { //--- create a variable double result=0; //--- check if(b>=0.0) result=MathAbs(a); else result=-MathAbs(a); //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CBdSingValueDecompose::SVD2x2(const double f,const double g, const double h,double &ssmin, double &ssmax) { //--- create variables double aas=0; double at=0; double au=0; double c=0; double fa=MathAbs(f); double ga=MathAbs(g); double ha=MathAbs(h); double fhmn=MathMin(fa,ha); double fhmx=MathMax(fa,ha); //--- initialization ssmin=0; ssmax=0; //--- check if(fhmn==0.0) { ssmin=0; //--- check if(fhmx==0.0) ssmax=ga; else ssmax=MathMax(fhmx,ga)*MathSqrt(1+CMath::Sqr(MathMin(fhmx,ga)/MathMax(fhmx,ga))); } else { //--- check if(gafa; //--- check if(swp) { //--- Now FA .ge. HA pmax=3; temp=ft; ft=ht; ht=temp; temp=fa; fa=ha; ha=temp; } gt=g; ga=MathAbs(gt); //--- check if(ga==0.0) { //--- Diagonal matrix ssmin=ha; ssmax=fa; clt=1; crt=1; slt=0; srt=0; } else { gasmal=true; //--- check if(ga>fa) { pmax=2; //--- check if(fa/ga1.0) { v=ga/ha; ssmin=fa/v; } else { v=fa/ga; ssmin=v*ha; } //--- change values clt=1; slt=ht/gt; srt=1; crt=ft/gt; } } //--- check if(gasmal) { //--- Normal case d=fa-ha; //--- check if(d==fa) l=1; else l=d/fa; //--- change values m=gt/ft; t=2-l; mm=m*m; tt=t*t; s=MathSqrt(tt+mm); //--- check if(l==0.0) r=MathAbs(m); else r=MathSqrt(l*l+mm); //--- change values a=0.5*(s+r); ssmin=ha/a; ssmax=fa*a; //--- check if(mm==0.0) { //--- Note that M is very tiny if(l==0.0) t=ExtSignBdSQR(2,ft)*ExtSignBdSQR(1,gt); else t=gt/ExtSignBdSQR(d,ft)+m/t; } else t=(m/(s+t)+m/(r+l))*(1+a); //--- change values l=MathSqrt(t*t+4); crt=2/l; srt=t/l; clt=(crt+srt*m)/a; v=ht/ft; slt=v*srt/a; } } //--- check if(swp) { csl=srt; snl=crt; csr=slt; snr=clt; } else { csl=clt; snl=slt; csr=crt; snr=srt; } //--- Correct signs of SSMAX and SSMIN if(pmax==1) tsign=ExtSignBdSQR(1,csr)*ExtSignBdSQR(1,csl)*ExtSignBdSQR(1,f); //--- check if(pmax==2) tsign=ExtSignBdSQR(1,snr)*ExtSignBdSQR(1,csl)*ExtSignBdSQR(1,g); //--- check if(pmax==3) tsign=ExtSignBdSQR(1,snr)*ExtSignBdSQR(1,snl)*ExtSignBdSQR(1,h); //--- get result ssmax=ExtSignBdSQR(ssmax,tsign); ssmin=ExtSignBdSQR(ssmin,tsign*ExtSignBdSQR(1,f)*ExtSignBdSQR(1,h)); } //+------------------------------------------------------------------+ //| Singular value decomposition | //+------------------------------------------------------------------+ class CSingValueDecompose { public: static bool RMatrixSVD(CMatrixDouble &ca,const int m,const int n,const int uneeded,const int vtneeded,const int additionalmemory,double &w[],CMatrixDouble &u,CMatrixDouble &vt); static bool RMatrixSVD(CMatrixDouble &ca,const int m,const int n,const int uneeded,const int vtneeded,const int additionalmemory,CRowDouble &w,CMatrixDouble &u,CMatrixDouble &vt); }; //+------------------------------------------------------------------+ //| Singular value decomposition of a rectangular matrix. | //| The algorithm calculates the singular value decomposition of a | //| matrix of size MxN: A = U * S * V^T | //| The algorithm finds the singular values and, optionally, matrices| //| U and V^T. The algorithm can find both first min(M,N) columns of | //| matrix U and rows of matrix V^T (singular vectors), and matrices | //| U and V^T wholly (of sizes MxM and NxN respectively). | //| Take into account that the subroutine does not return matrix V | //| but V^T. | //| Input parameters: | //| A - matrix to be decomposed. | //| Array whose indexes range within | //| [0..M-1, 0..N-1]. | //| M - number of rows in matrix A. | //| N - number of columns in matrix A. | //| UNeeded - 0, 1 or 2. See the description of the | //| parameter U. | //| VTNeeded - 0, 1 or 2. See the description of the | //| parameter VT. | //| AdditionalMemory - | //| If the parameter: | //| * equals 0, the algorithm doesn?t use | //| additional memory (lower requirements, | //| lower performance). | //| * equals 1, the algorithm uses additional | //| memory of size min(M,N)*min(M,N) of real | //| numbers. It often speeds up the algorithm.| //| * equals 2, the algorithm uses additional | //| memory of size M*min(M,N) of real numbers.| //| It allows to get a maximum performance. | //| The recommended value of the parameter is 2. | //| Output parameters: | //| W - contains singular values in descending order.| //| U - if UNeeded=0, U isn't changed, the left | //| singular vectors are not calculated. | //| if Uneeded=1, U contains left singular | //| vectors (first min(M,N) columns of matrix U).| //| Array whose indexes range within | //| [0..M-1, 0..Min(M,N)-1]. if UNeeded=2, U | //| contains matrix U wholly. Array whose indexes| //| range within [0..M-1, 0..M-1]. | //| VT - if VTNeeded=0, VT isn?t changed, the right | //| singular vectors are not calculated. | //| if VTNeeded=1, VT contains right singular | //| vectors (first min(M,N) rows of matrix V^T). | //| Array whose indexes range within | //| [0..min(M,N)-1, 0..N-1]. if VTNeeded=2, VT | //| contains matrix V^T wholly. Array whose | //| indexes range within [0..N-1, 0..N-1]. | //+------------------------------------------------------------------+ bool CSingValueDecompose::RMatrixSVD(CMatrixDouble &ca,const int m, const int n,const int uneeded, const int vtneeded, const int additionalmemory, double &w[],CMatrixDouble &u, CMatrixDouble &vt) { CRowDouble W; if(!RMatrixSVD(ca,m,n,uneeded,vtneeded,additionalmemory,W,u,vt)) return(false); W.ToArray(w); //--- return result return(true); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CSingValueDecompose::RMatrixSVD(CMatrixDouble &ca,const int m, const int n,const int uneeded, const int vtneeded, const int additionalmemory, CRowDouble &w,CMatrixDouble &u, CMatrixDouble &vt) { //--- check if(m==0 || n==0) return(true); //--- create variables bool result=true; bool IsUpper; int minmn=0; int ncu=0; int nrvt=0; int nru=0; int ncvt=0; int i=0; int j=0; //--- create arrays CRowDouble tauq; CRowDouble taup; CRowDouble tau; CRowDouble e; CRowDouble work; //--- create matrix CMatrixDouble t2; CMatrixDouble a=ca; //--- check if(!CAp::Assert(uneeded>=0 && uneeded<=2,__FUNCTION__+": wrong parameters!")) return(false); //--- check if(!CAp::Assert(vtneeded>=0 && vtneeded<=2,__FUNCTION__+": wrong parameters!")) return(false); //--- check if(!CAp::Assert(additionalmemory>=0 && additionalmemory<=2,__FUNCTION__+": wrong parameters!")) return(false); //--- initialization minmn=MathMin(m,n); w.Resize(minmn+1); //--- check if(uneeded==1) { nru=m; ncu=minmn; u.Resize(nru,ncu); } //--- check if(uneeded==2) { nru=m; ncu=m; u.Resize(nru,ncu); } //--- check if(vtneeded==1) { nrvt=minmn; ncvt=n; vt.Resize(nrvt,ncvt); } //--- check if(vtneeded==2) { nrvt=n; ncvt=n; vt.Resize(nrvt,ncvt); } //--- M much larger than N //--- Use bidiagonal reduction with QR-decomposition if((double)(m)>(double)(1.6*n)) { //--- check if(uneeded==0) { //-- No left singular vectors to be computed COrtFac::RMatrixQR(a,m,n,tau); for(i=0; i(double)(1.6*m)) { //--- check if(vtneeded==0) { //--- No right singular vectors to be computed COrtFac::RMatrixLQ(a,m,n,tau); for(i=0; i<=m-1; i++) { for(j=i+1; j<=m-1; j++) a.Set(i,j,0); } //--- function call COrtFac::RMatrixBD(a,m,m,tauq,taup); //--- function call COrtFac::RMatrixBDUnpackQ(a,m,m,tauq,ncu,u); //--- function call COrtFac::RMatrixBDUnpackDiagonals(a,m,m,IsUpper,w,e); work.Resize(m+1); //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- get result result=CBdSingValueDecompose::RMatrixBdSVD(w,e,m,IsUpper,false,a,0,u,nru,vt,0); //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- return result return(result); } else { //--- Right singular vectors (may be full matrix VT) to be computed COrtFac::RMatrixLQ(a,m,n,tau); //--- function call COrtFac::RMatrixLQUnpackQ(a,m,n,tau,nrvt,vt); for(i=0; i<=m-1; i++) { for(j=i+1; j<=m-1; j++) a.Set(i,j,0); } //--- function call COrtFac::RMatrixBD(a,m,m,tauq,taup); //--- function call COrtFac::RMatrixBDUnpackQ(a,m,m,tauq,ncu,u); //--- function call COrtFac::RMatrixBDUnpackDiagonals(a,m,m,IsUpper,w,e); work.Resize(MathMax(m,n)+1); //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- check if(additionalmemory<1) { //--- No additional memory available COrtFac::RMatrixBDMultiplyByP(a,m,m,taup,vt,m,n,false,true); //--- get result result=CBdSingValueDecompose::RMatrixBdSVD(w,e,m,IsUpper,false,a,0,u,nru,vt,n); } else { //--- Large VT. Transforming intermediate matrix T2 COrtFac::RMatrixBDUnpackPT(a,m,m,taup,m,t2); //--- get result result=CBdSingValueDecompose::RMatrixBdSVD(w,e,m,IsUpper,false,a,0,u,nru,t2,m); //--- function call CBlas::CopyMatrix(vt,0,m-1,0,n-1,a,0,m-1,0,n-1); //--- function call CAblas::RMatrixGemm(m,n,m,1.0,t2,0,0,0,a,0,0,0,0.0,vt,0,0); } //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- return result return(result); } } //--- M<=N //--- We can use inplace transposition of U to get rid of columnwise operations if(m<=n) { //--- function call COrtFac::RMatrixBD(a,m,n,tauq,taup); //--- function call COrtFac::RMatrixBDUnpackQ(a,m,n,tauq,ncu,u); //--- function call COrtFac::RMatrixBDUnpackPT(a,m,n,taup,nrvt,vt); //--- function call COrtFac::RMatrixBDUnpackDiagonals(a,m,n,IsUpper,w,e); work.Resize(m+1); //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- get result result=CBdSingValueDecompose::RMatrixBdSVD(w,e,minmn,IsUpper,false,a,0,u,nru,vt,ncvt); //--- function call CBlas::InplaceTranspose(u,0,nru-1,0,ncu-1,work); //--- return result return(result); } //--- Simple bidiagonal reduction COrtFac::RMatrixBD(a,m,n,tauq,taup); //--- function call COrtFac::RMatrixBDUnpackQ(a,m,n,tauq,ncu,u); //--- function call COrtFac::RMatrixBDUnpackPT(a,m,n,taup,nrvt,vt); //--- function call COrtFac::RMatrixBDUnpackDiagonals(a,m,n,IsUpper,w,e); //--- check if(additionalmemory<2 || uneeded==0) { //--- We cant use additional memory or there is no need in such operations result=CBdSingValueDecompose::RMatrixBdSVD(w,e,minmn,IsUpper,false,u,nru,a,0,vt,ncvt); } else { //--- We can use additional memory t2.Resize(minmn,m); //--- function call CBlas::CopyAndTranspose(u,0,m-1,0,minmn-1,t2,0,minmn-1,0,m-1); //--- get result result=CBdSingValueDecompose::RMatrixBdSVD(w,e,minmn,IsUpper,false,u,0,t2,m,vt,ncvt); //--- function call CBlas::CopyAndTranspose(t2,0,minmn-1,0,m-1,u,0,m-1,0,minmn-1); } //--- return result return(result); } //+------------------------------------------------------------------+ //| Structure which stores state of linear CG solver between | //| subsequent calls of FBLSCgIteration(). Initialized with | //| FBLSCGCreate(). | //| USAGE: | //| 1. call to FBLSCGCreate() | //| 2. F:=FBLSCgIteration(State) | //| 3. if F is False, iterations are over | //| 4. otherwise, fill State.AX with A*x, State.XAX with x'*A*x | //| 5. goto 2 | //| If you want to rerminate iterations, pass zero or negative value | //| to XAX. | //| FIELDS: | //| E1 - 2-norm of residual at the start | //| E2 - 2-norm of residual at the end | //| X - on return from FBLSCgIteration() it contains | //| vector for matrix-vector product | //| AX - must be filled with A*x if FBLSCgIteration() | //| returned True | //| XAX - must be filled with x'*A*x | //| XK - contains result (if FBLSCgIteration() returned | //| False) | //| Other fields are private and should not be used by outsiders. | //+------------------------------------------------------------------+ struct CFblsLinCgState { //--- variables double m_e1; double m_e2; CRowDouble m_x; CRowDouble m_ax; double m_xax; int m_n; CRowDouble m_rk; CRowDouble m_rk1; CRowDouble m_xk; CRowDouble m_xk1; CRowDouble m_pk; CRowDouble m_pk1; CRowDouble m_b; RCommState m_rstate; CRowDouble m_tmp2; //--- constructor, destructor CFblsLinCgState(void); ~CFblsLinCgState(void) {} void Copy(const CFblsLinCgState &obj); //--- overloading void operator=(const CFblsLinCgState &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Constructor | //+------------------------------------------------------------------+ CFblsLinCgState::CFblsLinCgState(void) { m_e1=0; m_e2=0; m_xax=0; m_n=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CFblsLinCgState::Copy(const CFblsLinCgState &obj) { m_e1=obj.m_e1; m_e2=obj.m_e2; m_x=obj.m_x; m_ax=obj.m_ax; m_xax=obj.m_xax; m_n=obj.m_n; m_rk=obj.m_rk; m_rk1=obj.m_rk1; m_xk=obj.m_xk; m_xk1=obj.m_xk1; m_pk=obj.m_pk; m_pk1=obj.m_pk1; m_b=obj.m_b; m_rstate=obj.m_rstate; m_tmp2=obj.m_tmp2; } //+------------------------------------------------------------------+ //| Structure which stores state of basic GMRES(k) solver between | //| subsequent calls of FBLSGMRESIteration(). Initialized with | //| FBLSGMRESCreate(). | //| USAGE: | //| 1. call to FBLSCGCreate() | //| 2. F:=FBLSGMRESIteration(State) | //| 3. if F is False, iterations are over | //| 4. otherwise, fill State.AX with A*x | //| 5. goto 2 | //| RCOMM FIELDS: | //| X - on return from FBLSCgIteration() it contains vector | //| for matrix-vector product | //| AX - must be filled with A*x if FBLSCgIteration() returned | //| True | //| RESULT: | //| XS - contains result (if FBLSCgIteration() returned False) | //| State - following fields can be used: | //| * ItsPerformed | //| * RetCode | //| Other fields are private and should not be used by outsiders: | //| Qi - rows store orthonormal basis of the Krylov subspace | //| AQi - rows store products A*Qi | //+------------------------------------------------------------------+ struct CFblsGMRESState { CRowDouble m_b; CRowDouble m_x; CRowDouble m_ax; CRowDouble m_xs; CMatrixDouble m_qi; CMatrixDouble m_aqi; CMatrixDouble m_h; CMatrixDouble m_hq; CMatrixDouble m_hr; CRowDouble m_hqb; CRowDouble m_ys; CRowDouble m_tmp0; CRowDouble m_tmp1; int m_n; int m_itscnt; double m_epsort; double m_epsres; double m_epsred; double m_epsdiag; int m_itsperformed; int m_retcode; double m_reprelres; RCommState m_rstate; //--- constructor, destructor CFblsGMRESState(void); ~CFblsGMRESState(void) {} void Copy(const CFblsGMRESState &obj); //--- overloading void operator=(const CFblsGMRESState &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Constructor | //+------------------------------------------------------------------+ CFblsGMRESState::CFblsGMRESState(void) { m_n=0; m_itscnt=0; m_epsort=0; m_epsres=0; m_epsred=0; m_epsdiag=0; m_itsperformed=0; m_retcode=0; m_reprelres=0; } //+------------------------------------------------------------------+ //| Copy | //+------------------------------------------------------------------+ void CFblsGMRESState::Copy(const CFblsGMRESState &obj) { m_b=obj.m_b; m_x=obj.m_x; m_ax=obj.m_ax; m_xs=obj.m_xs; m_qi=obj.m_qi; m_aqi=obj.m_aqi; m_h=obj.m_h; m_hq=obj.m_hq; m_hr=obj.m_hr; m_hqb=obj.m_hqb; m_ys=obj.m_ys; m_tmp0=obj.m_tmp0; m_tmp1=obj.m_tmp1; m_n=obj.m_n; m_itscnt=obj.m_itscnt; m_epsort=obj.m_epsort; m_epsres=obj.m_epsres; m_epsred=obj.m_epsred; m_epsdiag=obj.m_epsdiag; m_itsperformed=obj.m_itsperformed; m_retcode=obj.m_retcode; m_reprelres=obj.m_reprelres; m_rstate=obj.m_rstate; } //+------------------------------------------------------------------+ //| Fast basic linear solutions | //+------------------------------------------------------------------+ class CFbls { public: static void FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea,const int n,const bool IsUpper,double &xb[],double &tmp[]); static void FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea,const int n,const bool IsUpper,CRowDouble &xb,CRowDouble &tmp); static void FblsSolveCGx(CMatrixDouble &a,const int m,const int n,const double alpha,const double &b[],double &x[],double &buf[]); static void FblsSolveCGx(CMatrixDouble &a,const int m,const int n,const double alpha,const CRowDouble &b,CRowDouble &x,CRowDouble &buf); static void FblsCGCreate(double &x[],double &b[],const int n,CFblsLinCgState &state); static void FblsCGCreate(CRowDouble &x,CRowDouble &b,const int n,CFblsLinCgState &state); static bool FblsCGIteration(CFblsLinCgState &state); static void FblsGMRESCreate(CRowDouble &b,int n,int k,CFblsGMRESState &state); static bool FblsGMRESIteration(CFblsGMRESState &state); static void FblsSolveLS(CMatrixDouble &a,CRowDouble &b,int m,int n,CRowDouble &tmp0,CRowDouble &tmp1,CRowDouble &tmp2); private: //--- auxiliary functions for FblsCGiteration static void Func_lbl_rcomm(CFblsLinCgState &state,int n,int k,double rk2,double rk12,double pap,double s,double betak,double v1,double v2); static bool Func_lbl_3(CFblsLinCgState &state,int &n,int &k,double &rk2,double &rk12,double &pap,double &s,double &betak,double &v1,double &v2); static bool Func_lbl_5(CFblsLinCgState &state,int &n,int &k,double &rk2,double &rk12,double &pap,double &s,double &betak,double &v1,double &v2); static void FblsGMRESIteration_lbl_3(CFblsGMRESState &state,int kdim,int n); }; //+------------------------------------------------------------------+ //| Basic Cholesky solver for ScaleA*Cholesky(A)'*x = y. | //| This subroutine assumes that: | //| * A*ScaleA is well scaled | //| * A is well-conditioned, so no zero divisions or overflow may | //| occur | //| INPUT PARAMETERS: | //| CHA - Cholesky decomposition of A | //| SqrtScaleA- square root of scale factor ScaleA | //| N - matrix size | //| IsUpper - storage type | //| XB - right part | //| Tmp - buffer; function automatically allocates it, if | //| it is too small. It can be reused if function is | //| called several times. | //| OUTPUT PARAMETERS: | //| XB - solution | //| NOTES: no assertion or tests are done during algorithm operation | //+------------------------------------------------------------------+ void CFbls::FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea, const int n,const bool IsUpper,double &xb[], double &tmp[]) { CRowDouble XB=xb; CRowDouble Tmp; FblsCholeskySolve(cha,sqrtscalea,n,IsUpper,XB,Tmp); XB.ToArray(xb); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void CFbls::FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea, const int n,const bool IsUpper,CRowDouble &xb, CRowDouble &tmp) { //--- create variable double v=0; if(n<=0) { return; } //--- Scale right part xb*=1/CMath::Sqr(sqrtscalea); //--- Solve A = L*L' or A=U'*U if(IsUpper) { //--- Solve U'*y=b first. CAblas::RMatrixTrsVect(n,cha,0,0,true,false,1,xb,0); //--- Solve U*x=y then. CAblas::RMatrixTrsVect(n,cha,0,0,true,false,0,xb,0); } else { //--- Solve L*y=b first CAblas::RMatrixTrsVect(n,cha,0,0,false,false,0,xb,0); //--- Solve L'*x=y then. CAblas::RMatrixTrsVect(n,cha,0,0,false,false,1,xb,0); } } //+------------------------------------------------------------------+ //| Fast basic linear solver: linear SPD CG | //| Solves (A^T*A + alpha*I)*x = b where: | //| * A is MxN matrix | //| * alpha>0 is a scalar | //| * I is NxN identity matrix | //| * b is Nx1 vector | //| * X is Nx1 unknown vector. | //| N iterations of linear conjugate gradient are used to solve | //| problem. | //| INPUT PARAMETERS: | //| A - array[M,N], matrix | //| M - number of rows | //| N - number of unknowns | //| B - array[N], right part | //| X - initial approxumation, array[N] | //| Buf - buffer; function automatically allocates it, if it | //| is too small. It can be reused if function is called | //| several times with same M and N. | //| OUTPUT PARAMETERS: | //| X - improved solution | //| NOTES: | //| * solver checks quality of improved solution. If (because of | //| problem condition number, numerical noise, etc.) new solution| //| is WORSE than original approximation, then original | //| approximation is returned. | //| * solver assumes that both A, B, Alpha are well scaled (i.e. | //| they are less than sqrt(overflow) and greater than | //| sqrt(underflow)). | //+------------------------------------------------------------------+ void CFbls::FblsSolveCGx(CMatrixDouble &a,const int m,const int n, const double alpha,const double &b[], double &x[],double &buf[]) { CRowDouble X=x; CRowDouble B=b; CRowDouble Buf; FblsSolveCGx(a,m,n,alpha,B,X,Buf); X.ToArray(x); } //+------------------------------------------------------------------+ //| Same | //+------------------------------------------------------------------+ void CFbls::FblsSolveCGx(CMatrixDouble &a,const int m,const int n, const double alpha,const CRowDouble &b, CRowDouble &x,CRowDouble &buf) { //--- create variables int k=0; int offsrk=0; int offsrk1=offsrk+n; int offsxk=offsrk1+n; int offsxk1=offsxk+n; int offspk=offsxk1+n; int offspk1=offspk+n; int offstmp1=offspk1+n; int offstmp2=offstmp1+m; int bs=offstmp2+n; double e1=0; double e2=0; double rk2=0; double rk12=0; double pap=0; double s=0; double betak=0; double v1=0; double v2=0; int i_=0; int i1_=0; //--- Test for special case: B=0 v1=(b.Abs()+0).Sum(); //--- check if(v1==0.0) { x=vector::Zeros(n); //--- exit the function return; } //--- Offsets inside Buf for: //--- * R[K], R[K+1] //--- * X[K], X[K+1] //--- * P[K], P[K+1] //--- * Tmp1 - array[M], Tmp2 - array[N] //--- check if(CAp::Len(buf)=0) { //--- initialization n=state.m_rstate.ia[0]; k=state.m_rstate.ia[1]; rk2=state.m_rstate.ra[0]; rk12=state.m_rstate.ra[1]; pap=state.m_rstate.ra[2]; s=state.m_rstate.ra[3]; betak=state.m_rstate.ra[4]; v1=state.m_rstate.ra[5]; v2=state.m_rstate.ra[6]; } else { //--- initialization n=359; k=-58; rk2=-919; rk12=-909; pap=81; s=255; betak=74; v1=-788; v2=809; } //--- check switch(state.m_rstate.stage) { case 0: //--- calculation state.m_rk=state.m_b-state.m_ax+0; //--- change value rk2=state.m_rk.Dot(state.m_rk); //--- copy state.m_pk=state.m_rk; state.m_e1=MathSqrt(rk2); //--- cycle k=0; //--- function call return(Func_lbl_3(state,n,k,rk2,rk12,pap,s,betak,v1,v2)); case 1: //--- copy state.m_tmp2=state.m_ax; pap=state.m_xax; //--- check if(!CMath::IsFinite(pap) || pap<=0.0) return(Func_lbl_5(state,n,k,rk2,rk12,pap,s,betak,v1,v2)); //--- S=(r(k)'*r(k))/(p(k)'*A*p(k)) s=rk2/pap; //--- x(k+1)=x(k) + S*p(k) state.m_xk1=state.m_xk.ToVector()+state.m_pk*s; //--- r(k+1)=r(k) - S*A*p(k) //--- RK12=r(k+1)'*r(k+1) //--- Break if r(k+1) small enough (when compared to r(k)) state.m_rk1=state.m_rk.ToVector()-state.m_tmp2*s; rk12=state.m_rk1.Dot(state.m_rk1); //--- check if(MathSqrt(rk12)<=100*CMath::m_machineepsilon*state.m_e1) { //--- X(k) = x(k+1) before exit - //--- - because we expect to find solution at x(k) state.m_xk=state.m_xk1; //--- function call return(Func_lbl_5(state,n,k,rk2,rk12,pap,s,betak,v1,v2)); } //--- BetaK=RK12/RK2 //--- p(k+1)=r(k+1)+betak*p(k) //--- NOTE: we expect that BetaK won't overflow because of //--- "Sqrt(RK12)<=100*MachineEpsilon*E1" test above. betak=rk12/rk2; state.m_pk1=state.m_rk1.ToVector()+state.m_pk*betak; //--- r(k) :=r(k+1) //--- x(k) :=x(k+1) //--- p(k) :=p(k+1) state.m_rk=state.m_rk1; state.m_xk=state.m_xk1; state.m_pk=state.m_pk1; rk2=rk12; k++; //--- function call return(Func_lbl_3(state,n,k,rk2,rk12,pap,s,betak,v1,v2)); break; //--- check case 2: //--- calculation state.m_rk=state.m_b-state.m_ax+0; //--- change value v1=(state.m_rk.Pow(2)+0).Sum(); state.m_e2=MathSqrt(v1); //--- return result return(false); break; } //--- Routine body //--- prepare locals n=state.m_n; //--- Test for special case: B=0 v1=state.m_b.Dot(state.m_b); //--- check if(v1==0.0) { state.m_xk=vector::Zeros(n); //--- return result return(false); } //--- r(0)=b-A*x(0) //--- RK2=r(0)'*r(0) state.m_x=state.m_xk; state.m_rstate.stage=0; //--- Saving state Func_lbl_rcomm(state,n,k,rk2,rk12,pap,s,betak,v1,v2); //--- return result return(true); } //+------------------------------------------------------------------+ //| Construction of GMRES(k) solver. | //| State parameter passed using "shared" semantics (i.e. previous | //| state is NOT erased). When it is already initialized, we can | //| reause prevously allocated memory. | //| After (but not before!) initialization you can tweak following | //| fields (they are initialized by default values, but you can | //| change it): | //| * State.EpsOrt - stop if norm of new candidate for | //| orthogonalization is below EpsOrt | //| * State.EpsRes - stop of residual decreased below EpsRes*|B|| //| * State.EpsRed - stop if relative reduction of residual | //| |R(k+1)|/|R(k)|>EpsRed | //| INPUT PARAMETERS: | //| B - right part | //| N - system size | //| K - iterations count, K>=1 | //| State - structure; may be preallocated, if we want to reuse | //| memory | //| OUTPUT PARAMETERS: | //| State - structure which is used by FBLSGMRESIteration() to | //| store algorithm state between subsequent calls. | //| NOTE: no error checking is done; caller must check all | //| parameters, prevent overflows, and so on. | //+------------------------------------------------------------------+ void CFbls::FblsGMRESCreate(CRowDouble &b, int n, int k, CFblsGMRESState &state) { //--- check if(!CAp::Assert(n>0 && k>0 && k<=n,__FUNCTION__+": incorrect params")) return; state.m_n=n; state.m_itscnt=k; state.m_epsres=state.m_epsort=(1000+MathSqrt(n))*CMath::m_machineepsilon; state.m_epsred=1.0; state.m_epsdiag=(10000+n)*CMath::m_machineepsilon; state.m_itsperformed=0; state.m_retcode=0; CAblasF::RCopyAllocV(n,b,state.m_b); CAblasF::RAllocV(n,state.m_x); CAblasF::RAllocV(n,state.m_ax); state.m_rstate.ia.Resize(4+1); state.m_rstate.ra.Resize(10+1); state.m_rstate.stage=-1; } //+------------------------------------------------------------------+ //| Linear CG solver, function relying on reverse communication to | //| calculate matrix-vector products. | //| See comments for FBLSLinCGState structure for more info. | //+------------------------------------------------------------------+ bool CFbls::FblsGMRESIteration(CFblsGMRESState &state) { //--- create variables int n=0; int itidx=0; int kdim=0; double rmax=0; double rmindiag=0; double cs=0; double sn=0; double v=0; double vv=0; double anrm=0; double qnrm=0; double bnrm=0; double resnrm=0; double prevresnrm=0; int i=0; int j=0; //--- Reverse communication preparations //--- This code initializes locals by: //--- * random values determined during code //--- generation - on first subroutine call //--- * values from previous call - on subsequent calls if(state.m_rstate.stage>=0) { n=state.m_rstate.ia[0]; itidx=state.m_rstate.ia[1]; kdim=state.m_rstate.ia[2]; i=state.m_rstate.ia[3]; j=state.m_rstate.ia[4]; rmax=state.m_rstate.ra[0]; rmindiag=state.m_rstate.ra[1]; cs=state.m_rstate.ra[2]; sn=state.m_rstate.ra[3]; v=state.m_rstate.ra[4]; vv=state.m_rstate.ra[5]; anrm=state.m_rstate.ra[6]; qnrm=state.m_rstate.ra[7]; bnrm=state.m_rstate.ra[8]; resnrm=state.m_rstate.ra[9]; prevresnrm=state.m_rstate.ra[10]; } else { n=205; itidx=-838; kdim=939; i=-526; j=763; rmax=-541; rmindiag=-698; cs=-900; sn=-318; v=-940; vv=1016; anrm=-229; qnrm=-536; bnrm=487; resnrm=-115; prevresnrm=886; } if(state.m_rstate.stage==0) { CAblasF::RCopyVR(n,state.m_ax,state.m_aqi,itidx); anrm=MathSqrt(CAblasF::RDotV2(n,state.m_ax)); if(anrm==0.0) { state.m_retcode=2; FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } CAblas::RowWiseGramSchmidt(state.m_qi,itidx+1,n,state.m_ax,state.m_tmp0,true); CAblas::RowWiseGramSchmidt(state.m_qi,itidx+1,n,state.m_ax,state.m_tmp1,true); CAblasF::RAddVC(itidx+1,1.0,state.m_tmp0,state.m_h,itidx); CAblasF::RAddVC(itidx+1,1.0,state.m_tmp1,state.m_h,itidx); qnrm=MathSqrt(CAblasF::RDotV2(n,state.m_ax)); state.m_h.Set(itidx+1,itidx,qnrm); CAblasF::RMulV(n,1/CApServ::Coalesce(qnrm,1),state.m_ax); CAblasF::RCopyVR(n,state.m_ax,state.m_qi,itidx+1); //--- We have QR decomposition of H from the previous iteration: //--- * (ItIdx+1)*(ItIdx+1) orthogonal HQ embedded into larger (ItIdx+2)*(ItIdx+2) identity matrix //--- * (ItIdx+1)*ItIdx triangular HR embedded into larger (ItIdx+2)*(ItIdx+1) zero matrix //--- We just have to update QR decomposition after one more column is added to H: //--- * multiply this column by HQ to obtain (ItIdx+2)-dimensional vector X //--- * generate rotation to nullify last element of X to obtain (ItIdx+1)-dimensional vector Y //--- that is copied into (ItIdx+1)-th column of HR //--- * apply same rotation to HQ //--- * apply same rotation to HQB - current right-hand side CAblasF::RCopyCV(itidx+2,state.m_h,itidx,state.m_tmp0); CAblas::RMatrixGemVect(itidx+2,itidx+2,1.0,state.m_hq,0,0,0,state.m_tmp0,0,0.0,state.m_tmp1,0); CRotations::GenerateRotation(state.m_tmp1[itidx],state.m_tmp1[itidx+1],cs,sn,v); state.m_tmp1.Set(itidx,v); state.m_tmp1.Set(itidx+1,0); rmax=MathMax(rmax,CAblasF::RMaxAbsV(itidx+2,state.m_tmp1)); rmindiag=MathMin(rmindiag,MathAbs(v)); if(rmindiag<=(rmax*state.m_epsdiag)) { state.m_retcode=3; FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } CAblasF::RCopyVC(itidx+2,state.m_tmp1,state.m_hr,itidx); for(j=0; j<=itidx+1; j++) { v=state.m_hq.Get(itidx+0,j); vv=state.m_hq.Get(itidx+1,j); state.m_hq.Set(itidx+0,j,cs*v+sn*vv); state.m_hq.Set(itidx+1,j,-(sn*v)+cs*vv); } v=state.m_hqb[itidx+0]; vv=state.m_hqb[itidx+1]; state.m_hqb.Set(itidx,cs*v+sn*vv); state.m_hqb.Set(itidx+1,-(sn*v)+cs*vv); resnrm=MathAbs(state.m_hqb[itidx+1]); //--- Previous attempt to extend R was successful (no small diagonal elements). //--- Increase Krylov subspace dimensionality. kdim=kdim+1; //--- Iteration is over. //--- Terminate if: //--- * last Qi was nearly zero after orthogonalization. //--- * sufficient decrease of residual //--- * stagnation of residual state.m_itsperformed++; if(qnrm<=(state.m_epsort*anrm) || qnrm==0.0) { state.m_retcode=4; FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } if(resnrm<=(state.m_epsres*bnrm)) { state.m_retcode=5; FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } if((resnrm/prevresnrm)>state.m_epsred) { state.m_retcode=6; FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } itidx=itidx+1; } else { //--- Routine body n=state.m_n; state.m_retcode=1; //--- Set up Q0 CAblasF::RSetAllocV(n,0.0,state.m_xs); bnrm=MathSqrt(CAblasF::RDotV2(n,state.m_b)); if(bnrm==0.0) { state.m_reprelres=0; return(false); } CAblasF::RAllocM(state.m_itscnt+1,n,state.m_qi); CAblasF::RAllocM(state.m_itscnt,n,state.m_aqi); CAblasF::RCopyMulVR(n,1/bnrm,state.m_b,state.m_qi,0); CAblasF::RSetAllocM(state.m_itscnt+1,state.m_itscnt,0.0,state.m_h); CAblasF::RSetAllocM(state.m_itscnt+1,state.m_itscnt,0.0,state.m_hr); CAblasF::RSetAllocM(state.m_itscnt+1,state.m_itscnt+1,0.0,state.m_hq); for(i=0; i<=state.m_itscnt; i++) state.m_hq.Set(i,i,1); CAblasF::RSetAllocV(state.m_itscnt+1,0.0,state.m_hqb); state.m_hqb.Set(0,bnrm); //--- Perform iteration resnrm=bnrm; kdim=0; rmax=0; rmindiag=1.0E99; CAblasF::RSetAllocV(state.m_itscnt,0.0,state.m_ys); CAblasF::RAllocV(MathMax(n,state.m_itscnt+2),state.m_tmp0); CAblasF::RAllocV(MathMax(n,state.m_itscnt+2),state.m_tmp1); itidx=0; } if(itidx>state.m_itscnt-1) { FblsGMRESIteration_lbl_3(state,kdim,n); return(false); } prevresnrm=resnrm; state.m_reprelres=resnrm/bnrm; //--- Compute A*Qi[ItIdx], then compute Qi[ItIdx+1] CAblasF::RCopyRV(n,state.m_qi,itidx,state.m_x); state.m_rstate.stage=0; //--- Saving state state.m_rstate.ia.Set(0,n); state.m_rstate.ia.Set(1,itidx); state.m_rstate.ia.Set(2,kdim); state.m_rstate.ia.Set(3,i); state.m_rstate.ia.Set(4,j); state.m_rstate.ra.Set(0,rmax); state.m_rstate.ra.Set(1,rmindiag); state.m_rstate.ra.Set(2,cs); state.m_rstate.ra.Set(3,sn); state.m_rstate.ra.Set(4,v); state.m_rstate.ra.Set(5,vv); state.m_rstate.ra.Set(6,anrm); state.m_rstate.ra.Set(7,qnrm); state.m_rstate.ra.Set(8,bnrm); state.m_rstate.ra.Set(9,resnrm); state.m_rstate.ra.Set(10,prevresnrm); return(true); } //+------------------------------------------------------------------+ //| Post-solve | //+------------------------------------------------------------------+ void CFbls::FblsGMRESIteration_lbl_3(CFblsGMRESState &state,int kdim,int n) { if(kdim>0) { CAblasF::RCopyV(kdim,state.m_hqb,state.m_ys); CAblas::RMatrixTrsVect(kdim,state.m_hr,0,0,true,false,0,state.m_ys,0); CAblas::RMatrixMVect(n,kdim,state.m_qi,0,0,1,state.m_ys,0,state.m_xs,0); } } //+------------------------------------------------------------------+ //| Fast least squares solver, solves well conditioned system without| //| performing any checks for degeneracy, and using user - provided | //| buffers (which are automatically reallocated if too small). | //| This function is intended for solution of moderately sized | //| systems. It uses factorization algorithms based on Level 2 BLAS | //| operations, thus it won't work efficiently on large scale systems| //| INPUT PARAMETERS: | //| A - array[M, N], system matrix. Contents of A is | //| destroyed during solution. | //| B - array[M], right part | //| M - number of equations | //| N - number of variables, N <= M | //| Tmp0, Tmp1, Tmp2 - buffers; function automatically allocates | //| them, if they are too small. They can be reused if | //| function is called several times. | //| OUTPUT PARAMETERS: | //| B - solution(first N components, next M - N are zero) | //+------------------------------------------------------------------+ void CFbls::FblsSolveLS(CMatrixDouble &a,CRowDouble &b,int m,int n, CRowDouble &tmp0, CRowDouble &tmp1, CRowDouble &tmp2) { //--- create variables int i=0; int k=0; double v=0; int i_=0; //--- check if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(m>=n,__FUNCTION__+": M=m,__FUNCTION__+": Rows(A)=n,__FUNCTION__+": Cols(A)=m,__FUNCTION__+": Length(B)::Zeros(MathMax(m,n)+1); tmp1=vector::Zeros(MathMax(m,n)+1); tmp2=vector::Zeros(MathMin(m,n)); //--- Call basecase QR COrtFac::RMatrixQRBaseCase(a,m,n,tmp0,tmp1,tmp2); //--- Multiply B by Q' for(k=0; k=0; i--) { v=0.0; for(i_=i+1; i_<=n-1; i_++) v+=a.Get(i,i_)*b[i_]; b.Set(i,(b[i]-v)/a.Get(i,i)); } for(i=n; i<=m-1; i++) b.Set(i,0.0); } //+------------------------------------------------------------------+ //| Auxiliary function for FblsCGiteration. Is a product to get rid | //| of the operator unconditional jump goto. | //+------------------------------------------------------------------+ void CFbls::Func_lbl_rcomm(CFblsLinCgState &state,int n,int k, double rk2,double rk12,double pap, double s,double betak,double v1,double v2) { //--- save state.m_rstate.ia.Set(0,n); state.m_rstate.ia.Set(1,k); state.m_rstate.ra.Set(0,rk2); state.m_rstate.ra.Set(1,rk12); state.m_rstate.ra.Set(2,pap); state.m_rstate.ra.Set(3,s); state.m_rstate.ra.Set(4,betak); state.m_rstate.ra.Set(5,v1); state.m_rstate.ra.Set(6,v2); } //+------------------------------------------------------------------+ //| Auxiliary function for FblsCGiteration. Is a product to get rid | //| of the operator unconditional jump goto. | //+------------------------------------------------------------------+ bool CFbls::Func_lbl_3(CFblsLinCgState &state,int &n,int &k, double &rk2,double &rk12,double &pap, double &s,double &betak,double &v1,double &v2) { //--- check if(k>n-1) return(Func_lbl_5(state,n,k,rk2,rk12,pap,s,betak,v1,v2)); //--- Calculate A*p(k) - store in State.Tmp2 //--- and p(k)'*A*p(k) - store in PAP //--- If PAP=0,break (iteration is over) state.m_x=state.m_pk; state.m_rstate.stage=1; //--- Saving state Func_lbl_rcomm(state,n,k,rk2,rk12,pap,s,betak,v1,v2); //--- return result return(true); } //+------------------------------------------------------------------+ //| Auxiliary function for FblsCGiteration. Is a product to get rid | //| of the operator unconditional jump goto. | //+------------------------------------------------------------------+ bool CFbls::Func_lbl_5(CFblsLinCgState &state,int &n,int &k, double &rk2,double &rk12,double &pap, double &s,double &betak,double &v1,double &v2) { //--- calculation E2 state.m_x=state.m_xk; state.m_rstate.stage=2; //--- Saving state Func_lbl_rcomm(state,n,k,rk2,rk12,pap,s,betak,v1,v2); //--- return result return(true); } //+------------------------------------------------------------------+ //| Determinant calculation | //+------------------------------------------------------------------+ class CMatDet { public: static double RMatrixLUDet(CMatrixDouble &a,int &pivots[],const int n); static double RMatrixLUDet(CMatrixDouble &a,CRowInt &pivots,const int n); static double RMatrixDet(CMatrixDouble &ca,const int n); static double SPDMatrixCholeskyDet(CMatrixDouble &a,const int n); static double SPDMatrixDet(CMatrixDouble &ca,const int n,const bool IsUpper); static complex CMatrixLUDet(CMatrixComplex &a,int &pivots[],const int n); static complex CMatrixLUDet(CMatrixComplex &a,CRowInt &pivots,const int n); static complex CMatrixDet(CMatrixComplex &ca,const int n); }; //+------------------------------------------------------------------+ //| Determinant calculation of the matrix given by its LU | //| decomposition. | //| Input parameters: | //| A - LU decomposition of the matrix (output of | //| RMatrixLU subroutine). | //| Pivots - table of permutations which were made during | //| the LU decomposition. | //| Output of RMatrixLU subroutine. | //| N - (optional) size of matrix A: | //| * if given, only principal NxN submatrix is | //| processed and overwritten. other elements are | //| unchanged. | //| * if not given, automatically determined from | //| matrix size (A must be square matrix) | //| Result: matrix determinant. | //+------------------------------------------------------------------+ double CMatDet::RMatrixLUDet(CMatrixDouble &a,int &pivots[],const int n) { CRowInt Pivots=pivots; return(RMatrixLUDet(a,Pivots,n)); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ double CMatDet::RMatrixLUDet(CMatrixDouble &a,CRowInt &pivots,const int n) { //--- check if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": Pivots array is too short!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(a)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(ca)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": Pivots array is too short!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(a)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(ca)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(a)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)=1,__FUNCTION__+": N<1!")) return(EMPTY_VALUE); if(!CAp::Assert((int)CAp::Rows(ca)>=n,__FUNCTION__+": rows(A)=n,__FUNCTION__+": cols(A)::Zeros(n,n); //--- Setup R properties if(isUpperr) { j1=0; j2=n-1; j1inc=1; j2inc=0; } else { j1=0; j2=0; j1inc=0; j2inc=1; } //--- Calculate R*Z for(i=0; i0,__FUNCTION__+": N<=0!")) return(false); //--- check if(!CAp::Assert(problemtype==1 || problemtype==2 || problemtype==3,__FUNCTION__+": incorrect ProblemType!")) return(false); //--- create variables bool result; int i=0; int j=0; double v=0; int info=0; int i_=0; int i1_=0; //--- create matrix CMatrixDouble t; //--- create arrays CRowDouble w1; CRowDouble w2; CRowDouble w3; //--- object of class CMatInvReport rep; //--- initialization result=true; //--- Problem 1: A*x = lambda*B*x //--- Reducing to: //--- C*y = lambda*y //--- C = L^(-1) * A * L^(-T) //--- x = L^(-T) * y if(problemtype==1) { //--- Factorize B in T: B = LL' t.Resize(n,n); //--- check if(isUpperb) t=(b.Transpose()+0).TriL(); else t=b.TriL()+0; //--- check if(!CTrFac::SPDMatrixCholesky(t,n,false)) return(false); //--- Invert L in T CMatInv::RMatrixTrInverse(t,n,false,false,info,rep); //--- check if(info<=0) return(false); //--- Build L^(-1) * A * L^(-T) in R w1.Resize(n+1); w2.Resize(n+1); r.Resize(n,n); for(j=1; j<=n; j++) { //--- Form w2 = A * l'(j) (here l'(j) is j-th column of L^(-T)) i1_=-1; for(i_=1; i_<=j; i_++) w1.Set(i_,t.Get(j-1,i_+i1_)); //--- function call CSblas::SymmetricMatrixVectorMultiply(a,isUppera,0,j-1,w1,1.0,w2); //--- check if(isUppera) CBlas::MatrixVectorMultiply(a,0,j-1,j,n-1,true,w1,1,j,1.0,w2,j+1,n,0.0); else CBlas::MatrixVectorMultiply(a,j,n-1,0,j-1,false,w1,1,j,1.0,w2,j+1,n,0.0); //--- Form l(i)*w2 (here l(i) is i-th row of L^(-1)) for(i=1; i<=n; i++) { i1_=1; v=0.0; for(i_=0; i_=0 && updrow=0 && updcolumn t1; vector t2; //--- create variables int i=0; int j=0; double lambdav=0; double vt=0; int i_=0; //--- T1=InvA * U t1=inva.Col(updrow); //--- T2=v*InvA t2=v.ToVector(); t2=(inva.Transpose()+0).MatMul(t2); //--- Lambda=v * InvA * U lambdav=t2[updrow]; //--- InvA=InvA - correction for(i=0; i t1=u.ToVector(); vector t2; //--- create variables int i=0; double lambdav=0; double vt=0; int i_=0; //--- T1=InvA * U t1=(inva.ToMatrix()+0).MatMul(t1); //--- Lambda=v * InvA * U lambdav=t1[updcolumn]; //--- T2=v*InvA t2=inva[updcolumn]; //--- InvA=InvA - correction t1/=(1+lambdav); for(i=0; i t1=u.ToVector(); vector t2=v.ToVector(); //--- create variables double lambdav=0; double vt=0; //--- T1=InvA * U t1=(inva.ToMatrix()+0).MatMul(t1); //--- Lambda=v * T1 lambdav=t2.MatMul(t1); //--- T2=v*InvA t2=(inva.Transpose()+0).MatMul(t2); //--- InvA=InvA - correction t1/=(1+lambdav); for(int i=0; i=0. | //| Output parameters: | //| A - contains matrix T. | //| Array whose indexes range within [0..N-1, 0..N-1]. | //| S - contains Schur vectors. | //| Array whose indexes range within [0..N-1, 0..N-1]. | //| Note 1: | //| The block structure of matrix T can be easily recognized: | //| since all the elements below the blocks are zeros, the | //| elements a[i+1,i] which are equal to 0 show the block border.| //| Note 2: | //| The algorithm performance depends on the value of the | //| internal parameter NS of the InternalSchurDecomposition | //| subroutine which defines the number of shifts in the QR | //| algorithm (similarly to the block width in block-matrix | //| algorithms in linear algebra). If you require maximum | //| performance on your machine, it is recommended to adjust | //| this parameter manually. | //| Result: | //| True, | //| if the algorithm has converged and parameters A and S | //| contain the result. | //| False, | //| if the algorithm has not converged. | //| Algorithm implemented on the basis of the DHSEQR subroutine | //| (LAPACK 3.0 library). | //+------------------------------------------------------------------+ bool CSchur::RMatrixSchur(CMatrixDouble &a,const int n,CMatrixDouble &s) { //--- create variables int info=0; //--- create arrays CRowDouble tau; CRowDouble wi; CRowDouble wr; //--- Upper Hessenberg form of the 0-based matrix COrtFac::RMatrixHessenberg(a,n,tau); COrtFac::RMatrixHessenbergUnpackQ(a,n,tau,s); //--- Schur decomposition CHsSchur::RMatrixInternalSchurDecomposition(a,n,1,1,wr,wi,s,info); //--- return result return(info==0); } //+------------------------------------------------------------------+ //| This structure is used by sparse LU to store "left" and "upper" | //| rectangular submatrices BL and BU, as defined below: | //| [ | : ] | //| [ LU | BU : ] | //| [ | : ] | //| [--------------: dense ] | //| [ | : trail ] | //| [ | sparse : ] | //| [ BL | : ] | //| [ | trail : ] | //| [ | : ] | //+------------------------------------------------------------------+ class CSLUV2List1Matrix { public: int m_NFixed; int m_NDynamic; CRowInt m_IdxFirst; CRowInt m_StrgIdx; CRowDouble m_StrgVal; int m_NAllocated; int m_NUsed; //--- CSLUV2List1Matrix(void) { Init();} ~CSLUV2List1Matrix(void) { } void Init(void) { }; void Copy(const CSLUV2List1Matrix &obj); //--- overloading void operator=(const CSLUV2List1Matrix &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| Make copy of object | //+------------------------------------------------------------------+ void CSLUV2List1Matrix::Copy(const CSLUV2List1Matrix &obj) { m_NFixed=obj.m_NFixed; m_NDynamic=obj.m_NDynamic; m_IdxFirst=obj.m_IdxFirst; m_StrgIdx=obj.m_StrgIdx; m_StrgVal=obj.m_StrgVal; m_NAllocated=obj.m_NAllocated; m_NUsed=obj.m_NUsed; } //+------------------------------------------------------------------+ //| This structure is used by sparse LU to store sparse trail | //| submatrix as defined below: | //| [ | : ] | //| [ LU | BU : ] | //| [ | : ] | //| [--------------: dense ] | //| [ | : trail ] | //| [ | sparse : ] | //| [ BL | : ] | //| [ | trail : ] | //| [ | : ] | //+------------------------------------------------------------------+ struct CSLUV2SparseTrail { int m_N; int m_K; int m_MaxWrkCnt; int m_MaxWrkNz; int m_WrkCnt; int m_SlsUsed; CRowInt m_Nzc; CRowInt m_WrkSet; CRowInt m_ColId; bool m_IsDensified[]; CRowInt m_SlsColPtr; CRowInt m_SlsRowPtr; CRowInt m_SlsIdx; CRowDouble m_SlsVal; CRowDouble m_Tmp0; //--- CSLUV2SparseTrail(void) { Init(); } ~CSLUV2SparseTrail(void) {} void Init(void); void Copy(const CSLUV2SparseTrail &obj); //--- overloading void operator=(const CSLUV2SparseTrail &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSLUV2SparseTrail::Init(void) { m_N=0; m_K=0; m_MaxWrkCnt=0; m_MaxWrkNz=0; m_WrkCnt=0; m_SlsUsed=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSLUV2SparseTrail::Copy(const CSLUV2SparseTrail &obj) { m_N=obj.m_N; m_K=obj.m_K; m_MaxWrkCnt=obj.m_MaxWrkCnt; m_MaxWrkNz=obj.m_MaxWrkNz; m_WrkCnt=obj.m_WrkCnt; m_SlsUsed=obj.m_SlsUsed; m_Nzc=obj.m_Nzc; m_WrkSet=obj.m_WrkSet; m_ColId=obj.m_ColId; ArrayCopy(m_IsDensified,obj.m_IsDensified); m_SlsColPtr=obj.m_SlsColPtr; m_SlsRowPtr=obj.m_SlsRowPtr; m_SlsIdx=m_SlsIdx; m_SlsVal=obj.m_SlsVal; m_Tmp0=obj.m_Tmp0; } //+------------------------------------------------------------------+ //| This structure is used by sparse LU to store dense trail | //| submatrix as defined below: | //| [ | : ] | //| [ LU | BU : ] | //| [ | : ] | //| [--------------: dense ] | //| [ | : trail ] | //| [ | sparse : ] | //| [ BL | : ] | //| [ | trail : ] | //| [ | : ] | //+------------------------------------------------------------------+ struct CSLUV2DenseTrail { int m_N; int m_NDense; CMatrixDouble m_D; CRowInt m_Did; //--- CSLUV2DenseTrail(void) { Init(); } ~CSLUV2DenseTrail(void) {} void Init(void); void Copy(const CSLUV2DenseTrail &obj); //--- overloading void operator=(const CSLUV2DenseTrail &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSLUV2DenseTrail::Init(void) { m_N=0; m_NDense=0; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSLUV2DenseTrail::Copy(const CSLUV2DenseTrail &obj) { m_N=obj.m_N; m_NDense=obj.m_NDense; m_D=obj.m_D; m_Did=obj.m_Did; } //+------------------------------------------------------------------+ //| This structure is used by sparse LU for buffer storage | //+------------------------------------------------------------------+ struct CSLUV2Buffer { int m_N; CSparseMatrix m_SparseL; CSparseMatrix m_SparseUT; CSLUV2List1Matrix m_BLeft; CSLUV2List1Matrix m_BUpper; CSLUV2SparseTrail m_STrail; CSLUV2DenseTrail m_DTrail; CRowInt m_RowPermRawIdx; CMatrixDouble m_DBuf; CRowInt m_V0i; CRowInt m_V1i; CRowDouble m_V0r; CRowDouble m_V1r; CRowDouble m_Tmp0; CRowInt m_TmpI; CRowInt m_TmpP; //--- CSLUV2Buffer(void) { Init(); }; ~CSLUV2Buffer(void) {} void Init() { m_N=0; } void Copy(const CSLUV2Buffer &obj); //--- overloading void operator=(const CSLUV2Buffer &obj) { Copy(obj); } }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CSLUV2Buffer::Copy(const CSLUV2Buffer &obj) { m_N=obj.m_N; m_SparseL=obj.m_SparseL; m_SparseUT=obj.m_SparseUT; m_BLeft=obj.m_BLeft; m_BUpper=obj.m_BUpper; m_STrail=obj.m_STrail; m_DTrail=obj.m_DTrail; m_RowPermRawIdx=obj.m_RowPermRawIdx; m_DBuf=obj.m_DBuf; m_V0i=obj.m_V0i; m_V1i=obj.m_V1i; m_V0r=obj.m_V0r; m_V1r=obj.m_V1r; m_Tmp0=obj.m_Tmp0; m_TmpI=obj.m_TmpI; m_TmpP=obj.m_TmpP; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ class CSpTrf { public: static const double m_DenseBnd; static const int m_SlsWidth; static bool SpTrfLU(CSparseMatrix &a,int pivottype,CRowInt &pr,CRowInt &pc,CSLUV2Buffer &buf); private: static void SLUV2List1Init(int n,CSLUV2List1Matrix &a); static void SLUV2List1Swap(CSLUV2List1Matrix &a,int i,int j); static void SLUV2List1DropSequence(CSLUV2List1Matrix &a,int i); static void SLUV2List1AppendSequenceToMatrix(CSLUV2List1Matrix &a,int src,bool HasDiagonal,double d,int nzmax,CSparseMatrix &s,int dst); static void SLUV2List1PushSparseVector(CSLUV2List1Matrix &a,CRowInt &si,CRowDouble &sv,int nz); static void DenseTrailInit(CSLUV2DenseTrail &d,int n); static void DenseTrailAppendColumn(CSLUV2DenseTrail &d,CRowDouble &x,int id); static void SparseTrailInit(CSparseMatrix &s,CSLUV2SparseTrail &a); static bool SparseTrailFindPivot(CSLUV2SparseTrail &a,int pivottype,int &ipiv,int &jpiv); static void SparseTrailPivotOut(CSLUV2SparseTrail &a,int ipiv,int jpiv,double &uu,CRowInt &v0i,CRowDouble &v0r,int &nz0,CRowInt &v1i,CRowDouble &v1r,int &nz1); static void SparseTrailDensify(CSLUV2SparseTrail &a,int i1,CSLUV2List1Matrix &BUpper,CSLUV2DenseTrail &DTrail); static void SparseTrailUpdate(CSLUV2SparseTrail &a,CRowInt &v0i,CRowDouble &v0r,int nz0,CRowInt &v1i,CRowDouble &v1r,int nz1,CSLUV2List1Matrix &BUpper,CSLUV2DenseTrail &DTrail,bool DensificationSupported); }; //+------------------------------------------------------------------+ //| Constants | //+------------------------------------------------------------------+ const double CSpTrf::m_DenseBnd=0.10; const int CSpTrf::m_SlsWidth=8; //+------------------------------------------------------------------+ //| Sparse LU for square NxN CRS matrix with both row and column | //| permutations. | //| Represents A as Pr*L*U*Pc, where: | //| * Pr is a product of row permutations | //| Pr=Pr(0)*Pr(1)*...*Pr(n-2)*Pr(n-1) | //| * Pc is a product of col permutations | //| Pc=Pc(n-1)*Pc(n-2)*...*Pc(1)*Pc(0) | //| * L is lower unitriangular | //| * U is upper triangular | //| INPUT PARAMETERS: | //| A - sparse square matrix in CRS format | //| PivotType - pivot type: | //| * 0 - for best pivoting available | //| * 1 - row-only pivoting | //| * 2 - row and column greedy pivoting algorithm (most| //| sparse pivot column is selected from the | //| trailing matrix at each step) | //| Buf - temporary buffer, previously allocated memory is | //| reused as much as possible | //| OUTPUT PARAMETERS: | //| A - LU decomposition of A | //| PR - array[N], row pivots | //| PC - array[N], column pivots | //| Buf - following fields of Buf are set: | //| * Buf.RowPermRawIdx[] - contains row permutation, with| //| RawIdx[I]=J meaning that J-th row of the original| //| input matrix was moved to Ith position of the output| //| factorization | //| This function always succeeds i.e. it ALWAYS returns valid | //| factorization, but for your convenience it also returns boolean | //| value which helps to detect symbolically degenerate matrix: | //| * function returns TRUE if the matrix was factorized AND | //| symbolically non-degenerate | //| * function returns FALSE if the matrix was factorized but U has| //| strictly zero elements at the diagonal (the factorization is | //| returned anyway). | //+------------------------------------------------------------------+ bool CSpTrf::SpTrfLU(CSparseMatrix &a, int pivottype, CRowInt &pr, CRowInt &pc, CSLUV2Buffer &buf) { bool result; int n=CSparse::SparseGetNRows(a); int k=0; int i=0; int j=0; int jp=0; int i0=0; int i1=0; int ibest=0; int jbest=0; double v=0; double v0=0; int nz0=0; int nz1=0; double uu=0; int Offs=0; int tmpndense=0; bool DensificationSupported; int DensifyAbove=0; //--- check if(!CAp::Assert(CSparse::SparseIsCRS(a),__FUNCTION__+": A is not stored in CRS format")) return(false); if(!CAp::Assert(n==CSparse::SparseGetNCols(a),__FUNCTION__+": non-square A")) return(false); //--- check if(!CAp::Assert((pivottype==0 || pivottype==1) || pivottype==2,__FUNCTION__+": unexpected pivot type")) return(false); //--- Initialization result=true; if(pivottype==0) { pivottype=2; } DensificationSupported=pivottype==2; buf.m_N=n; CApServ::IVectorSetLengthAtLeast(buf.m_RowPermRawIdx,n); for(i=0; iDensifyAbove) SparseTrailDensify(buf.m_STrail,i,buf.m_BUpper,buf.m_DTrail); } //--- Process sparse part for(k=0; k0) { //--- Update dense trail //--- NOTE: this update MUST be performed before we update sparse trail, //--- because sparse update may move columns to dense storage after //--- update is performed on them. Thus, we have to avoid applying //--- same update twice. if(buf.m_DTrail.m_NDense>0) { tmpndense=buf.m_DTrail.m_NDense; for(i=0; i0) { tmpndense=buf.m_DTrail.m_NDense; //--- Generate column pivots to bring actual order of columns in the //--- working part of the matrix to one used for dense storage for(i=n-tmpndense; i=0,__FUNCTION__+": integrity check failed during reordering")) return(false); buf.m_STrail.m_ColId.Swap(i,jp); pc.Set(i,jp); } //--- Perform dense LU decomposition on dense trail CApServ::RMatrixSetLengthAtLeast(buf.m_DBuf,buf.m_DTrail.m_NDense,buf.m_DTrail.m_NDense); for(i=0; i=1,__FUNCTION__+": N<1")) return; a.m_NFixed=n; a.m_NDynamic=0; a.m_NAllocated=n; a.m_NUsed=0; CApServ::VectorGrowTo(a.m_IdxFirst,n); CApServ::VectorGrowTo(a.m_StrgIdx,2*a.m_NAllocated); CApServ::VectorGrowTo(a.m_StrgVal,a.m_NAllocated); a.m_IdxFirst.Fill(-1); } //+------------------------------------------------------------------+ //| This function swaps sequences #I and #J stored by the structure | //+------------------------------------------------------------------+ void CSpTrf::SLUV2List1Swap(CSLUV2List1Matrix &a,int i,int j) { a.m_IdxFirst.Swap(i,j); } //+------------------------------------------------------------------+ //| This function drops sequence #I from the structure | //+------------------------------------------------------------------+ void CSpTrf::SLUV2List1DropSequence(CSLUV2List1Matrix &a,int i) { a.m_IdxFirst.Set(i,-1); } //+------------------------------------------------------------------+ //| This function appends sequence from the structure to the sparse | //| matrix. | //| It is assumed that S is a lower triangular matrix, and A stores | //| strictly lower triangular elements (no diagonal ones!). You can | //| explicitly control whether you want to add diagonal elements or | //| not. | //| Output matrix is assumed to be stored in CRS format and to be | //| partially initialized (up to, but not including, Dst-th row). | //| DIdx and UIdx are NOT updated by this function as well as | //| NInitialized. | //| INPUT PARAMETERS: | //| A - rectangular matrix structure | //| Src - sequence (row or column) index in the structure | //| HasDiagonal- whether we want to add diagonal element | //| D - diagonal element, if HasDiagonal=True | //| NZMAX - maximum estimated number of non-zeros in the row, | //| this function will preallocate storage in the | //| output matrix. | //| S - destination matrix in CRS format, partially | //| initialized | //| Dst - destination row index | //+------------------------------------------------------------------+ void CSpTrf::SLUV2List1AppendSequenceToMatrix(CSLUV2List1Matrix &a, int src, bool HasDiagonal, double d,int nzmax, CSparseMatrix &s, int dst) { //--- create variables int i0=s.m_RIdx[dst]; int i1=0; int jp=0; int nnz=0; CApServ::VectorGrowTo(s.m_Idx,i0+nzmax); CApServ::VectorGrowTo(s.m_Vals,i0+nzmax); if(HasDiagonal) { i1=i0+nzmax-1; s.m_Idx.Set(i1,dst); s.m_Vals.Set(i1,d); nnz=1; } else { i1=i0+nzmax; nnz=0; } jp=a.m_IdxFirst[src]; while(jp>=0) { i1=i1-1; s.m_Idx.Set(i1,a.m_StrgIdx[2*jp+1]); s.m_Vals.Set(i1,a.m_StrgVal[jp]); nnz=nnz+1; jp=a.m_StrgIdx[2*jp+0]; } for(int i=0; iN")) return; //--- check if(!CAp::Assert(s.m_MatrixType==1,__FUNCTION__+": non-CRS input")) return; //--- initialization a.m_N=s.m_N; a.m_K=0; CApServ::IVectorSetLengthAtLeast(a.m_Nzc,n); CApServ::IVectorSetLengthAtLeast(a.m_ColId,n); CApServ::RVectorSetLengthAtLeast(a.m_Tmp0,n); for(i=0; i=0; i--) { j0=s.m_RIdx[i]; j1=s.m_RIdx[i+1]-1; for(jj=j1; jj>=j0; jj--) { j=s.m_Idx[jj]; //--- Update non-zero counts for columns a.m_Nzc.Set(j,a.m_Nzc[j]+1); //--- Insert into column list p=a.m_SlsColPtr[j]; if(p>=0) a.m_SlsIdx.Set(p*m_SlsWidth,slsused); a.m_SlsIdx.Set(slsused*m_SlsWidth,-1); a.m_SlsIdx.Set(slsused*m_SlsWidth+1,p); a.m_SlsColPtr.Set(j,slsused); //--- Insert into row list p=a.m_SlsRowPtr[i]; if(p>=0) a.m_SlsIdx.Set(p*m_SlsWidth+2,slsused); a.m_SlsIdx.Set(slsused*m_SlsWidth+2,-1); a.m_SlsIdx.Set(slsused*m_SlsWidth+3,p); a.m_SlsRowPtr.Set(i,slsused); //--- Store index and value a.m_SlsIdx.Set(slsused*m_SlsWidth+4,i); a.m_SlsIdx.Set(slsused*m_SlsWidth+5,j); a.m_SlsVal.Set(slsused,s.m_Vals[jj]); slsused++; } } a.m_SlsUsed=slsused; } //+------------------------------------------------------------------+ //| This function searches for a appropriate pivot column/row. | //| If there exists non-densified column, it returns indexes of pivot| //| column and row, with most sparse column selected for column | //| pivoting, and largest element selected for row pivoting. Function| //| result is True. | //| PivotType=1 means that no column pivoting is performed | //| PivotType=2 means that both column and row pivoting are | //| supported | //| If all columns were densified, False is returned. | //+------------------------------------------------------------------+ bool CSpTrf::SparseTrailFindPivot(CSLUV2SparseTrail &a, int pivottype, int &ipiv, int &jpiv) { //--- create variables bool result=true; int n=a.m_N; int k=a.m_K; int j=0; int jp=0; int entry=0; int nz=0; int maxwrknz=0; int nnzbest=n+1; double s=0; double bbest=0; int wrk0=0; int wrk1=0; jpiv=-1; ipiv=-1; //--- Select pivot column if(pivottype==1) { //--- No column pivoting //--- check if(!CAp::Assert(!a.m_IsDensified[k],__FUNCTION__+": integrity check failed")) return(false); jpiv=k; } else { //--- Find pivot column while(true) { //--- Scan working set (if non-empty) for good columns maxwrknz=a.m_MaxWrkNz; for(j=0; jmaxwrknz) continue; if(jpiv<0 || nz=0) break; //--- Well, nothing found. Recompute working set: //--- * determine most sparse unprocessed yet column //--- * gather all columns with density in [Wrk0,Wrk1) range, //--- increase range, repeat, until working set is full a.m_WrkCnt=0; a.m_MaxWrkNz=0; wrk0=n+1; for(jp=k; jpn) //--- Only densified columns are present, exit. return(false); wrk1=wrk0+1; while(a.m_WrkCnt=wrk0 && a.m_Nzc[jp]=0) { s=MathAbs(a.m_SlsVal[entry]); if(ipiv<0 || s>bbest) { bbest=s; ipiv=a.m_SlsIdx[entry*m_SlsWidth+4]; } entry=a.m_SlsIdx[entry*m_SlsWidth+1]; } if(ipiv<0) { ipiv=k; } return(result); } //+------------------------------------------------------------------+ //| This function pivots out specified row and column. | //| Sparse trail range changes from [K,N) to [K+1,N). | //| V0I, V0R, V1I, V1R must be preallocated arrays[N]. | //| Following data are returned: | //| * UU - diagonal element (pivoted out), can be zero | //| * V0I, V0R, NZ0 - sparse column pivoted out to the left (after | //| permutation is applied to its elements) and | //| divided by UU. | //| V0I is array[NZ0] which stores row indexes in [K+1,N) range, V0R | //| stores values. | //| * V1I, V1R, NZ1 - sparse row pivoted out to the top. | //+------------------------------------------------------------------+ void CSpTrf::SparseTrailPivotOut(CSLUV2SparseTrail &a, int ipiv, int jpiv, double &uu, CRowInt &v0i, CRowDouble &v0r, int &nz0, CRowInt &v1i, CRowDouble &v1r, int &nz1) { //--- create variables int n=a.m_N; int k=a.m_K; int i=0; int j=0; int entry=a.m_SlsColPtr[jpiv]; double v=0; double s=0; bool vb; int pos0k=-1; int pos0piv=-1; int pprev=0; int pnext=0; int pnextnext=0; uu=0; nz0=0; nz1=0; //--- check if(!CAp::Assert(kJPiv //--- NOTE: this code leaves V0I/V0R/NZ0 in the unfinalized state, //--- i.e. these arrays do not account for pivoting performed //--- on rows. They will be post-processed later. while(entry>=0) { //--- Offload element i=a.m_SlsIdx[entry*m_SlsWidth+4]; v0i.Set(nz0,i); v0r.Set(nz0,a.m_SlsVal[entry]); if(i==k) pos0k=nz0; if(i==ipiv) pos0piv=nz0; nz0=nz0+1; //--- Remove element from the row list pprev=a.m_SlsIdx[entry*m_SlsWidth+2]; pnext=a.m_SlsIdx[entry*m_SlsWidth+3]; if(pprev>=0) a.m_SlsIdx.Set(pprev*m_SlsWidth+3,pnext); else a.m_SlsRowPtr.Set(i,pnext); if(pnext>=0) a.m_SlsIdx.Set(pnext*m_SlsWidth+2,pprev); //--- Select next entry entry=a.m_SlsIdx[entry*m_SlsWidth+1]; } entry=a.m_SlsColPtr[k]; a.m_SlsColPtr.Set(jpiv,entry); while(entry>=0) { //--- Change column index a.m_SlsIdx.Set(entry*m_SlsWidth+5,jpiv); //--- Next entry entry=a.m_SlsIdx[entry*m_SlsWidth+1]; } //--- Post-process V0, account for pivoting. //--- Compute diagonal element UU. uu=0; if(pos0k>=0 || pos0piv>=0) { //--- Apply permutation to rows of pivoted out column, specific //--- implementation depends on the sparsity at locations #Pos0K //--- and #Pos0Piv of the V0 array. if(pos0k>=0 && pos0piv>=0) { //--- Obtain diagonal element uu=v0r[pos0piv]; if(uu!=0) s=1/uu; else s=1; //--- Move pivoted out element, shift array by one in order //--- to remove heading diagonal element (not needed here //--- anymore). v0r.Set(pos0piv,v0r[pos0k]); for(i=0; i=0 && pos0piv<0) { //--- Diagonal element is zero uu=0; //--- Pivot out element, reorder array v0i.Set(pos0k,ipiv); for(i=pos0k; i=0) { //--- Get diagonal element uu=v0r[pos0piv]; if(uu!=0) s=1/uu; else s=1; //--- Shift array past the pivoted in element by one //--- in order to remove pivot CAblasF::RMulV(pos0piv,s,v0r); for(i=pos0piv; i=0) { //--- Offload element j=a.m_SlsIdx[entry*m_SlsWidth+5]; v1i.Set(nz1,j); v1r.Set(nz1,a.m_SlsVal[entry]); nz1=nz1+1; //--- Remove element from the column list pprev=a.m_SlsIdx[entry*m_SlsWidth+0]; pnext=a.m_SlsIdx[entry*m_SlsWidth+1]; if(pprev>=0) a.m_SlsIdx.Set(pprev*m_SlsWidth+1,pnext); else a.m_SlsColPtr.Set(j,pnext); if(pnext>=0) a.m_SlsIdx.Set(pnext*m_SlsWidth,pprev); //--- Select next entry entry=a.m_SlsIdx[entry*m_SlsWidth+3]; } a.m_SlsRowPtr.Set(ipiv,a.m_SlsRowPtr[k]); entry=a.m_SlsRowPtr[ipiv]; while(entry>=0) { //--- Change row index a.m_SlsIdx.Set(entry*m_SlsWidth+4,ipiv); //--- Resort column affected by row pivoting j=a.m_SlsIdx[entry*m_SlsWidth+5]; pprev=a.m_SlsIdx[entry*m_SlsWidth+0]; pnext=a.m_SlsIdx[entry*m_SlsWidth+1]; while(pnext>=0 && a.m_SlsIdx[pnext*m_SlsWidth+4]next if(pprev>=0) a.m_SlsIdx.Set(pprev*m_SlsWidth+1,pnext); else a.m_SlsColPtr.Set(j,pnext); //--- entry->prev, entry->next a.m_SlsIdx.Set(entry*m_SlsWidth,pnext); a.m_SlsIdx.Set(entry*m_SlsWidth+1,pnextnext); //--- next->prev, next->next a.m_SlsIdx.Set(pnext*m_SlsWidth,pprev); a.m_SlsIdx.Set(pnext*m_SlsWidth+1,entry); //--- nextnext->prev if(pnextnext>=0) a.m_SlsIdx.Set(pnextnext*m_SlsWidth,entry); //--- PPrev, Item, PNext pprev=pnext; pnext=pnextnext; } //--- Next entry entry=a.m_SlsIdx[entry*m_SlsWidth+3]; } //--- Reorder other structures a.m_Nzc.Swap(k,jpiv); a.m_ColId.Swap(k,jpiv); vb=a.m_IsDensified[k]; a.m_IsDensified[k]=a.m_IsDensified[jpiv]; a.m_IsDensified[jpiv]=vb; //--- Handle removal of col/row #K for(i=0; i=0) { a.m_Tmp0.Set(BUpper.m_StrgIdx[2*jp+1],BUpper.m_StrgVal[jp]); jp=BUpper.m_StrgIdx[2*jp+0]; } SLUV2List1DropSequence(BUpper,i1); //--- Offload items [K,N) of densified column from BLeft entry=a.m_SlsColPtr[i1]; while(entry>=0) { //--- Offload element i=a.m_SlsIdx[entry*m_SlsWidth+4]; a.m_Tmp0.Set(i,a.m_SlsVal[entry]); //--- Remove element from the row list pprev=a.m_SlsIdx[entry*m_SlsWidth+2]; pnext=a.m_SlsIdx[entry*m_SlsWidth+3]; if(pprev>=0) a.m_SlsIdx.Set(pprev*m_SlsWidth+3,pnext); else a.m_SlsRowPtr.Set(i,pnext); if(pnext>=0) a.m_SlsIdx.Set(pnext*m_SlsWidth+2,pprev); //--- Select next entry entry=a.m_SlsIdx[entry*m_SlsWidth+1]; } //--- Densify a.m_Nzc.Set(i1,0); a.m_IsDensified[i1]=true; a.m_SlsColPtr.Set(i1,-1); DenseTrailAppendColumn(DTrail,a.m_Tmp0,a.m_ColId[i1]); } //+------------------------------------------------------------------+ //| This function appends rank-1 update to the sparse trail. Dense | //| trail is not updated here, but we may move some columns to dense | //| trail during update (i.e. densify them). Thus, you have to update| //| dense trail BEFORE you start updating sparse one (otherwise, | //| recently densified columns will be updated twice). | //| PARAMETERS: | //| A - sparse trail | //| V0I, V0R - update column returned by SparseTrailPivotOut (MUST| //| be array[N] independently of the NZ0). | //| NZ0 - non-zero count for update column | //| V1I, V1R - update row returned by SparseTrailPivotOut | //| NZ1 - non-zero count for update row | //| BUpper - upper rectangular submatrix, updated during | //| densification of the columns (densified columns are| //| removed) | //| DTrail - dense trail, receives densified columns from sparse| //| trail and BUpper | //| DensificationSupported- if False, no densification is performed| //+------------------------------------------------------------------+ void CSpTrf::SparseTrailUpdate(CSLUV2SparseTrail &a, CRowInt &v0i, CRowDouble &v0r, int nz0, CRowInt &v1i, CRowDouble &v1r, int nz1, CSLUV2List1Matrix &BUpper, CSLUV2DenseTrail &DTrail, bool DensificationSupported) { //--- create variables int n=a.m_N; int k=a.m_K; int i=0; int j=0; int i0=0; int i1=0; double v1=0; int densifyabove=(int)MathRound(m_DenseBnd*(n-k))+1; int nnz=0; int entry=0; int newentry=0; int pprev=0; int pnext=0; int p=0; int nexti=0; int newoffs=0; //--- check if(!CAp::Assert(k=nz0+1,__FUNCTION__+": integrity check failed")) return; //--- check if(!CAp::Assert(CAp::Len(v0r)>=nz0+1,__FUNCTION__+": integrity check failed")) return; v0i.Set(nz0,-1); v0r.Set(nz0,0); //--- Update sparse representation CApServ::VectorGrowTo(a.m_SlsIdx,(a.m_SlsUsed+nz0*nz1)*m_SlsWidth); CApServ::VectorGrowTo(a.m_SlsVal,a.m_SlsUsed+nz0*nz1); for(j=0; j=0) nexti=a.m_SlsIdx[entry*m_SlsWidth+4]; else nexti=n+1; while(i=nexti) break; //--- Allocate new entry, store column/row/value newentry=a.m_SlsUsed; a.m_SlsUsed=newentry+1; nnz=nnz+1; newoffs=newentry*m_SlsWidth; a.m_SlsIdx.Set(newoffs+4,i0); a.m_SlsIdx.Set(newoffs+5,i1); a.m_SlsVal.Set(newentry,-(v1*v0r[i])); //--- Insert entry into column list a.m_SlsIdx.Set(newoffs,pprev); a.m_SlsIdx.Set(newoffs+1,pnext); if(pprev>=0) a.m_SlsIdx.Set(pprev*m_SlsWidth+1,newentry); else a.m_SlsColPtr.Set(i1,newentry); if(entry>=0) a.m_SlsIdx.Set(entry*m_SlsWidth,newentry); //--- Insert entry into row list p=a.m_SlsRowPtr[i0]; a.m_SlsIdx.Set(newoffs+2,-1); a.m_SlsIdx.Set(newoffs+3,p); if(p>=0) a.m_SlsIdx.Set(p*m_SlsWidth+2,newentry); a.m_SlsRowPtr.Set(i0,newentry); //--- Advance pointers pprev=newentry; i=i+1; i0=v0i[i]; } if(i>=nz0) break; //--- Update already existing entry of the column list, if needed if(entry>=0) { if(i0==nexti) { a.m_SlsVal.Set(entry,a.m_SlsVal[entry]-v1*v0r[i]); i=i+1; i0=v0i[i]; } pprev=entry; } //--- Advance to the next pre-existing entry (if present) if(entry>=0) entry=a.m_SlsIdx[entry*m_SlsWidth+1]; } a.m_Nzc.Set(i1,nnz); //--- Densify column if needed if((DensificationSupported && nnz>densifyabove) && !a.m_IsDensified[i1]) SparseTrailDensify(a,i1,BUpper,DTrail); } } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ class CAmdOrdering { public: static const int m_KNsHeaderSize; static const int m_LLMentrySize; static void GenerateAmdPermutation(CSparseMatrix &A,int n,CRowInt &Perm,CRowInt &InvPerm,CAmdBuffer &Buf); static int GenerateAmdPermutationX(CSparseMatrix &A,bool &Eligible[],int n,CRowInt &Perm,CRowInt &InvPerm,int AmdType,CAmdBuffer &Buf); private: static void NsInitEmptySlow(int n,CAmdNSet &SA); static void NsCopy(CAmdNSet &SSrc,CAmdNSet &SDst); static void NsAddElement(CAmdNSet &SA,int k); static void NsAddKth(CAmdNSet &SA,CAmdKNSet &Src,int k); static void NsSubtract1(CAmdNSet &SA,CAmdNSet &Src); static void NsSubtractKth(CAmdNSet &SA,CAmdKNSet &Src,int k); static void NsClear(CAmdNSet &SA); static int NsCount(CAmdNSet &SA); static int NsCountNotKth(CAmdNSet &SA,CAmdKNSet &Src,int k); static int NsCountAndKth(CAmdNSet &SA,CAmdKNSet &Src,int k); static bool NsEqual(CAmdNSet &S0,CAmdNSet &S1); static void NsStartEnumeration(CAmdNSet &SA); static bool NsEnumerate(CAmdNSet &SA,int &J); static void KNsCompressStorage(CAmdKNSet &SA); static void KNsRealLocate(CAmdKNSet &SA,int setidx,int NewAllocated); static void KNsInit(int k,int n,int kPrealloc,CAmdKNSet &SA); static void KNsInitFromA(CSparseMatrix &A,int n,CAmdKNSet &SA); static void KNsStartEnumeration(CAmdKNSet &SA,int i); static bool KNsEnumerate(CAmdKNSet &SA,int &J); static void KNsDirectAccess(CAmdKNSet &SA,int k,int &idxbegin,int &idxend); static void KNsAddNewElement(CAmdKNSet &SA,int i,int k); static void KNsSubtract1(CAmdKNSet &SA,int i,CAmdNSet &Src); static void KNsAddKthDistinct(CAmdKNSet &SA,int i,CAmdKNSet &Src,int k); static int KNsCountKth(CAmdKNSet &S0,int k); static int KNsCountNot(CAmdKNSet &S0,int i,CAmdNSet &S1); static int KNsCountNotKth(CAmdKNSet &S0,int i,CAmdKNSet &S1,int k); static int KNsCountAndKth(CAmdKNSet &S0,int i,CAmdKNSet &S1,int k); static int KNsSumKth(CAmdKNSet &s0,int i); static void KNsClearKthNoReclaim(CAmdKNSet &SA,int k); static void KNsClearKthReclaim(CAmdKNSet &SA,int k); static void MtxInit(int n,CAmdLLMatrix &A); static void MtxAddColumnTo(CAmdLLMatrix &A,int j,CAmdNSet &S); static void MtxInsertNewElement(CAmdLLMatrix &A,int i,int j); static int MtxCountColumnNot(CAmdLLMatrix &A,int j,CAmdNSet &S); static int MtxCountColumn(CAmdLLMatrix &A,int j); static void MtxClearX(CAmdLLMatrix &A,int k,bool IsCol); static void MtxClearColumn(CAmdLLMatrix &A,int j); static void MtxClearRow(CAmdLLMatrix &A,int j); static void VtxInit(CSparseMatrix &A,int n,bool CheckExactDegrees,CAmdVertexSet &S); static void VtxRemoveVertex(CAmdVertexSet &S,int p); static int VtxGetApprox(CAmdVertexSet &S,int p); static int VtxGetExact(CAmdVertexSet &S,int p); static int VtxGetApproxMinDegree(CAmdVertexSet &S); static void VtxUpdateApproximateDegree(CAmdVertexSet &S,int p,int DNew); static void VtxUpdateExactDegree(CAmdVertexSet &S,int p,int d); static void AmdSelectPivotElement(CAmdBuffer &Buf,int k,int &p,int &nodesize); static void AmdComputeLp(CAmdBuffer &Buf,int p); static void AmdMasselimination(CAmdBuffer &Buf,int p,int k,int tau); static void AmdDetectSuperNodes(CAmdBuffer &Buf); static void AmdMoveToQuasiDense(CAmdBuffer &Buf,CAmdNSet &Cand,int p); }; //+------------------------------------------------------------------+ //| Constants | //+------------------------------------------------------------------+ const int CAmdOrdering::m_KNsHeaderSize=2; const int CAmdOrdering::m_LLMentrySize=6; //+------------------------------------------------------------------+ //| This function generates approximate minimum degree ordering | //| INPUT PARAMETERS: | //| A - lower triangular sparse matrix in CRS format. Only | //| sparsity structure (as given by Idx[] field) | //| matters, specific values of matrix elements are | //| ignored. | //| N - problem size | //| Buf - reusable buffer object, does not need special | //| initialization | //| OUTPUT PARAMETERS: | //| Perm - array[N], maps original indexes I to permuted | //| indexes | //| InvPerm - array[N], maps permuted indexes I to original | //| indexes | //| NOTE: definite 'DEBUG.SLOW' Trace tag will activate extra-slow | //| (roughly N^3 ops) integrity checks, in addition to cheap | //| O(1) ones. | //+------------------------------------------------------------------+ void CAmdOrdering::GenerateAmdPermutation(CSparseMatrix &a, int n,CRowInt &perm, CRowInt &invperm, CAmdBuffer &buf) { bool dummy[]; int r=GenerateAmdPermutationX(a,dummy,n,perm,invperm,0,buf); //--- check CAp::Assert(r==n,__FUNCTION__+": integrity check failed,the matrix is only partially processed"); } //+------------------------------------------------------------------+ //| This function generates approximate minimum degree ordering, | //| either classic or improved with better support for dense rows: | //| * the classic version processed entire matrix and returns N as | //| result. The problem with classic version is that it may be | //| slow for matrices with dense or nearly dense rows | //| * the improved version processes K most sparse rows, and moves | //| other N-K ones to the end. The number of sparse rows K is | //| returned. The Tail, which is now a (N-K)*(N-K) matrix, should| //| be repeatedly processed by the same function until zero is | //| returned. | //| INPUT PARAMETERS: | //| A - lower triangular sparse matrix in CRS format | //| Eligible - array[N], set of boolean flags that mark columns of| //| A as eligible for ordering. Columns that are not | //| eligible are postponed (moved to the end) by the | //| improved AMD algorithm. This array is ignored (not | //| referenced at all) when AMDType=0. | //| N - problem size | //| AMDType - ordering type: | //| * 0 for the classic AMD | //| * 1 for the improved AMD | //| Buf - reusable buffer object, does not need special | //| initialization | //| OUTPUT PARAMETERS: | //| Perm - array[N], maps original indexes I to permuted | //| indexes | //| InvPerm - array[N], maps permuted indexes I to original | //| indexes | //| RESULT: | //| number of successfully ordered rows/cols; | //| for AMDType=0: Result=N | //| for AMDType=1: 0<=Result<=N. Result=0 is returned only when | //| there are no columns that are both sparse | //| enough and eligible. | //| NOTE: defining 'DEBUG.SLOW' Trace tag will activate extra-slow | //| (roughly N^3 ops) integrity checks, in addition to cheap | //| O(1) ones. | //+------------------------------------------------------------------+ int CAmdOrdering::GenerateAmdPermutationX(CSparseMatrix &a, bool &eligible[], int n,CRowInt &perm, CRowInt &invperm, int amdtype, CAmdBuffer &buf) { //--- create variables int setprealloc=3; int inithashbucketsize=16; int extendeddebug=CAp::IsTraceEnabled("DEBUG.SLOW") && n <= 100; int result=n; int i=0; int j=0; int k=0; int p=0; int nodesize=0; int cnt0=0; int cnt1=0; int tau=0; double meand=0; int d=0; //--- check if(!CAp::Assert(amdtype==0 || amdtype==1,__FUNCTION__+": unexpected ordering type")) return(-1);; //--- initialization buf.m_N=n; buf.m_CheckExactDegrees=extendeddebug; buf.m_ExtendedDebug=extendeddebug; MtxInit(n,buf.m_MtxL); KNsInitFromA(a,n,buf.m_SetA); KNsInit(n,n,setprealloc,buf.m_SetSuper); for(i=0; i::Identity(n,n); for(i=0; i=i && CSparse::SparseExists(a,j,i))) buf.m_Dbga.Set(i,j,(0.1/n*(MathSin(i+0.17)+MathCos(MathSqrt(j+0.65))))); else break; } } } tau=0; if(amdtype==1) { //--- check if(!CAp::Assert(CAp::Len(eligible)>=n,__FUNCTION__+": length(Eligible)tau) NsAddElement(buf.m_SetQSuperCand,i); AmdMoveToQuasiDense(buf,buf.m_SetQSuperCand,-1); } k=0; while(k=VtxGetExact(buf.m_VertexDegrees,p),__FUNCTION__+": integrity check for ApproxD failed")) return(-1); //--- check if(!CAp::Assert(VtxGetExact(buf.m_VertexDegrees,p)==cnt0,__FUNCTION__+": integrity check for ExactD failed")) return(-1); } //--- check if(!CAp::Assert(VtxGetApprox(buf.m_VertexDegrees,p)>=NsCount(buf.m_Lp),__FUNCTION__+": integrity check 7956 failed")) return(-1); //--- check if(!CAp::Assert((KNsCountKth(buf.m_SetE,p)>2 || NsCount(buf.m_SetQ)>0) || VtxGetApprox(buf.m_VertexDegrees,p)==NsCount(buf.m_Lp),__FUNCTION__+": integrity check 7295 failed")) return(-1); KNsStartEnumeration(buf.m_SetE,p); while(KNsEnumerate(buf.m_SetE,j)) MtxClearColumn(buf.m_MtxL,j); KNsStartEnumeration(buf.m_SetSuper,p); while(KNsEnumerate(buf.m_SetSuper,j)) { buf.m_IsEliminated[j]=true; MtxClearRow(buf.m_MtxL,j); } KNsClearKthReclaim(buf.m_SetA,p); KNsClearKthReclaim(buf.m_SetE,p); buf.m_IsSuperNode[p]=false; VtxRemoveVertex(buf.m_VertexDegrees,p); k=k+nodesize; } //--- check if(!CAp::Assert(k+NsCount(buf.m_SetQ)==n,__FUNCTION__+": integrity check 6326 failed")) return(-1); //--- check if(!CAp::Assert(k>0 || amdtype==1,__FUNCTION__+": integrity check 9463 failed")) return(-1); result=k; CApServ::IVectorSetLengthAtLeast(perm,n); CApServ::IVectorSetLengthAtLeast(invperm,n); for(i=0; i=0) return; int ns=sa.m_NStored; sa.m_LocationOf.Set(k,ns); sa.m_Items.Set(ns,k); sa.m_NStored=ns+1; } //+------------------------------------------------------------------+ //| Add K-th set from the source kn-set | //| INPUT PARAMETERS: | //| SA - set | //| Src, K - source kn-set and set index K | //| OUTPUT PARAMETERS: | //| SA - modified SA | //+------------------------------------------------------------------+ void CAmdOrdering::NsAddKth(CAmdNSet &SA,CAmdKNSet &Src,int k) { int idxbegin=Src.m_VBegin[k]; int idxend=idxbegin+Src.m_VCnt[k]; int ns=SA.m_NStored; int j=0; while(idxbegin=0) { item=SA.m_Items[ns-1]; SA.m_Items.Set(loc,item); SA.m_LocationOf.Set(item,loc); SA.m_LocationOf.Set(j,-1); ns=ns-1; } } } else { i=0; while(i=0) { item=SA.m_Items[ns-1]; SA.m_Items.Set(i,item); SA.m_LocationOf.Set(item,i); SA.m_LocationOf.Set(j,-1); ns=ns-1; } else { i=i+1; } } } SA.m_NStored=ns; } //+------------------------------------------------------------------+ //| Subtracts K-th set from the source structure | //| INPUT PARAMETERS: | //| SA - set | //| Src, K - source kn-set and set index K | //| OUTPUT PARAMETERS: | //| SA - modified SA | //+------------------------------------------------------------------+ void CAmdOrdering::NsSubtractKth(CAmdNSet &SA,CAmdKNSet &Src, int k) { //--- create variables int idxbegin=Src.m_VBegin[k]; int idxend=idxbegin+Src.m_VCnt[k]; int j=0; int loc=0; int ns=SA.m_NStored; int item=0; while(idxbegin=0) { item=SA.m_Items[ns-1]; SA.m_Items.Set(loc,item); SA.m_LocationOf.Set(item,loc); SA.m_LocationOf.Set(j,-1); ns=ns-1; } idxbegin=idxbegin+1; } SA.m_NStored=ns; } //+------------------------------------------------------------------+ //| Clears set | //| INPUT PARAMETERS: | //| SA - set to be cleared | //+------------------------------------------------------------------+ void CAmdOrdering::NsClear(CAmdNSet &SA) { SA.m_LocationOf.Fill(-1); SA.m_NStored=0; } //+------------------------------------------------------------------+ //| Counts set elements | //| INPUT PARAMETERS: | //| SA - set | //| RESULT: | //| number of elements in SA | //+------------------------------------------------------------------+ int CAmdOrdering::NsCount(CAmdNSet &SA) { return(SA.m_NStored); } //+------------------------------------------------------------------+ //| Counts set elements not present in the K-th set of the source | //| structure | //| INPUT PARAMETERS: | //| SA - set | //| Src, K - source kn-set and set index K | //| RESULT: | //| number of elements in SA not present in Src[K] | //+------------------------------------------------------------------+ int CAmdOrdering::NsCountNotKth(CAmdNSet &SA,CAmdKNSet &Src, int k) { //--- create variables int result=0; int idxbegin=Src.m_VBegin[k]; int idxend=idxbegin+Src.m_VCnt[k]; int intersectcnt=0; //--- main loop for(int i=idxbegin; i=0) intersectcnt++; } result=SA.m_NStored-intersectcnt; //--- return result return(result); } //+------------------------------------------------------------------+ //| Counts set elements also present in the K-th set of the source | //| structure | //| INPUT PARAMETERS: | //| SA - set | //| Src, K - source kn-set and set index K | //| RESULT: | //| number of elements in SA also present in Src[K] | //+------------------------------------------------------------------+ int CAmdOrdering::NsCountAndKth(CAmdNSet &SA,CAmdKNSet &Src, int k) { //--- create variables int result=0; int idxbegin=Src.m_VBegin[k]; int idxend=idxbegin+Src.m_VCnt[k]; //--- main loop for(int i=idxbegin; i=0) result++; //--- return result return(result); } //+------------------------------------------------------------------+ //| Compare two sets, returns True for equal sets | //| INPUT PARAMETERS: | //| S0 - set 0 | //| S1 - set 1, must have same parameter N as set 0 | //| RESULT | //| True, if sets are equal | //+------------------------------------------------------------------+ bool CAmdOrdering::NsEqual(CAmdNSet &S0,CAmdNSet &S1) { //--- check if(S0.m_N!=S1.m_N) return(false); if(S0.m_NStored!=S1.m_NStored) return(false); int ns=S0.m_NStored; for(int i=0; i=SA.m_NStored) return(false); J=SA.m_Items[k]; SA.m_IterIdx=k+1; //--- return result return(true); } //+------------------------------------------------------------------+ //| Compresses internal storage, reclaiming previously dropped blocks| //| To be used internally by kn-set modification functions. | //| INPUT PARAMETERS: | //| SA - kn-set to compress | //+------------------------------------------------------------------+ void CAmdOrdering::KNsCompressStorage(CAmdKNSet &SA) { //--- create variables int blocklen=0; int setidx=0; int srcoffs=0; int dstoffs=0; //--- main loop while(srcoffs=m_KNsHeaderSize,__FUNCTION__+": integrity check 6385 failed")) return; if(setidx<0) { srcoffs=srcoffs+blocklen; continue; } if(srcoffs!=dstoffs) { for(int i=0; i=0) { SA.m_Data.Set(idxbegin,SA.m_Data[idxend-1]); idxend--; cnt=cnt-1; } else idxbegin++; } SA.m_VCnt.Set(I,cnt); } //+------------------------------------------------------------------+ //| Adds K-th set of the source kn-set to the I-th destination set. | //| The caller guarantees that SA[I] and Src[J] do NOT intersect, | //| i.e. do not have shared elements - it allows to use faster | //| algorithms. | //| INPUT PARAMETERS: | //| SA - destination kn-set structure | //| I - set index in the structure | //| Src - source kn-set | //| K - set index | //| OUTPUT PARAMETERS: | //| SA - I-th set plus for elements in K-th set of Src | //+------------------------------------------------------------------+ void CAmdOrdering::KNsAddKthDistinct(CAmdKNSet &SA,int i, CAmdKNSet &Src,int k) { //--- create variables int idxdst=0; int idxsrcbegin=0; int j=0; int cnt=SA.m_VCnt[i]; int srccnt=Src.m_VCnt[k]; if(cnt+srccnt>SA.m_VAllocated[i]) KNsRealLocate(SA,i,2*(cnt+srccnt)+1); idxsrcbegin=Src.m_VBegin[k]; idxdst=SA.m_VBegin[i]+cnt; for(j=0; j<=srccnt-1; j++) { SA.m_Data.Set(idxdst,Src.m_Data[idxsrcbegin+j]); idxdst=idxdst+1; } SA.m_VCnt.Set(i,cnt+srccnt); } //+------------------------------------------------------------------+ //| Counts elements of K-th set of S0 | //| INPUT PARAMETERS: | //| S0 - kn-set structure | //| K - set index in the structure S0 | //| RESULT | //| K-th set element count | //+------------------------------------------------------------------+ int CAmdOrdering::KNsCountKth(CAmdKNSet &S0,int k) { return(S0.m_VCnt[k]); } //+------------------------------------------------------------------+ //| Counts elements of I-th set of S0 not present in S1 | //| INPUT PARAMETERS: | //| S0 - kn-set structure | //| I - set index in the structure S0 | //| S - kn-set to compare against | //| RESULT | //| count | //+------------------------------------------------------------------+ int CAmdOrdering::KNsCountNot(CAmdKNSet &S0,int i,CAmdNSet &S1) { //--- create variables int result=0; int j=0; int cnt0=S0.m_VCnt[i]; int idxbegin0=S0.m_VBegin[i]; //--- main loop for(j=0; j0) result++; for(j=0; j=m_KNsHeaderSize) { SA.m_Data.Set(dxbegin-2,2); SA.m_Data.Set(dxbegin,allocated); SA.m_Data.Set(dxbegin+1,-1); SA.m_VAllocated.Set(k,0); } } //+------------------------------------------------------------------+ //| Initialize linked list matrix | //| INPUT PARAMETERS: | //| N - matrix size | //| OUTPUT PARAMETERS: | //| A - NxN linked list matrix | //+------------------------------------------------------------------+ void CAmdOrdering::MtxInit(int n,CAmdLLMatrix &A) { A.m_N=n; CAblasF::ISetAllocV(2*n+1,-1,A.m_VBegin); CAblasF::ISetAllocV(n,0,A.m_VColCnt); A.m_EntriesInitialized=0; } //+------------------------------------------------------------------+ //| Adds column from matrix to n-set | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| J - column index to add | //| S - target n-set | //| OUTPUT PARAMETERS: | //| S - elements from J-th column are added to S | //+------------------------------------------------------------------+ void CAmdOrdering::MtxAddColumnTo(CAmdLLMatrix &A,int j,CAmdNSet &S) { //--- create variables int n=A.m_N; int eidx=A.m_VBegin[n+j]; //--- main loop while(eidx>=0) { NsAddElement(S,A.m_Entries[eidx*m_LLMentrySize+4]); eidx=A.m_Entries[eidx*m_LLMentrySize+3]; } } //+------------------------------------------------------------------+ //| Inserts new element into column J, row I. The caller guarantees | //| that the element being inserted is NOT already present in the | //| matrix. | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| I - row index | //| J - column index | //| OUTPUT PARAMETERS: | //| A - element (I,J) added to the list. | //+------------------------------------------------------------------+ void CAmdOrdering::MtxInsertNewElement(CAmdLLMatrix &A,int i,int j) { //--- create variables int k=0; int newsize=0; int eidx=0; int Offs=0; int n=A.m_N; if(A.m_VBegin[2*n]<0) { newsize=2*A.m_EntriesInitialized+1; A.m_Entries.Resize(newsize*m_LLMentrySize); for(k=A.m_EntriesInitialized; k=0) A.m_Entries.Set(A.m_VBegin[i]*m_LLMentrySize,eidx); A.m_Entries.Set(Offs+2,-1); A.m_Entries.Set(Offs+3,A.m_VBegin[j+n]); if(A.m_VBegin[j+n]>=0) A.m_Entries.Set(A.m_VBegin[j+n]*m_LLMentrySize+2,eidx); A.m_Entries.Set(Offs+4,i); A.m_Entries.Set(Offs+5,j); A.m_VBegin.Set(i,eidx); A.m_VBegin.Set(j+n,eidx); A.m_VColCnt.Set(j,A.m_VColCnt[j]+1); } //+------------------------------------------------------------------+ //| Counts elements in J-th column that are not present in n-set S | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| J - column index | //| S - n-set to compare against | //| RESULT | //| element count | //+------------------------------------------------------------------+ int CAmdOrdering::MtxCountColumnNot(CAmdLLMatrix &A,int j, CAmdNSet &S) { //--- create variables int result=0; int n=A.m_N; int eidx=A.m_VBegin[n+j]; while(eidx>=0) { if(S.m_LocationOf[A.m_Entries[eidx*m_LLMentrySize+4]]<0) result++; eidx=A.m_Entries[eidx*m_LLMentrySize+3]; } //--- return result return(result); } //+------------------------------------------------------------------+ //| Counts elements in J-th column | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| J - column index | //| RESULT | //| element count | //+------------------------------------------------------------------+ int CAmdOrdering::MtxCountColumn(CAmdLLMatrix &A,int j) { return(A.m_VColCnt[j]); } //+------------------------------------------------------------------+ //| Clears K-th column or row | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| K - column/row index to clear | //| IsCol - whether we want to clear row or column | //| OUTPUT PARAMETERS: | //| A - K-th column or row is empty | //+------------------------------------------------------------------+ void CAmdOrdering::MtxClearX(CAmdLLMatrix &A,int k,bool IsCol) { //--- create variables int enext=0; int idxprev=0; int idxnext=0; int idxr=0; int idxc=0; int n=A.m_N; int eidx=(IsCol?A.m_VBegin[n+k]: A.m_VBegin[k]); //--- main loop while(eidx>=0) { idxr=A.m_Entries[eidx*m_LLMentrySize+4]; idxc=A.m_Entries[eidx*m_LLMentrySize+5]; if(IsCol) enext=A.m_Entries[eidx*m_LLMentrySize+3]; else enext=A.m_Entries[eidx*m_LLMentrySize+1]; idxprev=A.m_Entries[eidx*m_LLMentrySize]; idxnext=A.m_Entries[eidx*m_LLMentrySize+1]; if(idxprev>=0) A.m_Entries.Set(idxprev*m_LLMentrySize+1,idxnext); else A.m_VBegin.Set(idxr,idxnext); if(idxnext>=0) A.m_Entries.Set(idxnext*m_LLMentrySize,idxprev); idxprev=A.m_Entries[eidx*m_LLMentrySize+2]; idxnext=A.m_Entries[eidx*m_LLMentrySize+3]; if(idxprev>=0) A.m_Entries.Set(idxprev*m_LLMentrySize+3,idxnext); else A.m_VBegin.Set(idxc+n,idxnext); if(idxnext>=0) A.m_Entries.Set(idxnext*m_LLMentrySize+2,idxprev); A.m_Entries.Set(eidx*m_LLMentrySize,A.m_VBegin[2*n]); A.m_VBegin.Set(2*n,eidx); eidx=enext; if(!IsCol) A.m_VColCnt.Set(idxc,A.m_VColCnt[idxc]-1); } if(IsCol) A.m_VColCnt.Set(k,0); } //+------------------------------------------------------------------+ //| Clears J-th column | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| J - column index to clear | //| OUTPUT PARAMETERS: | //| A - J-th column is empty | //+------------------------------------------------------------------+ void CAmdOrdering::MtxClearColumn(CAmdLLMatrix &A,int j) { MtxClearX(A,j,true); } //+------------------------------------------------------------------+ //| Clears J-th row | //| INPUT PARAMETERS: | //| A - NxN linked list matrix | //| J - row index to clear | //| OUTPUT PARAMETERS: | //| A - J-th row is empty | //+------------------------------------------------------------------+ void CAmdOrdering::MtxClearRow(CAmdLLMatrix &A,int j) { MtxClearX(A,j,false); } //+------------------------------------------------------------------+ //| Initialize vertex storage using A to estimate initial degrees | //| INPUT PARAMETERS: | //| A - NxN lower triangular sparse CRS matrix | //| N - problem size | //| CheckExactDegrees- | //| whether we want to maintain additional exact degress| //| (the search is still done using approximate ones) | //| OUTPUT PARAMETERS: | //| S - vertex set | //+------------------------------------------------------------------+ void CAmdOrdering::VtxInit(CSparseMatrix &A,int n, bool CheckExactDegrees, CAmdVertexSet &S) { //--- create variables int i=0; int j=0; int jj=0; int j0=0; int j1=0; //--- initialization S.m_N=n; S.m_CheckExactDegrees=CheckExactDegrees; S.m_SmallestDegree=0; CAblasF::BSetAllocV(n,true,S.m_IsVertex); CAblasF::ISetAllocV(n,0,S.m_ApproxD); for(i=0; i=0) S.m_VPrev.Set(j0,i); } } //+------------------------------------------------------------------+ //| Removes vertex from the storage | //| INPUT PARAMETERS: | //| S - vertex set | //| P - vertex to be removed | //| OUTPUT PARAMETERS: | //| S - modified | //+------------------------------------------------------------------+ void CAmdOrdering::VtxRemoveVertex(CAmdVertexSet &S,int p) { //--- create variables int d=S.m_ApproxD[p]; int idxprev=S.m_VPrev[p]; int idxnext=S.m_VNext[p]; //--- check if(idxprev>=0) S.m_VNext.Set(idxprev,idxnext); else S.m_VBegin.Set(d,idxnext); if(idxnext>=0) S.m_VPrev.Set(idxnext,idxprev); S.m_IsVertex[p]=false; S.m_ApproxD.Set(p,-9999999); if(S.m_CheckExactDegrees) S.m_OptionalExactD.Set(p,-9999999); } //+------------------------------------------------------------------+ //| Get approximate degree. Result is undefined for removed vertexes.| //| INPUT PARAMETERS: | //| S - vertex set | //| P - vertex index | //| RESULT | //| vertex degree | //+------------------------------------------------------------------+ int CAmdOrdering::VtxGetApprox(CAmdVertexSet &S,int p) { return(S.m_ApproxD[p]); } //+------------------------------------------------------------------+ //| Get exact degree (or 0, if not supported). Result is undefined | //| for removed vertexes. | //| INPUT PARAMETERS: | //| S - vertex set | //| P - vertex index | //| RESULT | //| vertex degree | //+------------------------------------------------------------------+ int CAmdOrdering::VtxGetExact(CAmdVertexSet &S,int p) { return (S.m_CheckExactDegrees?S.m_OptionalExactD[p]:0); } //+------------------------------------------------------------------+ //| Returns index of vertex with minimum approximate degree, or -1 | //| when there is no vertex. | //| INPUT PARAMETERS: | //| S - vertex set | //| RESULT | //| vertex index, or -1 | //+------------------------------------------------------------------+ int CAmdOrdering::VtxGetApproxMinDegree(CAmdVertexSet &S) { //--- create variables int result=-1; int n=S.m_N; //--- main loop for(int i=S.m_SmallestDegree; i=0) { S.m_SmallestDegree=i; result=S.m_VBegin[i]; break; } } //--- return result return(result); } //+------------------------------------------------------------------+ //| Update approximate degree | //| INPUT PARAMETERS: | //| S - vertex set | //| P - vertex to be updated | //| DNew - new degree | //| OUTPUT PARAMETERS: | //| S - modified | //+------------------------------------------------------------------+ void CAmdOrdering::VtxUpdateApproximateDegree(CAmdVertexSet &S, int p,int DNew) { //--- create variables int idxprev=S.m_VPrev[p]; int idxnext=S.m_VNext[p]; int oldbegin=0; int dold=S.m_ApproxD[p]; if(dold==DNew) return; if(idxprev>=0) S.m_VNext.Set(idxprev,idxnext); else S.m_VBegin.Set(dold,idxnext); if(idxnext>=0) S.m_VPrev.Set(idxnext,idxprev); oldbegin=S.m_VBegin[DNew]; S.m_VBegin.Set(DNew,p); S.m_VNext.Set(p,oldbegin); S.m_VPrev.Set(p,-1); if(oldbegin>=0) S.m_VPrev.Set(oldbegin,p); S.m_ApproxD.Set(p,DNew); if(DNew=0,__FUNCTION__+": integrity check 3634 failed")) return; if(!CAp::Assert(VtxGetApprox(Buf.m_VertexDegrees,p)>=0,__FUNCTION__+": integrity check RDFD2 failed")) return; KNsStartEnumeration(Buf.m_SetSuper,p); while(KNsEnumerate(Buf.m_SetSuper,j)) { i=Buf.m_Perm[j]; Buf.m_ColumnSwaps.Set(k+nodesize,i); Buf.m_InvPerm.Set(i,Buf.m_InvPerm[k+nodesize]); Buf.m_InvPerm.Set(k+nodesize,j); Buf.m_Perm.Set(Buf.m_InvPerm[i],i); Buf.m_Perm.Set(Buf.m_InvPerm[k+nodesize],k+nodesize); nodesize++; } //--- check CAp::Assert(VtxGetApprox(Buf.m_VertexDegrees,p)>=0 && (!Buf.m_CheckExactDegrees || VtxGetExact(Buf.m_VertexDegrees,p)>=0), __FUNCTION__+": integrity check RDFD failed"); } //+------------------------------------------------------------------+ //| This function computes nonzero pattern of Lp, the column that is | //| added to the lower triangular Cholesky factor. | //| INPUT PARAMETERS: | //| Buf - properly initialized buffer object | //| P - pivot column | //| OUTPUT PARAMETERS: | //| Buf.m_setP - initialized with setSuper[P] | //| Buf.m_Lp - initialized with Lp\P | //| Buf.m_setRp- initialized with Lp\{P+Q} | //| Buf.m_Ep - initialized with setE[P] | //| Buf.m_MtxL - L := L+Lp | //| Buf.m_Ls - first Buf.LSCnt elements contain subset of Lp | //| elements that are principal nodes in supervariables.| //+------------------------------------------------------------------+ void CAmdOrdering::AmdComputeLp(CAmdBuffer &Buf,int p) { //--- create variables int i=0; NsClear(Buf.m_SetP); NsAddKth(Buf.m_SetP,Buf.m_SetSuper,p); NsClear(Buf.m_Lp); NsAddKth(Buf.m_Lp,Buf.m_SetA,p); KNsStartEnumeration(Buf.m_SetE,p); while(KNsEnumerate(Buf.m_SetE,i)) MtxAddColumnTo(Buf.m_MtxL,i,Buf.m_Lp); NsSubtractKth(Buf.m_Lp,Buf.m_SetSuper,p); NsCopy(Buf.m_Lp,Buf.m_SetRP); NsSubtract1(Buf.m_SetRP,Buf.m_SetQ); Buf.m_LSCnt=0; NsStartEnumeration(Buf.m_Lp); while(NsEnumerate(Buf.m_Lp,i)) { //--- check if(!CAp::Assert(!Buf.m_IsEliminated[i],__FUNCTION__+": integrity check 0740 failed")) return; MtxInsertNewElement(Buf.m_MtxL,i,p); if(Buf.m_IsSuperNode[i]) { Buf.m_Ls.Set(Buf.m_LSCnt,i); Buf.m_LSCnt++; } } NsClear(Buf.m_Ep); NsAddKth(Buf.m_Ep,Buf.m_SetE,p); } //+------------------------------------------------------------------+ //| Having output of AMDComputeLp() in the Buf object, this function | //| performs mass elimination in the quotient graph. | //| INPUT PARAMETERS: | //| Buf - properly initialized buffer object | //| P - pivot column | //| K - number of already eliminated columns (P-th is not | //| counted) | //| Tau - variables with degrees higher than Tau will be | //| classified as quasidense | //| OUTPUT PARAMETERS: | //| Buf.m_SetA - Lp is eliminated from setA | //| Buf.m_SetE - Ep is eliminated from setE, P is added | //| approxD - updated | //| Buf.m_SetQSuperCand - contains candidates for quasidense | //| status assignment | //+------------------------------------------------------------------+ void CAmdOrdering::AmdMasselimination(CAmdBuffer &Buf,int p, int k,int tau) { //--- create variables int lidx=0; int lpi=0; int cntsuperi=0; int cntq=0; int cntainoti=0; int cntainotqi=0; int cntlpnoti=0; int cntlpnotqi=0; int cc=0; int j=0; int e=0; int we=0; int cnttoclean=0; int idxbegin=0; int idxend=0; int jj=0; int bnd0=0; int bnd1=0; int bnd2=0; int d=0; int n=Buf.m_N; CApServ::IVectorSetLengthAtLeast(Buf.m_Tmp0,n); cnttoclean=0; for(lidx=0; lidx0) cntainotqi=KNsCountNot(Buf.m_SetA,lpi,Buf.m_SetQ); else cntainotqi=cntainoti; cntlpnoti=NsCount(Buf.m_Lp)-cntsuperi; cntlpnotqi=NsCount(Buf.m_SetRP)-cntsuperi; cc=0; KNsDirectAccess(Buf.m_SetE,lpi,idxbegin,idxend); for(jj=idxbegin; jj0) e=MtxCountColumnNot(Buf.m_MtxL,j,Buf.m_SetQ); else e=MtxCountColumn(Buf.m_MtxL,j); } cc=cc+e; } bnd0=n-k-NsCount(Buf.m_SetP); bnd1=VtxGetApprox(Buf.m_VertexDegrees,lpi)+cntlpnoti; bnd2=cntq+cntainotqi+cntlpnotqi+cc; d=MathMin(bnd0,MathMin(bnd1,bnd2)); VtxUpdateApproximateDegree(Buf.m_VertexDegrees,lpi,d); if(tau>0 && d+cntsuperi>tau) NsAddElement(Buf.m_SetQSuperCand,lpi); if(Buf.m_CheckExactDegrees) { NsClear(Buf.m_ExactDegreeTmp0); KNsStartEnumeration(Buf.m_SetE,lpi); while(KNsEnumerate(Buf.m_SetE,j)) MtxAddColumnTo(Buf.m_MtxL,j,Buf.m_ExactDegreeTmp0); VtxUpdateExactDegree(Buf.m_VertexDegrees,lpi,cntainoti+NsCountNotKth(Buf.m_ExactDegreeTmp0,Buf.m_SetSuper,lpi)); //--- check if(!CAp::Assert((KNsCountKth(Buf.m_SetE,lpi)>2 || cntq>0) || VtxGetApprox(Buf.m_VertexDegrees,lpi)==VtxGetExact(Buf.m_VertexDegrees,lpi), __FUNCTION__+": integrity check 7206 failed")) return; //--- check if(!CAp::Assert(VtxGetApprox(Buf.m_VertexDegrees,lpi)>=VtxGetExact(Buf.m_VertexDegrees,lpi),__FUNCTION__+": integrity check 8206 failed")) return; } } } for(j=0; j=2) { cnt=0; KNsStartEnumeration(Buf.m_HashBuckets,hashi); while(KNsEnumerate(Buf.m_HashBuckets,i)) { Buf.m_SNCandidates.Set(cnt,i); cnt++; } for(i=cnt-1; i>=0; i--) { for(j=cnt-1; j>=i+1; j--) { if(Buf.m_IsSuperNode[Buf.m_SNCandidates[i]] && Buf.m_IsSuperNode[Buf.m_SNCandidates[j]]) { lpi=Buf.m_SNCandidates[i]; lpj=Buf.m_SNCandidates[j]; NsClear(Buf.m_AdjI); NsClear(Buf.m_AdjJ); NsAddKth(Buf.m_AdjI,Buf.m_SetA,lpi); NsAddKth(Buf.m_AdjJ,Buf.m_SetA,lpj); NsAddKth(Buf.m_AdjI,Buf.m_SetE,lpi); NsAddKth(Buf.m_AdjJ,Buf.m_SetE,lpj); NsAddElement(Buf.m_AdjI,lpi); NsAddElement(Buf.m_AdjI,lpj); NsAddElement(Buf.m_AdjJ,lpi); NsAddElement(Buf.m_AdjJ,lpj); if(!NsEqual(Buf.m_AdjI,Buf.m_AdjJ)) continue; if(Buf.m_ExtendedDebug) { //--- check if(!CAp::Assert(VtxGetApprox(Buf.m_VertexDegrees,lpi)>=1 && (!Buf.m_CheckExactDegrees || VtxGetExact(Buf.m_VertexDegrees,lpi)>=1), __FUNCTION__+": integrity check &GBFF1 failed")) return; //--- check if(!CAp::Assert(VtxGetApprox(Buf.m_VertexDegrees,lpj)>=1 && (!Buf.m_CheckExactDegrees || VtxGetExact(Buf.m_VertexDegrees,lpj)>=1), __FUNCTION__+": integrity check &GBFF2 failed")) return; //--- check if(!CAp::Assert(KNsCountAndKth(Buf.m_SetSuper,lpi,Buf.m_SetSuper,lpj)==0, __FUNCTION__+": integrity check &GBFF3 failed")) return; } nj=KNsCountKth(Buf.m_SetSuper,lpj); KNsAddKthDistinct(Buf.m_SetSuper,lpi,Buf.m_SetSuper,lpj); KNsClearKthReclaim(Buf.m_SetSuper,lpj); KNsClearKthReclaim(Buf.m_SetA,lpj); KNsClearKthReclaim(Buf.m_SetE,lpj); Buf.m_IsSuperNode[lpj]=false; VtxRemoveVertex(Buf.m_VertexDegrees,lpj); VtxUpdateApproximateDegree(Buf.m_VertexDegrees,lpi,VtxGetApprox(Buf.m_VertexDegrees,lpi)-nj); if(Buf.m_CheckExactDegrees) VtxUpdateExactDegree(Buf.m_VertexDegrees,lpi,VtxGetExact(Buf.m_VertexDegrees,lpi)-nj); } } } } KNsClearKthNoReclaim(Buf.m_HashBuckets,hashi); } NsClear(Buf.m_NonEmptyBuckets); } //+------------------------------------------------------------------+ //| Assign quasidense status to proposed supervars, perform all the | //| necessary cleanup (remove vertices, etc) | //| INPUT PARAMETERS: | //| Buf - properly initialized buffer object | //| Cand - supervariables to be moved to quasidense status | //| P - current pivot element (used for integrity checks) | //| or -1, when this function is used for initial | //| status assignment. | //| OUTPUT PARAMETERS: | //| Buf - variables belonging to supervariables in cand are | //| added to SetQ. Supervariables are removed from all | //| lists | //+------------------------------------------------------------------+ void CAmdOrdering::AmdMoveToQuasiDense(CAmdBuffer &Buf, CAmdNSet &Cand, int p) { //--- create variables int i=0; int j=0; NsStartEnumeration(Cand); while(NsEnumerate(Cand,j)) { //--- check if(!CAp::Assert(j!=p,__FUNCTION__+": integrity check 9464 failed")) return; //--- check if(!CAp::Assert(Buf.m_IsSuperNode[j],__FUNCTION__+": integrity check 6284 failed")) return; //--- check if(!CAp::Assert(!Buf.m_IsEliminated[j],__FUNCTION__+": integrity check 3858 failed")) return; KNsStartEnumeration(Buf.m_SetSuper,j); while(KNsEnumerate(Buf.m_SetSuper,i)) NsAddElement(Buf.m_SetQ,i); KNsClearKthReclaim(Buf.m_SetA,j); KNsClearKthReclaim(Buf.m_SetE,j); Buf.m_IsSuperNode[j]=false; VtxRemoveVertex(Buf.m_VertexDegrees,j); } } //+------------------------------------------------------------------+ //| Analysis sparse Cholesky: elimination tree, factorization costs, | //| etc. | //+------------------------------------------------------------------+ class CSpChol { public: //--- constants static const int m_MaxSupernode; static const double m_MaxMergeinEfficiency; static const int m_SmallFakesTolerance; static const int m_MaxFastKernel; static const bool m_RelaxedSupernodes; //--- methods static bool SpSymmAnalyze(CSparseMatrix &A,CRowInt &Priorities,int FactType,int PermType,CSpCholAnalysis &Analysis); static void SpSymmSetModificationStrategy(CSpCholAnalysis &Analysis,int ModStrategy,double P0,double P1,double P2,double P3); static void SpSymmReload(CSpCholAnalysis &Analysis,CSparseMatrix &A); static void SpSymmReloadDiagonal(CSpCholAnalysis &Analysis,CRowDouble &d); static bool SpSymmFactorize(CSpCholAnalysis &Analysis); static void SpSymmExtract(CSpCholAnalysis &Analysis,CSparseMatrix &A,CRowDouble &d,CRowInt &p); static void SpSymmSolve(CSpCholAnalysis &Analysis,CRowDouble &b); static void SpSymmDiagErr(CSpCholAnalysis &Analysis,double &SumSq,double &ErrSq); private: static bool UpdateKernel4444(CRowDouble &rowstorage,int offss,int sheight,int offsu,int uheight,CRowDouble &diagd,int offsd,CRowInt &raw2smap,CRowInt &superrowidx,int urbase); static bool UpdateKernelABC4(CRowDouble &rowstorage,int offss,int twidth,int offsu,int uheight,int urank,int urowstride,int uwidth,CRowDouble &diagd,int offsd,CRowInt &raw2smap,CRowInt &superrowidx,int urbase); static void GenerateDbgPermutation(CSparseMatrix &A,int n,CRowInt &Perm,CRowInt &InvPerm); static void BuildUnorderedeTree(CSparseMatrix &A,int n,CRowInt &Parent,CRowInt &tAbove); static void FromParentToChildren(CRowInt &Parent,int n,CRowInt &ChildrenR,CRowInt &ChildrenI,CRowInt &tTmp0); static void BuildOrderedeTree(CSparseMatrix &A,int n,CRowInt &Parent,CRowInt &SupernodalPermutation,CRowInt &InvSupernodalPermutation,CRowInt &tRawParentOfRawNode,CRowInt &tRawParentOfReorderedNode,CRowInt &tTmp,bool &tFlagArray[]); static void CreateSupernodalStructure(CSparseMatrix &at,CRowInt &Parent,int n,CSpCholAnalysis &Analysis,CRowInt &Node2Supernode,CRowInt &tChildrenR,CRowInt &tChildrenI,CRowInt &tParentNodeOfSupernode,CRowInt &tFakeNonZeros,CRowInt &tTmp0,bool &tFlagArray[]); static void AnalyzeSupernodalDependencies(CSpCholAnalysis &Analysis,CSparseMatrix &RawA,CRowInt &Node2Supernode,int n,CRowInt &tTmp0,CRowInt &tTmp1,bool &tFlagArray[]); static void LoadMatrix(CSpCholAnalysis &Analysis,CSparseMatrix &at); static void ExtractMatrix(CSpCholAnalysis &Analysis,CRowInt &Offsets,CRowInt &Strides,CRowDouble &RowStorage,CRowDouble &DiagD,int N,CSparseMatrix &A,CRowDouble &D,CRowInt &P,CRowInt &TmpP); static void PartialCholeskyPattern(CSparseMatrix &A,int Head,int Tail,CSparseMatrix &ATail,CRowInt &tmpParent,CRowInt &tmpChildrenR,CRowInt &tmpChildrenI,CRowInt &Tmp1,bool &FlagArray[],CSparseMatrix &tmpBottomT,CSparseMatrix &tmpUpdateT,CSparseMatrix &tmpUpdate,CSparseMatrix &tmpNewTailT); static void TopologicalPermutation(CSparseMatrix&A,CRowInt &P,CSparseMatrix &B); static int ComputeNonzeroPattern(CSparseMatrix &wrkAT,int ColumnIdx,int N,CRowInt &SuperRowRIdx,CRowInt &SuperRowIdx,int NSuper,CRowInt &ChildrenNodesR,CRowInt &ChildrenNodesI,CRowInt &Node2Supernode,bool &TrueArray[],CRowInt &Tmp0); static int UpdateSupernode(CSpCholAnalysis &Analysis,int SIdx,int Cols0,int Cols1,int OffsS,CRowInt &Raw2Smap,int UIdx,int WrkRow,CRowDouble &DiagD,int OffsD); static bool FactorizeSupernode(CSpCholAnalysis &Analysis,int SIdx); static int RecommendedStrideFor(int RowSize); static int AlignPositionInArray(int Offs); static bool UpdateKernelRank1(CRowDouble &RowStorage,int OffsS,int tWidth,int tRowStride,int OffsU,int UHeight,int UWidth,CRowDouble &DiagD,int OffsD,CRowInt &Raw2Smap,CRowInt &SuperRowIdx,int URBase); static bool UpdateKernelRank2(CRowDouble &RowStorage,int OffsS,int tWidth,int tRowStride,int OffsU,int UHeight,int UWidth,CRowDouble &DiagD,int OffsD,CRowInt &Raw2Smap,CRowInt &SuperRowIdx,int URBase); static void SlowDebugChecks(CSparseMatrix &A,CRowInt &FillinPerm,int N,int Tail,CSparseMatrix &ReferenceTailA); static bool DbgMatrixCholesky2(CMatrixDouble &AAA,int Offs,int N,bool IsUpper); }; //+------------------------------------------------------------------+ //| Constants | //+------------------------------------------------------------------+ const int CSpChol::m_MaxSupernode=4; const double CSpChol::m_MaxMergeinEfficiency=0.25; const int CSpChol::m_SmallFakesTolerance=2; const int CSpChol::m_MaxFastKernel=4; const bool CSpChol::m_RelaxedSupernodes=true; //+------------------------------------------------------------------+ //| Symbolic phase of Cholesky decomposition. | //| Performs preliminary analysis of Cholesky/LDLT factorization. The| //| latter is computed with strictly diagonal D (no Bunch-Kauffman | //| pivoting). | //| The analysis object produced by this function will be used later | //| to guide actual decomposition. | //| Depending on settings specified during factorization, may produce| //| vanilla Cholesky or L*D*LT decomposition (with strictly diagonal | //| D), without permutation or with permutation P (being either | //| topological ordering or sparsity preserving ordering). | //| Thus, A is represented as either L*LT or L*D*LT or P*L*LT*PT or | //| P*L*D*LT*PT. | //| NOTE: L*D*LT family of factorization may be used to factorize | //| indefinite matrices. However, numerical stability is | //| guaranteed ONLY for a class of quasi-definite matrices. | //| INPUT PARAMETERS: | //| A - sparse square matrix in CRS format, with LOWER | //| triangle being used to store the matrix. | //| Priorities - array[N], optional priorities: | //| * ignored for PermType<>3 and PermType<>-3 | //| (not referenced at all) | //| * for PermType=3 or PermType=-3 this array | //| stores nonnegative column elimination | //| priorities. Columns with lower priorities are | //| eliminated first. At least max(Priorities[])+1| //| internal AMD rounds will be performed, so | //| avoid specifying too large values here. | //| Ideally, 0<=Priorities[I]<5. | //| FactType - factorization type: | //| * 0 for traditional Cholesky | //| * 1 for LDLT decomposition with strictly | //| diagonal D | //| PermType - permutation type: | //| *-3 for debug improved AMD (a sequence of | //| decreasing Tail sizes is generated, ~logN in | //| total, even if ordering can be done with just | //| one round of AMD). This ordering is used to | //| test correctness of multiple AMD rounds. | //| *-2 for column count ordering (NOT RECOMMENDED!)| //| *-1 for absence of permutation | //| * 0 for best permutation available | //| * 1 for supernodal ordering (improves locality | //| and performance, but does NOT change fill-in | //| pattern) | //| * 2 for supernodal AMD ordering (improves | //| fill-in) | //| * 3 for improved AMD (approximate minimum | //| degree) ordering with better handling of | //| matrices with dense rows/columns and ability | //| to perform priority ordering | //| Analysis - can be uninitialized instance, or previous analysis| //| results. Previously allocated memory is reused as | //| much as possible. | //| Buf - buffer; may be completely uninitialized, or one | //| remained from previous calls (including ones with | //| completely different matrices). Previously | //| allocated temporary space will be reused as much as| //| possible. | //| OUTPUT PARAMETERS: | //| Analysis - symbolic analysis of the matrix structure which | //| will be used later to guide numerical factorization| //| The numerical values are stored internally in the | //| structure, but you have to run factorization phase | //| explicitly with SPSymmFactorize(). You can also | //| reload another matrix with same sparsity pattern | //| with SPSymmReload() or rewrite its diagonal with | //| SPSymmReloadDiagonal(). | //| This function fails if and only if the matrix A is symbolically | //| degenerate, i.e. has diagonal element which is exactly zero. In | //| such case False is returned. | //| NOTE: defining 'SCHOLESKY' Trace tag will activate tracing. | //| defining 'SCHOLESKY.SS' Trace tag will activate detailed | //| tracing of the supernodal structure. | //| NOTE: defining 'DEBUG.SLOW' Trace tag will activate extra-slow | //| (roughly N^3 ops) integrity checks, in addition to cheap | //| O(1) ones. | //+------------------------------------------------------------------+ bool CSpChol::SpSymmAnalyze(CSparseMatrix &A, CRowInt &Priorities, int FactType, int PermType, CSpCholAnalysis &Analysis) { //--- create variables bool result=true; int n=0; int m=0; int i=0; int j=0; int jj=0; int j0=0; int j1=0; int k=0; int range0=0; int range1=0; int newrange0=0; int eligiblecnt=0; bool permready; //--- check if(!CAp::Assert(CSparse::SparseIsCRS(A),__FUNCTION__+": A is not stored in CRS format")) return(false); if(!CAp::Assert(CSparse::SparseGetNRows(A)==CSparse::SparseGetNCols(A),__FUNCTION__+": non-square A")) return(false); if(!CAp::Assert(FactType==0 || FactType==1,__FUNCTION__+": unexpected FactType")) return(false); if(!CAp::Assert((PermType>=-3 && PermType<=3),__FUNCTION__+": unexpected PermType")) return(false); n=CSparse::SparseGetNRows(A); if(PermType==-3 || PermType==3) { //--- check if(!CAp::Assert(CAp::Len(Priorities)>=n,__FUNCTION__+": length(Priorities)=k && Analysis.m_Tmp0[i]<2*k) j++; CAp::Trace(StringFormat("* [%d..%d) elements: %d rows\n",k,2 * k,j)); k=k*2; } } //--- Initial integrity check - diagonal MUST be symbolically nonzero for(i=0; i the matrix diagonal is symbolically zero,stopping"); return(false); } } //--- What type of permutation do we have? if(Analysis.m_IsTopologicalOrdering) { //--- check if(!CAp::Assert(PermType==-1 || PermType==1,__FUNCTION__+": integrity check failed (ihebd)")) return(false); //--- Build topologically ordered elimination tree BuildOrderedeTree(A,n,Analysis.m_TmpParent,Analysis.m_SuperPerm,Analysis.m_InvSuperPerm, Analysis.m_Tmp0,Analysis.m_Tmp1,Analysis.m_Tmp2,Analysis.m_FlagArray); CApServ::IVectorSetLengthAtLeast(Analysis.m_FillinPerm,n); CApServ::IVectorSetLengthAtLeast(Analysis.m_InvFillinPerm,n); CApServ::IVectorSetLengthAtLeast(Analysis.m_EffectivePerm,n); CApServ::IVectorSetLengthAtLeast(Analysis.m_InvEffectivePerm,n); for(i=0; i=n,__FUNCTION__+": integrity check failed (4653)")) return(false); //--- Perform iterative AMD, with nearly-dense columns being postponed to be handled later. //--- The current (residual) matrix A is divided into two parts: Head, with its columns being //--- properly ordered, and Tail, with its columns being reordered at the next iteration. //--- After each partial AMD we compute sparsity pattern of the Tail, set it as the new residual //--- and repeat iteration. CAblasF::IAllocV(n,Analysis.m_FillinPerm); CAblasF::IAllocV(n,Analysis.m_InvFillinPerm); CAblasF::IAllocV(n,Analysis.m_TmpPerm); CAblasF::IAllocV(n,Analysis.m_InvTmpPerm); for(i=0; i=range0 && j multiround AMD,column_range=[%d,%d] (%d out of %d),%5.1f%% eligible\n",range0,range1,range1 - range0,n,(double)(100 * eligiblecnt) / (double)m)); newrange0=range0+CAmdOrdering::GenerateAmdPermutationX(Analysis.m_TmpA,Analysis.m_Eligible,range1-range0,Analysis.m_TmpPerm,Analysis.m_InvTmpPerm,1,Analysis.m_AmdTmp); //Analysis.Trace(); if(PermType==-3) { //--- Special debug ordering in order to test correctness of multiple AMD rounds newrange0=MathMin(newrange0,range0+m/2+1); } //Analysis.Trace(); Analysis.m_CurPriorities-=1; //--- If there were columns that both eligible and sparse enough, //--- apply permutation and recompute trail. if(newrange0>range0) { //--- Apply permutation TmpPerm[] to the Tail of the permutation FillInPerm[] for(i=0; i0) { if(!CAp::Assert((Analysis.m_TmpA.m_M==m && Analysis.m_TmpA.m_N==m) && Analysis.m_TmpA.m_NInitialized==Analysis.m_TmpA.m_RIdx[m],__FUNCTION__+": integrity check failed (0572)")) return(false); CAblasF::ISetAllocV(m,1,Analysis.m_Tmp0); for(i=0; i0) { //--- K dense rows are moved to the end if(k multiround AMD,column_range=[%d,%d],stopped\n",range0,range1)); //Analysis.Trace(); permready=true; } //--- check if(!CAp::Assert(permready,__FUNCTION__+": integrity check failed (pp4td)")) return(false); //--- Apply permutation to the matrix, perform analysis on the initially reordered matrix //--- (we may need one more reordering, now topological one, due to supernodal analysis). //--- Build topologically ordered elimination tree CSparse::SparseSymmPermTblBuf(A,false,Analysis.m_FillinPerm,Analysis.m_TmpA); //Analysis.Trace(); BuildOrderedeTree(Analysis.m_TmpA,n,Analysis.m_TmpParent,Analysis.m_SuperPerm,Analysis.m_InvSuperPerm,Analysis.m_Tmp0, Analysis.m_Tmp1,Analysis.m_Tmp2,Analysis.m_FlagArray); //Analysis.Trace(); CApServ::IVectorSetLengthAtLeast(Analysis.m_EffectivePerm,n); CApServ::IVectorSetLengthAtLeast(Analysis.m_InvEffectivePerm,n); for(i=0; i=0.0,__FUNCTION__+": bad P0")) return; //--- check if(!CAp::Assert(CMath::IsFinite(P1),__FUNCTION__+": bad P1")) return; //--- check if(!CAp::Assert(CMath::IsFinite(P2),__FUNCTION__+": bad P2")) return; //--- check if(!CAp::Assert(CMath::IsFinite(P3),__FUNCTION__+": bad P3")) return; Analysis.m_ModType=ModStrategy; Analysis.m_ModParam0=P0; Analysis.m_ModParam1=P1; Analysis.m_ModParam2=P2; Analysis.m_ModParam3=P3; } //+------------------------------------------------------------------+ //| Updates symmetric matrix internally stored in previously | //| initialized Analysis object. | //| You can use this function to perform multiple factorizations with| //| same sparsity patterns: perform symbolic analysis once with | //| SPSymmAnalyze(), then update internal matrix with SPSymmReload() | //| and call SPSymmFactorize(). | //| INPUT PARAMETERS: | //| Analysis - symbolic analysis of the matrix structure | //| A - sparse square matrix in CRS format with LOWER | //| triangle being used to store the matrix. The matrix| //| MUST have sparsity pattern exactly same as one used| //| to initialize the Analysis object. | //| The algorithm will fail in an unpredictable way ifsomething | //| different was passed. | //| OUTPUT PARAMETERS: | //| Analysis - symbolic analysis of the matrix structure which | //| will be used later to guide numerical factorization| //| The numerical values are stored internally in the | //| structure, but you have to run factorization phase | //| explicitly with SPSymmAnalyze(). You can also | //| reload another matrix with same sparsity pattern | //| with SpSymmReload(). | //+------------------------------------------------------------------+ void CSpChol::SpSymmReload(CSpCholAnalysis &Analysis, CSparseMatrix &A) { //--- check if(!CAp::Assert(CSparse::SparseIsCRS(A),__FUNCTION__+": A is not stored in CRS format")) return; //--- check if(!CAp::Assert(CSparse::SparseGetNRows(A)==CSparse::SparseGetNCols(A),__FUNCTION__+": non-square A")) return; if(Analysis.m_IsTopologicalOrdering) { //--- Topological (fill-in preserving) ordering is used, we can copy //--- A directly into WrkAT using joint permute+transpose TopologicalPermutation(A,Analysis.m_EffectivePerm,Analysis.m_TmpAt); LoadMatrix(Analysis,Analysis.m_TmpAt); } else { //--- Non-topological permutation; first we perform generic symmetric //--- permutation, then transpose result CSparse::SparseSymmPermTblBuf(A,false,Analysis.m_EffectivePerm,Analysis.m_TmpA); CSparse::SparseCopyToCRSBuf(Analysis.m_TmpA,Analysis.m_TmpAt); LoadMatrix(Analysis,Analysis.m_TmpAt); } } //+------------------------------------------------------------------+ //| Updates diagonal of the symmetric matrix internally stored in the| //| previously initialized Analysis object. | //| When only diagonal of the matrix has changed, this function is | //| more efficient than SpSymmReload() that has to perform costly | //| permutation of the entire matrix. | //| You can use this function to perform multiple factorizations with| //| same off - diagonal elements: perform symbolic analysis once with| //| SpSymmAnalyze(), then update diagonal with SpSymmReloadDiagonal()| //| and call SpSymmFactorize(). | //| INPUT PARAMETERS: | //| Analysis - symbolic analysis of the matrix structure | //| D - array[N], diagonal factor | //| OUTPUT PARAMETERS: | //| Analysis - symbolic analysis of the matrix structure which | //| will be used later to guide numerical factorization| //| The numerical values are stored internally in the | //| structure, but you have to run factorization phase | //| explicitly with SpSymmAnalyze(). You can also | //| reload another matrix with same sparsity pattern | //| with SpSymmReload(). | //+------------------------------------------------------------------+ void CSpChol::SpSymmReloadDiagonal(CSpCholAnalysis &Analysis, CRowDouble &d) { //--- create variables int SIdx=0; int Cols0=0; int Cols1=0; int OffsS=0; int sstride=0; //--- check if(!CAp::Assert(CAp::Len(d)>=Analysis.m_N,__FUNCTION__+": length(D)= I). | //| If no permutation was requested during analysis | //| phase, still returned but filled with unit elements| //+------------------------------------------------------------------+ void CSpChol::SpSymmExtract(CSpCholAnalysis &Analysis, CSparseMatrix &A, CRowDouble &d, CRowInt &p) { ExtractMatrix(Analysis,Analysis.m_RowOffSets,Analysis.m_RowStrides,Analysis.m_OutputStorage,Analysis.m_DiagD,Analysis.m_N, A,d,p,Analysis.m_Tmp0); } //+------------------------------------------------------------------+ //| Solve linear system A*x = b, using internally stored | //| factorization of the matrix A. | //| Works faster than extracting the matrix and solving with | //| SparseTRSV() due to SIMD - friendly supernodal data structures | //| being used. | //| INPUT PARAMETERS: | //| Analysis - prior factorization performed on some sparse matrix| //| B - array[N], right - hand side | //| OUTPUT PARAMETERS: | //| B - overwritten by X | //+------------------------------------------------------------------+ void CSpChol::SpSymmSolve(CSpCholAnalysis &Analysis, CRowDouble &b) { //--- create variables int i=0; int j=0; int k=0; double v=0; int baseoffs=0; int Cols0=0; int Cols1=0; int OffsS=0; int sstride=0; int SIdx=0; int blocksize=0; int rbase=0; int offdiagsize=0; int n=Analysis.m_N; int simdwidth=1; CAblasF::RSetAllocV(n,0.0,Analysis.m_TmpX); //--- Handle left-hand side permutation, convert data to internal SIMD-friendly format CAblasF::RSetAllocV(n*simdwidth,0.0,Analysis.m_SimdBuf); for(i=0; i=0; SIdx--) { Cols0=Analysis.m_SuperColRange[SIdx]; Cols1=Analysis.m_SuperColRange[SIdx+1]; blocksize=Cols1-Cols0; OffsS=Analysis.m_RowOffSets[SIdx]; sstride=Analysis.m_RowStrides[SIdx]; rbase=Analysis.m_SuperRowRIdx[SIdx]; offdiagsize=Analysis.m_SuperRowRIdx[SIdx+1]-rbase; //--- Subtract already computed variables for(k=0; k=0; i--) { baseoffs=OffsS+i*sstride; v=Analysis.m_TmpX[Cols0+i]/Analysis.m_OutputStorage[baseoffs+i]; for(j=0; jn,__FUNCTION__+": input buffer Parent is too short")) return; if(!CAp::Assert(CAp::Len(tAbove)>n,__FUNCTION__+": input buffer tAbove is too short")) return; //--- Build elimination tree using Liu's algorithm with path compression for(int j=0; jn,__FUNCTION__+": input buffer tTmp0 is too short")) return; if(!CAp::Assert(CAp::Len(ChildrenR)>n,__FUNCTION__+": input buffer ChildrenR is too short")) return; if(!CAp::Assert(CAp::Len(ChildrenI)>n,__FUNCTION__+": input buffer ChildrenI is too short")) return; //--- Convert etree from per-column parent array to per-column children list CAblasF::ISetV(n,0,tTmp0); for(i=0; i=0) tTmp0.Set(nodeidx,tTmp0[nodeidx]+1); } ChildrenR.Set(0,0); for(i=0; i=0) { ChildrenI.Set(ChildrenR[k]+tTmp0[k],i); tTmp0.Set(k,tTmp0[k]+1); } } } //+------------------------------------------------------------------+ //| This function builds elimination tree and reorders it according | //| to the topological post - ordering. | //| INPUT PARAMETERS: | //| A - lower triangular sparse matrix in CRS format | //| N - problem size | //| tRawParentOfRawNode, | //| tRawParentOfReorderedNode, | //| tTmp, | //| tFlagArray - preallocated temporary arrays, length at least | //| N + 1, no meaningful output is provided in these| //| variables | //| OUTPUT PARAMETERS: | //| Parent - array[N], Parent[I] contains index of parent of | //| I-th column(after topological reordering). -1 is| //| used to denote column with no parents. | //| SupernodalPermutation - array[N], maps original indexes I to | //| permuted indexes | //| InvSupernodalPermutation - array[N], maps permuted indexes I | //| to original indexes | //+------------------------------------------------------------------+ void CSpChol::BuildOrderedeTree(CSparseMatrix &A,int n,CRowInt &Parent, CRowInt &SupernodalPermutation, CRowInt &InvSupernodalPermutation, CRowInt &tRawParentOfRawNode, CRowInt &tRawParentOfReorderedNode, CRowInt &tTmp,bool &tFlagArray[]) { //--- create variables int i=0; int k=0; int SIdx=0; int unprocessedchildrencnt=0; //--- check if(!CAp::Assert(CAp::Len(tRawParentOfRawNode)>n,__FUNCTION__+": input buffer tRawParentOfRawNode is too short")) return; if(!CAp::Assert(CAp::Len(tTmp)>n,__FUNCTION__+": input buffer tTmp is too short")) return; if(!CAp::Assert(CAp::Len(tRawParentOfReorderedNode)>n,__FUNCTION__+": input buffer tRawParentOfReorderedNode is too short")) return; if(!CAp::Assert(CAp::Len(tFlagArray)>=n+1,__FUNCTION__+": input buffer tFlagArray is too short")) return; //--- Avoid spurious compiler warnings //--- Build elimination tree with original column order BuildUnorderedeTree(A,n,tRawParentOfRawNode,tTmp); //--- Compute topological ordering of the elimination tree, produce: //--- * direct and inverse permutations //--- * reordered etree stored in Parent[] CAblasF::ISetAllocV(n,-1,InvSupernodalPermutation); CAblasF::ISetAllocV(n,-1,SupernodalPermutation); CAblasF::ISetAllocV(n,-1,Parent); CAblasF::ISetV(n,-1,tRawParentOfReorderedNode); CAblasF::ISetV(n,0,tTmp); for(i=0; i=0) tTmp.Set(k,tTmp[k]+1); } CAblasF::BSetV(n,true,tFlagArray); SIdx=0; for(i=0; i=0) { unprocessedchildrencnt=tTmp[k]-1; tTmp.Set(k,unprocessedchildrencnt); } SIdx=SIdx+1; //--- Add parents (as long as parent has no unprocessed children) while(k>=0 && unprocessedchildrencnt==0) { SupernodalPermutation.Set(k,SIdx); InvSupernodalPermutation.Set(SIdx,k); tFlagArray[k]=false; k=tRawParentOfRawNode[k]; tRawParentOfReorderedNode.Set(SIdx,k); if(k>=0) { unprocessedchildrencnt=tTmp[k]-1; tTmp.Set(k,unprocessedchildrencnt); } SIdx=SIdx+1; } } } for(i=0; i=0) Parent.Set(i,SupernodalPermutation[k]); } } //+------------------------------------------------------------------+ //| This function analyzes postordered elimination tree and creates | //| supernodal structure in Analysis object. | //| INPUT PARAMETERS: | //| AT - upper triangular CRS matrix, transpose and | //| reordering of the original input matrix A | //| Parent - array[N], supernodal etree | //| N - problem size | //| tChildrenR, | //| tChildrenI, | //| tParentNodeOfSupernode, | //| tNode2Supernode, | //| tTmp0, | //| tFlagArray - temporary arrays, length at least N + 1, simply | //| provide preallocated place. | //| OUTPUT PARAMETERS: | //| Analysis - following fields are initialized: | //| * Analysis.NSuper | //| * Analysis.SuperColRange | //| * Analysis.SuperRowRIdx | //| * Analysis.SuperRowIdx | //| * Analysis.ParentSupernode | //| * Analysis.OutRowCounts | //| other fields are ignored and not changed. | //| Node2Supernode - array[N] that maps node indexes to supernode | //| indexes | //+------------------------------------------------------------------+ void CSpChol::CreateSupernodalStructure(CSparseMatrix &at,CRowInt &Parent, int n,CSpCholAnalysis &Analysis, CRowInt &Node2Supernode, CRowInt &tChildrenR, CRowInt &tChildrenI, CRowInt &tParentNodeOfSupernode, CRowInt &tFakeNonZeros, CRowInt &tTmp0, bool &tFlagArray[]) { //--- create variables int NSuper=0; int i=0; int j=0; int k=0; int sidx=0; int i0=0; int ii=0; int ColumnIdx=0; int nodeidx=0; int rfirst=0; int rlast=0; int cols0=0; int cols1=0; int blocksize=0; bool createsupernode; int colcount=0; int offdiagcnt=0; int childcolcount=0; int childoffdiagcnt=0; int fakezerosinnewsupernode=0; double mergeinefficiency=0; bool hastheonlychild; //--- check if(!CAp::Assert(CAp::Len(tTmp0)>n,__FUNCTION__+": input buffer tTmp0 is too short")) return; if(!CAp::Assert(CAp::Len(tChildrenR)>n,__FUNCTION__+": input buffer ChildrenR is too short")) return; if(!CAp::Assert(CAp::Len(tChildrenI)>n,__FUNCTION__+": input buffer ChildrenI is too short")) return; if(!CAp::Assert(CAp::Len(tParentNodeOfSupernode)>n,__FUNCTION__+": input buffer tParentNodeOfSupernode is too short")) return; if(!CAp::Assert(CAp::Len(tFakeNonZeros)>n,__FUNCTION__+": input buffer tFakeNonzeros is too short")) return; if(!CAp::Assert(CAp::Len(tFlagArray)>n,__FUNCTION__+": input buffer tFlagArray is too short")) return; //--- Trace if(Analysis.m_DotraceSupernodalStructure) CAp::Trace("=== GENERATING SUPERNODAL STRUCTURE ================================================================\n"); //--- Convert etree from per-column parent array to per-column children list FromParentToChildren(Parent,n,tChildrenR,tChildrenI,tTmp0); //--- Analyze supernodal structure: //--- * determine children count for each node //--- * combine chains of children into supernodes //--- * generate direct and inverse supernodal (topological) permutations //--- * generate column structure of supernodes (after supernodal permutation) CAblasF::ISetAllocV(n,-1,Node2Supernode); CApServ::IVectorSetLengthAtLeast(Analysis.m_SuperColRange,n+1); CApServ::IVectorSetLengthAtLeast(Analysis.m_SuperRowRIdx,n+1); CAblasF::ISetV(n,n+1,tParentNodeOfSupernode); CAblasF::BSetV(n,true,tFlagArray); NSuper=0; Analysis.m_SuperColRange.Set(0,0); Analysis.m_SuperRowRIdx.Set(0,0); while(Analysis.m_SuperColRange[NSuper] incoming column %d\n",ColumnIdx)); CAp::Trace(StringFormat("offdiagnnz = %d\n",rlast - rfirst)); CAp::Trace("children = [ "); for(i=tChildrenR[ColumnIdx]; i=2 && tParentNodeOfSupernode[NSuper-2]==ColumnIdx) { childcolcount=Analysis.m_SuperColRange[NSuper-1]-Analysis.m_SuperColRange[NSuper-2]; childoffdiagcnt=Analysis.m_SuperRowRIdx[NSuper-1]-Analysis.m_SuperRowRIdx[NSuper-2]; hastheonlychild=tChildrenR[ColumnIdx+1]-tChildrenR[ColumnIdx]==1; if((hastheonlychild || m_RelaxedSupernodes) && colcount+childcolcount<=m_MaxSupernode) { i=colcount+childcolcount; k=i*(i+1)/2+offdiagcnt*i; fakezerosinnewsupernode=tFakeNonZeros[NSuper-2]+tFakeNonZeros[NSuper-1]+(offdiagcnt-(childoffdiagcnt-1))*childcolcount; mergeinefficiency=(double)fakezerosinnewsupernode/(double)k; if(colcount+childcolcount==2 && fakezerosinnewsupernode<=m_SmallFakesTolerance) createsupernode=true; if(mergeinefficiency<=m_MaxMergeinEfficiency) createsupernode=true; } } //--- Create supernode if needed if(createsupernode) { //--- Create supernode from nodes NSuper-2 and NSuper-1. //--- Because these nodes are in the child-parent relation, we can simply //--- copy nonzero pattern from NSuper-1. //--- check if(!CAp::Assert(tParentNodeOfSupernode[NSuper-2]==ColumnIdx,__FUNCTION__+": integrity check 9472 failed")) return; i0=Analysis.m_SuperRowRIdx[NSuper-1]; ii=Analysis.m_SuperRowRIdx[NSuper]-Analysis.m_SuperRowRIdx[NSuper-1]; rfirst=Analysis.m_SuperRowRIdx[NSuper-2]; rlast=rfirst+ii; for(i=0; i<=ii-1; i++) Analysis.m_SuperRowIdx.Set(rfirst+i,Analysis.m_SuperRowIdx[i0+i]); Analysis.m_SuperColRange.Set(NSuper-1,ColumnIdx+1); Analysis.m_SuperRowRIdx.Set(NSuper-1,rlast); Node2Supernode.Set(ColumnIdx,NSuper-2); tFakeNonZeros.Set(NSuper-2,fakezerosinnewsupernode); tParentNodeOfSupernode.Set(NSuper-2,Parent[ColumnIdx]); NSuper--; //--- Trace if(Analysis.m_DotraceSupernodalStructure) { CAp::Trace(StringFormat("> merged with supernode S%d",NSuper - 1)); if(mergeinefficiency!=0.0) CAp::Trace(StringFormat(" (%2.0f%% inefficiency)",mergeinefficiency * 100)); CAp::Trace("\n*\n"); } } else { //--- Trace if(Analysis.m_DotraceSupernodalStructure) CAp::Trace(StringFormat("> standalone node S%d created\n*\n",NSuper - 1)); } } Analysis.m_NSuper=NSuper; //--- check if(!CAp::Assert(Analysis.m_NSuper>=1,__FUNCTION__+": integrity check failed (95mgd)")) return; if(!CAp::Assert(Analysis.m_SuperColRange[0]==0,__FUNCTION__+": integrity check failed (f446s)")) return; if(!CAp::Assert(Analysis.m_SuperColRange[NSuper]==n,__FUNCTION__+": integrity check failed (04ut4)")) return; CAblasF::ISetAllocV(NSuper,-1,Analysis.m_ParentSupernode); for(sidx=0; sidx=0) { nodeidx=Node2Supernode[nodeidx]; Analysis.m_ParentSupernode.Set(sidx,nodeidx); } } //--- Allocate supernodal storage CApServ::IVectorSetLengthAtLeast(Analysis.m_RowOffSets,Analysis.m_NSuper+1); CApServ::IVectorSetLengthAtLeast(Analysis.m_RowStrides,Analysis.m_NSuper); Analysis.m_RowOffSets.Set(0,0); for(i=0; in,__FUNCTION__+": input buffer tTmp0 is too short")) return; if(!CAp::Assert(CAp::Len(tTmp1)>n,__FUNCTION__+": input buffer tTmp1 is too short")) return; if(!CAp::Assert(CAp::Len(tFlagArray)>n,__FUNCTION__+": input buffer tTmp0 is too short")) return; if(!CAp::Assert(CSparse::SparseIsCRS(RawA),__FUNCTION__+": RawA must be CRS matrix")) return; //--- Determine LAdjPlus - supernodes feeding updates to the SIdx-th one. //--- Without supernodes we have: K-th row of L (also denoted as ladj+(K)) //--- includes original nonzeros from A (also denoted as ladj(K)) as well //--- as all elements on paths in elimination tree from ladj(K) to K. //--- With supernodes: same principle applied. CAblasF::ISetAllocV(Analysis.m_NSuper+1,0,Analysis.m_LAdjPlusR); CAblasF::BSetV(n,true,tFlagArray); Analysis.m_LAdjPlusR.Set(0,0); for(SIdx=0; SIdx<=Analysis.m_NSuper-1; SIdx++) { //--- Generate list of nodes feeding updates to SIdx-th one CApServ::VectorGrowTo(Analysis.m_LAdjPlus,Analysis.m_LAdjPlusR[SIdx]+Analysis.m_NSuper); rfirst=Analysis.m_LAdjPlusR[SIdx]; rlast=rfirst; for(rowidx=Analysis.m_SuperColRange[SIdx]; rowidx=0 && j=4) dbgrank4plusflop+=uflop; if((urank==4 && UWidth==4) && tWidth==4) dbg444flop+=uflop; if(tWidth==4) dbgxx4flop+=uflop; } uflop=0; for(i=0; i factor size:\n"); CAp::Trace(StringFormat("nz(L) = %d\n",dbgnzl)); CAp::Trace("> node size statistics:\n"); CAp::Trace(StringFormat("rank1 = %d\n",dbgrank1nodes)); CAp::Trace(StringFormat("rank2 = %d\n",dbgrank2nodes)); CAp::Trace(StringFormat("rank3 = %d\n",dbgrank3nodes)); CAp::Trace(StringFormat("rank4 = %d\n",dbgrank4nodes)); CAp::Trace(StringFormat("big nodes = %d\n",dbgbignodes)); CAp::Trace("> Total FLOP count (fused multiply-adds):\n"); CAp::Trace(StringFormat("total = %.8f MFLOP\n",1.0E-6 * dbgtotalflop)); CAp::Trace("> FLOP counts for updates:\n"); CAp::Trace(StringFormat("no-sctr = %.8f MFLOP (no row scatter,no col scatter,best case)\n",1.0E-6 * dbgnoscatterflop)); CAp::Trace(StringFormat("M4*44->N4 = %.8f MFLOP (no col scatter,big blocks,good case)\n",1.0E-6 * dbg444flop)); CAp::Trace(StringFormat("no-row-sctr = %.8f MFLOP (no row scatter,good case for col-wise storage)\n",1.0E-6 * dbgnorowscatterflop)); CAp::Trace(StringFormat("no-col-sctr = %.8f MFLOP (no col scatter,good case for row-wise storage)\n",1.0E-6 * dbgnocolscatterflop)); CAp::Trace(StringFormat("XX*XX->N4 = %.8f MFLOP\n",1.0E-6 * dbgxx4flop)); CAp::Trace(StringFormat("rank1 = %.8f MFLOP\n",1.0E-6 * dbgrank1flop)); CAp::Trace(StringFormat("rank4+ = %.8f MFLOP\n",1.0E-6 * dbgrank4plusflop)); CAp::Trace("> FLOP counts for Cholesky:\n"); CAp::Trace(StringFormat("cholesky = %.8f MFLOP\n",1.0E-6 * dbgcholeskyflop)); CAp::Trace(StringFormat("cholesky4 = %.8f MFLOP\n",1.0E-6 * dbgcholesky4flop)); } } //+------------------------------------------------------------------+ //| This function loads matrix into the supernodal storage. | //+------------------------------------------------------------------+ void CSpChol::LoadMatrix(CSpCholAnalysis &Analysis, CSparseMatrix &at) { //--- create variables int i0=0; int i1=0; int Cols0=0; int Cols1=0; int OffsS=0; int sstride=0; int blocksize=0; int SIdx=0; bool rowsizesmatch=true; int n=Analysis.m_N; //--- Perform quick integrity checks for(int i=0; i<=n; i++) rowsizesmatch=(rowsizesmatch && Analysis.m_ReferenceRIdx[i]==at.m_RIdx[i]); //--- check if(!CAp::Assert(rowsizesmatch,__FUNCTION__+": sparsity patterns do not match")) return; //--- Load CAblasF::IAllocV(n,Analysis.m_Raw2Smap); CAblasF::RSetAllocV(Analysis.m_RowOffSets[Analysis.m_NSuper],0.0,Analysis.m_InputStorage); for(SIdx=0; SIdxN,__FUNCTION__+": preallocated temporary TmpP is too short")) return; //--- Basic initialization A.m_MatrixType=1; A.m_N=N; A.m_M=N; //--- Various permutation types if(Analysis.m_ApplyPermutationToOutput) { //--- check if(!CAp::Assert(Analysis.m_IsTopologicalOrdering,__FUNCTION__+": critical integrity check failed (attempt to merge in nontopological permutation)")) return; //--- Output matrix is topologically permuted, so we return A=L*L' instead of A=P*L*L'*P'. //--- Somewhat inefficient because we have to apply permutation to L returned by supernodal code. CApServ::IVectorSetLengthAtLeast(A.m_RIdx,N+1); CApServ::IVectorSetLengthAtLeast(A.m_DIdx,N); A.m_RIdx.Set(0,0); for(i=0; icursize,__FUNCTION__+": Length(tmpParent)cursize,__FUNCTION__+": Length(tmpChildrenR)cursize,__FUNCTION__+": Length(tmpChildrenI)cursize,__FUNCTION__+": Length(tmp1)cursize,__FUNCTION__+": Length(tmp1)=Head) { //--- J-th column of the Head forwards its sparsity pattern directly into the Tail, save it to tmpUpdateT k=tmpUpdateT.m_RIdx[j]; CAblasF::IGrowV(k+Tail,tmpUpdateT.m_Idx); CAblasF::RGrowV(k+Tail,tmpUpdateT.m_Vals); for(jj=tmpBottomT.m_RIdx[j]; jj=A.m_N,__FUNCTION__+": Length(P)=0 && j=N,__FUNCTION__+": input temporary is too short")) return(-1); if(!CAp::Assert(CAp::Len(Tmp0)>=N,__FUNCTION__+": input temporary is too short")) return(-1); //--- Determine supernodal children in Tmp0 for(ii=i0; iii1) break; ii=SuperRowIdx[i0]; } if(jjj1) break; jj=SuperRowIdx[j0]; } if(jj==ii) { SuperRowIdx.Set(tlast,ii); tlast++; i0++; j0++; if(i0>i1) break; if(j0>j1) break; ii=SuperRowIdx[i0]; jj=SuperRowIdx[j0]; } } for(ii=i0; ii<=i1; ii++) { SuperRowIdx.Set(tlast,SuperRowIdx[ii]); tlast++; } for(jj=j0; jj<=j1; jj++) { SuperRowIdx.Set(tlast,SuperRowIdx[jj]); tlast++; } CAblasF::ICopyVX(tlast-tfirst,SuperRowIdx,tfirst,SuperRowIdx,rfirst); rlast=rfirst+(tlast-tfirst); } result=rlast; } else { //--- Unordered merge followed by sort. Guaranteed N*logN worst case. for(ii=rfirst; ii= tWidth in | //| RowStorage[OffsS:OffsS + tHeight * tStride - 1] | //| * lower trapezoidal i.e. its leading tWidth*tWidth submatrix is| //| lower triangular. One may update either entire tWidth*tWidth | //| submatrix or just its lower part, because upper triangle is | //| not referenced anyway. | //| * the height of S is not given because it is not actually | //| needed | //| * U is an uHeight*uRank rectangular update matrix tht is: | //| * stored with row stride uStride >= uRank in | //| RowStorage[OffsU:OffsU + uHeight * uStride - 1]. | //| * Uc is the leading uWidth*uRank submatrix of U | //| * D is uRank*uRank diagonal matrix that is: | //| * stored in DiagD[OffsD:OffsD + uRank - 1] | //| * unit, when Analysis.UnitD = True. In this case it can be | //| ignored, although DiagD still contains 1's in all of its | //| entries | //| * uHeight <= tHeight, uWidth <= tWidth, so scatter operation is| //| needed to update S with smaller update. | //| * scatter() is an operation that extends smaller | //| uHeight*uWidth update matrix U*Uc' into larger tHeight*tWidth| //| target matrix by adding zero rows and columns into U*Uc': | //| * I-th row of update modifies | //| Raw2SMap[SuperRowIdx[URBase + I]] -th row of the matrix S | //| * J-th column of update modifies | //| Raw2SMap[SuperRowIdx[URBase + J]] -th col of the matrix S | //+------------------------------------------------------------------+ int CSpChol::UpdateSupernode(CSpCholAnalysis &Analysis, int SIdx, int Cols0, int Cols1, int OffsS, CRowInt &Raw2Smap, int UIdx, int WrkRow, CRowDouble &DiagD, int OffsD) { //--- create variables int result=0; int i=0; int j=0; int k=0; int UWidth=0; int UHeight=0; int targetrow=0; int targetcol=0; int offdiagrow=0; int lastrow=0; int offs0=0; int offsj=0; int offsk=0; double v=0; int tWidth=Cols1-Cols0; int theight=tWidth+(Analysis.m_SuperRowRIdx[SIdx+1]-Analysis.m_SuperRowRIdx[SIdx]); int OffsU=Analysis.m_RowOffSets[UIdx]; int colu0=Analysis.m_SuperColRange[UIdx]; int colu1=Analysis.m_SuperColRange[UIdx+1]; int URBase=Analysis.m_SuperRowRIdx[UIdx]; int urlast=Analysis.m_SuperRowRIdx[UIdx+1]; int urank=colu1-colu0; int tRowStride=Analysis.m_RowStrides[SIdx]; int urowstride=Analysis.m_RowStrides[UIdx]; //--- Skip leading uRank+WrkRow rows of U because they are not used. OffsU+=(colu1-colu0+WrkRow)*urowstride; //--- Analyze range of rows in supernode LAdjPlus[II] and determine two subranges: //--- * one with indexes stored at SuperRowIdx[WrkRow:OffdiagRow); //--- these indexes are the ones that intersect with range of rows/columns [ColS0,ColS1) //--- occupied by diagonal block of the supernode SIdx //--- * one with indexes stored at SuperRowIdx[OffdiagRow:LastRow); //--- these indexes are ones that intersect with range of rows occupied by //--- offdiagonal block of the supernode SIdx if(Analysis.m_ExtendedDebug) { //--- check if(!CAp::Assert(Analysis.m_SuperRowIdx[URBase+WrkRow]>=Cols0,__FUNCTION__+": integrity check 6378 failed")) return(-1); if(!CAp::Assert(Analysis.m_SuperRowIdx[URBase+WrkRow]=Cols0,__FUNCTION__+": integrity check failed (44trg6)")) return(-1); for(i=WrkRow; i=0,__FUNCTION__+": integrity check failed (43t63)")) return(-1); } } //--- Handle special cases if(tRowStride==4) { //--- Target is stride-4 column, try several kernels that may work with tWidth=3 and tWidth=4 if(UWidth==4 && tWidth==4 && urank==4 && urowstride==4) { if(UpdateKernel4444(Analysis.m_OutputStorage,OffsS,theight,OffsU,UHeight,Analysis.m_DiagD,colu0,Raw2Smap,Analysis.m_SuperRowIdx,URBase+WrkRow)) return(result); } if(UpdateKernelABC4(Analysis.m_OutputStorage,OffsS,tWidth,OffsU,UHeight,urank,urowstride,UWidth,Analysis.m_DiagD,colu0,Raw2Smap,Analysis.m_SuperRowIdx,URBase+WrkRow)) return(result); } if(urank==1 && urowstride==1) { if(UpdateKernelRank1(Analysis.m_OutputStorage,OffsS,tWidth,tRowStride,OffsU,UHeight,UWidth,Analysis.m_DiagD,colu0,Raw2Smap,Analysis.m_SuperRowIdx,URBase+WrkRow)) return(result); } if(urank==2 && urowstride==2) { if(UpdateKernelRank2(Analysis.m_OutputStorage,OffsS,tWidth,tRowStride,OffsU,UHeight,UWidth,Analysis.m_DiagD,colu0,Raw2Smap,Analysis.m_SuperRowIdx,URBase+WrkRow)) return(result); } //--- Handle general update, rerefence code CApServ::IVectorSetLengthAtLeast(Analysis.m_U2Smap,UHeight); for(i=0; i0.0); bool controloverflow=(Analysis.m_ModType==1 && Analysis.m_ModParam1>0.0); //--- check if(Analysis.m_UnitD) { //--- Classic Cholesky for(j=0; j<=blocksize-1; j++) { //--- Compute J-th column vs=0; for(k=j; k<(blocksize+offdiagsize); k++) { v=Analysis.m_OutputStorage[OffsS+k*sstride+j]; for(i=0; iAnalysis.m_ModParam1) //--- Possible failure due to accumulation of numerical errors return(false); //--- Handle pivot element v=Analysis.m_OutputStorage[OffsS+j*sstride+j]; if(controlpivot && v<=Analysis.m_ModParam0) { //--- Basic modified Cholesky v=MathSqrt(Analysis.m_ModParam0); Analysis.m_DiagD.Set(Cols0+j,1.0); Analysis.m_OutputStorage.Set(OffsS+j*sstride+j,v); v=1/v; for(k=j+1; kAnalysis.m_ModParam1) //--- Possible failure due to accumulation of numerical errors return(false); //--- Handle pivot element possignvraw=CApServ::PosSign(Analysis.m_InputStorage[OffsS+j*sstride+j]); v=Analysis.m_OutputStorage[OffsS+j*sstride+j]; if(controlpivot && v/possignvraw<=Analysis.m_ModParam0) { //--- Basic modified LDLT v=possignvraw*Analysis.m_ModParam0; Analysis.m_DiagD.Set(Cols0+j,v); Analysis.m_OutputStorage.Set(OffsS+j*sstride+j,1.0); v=1/v; for(k=j+1; k4) return(result); if(UWidth>4) return(result); //--- Determine target columns, load update matrix if(UWidth>=1) { col0=Raw2Smap[SuperRowIdx[URBase+0]]; u00=d0*RowStorage[OffsU+0]; } if(UWidth>=2) { col1=Raw2Smap[SuperRowIdx[URBase+1]]; u10=d0*RowStorage[OffsU+1]; } if(UWidth>=3) { col2=Raw2Smap[SuperRowIdx[URBase+2]]; u20=d0*RowStorage[OffsU+2]; } if(UWidth>=4) { col3=Raw2Smap[SuperRowIdx[URBase+3]]; u30=d0*RowStorage[OffsU+3]; } //--- Run update switch(UWidth) { case 1: for(k=0; k4 || UWidth>4) return(result); //--- Determine target columns, load update matrix if(UWidth>=1) { col0=Raw2Smap[SuperRowIdx[URBase+0]]; u00=d0*RowStorage[OffsU+0]; u01=d1*RowStorage[OffsU+1]; } if(UWidth>=2) { col1=Raw2Smap[SuperRowIdx[URBase+1]]; u10=d0*RowStorage[OffsU+1*2+0]; u11=d1*RowStorage[OffsU+1*2+1]; } if(UWidth>=3) { col2=Raw2Smap[SuperRowIdx[URBase+2]]; u20=d0*RowStorage[OffsU+2*2+0]; u21=d1*RowStorage[OffsU+2*2+1]; } if(UWidth>=4) { col3=Raw2Smap[SuperRowIdx[URBase+3]]; u30=d0*RowStorage[OffsU+3*2+0]; u31=d1*RowStorage[OffsU+3*2+1]; } //--- Run update switch(UWidth) { case 1: for(k=0; k::Identity(N,N); CSparse::SparseSymmPermTblBuf(A,false,FillinPerm,perma); densea.Resize(N,N); for(i=0; i::Zeros(2*N); int i_=0; int i1_=0; //--- Quick return if possible if(N==0) return(result); if(IsUpper) { //--- Compute the Cholesky factorization A = U'*U. for(j=0; j0) { i1_=Offs; for(i_=0; i_0) { i1_=Offs; for(i_=0; i_0 | //| N - number of columns in the matrix being estimated, | //| N>0 | //| NStart - number of random starting vectors, recommended | //| value - at least 5. | //| NIts - number of iterations to do with best starting | //| vector recommended value - at least 5. | //| OUTPUT PARAMETERS: | //| State - structure which stores algorithm state | //| NOTE: this algorithm is effectively deterministic, i.e. it always| //| returns same result when repeatedly called for the same | //| matrix. In fact, algorithm uses randomized starting v | //| ectors, but internal random numbers generator always | //| generates same sequence of the random values (it is a | //| feature, not bug). | //| Algorithm can be made non-deterministic with | //| NormEstimatorSetSeed(0) call. | //+------------------------------------------------------------------+ void CNormEstimator::NormEstimatorCreate(int m,int n,int nstart,int nits, CNormEstimatorState &state) { //--- check if(!CAp::Assert(m>0,__FUNCTION__+": M<=0")) return; if(!CAp::Assert(n>0,__FUNCTION__+": N<=0")) return; if(!CAp::Assert(nstart>0,__FUNCTION__+": NStart<=0")) return; if(!CAp::Assert(nits>0,__FUNCTION__+": NIts<=0")) return; //--- initialization state.m_M=m; state.m_N=n; state.m_NStart=nstart; state.m_NIts=nits; state.m_SeedVal=11; CHighQualityRand::HQRndRandomize(state.m_R); state.m_X0.Resize(state.m_N); state.m_T.Resize(state.m_M); state.m_X1.Resize(state.m_N); state.m_XBest.Resize(state.m_N); state.m_X.Resize(MathMax(state.m_N,state.m_M)); state.m_Mv.Resize(state.m_M); state.m_Mtv.Resize(state.m_N); state.m_RState.ia.Resize(3+1); state.m_RState.ra.Resize(2+1); state.m_RState.stage=-1; } //+------------------------------------------------------------------+ //| This function changes seed value used by algorithm. In some cases| //| we need deterministic processing, i.e. subsequent calls must | //| return equal results, in other cases we need non-deterministic | //| algorithm which returns different results for the same matrix on | //| every pass. | //| Setting zero seed will lead to non-deterministic algorithm, while| //| non-zero value will make our algorithm deterministic. | //| INPUT PARAMETERS: | //| State - norm estimator state, must be initialized with a | //| call to NormEstimatorCreate() | //| SeedVal - seed value, >=0. Zero value=non-deterministic algo.| //+------------------------------------------------------------------+ void CNormEstimator::NormEstimatorSetSeed(CNormEstimatorState &state, int SeedVal) { //--- check if(!CAp::Assert(SeedVal>=0,__FUNCTION__+": SeedVal<0")) return; state.m_SeedVal=SeedVal; } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CNormEstimator::NormEstimatorIteration(CNormEstimatorState &state) { //--- create variables bool result; int n=0; int m=0; int i=0; int itcnt=0; double v=0; double growth=0; double bestgrowth=0; int i_=0; int label=-1; //--- Reverse communication preparations //--- I know it looks ugly, but it works the same way //--- anywhere from C++ to Python. //--- This code initializes locals by: //--- * random values determined during code //--- generation - on first subroutine call //--- * values from previous call - on subsequent calls if(state.m_RState.stage>=0) { n=state.m_RState.ia[0]; m=state.m_RState.ia[1]; i=state.m_RState.ia[2]; itcnt=state.m_RState.ia[3]; v=state.m_RState.ra[0]; growth=state.m_RState.ra[1]; bestgrowth=state.m_RState.ra[2]; } else { n=359; m=-58; i=-919; itcnt=-909; v=81; growth=255; bestgrowth=74; } switch(state.m_RState.stage) { case 0: label=0; break; case 1: label=1; break; case 2: label=2; break; case 3: label=3; break; default: //--- Routine body n=state.m_N; m=state.m_M; if(state.m_SeedVal>0) CHighQualityRand::HQRndSeed(state.m_SeedVal,state.m_SeedVal+2,state.m_R); bestgrowth=0; state.m_XBest=vector::Zeros(n); state.m_XBest.Set(0,1); itcnt=0; label=4; break; } //--- main loop while(label>=0) switch(label) { case 4: if(itcnt>state.m_NStart-1) { label=6; break; } do { v=0; for(i=0; ibestgrowth) { v=1/MathSqrt(v); state.m_XBest=state.m_X1.ToVector()*v; bestgrowth=growth; } itcnt++; label=4; break; case 6: state.m_X0=state.m_XBest; itcnt=0; case 7: if(itcnt>state.m_NIts-1) { label=9; break; } for(i_=0; i_= 0 | //+------------------------------------------------------------------+ void CNormEstimator::NormEstimatorResults(CNormEstimatorState &state, double &nrm) { nrm=0; nrm=state.m_RepNorm; } //+------------------------------------------------------------------+ //| This function restarts estimator and prepares it for the next | //| estimation round. | //| INPUT PARAMETERS: | //| State - algorithm state | //+------------------------------------------------------------------+ void CNormEstimator::NormEstimatorRestart(CNormEstimatorState &state) { state.m_RState.ia.Resize(3+1); state.m_RState.ra=vector::Zeros(2+1); state.m_RState.stage=-1; } //+------------------------------------------------------------------+ //| Schur decomposition of Hessenberg matrix | //+------------------------------------------------------------------+ class CHsSchur { public: static void RMatrixInternalSchurDecomposition(CMatrixDouble &h,int n,int tneeded,int zneeded,CRowDouble &wr,CRowDouble &wi,CMatrixDouble &z,int &info); static bool UpperHessenbergSchurDecomposition(CMatrixDouble &h,const int n,CMatrixDouble &s); static void InternalSchurDecomposition(CMatrixDouble &h,const int n,const int tneeded,const int zneeded,double &wr[],double &wi[],CMatrixDouble &z,int &info); static void InternalSchurDecomposition(CMatrixDouble &h,const int n,const int tneeded,const int zneeded,CRowDouble &wr,CRowDouble &wi,CMatrixDouble &z,int &info); private: static void InternalAuxSchur(const bool wantt,const bool wantz,const int n,const int ilo,const int ihi,CMatrixDouble &h,CRowDouble &wr,CRowDouble &wi,const int iloz,const int ihiz,CMatrixDouble &z,CRowDouble &work,CRowDouble &workv3,CRowDouble &workc1,CRowDouble &works1,int &info); static void Aux2x2Schur(double &a,double &b,double &c,double &d,double &rt1r,double &rt1i,double &rt2r,double &rt2i,double &cs,double &sn); static double ExtSchurSign(const double a,const double b); static int ExtSchurSignToone(const double b); }; //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ void CHsSchur::RMatrixInternalSchurDecomposition(CMatrixDouble &h, int n,int tneeded,int zneeded,CRowDouble &wr,CRowDouble &wi, CMatrixDouble &z,int &info) { //--- create variables int i=0; int j=0; CMatrixDouble h1; CMatrixDouble z1; CRowDouble wr1; CRowDouble wi1; info=0; //--- Allocate space wr.Resize(n); wi.Resize(n); if(zneeded==2) CApServ::RMatrixSetLengthAtLeast(z,n,n); //--- ALGLIB version h1.Resize(n+1,n+1); for(i=0; i=0. | //| Output parameters: | //| H ? contains the matrix T. | //| Array whose indexes range within [1..N, 1..N]. | //| All elements below the blocks on the main diagonal | //| are equal to 0. | //| S - contains Schur vectors. | //| Array whose indexes range within [1..N, 1..N]. | //| Note 1: | //| The block structure of matrix T could be easily recognized: | //| since all the elements below the blocks are zeros, the | //| elements a[i+1,i] which are equal to 0 show the block border.| //| Note 2: | //| the algorithm performance depends on the value of the | //| internal parameter NS of InternalSchurDecomposition | //| subroutine which defines the number of shifts in the QR | //| algorithm (analog of the block width in block matrix | //| algorithms in linear algebra). If you require maximum | //| performance on your machine, it is recommended to | //| adjust thisparameter manually. | //| Result: | //| True, if the algorithm has converged and the parameters H and| //| S contain the result. | //| False, if the algorithm has not converged. | //| Algorithm implemented on the basis of subroutine DHSEQR | //| (LAPACK 3.0 library). | //+------------------------------------------------------------------+ bool CHsSchur::UpperHessenbergSchurDecomposition(CMatrixDouble &h, const int n, CMatrixDouble &s) { //--- create variables bool result; int info=0; //--- create arrays CRowDouble wi; CRowDouble wr; //--- function call InternalSchurDecomposition(h,n,1,2,wr,wi,s,info); result=info==0; //--- return result return(result); } //+------------------------------------------------------------------+ //| Internal subroutine | //+------------------------------------------------------------------+ void CHsSchur::InternalSchurDecomposition(CMatrixDouble &h,const int n, const int tneeded, const int zneeded, CRowDouble &wr,CRowDouble &wi, CMatrixDouble &z,int &info) { //--- check if(!CAp::Assert(n>=0,__FUNCTION__+": incorrect N!")) return; if(!CAp::Assert(tneeded==0 || tneeded==1,__FUNCTION__+": incorrect TNeeded!")) return; if(!CAp::Assert((zneeded==0 || zneeded==1) || zneeded==2,__FUNCTION__+": incorrect ZNeeded!")) return; //--- create variables int i=0; int i1=0; int i2=0; int ierr=0; int ii=0; int itemp=0; int itn=0; int its=0; int j=0; int k=0; int l=0; int maxb=0; int nr=0; int ns=0; int nv=0; double absw=0; double smlnum=0; double tau=0; double temp=0; double tst1=0; double ulp=0; double unfl=0; bool initz; bool wantt; bool wantz; double cnst=0; bool failflag; int p1=0; int p2=0; double vt=0; int i_=0; int i1_=0; //--- create arrays CRowDouble v; CRowDouble vv; CRowDouble work; CRowDouble workc1; CRowDouble works1; CRowDouble workv3; CRowDouble tmpwr; CRowDouble tmpwi; CMatrixDouble s; //--- initialization info=0; //--- Set the order of the multi-shift QR algorithm to be used. //--- If you want to tune algorithm, change this values ns=12; maxb=50; //--- Now 2 < NS <= MAXB < NH. maxb=(int)MathMax(3,maxb); ns=MathMin(maxb,ns); //--- Initialize cnst=1.5; //--- allocation work=vector::Zeros((int)MathMax(n,1)+1); s=matrix::Zeros(ns+1,ns+1); v=vector::Zeros(ns+2); vv=vector::Zeros(ns+2); wr=vector::Zeros((int)MathMax(n,1)+1); wi=vector::Zeros((int)MathMax(n,1)+1); workc1=vector::Zeros(2); works1=vector::Zeros(2); workv3=vector::Zeros(4); tmpwr.Resize((int)MathMax(n,1)+1); tmpwi.Resize((int)MathMax(n,1)+1); //--- initialization wantt=tneeded==1; initz=zneeded==2; wantz=zneeded!=0; info=0; //--- Initialize Z, if necessary if(initz) z=matrix::Eye(n+1,n+1); //--- Quick return if possible if(n==0) return; //--- check if(n==1) { wr.Set(1,h.Get(1,1)); wi.Set(1,0); //--- exit the function return; } //--- Set rows and columns 1 to N to zero below the first //--- subdiagonal. h=h.TriU(-1)*1.0; //--- Test if N is sufficiently small if((ns<=2 || ns>n) || maxb>=n) { //--- Use the standard double-shift algorithm InternalAuxSchur(wantt,wantz,n,1,n,h,wr,wi,1,n,z,work,workv3,workc1,works1,info); //--- fill entries under diagonal blocks of T with zeros if(wantt) { j=1; while(j<=n) { //--- check if(wi[j]==0.0) { for(i=j+1; i<=n; i++) h.Set(i,j,0); j=j+1; } else { for(i=j+2; i<=n; i++) { h.Set(i,j,0); h.Set(i,j+1,0); } j=j+2; } } } //--- exit the function return; } //--- change values unfl=CMath::m_minrealnumber; ulp=2*CMath::m_machineepsilon; smlnum=unfl*(n/ulp); //--- I1 and I2 are the indices of the first row and last column of H //--- to which transformations must be applied. If eigenvalues only are //--- being computed, I1 and I2 are set inside the main loop. i1=1; i2=n; //--- ITN is the total number of multiple-shift QR iterations allowed. itn=30*n; //--- The main loop begins here. I is the loop index and decreases from //--- IHI to ILO in steps of at most MAXB. Each iteration of the loop //--- works with the active submatrix in rows and columns L to I. //--- Eigenvalues I+1 to IHI have already converged. Either L = ILO or //--- H(L,L-1) is negligible so that the matrix splits. i=n; while(true) { l=1; //--- check if(i<1) { //--- fill entries under diagonal blocks of T with zeros if(wantt) { j=1; while(j<=n) { //--- check if(wi[j]==0.0) { for(i=j+1; i<=n; i++) h.Set(i,j,0); j=j+1; } else { for(i=j+2; i<=n; i++) { h.Set(i,j,0); h.Set(i,j+1,0); } j=j+2; } } } //--- Exit return; } //--- Perform multiple-shift QR iterations on rows and columns ILO to I //--- until a submatrix of order at most MAXB splits off at the bottom //--- because a subdiagonal element has become negligible. failflag=true; for(its=0; its<=itn; its++) { //--- Look for a single small subdiagonal element. for(k=i; k>=l+1; k--) { tst1=MathAbs(h[k-1][k-1])+MathAbs(h[k][k]); //--- check if(tst1==0.0) tst1=CBlas::UpperHessenberg1Norm(h,l,i,l,i,work); //--- check if(MathAbs(h[k][k-1])<=MathMax(ulp*tst1,smlnum)) break; } l=k; //--- check if(l>1) //--- H(L,L-1) is negligible. h.Set(l,l-1,0); //--- Exit from loop if a submatrix of order <= MAXB has split off. if(l>=i-maxb+1) { failflag=false; break; } //--- Now the active submatrix is in rows and columns L to I. If //--- eigenvalues only are being computed, only the active submatrix //--- need be transformed. if(its==20 || its==30) { //--- Exceptional shifts. for(ii=i-ns+1; ii<=i; ii++) { wr.Set(ii,cnst*(MathAbs(h.Get(ii,ii-1))+MathAbs(h.Get(ii,ii)))); wi.Set(ii,0); } } else { //--- Use eigenvalues of trailing submatrix of order NS as shifts. CBlas::CopyMatrix(h,i-ns+1,i,i-ns+1,i,s,1,ns,1,ns); //--- function call InternalAuxSchur(false,false,ns,1,ns,s,tmpwr,tmpwi,1,ns,z,work,workv3,workc1,works1,ierr); for(p1=1; p1<=ns; p1++) { wr.Set(i-ns+p1,tmpwr[p1]); wi.Set(i-ns+p1,tmpwi[p1]); } //--- check if(ierr>0) { //--- If DLAHQR failed to compute all NS eigenvalues, use the //--- unconverged diagonal elements as the remaining shifts. for(ii=1; ii<=ierr; ii++) { wr.Set(i-ns+ii,s.Get(ii,ii)); wi.Set(i-ns+ii,0); } } } //--- Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) //--- where G is the Hessenberg submatrix H(L:I,L:I) and w is //--- the vector of shifts (stored in WR and WI). The result is //--- stored in the local array V. v.Set(1,1); for(ii=2; ii=0.0) { //--- check if(wi[j]==0.0) { //--- real shift p1=nv+1; for(i_=1; i_<=p1; i_++) vv.Set(i_,v[i_]); //--- function call CBlas::MatrixVectorMultiply(h,l,l+nv,l,l+nv-1,false,vv,1,nv,1.0,v,1,nv+1,-wr[j]); nv=nv+1; } else { //--- check if(wi[j]>0.0) { //--- complex conjugate pair of shifts p1=nv+1; for(i_=1; i_<=p1; i_++) vv.Set(i_,v[i_]); //--- function call CBlas::MatrixVectorMultiply(h,l,l+nv,l,l+nv-1,false,v,1,nv,1.0,vv,1,nv+1,-(2*wr[j])); //--- function call itemp=CBlas::VectorIdxAbsMax(vv,1,nv+1); temp=1/MathMax(MathAbs(vv[itemp]),smlnum); p1=nv+1; for(i_=1; i_<=p1; i_++) vv.Set(i_,temp*vv[i_]); //--- function call absw=CBlas::PyThag2(wr[j],wi[j]); temp=temp*absw*absw; //--- function call CBlas::MatrixVectorMultiply(h,l,l+nv+1,l,l+nv,false,vv,1,nv+1,1.0,v,1,nv+2,temp); nv=nv+2; } } //--- Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, //--- reset it to the unit vector. itemp=CBlas::VectorIdxAbsMax(v,1,nv); temp=MathAbs(v[itemp]); //--- check if(temp==0.0) { v.Set(1,1); for(ii=2; ii<=nv; ii++) v.Set(ii,0); } else { temp=MathMax(temp,smlnum); vt=1/temp; for(i_=1; i_<=nv; i_++) v.Set(i_,vt*v[i_]); } } } //--- Multiple-shift QR step for(k=l; k<=i-1; k++) { //--- The first iteration of this loop determines a reflection G //--- from the vector V and applies it from left and right to H, //--- thus creating a nonzero bulge below the subdiagonal. //--- Each subsequent iteration determines a reflection G to //--- restore the Hessenberg form in the (K-1)th column, and thus //--- chases the bulge one step toward the bottom of the active //--- submatrix. NR is the order of G. nr=MathMin(ns+1,i-k+1); //--- check if(k>l) { //--- change values p1=k-1; p2=k+nr-1; i1_=k-1; for(i_=1; i_<=nr; i_++) v.Set(i_,h.Get(i_+i1_,p1)); } //--- function call CAblas::GenerateReflection(v,nr,tau); //--- check if(k>l) { h.Set(k,k-1,v[1]); for(ii=k+1; ii<=i; ii++) h.Set(ii,k-1,0); } v.Set(1,1); //--- Apply G from the left to transform the rows of the matrix in //--- columns K to I2. CAblas::ApplyReflectionFromTheLeft(h,tau,v,k,k+nr-1,k,i2,work); //--- Apply G from the right to transform the columns of the //--- matrix in rows I1 to min(K+NR,I). CAblas::ApplyReflectionFromTheRight(h,tau,v,i1,MathMin(k+nr,i),k,k+nr-1,work); //--- check if(wantz) //--- Accumulate transformations in the matrix Z CAblas::ApplyReflectionFromTheRight(z,tau,v,1,n,k,k+nr-1,work); } } //--- Failure to converge in remaining number of iterations if(failflag) { info=i; //--- exit the function return; } //--- A submatrix of order <= MAXB in rows and columns L to I has split //--- off. Use the double-shift QR algorithm to handle it. InternalAuxSchur(wantt,wantz,n,l,i,h,wr,wi,1,n,z,work,workv3,workc1,works1,info); //--- check if(info>0) return; //--- Decrement number of remaining iterations, and return to start of //--- the main loop with a new value of I. itn=itn-its; i=l-1; } } //+------------------------------------------------------------------+ //| Translation of DLAHQR from LAPACK | //+------------------------------------------------------------------+ void CHsSchur::InternalAuxSchur(const bool wantt,const bool wantz, const int n,const int ilo,const int ihi, CMatrixDouble &h,CRowDouble &wr,CRowDouble &wi, const int iloz,const int ihiz,CMatrixDouble &z, CRowDouble &work,CRowDouble &workv3, CRowDouble &workc1,CRowDouble &works1,int &info) { //--- create variables double safmin=0; double tst=0; double ab=0; double ba=0; double aa=0; double bb=0; double rt1r=0; double rt1i=0; double rt2r=0; double rt2i=0; double tr=0; double det=0; double rtdisc=0; double h21s=0; int i=0; int i1=0; int i2=0; int itmax=0; int its=0; int j=0; int k=0; int l=0; int m=0; int nh=0; int nr=0; int nz=0; double cs=0; double h11=0; double h12=0; double h21=0; double h22=0; double s=0; double smlnum=0; double sn=0; double sum=0; double t1=0; double t2=0; double t3=0; double v2=0; double v3=0; bool failflag; double dat1=0; double dat2=0; int p1=0; double him1im1=0; double him1i=0; double hiim1=0; double hii=0; double wrim1=0; double wri=0; double wiim1=0; double wii=0; double ulp=0; //--- initialization info=0; dat1=0.75; dat2=-0.4375; ulp=CMath::m_machineepsilon; //--- Quick return if possible if(n==0) return; //--- check if(ilo==ihi) { wr.Set(ilo,h.Get(ilo,ilo)); wi.Set(ilo,0); //--- exit the function return; } //--- clear out the trash // for(j=ilo; jl; k--) { //--- check if(MathAbs(h[k][k-1])<=smlnum) break; tst=MathAbs(h[k-1][k-1])+MathAbs(h[k][k]); //--- check if(tst==0.0) { if(k-2>=ilo) tst=tst+MathAbs(h[k-1][k-2]); if(k+1<=ihi) tst=tst+MathAbs(h[k+1][k]); } //--- The following is a conservative small subdiagonal //--- deflation criterion due to Ahues & Tisseur (LAWN 122, //--- 1997). It has better mathematical foundation and //--- improves accuracy in some cases. if(MathAbs(h[k][k-1])<=(double)(ulp*tst)) { ab=MathMax(MathAbs(h[k][k-1]),MathAbs(h[k-1][k])); ba=MathMin(MathAbs(h[k][k-1]),MathAbs(h[k-1][k])); aa=MathMax(MathAbs(h[k][k]),MathAbs(h[k-1][k-1]-h[k][k])); bb=MathMin(MathAbs(h[k][k]),MathAbs(h[k-1][k-1]-h[k][k])); s=aa+ab; if((ba*(ab/s))<=MathMax(smlnum,ulp*(bb*(aa/s)))) break; } } l=k; //--- check if(l>ilo) //--- H(L,L-1) is negligible h.Set(l,l-1,0); //--- Exit from loop if a submatrix of order 1 or 2 has split off. if(l>=i-1) { failflag=false; break; } //--- Now the active submatrix is in rows and columns L to I. If //--- eigenvalues only are being computed, only the active submatrix //--- need be transformed. if(!wantt) { i1=l; i2=i; } if(its==10) { //--- Exceptional shift. s=MathAbs(h[l+1][l])+MathAbs(h[l+2][l+1]); h22=h11=dat1*s+h[l][l]; h12=dat2*s; h21=s; } else { if(its==20) { //--- Exceptional shift. s=MathAbs(h[i][i-1])+MathAbs(h[i-1][i-2]); h22=h11=dat1*s+h[i][i]; h12=dat2*s; h21=s; } else { //--- Prepare to use Francis' double shift //--- (i.e. 2nd degree generalized Rayleigh quotient) h11=h[i-1][i-1]; h21=h[i][i-1]; h12=h[i-1][i]; h22=h[i][i]; } } s=MathAbs(h11)+MathAbs(h12)+MathAbs(h21)+MathAbs(h22); if(s==0.0) { rt1r=0; rt1i=0; rt2r=0; rt2i=0; } else { h11=h11/s; h21=h21/s; h12=h12/s; h22=h22/s; tr=(h11+h22)/2; det=(h11-tr)*(h22-tr)-h12*h21; rtdisc=MathSqrt(MathAbs(det)); if(det>=0.0) { //--- complex conjugate shifts rt1r=tr*s; rt2r=rt1r; rt1i=rtdisc*s; rt2i=-rt1i; } else { //--- real shifts (use only one of them) rt1r=tr+rtdisc; rt2r=tr-rtdisc; if(MathAbs(rt1r-h22)<=MathAbs(rt2r-h22)) { rt1r=rt1r*s; rt2r=rt1r; } else { rt2r=rt2r*s; rt1r=rt2r; } rt1i=0; rt2i=0; } } //--- Look for two consecutive small subdiagonal elements. for(m=i-2; m>=l; m--) { //--- Determine the effect of starting the double-shift QR //--- iteration at row M, and see if this would make H(M,M-1) //--- negligible. s=MathAbs(h[m][m]-rt2r)+MathAbs(rt2i)+MathAbs(h[m+1][m]); h21s=h[m+1][m]/s; workv3.Set(1,h21s*h[m][m+1]+(h[m][m]-rt1r)*((h[m][m]-rt2r)/s)-rt1i*(rt2i/s)); workv3.Set(2,h21s*(h[m][m]+h[m+1][m+1]-rt1r-rt2r)); workv3.Set(3,h21s*h[m+2][m+1]); s=MathAbs(workv3[1])+MathAbs(workv3[2])+MathAbs(workv3[3]); workv3.Set(1,workv3[1]/s); workv3.Set(2,workv3[2]/s); workv3.Set(3,workv3[3]/s); //--- check if(m==l) break; if((MathAbs(h.Get(m,m-1))*(MathAbs(workv3[2])+MathAbs(workv3[3])))<=(ulp*MathAbs(workv3[1])*(MathAbs(h[m-1][m-1])+MathAbs(h[m][m])+MathAbs(h[m+1][m+1])))) break; } //--- Double-shift QR step for(k=m; km) { for(p1=1; p1<=nr; p1++) workv3.Set(p1,h.Get(k+p1-1,k-1)); } //--- function call CAblas::GenerateReflection(workv3,nr,t1); //--- check if(k>m) { h.Set(k,k-1,workv3[1]); h.Set(k+1,k-1,0); //--- check if(kl) //--- Use the following instead of //--- H( K, K-1 ) = -H( K, K-1 ) to //--- avoid a bug when v(2) and v(3) //--- underflow. h.Set(k,k-1,-h[k][k-1]); } v2=workv3[2]; t2=t1*v2; //--- check if(nr==3) { v3=workv3[3]; t3=t1*v3; //--- Apply G from the left to transform the rows of the matrix //--- in columns K to I2. for(j=k; j<=i2; j++) { sum=h[k][j]+v2*h[k+1][j]+v3*h[k+2][j]; h.Set(k,j,h[k][j]-sum*t1); h.Set(k+1,j,h[k+1][j]-sum*t2); h.Set(k+2,j,h[k+2][j]-sum*t3); } //--- Apply G from the right to transform the columns of the //--- matrix in rows I1 to min(K+3,I). for(j=i1; j<=MathMin(k+3,i); j++) { sum=h[j][k]+v2*h[j][k+1]+v3*h[j][k+2]; h.Set(j,k,h[j][k]-sum*t1); h.Set(j,k+1,h[j][k+1]-sum*t2); h.Set(j,k+2,h[j][k+2]-sum*t3); } //--- check if(wantz) { //--- Accumulate transformations in the matrix Z for(j=iloz; j<=ihiz; j++) { sum=z[j][k]+v2*z[j][k+1]+v3*z[j][k+2]; z.Set(j,k,z[j][k]-sum*t1); z.Set(j,k+1,z[j][k+1]-sum*t2); z.Set(j,k+2,z[j][k+2]-sum*t3); } } } else { //--- check if(nr==2) { //--- Apply G from the left to transform the rows of the matrix //--- in columns K to I2. for(j=k; j<=i2; j++) { sum=h[k][j]+v2*h[k+1][j]; h.Set(k,j,h[k][j]-sum*t1); h.Set(k+1,j,h[k+1][j]-sum*t2); } //--- Apply G from the right to transform the columns of the //--- matrix in rows I1 to min(K+3,I). for(j=i1; j<=i; j++) { sum=h[j][k]+v2*h[j][k+1]; h.Set(j,k,h[j][k]-sum*t1); h.Set(j,k+1,h[j][k+1]-sum*t2); } //--- check if(wantz) { //--- Accumulate transformations in the matrix Z for(j=iloz; j<=ihiz; j++) { sum=z[j][k]+v2*z[j][k+1]; z.Set(j,k,z[j][k]-sum*t1); z.Set(j,k+1,z[j][k+1]-sum*t2); } } } } } } //--- check if(failflag) { //--- Failure to converge in remaining number of iterations info=i; //--- exit the function return; } //--- Convergence if(l==i) { //--- H(I,I-1) is negligible: one eigenvalue has converged. wr.Set(i,h.Get(i,i)); wi.Set(i,0); } else { //--- check if(l==i-1) { //--- H(I-1,I-2) is negligible: a pair of eigenvalues have converged. //--- Transform the 2-by-2 submatrix to standard Schur form, //--- and compute and store the eigenvalues. him1im1=h[i-1][i-1]; him1i=h[i-1][i]; hiim1=h[i][i-1]; hii=h[i][i]; //--- function call Aux2x2Schur(him1im1,him1i,hiim1,hii,wrim1,wiim1,wri,wii,cs,sn); //--- change values wr.Set(i-1,wrim1); wi.Set(i-1,wiim1); wr.Set(i,wri); wi.Set(i,wii); h.Set(i-1,i-1,him1im1); h.Set(i-1,i,him1i); h.Set(i,i-1,hiim1); h.Set(i,i,hii); //--- check if(wantt) { //--- Apply the transformation to the rest of H. if(i2>i) { workc1.Set(1,cs); works1.Set(1,sn); //--- function call CRotations::ApplyRotationsFromTheLeft(true,i-1,i,i+1,i2,workc1,works1,h,work); } workc1.Set(1,cs); works1.Set(1,sn); //--- function call CRotations::ApplyRotationsFromTheRight(true,i1,i-2,i-1,i,workc1,works1,h,work); } //--- check if(wantz) { //--- Apply the transformation to Z. workc1.Set(1,cs); works1.Set(1,sn); //--- function call CRotations::ApplyRotationsFromTheRight(true,iloz,iloz+nz-1,i-1,i,workc1,works1,z,work); } } } //--- Decrement number of remaining iterations, and return to start of //--- the main loop with new value of I. i=l-1; } } //+------------------------------------------------------------------+ //| 2x2 | //+------------------------------------------------------------------+ void CHsSchur::Aux2x2Schur(double&a,double&b,double&c,double&d, double&rt1r,double&rt1i,double&rt2r, double&rt2i,double&cs,double&sn) { //--- create variables double multpl=0; double aa=0; double bb=0; double bcmax=0; double bcmis=0; double cc=0; double cs1=0; double dd=0; double eps=0; double p=0; double sab=0; double sac=0; double scl=0; double sigma=0; double sn1=0; double tau=0; double temp=0; double z=0; //--- initialization rt1r=0; rt1i=0; rt2r=0; rt2i=0; cs=0; sn=0; multpl=4.0; eps=CMath::m_machineepsilon; //--- check if(c==0.0) { cs=1; sn=0; } else { //--- check if(b==0.0) { //--- Swap rows and columns cs=0; sn=1; temp=d; d=a; a=temp; b=-c; c=0; } else { //--- check if(a-d==0.0 && ExtSchurSignToone(b)!=ExtSchurSignToone(c)) { cs=1; sn=0; } else { //--- change values temp=a-d; p=0.5*temp; bcmax=MathMax(MathAbs(b),MathAbs(c)); bcmis=MathMin(MathAbs(b),MathAbs(c))*ExtSchurSignToone(b)*ExtSchurSignToone(c); scl=MathMax(MathAbs(p),bcmax); z=p/scl*p+bcmax/scl*bcmis; //--- If Z is of the order of the machine accuracy, postpone the //--- decision on the nature of eigenvalues if(z>=multpl*eps) { //--- Real eigenvalues. Compute A and D. z=p+ExtSchurSign(MathSqrt(scl)*MathSqrt(z),p); a=d+z; d=d-bcmax/z*bcmis; //--- Compute B and the rotation matrix tau=CBlas::PyThag2(c,z); cs=z/tau; sn=c/tau; b=b-c; c=0; } else { //--- Complex eigenvalues, or real (almost) equal eigenvalues. //--- Make diagonal elements equal. sigma=b+c; tau=CBlas::PyThag2(sigma,temp); cs=MathSqrt(0.5*(1+MathAbs(sigma)/tau)); sn=-(p/(tau*cs)*ExtSchurSign(1,sigma)); //--- Compute [ AA BB ] = [ A B ] [ CS -SN ] //--- [ CC DD ] [ C D ] [ SN CS ] aa=a*cs+b*sn; bb=-(a*sn)+b*cs; cc=c*cs+d*sn; dd=-(c*sn)+d*cs; //--- Compute [ A B ] = [ CS SN ] [ AA BB ] //--- [ C D ] [-SN CS ] [ CC DD ] a=aa*cs+cc*sn; b=bb*cs+dd*sn; c=-(aa*sn)+cc*cs; d=-(bb*sn)+dd*cs; temp=0.5*(a+d); a=temp; d=temp; //--- check if(c!=0.0) { //--- check if(b!=0.0) { //--- check if(ExtSchurSignToone(b)==ExtSchurSignToone(c)) { //--- Real eigenvalues: reduce to upper triangular form sab=MathSqrt(MathAbs(b)); sac=MathSqrt(MathAbs(c)); //--- function call p=ExtSchurSign(sab*sac,c); tau=1/MathSqrt(MathAbs(b+c)); a=temp+p; d=temp-p; b=b-c; c=0; cs1=sab*tau; sn1=sac*tau; temp=cs*cs1-sn*sn1; sn=cs*sn1+sn*cs1; cs=temp; } } else { //--- change values b=-c; c=0; temp=cs; cs=-sn; sn=temp; } } } } } } //--- Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). rt1r=a; rt2r=d; //--- check if(c==0.0) { rt1i=0; rt2i=0; } else { rt1i=MathSqrt(MathAbs(b))*MathSqrt(MathAbs(c)); rt2i=-rt1i; } } //+------------------------------------------------------------------+ //| Schur sign | //+------------------------------------------------------------------+ double CHsSchur::ExtSchurSign(const double a,const double b) { //--- create variables double result=0; //--- check if(b>=0.0) result=MathAbs(a); else result=-MathAbs(a); //--- return result return(result); } //+------------------------------------------------------------------+ //| Schur sign (1 or -1) | //+------------------------------------------------------------------+ int CHsSchur::ExtSchurSignToone(const double b) { //--- create variables int result=0; //--- check if(b>=0.0) result=1; else result=-1; //--- return result return(result); } //+------------------------------------------------------------------+ //| | //+------------------------------------------------------------------+ bool CSpChol::UpdateKernel4444(CRowDouble &rowstorage, int offss, int sheight, int offsu, int uheight, CRowDouble &diagd, int offsd, CRowInt &raw2smap, CRowInt &superrowidx, int urbase) { //--- create variables double d0=diagd[offsd+0]; double d1=diagd[offsd+1]; double d2=diagd[offsd+2]; double d3=diagd[offsd+3]; double u00=d0*rowstorage[offsu+0*4+0]; double u01=d1*rowstorage[offsu+0*4+1]; double u02=d2*rowstorage[offsu+0*4+2]; double u03=d3*rowstorage[offsu+0*4+3]; double u10=d0*rowstorage[offsu+1*4+0]; double u11=d1*rowstorage[offsu+1*4+1]; double u12=d2*rowstorage[offsu+1*4+2]; double u13=d3*rowstorage[offsu+1*4+3]; double u20=d0*rowstorage[offsu+2*4+0]; double u21=d1*rowstorage[offsu+2*4+1]; double u22=d2*rowstorage[offsu+2*4+2]; double u23=d3*rowstorage[offsu+2*4+3]; double u30=d0*rowstorage[offsu+3*4+0]; double u31=d1*rowstorage[offsu+3*4+1]; double u32=d2*rowstorage[offsu+3*4+2]; double u33=d3*rowstorage[offsu+3*4+3]; int targetrow=0; int offsk=0; double uk0=0; double uk1=0; double uk2=0; double uk3=0; for(int k=0; k4) return(false); if(uwidth<3 || uwidth>4) return(false); if(urank>4) return(false); //--- Determine source columns for target columns, -1 if target column //--- is not updated. srccol0=-1; srccol1=-1; srccol2=-1; srccol3=-1; for(k=0; k=1) d0=diagd[offsd+0]; if(urank>=2) d1=diagd[offsd+1]; if(urank>=3) d2=diagd[offsd+2]; if(urank>=4) d3=diagd[offsd+3]; if(srccol0>=0) { if(urank>=1) u00=d0*rowstorage[offsu+srccol0*urowstride+0]; if(urank>=2) u01=d1*rowstorage[offsu+srccol0*urowstride+1]; if(urank>=3) u02=d2*rowstorage[offsu+srccol0*urowstride+2]; if(urank>=4) u03=d3*rowstorage[offsu+srccol0*urowstride+3]; } if(srccol1>=0) { if(urank>=1) u10=d0*rowstorage[offsu+srccol1*urowstride+0]; if(urank>=2) u11=d1*rowstorage[offsu+srccol1*urowstride+1]; if(urank>=3) u12=d2*rowstorage[offsu+srccol1*urowstride+2]; if(urank>=4) u13=d3*rowstorage[offsu+srccol1*urowstride+3]; } if(srccol2>=0) { if(urank>=1) u20=d0*rowstorage[offsu+srccol2*urowstride+0]; if(urank>=2) u21=d1*rowstorage[offsu+srccol2*urowstride+1]; if(urank>=3) u22=d2*rowstorage[offsu+srccol2*urowstride+2]; if(urank>=4) u23=d3*rowstorage[offsu+srccol2*urowstride+3]; } if(srccol3>=0) { if(urank>=1) u30=d0*rowstorage[offsu+srccol3*urowstride+0]; if(urank>=2) u31=d1*rowstorage[offsu+srccol3*urowstride+1]; if(urank>=3) u32=d2*rowstorage[offsu+srccol3*urowstride+2]; if(urank>=4) u33=d3*rowstorage[offsu+srccol3*urowstride+3]; } //--- Run update switch(urank) { case 1: for(k=0; k