Exemple #1
0
void qrdecomposition(ap::real_2d_array& a,
     int m,
     int n,
     ap::real_1d_array& tau)
{
    ap::real_1d_array work;
    ap::real_1d_array t;
    int i;
    int k;
    int mmip1;
    int minmn;
    double tmp;

    minmn = ap::minint(m, n);
    work.setbounds(1, n);
    t.setbounds(1, m);
    tau.setbounds(1, minmn);
    
    //
    // Test the input arguments
    //
    k = ap::minint(m, n);
    for(i = 1; i <= k; i++)
    {
        
        //
        // Generate elementary reflector H(i) to annihilate A(i+1:m,i)
        //
        mmip1 = m-i+1;
        ap::vmove(t.getvector(1, mmip1), a.getcolumn(i, i, m));
        generatereflection(t, mmip1, tmp);
        tau(i) = tmp;
        ap::vmove(a.getcolumn(i, i, m), t.getvector(1, mmip1));
        t(1) = 1;
        if( i<n )
        {
            
            //
            // Apply H(i) to A(i:m,i+1:n) from the left
            //
            applyreflectionfromtheleft(a, tau(i), t, i, m, i+1, n, work);
        }
    }
}
Exemple #2
0
/*************************************************************************
QR decomposition of a rectangular matrix of size MxN

Input parameters:
    A   -   matrix A whose indexes range within [0..M-1, 0..N-1].
    M   -   number of rows in matrix A.
    N   -   number of columns in matrix A.

Output parameters:
    A   -   matrices Q and R in compact form (see below).
    Tau -   array of scalar factors which are used to form
            matrix Q. Array whose index ranges within [0.. Min(M-1,N-1)].

Matrix A is represented as A = QR, where Q is an orthogonal matrix of size
MxM, R - upper triangular (or upper trapezoid) matrix of size M x N.

The elements of matrix R are located on and above the main diagonal of
matrix A. The elements which are located in Tau array and below the main
diagonal of matrix A are used to form matrix Q as follows:

Matrix Q is represented as a product of elementary reflections

Q = H(0)*H(2)*...*H(k-1),

where k = min(m,n), and each H(i) is in the form

H(i) = 1 - tau * v * (v^T)

where tau is a scalar stored in Tau[I]; v - real vector,
so that v(0:i-1) = 0, v(i) = 1, v(i+1:m-1) stored in A(i+1:m-1,i).

  -- LAPACK routine (version 3.0) --
     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
     Courant Institute, Argonne National Lab, and Rice University
     February 29, 1992.
     Translation from FORTRAN to pseudocode (AlgoPascal)
     by Sergey Bochkanov, ALGLIB project, 2005-2007.
*************************************************************************/
void rmatrixqr(ap::real_2d_array& a, int m, int n, ap::real_1d_array& tau)
{
    ap::real_1d_array work;
    ap::real_1d_array t;
    int i;
    int k;
    int minmn;
    double tmp;

    if( m<=0||n<=0 )
    {
        return;
    }
    minmn = ap::minint(m, n);
    work.setbounds(0, n-1);
    t.setbounds(1, m);
    tau.setbounds(0, minmn-1);
    
    //
    // Test the input arguments
    //
    k = minmn;
    for(i = 0; i <= k-1; i++)
    {
        
        //
        // Generate elementary reflector H(i) to annihilate A(i+1:m,i)
        //
        ap::vmove(t.getvector(1, m-i), a.getcolumn(i, i, m-1));
        generatereflection(t, m-i, tmp);
        tau(i) = tmp;
        ap::vmove(a.getcolumn(i, i, m-1), t.getvector(1, m-i));
        t(1) = 1;
        if( i<n )
        {
            
            //
            // Apply H(i) to A(i:m-1,i+1:n-1) from the left
            //
            applyreflectionfromtheleft(a, tau(i), t, i, m-1, i+1, n-1, work);
        }
    }
}
/*************************************************************************
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);
    }
}
/*************************************************************************
Multiplication of MxN matrix by MxM random Haar distributed orthogonal matrix

INPUT PARAMETERS:
    A   -   matrix, array[0..M-1, 0..N-1]
    M, N-   matrix size

OUTPUT PARAMETERS:
    A   -   Q*A, where Q is random MxM orthogonal matrix

  -- ALGLIB routine --
     04.12.2009
     Bochkanov Sergey
*************************************************************************/
void rmatrixrndorthogonalfromtheleft(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( m==1 )
    {
        
        //
        // special case
        //
        tau = 2*ap::randominteger(2)-1;
        for(j = 0; j <= n-1; j++)
        {
            a(0,j) = a(0,j)*tau;
        }
        return;
    }
    
    //
    // General case.
    // First pass.
    //
    w.setbounds(0, n-1);
    v.setbounds(1, m);
    hqrndrandomize(state);
    for(s = 2; s <= m; 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;
        applyreflectionfromtheleft(a, tau, v, m-s, m-1, 0, n-1, w);
    }
    
    //
    // Second pass.
    //
    for(i = 0; i <= m-1; i++)
    {
        tau = 2*ap::randominteger(2)-1;
        ap::vmul(&a(i, 0), ap::vlen(0,n-1), tau);
    }
}
Exemple #5
0
static void internalauxschur(bool wantt,
     bool wantz,
     int n,
     int ilo,
     int ihi,
     ap::real_2d_array& h,
     ap::real_1d_array& wr,
     ap::real_1d_array& wi,
     int iloz,
     int ihiz,
     ap::real_2d_array& z,
     ap::real_1d_array& work,
     ap::real_1d_array& workv3,
     ap::real_1d_array& workc1,
     ap::real_1d_array& works1,
     int& info)
{
    int i;
    int i1;
    int i2;
    int itn;
    int its;
    int j;
    int k;
    int l;
    int m;
    int nh;
    int nr;
    int nz;
    double ave;
    double cs;
    double disc;
    double h00;
    double h10;
    double h11;
    double h12;
    double h21;
    double h22;
    double h33;
    double h33s;
    double h43h34;
    double h44;
    double h44s;
    double ovfl;
    double s;
    double smlnum;
    double sn;
    double sum;
    double t1;
    double t2;
    double t3;
    double tst1;
    double unfl;
    double v1;
    double v2;
    double v3;
    bool failflag;
    double dat1;
    double dat2;
    int p1;
    double him1im1;
    double him1i;
    double hiim1;
    double hii;
    double wrim1;
    double wri;
    double wiim1;
    double wii;
    double ulp;

    info = 0;
    dat1 = 0.75;
    dat2 = -0.4375;
    ulp = ap::machineepsilon;
    
    //
    // Quick return if possible
    //
    if( n==0 )
    {
        return;
    }
    if( ilo==ihi )
    {
        wr(ilo) = h(ilo,ilo);
        wi(ilo) = 0;
        return;
    }
    nh = ihi-ilo+1;
    nz = ihiz-iloz+1;
    
    //
    // Set machine-dependent constants for the stopping criterion.
    // If norm(H) <= sqrt(OVFL), overflow should not occur.
    //
    unfl = ap::minrealnumber;
    ovfl = 1/unfl;
    smlnum = unfl*(nh/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 QR iterations allowed.
    //
    itn = 30*nh;
    
    //
    // The main loop begins here. I is the loop index and decreases from
    // IHI to ILO in steps of 1 or 2. 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 = ihi;
    while(true)
    {
        l = ilo;
        if( i<ilo )
        {
            return;
        }
        
        //
        // Perform QR iterations on rows and columns ILO to I until a
        // submatrix of order 1 or 2 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>ilo )
            {
                
                //
                // H(L,L-1) is negligible
                //
                h(l,l-1) = 0;
            }
            
            //
            // Exit from loop if a submatrix of order 1 or 2 has split off.
            //
            if( l>=i-1 )
            {
                failflag = false;
                break;
            }
            
            //
            // Now the active submatrix is in rows and columns L to I. If
            // eigenvalues only are being computed, only the active submatrix
            // need be transformed.
            //
            if( !wantt )
            {
                i1 = l;
                i2 = i;
            }
            if( its==10||its==20 )
            {
                
                //
                // Exceptional shift.
                //
                s = fabs(h(i,i-1))+fabs(h(i-1,i-2));
                h44 = dat1*s+h(i,i);
                h33 = h44;
                h43h34 = dat2*s*s;
            }
            else
            {
                
                //
                // Prepare to use Francis' double shift
                // (i.e. 2nd degree generalized Rayleigh quotient)
                //
                h44 = h(i,i);
                h33 = h(i-1,i-1);
                h43h34 = h(i,i-1)*h(i-1,i);
                s = h(i-1,i-2)*h(i-1,i-2);
                disc = (h33-h44)*0.5;
                disc = disc*disc+h43h34;
                if( disc>0 )
                {
                    
                    //
                    // Real roots: use Wilkinson's shift twice
                    //
                    disc = sqrt(disc);
                    ave = 0.5*(h33+h44);
                    if( fabs(h33)-fabs(h44)>0 )
                    {
                        h33 = h33*h44-h43h34;
                        h44 = h33/(extschursign(disc, ave)+ave);
                    }
                    else
                    {
                        h44 = extschursign(disc, ave)+ave;
                    }
                    h33 = h44;
                    h43h34 = 0;
                }
            }
            
            //
            // Look for two consecutive small subdiagonal elements.
            //
            for(m = i-2; m >= l; m--)
            {
                
                //
                // Determine the effect of starting the double-shift QR
                // iteration at row M, and see if this would make H(M,M-1)
                // negligible.
                //
                h11 = h(m,m);
                h22 = h(m+1,m+1);
                h21 = h(m+1,m);
                h12 = h(m,m+1);
                h44s = h44-h11;
                h33s = h33-h11;
                v1 = (h33s*h44s-h43h34)/h21+h12;
                v2 = h22-h11-h33s-h44s;
                v3 = h(m+2,m+1);
                s = fabs(v1)+fabs(v2)+fabs(v3);
                v1 = v1/s;
                v2 = v2/s;
                v3 = v3/s;
                workv3(1) = v1;
                workv3(2) = v2;
                workv3(3) = v3;
                if( m==l )
                {
                    break;
                }
                h00 = h(m-1,m-1);
                h10 = h(m,m-1);
                tst1 = fabs(v1)*(fabs(h00)+fabs(h11)+fabs(h22));
                if( fabs(h10)*(fabs(v2)+fabs(v3))<=ulp*tst1 )
                {
                    break;
                }
            }
            
            //
            // Double-shift QR step
            //
            for(k = m; 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(3, i-k+1);
                if( k>m )
                {
                    for(p1 = 1; p1 <= nr; p1++)
                    {
                        workv3(p1) = h(k+p1-1,k-1);
                    }
                }
                generatereflection(workv3, nr, t1);
                if( k>m )
                {
                    h(k,k-1) = workv3(1);
                    h(k+1,k-1) = 0;
                    if( k<i-1 )
                    {
                        h(k+2,k-1) = 0;
                    }
                }
                else
                {
                    if( m>l )
                    {
                        h(k,k-1) = -h(k,k-1);
                    }
                }
                v2 = workv3(2);
                t2 = t1*v2;
                if( nr==3 )
                {
                    v3 = workv3(3);
                    t3 = t1*v3;
                    
                    //
                    // Apply G from the left to transform the rows of the matrix
                    // in columns K to I2.
                    //
                    for(j = k; j <= i2; j++)
                    {
                        sum = h(k,j)+v2*h(k+1,j)+v3*h(k+2,j);
                        h(k,j) = h(k,j)-sum*t1;
                        h(k+1,j) = h(k+1,j)-sum*t2;
                        h(k+2,j) = h(k+2,j)-sum*t3;
                    }
                    
                    //
                    // Apply G from the right to transform the columns of the
                    // matrix in rows I1 to min(K+3,I).
                    //
                    for(j = i1; j <= ap::minint(k+3, i); j++)
                    {
                        sum = h(j,k)+v2*h(j,k+1)+v3*h(j,k+2);
                        h(j,k) = h(j,k)-sum*t1;
                        h(j,k+1) = h(j,k+1)-sum*t2;
                        h(j,k+2) = h(j,k+2)-sum*t3;
                    }
                    if( wantz )
                    {
                        
                        //
                        // Accumulate transformations in the matrix Z
                        //
                        for(j = iloz; j <= ihiz; j++)
                        {
                            sum = z(j,k)+v2*z(j,k+1)+v3*z(j,k+2);
                            z(j,k) = z(j,k)-sum*t1;
                            z(j,k+1) = z(j,k+1)-sum*t2;
                            z(j,k+2) = z(j,k+2)-sum*t3;
                        }
                    }
                }
                else
                {
                    if( nr==2 )
                    {
                        
                        //
                        // Apply G from the left to transform the rows of the matrix
                        // in columns K to I2.
                        //
                        for(j = k; j <= i2; j++)
                        {
                            sum = h(k,j)+v2*h(k+1,j);
                            h(k,j) = h(k,j)-sum*t1;
                            h(k+1,j) = h(k+1,j)-sum*t2;
                        }
                        
                        //
                        // Apply G from the right to transform the columns of the
                        // matrix in rows I1 to min(K+3,I).
                        //
                        for(j = i1; j <= i; j++)
                        {
                            sum = h(j,k)+v2*h(j,k+1);
                            h(j,k) = h(j,k)-sum*t1;
                            h(j,k+1) = h(j,k+1)-sum*t2;
                        }
                        if( wantz )
                        {
                            
                            //
                            // Accumulate transformations in the matrix Z
                            //
                            for(j = iloz; j <= ihiz; j++)
                            {
                                sum = z(j,k)+v2*z(j,k+1);
                                z(j,k) = z(j,k)-sum*t1;
                                z(j,k+1) = z(j,k+1)-sum*t2;
                            }
                        }
                    }
                }
            }
        }
        if( failflag )
        {
            
            //
            // Failure to converge in remaining number of iterations
            //
            info = i;
            return;
        }
        if( l==i )
        {
            
            //
            // H(I,I-1) is negligible: one eigenvalue has converged.
            //
            wr(i) = h(i,i);
            wi(i) = 0;
        }
        else
        {
            if( l==i-1 )
            {
                
                //
                // H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
                //
                //        Transform the 2-by-2 submatrix to standard Schur form,
                //        and compute and store the eigenvalues.
                //
                him1im1 = h(i-1,i-1);
                him1i = h(i-1,i);
                hiim1 = h(i,i-1);
                hii = h(i,i);
                aux2x2schur(him1im1, him1i, hiim1, hii, wrim1, wiim1, wri, wii, cs, sn);
                wr(i-1) = wrim1;
                wi(i-1) = wiim1;
                wr(i) = wri;
                wi(i) = wii;
                h(i-1,i-1) = him1im1;
                h(i-1,i) = him1i;
                h(i,i-1) = hiim1;
                h(i,i) = hii;
                if( wantt )
                {
                    
                    //
                    // Apply the transformation to the rest of H.
                    //
                    if( i2>i )
                    {
                        workc1(1) = cs;
                        works1(1) = sn;
                        applyrotationsfromtheleft(true, i-1, i, i+1, i2, workc1, works1, h, work);
                    }
                    workc1(1) = cs;
                    works1(1) = sn;
                    applyrotationsfromtheright(true, i1, i-2, i-1, i, workc1, works1, h, work);
                }
                if( wantz )
                {
                    
                    //
                    // Apply the transformation to Z.
                    //
                    workc1(1) = cs;
                    works1(1) = sn;
                    applyrotationsfromtheright(true, iloz, iloz+nz-1, i-1, i, workc1, works1, z, work);
                }
            }
        }
        
        //
        // Decrement number of remaining iterations, and return to start of
        // the main loop with new value of I.
        //
        itn = itn-its;
        i = l-1;
    }
}
Exemple #6
0
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;
    }
}
Exemple #7
0
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");
}
Exemple #8
0
/*************************************************************************
Reduction of a rectangular matrix to  bidiagonal form

The algorithm reduces the rectangular matrix A to  bidiagonal form by
orthogonal transformations P and Q: A = Q*B*P.

Input parameters:
    A       -   source matrix. array[0..M-1, 0..N-1]
    M       -   number of rows in matrix A.
    N       -   number of columns in matrix A.

Output parameters:
    A       -   matrices Q, B, P in compact form (see below).
    TauQ    -   scalar factors which are used to form matrix Q.
    TauP    -   scalar factors which are used to form matrix P.

The main diagonal and one of the  secondary  diagonals  of  matrix  A  are
replaced with bidiagonal  matrix  B.  Other  elements  contain  elementary
reflections which form MxM matrix Q and NxN matrix P, respectively.

If M>=N, B is the upper  bidiagonal  MxN  matrix  and  is  stored  in  the
corresponding  elements  of  matrix  A.  Matrix  Q  is  represented  as  a
product   of   elementary   reflections   Q = H(0)*H(1)*...*H(n-1),  where
H(i) = 1-tau*v*v'. Here tau is a scalar which is stored  in  TauQ[i],  and
vector v has the following  structure:  v(0:i-1)=0, v(i)=1, v(i+1:m-1)  is
stored   in   elements   A(i+1:m-1,i).   Matrix   P  is  as  follows:  P =
G(0)*G(1)*...*G(n-2), where G(i) = 1 - tau*u*u'. Tau is stored in TauP[i],
u(0:i)=0, u(i+1)=1, u(i+2:n-1) is stored in elements A(i,i+2:n-1).

If M<N, B is the  lower  bidiagonal  MxN  matrix  and  is  stored  in  the
corresponding   elements  of  matrix  A.  Q = H(0)*H(1)*...*H(m-2),  where
H(i) = 1 - tau*v*v', tau is stored in TauQ, v(0:i)=0, v(i+1)=1, v(i+2:m-1)
is    stored    in   elements   A(i+2:m-1,i).    P = G(0)*G(1)*...*G(m-1),
G(i) = 1-tau*u*u', tau is stored in  TauP,  u(0:i-1)=0, u(i)=1, u(i+1:n-1)
is stored in A(i,i+1:n-1).

EXAMPLE:

m=6, n=5 (m > n):               m=5, n=6 (m < n):

(  d   e   u1  u1  u1 )         (  d   u1  u1  u1  u1  u1 )
(  v1  d   e   u2  u2 )         (  e   d   u2  u2  u2  u2 )
(  v1  v2  d   e   u3 )         (  v1  e   d   u3  u3  u3 )
(  v1  v2  v3  d   e  )         (  v1  v2  e   d   u4  u4 )
(  v1  v2  v3  v4  d  )         (  v1  v2  v3  e   d   u5 )
(  v1  v2  v3  v4  v5 )

Here vi and ui are vectors which form H(i) and G(i), and d and e -
are the diagonal and off-diagonal elements of matrix B.
*************************************************************************/
void rmatrixbd(ap::real_2d_array& a,
     int m,
     int n,
     ap::real_1d_array& tauq,
     ap::real_1d_array& taup)
{
    ap::real_1d_array work;
    ap::real_1d_array t;
    int maxmn;
    int i;
    double ltau;

    
    //
    // Prepare
    //
    if( n<=0||m<=0 )
    {
        return;
    }
    maxmn = ap::maxint(m, n);
    work.setbounds(0, maxmn);
    t.setbounds(0, maxmn);
    if( m>=n )
    {
        tauq.setbounds(0, n-1);
        taup.setbounds(0, n-1);
    }
    else
    {
        tauq.setbounds(0, m-1);
        taup.setbounds(0, m-1);
    }
    if( m>=n )
    {
        
        //
        // Reduce to upper bidiagonal form
        //
        for(i = 0; i <= n-1; i++)
        {
            
            //
            // Generate elementary reflector H(i) to annihilate A(i+1:m-1,i)
            //
            ap::vmove(t.getvector(1, m-i), a.getcolumn(i, i, m-1));
            generatereflection(t, m-i, ltau);
            tauq(i) = ltau;
            ap::vmove(a.getcolumn(i, i, m-1), t.getvector(1, m-i));
            t(1) = 1;
            
            //
            // Apply H(i) to A(i:m-1,i+1:n-1) from the left
            //
            applyreflectionfromtheleft(a, ltau, t, i, m-1, i+1, n-1, work);
            if( i<n-1 )
            {
                
                //
                // Generate elementary reflector G(i) to annihilate
                // A(i,i+2:n-1)
                //
                ap::vmove(&t(1), &a(i, i+1), ap::vlen(1,n-i-1));
                generatereflection(t, n-1-i, ltau);
                taup(i) = ltau;
                ap::vmove(&a(i, i+1), &t(1), ap::vlen(i+1,n-1));
                t(1) = 1;
                
                //
                // Apply G(i) to A(i+1:m-1,i+1:n-1) from the right
                //
                applyreflectionfromtheright(a, ltau, t, i+1, m-1, i+1, n-1, work);
            }
            else
            {
                taup(i) = 0;
            }
        }
    }
    else
    {
        
        //
        // Reduce to lower bidiagonal form
        //
        for(i = 0; i <= m-1; i++)
        {
            
            //
            // Generate elementary reflector G(i) to annihilate A(i,i+1:n-1)
            //
            ap::vmove(&t(1), &a(i, i), ap::vlen(1,n-i));
            generatereflection(t, n-i, ltau);
            taup(i) = ltau;
            ap::vmove(&a(i, i), &t(1), ap::vlen(i,n-1));
            t(1) = 1;
            
            //
            // Apply G(i) to A(i+1:m-1,i:n-1) from the right
            //
            applyreflectionfromtheright(a, ltau, t, i+1, m-1, i, n-1, work);
            if( i<m-1 )
            {
                
                //
                // Generate elementary reflector H(i) to annihilate
                // A(i+2:m-1,i)
                //
                ap::vmove(t.getvector(1, m-1-i), a.getcolumn(i, i+1, m-1));
                generatereflection(t, m-1-i, ltau);
                tauq(i) = ltau;
                ap::vmove(a.getcolumn(i, i+1, m-1), t.getvector(1, m-1-i));
                t(1) = 1;
                
                //
                // Apply H(i) to A(i+1:m-1,i+1:n-1) from the left
                //
                applyreflectionfromtheleft(a, ltau, t, i+1, m-1, i+1, n-1, work);
            }
            else
            {
                tauq(i) = 0;
            }
        }
    }
}
Exemple #9
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;
            }
        }
    }
}
/*************************************************************************
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);
    }
}
/*************************************************************************
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);
    }
}