/* BKPfactor -- Bunch-Kaufman-Parlett factorisation of A in-situ
-- A is factored into the form P'AP = MDM' where
P is a permutation matrix, M lower triangular and D is block
diagonal with blocks of size 1 or 2
-- P is stored in pivot; blocks[i]==i iff D[i][i] is a block */
extern MAT *BKPfactor(MAT *A, PERM *pivot, PERM *blocks)
{
int i, j, k, n, onebyone, r;
Real **A_me, aii, aip1, aip1i, lambda, sigma, tmp;
Real det, s, t;
if ( ! A || ! pivot || ! blocks )
error(E_NULL,"BKPfactor");
if ( A->m != A->n )
error(E_SQUARE,"BKPfactor");
if ( A->m != pivot->size || pivot->size != blocks->size )
error(E_SIZES,"BKPfactor");
n = A->n;
A_me = A->me;
px_ident(pivot); px_ident(blocks);
for ( i = 0; i < n; i = onebyone ? i+1 : i+2 )
{
/* printf("# Stage: %d\n",i); */
aii = fabs(m_entry(A,i,i));
lambda = 0.0; r = (i+1 < n) ? i+1 : i;
for ( k = i+1; k < n; k++ )
{
tmp = fabs(m_entry(A,i,k));
if ( tmp >= lambda )
{
lambda = tmp;
r = k;
}
}
/* printf("# lambda = %g, r = %d\n", lambda, r); */
/* printf("# |A[%d][%d]| = %g\n",r,r,fabs(m_entry(A,r,r))); */
/* determine if 1x1 or 2x2 block, and do pivoting if needed */
if ( aii >= alpha*lambda )
{
onebyone = TRUE;
goto dopivot;
}
/* compute sigma */
sigma = 0.0;
for ( k = i; k < n; k++ )
{
if ( k == r )
continue;
tmp = ( k > r ) ? fabs(m_entry(A,r,k)) :
fabs(m_entry(A,k,r));
if ( tmp > sigma )
sigma = tmp;
}
if ( aii*sigma >= alpha*sqr(lambda) )
onebyone = TRUE;
else if ( fabs(m_entry(A,r,r)) >= alpha*sigma )
{
/* printf("# Swapping rows/cols %d and %d\n",i,r); */
interchange(A,i,r);
px_transp(pivot,i,r);
onebyone = TRUE;
}
else
{
/* printf("# Swapping rows/cols %d and %d\n",i+1,r); */
interchange(A,i+1,r);
px_transp(pivot,i+1,r);
px_transp(blocks,i,i+1);
onebyone = FALSE;
}
/* printf("onebyone = %s\n",btos(onebyone)); */
/* printf("# Matrix so far (@checkpoint A) =\n"); */
/* m_output(A); */
/* printf("# pivot =\n"); px_output(pivot); */
/* printf("# blocks =\n"); px_output(blocks); */
dopivot:
if ( onebyone )
{ /* do one by one block */
if ( m_entry(A,i,i) != 0.0 )
{
aii = m_entry(A,i,i);
for ( j = i+1; j < n; j++ )
{
tmp = m_entry(A,i,j)/aii;
for ( k = j; k < n; k++ )
m_sub_val(A,j,k,tmp*m_entry(A,i,k));
m_set_val(A,i,j,tmp);
}
}
}
else /* onebyone == FALSE */
{ /* do two by two block */
det = m_entry(A,i,i)*m_entry(A,i+1,i+1)-sqr(m_entry(A,i,i+1));
/* Must have det < 0 */
/* printf("# det = %g\n",det); */
aip1i = m_entry(A,i,i+1)/det;
aii = m_entry(A,i,i)/det;
aip1 = m_entry(A,i+1,i+1)/det;
for ( j = i+2; j < n; j++ )
{
s = - aip1i*m_entry(A,i+1,j) + aip1*m_entry(A,i,j);
t = - aip1i*m_entry(A,i,j) + aii*m_entry(A,i+1,j);
for ( k = j; k < n; k++ )
m_sub_val(A,j,k,m_entry(A,i,k)*s + m_entry(A,i+1,k)*t);
m_set_val(A,i,j,s);
m_set_val(A,i+1,j,t);
}
}
/* printf("# Matrix so far (@checkpoint B) =\n"); */
/* m_output(A); */
/* printf("# pivot =\n"); px_output(pivot); */
/* printf("# blocks =\n"); px_output(blocks); */
}
/* set lower triangular half */
for ( i = 0; i < A->m; i++ )
for ( j = 0; j < i; j++ )
m_set_val(A,i,j,m_entry(A,j,i));
return A;
}
/* v_sort -- sorts vector x, and generates permutation that gives the order
of the components; x = [1.3, 3.7, 0.5] -> [0.5, 1.3, 3.7] and
the permutation is order = [2, 0, 1].
-- if order is NULL on entry then it is ignored
-- the sorted vector x is returned */
VEC *v_sort(VEC *x, PERM *order)
{
Real *x_ve, tmp, v;
/* int *order_pe; */
int dim, i, j, l, r, tmp_i;
int stack[MAX_STACK], sp;
if ( ! x )
error(E_NULL,"v_sort");
if ( order != PNULL && order->size != x->dim )
order = px_resize(order, x->dim);
x_ve = x->ve;
dim = x->dim;
if ( order != PNULL )
px_ident(order);
if ( dim <= 1 )
return x;
/* using quicksort algorithm in Sedgewick,
"Algorithms in C", Ch. 9, pp. 118--122 (1990) */
sp = 0;
l = 0; r = dim-1;
/* v = x_ve[0]; valeur inutilisee ET v n'est pas statique */
for ( ; ; )
{
while ( r > l )
{
/* "i = partition(x_ve,l,r);" */
v = x_ve[r];
i = l-1;
j = r;
for ( ; ; )
{
while ( x_ve[++i] < v )
;
while ( x_ve[--j] > v )
;
if ( i >= j ) break;
tmp = x_ve[i];
x_ve[i] = x_ve[j];
x_ve[j] = tmp;
if ( order != PNULL )
{
tmp_i = order->pe[i];
order->pe[i] = order->pe[j];
order->pe[j] = tmp_i;
}
}
tmp = x_ve[i];
x_ve[i] = x_ve[r];
x_ve[r] = tmp;
if ( order != PNULL )
{
tmp_i = order->pe[i];
order->pe[i] = order->pe[r];
order->pe[r] = tmp_i;
}
if ( i-l > r-i )
{ stack[sp++] = l; stack[sp++] = i-1; l = i+1; }
else
{ stack[sp++] = i+1; stack[sp++] = r; r = i-1; }
}
/* recursion elimination */
if ( sp == 0 )
break;
r = stack[--sp];
l = stack[--sp];
}
return x;
}
SPMAT *spLUfactor(SPMAT *A, PERM *px, double alpha)
#endif
{
int i, best_i, k, idx, len, best_len, m, n;
SPROW *r, *r_piv, tmp_row;
STATIC SPROW *merge = (SPROW *)NULL;
Real max_val, tmp;
STATIC VEC *col_vals=VNULL;
if ( ! A || ! px )
error(E_NULL,"spLUfctr");
if ( alpha <= 0.0 || alpha > 1.0 )
error(E_RANGE,"alpha in spLUfctr");
if ( px->size <= A->m )
px = px_resize(px,A->m);
px_ident(px);
col_vals = v_resize(col_vals,A->m);
MEM_STAT_REG(col_vals,TYPE_VEC);
m = A->m; n = A->n;
if ( ! A->flag_col )
sp_col_access(A);
if ( ! A->flag_diag )
sp_diag_access(A);
A->flag_col = A->flag_diag = FALSE;
if ( ! merge ) {
merge = sprow_get(20);
MEM_STAT_REG(merge,TYPE_SPROW);
}
for ( k = 0; k < n; k++ )
{
/* find pivot row/element for partial pivoting */
/* get first row with a non-zero entry in the k-th column */
max_val = 0.0;
for ( i = k; i < m; i++ )
{
r = &(A->row[i]);
idx = sprow_idx(r,k);
if ( idx < 0 )
tmp = 0.0;
else
tmp = r->elt[idx].val;
if ( fabs(tmp) > max_val )
max_val = fabs(tmp);
col_vals->ve[i] = tmp;
}
if ( max_val == 0.0 )
continue;
best_len = n+1; /* only if no possibilities */
best_i = -1;
for ( i = k; i < m; i++ )
{
tmp = fabs(col_vals->ve[i]);
if ( tmp == 0.0 )
continue;
if ( tmp >= alpha*max_val )
{
r = &(A->row[i]);
idx = sprow_idx(r,k);
len = (r->len) - idx;
if ( len < best_len )
{
best_len = len;
best_i = i;
}
}
}
/* swap row #best_i with row #k */
MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW));
MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW));
MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW));
/* swap col_vals entries */
tmp = col_vals->ve[best_i];
col_vals->ve[best_i] = col_vals->ve[k];
col_vals->ve[k] = tmp;
px_transp(px,k,best_i);
r_piv = &(A->row[k]);
for ( i = k+1; i < n; i++ )
{
/* compute and set multiplier */
tmp = col_vals->ve[i]/col_vals->ve[k];
if ( tmp != 0.0 )
sp_set_val(A,i,k,tmp);
else
continue;
/* perform row operations */
merge->len = 0;
r = &(A->row[i]);
sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW);
idx = sprow_idx(r,k+1);
if ( idx < 0 )
idx = -(idx+2);
/* see if r needs expanding */
if ( r->maxlen < idx + merge->len )
sprow_xpd(r,idx+merge->len,TYPE_SPMAT);
r->len = idx+merge->len;
MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]),
merge->len*sizeof(row_elt));
}
}
#ifdef THREADSAFE
sprow_free(merge); V_FREE(col_vals);
#endif
return A;
}
