/*
----------------------------------------------
return the number of bytes taken by the object
created -- 98may01, cca
----------------------------------------------
*/
int
A2_sizeOf (
A2 *mtx
) {
int nbytes ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL ) {
fprintf(stderr, "\n fatal error in A2_sizeOf(%p)"
"\n bad input\n", mtx) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_sizeOf(%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, mtx->type) ;
exit(-1) ;
}
if ( A2_IS_REAL(mtx) ) {
nbytes = sizeof(struct _A2) + mtx->nowned*sizeof(double) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
nbytes = sizeof(struct _A2) + 2*mtx->nowned*sizeof(double) ;
}
return(nbytes) ; }
/*
---------------------------------------------------------------
shift the base of the entries and adjust dimensions
mtx(0:n1-rowoff-1,0:n2-coloff-1) = mtx(rowoff:n1-1,coloff:n2-1)
created -- 98may01, cca
---------------------------------------------------------------
*/
void
A2_shiftBase (
A2 *mtx,
int rowoff,
int coloff
) {
/*
---------------
check the input
---------------
*/
if ( mtx == NULL ) {
fprintf(stderr, "\n fatal error in A2_shiftbase(%p,%d,%d)"
"\n bad input\n", mtx, rowoff, coloff) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_shiftBase(%p,%d,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, rowoff, coloff, mtx->type) ;
exit(-1) ;
}
mtx->n1 -= rowoff ;
mtx->n2 -= coloff ;
if ( A2_IS_REAL(mtx) ) {
mtx->entries += rowoff*mtx->inc1 + coloff*mtx->inc2 ;
} else if ( A2_IS_COMPLEX(mtx) ) {
mtx->entries += 2*(rowoff*mtx->inc1 + coloff*mtx->inc2) ;
}
return ; }
/*
-----------------------------------------------
fill the matrix with normal(0,1) random numbers
created -- 98may01, cca
-----------------------------------------------
*/
void
A2_fillRandomNormal (
A2 *a,
double mean,
double variance,
int seed
) {
double *entries ;
int i, inc1, inc2, j, loc, n1, n2 ;
Drand drand ;
/*
---------------
check the input
---------------
*/
if ( a == NULL
|| (n1 = a->n1) <= 0
|| (n2 = a->n2) <= 0
|| (inc1 = a->inc1) <= 0
|| (inc2 = a->inc2) <= 0
|| (entries = a->entries) == NULL ) {
fprintf(stderr, "\n fatal error in A2_fillRandomNormal(%p,%d)"
"\n bad input\n",
a, seed) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(a) || A2_IS_COMPLEX(a)) ) {
fprintf(stderr, "\n fatal error in A2_fillRandomNormal(%p,%f,%f,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
a, mean, variance, seed, a->type) ;
exit(-1) ;
}
/*
----------------
fill the entries
----------------
*/
Drand_setDefaultFields(&drand) ;
Drand_init(&drand) ;
Drand_setSeed(&drand, seed) ;
Drand_setUniform(&drand, mean, variance) ;
for ( j = 0 ; j < n2 ; j++ ) {
for ( i = 0 ; i < n1 ; i++ ) {
loc = i*inc1 + j*inc2 ;
if ( A2_IS_REAL(a) ) {
entries[loc] = Drand_value(&drand) ;
} else if ( A2_IS_COMPLEX(a) ) {
entries[2*loc] = Drand_value(&drand) ;
entries[2*loc+1] = Drand_value(&drand) ;
}
}
}
return ; }
/*
-----------------------
transpose the matrix
created -- 98may01, cca
-----------------------
*/
void
A2_transpose (
A2 *mtx
) {
int inc1, n1 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL ) {
fprintf(stderr, "\n fatal error in A2_transpose(%p)"
"\n bad input\n", mtx) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_transpose(%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, mtx->type) ;
exit(-1) ;
}
n1 = mtx->n1 ;
mtx->n1 = mtx->n2 ;
mtx->n2 = n1 ;
inc1 = mtx->inc1 ;
mtx->inc1 = mtx->inc2 ;
mtx->inc2 = inc1 ;
return ; }
/*
-----------------------------------------------
purpose -- to write the matrix in matlab format
created -- 98may01, cca
-----------------------------------------------
*/
void
A2_writeForMatlab (
A2 *mtx,
char *mtxname,
FILE *fp
) {
int irow, jcol, ncol, nrow ;
if ( mtx == NULL || mtxname == NULL || fp == NULL ) {
fprintf(stderr, "\n fatal error in A2_writeForMatlab(%p,%p,%p)"
"\n bad input\n", mtx, mtxname, fp) ;
spoolesFatal();
}
nrow = A2_nrow(mtx) ;
ncol = A2_ncol(mtx) ;
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
if ( A2_IS_REAL(mtx) ) {
double value ;
A2_realEntry(mtx, irow, jcol, &value) ;
fprintf(fp, "\n %s(%d,%d) = %24.16e ;",
mtxname, irow+1, jcol+1, value) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
double imag, real ;
A2_complexEntry(mtx, irow, jcol, &real, &imag) ;
fprintf(fp, "\n %s(%d,%d) = %24.16e + %24.16e*i ;",
mtxname, irow+1, jcol+1, real, imag) ;
}
}
}
return ; }
/*
--------------------------------------------------------
purpose -- to write an adjacency object to a binary file
created -- 98may01, cca
--------------------------------------------------------
*/
void
A2_writeToBinaryFile (
A2 *mtx,
FILE *fp
) {
int size ;
if ( fp == NULL ) {
return ;
}
fwrite((void *) &mtx->type, sizeof(int), 1, fp) ;
fwrite((void *) &mtx->n1, sizeof(int), 1, fp) ;
fwrite((void *) &mtx->n2, sizeof(int), 1, fp) ;
fwrite((void *) &mtx->inc1, sizeof(int), 1, fp) ;
fwrite((void *) &mtx->inc2, sizeof(int), 1, fp) ;
if ( (size = 1 + (mtx->n1-1)*mtx->inc1 + (mtx->n2-1)*mtx->inc2) > 0
&& mtx->entries != NULL ) {
if ( A2_IS_REAL(mtx) ) {
fwrite((void *) &mtx->entries, sizeof(double), size, fp) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
fwrite((void *) &mtx->entries, sizeof(double), 2*size, fp) ;
}
}
return ; }
/*
-----------------------
set mtx(irow,*) = y[*]
created -- 98may01, cca
-----------------------
*/
void
A2_setRowDV (
A2 *mtx,
DV *rowDV,
int irow
) {
double *entries, *row ;
int inc2, j, k, n2 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || rowDV == NULL || DV_size(rowDV) != (n2 = mtx->n2)
|| irow < 0 || irow >= mtx->n1 ) {
fprintf(stderr, "\n fatal error in A2_setRowDV(%p,%p,%d)"
"\n bad input\n", mtx, rowDV, irow) ;
exit(-1) ;
}
if ( ! A2_IS_REAL(mtx) ) {
fprintf(stderr, "\n fatal error in A2_setRowDV(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL\n",
mtx, rowDV, irow, mtx->type) ;
exit(-1) ;
}
k = irow * mtx->inc1 ;
inc2 = mtx->inc2 ;
entries = mtx->entries ;
row = DV_entries(rowDV) ;
for ( j = 0 ; j < n2 ; j++, k += inc2 ) {
entries[k] = row[j] ;
}
return ; }
/*
-----------------------
set mtx(*,jcol) = y[*]
created -- 98may01, cca
-----------------------
*/
void
A2_setColumnDV (
A2 *mtx,
DV *colDV,
int jcol
) {
double *col, *entries ;
int inc1, i, k, n1 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || colDV == NULL || DV_size(colDV) != (n1 = mtx->n1)
|| jcol < 0 || jcol >= mtx->n2 ) {
fprintf(stderr, "\n fatal error in A2_setColumnDV(%p,%p,%d)"
"\n bad input\n", mtx, colDV, jcol) ;
exit(-1) ;
}
if ( ! A2_IS_REAL(mtx) ) {
fprintf(stderr, "\n fatal error in A2_setColumnDV(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL\n",
mtx, colDV, jcol, mtx->type) ;
exit(-1) ;
}
k = jcol * mtx->inc2 ;
inc1 = mtx->inc1 ;
entries = mtx->entries ;
col = DV_entries(colDV) ;
for ( i = 0 ; i < n1 ; i++, k += inc1 ) {
entries[k] = col[i] ;
}
return ; }
/*
--------------------------------------------------------------
returns 1 if the storage is row major, otherwise returns zero.
created -- 98may01, cca
--------------------------------------------------------------
*/
int
A2_rowMajor (
A2 *mtx
) {
/*
---------------
check the input
---------------
*/
if ( mtx == NULL ) {
fprintf(stderr, "\n fatal error in A2_rowMajor(%p)"
"\n bad input\n", mtx) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_rowMajor(%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, mtx->type) ;
exit(-1) ;
}
if ( mtx->inc2 == 1 ) {
return(1) ;
} else {
return(0) ;
} }
/*
--------------------------
fill the matrix with zeros
created -- 98may01, cca
--------------------------
*/
void
A2_zero (
A2 *a
) {
double *entries ;
int i, inc1, inc2, j, loc, n1, n2 ;
/*
---------------
check the input
---------------
*/
if ( a == NULL
|| (n1 = a->n1) <= 0
|| (n2 = a->n2) <= 0
|| (inc1 = a->inc1) <= 0
|| (inc2 = a->inc2) <= 0
|| (entries = a->entries) == NULL ) {
fprintf(stderr, "\n fatal error in A2_zero(%p)"
"\n bad input\n", a) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(a) || A2_IS_COMPLEX(a)) ) {
fprintf(stderr, "\n fatal error in A2_zero(%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
a, a->type) ;
exit(-1) ;
}
for ( j = 0 ; j < n2 ; j++ ) {
for ( i = 0 ; i < n1 ; i++ ) {
loc =i*inc1 + j*inc2 ;
if ( A2_IS_REAL(a) ) {
entries[loc] = 0.0 ;
} else if ( A2_IS_COMPLEX(a) ) {
entries[2*loc] = 0.0 ;
entries[2*loc+1] = 0.0 ;
}
}
}
return ; }
/*
----------------------------
extract row[*] = mtx(irow,*)
created -- 98may01, cca
----------------------------
*/
void
A2_extractRow (
A2 *mtx,
double row[],
int irow
) {
double *entries ;
int inc2, j, k, n2 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || row == NULL || mtx->entries == NULL
|| irow < 0 || irow >= mtx->n1 ) {
fprintf(stderr, "\n fatal error in A2_extractRow(%p,%p,%d)"
"\n bad input\n", mtx, row, irow) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_extractRow(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, row, irow, mtx->type) ;
exit(-1) ;
}
k = irow * mtx->inc1 ;
n2 = mtx->n2 ;
inc2 = mtx->inc2 ;
entries = mtx->entries ;
if ( A2_IS_REAL(mtx) ) {
for ( j = 0 ; j < n2 ; j++, k += inc2 ) {
row[j] = entries[k] ;
}
} else if ( A2_IS_COMPLEX(mtx) ) {
for ( j = 0 ; j < n2 ; j++, k += inc2 ) {
row[2*j] = entries[2*k] ;
row[2*j+1] = entries[2*k+1] ;
}
}
return ; }
/*
----------------------------
extract col[*] = mtx(*,jcol)
created -- 98may01, cca
----------------------------
*/
void
A2_extractColumn (
A2 *mtx,
double col[],
int jcol
) {
double *entries ;
int i, inc1, k, n1 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || col == NULL || mtx->entries == NULL
|| jcol < 0 || jcol >= mtx->n2 ) {
fprintf(stderr, "\n fatal error in A2_extractColumn(%p,%p,%d)"
"\n bad input\n", mtx, col, jcol) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_extractColumn(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, col, jcol, mtx->type) ;
exit(-1) ;
}
k = jcol * mtx->inc2 ;
n1 = mtx->n1 ;
inc1 = mtx->inc1 ;
entries = mtx->entries ;
if ( A2_IS_REAL(mtx) ) {
for ( i = 0 ; i < n1 ; i++, k += inc1 ) {
col[i] = entries[k] ;
}
} else if ( A2_IS_COMPLEX(mtx) ) {
for ( i = 0 ; i < n1 ; i++, k += inc1 ) {
col[2*i] = entries[2*k] ;
col[2*i+1] = entries[2*k+1] ;
}
}
return ; }
/*
----------------------------------------------
purpose -- to write the object for a human eye
created -- 98may01, cca
----------------------------------------------
*/
void
A2_writeForHumanEye (
A2 *mtx,
FILE *fp
) {
int i, j, jfirst, jlast, loc ;
if ( mtx == NULL || fp == NULL ) {
fprintf(stderr, "\n fatal error in A2_writeForHumanEye(%p,%p)"
"\n bad input\n", mtx, fp) ;
spoolesFatal();
}
A2_writeStats(mtx, fp) ;
if ( A2_IS_REAL(mtx) ) {
for ( jfirst = 0 ; jfirst < mtx->n2 ; jfirst += 4 ) {
jlast = jfirst + 3 ;
if ( jlast >= mtx->n2 ) {
jlast = mtx->n2 - 1 ;
}
fprintf(fp, "\n ") ;
for ( j = jfirst ; j <= jlast ; j++ ) {
fprintf(fp, "%19d", j) ;
}
for ( i = 0 ; i < mtx->n1 ; i++ ) {
fprintf(fp, "\n%4d", i) ;
for ( j = jfirst ; j <= jlast ; j++ ) {
fprintf(fp, "%19.11e",
mtx->entries[i*mtx->inc1 + j*mtx->inc2]) ;
}
}
}
} else if ( A2_IS_COMPLEX(mtx) ) {
for ( jfirst = 0 ; jfirst < mtx->n2 ; jfirst += 2 ) {
jlast = jfirst + 1 ;
if ( jlast >= mtx->n2 ) {
jlast = mtx->n2 - 1 ;
}
fprintf(fp, "\n ") ;
for ( j = jfirst ; j <= jlast ; j++ ) {
fprintf(fp, "%36d", j) ;
}
for ( i = 0 ; i < mtx->n1 ; i++ ) {
fprintf(fp, "\n%4d", i) ;
for ( j = jfirst ; j <= jlast ; j++ ) {
loc = 2*(i*mtx->inc1 + j*mtx->inc2) ;
fprintf(fp, " (%16.9e,%16.9e*i)",
mtx->entries[loc], mtx->entries[loc+1]) ;
}
}
}
}
return ; }
/*
----------------------------------------
fill the matrix with the identity matrix
created -- 98may01, cca
----------------------------------------
*/
void
A2_fillWithIdentity (
A2 *a
) {
double *entries ;
int ii, inc, inc1, inc2, j, n ;
/*
---------------
check the input
---------------
*/
if ( a == NULL
|| (n = a->n1) <= 0
|| n != a->n2
|| (inc1 = a->inc1) <= 0
|| (inc2 = a->inc2) <= 0
|| (inc1 != 1 && inc2 != 1)
|| (entries = a->entries) == NULL ) {
fprintf(stderr, "\n fatal error in A2_fillWithIdentity(%p)"
"\n bad input\n", a) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(a) || A2_IS_COMPLEX(a)) ) {
fprintf(stderr, "\n fatal error in A2_fillWithIdentity(%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
a, a->type) ;
exit(-1) ;
}
inc = (inc1 == 1) ? inc2 : inc1 ;
A2_zero(a) ;
for ( j = 0, ii = 0 ; j < n ; j++, ii += inc + 1 ) {
if ( A2_IS_REAL(a) ) {
entries[ii] = 1.0 ;
} else if ( A2_IS_COMPLEX(a) ) {
entries[2*ii] = 1.0 ;
}
}
return ; }
/*
--------------------------------------------------
copy the first column of mtxA into the vector H0[]
created -- 98may30, cca
--------------------------------------------------
*/
static int
copyIntoVec1 (
A2 *mtxA,
double H0[],
int msglvl,
FILE *msgFile
) {
double ival, rval ;
double *colA ;
int ii, inc1, irow, jj, lastrow, ncolA, nrowA ;
/*
----------------------------------
copy the column of A into a vector
and find the last nonzero element
----------------------------------
*/
nrowA = mtxA->n1 ;
ncolA = mtxA->n2 ;
inc1 = mtxA->inc1 ;
lastrow = -1 ;
colA = A2_column(mtxA, 0) ;
if ( A2_IS_REAL(mtxA) ) {
for ( irow = ii = jj = 0 ;
irow < nrowA ;
irow++, ii += inc1, jj++ ) {
rval = colA[ii] ;
if ( rval != 0.0 ) {
H0[jj] = rval ;
lastrow = irow ;
}
}
} else if ( A2_IS_COMPLEX(mtxA) ) {
for ( irow = ii = jj = 0 ;
irow < nrowA ;
irow++, ii += 2*inc1, jj += 2 ) {
rval = colA[ii] ; ival = colA[ii+1] ;
if ( rval != 0.0 || ival != 0.0 ) {
H0[jj] = rval ; H0[jj+1] = ival ;
lastrow = irow ;
}
}
}
return(lastrow) ; }
/*
-------------------------------------------------
purpose -- to write an object to a formatted file
created -- 98may01, cca
-------------------------------------------------
*/
void
A2_writeToFormattedFile (
A2 *mtx,
FILE *fp
) {
int size ;
if ( mtx == NULL || fp == NULL ) {
return ;
}
fprintf(fp, "\n %d %d %d %d %d",
mtx->type, mtx->n1, mtx->n2, mtx->inc1, mtx->inc2) ;
if ( (size = 1 + (mtx->n1-1)*mtx->inc1 + (mtx->n2-1)*mtx->inc2) > 0
&& mtx->entries != NULL ) {
if ( A2_IS_REAL(mtx) ) {
DVfprintf(fp, size, mtx->entries) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
DVfprintf(fp, 2*size, mtx->entries) ;
}
}
return ; }
/*
--------------------------------------
purpose -- to write out the statistics
created -- 98may01, cca
--------------------------------------
*/
void
A2_writeStats (
A2 *mtx,
FILE *fp
) {
if ( mtx == NULL || fp == NULL ) {
fprintf(stderr, "\n fatal error in A2_writeStats(%p,%p)"
"\n bad input\n", mtx, fp) ;
spoolesFatal();
}
if ( A2_IS_REAL(mtx) ) {
fprintf(fp, "\n A2 : double 2D array object :") ;
} else if ( A2_IS_COMPLEX(mtx) ) {
fprintf(fp, "\n A2 : double complex 2D array object :") ;
}
fprintf(fp,
"\n %d x %d matrix, inc1 = %d, inc2 = %d,"
"\n nowned = %d, %d entries allocated, occupies %d bytes"
"\n entries = %p, maxabs = %20.12e",
mtx->n1, mtx->n2, mtx->inc1, mtx->inc2, mtx->nowned,
mtx->n1*mtx->n2,
A2_sizeOf(mtx), mtx->entries, A2_maxabs(mtx)) ;
return ; }
/*
--------------------------------
subtract one matrix from another
A := A - B
created -- 98may01, cca
----------------------------
*/
void
A2_sub (
A2 *A,
A2 *B
) {
double *entA, *entB ;
int inc1A, inc1B, inc2A, inc2B, irow, jcol, locA, locB,
ncol, ncolA, ncolB, nrow, nrowA, nrowB ;
/*
---------------
check the input
---------------
*/
if ( A == NULL
|| B == NULL
|| (nrowA = A->n1) <= 0
|| (ncolA = A->n2) <= 0
|| (inc1A = A->inc1) <= 0
|| (inc2A = A->inc2) <= 0
|| (nrowB = B->n1) <= 0
|| (ncolB = B->n2) <= 0
|| (inc1B = B->inc1) <= 0
|| (inc2B = B->inc2) <= 0
|| (entA = A->entries) == NULL
|| (entB = B->entries) == NULL ) {
fprintf(stderr, "\n fatal error in A2_sub(%p,%p)"
"\n bad input\n", A, B) ;
if ( A != NULL ) {
fprintf(stderr, "\n\n first A2 object") ;
A2_writeStats(A, stderr) ;
}
if ( B != NULL ) {
fprintf(stderr, "\n\n second A2 object") ;
A2_writeStats(B, stderr) ;
}
exit(-1) ;
}
if ( ! (A2_IS_REAL(A) || A2_IS_COMPLEX(A)) ) {
fprintf(stderr, "\n fatal error in A2_sub(%p,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
A, B, A->type) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(B) || A2_IS_COMPLEX(B)) ) {
fprintf(stderr, "\n fatal error in A2_sub(%p,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
A, B, B->type) ;
exit(-1) ;
}
if ( A->type != B->type ) {
fprintf(stderr, "\n fatal error in A2_sub(%p,%p)"
"\n A's type %d, B's type = %d, must be the same\n",
A, B, A->type, B->type) ;
exit(-1) ;
}
/*
fprintf(stdout, "\n debug : A") ;
A2_writeForHumanEye(A, stdout) ;
fprintf(stdout, "\n debug : B") ;
A2_writeForHumanEye(B, stdout) ;
*/
nrow = (nrowA <= nrowB) ? nrowA : nrowB ;
ncol = (ncolA <= ncolB) ? ncolA : ncolB ;
if ( A2_IS_REAL(A) ) {
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
locA = irow*inc1A + jcol*inc2A ;
locB = irow*inc1B + jcol*inc2B ;
entA[locA] -= entB[locB] ;
}
}
} else if ( A2_IS_COMPLEX(A) ) {
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
locA = irow*inc1A + jcol*inc2A ;
locB = irow*inc1B + jcol*inc2B ;
entA[2*locA] -= entB[2*locB] ;
entA[2*locA+1] -= entB[2*locB+1] ;
}
}
}
return ; }
/*
-----------------------------------------------------------
A contains the following data from the A = QR factorization
A(1:ncolA,1:ncolA) = R
A(j+1:nrowA,j) is v_j, the j-th householder vector,
where v_j[j] = 1.0
NOTE: A and Q must be column major
created -- 98dec10, cca
-----------------------------------------------------------
*/
void
A2_computeQ (
A2 *Q,
A2 *A,
DV *workDV,
int msglvl,
FILE *msgFile
) {
double *betas ;
int irowA, jcolA, ncolA, nrowA ;
/*
---------------
check the input
---------------
*/
if ( Q == NULL ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n Q is NULL\n") ;
exit(-1) ;
}
if ( A == NULL ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n A is NULL\n") ;
exit(-1) ;
}
if ( workDV == NULL ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n workDV is NULL\n") ;
exit(-1) ;
}
if ( msglvl > 0 && msgFile == NULL ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n msglvl > 0 and msgFile is NULL\n") ;
exit(-1) ;
}
nrowA = A2_nrow(A) ;
ncolA = A2_ncol(A) ;
if ( nrowA <= 0 ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n nrowA = %d\n", nrowA) ;
exit(-1) ;
}
if ( ncolA <= 0 ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n ncolA = %d\n", nrowA) ;
exit(-1) ;
}
if ( nrowA != A2_nrow(Q) ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n nrowA = %d, nrowQ = %d\n", nrowA, A2_nrow(Q)) ;
exit(-1) ;
}
if ( ncolA != A2_ncol(Q) ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n ncolA = %d, ncolQ = %d\n", ncolA, A2_ncol(Q)) ;
exit(-1) ;
}
switch ( A->type ) {
case SPOOLES_REAL :
case SPOOLES_COMPLEX :
break ;
default :
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n invalid type for A\n") ;
exit(-1) ;
}
if ( A->type != Q->type ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n A->type = %d, Q->type = %d\n", A->type, Q->type) ;
exit(-1) ;
}
if ( A2_inc1(A) != 1 ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n A->inc1 = %d \n", A2_inc1(A)) ;
exit(-1) ;
}
if ( A2_inc1(Q) != 1 ) {
fprintf(stderr, "\n fatal error in A2_computeQ()"
"\n Q->inc1 = %d, \n", A2_inc1(Q)) ;
exit(-1) ;
}
/*
--------------------------------------------------
compute the beta values, beta_j = 2./(V_j^H * V_j)
--------------------------------------------------
*/
DV_setSize(workDV, ncolA) ;
betas = DV_entries(workDV) ;
if ( A2_IS_REAL(A) ) {
int irowA, jcolA ;
double sum ;
double *colA ;
for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) {
sum = 1.0 ;
colA = A2_column(A, jcolA) ;
for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) {
sum += colA[irowA] * colA[irowA] ;
}
betas[jcolA] = 2./sum ;
}
} else {
double ival, rval, sum ;
double *colA ;
for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) {
sum = 1.0 ;
colA = A2_column(A, jcolA) ;
for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) {
rval = colA[2*irowA] ; ival = colA[2*irowA+1] ;
sum += rval*rval + ival*ival ;
}
betas[jcolA] = 2./sum ;
}
}
/*
-------------------------------------------
loop over the number of householder vectors
-------------------------------------------
*/
for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) {
double *V, *X ;
int jcolV ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n %% jcolA = %d", jcolA) ;
fflush(msgFile) ;
}
/*
------------------
set X[] to e_jcolA
------------------
*/
X = A2_column(Q, jcolA) ;
if ( A2_IS_REAL(Q) ) {
DVzero(nrowA, X) ;
X[jcolA] = 1.0 ;
} else {
DVzero(2*nrowA, X) ;
X[2*jcolA] = 1.0 ;
}
for ( jcolV = jcolA ; jcolV >= 0 ; jcolV-- ) {
double beta ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% jcolV = %d", jcolV) ;
fflush(msgFile) ;
}
/*
-----------------------------------------------------
update X = (I - beta_jcolV * V_jcolV * V_jcolV^T)X
= X - beta_jcolV * V_jcolV * V_jcolV^T * X
= X - (beta_jcolV * V_jcolV^T * X) * V_jcolV
-----------------------------------------------------
*/
V = A2_column(A, jcolV) ;
beta = betas[jcolV] ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% beta = %12.4e", beta) ;
fflush(msgFile) ;
}
if ( A2_IS_REAL(Q) ) {
double fac, sum = X[jcolV] ;
int irow ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n %% V[%d] = %12.4e, X[%d] = %12.4e",
irow, V[irow], irow, X[irow]) ;
fflush(msgFile) ;
}
sum += V[irow] * X[irow] ;
}
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% sum = %12.4e", sum) ;
fflush(msgFile) ;
}
fac = beta * sum ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% fac = %12.4e", fac) ;
fflush(msgFile) ;
}
X[jcolV] -= fac ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
X[irow] -= fac * V[irow] ;
}
} else {
double rfac, ifac, rsum = X[2*jcolV], isum = X[2*jcolV+1] ;
int irow ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
double Vi, Vr, Xi, Xr ;
Vr = V[2*irow] ; Vi = V[2*irow+1] ;
Xr = X[2*irow] ; Xi = X[2*irow+1] ;
rsum += Vr*Xr + Vi*Xi ;
isum += Vr*Xi - Vi*Xr ;
}
rfac = beta * rsum ;
ifac = beta * isum ;
X[2*jcolV] -= rfac ;
X[2*jcolV+1] -= ifac ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
double Vi, Vr ;
Vr = V[2*irow] ; Vi = V[2*irow+1] ;
X[2*irow] -= rfac*Vr - ifac*Vi ;
X[2*irow+1] -= rfac*Vi + ifac*Vr ;
}
}
}
}
return ; }
/*
-----------------------------------------------------------
A contains the following data from the A = QR factorization
A(1:ncolA,1:ncolA) = R
A(j+1:nrowA,j) is v_j, the j-th householder vector,
where v_j[j] = 1.0
we compute Y = Q^T X when A is real
and Y = Q^H X when A is complex
NOTE: A, Y and X must be column major.
NOTE: Y and X can be the same object,
in which case X is overwritten with Y
created -- 98dec10, cca
-----------------------------------------------------------
*/
void
A2_applyQT (
A2 *Y,
A2 *A,
A2 *X,
DV *workDV,
int msglvl,
FILE *msgFile
) {
double *betas ;
int irowA, jcolA, jcolX, ncolA, ncolX, nrowA ;
/*
---------------
check the input
---------------
*/
if ( A == NULL ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n A is NULL\n") ;
exit(-1) ;
}
if ( X == NULL ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n X is NULL\n") ;
exit(-1) ;
}
if ( workDV == NULL ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n workDV is NULL\n") ;
exit(-1) ;
}
if ( msglvl > 0 && msgFile == NULL ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n msglvl > 0 and msgFile is NULL\n") ;
exit(-1) ;
}
nrowA = A2_nrow(A) ;
ncolA = A2_ncol(A) ;
ncolX = A2_ncol(X) ;
if ( nrowA <= 0 ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n nrowA = %d\n", nrowA) ;
exit(-1) ;
}
if ( ncolA <= 0 ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n ncolA = %d\n", nrowA) ;
exit(-1) ;
}
if ( nrowA != A2_nrow(X) ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n nrowA = %d, nrowX = %d\n", nrowA, A2_nrow(X)) ;
exit(-1) ;
}
switch ( A->type ) {
case SPOOLES_REAL :
case SPOOLES_COMPLEX :
break ;
default :
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n invalid type for A\n") ;
exit(-1) ;
}
if ( A->type != X->type ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n A->type = %d, X->type = %d\n", A->type, X->type) ;
exit(-1) ;
}
if ( A2_inc1(A) != 1 ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n A->inc1 = %d \n", A2_inc1(A)) ;
exit(-1) ;
}
if ( A2_inc1(X) != 1 ) {
fprintf(stderr, "\n fatal error in A2_applyQT()"
"\n X->inc1 = %d, \n", A2_inc1(X)) ;
exit(-1) ;
}
/*
--------------------------------------------------
compute the beta values, beta_j = 2./(V_j^H * V_j)
--------------------------------------------------
*/
DV_setSize(workDV, ncolA) ;
betas = DV_entries(workDV) ;
if ( A2_IS_REAL(A) ) {
int irowA, jcolA ;
double sum ;
double *colA ;
for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) {
sum = 1.0 ;
colA = A2_column(A, jcolA) ;
for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) {
sum += colA[irowA] * colA[irowA] ;
}
betas[jcolA] = 2./sum ;
}
} else {
double ival, rval, sum ;
double *colA ;
for ( jcolA = 0 ; jcolA < ncolA ; jcolA++ ) {
sum = 1.0 ;
colA = A2_column(A, jcolA) ;
for ( irowA = jcolA + 1 ; irowA < nrowA ; irowA++ ) {
rval = colA[2*irowA] ; ival = colA[2*irowA+1] ;
sum += rval*rval + ival*ival ;
}
betas[jcolA] = 2./sum ;
}
}
/*
------------------------------------------
loop over the number of columns in X and Y
------------------------------------------
*/
for ( jcolX = 0 ; jcolX < ncolX ; jcolX++ ) {
double *V, *colX, *colY ;
int jcolV ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n %% jcolX = %d", jcolX) ;
fflush(msgFile) ;
}
/*
-------------------------------
copy X(:,jcolX) into Y(:,jcolX)
-------------------------------
*/
colY = A2_column(Y, jcolX) ;
colX = A2_column(X, jcolX) ;
if ( A2_IS_REAL(A) ) {
DVcopy(nrowA, colY, colX) ;
} else {
DVcopy(2*nrowA, colY, colX) ;
}
for ( jcolV = 0 ; jcolV < ncolA ; jcolV++ ) {
double beta ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% jcolV = %d", jcolV) ;
fflush(msgFile) ;
}
/*
------------------------------------------------------------
update colY = (I - beta_jcolV * V_jcolV * V_jcolV^T)colY
= colY - beta_jcolV * V_jcolV * V_jcolV^T * colY
= colY - (beta_jcolV * V_jcolV^T * Y) * V_jcolV
------------------------------------------------------------
*/
V = A2_column(A, jcolV) ;
beta = betas[jcolV] ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% beta = %12.4e", beta) ;
fflush(msgFile) ;
}
if ( A2_IS_REAL(A) ) {
double fac, sum = colY[jcolV] ;
int irow ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n %% V[%d] = %12.4e, X[%d] = %12.4e",
irow, V[irow], irow, colY[irow]) ;
fflush(msgFile) ;
}
sum += V[irow] * colY[irow] ;
}
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% sum = %12.4e", sum) ;
fflush(msgFile) ;
}
fac = beta * sum ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n %% fac = %12.4e", fac) ;
fflush(msgFile) ;
}
colY[jcolV] -= fac ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
colY[irow] -= fac * V[irow] ;
}
} else {
double rfac, ifac,
rsum = colY[2*jcolV], isum = colY[2*jcolV+1] ;
int irow ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
double Vi, Vr, Yi, Yr ;
Vr = V[2*irow] ; Vi = V[2*irow+1] ;
Yr = colY[2*irow] ; Yi = colY[2*irow+1] ;
rsum += Vr*Yr + Vi*Yi ;
isum += Vr*Yi - Vi*Yr ;
}
rfac = beta * rsum ;
ifac = beta * isum ;
colY[2*jcolV] -= rfac ;
colY[2*jcolV+1] -= ifac ;
for ( irow = jcolV + 1 ; irow < nrowA ; irow++ ) {
double Vi, Vr ;
Vr = V[2*irow] ; Vi = V[2*irow+1] ;
colY[2*irow] -= rfac*Vr - ifac*Vi ;
colY[2*irow+1] -= rfac*Vi + ifac*Vr ;
}
}
}
}
return ; }
/*
-----------------------------------------------
purpose -- to read an object from a binary file
return value -- 1 if success, 0 if failure
created -- 98may01, cca
-----------------------------------------------
*/
int
A2_readFromBinaryFile (
A2 *mtx,
FILE *fp
) {
int rc, size ;
int itemp[5] ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || fp == NULL ) {
fprintf(stderr, "\n fatal error in A2_readFromBinaryFile(%p,%p)"
"\n bad input", mtx, fp) ;
return(0) ;
}
/*
---------------------
clear the data fields
---------------------
*/
A2_clearData(mtx) ;
/*
------------------------------------------------------------
read in the five scalar parameters: type, n1, n2, inc1, inc2
------------------------------------------------------------
*/
if ( (rc = fread((char *) itemp, sizeof(int), 5, fp)) != 5 ) {
fprintf(stderr, "\n error in A2_readFromBinaryFile"
"\n %d items of %d read\n", rc, 5) ;
return(0) ;
}
fprintf(stdout, "\n itemp = {%d, %d, %d, %d, %d}",
itemp[0], itemp[1], itemp[2], itemp[3], itemp[4]) ;
fflush(stdout) ;
/*
---------------------
initialize the object
---------------------
*/
A2_init(mtx, itemp[0], itemp[1], itemp[2], itemp[3], itemp[4], NULL) ;
/*
----------------------------
read in the entries[] vector
----------------------------
*/
if ( (size = 1 + (mtx->n1-1)*mtx->inc1 + (mtx->n2-1)*mtx->inc2) > 0 ) {
if ( A2_IS_REAL(mtx) ) {
if ( (rc = fread(mtx->entries, sizeof(double), size, fp))
!= size ) {
fprintf(stderr, "\n error in A2_readFromBinaryFile"
"\n %d items of %d read\n", rc, size) ;
return(0) ;
}
} else if ( A2_IS_COMPLEX(mtx) ) {
if ( (rc = fread(mtx->entries, sizeof(double), 2*size, fp))
!= 2*size ) {
fprintf(stderr, "\n error in A2_readFromBinaryFile"
"\n %d items of %d read\n", rc, 2*size) ;
return(0) ;
}
}
}
return(1) ; }
/*
--------------------------------------------------
purpose -- to read an object from a formatted file
return value -- 1 if success, 0 if failure
created -- 98may01, cca
--------------------------------------------------
*/
int
A2_readFromFormattedFile (
A2 *mtx,
FILE *fp
) {
int rc, size ;
int itemp[5] ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || fp == NULL ) {
fprintf(stderr, "\n error in A2_readFromFormattedFile(%p,%p)"
"\n bad input", mtx, fp) ;
return(0) ;
}
/*
---------------------
clear the data fields
---------------------
*/
A2_clearData(mtx) ;
/*
-----------------------------------------------------------
read in the five scalar parameters: type n1, n2, inc1, inc2
-----------------------------------------------------------
*/
if ( (rc = IVfscanf(fp, 5, itemp)) != 5 ) {
fprintf(stderr, "\n error in A2_readFromFormattedFile()"
"\n %d items of %d read\n", rc, 5) ;
return(0) ;
}
/*
---------------------
initialize the object
---------------------
*/
A2_init(mtx, itemp[0], itemp[1], itemp[2], itemp[3], itemp[4], NULL) ;
/*
----------------------------
read in the entries[] vector
----------------------------
*/
if ( (size = 1 + (mtx->n1-1)*mtx->inc1 + (mtx->n2-1)*mtx->inc2) > 0 ) {
if ( A2_IS_REAL(mtx) ) {
if ( (rc = DVfscanf(fp, size, mtx->entries)) != size ) {
fprintf(stderr, "\n error in A2_readFromFormattedFile"
"\n %d items of %d read\n", rc, size) ;
return(0) ;
}
} else if ( A2_IS_COMPLEX(mtx) ) {
if ( (rc = DVfscanf(fp, 2*size, mtx->entries)) != 2*size ) {
fprintf(stderr, "\n error in A2_readFromFormattedFile"
"\n %d items of %d read\n", rc, 2*size) ;
return(0) ;
}
}
}
return(1) ; }
/*
--------------------------------------------------------------
purpose -- create and return an A2 object that contains rows
of A and rows from update matrices of the children.
the matrix may not be in staircase form
created -- 98may25, cca
--------------------------------------------------------------
*/
A2 *
FrontMtx_QR_assembleFront (
FrontMtx *frontmtx,
int J,
InpMtx *mtxA,
IVL *rowsIVL,
int firstnz[],
int colmap[],
Chv *firstchild,
DV *workDV,
int msglvl,
FILE *msgFile
) {
A2 *frontJ ;
Chv *chvI ;
double *rowI, *rowJ, *rowentA ;
int ii, irow, irowA, irowI, jcol, jj, jrow, ncolI, ncolJ,
nentA, nrowI, nrowJ, nrowFromA ;
int *colindA, *colindI, *colindJ, *map, *rowids, *rowsFromA ;
/*
---------------
check the input
---------------
*/
if ( frontmtx == NULL || mtxA == NULL || rowsIVL == NULL
|| (msglvl > 0 && msgFile == NULL) ) {
fprintf(stderr, "\n fatal error in FrontMtx_QR_assembleFront()"
"\n bad input\n") ;
exit(-1) ;
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n\n inside FrontMtx_QR_assembleFront(%d)", J) ;
fflush(msgFile) ;
}
/*
--------------------------------------------------
set up the map from global to local column indices
--------------------------------------------------
*/
FrontMtx_columnIndices(frontmtx, J, &ncolJ, &colindJ) ;
for ( jcol = 0 ; jcol < ncolJ ; jcol++ ) {
colmap[colindJ[jcol]] = jcol ;
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n front %d's column indices", J) ;
IVfprintf(msgFile, ncolJ, colindJ) ;
fflush(msgFile) ;
}
/*
-------------------------------------------------
compute the size of the front and map the global
indices of the update matrices into local indices
-------------------------------------------------
*/
IVL_listAndSize(rowsIVL, J, &nrowFromA, &rowsFromA) ;
nrowJ = nrowFromA ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n %d rows from A", nrowFromA) ;
fflush(msgFile) ;
}
for ( chvI = firstchild ; chvI != NULL ; chvI = chvI->next ) {
nrowJ += chvI->nD ;
Chv_columnIndices(chvI, &ncolI, &colindI) ;
for ( jcol = 0 ; jcol < ncolI ; jcol++ ) {
colindI[jcol] = colmap[colindI[jcol]] ;
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n %d rows from child %d", chvI->nD, chvI->id) ;
fflush(msgFile) ;
}
}
/*
----------------------------------------------------------
get workspace for the rowids[nrowJ] and map[nrowJ] vectors
----------------------------------------------------------
*/
if ( sizeof(int) == sizeof(double) ) {
DV_setSize(workDV, 2*nrowJ) ;
} else if ( 2*sizeof(int) == sizeof(double) ) {
DV_setSize(workDV, nrowJ) ;
}
rowids = (int *) DV_entries(workDV) ;
map = rowids + nrowJ ;
IVramp(nrowJ, rowids, 0, 1) ;
IVfill(nrowJ, map, -1) ;
/*
-----------------------------------------------------------------
get the map from incoming rows to their place in the front matrix
-----------------------------------------------------------------
*/
for ( irow = jrow = 0 ; irow < nrowFromA ; irow++, jrow++ ) {
irowA = rowsFromA[irow] ;
map[jrow] = colmap[firstnz[irowA]] ;
}
for ( chvI = firstchild ; chvI != NULL ; chvI = chvI->next ) {
nrowI = chvI->nD ;
Chv_columnIndices(chvI, &ncolI, &colindI) ;
for ( irow = 0 ; irow < nrowI ; irow++, jrow++ ) {
map[jrow] = colindI[irow] ;
}
}
IV2qsortUp(nrowJ, map, rowids) ;
for ( irow = 0 ; irow < nrowJ ; irow++ ) {
map[rowids[irow]] = irow ;
}
/*
----------------------------
allocate the A2 front object
----------------------------
*/
frontJ = A2_new() ;
A2_init(frontJ, frontmtx->type, nrowJ, ncolJ, ncolJ, 1, NULL) ;
A2_zero(frontJ) ;
/*
------------------------------------
load the original rows of the matrix
------------------------------------
*/
for ( jrow = 0 ; jrow < nrowFromA ; jrow++ ) {
irowA = rowsFromA[jrow] ;
rowJ = A2_row(frontJ, map[jrow]) ;
if ( A2_IS_REAL(frontJ) ) {
InpMtx_realVector(mtxA, irowA, &nentA, &colindA, &rowentA) ;
} else if ( A2_IS_COMPLEX(frontJ) ) {
InpMtx_complexVector(mtxA, irowA, &nentA, &colindA, &rowentA) ;
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n loading row %d", irowA) ;
fprintf(msgFile, "\n global indices") ;
IVfprintf(msgFile, nentA, colindA) ;
fflush(msgFile) ;
}
if ( A2_IS_REAL(frontJ) ) {
for ( ii = 0 ; ii < nentA ; ii++ ) {
jj = colmap[colindA[ii]] ;
rowJ[jj] = rowentA[ii] ;
}
} else if ( A2_IS_COMPLEX(frontJ) ) {
for ( ii = 0 ; ii < nentA ; ii++ ) {
jj = colmap[colindA[ii]] ;
rowJ[2*jj] = rowentA[2*ii] ;
rowJ[2*jj+1] = rowentA[2*ii+1] ;
}
}
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n after assembling rows of A") ;
A2_writeForHumanEye(frontJ, msgFile) ;
fflush(msgFile) ;
}
/*
----------------------------------
load the updates from the children
----------------------------------
*/
for ( chvI = firstchild ; chvI != NULL ; chvI = chvI->next ) {
nrowI = chvI->nD ;
Chv_columnIndices(chvI, &ncolI, &colindI) ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n loading child %d", chvI->id) ;
fprintf(msgFile, "\n child's column indices") ;
IVfprintf(msgFile, ncolI, colindI) ;
Chv_writeForHumanEye(chvI, msgFile) ;
fflush(msgFile) ;
}
rowI = Chv_entries(chvI) ;
for ( irowI = 0 ; irowI < nrowI ; irowI++, jrow++ ) {
rowJ = A2_row(frontJ, map[jrow]) ;
if ( A2_IS_REAL(frontJ) ) {
for ( ii = irowI ; ii < ncolI ; ii++ ) {
jj = colindI[ii] ;
rowJ[jj] = rowI[ii] ;
}
rowI += ncolI - irowI - 1 ;
} else if ( A2_IS_COMPLEX(frontJ) ) {
for ( ii = irowI ; ii < ncolI ; ii++ ) {
jj = colindI[ii] ;
rowJ[2*jj] = rowI[2*ii] ;
rowJ[2*jj+1] = rowI[2*ii+1] ;
}
rowI += 2*(ncolI - irowI - 1) ;
}
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n after assembling child %d", chvI->id) ;
A2_writeForHumanEye(frontJ, msgFile) ;
fflush(msgFile) ;
}
}
return(frontJ) ; }
/*
----------------------------------------------------
store the factor entries of the reduced front matrix
created -- 98may25, cca
----------------------------------------------------
*/
void
FrontMtx_QR_storeFront (
FrontMtx *frontmtx,
int J,
A2 *frontJ,
int msglvl,
FILE *msgFile
) {
A2 tempA2 ;
double fac, ifac, imag, real, rfac ;
double *entDJJ, *entUJJ, *entUJN, *row ;
int inc1, inc2, irow, jcol, ncol, ncolJ, nD, nentD, nentUJJ,
nfront, nrow, nU ;
int *colind, *colindJ, *firstlocs, *sizes ;
SubMtx *mtx ;
/*
---------------
check the input
---------------
*/
if ( frontmtx == NULL || frontJ == NULL
|| (msglvl > 0 && msgFile == NULL) ) {
fprintf(stderr, "\n fatal error in FrontMtx_QR_storeFront()"
"\n bad input\n") ;
exit(-1) ;
}
nfront = FrontMtx_nfront(frontmtx) ;
FrontMtx_columnIndices(frontmtx, J, &ncolJ, &colindJ) ;
nrow = A2_nrow(frontJ) ;
ncol = A2_ncol(frontJ) ;
A2_setDefaultFields(&tempA2) ;
nD = FrontMtx_frontSize(frontmtx, J) ;
nU = ncol - nD ;
/*
--------------------------------------
scale the rows and square the diagonal
--------------------------------------
*/
row = A2_entries(frontJ) ;
if ( A2_IS_REAL(frontJ) ) {
for ( irow = 0 ; irow < nD ; irow++ ) {
if ( row[irow] != 0.0 ) {
fac = 1./row[irow] ;
for ( jcol = irow + 1 ; jcol < ncol ; jcol++ ) {
row[jcol] *= fac ;
}
row[irow] = row[irow] * row[irow] ;
}
row += ncol ;
}
} else if ( A2_IS_COMPLEX(frontJ) ) {
for ( irow = 0 ; irow < nD ; irow++ ) {
real = row[2*irow] ; imag = row[2*irow+1] ;
if ( real != 0.0 || imag != 0.0 ) {
Zrecip(real, imag, &rfac, &ifac) ;
ZVscale(ncol - irow - 1, & row[2*irow+2], rfac, ifac) ;
row[2*irow] = real*real + imag*imag ;
row[2*irow+1] = 0.0 ;
}
row += 2*ncol ;
}
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n after scaling rows of A") ;
A2_writeForHumanEye(frontJ, msgFile) ;
fflush(msgFile) ;
}
/*
-------------------------
copy the diagonal entries
-------------------------
*/
mtx = FrontMtx_diagMtx(frontmtx, J) ;
SubMtx_diagonalInfo(mtx, &nentD, &entDJJ) ;
A2_subA2(&tempA2, frontJ, 0, nD-1, 0, nD-1) ;
A2_copyEntriesToVector(&tempA2, nentD, entDJJ,
A2_DIAGONAL, A2_BY_ROWS) ;
SubMtx_columnIndices(mtx, &ncol, &colind) ;
IVcopy(nD, colind, colindJ) ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n diagonal factor matrix") ;
SubMtx_writeForHumanEye(mtx, msgFile) ;
fflush(msgFile) ;
}
if ( (mtx = FrontMtx_upperMtx(frontmtx, J, J)) != NULL ) {
/*
------------------------
copy the U_{J,J} entries
------------------------
*/
SubMtx_denseSubcolumnsInfo(mtx, &nD, &nentUJJ,
&firstlocs, &sizes, &entUJJ) ;
A2_copyEntriesToVector(&tempA2, nentUJJ, entUJJ,
A2_STRICT_UPPER, A2_BY_COLUMNS) ;
SubMtx_columnIndices(mtx, &ncol, &colind) ;
IVcopy(nD, colind, colindJ) ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n UJJ factor matrix") ;
SubMtx_writeForHumanEye(mtx, msgFile) ;
fflush(msgFile) ;
}
}
if ( ncolJ > nD ) {
/*
-----------------------------
copy the U_{J,bnd{J}} entries
-----------------------------
*/
mtx = FrontMtx_upperMtx(frontmtx, J, nfront) ;
SubMtx_denseInfo(mtx, &nD, &nU, &inc1, &inc2, &entUJN) ;
A2_subA2(&tempA2, frontJ, 0, nD-1, nD, ncolJ-1) ;
A2_copyEntriesToVector(&tempA2, nD*nU, entUJN,
A2_ALL_ENTRIES, A2_BY_COLUMNS) ;
SubMtx_columnIndices(mtx, &ncol, &colind) ;
IVcopy(nU, colind, colindJ + nD) ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n UJN factor matrix") ;
SubMtx_writeForHumanEye(mtx, msgFile) ;
fflush(msgFile) ;
}
}
return ; }
/*
-------------------------------------------------
sort the columns of the matrix in ascending order
of the colids[] vector. on return, colids is
in asending order. return value is the number
of column swaps made.
created -- 98apr15, cca
-------------------------------------------------
*/
int
A2_sortColumnsUp (
A2 *mtx,
int ncol,
int colids[]
) {
int ii, mincol, mincolid, nswap, target ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || mtx->n2 < ncol || ncol < 0 || colids == NULL ) {
fprintf(stderr, "\n fatal error in A2_sortColumnsUp(%p,%d,%p)"
"\n bad input\n", mtx, ncol, colids) ;
if ( mtx != NULL ) {
A2_writeStats(mtx, stderr) ;
}
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_sortColumnsUp(%p,%d,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, ncol, colids, mtx->type) ;
exit(-1) ;
}
nswap = 0 ;
if ( mtx->inc2 == 1 ) {
double *dvtmp ;
int irow, nrow ;
int *ivtmp ;
/*
---------------------------------------------------
matrix is stored by rows, so permute each row
---------------------------------------------------
*/
ivtmp = IVinit(ncol, -1) ;
if ( A2_IS_REAL(mtx) ) {
dvtmp = DVinit(ncol, 0.0) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
dvtmp = DVinit(2*ncol, 0.0) ;
}
IVramp(ncol, ivtmp, 0, 1) ;
IV2qsortUp(ncol, colids, ivtmp) ;
nrow = mtx->n1 ;
for ( irow = 0 ; irow < nrow ; irow++ ) {
if ( A2_IS_REAL(mtx) ) {
DVcopy(ncol, dvtmp, A2_row(mtx, irow)) ;
DVgather(ncol, A2_row(mtx, irow), dvtmp, ivtmp) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
ZVcopy(ncol, dvtmp, A2_row(mtx, irow)) ;
ZVgather(ncol, A2_row(mtx, irow), dvtmp, ivtmp) ;
}
}
IVfree(ivtmp) ;
DVfree(dvtmp) ;
} else {
/*
----------------------------------------
use a simple insertion sort to swap cols
----------------------------------------
*/
for ( target = 0 ; target < ncol ; target++ ) {
mincol = target ;
mincolid = colids[target] ;
for ( ii = target + 1 ; ii < ncol ; ii++ ) {
if ( mincolid > colids[ii] ) {
mincol = ii ;
mincolid = colids[ii] ;
}
}
if ( mincol != target ) {
colids[mincol] = colids[target] ;
colids[target] = mincolid ;
A2_swapColumns(mtx, target, mincol) ;
nswap++ ;
}
}
}
return(nswap) ; }
/*
---------------------------------
compute A := A - H0 * beta0 * W0
created -- 98may30, cca
---------------------------------
*/
static double
updateA1 (
A2 *mtxA,
double H0[],
double beta0,
double W0[],
int msglvl,
FILE *msgFile
) {
double nops ;
int inc1, inc2, ncolA, nrowA ;
if ( msglvl > 5 ) {
fprintf(msgFile, "\n %% inside updateA1, nrow %d, ncol %d",
mtxA->n1, mtxA->n2) ;
}
nrowA = mtxA->n1 ;
ncolA = mtxA->n2 ;
inc1 = mtxA->inc1 ;
inc2 = mtxA->inc2 ;
nops = 0.0 ;
if ( A2_IS_REAL(mtxA) ) {
int irow, jcol ;
if ( inc1 == 1 ) {
double alpha[3] ;
double *colA0, *colA1, *colA2 ;
/*
-----------------------------------------
A is column major
compute A(:,jcol) -= beta * W0(jcol) * H0
-----------------------------------------
*/
for ( jcol = 0 ; jcol < ncolA - 2 ; jcol += 3 ) {
colA0 = A2_column(mtxA, jcol) ;
colA1 = A2_column(mtxA, jcol+1) ;
colA2 = A2_column(mtxA, jcol+2) ;
alpha[0] = -beta0 * W0[jcol] ;
alpha[1] = -beta0 * W0[jcol+1] ;
alpha[2] = -beta0 * W0[jcol+2] ;
DVaxpy31(nrowA, colA0, colA1, colA2, alpha, H0) ;
nops += 6*nrowA ;
}
if ( jcol == ncolA - 2 ) {
colA0 = A2_column(mtxA, jcol) ;
colA1 = A2_column(mtxA, jcol+1) ;
alpha[0] = -beta0 * W0[jcol] ;
alpha[1] = -beta0 * W0[jcol+1] ;
DVaxpy21(nrowA, colA0, colA1, alpha, H0) ;
nops += 4*nrowA ;
} else if ( jcol == ncolA - 1 ) {
colA0 = A2_column(mtxA, jcol) ;
alpha[0] = -beta0 * W0[jcol] ;
DVaxpy11(nrowA, colA0, alpha, H0) ;
nops += 2*nrowA ;
}
} else {
double alpha[3] ;
double *rowA0, *rowA1, *rowA2 ;
/*
-----------------------------------------
A is row major
compute A(irow,:) -= H0[irow]*beta0*W0(:)
-----------------------------------------
*/
for ( irow = 0 ; irow < nrowA - 2 ; irow += 3 ) {
rowA0 = A2_row(mtxA, irow) ;
rowA1 = A2_row(mtxA, irow+1) ;
rowA2 = A2_row(mtxA, irow+2) ;
alpha[0] = -beta0 * H0[irow] ;
alpha[1] = -beta0 * H0[irow+1] ;
alpha[2] = -beta0 * H0[irow+2] ;
DVaxpy31(ncolA, rowA0, rowA1, rowA2, alpha, W0) ;
nops += 6*ncolA + 3 ;
}
if ( irow == nrowA - 2 ) {
rowA0 = A2_row(mtxA, irow) ;
rowA1 = A2_row(mtxA, irow+1) ;
alpha[0] = -beta0 * H0[irow] ;
alpha[1] = -beta0 * H0[irow+1] ;
DVaxpy21(ncolA, rowA0, rowA1, alpha, W0) ;
nops += 4*ncolA + 2 ;
} else if ( irow == nrowA - 1 ) {
rowA0 = A2_row(mtxA, irow) ;
alpha[0] = -beta0 * H0[irow] ;
DVaxpy11(ncolA, rowA0, alpha, W0) ;
nops += 2*ncolA + 1 ;
}
}
} else if ( A2_IS_COMPLEX(mtxA) ) {
int irow, jcol ;
if ( inc1 == 1 ) {
double alpha[6] ;
double *colA0, *colA1, *colA2 ;
/*
-----------------------------------------
A is column major
compute A(:,jcol) -= beta * W0(jcol) * H0
-----------------------------------------
*/
for ( jcol = 0 ; jcol < ncolA - 2 ; jcol += 3 ) {
colA0 = A2_column(mtxA, jcol) ;
colA1 = A2_column(mtxA, jcol+1) ;
colA2 = A2_column(mtxA, jcol+2) ;
alpha[0] = -beta0 * W0[2*jcol] ;
alpha[1] = -beta0 * W0[2*jcol+1] ;
alpha[2] = -beta0 * W0[2*(jcol+1)] ;
alpha[3] = -beta0 * W0[2*(jcol+1)+1] ;
alpha[4] = -beta0 * W0[2*(jcol+2)] ;
alpha[5] = -beta0 * W0[2*(jcol+2)+1] ;
ZVaxpy31(nrowA, colA0, colA1, colA2, alpha, H0) ;
nops += 24*nrowA ;
}
if ( jcol == ncolA - 2 ) {
colA0 = A2_column(mtxA, jcol) ;
colA1 = A2_column(mtxA, jcol+1) ;
alpha[0] = -beta0 * W0[2*jcol] ;
alpha[1] = -beta0 * W0[2*jcol+1] ;
alpha[2] = -beta0 * W0[2*(jcol+1)] ;
alpha[3] = -beta0 * W0[2*(jcol+1)+1] ;
ZVaxpy21(nrowA, colA0, colA1, alpha, H0) ;
nops += 16*nrowA ;
} else if ( jcol == ncolA - 1 ) {
colA0 = A2_column(mtxA, jcol) ;
alpha[0] = -beta0 * W0[2*jcol] ;
alpha[1] = -beta0 * W0[2*jcol+1] ;
ZVaxpy11(nrowA, colA0, alpha, H0) ;
nops += 8*nrowA ;
}
} else {
double alpha[6] ;
double *rowA0, *rowA1, *rowA2 ;
/*
-----------------------------------------
A is row major
compute A(irow,:) -= H0[irow]*beta0*W0(:)
-----------------------------------------
*/
for ( irow = 0 ; irow < nrowA - 2 ; irow += 3 ) {
rowA0 = A2_row(mtxA, irow) ;
rowA1 = A2_row(mtxA, irow+1) ;
rowA2 = A2_row(mtxA, irow+2) ;
alpha[0] = -beta0 * H0[2*irow] ;
alpha[1] = -beta0 * H0[2*irow+1] ;
alpha[2] = -beta0 * H0[2*(irow+1)] ;
alpha[3] = -beta0 * H0[2*(irow+1)+1] ;
alpha[4] = -beta0 * H0[2*(irow+2)] ;
alpha[5] = -beta0 * H0[2*(irow+2)+1] ;
ZVaxpy31(ncolA, rowA0, rowA1, rowA2, alpha, W0) ;
nops += 24*ncolA + 12 ;
}
if( irow == nrowA - 2 ) {
rowA0 = A2_row(mtxA, irow) ;
rowA1 = A2_row(mtxA, irow+1) ;
alpha[0] = -beta0 * H0[2*irow] ;
alpha[1] = -beta0 * H0[2*irow+1] ;
alpha[2] = -beta0 * H0[2*(irow+1)] ;
alpha[3] = -beta0 * H0[2*(irow+1)+1] ;
ZVaxpy21(ncolA, rowA0, rowA1, alpha, W0) ;
nops += 16*ncolA + 8 ;
} else if( irow == nrowA - 1 ) {
rowA0 = A2_row(mtxA, irow) ;
alpha[0] = -beta0 * H0[2*irow] ;
alpha[1] = -beta0 * H0[2*irow+1] ;
ZVaxpy11(ncolA, rowA0, alpha, W0) ;
nops += 8*ncolA + 4 ;
}
}
}
return(nops) ; }
/*
----------------------------
copy one matrix into another
A := B
created -- 98may01, cca
----------------------------
*/
void
A2_copy (
A2 *A,
A2 *B
) {
double *entA, *entB ;
int inc1A, inc1B, inc2A, inc2B, irow, jcol, locA, locB,
ncol, ncolA, ncolB, nrow, nrowA, nrowB ;
/*
---------------
check the input
---------------
*/
if ( A == NULL
|| (nrowA = A->n1) < 0
|| (ncolA = A->n2) < 0
|| (inc1A = A->inc1) <= 0
|| (inc2A = A->inc2) <= 0
|| (entA = A->entries) == NULL
|| B == NULL
|| (nrowB = B->n1) < 0
|| (ncolB = B->n2) < 0
|| (inc1B = B->inc1) <= 0
|| (inc2B = B->inc2) <= 0
|| (entB = B->entries) == NULL ) {
fprintf(stderr, "\n fatal error in A2_copy(%p,%p)"
"\n bad input\n", A, B) ;
if ( A != NULL ) {
fprintf(stderr, "\n\n first A2 object") ;
A2_writeStats(A, stderr) ;
}
if ( B != NULL ) {
fprintf(stderr, "\n\n second A2 object") ;
A2_writeStats(B, stderr) ;
}
exit(-1) ;
}
if ( ! (A2_IS_REAL(A) || A2_IS_COMPLEX(A)) ) {
fprintf(stderr, "\n fatal error in A2_copy(%p,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
A, B, A->type) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(B) || A2_IS_COMPLEX(B)) ) {
fprintf(stderr, "\n fatal error in A2_copy(%p,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
A, B, B->type) ;
exit(-1) ;
}
if ( A->type != B->type ) {
fprintf(stderr, "\n fatal error in A2_copy(%p,%p)"
"\n A's type %d, B's type = %d, must be the same\n",
A, B, A->type, B->type) ;
exit(-1) ;
}
nrow = (nrowA <= nrowB) ? nrowA : nrowB ;
ncol = (ncolA <= ncolB) ? ncolA : ncolB ;
if ( A2_IS_REAL(A) ) {
if ( inc1A == 1 && inc1B == 1 ) {
double *colA = entA, *colB = entB ;
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
for ( irow = 0 ; irow < nrow ; irow++ ) {
colA[irow] = colB[irow] ;
}
colA += inc2A ;
colB += inc2B ;
}
} else if ( inc2A == 1 && inc2B == 1 ) {
double *rowA = entA, *rowB = entB ;
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
rowA[jcol] = rowB[jcol] ;
}
rowA += 2*inc1A ;
}
} else {
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
locA = irow*inc1A + jcol*inc2A ;
locB = irow*inc1B + jcol*inc2B ;
entA[locA] = entB[locB] ;
}
}
}
} else if ( A2_IS_COMPLEX(A) ) {
if ( inc1A == 1 && inc1B == 1 ) {
double *colA = entA, *colB = entB ;
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
for ( irow = 0 ; irow < nrow ; irow++ ) {
colA[2*irow] = colB[2*irow] ;
colA[2*irow+1] = colB[2*irow+1] ;
}
colA += 2*inc2A ;
colB += 2*inc2B ;
}
} else if ( inc2A == 1 && inc2B == 1 ) {
double *rowA = entA, *rowB = entB ;
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
rowA[2*jcol] = rowB[2*jcol] ;
rowA[2*jcol+1] = rowB[2*jcol+1] ;
}
rowA += 2*inc1A ;
rowB += 2*inc1B ;
}
} else {
for ( irow = 0 ; irow < nrow ; irow++ ) {
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
locA = irow*inc1A + jcol*inc2A ;
locB = irow*inc1B + jcol*inc2B ;
entA[2*locA] = entB[2*locB] ;
entA[2*locA+1] = entB[2*locB+1] ;
}
}
}
}
return ; }
/*
---------------------------
swap two rows of the matrix
created -- 98may01, cca
---------------------------
*/
void
A2_swapRows (
A2 *a,
int irow1,
int irow2
) {
double temp ;
double *row1, *row2 ;
int inc2, j, k, n2 ;
/*
-----------
check input
-----------
*/
if ( a == NULL
|| irow1 < 0 || irow1 >= a->n1
|| irow2 < 0 || irow2 >= a->n1 ) {
fprintf(stderr,
"\n fatal error in A2_swapRows(%p,%d,%d)"
"\n bad input\n", a, irow1, irow2) ;
exit(-1) ;
}
if ( a->n1 <= 0
|| a->inc1 <= 0
|| (n2 = a->n2) <= 0
|| (inc2 = a->inc2) <= 0
|| a->entries == NULL ) {
fprintf(stderr,
"\n fatal error in A2_swapRows(%p,%d,%d)"
"\n bad structure\n", a, irow1, irow2) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(a) || A2_IS_COMPLEX(a)) ) {
fprintf(stderr, "\n fatal error in A2_swapRows(%p,%d,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
a, irow1, irow2, a->type) ;
exit(-1) ;
}
if ( irow1 == irow2 ) {
return ;
}
if ( A2_IS_REAL(a) ) {
row1 = a->entries + irow1*a->inc1 ;
row2 = a->entries + irow2*a->inc1 ;
if ( inc2 == 1 ) {
for ( j = 0 ; j < n2 ; j++ ) {
temp = row1[j] ;
row1[j] = row2[j] ;
row2[j] = temp ;
}
} else {
for ( j = 0, k = 0 ; j < n2 ; j++, k += inc2 ) {
temp = row1[k] ;
row1[k] = row2[k] ;
row2[k] = temp ;
}
}
} else if ( A2_IS_COMPLEX(a) ) {
row1 = a->entries + 2*irow1*a->inc1 ;
row2 = a->entries + 2*irow2*a->inc1 ;
if ( inc2 == 1 ) {
for ( j = 0 ; j < n2 ; j++ ) {
temp = row1[2*j] ;
row1[2*j] = row2[2*j] ;
row2[2*j] = temp ;
temp = row1[2*j+1] ;
row1[2*j+1] = row2[2*j+1] ;
row2[2*j+1] = temp ;
}
} else {
for ( j = 0, k = 0 ; j < n2 ; j++, k += inc2 ) {
temp = row1[2*k] ;
row1[2*k] = row2[2*k] ;
row2[2*k] = temp ;
temp = row1[2*k+1] ;
row1[2*k+1] = row2[2*k+1] ;
row2[2*k+1] = temp ;
}
}
}
return ; }
/*
----------------------------------------------
sort the rows of the matrix in ascending order
of the rowids[] vector. on return, rowids is
in asending order. return value is the number
of row swaps made.
created -- 98apr15, cca
----------------------------------------------
*/
int
A2_sortRowsUp (
A2 *mtx,
int nrow,
int rowids[]
) {
int ii, minrow, minrowid, nswap, target ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || mtx->n1 < nrow || nrow < 0 || rowids == NULL ) {
fprintf(stderr, "\n fatal error in A2_sortRowsUp(%p,%d,%p)"
"\n bad input\n", mtx, nrow, rowids) ;
if ( mtx != NULL ) {
A2_writeStats(mtx, stderr) ;
}
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtx) || A2_IS_COMPLEX(mtx)) ) {
fprintf(stderr, "\n fatal error in A2_sortRowsUp(%p,%d,%p)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
mtx, nrow, rowids, mtx->type) ;
exit(-1) ;
}
nswap = 0 ;
if ( mtx->inc1 == 1 ) {
double *dvtmp ;
int jcol, ncol ;
int *ivtmp ;
/*
---------------------------------------------------
matrix is stored by columns, so permute each column
---------------------------------------------------
*/
ivtmp = IVinit(nrow, -1) ;
if ( A2_IS_REAL(mtx) ) {
dvtmp = DVinit(nrow, 0.0) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
dvtmp = DVinit(2*nrow, 0.0) ;
}
IVramp(nrow, ivtmp, 0, 1) ;
IV2qsortUp(nrow, rowids, ivtmp) ;
ncol = mtx->n2 ;
for ( jcol = 0 ; jcol < ncol ; jcol++ ) {
if ( A2_IS_REAL(mtx) ) {
DVcopy(nrow, dvtmp, A2_column(mtx, jcol)) ;
DVgather(nrow, A2_column(mtx, jcol), dvtmp, ivtmp) ;
} else if ( A2_IS_COMPLEX(mtx) ) {
ZVcopy(nrow, dvtmp, A2_column(mtx, jcol)) ;
ZVgather(nrow, A2_column(mtx, jcol), dvtmp, ivtmp) ;
}
}
IVfree(ivtmp) ;
DVfree(dvtmp) ;
} else {
/*
----------------------------------------
use a simple insertion sort to swap rows
----------------------------------------
*/
for ( target = 0 ; target < nrow ; target++ ) {
minrow = target ;
minrowid = rowids[target] ;
for ( ii = target + 1 ; ii < nrow ; ii++ ) {
if ( minrowid > rowids[ii] ) {
minrow = ii ;
minrowid = rowids[ii] ;
}
}
if ( minrow != target ) {
rowids[minrow] = rowids[target] ;
rowids[target] = minrowid ;
A2_swapRows(mtx, target, minrow) ;
nswap++ ;
}
}
}
return(nswap) ; }
/*
------------------------------
swap two columns of the matrix
created -- 98may01, cca
------------------------------
*/
void
A2_swapColumns (
A2 *a,
int jcol1,
int jcol2
) {
double temp ;
double *col1, *col2 ;
int i, inc1, k, n1 ;
/*
-----------
check input
-----------
*/
if ( a == NULL
|| jcol1 < 0 || jcol1 >= a->n2
|| jcol2 < 0 || jcol2 >= a->n2 ) {
fprintf(stderr,
"\n fatal error in A2_swapColumns(%p,%d,%d)"
"\n bad input\n", a, jcol1, jcol2) ;
exit(-1) ;
}
if ( (n1 = a->n1) <= 0
|| (inc1 = a->inc1) <= 0
|| a->n2 <= 0
|| a->inc2 <= 0
|| a->entries == NULL ) {
fprintf(stderr,
"\n fatal error in A2_swapColumns(%p,%d,%d)"
"\n bad structure\n", a, jcol1, jcol2) ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(a) || A2_IS_COMPLEX(a)) ) {
fprintf(stderr, "\n fatal error in A2_swapColumns(%p,%d,%d)"
"\n bad type %d, must be SPOOLES_REAL or SPOOLES_COMPLEX\n",
a, jcol1, jcol2, a->type) ;
exit(-1) ;
}
if ( jcol1 == jcol2 ) {
return ;
}
if ( A2_IS_REAL(a) ) {
col1 = a->entries + jcol1*a->inc2 ;
col2 = a->entries + jcol2*a->inc2 ;
if ( inc1 == 1 ) {
for ( i = 0 ; i < n1 ; i++ ) {
temp = col1[i] ;
col1[i] = col2[i] ;
col2[i] = temp ;
}
} else {
for ( i = 0, k = 0 ; i < n1 ; i++, k += inc1 ) {
temp = col1[k] ;
col1[k] = col2[k] ;
col2[k] = temp ;
}
}
} else if ( A2_IS_COMPLEX(a) ) {
col1 = a->entries + 2*jcol1*a->inc2 ;
col2 = a->entries + 2*jcol2*a->inc2 ;
if ( inc1 == 1 ) {
for ( i = 0 ; i < n1 ; i++ ) {
temp = col1[2*i] ;
col1[2*i] = col2[2*i] ;
col2[2*i] = temp ;
temp = col1[2*i+1] ;
col1[2*i+1] = col2[2*i+1] ;
col2[2*i+1] = temp ;
}
} else {
for ( i = 0, k = 0 ; i < n1 ; i++, k += inc1 ) {
temp = col1[2*k] ;
col1[2*k] = col2[2*k] ;
col2[2*k] = temp ;
temp = col1[2*k+1] ;
col1[2*k+1] = col2[2*k+1] ;
col2[2*k+1] = temp ;
}
}
}
return ; }
