void
sqrdc (float **x, int n, int p, float *qraux, int *jpvt,
float *work, int job)
/*****************************************************************************
Use Householder transformations to compute the QR decomposition of an n by p
matrix x. Column pivoting based on the 2-norms of the reduced columns may be
performed at the user's option.
******************************************************************************
Input:
x matrix[p][n] to decompose (see notes below)
n number of rows in the matrix x
p number of columns in the matrix x
jpvt array[p] controlling the pivot columns (see notes below)
job =0 for no pivoting;
=1 for pivoting
Output:
x matrix[p][n] decomposed (see notes below)
qraux array[p] containing information required to recover the
orthogonal part of the decomposition
jpvt array[p] with jpvt[k] containing the index of the original
matrix that has been interchanged into the k-th column, if
pivoting is requested.
Workspace:
work array[p] of workspace
******************************************************************************
Notes:
This function was adapted from LINPACK FORTRAN. Because two-dimensional
arrays cannot be declared with variable dimensions in C, the matrix x
is actually a pointer to an array of pointers to floats, as declared
above and used below.
Elements of x are stored as follows:
x[0][0] x[1][0] x[2][0] ... x[p-1][0]
x[0][1] x[1][1] x[2][1] ... x[p-1][1]
x[0][2] x[1][2] x[2][2] ... x[p-1][2]
. .
. . .
. . .
. .
x[0][n-1] x[1][n-1] x[2][n-1] ... x[p-1][n-1]
After decomposition, x contains in its upper triangular matrix R of the QR
decomposition. Below its diagonal x contains information from which the
orthogonal part of the decomposition can be recovered. Note that if
pivoting has been requested, the decomposition is not that of the original
matrix x but that of x with its columns permuted as described by jpvt.
The selection of pivot columns is controlled by jpvt as follows.
The k-th column x[k] of x is placed in one of three classes according to
the value of jpvt[k].
if jpvt[k] > 0, then x[k] is an initial column.
if jpvt[k] == 0, then x[k] is a free column.
if jpvt[k] < 0, then x[k] is a final column.
Before the decomposition is computed, initial columns are moved to the
beginning of the array x and final columns to the end. Both initial and
final columns are frozen in place during the computation and only free
columns are moved. At the k-th stage of the reduction, if x[k] is occupied
by a free column it is interchanged with the free column of largest reduced
norm. jpvt is not referenced if job == 0.
******************************************************************************
Author: Dave Hale, Colorado School of Mines, 12/29/89
*****************************************************************************/
{
int j,jp,l,lup,maxj,pl,pu,negj,swapj;
float maxnrm,t,tt,ttt,nrmxl;
pl = 0;
pu = -1;
/* if pivoting has been requested */
if (job!=0) {
/* rearrange columns according to jpvt */
for (j=0; j<p; j++) {
swapj = jpvt[j]>0;
negj = jpvt[j]<0;
jpvt[j] = j;
if (negj) jpvt[j] = -j;
if (swapj) {
if (j!=pl) sswap(n,x[pl],1,x[j],1);
jpvt[j] = jpvt[pl];
jpvt[pl] = j;
pl++;
}
}
pu = p-1;
for (j=p-1; j>=0; j--) {
if (jpvt[j]<0) {
jpvt[j] = -jpvt[j];
if (j!=pu) {
sswap(n,x[pu],1,x[j],1);
jp = jpvt[pu];
jpvt[pu] = jpvt[j];
jpvt[j] = jp;
}
pu--;
}
}
}
/* compute the norms of the free columns */
for (j=pl; j<=pu; j++) {
qraux[j] = snrm2(n,x[j],1);
work[j] = qraux[j];
}
/* perform the Householder reduction of x */
lup = MIN(n,p);
for (l=0; l<lup; l++) {
if (l>=pl && l<pu) {
/*
* locate the column of largest norm and
* bring it into pivot position.
*/
maxnrm = 0.0;
maxj = l;
for (j=l; j<=pu; j++) {
if (qraux[j]>maxnrm) {
maxnrm = qraux[j];
maxj = j;
}
}
if (maxj!=l) {
sswap(n,x[l],1,x[maxj],1);
qraux[maxj] = qraux[l];
work[maxj] = work[l];
jp = jpvt[maxj];
jpvt[maxj] = jpvt[l];
jpvt[l] = jp;
}
}
qraux[l] = 0.0;
if (l!=n-1) {
/*
* compute the Householder transformation
* for column l
*/
nrmxl = snrm2(n-l,&x[l][l],1);
if (nrmxl!=0.0) {
if (x[l][l]!=0.0)
nrmxl = (x[l][l]>0.0) ?
ABS(nrmxl) :
-ABS(nrmxl);
sscal(n-l,1.0/nrmxl,&x[l][l],1);
x[l][l] += 1.0;
/*
* apply the transformation to the remaining
* columns, updating the norms
*/
for (j=l+1; j<p; j++) {
t = -sdot(n-l,&x[l][l],1,&x[j][l],1)/
x[l][l];
saxpy(n-l,t,&x[l][l],1,&x[j][l],1);
if (j>=pl && j<=pu && qraux[j]!=0.0) {
tt = ABS(x[j][l])/qraux[j];
tt = 1.0-tt*tt;
tt = MAX(tt,0.0);
t = tt;
ttt = qraux[j]/work[j];
tt = 1.0+0.05*tt*ttt*ttt;
if (tt!=1.0) {
qraux[j] *= sqrt(t);
} else {
qraux[j] = snrm2(n-l-1,
&x[j][l+1],1);
work[j] = qraux[j];
}
}
}
/* save the transformation */
qraux[l] = x[l][l];
x[l][l] = -nrmxl;
}
}
}
}
main()
{
int i,n=N;
printf("isamax = %d\n",isamax(n,sx,1));
printf("isamax = %d\n",isamax(n/2,sx,2));
printf("isamax = %d\n",isamax(n,sy,1));
printf("sasum = %g\n",sasum(n,sx,1));
printf("sasum = %g\n",sasum(n/2,sx,2));
printf("sasum = %g\n",sasum(n,sy,1));
printf("snrm2 = %g\n",snrm2(n,sx,1));
printf("snrm2 = %g\n",snrm2(n/2,sx,2));
printf("snrm2 = %g\n",snrm2(n,sy,1));
printf("sdot = %g\n",sdot(n,sx,1,sy,1));
printf("sdot = %g\n",sdot(n/2,sx,2,sy,2));
printf("sdot = %g\n",sdot(n/2,sx,-2,sy,2));
printf("sdot = %g\n",sdot(n,sy,1,sy,1));
printf("sscal\n");
sscal(n,2.0,sx,1);
pvec(n,sx);
sscal(n,0.5,sx,1);
pvec(n,sx);
sscal(n/2,2.0,sx,2);
pvec(n,sx);
sscal(n/2,0.5,sx,2);
pvec(n,sx);
printf("sswap\n");
sswap(n,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
sswap(n,sy,1,sx,1);
pvec(n,sx); pvec(n,sy);
sswap(n/2,sx,1,sx+n/2,-1);
pvec(n,sx);
sswap(n/2,sx,1,sx+n/2,-1);
pvec(n,sx);
sswap(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
sswap(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
printf("saxpy\n");
saxpy(n,2.0,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n,-2.0,sx,1,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,2.0,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,-2.0,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,2.0,sx,-2,sy,1);
pvec(n,sx); pvec(n,sy);
saxpy(n/2,-2.0,sx,-2,sy,1);
pvec(n,sx); pvec(n,sy);
printf("scopy\n");
scopy(n/2,sx,2,sy,2);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx+1,2,sy+1,2);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx,2,sy,1);
pvec(n,sx); pvec(n,sy);
scopy(n/2,sx+1,-2,sy+n/2,-1);
pvec(n,sx); pvec(n,sy);
}
