gavindiaz/All-MQL5-code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
master
All-MQL5-code/Include/Math/Alglib/linalg.mqh
T
Pierre8rTeam 25e9006a0b First commit [09/03/2018]
2018-03-09 16:43:19 +01:00

20340 lines
692 KiB
Plaintext
Raw Permalink Blame History

//+------------------------------------------------------------------+
//| linalg.mqh |
//| Copyright 2003-2012 Sergey Bochkanov (ALGLIB project) |
//| Copyright 2012-2017, MetaQuotes Software Corp. |
//| https://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
{
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 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 CMatrixSyrk2(const int n,const int k,const double alpha,const 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 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 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);
public:
CAblas(void);
~CAblas(void);
//--- size
static int AblasBlockSize(void) { return(32);}
static int AblasMicroBlockSize(void) { return(8); }
static int AblasComplexBlockSize(void) { return(24);}
//--- 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 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 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 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 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 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 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 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);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CAblas::CAblas(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CAblas::~CAblas(void)
{
}
//+------------------------------------------------------------------+
//| Same as CMatrixSYRK, but for real matrices |
//| OpType may be only 0 or 1. |
//+------------------------------------------------------------------+
static 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 bs=0;
//--- calculation size
bs=AblasBlockSize();
//--- check
if(n<=bs && k<=bs)
{
RMatrixSyrk2(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
return;
}
//--- check
if(k>=n)
{
//--- Split K
AblasSplitLength(a,k,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
AblasSplitLength(a,n,s1,s2);
//--- check
if(optypea==0 && isUpper)
{
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);
//--- exit the function
return;
}
//--- check
if(optypea==0 && !isUpper)
{
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);
//--- exit the function
return;
}
//--- check
if(optypea!=0 && isUpper)
{
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);
//--- exit the function
return;
}
//--- check
if(optypea!=0 && !isUpper)
{
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);
//--- exit the function
return;
}
}
//--- 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 |
//+------------------------------------------------------------------+
static 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 |
//+------------------------------------------------------------------+
static 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);
}
//+------------------------------------------------------------------+
//| Same as CMatrixGEMM, but for real numbers. |
//| OpType may be only 0 or 1. |
//+------------------------------------------------------------------+
static 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)
{
//--- create variables
int s1=0;
int s2=0;
int bs;
//--- calculation size
bs=AblasBlockSize();
//--- check
if(m<=bs && n<=bs && k<=bs)
{
RMatrixGemmK(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
return;
}
//--- check
if(m>=n && m>=k)
{
//--- A*B = (A1 A2)^T*B
AblasSplitLength(a,m,s1,s2);
//--- check
if(optypea==0)
{
RMatrixGemm(s1,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(s2,n,k,alpha,a,ia+s1,ja,optypea,b,ib,jb,optypeb,beta,c,ic+s1,jc);
}
else
{
RMatrixGemm(s1,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(s2,n,k,alpha,a,ia,ja+s1,optypea,b,ib,jb,optypeb,beta,c,ic+s1,jc);
}
return;
}
//--- check
if(n>=m && n>=k)
{
//--- A*B = A*(B1 B2)
AblasSplitLength(a,n,s1,s2);
//--- check
if(optypeb==0)
{
RMatrixGemm(m,s1,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,s2,k,alpha,a,ia,ja,optypea,b,ib,jb+s1,optypeb,beta,c,ic,jc+s1);
}
else
{
RMatrixGemm(m,s1,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,s2,k,alpha,a,ia,ja,optypea,b,ib+s1,jb,optypeb,beta,c,ic,jc+s1);
}
return;
}
//--- check
if(k>=m && k>=n)
{
//--- A*B = (A1 A2)*(B1 B2)^T
AblasSplitLength(a,k,s1,s2);
//--- check
if(optypea==0 && optypeb==0)
{
RMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,n,s2,alpha,a,ia,ja+s1,optypea,b,ib+s1,jb,optypeb,1.0,c,ic,jc);
}
//--- check
if(optypea==0 && optypeb!=0)
{
RMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,n,s2,alpha,a,ia,ja+s1,optypea,b,ib,jb+s1,optypeb,1.0,c,ic,jc);
}
//--- check
if(optypea!=0 && optypeb==0)
{
RMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,n,s2,alpha,a,ia+s1,ja,optypea,b,ib+s1,jb,optypeb,1.0,c,ic,jc);
}
//--- check
if(optypea!=0 && optypeb!=0)
{
RMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
RMatrixGemm(m,n,s2,alpha,a,ia+s1,ja,optypea,b,ib,jb+s1,optypeb,1.0,c,ic,jc);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level 2 subrotuine |
//+------------------------------------------------------------------+
static 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;
//--- check
if(optypea==0)
{
//--- C=alpha*A*A^H+beta*C
for(i=0;i<n;i++)
{
if(isUpper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
for(j=j1;j<=j2;j++)
{
//--- check
if(alpha!=0 && k>0)
{
v=0.0;
for(i_=ja;i_<ja+k;i_++)
v+=a[ia+i][i_]*a[ia+j][i_];
}
else
v=0;
//--- check
if(beta==0)
c[ic+i].Set(jc+j,alpha*v);
else
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]+alpha*v);
}
}
return;
}
else
{
//--- C=alpha*A^H*A+beta*C
for(i=0;i<n;i++)
{
//--- check
if(isUpper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
//--- check
if(beta==0)
{
for(j=j1;j<=j2;j++)
c[ic+i].Set(jc+j,0);
}
else
{
for(i_=jc+j1;i_<=jc+j2;i_++)
c[ic+i].Set(i_,beta*c[ic+i][i_]);
}
}
for(i=0;i<k;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(isUpper)
{
j1=j;
j2=n-1;
}
else
{
j1=0;
j2=j;
}
//--- change values
v=alpha*a[ia+i][ja+j];
i1_=(ja+j1)-(jc+j1);
for(i_=jc+j1;i_<=jc+j2;i_++)
c[ic+j].Set(i_,c[ic+j][i_]+v*a[ia+i][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Complex ABLASSplitLength |
//+------------------------------------------------------------------+
static void CAblas::AblasInternalSplitLength(const int n,const int nb,
int &n1,int &n2)
{
//--- initialization
int r=0;
n1=0;
n2=0;
//--- check
if(n<=nb)
{
//--- Block size, no further splitting
n1=n;
n2=0;
}
else
{
//--- Greater than block size
if(n%nb!=0)
{
//--- Split remainder
n2=n%nb;
n1=n-n2;
}
else
{
//--- Split on block boundaries
n2=n/2;
n1=n-n2;
//--- check
if(n1%nb==0)
return;
r=nb-n1%nb;
n1+=r;
n2-=r;
}
}
}
//+------------------------------------------------------------------+
//| GEMM kernel |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(m*n==0)
return;
//--- create variables
int i=0;
int j=0;
double v=0;
int i_=0;
int i1_=0;
//--- if K=0, then C=Beta*C
if(k==0)
{
//--- check
if(beta!=1)
{
//--- check
if(beta!=0)
{
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]);
}
else
{
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,0);
}
}
return;
}
//--- check
if(optypea==0 && optypeb!=0)
{
//--- a*b'
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(k==0 || alpha==0)
v=0;
else
{
i1_=jb-ja;
v=0.0;
for(i_=ja;i_<ja+k;i_++)
v+=a[ia+i][i_]*b[ib+j][i_+i1_];
}
//--- check
if(beta==0)
c[ic+i].Set(jc+j,alpha*v);
else
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]+alpha*v);
}
}
return;
}
//--- check
if(optypea==0 && optypeb==0)
{
//--- a*b
for(i=0;i<m;i++)
{
//--- check
if(beta!=0)
{
for(i_=jc;i_<jc+n;i_++)
c[ic+i].Set(i_,beta*c[ic+i][i_]);
}
else
{
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,0);
}
//--- check
if(alpha!=0)
{
for(j=0;j<k;j++)
{
v=alpha*a[ia+i][ja+j];
i1_=jb-jc;
for(i_=jc;i_<jc+n;i_++)
c[ic+i].Set(i_,c[ic+i][i_]+v*b[ib+j][i_+i1_]);
}
}
}
return;
}
//--- check
if(optypea!=0 && optypeb!=0)
{
//--- a`*b`
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(alpha==0)
v=0;
else
{
i1_=(jb)-(ia);
v=0.0;
for(i_=ia;i_<ia+k;i_++)
v+=a[i_][ja+i]*b[ib+j][i_+i1_];
}
//--- check
if(beta==0)
c[ic+i].Set(jc+j,alpha*v);
else
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]+alpha*v);
}
}
return;
}
//--- check
if(optypea!=0 && optypeb==0)
{
//--- a`*b
if(beta==0)
{
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,0);
}
else
{
for(i=0;i<m;i++)
for(i_=jc;i_<jc+n;i_++)
c[ic+i].Set(i_,beta*c[ic+i][i_]);
}
//--- check
if(alpha!=0)
{
for(j=0;j<k;j++)
for(i=0;i<m;i++)
{
v=alpha*a[ia+j][ja+i];
i1_=jb-jc;
for(i_=jc;i_<jc+n;i_++)
c[ic+i].Set(i_,c[ic+i][i_]+v*b[ib+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| 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) |
//| A - destination matrix |
//| IB - submatrix offset (row index) |
//| JB - submatrix offset (column index) |
//+------------------------------------------------------------------+
static 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;i<m;i++)
{
i1_=ja-ib;
for(i_=ib;i_<ib+n;i_++)
b[i_].Set(jb+i,a[ia+i][i_+i1_]);
}
}
else
{
//--- Cache-oblivious recursion
if(m>n)
{
//--- 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) |
//+------------------------------------------------------------------+
static 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;i<m;i++)
{
i1_=ja-ib;
for(i_=ib;i_<ib+n;i_++)
b[i_].Set(jb+i,a[ia+i][i_+i1_]);
}
}
else
{
//--- Cache-oblivious recursion
if(m>n)
{
//--- 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);
}
}
}
//+------------------------------------------------------------------+
//| Copy |
//| 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) |
//+------------------------------------------------------------------+
static void CAblas::CMatrixCopy(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 i_=0;
int i1_=0;
//--- copy
for(i=0;i<m;i++)
{
i1_=ja-jb;
for(i_=jb;i_<jb+n;i_++)
b[ib+i].Set(i_,a[ia+i][i_+i1_]);
}
}
//+------------------------------------------------------------------+
//| Copy |
//| 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) |
//+------------------------------------------------------------------+
static void CAblas::RMatrixCopy(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 i_=0;
int i1_=0;
//--- copy
for(i=0;i<m;i++)
{
i1_=ja-jb;
for(i_=jb;i_<jb+n;i_++)
b[ib+i].Set(i_,a[ia+i][i_+i1_]);
}
}
//+------------------------------------------------------------------+
//| Rank-1 correction: A := A + u*v' |
//| INPUT PARAMETERS: |
//| M - number of rows |
//| N - number of columns |
//| A - target matrix, MxN submatrix is updated |
//| IA - submatrix offset (row index) |
//| JA - submatrix offset (column index) |
//| U - vector #1 |
//| IU - subvector offset |
//| V - vector #2 |
//| IV - subvector offset |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(m==0 || n==0)
return;
//--- create variables
int i=0;
complex s=0;
int i_=0;
int i1_=0;
//--- correction
for(i=0;i<m;i++)
{
s=u[iu+i];
i1_=iv-ja;
for(i_=ja;i_<ja+n;i_++)
a[ia+i].Set(i_,a[ia+i][i_]+s*v[i_+i1_]);
}
}
//+------------------------------------------------------------------+
//| Rank-1 correction: A := A + u*v' |
//| INPUT PARAMETERS: |
//| M - number of rows |
//| N - number of columns |
//| A - target matrix, MxN submatrix is updated |
//| IA - submatrix offset (row index) |
//| JA - submatrix offset (column index) |
//| U - vector #1 |
//| IU - subvector offset |
//| V - vector #2 |
//| IV - subvector offset |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(m==0 || n==0)
return;
//--- create variables
int i=0;
double s=0;
int i_=0;
int i1_=0;
//--- correction
for(i=0;i<m;i++)
{
s=u[iu+i];
i1_=iv-ja;
for(i_=ja;i_<ja+n;i_++)
a[ia+i].Set(i_,a[ia+i][i_]+s*v[i_+i1_]);
}
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static 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)
{
//--- create variables
int i=0;
complex v=0;
int i_=0;
int i1_=0;
//--- check
if(m==0)
return;
//--- check
if(n==0)
{
for(i=0;i<m;i++)
y[iy+i]=0;
//--- exit the function
return;
}
//--- check
if(opa==0)
{
//--- y = A*x
for(i=0;i<m;i++)
{
i1_=ix-ja;
v=0.0;
for(i_=ja;i_<ja+n;i_++)
v+=a[ia+i][i_]*x[i_+i1_];
//--- get y
y[iy+i]=v;
}
//--- exit the function
return;
}
//--- check
if(opa==1)
{
//--- y = A^T*x
for(i=0;i<m;i++)
y[iy+i]=0;
for(i=0;i<n;i++)
{
v=x[ix+i];
i1_=ja-iy;
for(i_=iy;i_<=iy+m-1;i_++)
y[i_]+=v*a[ia+i][i_+i1_];
}
//--- exit the function
return;
}
//--- check
if(opa==2)
{
//--- y = A^H*x
for(i=0;i<m;i++)
y[iy+i]=0;
for(i=0;i<n;i++)
{
v=x[ix+i];
i1_=ja-iy;
for(i_=iy;i_<=iy+m-1;i_++)
y[i_]+=v*CMath::Conj(a[ia+i][i_+i1_]);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Matrix-vector product: y := op(A)*x |
//| INPUT PARAMETERS: |
//| M - number of rows of op(A) |
//| N - number of columns of op(A) |
//| 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 |
//| 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. |
//+------------------------------------------------------------------+
static 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)
{
//--- create variables
int i=0;
double v=0;
int i_=0;
int i1_=0;
//--- check
if(m==0)
return;
//--- check
if(n==0)
{
for(i=0;i<m;i++)
y[iy+i]=0;
//--- exit the function
return;
}
//--- check
if(opa==0)
{
//--- y = A*x
for(i=0;i<m;i++)
{
i1_=ix-ja;
v=0.0;
for(i_=ja;i_<ja+n;i_++)
v+=a[ia+i][i_]*x[i_+i1_];
y[iy+i]=v;
}
//--- exit the function
return;
}
//--- check
if(opa==1)
{
//--- y = A^T*x
for(i=0;i<m;i++)
y[iy+i]=0;
for(i=0;i<n;i++)
{
v=x[ix+i];
i1_=ja-iy;
for(i_=iy;i_<iy+m;i_++)
y[i_]+=v*a[ia+i][i_+i1_];
}
//--- exit the function
return;
}
}
//+------------------------------------------------------------------+
//| 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, 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+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 |
//| C - matrix, actial matrix is stored in |
//| C[I2:I2+M-1,J2:J2+N-1] |
//| I2 - submatrix offset |
//| J2 - submatrix offset |
//+------------------------------------------------------------------+
static 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
complex Alpha(-1,0);
complex Beta(1,0);
int s1=0;
int s2=0;
int bs=AblasComplexBlockSize();
//--- check
if(m<=bs && n<=bs)
{
//--- basic algorithm
CMatrixRightTrsM2(m,n,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
//--- exit the function
return;
}
//--- check
if(m>=n)
{
//--- Split X: X*A = (X1 X2)^T*A
AblasComplexSplitLength(a,m,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
AblasComplexSplitLength(a,n,s1,s2);
//--- check
if(isUpper && 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,Alpha,x,i2,j2,0,a,i1,j1+s1,0,Beta,x,i2,j2+s1);
CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,isUpper,isUnit,optype,x,i2,j2+s1);
//--- exit the function
return;
}
//--- check
if(isUpper && optype!=0)
{
//--- (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,Alpha,x,i2,j2+s1,0,a,i1,j1+s1,optype,Beta,x,i2,j2);
CMatrixRightTrsM(m,s1,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
//--- exit the function
return;
}
//--- check
if(!isUpper && 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,Alpha,x,i2,j2+s1,0,a,i1+s1,j1,0,Beta,x,i2,j2);
CMatrixRightTrsM(m,s1,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
//--- exit the function
return;
}
//--- check
if(!isUpper && optype!=0)
{
//--- (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,Alpha,x,i2,j2,0,a,i1+s1,j1,optype,Beta,x,i2,j2+s1);
CMatrixRightTrsM(m,s2,a,i1+s1,j1+s1,isUpper,isUnit,optype,x,i2,j2+s1);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| 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 |
//+------------------------------------------------------------------+
static 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
complex Alpha(-1,0);
complex Beta(1,0);
int s1=0;
int s2=0;
int bs=AblasComplexBlockSize();
//--- check
if(m<=bs && n<=bs)
{
//--- basic algorithm
CMatrixLeftTrsM2(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)
AblasComplexSplitLength(x,n,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
AblasComplexSplitLength(a,m,s1,s2);
//--- check
if(isUpper && 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,Alpha,a,i1,j1+s1,0,x,i2+s1,j2,0,Beta,x,i2,j2);
CMatrixLeftTrsM(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 )
CMatrixLeftTrsM(s1,n,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
CMatrixGemm(s2,n,s1,Alpha,a,i1,j1+s1,optype,x,i2,j2,0,Beta,x,i2+s1,j2);
CMatrixLeftTrsM(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 )
CMatrixLeftTrsM(s1,n,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
CMatrixGemm(s2,n,s1,Alpha,a,i1+s1,j1,0,x,i2,j2,0,Beta,x,i2+s1,j2);
CMatrixLeftTrsM(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 )
CMatrixLeftTrsM(s2,n,a,i1+s1,j1+s1,isUpper,isUnit,optype,x,i2+s1,j2);
CMatrixGemm(s1,n,s2,Alpha,a,i1+s1,j1,optype,x,i2+s1,j2,0,Beta,x,i2,j2);
CMatrixLeftTrsM(s1,n,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Same as CMatrixRightTRSM, but for real matrices |
//| OpType may be only 0 or 1. |
//+------------------------------------------------------------------+
static 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 bs=AblasBlockSize();
//--- check
if(m<=bs && n<=bs)
{
//--- basic algorithm
RMatrixRightTrsM2(m,n,a,i1,j1,isUpper,isUnit,optype,x,i2,j2);
//--- exit the function
return;
}
//--- check
if(m>=n)
{
//--- Split X: X*A = (X1 X2)^T*A
AblasSplitLength(a,m,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
AblasSplitLength(a,n,s1,s2);
//--- check
if(isUpper && 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);
//--- exit the function
return;
}
//--- check
if(isUpper && optype!=0)
{
//--- (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);
//--- exit the function
return;
}
//--- check
if(!isUpper && 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);
//--- exit the function
return;
}
//--- check
if(!isUpper && optype!=0)
{
//--- (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);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Same as CMatrixLeftTRSM, but for real matrices |
//| OpType may be only 0 or 1. |
//+------------------------------------------------------------------+
static 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);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| 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|
//+------------------------------------------------------------------+
static 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)
{
//--- create variables
complex Alpha(alpha,0);
complex Beta(beta,0);
int s1=0;
int s2=0;
int bs=AblasComplexBlockSize();
//--- check
if(n<=bs && k<=bs)
{
//--- basic algorithm
CMatrixSyrk2(n,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
//--- exit the function
return;
}
//--- check
if(k>=n)
{
//--- Split K
AblasComplexSplitLength(a,k,s1,s2);
//--- check
if(optypea==0)
{
CMatrixSyrk(n,s1,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixSyrk(n,s2,alpha,a,ia,ja+s1,optypea,1.0,c,ic,jc,isUpper);
}
else
{
CMatrixSyrk(n,s1,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixSyrk(n,s2,alpha,a,ia+s1,ja,optypea,1.0,c,ic,jc,isUpper);
}
}
else
{
//--- Split N
AblasComplexSplitLength(a,n,s1,s2);
//--- check
if(optypea==0 && isUpper)
{
CMatrixSyrk(s1,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixGemm(s1,s2,k,Alpha,a,ia,ja,0,a,ia+s1,ja,2,Beta,c,ic,jc+s1);
CMatrixSyrk(s2,k,alpha,a,ia+s1,ja,optypea,beta,c,ic+s1,jc+s1,isUpper);
//--- exit the function
return;
}
//--- check
if(optypea==0 && !isUpper)
{
CMatrixSyrk(s1,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixGemm(s2,s1,k,Alpha,a,ia+s1,ja,0,a,ia,ja,2,Beta,c,ic+s1,jc);
CMatrixSyrk(s2,k,alpha,a,ia+s1,ja,optypea,beta,c,ic+s1,jc+s1,isUpper);
//--- exit the function
return;
}
//--- check
if(optypea!=0 && isUpper)
{
CMatrixSyrk(s1,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixGemm(s1,s2,k,Alpha,a,ia,ja,2,a,ia,ja+s1,0,Beta,c,ic,jc+s1);
CMatrixSyrk(s2,k,alpha,a,ia,ja+s1,optypea,beta,c,ic+s1,jc+s1,isUpper);
//--- exit the function
return;
}
//--- check
if(optypea!=0 && !isUpper)
{
CMatrixSyrk(s1,k,alpha,a,ia,ja,optypea,beta,c,ic,jc,isUpper);
CMatrixGemm(s2,s1,k,Alpha,a,ia,ja+s1,2,a,ia,ja,0,Beta,c,ic+s1,jc);
CMatrixSyrk(s2,k,alpha,a,ia,ja+s1,optypea,beta,c,ic+s1,jc+s1,isUpper);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| 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, conjugate |
//| 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. |
//| INPUT PARAMETERS |
//| N - matrix size, N>0 |
//| 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 |
//+------------------------------------------------------------------+
static 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
if(m<=bs && n<=bs && k<=bs)
{
//--- basic algorithm
CMatrixGemmk(m,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
//--- exit the function
return;
}
//--- check
if(m>=n && m>=k)
{
//--- A*B = (A1 A2)^T*B
AblasComplexSplitLength(a,m,s1,s2);
CMatrixGemm(s1,n,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
//--- check
if(optypea==0)
CMatrixGemm(s2,n,k,alpha,a,ia+s1,ja,optypea,b,ib,jb,optypeb,beta,c,ic+s1,jc);
else
CMatrixGemm(s2,n,k,alpha,a,ia,ja+s1,optypea,b,ib,jb,optypeb,beta,c,ic+s1,jc);
//--- exit the function
return;
}
//--- check
if(n>=m && n>=k)
{
//---A*B = A*(B1 B2)
AblasComplexSplitLength(a,n,s1,s2);
//--- check
if(optypeb==0)
{
CMatrixGemm(m,s1,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,s2,k,alpha,a,ia,ja,optypea,b,ib,jb+s1,optypeb,beta,c,ic,jc+s1);
}
else
{
CMatrixGemm(m,s1,k,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,s2,k,alpha,a,ia,ja,optypea,b,ib+s1,jb,optypeb,beta,c,ic,jc+s1);
}
//--- exit the function
return;
}
//--- check
if(k>=m && k>=n)
{
//--- A*B = (A1 A2)*(B1 B2)^T
AblasComplexSplitLength(a,k,s1,s2);
//--- check
if(optypea==0 && optypeb==0)
{
CMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,n,s2,alpha,a,ia,ja+s1,optypea,b,ib+s1,jb,optypeb,Beta,c,ic,jc);
}
//--- check
if(optypea==0 && optypeb!=0)
{
CMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,n,s2,alpha,a,ia,ja+s1,optypea,b,ib,jb+s1,optypeb,Beta,c,ic,jc);
}
//--- check
if(optypea!=0 && optypeb==0)
{
CMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,n,s2,alpha,a,ia+s1,ja,optypea,b,ib+s1,jb,optypeb,Beta,c,ic,jc);
}
//--- check
if(optypea!=0 && optypeb!=0)
{
CMatrixGemm(m,n,s1,alpha,a,ia,ja,optypea,b,ib,jb,optypeb,beta,c,ic,jc);
CMatrixGemm(m,n,s2,alpha,a,ia+s1,ja,optypea,b,ib,jb+s1,optypeb,Beta,c,ic,jc);
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level 2 variant of CMatrixRightTRSM |
//+------------------------------------------------------------------+
static 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
if(optype==0)
{
//--- X*A^(-1)
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(isUnit)
vd=1;
else
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,x[i2+i][j2+j]/vd);
//--- check
if(j<n-1)
{
vc=x[i2+i][j2+j];
i1_=j1-j2;
for(i_=j2+j+1;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vc*a[i1+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- X*A^(-T)
for(i=0;i<m;i++)
{
for(j=n-1;j>=0;j--)
{
vc=0;
vd=1;
//--- check
if(j<n-1)
{
i1_=j1-j2;
vc=0.0;
for(i_=j2+j+1;i_<j2+n;i_++)
vc+=x[i2+i][i_]*a[i1+j][i_+i1_];
}
//--- check
if(!isUnit)
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vc)/vd);
}
}
//--- exit the function
return;
}
//--- check
if(optype==2)
{
//--- X*A^(-H)
for(i=0;i<m;i++)
{
for(j=n-1;j>=0;j--)
{
vc=0;
vd=1;
//--- check
if(j<n-1)
{
i1_=j1-j2;
vc=0.0;
for(i_=j2+j+1;i_<j2+n;i_++)
vc+=x[i2+i][i_]*CMath::Conj(a[i1+j][i_+i1_]);
}
//--- check
if(!isUnit)
vd=CMath::Conj(a[i1+j][j1+j]);
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vc)/vd);
}
}
//--- exit the function
return;
}
}
else
{
//--- Lower triangular matrix
if(optype==0)
{
//--- X*A^(-1)
for(i=0;i<m;i++)
{
for(j=n-1;j>=0;j--)
{
//--- check
if(isUnit)
vd=1;
else
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,x[i2+i][j2+j]/vd);
//--- check
if(j>0)
{
vc=x[i2+i][j2+j];
i1_=j1-j2;
for(i_=j2;i_<j2+j;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vc*a[i1+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
if(optype==1)
{
//--- X*A^(-T)
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
vc=0;
vd=1;
//--- check
if(j>0)
{
i1_=j1-j2;
vc=0.0;
for(i_=j2;i_<j2+j;i_++)
vc+=x[i2+i][i_]*a[i1+j][i_+i1_];
}
//--- check
if(!isUnit)
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vc)/vd);
}
}
//--- exit the function
return;
}
if(optype==2)
{
//--- X*A^(-H)
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
vc=0;
vd=1;
//--- check
if(j>0)
{
i1_=j1-j2;
vc=0.0;
for(i_=j2;i_<j2+j;i_++)
vc+=x[i2+i][i_]*CMath::Conj(a[i1+j][i_+i1_]);
}
//--- check
if(!isUnit)
vd=CMath::Conj(a[i1+j][j1+j]);
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vc)/vd);
}
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level-2 subroutine |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(n*m==0)
return;
//--- create variables
complex Beta(1,0);
int i=0;
int j=0;
complex vc=0;
complex vd=0;
int i_=0;
//--- General case
if(isUpper)
{
//--- Upper triangular matrix
if(optype==0)
{
//--- A^(-1)*X
for(i=m-1;i>=0;i--)
{
for(j=i+1;j<=m-1;j++)
{
vc=a[i1+i][j1+j];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vc*x[i2+j][i_]);
}
//--- check
if(!isUnit)
{
vd=Beta/a[i1+i][j1+i];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- A^(-T)*X
for(i=0;i<m;i++)
{
//--- check
if(isUnit)
vd=1;
else
vd=Beta/a[i1+i][j1+i];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i+1;j<=m-1;j++)
{
vc=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vc*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
//--- check
if(optype==2)
{
//--- A^(-H)*X
for(i=0;i<m;i++)
{
//--- check
if(isUnit)
vd=1;
else
vd=Beta/CMath::Conj(a[i1+i][j1+i]);
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i+1;j<=m-1;j++)
{
vc=CMath::Conj(a[i1+i][j1+j]);
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vc*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
}
else
{
//--- Lower triangular matrix
if(optype==0)
{
//--- A^(-1)*X
for(i=0;i<m;i++)
{
//--- change x
for(j=0;j<i;j++)
{
vc=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vc*x[i2+j][i_]);
}
//--- check
if(isUnit)
vd=1;
else
vd=Beta/a[i1+j][j1+j];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
}
//--- exit the function
return;
}
if(optype==1)
{
//--- A^(-T)*X
for(i=m-1;i>=0;i--)
{
//--- check
if(isUnit)
vd=1;
else
vd=Beta/a[i1+i][j1+i];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i-1;j>=0;j--)
{
vc=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vc*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
if(optype==2)
{
//--- A^(-H)*X
for(i=m-1;i>=0;i--)
{
//--- check
if(isUnit)
vd=1;
else
vd=Beta/CMath::Conj(a[i1+i][j1+i]);
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i-1;j>=0;j--)
{
vc=CMath::Conj(a[i1+i][j1+j]);
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vc*x[i2+i][i_]);
}
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level 2 subroutine |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(n*m==0)
return;
//--- create variables
int i=0;
int j=0;
double vr=0;
double vd=0;
int i_=0;
int i1_=0;
//--- check
if(isUpper)
{
//--- Upper triangular matrix
if(optype==0)
{
//--- X*A^(-1)
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(isUnit)
vd=1;
else
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,x[i2+i][j2+j]/vd);
//--- check
if(j<n-1)
{
vr=x[i2+i][j2+j];
i1_=j1-j2;
//--- change x
for(i_=j2+j+1;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vr*a[i1+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- X*A^(-T)
for(i=0;i<m;i++)
{
for(j=n-1;j>=0;j--)
{
vr=0;
vd=1;
//--- check
if(j<n-1)
{
i1_=j1-j2;
vr=0.0;
for(i_=j2+j+1;i_<j2+n;i_++)
vr+=x[i2+i][i_]*a[i1+j][i_+i1_];
}
//--- check
if(!isUnit)
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vr)/vd);
}
}
//--- exit the function
return;
}
}
else
{
//--- Lower triangular matrix
if(optype==0)
{
//--- X*A^(-1)
for(i=0;i<m;i++)
{
for(j=n-1;j>=0;j--)
{
//--- check
if(isUnit)
vd=1;
else
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,x[i2+i][j2+j]/vd);
//--- check
if(j>0)
{
vr=x[i2+i][j2+j];
i1_=j1-j2;
//--- change x
for(i_=j2;i_<j2+j;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vr*a[i1+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- X*A^(-T)
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
vr=0;
vd=1;
//--- check
if(j>0)
{
i1_=j1-j2;
vr=0.0;
for(i_=j2;i_<j2+j;i_++)
vr+=x[i2+i][i_]*a[i1+j][i_+i1_];
}
//--- check
if(!isUnit)
vd=a[i1+j][j1+j];
//--- change x
x[i2+i].Set(j2+j,(x[i2+i][j2+j]-vr)/vd);
}
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level 2 subroutine |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(n*m==0)
return;
//--- create variables
int i=0;
int j=0;
double vr=0;
double vd=0;
int i_=0;
//--- check
if(isUpper)
{
//--- Upper triangular matrix
if(optype==0)
{
//--- A^(-1)*X
for(i=m-1;i>=0;i--)
{
for(j=i+1;j<=m-1;j++)
{
vr=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vr*x[i2+j][i_]);
}
//--- check
if(!isUnit)
{
vd=1/a[i1+i][j1+i];
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- A^(-T)*X
for(i=0;i<m;i++)
{
//--- check
if(isUnit)
vd=1;
else
vd=1/a[i1+i][j1+i];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i+1;j<=m-1;j++)
{
vr=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vr*x[i2+i][i_]);
}
}
//--- exit the function
return;
}
}
else
{
//--- Lower triangular matrix
if(optype==0)
{
//--- A^(-1)*X
for(i=0;i<m;i++)
{
for(j=0;j<i;j++)
{
vr=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,x[i2+i][i_]-vr*x[i2+j][i_]);
}
//--- check
if(isUnit)
vd=1;
else
vd=1/a[i1+j][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
}
//--- exit the function
return;
}
//--- check
if(optype==1)
{
//--- A^(-T)*X
for(i=m-1;i>=0;i--)
{
//--- check
if(isUnit)
vd=1;
else
vd=1/a[i1+i][j1+i];
//--- change x
for(i_=j2;i_<j2+n;i_++)
x[i2+i].Set(i_,vd*x[i2+i][i_]);
for(j=i-1;j>=0;j--)
{
vr=a[i1+i][j1+j];
for(i_=j2;i_<j2+n;i_++)
x[i2+j].Set(i_,x[i2+j][i_]-vr*x[i2+i][i_]);
}
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Level 2 subroutine |
//+------------------------------------------------------------------+
static void CAblas::CMatrixSyrk2(const int n,const int k,const double alpha,
const 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)
{
//--- check
if((alpha==0 || k==0) && beta==1)
return;
//--- create variables
complex Alpha(alpha,0);
complex Beta(beta,0);
complex Zero(0,0);
int i=0;
int j=0;
int j1=0;
int j2=0;
complex v=0;
int i_=0;
int i1_=0;
//--- check
if(optypea==0)
{
//--- C = alpha*A*A^H+beta*C
for(i=0;i<n;i++)
{
//--- check
if(isUpper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
//--- cycle
for(j=j1;j<=j2;j++)
{
//--- check
if(alpha!=0 && k>0)
{
v=0.0;
for(i_=ja;i_<=ja+k-1;i_++)
v+=a[ia+i][i_]*CMath::Conj(a[ia+j][i_]);
}
else
v=0;
//--- check
if(beta==0)
c[ic+i].Set(jc+j,Alpha*v);
else
c[ic+i].Set(jc+j,Beta*c[ic+i][jc+j]+Alpha*v);
}
}
//--- exit the function
return;
}
else
{
//--- C = alpha*A^H*A+beta*C
for(i=0;i<n;i++)
{
//--- check
if(isUpper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
//--- check
if(beta==0)
{
for(j=j1;j<=j2;j++)
c[ic+i].Set(jc+j,Zero);
}
else
{
for(i_=jc+j1;i_<=jc+j2;i_++)
c[ic+i].Set(i_,Beta*c[ic+i][i_]);
}
}
//--- cycle
for(i=0;i<k;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(isUpper)
{
j1=j;
j2=n-1;
}
else
{
j1=0;
j2=j;
}
v=Alpha*CMath::Conj(a[ia+i][ja+j]);
i1_=(ja+j1)-(jc+j1);
for(i_=jc+j1;i_<=jc+j2;i_++)
c[ic+j].Set(i_,c[ic+j][i_]+v*a[ia+i][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| GEMM kernel |
//+------------------------------------------------------------------+
static void CAblas::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)
{
//--- check
if(m*n==0)
return;
//--- create variables
complex Zero(0,0);
int i=0;
int j=0;
complex v=0;
int i_=0;
int i1_=0;
//--- special case
if(k==0)
{
//--- check
if(beta!=Zero)
{
//--- get c
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]);
}
else
{
//--- get c
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,Zero);
}
//--- exit the function
return;
}
//--- General case
if(optypea==0 && optypeb!=0)
{
//--- A*B'
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(k==0 || alpha==Zero)
v=0;
else
{
//--- check
if(optypeb==1)
{
i1_=(jb)-(ja);
v=0.0;
for(i_=ja;i_<=ja+k-1;i_++)
v+=a[ia+i][i_]*b[ib+j][i_+i1_];
}
else
{
i1_=(jb)-(ja);
v=0.0;
for(i_=ja;i_<=ja+k-1;i_++)
v+=a[ia+i][i_]*CMath::Conj(b[ib+j][i_+i1_]);
}
}
//--- check
if(beta==Zero)
c[ic+i].Set(jc+j,alpha*v);
else
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]+alpha*v);
}
}
//--- exit the function
return;
}
if(optypea==0 && optypeb==0)
{
//--- A*B
for(i=0;i<m;i++)
{
//--- check
if(beta!=Zero)
{
for(i_=jc;i_<=jc+n-1;i_++)
c[ic+i].Set(i_,beta*c[ic+i][i_]);
}
else
{
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,Zero);
}
//--- check
if(alpha!=Zero)
{
for(j=0;j<=k-1;j++)
{
v=alpha*a[ia+i][ja+j];
i1_=(jb)-(jc);
for(i_=jc;i_<=jc+n-1;i_++)
c[ic+i].Set(i_,c[ic+i][i_]+v*b[ib+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//--- check
if(optypea!=0 && optypeb!=0)
{
//--- A'*B'
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(alpha==Zero)
v=0;
else
{
//--- check
if(optypea==1)
{
//--- check
if(optypeb==1)
{
i1_=(jb)-(ia);
v=0.0;
for(i_=ia;i_<=ia+k-1;i_++)
v+=a[i_][ja+i]*b[ib+j][i_+i1_];
}
else
{
i1_=(jb)-(ia);
v=0.0;
for(i_=ia;i_<=ia+k-1;i_++)
v+=a[i_][ja+i]*CMath::Conj(b[ib+j][i_+i1_]);
}
}
else
{
//--- check
if(optypeb==1)
{
i1_=(jb)-(ia);
v=0.0;
for(i_=ia;i_<=ia+k-1;i_++)
v+=CMath::Conj(a[i_][ja+i])*b[ib+j][i_+i1_];
}
else
{
i1_=(jb)-(ia);
v=0.0;
for(i_=ia;i_<=ia+k-1;i_++)
v+=CMath::Conj(a[i_][ja+i])*CMath::Conj(b[ib+j][i_+i1_]);
}
}
}
//--- check
if(beta==Zero)
c[ic+i].Set(jc+j,alpha*v);
else
c[ic+i].Set(jc+j,beta*c[ic+i][jc+j]+alpha*v);
}
}
//--- exit the function
return;
}
//--- check
if(optypea!=0 && optypeb==0)
{
//--- A'*B
if(beta==Zero)
{
for(i=0;i<m;i++)
for(j=0;j<n;j++)
c[ic+i].Set(jc+j,Zero);
}
else
{
for(i=0;i<m;i++)
for(i_=jc;i_<=jc+n-1;i_++)
c[ic+i].Set(i_,beta*c[ic+i][i_]);
}
//--- check
if(alpha!=Zero)
{
for(j=0;j<=k-1;j++)
for(i=0;i<m;i++)
{
//--- check
if(optypea==1)
v=alpha*a[ia+j][ja+i];
else
v=alpha*CMath::Conj(a[ia+j][ja+i]);
i1_=(jb)-(jc);
for(i_=jc;i_<=jc+n-1;i_++)
c[ic+i].Set(i_,c[ic+i][i_]+v*b[ib+j][i_+i1_]);
}
}
}
//--- exit the function
return;
}
//+------------------------------------------------------------------+
//| Orthogonal factorizations |
//+------------------------------------------------------------------+
class COrtFac
{
private:
//--- private methods
static void RMatrixQRBaseCase(CMatrixDouble &a,const int m,const int n,double &work[],double &t[],double &tau[]);
static void RMatrixLQBaseCase(CMatrixDouble &a,const int m,const int n,double &work[],double &t[],double &tau[]);
static void CMatrixQRBaseCase(CMatrixComplex &a,const int m,const int n,complex &work[],complex &t[],complex &tau[]);
static void CMatrixLQBaseCase(CMatrixComplex &a,const int m,const int n,complex &work[],complex &t[],complex &tau[]);
static void RMatrixBlockReflector(CMatrixDouble &a,double &tau[],const bool columnwisea,const int lengtha,const int blocksize,CMatrixDouble &t,double &work[]);
static void CMatrixBlockReflector(CMatrixComplex &a,complex &tau[],const bool columnwisea,const int lengtha,const int blocksize,CMatrixComplex &t,complex &work[]);
public:
//--- constructor, destructor
COrtFac(void);
~COrtFac(void);
//--- real matrix
static void RMatrixQR(CMatrixDouble &a,const int m,const int n,double &tau[]);
static void RMatrixLQ(CMatrixDouble &a,const int m,const int n,double &tau[]);
static void RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n,double &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 RMatrixLQUnpackL(CMatrixDouble &a,const int m,const int n,CMatrixDouble &l);
static void RMatrixBD(CMatrixDouble &a,const int m,const int n,double &tauq[],double &taup[]);
static void RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n,double &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 RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n,double &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 RMatrixBDUnpackDiagonals(CMatrixDouble &b,const int m,const int n,bool &isupper,double &d[],double &e[]);
static void RMatrixHessenberg(CMatrixDouble &a,const int n,double &tau[]);
static void RMatrixHessenbergUnpackQ(CMatrixDouble &a,const int n,double &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 SMatrixTDUnpackQ(CMatrixDouble &a,const int n,const bool isupper,double &tau[],CMatrixDouble &q);
//--- complex matrix
static void CMatrixQR(CMatrixComplex &a,const int m,const int n,complex &tau[]);
static void CMatrixLQ(CMatrixComplex &a,const int m,const int n,complex &tau[]);
static void CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n,complex &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 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 HMatrixTDUnpackQ(CMatrixComplex &a,const int n,const bool isupper,complex &tau[],CMatrixComplex &q);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
COrtFac::COrtFac(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
COrtFac::~COrtFac(void)
{
}
//+------------------------------------------------------------------+
//| 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). |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixQR(CMatrixDouble &a,const int m,const int n,double &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
double work[];
double t[];
double taubuf[];
//--- create matrix
CMatrixDouble tmpa;
CMatrixDouble tmpt;
CMatrixDouble tmpr;
//--- allocation
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(tau,minmn);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(m,CAblas::AblasBlockSize());
tmpt.Resize(CAblas::AblasBlockSize(),2*CAblas::AblasBlockSize());
tmpr.Resize(2*CAblas::AblasBlockSize(),n);
//--- Blocked code
while(blockstart!=minmn)
{
//--- Determine block size
blocksize=minmn-blockstart;
if(blocksize>CAblas::AblasBlockSize())
blocksize=CAblas::AblasBlockSize();
//--- 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[i_]=taubuf[i_+i1_];
//--- check
if(blockstart+blocksize<=n-1)
{
//--- 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(n-blockstart-blocksize>=2*CAblas::AblasBlockSize() || rowscount>=4*CAblas::AblasBlockSize())
{
//--- 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;i<blocksize;i++)
{
i1_=i-1;
for(i_=1;i_<=rowscount-i;i_++)
t[i_]=tmpa[i_+i1_][i];
t[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheLeft(a,taubuf[i],t,blockstart+i,m-1,blockstart+blocksize,n-1,work);
}
}
}
//--- change value
blockstart=blockstart+blocksize;
}
}
//+------------------------------------------------------------------+
//| LQ 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 L and Q 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,N)-1]. |
//| Matrix A is represented as A = LQ, where Q is an orthogonal |
//| matrix of size MxM, L - lower triangular (or lower trapezoid) |
//| matrix of size M x N. |
//| The elements of matrix L are located on and below the main |
//| diagonal of matrix A. The elements which are located in Tau |
//| array and above 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(k-1)*H(k-2)*...*H(1)*H(0), |
//| where k = min(m,n), and each H(i) is of 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:n-1) stored in A(i,i+1:n-1). |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixLQ(CMatrixDouble &a,const int m,const int n,double &tau[])
{
//--- check
if(m<=0 || n<=0)
return;
//--- create variables
int minmn=MathMin(m,n);
int blockstart=0;
int blocksize=0;
int columnscount=0;
int i=0;
int i_=0;
int i1_=0;
//--- create arrays
double work[];
double t[];
double taubuf[];
//--- create matrix
CMatrixDouble tmpa;
CMatrixDouble tmpt;
CMatrixDouble tmpr;
//--- allocation
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(tau,minmn);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(CAblas::AblasBlockSize(),n);
tmpt.Resize(CAblas::AblasBlockSize(),2*CAblas::AblasBlockSize());
tmpr.Resize(m,2*CAblas::AblasBlockSize());
//--- Blocked code
while(blockstart!=minmn)
{
//--- Determine block size
blocksize=minmn-blockstart;
if(blocksize>CAblas::AblasBlockSize())
blocksize=CAblas::AblasBlockSize();
//--- 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[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;i<blocksize;i++)
{
i1_=i-1;
for(i_=1;i_<=columnscount-i;i_++)
t[i_]=tmpa[i][i_+i1_];
t[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheRight(a,taubuf[i],t,blockstart+blocksize,m-1,blockstart+i,n-1,work);
}
}
}
//--- change value
blockstart=blockstart+blocksize;
}
}
//+------------------------------------------------------------------+
//| QR decomposition of a rectangular complex 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 |
//| Tau - array of scalar factors which are used to form |
//| matrix Q. Array whose indexes range within |
//| [0.. Min(M,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 MxN. |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| September 30, 1994 |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixQR(CMatrixComplex &a,const int m,const int n,complex &tau[])
{
//--- check
if(m<=0 || n<=0)
return;
//--- create arrays
complex work[];
complex t[];
complex taubuf[];
//--- create matrix
CMatrixComplex tmpa;
CMatrixComplex tmpt;
CMatrixComplex tmpr;
//--- 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;
complex One(1,0);
complex Alpha(1,0);
complex Beta(0,0);
//--- allocation
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(tau,minmn);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(m,CAblas::AblasComplexBlockSize());
tmpt.Resize(CAblas::AblasComplexBlockSize(),CAblas::AblasComplexBlockSize());
tmpr.Resize(2*CAblas::AblasComplexBlockSize(),n);
//--- Blocked code
while(blockstart!=minmn)
{
//--- Determine block size
blocksize=minmn-blockstart;
if(blocksize>CAblas::AblasComplexBlockSize())
blocksize=CAblas::AblasComplexBlockSize();
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_<=blockstart+blocksize-1;i_++)
tau[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<=n-1)
{
//--- check
if(n-blockstart-blocksize>=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;i<blocksize;i++)
{
i1_=i-1;
for(i_=1;i_<=rowscount-i;i_++)
t[i_]=tmpa[i_+i1_][i];
t[1]=One;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(a,CMath::Conj(taubuf[i]),t,blockstart+i,m-1,blockstart+blocksize,n-1,work);
}
}
}
//--- change value
blockstart=blockstart+blocksize;
}
}
//+------------------------------------------------------------------+
//| LQ decomposition of a rectangular complex 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 L in compact form |
//| Tau - array of scalar factors which are used to form |
//| matrix Q. Array whose indexes range within |
//| [0.. Min(M,N)-1] |
//| Matrix A is represented as A = LQ, where Q is an orthogonal |
//| matrix of size MxM, L - lower triangular (or lower trapezoid) |
//| matrix of size MxN. |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| September 30, 1994 |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixLQ(CMatrixComplex &a,const int m,const int n,complex &tau[])
{
//--- check
if(m<=0 || n<=0)
return;
//--- create arrays
complex work[];
complex t[];
complex taubuf[];
//--- create matrix
CMatrixComplex tmpa;
CMatrixComplex tmpt;
CMatrixComplex tmpr;
//--- create variables
int minmn=MathMin(m,n);
int blockstart=0;
int blocksize=0;
int columnscount=0;
int i=0;
int i_=0;
int i1_=0;
complex One(1,0);
complex Alpha(1,0);
complex Beta(0,0);
//--- allocation
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(tau,minmn);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(CAblas::AblasComplexBlockSize(),n);
tmpt.Resize(CAblas::AblasComplexBlockSize(),CAblas::AblasComplexBlockSize());
tmpr.Resize(m,2*CAblas::AblasComplexBlockSize());
//--- Blocked code
while(blockstart!=minmn)
{
//--- Determine block size
blocksize=minmn-blockstart;
if(blocksize>CAblas::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[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::AblasComplexBlockSize())
{
//--- 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<blocksize;i++)
{
i1_=i-1;
for(i_=1;i_<=columnscount-i;i_++)
t[i_]=CMath::Conj(tmpa[i][i_+i1_]);
t[1]=One;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheRight(a,taubuf[i],t,blockstart+blocksize,m-1,blockstart+i,n-1,work);
}
}
}
//--- change value
blockstart=blockstart+blocksize;
}
}
//+------------------------------------------------------------------+
//| Partial unpacking of matrix Q 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. |
//| 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. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixQRUnpackQ(CMatrixDouble &a,const int m,const int n,
double &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
double work[];
double t[];
double taubuf[];
//--- create matrix
CMatrixDouble tmpa;
CMatrixDouble tmpt;
CMatrixDouble tmpr;
//--- create variables
int minmn=MathMin(m,n);
int refcnt=MathMin(minmn,qcolumns);
int blockstart=CAblas::AblasBlockSize()*(refcnt/CAblas::AblasBlockSize());
int blocksize=refcnt-blockstart;
int rowscount=0;
int i=0;
int j=0;
int i_=0;
int i1_=0;
//--- allocation
q.Resize(m,qcolumns);
//--- identity matrix
for(i=0;i<m;i++)
{
for(j=0;j<qcolumns;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- allocation
ArrayResizeAL(work,MathMax(m,qcolumns)+1);
ArrayResizeAL(t,MathMax(m,qcolumns)+1);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(m,CAblas::AblasBlockSize());
tmpt.Resize(CAblas::AblasBlockSize(),2*CAblas::AblasBlockSize());
tmpr.Resize(2*CAblas::AblasBlockSize(),qcolumns);
//--- Blocked code
while(blockstart>=0)
{
rowscount=m-blockstart;
//--- Copy current block
CAblas::RMatrixCopy(rowscount,blocksize,a,blockstart,blockstart,tmpa,0,0);
i1_=blockstart;
for(i_=0;i_<blocksize;i_++)
taubuf[i_]=tau[i_+i1_];
//--- Update, 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(qcolumns>=2*CAblas::AblasBlockSize())
{
//--- 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_=1;i_<=rowscount-i;i_++)
{
t[i_]=tmpa[i_+i1_][i];
}
t[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheLeft(q,taubuf[i],t,blockstart+i,m-1,0,qcolumns-1,work);
}
}
//--- change value
blockstart=blockstart-CAblas::AblasBlockSize();
blocksize=CAblas::AblasBlockSize();
}
}
//+------------------------------------------------------------------+
//| 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]. |
//+------------------------------------------------------------------+
static 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;
//--- allocation
r.Resize(m,n);
//--- Prepare matrix
for(i=0;i<n;i++)
r[0].Set(i,0);
for(i=1;i<m;i++)
{
for(i_=0;i_<n;i_++)
r[i].Set(i_,r[0][i_]);
}
//--- get result
for(i=0;i<k;i++)
{
for(i_=i;i_<n;i_++)
r[i].Set(i_,a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixLQUnpackQ(CMatrixDouble &a,const int m,const int n,
double &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
double work[];
double t[];
double taubuf[];
//--- create matrix
CMatrixDouble tmpa;
CMatrixDouble tmpt;
CMatrixDouble tmpr;
//--- create variables
int minmn=MathMin(m,n);
int refcnt=MathMin(minmn,qrows);
int blockstart=CAblas::AblasBlockSize()*(refcnt/CAblas::AblasBlockSize());
int blocksize=refcnt-blockstart;
int columnscount=0;
int i=0;
int j=0;
int i_=0;
int i1_=0;
//--- allocation
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(CAblas::AblasBlockSize(),n);
tmpt.Resize(CAblas::AblasBlockSize(),2*CAblas::AblasBlockSize());
tmpr.Resize(qrows,2*CAblas::AblasBlockSize());
q.Resize(qrows,n);
//--- identity matrix
for(i=0;i<=qrows-1;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- Blocked code
while(blockstart>=0)
{
columnscount=n-blockstart;
//--- Copy submatrix
CAblas::RMatrixCopy(blocksize,columnscount,a,blockstart,blockstart,tmpa,0,0);
i1_=blockstart;
for(i_=0;i_<blocksize;i_++)
taubuf[i_]=tau[i_+i1_];
//--- 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*CAblas::AblasBlockSize())
{
//--- 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_=1;i_<=columnscount-i;i_++)
t[i_]=tmpa[i][i_+i1_];
t[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheRight(q,taubuf[i],t,0,qrows-1,blockstart+i,n-1,work);
}
}
//--- change value
blockstart=blockstart-CAblas::AblasBlockSize();
blocksize=CAblas::AblasBlockSize();
}
}
//+------------------------------------------------------------------+
//| 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]. |
//+------------------------------------------------------------------+
static 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;
//--- allocation
l.Resize(m,n);
//--- Prepare matrix
for(i=0;i<n;i++)
l[0].Set(i,0);
for(i=1;i<m;i++)
{
for(i_=0;i_<n;i_++)
l[i].Set(i_,l[0][i_]);
}
//--- get result
for(i=0;i<m;i++)
{
k=MathMin(i,n-1);
for(i_=0;i_<=k;i_++)
l[i].Set(i_,a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Partial unpacking of matrix Q from QR decomposition of a complex |
//| matrix A. |
//| Input parameters: |
//| A - matrices Q and R in compact form. |
//| Output of CMatrixQR subroutine . |
//| M - number of rows in matrix A. M>=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. |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixQRUnpackQ(CMatrixComplex &a,const int m,const int n,
complex &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
complex work[];
complex t[];
complex taubuf[];
//--- create matrix
CMatrixComplex tmpa;
CMatrixComplex tmpt;
CMatrixComplex tmpr;
//--- create variables
int minmn=MathMin(m,n);
int refcnt=MathMin(minmn,qcolumns);
int blockstart=CAblas::AblasComplexBlockSize()*(refcnt/CAblas::AblasComplexBlockSize());
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
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(m,CAblas::AblasComplexBlockSize());
tmpt.Resize(CAblas::AblasComplexBlockSize(),CAblas::AblasComplexBlockSize());
tmpr.Resize(2*CAblas::AblasComplexBlockSize(),qcolumns);
q.Resize(m,qcolumns);
for(i=0;i<m;i++)
{
for(j=0;j<qcolumns;j++)
{
if(i==j)
q[i].Set(j,One);
else
q[i].Set(j,Zero);
}
}
//--- Blocked code
while(blockstart>=0)
{
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);
i1_=blockstart;
for(i_=0;i_<blocksize;i_++)
taubuf[i_]=tau[i_+i1_];
//--- 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(qcolumns>=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'
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[i_]=tmpa[i_+i1_][i];
t[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(q,taubuf[i],t,blockstart+i,m-1,0,qcolumns-1,work);
}
}
//--- change value
blockstart=blockstart-CAblas::AblasComplexBlockSize();
blocksize=CAblas::AblasComplexBlockSize();
}
}
//+------------------------------------------------------------------+
//| 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]. |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixQRUnpackR(CMatrixComplex &a,const int m,const int n,CMatrixComplex &r)
{
//--- check
if(m<=0 || n<=0)
return;
//--- create variables
complex Zero(0,0);
int i=0;
int k=MathMin(m,n);
int i_=0;
//--- allocation
r.Resize(m,n);
//--- Prepare matrix
for(i=0;i<n;i++)
r[0].Set(i,Zero);
for(i=1;i<m;i++)
{
for(i_=0;i_<n;i_++)
r[i].Set(i_,r[0][i_]);
}
//--- get result
for(i=0;i<k;i++)
{
for(i_=i;i_<n;i_++)
r[i].Set(i_,a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Partial unpacking of matrix Q from LQ decomposition of a complex |
//| matrix A. |
//| Input parameters: |
//| A - matrices Q and R in compact form. |
//| Output of CMatrixLQ subroutine. |
//| M - number of rows in matrix A. M>=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. |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixLQUnpackQ(CMatrixComplex &a,const int m,const int n,
complex &tau[],const int qrows,CMatrixComplex &q)
{
//--- check
if(m<=0 || n<=0)
return;
//--- create arrays
complex work[];
complex t[];
complex taubuf[];
//--- create matrix
CMatrixComplex tmpa;
CMatrixComplex tmpt;
CMatrixComplex tmpr;
//--- create variables
int minmn=MathMin(m,n);
int refcnt=MathMin(minmn,qrows);
int blockstart=CAblas::AblasComplexBlockSize()*(refcnt/CAblas::AblasComplexBlockSize());
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
ArrayResizeAL(work,MathMax(m,n)+1);
ArrayResizeAL(t,MathMax(m,n)+1);
ArrayResizeAL(taubuf,minmn);
//--- allocation
tmpa.Resize(CAblas::AblasComplexBlockSize(),n);
tmpt.Resize(CAblas::AblasComplexBlockSize(),CAblas::AblasComplexBlockSize());
tmpr.Resize(qrows,2*CAblas::AblasComplexBlockSize());
q.Resize(qrows,n);
for(i=0;i<=qrows-1;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
q[i].Set(j,One);
else
q[i].Set(j,Zero);
}
}
//--- Blocked code
while(blockstart>=0)
{
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);
i1_=blockstart;
for(i_=0;i_<blocksize;i_++)
taubuf[i_]=tau[i_+i1_];
//--- 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*CAblas::AblasComplexBlockSize())
{
//--- 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_=1;i_<=columnscount-i;i_++)
t[i_]=CMath::Conj(tmpa[i][i_+i1_]);
t[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheRight(q,CMath::Conj(taubuf[i]),t,0,qrows-1,blockstart+i,n-1,work);
}
}
//--- change value
blockstart=blockstart-CAblas::AblasComplexBlockSize();
blocksize=CAblas::AblasComplexBlockSize();
}
}
//+------------------------------------------------------------------+
//| 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]. |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixLQUnpackL(CMatrixComplex &a,const int m,const int n,CMatrixComplex &l)
{
//--- check
if(m<=0 || n<=0)
return;
//--- create variables
complex Zero(0,0);
int i=0;
int k=0;
int i_=0;
//--- allocation
l.Resize(m,n);
//--- Prepare matrix
for(i=0;i<n;i++)
l[0].Set(i,Zero);
for(i=1;i<m;i++)
{
for(i_=0;i_<n;i_++)
l[i].Set(i_,l[0][i_]);
}
//--- get result
for(i=0;i<m;i++)
{
k=MathMin(i,n-1);
for(i_=0;i_<=k;i_++)
l[i].Set(i_,a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Reduction of a rectangular matrix to bidiagonal form |
//| The algorithm reduces the rectangular matrix A to bidiagonal |
//| form by orthogonal transformations P and Q: A = Q*B*P. |
//| Input parameters: |
//| A - source matrix. 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 Q, B, P in compact form (see below). |
//| TauQ - scalar factors which are used to form matrix Q. |
//| TauP - scalar factors which are used to form matrix P. |
//| The main diagonal and one of the secondary diagonals of matrix A |
//| are replaced with bidiagonal matrix B. Other elements contain |
//| elementary reflections which form MxM matrix Q and NxN matrix P, |
//| respectively. |
//| If M>=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, B is the lower bidiagonal MxN matrix and is stored in the|
//| corresponding elements of matrix A. Q = H(0)*H(1)*...*H(m-2), |
//| where H(i) = 1 - tau*v*v', tau is stored in TauQ, v(0:i)=0, |
//| v(i+1)=1, v(i+2:m-1) is stored in elements A(i+2:m-1,i). |
//| P = G(0)*G(1)*...*G(m-1), G(i) = 1-tau*u*u', tau is stored in |
//| TauP, u(0:i-1)=0, u(i)=1, u(i+1:n-1) is stored in A(i,i+1:n-1). |
//| EXAMPLE: |
//| m=6, n=5 (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. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixBD(CMatrixDouble &a,const int m,const int n,double &tauq[],double &taup[])
{
//--- check
if(n<=0 || m<=0)
return;
//--- create arrays
double work[];
double t[];
//--- create variables
int minmn=0;
int maxmn=MathMax(m,n);
int i=0;
double ltau=0;
int i_=0;
int i1_=0;
//--- allocation
ArrayResizeAL(work,maxmn+1);
ArrayResizeAL(t,maxmn+1);
//--- check
if(m>=n)
{
ArrayResizeAL(tauq,n);
ArrayResizeAL(taup,n);
}
else
{
ArrayResizeAL(tauq,m);
ArrayResizeAL(taup,m);
}
//--- check
if(m>=n)
{
//--- Reduce to upper bidiagonal form
for(i=0;i<n;i++)
{
//--- Generate elementary reflector H(i) to annihilate A(i+1:m-1,i)
i1_=i-1;
for(i_=1;i_<=m-i;i_++)
t[i_]=a[i_+i1_][i];
CReflections::GenerateReflection(t,m-i,ltau);
tauq[i]=ltau;
i1_=1-i;
for(i_=i;i_<m;i_++)
a[i_].Set(i,t[i_+i1_]);
t[1]=1;
//--- Apply H(i) to A(i:m-1,i+1:n-1) from the left
CReflections::ApplyReflectionFromTheLeft(a,ltau,t,i,m-1,i+1,n-1,work);
//--- check
if(i<n-1)
{
//--- Generate elementary reflector G(i) to annihilate
//--- A(i,i+2:n-1)
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i][i_+i1_];
CReflections::GenerateReflection(t,n-1-i,ltau);
taup[i]=ltau;
i1_=-i;
for(i_=i+1;i_<n;i_++)
a[i].Set(i_,t[i_+i1_]);
t[1]=1;
//--- Apply G(i) to A(i+1:m-1,i+1:n-1) from the right
CReflections::ApplyReflectionFromTheRight(a,ltau,t,i+1,m-1,i+1,n-1,work);
}
else
taup[i]=0;
}
}
else
{
//--- Reduce to lower bidiagonal form
for(i=0;i<m;i++)
{
//--- Generate elementary reflector G(i) to annihilate A(i,i+1:n-1)
i1_=i-1;
for(i_=1;i_<=n-i;i_++)
t[i_]=a[i][i_+i1_];
CReflections::GenerateReflection(t,n-i,ltau);
taup[i]=ltau;
i1_=1-i;
for(i_=i;i_<n;i_++)
a[i].Set(i_,t[i_+i1_]);
t[1]=1;
//--- Apply G(i) to A(i+1:m-1,i:n-1) from the right
CReflections::ApplyReflectionFromTheRight(a,ltau,t,i+1,m-1,i,n-1,work);
//--- check
if(i<m-1)
{
//--- Generate elementary reflector H(i) to annihilate
//--- A(i+2:m-1,i)
i1_=i;
for(i_=1;i_<m-i;i_++)
t[i_]=a[i_+i1_][i];
CReflections::GenerateReflection(t,m-1-i,ltau);
tauq[i]=ltau;
i1_=-i;
for(i_=i+1;i_<m;i_++)
a[i_].Set(i,t[i_+i1_]);
t[1]=1;
//--- Apply H(i) to A(i+1:m-1,i+1:n-1) from the left
CReflections::ApplyReflectionFromTheLeft(a,ltau,t,i+1,m-1,i+1,n-1,work);
}
else
tauq[i]=0;
}
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix Q which reduces a matrix to bidiagonal form. |
//| 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. |
//| QColumns - required number of columns in matrix Q. |
//| M>=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. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixBDUnpackQ(CMatrixDouble &qp,const int m,const int n,
double &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;
//--- create variables
int i=0;
int j=0;
//--- allocation
q.Resize(m,qcolumns);
//--- identity matrix
for(i=0;i<m;i++)
{
for(j=0;j<qcolumns;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- 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. |
//+------------------------------------------------------------------+
static 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)
{
//--- 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
double v[];
double work[];
//--- initialization
mx=MathMax(m,n);
mx=MathMax(mx,zrows);
mx=MathMax(mx,zcolumns);
//--- allocation
ArrayResizeAL(v,mx+1);
ArrayResizeAL(work,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_=1;i_<=m-i;i_++)
v[i_]=qp[i_+i1_][i];
v[1]=1;
//--- check
if(fromtheright)
CReflections::ApplyReflectionFromTheRight(z,tauq[i],v,0,zrows-1,i,m-1,work);
else
CReflections::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_=1;i_<=m-i-1;i_++)
v[i_]=qp[i_+i1_][i];
v[1]=1;
//--- check
if(fromtheright)
CReflections::ApplyReflectionFromTheRight(z,tauq[i],v,0,zrows-1,i+1,m-1,work);
else
CReflections::ApplyReflectionFromTheLeft(z,tauq[i],v,i+1,m-1,0,zcolumns-1,work);
i=i+istep;
}
while(i!=i2+istep);
}
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix P which reduces matrix A to bidiagonal form. |
//| The subroutine returns transposed matrix P. |
//| 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. |
//| TAUP - scalar factors which are used to form P. |
//| Output of ToBidiagonal subroutine. |
//| PTRows - required number of rows of matrix P^T. |
//| N >= 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. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixBDUnpackPT(CMatrixDouble &qp,const int m,const int n,
double &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;
//--- create variables
int i=0;
int j=0;
//--- allocation
pt.Resize(ptrows,n);
//--- prepare
for(i=0;i<=ptrows-1;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
pt[i].Set(j,1);
else
pt[i].Set(j,0);
}
}
//--- 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. |
//+------------------------------------------------------------------+
static 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)
{
//--- 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
double v[];
double 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
ArrayResizeAL(v,mx+1);
ArrayResizeAL(work,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_=1;i_<n-i;i_++)
v[i_]=qp[i][i_+i1_];
v[1]=1;
//--- check
if(fromtheright)
CReflections::ApplyReflectionFromTheRight(z,taup[i],v,0,zrows-1,i+1,n-1,work);
else
CReflections::ApplyReflectionFromTheLeft(z,taup[i],v,i+1,n-1,0,zcolumns-1,work);
i=i+istep;
}
while(i!=i2+istep);
}
}
else
{
//--- setup
if(fromtheright)
{
i1=m-1;
i2=0;
istep=-1;
}
else
{
i1=0;
i2=m-1;
istep=1;
}
//--- check
if(!dotranspose)
{
i=i1;
i1=i2;
i2=i;
istep=-istep;
}
//--- Process
i=i1;
do
{
i1_=i-1;
for(i_=1;i_<=n-i;i_++)
v[i_]=qp[i][i_+i1_];
v[1]=1;
//--- check
if(fromtheright)
CReflections::ApplyReflectionFromTheRight(z,taup[i],v,0,zrows-1,i,n-1,work);
else
CReflections::ApplyReflectionFromTheLeft(z,taup[i],v,i,n-1,0,zcolumns-1,work);
i=i+istep;
}
while(i!=i2+istep);
}
}
//+------------------------------------------------------------------+
//| Unpacking of the main and secondary diagonals of bidiagonal |
//| decomposition of matrix A. |
//| Input parameters: |
//| B - output of RMatrixBD subroutine. |
//| M - number of rows in matrix B. |
//| N - number of columns in matrix B. |
//| Output parameters: |
//| IsUpper - True, if the matrix is upper bidiagonal. |
//| otherwise IsUpper is False. |
//| D - the main diagonal. |
//| Array whose index ranges within [0..Min(M,N)-1]. |
//| E - the secondary diagonal (upper or lower, depending|
//| on the value of IsUpper). |
//| Array index ranges within [0..Min(M,N)-1], the |
//| last element is not used. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixBDUnpackDiagonals(CMatrixDouble &b,const int m,const int n,
bool &isupper,double &d[],double &e[])
{
//--- check
if(m<=0 || n<=0)
return;
//--- create variables
int i=0;
//--- check
if(m>=n)
isupper=true;
else
isupper=false;
//--- check
if(isupper)
{
//--- allocation
ArrayResizeAL(d,n);
ArrayResizeAL(e,n);
//--- get result
for(i=0;i<n-1;i++)
{
d[i]=b[i][i];
e[i]=b[i][i+1];
}
d[n-1]=b[n-1][n-1];
}
else
{
//--- allocation
ArrayResizeAL(d,m);
ArrayResizeAL(e,m);
//--- get result
for(i=0;i<m-1;i++)
{
d[i]=b[i][i];
e[i]=b[i+1][i];
}
d[m-1]=b[m-1][m-1];
}
}
//+------------------------------------------------------------------+
//| 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 |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixHessenberg(CMatrixDouble &a,const int n,double &tau[])
{
//--- check
if(n<=1)
return;
//--- check
if(!CAp::Assert(n>=0,__FUNCTION__+": incorrect N!"))
return;
//--- create arrays
double t[];
double work[];
//--- create variables
int i=0;
double v=0;
int i_=0;
int i1_=0;
//--- allocation
ArrayResizeAL(tau,n-1);
ArrayResizeAL(t,n+1);
ArrayResizeAL(work,n);
for(i=0;i<n-1;i++)
{
//--- Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
CReflections::GenerateReflection(t,n-i-1,v);
i1_=-i;
for(i_=i+1;i_<n;i_++)
a[i_].Set(i,t[i_+i1_]);
tau[i]=v;
t[1]=1;
//--- Apply H(i) to A(1:ihi,i+1:ihi) from the right
CReflections::ApplyReflectionFromTheRight(a,v,t,0,n-1,i+1,n-1,work);
//--- Apply H(i) to A(i+1:ihi,i+1:n) from the left
CReflections::ApplyReflectionFromTheLeft(a,v,t,i+1,n-1,i+1,n-1,work);
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix Q which reduces matrix A to upper Hessenberg |
//| form |
//| Input parameters: |
//| A - output of RMatrixHessenberg subroutine. |
//| N - size of matrix A. |
//| Tau - scalar factors which are used to form Q. |
//| Output of RMatrixHessenberg subroutine. |
//| Output parameters: |
//| Q - matrix Q. |
//| Array whose indexes range within [0..N-1, 0..N-1]. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixHessenbergUnpackQ(CMatrixDouble &a,const int n,
double &tau[],CMatrixDouble &q)
{
//--- check
if(n==0)
return;
//--- create arrays
double v[];
double work[];
//--- create variables
int i=0;
int j=0;
int i_=0;
int i1_=0;
//--- allocation
q.Resize(n,n);
//--- allocation
ArrayResizeAL(v,n);
ArrayResizeAL(work,n);
//--- identity matrix
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- unpack Q
for(i=0;i<n-1;i++)
{
//--- Apply H(i)
i1_=i;
for(i_=1;i_<n-i;i_++)
v[i_]=a[i_+i1_][i];
v[1]=1;
CReflections::ApplyReflectionFromTheRight(q,tau[i],v,0,n-1,i+1,n-1,work);
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix H (the result of matrix A reduction to upper |
//| Hessenberg form) |
//| Input parameters: |
//| A - output of RMatrixHessenberg subroutine. |
//| N - size of matrix A. |
//| Output parameters: |
//| H - matrix H. Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixHessenbergUnpackH(CMatrixDouble &a,const int n,CMatrixDouble &h)
{
//--- check
if(n==0)
return;
//--- create arrays
double v[];
double work[];
//--- create variables
int i=0;
int j=0;
int i_=0;
//--- allocation
h.Resize(n,n);
//--- get result
for(i=0;i<n;i++)
{
for(j=0;j<=i-2;j++)
h[i].Set(j,0);
j=(int)MathMax(0,i-1);
for(i_=j;i_<n;i_++)
h[i].Set(i_,a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Reduction of a symmetric matrix which is given by its higher or |
//| lower triangular part to a tridiagonal matrix using orthogonal |
//| similarity transformation: Q'*A*Q=T. |
//| Input parameters: |
//| A - matrix to be transformed |
//| array with elements [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| IsUpper - storage format. If IsUpper = True, then matrix A |
//| is given by its upper triangle, and the lower |
//| triangle is not used and not modified by the |
//| algorithm, and vice versa if IsUpper = False. |
//| Output parameters: |
//| A - matrices T and Q in compact form (see lower) |
//| Tau - array of factors which are forming matrices H(i) |
//| array with elements [0..N-2]. |
//| D - main diagonal of symmetric matrix T. |
//| array with elements [0..N-1]. |
//| E - secondary diagonal of symmetric matrix T. |
//| array with elements [0..N-2]. |
//| If IsUpper=True, the matrix Q is represented as a product of |
//| elementary reflectors |
//| Q = H(n-2) . . . H(2) H(0). |
//| Each H(i) has the form |
//| H(i) = I - tau * v * v' |
//| where tau is a real scalar, and v is a real vector with |
//| v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in |
//| A(0:i-1,i+1), and tau in TAU(i). |
//| If IsUpper=False, the matrix Q is represented as a product of |
//| elementary reflectors |
//| Q = H(0) H(2) . . . H(n-2). |
//| Each H(i) has the form |
//| H(i) = I - tau * v * v' |
//| where tau is a real scalar, and v is a real vector with |
//| v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in |
//| A(i+2:n-1,i), and tau in TAU(i). |
//| The contents of A on exit are illustrated by the following |
//| examples with n = 5: |
//| if UPLO = 'U': if UPLO = 'L': |
//| ( d e v1 v2 v3 ) ( d ) |
//| ( d e v2 v3 ) ( e d ) |
//| ( d e v3 ) ( v0 e d ) |
//| ( d e ) ( v0 v1 e d ) |
//| ( d ) ( v0 v1 v2 e d ) |
//| where d and e denote diagonal and off-diagonal elements of T, |
//| and vi denotes an element of the vector defining H(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 |
//+------------------------------------------------------------------+
static void COrtFac::SMatrixTD(CMatrixDouble &a,const int n,const bool isupper,
double &tau[],double &d[],double &e[])
{
//--- check
if(n<=0)
return;
//--- create arrays
double t[];
double t2[];
double t3[];
//--- create variables
int i=0;
double alpha=0;
double taui=0;
double v=0;
int i_=0;
int i1_=0;
//--- allocation
ArrayResizeAL(t,n+1);
ArrayResizeAL(t2,n+1);
ArrayResizeAL(t3,n+1);
//--- check
if(n>1)
ArrayResizeAL(tau,n-1);
ArrayResizeAL(d,n);
//--- check
if(n>1)
ArrayResizeAL(e,n-1);
//--- 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_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
}
t[1]=a[i][i+1];
CReflections::GenerateReflection(t,i+1,taui);
//--- check
if(i>=1)
{
i1_=2;
for(i_=0;i_<i;i_++)
a[i_].Set(i+1,t[i_+i1_]);
}
a[i].Set(i+1,t[1]);
e[i]=a[i][i+1];
//--- check
if(taui!=0)
{
//--- Apply H from both sides to A
a[i].Set(i+1,1);
//--- Compute x := tau * A * v storing x in TAU
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
CSblas::SymmetricMatrixVectorMultiply(a,isupper,0,i,t,taui,t3);
i1_=1;
for(i_=0;i_<=i;i_++)
tau[i_]=t3[i_+i1_];
//--- Compute w := x - 1/2 * tau * (x'*v) * v
v=0.0;
for(i_=0;i_<=i;i_++)
v+=tau[i_]*a[i_][i+1];
alpha=-(0.5*taui*v);
for(i_=0;i_<=i;i_++)
tau[i_]=tau[i_]+alpha*a[i_][i+1];
//--- Apply the transformation as a rank-2 update:
//--- A := A - v * w' - w * v'
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t3[i_]=tau[i_+i1_];
CSblas::SymmetricRank2Update(a,isupper,0,i,t,t3,t2,-1);
a[i].Set(i+1,e[i]);
}
d[i+1]=a[i+1][i+1];
tau[i]=taui;
}
d[0]=a[0][0];
}
else
{
//--- Reduce the lower triangle of A
for(i=0;i<n-1;i++)
{
//--- Generate elementary reflector H = E - tau * v * v'
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
CReflections::GenerateReflection(t,n-i-1,taui);
i1_=-i;
for(i_=i+1;i_<n;i_++)
a[i_].Set(i,t[i_+i1_]);
e[i]=a[i+1][i];
if(taui!=0)
{
//--- Apply H from both sides to A
a[i+1].Set(i,1);
//--- Compute x := tau * A * v storing y in TAU
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
CSblas::SymmetricMatrixVectorMultiply(a,isupper,i+1,n-1,t,taui,t2);
i1_=1-i;
for(i_=i;i_<n-1;i_++)
tau[i_]=t2[i_+i1_];
//--- Compute w := x - 1/2 * tau * (x'*v) * v
i1_=1;
v=0.0;
for(i_=i;i_<=n-2;i_++)
v+=tau[i_]*a[i_+i1_][i];
alpha=-(0.5*taui*v);
i1_=1;
for(i_=i;i_<n-1;i_++)
tau[i_]=tau[i_]+alpha*a[i_+i1_][i];
//--- Apply the transformation as a rank-2 update:
//--- A := A - v * w' - w * v'
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
i1_=i-1;
for(i_=1;i_<n-i;i_++)
t2[i_]=tau[i_+i1_];
CSblas::SymmetricRank2Update(a,isupper,i+1,n-1,t,t2,t3,-1);
a[i+1].Set(i,e[i]);
}
d[i]=a[i][i];
tau[i]=taui;
}
d[n-1]=a[n-1][n-1];
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix Q which reduces symmetric matrix to a |
//| tridiagonal form. |
//| Input parameters: |
//| A - the result of a SMatrixTD subroutine |
//| N - size of matrix A. |
//| IsUpper - storage format (a parameter of SMatrixTD |
//| subroutine) |
//| Tau - the result of a SMatrixTD subroutine |
//| Output parameters: |
//| Q - transformation matrix. |
//| array with elements [0..N-1, 0..N-1]. |
//+------------------------------------------------------------------+
static void COrtFac::SMatrixTDUnpackQ(CMatrixDouble &a,const int n,const bool isupper,
double &tau[],CMatrixDouble &q)
{
//--- check
if(n==0)
return;
//--- create arrays
double v[];
double work[];
//--- create variables
int i=0;
int j=0;
int i_=0;
int i1_=0;
//--- allocation
q.Resize(n,n);
//--- allocation
ArrayResizeAL(v,n+1);
ArrayResizeAL(work,n);
//--- identity matrix
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- unpack Q
if(isupper)
{
for(i=0;i<n-1;i++)
{
//--- Apply H(i)
i1_=-1;
for(i_=1;i_<=i+1;i_++)
v[i_]=a[i_+i1_][i+1];
v[i+1]=1;
//--- function call
CReflections::ApplyReflectionFromTheLeft(q,tau[i],v,0,i,0,n-1,work);
}
}
else
{
for(i=n-2;i>=0;i--)
{
//--- Apply H(i)
i1_=i;
for(i_=1;i_<n-i;i_++)
v[i_]=a[i_+i1_][i];
v[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheLeft(q,tau[i],v,i+1,n-1,0,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Reduction of a Hermitian matrix which is given by its higher or |
//| lower triangular part to a real tridiagonal matrix using unitary |
//| similarity transformation: Q'*A*Q = T. |
//| Input parameters: |
//| A - matrix to be transformed |
//| array with elements [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| IsUpper - storage format. If IsUpper = True, then matrix A |
//| is given by its upper triangle, and the lower |
//| triangle is not used and not modified by the |
//| algorithm, and vice versa if IsUpper = False. |
//| Output parameters: |
//| A - matrices T and Q in compact form (see lower) |
//| Tau - array of factors which are forming matrices H(i) |
//| array with elements [0..N-2]. |
//| D - main diagonal of real symmetric matrix T. |
//| array with elements [0..N-1]. |
//| E - secondary diagonal of real symmetric matrix T. |
//| array with elements [0..N-2]. |
//| If IsUpper=True, the matrix Q is represented as a product of |
//| elementary reflectors |
//| Q = H(n-2) . . . H(2) H(0). |
//| Each H(i) has the form |
//| H(i) = I - tau * v * v' |
//| where tau is a complex scalar, and v is a complex vector with |
//| v(i+1:n-1) = 0, v(i) = 1, v(0:i-1) is stored on exit in |
//| A(0:i-1,i+1), and tau in TAU(i). |
//| If IsUpper=False, the matrix Q is represented as a product of |
//| elementary reflectors |
//| Q = H(0) H(2) . . . H(n-2). |
//| Each H(i) has the form |
//| H(i) = I - tau * v * v' |
//| where tau is a complex scalar, and v is a complex vector with |
//| v(0:i) = 0, v(i+1) = 1, v(i+2:n-1) is stored on exit in |
//| A(i+2:n-1,i), and tau in TAU(i). |
//| The contents of A on exit are illustrated by the following |
//| examples with n = 5: |
//| if UPLO = 'U': if UPLO = 'L': |
//| ( d e v1 v2 v3 ) ( d ) |
//| ( d e v2 v3 ) ( e d ) |
//| ( d e v3 ) ( v0 e d ) |
//| ( d e ) ( v0 v1 e d ) |
//| ( d ) ( v0 v1 v2 e d ) |
//| where d and e denote diagonal and off-diagonal elements of T, and|
//| vi denotes an element of the vector defining H(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 |
//+------------------------------------------------------------------+
static void COrtFac::HMatrixTD(CMatrixComplex &a,const int n,const bool isupper,
complex &tau[],double &d[],double &e[])
{
//--- check
if(n<=0)
return;
//--- create arrays
complex t[];
complex t2[];
complex t3[];
//--- create variables
complex Half(0.5,0);
complex Zero(0,0);
complex _One(-1,0);
complex alpha=0;
complex taui=0;
complex v=0;
int i=0;
int i_=0;
int i1_=0;
for(i=0;i<n;i++)
{
//--- check
if(!CAp::Assert(a[i][i].im==0))
return;
}
//--- allocation
if(n>1)
{
ArrayResizeAL(tau,n-1);
ArrayResizeAL(e,n-1);
}
ArrayResizeAL(d,n);
ArrayResizeAL(t,n);
ArrayResizeAL(t2,n);
ArrayResizeAL(t3,n);
//--- check
if(isupper)
{
//--- Reduce the upper triangle of A
a[n-1].Set(n-1,a[n-1][n-1].re);
for(i=n-2;i>=0;i--)
{
//--- Generate elementary reflector H = I+1 - tau * v * v'
alpha=a[i][i+1];
t[1]=alpha;
//--- check
if(i>=1)
{
i1_=-2;
for(i_=2;i_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
}
//--- function call
CComplexReflections::ComplexGenerateReflection(t,i+1,taui);
//--- check
if(i>=1)
{
i1_=2;
for(i_=0;i_<i;i_++)
a[i_].Set(i+1,t[i_+i1_]);
}
//--- change values
alpha=t[1];
e[i]=alpha.re;
//--- check
if(taui!=Zero)
{
//--- Apply H(I+1) from both sides to A
a[i].Set(i+1,1);
//--- Compute x := tau * A * v storing x in TAU
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
CHblas::HermitianMatrixVectorMultiply(a,isupper,0,i,t,taui,t2);
i1_=1;
for(i_=0;i_<=i;i_++)
tau[i_]=t2[i_+i1_];
//--- Compute w := x - 1/2 * tau * (x'*v) * v
v=0.0;
for(i_=0;i_<=i;i_++)
v+=CMath::Conj(tau[i_])*a[i_][i+1];
//--- calculation
alpha=Half*taui*v;
alpha.re=-alpha.re;
alpha.im=-alpha.im;
for(i_=0;i_<=i;i_++)
tau[i_]=tau[i_]+alpha*a[i_][i+1];
//--- Apply the transformation as a rank-2 update:
//--- A := A - v * w' - w * v'
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t[i_]=a[i_+i1_][i+1];
i1_=-1;
for(i_=1;i_<=i+1;i_++)
t3[i_]=tau[i_+i1_];
CHblas::HermitianRank2Update(a,isupper,0,i,t,t3,t2,_One);
}
else
a[i].Set(i,a[i][i].re);
//--- change values
a[i].Set(i+1,e[i]);
d[i+1]=a[i+1][i+1].re;
tau[i]=taui;
}
d[0]=a[0][0].re;
}
else
{
//--- Reduce the lower triangle of A
a[0].Set(0,a[0][0].re);
for(i=0;i<n-1;i++)
{
//--- Generate elementary reflector H = I - tau * v * v'
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
//--- function call
CComplexReflections::ComplexGenerateReflection(t,n-i-1,taui);
i1_=-i;
for(i_=i+1;i_<n;i_++)
a[i_].Set(i,t[i_+i1_]);
e[i]=a[i+1][i].re;
//--- check
if(taui!=Zero)
{
//--- Apply H(i) from both sides to A(i+1:n,i+1:n)
a[i+1].Set(i,1);
//--- Compute x := tau * A * v storing y in TAU
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
CHblas::HermitianMatrixVectorMultiply(a,isupper,i+1,n-1,t,taui,t2);
i1_=1-i;
for(i_=i;i_<n-1;i_++)
tau[i_]=t2[i_+i1_];
//--- Compute w := x - 1/2 * tau * (x'*v) * v
i1_=1;
v=0.0;
for(i_=i;i_<n-1;i_++)
v+=CMath::Conj(tau[i_])*a[i_+i1_][i];
//--- calculation
alpha=Half*taui*v;
alpha.re=-alpha.re;
alpha.im=-alpha.im;
i1_=1;
for(i_=i;i_<n-1;i_++)
tau[i_]=tau[i_]+alpha*a[i_+i1_][i];
//--- Apply the transformation as a rank-2 update:
//--- A := A - v * w' - w * v'
i1_=i;
for(i_=1;i_<n-i;i_++)
t[i_]=a[i_+i1_][i];
i1_=i-1;
for(i_=1;i_<n-i;i_++)
t2[i_]=tau[i_+i1_];
CHblas::HermitianRank2Update(a,isupper,i+1,n-1,t,t2,t3,_One);
}
else
a[i+1].Set(i+1,a[i+1][i+1].re);
//--- change values
a[i+1].Set(i,e[i]);
d[i]=a[i][i].re;
tau[i]=taui;
}
d[n-1]=a[n-1][n-1].re;
}
}
//+------------------------------------------------------------------+
//| Unpacking matrix Q which reduces a Hermitian matrix to a real |
//| tridiagonal form. |
//| Input parameters: |
//| A - the result of a HMatrixTD subroutine |
//| N - size of matrix A. |
//| IsUpper - storage format (a parameter of HMatrixTD |
//| subroutine) |
//| Tau - the result of a HMatrixTD subroutine |
//| Output parameters: |
//| Q - transformation matrix. |
//| array with elements [0..N-1, 0..N-1]. |
//+------------------------------------------------------------------+
static void COrtFac::HMatrixTDUnpackQ(CMatrixComplex &a,const int n,const bool isupper,
complex &tau[],CMatrixComplex &q)
{
//--- check
if(n==0)
return;
//--- create arrays
complex v[];
complex work[];
//--- create variables
int i=0;
int j=0;
int i_=0;
int i1_=0;
//--- allocation
q.Resize(n,n);
//--- allocation
ArrayResizeAL(v,n+1);
ArrayResizeAL(work,n+1);
//--- identity matrix
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
{
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- unpack Q
if(isupper)
{
for(i=0;i<n-1;i++)
{
//--- Apply H(i)
i1_=-1;
for(i_=1;i_<=i+1;i_++)
v[i_]=a[i_+i1_][i+1];
v[i+1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(q,tau[i],v,0,i,0,n-1,work);
}
}
else
{
for(i=n-2;i>=0;i--)
{
//--- Apply H(i)
i1_=i;
for(i_=1;i_<n-i;i_++)
v[i_]=a[i_+i1_][i];
v[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(q,tau[i],v,i+1,n-1,0,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Base case for real QR |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixQRBaseCase(CMatrixDouble &a,const int m,const int n,
double &work[],double &t[],double &tau[])
{
//--- create variables
int i=0;
int k=MathMin(m,n);
int minmn=MathMin(m,n);
double tmp=0;
int i_=0;
int i1_=0;
//--- calculations
for(i=0;i<k;i++)
{
//--- Generate elementary reflector H(i) to annihilate A(i+1:m,i)
i1_=i-1;
for(i_=1;i_<=m-i;i_++)
t[i_]=a[i_+i1_][i];
CReflections::GenerateReflection(t,m-i,tmp);
tau[i]=tmp;
i1_=1-i;
for(i_=i;i_<m;i_++)
a[i_].Set(i,t[i_+i1_]);
t[1]=1;
//--- check
if(i<n)
{
//--- Apply H(i) to A(i:m-1,i+1:n-1) from the left
CReflections::ApplyReflectionFromTheLeft(a,tau[i],t,i,m-1,i+1,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Base case for real LQ |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixLQBaseCase(CMatrixDouble &a,const int m,const int n,
double &work[],double &t[],double &tau[])
{
//--- create variables
int i=0;
int k=MathMin(m,n);
int minmn=MathMin(m,n);
double tmp=0;
int i_=0;
int i1_=0;
//--- calculation
for(i=0;i<k;i++)
{
//--- Generate elementary reflector H(i) to annihilate A(i,i+1:n-1)
i1_=i-1;
for(i_=1;i_<=n-i;i_++)
t[i_]=a[i][i_+i1_];
CReflections::GenerateReflection(t,n-i,tmp);
tau[i]=tmp;
i1_=1-i;
for(i_=i;i_<n;i_++)
a[i].Set(i_,t[i_+i1_]);
t[1]=1;
//--- check
if(i<n)
{
//--- Apply H(i) to A(i+1:m,i:n) from the right
CReflections::ApplyReflectionFromTheRight(a,tau[i],t,i+1,m-1,i,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Base case for complex QR |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixQRBaseCase(CMatrixComplex &a,const int m,const int n,
complex &work[],complex &t[],complex &tau[])
{
//--- create variables
int i=0;
int k=MathMin(m,n);
int mmi=0;
int minmn=MathMin(m,n);
complex tmp=0;
int i_=0;
int i1_=0;
//--- check
if(minmn<=0)
return;
//--- calculation
for(i=0;i<k;i++)
{
//--- Generate elementary reflector H(i) to annihilate A(i+1:m,i)
mmi=m-i;
i1_=i-1;
for(i_=1;i_<=mmi;i_++)
t[i_]=a[i_+i1_][i];
//--- function call
CComplexReflections::ComplexGenerateReflection(t,mmi,tmp);
tau[i]=tmp;
i1_=1-i;
for(i_=i;i_<m;i_++)
a[i_].Set(i,t[i_+i1_]);
t[1]=1;
//--- check
if(i<n-1)
{
//--- Apply H'(i) to A(i:m,i+1:n) from the left
CComplexReflections::ComplexApplyReflectionFromTheLeft(a,CMath::Conj(tau[i]),t,i,m-1,i+1,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Base case for complex LQ |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixLQBaseCase(CMatrixComplex &a,const int m,const int n,
complex &work[],complex &t[],complex &tau[])
{
//--- create variables
int i=0;
int minmn=MathMin(m,n);
complex tmp=0;
int i_=0;
int i1_=0;
//--- check
if(minmn<=0)
return;
//--- calculation
for(i=0;i<=minmn-1;i++)
{
//--- Generate elementary reflector H(i)
//--- NOTE: ComplexGenerateReflection() generates left reflector,
//--- i.e. H which reduces x by applyiong from the left, but we
//--- need RIGHT reflector. So we replace H=E-tau*v*v' by H^H,
//--- which changes v to conj(v).
i1_=i-1;
for(i_=1;i_<=n-i;i_++)
t[i_]=CMath::Conj(a[i][i_+i1_]);
CComplexReflections::ComplexGenerateReflection(t,n-i,tmp);
tau[i]=tmp;
i1_=1-i;
for(i_=i;i_<n;i_++)
a[i].Set(i_,CMath::Conj(t[i_+i1_]));
t[1]=1;
//--- check
if(i<m-1)
{
//--- Apply H'(i)
CComplexReflections::ComplexApplyReflectionFromTheRight(a,tau[i],t,i+1,m-1,i,n-1,work);
}
}
}
//+------------------------------------------------------------------+
//| Generate block reflector: |
//| * fill unused parts of reflectors matrix by zeros |
//| * fill diagonal of reflectors matrix by ones |
//| * generate triangular factor T |
//| PARAMETERS: |
//| A - either LengthA*BlockSize (if ColumnwiseA) or |
//| BlockSize*LengthA (if not ColumnwiseA) matrix|
//| of elementary reflectors. |
//| Modified on exit. |
//| Tau - scalar factors |
//| ColumnwiseA - reflectors are stored in rows or in columns |
//| LengthA - length of largest reflector |
//| BlockSize - number of reflectors |
//| T - array[BlockSize,2*BlockSize]. Left |
//| BlockSize*BlockSize submatrix stores |
//| triangular factor on exit. |
//| WORK - array[BlockSize] |
//+------------------------------------------------------------------+
static void COrtFac::RMatrixBlockReflector(CMatrixDouble &a,double &tau[],
const bool columnwisea,const int lengtha,
const int blocksize,CMatrixDouble &t,double &work[])
{
//--- create variables
int i=0;
int j=0;
int k=0;
double v=0;
int i_=0;
int i1_=0;
//--- fill beginning of new column with zeros,
//--- load 1.0 in the first non-zero element
for(k=0;k<blocksize;k++)
{
//--- check
if(columnwisea)
{
for(i=0;i<k;i++)
a[i].Set(k,0);
}
else
{
for(i=0;i<k;i++)
a[k].Set(i,0);
}
a[k].Set(k,1);
}
//--- Calculate Gram matrix of A
for(i=0;i<blocksize;i++)
{
for(j=0;j<blocksize;j++)
t[i].Set(blocksize+j,0);
}
for(k=0;k<=lengtha-1;k++)
{
for(j=1;j<blocksize;j++)
{
//--- check
if(columnwisea)
{
v=a[k][j];
//--- check
if(v!=0)
{
i1_=-blocksize;
for(i_=blocksize;i_<=blocksize+j-1;i_++)
t[j].Set(i_,t[j][i_]+v*a[k][i_+i1_]);
}
}
else
{
v=a[j][k];
//--- check
if(v!=0)
{
i1_=-blocksize;
for(i_=blocksize;i_<=blocksize+j-1;i_++)
t[j].Set(i_,t[j][i_]+v*a[i_+i1_][k]);
}
}
}
}
//--- Prepare Y (stored in TmpA) and T (stored in TmpT)
for(k=0;k<blocksize;k++)
{
//--- fill non-zero part of T, use pre-calculated Gram matrix
i1_=blocksize;
for(i_=0;i_<k;i_++)
work[i_]=t[k][i_+i1_];
for(i=0;i<k;i++)
{
v=0.0;
for(i_=i;i_<k;i_++)
v+=t[i][i_]*work[i_];
t[i].Set(k,-(tau[k]*v));
}
t[k].Set(k,-tau[k]);
//--- Rest of T is filled by zeros
for(i=k+1;i<blocksize;i++)
t[i].Set(k,0);
}
}
//+------------------------------------------------------------------+
//| Generate block reflector (complex): |
//| * fill unused parts of reflectors matrix by zeros |
//| * fill diagonal of reflectors matrix by ones |
//| * generate triangular factor T |
//+------------------------------------------------------------------+
static void COrtFac::CMatrixBlockReflector(CMatrixComplex &a,complex &tau[],
const bool columnwisea,const int lengtha,
const int blocksize,CMatrixComplex &t,complex &work[])
{
//--- create variables
int i=0;
int k=0;
complex v=0;
complex tauv=0;
int i_=0;
//--- Prepare Y (stored in TmpA) and T (stored in TmpT)
for(k=0;k<blocksize;k++)
{
//--- fill beginning of new column with zeros,
//--- load 1.0 in the first non-zero element
if(columnwisea)
{
for(i=0;i<k;i++)
a[i].Set(k,0);
}
else
{
for(i=0;i<k;i++)
a[k].Set(i,0);
}
a[k].Set(k,1);
//--- fill non-zero part of T
for(i=0;i<k;i++)
{
//--- check
if(columnwisea)
{
v=0.0;
for(i_=k;i_<=lengtha-1;i_++)
v+=CMath::Conj(a[i_][i])*a[i_][k];
}
else
{
v=0.0;
for(i_=k;i_<=lengtha-1;i_++)
v+=a[i][i_]*CMath::Conj(a[k][i_]);
}
work[i]=v;
}
for(i=0;i<k;i++)
{
v=0.0;
for(i_=i;i_<k;i_++)
v+=t[i][i_]*work[i_];
//--- change
tauv=tau[k]*v;
tauv.re=-tauv.re;
tauv.im=-tauv.im;
t[i].Set(k,tauv);
}
//--- change
tauv=tau[k];
tauv.re=-tauv.re;
tauv.im=-tauv.im;
t[k].Set(k,tauv);
//--- Rest of T is filled by zeros
for(i=k+1;i<blocksize;i++)
t[i].Set(k,0);
}
}
//+------------------------------------------------------------------+
//| Eigenvalues and eigenvectors |
//+------------------------------------------------------------------+
class CEigenVDetect
{
private:
//--- private methods
static bool TtidiagonalEVD(double &d[],double &ce[],const int n,const int zneeded,CMatrixDouble &z);
static void TdEVDE2(const double a,const double b,const double c,double &rt1,double &rt2);
static void TdEVDEv2(const double a,const double b,const double c,double &rt1,double &rt2,double &cs1,double &sn1);
static double TdEVDPythag(const double a,const double b);
static double TdEVDExtSign(const double a,const double b);
static bool InternalBisectionEigenValues(double &cd[],double &ce[],const int n,int irange,const int iorder,const double vl,const double vu,const int il,const int iu,const double abstol,double &w[],int &m,int &nsplit,int &iblock[],int &isplit[],int &errorcode);
static void InternalDStein(const int n,double &d[],double &ce[],const int m,double &cw[],int &iblock[],int &isplit[],CMatrixDouble &z,int &ifail[],int &info);
static void TdIninternalDLAGTF(const int n,double &a[],const double lambdav,double &b[],double &c[],double tol,double &d[],int &iin[],int &info);
static void TdIninternalDLAGTS(const int n,double &a[],double &b[],double &c[],double &d[],int &iin[],double &y[],double &tol,int &info);
static void 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,double &d[],double &e[],double &e2[],int &nval[],CMatrixDouble &ab,double &c[],int &mout,CMatrixInt &nab,double &work[],int &iwork[],int &info);
static void InternalTREVC(CMatrixDouble &t,const int n,const int side,const int howmny,bool &cvselect[],CMatrixDouble &vl,CMatrixDouble &vr,int &m,int &info);
static void InternalHsEVDLALN2(const bool ltrans,const int na,const int nw,const double smin,const double ca,CMatrixDouble &a,const double d1,const double d2,CMatrixDouble &b,const double wr,const double wi,bool &rswap4[],bool &zswap4[],CMatrixInt &ipivot44,double &civ4[],double &crv4[],CMatrixDouble &x,double &scl,double &xnorm,int &info);
static void InternalHsEVDLADIV(const double a,const double b,const double c,const double d,double &p,double &q);
static bool NonSymmetricEVD(CMatrixDouble &ca,const int n,const int vneeded,double &wr[],double &wi[],CMatrixDouble &vl,CMatrixDouble &vr);
static void ToUpperHessenberg(CMatrixDouble &a,const int n,double &tau[]);
static void UnpackQFromUpperHessenberg(CMatrixDouble &a,const int n,double &tau[],CMatrixDouble &q);
public:
CEigenVDetect(void);
~CEigenVDetect(void);
//--- public methods
static bool SMatrixEVD(CMatrixDouble &ca,const int n,const int zneeded,const bool isupper,double &d[],CMatrixDouble &z);
static bool SMatrixEVDR(CMatrixDouble &ca,const int n,const int zneeded,const bool isupper,const double b1,const double b2,int &m,double &w[],CMatrixDouble &z);
static bool SMatrixEVDI(CMatrixDouble &ca,const int n,const int zneeded,const bool isupper,const int i1,const int i2,double &w[],CMatrixDouble &z);
static bool HMatrixEVD(CMatrixComplex &ca,const int n,int zneeded,const bool isupper,double &d[],CMatrixComplex &z);
static bool HMatrixEVDR(CMatrixComplex &ca,const int n,int zneeded,bool isupper,const double b1,const double b2,int &m,double &w[],CMatrixComplex &z);
static bool HMatrixEVDI(CMatrixComplex &ca,const int n,int zneeded,const bool isupper,const int i1,const int i2,double &w[],CMatrixComplex &z);
static bool SMatrixTdEVD(double &d[],double &ce[],const int n,const int zneeded,CMatrixDouble &z);
static bool SMatrixTdEVDR(double &d[],double &e[],const int n,const int zneeded,const double a,const double b,int &m,CMatrixDouble &z);
static bool SMatrixTdEVDI(double &d[],double &e[],const int n,const int zneeded,const int i1,const int i2,CMatrixDouble &z);
static bool RMatrixEVD(CMatrixDouble &ca,const int n,const int vneeded,double &wr[],double &wi[],CMatrixDouble &vl,CMatrixDouble &vr);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CEigenVDetect::CEigenVDetect(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CEigenVDetect::~CEigenVDetect(void)
{
}
//+------------------------------------------------------------------+
//| Finding the eigenvalues and eigenvectors of a symmetric matrix |
//| The algorithm finds eigen pairs of a symmetric matrix by reducing|
//| it to tridiagonal form and using the QL/QR algorithm. |
//| 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. |
//| IsUpper - storage format. |
//| 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). |
//+------------------------------------------------------------------+
static bool CEigenVDetect::SMatrixEVD(CMatrixDouble &ca,const int n,const int zneeded,
const bool isupper,double &d[],CMatrixDouble &z)
{
//--- create arrays
double tau[];
double e[];
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(zneeded==0 || zneeded==1,__FUNCTION__+": incorrect ZNeeded"))
return(false);
//--- function call
COrtFac::SMatrixTD(a,n,isupper,tau,d,e);
//--- check
if(zneeded==1)
{
//--- function call
COrtFac::SMatrixTDUnpackQ(a,n,isupper,tau,z);
}
//--- return result
return(SMatrixTdEVD(d,e,n,zneeded,z));
}
//+------------------------------------------------------------------+
//| Subroutine for finding the eigenvalues (and eigenvectors) of a |
//| symmetric matrix in a given half open interval (A, B] by using a |
//| bisection and inverse iteration |
//| Input parameters: |
//| A - symmetric matrix which is given by its upper or |
//| lower triangular part. Array [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. |
//| B1, B2 - half open interval (B1, B2] to search |
//| eigenvalues in. |
//| Output parameters: |
//| M - number of eigenvalues found in a given |
//| half-interval (M>=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. |
//+------------------------------------------------------------------+
static 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)
{
//--- create arrays
double tau[];
double e[];
//--- create copy
CMatrixDouble a;
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. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::SMatrixEVDI(CMatrixDouble &ca,const int n,const int zneeded,
const bool isupper,const int i1,const int i2,
double &w[],CMatrixDouble &z)
{
//--- create arrays
double tau[];
double e[];
//--- create copy
CMatrixDouble a;
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. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::HMatrixEVD(CMatrixComplex &ca,const int n,int zneeded,
const bool isupper,double &d[],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
CMatrixDouble t;
CMatrixComplex q;
//--- create copy
CMatrixComplex a;
a=ca;
//--- 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)
{
ArrayResizeAL(work,n);
z.Resize(n,n);
for(i=0;i<n;i++)
{
//--- Calculate real part
for(k=0;k<n;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].re;
for(i_=0;i_<n;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get real part
for(k=0;k<n;k++)
z[i].SetRe(k,work[k]);
//--- Calculate imaginary part
for(k=0;k<n;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].im;
for(i_=0;i_<n;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get imaginary part
for(k=0;k<n;k++)
z[i].SetIm(k,work[k]);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Subroutine for finding the eigenvalues (and eigenvectors) of a |
//| Hermitian matrix in a given half-interval (A, B] by using a |
//| bisection and inverse iteration |
//| 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. |
//| 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. |
//| B1, B2 - half-interval (B1, B2] to search eigenvalues in. |
//| Output parameters: |
//| M - number of eigenvalues found in a given |
//| half-interval, M>=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. |
//+------------------------------------------------------------------+
static 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)
{
ArrayResizeAL(work,m);
z.Resize(n,m);
for(i=0;i<n;i++)
{
//--- Calculate real part
for(k=0;k<=m-1;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].re;
for(i_=0;i_<m;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get real part
for(k=0;k<=m-1;k++)
z[i].SetRe(k,work[k]);
//--- Calculate imaginary part
for(k=0;k<=m-1;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].im;
for(i_=0;i_<m;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get imaginary part
for(k=0;k<=m-1;k++)
z[i].SetIm(k,work[k]);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Subroutine for finding the eigenvalues and eigenvectors of a |
//| Hermitian matrix with given indexes by using bisection and |
//| inverse iteration methods |
//| 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. |
//| 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 |
//| corresponding eigenvectors. iteration subroutine wasn't able |
//| to find all the corresponding eigenvectors. In that case, |
//| the eigenvalues and eigenvectors are not returned. |
//| Note: |
//| eigen vectors of Hermitian matrix are defined up to |
//| multiplication by a complex number L, such as |L|=1. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::HMatrixEVDI(CMatrixComplex &ca,const int n,int zneeded,
const bool isupper,const int i1,const int i2,
double &w[],CMatrixComplex &z)
{
//--- create variables
int i=0;
int k=0;
double v=0;
int m=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;
//--- 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=SMatrixTdEVDI(w,e,n,zneeded,i1,i2,t);
//--- Eigenvectors are needed
//--- Calculate Z = Q*T = Re(Q)*T + i*Im(Q)*T
m=i2-i1+1;
//--- check
if(result && zneeded!=0)
{
ArrayResizeAL(work,m);
z.Resize(n,m);
for(i=0;i<n;i++)
{
//--- Calculate real part
for(k=0;k<=m-1;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].re;
for(i_=0;i_<m;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get real part
for(k=0;k<=m-1;k++)
z[i].SetRe(k,work[k]);
//--- Calculate imaginary part
for(k=0;k<=m-1;k++)
work[k]=0;
for(k=0;k<n;k++)
{
v=q[i][k].im;
for(i_=0;i_<m;i_++)
work[i_]=work[i_]+v*t[k][i_];
}
//--- get imaginary part
for(k=0;k<=m-1;k++)
z[i].SetIm(k,work[k]);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Finding the eigenvalues and eigenvectors of a tridiagonal |
//| symmetric matrix |
//| The algorithm finds the eigen pairs of a tridiagonal symmetric |
//| matrix by using an QL/QR algorithm with implicit shifts. |
//| Input parameters: |
//| D - the main diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-1]. |
//| E - the secondary diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-2]. |
//| 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 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 the square matrix Z; |
//| * 3, matrix Z contains the first row of the |
//| eigenvectors matrix. |
//| Z - if ZNeeded=1, Z contains the square matrix by |
//| which the eigenvectors are multiplied. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| 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 product of a given matrix |
//| (from the left) and the eigenvectors matrix |
//| (from the right); |
//| * 2, Z contains the eigenvectors. |
//| * 3, Z contains the first row of the |
//| eigenvectors matrix. |
//| If ZNeeded<3, Z is the array whose indexes range |
//| within [0..N-1, 0..N-1]. |
//| In that case, the eigenvectors are stored in the |
//| matrix columns. |
//| If ZNeeded=3, Z is the array whose indexes range |
//| within [0..0, 0..N-1]. |
//| Result: |
//| True, if the algorithm has converged. |
//| False, if the algorithm hasn't converged. |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| September 30, 1994 |
//+------------------------------------------------------------------+
static bool CEigenVDetect::SMatrixTdEVD(double &d[],double &ce[],const int n,const int zneeded,CMatrixDouble &z)
{
//--- create variables
int i=0;
int i_=0;
int i1_=0;
bool result;
//--- create arrays
double d1[];
double e1[];
//--- create matrix
CMatrixDouble z1;
//--- create copy
double e[];
ArrayResizeAL(e,ArraySize(ce));
ArrayCopy(e,ce);
//--- Prepare 1-based task
ArrayResizeAL(d1,n+1);
ArrayResizeAL(e1,n+1);
i1_=-1;
for(i_=1;i_<=n;i_++)
d1[i_]=d[i_+i1_];
//--- check
if(n>1)
{
i1_=-1;
for(i_=1;i_<n;i_++)
e1[i_]=e[i_+i1_];
}
//--- check
if(zneeded==1)
{
z1.Resize(n+1,n+1);
for(i=1;i<=n;i++)
{
i1_=-1;
for(i_=1;i_<=n;i_++)
z1[i].Set(i_,z[i-1][i_+i1_]);
}
}
//--- Solve 1-based task
result=TtidiagonalEVD(d1,e1,n,zneeded,z1);
//--- check
if(!result)
return(result);
//--- Convert back to 0-based result
i1_=1;
for(i_=0;i_<n;i_++)
d[i_]=d1[i_+i1_];
//--- check
if(zneeded!=0)
{
//--- check
if(zneeded==1)
{
for(i=1;i<=n;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i-1].Set(i_,z1[i][i_+i1_]);
}
//--- return result
return(result);
}
//--- check
if(zneeded==2)
{
z.Resize(n,n);
for(i=1;i<=n;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i-1].Set(i_,z1[i][i_+i1_]);
}
//--- return result
return(result);
}
//--- check
if(zneeded==3)
{
z.Resize(1,n);
i1_=1;
for(i_=0;i_<n;i_++)
z[0].Set(i_,z1[1][i_+i1_]);
//--- return result
return(result);
}
//--- check
if(!CAp::Assert(false,__FUNCTION__+": Incorrect ZNeeded!"))
return(false);
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Subroutine for finding the tridiagonal matrix eigenvalues/vectors|
//| in a given half-interval (A, B] by using bisection and inverse |
//| iteration. |
//| Input parameters: |
//| D - the main diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-1]. |
//| E - the secondary diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-2]. |
//| N - size of matrix, N>=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. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::SMatrixTdEVDR(double &d[],double &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
int iblock[];
int isplit[];
int ifail[];
double d1[];
double e1[];
double 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
ArrayResizeAL(d1,n+1);
i1_=-1;
for(i_=1;i_<=n;i_++)
d1[i_]=d[i_+i1_];
//--- check
if(n>1)
{
ArrayResizeAL(e1,n);
i1_=-1;
for(i_=1;i_<n;i_++)
e1[i_]=e[i_+i1_];
}
//--- No eigen vectors
if(zneeded==0)
{
//--- get result
result=InternalBisectionEigenValues(d1,e1,n,2,1,a,b,0,0,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result || m==0)
{
m=0;
return(result);
}
ArrayResizeAL(d,m);
i1_=1;
for(i_=0;i_<m;i_++)
{
d[i_]=w[i_+i1_];
}
//--- return result
return(result);
}
//--- Eigen vectors are multiplied by Z
if(zneeded==1)
{
//--- Find eigen pairs
result=InternalBisectionEigenValues(d1,e1,n,2,2,a,b,0,0,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result || m==0)
{
m=0;
return(result);
}
//--- function call
InternalDStein(n,d1,e1,m,w,iblock,isplit,z2,ifail,cr);
//--- check
if(cr!=0)
{
m=0;
//--- get result
result=false;
return(result);
}
//--- Sort eigen values and vectors
for(i=1;i<=m;i++)
{
k=i;
for(j=i;j<=m;j++)
{
//--- check
if(w[j]<w[k])
k=j;
}
//--- swap
v=w[i];
w[i]=w[k];
w[k]=v;
for(j=1;j<=n;j++)
{
//--- swap
v=z2[j][i];
z2[j].Set(i,z2[j][k]);
z2[j].Set(k,v);
}
}
//--- Transform Z2 and overwrite Z
z3.Resize(m+1,n+1);
for(i=1;i<=m;i++)
for(i_=1;i_<=n;i_++)
z3[i].Set(i_,z2[i_][i]);
for(i=1;i<=n;i++)
{
for(j=1;j<=m;j++)
{
i1_=1;
v=0.0;
for(i_=0;i_<n;i_++)
v+=z[i-1][i_]*z3[j][i_+i1_];
z2[i].Set(j,v);
}
}
//--- rewrite
z.Resize(n,m);
for(i=1;i<=m;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i_].Set(i-1,z2[i_+i1_][i]);
}
//--- Store W
ArrayResizeAL(d,m);
for(i=1;i<=m;i++)
d[i-1]=w[i];
//--- return result
return(result);
}
//--- Eigen vectors are stored in Z
if(zneeded==2)
{
//--- Find eigen pairs
result=InternalBisectionEigenValues(d1,e1,n,2,2,a,b,0,0,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result || m==0)
{
m=0;
return(result);
}
//--- function call
InternalDStein(n,d1,e1,m,w,iblock,isplit,z2,ifail,cr);
//--- check
if(cr!=0)
{
m=0;
result=false;
return(result);
}
//--- Sort eigen values and vectors
for(i=1;i<=m;i++)
{
k=i;
for(j=i;j<=m;j++)
{
//--- check
if(w[j]<w[k])
k=j;
}
//--- swap
v=w[i];
w[i]=w[k];
w[k]=v;
for(j=1;j<=n;j++)
{
//--- swap
v=z2[j][i];
z2[j].Set(i,z2[j][k]);
z2[j].Set(k,v);
}
}
//--- Store W
ArrayResizeAL(d,m);
for(i=1;i<=m;i++)
d[i-1]=w[i];
z.Resize(n,m);
for(i=1;i<=m;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i_].Set(i-1,z2[i_+i1_][i]);
}
//--- return result
return(result);
}
//--- return result
return(false);
}
//+------------------------------------------------------------------+
//| Subroutine for finding tridiagonal matrix eigenvalues/vectors |
//| with given indexes (in ascending order) by using the bisection |
//| and inverse iteraion. |
//| Input parameters: |
//| D - the main diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-1]. |
//| E - the secondary diagonal of a tridiagonal matrix. |
//| Array whose index ranges within [0..N-2]. |
//| N - size of matrix. N>=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. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::SMatrixTdEVDI(double &d[],double &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
int iblock[];
int isplit[];
int ifail[];
double w[];
double d1[];
double e1[];
//--- create matrix
CMatrixDouble z2;
CMatrixDouble z3;
//--- check
if(!CAp::Assert((0<=i1 && i1<=i2) && i2<n,__FUNCTION__+": incorrect I1/I2!"))
return(false);
//--- Copy D,E to D1, E1
ArrayResizeAL(d1,n+1);
i1_=-1;
for(i_=1;i_<=n;i_++)
d1[i_]=d[i_+i1_];
//--- check
if(n>1)
{
ArrayResizeAL(e1,n);
i1_=-1;
for(i_=1;i_<n;i_++)
e1[i_]=e[i_+i1_];
}
//--- No eigen vectors
if(zneeded==0)
{
result=InternalBisectionEigenValues(d1,e1,n,3,1,0,0,i1+1,i2+1,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result)
return(result);
//--- check
if(m!=i2-i1+1)
{
result=false;
return(result);
}
ArrayResizeAL(d,m);
for(i=1;i<=m;i++)
d[i-1]=w[i];
//--- return result
return(result);
}
//--- Eigen vectors are multiplied by Z
if(zneeded==1)
{
//--- Find eigen pairs
result=InternalBisectionEigenValues(d1,e1,n,3,2,0,0,i1+1,i2+1,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result)
return(result);
//--- check
if(m!=i2-i1+1)
{
result=false;
return(result);
}
//--- function call
InternalDStein(n,d1,e1,m,w,iblock,isplit,z2,ifail,cr);
//--- check
if(cr!=0)
{
result=false;
return(result);
}
//--- Sort eigen values and vectors
for(i=1;i<=m;i++)
{
k=i;
for(j=i;j<=m;j++)
{
//--- check
if(w[j]<w[k])
k=j;
}
//--- swap
v=w[i];
w[i]=w[k];
w[k]=v;
for(j=1;j<=n;j++)
{
//--- swap
v=z2[j][i];
z2[j].Set(i,z2[j][k]);
z2[j].Set(k,v);
}
}
//--- Transform Z2 and overwrite Z
z3.Resize(m+1,n+1);
for(i=1;i<=m;i++)
for(i_=1;i_<=n;i_++)
z3[i].Set(i_,z2[i_][i]);
for(i=1;i<=n;i++)
{
for(j=1;j<=m;j++)
{
i1_=1;
v=0.0;
for(i_=0;i_<n;i_++)
v+=z[i-1][i_]*z3[j][i_+i1_];
z2[i].Set(j,v);
}
}
//--- rewrite z
z.Resize(n,m);
for(i=1;i<=m;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i_].Set(i-1,z2[i_+i1_][i]);
}
//--- Store W
ArrayResizeAL(d,m);
for(i=1;i<=m;i++)
d[i-1]=w[i];
//--- return result
return(result);
}
//--- Eigen vectors are stored in Z
if(zneeded==2)
{
//--- Find eigen pairs
result=InternalBisectionEigenValues(d1,e1,n,3,2,0,0,i1+1,i2+1,-1,w,m,nsplit,iblock,isplit,errorcode);
//--- check
if(!result)
return(result);
//--- check
if(m!=i2-i1+1)
{
result=false;
return(result);
}
//--- function call
InternalDStein(n,d1,e1,m,w,iblock,isplit,z2,ifail,cr);
//--- check
if(cr!=0)
{
result=false;
return(result);
}
//--- Sort eigen values and vectors
for(i=1;i<=m;i++)
{
k=i;
for(j=i;j<=m;j++)
{
//--- check
if(w[j]<w[k])
k=j;
}
//--- swap
v=w[i];
w[i]=w[k];
w[k]=v;
for(j=1;j<=n;j++)
{
//--- swap
v=z2[j][i];
z2[j].Set(i,z2[j][k]);
z2[j].Set(k,v);
}
}
//--- Store Z
z.Resize(n,m);
for(i=1;i<=m;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
z[i_].Set(i-1,z2[i_+i1_][i]);
}
//--- Store W
ArrayResizeAL(d,m);
for(i=1;i<=m;i++)
d[i-1]=w[i];
//--- return result
return(result);
}
//--- return result
return(false);
}
//+------------------------------------------------------------------+
//| Finding eigenvalues and eigenvectors of a general matrix |
//| The algorithm finds eigenvalues and eigenvectors of a general |
//| matrix by using the QR algorithm with multiple shifts. The |
//| algorithm can find eigenvalues and both left and right |
//| eigenvectors. |
//| The right eigenvector is a vector x such that A*x = w*x, and the |
//| left eigenvector is a vector y such that y'*A = w*y' (here y' |
//| implies a complex conjugate transposition of vector y). |
//| Input parameters: |
//| A - matrix. Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| VNeeded - flag controlling whether eigenvectors are needed |
//| or not. If VNeeded is equal to: |
//| * 0, eigenvectors are not returned; |
//| * 1, right eigenvectors are returned; |
//| * 2, left eigenvectors are returned; |
//| * 3, both left and right eigenvectors are |
//| returned. |
//| Output parameters: |
//| WR - real parts of eigenvalues. |
//| Array whose index ranges within [0..N-1]. |
//| WR - imaginary parts of eigenvalues. |
//| Array whose index ranges within [0..N-1]. |
//| VL, VR - arrays of left and right eigenvectors (if they |
//| are needed). If WI[i]=0, the respective |
//| eigenvalue is a real number, and it corresponds |
//| to the column number I of matrices VL/VR. If |
//| WI[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. |
//+------------------------------------------------------------------+
static bool CEigenVDetect::RMatrixEVD(CMatrixDouble &ca,const int n,const int vneeded,
double &wr[],double &wi[],
CMatrixDouble &vl,CMatrixDouble &vr)
{
//--- create variables
int i=0;
int i_=0;
int i1_=0;
bool result;
//--- create arrays
double wr1[];
double wi1[];
//--- create matrix
CMatrixDouble a1;
CMatrixDouble vl1;
CMatrixDouble vr1;
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(vneeded>=0 && vneeded<=3,__FUNCTION__+": incorrect VNeeded!"))
return(false);
a1.Resize(n+1,n+1);
for(i=1;i<=n;i++)
{
i1_=-1;
for(i_=1;i_<=n;i_++)
a1[i].Set(i_,a[i-1][i_+i1_]);
}
//--- get result
result=NonSymmetricEVD(a1,n,vneeded,wr1,wi1,vl1,vr1);
//--- check
if(result)
{
//--- allocation
ArrayResizeAL(wr,n);
ArrayResizeAL(wi,n);
i1_=1;
for(i_=0;i_<n;i_++)
wr[i_]=wr1[i_+i1_];
i1_=1;
for(i_=0;i_<n;i_++)
wi[i_]=wi1[i_+i1_];
//--- check
if(vneeded==2 || vneeded==3)
{
vl.Resize(n,n);
for(i=0;i<n;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
vl[i].Set(i_,vl1[i+1][i_+i1_]);
}
}
//--- check
if(vneeded==1 || vneeded==3)
{
vr.Resize(n,n);
for(i=0;i<n;i++)
{
i1_=1;
for(i_=0;i_<n;i_++)
vr[i].Set(i_,vr1[i+1][i_+i1_]);
}
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Eigenvalues and eigenvectors in tridiagonal matrix |
//+------------------------------------------------------------------+
static bool CEigenVDetect::TtidiagonalEVD(double &d[],double &ce[],const int n,
const int zneeded,CMatrixDouble &z)
{
//--- create variables
bool result;
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 mm=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;
bool gotoflag;
int zrows=0;
bool wastranspose;
int i_=0;
//--- create arrays
double work1[];
double work2[];
double workc[];
double works[];
double wtemp[];
//--- create copy
double e[];
ArrayResizeAL(e,ArraySize(ce));
ArrayCopy(e,ce);
//--- check
if(!CAp::Assert(zneeded>=0 && zneeded<=3,__FUNCTION__+": Incorrent ZNeeded"))
return(false);
//--- check
if(zneeded<0 || zneeded>3)
return(false);
//--- initialization
result=true;
//--- check
if(n==0)
return(result);
//--- check
if(n==1)
{
//--- check
if(zneeded==2 || zneeded==3)
{
z.Resize(2,2);
z[1].Set(1,1);
}
//--- return result
return(result);
}
//--- initialization
maxit=30;
//--- allocation
ArrayResizeAL(wtemp,n+1);
ArrayResizeAL(work1,n);
ArrayResizeAL(work2,n);
ArrayResizeAL(workc,n+1);
ArrayResizeAL(works,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;
//--- Here we are using transposition to get rid of column operations
wastranspose=false;
zrows=0;
//--- check
if(zneeded==1)
zrows=n;
//--- check
if(zneeded==2)
zrows=n;
//--- check
if(zneeded==3)
zrows=1;
//--- check
if(zneeded==1)
{
wastranspose=true;
//--- function call
CBlas::InplaceTranspose(z,1,n,1,n,wtemp);
}
//--- check
if(zneeded==2)
{
wastranspose=true;
z.Resize(n+1,n+1);
for(i=1;i<=n;i++)
{
for(j=1;j<=n;j++)
{
//--- check
if(i==j)
z[i].Set(j,1);
else
z[i].Set(j,0);
}
}
}
//--- check
if(zneeded==3)
{
wastranspose=false;
z.Resize(2,n+1);
for(j=1;j<=n;j++)
{
//--- check
if(j==1)
z[1].Set(j,1);
else
z[1].Set(j,0);
}
}
//--- initialization
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)
{
//--- check
if(l1>n)
break;
//--- check
if(l1>1)
e[l1-1]=0;
gotoflag=false;
m=l1;
//--- check
if(l1<=nm1)
{
for(m=l1;m<=nm1;m++)
{
tst=MathAbs(e[m]);
//--- check
if(tst==0.0)
{
gotoflag=true;
//--- break the cycle
break;
}
//--- check
if(tst<=MathSqrt(MathAbs(d[m]))*MathSqrt(MathAbs(d[m+1]))*eps)
{
e[m]=0;
gotoflag=true;
//--- break the cycle
break;
}
}
}
//--- check
if(!gotoflag)
m=n;
//--- change values
l=l1;
lsv=l;
lend=m;
lendsv=lend;
l1=m+1;
//--- check
if(lend==l)
continue;
//--- Scale submatrix in rows and columns L to LEND
if(l==lend)
anorm=MathAbs(d[l]);
else
{
anorm=MathMax(MathAbs(d[l])+MathAbs(e[l]),MathAbs(e[lend-1])+MathAbs(d[lend]));
for(i=l+1;i<=lend-1;i++)
anorm=MathMax(anorm,MathAbs(d[i])+MathAbs(e[i])+MathAbs(e[i-1]));
}
iscale=0;
//--- check
if(anorm==0.0)
continue;
//--- check
if(anorm>(double)(ssfmax))
{
iscale=1;
tmp=ssfmax/anorm;
tmpint=lend-1;
for(i_=l;i_<=lend;i_++)
d[i_]=tmp*d[i_];
for(i_=l;i_<=tmpint;i_++)
e[i_]=tmp*e[i_];
}
//--- check
if(anorm<ssfmin)
{
iscale=2;
tmp=ssfmin/anorm;
tmpint=lend-1;
for(i_=l;i_<=lend;i_++)
d[i_]=tmp*d[i_];
for(i_=l;i_<=tmpint;i_++)
e[i_]=tmp*e[i_];
}
//--- Choose between QL and QR iteration
if(MathAbs(d[lend])<MathAbs(d[l]))
{
lend=lsv;
l=lendsv;
}
//--- check
if(lend>l)
{
//--- QL Iteration
//--- Look for small subdiagonal element.
while(true)
{
gotoflag=false;
//--- check
if(l!=lend)
{
lendm1=lend-1;
for(m=l;m<=lendm1;m++)
{
tst=CMath::Sqr(MathAbs(e[m]));
//--- check
if(tst<=eps2*MathAbs(d[m])*MathAbs(d[m+1])+safmin)
{
gotoflag=true;
//--- break the cycle
break;
}
}
}
//--- check
if(!gotoflag)
m=lend;
//--- check
if(m<lend)
e[m]=0;
p=d[l];
//--- check
if(m!=l)
{
//--- If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
//--- to compute its eigensystem.
if(m==l+1)
{
//--- check
if(zneeded>0)
{
//--- function call
TdEVDEv2(d[l],e[l],d[l+1],rt1,rt2,c,s);
//--- change values
work1[l]=c;
work2[l]=s;
workc[1]=work1[l];
works[1]=work2[l];
//--- check
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
//--- function call
TdEVDE2(d[l],e[l],d[l+1],rt1,rt2);
//--- change values
d[l]=rt1;
d[l+1]=rt2;
e[l]=0;
l=l+2;
//--- check
if(l<=lend)
continue;
//--- break the cycle
break;
}
//--- check
if(jtot==nmaxit)
break;
jtot=jtot+1;
//--- Form shift.
g=(d[l+1]-p)/(2*e[l]);
//--- function call
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];
//--- function call
CRotations::GenerateRotation(g,f,c,s,r);
//--- check
if(i!=m-1)
e[i+1]=r;
g=d[i+1]-p;
r=(d[i]-g)*s+2*c*b;
p=s*r;
d[i+1]=g+p;
g=c*r-b;
//--- If eigenvectors are desired, then save rotations.
if(zneeded>0)
{
work1[i]=c;
work2[i]=-s;
}
}
//--- If eigenvectors are desired, then apply saved rotations.
if(zneeded>0)
{
for(i=l;i<m;i++)
{
workc[i-l+1]=work1[i];
works[i-l+1]=work2[i];
}
//--- check
if(!wastranspose)
{
//--- function call
CRotations::ApplyRotationsFromTheRight(false,1,zrows,l,m,workc,works,z,wtemp);
}
else
{
//--- function call
CRotations::ApplyRotationsFromTheLeft(false,l,m,1,zrows,workc,works,z,wtemp);
}
}
d[l]=d[l]-p;
e[l]=g;
continue;
}
//--- Eigenvalue found.
d[l]=p;
l=l+1;
//--- check
if(l<=lend)
continue;
//--- break the cycle
break;
}
}
else
{
//--- QR Iteration
//--- Look for small superdiagonal element.
while(true)
{
gotoflag=false;
//--- check
if(l!=lend)
{
lendp1=lend+1;
for(m=l;m>=lendp1;m--)
{
tst=CMath::Sqr(MathAbs(e[m-1]));
//--- check
if(tst<=(double)(eps2*MathAbs(d[m])*MathAbs(d[m-1])+safmin))
{
gotoflag=true;
//--- break the cycle
break;
}
}
}
//--- check
if(!gotoflag)
m=lend;
//--- check
if(m>lend)
e[m-1]=0;
p=d[l];
//--- check
if(m!=l)
{
//--- If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
//--- to compute its eigensystem.
if(m==l-1)
{
//--- check
if(zneeded>0)
{
//--- function call
TdEVDEv2(d[l-1],e[l-1],d[l],rt1,rt2,c,s);
work1[m]=c;
work2[m]=s;
workc[1]=c;
works[1]=s;
//--- check
if(!wastranspose)
{
//--- function call
CRotations::ApplyRotationsFromTheRight(true,1,zrows,l-1,l,workc,works,z,wtemp);
}
else
{
//--- function call
CRotations::ApplyRotationsFromTheLeft(true,l-1,l,1,zrows,workc,works,z,wtemp);
}
}
else
{
//--- function call
TdEVDE2(d[l-1],e[l-1],d[l],rt1,rt2);
}
d[l-1]=rt1;
d[l]=rt2;
e[l-1]=0;
l=l-2;
//--- check
if(l>=lend)
continue;
//--- break the cycle
break;
}
//--- check
if(jtot==nmaxit)
break;
jtot=jtot+1;
//--- Form shift.
g=(d[l-1]-p)/(2*e[l-1]);
//--- function call
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];
//--- function call
CRotations::GenerateRotation(g,f,c,s,r);
//--- check
if(i!=m)
e[i-1]=r;
//--- change values
g=d[i]-p;
r=(d[i+1]-g)*s+2*c*b;
p=s*r;
d[i]=g+p;
g=c*r-b;
//--- If eigenvectors are desired, then save rotations.
if(zneeded>0)
{
work1[i]=c;
work2[i]=s;
}
}
//--- If eigenvectors are desired, then apply saved rotations.
if(zneeded>0)
{
mm=l-m+1;
for(i=m;i<=l-1;i++)
{
workc[i-m+1]=work1[i];
works[i-m+1]=work2[i];
}
//--- check
if(!wastranspose)
{
//--- function call
CRotations::ApplyRotationsFromTheRight(true,1,zrows,m,l,workc,works,z,wtemp);
}
else
{
//--- function call
CRotations::ApplyRotationsFromTheLeft(true,m,l,1,zrows,workc,works,z,wtemp);
}
}
d[l]=d[l]-p;
e[lm1]=g;
continue;
}
//--- Eigenvalue found.
d[l]=p;
l=l-1;
//--- check
if(l>=lend)
continue;
//--- break the cycle
break;
}
}
//--- Undo scaling if necessary
if(iscale==1)
{
tmp=anorm/ssfmax;
tmpint=lendsv-1;
for(i_=lsv;i_<=lendsv;i_++)
d[i_]=tmp*d[i_];
for(i_=lsv;i_<=tmpint;i_++)
e[i_]=tmp*e[i_];
}
//--- check
if(iscale==2)
{
tmp=anorm/ssfmin;
tmpint=lendsv-1;
for(i_=lsv;i_<=lendsv;i_++)
d[i_]=tmp*d[i_];
for(i_=lsv;i_<=tmpint;i_++)
e[i_]=tmp*e[i_];
}
//--- Check for no convergence to an eigenvalue after a total
//--- of N*MAXIT iterations.
if(jtot>=nmaxit)
{
result=false;
//--- check
if(wastranspose)
{
//--- function call
CBlas::InplaceTranspose(z,1,n,1,n,wtemp);
}
//--- return result
return(result);
}
}
//--- Order eigenvalues and eigenvectors.
if(zneeded==0)
{
//--- Sort
if(n==1)
return(result);
//--- check
if(n==2)
{
//--- check
if(d[1]>d[2])
{
tmp=d[1];
d[1]=d[2];
d[2]=tmp;
}
//--- return result
return(result);
}
i=2;
do
{
t=i;
while(t!=1)
{
k=t/2;
//--- check
if(d[k]>=d[t])
t=1;
else
{
//--- change values
tmp=d[k];
d[k]=d[t];
d[t]=tmp;
t=k;
}
}
i=i+1;
}
//--- cycle
while(i<=n);
i=n-1;
do
{
tmp=d[i+1];
d[i+1]=d[1];
d[1]=tmp;
t=1;
while(t!=0)
{
k=2*t;
//--- check
if(k>i)
t=0;
else
{
//--- check
if(k<i)
{
//--- check
if(d[k+1]>d[k])
k=k+1;
}
//--- check
if(d[t]>=d[k])
t=0;
else
{
//--- change values
tmp=d[k];
d[k]=d[t];
d[t]=tmp;
t=k;
}
}
}
i=i-1;
}
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++)
{
//--- check
if(d[j]<p)
{
k=j;
p=d[j];
}
}
//--- check
if(k!=i)
{
d[k]=d[i];
d[i]=p;
//--- check
if(wastranspose)
{
for(i_=1;i_<=n;i_++)
wtemp[i_]=z[i][i_];
for(i_=1;i_<=n;i_++)
z[i].Set(i_,z[k][i_]);
for(i_=1;i_<=n;i_++)
z[k].Set(i_,wtemp[i_]);
}
else
{
for(i_=1;i_<=zrows;i_++)
wtemp[i_]=z[i_][i];
for(i_=1;i_<=zrows;i_++)
z[i_].Set(i,z[i_][k]);
for(i_=1;i_<=zrows;i_++)
z[i_].Set(k,wtemp[i_]);
}
}
}
//--- check
if(wastranspose)
{
//--- function call
CBlas::InplaceTranspose(z,1,n,1,n,wtemp);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix |
//| [ A B ] |
//| [ B C ]. |
//| On return, RT1 is the eigenvalue of larger absolute value, and |
//| RT2 is the eigenvalue of smaller absolute value. |
//| -- 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 |
//+------------------------------------------------------------------+
static void CEigenVDetect::TdEVDE2(const double a,const double b,const double c,
double &rt1,double &rt2)
{
//--- create variables
double ab=0;
double acmn=0;
double acmx=0;
double adf=0;
double df=0;
double rt=0;
double sm=0;
double tb=0;
//--- initialization
rt1=0;
rt2=0;
sm=a+c;
df=a-c;
adf=MathAbs(df);
tb=b+b;
ab=MathAbs(tb);
//--- check
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(adf<ab)
rt=ab*MathSqrt(1+CMath::Sqr(adf/ab));
else
{
//--- Includes case AB=ADF=0
rt=ab*MathSqrt(2);
}
}
//--- check
if(sm<0.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
{
//--- check
if(sm>0.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 |
//+------------------------------------------------------------------+
static void CEigenVDetect::TdEVDEv2(const double a,const double b,const double c,
double &rt1,double &rt2,double &cs1,double &sn1)
{
//--- create variables
int sgn1=0;
int sgn2=0;
double ab=0;
double acmn=0;
double acmx=0;
double acs=0;
double adf=0;
double cs=0;
double ct=0;
double df=0;
double rt=0;
double sm=0;
double tb=0;
double tn=0;
//--- initialization
rt1=0;
rt2=0;
cs1=0;
sn1=0;
//--- Compute the eigenvalues
sm=a+c;
df=a-c;
adf=MathAbs(df);
tb=b+b;
ab=MathAbs(tb);
//--- check
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(adf<ab)
rt=ab*MathSqrt(1+CMath::Sqr(adf/ab));
else
{
//--- Includes case AB=ADF=0
rt=ab*MathSqrt(2);
}
}
//--- check
if(sm<0.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
{
//--- check
if(sm>0.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 |
//+------------------------------------------------------------------+
static double CEigenVDetect::TdEVDPythag(const double a,const double b)
{
//--- create variables
double result=0;
//--- check
if(MathAbs(a)<MathAbs(b))
result=MathAbs(b)*MathSqrt(1+CMath::Sqr(a/b));
else
result=MathAbs(a)*MathSqrt(1+CMath::Sqr(b/a));
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Internal routine |
//+------------------------------------------------------------------+
static double CEigenVDetect::TdEVDExtSign(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);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static bool CEigenVDetect::InternalBisectionEigenValues(double &cd[],double &ce[],
const int n,int irange,
const int iorder,const double vl,
const double vu,const int il,
const int iu,const double abstol,
double &w[],int &m,
int &nsplit,int &iblock[],
int &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
int idumma[];
double work[];
int iwork[];
int ia1s2[];
double ra1s2[];
double ra1siin[];
double ra2siin[];
double ra3siin[];
double ra4siin[];
int iworkspace[];
double rworkspace[];
//--- create matrix
CMatrixDouble ra1s2x2;
CMatrixInt ia1s2x2;
CMatrixDouble ra1siinx2;
CMatrixInt ia1siinx2;
//--- create copy
double d[];
ArrayResizeAL(d,ArraySize(cd));
ArrayCopy(d,cd);
//--- create copy
double e[];
ArrayResizeAL(e,ArraySize(ce));
ArrayCopy(e,ce);
//--- initialization
m=0;
nsplit=0;
errorcode=0;
//--- check
if(n==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
ArrayResizeAL(idumma,2);
ArrayResizeAL(work,4*n+1);
ArrayResizeAL(iwork,3*n+1);
ArrayResizeAL(w,n+1);
ArrayResizeAL(iblock,n+1);
ArrayResizeAL(isplit,n+1);
ArrayResizeAL(ia1s2,3);
ArrayResizeAL(ra1s2,3);
ArrayResizeAL(ra1siin,n+1);
ArrayResizeAL(ra2siin,n+1);
ArrayResizeAL(ra3siin,n+1);
ArrayResizeAL(ra4siin,n+1);
ArrayResizeAL(iworkspace,n+1);
ArrayResizeAL(rworkspace,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;
//--- check
if(iorder<=0 || iorder>=3)
errorcode=-5;
//--- check
if(n<0)
errorcode=-3;
//--- check
if(irange==2 && vl>=vu)
errorcode=-6;
//--- check
if(irange==3 && (il<1 || il>MathMax(1,n)))
errorcode=-8;
//--- check
if(irange==3 && (iu<MathMin(n,il) || iu>n))
errorcode=-9;
//--- check
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[1]=1;
//--- check
if((irange==2 && vl>=d[1]) || vu<d[1])
m=0;
else
{
w[1]=d[1];
iblock[1]=1;
m=1;
}
//--- return result
return(true);
}
//--- Scaling
t=MathAbs(d[n]);
for(j=1;j<n;j++)
{
t=MathMax(t,MathAbs(d[j]));
t=MathMax(t,MathAbs(e[j]));
}
scalefactor=1;
//--- check
if(t!=0.0)
{
//--- check
if(t>MathSqrt(MathSqrt(CMath::m_minrealnumber))*MathSqrt(CMath::m_maxrealnumber))
scalefactor=t;
//--- check
if(t<MathSqrt(MathSqrt(CMath::m_maxrealnumber))*MathSqrt(CMath::m_minrealnumber))
scalefactor=t;
for(j=1;j<n;j++)
{
d[j]=d[j]/scalefactor;
e[j]=e[j]/scalefactor;
}
d[n]=d[n]/scalefactor;
}
//--- Compute Splitting Points
nsplit=1;
work[n]=0;
pivmin=1;
for(j=2;j<=n;j++)
{
tmp1=CMath::Sqr(e[j-1]);
//--- check
if(MathAbs(d[j]*d[j-1])*CMath::Sqr(ulp)+safemn>tmp1)
{
isplit[nsplit]=j-1;
nsplit=nsplit+1;
work[j-1]=0;
}
else
{
work[j-1]=tmp1;
pivmin=MathMax(pivmin,tmp1);
}
}
isplit[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;j++)
{
//--- change values
tmp2=MathSqrt(work[j]);
gu=MathMax(gu,d[j]+tmp1+tmp2);
gl=MathMin(gl,d[j]-tmp1-tmp2);
tmp1=tmp2;
}
//--- change values
gu=MathMax(gu,d[n]+tmp1);
gl=MathMin(gl,d[n]-tmp1);
tnorm=MathMax(MathAbs(gl),MathAbs(gu));
gl=gl-fudge*tnorm*ulp*n-fudge*2*pivmin;
gu=gu+fudge*tnorm*ulp*n+fudge*pivmin;
//--- Compute Iteration parameters
itmax=(int)MathCeil((MathLog(tnorm+pivmin)-MathLog(pivmin))/MathLog(2))+2;
//--- check
if(abstol<=0.0)
atoli=ulp*tnorm;
else
atoli=abstol;
//--- change values
work[n+1]=gl;
work[n+2]=gl;
work[n+3]=gu;
work[n+4]=gu;
work[n+5]=gl;
work[n+6]=gu;
iwork[1]=-1;
iwork[2]=-1;
iwork[3]=n+1;
iwork[4]=n+1;
iwork[5]=il-1;
iwork[6]=iu;
//--- Calling DLAEBZ
//--- DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
//--- WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
//--- IWORK, W, IBLOCK, IINFO )
ia1s2[1]=iwork[5];
ia1s2[2]=iwork[6];
ra1s2[1]=work[n+5];
ra1s2[2]=work[n+6];
ra1s2x2[1].Set(1,work[n+1]);
ra1s2x2[2].Set(1,work[n+2]);
ra1s2x2[1].Set(2,work[n+3]);
ra1s2x2[2].Set(2,work[n+4]);
ia1s2x2[1].Set(1,iwork[1]);
ia1s2x2[2].Set(1,iwork[2]);
ia1s2x2[1].Set(2,iwork[3]);
ia1s2x2[2].Set(2,iwork[4]);
//--- function call
InternalDLAEBZ(3,itmax,n,2,2,atoli,rtoli,pivmin,d,e,work,ia1s2,ra1s2x2,ra1s2,iout,ia1s2x2,w,iblock,iinfo);
iwork[5]=ia1s2[1];
iwork[6]=ia1s2[2];
work[n+5]=ra1s2[1];
work[n+6]=ra1s2[2];
work[n+1]=ra1s2x2[1][1];
work[n+2]=ra1s2x2[2][1];
work[n+3]=ra1s2x2[1][2];
work[n+4]=ra1s2x2[2][2];
iwork[1]=ia1s2x2[1][1];
iwork[2]=ia1s2x2[2][1];
iwork[3]=ia1s2x2[1][2];
iwork[4]=ia1s2x2[2][2];
//--- check
if(iwork[6]==iu)
{
//--- change values
wl=work[n+1];
wlu=work[n+3];
nwl=iwork[1];
wu=work[n+4];
wul=work[n+2];
nwu=iwork[4];
}
else
{
//--- change values
wl=work[n+2];
wlu=work[n+4];
nwl=iwork[2];
wu=work[n+3];
wul=work[n+1];
nwu=iwork[3];
}
//--- check
if(nwl<0 || nwl>=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<n;j++)
tnorm=MathMax(tnorm,MathAbs(d[j])+MathAbs(e[j-1])+MathAbs(e[j]));
//--- check
if(abstol<=0.0)
atoli=ulp*tnorm;
else
atoli=abstol;
//--- check
if(irange==2)
{
wl=vl;
wu=vu;
}
else
{
wl=0;
wu=0;
}
}
//--- Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
//--- NWL accumulates the number of eigenvalues .le. WL,
//--- NWU accumulates the number of eigenvalues .le. WU
m=0;
iend=0;
errorcode=0;
nwl=0;
nwu=0;
for(jb=1;jb<=nsplit;jb++)
{
ioff=iend;
ibegin=ioff+1;
iend=isplit[jb];
iin=iend-ioff;
//--- check
if(iin==1)
{
//--- check
if(irange==1 || wl>=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) && wu>=d[ibegin]-pivmin)
{
m=m+1;
w[m]=d[ibegin];
iblock[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;j<=iend-1;j++)
{
//--- change values
tmp2=MathAbs(e[j]);
gu=MathMax(gu,d[j]+tmp1+tmp2);
gl=MathMin(gl,d[j]-tmp1-tmp2);
tmp1=tmp2;
}
//--- change values
gu=MathMax(gu,d[iend]+tmp1);
gl=MathMin(gl,d[iend]-tmp1);
bnorm=MathMax(MathAbs(gl),MathAbs(gu));
gl=gl-fudge*bnorm*ulp*iin-fudge*pivmin;
gu=gu+fudge*bnorm*ulp*iin+fudge*pivmin;
//--- Compute ATOLI for the current submatrix
if(abstol<=0.0)
atoli=ulp*MathMax(MathAbs(gl),MathAbs(gu));
else
atoli=abstol;
//--- check
if(irange>1)
{
//--- check
if(gu<wl)
{
nwl=nwl+iin;
nwu=nwu+iin;
continue;
}
gl=MathMax(gl,wl);
gu=MathMin(gu,wu);
//--- check
if(gl>=gu)
continue;
}
//--- Set Up Initial Interval
work[n+1]=gl;
work[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[tmpi]=d[ibegin-1+tmpi];
//--- check
if(ibegin-1+tmpi<n)
ra2siin[tmpi]=e[ibegin-1+tmpi];
//--- change values
ra3siin[tmpi]=work[ibegin-1+tmpi];
ra1siinx2[tmpi].Set(1,work[n+tmpi]);
ra1siinx2[tmpi].Set(2,work[n+tmpi+iin]);
ra4siin[tmpi]=work[n+2*iin+tmpi];
rworkspace[tmpi]=w[m+tmpi];
iworkspace[tmpi]=iblock[m+tmpi];
ia1siinx2[tmpi].Set(1,iwork[tmpi]);
ia1siinx2[tmpi].Set(2,iwork[tmpi+iin]);
}
//--- function call
InternalDLAEBZ(1,0,iin,iin,1,atoli,rtoli,pivmin,ra1siin,ra2siin,ra3siin,idumma,ra1siinx2,ra4siin,im,ia1siinx2,rworkspace,iworkspace,iinfo);
for(tmpi=1;tmpi<=iin;tmpi++)
{
//--- change values
work[n+tmpi]=ra1siinx2[tmpi][1];
work[n+tmpi+iin]=ra1siinx2[tmpi][2];
work[n+2*iin+tmpi]=ra4siin[tmpi];
w[m+tmpi]=rworkspace[tmpi];
iblock[m+tmpi]=iworkspace[tmpi];
iwork[tmpi]=ia1siinx2[tmpi][1];
iwork[tmpi+iin]=ia1siinx2[tmpi][2];
}
nwl=nwl+iwork[1];
nwu=nwu+iwork[iin+1];
iwoff=m-iwork[1];
//--- Compute Eigenvalues
itmax=(int)MathCeil((MathLog(gu-gl+pivmin)-MathLog(pivmin))/MathLog(2))+2;
//--- Calling DLAEBZ
//--- CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
//--- D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
//--- IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
//--- IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
for(tmpi=1;tmpi<=iin;tmpi++)
{
ra1siin[tmpi]=d[ibegin-1+tmpi];
//--- check
if(ibegin-1+tmpi<n)
ra2siin[tmpi]=e[ibegin-1+tmpi];
//--- change values
ra3siin[tmpi]=work[ibegin-1+tmpi];
ra1siinx2[tmpi].Set(1,work[n+tmpi]);
ra1siinx2[tmpi].Set(2,work[n+tmpi+iin]);
ra4siin[tmpi]=work[n+2*iin+tmpi];
rworkspace[tmpi]=w[m+tmpi];
iworkspace[tmpi]=iblock[m+tmpi];
ia1siinx2[tmpi].Set(1,iwork[tmpi]);
ia1siinx2[tmpi].Set(2,iwork[tmpi+iin]);
}
//--- function call
InternalDLAEBZ(2,itmax,iin,iin,1,atoli,rtoli,pivmin,ra1siin,ra2siin,ra3siin,idumma,ra1siinx2,ra4siin,iout,ia1siinx2,rworkspace,iworkspace,iinfo);
for(tmpi=1;tmpi<=iin;tmpi++)
{
//--- change values
work[n+tmpi]=ra1siinx2[tmpi][1];
work[n+tmpi+iin]=ra1siinx2[tmpi][2];
work[n+2*iin+tmpi]=ra4siin[tmpi];
w[m+tmpi]=rworkspace[tmpi];
iblock[m+tmpi]=iworkspace[tmpi];
iwork[tmpi]=ia1siinx2[tmpi][1];
iwork[tmpi+iin]=ia1siinx2[tmpi][2];
}
//--- Copy Eigenvalues Into W and IBLOCK
//--- Use -JB for block number for unconverged eigenvalues.
for(j=1;j<=iout;j++)
{
tmp1=0.5*(work[j+n]+work[j+iin+n]);
//--- Flag non-convergence.
if(j>iout-iinfo)
{
ncnvrg=true;
ib=-jb;
}
else
ib=jb;
for(je=iwork[j]+1+iwoff;je<=iwork[j+iin]+iwoff;je++)
{
w[je]=tmp1;
iblock[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=im+1;
w[im]=w[je];
iblock[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[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[iw]=0;
}
}
im=0;
for(je=1;je<=m;je++)
{
//--- check
if(iblock[je]!=0)
{
im=im+1;
w[im]=w[je];
iblock[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]<tmp1)
{
ie=j;
tmp1=w[j];
}
}
//--- check
if(ie!=0)
{
//--- change values
itmp1=iblock[ie];
w[ie]=w[je];
iblock[ie]=iblock[je];
w[je]=tmp1;
iblock[je]=itmp1;
}
}
}
for(j=1;j<=m;j++)
w[j]=w[j]*scalefactor;
errorcode=0;
//--- check
if(ncnvrg)
errorcode=errorcode+1;
//--- check
if(toofew)
errorcode=errorcode+2;
result=errorcode==0;
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CEigenVDetect::InternalDStein(const int n,double &d[],double &ce[],
const int m,double &cw[],int &iblock[],
int &isplit[],CMatrixDouble &z,
int &ifail[],int &info)
{
//--- create variables
int maxits=0;
int extra=0;
int b1=0;
int blksiz=0;
int bn=0;
int gpind=0;
int i=0;
int iinfo=0;
int its=0;
int j=0;
int j1=0;
int jblk=0;
int jmax=0;
int nblk=0;
int nrmchk=0;
double dtpcrt=0;
double eps=0;
double eps1=0;
double nrm=0;
double onenrm=0;
double ortol=0;
double pertol=0;
double scl=0;
double sep=0;
double tol=0;
double xj=0;
double xjm=0;
double ztr=0;
bool tmpcriterion;
int ti=0;
int i1=0;
int i2=0;
double v=0;
int i_=0;
int i1_=0;
//--- create arrays
double work1[];
double work2[];
double work3[];
double work4[];
double work5[];
int iwork[];
//--- create copy
double e[];
ArrayResizeAL(e,ArraySize(ce));
ArrayCopy(e,ce);
//--- create copy
double w[];
ArrayResizeAL(w,ArraySize(cw));
ArrayCopy(w,cw);
//--- initialization
info=0;
maxits=5;
extra=2;
//--- allocation
ArrayResizeAL(work1,(int)MathMax(n,1)+1);
ArrayResizeAL(work2,(int)MathMax(n-1,1)+1);
ArrayResizeAL(work3,(int)MathMax(n,1)+1);
ArrayResizeAL(work4,(int)MathMax(n,1)+1);
ArrayResizeAL(work5,(int)MathMax(n,1)+1);
ArrayResizeAL(iwork,(int)MathMax(n,1)+1);
ArrayResizeAL(ifail,(int)MathMax(m,1)+1);
z.Resize((int)MathMax(n,1)+1,(int)MathMax(m,1)+1);
//--- initialization
gpind=0;
onenrm=0;
ortol=0;
dtpcrt=0;
xjm=0;
//--- check input parameters
info=0;
for(i=1;i<=m;i++)
ifail[i]=0;
//--- check
if(n<0)
{
info=-1;
return;
}
//--- check
if(m<0 || m>n)
{
info=-4;
return;
}
for(j=2;j<=m;j++)
{
//--- check
if(iblock[j]<iblock[j-1])
{
info=-6;
//--- break the cycle
break;
}
//--- check
if(iblock[j]==iblock[j-1] && w[j]<w[j-1])
{
info=-5;
//--- break the cycle
break;
}
}
//--- check
if(info!=0)
return;
//--- check
if(n==0 || m==0)
return;
//--- check
if(n==1)
{
z[1].Set(1,1);
return;
}
//--- Some preparations
ti=n-1;
for(i_=1;i_<=ti;i_++)
work1[i_]=e[i_];
ArrayResizeAL(e,n+1);
for(i_=1;i_<=ti;i_++)
e[i_]=work1[i_];
for(i_=1;i_<=m;i_++)
work1[i_]=w[i_];
ArrayResizeAL(w,n+1);
for(i_=1;i_<=m;i_++)
w[i_]=work1[i_];
//--- Get machine constants.
eps=CMath::m_machineepsilon;
//--- Compute eigenvectors of matrix blocks.
j1=1;
for(nblk=1;nblk<=iblock[m];nblk++)
{
//--- Find starting and ending indices of block nblk.
if(nblk==1)
b1=1;
else
b1=isplit[nblk-1]+1;
bn=isplit[nblk];
blksiz=bn-b1+1;
//--- check
if(blksiz!=1)
{
//--- Compute reorthogonalization criterion and stopping criterion.
gpind=b1;
onenrm=MathAbs(d[b1])+MathAbs(e[b1]);
onenrm=MathMax(onenrm,MathAbs(d[bn])+MathAbs(e[bn-1]));
for(i=b1+1;i<=bn-1;i++)
onenrm=MathMax(onenrm,MathAbs(d[i])+MathAbs(e[i-1])+MathAbs(e[i]));
ortol=0.001*onenrm;
dtpcrt=MathSqrt(0.1/blksiz);
}
//--- Loop through eigenvalues of block nblk.
jblk=0;
for(j=j1;j<=m;j++)
{
//--- check
if(iblock[j]!=nblk)
{
j1=j;
//--- break the cycle
break;
}
jblk=jblk+1;
xj=w[j];
//--- check
if(blksiz==1)
{
//--- Skip all the work if the block size is one.
work1[1]=1;
}
else
{
//--- If eigenvalues j and j-1 are too close, add a relatively
//--- small perturbation.
if(jblk>1)
{
eps1=MathAbs(eps*xj);
pertol=10*eps1;
sep=xj-xjm;
//--- check
if(sep<pertol)
xj=xjm+pertol;
}
its=0;
nrmchk=0;
//--- Get random starting vector.
for(ti=1;ti<=blksiz;ti++)
work1[ti]=2*CMath::RandomReal()-1;
//--- Copy the matrix T so it won't be destroyed in factorization.
for(ti=1;ti<=blksiz-1;ti++)
{
work2[ti]=e[b1+ti-1];
work3[ti]=e[b1+ti-1];
work4[ti]=d[b1+ti-1];
}
work4[blksiz]=d[b1+blksiz-1];
//--- Compute LU factors with partial pivoting ( PT = LU )
tol=0;
TdIninternalDLAGTF(blksiz,work4,xj,work2,work3,tol,work5,iwork,iinfo);
//--- Update iteration count.
do
{
its=its+1;
//--- check
if(its>maxits)
{
//--- If stopping criterion was not satisfied, update info and
//--- store eigenvector number in array ifail.
info=info+1;
ifail[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;
for(i_=1;i_<=blksiz;i_++)
work1[i_]=scl*work1[i_];
//--- 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<j;i++)
{
i1=b1;
i2=b1+blksiz-1;
i1_=i1-1;
ztr=0.0;
for(i_=1;i_<=blksiz;i_++)
ztr+=work1[i_]*z[i_+i1_][i];
i1_=i1-1;
for(i_=1;i_<=blksiz;i_++)
work1[i_]=work1[i_]-ztr*z[i_+i1_][i];
}
}
}
//--- Check the infinity norm of the iterate.
jmax=CBlas::VectorIdxAbsMax(work1,1,blksiz);
nrm=MathAbs(work1[jmax]);
//--- Continue for additional iterations after norm reaches
//--- stopping criterion.
tmpcriterion=false;
//--- check
if(nrm<dtpcrt)
tmpcriterion=true;
else
{
nrmchk=nrmchk+1;
//--- check
if(nrmchk<extra+1)
tmpcriterion=true;
}
}
while(tmpcriterion);
//--- Accept iterate as jth eigenvector.
scl=1/CBlas::VectorNorm2(work1,1,blksiz);
jmax=CBlas::VectorIdxAbsMax(work1,1,blksiz);
//--- check
if(work1[jmax]<0.0)
scl=-scl;
for(i_=1;i_<=blksiz;i_++)
work1[i_]=scl*work1[i_];
}
for(i=1;i<=n;i++)
z[i].Set(j,0);
for(i=1;i<=blksiz;i++)
z[b1+i-1].Set(j,work1[i]);
//--- Save the shift to check eigenvalue spacing at next iteration.
xjm=xj;
}
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CEigenVDetect::TdIninternalDLAGTF(const int n,double &a[],const double lambdav,
double &b[],double &c[],double tol,
double &d[],int &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[1]=a[1]-lambdav;
iin[n]=0;
//--- check
if(n==1)
{
//--- check
if(a[1]==0.0)
iin[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;k<n;k++)
{
a[k+1]=a[k+1]-lambdav;
scale2=MathAbs(c[k])+MathAbs(a[k+1]);
//--- check
if(k<n-1)
scale2=scale2+MathAbs(b[k+1]);
//--- check
if(a[k]==0.0)
piv1=0;
else
piv1=MathAbs(a[k])/scale1;
//--- check
if(c[k]==0.0)
{
iin[k]=0;
piv2=0;
scale1=scale2;
//--- check
if(k<n-1)
d[k]=0;
}
else
{
piv2=MathAbs(c[k])/scale2;
//--- check
if(piv2<=piv1)
{
//--- change values
iin[k]=0;
scale1=scale2;
c[k]=c[k]/a[k];
a[k+1]=a[k+1]-c[k]*b[k];
//--- check
if(k<n-1)
d[k]=0;
}
else
{
//--- change values
iin[k]=1;
mult=a[k]/c[k];
a[k]=c[k];
temp=a[k+1];
a[k+1]=b[k]-mult*temp;
if(k<n-1)
{
d[k]=b[k+1];
b[k+1]=-(mult*d[k]);
}
b[k]=temp;
c[k]=mult;
}
}
//--- check
if(MathMax(piv1,piv2)<=tl && iin[n]==0)
iin[n]=k;
}
//--- check
if(MathAbs(a[n])<=scale1*tl && iin[n]==0)
iin[n]=n;
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CEigenVDetect::TdIninternalDLAGTS(const int n,double &a[],double &b[],
double &c[],double &d[],int &iin[],
double &y[],double &tol,int &info)
{
//--- create variables
int k=0;
double absak=0;
double ak=0;
double bignum=0;
double eps=0;
double pert=0;
double sfmin=0;
double temp=0;
//--- initialization
info=0;
//--- check
if(n<0)
{
info=-1;
return;
}
//--- check
if(n==0)
return;
//--- initialization
eps=CMath::m_machineepsilon;
sfmin=CMath::m_minrealnumber;
bignum=1/sfmin;
//--- check
if(tol<=0.0)
{
tol=MathAbs(a[1]);
//--- check
if(n>1)
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]))));
tol=tol*eps;
//--- check
if(tol==0.0)
tol=eps;
}
for(k=2;k<=n;k++)
{
//--- check
if(iin[k-1]==0)
y[k]=y[k]-c[k-1]*y[k-1];
else
{
temp=y[k-1];
y[k-1]=y[k];
y[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(absak<sfmin)
{
//--- check
if(absak==0.0 || MathAbs(temp)*sfmin>absak)
{
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[k]=temp/ak;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static 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,double &d[],
double &e[],double &e2[],int &nval[],
CMatrixDouble &ab,double &c[],int &mout,
CMatrixInt &nab,double &work[],
int &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[ji][jp];
//--- check
if(MathAbs(tmp1)<pivmin)
tmp1=-pivmin;
nab[ji].Set(jp,0);
//--- check
if(tmp1<=0.0)
nab[ji].Set(jp,1);
for(j=2;j<=n;j++)
{
tmp1=d[j]-e2[j-1]/tmp1-ab[ji][jp];
//--- check
if(MathAbs(tmp1)<pivmin)
tmp1=-pivmin;
//--- check
if(tmp1<=0.0)
nab[ji].Set(jp,nab[ji][jp]+1);
}
}
mout=mout+nab[ji][2]-nab[ji][1];
}
//--- exit the function
return;
}
//--- Initialize for loop
//--- KF and KL have the following meaning:
//--- Intervals 1,...,KF-1 have converged.
//--- Intervals KF,...,KL still need to be refined.
kf=1;
kl=minp;
//--- If IJOB=2, initialize C.
//--- If IJOB=3, use the user-supplied starting point.
if(ijob==2)
{
for(ji=1;ji<=minp;ji++)
c[ji]=0.5*(ab[ji][1]+ab[ji][2]);
}
//--- Iteration loop
for(jit=1;jit<=nitmax;jit++)
{
//--- Loop over intervals
//--- Serial Version of the loop
klnew=kl;
for(ji=kf;ji<=kl;ji++)
{
//--- Compute N(w), the number of eigenvalues less than w
tmp1=c[ji];
tmp2=d[1]-tmp1;
itmp1=0;
//--- check
if(tmp2<=pivmin)
{
itmp1=1;
tmp2=MathMin(tmp2,-pivmin);
}
//--- A series of compiler directives to defeat vectorization
//--- for the next loop
//--- *$PL$ CMCHAR=' '
//--- CDIR$ NEXTSCALAR
//--- C$DIR SCALAR
//--- CDIR$ NEXT SCALAR
//--- CVD$L NOVECTOR
//--- CDEC$ NOVECTOR
//--- CVD$ NOVECTOR
//--- *VDIR NOVECTOR
//--- *VOCL LOOP,SCALAR
//--- CIBM PREFER SCALAR
//--- *$PL$ CMCHAR='*'
for(j=2;j<=n;j++)
{
tmp2=d[j]-e2[j-1]/tmp2-tmp1;
//--- check
if(tmp2<=pivmin)
{
itmp1=itmp1+1;
tmp2=MathMin(tmp2,-pivmin);
}
}
//--- check
if(ijob<=2)
{
//--- IJOB=2: Choose all intervals containing eigenvalues.
//--- Insure that N(w) is monotone
itmp1=MathMin(nab[ji][2],MathMax(nab[ji][1],itmp1));
//--- Update the Queue -- add intervals if both halves
//--- contain eigenvalues.
if(itmp1==nab[ji][2])
{
//--- No eigenvalue in the upper interval:
//--- just use the lower interval.
ab[ji].Set(2,tmp1);
}
else
{
//--- check
if(itmp1==nab[ji][1])
{
//--- No eigenvalue in the lower interval:
//--- just use the upper interval.
ab[ji].Set(1,tmp1);
}
else
{
//--- check
if(klnew<mmax)
{
//--- Eigenvalue in both intervals -- add upper to queue.
klnew=klnew+1;
ab[klnew].Set(2,ab[ji][2]);
nab[klnew].Set(2,nab[ji][2]);
ab[klnew].Set(1,tmp1);
nab[klnew].Set(1,itmp1);
ab[ji].Set(2,tmp1);
nab[ji].Set(2,itmp1);
}
else
{
info=mmax+1;
//--- exit the function
return;
}
}
}
}
else
{
//--- IJOB=3: Binary search. Keep only the interval
//--- containing w s.t. N(w) = NVAL
if(itmp1<=nval[ji])
{
ab[ji].Set(1,tmp1);
nab[ji].Set(1,itmp1);
}
//--- check
if(itmp1>=nval[ji])
{
ab[ji].Set(2,tmp1);
nab[ji].Set(2,itmp1);
}
}
}
kl=klnew;
//--- Check for convergence
kfnew=kf;
for(ji=kf;ji<=kl;ji++)
{
tmp1=MathAbs(ab[ji][2]-ab[ji][1]);
tmp2=MathMax(MathAbs(ab[ji][2]),MathAbs(ab[ji][1]));
//--- check
if(tmp1<(double)(MathMax(abstol,MathMax(pivmin,reltol*tmp2))) || nab[ji][1]>=nab[ji][2])
{
//--- Converged -- Swap with position KFNEW,
//--- then increment KFNEW
if(ji>kfnew)
{
tmp1=ab[ji][1];
tmp2=ab[ji][2];
itmp1=nab[ji][1];
itmp2=nab[ji][2];
//--- change values
ab[ji].Set(1,ab[kfnew][1]);
ab[ji].Set(2,ab[kfnew][2]);
nab[ji].Set(1,nab[kfnew][1]);
nab[ji].Set(2,nab[kfnew][2]);
ab[kfnew].Set(1,tmp1);
ab[kfnew].Set(2,tmp2);
nab[kfnew].Set(1,itmp1);
nab[kfnew].Set(2,itmp2);
//--- check
if(ijob==3)
{
itmp1=nval[ji];
nval[ji]=nval[kfnew];
nval[kfnew]=itmp1;
}
}
kfnew=kfnew+1;
}
}
kf=kfnew;
//--- Choose Midpoints
for(ji=kf;ji<=kl;ji++)
c[ji]=0.5*(ab[ji][1]+ab[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 |
//+------------------------------------------------------------------+
static void CEigenVDetect::InternalTREVC(CMatrixDouble &t,const int n,const int side,
const int howmny,bool &cvselect[],CMatrixDouble &vl,
CMatrixDouble &vr,int &m,int &info)
{
//--- create variables
bool allv;
bool bothv;
bool leftv;
bool over;
bool pair;
bool rightv;
bool somev;
int i=0;
int ierr=0;
int ii=0;
int ip=0;
int iis=0;
int j=0;
int j1=0;
int j2=0;
int jnxt=0;
int k=0;
int ki=0;
int n2=0;
double beta=0;
double bignum=0;
double emax=0;
double ovfl=0;
double rec=0;
double remax=0;
double scl=0;
double smin=0;
double smlnum=0;
double ulp=0;
double unfl=0;
double vcrit=0;
double vmax=0;
double wi=0;
double wr=0;
double xnorm=0;
bool skipflag;
int k1=0;
int k2=0;
int k3=0;
int k4=0;
double vt=0;
int i_=0;
int i1_=0;
//--- create arrays
double work[];
double temp[];
bool rswap4[];
bool zswap4[];
double civ4[];
double crv4[];
//--- create matrix
CMatrixDouble x;
CMatrixDouble temp11;
CMatrixDouble temp22;
CMatrixDouble temp11b;
CMatrixDouble temp21b;
CMatrixDouble temp12b;
CMatrixDouble temp22b;
CMatrixInt ipivot44;
//--- create copy
double vselect[];
ArrayResizeAL(vselect,ArraySize(cvselect));
ArrayCopy(vselect,cvselect);
//--- initialization
m=0;
info=0;
//--- allocation
x.Resize(3,3);
temp11.Resize(2,2);
temp11b.Resize(2,2);
temp21b.Resize(3,2);
temp12b.Resize(2,3);
temp22b.Resize(3,3);
temp22.Resize(3,3);
ArrayResizeAL(work,3*n+1);
ArrayResizeAL(temp,n+1);
ArrayResizeAL(rswap4,5);
ArrayResizeAL(zswap4,5);
ArrayResizeAL(civ4,5);
ArrayResizeAL(crv4,5);
ipivot44.Resize(5,5);
//--- check
if(howmny!=1)
{
//--- check
if(side==1 || side==3)
vr.Resize(n+1,n+1);
//--- check
if(side==2 || side==3)
vl.Resize(n+1,n+1);
}
//--- Decode and test the input parameters
bothv=side==3;
rightv=side==1 || bothv;
leftv=side==2 || bothv;
allv=howmny==2;
over=howmny==1;
somev=howmny==3;
info=0;
//--- check
if(n<0)
{
info=-2;
return;
}
//--- check
if(!rightv && !leftv)
{
info=-3;
return;
}
//--- check
if((!allv && !over) && !somev)
{
info=-4;
return;
}
//--- Set M to the number of columns required to store the selected
//--- eigenvectors, standardize the array SELECT if necessary, and
//--- test MM.
if(somev)
{
m=0;
pair=false;
for(j=1;j<=n;j++)
{
//--- check
if(pair)
{
pair=false;
vselect[j]=false;
}
else
{
//--- check
if(j<n)
{
//--- check
if(t[j+1][j]==0.0)
{
//--- check
if(vselect[j])
m=m+1;
}
else
{
pair=true;
//--- check
if(vselect[j] || vselect[j+1])
{
vselect[j]=true;
m=m+2;
}
}
}
else
{
//--- check
if(vselect[n])
m=m+1;
}
}
}
}
else
m=n;
//--- check
if(n==0)
return;
//--- Set the constants to control overflow.
unfl=CMath::m_minrealnumber;
ovfl=1/unfl;
ulp=CMath::m_machineepsilon;
smlnum=unfl*(n/ulp);
bignum=(1-ulp)/smlnum;
//--- Compute 1-norm of each column of strictly upper triangular
//--- part of T to control overflow in triangular solver.
work[1]=0;
for(j=2;j<=n;j++)
{
work[j]=0;
for(i=1;i<j;i++)
work[j]=work[j]+MathAbs(t[i][j]);
}
//--- Index IP is used to specify the real or complex eigenvalue:
//--- IP = 0, real eigenvalue,
//--- 1, first of conjugate complex pair: (wr,wi)
//--- -1, second of conjugate complex pair: (wr,wi)
n2=2*n;
//--- check
if(rightv)
{
//--- Compute right eigenvectors.
ip=0;
iis=m;
for(ki=n;ki>=1;ki--)
{
skipflag=false;
//--- check
if(ip==1)
skipflag=true;
else
{
//--- check
if(ki!=1)
{
//--- check
if(t[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[ki][ki];
wi=0;
//--- check
if(ip!=0)
wi=MathSqrt(MathAbs(t[ki][ki-1]))*MathSqrt(MathAbs(t[ki-1][ki]));
smin=MathMax(ulp*(MathAbs(wr)+MathAbs(wi)),smlnum);
//--- check
if(ip==0)
{
//--- Real right eigenvector
work[ki+n]=1;
//--- Form right-hand side
for(k=1;k<=ki-1;k++)
work[k+n]=-t[k][ki];
//--- Solve the upper quasi-triangular system:
//--- (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
jnxt=ki-1;
for(j=ki-1;j>=1;j--)
{
//--- check
if(j>jnxt)
continue;
j1=j;
j2=j;
jnxt=j-1;
//--- check
if(j>1)
{
//--- check
if(t[j][j-1]!=0.0)
{
j1=j-1;
jnxt=j-2;
}
}
//--- check
if(j1==j2)
{
//--- 1-by-1 diagonal block
temp11[1].Set(1,t[j][j]);
temp11b[1].Set(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[1].Set(1,x[1][1]/xnorm);
scl=scl/xnorm;
}
}
//--- Scale if necessary
if(scl!=1.0)
{
k1=n+1;
k2=n+ki;
for(i_=k1;i_<=k2;i_++)
work[i_]=scl*work[i_];
}
work[j+n]=x[1][1];
//--- Update right-hand side
k1=1+n;
k2=j-1+n;
k3=j-1;
vt=-x[1][1];
i1_=1-k1;
for(i_=k1;i_<=k2;i_++)
{
work[i_]=work[i_]+vt*t[i_+i1_][j];
}
}
else
{
//--- 2-by-2 diagonal block
temp22[1].Set(1,t[j-1][j-1]);
temp22[1].Set(2,t[j-1][j]);
temp22[2].Set(1,t[j][j-1]);
temp22[2].Set(2,t[j][j]);
temp21b[1].Set(1,work[j-1+n]);
temp21b[2].Set(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[1].Set(1,x[1][1]/xnorm);
x[2].Set(1,x[2][1]/xnorm);
scl=scl/xnorm;
}
}
//--- Scale if necessary
if(scl!=1.0)
{
k1=1+n;
k2=ki+n;
for(i_=k1;i_<=k2;i_++)
work[i_]=scl*work[i_];
}
work[j-1+n]=x[1][1];
work[j+n]=x[2][1];
//--- Update right-hand side
k1=1+n;
k2=j-2+n;
k3=j-2;
k4=j-1;
vt=-x[1][1];
i1_=1-k1;
for(i_=k1;i_<=k2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][k4];
vt=-x[2][1];
i1_=1-k1;
for(i_=k1;i_<=k2;i_++)
work[i_]=work[i_]+vt*t[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[i_].Set(iis,work[i_+i1_]);
//--- function call
ii=CBlas::ColumnIdxAbsMax(vr,1,ki,iis);
remax=1/MathAbs(vr[ii][iis]);
for(i_=1;i_<=ki;i_++)
vr[i_].Set(iis,remax*vr[i_][iis]);
for(k=ki+1;k<=n;k++)
vr[k].Set(iis,0);
}
else
{
//--- check
if(ki>1)
{
for(i_=1;i_<=n;i_++)
temp[i_]=vr[i_][ki];
//--- 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]);
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki,temp[i_]);
}
//--- function call
ii=CBlas::ColumnIdxAbsMax(vr,1,n,ki);
remax=1/MathAbs(vr[ii][ki]);
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki,remax*vr[i_][ki]);
}
}
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[ki-1][ki])>=MathAbs(t[ki][ki-1]))
{
work[ki-1+n]=1;
work[ki+n2]=wi/t[ki-1][ki];
}
else
{
work[ki-1+n]=-(wi/t[ki][ki-1]);
work[ki+n2]=1;
}
work[ki+n]=0;
work[ki-1+n2]=0;
//--- Form right-hand side
for(k=1;k<=ki-2;k++)
{
work[k+n]=-(work[ki-1+n]*t[k][ki-1]);
work[k+n2]=-(work[ki+n2]*t[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[j][j-1]!=0.0)
{
j1=j-1;
jnxt=j-2;
}
}
//--- check
if(j1==j2)
{
//--- 1-by-1 diagonal block
temp11[1].Set(1,t[j][j]);
temp12b[1].Set(1,work[j+n]);
temp12b[1].Set(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[1].Set(1,x[1][1]/xnorm);
x[1].Set(2,x[1][2]/xnorm);
scl=scl/xnorm;
}
}
//--- Scale if necessary
if(scl!=1.0)
{
k1=1+n;
k2=ki+n;
for(i_=k1;i_<=k2;i_++)
work[i_]=scl*work[i_];
k1=1+n2;
k2=ki+n2;
for(i_=k1;i_<=k2;i_++)
work[i_]=scl*work[i_];
}
work[j+n]=x[1][1];
work[j+n2]=x[1][2];
//--- Update the right-hand side
k1=1+n;
k2=j-1+n;
k3=1;
k4=j-1;
vt=-x[1][1];
i1_=k3-k1;
for(i_=k1;i_<=k2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][j];
//--- change values
k1=1+n2;
k2=j-1+n2;
k3=1;
k4=j-1;
vt=-x[1][2];
i1_=k3-k1;
for(i_=k1;i_<=k2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][j];
}
else
{
//--- 2-by-2 diagonal block
temp22[1].Set(1,t[j-1][j-1]);
temp22[1].Set(2,t[j-1][j]);
temp22[2].Set(1,t[j][j-1]);
temp22[2].Set(2,t[j][j]);
temp22b[1].Set(1,work[j-1+n]);
temp22b[1].Set(2,work[j-1+n+n]);
temp22b[2].Set(1,work[j+n]);
temp22b[2].Set(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[1].Set(1,x[1][1]*rec);
x[1].Set(2,x[1][2]*rec);
x[2].Set(1,x[2][1]*rec);
x[2].Set(2,x[2][2]*rec);
scl=scl*rec;
}
}
//--- Scale if necessary
if(scl!=1.0)
{
for(i_=1+n;i_<=ki+n;i_++)
work[i_]=scl*work[i_];
for(i_=1+n2;i_<=ki+n2;i_++)
work[i_]=scl*work[i_];
}
//--- change values
work[j-1+n]=x[1][1];
work[j+n]=x[2][1];
work[j-1+n2]=x[1][2];
work[j+n2]=x[2][2];
//--- Update the right-hand side
vt=-x[1][1];
i1_=-n;
for(i_=n+1;i_<=n+j-2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][j-1];
vt=-x[2][1];
i1_=-n;
for(i_=n+1;i_<=n+j-2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][j];
vt=-x[1][2];
i1_=-n2;
for(i_=n2+1;i_<=n2+j-2;i_++)
work[i_]=work[i_]+vt*t[i_+i1_][j-1];
vt=-x[2][2];
i1_=-n2;
for(i_=n2+1;i_<=n2+j-2;i_++)
work[i_]=work[i_]+vt*t[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[i_].Set(iis-1,work[i_+i1_]);
i1_=n2;
for(i_=1;i_<=ki;i_++)
vr[i_].Set(iis,work[i_+i1_]);
emax=0;
for(k=1;k<=ki;k++)
emax=MathMax(emax,MathAbs(vr[k][iis-1])+MathAbs(vr[k][iis]));
remax=1/emax;
//--- copy
for(i_=1;i_<=ki;i_++)
vr[i_].Set(iis-1,remax*vr[i_][iis-1]);
for(i_=1;i_<=ki;i_++)
vr[i_].Set(iis,remax*vr[i_][iis]);
for(k=ki+1;k<=n;k++)
vr[k].Set(iis-1,0);
vr[k].Set(iis,0);
}
else
{
//--- check
if(ki>2)
{
for(i_=1;i_<=n;i_++)
temp[i_]=vr[i_][ki-1];
//--- 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]);
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki-1,temp[i_]);
for(i_=1;i_<=n;i_++)
temp[i_]=vr[i_][ki];
//--- 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]);
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki,temp[i_]);
}
else
{
vt=work[ki-1+n];
//--- copy
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki-1,vt*vr[i_][ki-1]);
vt=work[ki+n2];
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki,vt*vr[i_][ki]);
}
emax=0;
for(k=1;k<=n;k++)
emax=MathMax(emax,MathAbs(vr[k][ki-1])+MathAbs(vr[k][ki]));
remax=1/emax;
//--- copy
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki-1,remax*vr[i_][ki-1]);
for(i_=1;i_<=n;i_++)
vr[i_].Set(ki,remax*vr[i_][ki]);
}
}
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[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[ki][ki];
wi=0;
//--- check
if(ip!=0)
wi=MathSqrt(MathAbs(t[ki][ki+1]))*MathSqrt(MathAbs(t[ki+1][ki]));
smin=MathMax(ulp*(MathAbs(wr)+MathAbs(wi)),smlnum);
//--- check
if(ip==0)
{
//--- Real left eigenvector.
work[ki+n]=1;
//--- Form right-hand side
for(k=ki+1;k<=n;k++)
work[k+n]=-t[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(j<jnxt)
continue;
j1=j;
j2=j;
jnxt=j+1;
//--- check
if(j<n)
{
//--- check
if(t[j+1][j]!=0.0)
{
j2=j+1;
jnxt=j+2;
}
}
//--- check
if(j1==j2)
{
//--- 1-by-1 diagonal block
//--- Scale if necessary to avoid overflow when forming
//--- the right-hand side.
if(work[j]>vcrit)
{
rec=1/vmax;
for(i_=ki+n;i_<=n+n;i_++)
{
work[i_]=rec*work[i_];
}
vmax=1;
vcrit=bignum;
}
i1_=n;
vt=0.0;
for(i_=ki+1;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
work[j+n]=work[j+n]-vt;
//--- Solve (T(J,J)-WR)'*X = WORK
temp11[1].Set(1,t[j][j]);
temp11b[1].Set(1,work[j+n]);
InternalHsEVDLALN2(false,1,1,smin,1.0,temp11,1.0,1.0,temp11b,wr,0,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr);
//--- Scale if necessary
if(scl!=1.0)
{
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=scl*work[i_];
}
work[j+n]=x[1][1];
vmax=MathMax(MathAbs(work[j+n]),vmax);
vcrit=bignum/vmax;
}
else
{
//--- 2-by-2 diagonal block
//--- Scale if necessary to avoid overflow when forming
//--- the right-hand side.
beta=MathMax(work[j],work[j+1]);
//--- check
if(beta>vcrit)
{
rec=1/vmax;
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=rec*work[i_];
vmax=1;
vcrit=bignum;
}
i1_=n;
vt=0.0;
for(i_=ki+1;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
//--- change values
work[j+n]=work[j+n]-vt;
i1_=n;
vt=0.0;
for(i_=ki+1;i_<j;i_++)
vt+=t[i_][j+1]*work[i_+i1_];
work[j+1+n]=work[j+1+n]-vt;
//--- Solve
//--- [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
//--- [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
temp22[1].Set(1,t[j][j]);
temp22[1].Set(2,t[j][j+1]);
temp22[2].Set(1,t[j+1][j]);
temp22[2].Set(2,t[j+1][j+1]);
temp21b[1].Set(1,work[j+n]);
temp21b[2].Set(1,work[j+1+n]);
//--- function call
InternalHsEVDLALN2(true,2,1,smin,1.0,temp22,1.0,1.0,temp21b,wr,0,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr);
//--- Scale if necessary
if(scl!=1.0)
{
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=scl*work[i_];
}
//--- change values
work[j+n]=x[1][1];
work[j+1+n]=x[2][1];
vmax=MathMax(MathAbs(work[j+n]),MathMax(MathAbs(work[j+1+n]),vmax));
vcrit=bignum/vmax;
}
}
//--- Copy the vector x or Q*x to VL and normalize.
if(!over)
{
i1_=n;;
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis,work[i_+i1_]);
//--- function call
ii=CBlas::ColumnIdxAbsMax(vl,ki,n,iis);
remax=1/MathAbs(vl[ii][iis]);
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis,remax*vl[i_][iis]);
for(k=1;k<=ki-1;k++)
vl[k].Set(iis,0);
}
else
{
//--- check
if(ki<n)
{
for(i_=1;i_<=n;i_++)
temp[i_]=vl[i_][ki];
//--- function call
CBlas::MatrixVectorMultiply(vl,1,n,ki+1,n,false,work,ki+1+n,n+n,1.0,temp,1,n,work[ki+n]);
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki,temp[i_]);
}
//--- function call
ii=CBlas::ColumnIdxAbsMax(vl,1,n,ki);
remax=1/MathAbs(vl[ii][ki]);
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki,remax*vl[i_][ki]);
}
}
else
{
//--- Complex left eigenvector.
//--- Initial solve:
//--- ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
//--- ((T(KI+1,KI) T(KI+1,KI+1)) )
if(MathAbs(t[ki][ki+1])>=MathAbs(t[ki+1][ki]))
{
work[ki+n]=wi/t[ki][ki+1];
work[ki+1+n2]=1;
}
else
{
work[ki+n]=1;
work[ki+1+n2]=-(wi/t[ki+1][ki]);
}
work[ki+1+n]=0;
work[ki+n2]=0;
//--- Form right-hand side
for(k=ki+2;k<=n;k++)
{
work[k+n]=-(work[ki+n]*t[ki][k]);
work[k+n2]=-(work[ki+1+n2]*t[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(j<jnxt)
continue;
j1=j;
j2=j;
jnxt=j+1;
//--- check
if(j<n)
{
//--- check
if(t[j+1][j]!=0.0)
{
j2=j+1;
jnxt=j+2;
}
}
//--- check
if(j1==j2)
{
//--- 1-by-1 diagonal block
//--- Scale if necessary to avoid overflow when
//--- forming the right-hand side elements.
if(work[j]>vcrit)
{
rec=1/vmax;
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=rec*work[i_];
for(i_=ki+n2;i_<=n+n2;i_++)
work[i_]=rec*work[i_];
vmax=1;
vcrit=bignum;
}
i1_=n;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
//--- calculation
work[j+n]=work[j+n]-vt;
i1_=n2;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
work[j+n2]=work[j+n2]-vt;
//--- Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
temp11[1].Set(1,t[j][j]);
temp12b[1].Set(1,work[j+n]);
temp12b[1].Set(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 if necessary
if(scl!=1.0)
{
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=scl*work[i_];
for(i_=ki+n2;i_<=n+n2;i_++)
work[i_]=scl*work[i_];
}
//--- change values
work[j+n]=x[1][1];
work[j+n2]=x[1][2];
vmax=MathMax(MathAbs(work[j+n]),MathMax(MathAbs(work[j+n2]),vmax));
vcrit=bignum/vmax;
}
else
{
//--- 2-by-2 diagonal block
//--- Scale if necessary to avoid overflow when forming
//--- the right-hand side elements.
beta=MathMax(work[j],work[j+1]);
//--- check
if(beta>vcrit)
{
rec=1/vmax;
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=rec*work[i_];
for(i_=ki+n2;i_<=n+n2;i_++)
work[i_]=rec*work[i_];
vmax=1;
vcrit=bignum;
}
i1_=n;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
//--- calculation
work[j+n]=work[j+n]-vt;
i1_=n2;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j]*work[i_+i1_];
//--- calculation
work[j+n2]=work[j+n2]-vt;
i1_=n;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j+1]*work[i_+i1_];
//--- calculation
work[j+1+n]=work[j+1+n]-vt;
i1_=n2;
vt=0.0;
for(i_=ki+2;i_<j;i_++)
vt+=t[i_][j+1]*work[i_+i1_];
work[j+1+n2]=work[j+1+n2]-vt;
//--- Solve 2-by-2 complex linear equation
//--- ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
//--- ([T(j+1,j) T(j+1,j+1)] )
temp22[1].Set(1,t[j][j]);
temp22[1].Set(2,t[j][j+1]);
temp22[2].Set(1,t[j+1][j]);
temp22[2].Set(2,t[j+1][j+1]);
temp22b[1].Set(1,work[j+n]);
temp22b[1].Set(2,work[j+n+n]);
temp22b[2].Set(1,work[j+1+n]);
temp22b[2].Set(2,work[j+1+n+n]);
//--- function call
InternalHsEVDLALN2(true,2,2,smin,1.0,temp22,1.0,1.0,temp22b,wr,-wi,rswap4,zswap4,ipivot44,civ4,crv4,x,scl,xnorm,ierr);
//--- Scale if necessary
if(scl!=1.0)
{
for(i_=ki+n;i_<=n+n;i_++)
work[i_]=scl*work[i_];
for(i_=ki+n2;i_<=n+n2;i_++)
work[i_]=scl*work[i_];
}
//--- change values
work[j+n]=x[1][1];
work[j+n2]=x[1][2];
work[j+1+n]=x[2][1];
work[j+1+n2]=x[2][2];
vmax=MathMax(MathAbs(x[1][1]),vmax);
vmax=MathMax(MathAbs(x[1][2]),vmax);
vmax=MathMax(MathAbs(x[2][1]),vmax);
vmax=MathMax(MathAbs(x[2][2]),vmax);
vcrit=bignum/vmax;
}
}
//--- Copy the vector x or Q*x to VL and normalize.
if(!over)
{
i1_=n;
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis,work[i_+i1_]);
i1_=n2;
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis+1,work[i_+i1_]);
emax=0;
for(k=ki;k<=n;k++)
emax=MathMax(emax,MathAbs(vl[k][iis])+MathAbs(vl[k][iis+1]));
remax=1/emax;
//--- copy
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis,remax*vl[i_][iis]);
for(i_=ki;i_<=n;i_++)
vl[i_].Set(iis+1,remax*vl[i_][iis+1]);
for(k=1;k<=ki-1;k++)
{
vl[k].Set(iis,0);
vl[k].Set(iis+1,0);
}
}
else
{
//--- check
if(ki<n-1)
{
for(i_=1;i_<=n;i_++)
temp[i_]=vl[i_][ki];
//--- function call
CBlas::MatrixVectorMultiply(vl,1,n,ki+2,n,false,work,ki+2+n,n+n,1.0,temp,1,n,work[ki+n]);
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki,temp[i_]);
for(i_=1;i_<=n;i_++)
temp[i_]=vl[i_][ki+1];
//--- function call
CBlas::MatrixVectorMultiply(vl,1,n,ki+2,n,false,work,ki+2+n2,n+n2,1.0,temp,1,n,work[ki+1+n2]);
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki+1,temp[i_]);
}
else
{
//--- copy
vt=work[ki+n];
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki,vt*vl[i_][ki]);
vt=work[ki+1+n2];
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki+1,vt*vl[i_][ki+1]);
}
emax=0;
for(k=1;k<=n;k++)
emax=MathMax(emax,MathAbs(vl[k][ki])+MathAbs(vl[k][ki+1]));
remax=1/emax;
//--- copy
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki,remax*vl[i_][ki]);
for(i_=1;i_<=n;i_++)
vl[i_].Set(ki+1,remax*vl[i_][ki+1]);
}
}
iis=iis+1;
//--- check
if(ip!=0)
iis=iis+1;
}
//--- check
if(ip==-1)
ip=0;
//--- check
if(ip==1)
ip=-1;
}
}
}
//+------------------------------------------------------------------+
//| DLALN2 solves a system of the form (ca A - w D ) X = s B |
//| or (ca A' - w D) X = s B with possible scaling ("s") and |
//| perturbation of A. (A' means A-transpose.) |
//| A is an NA x NA real matrix, ca is a real scalar, D is an NA x |
//| NA real diagonal matrix, w is a real or complex value, and X and |
//| B are NA x 1 matrices -- real if w is real, complex if w is |
//| complex. NA may be 1 or 2. |
//| If w is complex, X and B are represented as NA x 2 matrices, |
//| the first column of each being the real part and the second |
//| being the imaginary part. |
//| "s" is a scaling factor (.LE. 1), computed by DLALN2, which is |
//| so chosen that X can be computed without overflow. X is further |
//| scaled if necessary to assure that norm(ca A - w D)*norm(X) is |
//| less than overflow. |
//| If both singular values of (ca A - w D) are less than SMIN, |
//| SMIN*identity will be used instead of (ca A - w D). If only one |
//| singular value is less than SMIN, one element of (ca A - w D) |
//| will be perturbed enough to make the smallest singular value |
//| roughly SMIN. If both singular values are at least SMIN, |
//| (ca A - w D) will not be perturbed. In any case, the |
//| perturbation will be at most some small multiple of max( SMIN, |
//| ulp*norm(ca A - w D) ). The singular values are computed by |
//| infinity-norm approximations, and thus will only be correct to a |
//| factor of 2 or so. |
//| Note: all input quantities are assumed to be smaller than |
//| overflow by a reasonable factor. (See BIGNUM.) |
//| -- 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 |
//+------------------------------------------------------------------+
static void CEigenVDetect::InternalHsEVDLALN2(const bool ltrans,const int na,
const int nw,const double smin,
const double ca,CMatrixDouble &a,
const double d1,const double d2,
CMatrixDouble &b,const double wr,
const double wi,bool &rswap4[],
bool &zswap4[],CMatrixInt &ipivot44,
double &civ4[],double &crv4[],
CMatrixDouble &x,double &scl,
double &xnorm,int &info)
{
//--- create variables
int icmax=0;
int j=0;
double bbnd=0;
double bi1=0;
double bi2=0;
double bignum=0;
double bnorm=0;
double br1=0;
double br2=0;
double ci21=0;
double ci22=0;
double cmax=0;
double cnorm=0;
double cr21=0;
double cr22=0;
double csi=0;
double csr=0;
double li21=0;
double lr21=0;
double smini=0;
double smlnum=0;
double temp=0;
double u22abs=0;
double ui11=0;
double ui11r=0;
double ui12=0;
double ui12s=0;
double ui22=0;
double ur11=0;
double ur11r=0;
double ur12=0;
double ur12s=0;
double ur22=0;
double xi1=0;
double xi2=0;
double xr1=0;
double xr2=0;
double tmp1=0;
double tmp2=0;
//--- initialization
scl=0;
xnorm=0;
info=0;
zswap4[1]=false;
zswap4[2]=false;
zswap4[3]=true;
zswap4[4]=true;
rswap4[1]=false;
rswap4[2]=true;
rswap4[3]=false;
rswap4[4]=true;
ipivot44[1].Set(1,1);
ipivot44[2].Set(1,2);
ipivot44[3].Set(1,3);
ipivot44[4].Set(1,4);
ipivot44[1].Set(2,2);
ipivot44[2].Set(2,1);
ipivot44[3].Set(2,4);
ipivot44[4].Set(2,3);
ipivot44[1].Set(3,3);
ipivot44[2].Set(3,4);
ipivot44[3].Set(3,1);
ipivot44[4].Set(3,2);
ipivot44[1].Set(4,4);
ipivot44[2].Set(4,3);
ipivot44[3].Set(4,2);
ipivot44[4].Set(4,1);
smlnum=2*CMath::m_minrealnumber;
bignum=1/smlnum;
smini=MathMax(smin,smlnum);
//--- initialization
info=0;
scl=1;
//--- check
if(na==1)
{
//--- 1 x 1 (i.e., scalar) system C X = B
if(nw==1)
{
//--- Real 1x1 system.
//--- C = ca A - w D
csr=ca*a[1][1]-wr*d1;
cnorm=MathAbs(csr);
//--- If | C | < SMINI, use C = SMINI
if(cnorm<smini)
{
csr=smini;
cnorm=smini;
info=1;
}
//--- Check scaling for X = B / C
bnorm=MathAbs(b[1][1]);
//--- check
if(cnorm<1.0 && bnorm>1.0)
{
//--- check
if(bnorm>bignum*cnorm)
scl=1/bnorm;
}
//--- Compute X
x[1].Set(1,b[1][1]*scl/csr);
xnorm=MathAbs(x[1][1]);
}
else
{
//--- Complex 1x1 system (w is complex)
//--- C = ca A - w D
csr=ca*a[1][1]-wr*d1;
csi=-(wi*d1);
cnorm=MathAbs(csr)+MathAbs(csi);
//--- If | C | < SMINI, use C = SMINI
if(cnorm<smini)
{
csr=smini;
csi=0;
cnorm=smini;
info=1;
}
//--- Check scaling for X = B / C
bnorm=MathAbs(b[1][1])+MathAbs(b[1][2]);
//--- check
if(cnorm<1.0 && bnorm>1.0)
{
//--- check
if(bnorm>bignum*cnorm)
scl=1/bnorm;
}
//--- Compute X
InternalHsEVDLADIV(scl*b[1][1],scl*b[1][2],csr,csi,tmp1,tmp2);
x[1].Set(1,tmp1);
x[1].Set(2,tmp2);
xnorm=MathAbs(x[1][1])+MathAbs(x[1][2]);
}
}
else
{
//--- 2x2 System
//--- Compute the real part of C = ca A - w D (or ca A' - w D )
crv4[1+0]=ca*a[1][1]-wr*d1;
crv4[2+2]=ca*a[2][2]-wr*d2;
//--- check
if(ltrans)
{
crv4[1+2]=ca*a[2][1];
crv4[2+0]=ca*a[1][2];
}
else
{
crv4[2+0]=ca*a[2][1];
crv4[1+2]=ca*a[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(cmax<smini)
{
bnorm=MathMax(MathAbs(b[1][1]),MathAbs(b[2][1]));
//--- check
if(smini<1.0 && bnorm>1.0)
{
//--- check
if(bnorm>bignum*smini)
scl=1/bnorm;
}
//--- change values
temp=scl/smini;
x[1].Set(1,temp*b[1][1]);
x[2].Set(1,temp*b[2][1]);
xnorm=temp*bnorm;
info=1;
//--- exit the function
return;
}
//--- Gaussian elimination with complete pivoting.
ur11=crv4[icmax];
cr21=crv4[ipivot44[2][icmax]];
ur12=crv4[ipivot44[3][icmax]];
cr22=crv4[ipivot44[4][icmax]];
ur11r=1/ur11;
lr21=ur11r*cr21;
ur22=cr22-ur12*lr21;
//--- If smaller pivot < SMINI, use SMINI
if(MathAbs(ur22)<smini)
{
ur22=smini;
info=1;
}
//--- check
if(rswap4[icmax])
{
br1=b[2][1];
br2=b[1][1];
}
else
{
br1=b[1][1];
br2=b[2][1];
}
br2=br2-lr21*br1;
bbnd=MathMax(MathAbs(br1*(ur22*ur11r)),MathAbs(br2));
//--- check
if(bbnd>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[1].Set(1,xr2);
x[2].Set(1,xr1);
}
else
{
x[1].Set(1,xr1);
x[2].Set(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[1].Set(1,temp*x[1][1]);
x[2].Set(1,temp*x[2][1]);
xnorm=temp*xnorm;
scl=temp*scl;
}
}
}
else
{
//--- Complex 2x2 system (w is complex)
//--- Find the largest element in C
civ4[1+0]=-(wi*d1);
civ4[2+0]=0;
civ4[1+2]=0;
civ4[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(cmax<smini)
{
bnorm=MathMax(MathAbs(b[1][1])+MathAbs(b[1][2]),MathAbs(b[2][1])+MathAbs(b[2][2]));
//--- check
if(smini<1.0 && bnorm>1.0)
{
//--- check
if(bnorm>bignum*smini)
scl=1/bnorm;
}
//--- change values
temp=scl/smini;
x[1].Set(1,temp*b[1][1]);
x[2].Set(1,temp*b[2][1]);
x[1].Set(2,temp*b[1][2]);
x[2].Set(2,temp*b[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[2][icmax]];
ci21=civ4[ipivot44[2][icmax]];
ur12=crv4[ipivot44[3][icmax]];
ui12=civ4[ipivot44[3][icmax]];
cr22=crv4[ipivot44[4][icmax]];
ci22=civ4[ipivot44[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(u22abs<smini)
{
ur22=smini;
ui22=0;
info=1;
}
//--- check
if(rswap4[icmax])
{
br2=b[1][1];
br1=b[2][1];
bi2=b[1][2];
bi1=b[2][2];
}
else
{
br1=b[1][1];
br2=b[2][1];
bi1=b[1][2];
bi2=b[2][2];
}
br2=br2-lr21*br1+li21*bi1;
bi2=bi2-li21*br1-lr21*bi1;
bbnd=MathMax((MathAbs(br1)+MathAbs(bi1))*(u22abs*(MathAbs(ur11r)+MathAbs(ui11r))),MathAbs(br2)+MathAbs(bi2));
//--- check
if(bbnd>1.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[1].Set(1,xr2);
x[2].Set(1,xr1);
x[1].Set(2,xi2);
x[2].Set(2,xi1);
}
else
{
x[1].Set(1,xr1);
x[2].Set(1,xr2);
x[1].Set(2,xi1);
x[2].Set(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[1].Set(1,temp*x[1][1]);
x[2].Set(1,temp*x[2][1]);
x[1].Set(2,temp*x[1][2]);
x[2].Set(2,temp*x[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 |
//+------------------------------------------------------------------+
static 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)<MathAbs(c))
{
//--- get result
e=d/c;
f=c+d*e;
p=(a+b*e)/f;
q=(b-a*e)/f;
}
else
{
//--- get result
e=c/d;
f=d+c*e;
p=(b+a*e)/f;
q=(-a+b*e)/f;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static bool CEigenVDetect::NonSymmetricEVD(CMatrixDouble &ca,const int n,
const int vneeded,double &wr[],
double &wi[],CMatrixDouble &vl,
CMatrixDouble &vr)
{
//--- create variables
bool result;
int i=0;
int info=0;
int m=0;
int i_=0;
//--- create arrays
double tau[];
bool sel[];
//--- create matrix
CMatrixDouble s;
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(vneeded>=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[i].Set(i_,s[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[i].Set(i_,s[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 |
//+------------------------------------------------------------------+
static void CEigenVDetect::ToUpperHessenberg(CMatrixDouble &a,const int n,double &tau[])
{
//--- create variables
int i=0;
int ip1=0;
int nmi=0;
double v=0;
int i_=0;
int i1_=0;
//--- create arrays
double t[];
double work[];
//--- check
if(!CAp::Assert(n>=0,__FUNCTION__+": incorrect N!"))
return;
//--- check
if(n<=1)
return;
//--- allocation
ArrayResizeAL(tau,n);
ArrayResizeAL(t,n+1);
ArrayResizeAL(work,n+1);
//--- calculations
for(i=1;i<n;i++)
{
//--- Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
ip1=i+1;
nmi=n-i;
i1_=ip1-1;
for(i_=1;i_<=nmi;i_++)
t[i_]=a[i_+i1_][i];
//--- function call
CReflections::GenerateReflection(t,nmi,v);
i1_=1-ip1;
for(i_=ip1;i_<=n;i_++)
a[i_].Set(i,t[i_+i1_]);
tau[i]=v;
t[1]=1;
//--- Apply H(i) to A(1:ihi,i+1:ihi) from the right
CReflections::ApplyReflectionFromTheRight(a,v,t,1,n,i+1,n,work);
//--- Apply H(i) to A(i+1:ihi,i+1:n) from the left
CReflections::ApplyReflectionFromTheLeft(a,v,t,i+1,n,i+1,n,work);
}
}
//+------------------------------------------------------------------+
//| Unpack Q from the matrix of the upper Hessenberg form |
//+------------------------------------------------------------------+
static void CEigenVDetect::UnpackQFromUpperHessenberg(CMatrixDouble &a,const int n,
double &tau[],CMatrixDouble &q)
{
//--- create variables
int i=0;
int j=0;
int ip1=0;
int nmi=0;
int i_=0;
int i1_=0;
//--- create arrays
double v[];
double work[];
//--- check
if(n==0)
return;
//--- allocation
q.Resize(n+1,n+1);
ArrayResizeAL(v,n+1);
ArrayResizeAL(work,n+1);
//--- identity matrix
for(i=1;i<=n;i++)
{
for(j=1;j<=n;j++)
{
//--- check
if(i==j)
q[i].Set(j,1);
else
q[i].Set(j,0);
}
}
//--- unpack Q
for(i=1;i<n;i++)
{
//--- Apply H(i)
ip1=i+1;
nmi=n-i;
i1_=ip1-1;
for(i_=1;i_<=nmi;i_++)
v[i_]=a[i_+i1_][i];
v[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheRight(q,tau[i],v,1,n,i+1,n,work);
}
}
//+------------------------------------------------------------------+
//| Random matrix generation |
//+------------------------------------------------------------------+
class CMatGen
{
public:
CMatGen(void);
~CMatGen(void);
//--- public methods
static void RMatrixRndOrthogonal(const int n,CMatrixDouble &a);
static void RMatrixRndCond(const int n,const double c,CMatrixDouble &a);
static void CMatrixRndOrthogonal(const int n,CMatrixComplex &a);
static void CMatrixRndCond(const int n,const double c,CMatrixComplex &a);
static void SMatrixRndCond(const int n,const double c,CMatrixDouble &a);
static void SPDMatrixRndCond(const int n,const double c,CMatrixDouble &a);
static void HMatrixRndCond(const int n,const double c,CMatrixComplex &a);
static void HPDMatrixRndCond(const int n,const double c,CMatrixComplex &a);
static void RMatrixRndOrthogonalFromTheRight(CMatrixDouble &a,const int m,const int n);
static void RMatrixRndOrthogonalFromTheLeft(CMatrixDouble &a,const int m,const int n);
static void CMatrixRndOrthogonalFromTheRight(CMatrixComplex &a,const int m,const int n);
static void CMatrixRndOrthogonalFromTheLeft(CMatrixComplex &a,const int m,const int n);
static void SMatrixRndMultiply(CMatrixDouble &a,const int n);
static void HMatrixRndMultiply(CMatrixComplex &a,const int n);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CMatGen::CMatGen(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CMatGen::~CMatGen(void)
{
}
//+------------------------------------------------------------------+
//| Generation of a random uniformly distributed (Haar) orthogonal |
//| matrix |
//| INPUT PARAMETERS: |
//| N - matrix size, N>=1 |
//| OUTPUT PARAMETERS: |
//| A - orthogonal NxN matrix, array[0..N-1,0..N-1] |
//+------------------------------------------------------------------+
static void CMatGen::RMatrixRndOrthogonal(const int n,CMatrixDouble &a)
{
//--- create variables
int i=0;
int j=0;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return;
//--- allocation
a.Resize(n,n);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(i==j)
a[i].Set(j,1);
else
a[i].Set(j,0);
}
}
//--- 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 |
//+------------------------------------------------------------------+
static 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[0].Set(0,2*CMath::RandomInteger(2)-1);
//--- exit the function
return;
}
//--- initialization
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- change a
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(n-1,MathExp(l2));
//--- function call
RMatrixRndOrthogonalFromTheLeft(a,n,n);
//--- function call
RMatrixRndOrthogonalFromTheRight(a,n,n);
}
//+------------------------------------------------------------------+
//| Generation of a random Haar distributed orthogonal complex matrix|
//| INPUT PARAMETERS: |
//| N - matrix size, N>=1 |
//| OUTPUT PARAMETERS: |
//| A - orthogonal NxN matrix, array[0..N-1,0..N-1] |
//+------------------------------------------------------------------+
static void CMatGen::CMatrixRndOrthogonal(const int n,CMatrixComplex &a)
{
//--- create variables
int i=0;
int j=0;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return;
//--- allocation
a.Resize(n,n);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
{
//--- check
if(i==j)
a[i].Set(j,1);
else
a[i].Set(j,0);
}
}
//--- 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 |
//+------------------------------------------------------------------+
static void CMatGen::CMatrixRndCond(const int n,const double c,CMatrixComplex &a)
{
//--- create variables
int i=0;
int j=0;
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.Resize(n,n);
//--- check
if(n==1)
{
//--- function call
CHighQualityRand::HQRndRandomize(state);
//--- function call
CHighQualityRand::HQRndUnit2(state,v.re,v.im);
a[0].Set(0,v);
return;
}
//--- initialization
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- change values
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(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 |
//+------------------------------------------------------------------+
static void CMatGen::SMatrixRndCond(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[0].Set(0,2*CMath::RandomInteger(2)-1);
return;
}
//--- Prepare matrix
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- initialization
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,(2*CMath::RandomInteger(2)-1)*MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(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 |
//+------------------------------------------------------------------+
static void CMatGen::SPDMatrixRndCond(const int n,const double c,CMatrixDouble &a)
{
//--- create variables
int i=0;
int j=0;
double l1=0;
double l2=0;
//--- check
if(n<=0 || c<1.0)
return;
//--- allocation
a.Resize(n,n);
//--- check
if(n==1)
{
a[0].Set(0,1);
return;
}
//--- Prepare matrix
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- initialization
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(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 |
//+------------------------------------------------------------------+
static void CMatGen::HMatrixRndCond(const int n,const double c,CMatrixComplex &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[0].Set(0,2*CMath::RandomInteger(2)-1);
return;
}
//--- Prepare matrix
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- initialization
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,(2*CMath::RandomInteger(2)-1)*MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(n-1,MathExp(l2));
//--- Multiply
HMatrixRndMultiply(a,n);
//--- post-process to ensure that matrix diagonal is real
for(i=0;i<n;i++)
a[i].SetIm(i,0);
}
//+------------------------------------------------------------------+
//| Generation of random NxN Hermitian 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 HPD matrix with norm2(A)=1 and cond(A)=C |
//+------------------------------------------------------------------+
static void CMatGen::HPDMatrixRndCond(const int n,const double c,CMatrixComplex &a)
{
//--- create variables
int i=0;
int j=0;
double l1=0;
double l2=0;
//--- check
if(n<=0 || c<1.0)
return;
//--- allocation
a.Resize(n,n);
//--- check
if(n==1)
{
a[0].Set(0,1);
return;
}
//--- Prepare matrix
l1=0;
l2=MathLog(1/c);
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- initialization
a[0].Set(0,MathExp(l1));
for(i=1;i<=n-2;i++)
a[i].Set(i,MathExp(CMath::RandomReal()*(l2-l1)+l1));
a[n-1].Set(n-1,MathExp(l2));
//--- Multiply
HMatrixRndMultiply(a,n);
//--- post-process to ensure that matrix diagonal is real
for(i=0;i<n;i++)
a[i].SetIm(i,0);
}
//+------------------------------------------------------------------+
//| Multiplication of MxN matrix by NxN random Haar distributed |
//| orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..M-1, 0..N-1] |
//| M, N- matrix size |
//| OUTPUT PARAMETERS: |
//| A - A*Q, where Q is random NxN orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::RMatrixRndOrthogonalFromTheRight(CMatrixDouble &a,const int m,
const int n)
{
//--- create variables
double tau=0;
double lambdav=0;
int s=0;
int i=0;
double u1=0;
double u2=0;
int i_=0;
//--- create arrays
double w[];
double v[];
//--- object of class
CHighQualityRandState state;
//--- check
if(!CAp::Assert(n>=1 && m>=1,__FUNCTION__+": N<1 or M<1!"))
return;
//--- check
if(n==1)
{
tau=2*CMath::RandomInteger(2)-1;
for(i=0;i<m;i++)
a[i].Set(0,a[i][0]*tau);
//--- exit the function
return;
}
//--- General case.
//--- First pass.
ArrayResizeAL(w,m);
ArrayResizeAL(v,n+1);
//--- function call
CHighQualityRand::HQRndRandomize(state);
for(s=2;s<=n;s++)
{
//--- Prepare random normal v
do
{
i=1;
while(i<=s)
{
//--- function call
CHighQualityRand::HQRndNormal2(state,u1,u2);
v[i]=u1;
//--- check
if(i+1<=s)
v[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 and apply reflection
CReflections::GenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheRight(a,tau,v,0,m-1,n-s,n-1,w);
}
//--- Second pass.
for(i=0;i<n;i++)
{
tau=2*CMath::RandomInteger(2)-1;
for(i_=0;i_<m;i_++)
a[i_].Set(i,tau*a[i_][i]);
}
}
//+------------------------------------------------------------------+
//| Multiplication of MxN matrix by MxM random Haar distributed |
//| orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..M-1, 0..N-1] |
//| M, N- matrix size |
//| OUTPUT PARAMETERS: |
//| A - Q*A, where Q is random MxM orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::RMatrixRndOrthogonalFromTheLeft(CMatrixDouble &a,const int m,
const int n)
{
//--- create variables
double tau=0;
double lambdav=0;
int s=0;
int i=0;
int j=0;
double u1=0;
double u2=0;
//--- create arrays
double w[];
double v[];
//--- object of class
CHighQualityRandState state;
int i_=0;
//--- check
if(!CAp::Assert(n>=1 && m>=1,__FUNCTION__+": N<1 or M<1!"))
return;
//--- check
if(m==1)
{
tau=2*CMath::RandomInteger(2)-1;
for(j=0;j<n;j++)
a[0].Set(j,a[0][j]*tau);
//--- exit the function
return;
}
//--- General case.
//--- First pass.
ArrayResizeAL(w,n);
ArrayResizeAL(v,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[i]=u1;
//--- check
if(i+1<=s)
v[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
CReflections::GenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheLeft(a,tau,v,m-s,m-1,0,n-1,w);
}
//--- Second pass.
for(i=0;i<m;i++)
{
tau=2*CMath::RandomInteger(2)-1;
for(i_=0;i_<n;i_++)
a[i].Set(i_,tau*a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Multiplication of MxN complex matrix by NxN random Haar |
//| distributed complex orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..M-1, 0..N-1] |
//| M, N- matrix size |
//| OUTPUT PARAMETERS: |
//| A - A*Q, where Q is random NxN orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::CMatrixRndOrthogonalFromTheRight(CMatrixComplex &a,const int m,const int n)
{
//--- create variables
complex zero=0;
complex lambdav=0;
complex tau=0;
int s=0;
int i=0;
int i_=0;
//--- create arrays
complex w[];
complex v[];
//--- object of class
CHighQualityRandState state;
//--- check
if(!CAp::Assert(n>=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.re,tau.im);
for(i=0;i<m;i++)
a[i].Set(0,a[i][0]*tau);
//--- exit the function
return;
}
//--- General case.
//--- First pass.
ArrayResizeAL(w,m);
ArrayResizeAL(v,n+1);
//--- function call
CHighQualityRand::HQRndRandomize(state);
for(s=2;s<=n;s++)
{
//--- Prepare random normal v
do
{
for(i=1;i<=s;i++)
{
//--- function call
CHighQualityRand::HQRndNormal2(state,tau.re,tau.im);
v[i]=tau;
}
//--- change values
lambdav=0.0;
for(i_=1;i_<=s;i_++)
lambdav+=v[i_]*CMath::Conj(v[i_]);
}
while(lambdav==zero);
//--- Prepare and apply reflection
CComplexReflections::ComplexGenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheRight(a,tau,v,0,m-1,n-s,n-1,w);
}
//--- Second pass.
for(i=0;i<n;i++)
{
//--- function call
CHighQualityRand::HQRndUnit2(state,tau.re,tau.im);
for(i_=0;i_<m;i_++)
a[i_].Set(i,tau*a[i_][i]);
}
}
//+------------------------------------------------------------------+
//| Multiplication of MxN complex matrix by MxM random Haar |
//| distributed complex orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..M-1, 0..N-1] |
//| M, N- matrix size |
//| OUTPUT PARAMETERS: |
//| A - Q*A, where Q is random MxM orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::CMatrixRndOrthogonalFromTheLeft(CMatrixComplex &a,const int m,
const int n)
{
//--- create variables
complex zero=0;
complex tau=0;
complex lambdav=0;
int s=0;
int i=0;
int j=0;
int i_=0;
//--- create arrays
complex w[];
complex v[];
//--- object of class
CHighQualityRandState state;
//--- check
if(!CAp::Assert(n>=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.re,tau.im);
for(j=0;j<n;j++)
a[0].Set(j,a[0][j]*tau);
//--- exit the function
return;
}
//--- General case.
//--- First pass.
ArrayResizeAL(w,n);
ArrayResizeAL(v,m+1);
//--- function call
CHighQualityRand::HQRndRandomize(state);
for(s=2;s<=m;s++)
{
//--- Prepare random normal v
do
{
for(i=1;i<=s;i++)
{
//--- function call
CHighQualityRand::HQRndNormal2(state,tau.re,tau.im);
v[i]=tau;
}
//--- change values
lambdav=0.0;
for(i_=1;i_<=s;i_++)
lambdav+=v[i_]*CMath::Conj(v[i_]);
}
while(lambdav==zero);
//--- Prepare and apply reflection
CComplexReflections::ComplexGenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(a,tau,v,m-s,m-1,0,n-1,w);
}
//--- Second pass.
for(i=0;i<m;i++)
{
//--- function call
CHighQualityRand::HQRndUnit2(state,tau.re,tau.im);
for(i_=0;i_<n;i_++)
a[i].Set(i_,tau*a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Symmetric multiplication of NxN matrix by random Haar |
//| distributed orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..N-1, 0..N-1] |
//| N - matrix size |
//| OUTPUT PARAMETERS: |
//| A - Q'*A*Q, where Q is random NxN orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::SMatrixRndMultiply(CMatrixDouble &a,const int n)
{
//--- create variables
double tau=0;
double lambdav=0;
int s=0;
int i=0;
double u1=0;
double u2=0;
int i_=0;
//--- create arrays
double w[];
double v[];
//--- object of class
CHighQualityRandState state;
//--- General case.
ArrayResizeAL(w,n);
ArrayResizeAL(v,n+1);
//--- function call
CHighQualityRand::HQRndRandomize(state);
for(s=2;s<=n;s++)
{
//--- Prepare random normal v
do
{
i=1;
while(i<=s)
{
//--- function call
CHighQualityRand::HQRndNormal2(state,u1,u2);
v[i]=u1;
//--- check
if(i+1<=s)
v[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 and apply reflection
CReflections::GenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CReflections::ApplyReflectionFromTheRight(a,tau,v,0,n-1,n-s,n-1,w);
//--- function call
CReflections::ApplyReflectionFromTheLeft(a,tau,v,n-s,n-1,0,n-1,w);
}
//--- Second pass.
for(i=0;i<n;i++)
{
tau=2*CMath::RandomInteger(2)-1;
for(i_=0;i_<n;i_++)
a[i_].Set(i,tau*a[i_][i]);
for(i_=0;i_<n;i_++)
a[i].Set(i_,tau*a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Hermitian multiplication of NxN matrix by random Haar distributed|
//| complex orthogonal matrix |
//| INPUT PARAMETERS: |
//| A - matrix, array[0..N-1, 0..N-1] |
//| N - matrix size |
//| OUTPUT PARAMETERS: |
//| A - Q^H*A*Q, where Q is random NxN orthogonal matrix |
//+------------------------------------------------------------------+
static void CMatGen::HMatrixRndMultiply(CMatrixComplex &a,const int n)
{
//--- create variables
complex zero=0;
complex tau=0;
complex lambdav=0;
int s=0;
int i=0;
int i_=0;
//--- create arrays
complex w[];
complex v[];
//--- object of class
CHighQualityRandState state;
//--- General case.
ArrayResizeAL(w,n);
ArrayResizeAL(v,n+1);
//--- function call
CHighQualityRand::HQRndRandomize(state);
for(s=2;s<=n;s++)
{
//--- Prepare random normal v
do
{
for(i=1;i<=s;i++)
{
//--- function call
CHighQualityRand::HQRndNormal2(state,tau.re,tau.im);
v[i]=tau;
}
//--- change values
lambdav=0.0;
for(i_=1;i_<=s;i_++)
lambdav+=v[i_]*CMath::Conj(v[i_]);
}
while(lambdav==zero);
//--- Prepare and apply reflection
CComplexReflections::ComplexGenerateReflection(v,s,tau);
v[1]=1;
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheRight(a,tau,v,0,n-1,n-s,n-1,w);
//--- function call
CComplexReflections::ComplexApplyReflectionFromTheLeft(a,CMath::Conj(tau),v,n-s,n-1,0,n-1,w);
}
//--- Second pass.
for(i=0;i<n;i++)
{
//--- function call
CHighQualityRand::HQRndUnit2(state,tau.re,tau.im);
for(i_=0;i_<n;i_++)
a[i_].Set(i,tau*a[i_][i]);
tau=CMath::Conj(tau);
for(i_=0;i_<n;i_++)
a[i].Set(i_,tau*a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| Triangular factorizations |
//+------------------------------------------------------------------+
class CTrFac
{
private:
//--- private methods
static void CMatrixLUPRec(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[]);
static void RMatrixLUPRec(CMatrixDouble &a,const int offs,const int m,const int n,int &pivots[],double &tmp[]);
static void CMatrixPLURec(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[]);
static void RMatrixPLURec(CMatrixDouble &a,const int offs,const int m,const int n,int &pivots[],double &tmp[]);
static void CMatrixLUP2(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[]);
static void RMatrixLUP2(CMatrixDouble &a,const int offs,const int m,const int n,int &pivots[],double &tmp[]);
static void CMatrixPLU2(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[]);
static void RMatrixPLU2(CMatrixDouble &a,const int offs,const int m,const int n,int &pivots[],double &tmp[]);
static bool HPDMatrixCholeskyRec(CMatrixComplex &a,const int offs,const int n,const bool isupper,complex &tmp[]);
static bool HPDMatrixCholesky2(CMatrixComplex &aaa,const int offs,const int n,const bool isupper,complex &tmp[]);
static bool SPDMatrixCholesky2(CMatrixDouble &aaa,const int offs,const int n,const bool isupper,double &tmp[]);
public:
CTrFac(void);
~CTrFac(void);
//--- public methods
static void RMatrixLU(CMatrixDouble &a,const int m,const int n,int &pivots[]);
static void CMatrixLU(CMatrixComplex &a,const int m,const int n,int &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 RMatrixLUP(CMatrixDouble &a,const int m,const int n,int &pivots[]);
static void CMatrixLUP(CMatrixComplex &a,const int m,const int n,int &pivots[]);
static void RMatrixPLU(CMatrixDouble &a,const int m,const int n,int &pivots[]);
static void CMatrixPLU(CMatrixComplex &a,const int m,const int n,int &pivots[]);
static bool SPDMatrixCholeskyRec(CMatrixDouble &a,const int offs,const int n,const bool isupper,double &tmp[]);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CTrFac::CTrFac(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CTrFac::~CTrFac(void)
{
}
//+------------------------------------------------------------------+
//| 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)]. |
//+------------------------------------------------------------------+
static 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);
}
//+------------------------------------------------------------------+
//| 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)]. |
//+------------------------------------------------------------------+
static 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);
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static bool CTrFac::HPDMatrixCholesky(CMatrixComplex &a,const int n,const bool isupper)
{
//--- create array
complex tmp[];
//--- check
if(n<1)
return(false);
//--- 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. |
//+------------------------------------------------------------------+
static bool CTrFac::SPDMatrixCholesky(CMatrixDouble &a,const int n,const bool isupper)
{
//--- create array
double tmp[];
//--- check
if(n<1)
return(false);
//--- return result
return(SPDMatrixCholeskyRec(a,0,n,isupper,tmp));
}
//+------------------------------------------------------------------+
//| LUP decomposition of general real matrix |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixLUP(CMatrixDouble &a,const int m,const int n,int &pivots[])
{
//--- create variables
int i=0;
int j=0;
double mx=0;
double v=0;
int i_=0;
//--- create array
double tmp[];
//--- Internal LU decomposition subroutine.
//--- Never call it directly.
if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!"))
return;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!"))
return;
//--- Scale matrix to avoid overflows,
//--- decompose it, then scale back.
mx=0;
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
mx=MathMax(mx,MathAbs(a[i][j]));
}
//--- check
if(mx!=0.0)
{
v=1/mx;
//--- change matrix
for(i=0;i<m;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
//--- allocation
ArrayResizeAL(pivots,MathMin(m,n));
ArrayResizeAL(tmp,2*MathMax(m,n));
//--- function call
RMatrixLUPRec(a,0,m,n,pivots,tmp);
//--- check
if(mx!=0.0)
{
v=mx;
//--- get result
for(i=0;i<m;i++)
for(i_=0;i_<=MathMin(i,n-1);i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
//+------------------------------------------------------------------+
//| LUP decomposition of general complex matrix |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixLUP(CMatrixComplex &a,const int m,const int n,int &pivots[])
{
//--- create variables
int i=0;
int j=0;
double mx=0;
double v=0;
complex cV;
int i_=0;
//--- create array
complex tmp[];
//--- Internal LU decomposition subroutine.
//--- Never call it directly.
if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!"))
return;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!"))
return;
//--- Scale matrix to avoid overflows,
//--- decompose it, then scale back.
mx=0;
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
mx=MathMax(mx,CMath::AbsComplex(a[i][j]));
}
//--- check
if(mx!=0.0)
{
v=1/mx;
cV=v;
//--- change matrix
for(i=0;i<m;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,cV*a[i][i_]);
}
}
//--- allocation
ArrayResizeAL(pivots,MathMin(m,n));
ArrayResizeAL(tmp,2*MathMax(m,n));
//--- function call
CMatrixLUPRec(a,0,m,n,pivots,tmp);
//--- check
if(mx!=0.0)
{
v=mx;
cV=v;
//--- get result
for(i=0;i<m;i++)
{
for(i_=0;i_<=MathMin(i,n-1);i_++)
a[i].Set(i_,cV*a[i][i_]);
}
}
}
//+------------------------------------------------------------------+
//| PLU decomposition of general real matrix |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixPLU(CMatrixDouble &a,const int m,const int n,int &pivots[])
{
//--- create variables
int i=0;
int j=0;
double mx=0;
double v=0;
int i_=0;
//--- create array
double tmp[];
//--- Internal LU decomposition subroutine.
//--- Never call it directly.
if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!"))
return;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!"))
return;
//--- allocation
ArrayResizeAL(tmp,2*MathMax(m,n));
ArrayResizeAL(pivots,MathMin(m,n));
//--- Scale matrix to avoid overflows,
//--- decompose it, then scale back.
mx=0;
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
mx=MathMax(mx,MathAbs(a[i][j]));
}
//--- check
if(mx!=0.0)
{
v=1/mx;
//--- change matrix
for(i=0;i<m;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
//--- function call
RMatrixPLURec(a,0,m,n,pivots,tmp);
//--- check
if(mx!=0.0)
{
v=mx;
//--- get result
for(i=0;i<=MathMin(m,n)-1;i++)
{
for(i_=i;i_<n;i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
}
//+------------------------------------------------------------------+
//| PLU decomposition of general complex matrix |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixPLU(CMatrixComplex &a,const int m,const int n,int &pivots[])
{
//--- create variables
int i=0;
int j=0;
double mx=0;
complex v=0;
int i_=0;
//--- create array
complex tmp[];
//--- Internal LU decomposition subroutine.
//--- Never call it directly.
if(!CAp::Assert(m>0,__FUNCTION__+": incorrect M!"))
return;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": incorrect N!"))
return;
//--- allocation
ArrayResizeAL(tmp,2*MathMax(m,n));
ArrayResizeAL(pivots,MathMin(m,n));
//--- Scale matrix to avoid overflows,
//--- decompose it, then scale back.
mx=0;
for(i=0;i<m;i++)
{
for(j=0;j<n;j++)
mx=MathMax(mx,CMath::AbsComplex(a[i][j]));
}
//--- check
if(mx!=0.0)
{
v=1/mx;
//--- change matrix
for(i=0;i<m;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
//--- function call
CMatrixPLURec(a,0,m,n,pivots,tmp);
//--- check
if(mx!=0.0)
{
v=mx;
//--- get result
for(i=0;i<=MathMin(m,n)-1;i++)
{
for(i_=i;i_<n;i_++)
a[i].Set(i_,v*a[i][i_]);
}
}
}
//+------------------------------------------------------------------+
//| Recursive computational subroutine for SPDMatrixCholesky. |
//| INPUT PARAMETERS: |
//| A - matrix given by upper or lower triangle |
//| Offs - offset of diagonal block to decompose |
//| N - diagonal block size |
//| IsUpper - what half is given |
//| Tmp - temporary array; allocated by function, if its |
//| size is too small; can be reused on subsequent |
//| calls. |
//| OUTPUT PARAMETERS: |
//| A - upper (or lower) triangle contains Cholesky |
//| decomposition |
//| RESULT: |
//| True, on success |
//| False, on failure |
//+------------------------------------------------------------------+
static bool CTrFac::SPDMatrixCholeskyRec(CMatrixDouble &a,const int offs,const int n,
const bool isupper,double &tmp[])
{
//--- create variables
bool result;
int n1=0;
int n2=0;
//--- check
if(n<1)
return(false);
//--- prepare bufer
if(CAp::Len(tmp)<2*n)
ArrayResizeAL(tmp,2*n);
//--- special cases
if(n==1)
{
//--- check
if(a[offs][offs]>0.0)
{
a[offs].Set(offs,MathSqrt(a[offs][offs]));
//--- return result
return(true);
}
else
{
//--- return result
return(false);
}
}
//--- check
if(n<=CAblas::AblasBlockSize())
{
//--- return result
return(SPDMatrixCholesky2(a,offs,n,isupper,tmp));
}
//--- general case: split task in cache-oblivious manner
result=true;
CAblas::AblasSplitLength(a,n,n1,n2);
result=SPDMatrixCholeskyRec(a,offs,n1,isupper,tmp);
//--- check
if(!result)
{
//--- return result
return(result);
}
//--- check
if(n2>0)
{
if(isupper)
{
//--- function call
CAblas::RMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,false,1,a,offs,offs+n1);
//--- function call
CAblas::RMatrixSyrk(n2,n1,-1.0,a,offs,offs+n1,1,1.0,a,offs+n1,offs+n1,isupper);
}
else
{
//--- function call
CAblas::RMatrixRightTrsM(n2,n1,a,offs,offs,isupper,false,1,a,offs+n1,offs);
//--- function call
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);
//--- check
if(!result)
{
//--- return result
return(result);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Recurrent complex LU subroutine. |
//| Never call it directly. |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixLUPRec(CMatrixComplex &a,const int offs,const int m,
const int n,int &pivots[],complex &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;i<n;i++)
{
i1_=offs+n;
for(i_=0;i_<m-n;i_++)
tmp[i_]=a[i_+i1_][offs+i];
//--- change matrix
for(i_=offs+n;i_<offs+m;i_++)
a[i_].Set(offs+i,a[i_][pivots[offs+i]]);
i1_=-(offs+n);
for(i_=offs+n;i_<offs+m;i_++)
a[i_].Set(pivots[offs+i],tmp[i_+i1_]);
}
//--- function call
CAblas::CMatrixRightTrsM(m-n,n,a,offs,offs,true,true,0,a,offs+n,offs);
//--- exit the function
return;
}
//--- Non-kernel case
CAblas::AblasComplexSplitLength(a,m,m1,m2);
//--- function call
CMatrixLUPRec(a,offs,m1,n,pivots,tmp);
//--- check
if(m2>0)
{
for(i=0;i<m1;i++)
{
//--- check
if(offs+i!=pivots[offs+i])
{
i1_=offs+m1;
for(i_=0;i_<m2;i_++)
tmp[i_]=a[i_+i1_][offs+i];
//--- change matrix
for(i_=offs+m1;i_<offs+m;i_++)
a[i_].Set(offs+i,a[i_][pivots[offs+i]]);
i1_=-(offs+m1);
for(i_=offs+m1;i_<offs+m;i_++)
a[i_].Set(pivots[offs+i],tmp[i_+i1_]);
}
}
//--- function call
CAblas::CMatrixRightTrsM(m2,m1,a,offs,offs,true,true,0,a,offs+m1,offs);
//--- function call
CAblas::CMatrixGemm(m-m1,n-m1,m1,_One,a,offs+m1,offs,0,a,offs,offs+m1,0,One,a,offs+m1,offs+m1);
//--- function call
CMatrixLUPRec(a,offs+m1,m-m1,n-m1,pivots,tmp);
for(i=0;i<m2;i++)
{
//--- check
if(offs+m1+i!=pivots[offs+m1+i])
{
i1_=offs;
for(i_=0;i_<m1;i_++)
tmp[i_]=a[i_+i1_][offs+m1+i];
//--- change matrix
for(i_=offs;i_<offs+m1;i_++)
a[i_].Set(offs+m1+i,a[i_][pivots[offs+m1+i]]);
i1_=-offs;
for(i_=offs;i_<offs+m1;i_++)
a[i_].Set(pivots[offs+m1+i],tmp[i_+i1_]);
}
}
}
}
//+------------------------------------------------------------------+
//| Recurrent real LU subroutine. |
//| Never call it directly. |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixLUPRec(CMatrixDouble &a,const int offs,const int m,
const int n,int &pivots[],double &tmp[])
{
//--- create variables
int i=0;
int m1=0;
int m2=0;
int i_=0;
int i1_=0;
//--- Kernel case
if(MathMin(m,n)<=CAblas::AblasBlockSize())
{
RMatrixLUP2(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
RMatrixLUPRec(a,offs,n,n,pivots,tmp);
for(i=0;i<n;i++)
{
//--- check
if(offs+i!=pivots[offs+i])
{
i1_=offs+n;
for(i_=0;i_<m-n;i_++)
tmp[i_]=a[i_+i1_][offs+i];
//--- change matrix
for(i_=offs+n;i_<offs+m;i_++)
a[i_].Set(offs+i,a[i_][pivots[offs+i]]);
i1_=-(offs+n);
for(i_=offs+n;i_<offs+m;i_++)
a[i_].Set(pivots[offs+i],tmp[i_+i1_]);
}
}
//--- function call
CAblas::RMatrixRightTrsM(m-n,n,a,offs,offs,true,true,0,a,offs+n,offs);
//--- exit the function
return;
}
//--- Non-kernel case
CAblas::AblasSplitLength(a,m,m1,m2);
//--- function call
RMatrixLUPRec(a,offs,m1,n,pivots,tmp);
//--- check
if(m2>0)
{
for(i=0;i<m1;i++)
{
//--- check
if(offs+i!=pivots[offs+i])
{
i1_=offs+m1;
for(i_=0;i_<m2;i_++)
tmp[i_]=a[i_+i1_][offs+i];
//--- change matrix
for(i_=offs+m1;i_<offs+m;i_++)
a[i_].Set(offs+i,a[i_][pivots[offs+i]]);
i1_=-(offs+m1);
for(i_=offs+m1;i_<offs+m;i_++)
a[i_].Set(pivots[offs+i],tmp[i_+i1_]);
}
}
//--- function call
CAblas::RMatrixRightTrsM(m2,m1,a,offs,offs,true,true,0,a,offs+m1,offs);
//--- function call
CAblas::RMatrixGemm(m-m1,n-m1,m1,-1.0,a,offs+m1,offs,0,a,offs,offs+m1,0,1.0,a,offs+m1,offs+m1);
//--- function call
RMatrixLUPRec(a,offs+m1,m-m1,n-m1,pivots,tmp);
for(i=0;i<m2;i++)
{
//--- check
if(offs+m1+i!=pivots[offs+m1+i])
{
i1_=offs;
for(i_=0;i_<m1;i_++)
tmp[i_]=a[i_+i1_][offs+m1+i];
//--- change matrix
for(i_=offs;i_<offs+m1;i_++)
a[i_].Set(offs+m1+i,a[i_][pivots[offs+m1+i]]);
i1_=-offs;
for(i_=offs;i_<offs+m1;i_++)
a[i_].Set(pivots[offs+m1+i],tmp[i_+i1_]);
}
}
}
}
//+------------------------------------------------------------------+
//| Recurrent complex LU subroutine. |
//| Never call it directly. |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixPLURec(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[])
{
//--- create variables
int i=0;
int n1=0;
int n2=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())
{
//--- function call
CMatrixPLU2(a,offs,m,n,pivots,tmp);
//--- exit the function
return;
}
//--- Preliminary step, make M>=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;i<m;i++)
{
i1_=offs+m;
for(i_=0;i_<n-m;i_++)
tmp[i_]=a[offs+i][i_+i1_];
//--- change matrix
for(i_=offs+m;i_<offs+n;i_++)
a[offs+i].Set(i_,a[pivots[offs+i]][i_]);
i1_=-(offs+m);
for(i_=offs+m;i_<offs+n;i_++)
a[pivots[offs+i]].Set(i_,tmp[i_+i1_]);
}
//--- function call
CAblas::CMatrixLeftTrsM(m,n-m,a,offs,offs,false,true,0,a,offs,offs+m);
//--- exit the function
return;
}
//--- Non-kernel case
CAblas::AblasComplexSplitLength(a,n,n1,n2);
//--- function call
CMatrixPLURec(a,offs,m,n1,pivots,tmp);
//--- check
if(n2>0)
{
for(i=0;i<n1;i++)
{
//--- check
if(offs+i!=pivots[offs+i])
{
i1_=offs+n1;
for(i_=0;i_<n2;i_++)
tmp[i_]=a[offs+i][i_+i1_];
//--- change matrix
for(i_=offs+n1;i_<offs+n;i_++)
a[offs+i].Set(i_,a[pivots[offs+i]][i_]);
i1_=-(offs+n1);
for(i_=offs+n1;i_<offs+n;i_++)
a[pivots[offs+i]].Set(i_,tmp[i_+i1_]);
}
}
//--- function call
CAblas::CMatrixLeftTrsM(n1,n2,a,offs,offs,false,true,0,a,offs,offs+n1);
//--- function call
CAblas::CMatrixGemm(m-n1,n-n1,n1,_One,a,offs+n1,offs,0,a,offs,offs+n1,0,One,a,offs+n1,offs+n1);
//--- function call
CMatrixPLURec(a,offs+n1,m-n1,n-n1,pivots,tmp);
for(i=0;i<n2;i++)
{
//--- check
if(offs+n1+i!=pivots[offs+n1+i])
{
i1_=offs;
for(i_=0;i_<n1;i_++)
tmp[i_]=a[offs+n1+i][i_+i1_];
//--- change matrix
for(i_=offs;i_<offs+n1;i_++)
a[offs+n1+i].Set(i_,a[pivots[offs+n1+i]][i_]);
i1_=-offs;
for(i_=offs;i_<offs+n1;i_++)
a[pivots[offs+n1+i]].Set(i_,tmp[i_+i1_]);
}
}
}
}
//+------------------------------------------------------------------+
//| Recurrent real LU subroutine. |
//| Never call it directly. |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixPLURec(CMatrixDouble &a,const int offs,const int m,
const int n,int &pivots[],double &tmp[])
{
//--- create variables
int i=0;
int n1=0;
int n2=0;
int i_=0;
int i1_=0;
//--- Kernel case
if(MathMin(m,n)<=CAblas::AblasBlockSize())
{
//--- function call
RMatrixPLU2(a,offs,m,n,pivots,tmp);
//--- exit the function
return;
}
//--- Preliminary step, make M>=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;i<m;i++)
{
i1_=offs+m;
for(i_=0;i_<n-m;i_++)
tmp[i_]=a[offs+i][i_+i1_];
//--- change matrix
for(i_=offs+m;i_<offs+n;i_++)
a[offs+i].Set(i_,a[pivots[offs+i]][i_]);
i1_=-(offs+m);
for(i_=offs+m;i_<offs+n;i_++)
a[pivots[offs+i]].Set(i_,tmp[i_+i1_]);
}
//--- function call
CAblas::RMatrixLeftTrsM(m,n-m,a,offs,offs,false,true,0,a,offs,offs+m);
//--- exit the function
return;
}
//--- Non-kernel case
CAblas::AblasSplitLength(a,n,n1,n2);
//--- function call
RMatrixPLURec(a,offs,m,n1,pivots,tmp);
//--- check
if(n2>0)
{
for(i=0;i<n1;i++)
{
//--- check
if(offs+i!=pivots[offs+i])
{
i1_=offs+n1;
for(i_=0;i_<n2;i_++)
tmp[i_]=a[offs+i][i_+i1_];
//--- change matrix
for(i_=offs+n1;i_<offs+n;i_++)
a[offs+i].Set(i_,a[pivots[offs+i]][i_]);
i1_=-(offs+n1);
for(i_=offs+n1;i_<offs+n;i_++)
a[pivots[offs+i]].Set(i_,tmp[i_+i1_]);
}
}
//--- function call
CAblas::RMatrixLeftTrsM(n1,n2,a,offs,offs,false,true,0,a,offs,offs+n1);
//--- function call
CAblas::RMatrixGemm(m-n1,n-n1,n1,-1.0,a,offs+n1,offs,0,a,offs,offs+n1,0,1.0,a,offs+n1,offs+n1);
//--- function call
RMatrixPLURec(a,offs+n1,m-n1,n-n1,pivots,tmp);
for(i=0;i<n2;i++)
{
//--- check
if(offs+n1+i!=pivots[offs+n1+i])
{
i1_=offs;
for(i_=0;i_<n1;i_++)
tmp[i_]=a[offs+n1+i][i_+i1_];
//--- change matrix
for(i_=offs;i_<offs+n1;i_++)
a[offs+n1+i].Set(i_,a[pivots[offs+n1+i]][i_]);
i1_=-offs;
for(i_=offs;i_<offs+n1;i_++)
a[pivots[offs+n1+i]].Set(i_,tmp[i_+i1_]);
}
}
}
}
//+------------------------------------------------------------------+
//| Complex LUP kernel |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixLUP2(CMatrixComplex &a,const int offs,const int m,const int n,int &pivots[],complex &tmp[])
{
//--- create variables
int i=0;
int j=0;
int jp=0;
complex s=0;
int i_=0;
int i1_=0;
complex zero=0;
complex One(1.0,0.0);
//--- check
if(m==0 || n==0)
return;
//--- main cycle
for(j=0;j<=MathMin(m-1,n-1);j++)
{
//--- Find pivot, swap columns
jp=j;
for(i=j+1;i<n;i++)
{
//--- check
if(CMath::AbsComplex(a[offs+j][offs+i])>CMath::AbsComplex(a[offs+j][offs+jp]))
jp=i;
}
pivots[offs+j]=offs+jp;
//--- check
if(jp!=j)
{
i1_=offs;
for(i_=0;i_<m;i_++)
tmp[i_]=a[i_+i1_][offs+j];
//--- change matrix
for(i_=offs;i_<offs+m;i_++)
a[i_].Set(offs+j,a[i_][offs+jp]);
i1_=-offs;
for(i_=offs;i_<offs+m;i_++)
a[i_].Set(offs+jp,tmp[i_+i1_]);
}
//--- LU decomposition of 1x(N-J) matrix
if(a[offs+j][offs+j]!=zero && j+1<=n-1)
{
s=One/a[offs+j][offs+j];
for(i_=offs+j+1;i_<offs+n;i_++)
a[offs+j].Set(i_,s*a[offs+j][i_]);
}
//--- Update trailing (M-J-1)x(N-J-1) matrix
if(j<MathMin(m-1,n-1))
{
i1_=offs+j+1;
for(i_=0;i_<m-j-1;i_++)
tmp[i_]=a[i_+i1_][offs+j];
i1_=(offs+j+1)-(m);
for(i_=m;i_<m+n-j-1;i_++)
{
tmp[i_]=a[offs+j][i_+i1_];
tmp[i_].re=-tmp[i_].re;
tmp[i_].im=-tmp[i_].im;
}
//--- function call
CAblas::CMatrixRank1(m-j-1,n-j-1,a,offs+j+1,offs+j+1,tmp,0,tmp,m);
}
}
}
//+------------------------------------------------------------------+
//| Real LUP kernel |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixLUP2(CMatrixDouble &a,const int offs,const int m,
const int n,int &pivots[],double &tmp[])
{
//--- create variables
int i=0;
int j=0;
int jp=0;
double s=0;
int i_=0;
int i1_=0;
//--- check
if(m==0 || n==0)
return;
//--- main cycle
for(j=0;j<=MathMin(m-1,n-1);j++)
{
//--- Find pivot, swap columns
jp=j;
for(i=j+1;i<n;i++)
{
if(MathAbs(a[offs+j][offs+i])>MathAbs(a[offs+j][offs+jp]))
jp=i;
}
pivots[offs+j]=offs+jp;
//--- check
if(jp!=j)
{
i1_=offs;
for(i_=0;i_<m;i_++)
tmp[i_]=a[i_+i1_][offs+j];
//--- change matrix
for(i_=offs;i_<offs+m;i_++)
a[i_].Set(offs+j,a[i_][offs+jp]);
i1_=-offs;
for(i_=offs;i_<offs+m;i_++)
a[i_].Set(offs+jp,tmp[i_+i1_]);
}
//--- LU decomposition of 1x(N-J) matrix
if(a[offs+j][offs+j]!=0.0 && j+1<=n-1)
{
s=1/a[offs+j][offs+j];
for(i_=offs+j+1;i_<offs+n;i_++)
a[offs+j].Set(i_,s*a[offs+j][i_]);
}
//--- Update trailing (M-J-1)x(N-J-1) matrix
if(j<MathMin(m-1,n-1))
{
i1_=offs+j+1;
for(i_=0;i_<m-j-1;i_++)
tmp[i_]=a[i_+i1_][offs+j];
i1_=(offs+j+1)-(m);
for(i_=m;i_<m+n-j-1;i_++)
tmp[i_]=-a[offs+j][i_+i1_];
//--- function call
CAblas::RMatrixRank1(m-j-1,n-j-1,a,offs+j+1,offs+j+1,tmp,0,tmp,m);
}
}
}
//+------------------------------------------------------------------+
//| Complex PLU kernel |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee,Univ. of California Berkeley,NAG Ltd., |
//| Courant Institute,Argonne National Lab,and Rice University |
//| June 30,1992 |
//+------------------------------------------------------------------+
static void CTrFac::CMatrixPLU2(CMatrixComplex &a,const int offs,const int m,
const int n,int &pivots[],complex &tmp[])
{
//--- create variables
int i=0;
int j=0;
int jp=0;
complex s=0;
complex zero=0;
complex One(1.0,0.0);
int i_=0;
int i1_=0;
//--- check
if(m==0 || n==0)
return;
for(j=0;j<=MathMin(m-1,n-1);j++)
{
//--- Find pivot and test for singularity.
jp=j;
for(i=j+1;i<m;i++)
{
//--- check
if(CMath::AbsComplex(a[offs+i][offs+j])>CMath::AbsComplex(a[offs+jp][offs+j]))
jp=i;
}
pivots[offs+j]=offs+jp;
if(a[offs+jp][offs+j]!=zero)
{
//--- Apply the interchange to rows
if(jp!=j)
{
for(i=0;i<n;i++)
{
s=a[offs+j][offs+i];
a[offs+j].Set(offs+i,a[offs+jp][offs+i]);
a[offs+jp].Set(offs+i,s);
}
}
//--- Compute elements J+1:M of J-th column.
if(j+1<=m-1)
{
s=One/a[offs+j][offs+j];
for(i_=offs+j+1;i_<offs+m;i_++)
a[i_].Set(offs+j,s*a[i_][offs+j]);
}
}
//--- check
if(j<MathMin(m,n)-1)
{
//--- Update trailing submatrix.
i1_=offs+j+1;
for(i_=0;i_<m-j-1;i_++)
tmp[i_]=a[i_+i1_][offs+j];
i1_=(offs+j+1)-(m);
for(i_=m;i_<m+n-j-1;i_++)
{
tmp[i_]=a[offs+j][i_+i1_];
tmp[i_].re=-tmp[i_].re;
tmp[i_].im=-tmp[i_].im;
}
//--- function call
CAblas::CMatrixRank1(m-j-1,n-j-1,a,offs+j+1,offs+j+1,tmp,0,tmp,m);
}
}
}
//+------------------------------------------------------------------+
//| Real PLU kernel |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee,Univ. of California Berkeley,NAG Ltd., |
//| Courant Institute,Argonne National Lab,and Rice University |
//| June 30,1992 |
//+------------------------------------------------------------------+
static void CTrFac::RMatrixPLU2(CMatrixDouble &a,const int offs,const int m,
const int n,int &pivots[],double &tmp[])
{
//--- create variables
int i=0;
int j=0;
int jp=0;
double s=0;
int i_=0;
int i1_=0;
//--- check
if(m==0 || n==0)
return;
for(j=0;j<=MathMin(m-1,n-1);j++)
{
//--- Find pivot and test for singularity.
jp=j;
for(i=j+1;i<m;i++)
{
//--- check
if(MathAbs(a[offs+i][offs+j])>MathAbs(a[offs+jp][offs+j]))
jp=i;
}
pivots[offs+j]=offs+jp;
//--- check
if(a[offs+jp][offs+j]!=0.0)
{
//--- Apply the interchange to rows
if(jp!=j)
{
for(i=0;i<n;i++)
{
s=a[offs+j][offs+i];
a[offs+j].Set(offs+i,a[offs+jp][offs+i]);
a[offs+jp].Set(offs+i,s);
}
}
//--- Compute elements J+1:M of J-th column.
if(j+1<=m-1)
{
s=1/a[offs+j][offs+j];
for(i_=offs+j+1;i_<offs+m;i_++)
a[i_].Set(offs+j,s*a[i_][offs+j]);
}
}
//--- check
if(j<MathMin(m,n)-1)
{
//--- Update trailing submatrix.
i1_=offs+j+1;
for(i_=0;i_<m-j-1;i_++)
tmp[i_]=a[i_+i1_][offs+j];
i1_=(offs+j+1)-(m);
for(i_=m;i_<m+n-j-1;i_++)
tmp[i_]=-a[offs+j][i_+i1_];
//--- function call
CAblas::RMatrixRank1(m-j-1,n-j-1,a,offs+j+1,offs+j+1,tmp,0,tmp,m);
}
}
}
//+------------------------------------------------------------------+
//| Recursive computational subroutine for HPDMatrixCholesky |
//+------------------------------------------------------------------+
static bool CTrFac::HPDMatrixCholeskyRec(CMatrixComplex &a,const int offs,const int n,
const bool isupper,complex &tmp[])
{
//--- create variables
bool result;
int n1=0;
int n2=0;
//--- check
if(n<1)
return(false);
//--- prepare bufer
if(CAp::Len(tmp)<2*n)
ArrayResizeAL(tmp,2*n);
//--- special cases
if(n==1)
{
//--- check
if(a[offs][offs].re>0.0)
{
a[offs].Set(offs,MathSqrt(a[offs][offs].re));
result=true;
}
else
{
result=false;
}
//--- return result
return(result);
}
//--- check
if(n<=CAblas::AblasComplexBlockSize())
{
result=HPDMatrixCholesky2(a,offs,n,isupper,tmp);
//--- return result
return(result);
}
//--- general case: split task in cache-oblivious manner
result=true;
//--- function call
CAblas::AblasComplexSplitLength(a,n,n1,n2);
result=HPDMatrixCholeskyRec(a,offs,n1,isupper,tmp);
//--- check
if(!result)
return(result);
//--- check
if(n2>0)
{
//--- check
if(isupper)
{
//--- function call
CAblas::CMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,false,2,a,offs,offs+n1);
//--- function call
CAblas::CMatrixSyrk(n2,n1,-1.0,a,offs,offs+n1,2,1.0,a,offs+n1,offs+n1,isupper);
}
else
{
//--- function call
CAblas::CMatrixRightTrsM(n2,n1,a,offs,offs,isupper,false,2,a,offs+n1,offs);
//--- function call
CAblas::CMatrixSyrk(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);
//--- check
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 |
//+------------------------------------------------------------------+
static bool CTrFac::HPDMatrixCholesky2(CMatrixComplex &aaa,const int offs,
const int n,const bool isupper,complex &tmp[])
{
//--- create variables
bool result;
int i=0;
int j=0;
double ajj=0;
complex v=0;
complex cR;
double r=0;
int i_=0;
int i1_=0;
//--- initialization
result=true;
//--- check
if(n<0)
return(false);
//--- check
if(n==0)
return(result);
//--- check
if(isupper)
{
//--- Compute the Cholesky factorization A = U'*U.
for(j=0;j<n;j++)
{
//--- Compute U(J,J) and test for non-positive-definiteness.
v=0.0;
for(i_=offs;i_<offs+j;i_++)
v+=CMath::Conj(aaa[i_][offs+j])*aaa[i_][offs+j];
ajj=(aaa[offs+j][offs+j]-v).re;
//--- check
if(ajj<=0.0)
{
aaa[offs+j].Set(offs+j,ajj);
//--- return result
return(false);
}
ajj=MathSqrt(ajj);
aaa[offs+j].Set(offs+j,ajj);
//--- Compute elements J+1:N-1 of row J.
if(j<n-1)
{
//--- check
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
{
tmp[i_]=CMath::Conj(aaa[i_+i1_][offs+j]);
tmp[i_].re=-tmp[i_].re;
tmp[i_].im=-tmp[i_].im;
}
//--- function call
CAblas::CMatrixMVect(n-j-1,j,aaa,offs,offs+j+1,1,tmp,0,tmp,n);
i1_=(n)-(offs+j+1);
for(i_=offs+j+1;i_<offs+n;i_++)
aaa[offs+j].Set(i_,aaa[offs+j][i_]+tmp[i_+i1_]);
}
r=1/ajj;
cR=r;
//--- change matrix
for(i_=offs+j+1;i_<offs+n;i_++)
aaa[offs+j].Set(i_,cR*aaa[offs+j][i_]);
}
}
}
else
{
//--- Compute the Cholesky factorization A = L*L'.
for(j=0;j<n;j++)
{
//--- Compute L(J+1,J+1) and test for non-positive-definiteness.
v=0.0;
for(i_=offs;i_<offs+j;i_++)
v+=CMath::Conj(aaa[offs+j][i_])*aaa[offs+j][i_];
ajj=(aaa[offs+j][offs+j]-v).re;
//--- check
if(ajj<=0.0)
{
aaa[offs+j].Set(offs+j,ajj);
//--- return result
return(false);
}
ajj=MathSqrt(ajj);
aaa[offs+j].Set(offs+j,ajj);
//--- Compute elements J+1:N of column J.
if(j<n-1)
{
//--- check
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
tmp[i_]=CMath::Conj(aaa[offs+j][i_+i1_]);
//--- function call
CAblas::CMatrixMVect(n-j-1,j,aaa,offs+j+1,offs,0,tmp,0,tmp,n);
for(i=0;i<n-j-1;i++)
aaa[offs+j+1+i].Set(offs+j,(aaa[offs+j+1+i][offs+j]-tmp[n+i])/ajj);
}
else
{
for(i=0;i<n-j-1;i++)
aaa[offs+j+1+i].Set(offs+j,aaa[offs+j+1+i][offs+j]/ajj);
}
}
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Level-2 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 |
//+------------------------------------------------------------------+
static bool CTrFac::SPDMatrixCholesky2(CMatrixDouble &aaa,const int offs,const int n,
const bool isupper,double &tmp[])
{
//--- create variables
bool result;
int i=0;
int j=0;
double ajj=0;
double v=0;
double r=0;
int i_=0;
int i1_=0;
//--- initialization
result=true;
//--- check
if(n<0)
return(false);
//--- check
if(n==0)
return(result);
//--- check
if(isupper)
{
//--- Compute the Cholesky factorization A = U'*U.
for(j=0;j<n;j++)
{
//--- Compute U(J,J) and test for non-positive-definiteness.
v=0.0;
for(i_=offs;i_<offs+j;i_++)
v+=aaa[i_][offs+j]*aaa[i_][offs+j];
ajj=aaa[offs+j][offs+j]-v;
//--- check
if(ajj<=0.0)
{
aaa[offs+j].Set(offs+j,ajj);
result=false;
//--- return result
return(result);
}
ajj=MathSqrt(ajj);
aaa[offs+j].Set(offs+j,ajj);
//--- Compute elements J+1:N-1 of row J.
if(j<n-1)
{
//--- check
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
tmp[i_]=-aaa[i_+i1_][offs+j];
//--- function call
CAblas::RMatrixMVect(n-j-1,j,aaa,offs,offs+j+1,1,tmp,0,tmp,n);
i1_=(n)-(offs+j+1);
for(i_=offs+j+1;i_<offs+n;i_++)
aaa[offs+j].Set(i_,aaa[offs+j][i_]+tmp[i_+i1_]);
}
r=1/ajj;
//--- change matrix
for(i_=offs+j+1;i_<offs+n;i_++)
aaa[offs+j].Set(i_,r*aaa[offs+j][i_]);
}
}
}
else
{
//--- Compute the Cholesky factorization A = L*L'.
for(j=0;j<n;j++)
{
//--- Compute L(J+1,J+1) and test for non-positive-definiteness.
v=0.0;
for(i_=offs;i_<offs+j;i_++)
v+=aaa[offs+j][i_]*aaa[offs+j][i_];
ajj=aaa[offs+j][offs+j]-v;
//--- check
if(ajj<=0.0)
{
aaa[offs+j].Set(offs+j,ajj);
//--- return result
return(false);
}
ajj=MathSqrt(ajj);
aaa[offs+j].Set(offs+j,ajj);
//--- Compute elements J+1:N of column J.
if(j<n-1)
{
//--- check
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
tmp[i_]=aaa[offs+j][i_+i1_];
//--- function call
CAblas::RMatrixMVect(n-j-1,j,aaa,offs+j+1,offs,0,tmp,0,tmp,n);
for(i=0;i<n-j-1;i++)
aaa[offs+j+1+i].Set(offs+j,(aaa[offs+j+1+i][offs+j]-tmp[n+i])/ajj);
}
else
{
for(i=0;i<n-j-1;i++)
aaa[offs+j+1+i].Set(offs+j,aaa[offs+j+1+i][offs+j]/ajj);
}
}
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Estimate of a matrix condition number |
//+------------------------------------------------------------------+
class CRCond
{
private:
//--- private methods
static void RMatrixRCondTrInternal(CMatrixDouble &a,const int n,const bool isupper,const bool isunit,const bool onenorm,double anorm,double &rc);
static void CMatrixRCondTrInternal(CMatrixComplex &a,const int n,const bool isupper,const bool isunit,const bool onenorm,double anorm,double &rc);
static void SPDMatrixRCondCholeskyInternal(CMatrixDouble &cha,const int n,const bool isupper,const bool isnormprovided,double anorm,double &rc);
static void HPDMatrixRCondCholeskyInternal(CMatrixComplex &cha,const int n,const bool isupper,const bool isnormprovided,double anorm,double &rc);
static void RMatrixRCondLUInternal(CMatrixDouble &lua,const int n,const bool onenorm,const bool isanormprovided,double anorm,double &rc);
static void CMatrixRCondLUInternal(CMatrixComplex &lua,const int n,const bool onenorm,const bool isanormprovided,double anorm,double &rc);
static void RMatrixEstimateNorm(const int n,double &v[],double &x[],int &isgn[],double &est,int &kase);
static void CMatrixEstimateNorm(const int n,complex &v[],complex &x[],double &est,int &kase,int &isave[],double &rsave[]);
static double InternalComplexRCondScSum1(complex &x[],const int n);
static int InternalComplexRCondIcMax1(complex &x[],const int n);
static void InternalComplexRCondSaveAll(int &isave[],double &rsave[],int &i,int &iter,int &j,int &jlast,int &jump,double &absxi,double &altsgn,double &estold,double &temp);
static void InternalComplexRCondLoadAll(int &isave[],double &rsave[],int &i,int &iter,int &j,int &jlast,int &jump,double &absxi,double &altsgn,double &estold,double &temp);
public:
//--- public methods
static double RMatrixRCond1(CMatrixDouble &ca,const int n);
static double RMatrixRCondInf(CMatrixDouble &ca,const int n);
static double SPDMatrixRCond(CMatrixDouble &ca,const int n,const bool isupper);
static double RMatrixTrRCond1(CMatrixDouble &a,const int n,const bool isupper,const bool isunit);
static double RMatrixTrRCondInf(CMatrixDouble &a,const int n,const bool isupper,const bool isunit);
static double RMatrixLURCond1(CMatrixDouble &lua,const int n);
static double RMatrixLURCondInf(CMatrixDouble &lua,const int n);
static double SPDMatrixCholeskyRCond(CMatrixDouble &a,const int n,const bool isupper);
static double HPDMatrixRCond(CMatrixComplex &ca,const int n,const bool isupper);
static double CMatrixRCond1(CMatrixComplex &ca,const int n);
static double CMatrixRCondInf(CMatrixComplex &ca,const int n);
static double HPDMatrixCholeskyRCond(CMatrixComplex &a,const int n,const bool isupper);
static double CMatrixLURCond1(CMatrixComplex &lua,const int n);
static double CMatrixLURCondInf(CMatrixComplex &lua,const int n);
static double CMatrixTrRCond1(CMatrixComplex &a,const int n,const bool isupper,const bool isunit);
static double CMatrixTrRCondInf(CMatrixComplex &a,const int n,const bool isupper,const bool isunit);
static double RCondThreshold(void);
};
//+------------------------------------------------------------------+
//| Estimate of a matrix 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 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. |
//+------------------------------------------------------------------+
static double CRCond::RMatrixRCond1(CMatrixDouble &ca,const int n)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
//--- create arrays
int pivots[];
double t[];
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
t[j]=t[j]+MathAbs(a[i][j]);
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- 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. |
//+------------------------------------------------------------------+
static double CRCond::RMatrixRCondInf(CMatrixDouble &ca,const int n)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
//--- create array
int pivots[];
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- change values
nrm=0;
for(i=0;i<n;i++)
{
v=0;
for(j=0;j<n;j++)
v=v+MathAbs(a[i][j]);
nrm=MathMax(nrm,v);
}
//--- 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. |
//+------------------------------------------------------------------+
static 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
double t[];
//--- create copy
CMatrixDouble a;
a=ca;
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
//--- change t
for(j=j1;j<=j2;j++)
{
//--- check
if(i==j)
t[i]=t[i]+MathAbs(a[i][i]);
else
{
t[i]=t[i]+MathAbs(a[i][j]);
t[j]=t[j]+MathAbs(a[i][j]);
}
}
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- check
if(CTrFac::SPDMatrixCholesky(a,n,isupper))
{
//--- function call
SPDMatrixRCondCholeskyInternal(a,n,isupper,true,nrm,v);
//--- get result
result=v;
}
else
result=-1;
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static double CRCond::RMatrixTrRCond1(CMatrixDouble &a,const int n,
const bool isupper,const bool isunit)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
int j1=0;
int j2=0;
//--- create arrays
int pivots[];
double t[];
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change t
for(j=j1;j<=j2;j++)
t[j]=t[j]+MathAbs(a[i][j]);
//--- check
if(isunit)
t[i]=t[i]+1;
else
t[i]=t[i]+MathAbs(a[i][i]);
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- function call
RMatrixRCondTrInternal(a,n,isupper,isunit,true,nrm,v);
//--- return result
return(v);
}
//+-------------------------------------------------------------------+
//| Triangular matrix: 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. |
//| 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. |
//+-------------------------------------------------------------------+
static double CRCond::RMatrixTrRCondInf(CMatrixDouble &a,const int n,
const bool isupper,const bool isunit)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
int j1=0;
int j2=0;
//--- create array
int pivots[];
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- change values
nrm=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change v
v=0;
for(j=j1;j<=j2;j++)
v=v+MathAbs(a[i][j]);
//--- check
if(isunit)
v=v+1;
else
v=v+MathAbs(a[i][i]);
nrm=MathMax(nrm,v);
}
//--- function call
RMatrixRCondTrInternal(a,n,isupper,isunit,false,nrm,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Condition number estimate of a Hermitian 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 - Hermitian 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. |
//+------------------------------------------------------------------+
static double CRCond::HPDMatrixRCond(CMatrixComplex &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
double t[];
//--- create copy
CMatrixComplex a;
a=ca;
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i;
j2=n-1;
}
else
{
j1=0;
j2=i;
}
//--- change t
for(j=j1;j<=j2;j++)
{
//--- check
if(i==j)
t[i]=t[i]+CMath::AbsComplex(a[i][i]);
else
{
t[i]=t[i]+CMath::AbsComplex(a[i][j]);
t[j]=t[j]+CMath::AbsComplex(a[i][j]);
}
}
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- check
if(CTrFac::HPDMatrixCholesky(a,n,isupper))
{
//--- function call
HPDMatrixRCondCholeskyInternal(a,n,isupper,true,nrm,v);
//--- get result
result=v;
}
else
result=-1;
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Estimate of a matrix 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 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. |
//+------------------------------------------------------------------+
static double CRCond::CMatrixRCond1(CMatrixComplex &ca,const int n)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
//--- create arrays
double t[];
int pivots[];
//--- create copy
CMatrixComplex a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
t[j]=t[j]+CMath::AbsComplex(a[i][j]);
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- function call
CTrFac::CMatrixLU(a,n,n,pivots);
//--- function call
CMatrixRCondLUInternal(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. |
//+------------------------------------------------------------------+
static double CRCond::CMatrixRCondInf(CMatrixComplex &ca,const int n)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
//--- create array
int pivots[];
//--- create copy
CMatrixComplex a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- change values
nrm=0;
for(i=0;i<n;i++)
{
v=0;
for(j=0;j<n;j++)
v=v+CMath::AbsComplex(a[i][j]);
nrm=MathMax(nrm,v);
}
//--- function call
CTrFac::CMatrixLU(a,n,n,pivots);
//--- function call
CMatrixRCondLUInternal(a,n,false,true,nrm,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Estimate of the condition number of a matrix given by its LU |
//| decomposition (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: |
//| LUA - LU decomposition of a matrix in compact form.|
//| Output of the RMatrixLU 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. |
//+------------------------------------------------------------------+
static double CRCond::RMatrixLURCond1(CMatrixDouble &lua,const int n)
{
//--- create a variable
double v=0;
//--- function call
RMatrixRCondLUInternal(lua,n,true,false,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 RMatrixLU 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. |
//+------------------------------------------------------------------+
static double CRCond::RMatrixLURCondInf(CMatrixDouble &lua,const int n)
{
//--- create a variable
double v=0;
//--- function call
RMatrixRCondLUInternal(lua,n,false,false,0,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Condition number estimate of a symmetric positive definite matrix|
//| given by Cholesky decomposition. |
//| 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 condition numbers of |
//| symmetric matrices are equal, so the algorithm doesn't take into |
//| account the differences between these types of norms. |
//| Input parameters: |
//| CD - Cholesky decomposition of matrix A, |
//| output of SMatrixCholesky 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. |
//+------------------------------------------------------------------+
static double CRCond::SPDMatrixCholeskyRCond(CMatrixDouble &a,const int n,
const bool isupper)
{
//--- create a variable
double v=0;
//--- function call
SPDMatrixRCondCholeskyInternal(a,n,isupper,false,0,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Condition number estimate of a Hermitian positive definite matrix|
//| given by Cholesky decomposition. |
//| 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 condition numbers of |
//| symmetric matrices are equal, so the algorithm doesn't take into |
//| account the differences between these types of norms. |
//| Input parameters: |
//| CD - Cholesky decomposition of matrix A, |
//| output of SMatrixCholesky 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. |
//+------------------------------------------------------------------+
static double CRCond::HPDMatrixCholeskyRCond(CMatrixComplex &a,const int n,
const bool isupper)
{
//--- create a variable
double v=0;
//--- function call
HPDMatrixRCondCholeskyInternal(a,n,isupper,false,0,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Estimate of the condition number of a matrix given by its LU |
//| decomposition (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: |
//| 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. |
//+------------------------------------------------------------------+
static double CRCond::CMatrixLURCond1(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,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. |
//+------------------------------------------------------------------+
static 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. |
//+------------------------------------------------------------------+
static double CRCond::CMatrixTrRCond1(CMatrixComplex &a,const int n,
const bool isupper,const bool isunit)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
int j1=0;
int j2=0;
//--- create arrays
int pivots[];
double t[];
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- allocation
ArrayResizeAL(t,n);
//--- fiiling array
for(i=0;i<n;i++)
t[i]=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change t
for(j=j1;j<=j2;j++)
t[j]=t[j]+CMath::AbsComplex(a[i][j]);
//--- check
if(isunit)
t[i]=t[i]+1;
else
t[i]=t[i]+CMath::AbsComplex(a[i][i]);
}
//--- change values
nrm=0;
for(i=0;i<n;i++)
nrm=MathMax(nrm,t[i]);
//--- function call
CMatrixRCondTrInternal(a,n,isupper,isunit,true,nrm,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Triangular matrix: 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. |
//| 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. |
//+------------------------------------------------------------------+
static double CRCond::CMatrixTrRCondInf(CMatrixComplex &a,const int n,
const bool isupper,const bool isunit)
{
//--- create variables
int i=0;
int j=0;
double v=0;
double nrm=0;
int j1=0;
int j2=0;
//--- create array
int pivots[];
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- change values
nrm=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change v
v=0;
for(j=j1;j<=j2;j++)
v=v+CMath::AbsComplex(a[i][j]);
//--- check
if(isunit)
v=v+1;
else
v=v+CMath::AbsComplex(a[i][i]);
nrm=MathMax(nrm,v);
}
//--- function call
CMatrixRCondTrInternal(a,n,isupper,isunit,false,nrm,v);
//--- return result
return(v);
}
//+------------------------------------------------------------------+
//| Threshold for rcond: matrices with condition number beyond this |
//| threshold are considered singular. |
//| Threshold must be far enough from underflow, at least |
//| Sqr(Threshold) must be greater than underflow. |
//+------------------------------------------------------------------+
static double CRCond::RCondThreshold(void)
{
//--- return result
return(MathSqrt(MathSqrt(CMath::m_minrealnumber)));
}
//+------------------------------------------------------------------+
//| Internal subroutine for condition number estimation |
//| -- 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 |
//+------------------------------------------------------------------+
static void CRCond::RMatrixRCondTrInternal(CMatrixDouble &a,const int n,
const bool isupper,const bool isunit,
const bool onenorm,double anorm,
double &rc)
{
//--- create variables
int i=0;
int j=0;
int kase=0;
int kase1=0;
int j1=0;
int j2=0;
double ainvnm=0;
double maxgrowth=0;
double s=0;
bool mupper;
bool mtrans;
bool munit;
//--- create arrays
double ex[];
double ev[];
int iwork[];
double tmp[];
//--- check
if(onenorm)
kase1=1;
else
kase1=2;
//--- initialization
rc=0;
mupper=true;
mtrans=true;
munit=true;
//--- allocation
ArrayResizeAL(iwork,n+1);
ArrayResizeAL(tmp,n);
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
s=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change s
for(j=j1;j<=j2;j++)
s=MathMax(s,MathAbs(a[i][j]));
//--- check
if(isunit)
s=MathMax(s,1);
else
s=MathMax(s,MathAbs(a[i][i]));
}
//--- check
if(s==0.0)
s=1;
s=1/s;
//--- Scale according to S
anorm=anorm*s;
//--- Quick return if possible
//--- We assume that ANORM<>0 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<n;i++)
ex[i]=ex[i+1];
//--- multiply by inv(A) or inv(A')
if(kase==kase1)
{
//--- multiply by inv(A)
if(!CSafeSolve::RMatrixScaledTrSafeSolve(a,s,n,ex,isupper,0,isunit,maxgrowth))
return;
}
else
{
//--- multiply by inv(A')
if(!CSafeSolve::RMatrixScaledTrSafeSolve(a,s,n,ex,isupper,1,isunit,maxgrowth))
return;
}
//--- from 0-based array to 1-based
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Condition number estimation |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| March 31, 1993 |
//+------------------------------------------------------------------+
static void CRCond::CMatrixRCondTrInternal(CMatrixComplex &a,const int n,
const bool isupper,const bool isunit,
const bool onenorm,double anorm,
double &rc)
{
//--- create variables
int kase=0;
int kase1=0;
double ainvnm=0;
int i=0;
int j=0;
int j1=0;
int j2=0;
double s=0;
double maxgrowth=0;
//--- create arrays
complex ex[];
complex cwork2[];
complex cwork3[];
complex cwork4[];
int isave[];
double rsave[];
//--- initialization
rc=0;
//--- check
if(n<=0)
return;
//--- check
if(n==0)
{
rc=1;
return;
}
//--- allocation
ArrayResizeAL(cwork2,n+1);
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
s=0;
for(i=0;i<n;i++)
{
//--- check
if(isupper)
{
j1=i+1;
j2=n-1;
}
else
{
j1=0;
j2=i-1;
}
//--- change s
for(j=j1;j<=j2;j++)
s=MathMax(s,CMath::AbsComplex(a[i][j]));
//--- check
if(isunit)
s=MathMax(s,1);
else
s=MathMax(s,CMath::AbsComplex(a[i][i]));
}
//--- check
if(s==0.0)
s=1;
s=1/s;
//--- Scale according to S
anorm=anorm*s;
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<n;i++)
ex[i]=ex[i+1];
//--- multiply by inv(A) or inv(A')
if(kase==kase1)
{
//--- multiply by inv(A)
if(!CSafeSolve::CMatrixScaledTrSafeSolve(a,s,n,ex,isupper,0,isunit,maxgrowth))
return;
}
else
{
//--- multiply by inv(A')
if(!CSafeSolve::CMatrixScaledTrSafeSolve(a,s,n,ex,isupper,2,isunit,maxgrowth))
return;
}
//--- from 0-based array to 1-based
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine for condition number estimation |
//| -- 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 |
//+------------------------------------------------------------------+
static void CRCond::SPDMatrixRCondCholeskyInternal(CMatrixDouble &cha,const int n,
const bool isupper,
const bool isnormprovided,
double anorm,double &rc)
{
//--- 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
double ex[];
double ev[];
double tmp[];
int iwork[];
//--- check
if(!CAp::Assert(n>=1))
return;
//--- allocation
ArrayResizeAL(tmp,n);
//--- initialization
rc=0;
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
sa=0;
//--- check
if(isupper)
{
for(i=0;i<n;i++)
for(j=i;j<n;j++)
sa=MathMax(sa,CMath::AbsComplex(cha[i][j]));
}
else
{
for(i=0;i<n;i++)
for(j=0;j<=i;j++)
sa=MathMax(sa,CMath::AbsComplex(cha[i][j]));
}
//--- check
if(sa==0.0)
sa=1;
sa=1/sa;
//--- Estimate the norm of A
if(!isnormprovided)
{
kase=0;
anorm=0;
while(true)
{
//--- function call
RMatrixEstimateNorm(n,ev,ex,iwork,anorm,kase);
//--- check
if(kase==0)
break;
//--- check
if(isupper)
{
//--- Multiply by U
for(i=1;i<=n;i++)
{
i1_=1;
v=0.0;
for(i_=i-1;i_<n;i_++)
v+=cha[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
for(i_=1;i_<=n;i_++)
ex[i_]=sa*ex[i_];
//--- Multiply by U'
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
for(i_=i;i_<n;i_++)
tmp[i_]=tmp[i_]+v*cha[i][i_];
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
for(i_=1;i_<=n;i_++)
ex[i_]=sa*ex[i_];
}
else
{
//--- Multiply by L''
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
for(i_=0;i_<=i;i_++)
tmp[i_]=tmp[i_]+v*cha[i][i_];
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
for(i_=1;i_<=n;i_++)
ex[i_]=sa*ex[i_];
//--- Multiply by L'
for(i=n;i>=1;i--)
{
i1_=1;
v=0.0;
for(i_=0;i_<i;i_++)
v+=cha[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
for(i_=1;i_<=n;i_++)
ex[i_]=sa*ex[i_];
}
}
}
//--- check
if(anorm==0.0)
return;
//--- check
if(n==1)
{
rc=1;
return;
}
//--- Estimate the 1-norm of inv(A).
kase=0;
while(true)
{
//--- function call
RMatrixEstimateNorm(n,ev,ex,iwork,ainvnm,kase);
//--- check
if(kase==0)
break;
for(i=0;i<n;i++)
ex[i]=ex[i+1];
//--- check
if(isupper)
{
//--- Multiply by inv(U')
if(!CSafeSolve::RMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,1,false,maxgrowth))
return;
//--- Multiply by inv(U)
if(!CSafeSolve::RMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,0,false,maxgrowth))
return;
}
else
{
//--- Multiply by inv(L)
if(!CSafeSolve::RMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,0,false,maxgrowth))
return;
//--- Multiply by inv(L')
if(!CSafeSolve::RMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,1,false,maxgrowth))
return;
}
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine for condition number estimation |
//| -- 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 |
//+------------------------------------------------------------------+
static void CRCond::HPDMatrixRCondCholeskyInternal(CMatrixComplex &cha,const int n,
const bool isupper,
const bool isnormprovided,
double anorm,double &rc)
{
//--- 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
int isave[];
double rsave[];
complex ex[];
complex ev[];
complex tmp[];
//--- check
if(!CAp::Assert(n>=1))
return;
//--- allocation
ArrayResizeAL(tmp,n);
//--- initialization
rc=0;
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
sa=0;
//--- check
if(isupper)
{
for(i=0;i<n;i++)
for(j=i;j<n;j++)
sa=MathMax(sa,CMath::AbsComplex(cha[i][j]));
}
else
{
for(i=0;i<n;i++)
for(j=0;j<=i;j++)
sa=MathMax(sa,CMath::AbsComplex(cha[i][j]));
}
//--- check
if(sa==0.0)
sa=1;
sa=1/sa;
//--- Estimate the norm of A
if(!isnormprovided)
{
anorm=0;
kase=0;
while(true)
{
//--- function call
CMatrixEstimateNorm(n,ev,ex,anorm,kase,isave,rsave);
//--- check
if(kase==0)
break;
//--- check
if(isupper)
{
//--- Multiply by U
for(i=1;i<=n;i++)
{
i1_=1;
v=0.0;
for(i_=i-1;i_<n;i_++)
v+=cha[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
for(i_=1;i_<=n;i_++)
{
Csa=sa;
ex[i_]=Csa*ex[i_];
}
//--- Multiply by U'
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
for(i_=i;i_<n;i_++)
tmp[i_]=tmp[i_]+v*CMath::Conj(cha[i][i_]);
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
for(i_=1;i_<=n;i_++)
{
Csa=sa;
ex[i_]=Csa*ex[i_];
}
}
else
{
//--- Multiply by L''
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
for(i_=0;i_<=i;i_++)
tmp[i_]=tmp[i_]+v*CMath::Conj(cha[i][i_]);
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
for(i_=1;i_<=n;i_++)
{
Csa=sa;
ex[i_]=Csa*ex[i_];
}
//--- Multiply by L'
for(i=n;i>=1;i--)
{
i1_=1;
v=0.0;
for(i_=0;i_<i;i_++)
v+=cha[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
for(i_=1;i_<=n;i_++)
{
Csa=sa;
ex[i_]=Csa*ex[i_];
}
}
}
}
//--- Quick return if possible
//--- After this block we assume that ANORM<>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<n;i++)
ex[i]=ex[i+1];
//--- check
if(isupper)
{
//--- Multiply by inv(U')
if(!CSafeSolve::CMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,2,false,maxgrowth))
return;
//--- Multiply by inv(U)
if(!CSafeSolve::CMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,0,false,maxgrowth))
return;
}
else
{
//--- Multiply by inv(L)
if(!CSafeSolve::CMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,0,false,maxgrowth))
return;
//--- Multiply by inv(L')
if(!CSafeSolve::CMatrixScaledTrSafeSolve(cha,sa,n,ex,isupper,2,false,maxgrowth))
return;
}
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine for condition number estimation |
//| -- 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 |
//+------------------------------------------------------------------+
static void CRCond::RMatrixRCondLUInternal(CMatrixDouble &lua,const int n,
const bool onenorm,
const bool isanormprovided,
double anorm,double &rc)
{
//--- create variables
double v=0;
int i=0;
int j=0;
int kase=0;
int kase1=0;
double ainvnm=0;
double maxgrowth=0;
double su=0;
double sl=0;
bool mupper;
bool mtrans;
bool munit;
int i_=0;
int i1_=0;
//--- create arrays
double ex[];
double ev[];
int iwork[];
double tmp[];
//--- check
if(onenorm)
kase1=1;
else
kase1=2;
//--- initialization
rc=0;
mupper=true;
mtrans=true;
munit=true;
//--- allocation
ArrayResizeAL(iwork,n+1);
ArrayResizeAL(tmp,n);
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
su=0;
sl=1;
for(i=0;i<n;i++)
{
for(j=0;j<i;j++)
sl=MathMax(sl,MathAbs(lua[i][j]));
for(j=i;j<n;j++)
su=MathMax(su,MathAbs(lua[i][j]));
}
//--- check
if(su==0.0)
su=1;
su=1/su;
sl=1/sl;
//--- Estimate the norm of A
if(!isanormprovided)
{
kase=0;
anorm=0;
while(true)
{
//--- function call
RMatrixEstimateNorm(n,ev,ex,iwork,anorm,kase);
//--- check
if(kase==0)
break;
//--- check
if(kase==kase1)
{
//--- Multiply by U
for(i=1;i<=n;i++)
{
i1_=1;
v=0.0;
for(i_=i-1;i_<n;i_++)
v+=lua[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
//--- Multiply by L
for(i=n;i>=1;i--)
{
//--- check
if(i>1)
{
i1_=1;
v=0.0;
for(i_=0;i_<=i-2;i_++)
v+=lua[i-1][i_]*ex[i_+i1_];
}
else
v=0;
ex[i]=ex[i]+v;
}
}
else
{
//--- Multiply by L'
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
//--- check
if(i>=1)
{
for(i_=0;i_<i;i_++)
tmp[i_]=tmp[i_]+v*lua[i][i_];
}
tmp[i]=tmp[i]+v;
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
//--- Multiply by U'
for(i=0;i<n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
{
v=ex[i+1];
for(i_=i;i_<n;i_++)
tmp[i_]=tmp[i_]+v*lua[i][i_];
}
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
ex[i_]=tmp[i_+i1_];
}
}
}
//--- Scale according to SU/SL
anorm=anorm*su*sl;
//--- Quick return if possible
//--- We assume that ANORM<>0 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<n;i++)
ex[i]=ex[i+1];
//--- multiply by inv(A) or inv(A')
if(kase==kase1)
{
//--- Multiply by inv(L)
if(!CSafeSolve::RMatrixScaledTrSafeSolve(lua,sl,n,ex,!mupper,0,munit,maxgrowth))
return;
//--- Multiply by inv(U)
if(!CSafeSolve::RMatrixScaledTrSafeSolve(lua,su,n,ex,mupper,0,!munit,maxgrowth))
return;
}
else
{
//--- Multiply by inv(U')
if(!CSafeSolve::RMatrixScaledTrSafeSolve(lua,su,n,ex,mupper,1,!munit,maxgrowth))
return;
//--- Multiply by inv(L')
if(!CSafeSolve::RMatrixScaledTrSafeSolve(lua,sl,n,ex,!mupper,1,munit,maxgrowth))
return;
}
//--- from 0-based array to 1-based
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Condition number estimation |
//| -- LAPACK routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| March 31, 1993 |
//+------------------------------------------------------------------+
static void CRCond::CMatrixRCondLUInternal(CMatrixComplex &lua,const int n,
const bool onenorm,
const bool isanormprovided,
double anorm,double &rc)
{
//--- create variables
int kase=0;
int kase1=0;
double ainvnm=0;
complex v=0;
int i=0;
int j=0;
double su=0;
double sl=0;
double maxgrowth=0;
int i_=0;
int i1_=0;
//--- create arrays
complex ex[];
complex cwork2[];
complex cwork3[];
complex cwork4[];
int isave[];
double rsave[];
//--- check
if(n<=0)
return;
//--- allocation
ArrayResizeAL(cwork2,n+1);
//--- initialization
rc=0;
//--- check
if(n==0)
{
rc=1;
return;
}
//--- prepare parameters for triangular solver
maxgrowth=1/RCondThreshold();
su=0;
sl=1;
for(i=0;i<n;i++)
{
for(j=0;j<i;j++)
sl=MathMax(sl,CMath::AbsComplex(lua[i][j]));
for(j=i;j<n;j++)
su=MathMax(su,CMath::AbsComplex(lua[i][j]));
}
//--- check
if(su==0.0)
su=1;
su=1/su;
sl=1/sl;
//--- Estimate the norm of SU*SL*A
if(!isanormprovided)
{
anorm=0;
//--- check
if(onenorm)
kase1=1;
else
kase1=2;
kase=0;
do
{
//--- function call
CMatrixEstimateNorm(n,cwork4,ex,anorm,kase,isave,rsave);
//--- check
if(kase!=0)
{
//--- check
if(kase==kase1)
{
//--- Multiply by U
for(i=1;i<=n;i++)
{
i1_=1;
v=0.0;
for(i_=i-1;i_<n;i_++)
v+=lua[i-1][i_]*ex[i_+i1_];
ex[i]=v;
}
//--- Multiply by L
for(i=n;i>=1;i--)
{
v=0;
//--- check
if(i>1)
{
i1_=1;
v=0.0;
for(i_=0;i_<=i-2;i_++)
v+=lua[i-1][i_]*ex[i_+i1_];
}
ex[i]=v+ex[i];
}
}
else
{
//--- Multiply by L'
for(i=1;i<=n;i++)
cwork2[i]=0;
for(i=1;i<=n;i++)
{
v=ex[i];
//--- check
if(i>1)
{
i1_=-1;
for(i_=1;i_<i;i_++)
cwork2[i_]=cwork2[i_]+v*CMath::Conj(lua[i-1][i_+i1_]);
}
cwork2[i]=cwork2[i]+v;
}
//--- Multiply by U'
for(i=1;i<=n;i++)
ex[i]=0;
for(i=1;i<=n;i++)
{
v=cwork2[i];
i1_=-1;
for(i_=i;i_<=n;i_++)
ex[i_]=ex[i_]+v*CMath::Conj(lua[i-1][i_+i1_]);
}
}
}
}
while(kase!=0);
}
//--- Scale according to SU/SL
anorm=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<n;i++)
ex[i]=ex[i+1];
//--- multiply by inv(A) or inv(A')
if(kase==kase1)
{
//--- Multiply by inv(L)
if(!CSafeSolve::CMatrixScaledTrSafeSolve(lua,sl,n,ex,false,0,true,maxgrowth))
{
rc=0;
//--- exit the function
return;
}
//--- Multiply by inv(U)
if(!CSafeSolve::CMatrixScaledTrSafeSolve(lua,su,n,ex,true,0,false,maxgrowth))
{
rc=0;
//--- exit the function
return;
}
}
else
{
//--- Multiply by inv(U')
if(!CSafeSolve::CMatrixScaledTrSafeSolve(lua,su,n,ex,true,2,false,maxgrowth))
{
rc=0;
//--- exit the function
return;
}
//--- Multiply by inv(L')
if(!CSafeSolve::CMatrixScaledTrSafeSolve(lua,sl,n,ex,false,2,true,maxgrowth))
{
rc=0;
//--- exit the function
return;
}
}
//--- from 0-based array to 1-based
for(i=n-1;i>=0;i--)
ex[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<RCondThreshold())
rc=0;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine for matrix norm estimation |
//| -- LAPACK auxiliary routine (version 3.0) -- |
//| Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
//| Courant Institute, Argonne National Lab, and Rice University|
//| February 29, 1992 |
//+------------------------------------------------------------------+
static void CRCond::RMatrixEstimateNorm(const int n,double &v[],double &x[],
int &isgn[],double &est,int &kase)
{
//--- create variables
int itmax=0;
int i=0;
double t=0;
bool flg;
int positer=0;
int posj=0;
int posjlast=0;
int posjump=0;
int posaltsgn=0;
int posestold=0;
int postemp=0;
int i_=0;
//--- initialization
itmax=5;
posaltsgn=n+1;
posestold=n+2;
postemp=n+3;
positer=n+1;
posj=n+2;
posjlast=n+3;
posjump=n+4;
//--- check
if(kase==0)
{
//--- allocation
ArrayResizeAL(v,n+4);
ArrayResizeAL(x,n+1);
ArrayResizeAL(isgn,n+5);
//--- change values
t=1.0/(double)n;
for(i=1;i<=n;i++)
x[i]=t;
kase=1;
isgn[posjump]=1;
//--- exit the function
return;
}
//--- ................ entry (jump = 1)
//--- first iteration. x has been overwritten by a*x.
if(isgn[posjump]==1)
{
//--- check
if(n==1)
{
v[1]=x[1];
est=MathAbs(v[1]);
kase=0;
//--- exit the function
return;
}
//--- change value
est=0;
for(i=1;i<=n;i++)
est=est+MathAbs(x[i]);
for(i=1;i<=n;i++)
{
//--- check
if(x[i]>=0.0)
x[i]=1;
else
x[i]=-1;
//--- check
if(x[i]>0)
isgn[i]=1;
//--- check
if(x[i]<0)
isgn[i]=-1;
//--- check
if(x[i]==0)
isgn[i]=0;
}
kase=2;
isgn[posjump]=2;
//--- exit the function
return;
}
//--- ................ entry (jump = 2)
//--- first iteration. x has been overwritten by trandpose(a)*x.
if(isgn[posjump]==2)
{
isgn[posj]=1;
for(i=2;i<=n;i++)
{
//--- check
if(MathAbs(x[i])>MathAbs(x[isgn[posj]]))
isgn[posj]=i;
}
isgn[positer]=2;
//--- main loop - iterations 2,3,...,itmax.
for(i=1;i<=n;i++)
x[i]=0;
x[isgn[posj]]=1;
kase=1;
isgn[posjump]=3;
//--- exit the function
return;
}
//--- ................ entry (jump = 3)
//--- x has been overwritten by a*x.
if(isgn[posjump]==3)
{
for(i_=1;i_<=n;i_++)
v[i_]=x[i_];
v[posestold]=est;
//--- change value
est=0;
for(i=1;i<=n;i++)
est=est+MathAbs(v[i]);
flg=false;
for(i=1;i<=n;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[posaltsgn]=1;
for(i=1;i<=n;i++)
{
x[i]=v[posaltsgn]*(1+(double)(i-1)/(double)(n-1));
v[posaltsgn]=-v[posaltsgn];
}
kase=1;
isgn[posjump]=5;
//--- exit the function
return;
}
for(i=1;i<=n;i++)
{
//--- check
if(x[i]>=0.0)
{
x[i]=1;
isgn[i]=1;
}
else
{
x[i]=-1;
isgn[i]=-1;
}
}
kase=2;
isgn[posjump]=4;
//--- exit the function
return;
}
//--- ................ entry (jump = 4)
//--- x has been overwritten by trandpose(a)*x.
if(isgn[posjump]==4)
{
isgn[posjlast]=isgn[posj];
isgn[posj]=1;
for(i=2;i<=n;i++)
{
//--- check
if(MathAbs(x[i])>MathAbs(x[isgn[posj]]))
isgn[posj]=i;
}
//--- check
if(x[isgn[posjlast]]!=MathAbs(x[isgn[posj]]) && isgn[positer]<itmax)
{
isgn[positer]=isgn[positer]+1;
for(i=1;i<=n;i++)
x[i]=0;
x[isgn[posj]]=1;
kase=1;
isgn[posjump]=3;
//--- exit the function
return;
}
//--- iteration complete. final stage.
v[posaltsgn]=1;
for(i=1;i<=n;i++)
{
x[i]=v[posaltsgn]*(1+(double)(i-1)/(double)(n-1));
v[posaltsgn]=-v[posaltsgn];
}
kase=1;
isgn[posjump]=5;
//--- exit the function
return;
}
//--- ................ entry (jump = 5)
//--- x has been overwritten by a*x.
if(isgn[posjump]==5)
{
v[postemp]=0;
for(i=1;i<=n;i++)
v[postemp]=v[postemp]+MathAbs(x[i]);
v[postemp]=2*v[postemp]/(3*n);
//--- check
if(v[postemp]>est)
{
for(i_=1;i_<=n;i_++)
v[i_]=x[i_];
est=v[postemp];
}
kase=0;
//--- exit the function
return;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CRCond::CMatrixEstimateNorm(const int n,complex &v[],complex &x[],
double &est,int &kase,int &isave[],
double &rsave[])
{
//--- create variables
int itmax=0;
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=0;
double temp=0;
int i_=0;
//--- Executable Statements
itmax=5;
safmin=CMath::m_minrealnumber;
//--- check
if(kase==0)
{
//--- allocation
ArrayResizeAL(v,n+1);
ArrayResizeAL(x,n+1);
ArrayResizeAL(isave,5);
ArrayResizeAL(rsave,4);
for(i=1;i<=n;i++)
x[i]=1.0/(double)n;
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);
//--- entry (jump = 1)
//--- first iteration. x has been overwritten by a*x.
if(jump==1)
{
//--- check
if(n==1)
{
v[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[i]=x[i]/absxi;
else
x[i]=1;
}
kase=2;
jump=2;
//--- function call
InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp);
//--- exit the function
return;
}
//--- entry (jump = 2)
//--- first iteration. x has been overwritten by ctrans(a)*x.
if(jump==2)
{
j=InternalComplexRCondIcMax1(x,n);
iter=2;
//--- main loop - iterations 2,3,...,itmax.
for(i=1;i<=n;i++)
x[i]=0;
x[j]=1;
kase=1;
jump=3;
//--- function call
InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp);
//--- exit the function
return;
}
//--- entry (jump = 3)
//--- x has been overwritten by a*x.
if(jump==3)
{
for(i_=1;i_<=n;i_++)
v[i_]=x[i_];
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[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
return;
}
for(i=1;i<=n;i++)
{
absxi=CMath::AbsComplex(x[i]);
//--- check
if(absxi>safmin)
x[i]=x[i]/absxi;
else
x[i]=1;
}
kase=2;
jump=4;
//--- function call
InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp);
//--- exit the function
return;
}
//--- entry (jump = 4)
//--- x has been overwritten by ctrans(a)*x.
if(jump==4)
{
jlast=j;
j=InternalComplexRCondIcMax1(x,n);
//--- check
if(CMath::AbsComplex(x[jlast])!=CMath::AbsComplex(x[j]) && iter<itmax)
{
iter=iter+1;
//--- main loop - iterations 2,3,...,itmax.
for(i=1;i<=n;i++)
x[i]=0;
x[j]=1;
kase=1;
jump=3;
//--- function call
InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp);
//--- exit the function
return;
}
//--- iteration complete. final stage.
altsgn=1;
for(i=1;i<=n;i++)
{
x[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
return;
}
//--- entry (jump = 5)
//--- x has been overwritten by a*x.
if(jump==5)
{
temp=2*(InternalComplexRCondScSum1(x,n)/(3*n));
//--- check
if(temp>est)
{
for(i_=1;i_<=n;i_++)
v[i_]=x[i_];
est=temp;
}
kase=0;
//--- function call
InternalComplexRCondSaveAll(isave,rsave,i,iter,j,jlast,jump,absxi,altsgn,estold,temp);
//--- exit the function
return;
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static double CRCond::InternalComplexRCondScSum1(complex &x[],const int n)
{
//--- create variables
double result=0;
int i=0;
//--- get result
for(i=1;i<=n;i++)
result=result+CMath::AbsComplex(x[i]);
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static int CRCond::InternalComplexRCondIcMax1(complex &x[],const int n)
{
//--- create variables
int result=0;
int i=0;
double m=0;
//--- get result
result=1;
m=CMath::AbsComplex(x[1]);
for(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 |
//+------------------------------------------------------------------+
static void CRCond::InternalComplexRCondSaveAll(int &isave[],double &rsave[],
int &i,int &iter,int &j,
int &jlast,int &jump,
double &absxi,double &altsgn,
double &estold,double &temp)
{
//--- copy
isave[0]=i;
isave[1]=iter;
isave[2]=j;
isave[3]=jlast;
isave[4]=jump;
//--- copy
rsave[0]=absxi;
rsave[1]=altsgn;
rsave[2]=estold;
rsave[3]=temp;
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CRCond::InternalComplexRCondLoadAll(int &isave[],double &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);
~CMatInvReport(void);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CMatInvReport::CMatInvReport(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CMatInvReport::~CMatInvReport(void)
{
}
//+------------------------------------------------------------------+
//| 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);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CMatInvReportShell::CMatInvReportShell(void)
{
}
//+------------------------------------------------------------------+
//| Copy |
//+------------------------------------------------------------------+
CMatInvReportShell::CMatInvReportShell(CMatInvReport &obj)
{
m_innerobj.m_r1=obj.m_r1;
m_innerobj.m_rinf=obj.m_rinf;
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CMatInvReportShell::~CMatInvReportShell(void)
{
}
//+------------------------------------------------------------------+
//| 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
{
private:
//--- private methods
static void RMatrixTrInverseRec(CMatrixDouble &a,const int offs,const int n,const bool isupper,const bool isunit,double &tmp[],int &info,CMatInvReport &rep);
static void CMatrixTrInverseRec(CMatrixComplex &a,const int offs,const int n,const bool isupper,const bool isunit,complex &tmp[],int &info,CMatInvReport &rep);
static void RMatrixLUInverseRec(CMatrixDouble &a,const int offs,const int n,double &work[],int &info,CMatInvReport &rep);
static void CMatrixLUInverseRec(CMatrixComplex &a,const int offs,const int n,complex &work[],int &info,CMatInvReport &rep);
static void SPDMatrixCholeskyInverseRec(CMatrixDouble &a,const int offs,const int n,const bool isupper,double &tmp[]);
static void HPDMatrixCholeskyInverseRec(CMatrixComplex &a,const int offs,const int n,const bool isupper,complex &tmp[]);
public:
CMatInv(void);
~CMatInv(void);
//--- public methods
static void RMatrixLUInverse(CMatrixDouble &a,int &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 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);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CMatInv::CMatInv(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CMatInv::~CMatInv(void)
{
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static void CMatInv::RMatrixLUInverse(CMatrixDouble &a,int &pivots[],
const int n,int &info,CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
int k=0;
double v=0;
//--- create array
double work[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": len(Pivots)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
for(i=0;i<n;i++)
{
//--- check
if(pivots[i]>n-1 || pivots[i]<i)
info=-1;
}
//--- check
if(!CAp::Assert(info>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<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Call cache-oblivious code
ArrayResizeAL(work,n);
RMatrixLUInverseRec(a,0,n,work,info,rep);
//--- apply permutations
for(i=0;i<n;i++)
{
for(j=n-2;j>=0;j--)
{
k=pivots[j];
v=a[i][j];
a[i].Set(j,a[i][k]);
a[i].Set(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. |
//+------------------------------------------------------------------+
static void CMatInv::RMatrixInverse(CMatrixDouble &a,const int n,int &info,
CMatInvReport &rep)
{
//--- create array
int pivots[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- function call
CTrFac::RMatrixLU(a,n,n,pivots);
//--- function call
RMatrixLUInverse(a,pivots,n,info,rep);
}
//+------------------------------------------------------------------+
//| Inversion of a matrix given by its LU decomposition. |
//| INPUT PARAMETERS: |
//| A - LU decomposition of the matrix |
//| (output of CMatrixLU subroutine). |
//| Pivots - table of permutations |
//| (the output of CMatrixLU 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, same as in RMatrixLUInverse |
//| Rep - solver report, same as in RMatrixLUInverse |
//| A - inverse of matrix A, same as in RMatrixLUInverse |
//+------------------------------------------------------------------+
static void CMatInv::CMatrixLUInverse(CMatrixComplex &a,int &pivots[],
const int n,int &info,CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
int k=0;
complex v=0;
//--- create array
complex work[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": len(Pivots)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteComplexMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
for(i=0;i<n;i++)
{
//--- check
if(pivots[i]>n-1 || pivots[i]<i)
info=-1;
}
//--- check
if(!CAp::Assert(info>0,__FUNCTION__+": incorrect Pivots array!"))
return;
//--- calculate condition numbers
rep.m_r1=CRCond::CMatrixLURCond1(a,n);
rep.m_rinf=CRCond::CMatrixLURCondInf(a,n);
//--- check
if(rep.m_r1<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Call cache-oblivious code
ArrayResizeAL(work,n);
CMatrixLUInverseRec(a,0,n,work,info,rep);
//--- apply permutations
for(i=0;i<n;i++)
{
for(j=n-2;j>=0;j--)
{
k=pivots[j];
v=a[i][j];
a[i].Set(j,a[i][k]);
a[i].Set(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 |
//+------------------------------------------------------------------+
static void CMatInv::CMatrixInverse(CMatrixComplex &a,const int n,int &info,
CMatInvReport &rep)
{
//--- create array
int pivots[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteComplexMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- function call
CTrFac::CMatrixLU(a,n,n,pivots);
//--- function call
CMatrixLUInverse(a,pivots,n,info,rep);
}
//+------------------------------------------------------------------+
//| Inversion of a symmetric positive definite matrix which is given |
//| by Cholesky decomposition. |
//| Input parameters: |
//| A - Cholesky decomposition of the matrix to be |
//| inverted: A=U?*U or A = L*L'. |
//| Output of SPDMatrixCholesky 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) |
//| IsUpper - storage type (optional): |
//| * if True, symmetric matrix A is given by its |
//| upper triangle, and the lower triangle isn?t |
//| used/changed by function |
//| * if False, symmetric matrix A is given by its |
//| lower triangle, and the upper triangle isn?t |
//| used/changed by function |
//| * if not given, lower half is used. |
//| 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 |
//+------------------------------------------------------------------+
static void CMatInv::SPDMatrixCholeskyInverse(CMatrixDouble &a,const int n,
const bool isupper,int &info,
CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
bool f;
//--- create array
double tmp[];
//--- object of class
CMatInvReport rep2;
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- initialization
info=1;
f=true;
for(i=0;i<n;i++)
f=f && CMath::IsFinite(a[i][i]);
//--- check
if(!CAp::Assert(f,__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- calculate condition numbers
rep.m_r1=CRCond::SPDMatrixCholeskyRCond(a,n,isupper);
rep.m_rinf=rep.m_r1;
//--- check
if(rep.m_r1<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{//--- check
if(isupper)
{
for(i=0;i<n;i++)
for(j=i;j<n;j++)
a[i].Set(j,0);
}
else
{
for(i=0;i<n;i++)
for(j=0;j<=i;j++)
a[i].Set(j,0);
}
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Inverse
ArrayResizeAL(tmp,n);
SPDMatrixCholeskyInverseRec(a,0,n,isupper,tmp);
}
//+------------------------------------------------------------------+
//| Inversion of a symmetric positive definite matrix. |
//| Given an upper or lower triangle of a symmetric positive definite|
//| matrix, the algorithm generates matrix A^-1 and saves the upper |
//| or lower triangle depending on the input. |
//| Input parameters: |
//| A - matrix to be inverted (upper or lower triangle). |
//| Array with elements [0..N-1,0..N-1]. |
//| 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) |
//| IsUpper - storage type (optional): |
//| * if True, symmetric matrix A is given by its |
//| upper triangle, and the lower triangle isn?t |
//| used/changed by function |
//| * if False, symmetric matrix A is given by its |
//| lower triangle, and the upper triangle isn?t |
//| used/changed by function |
//| * if not given, both lower and upper triangles |
//| must be filled. |
//| 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 |
//+------------------------------------------------------------------+
static void CMatInv::SPDMatrixInverse(CMatrixDouble &a,const int n,
const bool isupper,int &info,
CMatInvReport &rep)
{
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteRTrMatrix(a,n,isupper),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
//--- check
if(CTrFac::SPDMatrixCholesky(a,n,isupper))
SPDMatrixCholeskyInverse(a,n,isupper,info,rep);
else
info=-3;
}
//+------------------------------------------------------------------+
//| Inversion of a Hermitian positive definite matrix which is given |
//| by Cholesky decomposition. |
//| Input parameters: |
//| A - Cholesky decomposition of the matrix to be |
//| inverted: A=U?*U or A = L*L'. |
//| Output of HPDMatrixCholesky 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) |
//| IsUpper - storage type (optional): |
//| * if True, symmetric matrix A is given by its |
//| upper triangle, and the lower triangle isn?t |
//| used/changed by function |
//| * if False, symmetric matrix A is given by its |
//| lower triangle, and the upper triangle isn?t |
//| used/changed by function |
//| * if not given, lower half is used. |
//| 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 |
//+------------------------------------------------------------------+
static void CMatInv::HPDMatrixCholeskyInverse(CMatrixComplex &a,const int n,
const bool isupper,int &info,
CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
bool f;
//--- create array
complex tmp[];
//--- object of class
CMatInvReport rep2;
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- initialization
f=true;
for(i=0;i<n;i++)
f=(f && CMath::IsFinite(a[i][i].re)) && CMath::IsFinite(a[i][i].im);
//--- check
if(!CAp::Assert(f,__FUNCTION__+": A contains infinite or NaN values!"))
return;
info=1;
//--- calculate condition numbers
rep.m_r1=CRCond::HPDMatrixCholeskyRCond(a,n,isupper);
rep.m_rinf=rep.m_r1;
//--- check
if(rep.m_r1<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{
//--- check
if(isupper)
{
for(i=0;i<n;i++)
for(j=i;j<n;j++)
a[i].Set(j,0);
}
else
{
for(i=0;i<n;i++)
for(j=0;j<=i;j++)
a[i].Set(j,0);
}
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Inverse
ArrayResizeAL(tmp,n);
HPDMatrixCholeskyInverseRec(a,0,n,isupper,tmp);
}
//+------------------------------------------------------------------+
//| Inversion of a Hermitian positive definite matrix. |
//| Given an upper or lower triangle of a Hermitian positive definite|
//| matrix, the algorithm generates matrix A^-1 and saves the upper |
//| or lower triangle depending on the input. |
//| Input parameters: |
//| A - matrix to be inverted (upper or lower triangle). |
//| Array with elements [0..N-1,0..N-1]. |
//| 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) |
//| IsUpper - storage type (optional): |
//| * if True, symmetric matrix A is given by its |
//| upper triangle, and the lower triangle isn?t |
//| used/changed by function |
//| * if False, symmetric matrix A is given by its |
//| lower triangle, and the upper triangle isn?t |
//| used/changed by function |
//| * if not given, both lower and upper triangles |
//| must be filled. |
//| 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 |
//+------------------------------------------------------------------+
static void CMatInv::HPDMatrixInverse(CMatrixComplex &a,const int n,
const bool isupper,int &info,
CMatInvReport &rep)
{
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteCTrMatrix(a,n,isupper),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
//--- check
if(CTrFac::HPDMatrixCholesky(a,n,isupper))
HPDMatrixCholeskyInverse(a,n,isupper,info,rep);
else
info=-3;
}
//+------------------------------------------------------------------+
//| Triangular matrix inverse (real) |
//| The subroutine inverts the following types of matrices: |
//| * upper triangular |
//| * upper triangular with unit diagonal |
//| * lower triangular |
//| * lower triangular with unit diagonal |
//| In case of an upper (lower) triangular matrix, the inverse matrix|
//| will also be upper (lower) triangular, and after the end of the |
//| algorithm, the inverse matrix replaces the source matrix. The |
//| elements below (above) the main diagonal are not changed by the |
//| algorithm. |
//| If the matrix has a unit diagonal, the inverse matrix also has a |
//| unit diagonal, and the diagonal elements are not passed to the |
//| algorithm. |
//| Input parameters: |
//| A - matrix, array[0..N-1, 0..N-1]. |
//| 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) |
//| IsUpper - True, if the matrix is upper triangular. |
//| IsUnit - diagonal type (optional): |
//| * if True, matrix has unit diagonal (a[i,i] are |
//| NOT used) |
//| * if False, matrix diagonal is arbitrary |
//| * if not given, False is assumed |
//| Output parameters: |
//| Info - same as for RMatrixLUInverse |
//| Rep - same as for RMatrixLUInverse |
//| A - same as for RMatrixLUInverse. |
//+------------------------------------------------------------------+
static void CMatInv::RMatrixTrInverse(CMatrixDouble &a,const int n,
const bool isupper,const bool isunit,
int &info,CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
//--- create array
double tmp[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteRTrMatrix(a,n,isupper),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
//--- calculate condition numbers
rep.m_r1=CRCond::RMatrixTrRCond1(a,n,isupper,isunit);
rep.m_rinf=CRCond::RMatrixTrRCondInf(a,n,isupper,isunit);
//--- check
if(rep.m_r1<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{
for(i=0;i<n;i++)
for(j=0;j<n;j++)
a[i].Set(j,0);
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Inverse
ArrayResizeAL(tmp,n);
RMatrixTrInverseRec(a,0,n,isupper,isunit,tmp,info,rep);
}
//+------------------------------------------------------------------+
//| Triangular matrix inverse (complex) |
//| The subroutine inverts the following types of matrices: |
//| * upper triangular |
//| * upper triangular with unit diagonal |
//| * lower triangular |
//| * lower triangular with unit diagonal |
//| In case of an upper (lower) triangular matrix, the inverse matrix|
//| will also be upper (lower) triangular, and after the end of the |
//| algorithm, the inverse matrix replaces the source matrix. The |
//| elements below (above) the main diagonal are not changed by the |
//| algorithm. |
//| If the matrix has a unit diagonal, the inverse matrix also has a |
//| unit diagonal, and the diagonal elements are not passed to the |
//| algorithm. |
//| Input parameters: |
//| A - matrix, array[0..N-1, 0..N-1]. |
//| 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) |
//| IsUpper - True, if the matrix is upper triangular. |
//| IsUnit - diagonal type (optional): |
//| * if True, matrix has unit diagonal (a[i,i] are |
//| NOT used) |
//| * if False, matrix diagonal is arbitrary |
//| * if not given, False is assumed |
//| Output parameters: |
//| Info - same as for RMatrixLUInverse |
//| Rep - same as for RMatrixLUInverse |
//| A - same as for RMatrixLUInverse. |
//+------------------------------------------------------------------+
static void CMatInv::CMatrixTrInverse(CMatrixComplex &a,const int n,
const bool isupper,const bool isunit,
int &info,CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
//--- create array
complex tmp[];
//--- initialization
info=0;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return;
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return;
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return;
//--- check
if(!CAp::Assert(CApServ::IsFiniteCTrMatrix(a,n,isupper),__FUNCTION__+": A contains infinite or NaN values!"))
return;
//--- initialization
info=1;
//--- calculate condition numbers
rep.m_r1=CRCond::CMatrixTrRCond1(a,n,isupper,isunit);
rep.m_rinf=CRCond::CMatrixTrRCondInf(a,n,isupper,isunit);
//--- check
if(rep.m_r1<CRCond::RCondThreshold() || rep.m_rinf<CRCond::RCondThreshold())
{
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
a[i].Set(j,0);
}
//--- change values
rep.m_r1=0;
rep.m_rinf=0;
info=-3;
//--- exit the function
return;
}
//--- Inverse
ArrayResizeAL(tmp,n);
CMatrixTrInverseRec(a,0,n,isupper,isunit,tmp,info,rep);
}
//+------------------------------------------------------------------+
//| Triangular matrix inversion, recursive subroutine |
//+------------------------------------------------------------------+
static void CMatInv::RMatrixTrInverseRec(CMatrixDouble &a,const int offs,
const int n,const bool isupper,
const bool isunit,double &tmp[],
int &info,CMatInvReport &rep)
{
//--- 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;
//--- check
if(n<1)
{
info=-1;
//--- exit the function
return;
}
//--- base case
if(n<=CAblas::AblasBlockSize())
{
//--- check
if(isupper)
{
//--- Compute inverse of upper triangular matrix.
for(j=0;j<n;j++)
{
//--- check
if(!isunit)
{
//--- check
if(a[offs+j][offs+j]==0.0)
{
info=-3;
//--- exit the function
return;
}
a[offs+j].Set(offs+j,1/a[offs+j][offs+j]);
ajj=-a[offs+j][offs+j];
}
else
ajj=-1;
//--- Compute elements 1:j-1 of j-th column.
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
tmp[i_]=a[i_+i1_][offs+j];
for(i=0;i<j;i++)
{
//--- check
if(i<j-1)
{
i1_=(i+1)-(offs+i+1);
v=0.0;
for(i_=offs+i+1;i_<=offs+j-1;i_++)
v+=a[offs+i][i_]*tmp[i_+i1_];
}
else
v=0;
//--- check
if(!isunit)
a[offs+i].Set(offs+j,v+a[offs+i][offs+i]*tmp[i]);
else
a[offs+i].Set(offs+j,v+tmp[i]);
}
for(i_=offs+0;i_<=offs+j-1;i_++)
a[i_].Set(offs+j,ajj*a[i_][offs+j]);
}
}
}
else
{
//--- Compute inverse of lower triangular matrix.
for(j=n-1;j>=0;j--)
{
//--- check
if(!isunit)
{
//--- check
if(a[offs+j][offs+j]==0.0)
{
info=-3;
//--- exit the function
return;
}
a[offs+j].Set(offs+j,1/a[offs+j][offs+j]);
ajj=-a[offs+j][offs+j];
}
else
ajj=-1;
//--- check
if(j<n-1)
{
//--- Compute elements j+1:n of j-th column.
i1_=offs;
for(i_=j+1;i_<n;i_++)
tmp[i_]=a[i_+i1_][offs+j];
for(i=j+1;i<n;i++)
{
//--- check
if(i>j+1)
{
i1_=-offs;
v=0.0;
for(i_=offs+j+1;i_<offs+i;i_++)
v+=a[offs+i][i_]*tmp[i_+i1_];
}
else
v=0;
//--- check
if(!isunit)
a[offs+i].Set(offs+j,v+a[offs+i][offs+i]*tmp[i]);
else
a[offs+i].Set(offs+j,v+tmp[i]);
}
for(i_=offs+j+1;i_<=offs+n-1;i_++)
a[i_].Set(offs+j,ajj*a[i_][offs+j]);
}
}
}
//--- exit the function
return;
}
//--- Recursive case
CAblas::AblasSplitLength(a,n,n1,n2);
//--- check
if(n2>0)
{
//--- check
if(isupper)
{
for(i=0;i<n1;i++)
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,-1*a[offs+i][i_]);
//--- function call
CAblas::RMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,isunit,0,a,offs,offs+n1);
//--- function call
CAblas::RMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,isunit,0,a,offs,offs+n1);
}
else
{
for(i=0;i<n2;i++)
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,-1*a[offs+n1+i][i_]);
//--- function call
CAblas::RMatrixRightTrsM(n2,n1,a,offs,offs,isupper,isunit,0,a,offs+n1,offs);
//--- function call
CAblas::RMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,isunit,0,a,offs+n1,offs);
}
//--- function call
RMatrixTrInverseRec(a,offs+n1,n2,isupper,isunit,tmp,info,rep);
}
//--- function call
RMatrixTrInverseRec(a,offs,n1,isupper,isunit,tmp,info,rep);
}
//+------------------------------------------------------------------+
//| Triangular matrix inversion, recursive subroutine |
//+------------------------------------------------------------------+
static void CMatInv::CMatrixTrInverseRec(CMatrixComplex &a,const int offs,
const int n,const bool isupper,
const bool isunit,complex &tmp[],
int &info,CMatInvReport &rep)
{
//--- create variables
complex One=1.0;
complex _One=-1.0;
int n1=0;
int n2=0;
int i=0;
int j=0;
complex v=0;
complex ajj=0;
int i_=0;
int i1_=0;
//--- check
if(n<1)
{
info=-1;
//--- exit the function
return;
}
//--- base case
if(n<=CAblas::AblasComplexBlockSize())
{
//--- check
if(isupper)
{
//--- Compute inverse of upper triangular matrix.
for(j=0;j<n;j++)
{
//--- check
if(!isunit)
{
//--- check
if(a[offs+j][offs+j]==0)
{
info=-3;
//--- exit the function
return;
}
a[offs+j].Set(offs+j,One/a[offs+j][offs+j]);
ajj=-a[offs+j][offs+j];
}
else
ajj=-1;
//--- Compute elements 1:j-1 of j-th column.
if(j>0)
{
i1_=offs;
for(i_=0;i_<j;i_++)
tmp[i_]=a[i_+i1_][offs+j];
for(i=0;i<j;i++)
{
//--- check
if(i<j-1)
{
i1_=(i+1)-(offs+i+1);
v=0.0;
for(i_=offs+i+1;i_<=offs+j-1;i_++)
v+=a[offs+i][i_]*tmp[i_+i1_];
}
else
v=0;
//--- check
if(!isunit)
a[offs+i].Set(offs+j,v+a[offs+i][offs+i]*tmp[i]);
else
a[offs+i].Set(offs+j,v+tmp[i]);
}
for(i_=offs+0;i_<=offs+j-1;i_++)
a[i_].Set(offs+j,ajj*a[i_][offs+j]);
}
}
}
else
{
//--- Compute inverse of lower triangular matrix.
for(j=n-1;j>=0;j--)
{
//--- check
if(!isunit)
{
//--- check
if(a[offs+j][offs+j]==0)
{
info=-3;
//--- exit the function
return;
}
a[offs+j].Set(offs+j,One/a[offs+j][offs+j]);
ajj=-a[offs+j][offs+j];
}
else
ajj=-1;
//--- check
if(j<n-1)
{
//--- Compute elements j+1:n of j-th column.
i1_=offs;
for(i_=j+1;i_<n;i_++)
tmp[i_]=a[i_+i1_][offs+j];
for(i=j+1;i<n;i++)
{
//--- check
if(i>j+1)
{
i1_=-offs;
v=0.0;
for(i_=offs+j+1;i_<offs+i;i_++)
v+=a[offs+i][i_]*tmp[i_+i1_];
}
else
v=0;
//--- check
if(!isunit)
a[offs+i].Set(offs+j,v+a[offs+i][offs+i]*tmp[i]);
else
a[offs+i].Set(offs+j,v+tmp[i]);
}
for(i_=offs+j+1;i_<=offs+n-1;i_++)
a[i_].Set(offs+j,ajj*a[i_][offs+j]);
}
}
}
//--- exit the function
return;
}
//--- Recursive case
CAblas::AblasComplexSplitLength(a,n,n1,n2);
//--- check
if(n2>0)
{
//--- check
if(isupper)
{
for(i=0;i<n1;i++)
{
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,_One*a[offs+i][i_]);
}
//--- function call
CAblas::CMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,isunit,0,a,offs,offs+n1);
//--- function call
CAblas::CMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,isunit,0,a,offs,offs+n1);
}
else
{
for(i=0;i<n2;i++)
{
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,_One*a[offs+n1+i][i_]);
}
//--- function call
CAblas::CMatrixRightTrsM(n2,n1,a,offs,offs,isupper,isunit,0,a,offs+n1,offs);
//--- function call
CAblas::CMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,isunit,0,a,offs+n1,offs);
}
//--- function call
CMatrixTrInverseRec(a,offs+n1,n2,isupper,isunit,tmp,info,rep);
}
//--- function call
CMatrixTrInverseRec(a,offs,n1,isupper,isunit,tmp,info,rep);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CMatInv::RMatrixLUInverseRec(CMatrixDouble &a,const int offs,
const int n,double &work[],
int &info,CMatInvReport &rep)
{
//--- create variables
int i=0;
int j=0;
double v=0;
int n1=0;
int n2=0;
int i_=0;
int i1_=0;
//--- check
if(n<1)
{
info=-1;
//--- exit the function
return;
}
//--- base case
if(n<=CAblas::AblasBlockSize())
{
//--- Form inv(U)
RMatrixTrInverseRec(a,offs,n,true,false,work,info,rep);
//--- check
if(info<=0)
return;
//--- Solve the equation inv(A)*L = inv(U) for inv(A).
for(j=n-1;j>=0;j--)
{
//--- Copy current column of L to WORK and replace with zeros.
for(i=j+1;i<n;i++)
{
work[i]=a[offs+i][offs+j];
a[offs+i].Set(offs+j,0);
}
//--- Compute current column of inv(A).
if(j<n-1)
{
for(i=0;i<n;i++)
{
i1_=-offs;
v=0.0;
for(i_=offs+j+1;i_<=offs+n-1;i_++)
v+=a[offs+i][i_]*work[i_+i1_];
a[offs+i].Set(offs+j,a[offs+i][offs+j]-v);
}
}
}
//--- exit the function
return;
}
//--- Recursive code:
//--- ( L1 ) ( U1 U12 )
//--- A = ( ) * ( )
//--- ( L12 L2 ) ( U2 )
//--- ( W X )
//--- A^-1 = ( )
//--- ( Y Z )
CAblas::AblasSplitLength(a,n,n1,n2);
//--- check
if(!CAp::Assert(n2>0,__FUNCTION__+": internal error!"))
return;
//--- X :=inv(U1)*U12*inv(U2)
CAblas::RMatrixLeftTrsM(n1,n2,a,offs,offs,true,false,0,a,offs,offs+n1);
CAblas::RMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,true,false,0,a,offs,offs+n1);
//--- Y :=inv(L2)*L12*inv(L1)
CAblas::RMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,false,true,0,a,offs+n1,offs);
CAblas::RMatrixRightTrsM(n2,n1,a,offs,offs,false,true,0,a,offs+n1,offs);
//--- W :=inv(L1*U1)+X*Y
RMatrixLUInverseRec(a,offs,n1,work,info,rep);
//--- check
if(info<=0)
return;
//--- function call
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);
for(i=0;i<n1;i++)
{
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,-1*a[offs+i][i_]);
}
CAblas::RMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,true,false,0,a,offs+n1,offs);
for(i=0;i<n2;i++)
{
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,-1*a[offs+n1+i][i_]);
}
//--- Z :=inv(L2*U2)
RMatrixLUInverseRec(a,offs+n1,n2,work,info,rep);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CMatInv::CMatrixLUInverseRec(CMatrixComplex &a,const int offs,
const int n,complex &work[],
int &info,CMatInvReport &rep)
{
//--- create variables
complex One=1.0;
complex _One=-1.0;
int i=0;
int j=0;
complex v=0;
int n1=0;
int n2=0;
int i_=0;
int i1_=0;
//--- check
if(n<1)
{
info=-1;
//--- exit the function
return;
}
//--- base case
if(n<=CAblas::AblasComplexBlockSize())
{
//--- Form inv(U)
CMatrixTrInverseRec(a,offs,n,true,false,work,info,rep);
//--- check
if(info<=0)
return;
//--- Solve the equation inv(A)*L = inv(U) for inv(A).
for(j=n-1;j>=0;j--)
{
//--- Copy current column of L to WORK and replace with zeros.
for(i=j+1;i<n;i++)
{
work[i]=a[offs+i][offs+j];
a[offs+i].Set(offs+j,0);
}
//--- Compute current column of inv(A).
if(j<n-1)
{
for(i=0;i<n;i++)
{
i1_=-offs;
v=0.0;
for(i_=offs+j+1;i_<=offs+n-1;i_++)
v+=a[offs+i][i_]*work[i_+i1_];
a[offs+i].Set(offs+j,a[offs+i][offs+j]-v);
}
}
}
//--- exit the function
return;
}
//--- Recursive code:
//--- ( L1 ) ( U1 U12 )
//--- A = ( ) * ( )
//--- ( L12 L2 ) ( U2 )
//--- ( W X )
//--- A^-1 = ( )
//--- ( Y Z )
CAblas::AblasComplexSplitLength(a,n,n1,n2);
//--- check
if(!CAp::Assert(n2>0,__FUNCTION__+": internal error!"))
return;
//--- X :=inv(U1)*U12*inv(U2)
CAblas::CMatrixLeftTrsM(n1,n2,a,offs,offs,true,false,0,a,offs,offs+n1);
CAblas::CMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,true,false,0,a,offs,offs+n1);
//--- Y :=inv(L2)*L12*inv(L1)
CAblas::CMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,false,true,0,a,offs+n1,offs);
CAblas::CMatrixRightTrsM(n2,n1,a,offs,offs,false,true,0,a,offs+n1,offs);
//--- W :=inv(L1*U1)+X*Y
CMatrixLUInverseRec(a,offs,n1,work,info,rep);
//--- check
if(info<=0)
return;
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);
for(i=0;i<n1;i++)
{
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,_One*a[offs+i][i_]);
}
CAblas::CMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,true,false,0,a,offs+n1,offs);
for(i=0;i<n2;i++)
{
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,_One*a[offs+n1+i][i_]);
}
//--- Z :=inv(L2*U2)
CMatrixLUInverseRec(a,offs+n1,n2,work,info,rep);
}
//+------------------------------------------------------------------+
//| Recursive subroutine for SPD inversion. | |
//+------------------------------------------------------------------+
static void CMatInv::SPDMatrixCholeskyInverseRec(CMatrixDouble &a,const int offs,
const int n,const bool isupper,
double &tmp[])
{
//--- create variables
int i=0;
int j=0;
double v=0;
int n1=0;
int n2=0;
int info2=0;
int i_=0;
int i1_=0;
//--- object of class
CMatInvReport rep2;
//--- check
if(n<1)
return;
//--- base case
if(n<=CAblas::AblasBlockSize())
{
RMatrixTrInverseRec(a,offs,n,isupper,false,tmp,info2,rep2);
//--- check
if(isupper)
{
//--- Compute the product U * U'.
//--- NOTE: we never assume that diagonal of U is real
for(i=0;i<n;i++)
{
//--- check
if(i==0)
{
//--- 1x1 matrix
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i]));
}
else
{
//--- (I+1)x(I+1) matrix,
//--- ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H )
//--- ( ) * ( ) = ( )
//--- ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H )
//--- A11 is IxI, A22 is 1x1.
i1_=offs;
for(i_=0;i_<=i-1;i_++)
tmp[i_]=a[i_+i1_][offs+i];
for(j=0;j<i;j++)
{
v=a[offs+j][offs+i];
i1_=-offs;
for(i_=offs+j;i_<offs+i;i_++)
a[offs+j].Set(i_,a[offs+j][i_]+v*tmp[i_+i1_]);
}
//--- change values
v=a[offs+i][offs+i];
for(i_=offs;i_<offs+i;i_++)
a[i_].Set(offs+i,v*a[i_][offs+i]);
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i]));
}
}
}
else
{
//--- Compute the product L' * L
//--- NOTE: we never assume that diagonal of L is reall
for(i=0;i<n;i++)
{
//--- check
if(i==0)
{
//--- 1x1 matrix
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i]));
}
else
{
//--- (I+1)x(I+1) matrix,
//--- ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 )
//--- ( ) * ( ) = ( )
//--- ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 )
//--- A11 is IxI, A22 is 1x1.
i1_=offs;
for(i_=0;i_<=i-1;i_++)
tmp[i_]=a[offs+i][i_+i1_];
for(j=0;j<i;j++)
{
v=a[offs+i][offs+j];
i1_=-offs;
for(i_=offs;i_<=offs+j;i_++)
a[offs+j].Set(i_,a[offs+j][i_]+v*tmp[i_+i1_]);
}
//--- change values
v=a[offs+i][offs+i];
for(i_=offs;i_<offs+i;i_++)
a[offs+i].Set(i_,v*a[offs+i][i_]);
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i]));
}
}
}
//--- exit the function
return;
}
//--- Recursive code: triangular factor inversion merged with
//--- UU' or L'L multiplication
CAblas::AblasSplitLength(a,n,n1,n2);
//--- form off-diagonal block of trangular inverse
if(isupper)
{
for(i=0;i<n1;i++)
{
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,-1*a[offs+i][i_]);
}
//--- function call
CAblas::RMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,false,0,a,offs,offs+n1);
//--- function call
CAblas::RMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,false,0,a,offs,offs+n1);
}
else
{
for(i=0;i<n2;i++)
{
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,-1*a[offs+n1+i][i_]);
}
//--- function call
CAblas::RMatrixRightTrsM(n2,n1,a,offs,offs,isupper,false,0,a,offs+n1,offs);
//--- function call
CAblas::RMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,false,0,a,offs+n1,offs);
}
//--- invert first diagonal block
SPDMatrixCholeskyInverseRec(a,offs,n1,isupper,tmp);
//--- update first diagonal block with off-diagonal block,
//--- update off-diagonal block
if(isupper)
{
//--- function call
CAblas::RMatrixSyrk(n1,n2,1.0,a,offs,offs+n1,0,1.0,a,offs,offs,isupper);
//--- function call
CAblas::RMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,false,1,a,offs,offs+n1);
}
else
{
//--- function call
CAblas::RMatrixSyrk(n1,n2,1.0,a,offs+n1,offs,1,1.0,a,offs,offs,isupper);
//--- function call
CAblas::RMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,false,1,a,offs+n1,offs);
}
//--- invert second diagonal block
SPDMatrixCholeskyInverseRec(a,offs+n1,n2,isupper,tmp);
}
//+------------------------------------------------------------------+
//| Recursive subroutine for HPD inversion. |
//+------------------------------------------------------------------+
static void CMatInv::HPDMatrixCholeskyInverseRec(CMatrixComplex &a,const int offs,
const int n,const bool isupper,
complex &tmp[])
{
//--- create variables
complex _One=-1.0;
int i=0;
int j=0;
complex v=0;
int n1=0;
int n2=0;
int info2=0;
int i_=0;
int i1_=0;
//--- object of class
CMatInvReport rep2;
//--- check
if(n<1)
return;
//--- base case
if(n<=CAblas::AblasComplexBlockSize())
{
CMatrixTrInverseRec(a,offs,n,isupper,false,tmp,info2,rep2);
//--- check
if(isupper)
{
//--- Compute the product U * U'.
//--- NOTE: we never assume that diagonal of U is real
for(i=0;i<n;i++)
{
//--- check
if(i==0)
{
//--- 1x1 matrix
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i].re)+CMath::Sqr(a[offs+i][offs+i].im));
}
else
{
//--- (I+1)x(I+1) matrix,
//--- ( A11 A12 ) ( A11^H ) ( A11*A11^H+A12*A12^H A12*A22^H )
//--- ( ) * ( ) = ( )
//--- ( A22 ) ( A12^H A22^H ) ( A22*A12^H A22*A22^H )
//--- A11 is IxI, A22 is 1x1.
i1_=offs;
for(i_=0;i_<=i-1;i_++)
tmp[i_]=CMath::Conj(a[i_+i1_][offs+i]);
for(j=0;j<i;j++)
{
v=a[offs+j][offs+i];
i1_=-offs;
for(i_=offs+j;i_<offs+i;i_++)
a[offs+j].Set(i_,a[offs+j][i_]+v*tmp[i_+i1_]);
}
//--- change values
v=CMath::Conj(a[offs+i][offs+i]);
for(i_=offs;i_<offs+i;i_++)
a[i_].Set(offs+i,v*a[i_][offs+i]);
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i].re)+CMath::Sqr(a[offs+i][offs+i].im));
}
}
}
else
{
//--- Compute the product L' * L
//--- NOTE: we never assume that diagonal of L is reall
for(i=0;i<n;i++)
{
//--- check
if(i==0)
{
//--- 1x1 matrix
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i].re)+CMath::Sqr(a[offs+i][offs+i].im));
}
else
{
//--- (I+1)x(I+1) matrix,
//--- ( A11^H A21^H ) ( A11 ) ( A11^H*A11+A21^H*A21 A21^H*A22 )
//--- ( ) * ( ) = ( )
//--- ( A22^H ) ( A21 A22 ) ( A22^H*A21 A22^H*A22 )
//--- A11 is IxI, A22 is 1x1.
i1_=offs;
for(i_=0;i_<=i-1;i_++)
tmp[i_]=a[offs+i][i_+i1_];
for(j=0;j<i;j++)
{
v=CMath::Conj(a[offs+i][offs+j]);
i1_=-offs;
for(i_=offs;i_<=offs+j;i_++)
a[offs+j].Set(i_,a[offs+j][i_]+v*tmp[i_+i1_]);
}
v=CMath::Conj(a[offs+i][offs+i]);
for(i_=offs;i_<offs+i;i_++)
a[offs+i].Set(i_,v*a[offs+i][i_]);
a[offs+i].Set(offs+i,CMath::Sqr(a[offs+i][offs+i].re)+CMath::Sqr(a[offs+i][offs+i].im));
}
}
}
//--- exit the function
return;
}
//--- Recursive code: triangular factor inversion merged with
//--- UU' or L'L multiplication
CAblas::AblasComplexSplitLength(a,n,n1,n2);
//--- form off-diagonal block of trangular inverse
if(isupper)
{
for(i=0;i<n1;i++)
{
for(i_=offs+n1;i_<=offs+n-1;i_++)
a[offs+i].Set(i_,_One*a[offs+i][i_]);
}
//--- function call
CAblas::CMatrixLeftTrsM(n1,n2,a,offs,offs,isupper,false,0,a,offs,offs+n1);
//--- function call
CAblas::CMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,false,0,a,offs,offs+n1);
}
else
{
for(i=0;i<n2;i++)
{
for(i_=offs;i_<=offs+n1-1;i_++)
a[offs+n1+i].Set(i_,_One*a[offs+n1+i][i_]);
}
//--- function call
CAblas::CMatrixRightTrsM(n2,n1,a,offs,offs,isupper,false,0,a,offs+n1,offs);
//--- function call
CAblas::CMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,false,0,a,offs+n1,offs);
}
//--- invert first diagonal block
HPDMatrixCholeskyInverseRec(a,offs,n1,isupper,tmp);
//--- update first diagonal block with off-diagonal block,
//--- update off-diagonal block
if(isupper)
{
//--- function call
CAblas::CMatrixSyrk(n1,n2,1.0,a,offs,offs+n1,0,1.0,a,offs,offs,isupper);
//--- function call
CAblas::CMatrixRightTrsM(n1,n2,a,offs+n1,offs+n1,isupper,false,2,a,offs,offs+n1);
}
else
{
//--- function call
CAblas::CMatrixSyrk(n1,n2,1.0,a,offs+n1,offs,2,1.0,a,offs,offs,isupper);
//--- function call
CAblas::CMatrixLeftTrsM(n2,n1,a,offs+n1,offs+n1,isupper,false,2,a,offs+n1,offs);
}
//--- invert second diagonal block
HPDMatrixCholeskyInverseRec(a,offs+n1,n2,isupper,tmp);
}
//+------------------------------------------------------------------+
//| Singular value decomposition of a bidiagonal matrix |
//+------------------------------------------------------------------+
class CBdSingValueDecompose
{
private:
//--- private methods
static bool BidiagonalSVDDecompositionInternal(double &d[],double &ce[],const int n,const bool isupper,const bool isfractionalaccuracyrequired,CMatrixDouble &u,const int ustart,const int nru,CMatrixDouble &c,const int cstart,const int ncc,CMatrixDouble &vt,const int vstart,const int ncvt);
static double ExtSignBdSQR(const double a,const double b);
static void SVD2x2(const double f,const double g,const double h,double &ssmin,double &ssmax);
static void SVDV2x2(const double f,const double g,const double h,double &ssmin,double &ssmax,double &snr,double &csr,double &snl,double &csl);
public:
CBdSingValueDecompose(void);
~CBdSingValueDecompose(void);
//--- public methods
static bool RMatrixBdSVD(double &d[],double &ce[],const int n,const bool isupper,const bool isfractionalaccuracyrequired,CMatrixDouble &u,const int nru,CMatrixDouble &c,const int ncc,CMatrixDouble &vt,const int ncvt);
static bool BidiagonalSVDDecomposition(double &d[],double &ce[],const int n,const bool isupper,const bool isfractionalaccuracyrequired,CMatrixDouble &u,const int nru,CMatrixDouble &c,const int ncc,CMatrixDouble &vt,const int ncvt);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CBdSingValueDecompose::CBdSingValueDecompose(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CBdSingValueDecompose::~CBdSingValueDecompose(void)
{
}
//+------------------------------------------------------------------+
//| Singular value decomposition of a bidiagonal matrix (extended |
//| algorithm) |
//| The algorithm performs the singular value decomposition of a |
//| bidiagonal matrix B (upper or lower) representing it as |
//| B = Q*S*P^T, where Q and P - orthogonal matrices, S - diagonal |
//| matrix with non-negative elements on the main diagonal, in |
//| descending order. |
//| The algorithm finds singular values. In addition, the algorithm |
//| can calculate matrices Q and P (more precisely, not the matrices,|
//| but their product with given matrices U and VT - U*Q and |
//| (P^T)*VT)). Of course, matrices U and VT can be of any type, |
//| including identity. Furthermore, the algorithm can calculate Q'*C|
//| (this product is calculated more effectively than U*Q, because |
//| this calculation operates with rows instead of matrix columns). |
//| The feature of the algorithm is its ability to find all singular |
//| values including those which are arbitrarily close to 0 with |
//| relative accuracy close to machine precision. If the parameter |
//| IsFractionalAccuracyRequired is set to True, all singular values |
//| will have high relative accuracy close to machine precision. If |
//| the parameter is set to False, only the biggest singular value |
//| will have relative accuracy close to machine precision. The |
//| absolute error of other singular values is equal to the absolute |
//| error of the biggest singular value. |
//| Input parameters: |
//| D - main diagonal of matrix B. |
//| Array whose index ranges within [0..N-1]. |
//| E - superdiagonal (or subdiagonal) of matrix B. |
//| Array whose index ranges within [0..N-2]. |
//| N - size of matrix B. |
//| IsUpper - True, if the matrix is upper bidiagonal. |
//| IsFractionalAccuracyRequired - |
//| accuracy to search singular values with. |
//| U - matrix to be multiplied by Q. |
//| Array whose indexes range within |
//| [0..NRU-1, 0..N-1]. |
//| The matrix can be bigger, in that case only the |
//| submatrix [0..NRU-1, 0..N-1] will be multiplied |
//| by Q. |
//| NRU - number of rows in matrix U. |
//| C - matrix to be multiplied by Q'. |
//| Array whose indexes range within |
//| [0..N-1, 0..NCC-1]. |
//| The matrix can be bigger, in that case only the |
//| submatrix [0..N-1, 0..NCC-1] will be multiplied |
//| by Q'. |
//| NCC - number of columns in matrix C. |
//| VT - matrix to be multiplied by P^T. |
//| Array whose indexes range within |
//| [0..N-1, 0..NCVT-1]. |
//| The matrix can be bigger, in that case only the |
//| submatrix [0..N-1, 0..NCVT-1] will be multiplied |
//| by P^T. |
//| NCVT - number of columns in matrix VT. |
//| Output parameters: |
//| D - singular values of matrix B in descending order. |
//| U - if NRU>0, 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. |
//+------------------------------------------------------------------+
static bool CBdSingValueDecompose::RMatrixBdSVD(double &d[],double &ce[],
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;
//--- create arrays
double d1[];
double e1[];
int i_=0;
int i1_=0;
//--- create copy
double e[];
ArrayCopy(e,ce);
//--- allocation
ArrayResizeAL(d1,n+1);
//--- change values
i1_=-1;
for(i_=1;i_<=n;i_++)
d1[i_]=d[i_+i1_];
//--- check
if(n>1)
{
//--- allocation
ArrayResizeAL(e1,n);
//--- change values
i1_=-1;
for(i_=1;i_<n;i_++)
e1[i_]=e[i_+i1_];
}
//--- get result
result=BidiagonalSVDDecompositionInternal(d1,e1,n,isupper,isfractionalaccuracyrequired,u,0,nru,c,0,ncc,vt,0,ncvt);
//--- change values
i1_=1;
for(i_=0;i_<n;i_++)
d[i_]=d1[i_+i1_];
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Singular value decomposition of a bidiagonal matrix |
//+------------------------------------------------------------------+
static bool CBdSingValueDecompose::BidiagonalSVDDecomposition(double &d[],double &ce[],
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 copy
double e[];
ArrayCopy(e,ce);
//--- return result
return(BidiagonalSVDDecompositionInternal(d,e,n,isupper,isfractionalaccuracyrequired,u,1,nru,c,1,ncc,vt,1,ncvt));
}
//+------------------------------------------------------------------+
//| Internal working subroutine for bidiagonal decomposition |
//+------------------------------------------------------------------+
static bool CBdSingValueDecompose::BidiagonalSVDDecompositionInternal(double &d[],double &ce[],
const int n,const bool isupper,
const bool isfractionalaccuracyrequired,
CMatrixDouble &u,const int ustart,
const int nru,CMatrixDouble &c,
const int cstart,const int ncc,
CMatrixDouble &vt,const int vstart,
const int ncvt)
{
//--- create variables
bool result;
int i=0;
int idir=0;
int isub=0;
int iter=0;
int j=0;
int ll=0;
int lll=0;
int m=0;
int maxit=0;
int oldll=0;
int oldm=0;
double abse=0;
double abss=0;
double cosl=0;
double cosr=0;
double cs=0;
double eps=0;
double f=0;
double g=0;
double h=0;
double mu=0;
double oldcs=0;
double oldsn=0;
double r=0;
double shift=0;
double sigmn=0;
double sigmx=0;
double sinl=0;
double sinr=0;
double sll=0;
double smax=0;
double smin=0;
double sminl=0;
double sminlo=0;
double sminoa=0;
double sn=0;
double thresh=0;
double tol=0;
double tolmul=0;
double unfl=0;
int maxitr=0;
bool matrixsplitflag;
bool iterflag;
bool rightside;
bool fwddir;
double tmp=0;
int mm1=0;
int mm0=0;
bool bchangedir;
int uend=0;
int cend=0;
int vend=0;
int i_=0;
//--- create arrays
double work0[];
double work1[];
double work2[];
double work3[];
double utemp[];
double vttemp[];
double ctemp[];
double etemp[];
//--- create copy
double e[];
ArrayCopy(e,ce);
//--- initialization
result=true;
//--- check
if(n==0)
return(true);
//--- check
if(n==1)
{
//--- check
if(d[1]<0.0)
{
d[1]=-d[1];
//--- check
if(ncvt>0)
for(i_=vstart;i_<=vstart+ncvt-1;i_++)
vt[vstart].Set(i_,-1*vt[vstart][i_]);
}
//--- return result
return(result);
}
//--- initialization
ll=0;
oldsn=0;
//--- allocation
ArrayResizeAL(work0,n);
ArrayResizeAL(work1,n);
ArrayResizeAL(work2,n);
ArrayResizeAL(work3,n);
uend=ustart+(int)MathMax(nru-1,0);
vend=vstart+(int)MathMax(ncvt-1,0);
cend=cstart+(int)MathMax(ncc-1,0);
ArrayResizeAL(utemp,uend+1);
ArrayResizeAL(vttemp,vend+1);
ArrayResizeAL(ctemp,cend+1);
//--- initialization
maxitr=12;
rightside=true;
fwddir=true;
//--- resize E from N-1 to N
ArrayResizeAL(etemp,n+1);
for(i=1;i<n;i++)
etemp[i]=e[i];
ArrayResizeAL(e,n+1);
for(i=1;i<n;i++)
e[i]=etemp[i];
e[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;i<n;i++)
{
//--- function call
CRotations::GenerateRotation(d[i],e[i],cs,sn,r);
d[i]=r;
e[i]=sn*d[i+1];
d[i+1]=cs*d[i+1];
work0[i]=cs;
work1[i]=sn;
}
//--- Update singular vectors if desired
if(nru>0)
{
//--- 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,1+cstart-1,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;
//--- Compute approximate maximum, minimum singular values
smax=0;
for(i=1;i<=n;i++)
smax=MathMax(smax,MathAbs(d[i]));
for(i=1;i<n;i++)
smax=MathMax(smax,MathAbs(e[i]));
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=sminoa/MathSqrt(n);
thresh=MathMax(tol*sminoa,maxitr*n*n*unfl);
}
else
{
//--- Absolute accuracy desired
thresh=MathMax(MathAbs(tol)*smax,maxitr*n*n*unfl);
}
//--- Prepare for main iteration loop for the singular values
//--- (MAXIT is the maximum number of passes through the inner
//--- loop permitted before nonconvergence signalled.)
maxit=maxitr*n*n;
iter=0;
oldll=-1;
oldm=-1;
//--- M points to last element of unconverged part of matrix
m=n;
//--- Begin main iteration loop
while(true)
{
//--- Check for convergence or exceeding iteration count
if(m<=1)
break;
//--- check
if(iter>maxit)
return(false);
//--- Find diagonal block of matrix to work on
if(tol<0.0 && MathAbs(d[m])<=thresh)
d[m]=0;
//--- change values
smax=MathAbs(d[m]);
smin=smax;
matrixsplitflag=false;
for(lll=1;lll<=m-1;lll++)
{
ll=m-lll;
abss=MathAbs(d[ll]);
abse=MathAbs(e[ll]);
//--- check
if(tol<0.0 && abss<=thresh)
d[ll]=0;
//--- check
if(abse<=thresh)
{
matrixsplitflag=true;
break;
}
//--- change values
smin=MathMin(smin,abss);
smax=MathMax(smax,MathMax(abss,abse));
}
//--- check
if(!matrixsplitflag)
ll=0;
else
{
//--- Matrix splits since E(LL) = 0
e[ll]=0;
//--- check
if(ll==m-1)
{
//--- Convergence of bottom singular value, return to top of loop
m=m-1;
continue;
}
}
ll=ll+1;
//--- E(LL) through E(M-1) are nonzero, E(LL-1) is zero
if(ll==m-1)
{
//--- 2 by 2 block, handle separately
SVDV2x2(d[m-1],e[m-1],d[m],sigmn,sigmx,sinr,cosr,sinl,cosl);
d[m-1]=sigmx;
e[m-1]=0;
d[m]=sigmn;
//--- Compute singular vectors, if desired
if(ncvt>0)
{
mm0=m+(vstart-1);
mm1=m-1+(vstart-1);
//--- swap
for(i_=vstart;i_<=vend;i_++)
vttemp[i_]=cosr*vt[mm1][i_];
for(i_=vstart;i_<=vend;i_++)
vttemp[i_]=vttemp[i_]+sinr*vt[mm0][i_];
for(i_=vstart;i_<=vend;i_++)
vt[mm0].Set(i_,cosr*vt[mm0][i_]);
for(i_=vstart;i_<=vend;i_++)
vt[mm0].Set(i_,vt[mm0][i_]-sinr*vt[mm1][i_]);
for(i_=vstart;i_<=vend;i_++)
vt[mm1].Set(i_,vttemp[i_]);
}
//--- check
if(nru>0)
{
mm0=m+ustart-1;
mm1=m-1+ustart-1;
//--- swap
for(i_=ustart;i_<=uend;i_++)
utemp[i_]=cosl*u[i_][mm1];
for(i_=ustart;i_<=uend;i_++)
utemp[i_]=utemp[i_]+sinl*u[i_][mm0];
for(i_=ustart;i_<=uend;i_++)
u[i_].Set(mm0,cosl*u[i_][mm0]);
for(i_=ustart;i_<=uend;i_++)
u[i_].Set(mm0,u[i_][mm0]-sinl*u[i_][mm1]);
for(i_=ustart;i_<=uend;i_++)
u[i_].Set(mm1,utemp[i_]);
}
//--- check
if(ncc>0)
{
mm0=m+cstart-1;
mm1=m-1+cstart-1;
//--- swap
for(i_=cstart;i_<=cend;i_++)
ctemp[i_]=cosl*c[mm1][i_];
for(i_=cstart;i_<=cend;i_++)
ctemp[i_]=ctemp[i_]+sinl*c[mm0][i_];
for(i_=cstart;i_<=cend;i_++)
c[mm0].Set(i_,cosl*c[mm0][i_]);
for(i_=cstart;i_<=cend;i_++)
c[mm0].Set(i_,c[mm0][i_]-sinl*c[mm1][i_]);
for(i_=cstart;i_<=cend;i_++)
c[mm1].Set(i_,ctemp[i_]);
}
m=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<OLDLL) then"
//--- fixed thanks to Michael Rolle < m@rolle.name >
//--- 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[m-1]=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<=m-1;lll++)
{
//--- check
if(MathAbs(e[lll])<=tol*mu)
{
e[lll]=0;
iterflag=true;
//--- break the cycle
break;
}
//--- change values
sminlo=sminl;
mu=MathAbs(d[lll+1])*(mu/(mu+MathAbs(e[lll])));
sminl=MathMin(sminl,mu);
}
//--- check
if(iterflag)
continue;
}
}
else
{
//--- Run convergence test in backward direction
//--- First apply standard test to top of matrix
if(MathAbs(e[ll])<=MathAbs(tol)*MathAbs(d[ll]) || (tol<0.0 && MathAbs(e[ll])<=thresh))
{
e[ll]=0;
continue;
}
//--- check
if(tol>=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[lll]=0;
iterflag=true;
//--- break the cycle
break;
}
sminlo=sminl;
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)<eps)
shift=0;
}
}
//--- Increment iteration count
iter=iter+m-ll;
//--- If SHIFT = 0, do simplified QR iteration
if(shift==0.0)
{
//--- check
if(idir==1)
{
//--- Chase bulge from top to bottom
//--- Save cosines and sines for later singular vector updates
cs=1;
oldcs=1;
for(i=ll;i<m;i++)
{
//--- function call
CRotations::GenerateRotation(d[i]*cs,e[i],cs,sn,r);
//--- check
if(i>ll)
e[i-1]=oldsn*r;
//--- function call
CRotations::GenerateRotation(oldcs*r,d[i+1]*sn,oldcs,oldsn,tmp);
//--- change values
d[i]=tmp;
work0[i-ll+1]=cs;
work1[i-ll+1]=sn;
work2[i-ll+1]=oldcs;
work3[i-ll+1]=oldsn;
}
//--- change values
h=d[m]*cs;
d[m]=h*oldcs;
e[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[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+1;i--)
{
//--- function call
CRotations::GenerateRotation(d[i]*cs,e[i-1],cs,sn,r);
//--- check
if(i<m)
e[i]=oldsn*r;
//--- function call
CRotations::GenerateRotation(oldcs*r,d[i-1]*sn,oldcs,oldsn,tmp);
//--- change values
d[i]=tmp;
work0[i-ll]=cs;
work1[i-ll]=-sn;
work2[i-ll]=oldcs;
work3[i-ll]=-oldsn;
}
//--- change values
h=d[ll]*cs;
d[ll]=h*oldcs;
e[ll]=h*oldsn;
//--- Update singular vectors
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);
}
//--- Check for convergence
if(MathAbs(e[ll])<=thresh)
e[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;i<m;i++)
{
//--- function call
CRotations::GenerateRotation(f,g,cosr,sinr,r);
//--- check
if(i>ll)
e[i-1]=r;
//--- change values
f=cosr*d[i]+sinr*e[i];
e[i]=cosr*e[i]-sinr*d[i];
g=sinr*d[i+1];
d[i+1]=cosr*d[i+1];
//--- function call
CRotations::GenerateRotation(f,g,cosl,sinl,r);
//--- change values
d[i]=r;
f=cosl*e[i]+sinl*d[i+1];
d[i+1]=cosl*d[i+1]-sinl*e[i];
//--- check
if(i<m-1)
{
g=sinl*e[i+1];
e[i+1]=cosl*e[i+1];
}
//--- change values
work0[i-ll+1]=cosr;
work1[i-ll+1]=sinr;
work2[i-ll+1]=cosl;
work3[i-ll+1]=sinl;
}
e[m-1]=f;
//--- 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[m-1]=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+1;i--)
{
//--- function call
CRotations::GenerateRotation(f,g,cosr,sinr,r);
//--- check
if(i<m)
e[i]=r;
//--- change values
f=cosr*d[i]+sinr*e[i-1];
e[i-1]=cosr*e[i-1]-sinr*d[i];
g=sinr*d[i-1];
d[i-1]=cosr*d[i-1];
//--- function call
CRotations::GenerateRotation(f,g,cosl,sinl,r);
//--- change values
d[i]=r;
f=cosl*e[i-1]+sinl*d[i-1];
d[i-1]=cosl*d[i-1]-sinl*e[i-1];
//--- check
if(i>ll+1)
{
g=sinl*e[i-2];
e[i-2]=cosl*e[i-2];
}
//--- change values
work0[i-ll]=cosr;
work1[i-ll]=-sinr;
work2[i-ll]=cosl;
work3[i-ll]=-sinl;
}
e[ll]=f;
//--- Check for convergence
if(MathAbs(e[ll])<=thresh)
e[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[i]=-d[i];
//--- Change sign of singular vectors, if desired
if(ncvt>0)
{
for(i_=vstart;i_<=vend;i_++)
vt[i+vstart-1].Set(i_,-1*vt[i+vstart-1][i_]);
}
}
}
//--- Sort the singular values into decreasing order (insertion sort on
//--- singular values, but only one transposition per singular vector)
for(i=1;i<n;i++)
{
//--- Scan for smallest D(I)
isub=1;
smin=d[1];
for(j=2;j<=n+1-i;j++)
{
//--- check
if(d[j]<=smin)
{
isub=j;
smin=d[j];
}
}
//--- check
if(isub!=n+1-i)
{
//--- Swap singular values and vectors
d[isub]=d[n+1-i];
d[n+1-i]=smin;
//--- check
if(ncvt>0)
{
j=n+1-i;
//--- swap
for(i_=vstart;i_<=vend;i_++)
vttemp[i_]=vt[isub+vstart-1][i_];
for(i_=vstart;i_<=vend;i_++)
vt[isub+vstart-1].Set(i_,vt[j+vstart-1][i_]);
for(i_=vstart;i_<=vend;i_++)
vt[j+vstart-1].Set(i_,vttemp[i_]);
}
if(nru>0)
{
j=n+1-i;
//--- swap
for(i_=ustart;i_<=uend;i_++)
utemp[i_]=u[i_][isub+ustart-1];
for(i_=ustart;i_<=uend;i_++)
u[i_].Set(isub+ustart-1,u[i_][j+ustart-1]);
for(i_=ustart;i_<=uend;i_++)
u[i_].Set(j+ustart-1,utemp[i_]);
}
//--- check
if(ncc>0)
{
j=n+1-i;
//--- swap
for(i_=cstart;i_<=cend;i_++)
ctemp[i_]=c[isub+cstart-1][i_];
for(i_=cstart;i_<=cend;i_++)
c[isub+cstart-1].Set(i_,c[j+cstart-1][i_]);
for(i_=cstart;i_<=cend;i_++)
c[j+cstart-1].Set(i_,ctemp[i_]);
}
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static 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 |
//+------------------------------------------------------------------+
static 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=0;
double fhmn=0;
double fhmx=0;
double ga=0;
double ha=0;
//--- initialization
ssmin=0;
ssmax=0;
fa=MathAbs(f);
ga=MathAbs(g);
ha=MathAbs(h);
fhmn=MathMin(fa,ha);
fhmx=MathMax(fa,ha);
//--- 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(ga<fhmx)
{
//--- change values
aas=1+fhmn/fhmx;
at=(fhmx-fhmn)/fhmx;
au=CMath::Sqr(ga/fhmx);
c=2/(MathSqrt(aas*aas+au)+MathSqrt(at*at+au));
ssmin=fhmn*c;
ssmax=fhmx/c;
}
else
{
au=fhmx/ga;
//--- check
if(au==0.0)
{
//--- Avoid possible harmful underflow if exponent range
//--- asymmetric (true SSMIN may not underflow even if
//--- AU underflows)
ssmin=fhmn*fhmx/ga;
ssmax=ga;
}
else
{
//--- change values
aas=1+fhmn/fhmx;
at=(fhmx-fhmn)/fhmx;
c=1/(MathSqrt(1+CMath::Sqr(aas*au))+MathSqrt(1+CMath::Sqr(at*au)));
ssmin=fhmn*c*au;
ssmin=ssmin+ssmin;
ssmax=ga/(c+c);
}
}
}
}
//+------------------------------------------------------------------+
//| Internal subroutine |
//+------------------------------------------------------------------+
static void CBdSingValueDecompose::SVDV2x2(const double f,const double g,
const double h,double &ssmin,
double &ssmax,double &snr,
double &csr,double &snl,
double &csl)
{
//--- create variables
bool gasmal;
bool swp;
int pmax=0;
double a=0;
double clt=0;
double crt=0;
double d=0;
double fa=0;
double ft=0;
double ga=0;
double gt=0;
double ha=0;
double ht=0;
double l=0;
double m=0;
double mm=0;
double r=0;
double s=0;
double slt=0;
double srt=0;
double t=0;
double temp=0;
double tsign=0;
double tt=0;
double v=0;
//--- initialization
ssmin=0;
ssmax=0;
snr=0;
csr=0;
snl=0;
csl=0;
ft=f;
fa=MathAbs(ft);
ht=h;
ha=MathAbs(h);
clt=0;
crt=0;
slt=0;
srt=0;
tsign=0;
//--- PMAX points to the maximum absolute element of matrix
//--- PMAX = 1 if F largest in absolute values
//--- PMAX = 2 if G largest in absolute values
//--- PMAX = 3 if H largest in absolute values
pmax=1;
swp=ha>fa;
//--- 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/ga<CMath::m_machineepsilon)
{
//--- Case of very large GA
gasmal=false;
ssmax=ga;
//--- check
if(ha>1.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:
//--- constructor, destructor
CSingValueDecompose(void);
~CSingValueDecompose(void);
//--- method
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);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CSingValueDecompose::CSingValueDecompose(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CSingValueDecompose::~CSingValueDecompose(void)
{
}
//+------------------------------------------------------------------+
//| 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]. |
//+------------------------------------------------------------------+
static 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)
{
//--- create variables
bool result;
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
double tauq[];
double taup[];
double tau[];
double e[];
double work[];
//--- create matrix
CMatrixDouble t2;
//--- create copy
CMatrixDouble a;
a=ca;
//--- initialization
result=true;
//--- check
if(m==0 || n==0)
return(true);
//--- 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);
ArrayResizeAL(w,minmn+1);
ncu=0;
nru=0;
//--- check
if(uneeded==1)
{
nru=m;
ncu=minmn;
u.Resize(nru,ncu);
}
//--- check
if(uneeded==2)
{
nru=m;
ncu=m;
u.Resize(nru,ncu);
}
nrvt=0;
ncvt=0;
//--- 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<n;i++)
{
for(j=0;j<i;j++)
a[i].Set(j,0);
}
//--- function call
COrtFac::RMatrixBD(a,n,n,tauq,taup);
//--- function call
COrtFac::RMatrixBDUnpackPT(a,n,n,taup,nrvt,vt);
//--- function call
COrtFac::RMatrixBDUnpackDiagonals(a,n,n,isupper,w,e);
//--- return result
return(CBdSingValueDecompose::RMatrixBdSVD(w,e,n,isupper,false,u,0,a,0,vt,ncvt));
}
else
{
//--- Left singular vectors (may be full matrix U) to be computed
COrtFac::RMatrixQR(a,m,n,tau);
//--- function call
COrtFac::RMatrixQRUnpackQ(a,m,n,tau,ncu,u);
for(i=0;i<n;i++)
{
for(j=0;j<i;j++)
a[i].Set(j,0);
}
//--- function call
COrtFac::RMatrixBD(a,n,n,tauq,taup);
//--- function call
COrtFac::RMatrixBDUnpackPT(a,n,n,taup,nrvt,vt);
//--- function call
COrtFac::RMatrixBDUnpackDiagonals(a,n,n,isupper,w,e);
//--- check
if(additionalmemory<1)
{
//--- No additional memory can be used
COrtFac::RMatrixBDMultiplyByQ(a,n,n,tauq,u,m,n,true,false);
//--- get result
result=CBdSingValueDecompose::RMatrixBdSVD(w,e,n,isupper,false,u,m,a,0,vt,ncvt);
}
else
{
//--- Large U. Transforming intermediate matrix T2
ArrayResizeAL(work,MathMax(m,n)+1);
//--- function call
COrtFac::RMatrixBDUnpackQ(a,n,n,tauq,n,t2);
//--- function call
CBlas::CopyMatrix(u,0,m-1,0,n-1,a,0,m-1,0,n-1);
//--- function call
CBlas::InplaceTranspose(t2,0,n-1,0,n-1,work);
//--- get result
result=CBdSingValueDecompose::RMatrixBdSVD(w,e,n,isupper,false,u,0,t2,n,vt,ncvt);
//--- function call
CBlas::MatrixMatrixMultiply(a,0,m-1,0,n-1,false,t2,0,n-1,0,n-1,true,1.0,u,0,m-1,0,n-1,0.0,work);
}
//--- return result
return(result);
}
}
//--- N much larger than M
//--- Use bidiagonal reduction with LQ-decomposition
if((double)(n)>(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[i].Set(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);
ArrayResizeAL(work,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[i].Set(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);
ArrayResizeAL(work,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
CBlas::MatrixMatrixMultiply(t2,0,m-1,0,m-1,false,a,0,m-1,0,n-1,false,1.0,vt,0,m-1,0,n-1,0.0,work);
}
//--- 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);
ArrayResizeAL(work,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. |
//+------------------------------------------------------------------+
class CFblsLinCgState
{
public:
//--- variables
double m_e1;
double m_e2;
double m_x[];
double m_ax[];
double m_xax;
double m_xk[];
int m_n;
double m_rk[];
double m_rk1[];
double m_xk1[];
double m_pk[];
double m_pk1[];
double m_b[];
RCommState m_rstate;
double m_tmp2[];
//--- constructor, destructor
CFblsLinCgState(void);
~CFblsLinCgState(void);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CFblsLinCgState::CFblsLinCgState(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CFblsLinCgState::~CFblsLinCgState(void)
{
}
//+------------------------------------------------------------------+
//| Fast basic linear solutions |
//+------------------------------------------------------------------+
class CFbls
{
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);
public:
//--- constructor, destructor
CFbls(void);
~CFbls(void);
//--- methods
static void FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea,const int n,const bool isupper,double &xb[],double &tmp[]);
static void FblsSolveCGx(CMatrixDouble &a,const int m,const int n,const double alpha,const double &b[],double &x[],double &buf[]);
static void FblsCGCreate(double &x[],double &b[],const int n,CFblsLinCgState &state);
static bool FblsCGIteration(CFblsLinCgState &state);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CFbls::CFbls(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CFbls::~CFbls(void)
{
}
//+------------------------------------------------------------------+
//| 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 |
//+------------------------------------------------------------------+
static void CFbls::FblsCholeskySolve(CMatrixDouble &cha,const double sqrtscalea,
const int n,const bool isupper,double &xb[],
double &tmp[])
{
//--- create variables
int i=0;
double v=0;
int i_=0;
//--- check
if(CAp::Len(tmp)<n)
ArrayResizeAL(tmp,n);
//--- A = L*L' or A=U'*U
if(isupper)
{
//--- Solve U'*y=b first.
for(i=0;i<n;i++)
{
xb[i]=xb[i]/(sqrtscalea*cha[i][i]);
//--- check
if(i<n-1)
{
v=xb[i];
for(i_=i+1;i_<n;i_++)
tmp[i_]=sqrtscalea*cha[i][i_];
for(i_=i+1;i_<n;i_++)
xb[i_]=xb[i_]-v*tmp[i_];
}
}
//--- Solve U*x=y then.
for(i=n-1;i>=0;i--)
{
//--- check
if(i<n-1)
{
for(i_=i+1;i_<n;i_++)
tmp[i_]=sqrtscalea*cha[i][i_];
v=0.0;
for(i_=i+1;i_<n;i_++)
v+=tmp[i_]*xb[i_];
xb[i]=xb[i]-v;
}
xb[i]=xb[i]/(sqrtscalea*cha[i][i]);
}
}
else
{
//--- Solve L*y=b first
for(i=0;i<n;i++)
{
//--- check
if(i>0)
{
for(i_=0;i_<i;i_++)
tmp[i_]=sqrtscalea*cha[i][i_];
v=0.0;
for(i_=0;i_<i;i_++)
v+=tmp[i_]*xb[i_];
xb[i]=xb[i]-v;
}
xb[i]=xb[i]/(sqrtscalea*cha[i][i]);
}
//--- Solve L'*x=y then.
for(i=n-1;i>=0;i--)
{
xb[i]=xb[i]/(sqrtscalea*cha[i][i]);
//--- check
if(i>0)
{
v=xb[i];
for(i_=0;i_<i;i_++)
tmp[i_]=sqrtscalea*cha[i][i_];
for(i_=0;i_<i;i_++)
xb[i_]=xb[i_]-v*tmp[i_];
}
}
}
}
//+------------------------------------------------------------------+
//| 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)). |
//+------------------------------------------------------------------+
static void CFbls::FblsSolveCGx(CMatrixDouble &a,const int m,const int n,
const double alpha,const double &b[],
double &x[],double &buf[])
{
//--- create variables
int k=0;
int offsrk=0;
int offsrk1=0;
int offsxk=0;
int offsxk1=0;
int offspk=0;
int offspk1=0;
int offstmp1=0;
int offstmp2=0;
int bs=0;
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=0.0;
for(i_=0;i_<n;i_++)
v1+=b[i_]*b[i_];
//--- check
if(v1==0.0)
{
for(k=0;k<n;k++)
x[k]=0;
//--- 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]
offsrk=0;
offsrk1=offsrk+n;
offsxk=offsrk1+n;
offsxk1=offsxk+n;
offspk=offsxk1+n;
offspk1=offspk+n;
offstmp1=offspk1+n;
offstmp2=offstmp1+m;
bs=offstmp2+n;
//--- check
if(CAp::Len(buf)<bs)
ArrayResizeAL(buf,bs);
//--- x(0)=x
i1_=-offsxk;
for(i_=offsxk;i_<=offsxk+n-1;i_++)
buf[i_]=x[i_+i1_];
//--- r(0)=b-A*x(0)
//--- RK2=r(0)'*r(0)
CAblas::RMatrixMVect(m,n,a,0,0,0,buf,offsxk,buf,offstmp1);
//--- function call
CAblas::RMatrixMVect(n,m,a,0,0,1,buf,offstmp1,buf,offstmp2);
//--- change array
i1_=offsxk-offstmp2;
for(i_=offstmp2;i_<offstmp2+n;i_++)
buf[i_]=buf[i_]+alpha*buf[i_+i1_];
//--- change array
i1_=-offsrk;
for(i_=offsrk;i_<offsrk+n;i_++)
buf[i_]=b[i_+i1_];
//--- change array
i1_=offstmp2-offsrk;
for(i_=offsrk;i_<offsrk+n;i_++)
buf[i_]=buf[i_]-buf[i_+i1_];
rk2=0.0;
for(i_=offsrk;i_<offsrk+n;i_++)
rk2+=buf[i_]*buf[i_];
//--- change array
i1_=offsrk-offspk;
for(i_=offspk;i_<=offspk+n-1;i_++)
buf[i_]=buf[i_+i1_];
e1=MathSqrt(rk2);
//--- cycle
for(k=0;k<n;k++)
{
//--- Calculate A*p(k) - store in Buf[OffsTmp2:OffsTmp2+N-1]
//--- and p(k)'*A*p(k) - store in PAP
//--- If PAP=0, break (iteration is over)
CAblas::RMatrixMVect(m,n,a,0,0,0,buf,offspk,buf,offstmp1);
v1=0.0;
for(i_=offstmp1;i_<=offstmp1+m-1;i_++)
v1+=buf[i_]*buf[i_];
v2=0.0;
for(i_=offspk;i_<=offspk+n-1;i_++)
v2+=buf[i_]*buf[i_];
pap=v1+alpha*v2;
//--- function call
CAblas::RMatrixMVect(n,m,a,0,0,1,buf,offstmp1,buf,offstmp2);
i1_=offspk-offstmp2;
for(i_=offstmp2;i_<offstmp2+n;i_++)
buf[i_]=buf[i_]+alpha*buf[i_+i1_];
//--- check
if(pap==0.0)
break;
//--- S=(r(k)'*r(k))/(p(k)'*A*p(k))
s=rk2/pap;
//--- x(k+1)=x(k) + S*p(k)
i1_=offsxk-offsxk1;
for(i_=offsxk1;i_<=offsxk1+n-1;i_++)
buf[i_]=buf[i_+i1_];
i1_=offspk-offsxk1;
for(i_=offsxk1;i_<=offsxk1+n-1;i_++)
buf[i_]=buf[i_]+s*buf[i_+i1_];
//--- 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))
i1_=offsrk-offsrk1;
for(i_=offsrk1;i_<=offsrk1+n-1;i_++)
buf[i_]=buf[i_+i1_];
i1_=offstmp2-offsrk1;
for(i_=offsrk1;i_<=offsrk1+n-1;i_++)
buf[i_]=buf[i_]-s*buf[i_+i1_];
rk12=0.0;
for(i_=offsrk1;i_<=offsrk1+n-1;i_++)
rk12+=buf[i_]*buf[i_];
//--- check
if(MathSqrt(rk12)<=100*CMath::m_machineepsilon*MathSqrt(rk2))
{
//--- X(k) = x(k+1) before exit -
//--- - because we expect to find solution at x(k)
i1_=offsxk1-offsxk;
for(i_=offsxk;i_<=offsxk+n-1;i_++)
buf[i_]=buf[i_+i1_];
break;
}
//--- BetaK=RK12/RK2
//--- p(k+1)=r(k+1)+betak*p(k)
betak=rk12/rk2;
i1_=offsrk1-offspk1;
for(i_=offspk1;i_<=offspk1+n-1;i_++)
buf[i_]=buf[i_+i1_];
i1_=offspk-offspk1;
for(i_=offspk1;i_<=offspk1+n-1;i_++)
buf[i_]=buf[i_]+betak*buf[i_+i1_];
//--- r(k) :=r(k+1)
//--- x(k) :=x(k+1)
//--- p(k) :=p(k+1)
i1_=offsrk1-offsrk;
for(i_=offsrk;i_<offsrk+n;i_++)
buf[i_]=buf[i_+i1_];
i1_=offsxk1-offsxk;
for(i_=offsxk;i_<=offsxk+n-1;i_++)
buf[i_]=buf[i_+i1_];
i1_=offspk1-offspk;
for(i_=offspk;i_<=offspk+n-1;i_++)
buf[i_]=buf[i_+i1_];
rk2=rk12;
}
//--- Calculate E2
CAblas::RMatrixMVect(m,n,a,0,0,0,buf,offsxk,buf,offstmp1);
//--- function call
CAblas::RMatrixMVect(n,m,a,0,0,1,buf,offstmp1,buf,offstmp2);
i1_=offsxk-offstmp2;
for(i_=offstmp2;i_<offstmp2+n;i_++)
buf[i_]=buf[i_]+alpha*buf[i_+i1_];
i1_=-offsrk;
for(i_=offsrk;i_<offsrk+n;i_++)
buf[i_]=b[i_+i1_];
i1_=offstmp2-offsrk;
for(i_=offsrk;i_<offsrk+n;i_++)
buf[i_]=buf[i_]-buf[i_+i1_];
v1=0.0;
for(i_=offsrk;i_<offsrk+n;i_++)
v1+=buf[i_]*buf[i_];
e2=MathSqrt(v1);
//--- Output result (if it was improved)
if(e2<e1)
{
i1_=offsxk;
for(i_=0;i_<n;i_++)
x[i_]=buf[i_+i1_];
}
}
//+------------------------------------------------------------------+
//| Construction of linear conjugate gradient solver. |
//| State parameter passed using "var" semantics (i.e. previous state|
//| is NOT erased). When it is already initialized, we can reause |
//| prevously allocated memory. |
//| INPUT PARAMETERS: |
//| X - initial solution |
//| B - right part |
//| N - system size |
//| State - structure; may be preallocated, if we want to |
//| reuse memory |
//| OUTPUT PARAMETERS: |
//| State - structure which is used by FBLSCGIteration() to |
//| store algorithm state between subsequent calls. |
//| NOTE: no error checking is done; caller must check all |
//| parameters, prevent overflows, and so on. |
//+------------------------------------------------------------------+
static void CFbls::FblsCGCreate(double &x[],double &b[],const int n,CFblsLinCgState &state)
{
//--- create variables
int i_=0;
//--- check
if(CAp::Len(state.m_b)<n)
ArrayResizeAL(state.m_b,n);
//--- check
if(CAp::Len(state.m_rk)<n)
ArrayResizeAL(state.m_rk,n);
//--- check
if(CAp::Len(state.m_rk1)<n)
ArrayResizeAL(state.m_rk1,n);
//--- check
if(CAp::Len(state.m_xk)<n)
ArrayResizeAL(state.m_xk,n);
//--- check
if(CAp::Len(state.m_xk1)<n)
ArrayResizeAL(state.m_xk1,n);
//--- check
if(CAp::Len(state.m_pk)<n)
ArrayResizeAL(state.m_pk,n);
//--- check
if(CAp::Len(state.m_pk1)<n)
ArrayResizeAL(state.m_pk1,n);
//--- check
if(CAp::Len(state.m_tmp2)<n)
ArrayResizeAL(state.m_tmp2,n);
//--- check
if(CAp::Len(state.m_x)<n)
ArrayResizeAL(state.m_x,n);
//--- check
if(CAp::Len(state.m_ax)<n)
ArrayResizeAL(state.m_ax,n);
//--- check
state.m_n=n;
for(i_=0;i_<n;i_++)
state.m_xk[i_]=x[i_];
for(i_=0;i_<n;i_++)
state.m_b[i_]=b[i_];
//--- allocation
ArrayResizeAL(state.m_rstate.ia,2);
ArrayResizeAL(state.m_rstate.ra,7);
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. |
//+------------------------------------------------------------------+
static bool CFbls::FblsCGIteration(CFblsLinCgState &state)
{
//--- create variables
int n=0;
int k=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;
//--- 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)
{
//--- 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=-983;
k=-989;
rk2=-834;
rk12=900;
pap=-287;
s=364;
betak=214;
v1=-338;
v2=-686;
}
//--- check
if(state.m_rstate.stage==0)
{
//--- copy
for(i_=0;i_<n;i_++)
state.m_rk[i_]=state.m_b[i_];
//--- calculation
for(i_=0;i_<n;i_++)
state.m_rk[i_]=state.m_rk[i_]-state.m_ax[i_];
//--- change value
rk2=0.0;
for(i_=0;i_<n;i_++)
rk2+=state.m_rk[i_]*state.m_rk[i_];
//--- copy
for(i_=0;i_<n;i_++)
state.m_pk[i_]=state.m_rk[i_];
state.m_e1=MathSqrt(rk2);
//--- cycle
k=0;
//--- function call
return(Func_lbl_3(state,n,k,rk2,rk12,pap,s,betak,v1,v2));
}
//--- check
if(state.m_rstate.stage==1)
{
//--- copy
for(i_=0;i_<n;i_++)
state.m_tmp2[i_]=state.m_ax[i_];
pap=state.m_xax;
//--- check
if(!CMath::IsFinite(pap))
return(Func_lbl_5(state,n,k,rk2,rk12,pap,s,betak,v1,v2));
//--- check
if(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)
for(i_=0;i_<n;i_++)
state.m_xk1[i_]=state.m_xk[i_];
for(i_=0;i_<n;i_++)
state.m_xk1[i_]=state.m_xk1[i_]+s*state.m_pk[i_];
//--- 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))
for(i_=0;i_<n;i_++)
state.m_rk1[i_]=state.m_rk[i_];
for(i_=0;i_<n;i_++)
state.m_rk1[i_]=state.m_rk1[i_]-s*state.m_tmp2[i_];
rk12=0.0;
for(i_=0;i_<n;i_++)
rk12+=state.m_rk1[i_]*state.m_rk1[i_];
//--- 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)
for(i_=0;i_<n;i_++)
state.m_xk[i_]=state.m_xk1[i_];
//--- 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;
for(i_=0;i_<n;i_++)
state.m_pk1[i_]=state.m_rk1[i_];
for(i_=0;i_<n;i_++)
state.m_pk1[i_]=state.m_pk1[i_]+betak*state.m_pk[i_];
//--- r(k) :=r(k+1)
//--- x(k) :=x(k+1)
//--- p(k) :=p(k+1)
for(i_=0;i_<n;i_++)
state.m_rk[i_]=state.m_rk1[i_];
for(i_=0;i_<n;i_++)
state.m_xk[i_]=state.m_xk1[i_];
for(i_=0;i_<n;i_++)
state.m_pk[i_]=state.m_pk1[i_];
rk2=rk12;
k=k+1;
//--- function call
return(Func_lbl_3(state,n,k,rk2,rk12,pap,s,betak,v1,v2));
}
//--- check
if(state.m_rstate.stage==2)
{
//--- copy
for(i_=0;i_<n;i_++)
state.m_rk[i_]=state.m_b[i_];
//--- calculation
for(i_=0;i_<n;i_++)
state.m_rk[i_]=state.m_rk[i_]-state.m_ax[i_];
//--- change value
v1=0.0;
for(i_=0;i_<n;i_++)
v1+=state.m_rk[i_]*state.m_rk[i_];
state.m_e2=MathSqrt(v1);
//--- return result
return(false);
}
//--- Routine body
//--- prepare locals
n=state.m_n;
//--- Test for special case: B=0
v1=0.0;
for(i_=0;i_<n;i_++)
v1+=state.m_b[i_]*state.m_b[i_];
//--- check
if(v1==0.0)
{
for(k=0;k<n;k++)
state.m_xk[k]=0;
//--- return result
return(false);
}
//--- r(0)=b-A*x(0)
//--- RK2=r(0)'*r(0)
for(i_=0;i_<n;i_++)
state.m_x[i_]=state.m_xk[i_];
state.m_rstate.stage=0;
//--- 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. |
//+------------------------------------------------------------------+
static 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[0]=n;
state.m_rstate.ia[1]=k;
state.m_rstate.ra[0]=rk2;
state.m_rstate.ra[1]=rk12;
state.m_rstate.ra[2]=pap;
state.m_rstate.ra[3]=s;
state.m_rstate.ra[4]=betak;
state.m_rstate.ra[5]=v1;
state.m_rstate.ra[6]=v2;
}
//+------------------------------------------------------------------+
//| Auxiliary function for FblsCGiteration. Is a product to get rid |
//| of the operator unconditional jump goto. |
//+------------------------------------------------------------------+
static 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)
for(int i_=0;i_<n;i_++)
state.m_x[i_]=state.m_pk[i_];
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. |
//+------------------------------------------------------------------+
static 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
for(int i_=0;i_<n;i_++)
state.m_x[i_]=state.m_xk[i_];
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:
CMatDet(void);
~CMatDet(void);
//--- public methods
static double RMatrixLUDet(CMatrixDouble &a,int &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 CMatrixDet(CMatrixComplex &ca,const int n);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CMatDet::CMatDet(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CMatDet::~CMatDet(void)
{
}
//+------------------------------------------------------------------+
//| 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. |
//+------------------------------------------------------------------+
static double CMatDet::RMatrixLUDet(CMatrixDouble &a,int &pivots[],const int n)
{
//--- create variables
double result=0;
int i=0;
int s=0;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": Pivots array is too short!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CApServ::IsFiniteMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
//--- initialization
result=1;
s=1;
for(i=0;i<n;i++)
{
result=result*a[i][i];
//--- check
if(pivots[i]!=i)
s=-s;
}
//--- return result
return(result*s);
}
//+------------------------------------------------------------------+
//| Calculation of the determinant of a general matrix |
//| Input parameters: |
//| A - matrix, array[0..N-1, 0..N-1] |
//| 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: determinant of matrix A. |
//+------------------------------------------------------------------+
static double CMatDet::RMatrixDet(CMatrixDouble &ca,const int n)
{
//--- create variables
double result=0;
int pivots[];
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CApServ::IsFiniteMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
//--- function call
CTrFac::RMatrixLU(a,n,n,pivots);
//--- return result
return(RMatrixLUDet(a,pivots,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. |
//+------------------------------------------------------------------+
static complex CMatDet::CMatrixLUDet(CMatrixComplex &a,int &pivots[],const int n)
{
//--- create variables
complex result=0;
int i=0;
int s=0;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Len(pivots)>=n,__FUNCTION__+": Pivots array is too short!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CApServ::IsFiniteComplexMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
//--- initialization
result=1;
s=1;
for(i=0;i<n;i++)
{
result=result*a[i][i];
//--- check
if(pivots[i]!=i)
s=-s;
}
//--- return result
return(result*s);
}
//+------------------------------------------------------------------+
//| Calculation of the determinant of a general matrix |
//| Input parameters: |
//| A - matrix, array[0..N-1, 0..N-1] |
//| 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: determinant of matrix A. |
//+------------------------------------------------------------------+
static complex CMatDet::CMatrixDet(CMatrixComplex &ca,const int n)
{
//--- create variables
complex result=0;
int pivots[];
//--- create copy
CMatrixComplex a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CApServ::IsFiniteComplexMatrix(a,n,n),__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
//--- function call
CTrFac::CMatrixLU(a,n,n,pivots);
//--- return result
return(CMatrixLUDet(a,pivots,n));
}
//+------------------------------------------------------------------+
//| Determinant calculation of the matrix given by the Cholesky |
//| decomposition. |
//| Input parameters: |
//| A - Cholesky decomposition, |
//| output of SMatrixCholesky 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) |
//| As the determinant is equal to the product of squares of diagonal|
//| elements, it?s not necessary to specify which triangle - lower |
//| or upper - the matrix is stored in. |
//| Result: |
//| matrix determinant. |
//+------------------------------------------------------------------+
static double CMatDet::SPDMatrixCholeskyDet(CMatrixDouble &a,const int n)
{
//--- create variables
double result=0;
int i=0;
bool f;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- initialization
f=true;
for(i=0;i<n;i++)
f=f && CMath::IsFinite(a[i][i]);
//--- check
if(!CAp::Assert(f,__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
result=1;
for(i=0;i<n;i++)
result=result*CMath::Sqr(a[i][i]);
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Determinant calculation of the symmetric positive definite |
//| matrix. |
//| Input parameters: |
//| A - matrix. Array with elements [0..N-1, 0..N-1]. |
//| 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) |
//| IsUpper - (optional) storage type: |
//| * if True, symmetric matrix A is given by its |
//| upper triangle, and the lower triangle isn?t |
//| used/changed by function |
//| * if False, symmetric matrix A is given by its |
//| lower triangle, and the upper triangle isn?t |
//| used/changed by function |
//| * if not given, both lower and upper triangles |
//| must be filled. |
//| Result: |
//| determinant of matrix A. |
//| If matrix A is not positive definite, exception is thrown. |
//+------------------------------------------------------------------+
static double CMatDet::SPDMatrixDet(CMatrixDouble &ca,const int n,const bool isupper)
{
//--- create variables
double result=0;
bool b;
//--- create copy
CMatrixDouble a;
a=ca;
//--- check
if(!CAp::Assert(n>=1,__FUNCTION__+": N<1!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Rows(a)>=n,__FUNCTION__+": rows(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CAp::Cols(a)>=n,__FUNCTION__+": cols(A)<N!"))
return(EMPTY_VALUE);
//--- check
if(!CAp::Assert(CApServ::IsFiniteRTrMatrix(a,n,isupper),__FUNCTION__+": A contains infinite or NaN values!"))
return(EMPTY_VALUE);
//--- function call
b=CTrFac::SPDMatrixCholesky(a,n,isupper);
//--- check
if(!CAp::Assert(b,__FUNCTION__+": A is not SPD!"))
return(EMPTY_VALUE);
//--- return result
return(SPDMatrixCholeskyDet(a,n));
}
//+------------------------------------------------------------------+
//| Generalized symmetric eigensolver |
//+------------------------------------------------------------------+
class CSpdGEVD
{
public:
//--- constructor, destructor
CSpdGEVD(void);
~CSpdGEVD(void);
//--- methods
static bool SMatrixGEVD(CMatrixDouble &ca,const int n,const bool isuppera,CMatrixDouble &b,const bool isupperb,const int zneeded,const int problemtype,double &d[],CMatrixDouble &z);
static bool SMatrixGEVDReduce(CMatrixDouble &a,const int n,const bool isuppera,CMatrixDouble &b,const bool isupperb,const int problemtype,CMatrixDouble &r,bool &isupperr);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CSpdGEVD::CSpdGEVD(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CSpdGEVD::~CSpdGEVD(void)
{
}
//+------------------------------------------------------------------+
//| Algorithm for solving the following generalized symmetric |
//| positive-definite eigenproblem: |
//| A*x = lambda*B*x (1) or |
//| A*B*x = lambda*x (2) or |
//| B*A*x = lambda*x (3). |
//| where A is a symmetric matrix, B - symmetric positive-definite |
//| matrix. The problem is solved by reducing it to an ordinary |
//| symmetric eigenvalue problem. |
//| 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 matrices A and B. |
//| IsUpperA - storage format of matrix A. |
//| B - symmetric positive-definite matrix which is |
//| given by its upper or lower triangular part. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| IsUpperB - storage format of matrix B. |
//| ZNeeded - if ZNeeded is equal to: |
//| * 0, the eigenvectors are not returned; |
//| * 1, the eigenvectors are returned. |
//| ProblemType - if ProblemType is equal to: |
//| * 1, the following problem is solved: |
//| A*x = lambda*B*x; |
//| * 2, the following problem is solved: |
//| A*B*x = lambda*x; |
//| * 3, the following problem is solved: |
//| B*A*x = lambda*x. |
//| 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 eigenvectors. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| The eigenvectors are stored in matrix |
//| columns. It should be noted that the |
//| eigenvectors in such problems do not form an |
//| orthogonal system. |
//| Result: |
//| True, if the problem was solved successfully. |
//| False, if the error occurred during the Cholesky |
//| decomposition of matrix B (the matrix isn?t |
//| positive-definite) or during the work of the iterative |
//| algorithm for solving the symmetric eigenproblem. |
//| See also the GeneralizedSymmetricDefiniteEVDReduce subroutine. |
//+------------------------------------------------------------------+
static bool CSpdGEVD::SMatrixGEVD(CMatrixDouble &ca,const int n,const bool isuppera,
CMatrixDouble &b,const bool isupperb,const int zneeded,
const int problemtype,double &d[],CMatrixDouble &z)
{
//--- create variables
bool result;
bool isupperr;
int j1=0;
int j2=0;
int j1inc=0;
int j2inc=0;
int i=0;
int j=0;
double v=0;
int i_=0;
//--- create matrix
CMatrixDouble r;
CMatrixDouble t;
//--- create copy
CMatrixDouble a;
a=ca;
//--- Reduce and solve
result=SMatrixGEVDReduce(a,n,isuppera,b,isupperb,problemtype,r,isupperr);
//--- check
if(!result)
return(result);
//--- get result
result=CEigenVDetect::SMatrixEVD(a,n,zneeded,isuppera,d,t);
//--- check
if(!result)
return(result);
//--- Transform eigenvectors if needed
if(zneeded!=0)
{
//--- fill Z with zeros
z.Resize(n,n);
for(j=0;j<n;j++)
z[0].Set(j,0.0);
for(i=1;i<n;i++)
{
for(i_=0;i_<n;i_++)
z[i].Set(i_,z[0][i_]);
}
//--- 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;i<n;i++)
{
for(j=j1;j<=j2;j++)
{
v=r[i][j];
for(i_=0;i_<n;i_++)
z[i].Set(i_,z[i][i_]+v*t[j][i_]);
}
j1=j1+j1inc;
j2=j2+j2inc;
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Algorithm for reduction of the following generalized symmetric |
//| positive- definite eigenvalue problem: |
//| A*x = lambda*B*x (1) or |
//| A*B*x = lambda*x (2) or |
//| B*A*x = lambda*x (3) |
//| to the symmetric eigenvalues problem C*y = lambda*y (eigenvalues |
//| of this and the given problems are the same, and the eigenvectors|
//| of the given problem could be obtained by multiplying the |
//| obtained eigenvectors by the transformation matrix x = R*y). |
//| Here A is a symmetric matrix, B - symmetric positive-definite |
//| matrix. |
//| 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 matrices A and B. |
//| IsUpperA - storage format of matrix A. |
//| B - symmetric positive-definite matrix which is |
//| given by its upper or lower triangular part. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| IsUpperB - storage format of matrix B. |
//| ProblemType - if ProblemType is equal to: |
//| * 1, the following problem is solved: |
//| A*x = lambda*B*x; |
//| * 2, the following problem is solved: |
//| A*B*x = lambda*x; |
//| * 3, the following problem is solved: |
//| B*A*x = lambda*x. |
//| Output parameters: |
//| A - symmetric matrix which is given by its upper |
//| or lower triangle depending on IsUpperA. |
//| Contains matrix C. Array whose indexes range |
//| within [0..N-1, 0..N-1]. |
//| R - upper triangular or low triangular |
//| transformation matrix which is used to obtain|
//| the eigenvectors of a given problem as the |
//| product of eigenvectors of C (from the right)|
//| and matrix R (from the left). If the matrix |
//| is upper triangular, the elements below the |
//| main diagonal are equal to 0 (and vice versa)|
//| Thus, we can perform the multiplication |
//| without taking into account the internal |
//| structure (which is an easier though less |
//| effective way). Array whose indexes range |
//| within [0..N-1, 0..N-1]. |
//| IsUpperR - type of matrix R (upper or lower triangular).|
//| Result: |
//| True, if the problem was reduced successfully. |
//| False, if the error occurred during the Cholesky |
//| decomposition of matrix B (the matrix is not |
//| positive-definite). |
//+------------------------------------------------------------------+
static bool CSpdGEVD::SMatrixGEVDReduce(CMatrixDouble &a,const int n,const bool isuppera,
CMatrixDouble &b,const bool isupperb,const int problemtype,
CMatrixDouble &r,bool &isupperr)
{
//--- 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
double w1[];
double w2[];
double w3[];
//--- object of class
CMatInvReport rep;
//--- check
if(!CAp::Assert(n>0,__FUNCTION__+": N<=0!"))
return(false);
//--- check
if(!CAp::Assert(problemtype==1 || problemtype==2 || problemtype==3,__FUNCTION__+": incorrect ProblemType!"))
return(false);
//--- 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)
{
for(i=0;i<n;i++)
for(i_=i;i_<n;i_++)
t[i_].Set(i,b[i][i_]);
}
else
{
for(i=0;i<n;i++)
for(i_=0;i_<=i;i_++)
t[i].Set(i_,b[i][i_]);
}
//--- 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
ArrayResizeAL(w1,n+1);
ArrayResizeAL(w2,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[i_]=t[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_<i;i_++)
v+=t[i-1][i_]*w2[i_+i1_];
r[i-1].Set(j-1,v);
}
}
// Copy R to A
for(i=0;i<n;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,r[i][i_]);
}
//--- Copy L^(-1) from T to R and transpose
isupperr=true;
for(i=0;i<n;i++)
{
for(j=0;j<i;j++)
r[i].Set(j,0);
}
for(i=0;i<n;i++)
{
for(i_=i;i_<n;i_++)
r[i].Set(i_,t[i_][i]);
}
//--- return result
return(result);
}
//--- Problem 2: A*B*x = lambda*x
//--- or
//--- problem 3: B*A*x = lambda*x
//--- Reducing to:
//--- C*y = lambda*y
//--- C = U * A * U'
//--- B = U'* U
if(problemtype==2||problemtype==3)
{
//--- Factorize B in T: B = U'*U
t.Resize(n,n);
//--- check
if(isupperb)
{
for(i=0;i<n;i++)
for(i_=i;i_<n;i_++)
t[i].Set(i_,b[i][i_]);
}
else
{
for(i=0;i<n;i++)
for(i_=i;i_<n;i_++)
t[i].Set(i_,b[i_][i]);
}
//--- check
if(!CTrFac::SPDMatrixCholesky(t,n,true))
return(false);
//--- Build U * A * U' in R
ArrayResizeAL(w1,n+1);
ArrayResizeAL(w2,n+1);
ArrayResizeAL(w3,n+1);
r.Resize(n,n);
for(j=1;j<=n;j++)
{
//--- Form w2 = A * u'(j) (here u'(j) is j-th column of U')
i1_=(j-1)-(1);
for(i_=1;i_<=n-j+1;i_++)
w1[i_]=t[j-1][i_+i1_];
//--- function call
CSblas::SymmetricMatrixVectorMultiply(a,isuppera,j-1,n-1,w1,1.0,w3);
i1_=(1)-(j);
for(i_=j;i_<=n;i_++)
w2[i_]=w3[i_+i1_];
i1_=(j-1)-(j);
for(i_=j;i_<=n;i_++)
w1[i_]=t[j-1][i_+i1_];
//--- check
if(isuppera)
CBlas::MatrixVectorMultiply(a,0,j-2,j-1,n-1,false,w1,j,n,1.0,w2,1,j-1,0.0);
else
CBlas::MatrixVectorMultiply(a,j-1,n-1,0,j-2,true,w1,j,n,1.0,w2,1,j-1,0.0);
//--- Form u(i)*w2 (here u(i) is i-th row of U)
for(i=1;i<=n;i++)
{
i1_=(i)-(i-1);
v=0.0;
for(i_=i-1;i_<n;i_++)
v+=t[i-1][i_]*w2[i_+i1_];
r[i-1].Set(j-1,v);
}
}
//--- Copy R to A
for(i=0;i<n;i++)
{
for(i_=0;i_<n;i_++)
a[i].Set(i_,r[i][i_]);
}
//--- check
if(problemtype==2)
{
//--- Invert U in T
CMatInv::RMatrixTrInverse(t,n,true,false,info,rep);
//--- check
if(info<=0)
return(false);
//--- Copy U^-1 from T to R
isupperr=true;
for(i=0;i<n;i++)
{
for(j=0;j<i;j++)
r[i].Set(j,0);
}
for(i=0;i<n;i++)
{
for(i_=i;i_<n;i_++)
r[i].Set(i_,t[i][i_]);
}
}
else
{
//--- Copy U from T to R and transpose
isupperr=false;
for(i=0;i<n;i++)
{
for(j=i+1;j<n;j++)
r[i].Set(j,0);
}
for(i=0;i<n;i++)
{
for(i_=i;i_<n;i_++)
r[i_].Set(i,t[i][i_]);
}
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
//| Inverse and update |
//+------------------------------------------------------------------+
class CInverseUpdate
{
public:
CInverseUpdate(void);
~CInverseUpdate(void);
//--- methods
static void RMatrixInvUpdateSimple(CMatrixDouble &inva,const int n,const int updrow,const int updcolumn,const double updval);
static void RMatrixInvUpdateRow(CMatrixDouble &inva,const int n,const int updrow,double &v[]);
static void RMatrixInvUpdateColumn(CMatrixDouble &inva,const int n,const int updcolumn,double &u[]);
static void RMatrixInvUpdateUV(CMatrixDouble &inva,const int n,double &u[],double &v[]);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CInverseUpdate::CInverseUpdate(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CInverseUpdate::~CInverseUpdate(void)
{
}
//+------------------------------------------------------------------+
//| Inverse matrix update by the Sherman-Morrison formula |
//| The algorithm updates matrix A^-1 when adding a number to an |
//| element of matrix A. |
//| Input parameters: |
//| InvA - inverse of matrix A. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| UpdRow - row where the element to be updated is stored. |
//| UpdColumn - column where the element to be updated is stored.|
//| UpdVal - a number to be added to the element. |
//| Output parameters: |
//| InvA - inverse of modified matrix A. |
//+------------------------------------------------------------------+
static void CInverseUpdate::RMatrixInvUpdateSimple(CMatrixDouble &inva,const int n,
const int updrow,const int updcolumn,
const double updval)
{
//--- create arrays
double t1[];
double t2[];
//--- create variables
int i=0;
double lambdav=0;
double vt=0;
int i_=0;
//--- check
if(!CAp::Assert(updrow>=0 && updrow<n,"RMatrixInvUpdateSimple: incorrect UpdRow!"))
return;
//--- check
if(!CAp::Assert(updcolumn>=0 && updcolumn<n,"RMatrixInvUpdateSimple: incorrect UpdColumn!"))
return;
//--- allocation
ArrayResizeAL(t1,n);
ArrayResizeAL(t2,n);
//--- T1=InvA * U
for(i_=0;i_<n;i_++)
t1[i_]=inva[i_][updrow];
//--- T2=v*InvA
for(i_=0;i_<n;i_++)
t2[i_]=inva[updcolumn][i_];
//--- Lambda=v * InvA * U
lambdav=updval*inva[updcolumn][updrow];
//--- InvA=InvA - correction
for(i=0;i<n;i++)
{
vt=updval*t1[i];
vt=vt/(1+lambdav);
for(i_=0;i_<n;i_++)
inva[i].Set(i_,inva[i][i_]-vt*t2[i_]);
}
}
//+------------------------------------------------------------------+
//| Inverse matrix update by the Sherman-Morrison formula |
//| The algorithm updates matrix A^-1 when adding a vector to a row |
//| of matrix A. |
//| Input parameters: |
//| InvA - inverse of matrix A. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| UpdRow - the row of A whose vector V was added. |
//| 0 <= Row <= N-1 |
//| V - the vector to be added to a row. |
//| Array whose index ranges within [0..N-1]. |
//| Output parameters: |
//| InvA - inverse of modified matrix A. |
//+------------------------------------------------------------------+
static void CInverseUpdate::RMatrixInvUpdateRow(CMatrixDouble &inva,const int n,
const int updrow,double &v[])
{
//--- create arrays
double t1[];
double t2[];
//--- create variables
int i=0;
int j=0;
double lambdav=0;
double vt=0;
int i_=0;
//--- allocation
ArrayResizeAL(t1,n);
ArrayResizeAL(t2,n);
//--- T1=InvA * U
for(i_=0;i_<n;i_++)
t1[i_]=inva[i_][updrow];
//--- T2=v*InvA
//--- Lambda=v * InvA * U
for(j=0;j<=n-1;j++)
{
vt=0.0;
for(i_=0;i_<n;i_++)
vt+=v[i_]*inva[i_][j];
t2[j]=vt;
}
lambdav=t2[updrow];
//--- InvA=InvA - correction
for(i=0;i<n;i++)
{
vt=t1[i]/(1+lambdav);
for(i_=0;i_<n;i_++)
inva[i].Set(i_,inva[i][i_]-vt*t2[i_]);
}
}
//+------------------------------------------------------------------+
//| Inverse matrix update by the Sherman-Morrison formula |
//| The algorithm updates matrix A^-1 when adding a vector to a |
//| column of matrix A. |
//| Input parameters: |
//| InvA - inverse of matrix A. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| UpdColumn - the column of A whose vector U was added. |
//| 0 <= UpdColumn <= N-1 |
//| U - the vector to be added to a column. |
//| Array whose index ranges within [0..N-1]. |
//| Output parameters: |
//| InvA - inverse of modified matrix A. |
//+------------------------------------------------------------------+
static void CInverseUpdate::RMatrixInvUpdateColumn(CMatrixDouble &inva,const int n,
const int updcolumn,double &u[])
{
//--- create arrays
double t1[];
double t2[];
//--- create variables
int i=0;
double lambdav=0;
double vt=0;
int i_=0;
//--- allocation
ArrayResizeAL(t1,n);
ArrayResizeAL(t2,n);
//--- T1=InvA * U
//--- Lambda=v * InvA * U
for(i=0;i<n;i++)
{
vt=0.0;
for(i_=0;i_<n;i_++)
vt+=inva[i][i_]*u[i_];
t1[i]=vt;
}
lambdav=t1[updcolumn];
//--- T2=v*InvA
for(i_=0;i_<n;i_++)
t2[i_]=inva[updcolumn][i_];
//--- InvA=InvA - correction
for(i=0;i<n;i++)
{
vt=t1[i]/(1+lambdav);
for(i_=0;i_<n;i_++)
inva[i].Set(i_,inva[i][i_]-vt*t2[i_]);
}
}
//+------------------------------------------------------------------+
//| Inverse matrix update by the Sherman-Morrison formula |
//| The algorithm computes the inverse of matrix A+u*v? by using the |
//| given matrix A^-1 and the vectors u and v. |
//| Input parameters: |
//| InvA - inverse of matrix A. |
//| Array whose indexes range within |
//| [0..N-1, 0..N-1]. |
//| N - size of matrix A. |
//| U - the vector modifying the matrix. |
//| Array whose index ranges within [0..N-1]. |
//| V - the vector modifying the matrix. |
//| Array whose index ranges within [0..N-1]. |
//| Output parameters: |
//| InvA - inverse of matrix A + u*v'. |
//+------------------------------------------------------------------+
static void CInverseUpdate::RMatrixInvUpdateUV(CMatrixDouble &inva,const int n,
double &u[],double &v[])
{
//--- create arrays
double t1[];
double t2[];
//--- create variables
int i=0;
int j=0;
double lambdav=0;
double vt=0;
int i_=0;
//--- allocation
ArrayResizeAL(t1,n);
ArrayResizeAL(t2,n);
//--- T1=InvA * U
//--- Lambda=v * T1
for(i=0;i<n;i++)
{
vt=0.0;
for(i_=0;i_<n;i_++)
vt+=inva[i][i_]*u[i_];
t1[i]=vt;
}
lambdav=0.0;
for(i_=0;i_<n;i_++)
lambdav+=v[i_]*t1[i_];
//--- T2=v*InvA
for(j=0;j<=n-1;j++)
{
vt=0.0;
for(i_=0;i_<n;i_++)
vt+=v[i_]*inva[i_][j];
t2[j]=vt;
}
//--- InvA=InvA - correction
for(i=0;i<n;i++)
{
vt=t1[i]/(1+lambdav);
for(i_=0;i_<n;i_++)
inva[i].Set(i_,inva[i][i_]-vt*t2[i_]);
}
}
//+------------------------------------------------------------------+
//| Schur decomposition |
//+------------------------------------------------------------------+
class CSchur
{
public:
//--- constructor, destructor
CSchur(void);
~CSchur(void);
//--- method
static bool RMatrixSchur(CMatrixDouble &a,const int n,CMatrixDouble &s);
};
//+------------------------------------------------------------------+
//| Constructor without parameters |
//+------------------------------------------------------------------+
CSchur::CSchur(void)
{
}
//+------------------------------------------------------------------+
//| Destructor |
//+------------------------------------------------------------------+
CSchur::~CSchur(void)
{
}
//+------------------------------------------------------------------+
//| Subroutine performing the Schur decomposition of a general matrix|
//| by using the QR algorithm with multiple shifts. |
//| The source matrix A is represented as S'*A*S = T, where S is an |
//| orthogonal matrix (Schur vectors), T - upper quasi-triangular |
//| matrix (with blocks of sizes 1x1 and 2x2 on the main diagonal). |
//| Input parameters: |
//| A - matrix to be decomposed. |
//| Array whose indexes range within [0..N-1, 0..N-1]. |
//| N - size of A, N>=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). |
//+------------------------------------------------------------------+
static bool CSchur::RMatrixSchur(CMatrixDouble &a,const int n,CMatrixDouble &s)
{
//--- create variables
bool result;
int info=0;
int i=0;
int j=0;
//--- create arrays
double tau[];
double wi[];
double wr[];
//--- create matrix
CMatrixDouble a1;
CMatrixDouble s1;
//--- Upper Hessenberg form of the 0-based matrix
COrtFac::RMatrixHessenberg(a,n,tau);
COrtFac::RMatrixHessenbergUnpackQ(a,n,tau,s);
//--- Convert from 0-based arrays to 1-based,
//--- then call InternalSchurDecomposition
//--- Awkward, of course, but Schur decompisiton subroutine
//--- is too complex to fix it.
a1.Resize(n+1,n+1);
s1.Resize(n+1,n+1);
for(i=1;i<=n;i++)
{
for(j=1;j<=n;j++)
{
a1[i].Set(j,a[i-1][j-1]);
s1[i].Set(j,s[i-1][j-1]);
}
}
//--- function call
CHsSchur::InternalSchurDecomposition(a1,n,1,1,wr,wi,s1,info);
result=info==0;
//--- convert from 1-based arrays to -based
for(i=1;i<=n;i++)
{
for(j=1;j<=n;j++)
{
a[i-1].Set(j-1,a1[i][j]);
s[i-1].Set(j-1,s1[i][j]);
}
}
//--- return result
return(result);
}
//+------------------------------------------------------------------+
Reference in New Issue View Git Blame Copy Permalink