/*
--------------------------------------------------------------------
inputComplex a number of (row,column, entry) triples into the matrix
created -- 98jan28, cca
--------------------------------------------------------------------
*/
static void
inputTriples (
InpMtx *inpmtx,
int ntriples,
int rowids[],
int colids[],
double entries[]
) {
int nent ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, ntriples) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
IVcopy(ntriples, ivec1 + nent, rowids) ;
IVcopy(ntriples, ivec2 + nent, colids) ;
IV_setSize(&inpmtx->ivec1IV, nent + ntriples) ;
IV_setSize(&inpmtx->ivec2IV, nent + ntriples) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
DVcopy(ntriples, dvec + nent, entries) ;
DV_setSize(&inpmtx->dvecDV, nent + ntriples) ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
ZVcopy(ntriples, dvec + 2*nent, entries) ;
DV_setSize(&inpmtx->dvecDV, 2*(nent + ntriples)) ;
}
inpmtx->nent += ntriples ;
inpmtx->storageMode = INPMTX_RAW_DATA ;
return ; }
/*
---------------------------------
set the present number of entries
created -- 98jan28, cca
--------------------------------
*/
void
InpMtx_setNent (
InpMtx *inpmtx,
int newnent
) {
/*
---------------
check the input
---------------
*/
if ( inpmtx == NULL || newnent < 0 ) {
fprintf(stderr, "\n fatal error in InpMtx_setNent(%p,%d)"
"\n bad input\n", inpmtx, newnent) ;
spoolesFatal();
}
if ( inpmtx->maxnent < newnent ) {
/*
-------------------------------------------------------
newnent requested is more than maxnent, set new maxnent
-------------------------------------------------------
*/
InpMtx_setMaxnent(inpmtx, newnent) ;
}
inpmtx->nent = newnent ;
IV_setSize(&inpmtx->ivec1IV, newnent) ;
IV_setSize(&inpmtx->ivec2IV, newnent) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
DV_setSize(&(inpmtx->dvecDV), newnent) ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
DV_setSize(&inpmtx->dvecDV, 2*newnent) ;
}
return ; }
/*
-----------------------------
input a chevron in the matrix
created -- 98jan28, cca
-----------------------------
*/
static void
inputChevron (
InpMtx *inpmtx,
int chv,
int chvsize,
int chvind[],
double chvent[]
) {
int col, ii, jj, nent, offset, row ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, chvsize) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
if ( INPMTX_IS_BY_ROWS(inpmtx) ) {
for ( ii = 0, jj = nent ; ii < chvsize ; ii++, jj++ ) {
if ( (offset = chvind[ii]) >= 0 ) {
row = chv ;
col = chv + offset ;
} else {
col = chv ;
row = chv - offset ;
}
ivec1[jj] = row ;
ivec2[jj] = col ;
}
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) {
for ( ii = 0, jj = nent ; ii < chvsize ; ii++, jj++ ) {
if ( (offset = chvind[ii]) >= 0 ) {
row = chv ;
col = chv + offset ;
} else {
col = chv ;
row = chv - offset ;
}
ivec1[jj] = col ;
ivec2[jj] = row ;
}
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) {
IVfill(chvsize, ivec1 + nent, chv) ;
IVcopy(chvsize, ivec2 + nent, chvind) ;
}
IV_setSize(&inpmtx->ivec1IV, nent + chvsize) ;
IV_setSize(&inpmtx->ivec2IV, nent + chvsize) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) + nent ;
DVcopy(chvsize, dvec, chvent) ;
DV_setSize(&inpmtx->dvecDV, nent + chvsize) ;
} else if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) + 2*nent ;
ZVcopy(chvsize, dvec, chvent) ;
DV_setSize(&inpmtx->dvecDV, 2*(nent + chvsize)) ;
}
inpmtx->nent += chvsize ;
inpmtx->storageMode = INPMTX_RAW_DATA ;
return ; }
/*
---------------------------------
input a row in the matrix
created -- 98jan28, cca
---------------------------------
*/
static void
inputRow (
InpMtx *inpmtx,
int row,
int rowsize,
int rowind[],
double rowent[]
) {
int col, ii, jj, nent ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, rowsize) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
if ( INPMTX_IS_BY_ROWS(inpmtx) ) { /* row coordinates */
IVfill(rowsize, ivec1 + nent, row) ;
IVcopy(rowsize, ivec2 + nent, rowind) ;
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) { /* column coordinates */
IVfill(rowsize, ivec2 + nent, row) ;
IVcopy(rowsize, ivec1 + nent, rowind) ;
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) { /* chevron coordinates */
for ( ii = 0, jj = nent ; ii < rowsize ; ii++, jj++ ) {
col = rowind[ii] ;
ivec1[ii] = (row <= col) ? row : col ;
ivec2[ii] = col - row ;
}
}
IV_setSize(&inpmtx->ivec1IV, nent + rowsize) ;
IV_setSize(&inpmtx->ivec2IV, nent + rowsize) ;
/*
-----------------
input the entries
-----------------
*/
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
DVcopy(rowsize, dvec + nent, rowent) ;
DV_setSize(&inpmtx->dvecDV, nent + rowsize) ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
ZVcopy(rowsize, dvec + 2*nent, rowent) ;
DV_setSize(&inpmtx->dvecDV, 2*(nent + rowsize)) ;
}
inpmtx->storageMode = INPMTX_RAW_DATA ;
inpmtx->nent += rowsize ;
return ; }
/*
----------------------------------
input a single entry in the matrix
created -- 98jan28, cca
----------------------------------
*/
static void
inputEntry (
InpMtx *inpmtx,
int row,
int col,
double real,
double imag
) {
int nent ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, 1) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
if ( INPMTX_IS_BY_ROWS(inpmtx) ) {
ivec1[nent] = row ;
ivec2[nent] = col ;
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) {
ivec1[nent] = col ;
ivec2[nent] = row ;
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) {
if ( row <= col ) {
ivec1[nent] = row ;
ivec2[nent] = col - row ;
} else {
ivec1[nent] = col ;
ivec2[nent] = col - row ;
}
}
IV_setSize(&inpmtx->ivec1IV, nent + 1) ;
IV_setSize(&inpmtx->ivec2IV, nent + 1) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
dvec[nent] = real ;
DV_setSize(&inpmtx->dvecDV, nent + 1) ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
dvec[2*nent] = real ;
dvec[2*nent+1] = imag ;
DV_setSize(&inpmtx->dvecDV, 2*(nent + 1)) ;
}
inpmtx->nent++ ;
inpmtx->storageMode = INPMTX_RAW_DATA ;
return ; }
/*
------------------------------------
input a complex column in the matrix
created -- 98jan28, cca
------------------------------------
*/
static void
inputColumn (
InpMtx *inpmtx,
int col,
int colsize,
int colind[],
double colent[]
) {
int ii, jj, nent, row ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, colsize) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
if ( INPMTX_IS_BY_ROWS(inpmtx) ) {
IVcopy(colsize, ivec1 + nent, colind) ;
IVfill(colsize, ivec2 + nent, col) ;
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) {
IVfill(colsize, ivec1 + nent, col) ;
IVcopy(colsize, ivec2 + nent, colind) ;
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) {
for ( ii = 0, jj = nent ; ii < colsize ; ii++, jj++ ) {
row = colind[jj] ;
ivec1[jj] = (row <= col) ? row : col ;
ivec2[jj] = col - row ;
}
}
IV_setSize(&inpmtx->ivec1IV, nent + colsize) ;
IV_setSize(&inpmtx->ivec2IV, nent + colsize) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) + nent ;
DVcopy(colsize, dvec, colent) ;
DV_setSize(&inpmtx->dvecDV, nent + colsize) ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) + 2*nent ;
ZVcopy(colsize, dvec, colent) ;
DV_setSize(&inpmtx->dvecDV, 2*(nent + colsize)) ;
}
inpmtx->nent = nent + colsize ;
inpmtx->storageMode = INPMTX_RAW_DATA ;
return ; }
/*
----------------------------------------------------------------
set the number of bytes in the workspace owned by this object
created -- 98apr30, cca
----------------------------------------------------------------
*/
void
Chv_setNbytesInWorkspace (
Chv *chv,
int nbytes
) {
if ( chv == NULL ) {
fprintf(stderr, "\n fatal error in Chv_setNbytesInWorkspace(%p,%d)"
"\n bad input\n", chv, nbytes) ;
exit(-1) ;
}
DV_setSize(&chv->wrkDV, nbytes/sizeof(double)) ;
return ; }
/*
-------------------------------------------------------------
set the number of bytes in the workspace owned by this object
created -- 98may02, cca
-------------------------------------------------------------
*/
void
DenseMtx_setNbytesInWorkspace (
DenseMtx *mtx,
int nbytes
) {
if ( mtx == NULL ) {
fprintf(stderr,
"\n fatal error in DenseMtx_setNbytesInWorkspace(%p)"
"\n bad input\n", mtx) ;
exit(-1) ;
}
DV_setSize(&mtx->wrkDV, nbytes/sizeof(double)) ;
return ; }
/*
----------------------------
extract col[*] = mtx(*,jcol)
created -- 98may01, cca
----------------------------
*/
void
A2_extractColumnDV (
A2 *mtx,
DV *colDV,
int jcol
) {
double *entries, *col ;
int i, inc1, k, n1 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || colDV == NULL || mtx->entries == NULL
|| jcol < 0 || jcol >= mtx->n2 ) {
fprintf(stderr, "\n fatal error in A2_extractColumnDV(%p,%p,%d)"
"\n bad input\n", mtx, colDV, jcol) ;
exit(-1) ;
}
if ( ! A2_IS_REAL(mtx) ) {
fprintf(stderr, "\n fatal error in A2_extractColumnDV(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL\n",
mtx, colDV, jcol, mtx->type) ;
exit(-1) ;
}
if ( DV_size(colDV) < (n1 = mtx->n1) ) {
DV_setSize(colDV, n1) ;
}
col = DV_entries(colDV) ;
k = jcol * mtx->inc2 ;
inc1 = mtx->inc1 ;
entries = mtx->entries ;
for ( i = 0 ; i < n1 ; i++, k += inc1 ) {
col[i] = entries[k] ;
}
return ; }
/*
----------------------------
extract row[*] = mtx(irow,*)
created -- 98may01, cca
----------------------------
*/
void
A2_extractRowDV (
A2 *mtx,
DV *rowDV,
int irow
) {
double *entries, *row ;
int inc2, j, k, n2 ;
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || rowDV == NULL || mtx->entries == NULL
|| irow < 0 || irow >= mtx->n1 ) {
fprintf(stderr, "\n fatal error in A2_extractRowDV(%p,%p,%d)"
"\n bad input\n", mtx, rowDV, irow) ;
exit(-1) ;
}
if ( ! A2_IS_REAL(mtx) ) {
fprintf(stderr, "\n fatal error in A2_extractRowDV(%p,%p,%d)"
"\n bad type %d, must be SPOOLES_REAL\n",
mtx, rowDV, irow, mtx->type) ;
exit(-1) ;
}
if ( DV_size(rowDV) < (n2 = mtx->n2) ) {
DV_setSize(rowDV, n2) ;
}
row = DV_entries(rowDV) ;
k = irow * mtx->inc1 ;
inc2 = mtx->inc2 ;
entries = mtx->entries ;
for ( j = 0 ; j < n2 ; j++, k += inc2 ) {
row[j] = entries[k] ;
}
return ; }
/*
--------------------------------------------------------------
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) ; }
/*
------------------------------------------------
purpose -- to get simple x[] and y[] coordinates
for the tree vertices
return values --
1 -- normal return
-1 -- tree is NULL
-2 -- heightflag is invalid
-3 -- coordflag is invalid
-4 -- xDV is NULL
-5 -- yDV is NULL
created -- 99jan07, cca
------------------------------------------------
*/
int
Tree_getSimpleCoords (
Tree *tree,
char heightflag,
char coordflag,
DV *xDV,
DV *yDV
) {
double *x, *y ;
int count, I, J, n, nleaves ;
int *fch, *par, *sib ;
/*
---------------
check the input
---------------
*/
if ( tree == NULL ) {
fprintf(stderr, "\n error in Tree_getSimpleCoords()"
"\n tree is NULL\n") ;
return(-1) ;
}
if ( heightflag != 'D' && heightflag != 'H' ) {
fprintf(stderr, "\n error in Tree_getSimpleCoords()"
"\n invalid heightflag = %c\n", heightflag) ;
return(-2) ;
}
if ( coordflag != 'C' && coordflag != 'P' ) {
fprintf(stderr, "\n error in Tree_getSimpleCoords()"
"\n invalid coordflag = %c\n", coordflag) ;
return(-3) ;
}
if ( xDV == NULL ) {
fprintf(stderr, "\n error in Tree_getSimpleCoords()"
"\n xDV is NULL\n") ;
return(-4) ;
}
if ( yDV == NULL ) {
fprintf(stderr, "\n error in Tree_getSimpleCoords()"
"\n yDV is NULL\n") ;
return(-5) ;
}
n = tree->n ;
par = tree->par ;
fch = tree->fch ;
sib = tree->sib ;
DV_setSize(xDV, n) ;
DV_setSize(yDV, n) ;
x = DV_entries(xDV) ;
y = DV_entries(yDV) ;
switch ( heightflag ) {
case 'D' : {
int J, K, maxdepth ;
for ( J = Tree_preOTfirst(tree), maxdepth = 0 ;
J != -1 ;
J = Tree_preOTnext(tree, J) ) {
if ( (K = par[J]) == -1 ) {
y[J] = 0.0 ;
} else {
y[J] = y[K] + 1.0 ;
}
if ( maxdepth < y[J] ) {
maxdepth = y[J] ;
}
}
if ( coordflag == 'C' ) {
for ( J = 0 ; J < n ; J++ ) {
y[J] = maxdepth - y[J] ;
}
}
} break ;
case 'H' : {
int height, I, J, maxheight ;
for ( J = Tree_postOTfirst(tree), maxheight = 0 ;
J != -1 ;
J = Tree_postOTnext(tree, J) ) {
if ( (I = fch[J]) == -1 ) {
y[J] = 0.0 ;
} else {
height = y[I] ;
for ( I = sib[I] ; I != -1 ; I = sib[I] ) {
if ( height < y[I] ) {
height = y[I] ;
}
}
y[J] = height + 1.0 ;
}
if ( maxheight < y[J] ) {
maxheight = y[J] ;
}
}
if ( coordflag == 'P' ) {
for ( J = 0 ; J < n ; J++ ) {
y[J] = maxheight - y[J] ;
}
}
} break ;
default :
break ;
}
#if MYDEBUG > 0
fprintf(stdout, "\n\n y") ;
DV_writeForHumanEye(yDV, stdout) ;
#endif
DV_zero(xDV) ;
nleaves = 0 ;
for ( J = Tree_postOTfirst(tree) ;
J != -1 ;
J = Tree_postOTnext(tree, J) ) {
if ( fch[J] == -1 ) {
x[J] = nleaves++ ;
} else {
for ( I = fch[J], count = 0 ; I != -1 ; I = sib[I] ) {
x[J] += x[I] ;
count++ ;
}
x[J] /= count ;
}
}
if ( coordflag == 'C' ) {
for ( J = 0 ; J < n ; J++ ) {
x[J] = x[J] / nleaves ;
}
} else {
double r, theta ;
for ( J = 0 ; J < n ; J++ ) {
theta = 6.283185 * x[J] / nleaves ;
r = y[J] ;
x[J] = r * cos(theta) ;
y[J] = r * sin(theta) ;
}
}
#if MYDEBUG > 0
fprintf(stdout, "\n\n x") ;
DV_writeForHumanEye(xDV, stdout) ;
#endif
return(1) ; }
/*
-----------------------------------------------------------
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 -- compute A = QR, where Q is a product of householder
vectors, (I - beta_j v_j v_j^T). on return, v_j is
found in the lower triangle of A, v_j(j) = 1.0.
return value -- # of floating point operations
created -- 98may25, cca
--------------------------------------------------------------
*/
double
A2_QRreduce (
A2 *mtxA,
DV *workDV,
int msglvl,
FILE *msgFile
) {
A2 tempA ;
double nops ;
double beta0 ;
double *colA, *H0, *W0 ;
int inc1, inc2, jcol, lastrow, length, ncolA, nrowA, nstep ;
/*
---------------
check the input
---------------
*/
if ( mtxA == NULL || workDV == NULL
|| (msglvl > 0 && msgFile == NULL) ) {
fprintf(stderr, "\n fatal error in A2_QRreduce()"
"\n bad input\n") ;
exit(-1) ;
}
if ( ! (A2_IS_REAL(mtxA) || A2_IS_COMPLEX(mtxA)) ) {
fprintf(stderr, "\n fatal error in A2_QRreduce()"
"\n matrix must be real or complex\n") ;
exit(-1) ;
}
nrowA = A2_nrow(mtxA) ;
ncolA = A2_ncol(mtxA) ;
inc1 = A2_inc1(mtxA) ;
inc2 = A2_inc2(mtxA) ;
if ( A2_IS_REAL(mtxA) ) {
DV_setSize(workDV, nrowA + ncolA) ;
H0 = DV_entries(workDV) ;
W0 = H0 + nrowA ;
} else if ( A2_IS_COMPLEX(mtxA) ) {
DV_setSize(workDV, 2*(nrowA + ncolA)) ;
H0 = DV_entries(workDV) ;
W0 = H0 + 2*nrowA ;
}
/*
-------------------------------------------------
determine the number of steps = min(ncolA, nrowA)
-------------------------------------------------
*/
nstep = (ncolA <= nrowA) ? ncolA : nrowA ;
/*
-------------------
loop over the steps
-------------------
*/
nops = 0.0 ;
for ( jcol = 0 ; jcol < nstep ; jcol++ ) {
if ( msglvl > 3 ) {
fprintf(msgFile, "\n %% jcol = %d", jcol) ;
}
/*
----------------------------------
copy the column of A into a vector
and find the last nonzero element
----------------------------------
*/
A2_subA2(&tempA, mtxA, jcol, nrowA-1, jcol, ncolA-1) ;
length = 1 + copyIntoVec1(&tempA, H0, msglvl, msgFile) ;
lastrow = jcol + length - 1 ;
if ( msglvl > 5 ) {
fprintf(msgFile,
"\n %% return from copyIntoVec1, length = %d, lastrow = %d",
length, lastrow) ;
}
/*
------------------------------
compute the Householder vector
and place into the column of A
------------------------------
*/
colA = A2_column(mtxA, jcol) ;
if ( A2_IS_REAL(mtxA) ) {
nops += getHouseholderVector1(SPOOLES_REAL, length, H0,
&beta0, msglvl, msgFile) ;
A2_subA2(&tempA, mtxA, jcol, lastrow, jcol, jcol) ;
A2_setColumn(&tempA, H0, 0) ;
H0[0] = 1.0 ;
} else if ( A2_IS_COMPLEX(mtxA) ) {
nops += getHouseholderVector1(SPOOLES_COMPLEX, length, H0,
&beta0, msglvl, msgFile) ;
A2_subA2(&tempA, mtxA, jcol, lastrow, jcol, jcol) ;
A2_setColumn(&tempA, H0, 0) ;
H0[0] = 1.0 ; H0[1] = 0.0 ;
}
if ( msglvl > 5 && jcol == 0 ) {
fprintf(msgFile, "\n %% beta0 = %12.4e;", beta0) ;
}
if ( beta0 != 0.0 && jcol + 1 < ncolA ) {
A2_subA2(&tempA, mtxA, jcol, lastrow, jcol+1, ncolA-1) ;
/*
------------------------------------------------
compute w = v^T * A(jcol:lastrow,jcol+1:nrowA-1)
------------------------------------------------
*/
if ( msglvl > 3 ) {
fprintf(msgFile, "\n %% compute w") ;
}
nops += computeW1(&tempA, H0, W0, msglvl, msgFile) ;
/*
-------------------------------------------------
update A(jcol:lastrow,jcol+1:nrowA-1) -= beta*v*w
-------------------------------------------------
*/
if ( msglvl > 3 ) {
fprintf(msgFile, "\n %% update A") ;
}
nops += updateA1(&tempA, H0, beta0, W0, msglvl, msgFile) ;
}
}
return(nops) ; }
/*
-----------------------
input a matrix
created -- 98jan28, cca
-----------------------
*/
static void
inputMatrix (
InpMtx *inpmtx,
int nrow,
int ncol,
int rowstride,
int colstride,
int rowind[],
int colind[],
double mtxent[]
) {
int col, ii, jj, kk, nent, row ;
int *ivec1, *ivec2 ;
prepareToAddNewEntries(inpmtx, nrow*ncol) ;
nent = inpmtx->nent ;
ivec1 = IV_entries(&inpmtx->ivec1IV) ;
ivec2 = IV_entries(&inpmtx->ivec2IV) ;
if ( INPMTX_IS_BY_ROWS(inpmtx) ) {
for ( jj = 0, kk = nent ; jj < ncol ; jj++ ) {
col = colind[jj] ;
for ( ii = 0 ; ii < nrow ; ii++, kk++ ) {
row = rowind[ii] ;
ivec1[kk] = row ;
ivec2[kk] = col ;
}
}
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) {
for ( jj = 0, kk = nent ; jj < ncol ; jj++ ) {
col = colind[jj] ;
for ( ii = 0 ; ii < nrow ; ii++, kk++ ) {
row = rowind[ii] ;
ivec1[kk] = col ;
ivec2[kk] = row ;
}
}
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) {
for ( jj = 0, kk = nent ; jj < ncol ; jj++ ) {
col = colind[jj] ;
for ( ii = 0 ; ii < nrow ; ii++, kk++ ) {
row = rowind[ii] ;
if ( row <= col ) {
ivec1[kk] = row ;
} else {
ivec1[kk] = col ;
}
ivec2[kk] = col - row ;
}
}
}
IV_setSize(&inpmtx->ivec1IV, nent + nrow*ncol) ;
IV_setSize(&inpmtx->ivec2IV, nent + nrow*ncol) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
int ij ;
for ( jj = 0, kk = nent ; jj < ncol ; jj++ ) {
for ( ii = 0 ; ii < nrow ; ii++, kk++ ) {
ij = ii*rowstride + jj*colstride ;
dvec[kk] = mtxent[ij] ;
}
}
DV_setSize(&inpmtx->dvecDV, nent + nrow*ncol) ;
} if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
double *dvec = DV_entries(&inpmtx->dvecDV) ;
int ij ;
for ( jj = 0, kk = nent ; jj < ncol ; jj++ ) {
for ( ii = 0 ; ii < nrow ; ii++, kk++ ) {
ij = ii*rowstride + jj*colstride ;
dvec[2*kk] = mtxent[2*ij] ;
dvec[2*kk+1] = mtxent[2*ij+1] ;
}
}
DV_setSize(&inpmtx->dvecDV, 2*(nent + nrow*ncol)) ;
}
inpmtx->nent += nrow*ncol ;
inpmtx->storageMode = INPMTX_RAW_DATA ;
return ; }
/*
----------------------------------------------------------
purpose -- to construct the map from fronts to processors,
and compute operations for each processor.
maptype -- type of map for parallel factorization
maptype = 1 --> wrap map
maptype = 2 --> balanced map
maptype = 3 --> subtree-subset map
maptype = 4 --> domain decomposition map
cutoff -- used when maptype = 4 as upper bound on
relative domain size
return value --
1 -- success
-1 -- bridge is NULL
-2 -- front tree is NULL
created -- 98sep25, cca
----------------------------------------------------------
*/
int
BridgeMPI_factorSetup (
BridgeMPI *bridge,
int maptype,
double cutoff
) {
double t1, t2 ;
DV *cumopsDV ;
ETree *frontETree ;
FILE *msgFile ;
int msglvl, nproc ;
/*
---------------
check the input
---------------
*/
MARKTIME(t1) ;
if ( bridge == NULL ) {
fprintf(stderr, "\n error in BridgeMPI_factorSetup()"
"\n bridge is NULL") ;
return(-1) ;
}
if ( (frontETree = bridge->frontETree) == NULL ) {
fprintf(stderr, "\n error in BridgeMPI_factorSetup()"
"\n frontETree is NULL") ;
return(-2) ;
}
nproc = bridge->nproc ;
msglvl = bridge->msglvl ;
msgFile = bridge->msgFile ;
/*
-------------------------------------------
allocate and initialize the cumopsDV object
-------------------------------------------
*/
if ( (cumopsDV = bridge->cumopsDV) == NULL ) {
cumopsDV = bridge->cumopsDV = DV_new() ;
}
DV_setSize(cumopsDV, nproc) ;
DV_zero(cumopsDV) ;
/*
----------------------------
create the owners map object
----------------------------
*/
switch ( maptype ) {
case 1 :
bridge->ownersIV = ETree_wrapMap(frontETree, bridge->type,
bridge->symmetryflag, cumopsDV) ;
break ;
case 2 :
bridge->ownersIV = ETree_balancedMap(frontETree, bridge->type,
bridge->symmetryflag, cumopsDV) ;
break ;
case 3 :
bridge->ownersIV = ETree_subtreeSubsetMap(frontETree, bridge->type,
bridge->symmetryflag, cumopsDV) ;
break ;
case 4 :
bridge->ownersIV = ETree_ddMap(frontETree, bridge->type,
bridge->symmetryflag, cumopsDV, cutoff) ;
break ;
default :
bridge->ownersIV = ETree_ddMap(frontETree, bridge->type,
bridge->symmetryflag, cumopsDV, 1./(2*nproc)) ;
break ;
}
MARKTIME(t2) ;
bridge->cpus[7] = t2 - t1 ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n parallel factor setup") ;
fprintf(msgFile, "\n type = %d, symmetryflag = %d",
bridge->type, bridge->symmetryflag) ;
fprintf(msgFile, "\n total factor operations = %.0f",
DV_sum(cumopsDV)) ;
fprintf(msgFile,
"\n upper bound on speedup due to load balance = %.2f",
DV_max(cumopsDV)/DV_sum(cumopsDV)) ;
fprintf(msgFile, "\n operations distributions over threads") ;
DV_writeForHumanEye(cumopsDV, msgFile) ;
fflush(msgFile) ;
}
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n owners map IV object") ;
IV_writeForHumanEye(bridge->ownersIV, msgFile) ;
fflush(msgFile) ;
}
/*
----------------------------
create the vertex map object
----------------------------
*/
bridge->vtxmapIV = IV_new() ;
IV_init(bridge->vtxmapIV, bridge->neqns, NULL) ;
IVgather(bridge->neqns, IV_entries(bridge->vtxmapIV),
IV_entries(bridge->ownersIV),
ETree_vtxToFront(bridge->frontETree)) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n vertex map IV object") ;
IV_writeForHumanEye(bridge->vtxmapIV, msgFile) ;
fflush(msgFile) ;
}
return(1) ;
}
/*
----------------------------------
drop entries in the upper triangle
created -- 98jan28, cca
----------------------------------
*/
void
InpMtx_dropUpperTriangle (
InpMtx *inpmtx
) {
double *dvec ;
int count, ii, nent ;
int *ivec1, *ivec2 ;
/*
---------------
check the input
---------------
*/
if ( inpmtx == NULL ) {
fprintf(stderr, "\n fatal error in InpMtx_dropUpperTriangle(%p)"
"\n bad input\n", inpmtx) ;
exit(-1) ;
}
if ( !( INPMTX_IS_BY_ROWS(inpmtx)
|| INPMTX_IS_BY_COLUMNS(inpmtx)
|| INPMTX_IS_BY_CHEVRONS(inpmtx) ) ) {
fprintf(stderr, "\n fatal error in InpMtx_dropUpperTriangle(%p)"
"\n bad coordType \n", inpmtx) ;
exit(-1) ;
}
nent = inpmtx->nent ;
ivec1 = InpMtx_ivec1(inpmtx) ;
ivec2 = InpMtx_ivec2(inpmtx) ;
count = 0 ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx)
|| INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
dvec = InpMtx_dvec(inpmtx) ;
}
if ( INPMTX_IS_BY_ROWS(inpmtx) ) {
for ( ii = 0 ; ii < nent ; ii++ ) {
if ( ivec1[ii] >= ivec2[ii] ) {
ivec1[count] = ivec1[ii] ;
ivec2[count] = ivec2[ii] ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
dvec[count] = dvec[ii] ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
dvec[2*count] = dvec[2*ii] ;
dvec[2*count+1] = dvec[2*ii+1] ;
}
count++ ;
}
}
} else if ( INPMTX_IS_BY_COLUMNS(inpmtx) ) {
for ( ii = 0 ; ii < nent ; ii++ ) {
if ( ivec1[ii] <= ivec2[ii] ) {
ivec1[count] = ivec1[ii] ;
ivec2[count] = ivec2[ii] ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
dvec[count] = dvec[ii] ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
dvec[2*count] = dvec[2*ii] ;
dvec[2*count+1] = dvec[2*ii+1] ;
}
count++ ;
}
}
} else if ( INPMTX_IS_BY_CHEVRONS(inpmtx) ) {
for ( ii = 0 ; ii < nent ; ii++ ) {
if ( ivec2[ii] <= 0 ) {
ivec1[count] = ivec1[ii] ;
ivec2[count] = ivec2[ii] ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx) ) {
dvec[count] = dvec[ii] ;
} else if ( INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
dvec[2*count] = dvec[2*ii] ;
dvec[2*count+1] = dvec[2*ii+1] ;
}
count++ ;
}
}
}
inpmtx->nent = count ;
IV_setSize(&inpmtx->ivec1IV, count) ;
IV_setSize(&inpmtx->ivec2IV, count) ;
if ( INPMTX_IS_REAL_ENTRIES(inpmtx)
|| INPMTX_IS_COMPLEX_ENTRIES(inpmtx) ) {
DV_setSize(&inpmtx->dvecDV, count) ;
}
return ; }
/*
------------------------------------------------------------------
to fill xDV and yDV with a log10 profile of the magnitudes of
the entries in the DV object. tausmall and tau big provide
cutoffs within which to examine the entries. pnzero, pnsmall
and pnbig are addresses to hold the number of entries zero,
smaller than tausmall and larger than taubig, respectively.
created -- 97feb14, cca
------------------------------------------------------------------
*/
void
DV_log10profile (
DV *dv,
int npts,
DV *xDV,
DV *yDV,
double tausmall,
double taubig,
int *pnzero,
int *pnsmall,
int *pnbig
) {
double deltaVal, maxval, minval, val ;
double *dvec, *sums, *x, *y ;
int ii, ipt, nbig, nsmall, nzero, size ;
/*
---------------
check the input
---------------
*/
if ( dv == NULL || npts <= 0 || xDV == NULL || yDV == NULL
|| tausmall < 0.0 || taubig < 0.0 || tausmall > taubig
|| pnzero == NULL || pnsmall == NULL || pnbig == NULL ) {
fprintf(stderr,
"\n fatal error in DV_log10profile(%p,%d,%p,%p,%f,%f,%p,%p,%p)"
"\n bad input\n",
dv, npts, xDV, yDV, tausmall, taubig, pnzero, pnsmall, pnbig) ;
exit(-1) ;
}
/*
-------------------------------------
find the largest and smallest entries
in the range [tausmall, taubig]
-------------------------------------
*/
nbig = nsmall = nzero = 0 ;
minval = maxval = 0.0 ;
DV_sizeAndEntries(dv, &size, &dvec) ;
for ( ii = 0 ; ii < size ; ii++ ) {
val = fabs(dvec[ii]) ;
if ( val == 0.0 ) {
nzero++ ;
} else if ( val <= tausmall ) {
nsmall++ ;
} else if ( val >= taubig ) {
nbig++ ;
} else {
if ( minval == 0.0 || minval > val ) {
minval = val ;
}
if ( maxval < val ) {
maxval = val ;
}
}
}
*pnzero = nzero ;
*pnsmall = nsmall ;
*pnbig = nbig ;
#if MYDEBUG > 0
fprintf(stdout,
"\n nzero = %d, minval = %e, nsmall = %d, maxval = %e, nbig = %d",
nzero, minval, nsmall, maxval, nbig) ;
#endif
/*
------------------
set up the buckets
------------------
*/
DV_setSize(xDV, npts) ;
DV_setSize(yDV, npts) ;
x = DV_entries(xDV) ;
y = DV_entries(yDV) ;
sums = DVinit(npts, 0.0) ;
minval = log10(minval) ;
maxval = log10(maxval) ;
/*
minval = log10(tausmall) ;
maxval = log10(taubig) ;
*/
deltaVal = (maxval - minval)/(npts - 1) ;
DVfill(npts, x, 0.0) ;
DVfill(npts, y, 0.0) ;
/*
--------------------------------
fill the sums and counts vectors
--------------------------------
*/
for ( ii = 0 ; ii < size ; ii++ ) {
val = fabs(dvec[ii]) ;
if ( tausmall < val && val < taubig ) {
ipt = (log10(val) - minval) / deltaVal ;
sums[ipt] += val ;
y[ipt]++ ;
}
}
#if MYDEBUG > 0
fprintf(stdout, "\n sum(y) = %.0f", DV_sum(yDV)) ;
#endif
/*
---------------------------
set the x-coordinate vector
---------------------------
*/
for ( ipt = 0 ; ipt < npts ; ipt++ ) {
if ( sums[ipt] == 0.0 ) {
x[ipt] = minval + ipt*deltaVal ;
} else {
x[ipt] = log10(sums[ipt]/y[ipt]) ;
}
}
/*
------------------------
free the working storage
------------------------
*/
DVfree(sums) ;
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 ; }
