void
add_rkmatrix_uniform(pcrkmatrix r, puniform unew)
{
amatrix tmp1, tmp2, tmp3, tmp4;
pamatrix At, Bt, Ac, Bc;
uint k;
assert(r->A.cols == r->B.cols);
k = r->A.cols;
At = init_amatrix(&tmp1, unew->rb->kbranch, k);
compress_clusterbasis_amatrix(unew->rb, &r->A, At);
Bt = init_amatrix(&tmp2, unew->cb->kbranch, k);
compress_clusterbasis_amatrix(unew->cb, &r->B, Bt);
Ac = init_sub_amatrix(&tmp3, At, unew->rb->k, 0, k, 0);
Bc = init_sub_amatrix(&tmp4, Bt, unew->cb->k, 0, k, 0);
addmul_amatrix(1.0, false, Ac, true, Bc, &unew->S);
uninit_amatrix(Bc);
uninit_amatrix(Ac);
uninit_amatrix(Bt);
uninit_amatrix(At);
}
void
basisproduct_clusteroperator(pcclusterbasis cb1, pcclusterbasis cb2,
pclusteroperator pr)
{
pamatrix X, Xt;
amatrix tmp1, tmp2;
uint i;
assert(cb1->t == pr->t);
assert(cb2->t == pr->t);
resize_clusteroperator(pr, cb1->k, cb2->k);
if (pr->sons > 0) {
assert(cb1->sons == pr->sons);
assert(cb2->sons == pr->sons);
for (i = 0; i < pr->sons; i++)
basisproduct_clusteroperator(cb1->son[i], cb2->son[i], pr->son[i]);
clear_amatrix(&pr->C);
for (i = 0; i < pr->sons; i++) {
X = init_amatrix(&tmp1, cb1->son[i]->k, cb2->k);
clear_amatrix(X);
addmul_amatrix(1.0, false, &pr->son[i]->C, false, &cb2->son[i]->E, X);
addmul_amatrix(1.0, true, &cb1->son[i]->E, false, X, &pr->C);
uninit_amatrix(X);
}
}
else {
if (cb1->sons == 0) {
if (cb2->sons == 0) {
clear_amatrix(&pr->C);
addmul_amatrix(1.0, true, &cb1->V, false, &cb2->V, &pr->C);
}
else {
Xt = init_amatrix(&tmp1, cb2->kbranch, cb1->k);
compress_clusterbasis_amatrix(cb2, &cb1->V, Xt);
X = init_sub_amatrix(&tmp2, Xt, cb2->k, 0, cb1->k, 0);
copy_amatrix(true, X, &pr->C);
uninit_amatrix(X);
uninit_amatrix(Xt);
}
}
else {
assert(cb2->sons == 0); /* Could be generalized */
Xt = init_amatrix(&tmp1, cb1->kbranch, cb2->k);
compress_clusterbasis_amatrix(cb1, &cb2->V, Xt);
X = init_sub_amatrix(&tmp2, Xt, cb1->k, 0, cb2->k, 0);
copy_amatrix(false, X, &pr->C);
uninit_amatrix(X);
uninit_amatrix(Xt);
}
}
}
static void
check_uppereval(bool unit, bool atrans, pcamatrix a, bool xtrans)
{
pamatrix a2, x, b, b2;
amatrix a2tmp, xtmp, btmp;
real error;
a2 = init_amatrix(&a2tmp, a->rows, a->cols);
if (atrans)
copy_lower_amatrix(a, unit, a2);
else
copy_upper_amatrix(a, unit, a2);
x = (atrans ? init_amatrix(&xtmp, a->rows, a->rows) :
init_amatrix(&xtmp, a->cols, a->cols));
random_amatrix(x);
b = (atrans ?
(xtrans ? init_amatrix(&btmp, a->rows, UINT_MAX(a->cols, a->rows)) :
init_amatrix(&btmp, UINT_MAX(a->rows, a->cols), a->rows)) :
(xtrans ? init_amatrix(&btmp, a->cols, UINT_MAX(a->cols, a->rows)) :
init_amatrix(&btmp, UINT_MAX(a->rows, a->cols), a->cols)));
copy_sub_amatrix(false, x, b);
triangulareval_amatrix(atrans, unit, atrans, a, xtrans, b);
if (xtrans)
addmul_amatrix(-1.0, false, x, !atrans, a2, b);
else
addmul_amatrix(-1.0, atrans, a2, false, x, b);
uninit_amatrix(a2);
b2 = (atrans ?
(xtrans ? init_sub_amatrix(&a2tmp, b, b->rows, 0, a->cols, 0) :
init_sub_amatrix(&a2tmp, b, a->cols, 0, b->cols, 0)) :
(xtrans ? init_sub_amatrix(&a2tmp, b, b->rows, 0, a->rows, 0) :
init_sub_amatrix(&a2tmp, b, a->rows, 0, b->cols, 0)));
error = norm2_amatrix(b2) / norm2_amatrix(x);
(void) printf("Checking uppereval(unit=%s, atrans=%s, xtrans=%s)\n"
" Accuracy %g, %sokay\n", (unit ? "tr" : "fl"),
(atrans ? "tr" : "fl"), (xtrans ? "tr" : "fl"), error,
(error < tolerance ? "" : " NOT "));
if (error >= tolerance)
problems++;
uninit_amatrix(b2);
uninit_amatrix(b);
uninit_amatrix(x);
}
void
coarsen_hmatrix(phmatrix G, ptruncmode tm, real eps, bool recursive)
{
uint rsons = G->rsons;
uint csons = G->csons;
phmatrix son;
prkmatrix R;
pamatrix A, B;
amatrix T, S;
uint i, j, leafs, ranksum, rankoffset, rowoffset, coloffset, rank;
size_t sizeold, sizenew;
leafs = 0;
/* recursion */
if (rsons * csons > 0) {
for (j = 0; j < csons; ++j) {
for (i = 0; i < rsons; ++i) {
son = G->son[i + j * rsons];
if (recursive == true) {
coarsen_hmatrix(son, tm, eps, recursive);
}
leafs += son->rsons * son->csons;
}
}
update_hmatrix(G);
}
else {
/* matrix is a leaf -> northing to do */
return;
}
if (leafs > 0) {
/* matrix has sons which are not leafs -> nothing to do */
return;
}
else {
if (G->rc == G->cc) {
return;
}
/* determine ranksum and size of sons */
ranksum = 0;
sizeold = 0;
for (j = 0; j < csons; ++j) {
for (i = 0; i < rsons; ++i) {
son = G->son[i + j * rsons];
if (son->r) {
ranksum += son->r->k;
sizeold += getsize_rkmatrix(son->r);
}
else {
assert(son->f != NULL);
ranksum += son->f->cols;
sizeold += getsize_amatrix(son->f);
}
}
}
/* new rank-k-matrix */
R = new_rkmatrix(G->rc->size, G->cc->size, ranksum);
A = &R->A;
B = &R->B;
clear_amatrix(A);
clear_amatrix(B);
/* copy sons into a big rank-k-matrix */
rankoffset = 0;
coloffset = 0;
for (j = 0; j < csons; ++j) {
rowoffset = 0;
for (i = 0; i < rsons; ++i) {
son = G->son[i + j * rsons];
rank = son->r ? son->r->k : son->f->cols;
init_sub_amatrix(&T, A, son->rc->size, rowoffset, rank, rankoffset);
init_sub_amatrix(&S, B, son->cc->size, coloffset, rank, rankoffset);
if (son->r) {
copy_amatrix(false, &(son->r->A), &T);
copy_amatrix(false, &(son->r->B), &S);
}
else {
copy_amatrix(false, son->f, &T);
identity_amatrix(&S);
}
rankoffset += rank;
rowoffset += son->rc->size;
uninit_amatrix(&T);
uninit_amatrix(&S);
}
coloffset += G->son[j * rsons]->cc->size;
}
/* compression */
trunc_rkmatrix(tm, eps, R);
sizenew = getsize_rkmatrix(R);
/* use new rank-k-matrix or discard */
if (sizenew < sizeold) {
for (j = 0; j < csons; ++j) {
for (i = 0; i < rsons; ++i) {
unref_hmatrix(G->son[i + j * rsons]);
}
}
G->rsons = 0;
G->csons = 0;
freemem(G->son);
G->son = NULL;
G->f = NULL;
G->r = R;
G->desc = 1;
}
else {
del_rkmatrix(R);
}
}
}