static void fillsparsede(ap::real_1d_array& d,
ap::real_1d_array& e,
int n,
double sparcity)
{
int i;
int j;
d.setbounds(0, n-1);
e.setbounds(0, ap::maxint(0, n-2));
for(i = 0; i <= n-1; i++)
{
if( ap::fp_greater_eq(ap::randomreal(),sparcity) )
{
d(i) = 2*ap::randomreal()-1;
}
else
{
d(i) = 0;
}
}
for(i = 0; i <= n-2; i++)
{
if( ap::fp_greater_eq(ap::randomreal(),sparcity) )
{
e(i) = 2*ap::randomreal()-1;
}
else
{
e(i) = 0;
}
}
}
bool in_out_variable_1D(const ap::boolean_1d_array& in, const ap::real_1d_array& X, ap::real_1d_array& x, ap::real_1d_array& vector, bool io)
{
// Routine to know the number of variables in/out
int rows = in.gethighbound(0) + 1;
int n_invar=0;
bool flag;
//ap::real_1d_array vector;
vector.setbounds(0,rows-1);
unsigned int k=0;
for (int i=0; i<rows; i++)
{
if (in(i)==io) //to know how many variables are in/out
{
vector(k) = i;
k++;
n_invar++;
}
}
if (n_invar>0)
{
// Routine to extract the in/out variables
x.setbounds(0,n_invar-1);
for (int i=0; i<n_invar; i++)
x(i) = X(static_cast<int>(vector(i)));
flag=TRUE;
}
else
flag=FALSE;
return flag;
}
/*************************************************************************
Serialization of LinearModel strucure
INPUT PARAMETERS:
LM - original
OUTPUT PARAMETERS:
RA - array of real numbers which stores model,
array[0..RLen-1]
RLen - RA lenght
-- ALGLIB --
Copyright 15.03.2009 by Bochkanov Sergey
*************************************************************************/
void lrserialize(const linearmodel& lm, ap::real_1d_array& ra, int& rlen)
{
rlen = ap::round(lm.w(0))+1;
ra.setbounds(0, rlen-1);
ra(0) = lrvnum;
ap::vmove(&ra(1), &lm.w(0), ap::vlen(1,rlen-1));
}
/*************************************************************************
Solving a system of linear equations with a system matrix given by its
LU decomposition.
The algorithm solves a system of linear equations whose matrix is given by
its LU decomposition. In case of a singular matrix, the algorithm returns
False.
The algorithm solves systems with a square matrix only.
Input parameters:
A - LU decomposition of a system matrix in compact form (the
result of the RMatrixLU subroutine).
Pivots - row permutation table (the result of a
RMatrixLU subroutine).
B - right side of a system.
Array whose index ranges within [0..N-1].
N - size of matrix A.
Output parameters:
X - solution of a system.
Array whose index ranges within [0..N-1].
Result:
True, if the matrix is not singular.
False, if the matrux is singular. In this case, X doesn't contain a
solution.
-- ALGLIB --
Copyright 2005-2008 by Bochkanov Sergey
*************************************************************************/
bool rmatrixlusolve(const ap::real_2d_array& a,
const ap::integer_1d_array& pivots,
ap::real_1d_array b,
int n,
ap::real_1d_array& x)
{
bool result;
ap::real_1d_array y;
int i;
int j;
double v;
y.setbounds(0, n-1);
x.setbounds(0, n-1);
result = true;
for(i = 0; i <= n-1; i++)
{
if( a(i,i)==0 )
{
result = false;
return result;
}
}
//
// pivots
//
for(i = 0; i <= n-1; i++)
{
if( pivots(i)!=i )
{
v = b(i);
b(i) = b(pivots(i));
b(pivots(i)) = v;
}
}
//
// Ly = b
//
y(0) = b(0);
for(i = 1; i <= n-1; i++)
{
v = ap::vdotproduct(&a(i, 0), &y(0), ap::vlen(0,i-1));
y(i) = b(i)-v;
}
//
// Ux = y
//
x(n-1) = y(n-1)/a(n-1,n-1);
for(i = n-2; i >= 0; i--)
{
v = ap::vdotproduct(&a(i, i+1), &x(i+1), ap::vlen(i+1,n-1));
x(i) = (y(i)-v)/a(i,i);
}
return result;
}
/*************************************************************************
Unpacks coefficients of linear model.
INPUT PARAMETERS:
LM - linear model in ALGLIB format
OUTPUT PARAMETERS:
V - coefficients, array[0..NVars]
NVars - number of independent variables (one less than number
of coefficients)
-- ALGLIB --
Copyright 30.08.2008 by Bochkanov Sergey
*************************************************************************/
void lrunpack(const linearmodel& lm, ap::real_1d_array& v, int& nvars)
{
int offs;
ap::ap_error::make_assertion(ap::round(lm.w(1))==lrvnum, "LINREG: Incorrect LINREG version!");
nvars = ap::round(lm.w(2));
offs = ap::round(lm.w(3));
v.setbounds(0, nvars);
ap::vmove(&v(0), &lm.w(offs), ap::vlen(0,nvars));
}
/*************************************************************************
Conversion of a series of Chebyshev polynomials to a power series.
Represents A[0]*T0(x) + A[1]*T1(x) + ... + A[N]*Tn(x) as
B[0] + B[1]*X + ... + B[N]*X^N.
Input parameters:
A - Chebyshev series coefficients
N - degree, N>=0
Output parameters
B - power series coefficients
*************************************************************************/
void fromchebyshev(const ap::real_1d_array& a,
const int& n,
ap::real_1d_array& b)
{
int i;
int k;
double e;
double d;
b.setbounds(0, n);
for(i = 0; i <= n; i++)
{
b(i) = 0;
}
d = 0;
i = 0;
do
{
k = i;
do
{
e = b(k);
b(k) = 0;
if( i<=1&&k==i )
{
b(k) = 1;
}
else
{
if( i!=0 )
{
b(k) = 2*d;
}
if( k>i+1 )
{
b(k) = b(k)-b(k-2);
}
}
d = e;
k = k+1;
}
while(k<=n);
d = b(i);
e = 0;
k = i;
while(k<=n)
{
e = e+b(k)*a(k);
k = k+2;
}
b(i) = e;
i = i+1;
}
while(i<=n);
}
/*************************************************************************
Representation of Ln as C[0] + C[1]*X + ... + C[N]*X^N
Input parameters:
N - polynomial degree, n>=0
Output parameters:
C - coefficients
*************************************************************************/
void laguerrecoefficients(const int& n, ap::real_1d_array& c)
{
int i;
c.setbounds(0, n);
c(0) = 1;
for(i = 0; i <= n-1; i++)
{
c(i+1) = -c(i)*(n-i)/(i+1)/(i+1);
}
}
/*************************************************************************
L-BFGS algorithm results
Called after MinLBFGSIteration() returned False.
INPUT PARAMETERS:
State - algorithm state (used by MinLBFGSIteration).
OUTPUT PARAMETERS:
X - array[0..N-1], solution
Rep - optimization report:
* Rep.TerminationType completetion code:
* -2 rounding errors prevent further improvement.
X contains best point found.
* -1 incorrect parameters were specified
* 1 relative function improvement is no more than
EpsF.
* 2 relative step is no more than EpsX.
* 4 gradient norm is no more than EpsG
* 5 MaxIts steps was taken
* 7 stopping conditions are too stringent,
further improvement is impossible
* Rep.IterationsCount contains iterations count
* NFEV countains number of function calculations
-- ALGLIB --
Copyright 02.04.2010 by Bochkanov Sergey
*************************************************************************/
void minlbfgsresults(const minlbfgsstate& state,
ap::real_1d_array& x,
minlbfgsreport& rep)
{
x.setbounds(0, state.n-1);
ap::vmove(&x(0), 1, &state.x(0), 1, ap::vlen(0,state.n-1));
rep.iterationscount = state.repiterationscount;
rep.nfev = state.repnfev;
rep.terminationtype = state.repterminationtype;
}
/*************************************************************************
Serialization of DecisionForest strucure
INPUT PARAMETERS:
DF - original
OUTPUT PARAMETERS:
RA - array of real numbers which stores decision forest,
array[0..RLen-1]
RLen - RA lenght
-- ALGLIB --
Copyright 13.02.2009 by Bochkanov Sergey
*************************************************************************/
void dfserialize(const decisionforest& df, ap::real_1d_array& ra, int& rlen)
{
ra.setbounds(0, df.bufsize+5-1);
ra(0) = dfvnum;
ra(1) = df.nvars;
ra(2) = df.nclasses;
ra(3) = df.ntrees;
ra(4) = df.bufsize;
ap::vmove(&ra(5), 1, &df.trees(0), 1, ap::vlen(5,5+df.bufsize-1));
rlen = 5+df.bufsize;
}
/*************************************************************************
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.
-- ALGLIB --
Copyright 2005-2007 by Bochkanov Sergey
*************************************************************************/
void rmatrixbdunpackdiagonals(const ap::real_2d_array& b,
int m,
int n,
bool& isupper,
ap::real_1d_array& d,
ap::real_1d_array& e)
{
int i;
isupper = m>=n;
if( m<=0||n<=0 )
{
return;
}
if( isupper )
{
d.setbounds(0, n-1);
e.setbounds(0, n-1);
for(i = 0; i <= n-2; i++)
{
d(i) = b(i,i);
e(i) = b(i,i+1);
}
d(n-1) = b(n-1,n-1);
}
else
{
d.setbounds(0, m-1);
e.setbounds(0, m-1);
for(i = 0; i <= m-2; i++)
{
d(i) = b(i,i);
e(i) = b(i+1,i);
}
d(m-1) = b(m-1,m-1);
}
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixBDUnpackDiagonals for 0-based replacement.
*************************************************************************/
void unpackdiagonalsfrombidiagonal(const ap::real_2d_array& b,
int m,
int n,
bool& isupper,
ap::real_1d_array& d,
ap::real_1d_array& e)
{
int i;
isupper = m>=n;
if( m==0||n==0 )
{
return;
}
if( isupper )
{
d.setbounds(1, n);
e.setbounds(1, n);
for(i = 1; i <= n-1; i++)
{
d(i) = b(i,i);
e(i) = b(i,i+1);
}
d(n) = b(n,n);
}
else
{
d.setbounds(1, m);
e.setbounds(1, m);
for(i = 1; i <= m-1; i++)
{
d(i) = b(i,i);
e(i) = b(i+1,i);
}
d(m) = b(m,m);
}
}
/*************************************************************************
Representation of Hn as C[0] + C[1]*X + ... + C[N]*X^N
Input parameters:
N - polynomial degree, n>=0
Output parameters:
C - coefficients
*************************************************************************/
void hermitecoefficients(const int& n, ap::real_1d_array& c)
{
int i;
c.setbounds(0, n);
for(i = 0; i <= n; i++)
{
c(i) = 0;
}
c(n) = exp(n*log(double(2)));
for(i = 0; i <= n/2-1; i++)
{
c(n-2*(i+1)) = -c(n-2*i)*(n-2*i)*(n-2*i-1)/4/(i+1);
}
}
/*************************************************************************
Multiclass Fisher LDA
Subroutine finds coefficients of linear combination which optimally separates
training set on classes.
INPUT PARAMETERS:
XY - training set, array[0..NPoints-1,0..NVars].
First NVars columns store values of independent
variables, next column stores number of class (from 0
to NClasses-1) which dataset element belongs to. Fractional
values are rounded to nearest integer.
NPoints - training set size, NPoints>=0
NVars - number of independent variables, NVars>=1
NClasses - number of classes, NClasses>=2
OUTPUT PARAMETERS:
Info - return code:
* -4, if internal EVD subroutine hasn't converged
* -2, if there is a point with class number
outside of [0..NClasses-1].
* -1, if incorrect parameters was passed (NPoints<0,
NVars<1, NClasses<2)
* 1, if task has been solved
* 2, if there was a multicollinearity in training set,
but task has been solved.
W - linear combination coefficients, array[0..NVars-1]
-- ALGLIB --
Copyright 31.05.2008 by Bochkanov Sergey
*************************************************************************/
void fisherlda(const ap::real_2d_array& xy,
int npoints,
int nvars,
int nclasses,
int& info,
ap::real_1d_array& w)
{
ap::real_2d_array w2;
fisherldan(xy, npoints, nvars, nclasses, info, w2);
if( info>0 )
{
w.setbounds(0, nvars-1);
ap::vmove(&w(0), 1, &w2(0, 0), w2.getstride(), ap::vlen(0,nvars-1));
}
}
void qrdecomposition(ap::real_2d_array& a,
int m,
int n,
ap::real_1d_array& tau)
{
ap::real_1d_array work;
ap::real_1d_array t;
int i;
int k;
int mmip1;
int minmn;
double tmp;
minmn = ap::minint(m, n);
work.setbounds(1, n);
t.setbounds(1, m);
tau.setbounds(1, minmn);
//
// Test the input arguments
//
k = ap::minint(m, n);
for(i = 1; i <= k; i++)
{
//
// Generate elementary reflector H(i) to annihilate A(i+1:m,i)
//
mmip1 = m-i+1;
ap::vmove(t.getvector(1, mmip1), a.getcolumn(i, i, m));
generatereflection(t, mmip1, tmp);
tau(i) = tmp;
ap::vmove(a.getcolumn(i, i, m), t.getvector(1, mmip1));
t(1) = 1;
if( i<n )
{
//
// Apply H(i) to A(i:m,i+1:n) from the left
//
applyreflectionfromtheleft(a, tau(i), t, i, m, i+1, n, work);
}
}
}
/*************************************************************************
QR decomposition of a rectangular matrix of size MxN
Input parameters:
A - matrix A whose indexes range within [0..M-1, 0..N-1].
M - number of rows in matrix A.
N - number of columns in matrix A.
Output parameters:
A - matrices Q and R in compact form (see below).
Tau - array of scalar factors which are used to form
matrix Q. Array whose index ranges within [0.. Min(M-1,N-1)].
Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
MxM, R - upper triangular (or upper trapezoid) matrix of size M x N.
The elements of matrix R are located on and above the main diagonal of
matrix A. The elements which are located in Tau array and below the main
diagonal of matrix A are used to form matrix Q as follows:
Matrix Q is represented as a product of elementary reflections
Q = H(0)*H(2)*...*H(k-1),
where k = min(m,n), and each H(i) is in the form
H(i) = 1 - tau * v * (v^T)
where tau is a scalar stored in Tau[I]; v - real vector,
so that v(0:i-1) = 0, v(i) = 1, v(i+1:m-1) stored in A(i+1:m-1,i).
-- 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.
Translation from FORTRAN to pseudocode (AlgoPascal)
by Sergey Bochkanov, ALGLIB project, 2005-2007.
*************************************************************************/
void rmatrixqr(ap::real_2d_array& a, int m, int n, ap::real_1d_array& tau)
{
ap::real_1d_array work;
ap::real_1d_array t;
int i;
int k;
int minmn;
double tmp;
if( m<=0||n<=0 )
{
return;
}
minmn = ap::minint(m, n);
work.setbounds(0, n-1);
t.setbounds(1, m);
tau.setbounds(0, minmn-1);
//
// Test the input arguments
//
k = minmn;
for(i = 0; i <= k-1; i++)
{
//
// Generate elementary reflector H(i) to annihilate A(i+1:m,i)
//
ap::vmove(t.getvector(1, m-i), a.getcolumn(i, i, m-1));
generatereflection(t, m-i, tmp);
tau(i) = tmp;
ap::vmove(a.getcolumn(i, i, m-1), t.getvector(1, m-i));
t(1) = 1;
if( i<n )
{
//
// Apply H(i) to A(i:m-1,i+1:n-1) from the left
//
applyreflectionfromtheleft(a, tau(i), t, i, m-1, i+1, n-1, work);
}
}
}
/*************************************************************************
Representation of Pn as C[0] + C[1]*X + ... + C[N]*X^N
Input parameters:
N - polynomial degree, n>=0
Output parameters:
C - coefficients
*************************************************************************/
void legendrecoefficients(const int& n, ap::real_1d_array& c)
{
int i;
c.setbounds(0, n);
for(i = 0; i <= n; i++)
{
c(i) = 0;
}
c(n) = 1;
for(i = 1; i <= n; i++)
{
c(n) = c(n)*(n+i)/2/i;
}
for(i = 0; i <= n/2-1; i++)
{
c(n-2*(i+1)) = -c(n-2*i)*(n-2*i)*(n-2*i-1)/2/(i+1)/(2*(n-i)-1);
}
}
/*************************************************************************
Conjugate gradient results
Called after MinASA returned False.
INPUT PARAMETERS:
State - algorithm state (used by MinASAIteration).
OUTPUT PARAMETERS:
X - array[0..N-1], solution
Rep - optimization report:
* Rep.TerminationType completetion code:
* -2 rounding errors prevent further improvement.
X contains best point found.
* -1 incorrect parameters were specified
* 1 relative function improvement is no more than
EpsF.
* 2 relative step is no more than EpsX.
* 4 gradient norm is no more than EpsG
* 5 MaxIts steps was taken
* 7 stopping conditions are too stringent,
further improvement is impossible
* Rep.IterationsCount contains iterations count
* NFEV countains number of function calculations
* ActiveConstraints contains number of active constraints
-- ALGLIB --
Copyright 20.03.2009 by Bochkanov Sergey
*************************************************************************/
void minasaresults(const minasastate& state,
ap::real_1d_array& x,
minasareport& rep)
{
int i;
x.setbounds(0, state.n-1);
ap::vmove(&x(0), 1, &state.x(0), 1, ap::vlen(0,state.n-1));
rep.iterationscount = state.repiterationscount;
rep.nfev = state.repnfev;
rep.terminationtype = state.repterminationtype;
rep.activeconstraints = 0;
for(i = 0; i <= state.n-1; i++)
{
if( ap::fp_eq(state.ak(i),0) )
{
rep.activeconstraints = rep.activeconstraints+1;
}
}
}
/*************************************************************************
Representation of Tn as C[0] + C[1]*X + ... + C[N]*X^N
Input parameters:
N - polynomial degree, n>=0
Output parameters:
C - coefficients
*************************************************************************/
void chebyshevcoefficients(const int& n, ap::real_1d_array& c)
{
int i;
c.setbounds(0, n);
for(i = 0; i <= n; i++)
{
c(i) = 0;
}
if( n==0||n==1 )
{
c(n) = 1;
}
else
{
c(n) = exp((n-1)*log(double(2)));
for(i = 0; i <= n/2-1; i++)
{
c(n-2*(i+1)) = -c(n-2*i)*(n-2*i)*(n-2*i-1)/4/(i+1)/(n-i-1);
}
}
}
void internalschurdecomposition(ap::real_2d_array& h,
int n,
int tneeded,
int zneeded,
ap::real_1d_array& wr,
ap::real_1d_array& wi,
ap::real_2d_array& z,
int& info)
{
ap::real_1d_array work;
int i;
int i1;
int i2;
int ierr;
int ii;
int itemp;
int itn;
int its;
int j;
int k;
int l;
int maxb;
int nr;
int ns;
int nv;
double absw;
double ovfl;
double smlnum;
double tau;
double temp;
double tst1;
double ulp;
double unfl;
ap::real_2d_array s;
ap::real_1d_array v;
ap::real_1d_array vv;
ap::real_1d_array workc1;
ap::real_1d_array works1;
ap::real_1d_array workv3;
ap::real_1d_array tmpwr;
ap::real_1d_array tmpwi;
bool initz;
bool wantt;
bool wantz;
double cnst;
bool failflag;
int p1;
int p2;
int p3;
int p4;
double vt;
//
// Set the order of the multi-shift QR algorithm to be used.
// If you want to tune algorithm, change this values
//
ns = 12;
maxb = 50;
//
// Now 2 < NS <= MAXB < NH.
//
maxb = ap::maxint(3, maxb);
ns = ap::minint(maxb, ns);
//
// Initialize
//
cnst = 1.5;
work.setbounds(1, ap::maxint(n, 1));
s.setbounds(1, ns, 1, ns);
v.setbounds(1, ns+1);
vv.setbounds(1, ns+1);
wr.setbounds(1, ap::maxint(n, 1));
wi.setbounds(1, ap::maxint(n, 1));
workc1.setbounds(1, 1);
works1.setbounds(1, 1);
workv3.setbounds(1, 3);
tmpwr.setbounds(1, ap::maxint(n, 1));
tmpwi.setbounds(1, ap::maxint(n, 1));
ap::ap_error::make_assertion(n>=0, "InternalSchurDecomposition: incorrect N!");
ap::ap_error::make_assertion(tneeded==0||tneeded==1, "InternalSchurDecomposition: incorrect TNeeded!");
ap::ap_error::make_assertion(zneeded==0||zneeded==1||zneeded==2, "InternalSchurDecomposition: incorrect ZNeeded!");
wantt = tneeded==1;
initz = zneeded==2;
wantz = zneeded!=0;
info = 0;
//
// Initialize Z, if necessary
//
if( initz )
{
z.setbounds(1, n, 1, n);
for(i = 1; i <= n; i++)
{
for(j = 1; j <= n; j++)
{
if( i==j )
{
z(i,j) = 1;
}
else
{
z(i,j) = 0;
}
}
}
}
//
// Quick return if possible
//
if( n==0 )
{
return;
}
if( n==1 )
{
wr(1) = h(1,1);
wi(1) = 0;
return;
}
//
// Set rows and columns 1 to N to zero below the first
// subdiagonal.
//
for(j = 1; j <= n-2; j++)
{
for(i = j+2; i <= n; i++)
{
h(i,j) = 0;
}
}
//
// Test if N is sufficiently small
//
if( ns<=2||ns>n||maxb>=n )
{
//
// Use the standard double-shift algorithm
//
internalauxschur(wantt, wantz, n, 1, n, h, wr, wi, 1, n, z, work, workv3, workc1, works1, info);
//
// fill entries under diagonal blocks of T with zeros
//
if( wantt )
{
j = 1;
while(j<=n)
{
if( wi(j)==0 )
{
for(i = j+1; i <= n; i++)
{
h(i,j) = 0;
}
j = j+1;
}
else
{
for(i = j+2; i <= n; i++)
{
h(i,j) = 0;
h(i,j+1) = 0;
}
j = j+2;
}
}
}
return;
}
unfl = ap::minrealnumber;
ovfl = 1/unfl;
ulp = 2*ap::machineepsilon;
smlnum = unfl*(n/ulp);
//
// I1 and I2 are the indices of the first row and last column of H
// to which transformations must be applied. If eigenvalues only are
// being computed, I1 and I2 are set inside the main loop.
//
if( wantt )
{
i1 = 1;
i2 = n;
}
//
// ITN is the total number of multiple-shift QR iterations allowed.
//
itn = 30*n;
//
// The main loop begins here. I is the loop index and decreases from
// IHI to ILO in steps of at most MAXB. Each iteration of the loop
// works with the active submatrix in rows and columns L to I.
// Eigenvalues I+1 to IHI have already converged. Either L = ILO or
// H(L,L-1) is negligible so that the matrix splits.
//
i = n;
while(true)
{
l = 1;
if( i<1 )
{
//
// fill entries under diagonal blocks of T with zeros
//
if( wantt )
{
j = 1;
while(j<=n)
{
if( wi(j)==0 )
{
for(i = j+1; i <= n; i++)
{
h(i,j) = 0;
}
j = j+1;
}
else
{
for(i = j+2; i <= n; i++)
{
h(i,j) = 0;
h(i,j+1) = 0;
}
j = j+2;
}
}
}
//
// Exit
//
return;
}
//
// Perform multiple-shift QR iterations on rows and columns ILO to I
// until a submatrix of order at most MAXB splits off at the bottom
// because a subdiagonal element has become negligible.
//
failflag = true;
for(its = 0; its <= itn; its++)
{
//
// Look for a single small subdiagonal element.
//
for(k = i; k >= l+1; k--)
{
tst1 = fabs(h(k-1,k-1))+fabs(h(k,k));
if( tst1==0 )
{
tst1 = upperhessenberg1norm(h, l, i, l, i, work);
}
if( fabs(h(k,k-1))<=ap::maxreal(ulp*tst1, smlnum) )
{
break;
}
}
l = k;
if( l>1 )
{
//
// H(L,L-1) is negligible.
//
h(l,l-1) = 0;
}
//
// Exit from loop if a submatrix of order <= MAXB has split off.
//
if( l>=i-maxb+1 )
{
failflag = false;
break;
}
//
// Now the active submatrix is in rows and columns L to I. If
// eigenvalues only are being computed, only the active submatrix
// need be transformed.
//
if( !wantt )
{
i1 = l;
i2 = i;
}
if( its==20||its==30 )
{
//
// Exceptional shifts.
//
for(ii = i-ns+1; ii <= i; ii++)
{
wr(ii) = cnst*(fabs(h(ii,ii-1))+fabs(h(ii,ii)));
wi(ii) = 0;
}
}
else
{
//
// Use eigenvalues of trailing submatrix of order NS as shifts.
//
copymatrix(h, i-ns+1, i, i-ns+1, i, s, 1, ns, 1, ns);
internalauxschur(false, false, ns, 1, ns, s, tmpwr, tmpwi, 1, ns, z, work, workv3, workc1, works1, ierr);
for(p1 = 1; p1 <= ns; p1++)
{
wr(i-ns+p1) = tmpwr(p1);
wi(i-ns+p1) = tmpwi(p1);
}
if( ierr>0 )
{
//
// If DLAHQR failed to compute all NS eigenvalues, use the
// unconverged diagonal elements as the remaining shifts.
//
for(ii = 1; ii <= ierr; ii++)
{
wr(i-ns+ii) = s(ii,ii);
wi(i-ns+ii) = 0;
}
}
}
//
// Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns))
// where G is the Hessenberg submatrix H(L:I,L:I) and w is
// the vector of shifts (stored in WR and WI). The result is
// stored in the local array V.
//
v(1) = 1;
for(ii = 2; ii <= ns+1; ii++)
{
v(ii) = 0;
}
nv = 1;
for(j = i-ns+1; j <= i; j++)
{
if( wi(j)>=0 )
{
if( wi(j)==0 )
{
//
// real shift
//
p1 = nv+1;
ap::vmove(&vv(1), &v(1), ap::vlen(1,p1));
matrixvectormultiply(h, l, l+nv, l, l+nv-1, false, vv, 1, nv, 1.0, v, 1, nv+1, -wr(j));
nv = nv+1;
}
else
{
if( wi(j)>0 )
{
//
// complex conjugate pair of shifts
//
p1 = nv+1;
ap::vmove(&vv(1), &v(1), ap::vlen(1,p1));
matrixvectormultiply(h, l, l+nv, l, l+nv-1, false, v, 1, nv, 1.0, vv, 1, nv+1, -2*wr(j));
itemp = vectoridxabsmax(vv, 1, nv+1);
temp = 1/ap::maxreal(fabs(vv(itemp)), smlnum);
p1 = nv+1;
ap::vmul(&vv(1), ap::vlen(1,p1), temp);
absw = pythag2(wr(j), wi(j));
temp = temp*absw*absw;
matrixvectormultiply(h, l, l+nv+1, l, l+nv, false, vv, 1, nv+1, 1.0, v, 1, nv+2, temp);
nv = nv+2;
}
}
//
// Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero,
// reset it to the unit vector.
//
itemp = vectoridxabsmax(v, 1, nv);
temp = fabs(v(itemp));
if( temp==0 )
{
v(1) = 1;
for(ii = 2; ii <= nv; ii++)
{
v(ii) = 0;
}
}
else
{
temp = ap::maxreal(temp, smlnum);
vt = 1/temp;
ap::vmul(&v(1), ap::vlen(1,nv), vt);
}
}
}
//
// Multiple-shift QR step
//
for(k = l; k <= i-1; k++)
{
//
// The first iteration of this loop determines a reflection G
// from the vector V and applies it from left and right to H,
// thus creating a nonzero bulge below the subdiagonal.
//
// Each subsequent iteration determines a reflection G to
// restore the Hessenberg form in the (K-1)th column, and thus
// chases the bulge one step toward the bottom of the active
// submatrix. NR is the order of G.
//
nr = ap::minint(ns+1, i-k+1);
if( k>l )
{
p1 = k-1;
p2 = k+nr-1;
ap::vmove(v.getvector(1, nr), h.getcolumn(p1, k, p2));
}
generatereflection(v, nr, tau);
if( k>l )
{
h(k,k-1) = v(1);
for(ii = k+1; ii <= i; ii++)
{
h(ii,k-1) = 0;
}
}
v(1) = 1;
//
// Apply G from the left to transform the rows of the matrix in
// columns K to I2.
//
applyreflectionfromtheleft(h, tau, v, k, k+nr-1, k, i2, work);
//
// Apply G from the right to transform the columns of the
// matrix in rows I1 to min(K+NR,I).
//
applyreflectionfromtheright(h, tau, v, i1, ap::minint(k+nr, i), k, k+nr-1, work);
if( wantz )
{
//
// Accumulate transformations in the matrix Z
//
applyreflectionfromtheright(z, tau, v, 1, n, k, k+nr-1, work);
}
}
}
//
// Failure to converge in remaining number of iterations
//
if( failflag )
{
info = i;
return;
}
//
// A submatrix of order <= MAXB in rows and columns L to I has split
// off. Use the double-shift QR algorithm to handle it.
//
internalauxschur(wantt, wantz, n, l, i, h, wr, wi, 1, n, z, work, workv3, workc1, works1, info);
if( info>0 )
{
return;
}
//
// Decrement number of remaining iterations, and return to start of
// the main loop with a new value of I.
//
itn = itn-its;
i = l-1;
}
}
/*************************************************************************
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].
-- ALGLIB --
Copyright 2005 by Bochkanov Sergey
*************************************************************************/
bool rmatrixsvd(ap::real_2d_array a,
int m,
int n,
int uneeded,
int vtneeded,
int additionalmemory,
ap::real_1d_array& w,
ap::real_2d_array& u,
ap::real_2d_array& vt)
{
bool result;
ap::real_1d_array tauq;
ap::real_1d_array taup;
ap::real_1d_array tau;
ap::real_1d_array e;
ap::real_1d_array work;
ap::real_2d_array t2;
bool isupper;
int minmn;
int ncu;
int nrvt;
int nru;
int ncvt;
int i;
int j;
result = true;
if( m==0||n==0 )
{
return result;
}
ap::ap_error::make_assertion(uneeded>=0&&uneeded<=2, "SVDDecomposition: wrong parameters!");
ap::ap_error::make_assertion(vtneeded>=0&&vtneeded<=2, "SVDDecomposition: wrong parameters!");
ap::ap_error::make_assertion(additionalmemory>=0&&additionalmemory<=2, "SVDDecomposition: wrong parameters!");
//
// initialize
//
minmn = ap::minint(m, n);
w.setbounds(1, minmn);
ncu = 0;
nru = 0;
if( uneeded==1 )
{
nru = m;
ncu = minmn;
u.setbounds(0, nru-1, 0, ncu-1);
}
if( uneeded==2 )
{
nru = m;
ncu = m;
u.setbounds(0, nru-1, 0, ncu-1);
}
nrvt = 0;
ncvt = 0;
if( vtneeded==1 )
{
nrvt = minmn;
ncvt = n;
vt.setbounds(0, nrvt-1, 0, ncvt-1);
}
if( vtneeded==2 )
{
nrvt = n;
ncvt = n;
vt.setbounds(0, nrvt-1, 0, ncvt-1);
}
//
// M much larger than N
// Use bidiagonal reduction with QR-decomposition
//
if( ap::fp_greater(m,1.6*n) )
{
if( uneeded==0 )
{
//
// No left singular vectors to be computed
//
rmatrixqr(a, m, n, tau);
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= i-1; j++)
{
a(i,j) = 0;
}
}
rmatrixbd(a, n, n, tauq, taup);
rmatrixbdunpackpt(a, n, n, taup, nrvt, vt);
rmatrixbdunpackdiagonals(a, n, n, isupper, w, e);
result = rmatrixbdsvd(w, e, n, isupper, false, u, 0, a, 0, vt, ncvt);
return result;
}
else
{
//
// Left singular vectors (may be full matrix U) to be computed
//
rmatrixqr(a, m, n, tau);
rmatrixqrunpackq(a, m, n, tau, ncu, u);
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= i-1; j++)
{
a(i,j) = 0;
}
}
rmatrixbd(a, n, n, tauq, taup);
rmatrixbdunpackpt(a, n, n, taup, nrvt, vt);
rmatrixbdunpackdiagonals(a, n, n, isupper, w, e);
if( additionalmemory<1 )
{
//
// No additional memory can be used
//
rmatrixbdmultiplybyq(a, n, n, tauq, u, m, n, true, false);
result = rmatrixbdsvd(w, e, n, isupper, false, u, m, a, 0, vt, ncvt);
}
else
{
//
// Large U. Transforming intermediate matrix T2
//
work.setbounds(1, ap::maxint(m, n));
rmatrixbdunpackq(a, n, n, tauq, n, t2);
copymatrix(u, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1);
inplacetranspose(t2, 0, n-1, 0, n-1, work);
result = rmatrixbdsvd(w, e, n, isupper, false, u, 0, t2, n, vt, ncvt);
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;
}
}
//
// N much larger than M
// Use bidiagonal reduction with LQ-decomposition
//
if( ap::fp_greater(n,1.6*m) )
{
if( vtneeded==0 )
{
//
// No right singular vectors to be computed
//
rmatrixlq(a, m, n, tau);
for(i = 0; i <= m-1; i++)
{
for(j = i+1; j <= m-1; j++)
{
a(i,j) = 0;
}
}
rmatrixbd(a, m, m, tauq, taup);
rmatrixbdunpackq(a, m, m, tauq, ncu, u);
rmatrixbdunpackdiagonals(a, m, m, isupper, w, e);
work.setbounds(1, m);
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
result = rmatrixbdsvd(w, e, m, isupper, false, a, 0, u, nru, vt, 0);
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
return result;
}
else
{
//
// Right singular vectors (may be full matrix VT) to be computed
//
rmatrixlq(a, m, n, tau);
rmatrixlqunpackq(a, m, n, tau, nrvt, vt);
for(i = 0; i <= m-1; i++)
{
for(j = i+1; j <= m-1; j++)
{
a(i,j) = 0;
}
}
rmatrixbd(a, m, m, tauq, taup);
rmatrixbdunpackq(a, m, m, tauq, ncu, u);
rmatrixbdunpackdiagonals(a, m, m, isupper, w, e);
work.setbounds(1, ap::maxint(m, n));
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
if( additionalmemory<1 )
{
//
// No additional memory available
//
rmatrixbdmultiplybyp(a, m, m, taup, vt, m, n, false, true);
result = rmatrixbdsvd(w, e, m, isupper, false, a, 0, u, nru, vt, n);
}
else
{
//
// Large VT. Transforming intermediate matrix T2
//
rmatrixbdunpackpt(a, m, m, taup, m, t2);
result = rmatrixbdsvd(w, e, m, isupper, false, a, 0, u, nru, t2, m);
copymatrix(vt, 0, m-1, 0, n-1, a, 0, m-1, 0, n-1);
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);
}
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
return result;
}
}
//
// M<=N
// We can use inplace transposition of U to get rid of columnwise operations
//
if( m<=n )
{
rmatrixbd(a, m, n, tauq, taup);
rmatrixbdunpackq(a, m, n, tauq, ncu, u);
rmatrixbdunpackpt(a, m, n, taup, nrvt, vt);
rmatrixbdunpackdiagonals(a, m, n, isupper, w, e);
work.setbounds(1, m);
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
result = rmatrixbdsvd(w, e, minmn, isupper, false, a, 0, u, nru, vt, ncvt);
inplacetranspose(u, 0, nru-1, 0, ncu-1, work);
return result;
}
//
// Simple bidiagonal reduction
//
rmatrixbd(a, m, n, tauq, taup);
rmatrixbdunpackq(a, m, n, tauq, ncu, u);
rmatrixbdunpackpt(a, m, n, taup, nrvt, vt);
rmatrixbdunpackdiagonals(a, m, n, isupper, w, e);
if( additionalmemory<2||uneeded==0 )
{
//
// We cant use additional memory or there is no need in such operations
//
result = rmatrixbdsvd(w, e, minmn, isupper, false, u, nru, a, 0, vt, ncvt);
}
else
{
//
// We can use additional memory
//
t2.setbounds(0, minmn-1, 0, m-1);
copyandtranspose(u, 0, m-1, 0, minmn-1, t2, 0, minmn-1, 0, m-1);
result = rmatrixbdsvd(w, e, minmn, isupper, false, u, 0, t2, m, vt, ncvt);
copyandtranspose(t2, 0, minmn-1, 0, m-1, u, 0, m-1, 0, minmn-1);
}
return result;
}
/*************************************************************************
Obsolete 1-based subroutine
*************************************************************************/
bool solvesystemlu(const ap::real_2d_array& a,
const ap::integer_1d_array& pivots,
ap::real_1d_array b,
int n,
ap::real_1d_array& x)
{
bool result;
ap::real_1d_array y;
int i;
int j;
double v;
int ip1;
int im1;
y.setbounds(1, n);
x.setbounds(1, n);
result = true;
for(i = 1; i <= n; i++)
{
if( a(i,i)==0 )
{
result = false;
return result;
}
}
//
// pivots
//
for(i = 1; i <= n; i++)
{
if( pivots(i)!=i )
{
v = b(i);
b(i) = b(pivots(i));
b(pivots(i)) = v;
}
}
//
// Ly = b
//
y(1) = b(1);
for(i = 2; i <= n; i++)
{
im1 = i-1;
v = ap::vdotproduct(&a(i, 1), &y(1), ap::vlen(1,im1));
y(i) = b(i)-v;
}
//
// Ux = y
//
x(n) = y(n)/a(n,n);
for(i = n-1; i >= 1; i--)
{
ip1 = i+1;
v = ap::vdotproduct(&a(i, ip1), &x(ip1), ap::vlen(ip1,n));
x(i) = (y(i)-v)/a(i,i);
}
return result;
}
/*************************************************************************
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
*************************************************************************/
void smatrixtd(ap::real_2d_array& a,
int n,
bool isupper,
ap::real_1d_array& tau,
ap::real_1d_array& d,
ap::real_1d_array& e)
{
int i;
double alpha;
double taui;
double v;
ap::real_1d_array t;
ap::real_1d_array t2;
ap::real_1d_array t3;
if( n<=0 )
{
return;
}
t.setbounds(1, n);
t2.setbounds(1, n);
t3.setbounds(1, n);
if( n>1 )
{
tau.setbounds(0, n-2);
}
d.setbounds(0, n-1);
if( n>1 )
{
e.setbounds(0, n-2);
}
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 )
{
ap::vmove(t.getvector(2, i+1), a.getcolumn(i+1, 0, i-1));
}
t(1) = a(i,i+1);
generatereflection(t, i+1, taui);
if( i>=1 )
{
ap::vmove(a.getcolumn(i+1, 0, i-1), t.getvector(2, i+1));
}
a(i,i+1) = t(1);
e(i) = a(i,i+1);
if( taui!=0 )
{
//
// Apply H from both sides to A
//
a(i,i+1) = 1;
//
// Compute x := tau * A * v storing x in TAU
//
ap::vmove(t.getvector(1, i+1), a.getcolumn(i+1, 0, i));
symmetricmatrixvectormultiply(a, isupper, 0, i, t, taui, t3);
ap::vmove(&tau(0), &t3(1), ap::vlen(0,i));
//
// Compute w := x - 1/2 * tau * (x'*v) * v
//
v = ap::vdotproduct(tau.getvector(0, i), a.getcolumn(i+1, 0, i));
alpha = -0.5*taui*v;
ap::vadd(tau.getvector(0, i), a.getcolumn(i+1, 0, i), alpha);
//
// Apply the transformation as a rank-2 update:
// A := A - v * w' - w * v'
//
ap::vmove(t.getvector(1, i+1), a.getcolumn(i+1, 0, i));
ap::vmove(&t3(1), &tau(0), ap::vlen(1,i+1));
symmetricrank2update(a, isupper, 0, i, t, t3, t2, double(-1));
a(i,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-2; i++)
{
//
// Generate elementary reflector H = E - tau * v * v'
//
ap::vmove(t.getvector(1, n-i-1), a.getcolumn(i, i+1, n-1));
generatereflection(t, n-i-1, taui);
ap::vmove(a.getcolumn(i, i+1, n-1), t.getvector(1, n-i-1));
e(i) = a(i+1,i);
if( taui!=0 )
{
//
// Apply H from both sides to A
//
a(i+1,i) = 1;
//
// Compute x := tau * A * v storing y in TAU
//
ap::vmove(t.getvector(1, n-i-1), a.getcolumn(i, i+1, n-1));
symmetricmatrixvectormultiply(a, isupper, i+1, n-1, t, taui, t2);
ap::vmove(&tau(i), &t2(1), ap::vlen(i,n-2));
//
// Compute w := x - 1/2 * tau * (x'*v) * v
//
v = ap::vdotproduct(tau.getvector(i, n-2), a.getcolumn(i, i+1, n-1));
alpha = -0.5*taui*v;
ap::vadd(tau.getvector(i, n-2), a.getcolumn(i, i+1, n-1), alpha);
//
// Apply the transformation as a rank-2 update:
// A := A - v * w' - w * v'
//
//
ap::vmove(t.getvector(1, n-i-1), a.getcolumn(i, i+1, n-1));
ap::vmove(&t2(1), &tau(i), ap::vlen(1,n-i-1));
symmetricrank2update(a, isupper, i+1, n-1, t, t2, t3, double(-1));
a(i+1,i) = e(i);
}
d(i) = a(i,i);
tau(i) = taui;
}
d(n-1) = a(n-1,n-1);
}
}
/*************************************************************************
Obsolete 1-based subroutine
*************************************************************************/
void totridiagonal(ap::real_2d_array& a,
int n,
bool isupper,
ap::real_1d_array& tau,
ap::real_1d_array& d,
ap::real_1d_array& e)
{
int i;
int ip1;
int im1;
int nmi;
int nm1;
double alpha;
double taui;
double v;
ap::real_1d_array t;
ap::real_1d_array t2;
ap::real_1d_array t3;
if( n<=0 )
{
return;
}
t.setbounds(1, n);
t2.setbounds(1, n);
t3.setbounds(1, n);
tau.setbounds(1, ap::maxint(1, n-1));
d.setbounds(1, n);
e.setbounds(1, ap::maxint(1, n-1));
if( isupper )
{
//
// Reduce the upper triangle of A
//
for(i = n-1; i >= 1; i--)
{
//
// Generate elementary reflector H(i) = I - tau * v * v'
// to annihilate A(1:i-1,i+1)
//
// DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI );
//
ip1 = i+1;
im1 = i-1;
if( i>=2 )
{
ap::vmove(t.getvector(2, i), a.getcolumn(ip1, 1, im1));
}
t(1) = a(i,ip1);
generatereflection(t, i, taui);
if( i>=2 )
{
ap::vmove(a.getcolumn(ip1, 1, im1), t.getvector(2, i));
}
a(i,ip1) = t(1);
e(i) = a(i,i+1);
if( taui!=0 )
{
//
// Apply H(i) from both sides to A(1:i,1:i)
//
a(i,i+1) = 1;
//
// Compute x := tau * A * v storing x in TAU(1:i)
//
// DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, TAU, 1 );
//
ip1 = i+1;
ap::vmove(t.getvector(1, i), a.getcolumn(ip1, 1, i));
symmetricmatrixvectormultiply(a, isupper, 1, i, t, taui, tau);
//
// Compute w := x - 1/2 * tau * (x'*v) * v
//
ip1 = i+1;
v = ap::vdotproduct(tau.getvector(1, i), a.getcolumn(ip1, 1, i));
alpha = -0.5*taui*v;
ap::vadd(tau.getvector(1, i), a.getcolumn(ip1, 1, i), alpha);
//
// Apply the transformation as a rank-2 update:
// A := A - v * w' - w * v'
//
// DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, LDA );
//
ap::vmove(t.getvector(1, i), a.getcolumn(ip1, 1, i));
symmetricrank2update(a, isupper, 1, i, t, tau, t2, double(-1));
a(i,i+1) = e(i);
}
d(i+1) = a(i+1,i+1);
tau(i) = taui;
}
d(1) = a(1,1);
}
else
{
//
// Reduce the lower triangle of A
//
for(i = 1; i <= n-1; i++)
{
//
// Generate elementary reflector H(i) = I - tau * v * v'
// to annihilate A(i+2:n,i)
//
//DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, TAUI );
//
nmi = n-i;
ip1 = i+1;
ap::vmove(t.getvector(1, nmi), a.getcolumn(i, ip1, n));
generatereflection(t, nmi, taui);
ap::vmove(a.getcolumn(i, ip1, n), t.getvector(1, nmi));
e(i) = a(i+1,i);
if( taui!=0 )
{
//
// Apply H(i) from both sides to A(i+1:n,i+1:n)
//
a(i+1,i) = 1;
//
// Compute x := tau * A * v storing y in TAU(i:n-1)
//
//DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO, TAU( I ), 1 );
//
ip1 = i+1;
nmi = n-i;
nm1 = n-1;
ap::vmove(t.getvector(1, nmi), a.getcolumn(i, ip1, n));
symmetricmatrixvectormultiply(a, isupper, i+1, n, t, taui, t2);
ap::vmove(&tau(i), &t2(1), ap::vlen(i,nm1));
//
// Compute w := x - 1/2 * tau * (x'*v) * v
//
nm1 = n-1;
ip1 = i+1;
v = ap::vdotproduct(tau.getvector(i, nm1), a.getcolumn(i, ip1, n));
alpha = -0.5*taui*v;
ap::vadd(tau.getvector(i, nm1), a.getcolumn(i, ip1, n), alpha);
//
// Apply the transformation as a rank-2 update:
// A := A - v * w' - w * v'
//
//DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, A( I+1, I+1 ), LDA );
//
nm1 = n-1;
nmi = n-i;
ip1 = i+1;
ap::vmove(t.getvector(1, nmi), a.getcolumn(i, ip1, n));
ap::vmove(&t2(1), &tau(i), ap::vlen(1,nmi));
symmetricrank2update(a, isupper, i+1, n, t, t2, t3, double(-1));
a(i+1,i) = e(i);
}
d(i) = a(i,i);
tau(i) = taui;
}
d(n) = a(n,n);
}
}
/*************************************************************************
Matrix norm estimation
The algorithm estimates the 1-norm of square matrix A on the assumption
that the multiplication of matrix A by the vector is available (the
iterative method is used). It is recommended to use this algorithm if it
is hard to calculate matrix elements explicitly (for example, when
estimating the inverse matrix norm).
The algorithm uses back communication for multiplying the vector by the
matrix. If KASE=0 after returning from a subroutine, its execution was
completed successfully, otherwise it is required to multiply the returned
vector by matrix A and call the subroutine again.
The DemoIterativeEstimateNorm subroutine shows a simple example.
Parameters:
N - size of matrix A.
V - vector. It is initialized by the subroutine on the first
call. It is then passed into it on repeated calls.
X - if KASE<>0, it contains the vector to be replaced by:
A * X, if KASE=1
A^T * X, if KASE=2
Array whose index ranges within [1..N].
ISGN - vector. It is initialized by the subroutine on the first
call. It is then passed into it on repeated calls.
EST - if KASE=0, it contains the lower boundary of the matrix
norm estimate.
KASE - on the first call, it should be equal to 0. After the last
return, it is equal to 0 (EST contains the matrix norm),
on intermediate returns it can be equal to 1 or 2 depending
on the operation to be performed on vector X.
-- 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
*************************************************************************/
void iterativeestimate1norm(int n,
ap::real_1d_array& v,
ap::real_1d_array& x,
ap::integer_1d_array& isgn,
double& est,
int& kase)
{
int itmax;
int i;
double t;
bool flg;
int positer;
int posj;
int posjlast;
int posjump;
int posaltsgn;
int posestold;
int postemp;
itmax = 5;
posaltsgn = n+1;
posestold = n+2;
postemp = n+3;
positer = n+1;
posj = n+2;
posjlast = n+3;
posjump = n+4;
if( kase==0 )
{
v.setbounds(1, n+3);
x.setbounds(1, n);
isgn.setbounds(1, n+4);
t = double(1)/double(n);
for(i = 1; i <= n; i++)
{
x(i) = t;
}
kase = 1;
isgn(posjump) = 1;
return;
}
//
// ................ ENTRY (JUMP = 1)
// FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
//
if( isgn(posjump)==1 )
{
if( n==1 )
{
v(1) = x(1);
est = fabs(v(1));
kase = 0;
return;
}
est = 0;
for(i = 1; i <= n; i++)
{
est = est+fabs(x(i));
}
for(i = 1; i <= n; i++)
{
if( ap::fp_greater_eq(x(i),0) )
{
x(i) = 1;
}
else
{
x(i) = -1;
}
isgn(i) = ap::sign(x(i));
}
kase = 2;
isgn(posjump) = 2;
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++)
{
if( ap::fp_greater(fabs(x(i)),fabs(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;
return;
}
//
// ................ ENTRY (JUMP = 3)
// X HAS BEEN OVERWRITTEN BY A*X.
//
if( isgn(posjump)==3 )
{
ap::vmove(&v(1), 1, &x(1), 1, ap::vlen(1,n));
v(posestold) = est;
est = 0;
for(i = 1; i <= n; i++)
{
est = est+fabs(v(i));
}
flg = false;
for(i = 1; i <= n; i++)
{
if( ap::fp_greater_eq(x(i),0)&&isgn(i)<0||ap::fp_less(x(i),0)&&isgn(i)>=0 )
{
flg = true;
}
}
//
// REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
// OR MAY BE CYCLING.
//
if( !flg||ap::fp_less_eq(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;
return;
}
for(i = 1; i <= n; i++)
{
if( ap::fp_greater_eq(x(i),0) )
{
x(i) = 1;
isgn(i) = 1;
}
else
{
x(i) = -1;
isgn(i) = -1;
}
}
kase = 2;
isgn(posjump) = 4;
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++)
{
if( ap::fp_greater(fabs(x(i)),fabs(x(isgn(posj)))) )
{
isgn(posj) = i;
}
}
if( ap::fp_neq(x(isgn(posjlast)),fabs(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;
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;
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)+fabs(x(i));
}
v(postemp) = 2*v(postemp)/(3*n);
if( ap::fp_greater(v(postemp),est) )
{
ap::vmove(&v(1), 1, &x(1), 1, ap::vlen(1,n));
est = v(postemp);
}
kase = 0;
return;
}
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixBD for 0-based replacement.
*************************************************************************/
void tobidiagonal(ap::real_2d_array& a,
int m,
int n,
ap::real_1d_array& tauq,
ap::real_1d_array& taup)
{
ap::real_1d_array work;
ap::real_1d_array t;
int minmn;
int maxmn;
int i;
double ltau;
int mmip1;
int nmi;
int ip1;
int nmip1;
int mmi;
minmn = ap::minint(m, n);
maxmn = ap::maxint(m, n);
work.setbounds(1, maxmn);
t.setbounds(1, maxmn);
taup.setbounds(1, minmn);
tauq.setbounds(1, minmn);
if( m>=n )
{
//
// Reduce to upper bidiagonal form
//
for(i = 1; i <= n; i++)
{
//
// Generate elementary reflector H(i) to annihilate A(i+1:m,i)
//
mmip1 = m-i+1;
ap::vmove(t.getvector(1, mmip1), a.getcolumn(i, i, m));
generatereflection(t, mmip1, ltau);
tauq(i) = ltau;
ap::vmove(a.getcolumn(i, i, m), t.getvector(1, mmip1));
t(1) = 1;
//
// Apply H(i) to A(i:m,i+1:n) from the left
//
applyreflectionfromtheleft(a, ltau, t, i, m, i+1, n, work);
if( i<n )
{
//
// Generate elementary reflector G(i) to annihilate
// A(i,i+2:n)
//
nmi = n-i;
ip1 = i+1;
ap::vmove(&t(1), &a(i, ip1), ap::vlen(1,nmi));
generatereflection(t, nmi, ltau);
taup(i) = ltau;
ap::vmove(&a(i, ip1), &t(1), ap::vlen(ip1,n));
t(1) = 1;
//
// Apply G(i) to A(i+1:m,i+1:n) from the right
//
applyreflectionfromtheright(a, ltau, t, i+1, m, i+1, n, work);
}
else
{
taup(i) = 0;
}
}
}
else
{
//
// Reduce to lower bidiagonal form
//
for(i = 1; i <= m; i++)
{
//
// Generate elementary reflector G(i) to annihilate A(i,i+1:n)
//
nmip1 = n-i+1;
ap::vmove(&t(1), &a(i, i), ap::vlen(1,nmip1));
generatereflection(t, nmip1, ltau);
taup(i) = ltau;
ap::vmove(&a(i, i), &t(1), ap::vlen(i,n));
t(1) = 1;
//
// Apply G(i) to A(i+1:m,i:n) from the right
//
applyreflectionfromtheright(a, ltau, t, i+1, m, i, n, work);
if( i<m )
{
//
// Generate elementary reflector H(i) to annihilate
// A(i+2:m,i)
//
mmi = m-i;
ip1 = i+1;
ap::vmove(t.getvector(1, mmi), a.getcolumn(i, ip1, m));
generatereflection(t, mmi, ltau);
tauq(i) = ltau;
ap::vmove(a.getcolumn(i, ip1, m), t.getvector(1, mmi));
t(1) = 1;
//
// Apply H(i) to A(i+1:m,i+1:n) from the left
//
applyreflectionfromtheleft(a, ltau, t, i+1, m, i+1, n, work);
}
else
{
tauq(i) = 0;
}
}
}
}
/*************************************************************************
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.
*************************************************************************/
void rmatrixbd(ap::real_2d_array& a,
int m,
int n,
ap::real_1d_array& tauq,
ap::real_1d_array& taup)
{
ap::real_1d_array work;
ap::real_1d_array t;
int maxmn;
int i;
double ltau;
//
// Prepare
//
if( n<=0||m<=0 )
{
return;
}
maxmn = ap::maxint(m, n);
work.setbounds(0, maxmn);
t.setbounds(0, maxmn);
if( m>=n )
{
tauq.setbounds(0, n-1);
taup.setbounds(0, n-1);
}
else
{
tauq.setbounds(0, m-1);
taup.setbounds(0, m-1);
}
if( m>=n )
{
//
// Reduce to upper bidiagonal form
//
for(i = 0; i <= n-1; i++)
{
//
// Generate elementary reflector H(i) to annihilate A(i+1:m-1,i)
//
ap::vmove(t.getvector(1, m-i), a.getcolumn(i, i, m-1));
generatereflection(t, m-i, ltau);
tauq(i) = ltau;
ap::vmove(a.getcolumn(i, i, m-1), t.getvector(1, m-i));
t(1) = 1;
//
// Apply H(i) to A(i:m-1,i+1:n-1) from the left
//
applyreflectionfromtheleft(a, ltau, t, i, m-1, i+1, n-1, work);
if( i<n-1 )
{
//
// Generate elementary reflector G(i) to annihilate
// A(i,i+2:n-1)
//
ap::vmove(&t(1), &a(i, i+1), ap::vlen(1,n-i-1));
generatereflection(t, n-1-i, ltau);
taup(i) = ltau;
ap::vmove(&a(i, i+1), &t(1), ap::vlen(i+1,n-1));
t(1) = 1;
//
// Apply G(i) to A(i+1:m-1,i+1:n-1) from the right
//
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-1; i++)
{
//
// Generate elementary reflector G(i) to annihilate A(i,i+1:n-1)
//
ap::vmove(&t(1), &a(i, i), ap::vlen(1,n-i));
generatereflection(t, n-i, ltau);
taup(i) = ltau;
ap::vmove(&a(i, i), &t(1), ap::vlen(i,n-1));
t(1) = 1;
//
// Apply G(i) to A(i+1:m-1,i:n-1) from the right
//
applyreflectionfromtheright(a, ltau, t, i+1, m-1, i, n-1, work);
if( i<m-1 )
{
//
// Generate elementary reflector H(i) to annihilate
// A(i+2:m-1,i)
//
ap::vmove(t.getvector(1, m-1-i), a.getcolumn(i, i+1, m-1));
generatereflection(t, m-1-i, ltau);
tauq(i) = ltau;
ap::vmove(a.getcolumn(i, i+1, m-1), t.getvector(1, m-1-i));
t(1) = 1;
//
// Apply H(i) to A(i+1:m-1,i+1:n-1) from the left
//
applyreflectionfromtheleft(a, ltau, t, i+1, m-1, i+1, n-1, work);
}
else
{
tauq(i) = 0;
}
}
}
}
/*************************************************************************
Internal working subroutine for bidiagonal decomposition
*************************************************************************/
bool bidiagonalsvddecompositioninternal(ap::real_1d_array& d,
ap::real_1d_array e,
int n,
bool isupper,
bool isfractionalaccuracyrequired,
ap::real_2d_array& u,
int ustart,
int nru,
ap::real_2d_array& c,
int cstart,
int ncc,
ap::real_2d_array& vt,
int vstart,
int ncvt)
{
bool result;
int i;
int idir;
int isub;
int iter;
int j;
int ll = 0; // Eliminate compiler warning.
int lll;
int m;
int maxit;
int oldll;
int oldm;
double abse;
double abss;
double cosl;
double cosr;
double cs;
double eps;
double f;
double g;
double h;
double mu;
double oldcs;
double oldsn = 0.; // Eliminate compiler warning.
double r;
double shift;
double sigmn;
double sigmx;
double sinl;
double sinr;
double sll;
double smax;
double smin;
double sminl;
double sminoa;
double sn;
double thresh;
double tol;
double tolmul;
double unfl;
ap::real_1d_array work0;
ap::real_1d_array work1;
ap::real_1d_array work2;
ap::real_1d_array work3;
int maxitr;
bool matrixsplitflag;
bool iterflag;
ap::real_1d_array utemp;
ap::real_1d_array vttemp;
ap::real_1d_array ctemp;
ap::real_1d_array etemp;
bool fwddir;
double tmp;
int mm1;
int mm0;
bool bchangedir;
int uend;
int cend;
int vend;
result = true;
if( n==0 )
{
return result;
}
if( n==1 )
{
if( d(1)<0 )
{
d(1) = -d(1);
if( ncvt>0 )
{
ap::vmul(&vt(vstart, vstart), ap::vlen(vstart,vstart+ncvt-1), -1);
}
}
return result;
}
//
// init
//
work0.setbounds(1, n-1);
work1.setbounds(1, n-1);
work2.setbounds(1, n-1);
work3.setbounds(1, n-1);
uend = ustart+ap::maxint(nru-1, 0);
vend = vstart+ap::maxint(ncvt-1, 0);
cend = cstart+ap::maxint(ncc-1, 0);
utemp.setbounds(ustart, uend);
vttemp.setbounds(vstart, vend);
ctemp.setbounds(cstart, cend);
maxitr = 12;
fwddir = true;
//
// resize E from N-1 to N
//
etemp.setbounds(1, n);
for(i = 1; i <= n-1; i++)
{
etemp(i) = e(i);
}
e.setbounds(1, n);
for(i = 1; i <= n-1; i++)
{
e(i) = etemp(i);
}
e(n) = 0;
idir = 0;
//
// Get machine constants
//
eps = ap::machineepsilon;
unfl = ap::minrealnumber;
//
// If matrix lower bidiagonal, rotate to be upper bidiagonal
// by applying Givens rotations on the left
//
if( !isupper )
{
for(i = 1; i <= n-1; i++)
{
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 )
{
applyrotationsfromtheright(fwddir, ustart, uend, 1+ustart-1, n+ustart-1, work0, work1, u, utemp);
}
if( ncc>0 )
{
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 = ap::maxreal(double(10), ap::minreal(double(100), pow(eps, -0.125)));
tol = tolmul*eps;
if( !isfractionalaccuracyrequired )
{
tol = -tol;
}
//
// Compute approximate maximum, minimum singular values
//
smax = 0;
for(i = 1; i <= n; i++)
{
smax = ap::maxreal(smax, fabs(d(i)));
}
for(i = 1; i <= n-1; i++)
{
smax = ap::maxreal(smax, fabs(e(i)));
}
sminl = 0;
if( tol>=0 )
{
//
// Relative accuracy desired
//
sminoa = fabs(d(1));
if( sminoa!=0 )
{
mu = sminoa;
for(i = 2; i <= n; i++)
{
mu = fabs(d(i))*(mu/(mu+fabs(e(i-1))));
sminoa = ap::minreal(sminoa, mu);
if( sminoa==0 )
{
break;
}
}
}
sminoa = sminoa/sqrt(double(n));
thresh = ap::maxreal(tol*sminoa, maxitr*n*n*unfl);
}
else
{
//
// Absolute accuracy desired
//
thresh = ap::maxreal(fabs(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;
}
if( iter>maxit )
{
result = false;
return result;
}
//
// Find diagonal block of matrix to work on
//
if( tol<0&&fabs(d(m))<=thresh )
{
d(m) = 0;
}
smax = fabs(d(m));
smin = smax;
matrixsplitflag = false;
for(lll = 1; lll <= m-1; lll++)
{
ll = m-lll;
abss = fabs(d(ll));
abse = fabs(e(ll));
if( tol<0&&abss<=thresh )
{
d(ll) = 0;
}
if( abse<=thresh )
{
matrixsplitflag = true;
break;
}
smin = ap::minreal(smin, abss);
smax = ap::maxreal(smax, ap::maxreal(abss, abse));
}
if( !matrixsplitflag )
{
ll = 0;
}
else
{
//
// Matrix splits since E(LL) = 0
//
e(ll) = 0;
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);
ap::vmove(&vttemp(vstart), &vt(mm1, vstart), ap::vlen(vstart,vend), cosr);
ap::vadd(&vttemp(vstart), &vt(mm0, vstart), ap::vlen(vstart,vend), sinr);
ap::vmul(&vt(mm0, vstart), ap::vlen(vstart,vend), cosr);
ap::vsub(&vt(mm0, vstart), &vt(mm1, vstart), ap::vlen(vstart,vend), sinr);
ap::vmove(&vt(mm1, vstart), &vttemp(vstart), ap::vlen(vstart,vend));
}
if( nru>0 )
{
mm0 = m+ustart-1;
mm1 = m-1+ustart-1;
ap::vmove(utemp.getvector(ustart, uend), u.getcolumn(mm1, ustart, uend), cosl);
ap::vadd(utemp.getvector(ustart, uend), u.getcolumn(mm0, ustart, uend), sinl);
ap::vmul(u.getcolumn(mm0, ustart, uend), cosl);
ap::vsub(u.getcolumn(mm0, ustart, uend), u.getcolumn(mm1, ustart, uend), sinl);
ap::vmove(u.getcolumn(mm1, ustart, uend), utemp.getvector(ustart, uend));
}
if( ncc>0 )
{
mm0 = m+cstart-1;
mm1 = m-1+cstart-1;
ap::vmove(&ctemp(cstart), &c(mm1, cstart), ap::vlen(cstart,cend), cosl);
ap::vadd(&ctemp(cstart), &c(mm0, cstart), ap::vlen(cstart,cend), sinl);
ap::vmul(&c(mm0, cstart), ap::vlen(cstart,cend), cosl);
ap::vsub(&c(mm0, cstart), &c(mm1, cstart), ap::vlen(cstart,cend), sinl);
ap::vmove(&c(mm1, cstart), &ctemp(cstart), ap::vlen(cstart,cend));
}
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 < *****@*****.** >
// Very strange that LAPACK still contains it.
//
bchangedir = false;
if( idir==1&&fabs(d(ll))<1.0E-3*fabs(d(m)) )
{
bchangedir = true;
}
if( idir==2&&fabs(d(m))<1.0E-3*fabs(d(ll)) )
{
bchangedir = true;
}
if( ll!=oldll||m!=oldm||bchangedir )
{
if( fabs(d(ll))>=fabs(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( (fabs(e(m-1))<=fabs(tol)*fabs(d(m)))||(tol<0&&fabs(e(m-1))<=thresh) )
{
e(m-1) = 0;
continue;
}
if( tol>=0 )
{
//
// If relative accuracy desired,
// apply convergence criterion forward
//
mu = fabs(d(ll));
sminl = mu;
iterflag = false;
for(lll = ll; lll <= m-1; lll++)
{
if( fabs(e(lll))<=tol*mu )
{
e(lll) = 0;
iterflag = true;
break;
}
mu = fabs(d(lll+1))*(mu/(mu+fabs(e(lll))));
sminl = ap::minreal(sminl, mu);
}
if( iterflag )
{
continue;
}
}
}
else
{
//
// Run convergence test in backward direction
// First apply standard test to top of matrix
//
if( (fabs(e(ll))<=fabs(tol)*fabs(d(ll)))||(tol<0&&fabs(e(ll))<=thresh) )
{
e(ll) = 0;
continue;
}
if( tol>=0 )
{
//
// If relative accuracy desired,
// apply convergence criterion backward
//
mu = fabs(d(m));
sminl = mu;
iterflag = false;
for(lll = m-1; lll >= ll; lll--)
{
if( fabs(e(lll))<=tol*mu )
{
e(lll) = 0;
iterflag = true;
break;
}
mu = fabs(d(lll))*(mu/(mu+fabs(e(lll))));
sminl = ap::minreal(sminl, mu);
}
if( iterflag )
{
continue;
}
}
}
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&&n*tol*(sminl/smax)<=ap::maxreal(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 = fabs(d(ll));
svd2x2(d(m-1), e(m-1), d(m), shift, r);
}
else
{
sll = fabs(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 )
{
if( ap::sqr(shift/sll)<eps )
{
shift = 0;
}
}
}
//
// Increment iteration count
//
iter = iter+m-ll;
//
// If SHIFT = 0, do simplified QR iteration
//
if( shift==0 )
{
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-1; i++)
{
generaterotation(d(i)*cs, e(i), cs, sn, r);
if( i>ll )
{
e(i-1) = oldsn*r;
}
generaterotation(oldcs*r, d(i+1)*sn, oldcs, oldsn, tmp);
d(i) = tmp;
work0(i-ll+1) = cs;
work1(i-ll+1) = sn;
work2(i-ll+1) = oldcs;
work3(i-ll+1) = oldsn;
}
h = d(m)*cs;
d(m) = h*oldcs;
e(m-1) = h*oldsn;
//
// Update singular vectors
//
if( ncvt>0 )
{
applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, work0, work1, vt, vttemp);
}
if( nru>0 )
{
applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, work2, work3, u, utemp);
}
if( ncc>0 )
{
applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, work2, work3, c, ctemp);
}
//
// Test convergence
//
if( fabs(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--)
{
generaterotation(d(i)*cs, e(i-1), cs, sn, r);
if( i<m )
{
e(i) = oldsn*r;
}
generaterotation(oldcs*r, d(i-1)*sn, oldcs, oldsn, tmp);
d(i) = tmp;
work0(i-ll) = cs;
work1(i-ll) = -sn;
work2(i-ll) = oldcs;
work3(i-ll) = -oldsn;
}
h = d(ll)*cs;
d(ll) = h*oldcs;
e(ll) = h*oldsn;
//
// Update singular vectors
//
if( ncvt>0 )
{
applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, work2, work3, vt, vttemp);
}
if( nru>0 )
{
applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, work0, work1, u, utemp);
}
if( ncc>0 )
{
applyrotationsfromtheleft(!fwddir, ll+cstart-1, m+cstart-1, cstart, cend, work0, work1, c, ctemp);
}
//
// Test convergence
//
if( fabs(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 = (fabs(d(ll))-shift)*(extsignbdsqr(double(1), d(ll))+shift/d(ll));
g = e(ll);
for(i = ll; i <= m-1; i++)
{
generaterotation(f, g, cosr, sinr, r);
if( i>ll )
{
e(i-1) = r;
}
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);
generaterotation(f, g, cosl, sinl, r);
d(i) = r;
f = cosl*e(i)+sinl*d(i+1);
d(i+1) = cosl*d(i+1)-sinl*e(i);
if( i<m-1 )
{
g = sinl*e(i+1);
e(i+1) = cosl*e(i+1);
}
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 )
{
applyrotationsfromtheleft(fwddir, ll+vstart-1, m+vstart-1, vstart, vend, work0, work1, vt, vttemp);
}
if( nru>0 )
{
applyrotationsfromtheright(fwddir, ustart, uend, ll+ustart-1, m+ustart-1, work2, work3, u, utemp);
}
if( ncc>0 )
{
applyrotationsfromtheleft(fwddir, ll+cstart-1, m+cstart-1, cstart, cend, work2, work3, c, ctemp);
}
//
// Test convergence
//
if( fabs(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 = (fabs(d(m))-shift)*(extsignbdsqr(double(1), d(m))+shift/d(m));
g = e(m-1);
for(i = m; i >= ll+1; i--)
{
generaterotation(f, g, cosr, sinr, r);
if( i<m )
{
e(i) = r;
}
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);
generaterotation(f, g, cosl, sinl, r);
d(i) = r;
f = cosl*e(i-1)+sinl*d(i-1);
d(i-1) = cosl*d(i-1)-sinl*e(i-1);
if( i>ll+1 )
{
g = sinl*e(i-2);
e(i-2) = cosl*e(i-2);
}
work0(i-ll) = cosr;
work1(i-ll) = -sinr;
work2(i-ll) = cosl;
work3(i-ll) = -sinl;
}
e(ll) = f;
//
// Test convergence
//
if( fabs(e(ll))<=thresh )
{
e(ll) = 0;
}
//
// Update singular vectors if desired
//
if( ncvt>0 )
{
applyrotationsfromtheleft(!fwddir, ll+vstart-1, m+vstart-1, vstart, vend, work2, work3, vt, vttemp);
}
if( nru>0 )
{
applyrotationsfromtheright(!fwddir, ustart, uend, ll+ustart-1, m+ustart-1, work0, work1, u, utemp);
}
if( ncc>0 )
{
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++)
{
if( d(i)<0 )
{
d(i) = -d(i);
//
// Change sign of singular vectors, if desired
//
if( ncvt>0 )
{
ap::vmul(&vt(i+vstart-1, vstart), ap::vlen(vstart,vend), -1);
}
}
}
//
// Sort the singular values into decreasing order (insertion sort on
// singular values, but only one transposition per singular vector)
//
for(i = 1; i <= n-1; i++)
{
//
// Scan for smallest D(I)
//
isub = 1;
smin = d(1);
for(j = 2; j <= n+1-i; j++)
{
if( d(j)<=smin )
{
isub = j;
smin = d(j);
}
}
if( isub!=n+1-i )
{
//
// Swap singular values and vectors
//
d(isub) = d(n+1-i);
d(n+1-i) = smin;
if( ncvt>0 )
{
j = n+1-i;
ap::vmove(&vttemp(vstart), &vt(isub+vstart-1, vstart), ap::vlen(vstart,vend));
ap::vmove(&vt(isub+vstart-1, vstart), &vt(j+vstart-1, vstart), ap::vlen(vstart,vend));
ap::vmove(&vt(j+vstart-1, vstart), &vttemp(vstart), ap::vlen(vstart,vend));
}
if( nru>0 )
{
j = n+1-i;
ap::vmove(utemp.getvector(ustart, uend), u.getcolumn(isub+ustart-1, ustart, uend));
ap::vmove(u.getcolumn(isub+ustart-1, ustart, uend), u.getcolumn(j+ustart-1, ustart, uend));
ap::vmove(u.getcolumn(j+ustart-1, ustart, uend), utemp.getvector(ustart, uend));
}
if( ncc>0 )
{
j = n+1-i;
ap::vmove(&ctemp(cstart), &c(isub+cstart-1, cstart), ap::vlen(cstart,cend));
ap::vmove(&c(isub+cstart-1, cstart), &c(j+cstart-1, cstart), ap::vlen(cstart,cend));
ap::vmove(&c(j+cstart-1, cstart), &ctemp(cstart), ap::vlen(cstart,cend));
}
}
}
return result;
}
bool obsoletesvddecomposition(ap::real_2d_array& a,
int m,
int n,
ap::real_1d_array& w,
ap::real_2d_array& v)
{
bool result;
int nm;
int minmn;
int l;
int k;
int j;
int jj;
int its;
int i;
double z;
double y;
double x;
double vscale;
double s;
double h;
double g;
double f;
double c;
double anorm;
ap::real_1d_array rv1;
bool flag;
rv1.setbounds(1, n);
w.setbounds(1, n);
v.setbounds(1, n, 1, n);
result = true;
if( m<n )
{
minmn = m;
}
else
{
minmn = n;
}
g = 0.0;
vscale = 0.0;
anorm = 0.0;
for(i = 1; i <= n; i++)
{
l = i+1;
rv1(i) = vscale*g;
g = 0;
s = 0;
vscale = 0;
if( i<=m )
{
for(k = i; k <= m; k++)
{
vscale = vscale+fabs(a(k,i));
}
if( ap::fp_neq(vscale,0.0) )
{
for(k = i; k <= m; k++)
{
a(k,i) = a(k,i)/vscale;
s = s+a(k,i)*a(k,i);
}
f = a(i,i);
g = -extsign(sqrt(s), f);
h = f*g-s;
a(i,i) = f-g;
if( i!=n )
{
for(j = l; j <= n; j++)
{
s = 0.0;
for(k = i; k <= m; k++)
{
s = s+a(k,i)*a(k,j);
}
f = s/h;
for(k = i; k <= m; k++)
{
a(k,j) = a(k,j)+f*a(k,i);
}
}
}
for(k = i; k <= m; k++)
{
a(k,i) = vscale*a(k,i);
}
}
}
w(i) = vscale*g;
g = 0.0;
s = 0.0;
vscale = 0.0;
if( i<=m&&i!=n )
{
for(k = l; k <= n; k++)
{
vscale = vscale+fabs(a(i,k));
}
if( ap::fp_neq(vscale,0.0) )
{
for(k = l; k <= n; k++)
{
a(i,k) = a(i,k)/vscale;
s = s+a(i,k)*a(i,k);
}
f = a(i,l);
g = -extsign(sqrt(s), f);
h = f*g-s;
a(i,l) = f-g;
for(k = l; k <= n; k++)
{
rv1(k) = a(i,k)/h;
}
if( i!=m )
{
for(j = l; j <= m; j++)
{
s = 0.0;
for(k = l; k <= n; k++)
{
s = s+a(j,k)*a(i,k);
}
for(k = l; k <= n; k++)
{
a(j,k) = a(j,k)+s*rv1(k);
}
}
}
for(k = l; k <= n; k++)
{
a(i,k) = vscale*a(i,k);
}
}
}
anorm = mymax(anorm, fabs(w(i))+fabs(rv1(i)));
}
for(i = n; i >= 1; i--)
{
if( i<n )
{
if( ap::fp_neq(g,0.0) )
{
for(j = l; j <= n; j++)
{
v(j,i) = a(i,j)/a(i,l)/g;
}
for(j = l; j <= n; j++)
{
s = 0.0;
for(k = l; k <= n; k++)
{
s = s+a(i,k)*v(k,j);
}
for(k = l; k <= n; k++)
{
v(k,j) = v(k,j)+s*v(k,i);
}
}
}
for(j = l; j <= n; j++)
{
v(i,j) = 0.0;
v(j,i) = 0.0;
}
}
v(i,i) = 1.0;
g = rv1(i);
l = i;
}
for(i = minmn; i >= 1; i--)
{
l = i+1;
g = w(i);
if( i<n )
{
for(j = l; j <= n; j++)
{
a(i,j) = 0.0;
}
}
if( ap::fp_neq(g,0.0) )
{
g = 1.0/g;
if( i!=n )
{
for(j = l; j <= n; j++)
{
s = 0.0;
for(k = l; k <= m; k++)
{
s = s+a(k,i)*a(k,j);
}
f = s/a(i,i)*g;
for(k = i; k <= m; k++)
{
a(k,j) = a(k,j)+f*a(k,i);
}
}
}
for(j = i; j <= m; j++)
{
a(j,i) = a(j,i)*g;
}
}
else
{
for(j = i; j <= m; j++)
{
a(j,i) = 0.0;
}
}
a(i,i) = a(i,i)+1.0;
}
for(k = n; k >= 1; k--)
{
for(its = 1; its <= maxsvditerations; its++)
{
flag = true;
for(l = k; l >= 1; l--)
{
nm = l-1;
if( ap::fp_eq(fabs(rv1(l))+anorm,anorm) )
{
flag = false;
break;
}
if( ap::fp_eq(fabs(w(nm))+anorm,anorm) )
{
break;
}
}
if( flag )
{
c = 0.0;
s = 1.0;
for(i = l; i <= k; i++)
{
f = s*rv1(i);
if( ap::fp_neq(fabs(f)+anorm,anorm) )
{
g = w(i);
h = pythag(f, g);
w(i) = h;
h = 1.0/h;
c = g*h;
s = -f*h;
for(j = 1; j <= m; j++)
{
y = a(j,nm);
z = a(j,i);
a(j,nm) = y*c+z*s;
a(j,i) = -y*s+z*c;
}
}
}
}
z = w(k);
if( l==k )
{
if( ap::fp_less(z,0.0) )
{
w(k) = -z;
for(j = 1; j <= n; j++)
{
v(j,k) = -v(j,k);
}
}
break;
}
if( its==maxsvditerations )
{
result = false;
return result;
}
x = w(l);
nm = k-1;
y = w(nm);
g = rv1(nm);
h = rv1(k);
f = ((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y);
g = pythag(f, double(1));
f = ((x-z)*(x+z)+h*(y/(f+extsign(g, f))-h))/x;
c = 1.0;
s = 1.0;
for(j = l; j <= nm; j++)
{
i = j+1;
g = rv1(i);
y = w(i);
h = s*g;
g = c*g;
z = pythag(f, h);
rv1(j) = z;
c = f/z;
s = h/z;
f = x*c+g*s;
g = -x*s+g*c;
h = y*s;
y = y*c;
for(jj = 1; jj <= n; jj++)
{
x = v(jj,j);
z = v(jj,i);
v(jj,j) = x*c+z*s;
v(jj,i) = -x*s+z*c;
}
z = pythag(f, h);
w(j) = z;
if( ap::fp_neq(z,0.0) )
{
z = 1.0/z;
c = f*z;
s = h*z;
}
f = c*g+s*y;
x = -s*g+c*y;
for(jj = 1; jj <= m; jj++)
{
y = a(jj,j);
z = a(jj,i);
a(jj,j) = y*c+z*s;
a(jj,i) = -y*s+z*c;
}
}
rv1(l) = 0.0;
rv1(k) = f;
w(k) = x;
}
}
return result;
}
/*************************************************************************
Unsets 1D array.
*************************************************************************/
static void unset1d(ap::real_1d_array& a)
{
a.setbounds(0, 0);
a(0) = 2*ap::randomreal()-1;
}
/*************************************************************************
Principal components analysis
Subroutine builds orthogonal basis where first axis corresponds to
direction with maximum variance, second axis maximizes variance in subspace
orthogonal to first axis and so on.
It should be noted that, unlike LDA, PCA does not use class labels.
INPUT PARAMETERS:
X - dataset, array[0..NPoints-1,0..NVars-1].
matrix contains ONLY INDEPENDENT VARIABLES.
NPoints - dataset size, NPoints>=0
NVars - number of independent variables, NVars>=1
бшундмше оюпюлерпш:
Info - return code:
* -4, if SVD subroutine haven't converged
* -1, if wrong parameters has been passed (NPoints<0,
NVars<1)
* 1, if task is solved
S2 - array[0..NVars-1]. variance values corresponding
to basis vectors.
V - array[0..NVars-1,0..NVars-1]
matrix, whose columns store basis vectors.
-- ALGLIB --
Copyright 25.08.2008 by Bochkanov Sergey
*************************************************************************/
void pcabuildbasis(const ap::real_2d_array& x,
int npoints,
int nvars,
int& info,
ap::real_1d_array& s2,
ap::real_2d_array& v)
{
ap::real_2d_array a;
ap::real_2d_array u;
ap::real_2d_array vt;
ap::real_1d_array m;
ap::real_1d_array t;
int i;
int j;
double mean;
double variance;
double skewness;
double kurtosis;
//
// Check input data
//
if( npoints<0||nvars<1 )
{
info = -1;
return;
}
info = 1;
//
// Special case: NPoints=0
//
if( npoints==0 )
{
s2.setbounds(0, nvars-1);
v.setbounds(0, nvars-1, 0, nvars-1);
for(i = 0; i <= nvars-1; i++)
{
s2(i) = 0;
}
for(i = 0; i <= nvars-1; i++)
{
for(j = 0; j <= nvars-1; j++)
{
if( i==j )
{
v(i,j) = 1;
}
else
{
v(i,j) = 0;
}
}
}
return;
}
//
// Calculate means
//
m.setbounds(0, nvars-1);
t.setbounds(0, npoints-1);
for(j = 0; j <= nvars-1; j++)
{
ap::vmove(t.getvector(0, npoints-1), x.getcolumn(j, 0, npoints-1));
calculatemoments(t, npoints, mean, variance, skewness, kurtosis);
m(j) = mean;
}
//
// Center, apply SVD, prepare output
//
a.setbounds(0, ap::maxint(npoints, nvars)-1, 0, nvars-1);
for(i = 0; i <= npoints-1; i++)
{
ap::vmove(&a(i, 0), &x(i, 0), ap::vlen(0,nvars-1));
ap::vsub(&a(i, 0), &m(0), ap::vlen(0,nvars-1));
}
for(i = npoints; i <= nvars-1; i++)
{
for(j = 0; j <= nvars-1; j++)
{
a(i,j) = 0;
}
}
if( !rmatrixsvd(a, ap::maxint(npoints, nvars), nvars, 0, 1, 2, s2, u, vt) )
{
info = -4;
return;
}
if( npoints!=1 )
{
for(i = 0; i <= nvars-1; i++)
{
s2(i) = ap::sqr(s2(i))/(npoints-1);
}
}
v.setbounds(0, nvars-1, 0, nvars-1);
copyandtranspose(vt, 0, nvars-1, 0, nvars-1, v, 0, nvars-1, 0, nvars-1);
}