/*************************************************************************
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;
}
/*************************************************************************
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;
}
}
}
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixBDMultiplyByQ for 0-based replacement.
*************************************************************************/
void multiplybyqfrombidiagonal(const ap::real_2d_array& qp,
int m,
int n,
const ap::real_1d_array& tauq,
ap::real_2d_array& z,
int zrows,
int zcolumns,
bool fromtheright,
bool dotranspose)
{
int i;
int ip1;
int i1;
int i2;
int istep;
ap::real_1d_array v;
ap::real_1d_array work;
int vm;
int mx;
if( m<=0||n<=0||zrows<=0||zcolumns<=0 )
{
return;
}
ap::ap_error::make_assertion((fromtheright&&zcolumns==m)||(!fromtheright&&zrows==m), "MultiplyByQFromBidiagonal: incorrect Z size!");
//
// init
//
mx = ap::maxint(m, n);
mx = ap::maxint(mx, zrows);
mx = ap::maxint(mx, zcolumns);
v.setbounds(1, mx);
work.setbounds(1, mx);
if( m>=n )
{
//
// setup
//
if( fromtheright )
{
i1 = 1;
i2 = n;
istep = +1;
}
else
{
i1 = n;
i2 = 1;
istep = -1;
}
if( dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
i = i1;
do
{
vm = m-i+1;
ap::vmove(v.getvector(1, vm), qp.getcolumn(i, i, m));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, tauq(i), v, 1, zrows, i, m, work);
}
else
{
applyreflectionfromtheleft(z, tauq(i), v, i, m, 1, zcolumns, work);
}
i = i+istep;
}
while(i!=i2+istep);
}
else
{
//
// setup
//
if( fromtheright )
{
i1 = 1;
i2 = m-1;
istep = +1;
}
else
{
i1 = m-1;
i2 = 1;
istep = -1;
}
if( dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
if( m-1>0 )
{
i = i1;
do
{
vm = m-i;
ip1 = i+1;
ap::vmove(v.getvector(1, vm), qp.getcolumn(i, ip1, m));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, tauq(i), v, 1, zrows, i+1, m, work);
}
else
{
applyreflectionfromtheleft(z, tauq(i), v, i+1, m, 1, zcolumns, work);
}
i = i+istep;
}
while(i!=i2+istep);
}
}
}
/*************************************************************************
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 which were made during the LU decomposition
(the output of RMatrixLU subroutine).
N - size of matrix A.
Output parameters:
A - inverse of matrix A.
Array whose indexes range within [0..N-1, 0..N-1].
Result:
True, if the matrix is not singular.
False, if the matrix is singular.
-- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
*************************************************************************/
bool rmatrixluinverse(ap::real_2d_array& a,
const ap::integer_1d_array& pivots,
int n)
{
bool result;
ap::real_1d_array work;
int i;
int iws;
int j;
int jb;
int jj;
int jp;
double v;
result = true;
//
// Quick return if possible
//
if( n==0 )
{
return result;
}
work.setbounds(0, n-1);
//
// Form inv(U)
//
if( !rmatrixtrinverse(a, n, true, false) )
{
result = false;
return result;
}
//
// 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-1; i++)
{
work(i) = a(i,j);
a(i,j) = 0;
}
//
// Compute current column of inv(A).
//
if( j<n-1 )
{
for(i = 0; i <= n-1; i++)
{
v = ap::vdotproduct(&a(i, j+1), &work(j+1), ap::vlen(j+1,n-1));
a(i,j) = a(i,j)-v;
}
}
}
//
// Apply column interchanges.
//
for(j = n-2; j >= 0; j--)
{
jp = pivots(j);
if( jp!=j )
{
ap::vmove(work.getvector(0, n-1), a.getcolumn(j, 0, n-1));
ap::vmove(a.getcolumn(j, 0, n-1), a.getcolumn(jp, 0, n-1));
ap::vmove(a.getcolumn(jp, 0, n-1), work.getvector(0, n-1));
}
}
return result;
}
/*************************************************************************
Matrix multiplication
*************************************************************************/
static void internalmatrixmatrixmultiply(const ap::real_2d_array& a,
int ai1,
int ai2,
int aj1,
int aj2,
bool transa,
const ap::real_2d_array& b,
int bi1,
int bi2,
int bj1,
int bj2,
bool transb,
ap::real_2d_array& c,
int ci1,
int ci2,
int cj1,
int cj2)
{
int arows;
int acols;
int brows;
int bcols;
int crows;
int ccols;
int i;
int j;
int k;
int l;
int r;
double v;
ap::real_1d_array work;
double beta;
double alpha;
//
// Pre-setup
//
k = ap::maxint(ai2-ai1+1, aj2-aj1+1);
k = ap::maxint(k, bi2-bi1+1);
k = ap::maxint(k, bj2-bj1+1);
work.setbounds(1, k);
beta = 0;
alpha = 1;
//
// Setup
//
if( !transa )
{
arows = ai2-ai1+1;
acols = aj2-aj1+1;
}
else
{
arows = aj2-aj1+1;
acols = ai2-ai1+1;
}
if( !transb )
{
brows = bi2-bi1+1;
bcols = bj2-bj1+1;
}
else
{
brows = bj2-bj1+1;
bcols = bi2-bi1+1;
}
ap::ap_error::make_assertion(acols==brows, "MatrixMatrixMultiply: incorrect matrix sizes!");
if( arows<=0||acols<=0||brows<=0||bcols<=0 )
{
return;
}
crows = arows;
ccols = bcols;
//
// Test WORK
//
i = ap::maxint(arows, acols);
i = ap::maxint(brows, i);
i = ap::maxint(i, bcols);
work(1) = 0;
work(i) = 0;
//
// Prepare C
//
if( beta==0 )
{
for(i = ci1; i <= ci2; i++)
{
for(j = cj1; j <= cj2; j++)
{
c(i,j) = 0;
}
}
}
else
{
for(i = ci1; i <= ci2; i++)
{
ap::vmul(&c(i, cj1), ap::vlen(cj1,cj2), beta);
}
}
//
// A*B
//
if( !transa&&!transb )
{
for(l = ai1; l <= ai2; l++)
{
for(r = bi1; r <= bi2; r++)
{
v = alpha*a(l,aj1+r-bi1);
k = ci1+l-ai1;
ap::vadd(&c(k, cj1), &b(r, bj1), ap::vlen(cj1,cj2), v);
}
}
return;
}
//
// A*B'
//
if( !transa&&transb )
{
if( arows*acols<brows*bcols )
{
for(r = bi1; r <= bi2; r++)
{
for(l = ai1; l <= ai2; l++)
{
v = ap::vdotproduct(&a(l, aj1), &b(r, bj1), ap::vlen(aj1,aj2));
c(ci1+l-ai1,cj1+r-bi1) = c(ci1+l-ai1,cj1+r-bi1)+alpha*v;
}
}
return;
}
else
{
for(l = ai1; l <= ai2; l++)
{
for(r = bi1; r <= bi2; r++)
{
v = ap::vdotproduct(&a(l, aj1), &b(r, bj1), ap::vlen(aj1,aj2));
c(ci1+l-ai1,cj1+r-bi1) = c(ci1+l-ai1,cj1+r-bi1)+alpha*v;
}
}
return;
}
}
//
// A'*B
//
if( transa&&!transb )
{
for(l = aj1; l <= aj2; l++)
{
for(r = bi1; r <= bi2; r++)
{
v = alpha*a(ai1+r-bi1,l);
k = ci1+l-aj1;
ap::vadd(&c(k, cj1), &b(r, bj1), ap::vlen(cj1,cj2), v);
}
}
return;
}
//
// A'*B'
//
if( transa&&transb )
{
if( arows*acols<brows*bcols )
{
for(r = bi1; r <= bi2; r++)
{
for(i = 1; i <= crows; i++)
{
work(i) = 0.0;
}
for(l = ai1; l <= ai2; l++)
{
v = alpha*b(r,bj1+l-ai1);
k = cj1+r-bi1;
ap::vadd(&work(1), &a(l, aj1), ap::vlen(1,crows), v);
}
ap::vadd(c.getcolumn(k, ci1, ci2), work.getvector(1, crows));
}
return;
}
else
{
for(l = aj1; l <= aj2; l++)
{
k = ai2-ai1+1;
ap::vmove(work.getvector(1, k), a.getcolumn(l, ai1, ai2));
for(r = bi1; r <= bi2; r++)
{
v = ap::vdotproduct(&work(1), &b(r, bj1), ap::vlen(1,k));
c(ci1+l-aj1,cj1+r-bi1) = c(ci1+l-aj1,cj1+r-bi1)+alpha*v;
}
}
return;
}
}
}
/*************************************************************************
Dense solver.
This subroutine solves a system A*X=B, where A is NxN non-denegerate
real matrix, X and B are NxM real matrices.
Additional features include:
* automatic detection of degenerate cases
* iterative improvement
INPUT PARAMETERS
A - array[0..N-1,0..N-1], system matrix
N - size of A
B - array[0..N-1,0..M-1], right part
M - size of right part
OUTPUT PARAMETERS
Info - return code:
* -3 if A is singular, or VERY close to singular.
X is filled by zeros in such cases.
* -1 if N<=0 or M<=0 was passed
* 1 if task is solved (matrix A may be near singular,
check R1/RInf parameters for condition numbers).
Rep - solver report, see below for more info
X - array[0..N-1,0..M-1], it contains:
* solution of A*X=B if A is non-singular (well-conditioned
or ill-conditioned, but not very close to singular)
* zeros, if A is singular or VERY close to singular
(in this case Info=-3).
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.
SEE ALSO:
DenseSolverR() - solves A*x = b, where x and b are Nx1 matrices.
-- ALGLIB --
Copyright 24.08.2009 by Bochkanov Sergey
*************************************************************************/
void rmatrixsolvem(const ap::real_2d_array& a,
int n,
const ap::real_2d_array& b,
int m,
int& info,
densesolverreport& rep,
ap::real_2d_array& x)
{
int i;
int j;
int k;
int rfs;
int nrfs;
ap::integer_1d_array p;
ap::real_1d_array xc;
ap::real_1d_array y;
ap::real_1d_array bc;
ap::real_1d_array xa;
ap::real_1d_array xb;
ap::real_1d_array tx;
ap::real_2d_array da;
double v;
double verr;
bool smallerr;
bool terminatenexttime;
//
// prepare: check inputs, allocate space...
//
if( n<=0||m<=0 )
{
info = -1;
return;
}
da.setlength(n, n);
x.setlength(n, m);
y.setlength(n);
xc.setlength(n);
bc.setlength(n);
tx.setlength(n+1);
xa.setlength(n+1);
xb.setlength(n+1);
//
// factorize matrix, test for exact/near singularity
//
for(i = 0; i <= n-1; i++)
{
ap::vmove(&da(i, 0), &a(i, 0), ap::vlen(0,n-1));
}
rmatrixlu(da, n, n, p);
rep.r1 = rmatrixlurcond1(da, n);
rep.rinf = rmatrixlurcondinf(da, n);
if( ap::fp_less(rep.r1,10*ap::machineepsilon)||ap::fp_less(rep.rinf,10*ap::machineepsilon) )
{
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= m-1; j++)
{
x(i,j) = 0;
}
}
rep.r1 = 0;
rep.rinf = 0;
info = -3;
return;
}
info = 1;
//
// solve
//
for(k = 0; k <= m-1; k++)
{
//
// First, non-iterative part of solution process:
// * pivots
// * L*y = b
// * U*x = y
//
ap::vmove(bc.getvector(0, n-1), b.getcolumn(k, 0, n-1));
for(i = 0; i <= n-1; i++)
{
if( p(i)!=i )
{
v = bc(i);
bc(i) = bc(p(i));
bc(p(i)) = v;
}
}
y(0) = bc(0);
for(i = 1; i <= n-1; i++)
{
v = ap::vdotproduct(&da(i, 0), &y(0), ap::vlen(0,i-1));
y(i) = bc(i)-v;
}
xc(n-1) = y(n-1)/da(n-1,n-1);
for(i = n-2; i >= 0; i--)
{
v = ap::vdotproduct(&da(i, i+1), &xc(i+1), ap::vlen(i+1,n-1));
xc(i) = (y(i)-v)/da(i,i);
}
//
// Iterative improvement of xc:
// * calculate r = bc-A*xc using extra-precise dot product
// * solve A*y = r
// * update x:=x+r
//
// This cycle is executed until one of two things happens:
// 1. maximum number of iterations reached
// 2. last iteration decreased error to the lower limit
//
nrfs = densesolverrfsmax(n, rep.r1, rep.rinf);
terminatenexttime = false;
for(rfs = 0; rfs <= nrfs-1; rfs++)
{
if( terminatenexttime )
{
break;
}
//
// generate right part
//
smallerr = true;
for(i = 0; i <= n-1; i++)
{
ap::vmove(&xa(0), &a(i, 0), ap::vlen(0,n-1));
xa(n) = -1;
ap::vmove(&xb(0), &xc(0), ap::vlen(0,n-1));
xb(n) = b(i,k);
xdot(xa, xb, n+1, tx, v, verr);
bc(i) = -v;
smallerr = smallerr&&ap::fp_less(fabs(v),4*verr);
}
if( smallerr )
{
terminatenexttime = true;
}
//
// solve
//
for(i = 0; i <= n-1; i++)
{
if( p(i)!=i )
{
v = bc(i);
bc(i) = bc(p(i));
bc(p(i)) = v;
}
}
y(0) = bc(0);
for(i = 1; i <= n-1; i++)
{
v = ap::vdotproduct(&da(i, 0), &y(0), ap::vlen(0,i-1));
y(i) = bc(i)-v;
}
tx(n-1) = y(n-1)/da(n-1,n-1);
for(i = n-2; i >= 0; i--)
{
v = ap::vdotproduct(&da(i, i+1), &tx(i+1), ap::vlen(i+1,n-1));
tx(i) = (y(i)-v)/da(i,i);
}
//
// update
//
ap::vadd(&xc(0), &tx(0), ap::vlen(0,n-1));
}
//
// Store xc
//
ap::vmove(x.getcolumn(k, 0, n-1), xc.getvector(0, n-1));
}
}
/*************************************************************************
Obsolete 1-based subroutine.
*************************************************************************/
bool choleskydecomposition(ap::real_2d_array& a, int n, bool isupper)
{
bool result;
int i;
int j;
double ajj;
double v;
int jm1;
int jp1;
//
// Test the input parameters.
//
ap::ap_error::make_assertion(n>=0, "Error in CholeskyDecomposition: incorrect function arguments");
//
// Quick return if possible
//
result = true;
if( n==0 )
{
return result;
}
if( isupper )
{
//
// Compute the Cholesky factorization A = U'*U.
//
for(j = 1; j <= n; j++)
{
//
// Compute U(J,J) and test for non-positive-definiteness.
//
jm1 = j-1;
v = ap::vdotproduct(a.getcolumn(j, 1, jm1), a.getcolumn(j, 1, jm1));
ajj = a(j,j)-v;
if( ajj<=0 )
{
result = false;
return result;
}
ajj = sqrt(ajj);
a(j,j) = ajj;
//
// Compute elements J+1:N of row J.
//
if( j<n )
{
for(i = j+1; i <= n; i++)
{
jm1 = j-1;
v = ap::vdotproduct(a.getcolumn(i, 1, jm1), a.getcolumn(j, 1, jm1));
a(j,i) = a(j,i)-v;
}
v = 1/ajj;
jp1 = j+1;
ap::vmul(&a(j, jp1), ap::vlen(jp1,n), v);
}
}
}
else
{
//
// Compute the Cholesky factorization A = L*L'.
//
for(j = 1; j <= n; j++)
{
//
// Compute L(J,J) and test for non-positive-definiteness.
//
jm1 = j-1;
v = ap::vdotproduct(&a(j, 1), &a(j, 1), ap::vlen(1,jm1));
ajj = a(j,j)-v;
if( ajj<=0 )
{
result = false;
return result;
}
ajj = sqrt(ajj);
a(j,j) = ajj;
//
// Compute elements J+1:N of column J.
//
if( j<n )
{
for(i = j+1; i <= n; i++)
{
jm1 = j-1;
v = ap::vdotproduct(&a(i, 1), &a(j, 1), ap::vlen(1,jm1));
a(i,j) = a(i,j)-v;
}
v = 1/ajj;
jp1 = j+1;
ap::vmul(a.getcolumn(j, jp1, n), v);
}
}
}
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);
}
}
/*************************************************************************
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].
-- ALGLIB --
Copyright 2005-2008 by Bochkanov Sergey
*************************************************************************/
void smatrixtdunpackq(const ap::real_2d_array& a,
const int& n,
const bool& isupper,
const ap::real_1d_array& tau,
ap::real_2d_array& q)
{
int i;
int j;
ap::real_1d_array v;
ap::real_1d_array work;
if( n==0 )
{
return;
}
//
// init
//
q.setbounds(0, n-1, 0, n-1);
v.setbounds(1, n);
work.setbounds(0, n-1);
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= n-1; j++)
{
if( i==j )
{
q(i,j) = 1;
}
else
{
q(i,j) = 0;
}
}
}
//
// unpack Q
//
if( isupper )
{
for(i = 0; i <= n-2; i++)
{
//
// Apply H(i)
//
ap::vmove(v.getvector(1, i+1), a.getcolumn(i+1, 0, i));
v(i+1) = 1;
applyreflectionfromtheleft(q, tau(i), v, 0, i, 0, n-1, work);
}
}
else
{
for(i = n-2; i >= 0; i--)
{
//
// Apply H(i)
//
ap::vmove(v.getvector(1, n-i-1), a.getcolumn(i, i+1, n-1));
v(1) = 1;
applyreflectionfromtheleft(q, tau(i), v, i+1, n-1, 0, n-1, work);
}
}
}
/*************************************************************************
Solving a system of linear equations with a system matrix given by its
Cholesky decomposition.
The algorithm solves systems with a square matrix only.
Input parameters:
A - Cholesky decomposition of a system matrix (the result of
the SMatrixCholesky subroutine).
B - right side of a system.
Array whose index ranges within [0..N-1].
N - size of matrix A.
IsUpper - points to the triangle of matrix A in which the Cholesky
decomposition is stored. If IsUpper=True, the Cholesky
decomposition has the form of U'*U, and the upper triangle
of matrix A stores matrix U (in that case, the lower
triangle isn’t used and isn’t changed by the subroutine)
Similarly, if IsUpper = False, the Cholesky decomposition
has the form of L*L', and the lower triangle stores
matrix L.
Output parameters:
X - solution of a system.
Array whose index ranges within [0..N-1].
Result:
True, if the system is not singular. X contains the solution.
False, if the system is singular (there is a zero element on the main
diagonal). In this case, X doesn't contain a solution.
-- ALGLIB --
Copyright 2005-2008 by Bochkanov Sergey
*************************************************************************/
bool spdmatrixcholeskysolve(const ap::real_2d_array& a,
ap::real_1d_array b,
int n,
bool isupper,
ap::real_1d_array& x)
{
bool result;
int i;
double v;
ap::ap_error::make_assertion(n>0, "Error: N<=0 in SolveSystemCholesky");
//
// det(A)=0?
//
result = true;
for(i = 0; i <= n-1; i++)
{
if( ap::fp_eq(a(i,i),0) )
{
result = false;
return result;
}
}
//
// det(A)<>0
//
x.setbounds(0, n-1);
if( isupper )
{
//
// A = U'*U, solve U'*y = b first
//
b(0) = b(0)/a(0,0);
for(i = 1; i <= n-1; i++)
{
v = ap::vdotproduct(a.getcolumn(i, 0, i-1), b.getvector(0, i-1));
b(i) = (b(i)-v)/a(i,i);
}
//
// Solve U*x = y
//
b(n-1) = b(n-1)/a(n-1,n-1);
for(i = n-2; i >= 0; i--)
{
v = ap::vdotproduct(&a(i, i+1), &b(i+1), ap::vlen(i+1,n-1));
b(i) = (b(i)-v)/a(i,i);
}
ap::vmove(&x(0), &b(0), ap::vlen(0,n-1));
}
else
{
//
// A = L*L', solve L'*y = b first
//
b(0) = b(0)/a(0,0);
for(i = 1; i <= n-1; i++)
{
v = ap::vdotproduct(&a(i, 0), &b(0), ap::vlen(0,i-1));
b(i) = (b(i)-v)/a(i,i);
}
//
// Solve L'*x = y
//
b(n-1) = b(n-1)/a(n-1,n-1);
for(i = n-2; i >= 0; i--)
{
v = ap::vdotproduct(a.getcolumn(i, i+1, n-1), b.getvector(i+1, n-1));
b(i) = (b(i)-v)/a(i,i);
}
ap::vmove(&x(0), &b(0), ap::vlen(0,n-1));
}
return result;
}
/*************************************************************************
Обращение треугольной матрицы
Подпрограмма обращает следующие типы матриц:
* верхнетреугольные
* верхнетреугольные с единичной диагональю
* нижнетреугольные
* нижнетреугольные с единичной диагональю
В случае, если матрица верхне(нижне)треугольная, то матрица, обратная к
ней, тоже верхне(нижне)треугольная, и после завершения работы алгоритма
обратная матрица замещает переданную. При этом элементы расположенные ниже
(выше) диагонали не меняются в ходе работы алгоритма.
Если матрица с единичной диагональю, то обратная к ней матрица тоже с
единичной диагональю. В алгоритм передаются только внедиагональные
элементы. При этом в результате работы алгоритма диагональные элементы не
меняются.
Входные параметры:
A - матрица. Массив с нумерацией элементов [0..N-1,0..N-1]
N - размер матрицы
IsUpper - True, если матрица верхнетреугольная
IsunitTriangular- True, если матрица с единичной диагональю.
Выходные параметры:
A - матрица, обратная к входной, если задача не вырождена.
Результат:
True, если матрица не вырождена
False, если матрица вырождена
-- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
*************************************************************************/
bool rmatrixtrinverse(ap::real_2d_array& a,
int n,
bool isupper,
bool isunittriangular)
{
bool result;
bool nounit;
int i;
int j;
double v;
double ajj;
ap::real_1d_array t;
result = true;
t.setbounds(0, n-1);
//
// Test the input parameters.
//
nounit = !isunittriangular;
if( isupper )
{
//
// Compute inverse of upper triangular matrix.
//
for(j = 0; j <= n-1; j++)
{
if( nounit )
{
if( a(j,j)==0 )
{
result = false;
return result;
}
a(j,j) = 1/a(j,j);
ajj = -a(j,j);
}
else
{
ajj = -1;
}
//
// Compute elements 1:j-1 of j-th column.
//
if( j>0 )
{
ap::vmove(t.getvector(0, j-1), a.getcolumn(j, 0, j-1));
for(i = 0; i <= j-1; i++)
{
if( i<j-1 )
{
v = ap::vdotproduct(&a(i, i+1), &t(i+1), ap::vlen(i+1,j-1));
}
else
{
v = 0;
}
if( nounit )
{
a(i,j) = v+a(i,i)*t(i);
}
else
{
a(i,j) = v+t(i);
}
}
ap::vmul(a.getcolumn(j, 0, j-1), ajj);
}
}
}
else
{
//
// Compute inverse of lower triangular matrix.
//
for(j = n-1; j >= 0; j--)
{
if( nounit )
{
if( a(j,j)==0 )
{
result = false;
return result;
}
a(j,j) = 1/a(j,j);
ajj = -a(j,j);
}
else
{
ajj = -1;
}
if( j<n-1 )
{
//
// Compute elements j+1:n of j-th column.
//
ap::vmove(t.getvector(j+1, n-1), a.getcolumn(j, j+1, n-1));
for(i = j+1; i <= n-1; i++)
{
if( i>j+1 )
{
v = ap::vdotproduct(&a(i, j+1), &t(j+1), ap::vlen(j+1,i-1));
}
else
{
v = 0;
}
if( nounit )
{
a(i,j) = v+a(i,i)*t(i);
}
else
{
a(i,j) = v+t(i);
}
}
ap::vmul(a.getcolumn(j, j+1, n-1), ajj);
}
}
}
return result;
}
bool solvesystemcholesky(const ap::real_2d_array& a,
ap::real_1d_array b,
int n,
bool isupper,
ap::real_1d_array& x)
{
bool result;
int i;
int im1;
int ip1;
double v;
ap::ap_error::make_assertion(n>0, "Error: N<=0 in SolveSystemCholesky");
//
// det(A)=0?
//
result = true;
for(i = 1; i <= n; i++)
{
if( ap::fp_eq(a(i,i),0) )
{
result = false;
return result;
}
}
//
// det(A)<>0
//
x.setbounds(1, n);
if( isupper )
{
//
// A = U'*U, solve U'*y = b first
//
b(1) = b(1)/a(1,1);
for(i = 2; i <= n; i++)
{
im1 = i-1;
v = ap::vdotproduct(a.getcolumn(i, 1, im1), b.getvector(1, im1));
b(i) = (b(i)-v)/a(i,i);
}
//
// Solve U*x = y
//
b(n) = b(n)/a(n,n);
for(i = n-1; i >= 1; i--)
{
ip1 = i+1;
v = ap::vdotproduct(&a(i, ip1), &b(ip1), ap::vlen(ip1,n));
b(i) = (b(i)-v)/a(i,i);
}
ap::vmove(&x(1), &b(1), ap::vlen(1,n));
}
else
{
//
// A = L*L', solve L'*y = b first
//
b(1) = b(1)/a(1,1);
for(i = 2; i <= n; i++)
{
im1 = i-1;
v = ap::vdotproduct(&a(i, 1), &b(1), ap::vlen(1,im1));
b(i) = (b(i)-v)/a(i,i);
}
//
// Solve L'*x = y
//
b(n) = b(n)/a(n,n);
for(i = n-1; i >= 1; i--)
{
ip1 = i+1;
v = ap::vdotproduct(a.getcolumn(i, ip1, n), b.getvector(ip1, n));
b(i) = (b(i)-v)/a(i,i);
}
ap::vmove(&x(1), &b(1), ap::vlen(1,n));
}
return result;
}
static void testnsevdproblem(const ap::real_2d_array& a,
int n,
double& vecerr,
double& valonlydiff,
bool& wfailed)
{
double mx;
int i;
int j;
int k;
int vjob;
bool needl;
bool needr;
ap::real_1d_array wr0;
ap::real_1d_array wi0;
ap::real_1d_array wr1;
ap::real_1d_array wi1;
ap::real_1d_array wr0s;
ap::real_1d_array wi0s;
ap::real_1d_array wr1s;
ap::real_1d_array wi1s;
ap::real_2d_array vl;
ap::real_2d_array vr;
ap::real_1d_array vec1r;
ap::real_1d_array vec1i;
ap::real_1d_array vec2r;
ap::real_1d_array vec2i;
ap::real_1d_array vec3r;
ap::real_1d_array vec3i;
double curwr;
double curwi;
double vt;
double tmp;
vec1r.setbounds(0, n-1);
vec2r.setbounds(0, n-1);
vec3r.setbounds(0, n-1);
vec1i.setbounds(0, n-1);
vec2i.setbounds(0, n-1);
vec3i.setbounds(0, n-1);
wr0s.setbounds(0, n-1);
wr1s.setbounds(0, n-1);
wi0s.setbounds(0, n-1);
wi1s.setbounds(0, n-1);
mx = 0;
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= n-1; j++)
{
if( fabs(a(i,j))>mx )
{
mx = fabs(a(i,j));
}
}
}
if( mx==0 )
{
mx = 1;
}
//
// Load values-only
//
if( !rmatrixevd(a, n, 0, wr0, wi0, vl, vr) )
{
wfailed = false;
return;
}
//
// Test different jobs
//
for(vjob = 1; vjob <= 3; vjob++)
{
needr = vjob==1||vjob==3;
needl = vjob==2||vjob==3;
if( !rmatrixevd(a, n, vjob, wr1, wi1, vl, vr) )
{
wfailed = false;
return;
}
//
// Test values:
// 1. sort by real part
// 2. test
//
ap::vmove(&wr0s(0), &wr0(0), ap::vlen(0,n-1));
ap::vmove(&wi0s(0), &wi0(0), ap::vlen(0,n-1));
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= n-2-i; j++)
{
if( wr0s(j)>wr0s(j+1) )
{
tmp = wr0s(j);
wr0s(j) = wr0s(j+1);
wr0s(j+1) = tmp;
tmp = wi0s(j);
wi0s(j) = wi0s(j+1);
wi0s(j+1) = tmp;
}
}
}
ap::vmove(&wr1s(0), &wr1(0), ap::vlen(0,n-1));
ap::vmove(&wi1s(0), &wi1(0), ap::vlen(0,n-1));
for(i = 0; i <= n-1; i++)
{
for(j = 0; j <= n-2-i; j++)
{
if( wr1s(j)>wr1s(j+1) )
{
tmp = wr1s(j);
wr1s(j) = wr1s(j+1);
wr1s(j+1) = tmp;
tmp = wi1s(j);
wi1s(j) = wi1s(j+1);
wi1s(j+1) = tmp;
}
}
}
for(i = 0; i <= n-1; i++)
{
valonlydiff = ap::maxreal(valonlydiff, fabs(wr0s(i)-wr1s(i)));
valonlydiff = ap::maxreal(valonlydiff, fabs(wi0s(i)-wi1s(i)));
}
//
// Test right vectors
//
if( needr )
{
k = 0;
while(k<=n-1)
{
if( wi1(k)==0 )
{
ap::vmove(vec1r.getvector(0, n-1), vr.getcolumn(k, 0, n-1));
for(i = 0; i <= n-1; i++)
{
vec1i(i) = 0;
}
curwr = wr1(k);
curwi = 0;
}
if( wi1(k)>0 )
{
ap::vmove(vec1r.getvector(0, n-1), vr.getcolumn(k, 0, n-1));
ap::vmove(vec1i.getvector(0, n-1), vr.getcolumn(k+1, 0, n-1));
curwr = wr1(k);
curwi = wi1(k);
}
if( wi1(k)<0 )
{
ap::vmove(vec1r.getvector(0, n-1), vr.getcolumn(k-1, 0, n-1));
ap::vmoveneg(vec1i.getvector(0, n-1), vr.getcolumn(k, 0, n-1));
curwr = wr1(k);
curwi = wi1(k);
}
for(i = 0; i <= n-1; i++)
{
vt = ap::vdotproduct(&a(i, 0), &vec1r(0), ap::vlen(0,n-1));
vec2r(i) = vt;
vt = ap::vdotproduct(&a(i, 0), &vec1i(0), ap::vlen(0,n-1));
vec2i(i) = vt;
}
ap::vmove(&vec3r(0), &vec1r(0), ap::vlen(0,n-1), curwr);
ap::vsub(&vec3r(0), &vec1i(0), ap::vlen(0,n-1), curwi);
ap::vmove(&vec3i(0), &vec1r(0), ap::vlen(0,n-1), curwi);
ap::vadd(&vec3i(0), &vec1i(0), ap::vlen(0,n-1), curwr);
for(i = 0; i <= n-1; i++)
{
vecerr = ap::maxreal(vecerr, fabs(vec2r(i)-vec3r(i)));
vecerr = ap::maxreal(vecerr, fabs(vec2i(i)-vec3i(i)));
}
k = k+1;
}
}
//
// Test left vectors
//
if( needl )
{
k = 0;
while(k<=n-1)
{
if( wi1(k)==0 )
{
ap::vmove(vec1r.getvector(0, n-1), vl.getcolumn(k, 0, n-1));
for(i = 0; i <= n-1; i++)
{
vec1i(i) = 0;
}
curwr = wr1(k);
curwi = 0;
}
if( wi1(k)>0 )
{
ap::vmove(vec1r.getvector(0, n-1), vl.getcolumn(k, 0, n-1));
ap::vmove(vec1i.getvector(0, n-1), vl.getcolumn(k+1, 0, n-1));
curwr = wr1(k);
curwi = wi1(k);
}
if( wi1(k)<0 )
{
ap::vmove(vec1r.getvector(0, n-1), vl.getcolumn(k-1, 0, n-1));
ap::vmoveneg(vec1i.getvector(0, n-1), vl.getcolumn(k, 0, n-1));
curwr = wr1(k);
curwi = wi1(k);
}
for(j = 0; j <= n-1; j++)
{
vt = ap::vdotproduct(vec1r.getvector(0, n-1), a.getcolumn(j, 0, n-1));
vec2r(j) = vt;
vt = ap::vdotproduct(vec1i.getvector(0, n-1), a.getcolumn(j, 0, n-1));
vec2i(j) = -vt;
}
ap::vmove(&vec3r(0), &vec1r(0), ap::vlen(0,n-1), curwr);
ap::vadd(&vec3r(0), &vec1i(0), ap::vlen(0,n-1), curwi);
ap::vmove(&vec3i(0), &vec1r(0), ap::vlen(0,n-1), curwi);
ap::vsub(&vec3i(0), &vec1i(0), ap::vlen(0,n-1), curwr);
for(i = 0; i <= n-1; i++)
{
vecerr = ap::maxreal(vecerr, fabs(vec2r(i)-vec3r(i)));
vecerr = ap::maxreal(vecerr, fabs(vec2i(i)-vec3i(i)));
}
k = k+1;
}
}
}
}
/*************************************************************************
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.
-- ALGLIB --
Copyright 2005 by Bochkanov Sergey
*************************************************************************/
void rmatrixbdmultiplybyq(const ap::real_2d_array& qp,
int m,
int n,
const ap::real_1d_array& tauq,
ap::real_2d_array& z,
int zrows,
int zcolumns,
bool fromtheright,
bool dotranspose)
{
int i;
int i1;
int i2;
int istep;
ap::real_1d_array v;
ap::real_1d_array work;
int mx;
if( m<=0||n<=0||zrows<=0||zcolumns<=0 )
{
return;
}
ap::ap_error::make_assertion(fromtheright&&zcolumns==m||!fromtheright&&zrows==m, "RMatrixBDMultiplyByQ: incorrect Z size!");
//
// init
//
mx = ap::maxint(m, n);
mx = ap::maxint(mx, zrows);
mx = ap::maxint(mx, zcolumns);
v.setbounds(0, mx);
work.setbounds(0, mx);
if( m>=n )
{
//
// setup
//
if( fromtheright )
{
i1 = 0;
i2 = n-1;
istep = +1;
}
else
{
i1 = n-1;
i2 = 0;
istep = -1;
}
if( dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
i = i1;
do
{
ap::vmove(v.getvector(1, m-i), qp.getcolumn(i, i, m-1));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, tauq(i), v, 0, zrows-1, i, m-1, work);
}
else
{
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;
}
if( dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
if( m-1>0 )
{
i = i1;
do
{
ap::vmove(v.getvector(1, m-i-1), qp.getcolumn(i, i+1, m-1));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, tauq(i), v, 0, zrows-1, i+1, m-1, work);
}
else
{
applyreflectionfromtheleft(z, tauq(i), v, i+1, m-1, 0, zcolumns-1, work);
}
i = i+istep;
}
while(i!=i2+istep);
}
}
}
/*************************************************************************
Linear regression
Variant of LRBuild which uses vector of standatd deviations (errors in
function values).
INPUT PARAMETERS:
XY - training set, array [0..NPoints-1,0..NVars]:
* NVars columns - independent variables
* last column - dependent variable
S - standard deviations (errors in function values)
array[0..NPoints-1], S[i]>0.
NPoints - training set size, NPoints>NVars+1
NVars - number of independent variables
OUTPUT PARAMETERS:
Info - return code:
* -255, in case of unknown internal error
* -4, if internal SVD subroutine haven't converged
* -1, if incorrect parameters was passed (NPoints<NVars+2, NVars<1).
* -2, if S[I]<=0
* 1, if subroutine successfully finished
LM - linear model in the ALGLIB format. Use subroutines of
this unit to work with the model.
AR - additional results
-- ALGLIB --
Copyright 02.08.2008 by Bochkanov Sergey
*************************************************************************/
void lrbuilds(const ap::real_2d_array& xy,
const ap::real_1d_array& s,
int npoints,
int nvars,
int& info,
linearmodel& lm,
lrreport& ar)
{
ap::real_2d_array xyi;
ap::real_1d_array x;
ap::real_1d_array means;
ap::real_1d_array sigmas;
int i;
int j;
double v;
int offs;
double mean;
double variance;
double skewness;
double kurtosis;
//
// Test parameters
//
if( npoints<=nvars+1||nvars<1 )
{
info = -1;
return;
}
//
// Copy data, add one more column (constant term)
//
xyi.setbounds(0, npoints-1, 0, nvars+1);
for(i = 0; i <= npoints-1; i++)
{
ap::vmove(&xyi(i, 0), &xy(i, 0), ap::vlen(0,nvars-1));
xyi(i,nvars) = 1;
xyi(i,nvars+1) = xy(i,nvars);
}
//
// Standartization
//
x.setbounds(0, npoints-1);
means.setbounds(0, nvars-1);
sigmas.setbounds(0, nvars-1);
for(j = 0; j <= nvars-1; j++)
{
ap::vmove(x.getvector(0, npoints-1), xy.getcolumn(j, 0, npoints-1));
calculatemoments(x, npoints, mean, variance, skewness, kurtosis);
means(j) = mean;
sigmas(j) = sqrt(variance);
if( ap::fp_eq(sigmas(j),0) )
{
sigmas(j) = 1;
}
for(i = 0; i <= npoints-1; i++)
{
xyi(i,j) = (xyi(i,j)-means(j))/sigmas(j);
}
}
//
// Internal processing
//
lrinternal(xyi, s, npoints, nvars+1, info, lm, ar);
if( info<0 )
{
return;
}
//
// Un-standartization
//
offs = ap::round(lm.w(3));
for(j = 0; j <= nvars-1; j++)
{
//
// Constant term is updated (and its covariance too,
// since it gets some variance from J-th component)
//
lm.w(offs+nvars) = lm.w(offs+nvars)-lm.w(offs+j)*means(j)/sigmas(j);
v = means(j)/sigmas(j);
ap::vsub(&ar.c(nvars, 0), &ar.c(j, 0), ap::vlen(0,nvars), v);
ap::vsub(ar.c.getcolumn(nvars, 0, nvars), ar.c.getcolumn(j, 0, nvars), v);
//
// J-th term is updated
//
lm.w(offs+j) = lm.w(offs+j)/sigmas(j);
v = 1/sigmas(j);
ap::vmul(&ar.c(j, 0), ap::vlen(0,nvars), v);
ap::vmul(ar.c.getcolumn(j, 0, nvars), v);
}
}
/*************************************************************************
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);
}
}
/*************************************************************************
Like LRBuildS, but builds model
Y = A(0)*X[0] + ... + A(N-1)*X[N-1]
i.e. with zero constant term.
-- ALGLIB --
Copyright 30.10.2008 by Bochkanov Sergey
*************************************************************************/
void lrbuildzs(const ap::real_2d_array& xy,
const ap::real_1d_array& s,
int npoints,
int nvars,
int& info,
linearmodel& lm,
lrreport& ar)
{
ap::real_2d_array xyi;
ap::real_1d_array x;
ap::real_1d_array c;
int i;
int j;
double v;
int offs;
double mean;
double variance;
double skewness;
double kurtosis;
//
// Test parameters
//
if( npoints<=nvars+1||nvars<1 )
{
info = -1;
return;
}
//
// Copy data, add one more column (constant term)
//
xyi.setbounds(0, npoints-1, 0, nvars+1);
for(i = 0; i <= npoints-1; i++)
{
ap::vmove(&xyi(i, 0), &xy(i, 0), ap::vlen(0,nvars-1));
xyi(i,nvars) = 0;
xyi(i,nvars+1) = xy(i,nvars);
}
//
// Standartization: unusual scaling
//
x.setbounds(0, npoints-1);
c.setbounds(0, nvars-1);
for(j = 0; j <= nvars-1; j++)
{
ap::vmove(x.getvector(0, npoints-1), xy.getcolumn(j, 0, npoints-1));
calculatemoments(x, npoints, mean, variance, skewness, kurtosis);
if( ap::fp_greater(fabs(mean),sqrt(variance)) )
{
//
// variation is relatively small, it is better to
// bring mean value to 1
//
c(j) = mean;
}
else
{
//
// variation is large, it is better to bring variance to 1
//
if( ap::fp_eq(variance,0) )
{
variance = 1;
}
c(j) = sqrt(variance);
}
for(i = 0; i <= npoints-1; i++)
{
xyi(i,j) = xyi(i,j)/c(j);
}
}
//
// Internal processing
//
lrinternal(xyi, s, npoints, nvars+1, info, lm, ar);
if( info<0 )
{
return;
}
//
// Un-standartization
//
offs = ap::round(lm.w(3));
for(j = 0; j <= nvars-1; j++)
{
//
// J-th term is updated
//
lm.w(offs+j) = lm.w(offs+j)/c(j);
v = 1/c(j);
ap::vmul(&ar.c(j, 0), ap::vlen(0,nvars), v);
ap::vmul(ar.c.getcolumn(j, 0, nvars), v);
}
}
/*************************************************************************
Obsolete 1-based subroutine
*************************************************************************/
void unpackqfromtridiagonal(const ap::real_2d_array& a,
const int& n,
const bool& isupper,
const ap::real_1d_array& tau,
ap::real_2d_array& q)
{
int i;
int j;
int ip1;
int nmi;
ap::real_1d_array v;
ap::real_1d_array work;
if( n==0 )
{
return;
}
//
// init
//
q.setbounds(1, n, 1, n);
v.setbounds(1, n);
work.setbounds(1, n);
for(i = 1; i <= n; i++)
{
for(j = 1; j <= n; j++)
{
if( i==j )
{
q(i,j) = 1;
}
else
{
q(i,j) = 0;
}
}
}
//
// unpack Q
//
if( isupper )
{
for(i = 1; i <= n-1; i++)
{
//
// Apply H(i)
//
ip1 = i+1;
ap::vmove(v.getvector(1, i), a.getcolumn(ip1, 1, i));
v(i) = 1;
applyreflectionfromtheleft(q, tau(i), v, 1, i, 1, n, work);
}
}
else
{
for(i = n-1; i >= 1; i--)
{
//
// Apply H(i)
//
ip1 = i+1;
nmi = n-i;
ap::vmove(v.getvector(1, nmi), a.getcolumn(i, ip1, n));
v(1) = 1;
applyreflectionfromtheleft(q, tau(i), v, i+1, n, 1, n, work);
}
}
}
/*************************************************************************
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);
}
/*************************************************************************
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;
}
}
}
}
/*************************************************************************
Cholesky decomposition
The algorithm computes Cholesky decomposition of a symmetric
positive-definite matrix.
The result of an algorithm is a representation of matrix A as A = U'*U or
A = L*L'.
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. This means that the
factorization could not be carried out.
-- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
*************************************************************************/
bool spdmatrixcholesky(ap::real_2d_array& a, int n, bool isupper)
{
bool result;
int i;
int j;
double ajj;
double v;
//
// Test the input parameters.
//
ap::ap_error::make_assertion(n>=0, "Error in SMatrixCholesky: incorrect function arguments");
//
// Quick return if possible
//
result = true;
if( n<=0 )
{
return result;
}
if( isupper )
{
//
// Compute the Cholesky factorization A = U'*U.
//
for(j = 0; j <= n-1; j++)
{
//
// Compute U(J,J) and test for non-positive-definiteness.
//
v = ap::vdotproduct(a.getcolumn(j, 0, j-1), a.getcolumn(j, 0, j-1));
ajj = a(j,j)-v;
if( ajj<=0 )
{
result = false;
return result;
}
ajj = sqrt(ajj);
a(j,j) = ajj;
//
// Compute elements J+1:N of row J.
//
if( j<n-1 )
{
for(i = 0; i <= j-1; i++)
{
v = a(i,j);
ap::vsub(&a(j, j+1), &a(i, j+1), ap::vlen(j+1,n-1), v);
}
v = 1/ajj;
ap::vmul(&a(j, j+1), ap::vlen(j+1,n-1), v);
}
}
}
else
{
//
// Compute the Cholesky factorization A = L*L'.
//
for(j = 0; j <= n-1; j++)
{
//
// Compute L(J,J) and test for non-positive-definiteness.
//
v = ap::vdotproduct(&a(j, 0), &a(j, 0), ap::vlen(0,j-1));
ajj = a(j,j)-v;
if( ajj<=0 )
{
result = false;
return result;
}
ajj = sqrt(ajj);
a(j,j) = ajj;
//
// Compute elements J+1:N of column J.
//
if( j<n-1 )
{
for(i = j+1; i <= n-1; i++)
{
v = ap::vdotproduct(&a(i, 0), &a(j, 0), ap::vlen(0,j-1));
a(i,j) = a(i,j)-v;
}
v = 1/ajj;
ap::vmul(a.getcolumn(j, j+1, n-1), v);
}
}
}
return result;
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixBDUnpackQ for 0-based replacement.
*************************************************************************/
void unpackqfrombidiagonal(const ap::real_2d_array& qp,
int m,
int n,
const ap::real_1d_array& tauq,
int qcolumns,
ap::real_2d_array& q)
{
int i;
int j;
int ip1;
ap::real_1d_array v;
ap::real_1d_array work;
int vm;
ap::ap_error::make_assertion(qcolumns<=m, "UnpackQFromBidiagonal: QColumns>M!");
if( m==0||n==0||qcolumns==0 )
{
return;
}
//
// init
//
q.setbounds(1, m, 1, qcolumns);
v.setbounds(1, m);
work.setbounds(1, qcolumns);
//
// prepare Q
//
for(i = 1; i <= m; i++)
{
for(j = 1; j <= qcolumns; j++)
{
if( i==j )
{
q(i,j) = 1;
}
else
{
q(i,j) = 0;
}
}
}
if( m>=n )
{
for(i = ap::minint(n, qcolumns); i >= 1; i--)
{
vm = m-i+1;
ap::vmove(v.getvector(1, vm), qp.getcolumn(i, i, m));
v(1) = 1;
applyreflectionfromtheleft(q, tauq(i), v, i, m, 1, qcolumns, work);
}
}
else
{
for(i = ap::minint(m-1, qcolumns-1); i >= 1; i--)
{
vm = m-i;
ip1 = i+1;
ap::vmove(v.getvector(1, vm), qp.getcolumn(i, ip1, m));
v(1) = 1;
applyreflectionfromtheleft(q, tauq(i), v, i+1, m, 1, qcolumns, work);
}
}
}
/*************************************************************************
Application of a sequence of elementary rotations to a matrix
The algorithm post-multiplies the matrix by a sequence of rotation
transformations which is given by arrays C and S. Depending on the value
of the IsForward parameter either 1 and 2, 3 and 4 and so on (if IsForward=true)
rows are rotated, or the rows N and N-1, N-2 and N-3 and so on are rotated.
Not the whole matrix but only a part of it is transformed (rows from M1
to M2, columns from N1 to N2). Only the elements of this submatrix are changed.
Input parameters:
IsForward - the sequence of the rotation application.
M1,M2 - the range of rows to be transformed.
N1, N2 - the range of columns to be transformed.
C,S - transformation coefficients.
Array whose index ranges within [1..N2-N1].
A - processed matrix.
WORK - working array whose index ranges within [M1..M2].
Output parameters:
A - transformed matrix.
Utility subroutine.
*************************************************************************/
void applyrotationsfromtheright(bool isforward,
int m1,
int m2,
int n1,
int n2,
const ap::real_1d_array& c,
const ap::real_1d_array& s,
ap::real_2d_array& a,
ap::real_1d_array& work)
{
int j;
int jp1;
double ctemp;
double stemp;
double temp;
//
// Form A * P'
//
if( isforward )
{
if( m1!=m2 )
{
//
// Common case: M1<>M2
//
for(j = n1; j <= n2-1; j++)
{
ctemp = c(j-n1+1);
stemp = s(j-n1+1);
if( ap::fp_neq(ctemp,1)||ap::fp_neq(stemp,0) )
{
jp1 = j+1;
ap::vmove(work.getvector(m1, m2), a.getcolumn(jp1, m1, m2), ctemp);
ap::vsub(work.getvector(m1, m2), a.getcolumn(j, m1, m2), stemp);
ap::vmul(a.getcolumn(j, m1, m2), ctemp);
ap::vadd(a.getcolumn(j, m1, m2), a.getcolumn(jp1, m1, m2), stemp);
ap::vmove(a.getcolumn(jp1, m1, m2), work.getvector(m1, m2));
}
}
}
else
{
//
// Special case: M1=M2
//
for(j = n1; j <= n2-1; j++)
{
ctemp = c(j-n1+1);
stemp = s(j-n1+1);
if( ap::fp_neq(ctemp,1)||ap::fp_neq(stemp,0) )
{
temp = a(m1,j+1);
a(m1,j+1) = ctemp*temp-stemp*a(m1,j);
a(m1,j) = stemp*temp+ctemp*a(m1,j);
}
}
}
}
else
{
if( m1!=m2 )
{
//
// Common case: M1<>M2
//
for(j = n2-1; j >= n1; j--)
{
ctemp = c(j-n1+1);
stemp = s(j-n1+1);
if( ap::fp_neq(ctemp,1)||ap::fp_neq(stemp,0) )
{
jp1 = j+1;
ap::vmove(work.getvector(m1, m2), a.getcolumn(jp1, m1, m2), ctemp);
ap::vsub(work.getvector(m1, m2), a.getcolumn(j, m1, m2), stemp);
ap::vmul(a.getcolumn(j, m1, m2), ctemp);
ap::vadd(a.getcolumn(j, m1, m2), a.getcolumn(jp1, m1, m2), stemp);
ap::vmove(a.getcolumn(jp1, m1, m2), work.getvector(m1, m2));
}
}
}
else
{
//
// Special case: M1=M2
//
for(j = n2-1; j >= n1; j--)
{
ctemp = c(j-n1+1);
stemp = s(j-n1+1);
if( ap::fp_neq(ctemp,1)||ap::fp_neq(stemp,0) )
{
temp = a(m1,j+1);
a(m1,j+1) = ctemp*temp-stemp*a(m1,j);
a(m1,j) = stemp*temp+ctemp*a(m1,j);
}
}
}
}
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixTRSafeSolve for 0-based replacement.
*************************************************************************/
void safesolvetriangular(const ap::real_2d_array& a,
int n,
ap::real_1d_array& x,
double& s,
bool isupper,
bool istrans,
bool isunit,
bool normin,
ap::real_1d_array& cnorm)
{
int i;
int imax;
int j;
int jfirst;
int jinc;
int jlast;
int jm1;
int jp1;
int ip1;
int im1;
int k;
int flg;
double v;
double vd;
double bignum;
double grow;
double rec;
double smlnum;
double sumj;
double tjj;
double tjjs;
double tmax;
double tscal;
double uscal;
double xbnd;
double xj;
double xmax;
bool notran;
bool upper;
bool nounit;
upper = isupper;
notran = !istrans;
nounit = !isunit;
//
// Quick return if possible
//
if( n==0 )
{
return;
}
//
// Determine machine dependent parameters to control overflow.
//
smlnum = ap::minrealnumber/(ap::machineepsilon*2);
bignum = 1/smlnum;
s = 1;
if( !normin )
{
cnorm.setbounds(1, n);
//
// Compute the 1-norm of each column, not including the diagonal.
//
if( upper )
{
//
// A is upper triangular.
//
for(j = 1; j <= n; j++)
{
v = 0;
for(k = 1; k <= j-1; k++)
{
v = v+fabs(a(k,j));
}
cnorm(j) = v;
}
}
else
{
//
// A is lower triangular.
//
for(j = 1; j <= n-1; j++)
{
v = 0;
for(k = j+1; k <= n; k++)
{
v = v+fabs(a(k,j));
}
cnorm(j) = v;
}
cnorm(n) = 0;
}
}
//
// Scale the column norms by TSCAL if the maximum element in CNORM is
// greater than BIGNUM.
//
imax = 1;
for(k = 2; k <= n; k++)
{
if( ap::fp_greater(cnorm(k),cnorm(imax)) )
{
imax = k;
}
}
tmax = cnorm(imax);
if( ap::fp_less_eq(tmax,bignum) )
{
tscal = 1;
}
else
{
tscal = 1/(smlnum*tmax);
ap::vmul(&cnorm(1), ap::vlen(1,n), tscal);
}
//
// Compute a bound on the computed solution vector to see if the
// Level 2 BLAS routine DTRSV can be used.
//
j = 1;
for(k = 2; k <= n; k++)
{
if( ap::fp_greater(fabs(x(k)),fabs(x(j))) )
{
j = k;
}
}
xmax = fabs(x(j));
xbnd = xmax;
if( notran )
{
//
// Compute the growth in A * x = b.
//
if( upper )
{
jfirst = n;
jlast = 1;
jinc = -1;
}
else
{
jfirst = 1;
jlast = n;
jinc = 1;
}
if( ap::fp_neq(tscal,1) )
{
grow = 0;
}
else
{
if( nounit )
{
//
// A is non-unit triangular.
//
// Compute GROW = 1/G(j) and XBND = 1/M(j).
// Initially, G(0) = max{x(i), i=1,...,n}.
//
grow = 1/ap::maxreal(xbnd, smlnum);
xbnd = grow;
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Exit the loop if the growth factor is too small.
//
if( ap::fp_less_eq(grow,smlnum) )
{
break;
}
//
// M(j) = G(j-1) / abs(A(j,j))
//
tjj = fabs(a(j,j));
xbnd = ap::minreal(xbnd, ap::minreal(double(1), tjj)*grow);
if( ap::fp_greater_eq(tjj+cnorm(j),smlnum) )
{
//
// G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
//
grow = grow*(tjj/(tjj+cnorm(j)));
}
else
{
//
// G(j) could overflow, set GROW to 0.
//
grow = 0;
}
if( j==jlast )
{
grow = xbnd;
}
j = j+jinc;
}
}
else
{
//
// A is unit triangular.
//
// Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
//
grow = ap::minreal(double(1), 1/ap::maxreal(xbnd, smlnum));
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Exit the loop if the growth factor is too small.
//
if( ap::fp_less_eq(grow,smlnum) )
{
break;
}
//
// G(j) = G(j-1)*( 1 + CNORM(j) )
//
grow = grow*(1/(1+cnorm(j)));
j = j+jinc;
}
}
}
}
else
{
//
// Compute the growth in A' * x = b.
//
if( upper )
{
jfirst = 1;
jlast = n;
jinc = 1;
}
else
{
jfirst = n;
jlast = 1;
jinc = -1;
}
if( ap::fp_neq(tscal,1) )
{
grow = 0;
}
else
{
if( nounit )
{
//
// A is non-unit triangular.
//
// Compute GROW = 1/G(j) and XBND = 1/M(j).
// Initially, M(0) = max{x(i), i=1,...,n}.
//
grow = 1/ap::maxreal(xbnd, smlnum);
xbnd = grow;
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Exit the loop if the growth factor is too small.
//
if( ap::fp_less_eq(grow,smlnum) )
{
break;
}
//
// G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
//
xj = 1+cnorm(j);
grow = ap::minreal(grow, xbnd/xj);
//
// M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
//
tjj = fabs(a(j,j));
if( ap::fp_greater(xj,tjj) )
{
xbnd = xbnd*(tjj/xj);
}
if( j==jlast )
{
grow = ap::minreal(grow, xbnd);
}
j = j+jinc;
}
}
else
{
//
// A is unit triangular.
//
// Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
//
grow = ap::minreal(double(1), 1/ap::maxreal(xbnd, smlnum));
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Exit the loop if the growth factor is too small.
//
if( ap::fp_less_eq(grow,smlnum) )
{
break;
}
//
// G(j) = ( 1 + CNORM(j) )*G(j-1)
//
xj = 1+cnorm(j);
grow = grow/xj;
j = j+jinc;
}
}
}
}
if( ap::fp_greater(grow*tscal,smlnum) )
{
//
// Use the Level 2 BLAS solve if the reciprocal of the bound on
// elements of X is not too small.
//
if( upper&¬ran||!upper&&!notran )
{
if( nounit )
{
vd = a(n,n);
}
else
{
vd = 1;
}
x(n) = x(n)/vd;
for(i = n-1; i >= 1; i--)
{
ip1 = i+1;
if( upper )
{
v = ap::vdotproduct(&a(i, ip1), &x(ip1), ap::vlen(ip1,n));
}
else
{
v = ap::vdotproduct(a.getcolumn(i, ip1, n), x.getvector(ip1, n));
}
if( nounit )
{
vd = a(i,i);
}
else
{
vd = 1;
}
x(i) = (x(i)-v)/vd;
}
}
else
{
if( nounit )
{
vd = a(1,1);
}
else
{
vd = 1;
}
x(1) = x(1)/vd;
for(i = 2; i <= n; i++)
{
im1 = i-1;
if( upper )
{
v = ap::vdotproduct(a.getcolumn(i, 1, im1), x.getvector(1, im1));
}
else
{
v = ap::vdotproduct(&a(i, 1), &x(1), ap::vlen(1,im1));
}
if( nounit )
{
vd = a(i,i);
}
else
{
vd = 1;
}
x(i) = (x(i)-v)/vd;
}
}
}
else
{
//
// Use a Level 1 BLAS solve, scaling intermediate results.
//
if( ap::fp_greater(xmax,bignum) )
{
//
// Scale X so that its components are less than or equal to
// BIGNUM in absolute value.
//
s = bignum/xmax;
ap::vmul(&x(1), ap::vlen(1,n), s);
xmax = bignum;
}
if( notran )
{
//
// Solve A * x = b
//
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Compute x(j) = b(j) / A(j,j), scaling x if necessary.
//
xj = fabs(x(j));
flg = 0;
if( nounit )
{
tjjs = a(j,j)*tscal;
}
else
{
tjjs = tscal;
if( ap::fp_eq(tscal,1) )
{
flg = 100;
}
}
if( flg!=100 )
{
tjj = fabs(tjjs);
if( ap::fp_greater(tjj,smlnum) )
{
//
// abs(A(j,j)) > SMLNUM:
//
if( ap::fp_less(tjj,1) )
{
if( ap::fp_greater(xj,tjj*bignum) )
{
//
// Scale x by 1/b(j).
//
rec = 1/xj;
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
xmax = xmax*rec;
}
}
x(j) = x(j)/tjjs;
xj = fabs(x(j));
}
else
{
if( ap::fp_greater(tjj,0) )
{
//
// 0 < abs(A(j,j)) <= SMLNUM:
//
if( ap::fp_greater(xj,tjj*bignum) )
{
//
// Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
// to avoid overflow when dividing by A(j,j).
//
rec = tjj*bignum/xj;
if( ap::fp_greater(cnorm(j),1) )
{
//
// Scale by 1/CNORM(j) to avoid overflow when
// multiplying x(j) times column j.
//
rec = rec/cnorm(j);
}
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
xmax = xmax*rec;
}
x(j) = x(j)/tjjs;
xj = fabs(x(j));
}
else
{
//
// A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
// scale = 0, and compute a solution to A*x = 0.
//
for(i = 1; i <= n; i++)
{
x(i) = 0;
}
x(j) = 1;
xj = 1;
s = 0;
xmax = 0;
}
}
}
//
// Scale x if necessary to avoid overflow when adding a
// multiple of column j of A.
//
if( ap::fp_greater(xj,1) )
{
rec = 1/xj;
if( ap::fp_greater(cnorm(j),(bignum-xmax)*rec) )
{
//
// Scale x by 1/(2*abs(x(j))).
//
rec = rec*0.5;
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
}
}
else
{
if( ap::fp_greater(xj*cnorm(j),bignum-xmax) )
{
//
// Scale x by 1/2.
//
ap::vmul(&x(1), ap::vlen(1,n), 0.5);
s = s*0.5;
}
}
if( upper )
{
if( j>1 )
{
//
// Compute the update
// x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
//
v = x(j)*tscal;
jm1 = j-1;
ap::vsub(x.getvector(1, jm1), a.getcolumn(j, 1, jm1), v);
i = 1;
for(k = 2; k <= j-1; k++)
{
if( ap::fp_greater(fabs(x(k)),fabs(x(i))) )
{
i = k;
}
}
xmax = fabs(x(i));
}
}
else
{
if( j<n )
{
//
// Compute the update
// x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
//
jp1 = j+1;
v = x(j)*tscal;
ap::vsub(x.getvector(jp1, n), a.getcolumn(j, jp1, n), v);
i = j+1;
for(k = j+2; k <= n; k++)
{
if( ap::fp_greater(fabs(x(k)),fabs(x(i))) )
{
i = k;
}
}
xmax = fabs(x(i));
}
}
j = j+jinc;
}
}
else
{
//
// Solve A' * x = b
//
j = jfirst;
while(jinc>0&&j<=jlast||jinc<0&&j>=jlast)
{
//
// Compute x(j) = b(j) - sum A(k,j)*x(k).
// k<>j
//
xj = fabs(x(j));
uscal = tscal;
rec = 1/ap::maxreal(xmax, double(1));
if( ap::fp_greater(cnorm(j),(bignum-xj)*rec) )
{
//
// If x(j) could overflow, scale x by 1/(2*XMAX).
//
rec = rec*0.5;
if( nounit )
{
tjjs = a(j,j)*tscal;
}
else
{
tjjs = tscal;
}
tjj = fabs(tjjs);
if( ap::fp_greater(tjj,1) )
{
//
// Divide by A(j,j) when scaling x if A(j,j) > 1.
//
rec = ap::minreal(double(1), rec*tjj);
uscal = uscal/tjjs;
}
if( ap::fp_less(rec,1) )
{
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
xmax = xmax*rec;
}
}
sumj = 0;
if( ap::fp_eq(uscal,1) )
{
//
// If the scaling needed for A in the dot product is 1,
// call DDOT to perform the dot product.
//
if( upper )
{
if( j>1 )
{
jm1 = j-1;
sumj = ap::vdotproduct(a.getcolumn(j, 1, jm1), x.getvector(1, jm1));
}
else
{
sumj = 0;
}
}
else
{
if( j<n )
{
jp1 = j+1;
sumj = ap::vdotproduct(a.getcolumn(j, jp1, n), x.getvector(jp1, n));
}
}
}
else
{
//
// Otherwise, use in-line code for the dot product.
//
if( upper )
{
for(i = 1; i <= j-1; i++)
{
v = a(i,j)*uscal;
sumj = sumj+v*x(i);
}
}
else
{
if( j<n )
{
for(i = j+1; i <= n; i++)
{
v = a(i,j)*uscal;
sumj = sumj+v*x(i);
}
}
}
}
if( ap::fp_eq(uscal,tscal) )
{
//
// Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
// was not used to scale the dotproduct.
//
x(j) = x(j)-sumj;
xj = fabs(x(j));
flg = 0;
if( nounit )
{
tjjs = a(j,j)*tscal;
}
else
{
tjjs = tscal;
if( ap::fp_eq(tscal,1) )
{
flg = 150;
}
}
//
// Compute x(j) = x(j) / A(j,j), scaling if necessary.
//
if( flg!=150 )
{
tjj = fabs(tjjs);
if( ap::fp_greater(tjj,smlnum) )
{
//
// abs(A(j,j)) > SMLNUM:
//
if( ap::fp_less(tjj,1) )
{
if( ap::fp_greater(xj,tjj*bignum) )
{
//
// Scale X by 1/abs(x(j)).
//
rec = 1/xj;
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
xmax = xmax*rec;
}
}
x(j) = x(j)/tjjs;
}
else
{
if( ap::fp_greater(tjj,0) )
{
//
// 0 < abs(A(j,j)) <= SMLNUM:
//
if( ap::fp_greater(xj,tjj*bignum) )
{
//
// Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
//
rec = tjj*bignum/xj;
ap::vmul(&x(1), ap::vlen(1,n), rec);
s = s*rec;
xmax = xmax*rec;
}
x(j) = x(j)/tjjs;
}
else
{
//
// A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
// scale = 0, and compute a solution to A'*x = 0.
//
for(i = 1; i <= n; i++)
{
x(i) = 0;
}
x(j) = 1;
s = 0;
xmax = 0;
}
}
}
}
else
{
//
// Compute x(j) := x(j) / A(j,j) - sumj if the dot
// product has already been divided by 1/A(j,j).
//
x(j) = x(j)/tjjs-sumj;
}
xmax = ap::maxreal(xmax, fabs(x(j)));
j = j+jinc;
}
}
s = s/tscal;
}
//
// Scale the column norms by 1/TSCAL for return.
//
if( ap::fp_neq(tscal,1) )
{
v = 1/tscal;
ap::vmul(&cnorm(1), ap::vlen(1,n), v);
}
}
