void AZ_calc_blk_diag_inv(double *val, int *indx, int *bindx, int *rpntr,
int *cpntr, int *bpntr, double *d_inv, int *d_indx,
int *d_bindx, int *d_rpntr, int *d_bpntr,
int *data_org)
/*******************************************************************************
Routine to calculate the inverse of the block-diagonal portion of the sparse
matrix in 'val' and the associated integer pointer vectors. This is used for
scaling and/or preconditioning.
Author: Scott A. Hutchinson, SNL, 1421
=======
Return code: void
============
Parameter list:
===============
val: Array containing the nonzero entries of the matrix (see
Aztec User's Guide).
indx,
bindx,
rpntr,
cpntr,
bpntr: Arrays used for DMSR and DVBR sparse matrix storage (see
file Aztec User's Guide).
d_inv: Vector containing the inverses of the diagonal blocks.
d_indx: The 'indx' array corresponding to the inverse-block
diagonals.
d_bindx: The 'bindx' array corresponding to the inverse-block
diagonals.
d_rpntr: The 'rpntr' array corresponding to the inverse-block
diagonals.
d_bpntr: The 'bpntr' array corresponding to the inverse-block
diagonals.
data_org: Array containing information on the distribution of the
matrix to this processor as well as communication parameters
(see Aztec User's Guide).
*******************************************************************************/
{
/* local variables */
register int i, j, iblk_row, jblk, icount = 0, iblk_count = 0, ival;
int m1, n1, itemp;
int m;
int bpoff, idoff;
int *ipiv, info;
double *work;
char *yo = "AZ_calc_blk_diag_inv: ";
/**************************** execution begins ******************************/
m = data_org[AZ_N_int_blk] + data_org[AZ_N_bord_blk];
if (m == 0) return;
/* allocate vectors for lapack routines */
ipiv = (int *) AZ_allocate(rpntr[m]*sizeof(int));
work = (double *) AZ_allocate(rpntr[m]*sizeof(double));
if (work == NULL) AZ_perror("Not enough space for Block Jacobi\n");
/* offset of the first block */
bpoff = *bpntr;
idoff = *indx;
/* loop over block rows */
for (iblk_row = 0; iblk_row < m; iblk_row++) {
/* number of rows in the current row block */
m1 = rpntr[iblk_row+1] - rpntr[iblk_row];
/* starting index of current row block */
ival = indx[bpntr[iblk_row] - bpoff] - idoff;
/* loop over column block numbers, looking for the diagonal block */
for (j = bpntr[iblk_row] - bpoff; j < bpntr[iblk_row+1] - bpoff; j++) {
jblk = bindx[j];
/* determine the number of columns in this block */
n1 = cpntr[jblk+1] - cpntr[jblk];
itemp = m1*n1;
if (jblk == iblk_row) { /* diagonal block */
/* error check */
if (n1 != m1) {
(void) AZ_printf_err( "%sERROR: diagonal blocks are not square\n.",
yo);
exit(-1);
}
else {
/* fill the vectors */
d_indx[iblk_count] = icount;
d_rpntr[iblk_count] = rpntr[iblk_row];
d_bpntr[iblk_count] = iblk_row;
d_bindx[iblk_count] = iblk_row;
for (i = 0; i < itemp; i++) d_inv[icount++] = val[ival + i];
/* invert the dense matrix */
DGETRF_F77(&m1, &m1, &d_inv[d_indx[iblk_count]], &m1, ipiv, &info);
if (info < 0) {
(void) AZ_printf_err( "%sERROR: argument %d is illegal.\n", yo,
-info);
exit(-1);
}
else if (info > 0) {
(void) AZ_printf_err( "%sERROR: the factorization has produced a "
"singular U with U[%d][%d] being exactly zero.\n",
yo, info, info);
exit(-1);
}
DGETRI_F77(&m1, &d_inv[d_indx[iblk_count]], &m1, ipiv, work, &m1, &info);
if (info < 0) {
(void) AZ_printf_err( "%sERROR: argument %d is illegal.\n", yo,
-info);
exit(-1);
}
else if (info > 0) {
(void) AZ_printf_err( "%sERROR: U[%d][%d] is exactly zero;\n", yo,
info, info);
(void) AZ_printf_err( "the matrix is singular and its inverse "
"could not be computed.\n");
exit(-1);
}
iblk_count++;
}
break;
}
else
ival += itemp;
}
}
d_indx[iblk_count] = icount;
d_rpntr[iblk_count] = rpntr[iblk_row];
d_bpntr[iblk_count] = iblk_row;
AZ_free((void *) ipiv);
AZ_free((void *) work);
} /* AZ_calc_blk_diag_inv */
//=============================================================================
void Epetra_LAPACK::GETRI( const int N, double * A, const int LDA, int * IPIV,
double * WORK, const int * LWORK, int * INFO) const {
DGETRI_F77(&N, A, &LDA, IPIV, WORK, LWORK, INFO);
}
