/*
----------------------------------------------
purpose -- initialize an aggregate SubMtx object
created -- 98mar27, cca
----------------------------------------------
*/
static SubMtx *
initBJ (
int type,
int J,
int nJ,
int nrhs,
SubMtxManager *mtxmanager,
int msglvl,
FILE *msgFile
) {
SubMtx *BJ ;
double *entries ;
int inc1, inc2, nbytes ;
/*
------------------------------------------
B_J not yet allocated (must not be owned),
create and zero the entries
------------------------------------------
*/
nbytes = SubMtx_nbytesNeeded(type, SUBMTX_DENSE_COLUMNS,
nJ, nrhs, nJ*nrhs);
BJ = SubMtxManager_newObjectOfSizeNbytes(mtxmanager, nbytes) ;
if ( BJ == NULL ) {
fprintf(stderr,
"\n 1. fatal error in forwardVisit(%d), BJ = NULL", J) ;
exit(-1) ;
}
SubMtx_init(BJ, type, SUBMTX_DENSE_COLUMNS, J, 0, nJ, nrhs, nJ*nrhs) ;
SubMtx_denseInfo(BJ, &nJ, &nrhs, &inc1, &inc2, &entries) ;
if ( type == SPOOLES_REAL ) {
DVzero(nJ*nrhs, entries) ;
} else if ( type == SPOOLES_COMPLEX ) {
DVzero(2*nJ*nrhs, entries) ;
}
return(BJ) ; }
/*
--------------------------------------------------------
purpose -- assemble any aggregates in the aggregate list
created -- 98mar26, cca
--------------------------------------------------------
*/
static void
assembleAggregates (
int J,
SubMtx *BJ,
SubMtxList *aggList,
SubMtxManager *mtxmanager,
int msglvl,
FILE *msgFile
) {
SubMtx *BJhat, *BJhead ;
double *entBJ, *entBJhat ;
int inc1, inc1hat, inc2, inc2hat, ncol, ncolhat, nrow, nrowhat ;
if ( BJ == NULL || aggList == NULL ) {
fprintf(stderr,
"\n fatal error in assembleAggregates()"
"\n BJ = %p, aggList = %p", BJ, aggList) ;
exit(-1) ;
}
if ( SubMtxList_isListNonempty(aggList, BJ->rowid) ) {
if ( msglvl > 3 ) {
fprintf(msgFile, "\n\n aggregate list is not-empty") ;
fflush(msgFile) ;
}
SubMtx_denseInfo(BJ, &nrow, &ncol, &inc1, &inc2, &entBJ) ;
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n\n BJ(%d,%d) : nrow %d, ncol %d, inc1 %d, inc2 %d, ent %p",
BJ->rowid, BJ->colid, nrow, ncol, inc1, inc2, entBJ) ;
fflush(msgFile) ;
}
BJhead = SubMtxList_getList(aggList, J) ;
for ( BJhat = BJhead ; BJhat != NULL ; BJhat = BJhat->next ) {
if ( BJhat == NULL ) {
fprintf(stderr,
"\n 3. fatal error in forwardVisit(%d)"
"\n BJhat = NULL", J) ;
exit(-1) ;
}
SubMtx_denseInfo(BJhat, &nrowhat, &ncolhat, &inc1hat, &inc2hat,
&entBJhat) ;
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n BJhat(%d,%d) : nrow %d, ncol %d, inc1 %d, inc2 %d, ent %p",
BJhat->rowid, BJhat->colid,
nrowhat, ncolhat, inc1hat, inc2hat, entBJhat) ;
fflush(msgFile) ;
}
if ( nrow != nrowhat || ncol != ncolhat
|| inc1 != inc1hat || inc2 != inc2hat || entBJhat == NULL ) {
fprintf(stderr, "\n fatal error") ;
exit(-1) ;
}
if ( msglvl > 3 ) {
fprintf(msgFile, "\n\n BJ") ;
SubMtx_writeForHumanEye(BJ, msgFile) ;
fprintf(msgFile, "\n\n BJhat") ;
SubMtx_writeForHumanEye(BJhat, msgFile) ;
fflush(msgFile) ;
}
if ( SUBMTX_IS_REAL(BJhat) ) {
DVadd(nrow*ncol, entBJ, entBJhat) ;
} else if ( SUBMTX_IS_COMPLEX(BJhat) ) {
DVadd(2*nrow*ncol, entBJ, entBJhat) ;
}
}
SubMtxManager_releaseListOfObjects(mtxmanager, BJhead) ;
if ( msglvl > 3 ) {
fprintf(msgFile, "\n\n BJ after assembly") ;
SubMtx_writeForHumanEye(BJ, msgFile) ;
fflush(msgFile) ;
}
}
return ; }
/*
---------------------------------------
purpose -- solve (A^T + I) X = B, where
(1) A is strictly upper triangular
(2) X overwrites B
(B) B has mode SUBMTX_DENSE_COLUMNS
created -- 98may01, cca
---------------------------------------
*/
static void
solveDenseSubcolumns (
SubMtx *mtxA,
SubMtx *mtxB
) {
double ai, ar, bi0, bi1, bi2, br0, br1, br2,
isum0, isum1, isum2, rsum0, rsum1, rsum2 ;
double *colB0, *colB1, *colB2, *entriesA, *entriesB ;
int first, ii, iloc, inc1, inc2, irowA, jcolB, kk, last,
ncolB, nentA, nrowA, nrowB, rloc ;
int *firstlocsA, *sizesA ;
/*
----------------------------------------------------
extract the pointer and dimensions from two matrices
----------------------------------------------------
*/
SubMtx_denseSubcolumnsInfo(mtxA, &nrowA, &nentA,
&firstlocsA, &sizesA, &entriesA) ;
SubMtx_denseInfo(mtxB, &nrowB, &ncolB, &inc1, &inc2, &entriesB) ;
#if MYDEBUG > 0
fprintf(stdout, "\n nentA = %d", nentA) ;
fflush(stdout) ;
#endif
colB0 = entriesB ;
for ( jcolB = 0 ; jcolB < ncolB - 2 ; jcolB += 3 ) {
colB1 = colB0 + 2*nrowB ;
colB2 = colB1 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n %% jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
#if MYDEBUG > 0
fprintf(stdout, "\n %% irowA %d, size %d", irowA, sizesA[irowA]) ;
fflush(stdout) ;
#endif
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
#if MYDEBUG > 0
fprintf(stdout, ", first %d, last %d", first, last) ;
fflush(stdout) ;
#endif
rsum0 = isum0 = 0.0 ;
rsum1 = isum1 = 0.0 ;
rsum2 = isum2 = 0.0 ;
for ( ii = first ; ii <= last ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
#if MYDEBUG > 0
fprintf(stdout, "\n %% A(%d,%d) = (%12.4e,%12.4e)",
irowA+1, ii+1, ar, ai) ;
fflush(stdout) ;
#endif
rloc = 2*ii ; iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
br2 = colB2[rloc] ; bi2 = colB2[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
rsum1 += ar*br1 + ai*bi1 ; isum1 += ar*bi1 - ai*br1 ;
rsum2 += ar*br2 + ai*bi2 ; isum2 += ar*bi2 - ai*br2 ;
}
rloc = 2*irowA ; iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
colB1[rloc] -= rsum1 ; colB1[iloc] -= isum1 ;
colB2[rloc] -= rsum2 ; colB2[iloc] -= isum2 ;
}
}
#if MYDEBUG > 0
fprintf(stdout, "\n %% kk = %d", kk) ;
fflush(stdout) ;
#endif
colB0 = colB2 + 2*nrowB ;
}
if ( jcolB == ncolB - 2 ) {
colB1 = colB0 + 2*nrowB ;
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
#if MYDEBUG > 0
fprintf(stdout, "\n %% irowA %d, size %d", irowA, sizesA[irowA]) ;
fflush(stdout) ;
#endif
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
#if MYDEBUG > 0
fprintf(stdout, ", first %d, last %d", first, last) ;
fflush(stdout) ;
#endif
rsum0 = isum0 = 0.0 ;
rsum1 = isum1 = 0.0 ;
for ( ii = first ; ii <= last ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
#if MYDEBUG > 0
fprintf(stdout, "\n %% A(%d,%d) = (%12.4e,%12.4e)",
irowA+1, ii+1, ar, ai) ;
fflush(stdout) ;
#endif
rloc = 2*ii ; iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
rsum1 += ar*br1 + ai*bi1 ; isum1 += ar*bi1 - ai*br1 ;
}
rloc = 2*irowA ; iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
colB1[rloc] -= rsum1 ; colB1[iloc] -= isum1 ;
}
#if MYDEBUG > 0
fprintf(stdout, "\n %% kk = %d", kk) ;
fflush(stdout) ;
#endif
}
} else if ( jcolB == ncolB - 1 ) {
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
#if MYDEBUG > 0
fprintf(stdout, "\n %% irowA %d, size %d", irowA, sizesA[irowA]) ;
fflush(stdout) ;
#endif
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
#if MYDEBUG > 0
fprintf(stdout, ", first %d, last %d", first, last) ;
fflush(stdout) ;
#endif
rsum0 = isum0 = 0.0 ;
for ( ii = first ; ii <= last ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
#if MYDEBUG > 0
fprintf(stdout, "\n %% A(%d,%d) = (%12.4e,%12.4e)",
irowA+1, ii+1, ar, ai) ;
fflush(stdout) ;
#endif
rloc = 2*ii ; iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
}
rloc = 2*irowA ; iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
}
#if MYDEBUG > 0
fprintf(stdout, "\n %% kk = %d", kk) ;
fflush(stdout) ;
#endif
}
}
return ; }
/*
---------------------------------------------------
purpose -- move the solution from the individual
SubMtx objects into the global solution SubMtx object
created -- 98feb20
---------------------------------------------------
*/
void
FrontMtx_storeSolution (
FrontMtx *frontmtx,
int owners[],
int myid,
SubMtxManager *manager,
SubMtx *p_mtx[],
DenseMtx *solmtx,
int msglvl,
FILE *msgFile
) {
char localsol ;
SubMtx *xmtxJ ;
double *sol, *xJ ;
int inc1, inc2, irow, jrhs, J, kk,
ncolJ, neqns, nfront, nJ, nrhs, nrowInSol, nrowJ ;
int *colindJ, *colmap, *rowind ;
if ( (nrowInSol = solmtx->nrow) != (neqns = frontmtx->neqns) ) {
/*
--------------------------------------------------------------
the solution matrix is only part of the total solution matrix.
(this happens in an MPI environment where the rhs
is partitioned among the processors.)
create a map from the global row indices to the
indices local to this solution matrix.
--------------------------------------------------------------
*/
colmap = IVinit(neqns, -1) ;
rowind = solmtx->rowind ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n solmtx->rowind") ;
IVfprintf(msgFile, solmtx->nrow, rowind) ;
fflush(msgFile) ;
}
for ( irow = 0 ; irow < nrowInSol ; irow++ ) {
colmap[rowind[irow]] = irow ;
}
localsol = 'T' ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n colmap") ;
IVfprintf(msgFile, neqns, colmap) ;
fflush(msgFile) ;
}
} else {
localsol = 'F' ;
}
DenseMtx_dimensions(solmtx, &neqns, &nrhs) ;
nfront = FrontMtx_nfront(frontmtx) ;
for ( J = 0 ; J < nfront ; J++ ) {
if ( (owners == NULL || owners[J] == myid)
&& (nJ = FrontMtx_frontSize(frontmtx, J)) > 0 ) {
FrontMtx_columnIndices(frontmtx, J, &ncolJ, &colindJ) ;
xmtxJ = p_mtx[J] ;
if ( xmtxJ == NULL ) {
fprintf(stderr,
"\n fatal error in storeSolution(%d)"
"\n thread %d, xmtxJ = NULL", J, myid) ;
exit(-1) ;
}
if ( msglvl > 1 ) {
fprintf(msgFile, "\n storing solution for front %d", J) ;
SubMtx_writeForHumanEye(xmtxJ, msgFile) ;
fflush(msgFile) ;
}
if ( localsol == 'T' ) {
/*
------------------------------------------------------
map the global row indices into the local row indices
------------------------------------------------------
*/
if ( msglvl > 1 ) {
fprintf(msgFile, "\n global row indices") ;
IVfprintf(msgFile, nJ, colindJ) ;
fflush(msgFile) ;
}
for ( irow = 0 ; irow < nJ ; irow++ ) {
colindJ[irow] = colmap[colindJ[irow]] ;
}
if ( msglvl > 1 ) {
fprintf(msgFile, "\n local row indices") ;
IVfprintf(msgFile, nJ, colindJ) ;
fflush(msgFile) ;
}
}
/*
----------------------------------
store x_{J,*} into solution matrix
----------------------------------
*/
sol = DenseMtx_entries(solmtx) ;
SubMtx_denseInfo(xmtxJ, &nrowJ, &ncolJ, &inc1, &inc2, &xJ) ;
if ( FRONTMTX_IS_REAL(frontmtx) ) {
for ( jrhs = 0 ; jrhs < nrhs ; jrhs++ ) {
for ( irow = 0 ; irow < nJ ; irow++ ) {
kk = colindJ[irow] ;
sol[kk] = xJ[irow] ;
}
sol += neqns ;
xJ += nJ ;
}
} else if ( FRONTMTX_IS_COMPLEX(frontmtx) ) {
for ( jrhs = 0 ; jrhs < nrhs ; jrhs++ ) {
for ( irow = 0 ; irow < nJ ; irow++ ) {
kk = colindJ[irow] ;
sol[2*kk] = xJ[2*irow] ;
sol[2*kk+1] = xJ[2*irow+1] ;
}
sol += 2*neqns ;
xJ += 2*nJ ;
}
}
/*
fprintf(msgFile, "\n solution for front %d stored", J) ;
*/
SubMtxManager_releaseObject(manager, xmtxJ) ;
if ( localsol == 'T' ) {
/*
-----------------------------------------------------------
map the local row indices back into the global row indices
-----------------------------------------------------------
*/
for ( irow = 0 ; irow < nJ ; irow++ ) {
colindJ[irow] = rowind[colindJ[irow]] ;
}
}
}
}
if ( localsol == 'T' ) {
IVfree(colmap) ;
}
/*
fprintf(msgFile, "\n\n SOLUTION") ;
DenseMtx_writeForHumanEye(solmtx, msgFile) ;
*/
return ; }
/*
---------------------------------------
purpose -- solve (I + A^T) X = B, where
(1) A is strictly lower triangular
(2) X overwrites B
(B) B has mode SUBMTX_DENSE_COLUMNS
created -- 98may01, cca
---------------------------------------
*/
static void
solveDenseSubrows (
SubMtx *mtxA,
SubMtx *mtxB
) {
double ai, ar, bi0, bi1, bi2, br0, br1, br2 ;
double *colB0, *colB1, *colB2, *entriesA, *entriesB ;
int colstart, first, iloc, inc1, inc2, irowA, jcolB,
jj, kk, last, ncolB, nentA, nrowA, nrowB, rloc ;
int *firstlocsA, *sizesA ;
/*
----------------------------------------------------
extract the pointer and dimensions from two matrices
----------------------------------------------------
*/
SubMtx_denseSubrowsInfo(mtxA, &nrowA, &nentA,
&firstlocsA, &sizesA, &entriesA) ;
SubMtx_denseInfo(mtxB, &nrowB, &ncolB, &inc1, &inc2, &entriesB) ;
#if MYDEBUG > 0
fprintf(stdout, "\n nrowA = %d, ncolA = %d", nrowA, nentA) ;
fflush(stdout) ;
#endif
colB0 = entriesB ;
for ( jcolB = 0 ; jcolB < ncolB - 2 ; jcolB += 3 ) {
colB1 = colB0 + 2*nrowB ;
colB2 = colB1 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = nrowA - 1, colstart = nentA ;
irowA >= 0 ;
irowA-- ) {
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
colstart -= last - first + 1 ;
rloc = 2*irowA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
br2 = colB2[rloc] ; bi2 = colB2[iloc] ;
for ( jj = first, kk = colstart ; jj <= last ; jj++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
colB1[rloc] -= ar*br1 + ai*bi1 ;
colB1[iloc] -= ar*bi1 - ai*br1 ;
colB2[rloc] -= ar*br2 + ai*bi2 ;
colB2[iloc] -= ar*bi2 - ai*br2 ;
}
}
}
colB0 = colB2 + 2*nrowB ;
}
if ( jcolB == ncolB - 2 ) {
colB1 = colB0 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = nrowA - 1, colstart = nentA ;
irowA >= 0 ;
irowA-- ) {
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
colstart -= last - first + 1 ;
rloc = 2*irowA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
for ( jj = first, kk = colstart ; jj <= last ; jj++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
colB1[rloc] -= ar*br1 + ai*bi1 ;
colB1[iloc] -= ar*bi1 - ai*br1 ;
}
}
}
} else if ( jcolB == ncolB - 1 ) {
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = nrowA - 1, colstart = nentA ;
irowA >= 0 ;
irowA-- ) {
if ( sizesA[irowA] > 0 ) {
first = firstlocsA[irowA] ;
last = first + sizesA[irowA] - 1 ;
colstart -= last - first + 1 ;
rloc = 2*irowA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
for ( jj = first, kk = colstart ; jj <= last ; jj++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
}
}
}
}
return ; }
/*
---------------------------------------
purpose -- solve (I + A^T) X = B, where
(1) A is strictly lower triangular
(2) X overwrites B
(B) B has mode SUBMTX_DENSE_COLUMNS
created -- 98may01, cca
---------------------------------------
*/
static void
solveSparseRows (
SubMtx *mtxA,
SubMtx *mtxB
) {
double ai, ar, bi0, bi1, bi2, br0, br1, br2 ;
double *colB0, *colB1, *colB2, *entriesA, *entriesB ;
int colstart, ii, iloc, inc1, inc2, jcolA, jcolB,
jj, kk, ncolB, nentA, nrowA, nrowB, rloc, size ;
int *indicesA, *sizesA ;
/*
----------------------------------------------------
extract the pointer and dimensions from two matrices
----------------------------------------------------
*/
SubMtx_sparseRowsInfo(mtxA, &nrowA, &nentA,
&sizesA, &indicesA, &entriesA) ;
SubMtx_denseInfo(mtxB, &nrowB, &ncolB, &inc1, &inc2, &entriesB) ;
#if MYDEBUG > 0
fprintf(stdout, "\n nrowA = %d, ncolA = %d", nrowA, nentA) ;
fflush(stdout) ;
#endif
colB0 = entriesB ;
for ( jcolB = 0 ; jcolB < ncolB - 2 ; jcolB += 3 ) {
colB1 = colB0 + 2*nrowB ;
colB2 = colB1 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( jcolA = nrowA - 1, colstart = nentA ;
jcolA >= 0 ;
jcolA-- ) {
if ( (size = sizesA[jcolA]) > 0 ) {
colstart -= size ;
rloc = 2*jcolA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
br2 = colB2[rloc] ; bi2 = colB2[iloc] ;
for ( ii = 0, kk = colstart ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
colB1[rloc] -= ar*br1 + ai*bi1 ;
colB1[iloc] -= ar*bi1 - ai*br1 ;
colB2[rloc] -= ar*br2 + ai*bi2 ;
colB2[iloc] -= ar*bi2 - ai*br2 ;
}
}
}
colB0 = colB2 + 2*nrowB ;
}
if ( jcolB == ncolB - 2 ) {
colB1 = colB0 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( jcolA = nrowA - 1, colstart = nentA ;
jcolA >= 0 ;
jcolA-- ) {
if ( (size = sizesA[jcolA]) > 0 ) {
colstart -= size ;
rloc = 2*jcolA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
for ( ii = 0, kk = colstart ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
colB1[rloc] -= ar*br1 + ai*bi1 ;
colB1[iloc] -= ar*bi1 - ai*br1 ;
}
}
}
} else if ( jcolB == ncolB - 1 ) {
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( jcolA = nrowA - 1, colstart = nentA ;
jcolA >= 0 ;
jcolA-- ) {
if ( (size = sizesA[jcolA]) > 0 ) {
colstart -= size ;
rloc = 2*jcolA ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
for ( ii = 0, kk = colstart ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ; ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
rloc = 2*jj ;
iloc = rloc + 1 ;
colB0[rloc] -= ar*br0 + ai*bi0 ;
colB0[iloc] -= ar*bi0 - ai*br0 ;
}
}
}
}
return ; }
/*
-------------------------------------------------------
purpose -- to find matrix entry (irow,jcol) if present.
return value --
if entry (irow,jcol) is not present then
*pReal and *pImag are 0.0
return value is -1
else entry (irow,jcol) is present then
(*pReal,*pImag) is the matrix entry
return value is offset into entries array
endif
created -- 98may01, cca
-------------------------------------------------------
*/
int
SubMtx_complexEntry (
SubMtx *mtx,
int irow,
int jcol,
double *pReal,
double *pImag
) {
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || irow < 0 || irow >= mtx->nrow || jcol < 0
|| jcol >= mtx->ncol || pReal == NULL || pImag == NULL ) {
fprintf(stderr,
"\n fatal error in SubMtx_complexEntry(%p,%d,%d,%p,%p)"
"\n bad input\n", mtx, irow, jcol, pReal, pImag) ;
exit(-1) ;
}
if ( ! SUBMTX_IS_COMPLEX(mtx) ) {
fprintf(stderr,
"\n fatal error in SubMtx_complexEntry(%p,%d,%d,%p,%p)"
"\n bad type %d, must be SPOOLES_COMPLEX\n",
mtx, irow, jcol, pReal, pImag, mtx->type) ;
exit(-1) ;
}
*pReal = *pImag = 0 ;
switch ( mtx->mode ) {
case SUBMTX_DENSE_ROWS :
case SUBMTX_DENSE_COLUMNS : {
double *entries ;
int inc1, inc2, ncol, nrow, offset ;
SubMtx_denseInfo(mtx, &nrow, &ncol, &inc1, &inc2, &entries) ;
if ( irow < 0 || irow >= nrow || jcol < 0 || jcol >= ncol ) {
return(-1) ;
}
offset = irow*inc1 + jcol*inc2 ;
*pReal = entries[2*offset] ;
*pImag = entries[2*offset+1] ;
return(offset) ;
} break ;
case SUBMTX_SPARSE_ROWS : {
double *entries ;
int ii, jj, nent, nrow, offset, *indices, *sizes ;
SubMtx_sparseRowsInfo(mtx, &nrow, &nent, &sizes, &indices, &entries) ;
if ( irow < 0 || irow >= nrow ) {
return(-1) ;
}
for ( ii = offset = 0 ; ii < irow ; ii++ ) {
offset += sizes[ii] ;
}
for ( ii = 0, jj = offset ; ii < sizes[irow] ; ii++, jj++ ) {
if ( indices[jj] == jcol ) {
*pReal = entries[2*jj] ;
*pImag = entries[2*jj+1] ;
return(jj) ;
}
}
return(-1) ;
} break ;
case SUBMTX_SPARSE_COLUMNS : {
double *entries ;
int ii, jj, nent, ncol, offset, *indices, *sizes ;
SubMtx_sparseColumnsInfo(mtx, &ncol, &nent,
&sizes, &indices, &entries) ;
if ( jcol < 0 || jcol >= ncol ) {
return(-1) ;
}
for ( ii = offset = 0 ; ii < jcol ; ii++ ) {
offset += sizes[ii] ;
}
for ( ii = 0, jj = offset ; ii < sizes[jcol] ; ii++, jj++ ) {
if ( indices[jj] == irow ) {
*pReal = entries[2*jj] ;
*pImag = entries[2*jj+1] ;
return(jj) ;
}
}
return(-1) ;
} break ;
case SUBMTX_SPARSE_TRIPLES : {
double *entries ;
int ii, nent, *colids, *rowids ;
SubMtx_sparseTriplesInfo(mtx, &nent, &rowids, &colids, &entries) ;
for ( ii = 0 ; ii < nent ; ii++ ) {
if ( irow == rowids[ii] && jcol == colids[ii] ) {
*pReal = entries[2*ii] ;
*pImag = entries[2*ii+1] ;
return(ii) ;
}
}
return(-1) ;
} break ;
case SUBMTX_DENSE_SUBROWS : {
double *entries ;
int ii, joff, nent, nrow, offset, *firstlocs, *sizes ;
SubMtx_denseSubrowsInfo(mtx, &nrow, &nent,
&firstlocs, &sizes, &entries) ;
if ( irow < 0 || irow >= nrow || sizes[irow] == 0 ) {
return(-1) ;
}
for ( ii = offset = 0 ; ii < irow ; ii++ ) {
offset += sizes[ii] ;
}
if ( 0 <= (joff = jcol - firstlocs[irow]) && joff < sizes[irow] ) {
offset += joff ;
*pReal = entries[2*offset] ;
*pImag = entries[2*offset+1] ;
return(offset) ;
}
return(-1) ;
} break ;
case SUBMTX_DENSE_SUBCOLUMNS : {
double *entries ;
int ii, ioff, nent, ncol, offset, *firstlocs, *sizes ;
SubMtx_denseSubcolumnsInfo(mtx, &ncol, &nent,
&firstlocs, &sizes, &entries) ;
if ( jcol < 0 || jcol >= ncol || sizes[jcol] == 0 ) {
return(-1) ;
}
for ( ii = offset = 0 ; ii < jcol ; ii++ ) {
offset += sizes[ii] ;
}
if ( 0 <= (ioff = irow - firstlocs[jcol]) && ioff < sizes[jcol] ) {
offset += ioff ;
*pReal = entries[2*offset] ;
*pImag = entries[2*offset+1] ;
return(offset) ;
}
return(-1) ;
} break ;
case SUBMTX_DIAGONAL : {
double *entries ;
int ncol ;
if ( irow < 0 || jcol < 0 || irow != jcol ) {
return(-1) ;
}
SubMtx_diagonalInfo(mtx, &ncol, &entries) ;
if ( irow >= ncol || jcol >= ncol ) {
return(-1) ;
}
*pReal = entries[2*irow] ;
*pImag = entries[2*irow+1] ;
return(irow) ;
} break ;
case SUBMTX_BLOCK_DIAGONAL_SYM : {
double *entries ;
int ii, ipivot, jrow, kk, m, ncol, nent, size ;
int *pivotsizes ;
if ( irow < 0 || jcol < 0 ) {
return(-1) ;
}
if ( irow > jcol ) {
ii = irow ;
irow = jcol ;
jcol = ii ;
}
SubMtx_blockDiagonalInfo(mtx, &ncol, &nent, &pivotsizes, &entries) ;
if ( irow >= ncol || jcol >= ncol ) {
return(-1) ;
}
for ( jrow = ipivot = kk = 0 ; jrow <= irow ; ipivot++ ) {
size = m = pivotsizes[ipivot] ;
for ( ii = 0 ; ii < m ; ii++, jrow++ ) {
if ( jrow == irow ) {
if ( jcol - irow > m - ii - 1 ) {
return(-1) ;
} else {
kk += jcol - irow ;
*pReal = entries[2*kk] ;
*pImag = entries[2*kk+1] ;
return(kk) ;
}
} else {
kk += size-- ;
}
}
}
return(kk) ;
} break ;
case SUBMTX_BLOCK_DIAGONAL_HERM : {
double sign ;
double *entries ;
int ii, ipivot, jrow, kk, m, ncol, nent, size ;
int *pivotsizes ;
if ( irow < 0 || jcol < 0 ) {
return(-1) ;
}
if ( irow > jcol ) {
ii = irow ;
irow = jcol ;
jcol = ii ;
sign = -1.0 ;
} else {
sign = 1.0 ;
}
SubMtx_blockDiagonalInfo(mtx, &ncol, &nent, &pivotsizes, &entries) ;
if ( irow >= ncol || jcol >= ncol ) {
return(-1) ;
}
for ( jrow = ipivot = kk = 0 ; jrow <= irow ; ipivot++ ) {
size = m = pivotsizes[ipivot] ;
for ( ii = 0 ; ii < m ; ii++, jrow++ ) {
if ( jrow == irow ) {
if ( jcol - irow > m - ii - 1 ) {
return(-1) ;
} else {
kk += jcol - irow ;
*pReal = entries[2*kk] ;
*pImag = sign*entries[2*kk+1] ;
return(kk) ;
}
} else {
kk += size-- ;
}
}
}
return(kk) ;
} break ;
default :
fprintf(stderr,
"\n fatal error in SubMtx_complexEntry(%p,%d,%d,%p,%p)"
"\n bad mode %d", mtx, irow, jcol, pReal, pImag, mtx->mode) ;
exit(-1) ;
break ;
}
return(-1) ; }
/*
---------------------------------------
purpose -- solve (A^T + I) X = B, where
(1) A is strictly upper triangular
(2) X overwrites B
(B) B has mode SUBMTX_DENSE_COLUMNS
created -- 98may01, cca
---------------------------------------
*/
static void
solveSparseColumns (
SubMtx *mtxA,
SubMtx *mtxB
) {
double ai, ar, bi0, bi1, bi2, br0, br1, br2,
isum0, isum1, isum2, rsum0, rsum1, rsum2 ;
double *colB0, *colB1, *colB2, *entriesA, *entriesB ;
int ii, iloc, inc1, inc2, irowA, jcolB, jj, kk,
ncolB, nentA, nrowA, nrowB, rloc, size ;
int *indicesA, *sizesA ;
/*
----------------------------------------------------
extract the pointer and dimensions from two matrices
----------------------------------------------------
*/
SubMtx_sparseColumnsInfo(mtxA, &nrowA, &nentA,
&sizesA, &indicesA, &entriesA) ;
SubMtx_denseInfo(mtxB, &nrowB, &ncolB, &inc1, &inc2, &entriesB) ;
colB0 = entriesB ;
for ( jcolB = 0 ; jcolB < ncolB - 2 ; jcolB += 3 ) {
colB1 = colB0 + 2*nrowB ;
colB2 = colB1 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
if ( (size = sizesA[irowA]) > 0 ) {
rsum0 = isum0 = 0.0 ;
rsum1 = isum1 = 0.0 ;
rsum2 = isum2 = 0.0 ;
for ( ii = 0 ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
if ( jj < 0 || jj >= irowA ) {
fprintf(stderr,
"\n fatal error, irowA = %d, kk =%d, ii = %d, jj = %d",
irowA, kk, ii, jj) ;
spoolesFatal();
}
rloc = 2*jj ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
br2 = colB2[rloc] ; bi2 = colB2[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
rsum1 += ar*br1 + ai*bi1 ; isum1 += ar*bi1 - ai*br1 ;
rsum2 += ar*br2 + ai*bi2 ; isum2 += ar*bi2 - ai*br2 ;
}
rloc = 2*irowA ;
iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
colB1[rloc] -= rsum1 ; colB1[iloc] -= isum1 ;
colB2[rloc] -= rsum2 ; colB2[iloc] -= isum2 ;
}
}
colB0 = colB2 + 2*nrowB ;
}
if ( jcolB == ncolB - 2 ) {
colB1 = colB0 + 2*nrowB ;
#if MYDEBUG > 0
fprintf(stdout, "\n jcolB = %d", jcolB) ;
fflush(stdout) ;
#endif
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
if ( (size = sizesA[irowA]) > 0 ) {
rsum0 = isum0 = 0.0 ;
rsum1 = isum1 = 0.0 ;
for ( ii = 0 ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
if ( jj < 0 || jj >= irowA ) {
fprintf(stderr,
"\n fatal error, irowA = %d, kk =%d, ii = %d, jj = %d",
irowA, kk, ii, jj) ;
spoolesFatal();
}
rloc = 2*jj ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
br1 = colB1[rloc] ; bi1 = colB1[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
rsum1 += ar*br1 + ai*bi1 ; isum1 += ar*bi1 - ai*br1 ;
}
rloc = 2*irowA ;
iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
colB1[rloc] -= rsum1 ; colB1[iloc] -= isum1 ;
}
}
} else if ( jcolB == ncolB - 1 ) {
for ( irowA = kk = 0 ; irowA < nrowA ; irowA++ ) {
if ( (size = sizesA[irowA]) > 0 ) {
rsum0 = isum0 = 0.0 ;
for ( ii = 0 ; ii < size ; ii++, kk++ ) {
ar = entriesA[2*kk] ;
ai = entriesA[2*kk+1] ;
jj = indicesA[kk] ;
if ( jj < 0 || jj >= irowA ) {
fprintf(stderr,
"\n fatal error, irowA = %d, kk =%d, ii = %d, jj = %d",
irowA, kk, ii, jj) ;
spoolesFatal();
}
rloc = 2*jj ;
iloc = rloc + 1 ;
br0 = colB0[rloc] ; bi0 = colB0[iloc] ;
rsum0 += ar*br0 + ai*bi0 ; isum0 += ar*bi0 - ai*br0 ;
}
rloc = 2*irowA ;
iloc = rloc + 1 ;
colB0[rloc] -= rsum0 ; colB0[iloc] -= isum0 ;
}
}
}
return ; }
/*
-------------------------------------------------
purpose -- to return a pointer to the location of
matrix entry (irow,jcol) if present.
if entry (irow,jcol) is not present then
*ppValue is NULL
else entry (irow,jcol) is present then
*ppValue is the location of the matrix entry
endif
created -- 98may01, cca
-------------------------------------------------
*/
void
SubMtx_locationOfRealEntry (
SubMtx *mtx,
int irow,
int jcol,
double **ppValue
) {
/*
---------------
check the input
---------------
*/
if ( mtx == NULL || irow < 0 || irow >= mtx->nrow || jcol < 0
|| jcol >= mtx->ncol || ppValue == NULL ) {
fprintf(stderr,
"\n fatal error in SubMtx_locationOfRealEntry(%p,%d,%d,%p)"
"\n bad input\n", mtx, irow, jcol, ppValue) ;
exit(-1) ;
}
if ( ! SUBMTX_IS_REAL(mtx) ) {
fprintf(stderr,
"\n fatal error in SubMtx_locationOfRealEntry(%p,%d,%d,%p)"
"\n bad type %d, must be SPOOLES_REAL\n",
mtx, irow, jcol, ppValue, mtx->type) ;
exit(-1) ;
}
*ppValue = NULL ;
switch ( mtx->mode ) {
case SUBMTX_DENSE_ROWS :
case SUBMTX_DENSE_COLUMNS : {
double *entries ;
int inc1, inc2, ncol, nrow, offset ;
SubMtx_denseInfo(mtx, &nrow, &ncol, &inc1, &inc2, &entries) ;
if ( irow >= 0 && irow < nrow && jcol >= 0 && jcol < ncol ) {
offset = irow*inc1 + jcol*inc2 ;
*ppValue = entries + offset ;
}
} break ;
case SUBMTX_SPARSE_ROWS : {
double *entries ;
int ii, jj, nent, nrow, offset, *indices, *sizes ;
SubMtx_sparseRowsInfo(mtx, &nrow, &nent, &sizes, &indices, &entries);
if ( irow >= 0 && irow < nrow ) {
for ( ii = offset = 0 ; ii < irow ; ii++ ) {
offset += sizes[ii] ;
}
for ( ii = 0, jj = offset ; ii < sizes[irow] ; ii++, jj++ ) {
if ( indices[jj] == jcol ) {
*ppValue = entries + jj ;
break ;
}
}
}
} break ;
case SUBMTX_SPARSE_COLUMNS : {
double *entries ;
int ii, jj, nent, ncol, offset, *indices, *sizes ;
SubMtx_sparseColumnsInfo(mtx, &ncol, &nent,
&sizes, &indices, &entries) ;
if ( jcol >= 0 && jcol < ncol ) {
for ( ii = offset = 0 ; ii < jcol ; ii++ ) {
offset += sizes[ii] ;
}
for ( ii = 0, jj = offset ; ii < sizes[jcol] ; ii++, jj++ ) {
if ( indices[jj] == irow ) {
*ppValue = entries + jj ;
break ;
}
}
}
} break ;
case SUBMTX_SPARSE_TRIPLES : {
double *entries ;
int ii, nent, *colids, *rowids ;
SubMtx_sparseTriplesInfo(mtx, &nent, &rowids, &colids, &entries) ;
for ( ii = 0 ; ii < nent ; ii++ ) {
if ( irow == rowids[ii] && jcol == colids[ii] ) {
*ppValue = entries + ii ;
break ;
}
}
} break ;
case SUBMTX_DENSE_SUBROWS : {
double *entries ;
int ii, joff, nent, nrow, offset, *firstlocs, *sizes ;
SubMtx_denseSubrowsInfo(mtx, &nrow, &nent,
&firstlocs, &sizes, &entries) ;
if ( irow >= 0 && irow < nrow && sizes[irow] != 0 ) {
for ( ii = offset = 0 ; ii < irow ; ii++ ) {
offset += sizes[ii] ;
}
if ( 0 <= (joff = jcol - firstlocs[irow])
&& joff < sizes[irow] ) {
offset += joff ;
*ppValue = entries + offset ;
break ;
}
}
} break ;
case SUBMTX_DENSE_SUBCOLUMNS : {
double *entries ;
int ii, ioff, nent, ncol, offset, *firstlocs, *sizes ;
SubMtx_denseSubcolumnsInfo(mtx, &ncol, &nent,
&firstlocs, &sizes, &entries) ;
if ( jcol >= 0 && jcol < ncol && sizes[jcol] != 0 ) {
for ( ii = offset = 0 ; ii < jcol ; ii++ ) {
offset += sizes[jcol] ;
}
if ( 0 <= (ioff = irow - firstlocs[jcol])
&& ioff < sizes[jcol] ) {
offset += ioff ;
*ppValue = entries + offset ;
break ;
}
}
} break ;
case SUBMTX_DIAGONAL : {
double *entries ;
int ncol ;
if ( irow >= 0 && jcol >= 0 && irow == jcol ) {
SubMtx_diagonalInfo(mtx, &ncol, &entries) ;
if ( irow < ncol && jcol < ncol ) {
*ppValue = entries + irow ;
}
}
} break ;
case SUBMTX_BLOCK_DIAGONAL_SYM :
case SUBMTX_BLOCK_DIAGONAL_HERM : {
double *entries ;
int ii, ipivot, jrow, kk, m, ncol, nent, size ;
int *pivotsizes ;
if ( irow >= 0 && jcol >= 0 ) {
SubMtx_blockDiagonalInfo(mtx, &ncol, &nent,
&pivotsizes, &entries) ;
if ( irow < ncol && jcol < ncol ) {
for ( jrow = ipivot = kk = 0 ; jrow <= irow ; ipivot++ ) {
size = m = pivotsizes[ipivot] ;
for ( ii = 0 ; ii < m ; ii++, jrow++ ) {
if ( jrow == irow ) {
if ( jrow - irow > m - ii ) {
kk = -1 ;
} else {
kk += jrow - irow ;
}
} else {
kk += size-- ;
}
}
}
if ( kk != -1 ) {
*ppValue = entries + kk ;
}
}
}
} break ;
default :
fprintf(stderr,
"\n fatal error in SubMtx_locationOfRealEntry(%p,%d,%d,%p)"
"\n bad mode %d", mtx, irow, jcol, ppValue, mtx->mode) ;
exit(-1) ;
break ;
}
return ; }
/*--------------------------------------------------------------------*/
int
main ( int argc, char *argv[] )
/*
-----------------------------
test the SubMtx_solve() method.
created -- 98apr15, cca
-----------------------------
*/
{
SubMtx *mtxA, *mtxB, *mtxX ;
double idot, rdot, t1, t2 ;
double *entB, *entX ;
Drand *drand ;
FILE *msgFile ;
int inc1, inc2, mode, msglvl, ncolA, nentA, nrowA,
ncolB, nrowB, ncolX, nrowX, seed, type ;
if ( argc != 9 ) {
fprintf(stdout,
"\n\n usage : %s msglvl msgFile type mode nrowA nentA ncolB seed"
"\n msglvl -- message level"
"\n msgFile -- message file"
"\n type -- type of matrix A"
"\n 1 -- real"
"\n 2 -- complex"
"\n mode -- mode of matrix A"
"\n 2 -- sparse stored by rows"
"\n 3 -- sparse stored by columns"
"\n 5 -- sparse stored by subrows"
"\n 6 -- sparse stored by subcolumns"
"\n 7 -- diagonal"
"\n 8 -- block diagonal symmetric"
"\n 9 -- block diagonal hermitian"
"\n nrowA -- # of rows in matrix A"
"\n nentA -- # of entries in matrix A"
"\n ncolB -- # of columns in matrix B"
"\n seed -- random number seed"
"\n", argv[0]) ;
return(0) ;
}
if ( (msglvl = atoi(argv[1])) < 0 ) {
fprintf(stderr, "\n message level must be positive\n") ;
spoolesFatal();
}
if ( strcmp(argv[2], "stdout") == 0 ) {
msgFile = stdout ;
} else if ( (msgFile = fopen(argv[2], "a")) == NULL ) {
fprintf(stderr, "\n unable to open file %s\n", argv[2]) ;
return(-1) ;
}
type = atoi(argv[3]) ;
mode = atoi(argv[4]) ;
nrowA = atoi(argv[5]) ;
nentA = atoi(argv[6]) ;
ncolB = atoi(argv[7]) ;
seed = atoi(argv[8]) ;
fprintf(msgFile, "\n %% %s:"
"\n %% msglvl = %d"
"\n %% msgFile = %s"
"\n %% type = %d"
"\n %% mode = %d"
"\n %% nrowA = %d"
"\n %% nentA = %d"
"\n %% ncolB = %d"
"\n %% seed = %d",
argv[0], msglvl, argv[2], type, mode,
nrowA, nentA, ncolB, seed) ;
ncolA = nrowA ;
nrowB = nrowA ;
nrowX = nrowA ;
ncolX = ncolB ;
/*
-----------------------------
check for errors in the input
-----------------------------
*/
if ( nrowA <= 0 || nentA <= 0 || ncolB <= 0 ) {
fprintf(stderr, "\n invalid input\n") ;
spoolesFatal();
}
switch ( type ) {
case SPOOLES_REAL :
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
break ;
default :
fprintf(stderr, "\n invalid mode %d\n", mode) ;
spoolesFatal();
}
break ;
case SPOOLES_COMPLEX :
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
case SUBMTX_BLOCK_DIAGONAL_HERM :
break ;
default :
fprintf(stderr, "\n invalid mode %d\n", mode) ;
spoolesFatal();
}
break ;
default :
fprintf(stderr, "\n invalid type %d\n", type) ;
spoolesFatal();
break ;
}
/*
--------------------------------------
initialize the random number generator
--------------------------------------
*/
drand = Drand_new() ;
Drand_init(drand) ;
Drand_setSeed(drand, seed) ;
Drand_setNormal(drand, 0.0, 1.0) ;
/*
------------------------------
initialize the X SubMtx object
------------------------------
*/
MARKTIME(t1) ;
mtxX = SubMtx_new() ;
SubMtx_initRandom(mtxX, type, SUBMTX_DENSE_COLUMNS, 0, 0,
nrowX, ncolX, nrowX*ncolX, ++seed) ;
SubMtx_denseInfo(mtxX, &nrowX, &ncolX, &inc1, &inc2, &entX) ;
MARKTIME(t2) ;
fprintf(msgFile, "\n %% CPU : %.3f to initialize X SubMtx object",
t2 - t1) ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n %% X SubMtx object") ;
fprintf(msgFile, "\n X = zeros(%d,%d) ;", nrowX, ncolX) ;
SubMtx_writeForMatlab(mtxX, "X", msgFile) ;
fflush(msgFile) ;
}
/*
------------------------------
initialize the B SubMtx object
------------------------------
*/
MARKTIME(t1) ;
mtxB = SubMtx_new() ;
SubMtx_init(mtxB, type,
SUBMTX_DENSE_COLUMNS, 0, 0, nrowB, ncolB, nrowB*ncolB) ;
SubMtx_denseInfo(mtxB, &nrowB, &ncolB, &inc1, &inc2, &entB) ;
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
if ( SUBMTX_IS_REAL(mtxX) ) {
DVcopy(nrowB*ncolB, entB, entX) ;
} else if ( SUBMTX_IS_COMPLEX(mtxX) ) {
ZVcopy(nrowB*ncolB, entB, entX) ;
}
break ;
default :
if ( SUBMTX_IS_REAL(mtxX) ) {
DVzero(nrowB*ncolB, entB) ;
} else if ( SUBMTX_IS_COMPLEX(mtxX) ) {
DVzero(2*nrowB*ncolB, entB) ;
}
break ;
}
MARKTIME(t2) ;
fprintf(msgFile, "\n %% CPU : %.3f to initialize B SubMtx object",
t2 - t1) ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n %% B SubMtx object") ;
fprintf(msgFile, "\n B = zeros(%d,%d) ;", nrowB, ncolB) ;
SubMtx_writeForMatlab(mtxB, "B", msgFile) ;
fflush(msgFile) ;
}
/*
-------------------------------------
initialize the A matrix SubMtx object
-------------------------------------
*/
seed++ ;
mtxA = SubMtx_new() ;
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
SubMtx_initRandomLowerTriangle(mtxA, type, mode, 0, 0,
nrowA, ncolA, nentA, seed, 1) ;
break ;
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
SubMtx_initRandomUpperTriangle(mtxA, type, mode, 0, 0,
nrowA, ncolA, nentA, seed, 1) ;
break ;
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
case SUBMTX_BLOCK_DIAGONAL_HERM :
SubMtx_initRandom(mtxA, type, mode, 0, 0,
nrowA, ncolA, nentA, seed) ;
break ;
default :
fprintf(stderr, "\n fatal error in test_solve"
"\n invalid mode = %d", mode) ;
spoolesFatal();
}
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n %% A SubMtx object") ;
fprintf(msgFile, "\n A = zeros(%d,%d) ;", nrowA, ncolA) ;
SubMtx_writeForMatlab(mtxA, "A", msgFile) ;
fflush(msgFile) ;
}
/*
--------------------------------------------------------
compute B = A * X (for diagonal and block diagonal)
or B = (I + A) * X (for lower and upper triangular)
--------------------------------------------------------
*/
if ( SUBMTX_IS_REAL(mtxA) ) {
DV *colDV, *rowDV ;
double value, *colX, *rowA, *pBij, *pXij ;
int irowA, jcolX ;
colDV = DV_new() ;
DV_init(colDV, nrowA, NULL) ;
colX = DV_entries(colDV) ;
rowDV = DV_new() ;
DV_init(rowDV, nrowA, NULL) ;
rowA = DV_entries(rowDV) ;
for ( jcolX = 0 ; jcolX < ncolB ; jcolX++ ) {
SubMtx_fillColumnDV(mtxX, jcolX, colDV) ;
for ( irowA = 0 ; irowA < nrowA ; irowA++ ) {
SubMtx_fillRowDV(mtxA, irowA, rowDV) ;
SubMtx_locationOfRealEntry(mtxX, irowA, jcolX, &pXij) ;
SubMtx_locationOfRealEntry(mtxB, irowA, jcolX, &pBij) ;
value = DVdot(nrowA, rowA, colX) ;
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
*pBij = *pXij + value ;
break ;
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
*pBij = value ;
break ;
}
}
}
DV_free(colDV) ;
DV_free(rowDV) ;
} else if ( SUBMTX_IS_COMPLEX(mtxA) ) {
ZV *colZV, *rowZV ;
double *colX, *rowA, *pBIij, *pBRij, *pXIij, *pXRij ;
int irowA, jcolX ;
colZV = ZV_new() ;
ZV_init(colZV, nrowA, NULL) ;
colX = ZV_entries(colZV) ;
rowZV = ZV_new() ;
ZV_init(rowZV, nrowA, NULL) ;
rowA = ZV_entries(rowZV) ;
for ( jcolX = 0 ; jcolX < ncolB ; jcolX++ ) {
SubMtx_fillColumnZV(mtxX, jcolX, colZV) ;
for ( irowA = 0 ; irowA < nrowA ; irowA++ ) {
SubMtx_fillRowZV(mtxA, irowA, rowZV) ;
SubMtx_locationOfComplexEntry(mtxX,
irowA, jcolX, &pXRij, &pXIij) ;
SubMtx_locationOfComplexEntry(mtxB,
irowA, jcolX, &pBRij, &pBIij) ;
ZVdotU(nrowA, rowA, colX, &rdot, &idot) ;
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
*pBRij = *pXRij + rdot ;
*pBIij = *pXIij + idot ;
break ;
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
case SUBMTX_BLOCK_DIAGONAL_HERM :
*pBRij = rdot ;
*pBIij = idot ;
break ;
}
}
}
ZV_free(colZV) ;
ZV_free(rowZV) ;
}
/*
----------------------
print out the matrices
----------------------
*/
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n %% X SubMtx object") ;
fprintf(msgFile, "\n X = zeros(%d,%d) ;", nrowX, ncolX) ;
SubMtx_writeForMatlab(mtxX, "X", msgFile) ;
fprintf(msgFile, "\n\n %% A SubMtx object") ;
fprintf(msgFile, "\n A = zeros(%d,%d) ;", nrowA, ncolA) ;
SubMtx_writeForMatlab(mtxA, "A", msgFile) ;
fprintf(msgFile, "\n\n %% B SubMtx object") ;
fprintf(msgFile, "\n B = zeros(%d,%d) ;", nrowB, ncolB) ;
SubMtx_writeForMatlab(mtxB, "B", msgFile) ;
fflush(msgFile) ;
}
/*
-----------------
check with matlab
-----------------
*/
if ( msglvl > 1 ) {
switch ( mode ) {
case SUBMTX_DENSE_SUBROWS :
case SUBMTX_SPARSE_ROWS :
case SUBMTX_DENSE_SUBCOLUMNS :
case SUBMTX_SPARSE_COLUMNS :
fprintf(msgFile,
"\n\n emtx = abs(B - X - A*X) ;"
"\n\n condA = cond(eye(%d,%d) + A)"
"\n\n maxabsZ = max(max(abs(emtx))) ", nrowA, nrowA) ;
fflush(msgFile) ;
break ;
case SUBMTX_DIAGONAL :
case SUBMTX_BLOCK_DIAGONAL_SYM :
case SUBMTX_BLOCK_DIAGONAL_HERM :
fprintf(msgFile,
"\n\n emtx = abs(B - A*X) ;"
"\n\n condA = cond(A)"
"\n\n maxabsZ = max(max(abs(emtx))) ") ;
fflush(msgFile) ;
break ;
}
}
/*
----------------------------------------
compute the solve DY = B or (I + A)Y = B
----------------------------------------
*/
SubMtx_solve(mtxA, mtxB) ;
if ( msglvl > 1 ) {
fprintf(msgFile, "\n\n %% Y SubMtx object") ;
fprintf(msgFile, "\n Y = zeros(%d,%d) ;", nrowB, ncolB) ;
SubMtx_writeForMatlab(mtxB, "Y", msgFile) ;
fprintf(msgFile,
"\n\n %% solerror = abs(Y - X) ;"
"\n\n solerror = abs(Y - X) ;"
"\n\n maxabserror = max(max(solerror)) ") ;
fflush(msgFile) ;
}
/*
------------------------
free the working storage
------------------------
*/
SubMtx_free(mtxA) ;
SubMtx_free(mtxX) ;
SubMtx_free(mtxB) ;
Drand_free(drand) ;
fprintf(msgFile, "\n") ;
return(1) ; }
/*
----------------------------------------------------------------
purpose -- for each L_{bnd{J},J} matrix, remove from hash table,
split into their L_{K,J} submatrices and insert
into the hash table.
created -- 98may04, cca
----------------------------------------------------------------
*/
void
FrontMtx_splitLowerMatrices (
FrontMtx *frontmtx,
int msglvl,
FILE *msgFile
) {
SubMtx *mtxLJ, *mtxLJJ, *mtxLKJ ;
SubMtxManager *manager ;
double *entLJ, *entLKJ ;
int count, first, ii, inc1, inc2, irow, jj, J, K, nbytes,
ncolLJ, ncolLKJ, nentLJ, nentLKJ, neqns, nfront, nJ,
nrowJ, nrowLJ, nrowLKJ, offset, v ;
int *colindLJ, *colindLKJ, *rowmap, *indicesLJ, *indicesLKJ,
*locmap, *rowindJ, *rowindLJ, *rowindLKJ, *sizesLJ,
*sizesLKJ ;
I2Ohash *lowerhash ;
/*
---------------
check the input
---------------
*/
if ( frontmtx == NULL || (msglvl > 0 && msgFile == NULL) ) {
fprintf(stderr,
"\n fatal error in FrontMtx_splitLowerMatrices(%p,%d,%p)"
"\n bad input\n", frontmtx, msglvl, msgFile) ;
spoolesFatal();
}
nfront = FrontMtx_nfront(frontmtx) ;
neqns = FrontMtx_neqns(frontmtx) ;
lowerhash = frontmtx->lowerhash ;
manager = frontmtx->manager ;
/*
--------------------------------
construct the row and local maps
--------------------------------
*/
rowmap = IVinit(neqns, -1) ;
locmap = IVinit(neqns, -1) ;
for ( J = 0 ; J < nfront ; J++ ) {
if ( (nJ = FrontMtx_frontSize(frontmtx, J)) > 0 ) {
FrontMtx_rowIndices(frontmtx, J, &nrowJ, &rowindJ) ;
if ( nrowJ > 0 && rowindJ != NULL ) {
for ( ii = 0 ; ii < nJ ; ii++ ) {
v = rowindJ[ii] ;
rowmap[v] = J ;
locmap[v] = ii ;
}
}
}
}
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n rowmap[]") ;
IVfprintf(msgFile, neqns, rowmap) ;
fprintf(msgFile, "\n\n locmap[]") ;
IVfprintf(msgFile, neqns, locmap) ;
fflush(msgFile) ;
}
/*
---------------------------------------------
move the L_{J,J} matrices into the hash table
---------------------------------------------
*/
for ( J = 0 ; J < nfront ; J++ ) {
if ( (mtxLJJ = FrontMtx_lowerMtx(frontmtx, J, J)) != NULL ) {
I2Ohash_insert(frontmtx->lowerhash, J, J, mtxLJJ) ;
}
}
/*
------------------------------------------------------------
now split the L_{bnd{J},J} matrices into L_{K,J} matrices.
note: columns of L_{bnd{J},J} are assumed to be in ascending
order with respect to the column ordering of the matrix.
------------------------------------------------------------
*/
for ( J = 0 ; J < nfront ; J++ ) {
mtxLJ = FrontMtx_lowerMtx(frontmtx, nfront, J) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n ### J = %d, mtxLJ = %p", J, mtxLJ) ;
fflush(msgFile) ;
}
if ( mtxLJ != NULL ) {
if ( msglvl > 2 ) {
SubMtx_writeForHumanEye(mtxLJ, msgFile) ;
fflush(msgFile) ;
}
SubMtx_columnIndices(mtxLJ, &ncolLJ, &colindLJ) ;
SubMtx_rowIndices(mtxLJ, &nrowLJ, &rowindLJ) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n column indices for J") ;
IVfprintf(msgFile, ncolLJ, colindLJ) ;
fprintf(msgFile, "\n row indices for LJ") ;
IVfprintf(msgFile, nrowLJ, rowindLJ) ;
fflush(msgFile) ;
}
if ( (K = rowmap[rowindLJ[0]]) == rowmap[rowindLJ[nrowLJ-1]] ) {
if ( msglvl > 2 ) {
fprintf(msgFile, "\n front %d supports only %d", J, K) ;
fflush(msgFile) ;
}
/*
-------------------------------------------------
L_{bnd{J},J} is one submatrix, bnd{J} \subseteq K
set row and column indices and change column id
-------------------------------------------------
*/
IVramp(ncolLJ, colindLJ, 0, 1) ;
for ( ii = 0 ; ii < nrowLJ ; ii++ ) {
rowindLJ[ii] = locmap[rowindLJ[ii]] ;
}
/*
mtxLJ->rowid = K ;
*/
SubMtx_setFields(mtxLJ, mtxLJ->type, mtxLJ->mode, K, J,
mtxLJ->nrow, mtxLJ->ncol, mtxLJ->nent) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n ## inserting L(%d,%d) ", K, J) ;
SubMtx_writeForHumanEye(mtxLJ, msgFile) ;
fflush(msgFile) ;
}
I2Ohash_insert(lowerhash, K, J, (void *) mtxLJ) ;
} else {
/*
-----------------------------------
split L_{bnd{J},J} into submatrices
-----------------------------------
*/
nJ = FrontMtx_frontSize(frontmtx, J) ;
if ( SUBMTX_IS_DENSE_ROWS(mtxLJ) ) {
SubMtx_denseInfo(mtxLJ,
&nrowLJ, &ncolLJ, &inc1, &inc2, &entLJ) ;
} else if ( SUBMTX_IS_SPARSE_ROWS(mtxLJ) ) {
SubMtx_sparseRowsInfo(mtxLJ, &nrowLJ, &nentLJ,
&sizesLJ, &indicesLJ, &entLJ) ;
offset = 0 ;
count = sizesLJ[0] ;
}
first = 0 ;
K = rowmap[rowindLJ[0]] ;
for ( irow = 1 ; irow <= nrowLJ ; irow++ ) {
if ( msglvl > 2 ) {
fprintf(msgFile, "\n irow = %d", irow) ;
if ( irow < nrowLJ ) {
fprintf(msgFile, ", rowmap[%d] = %d",
rowindLJ[irow], rowmap[rowindLJ[irow]]);
}
fflush(msgFile) ;
}
if ( irow == nrowLJ || K != rowmap[rowindLJ[irow]] ) {
nrowLKJ = irow - first ;
if ( SUBMTX_IS_DENSE_ROWS(mtxLJ) ) {
nentLKJ = nJ*nrowLKJ ;
} else if ( SUBMTX_IS_SPARSE_ROWS(mtxLJ) ) {
if ( count == 0 ) {
goto no_entries ;
}
nentLKJ = count ;
}
nbytes = SubMtx_nbytesNeeded(mtxLJ->type, mtxLJ->mode,
nrowLKJ, nJ, nentLKJ) ;
mtxLKJ = SubMtxManager_newObjectOfSizeNbytes(manager,
nbytes) ;
SubMtx_init(mtxLKJ, mtxLJ->type, mtxLJ->mode, K, J,
nrowLKJ, nJ, nentLKJ) ;
if ( SUBMTX_IS_DENSE_ROWS(mtxLJ) ) {
SubMtx_denseInfo(mtxLKJ,
&nrowLKJ, &ncolLKJ, &inc1, &inc2, &entLKJ) ;
if ( FRONTMTX_IS_REAL(frontmtx) ) {
DVcopy(nentLKJ, entLKJ, entLJ + first*nJ) ;
} else if ( FRONTMTX_IS_COMPLEX(frontmtx) ) {
DVcopy(2*nentLKJ, entLKJ, entLJ + 2*first*nJ) ;
}
} else if ( SUBMTX_IS_SPARSE_ROWS(mtxLJ) ) {
SubMtx_sparseRowsInfo(mtxLKJ, &nrowLKJ, &nentLKJ,
&sizesLKJ, &indicesLKJ, &entLKJ) ;
IVcopy(nrowLKJ, sizesLKJ, sizesLJ + first) ;
IVcopy(nentLKJ, indicesLKJ, indicesLJ + offset) ;
if ( FRONTMTX_IS_REAL(frontmtx) ) {
DVcopy(nentLKJ, entLKJ, entLJ + offset) ;
} else if ( FRONTMTX_IS_COMPLEX(frontmtx) ) {
DVcopy(2*nentLKJ, entLKJ, entLJ + 2*offset) ;
}
count = 0 ;
offset += nentLKJ ;
}
/*
-------------------------------------
initialize the row and column indices
-------------------------------------
*/
SubMtx_rowIndices(mtxLKJ, &nrowLKJ, &rowindLKJ) ;
for ( ii = 0, jj = first ; ii < nrowLKJ ; ii++, jj++ ) {
rowindLKJ[ii] = locmap[rowindLJ[jj]] ;
}
SubMtx_columnIndices(mtxLKJ, &ncolLKJ, &colindLKJ) ;
IVramp(ncolLKJ, colindLKJ, 0, 1) ;
/*
----------------------------------
insert L_{K,J} into the hash table
----------------------------------
*/
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n\n ## inserting L(%d,%d) ", K, J) ;
SubMtx_writeForHumanEye(mtxLKJ, msgFile) ;
fflush(msgFile) ;
}
I2Ohash_insert(lowerhash, K, J, (void *) mtxLKJ) ;
/*
-----------------------------------
we jump to here if there were no
entries to be stored in the matrix.
-----------------------------------
*/
no_entries :
/*
----------------------------------------------------
reset first and K to new first location and front id
----------------------------------------------------
*/
first = irow ;
if ( irow < nrowLJ ) {
K = rowmap[rowindLJ[irow]] ;
}
}
if ( irow < nrowLJ && SUBMTX_IS_SPARSE_ROWS(mtxLJ) ) {
count += sizesLJ[irow] ;
}
}
/*
--------------------------------------------
give L_{bnd{J},J} back to the matrix manager
--------------------------------------------
*/
SubMtxManager_releaseObject(manager, mtxLJ) ;
}
}
}
/*
------------------------
free the working storage
------------------------
*/
IVfree(rowmap) ;
IVfree(locmap) ;
return ; }
/*
----------------------------------------------------------------
purpose -- for each U_{J,bnd{J}} matrix, remove from hash table,
split into their U_{J,K} submatrices and insert
into the hash table.
created -- 98may04, cca
----------------------------------------------------------------
*/
void
FrontMtx_splitUpperMatrices (
FrontMtx *frontmtx,
int msglvl,
FILE *msgFile
) {
SubMtx *mtxUJ, *mtxUJJ, *mtxUJK ;
SubMtxManager *manager ;
double *entUJ, *entUJK ;
int count, first, ii, inc1, inc2, jcol, jj, J, K, nbytes,
ncolJ, ncolUJ, ncolUJK, nentUJ, nentUJK, neqns, nfront,
nJ, nrowUJ, nrowUJK, offset, v ;
int *colindJ, *colindUJ, *colindUJK, *colmap, *indicesUJ,
*indicesUJK, *locmap, *rowindUJ, *rowindUJK, *sizesUJ,
*sizesUJK ;
I2Ohash *upperhash ;
/*
---------------
check the input
---------------
*/
if ( frontmtx == NULL || (msglvl > 0 && msgFile == NULL) ) {
fprintf(stderr,
"\n fatal error in FrontMtx_splitUpperMatrices(%p,%d,%p)"
"\n bad input\n", frontmtx, msglvl, msgFile) ;
spoolesFatal();
}
nfront = FrontMtx_nfront(frontmtx) ;
neqns = FrontMtx_neqns(frontmtx) ;
upperhash = frontmtx->upperhash ;
manager = frontmtx->manager ;
/*
-----------------------------------
construct the column and local maps
-----------------------------------
*/
colmap = IVinit(neqns, -1) ;
locmap = IVinit(neqns, -1) ;
for ( J = 0 ; J < nfront ; J++ ) {
if ( (nJ = FrontMtx_frontSize(frontmtx, J)) > 0 ) {
FrontMtx_columnIndices(frontmtx, J, &ncolJ, &colindJ) ;
if ( ncolJ > 0 && colindJ != NULL ) {
for ( ii = 0 ; ii < nJ ; ii++ ) {
v = colindJ[ii] ;
colmap[v] = J ;
locmap[v] = ii ;
}
}
}
}
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n colmap[]") ;
IVfprintf(msgFile, neqns, colmap) ;
fprintf(msgFile, "\n\n locmap[]") ;
IVfprintf(msgFile, neqns, locmap) ;
fflush(msgFile) ;
}
/*
---------------------------------------------
move the U_{J,J} matrices into the hash table
---------------------------------------------
*/
for ( J = 0 ; J < nfront ; J++ ) {
if ( (mtxUJJ = FrontMtx_upperMtx(frontmtx, J, J)) != NULL ) {
I2Ohash_insert(frontmtx->upperhash, J, J, mtxUJJ) ;
}
}
/*
------------------------------------------------------------
now split the U_{J,bnd{J}} matrices into U_{J,K} matrices.
note: columns of U_{J,bnd{J}} are assumed to be in ascending
order with respect to the column ordering of the matrix.
------------------------------------------------------------
*/
for ( J = 0 ; J < nfront ; J++ ) {
mtxUJ = FrontMtx_upperMtx(frontmtx, J, nfront) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n ### J = %d, mtxUJ = %p", J, mtxUJ) ;
fflush(msgFile) ;
}
if ( mtxUJ != NULL ) {
if ( msglvl > 2 ) {
SubMtx_writeForHumanEye(mtxUJ, msgFile) ;
fflush(msgFile) ;
}
SubMtx_columnIndices(mtxUJ, &ncolUJ, &colindUJ) ;
SubMtx_rowIndices(mtxUJ, &nrowUJ, &rowindUJ) ;
if ( msglvl > 2 ) {
fprintf(msgFile, "\n column indices for J") ;
IVfprintf(msgFile, ncolUJ, colindUJ) ;
fprintf(msgFile, "\n row indices for UJ") ;
IVfprintf(msgFile, nrowUJ, rowindUJ) ;
fflush(msgFile) ;
}
if ( (K = colmap[colindUJ[0]]) == colmap[colindUJ[ncolUJ-1]] ) {
if ( msglvl > 2 ) {
fprintf(msgFile, "\n front %d supports only %d", J, K) ;
fflush(msgFile) ;
}
/*
-------------------------------------------------
U_{J,bnd{J}} is one submatrix, bnd{J} \subseteq K
set row and column indices and change column id
-------------------------------------------------
*/
IVramp(nrowUJ, rowindUJ, 0, 1) ;
for ( ii = 0 ; ii < ncolUJ ; ii++ ) {
colindUJ[ii] = locmap[colindUJ[ii]] ;
}
SubMtx_setFields(mtxUJ, mtxUJ->type, mtxUJ->mode, J, K,
mtxUJ->nrow, mtxUJ->ncol, mtxUJ->nent) ;
/*
mtxUJ->colid = K ;
*/
if ( msglvl > 2 ) {
fprintf(msgFile, "\n\n ## inserting U(%d,%d) ", J, K) ;
SubMtx_writeForHumanEye(mtxUJ, msgFile) ;
fflush(msgFile) ;
}
I2Ohash_insert(upperhash, J, K, (void *) mtxUJ) ;
} else {
/*
-----------------------------------
split U_{J,bnd{J}} into submatrices
-----------------------------------
*/
nJ = FrontMtx_frontSize(frontmtx, J) ;
if ( SUBMTX_IS_DENSE_COLUMNS(mtxUJ) ) {
SubMtx_denseInfo(mtxUJ,
&nrowUJ, &ncolUJ, &inc1, &inc2, &entUJ) ;
} else if ( SUBMTX_IS_SPARSE_COLUMNS(mtxUJ) ) {
SubMtx_sparseColumnsInfo(mtxUJ, &ncolUJ, &nentUJ,
&sizesUJ, &indicesUJ, &entUJ) ;
offset = 0 ;
count = sizesUJ[0] ;
}
first = 0 ;
K = colmap[colindUJ[0]] ;
for ( jcol = 1 ; jcol <= ncolUJ ; jcol++ ) {
if ( msglvl > 2 ) {
fprintf(msgFile, "\n jcol = %d", jcol) ;
if ( jcol < ncolUJ ) {
fprintf(msgFile, ", colmap[%d] = %d",
colindUJ[jcol], colmap[colindUJ[jcol]]);
}
fflush(msgFile) ;
}
if ( jcol == ncolUJ || K != colmap[colindUJ[jcol]] ) {
ncolUJK = jcol - first ;
if ( SUBMTX_IS_DENSE_COLUMNS(mtxUJ) ) {
nentUJK = nJ*ncolUJK ;
} else if ( SUBMTX_IS_SPARSE_COLUMNS(mtxUJ) ) {
if ( count == 0 ) {
goto no_entries ;
}
nentUJK = count ;
}
nbytes = SubMtx_nbytesNeeded(mtxUJ->type, mtxUJ->mode,
nJ, ncolUJK, nentUJK) ;
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n ncolUJK %d, nentUJK %d, nbytes %d",
ncolUJK, nentUJK, nbytes) ;
fflush(msgFile) ;
}
mtxUJK = SubMtxManager_newObjectOfSizeNbytes(manager,
nbytes) ;
SubMtx_init(mtxUJK, mtxUJ->type, mtxUJ->mode, J, K,
nJ, ncolUJK, nentUJK) ;
if ( SUBMTX_IS_DENSE_COLUMNS(mtxUJ) ) {
SubMtx_denseInfo(mtxUJK,
&nrowUJK, &ncolUJK, &inc1, &inc2, &entUJK) ;
if ( FRONTMTX_IS_REAL(frontmtx) ) {
DVcopy(nentUJK, entUJK, entUJ + first*nJ) ;
} else if ( FRONTMTX_IS_COMPLEX(frontmtx) ) {
DVcopy(2*nentUJK, entUJK, entUJ + 2*first*nJ) ;
}
} else if ( SUBMTX_IS_SPARSE_COLUMNS(mtxUJ) ) {
SubMtx_sparseColumnsInfo(mtxUJK, &ncolUJK, &nentUJK,
&sizesUJK, &indicesUJK, &entUJK) ;
IVcopy(ncolUJK, sizesUJK, sizesUJ + first) ;
IVcopy(nentUJK, indicesUJK, indicesUJ + offset) ;
if ( FRONTMTX_IS_REAL(frontmtx) ) {
DVcopy(nentUJK, entUJK, entUJ + offset) ;
} else if ( FRONTMTX_IS_COMPLEX(frontmtx) ) {
DVcopy(2*nentUJK, entUJK, entUJ + 2*offset) ;
}
count = 0 ;
offset += nentUJK ;
}
/*
-------------------------------------
initialize the row and column indices
-------------------------------------
*/
if ( msglvl > 2 ) {
fprintf(msgFile, "\n setting row and column indices");
fflush(msgFile) ;
}
SubMtx_rowIndices(mtxUJK, &nrowUJK, &rowindUJK) ;
IVramp(nJ, rowindUJK, 0, 1) ;
SubMtx_columnIndices(mtxUJK, &ncolUJK, &colindUJK) ;
for ( ii = 0, jj = first ; ii < ncolUJK ; ii++, jj++ ) {
colindUJK[ii] = locmap[colindUJ[jj]] ;
}
/*
----------------------------------
insert U_{J,K} into the hash table
----------------------------------
*/
if ( msglvl > 2 ) {
fprintf(msgFile,
"\n\n ## inserting U(%d,%d) ", J, K) ;
SubMtx_writeForHumanEye(mtxUJK, msgFile) ;
fflush(msgFile) ;
}
I2Ohash_insert(upperhash, J, K, (void *) mtxUJK) ;
/*
-----------------------------------
we jump to here if there were no
entries to be stored in the matrix.
-----------------------------------
*/
no_entries :
/*
----------------------------------------------------
reset first and K to new first location and front id
----------------------------------------------------
*/
first = jcol ;
if ( jcol < ncolUJ ) {
K = colmap[colindUJ[jcol]] ;
}
}
if ( jcol < ncolUJ && SUBMTX_IS_SPARSE_COLUMNS(mtxUJ) ) {
count += sizesUJ[jcol] ;
}
}
/*
--------------------------------------------
give U_{J,bnd{J}} back to the matrix manager
--------------------------------------------
*/
SubMtxManager_releaseObject(manager, mtxUJ) ;
}
}
}
/*
------------------------
free the working storage
------------------------
*/
IVfree(colmap) ;
IVfree(locmap) ;
return ; }
/*
----------------------------------------------------
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 ; }
