static void check_error(SCF *scf, const char *func)
{ int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int *p = scf->p;
double *c = scf->c;
int i, j, k;
double d, dmax = 0.0, s, t;
xassert(c != NULL);
for (i = 1; i <= n; i++)
{ for (j = 1; j <= n; j++)
{ /* compute element (i,j) of product F * C */
s = 0.0;
for (k = 1; k <= n; k++)
s += f[f_loc(scf, i, k)] * c[f_loc(scf, k, j)];
/* compute element (i,j) of product U * P */
k = p[j];
t = (i <= k ? u[u_loc(scf, i, k)] : 0.0);
/* compute the maximal relative error */
d = fabs(s - t) / (1.0 + fabs(t));
if (dmax < d) dmax = d;
}
}
if (dmax > 1e-8)
xprintf("%s: dmax = %g; relative error too large\n", func,
dmax);
return;
}
static void bg_transform(SCF *scf, int k, double un[])
{ int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int j, k1, kj, kk, n1, nj;
double t;
xassert(1 <= k && k <= n);
/* main elimination loop */
for (k = k; k < n; k++)
{ /* determine location of U[k,k] */
kk = u_loc(scf, k, k);
/* determine location of F[k,1] */
k1 = f_loc(scf, k, 1);
/* determine location of F[n,1] */
n1 = f_loc(scf, n, 1);
/* if |U[k,k]| < |U[n,k]|, interchange k-th and n-th rows to
provide |U[k,k]| >= |U[n,k]| */
if (fabs(u[kk]) < fabs(un[k]))
{ /* interchange k-th and n-th rows of matrix U */
for (j = k, kj = kk; j <= n; j++, kj++)
t = u[kj], u[kj] = un[j], un[j] = t;
/* interchange k-th and n-th rows of matrix F to keep the
main equality F * C = U * P */
for (j = 1, kj = k1, nj = n1; j <= n; j++, kj++, nj++)
t = f[kj], f[kj] = f[nj], f[nj] = t;
}
/* now |U[k,k]| >= |U[n,k]| */
/* if U[k,k] is too small in the magnitude, replace U[k,k] and
U[n,k] by exact zero */
if (fabs(u[kk]) < eps) u[kk] = un[k] = 0.0;
/* if U[n,k] is already zero, elimination is not needed */
if (un[k] == 0.0) continue;
/* compute gaussian multiplier t = U[n,k] / U[k,k] */
t = un[k] / u[kk];
/* apply gaussian elimination to nullify U[n,k] */
/* (n-th row of U) := (n-th row of U) - t * (k-th row of U) */
for (j = k+1, kj = kk+1; j <= n; j++, kj++)
un[j] -= t * u[kj];
/* (n-th row of F) := (n-th row of F) - t * (k-th row of F)
to keep the main equality F * C = U * P */
for (j = 1, kj = k1, nj = n1; j <= n; j++, kj++, nj++)
f[nj] -= t * f[kj];
}
/* if U[n,n] is too small in the magnitude, replace it by exact
zero */
if (fabs(un[n]) < eps) un[n] = 0.0;
/* store U[n,n] in a proper location */
u[u_loc(scf, n, n)] = un[n];
return;
}
void VectorFEBoundaryTangentLFIntegrator::AssembleRHSElementVect(
const FiniteElement &el, ElementTransformation &Tr, Vector &elvect)
{
int dof = el.GetDof();
DenseMatrix vshape(dof, 2);
Vector f_loc(3);
Vector f_hat(2);
elvect.SetSize(dof);
elvect = 0.0;
const IntegrationRule *ir = IntRule;
if (ir == NULL)
{
int intorder = 2*el.GetOrder(); // <----------
ir = &IntRules.Get(el.GetGeomType(), intorder);
}
for (int i = 0; i < ir->GetNPoints(); i++)
{
const IntegrationPoint &ip = ir->IntPoint(i);
Tr.SetIntPoint(&ip);
f.Eval(f_loc, Tr, ip);
Tr.Jacobian().MultTranspose(f_loc, f_hat);
el.CalcVShape(ip, vshape);
Swap<double>(f_hat(0), f_hat(1));
f_hat(0) = -f_hat(0);
f_hat *= ip.weight;
vshape.AddMult(f_hat, elvect);
}
}
static void tsolve(SCF *scf, double x[])
{ int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int *p = scf->p;
double *y = scf->w;
int i, j, ij;
double t;
/* y := P * b */
for (i = 1; i <= n; i++) y[i] = x[p[i]];
/* y := inv(U') * y */
for (i = 1; i <= n; i++)
{ /* compute y[i] */
ij = u_loc(scf, i, i);
t = (y[i] /= u[ij]);
/* substitute y[i] in other equations */
for (j = i+1, ij++; j <= n; j++, ij++)
y[j] -= u[ij] * t;
}
/* x := F' * y (computed as linear combination of rows of F) */
for (j = 1; j <= n; j++) x[j] = 0.0;
for (i = 1; i <= n; i++)
{ t = y[i]; /* coefficient of linear combination */
for (j = 1, ij = f_loc(scf, i, 1); j <= n; j++, ij++)
x[j] += f[ij] * t;
}
return;
}
static void solve(SCF *scf, double x[])
{ int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int *p = scf->p;
double *y = scf->w;
int i, j, ij;
double t;
/* y := F * b */
for (i = 1; i <= n; i++)
{ /* y[i] = (i-th row of F) * b */
t = 0.0;
for (j = 1, ij = f_loc(scf, i, 1); j <= n; j++, ij++)
t += f[ij] * x[j];
y[i] = t;
}
/* y := inv(U) * y */
for (i = n; i >= 1; i--)
{ t = y[i];
for (j = n, ij = u_loc(scf, i, n); j > i; j--, ij--)
t -= u[ij] * y[j];
y[i] = t / u[ij];
}
/* x := P' * y */
for (i = 1; i <= n; i++) x[p[i]] = y[i];
return;
}
static void gr_transform(SCF *scf, int k, double un[])
{ int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int j, k1, kj, kk, n1, nj;
double c, s;
xassert(1 <= k && k <= n);
/* main elimination loop */
for (k = k; k < n; k++)
{ /* determine location of U[k,k] */
kk = u_loc(scf, k, k);
/* determine location of F[k,1] */
k1 = f_loc(scf, k, 1);
/* determine location of F[n,1] */
n1 = f_loc(scf, n, 1);
/* if both U[k,k] and U[n,k] are too small in the magnitude,
replace them by exact zero */
if (fabs(u[kk]) < eps && fabs(un[k]) < eps)
u[kk] = un[k] = 0.0;
/* if U[n,k] is already zero, elimination is not needed */
if (un[k] == 0.0) continue;
/* compute the parameters of Givens plane rotation */
givens(u[kk], un[k], &c, &s);
/* apply Givens rotation to k-th and n-th rows of matrix U */
for (j = k, kj = kk; j <= n; j++, kj++)
{ double ukj = u[kj], unj = un[j];
u[kj] = c * ukj - s * unj;
un[j] = s * ukj + c * unj;
}
/* apply Givens rotation to k-th and n-th rows of matrix F
to keep the main equality F * C = U * P */
for (j = 1, kj = k1, nj = n1; j <= n; j++, kj++, nj++)
{ double fkj = f[kj], fnj = f[nj];
f[kj] = c * fkj - s * fnj;
f[nj] = s * fkj + c * fnj;
}
}
/* if U[n,n] is too small in the magnitude, replace it by exact
zero */
if (fabs(un[n]) < eps) un[n] = 0.0;
/* store U[n,n] in a proper location */
u[u_loc(scf, n, n)] = un[n];
return;
}
int scf_update_exp(SCF *scf, const double x[], const double y[],
double z)
{ int n_max = scf->n_max;
int n = scf->n;
double *f = scf->f;
double *u = scf->u;
int *p = scf->p;
#if _GLPSCF_DEBUG
double *c = scf->c;
#endif
double *un = scf->w;
int i, ij, in, j, k, nj, ret = 0;
double t;
/* check if the factorization can be expanded */
if (n == n_max)
{ /* there is not enough room */
ret = SCF_ELIMIT;
goto done;
}
/* increase the order of the factorization */
scf->n = ++n;
/* fill new zero column of matrix F */
for (i = 1, in = f_loc(scf, i, n); i < n; i++, in += n_max)
f[in] = 0.0;
/* fill new zero row of matrix F */
for (j = 1, nj = f_loc(scf, n, j); j < n; j++, nj++)
f[nj] = 0.0;
/* fill new unity diagonal element of matrix F */
f[f_loc(scf, n, n)] = 1.0;
/* compute new column of matrix U, which is (old F) * x */
for (i = 1; i < n; i++)
{ /* u[i,n] := (i-th row of old F) * x */
t = 0.0;
for (j = 1, ij = f_loc(scf, i, 1); j < n; j++, ij++)
t += f[ij] * x[j];
u[u_loc(scf, i, n)] = t;
}
/* compute new (spiked) row of matrix U, which is (old P) * y */
for (j = 1; j < n; j++) un[j] = y[p[j]];
/* store new diagonal element of matrix U, which is z */
un[n] = z;
/* expand matrix P */
p[n] = n;
#if _GLPSCF_DEBUG
/* expand matrix C */
/* fill its new column, which is x */
for (i = 1, in = f_loc(scf, i, n); i < n; i++, in += n_max)
c[in] = x[i];
/* fill its new row, which is y */
for (j = 1, nj = f_loc(scf, n, j); j < n; j++, nj++)
c[nj] = y[j];
/* fill its new diagonal element, which is z */
c[f_loc(scf, n, n)] = z;
#endif
/* restore upper triangular structure of matrix U */
for (k = 1; k < n; k++)
if (un[k] != 0.0) break;
transform(scf, k, un);
/* estimate the rank of matrices C and U */
scf->rank = estimate_rank(scf);
if (scf->rank != n) ret = SCF_ESING;
#if _GLPSCF_DEBUG
/* check that the factorization is accurate enough */
check_error(scf, "scf_update_exp");
#endif
done: return ret;
}
