/*************************************************************************
Multiplication of MxN matrix by NxN random Haar distributed orthogonal matrix
INPUT PARAMETERS:
A - matrix, array[0..M-1, 0..N-1]
M, N- matrix size
OUTPUT PARAMETERS:
A - A*Q, where Q is random NxN orthogonal matrix
-- ALGLIB routine --
04.12.2009
Bochkanov Sergey
*************************************************************************/
void rmatrixrndorthogonalfromtheright(ap::real_2d_array& a, int m, int n)
{
double tau;
double lambda;
int s;
int i;
int j;
double u1;
double u2;
ap::real_1d_array w;
ap::real_1d_array v;
double sm;
hqrndstate state;
ap::ap_error::make_assertion(n>=1&&m>=1, "RMatrixRndOrthogonalFromTheRight: N<1 or M<1!");
if( n==1 )
{
//
// Special case
//
tau = 2*ap::randominteger(2)-1;
for(i = 0; i <= m-1; i++)
{
a(i,0) = a(i,0)*tau;
}
return;
}
//
// General case.
// First pass.
//
w.setbounds(0, m-1);
v.setbounds(1, n);
hqrndrandomize(state);
for(s = 2; s <= n; s++)
{
//
// Prepare random normal v
//
do
{
i = 1;
while(i<=s)
{
hqrndnormal2(state, u1, u2);
v(i) = u1;
if( i+1<=s )
{
v(i+1) = u2;
}
i = i+2;
}
lambda = ap::vdotproduct(&v(1), &v(1), ap::vlen(1,s));
}
while(ap::fp_eq(lambda,0));
//
// Prepare and apply reflection
//
generatereflection(v, s, tau);
v(1) = 1;
applyreflectionfromtheright(a, tau, v, 0, m-1, n-s, n-1, w);
}
//
// Second pass.
//
for(i = 0; i <= n-1; i++)
{
tau = 2*ap::randominteger(2)-1;
ap::vmul(a.getcolumn(i, 0, m-1), tau);
}
}
/*************************************************************************
Symmetric multiplication of NxN matrix by random Haar distributed
orthogonal matrix
INPUT PARAMETERS:
A - matrix, array[0..N-1, 0..N-1]
N - matrix size
OUTPUT PARAMETERS:
A - Q'*A*Q, where Q is random NxN orthogonal matrix
-- ALGLIB routine --
04.12.2009
Bochkanov Sergey
*************************************************************************/
void smatrixrndmultiply(ap::real_2d_array& a, int n)
{
double tau;
double lambda;
int s;
int i;
int j;
double u1;
double u2;
ap::real_1d_array w;
ap::real_1d_array v;
double sm;
hqrndstate state;
//
// General case.
//
w.setbounds(0, n-1);
v.setbounds(1, n);
hqrndrandomize(state);
for(s = 2; s <= n; s++)
{
//
// Prepare random normal v
//
do
{
i = 1;
while(i<=s)
{
hqrndnormal2(state, u1, u2);
v(i) = u1;
if( i+1<=s )
{
v(i+1) = u2;
}
i = i+2;
}
lambda = ap::vdotproduct(&v(1), &v(1), ap::vlen(1,s));
}
while(ap::fp_eq(lambda,0));
//
// Prepare and apply reflection
//
generatereflection(v, s, tau);
v(1) = 1;
applyreflectionfromtheright(a, tau, v, 0, n-1, n-s, n-1, w);
applyreflectionfromtheleft(a, tau, v, n-s, n-1, 0, n-1, w);
}
//
// Second pass.
//
for(i = 0; i <= n-1; i++)
{
tau = 2*ap::randominteger(2)-1;
ap::vmul(a.getcolumn(i, 0, n-1), tau);
ap::vmul(&a(i, 0), ap::vlen(0,n-1), tau);
}
}
static void testreflections()
{
int i;
int j;
int n;
int m;
int maxmn;
ap::real_1d_array x;
ap::real_1d_array v;
ap::real_1d_array work;
ap::real_2d_array h;
ap::real_2d_array a;
ap::real_2d_array b;
ap::real_2d_array c;
double tmp;
double beta;
double tau;
double err;
double mer;
double mel;
double meg;
int pass;
int passcount;
passcount = 1000;
mer = 0;
mel = 0;
meg = 0;
for(pass = 1; pass <= passcount; pass++)
{
//
// Task
//
n = 1+ap::randominteger(10);
m = 1+ap::randominteger(10);
maxmn = ap::maxint(m, n);
//
// Initialize
//
x.setbounds(1, maxmn);
v.setbounds(1, maxmn);
work.setbounds(1, maxmn);
h.setbounds(1, maxmn, 1, maxmn);
a.setbounds(1, maxmn, 1, maxmn);
b.setbounds(1, maxmn, 1, maxmn);
c.setbounds(1, maxmn, 1, maxmn);
//
// GenerateReflection
//
for(i = 1; i <= n; i++)
{
x(i) = 2*ap::randomreal()-1;
v(i) = x(i);
}
generatereflection(v, n, tau);
beta = v(1);
v(1) = 1;
for(i = 1; i <= n; i++)
{
for(j = 1; j <= n; j++)
{
if( i==j )
{
h(i,j) = 1-tau*v(i)*v(j);
}
else
{
h(i,j) = -tau*v(i)*v(j);
}
}
}
err = 0;
for(i = 1; i <= n; i++)
{
tmp = ap::vdotproduct(&h(i, 1), &x(1), ap::vlen(1,n));
if( i==1 )
{
err = ap::maxreal(err, fabs(tmp-beta));
}
else
{
err = ap::maxreal(err, fabs(tmp));
}
}
meg = ap::maxreal(meg, err);
//
// ApplyReflectionFromTheLeft
//
for(i = 1; i <= m; i++)
{
x(i) = 2*ap::randomreal()-1;
v(i) = x(i);
}
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
a(i,j) = 2*ap::randomreal()-1;
b(i,j) = a(i,j);
}
}
generatereflection(v, m, tau);
beta = v(1);
v(1) = 1;
applyreflectionfromtheleft(b, tau, v, 1, m, 1, n, work);
for(i = 1; i <= m; i++)
{
for(j = 1; j <= m; j++)
{
if( i==j )
{
h(i,j) = 1-tau*v(i)*v(j);
}
else
{
h(i,j) = -tau*v(i)*v(j);
}
}
}
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
tmp = ap::vdotproduct(h.getrow(i, 1, m), a.getcolumn(j, 1, m));
c(i,j) = tmp;
}
}
err = 0;
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
err = ap::maxreal(err, fabs(b(i,j)-c(i,j)));
}
}
mel = ap::maxreal(mel, err);
//
// ApplyReflectionFromTheRight
//
for(i = 1; i <= n; i++)
{
x(i) = 2*ap::randomreal()-1;
v(i) = x(i);
}
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
a(i,j) = 2*ap::randomreal()-1;
b(i,j) = a(i,j);
}
}
generatereflection(v, n, tau);
beta = v(1);
v(1) = 1;
applyreflectionfromtheright(b, tau, v, 1, m, 1, n, work);
for(i = 1; i <= n; i++)
{
for(j = 1; j <= n; j++)
{
if( i==j )
{
h(i,j) = 1-tau*v(i)*v(j);
}
else
{
h(i,j) = -tau*v(i)*v(j);
}
}
}
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
tmp = ap::vdotproduct(a.getrow(i, 1, n), h.getcolumn(j, 1, n));
c(i,j) = tmp;
}
}
err = 0;
for(i = 1; i <= m; i++)
{
for(j = 1; j <= n; j++)
{
err = ap::maxreal(err, fabs(b(i,j)-c(i,j)));
}
}
mer = ap::maxreal(mer, err);
}
//
// Overflow crash test
//
x.setbounds(1, 10);
v.setbounds(1, 10);
for(i = 1; i <= 10; i++)
{
v(i) = ap::maxrealnumber*0.01*(2*ap::randomreal()-1);
}
generatereflection(v, 10, tau);
printf("TESTING REFLECTIONS\n");
printf("Pass count is %0ld\n",
long(passcount));
printf("Generate absolute error is %5.3le\n",
double(meg));
printf("Apply(Left) absolute error is %5.3le\n",
double(mel));
printf("Apply(Right) absolute error is %5.3le\n",
double(mer));
printf("Overflow crash test passed\n");
}
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;
}
}
/*************************************************************************
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);
}
}
}
/*************************************************************************
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 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;
}
}
}
}
/*************************************************************************
Multiplication by matrix P which reduces matrix A to bidiagonal form.
The algorithm allows pre- or post-multiply by P or P'.
Input parameters:
QP - matrices Q and P in compact form.
Output of RMatrixBD subroutine.
M - number of rows in matrix A.
N - number of columns in matrix A.
TAUP - scalar factors which are used to form P.
Output of RMatrixBD subroutine.
Z - multiplied matrix.
Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
ZRows - number of rows in matrix Z. If FromTheRight=False,
ZRows=N, otherwise ZRows can be arbitrary.
ZColumns - number of columns in matrix Z. If FromTheRight=True,
ZColumns=N, otherwise ZColumns can be arbitrary.
FromTheRight - pre- or post-multiply.
DoTranspose - multiply by P or P'.
Output parameters:
Z - product of Z and P.
Array whose indexes range within [0..ZRows-1,0..ZColumns-1].
If ZRows=0 or ZColumns=0, the array is not modified.
-- ALGLIB --
Copyright 2005-2007 by Bochkanov Sergey
*************************************************************************/
void rmatrixbdmultiplybyp(const ap::real_2d_array& qp,
int m,
int n,
const ap::real_1d_array& taup,
ap::real_2d_array& z,
int zrows,
int zcolumns,
bool fromtheright,
bool dotranspose)
{
int i;
ap::real_1d_array v;
ap::real_1d_array work;
int mx;
int i1;
int i2;
int istep;
if( m<=0||n<=0||zrows<=0||zcolumns<=0 )
{
return;
}
ap::ap_error::make_assertion((fromtheright&&zcolumns==n)||(!fromtheright&&zrows==n), "RMatrixBDMultiplyByP: 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);
v.setbounds(0, mx);
work.setbounds(0, mx);
if( m>=n )
{
//
// setup
//
if( fromtheright )
{
i1 = n-2;
i2 = 0;
istep = -1;
}
else
{
i1 = 0;
i2 = n-2;
istep = +1;
}
if( !dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
if( n-1>0 )
{
i = i1;
do
{
ap::vmove(&v(1), &qp(i, i+1), ap::vlen(1,n-1-i));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, taup(i), v, 0, zrows-1, i+1, n-1, work);
}
else
{
applyreflectionfromtheleft(z, taup(i), v, i+1, n-1, 0, zcolumns-1, work);
}
i = i+istep;
}
while(i!=i2+istep);
}
}
else
{
//
// setup
//
if( fromtheright )
{
i1 = m-1;
i2 = 0;
istep = -1;
}
else
{
i1 = 0;
i2 = m-1;
istep = +1;
}
if( !dotranspose )
{
i = i1;
i1 = i2;
i2 = i;
istep = -istep;
}
//
// Process
//
i = i1;
do
{
ap::vmove(&v(1), &qp(i, i), ap::vlen(1,n-i));
v(1) = 1;
if( fromtheright )
{
applyreflectionfromtheright(z, taup(i), v, 0, zrows-1, i, n-1, work);
}
else
{
applyreflectionfromtheleft(z, taup(i), v, i, n-1, 0, zcolumns-1, work);
}
i = i+istep;
}
while(i!=i2+istep);
}
}
/*************************************************************************
Obsolete 1-based subroutine.
See RMatrixBDUnpackPT for 0-based replacement.
*************************************************************************/
void unpackptfrombidiagonal(const ap::real_2d_array& qp,
int m,
int n,
const ap::real_1d_array& taup,
int ptrows,
ap::real_2d_array& pt)
{
int i;
int j;
int ip1;
ap::real_1d_array v;
ap::real_1d_array work;
int vm;
ap::ap_error::make_assertion(ptrows<=n, "UnpackPTFromBidiagonal: PTRows>N!");
if( m==0||n==0||ptrows==0 )
{
return;
}
//
// init
//
pt.setbounds(1, ptrows, 1, n);
v.setbounds(1, n);
work.setbounds(1, ptrows);
//
// prepare PT
//
for(i = 1; i <= ptrows; i++)
{
for(j = 1; j <= n; j++)
{
if( i==j )
{
pt(i,j) = 1;
}
else
{
pt(i,j) = 0;
}
}
}
if( m>=n )
{
for(i = ap::minint(n-1, ptrows-1); i >= 1; i--)
{
vm = n-i;
ip1 = i+1;
ap::vmove(&v(1), &qp(i, ip1), ap::vlen(1,vm));
v(1) = 1;
applyreflectionfromtheright(pt, taup(i), v, 1, ptrows, i+1, n, work);
}
}
else
{
for(i = ap::minint(m, ptrows); i >= 1; i--)
{
vm = n-i+1;
ap::vmove(&v(1), &qp(i, i), ap::vlen(1,vm));
v(1) = 1;
applyreflectionfromtheright(pt, taup(i), v, 1, ptrows, i, n, work);
}
}
}
