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);
}
puniform
new_uniform(pclusterbasis rb, pclusterbasis cb)
{
puniform u;
u = allocmem(sizeof(uniform));
u->rb = u->cb = 0;
u->rnext = u->rprev = u->cnext = u->cprev = 0;
ref_row_uniform(u, rb);
ref_col_uniform(u, cb);
init_amatrix(&u->S, rb->k, cb->k);
return u;
}
pclusteroperator
init_leaf_clusteroperator(pclusteroperator co, pccluster t)
{
assert(co != NULL);
co->t = t;
co->krow = 0;
co->kcol = 0;
init_amatrix(&co->C, 0, 0);
co->sons = 0;
co->son = NULL;
co->refs = 0;
#ifdef USE_OPENMP
#pragma omp atomic
#endif
active_clusteroperator++;
return co;
}
void
add_projected_uniform(pcuniform u,
pcclusteroperator ro, pcclusteroperator co,
puniform unew)
{
amatrix tmp;
pamatrix XS;
if (u->rb == unew->rb) {
if (u->cb == unew->cb)
add_amatrix(1.0, false, &u->S, &unew->S);
else {
assert(co->krow == unew->cb->k);
assert(co->kcol == u->cb->k);
addmul_amatrix(1.0, false, &u->S, true, &co->C, &unew->S);
}
}
else {
if (u->cb == unew->cb) {
assert(ro->krow == unew->rb->k);
assert(ro->kcol == u->rb->k);
addmul_amatrix(1.0, false, &ro->C, false, &u->S, &unew->S);
}
else {
assert(ro->krow == unew->rb->k);
assert(ro->kcol == u->rb->k);
assert(co->krow == unew->cb->k);
assert(co->kcol == u->cb->k);
XS = init_amatrix(&tmp, unew->rb->k, u->cb->k);
clear_amatrix(XS);
addmul_amatrix(1.0, false, &ro->C, false, &u->S, XS);
addmul_amatrix(1.0, false, XS, true, &co->C, &unew->S);
uninit_amatrix(XS);
}
}
}
static real
compareweights(pcclusteroperator co1, pcclusteroperator co2, uint level)
{
amatrix tmp;
pamatrix D;
real norm, error, error1;
uint k;
uint i;
k = co1->kcol;
assert(k == co2->kcol);
D = init_amatrix(&tmp, k, k);
clear_amatrix(D);
addmul_amatrix(1.0, true, &co1->C, false, &co1->C, D);
norm = norm2_amatrix(D);
addmul_amatrix(-1.0, true, &co2->C, false, &co2->C, D);
error = norm2_amatrix(D);
uninit_amatrix(D);
if (norm > 0.0)
error /= norm;
if (co1->sons != co2->sons)
printf("Tree mismatch");
else
for (i = 0; i < co1->sons; i++) {
error1 = compareweights(co1->son[i], co2->son[i], level + 1);
if (error1 > error)
error = error1;
}
return error;
}
static void
check_triangularaddmul(bool alower, bool atrans, bool blower, bool btrans)
{
pamatrix a, b, at, bt, x;
amatrix atmp, btmp, attmp, bttmp, xtmp;
real error;
uint dim1, dim2, dim3;
dim1 = 100;
dim2 = 80;
dim3 = 90;
a =
(atrans ? init_amatrix(&atmp, dim2, dim1) :
init_amatrix(&atmp, dim1, dim2));
random_amatrix(a);
b =
(btrans ? init_amatrix(&btmp, dim3, dim2) :
init_amatrix(&btmp, dim2, dim3));
random_amatrix(b);
at = init_amatrix(&attmp, a->rows, a->cols);
if (alower)
copy_lower_amatrix(a, false, at);
else
copy_upper_amatrix(a, false, at);
bt = init_amatrix(&bttmp, b->rows, b->cols);
if (blower)
copy_lower_amatrix(b, false, bt);
else
copy_upper_amatrix(b, false, bt);
x = init_amatrix(&xtmp, dim1, dim3);
clear_amatrix(x);
triangularaddmul_amatrix(1.0, alower, atrans, a, blower, btrans, b, x);
addmul_amatrix(-1.0, atrans, at, btrans, bt, x);
error = norm2_amatrix(x);
(void)
printf
("Checking triangularaddmul(alower=%s, atrans=%s, blower=%s, btrans=%s)\n"
" Accuracy %g, %sokay\n", (alower ? "tr" : "fl"),
(atrans ? "tr" : "fl"), (blower ? "tr" : "fl"), (btrans ? "tr" : "fl"),
error, (error < tolerance ? "" : " NOT "));
if (error >= tolerance)
problems++;
uninit_amatrix(x);
uninit_amatrix(bt);
uninit_amatrix(at);
uninit_amatrix(b);
uninit_amatrix(a);
dim1 = 70;
dim2 = 80;
dim3 = 90;
a =
(atrans ? init_amatrix(&atmp, dim2, dim1) :
init_amatrix(&atmp, dim1, dim2));
random_amatrix(a);
b =
(btrans ? init_amatrix(&btmp, dim3, dim2) :
init_amatrix(&btmp, dim2, dim3));
random_amatrix(b);
at = init_amatrix(&attmp, a->rows, a->cols);
if (alower)
copy_lower_amatrix(a, false, at);
else
copy_upper_amatrix(a, false, at);
bt = init_amatrix(&bttmp, b->rows, b->cols);
if (blower)
copy_lower_amatrix(b, false, bt);
else
copy_upper_amatrix(b, false, bt);
x = init_amatrix(&xtmp, dim1, dim3);
clear_amatrix(x);
triangularaddmul_amatrix(1.0, alower, atrans, a, blower, btrans, b, x);
addmul_amatrix(-1.0, atrans, at, btrans, bt, x);
error = norm2_amatrix(x);
(void)
printf
("Checking triangularaddmul(alower=%s, atrans=%s, blower=%s, btrans=%s)\n"
" Accuracy %g, %sokay\n", (alower ? "tr" : "fl"),
(atrans ? "tr" : "fl"), (blower ? "tr" : "fl"), (btrans ? "tr" : "fl"),
error, (error < tolerance ? "" : " NOT "));
if (error >= tolerance)
problems++;
uninit_amatrix(x);
uninit_amatrix(bt);
uninit_amatrix(at);
uninit_amatrix(b);
uninit_amatrix(a);
}
static void
check_triangularsolve(bool lower, bool unit, bool atrans,
pcamatrix a, bool xtrans)
{
uint n = a->rows;
amatrix xtmp, btmp;
pamatrix x, b;
avector xvtmp, bvtmp;
pavector xv, bv;
real error;
assert(n == a->cols);
/*
* amatrix
*/
x = init_amatrix(&xtmp, n, n);
random_amatrix(x);
b = init_zero_amatrix(&btmp, n, n);
if (xtrans)
addmul_amatrix(1.0, false, x, !atrans, a, b);
else
addmul_amatrix(1.0, atrans, a, false, x, b);
triangularsolve_amatrix(lower, unit, atrans, a, xtrans, b);
add_amatrix(-1.0, false, x, b);
error = norm2_amatrix(b) / norm2_amatrix(x);
(void) printf("Checking amatrix triangularsolve\n"
" (lower=%s, unit=%s, atrans=%s, xtrans=%s)\n"
" Accuracy %g, %sokay\n", (lower ? "tr" : "fl"),
(unit ? "tr" : "fl"), (atrans ? "tr" : "fl"),
(xtrans ? "tr" : "fl"), error,
(IS_IN_RANGE(0.0, error, 1.0e-14) ? "" : " NOT "));
if (!IS_IN_RANGE(0.0, error, 1.0e-14))
problems++;
copy_amatrix(false, x, b);
triangulareval_amatrix(lower, unit, atrans, a, xtrans, b);
triangularsolve_amatrix(lower, unit, atrans, a, xtrans, b);
add_amatrix(-1.0, false, x, b);
error = norm2_amatrix(b) / norm2_amatrix(x);
(void) printf("Checking amatrix triangulareval/triangularsolve\n"
" (lower=%s, unit=%s, atrans=%s, xtrans=%s):\n"
" Accuracy %g, %sokay\n", (lower ? "tr" : "fl"),
(unit ? "tr" : "fl"), (atrans ? "tr" : "fl"),
(xtrans ? "tr" : "fl"), error,
(IS_IN_RANGE(0.0, error, 1.0e-14) ? "" : " NOT "));
if (!IS_IN_RANGE(0.0, error, 1.0e-14))
problems++;
/*
* avector
*/
xv = init_avector(&xvtmp, n);
random_avector(xv);
bv = init_avector(&bvtmp, n);
clear_avector(bv);
if (atrans) {
addevaltrans_amatrix_avector(1.0, a, xv, bv);
}
else {
addeval_amatrix_avector(1.0, a, xv, bv);
}
triangularsolve_amatrix_avector(lower, unit, atrans, a, bv);
add_avector(-1.0, xv, bv);
error = norm2_avector(bv) / norm2_avector(xv);
(void) printf("Checking avector triangularsolve\n"
" (lower=%s, unit=%s, atrans=%s)\n"
" Accuracy %g, %sokay\n", (lower ? "tr" : "fl"),
(unit ? "tr" : "fl"), (atrans ? "tr" : "fl"), error,
(IS_IN_RANGE(0.0, error, 1.0e-14) ? "" : " NOT "));
if (!IS_IN_RANGE(0.0, error, 1.0e-14))
problems++;
copy_avector(xv, bv);
triangulareval_amatrix_avector(lower, unit, atrans, a, bv);
triangularsolve_amatrix_avector(lower, unit, atrans, a, bv);
add_avector(-1.0, xv, bv);
error = norm2_avector(bv) / norm2_avector(xv);
(void) printf("Checking avector triangulareval/triangularsolve\n"
" (lower=%s, unit=%s, atrans=%s):\n"
" Accuracy %g, %sokay\n", (lower ? "tr" : "fl"),
(unit ? "tr" : "fl"), (atrans ? "tr" : "fl"), error,
(IS_IN_RANGE(0.0, error, 1.0e-14) ? "" : " NOT "));
if (!IS_IN_RANGE(0.0, error, 1.0e-14))
problems++;
uninit_amatrix(b);
uninit_amatrix(x);
uninit_avector(bv);
uninit_avector(xv);
}
void
project_inplace_uniform(puniform u,
pclusterbasis rb, pcclusteroperator ro,
pclusterbasis cb, pcclusteroperator co)
{
amatrix tmp;
pamatrix X;
if (u->rb == rb) {
if (u->cb == cb) {
/* Nothing to do */
}
else {
assert(co);
assert(co->krow == cb->k);
assert(co->kcol == u->cb->k);
/* Transform coupling matrix */
X = init_amatrix(&tmp, u->rb->k, cb->k);
clear_amatrix(X);
addmul_amatrix(1.0, false, &u->S, true, &co->C, X);
resize_amatrix(&u->S, X->rows, X->cols);
copy_amatrix(false, X, &u->S);
uninit_amatrix(X);
/* Update pointer */
ref_col_uniform(u, cb);
}
}
else {
assert(ro);
assert(ro->krow == rb->k);
assert(ro->kcol == u->rb->k);
if (u->cb == cb) {
/* Transform coupling matrix */
X = init_amatrix(&tmp, rb->k, u->cb->k);
clear_amatrix(X);
addmul_amatrix(1.0, false, &ro->C, false, &u->S, X);
resize_amatrix(&u->S, X->rows, X->cols);
copy_amatrix(false, X, &u->S);
uninit_amatrix(X);
/* Update pointer */
ref_row_uniform(u, rb);
}
else {
assert(co);
assert(co->krow == cb->k);
assert(co->kcol == u->cb->k);
/* Transform coupling matrix for row... */
X = init_amatrix(&tmp, rb->k, u->cb->k);
clear_amatrix(X);
addmul_amatrix(1.0, false, &ro->C, false, &u->S, X);
/* ... and column basis */
resize_amatrix(&u->S, rb->k, cb->k);
clear_amatrix(&u->S);
addmul_amatrix(1.0, false, X, true, &co->C, &u->S);
uninit_amatrix(X);
/* Update pointers */
ref_row_uniform(u, rb);
ref_col_uniform(u, cb);
}
}
}
