void lpf_ftran(LPF *lpf, double x[])
{ int m0 = lpf->m0;
int m = lpf->m;
int n = lpf->n;
int *P_col = lpf->P_col;
int *Q_col = lpf->Q_col;
double *fg = lpf->work1;
double *f = fg;
double *g = fg + m0;
int i, ii;
#if GLPLPF_DEBUG
double *b;
#endif
if (!lpf->valid)
xfault("lpf_ftran: the factorization is not valid\n");
xassert(0 <= m && m <= m0 + n);
#if GLPLPF_DEBUG
/* save the right-hand side vector */
b = xcalloc(1+m, sizeof(double));
for (i = 1; i <= m; i++) b[i] = x[i];
#endif
/* (f g) := inv(P) * (b 0) */
for (i = 1; i <= m0 + n; i++)
fg[i] = ((ii = P_col[i]) <= m ? x[ii] : 0.0);
/* f1 := inv(L0) * f */
#if 0 /* 06/VI-2013 */
luf_f_solve(lpf->luf, 0, f);
#else
luf_f_solve(lpf->lufint->luf, f);
#endif
/* g1 := g - S * f1 */
s_prod(lpf, g, -1.0, f);
/* g2 := inv(C) * g1 */
scf_solve_it(lpf->scf, 0, g);
/* f2 := inv(U0) * (f1 - R * g2) */
r_prod(lpf, f, -1.0, g);
#if 0 /* 06/VI-2013 */
luf_v_solve(lpf->luf, 0, f);
#else
{ double *work = lpf->lufint->sgf->work;
luf_v_solve(lpf->lufint->luf, f, work);
memcpy(&f[1], &work[1], m0 * sizeof(double));
}
#endif
/* (x y) := inv(Q) * (f2 g2) */
for (i = 1; i <= m; i++)
x[i] = fg[Q_col[i]];
#if GLPLPF_DEBUG
/* check relative error in solution */
check_error(lpf, 0, x, b);
xfree(b);
#endif
return;
}
void inv_ftran(INV *inv, double x[], int save)
{ int m = inv->m;
int *pp_row = inv->luf->pp_row;
int *pp_col = inv->luf->pp_col;
double eps_tol = inv->luf->eps_tol;
int *p0_row = inv->p0_row;
int *p0_col = inv->p0_col;
int *cc_ndx = inv->cc_ndx;
double *cc_val = inv->cc_val;
int i, len;
double temp;
if (!inv->valid)
fault("inv_ftran: the factorization is not valid");
/* B = F*H*V, therefore inv(B) = inv(V)*inv(H)*inv(F) */
inv->luf->pp_row = p0_row;
inv->luf->pp_col = p0_col;
luf_f_solve(inv->luf, 0, x);
inv->luf->pp_row = pp_row;
inv->luf->pp_col = pp_col;
inv_h_solve(inv, 0, x);
/* save partially transformed column (if required) */
if (save)
{ len = 0;
for (i = 1; i <= m; i++)
{ temp = x[i];
if (temp == 0.0 || fabs(temp) < eps_tol) continue;
len++;
cc_ndx[len] = i;
cc_val[len] = temp;
}
inv->cc_len = len;
}
luf_v_solve(inv->luf, 0, x);
return;
}
void scf_r0_solve(SCF *scf, int tr, double x[/*1+n0*/])
{ switch (scf->type)
{ case 1:
/* A0 = F0 * V0, so R0 = F0 */
if (!tr)
luf_f_solve(scf->a0.luf, x);
else
luf_ft_solve(scf->a0.luf, x);
break;
case 2:
/* A0 = I * A0, so R0 = I */
break;
default:
xassert(scf != scf);
}
return;
}
void inv_btran(INV *inv, double x[])
{ int *pp_row = inv->luf->pp_row;
int *pp_col = inv->luf->pp_col;
int *p0_row = inv->p0_row;
int *p0_col = inv->p0_col;
/* B = F*H*V, therefore inv(B') = inv(F')*inv(H')*inv(V') */
if (!inv->valid)
fault("inv_btran: the factorization is not valid");
luf_v_solve(inv->luf, 1, x);
inv_h_solve(inv, 1, x);
inv->luf->pp_row = p0_row;
inv->luf->pp_col = p0_col;
luf_f_solve(inv->luf, 1, x);
inv->luf->pp_row = pp_row;
inv->luf->pp_col = pp_col;
return;
}
void fhv_btran(FHV *fhv, double x[])
{ int *pp_row = fhv->luf->pp_row;
int *pp_col = fhv->luf->pp_col;
int *p0_row = fhv->p0_row;
int *p0_col = fhv->p0_col;
if (!fhv->valid)
xfault("fhv_btran: the factorization is not valid\n");
/* B = F*H*V, therefore inv(B') = inv(F')*inv(H')*inv(V') */
luf_v_solve(fhv->luf, 1, x);
fhv_h_solve(fhv, 1, x);
fhv->luf->pp_row = p0_row;
fhv->luf->pp_col = p0_col;
luf_f_solve(fhv->luf, 1, x);
fhv->luf->pp_row = pp_row;
fhv->luf->pp_col = pp_col;
return;
}
void lpf_btran(LPF *lpf, double x[])
{ int m0 = lpf->m0;
int m = lpf->m;
int n = lpf->n;
int *P_row = lpf->P_row;
int *Q_row = lpf->Q_row;
double *fg = lpf->work1;
double *f = fg;
double *g = fg + m0;
int i, ii;
#if _GLPLPF_DEBUG
double *b;
#endif
if (!lpf->valid)
xfault("lpf_btran: the factorization is not valid\n");
xassert(0 <= m && m <= m0 + n);
#if _GLPLPF_DEBUG
/* save the right-hand side vector */
b = xcalloc(1+m, sizeof(double));
for (i = 1; i <= m; i++) b[i] = x[i];
#endif
/* (f g) := Q * (b 0) */
for (i = 1; i <= m0 + n; i++)
fg[i] = ((ii = Q_row[i]) <= m ? x[ii] : 0.0);
/* f1 := inv(U'0) * f */
luf_v_solve(lpf->luf, 1, f);
/* g1 := inv(C') * (g - R' * f1) */
rt_prod(lpf, g, -1.0, f);
scf_solve_it(lpf->scf, 1, g);
/* g2 := g1 */
g = g;
/* f2 := inv(L'0) * (f1 - S' * g2) */
st_prod(lpf, f, -1.0, g);
luf_f_solve(lpf->luf, 1, f);
/* (x y) := P * (f2 g2) */
for (i = 1; i <= m; i++)
x[i] = fg[P_row[i]];
#if _GLPLPF_DEBUG
/* check relative error in solution */
check_error(lpf, 1, x, b);
xfree(b);
#endif
return;
}
int fhv_update_it(FHV *fhv, int j, int len, const int ind[],
const double val[])
{ int m = fhv->m;
LUF *luf = fhv->luf;
int *vr_ptr = luf->vr_ptr;
int *vr_len = luf->vr_len;
int *vr_cap = luf->vr_cap;
double *vr_piv = luf->vr_piv;
int *vc_ptr = luf->vc_ptr;
int *vc_len = luf->vc_len;
int *vc_cap = luf->vc_cap;
int *pp_row = luf->pp_row;
int *pp_col = luf->pp_col;
int *qq_row = luf->qq_row;
int *qq_col = luf->qq_col;
int *sv_ind = luf->sv_ind;
double *sv_val = luf->sv_val;
double *work = luf->work;
double eps_tol = luf->eps_tol;
int *hh_ind = fhv->hh_ind;
int *hh_ptr = fhv->hh_ptr;
int *hh_len = fhv->hh_len;
int *p0_row = fhv->p0_row;
int *p0_col = fhv->p0_col;
int *cc_ind = fhv->cc_ind;
double *cc_val = fhv->cc_val;
double upd_tol = fhv->upd_tol;
int i, i_beg, i_end, i_ptr, j_beg, j_end, j_ptr, k, k1, k2, p, q,
p_beg, p_end, p_ptr, ptr, ret;
double f, temp;
if (!fhv->valid)
xfault("fhv_update_it: the factorization is not valid\n");
if (!(1 <= j && j <= m))
xfault("fhv_update_it: j = %d; column number out of range\n",
j);
/* check if the new factor of matrix H can be created */
if (fhv->hh_nfs == fhv->hh_max)
{ /* maximal number of updates has been reached */
fhv->valid = 0;
ret = FHV_ELIMIT;
goto done;
}
/* convert new j-th column of B to dense format */
for (i = 1; i <= m; i++)
cc_val[i] = 0.0;
for (k = 1; k <= len; k++)
{ i = ind[k];
if (!(1 <= i && i <= m))
xfault("fhv_update_it: ind[%d] = %d; row number out of rang"
"e\n", k, i);
if (cc_val[i] != 0.0)
xfault("fhv_update_it: ind[%d] = %d; duplicate row index no"
"t allowed\n", k, i);
if (val[k] == 0.0)
xfault("fhv_update_it: val[%d] = %g; zero element not allow"
"ed\n", k, val[k]);
cc_val[i] = val[k];
}
/* new j-th column of V := inv(F * H) * (new B[j]) */
fhv->luf->pp_row = p0_row;
fhv->luf->pp_col = p0_col;
luf_f_solve(fhv->luf, 0, cc_val);
fhv->luf->pp_row = pp_row;
fhv->luf->pp_col = pp_col;
fhv_h_solve(fhv, 0, cc_val);
/* convert new j-th column of V to sparse format */
len = 0;
for (i = 1; i <= m; i++)
{ temp = cc_val[i];
if (temp == 0.0 || fabs(temp) < eps_tol) continue;
len++, cc_ind[len] = i, cc_val[len] = temp;
}
/* clear old content of j-th column of matrix V */
j_beg = vc_ptr[j];
j_end = j_beg + vc_len[j] - 1;
for (j_ptr = j_beg; j_ptr <= j_end; j_ptr++)
{ /* get row index of v[i,j] */
i = sv_ind[j_ptr];
/* find v[i,j] in the i-th row */
i_beg = vr_ptr[i];
i_end = i_beg + vr_len[i] - 1;
for (i_ptr = i_beg; sv_ind[i_ptr] != j; i_ptr++) /* nop */;
xassert(i_ptr <= i_end);
/* remove v[i,j] from the i-th row */
sv_ind[i_ptr] = sv_ind[i_end];
sv_val[i_ptr] = sv_val[i_end];
vr_len[i]--;
}
/* now j-th column of matrix V is empty */
luf->nnz_v -= vc_len[j];
vc_len[j] = 0;
/* add new elements of j-th column of matrix V to corresponding
row lists; determine indices k1 and k2 */
k1 = qq_row[j], k2 = 0;
for (ptr = 1; ptr <= len; ptr++)
{ /* get row index of v[i,j] */
i = cc_ind[ptr];
/* at least one unused location is needed in i-th row */
if (vr_len[i] + 1 > vr_cap[i])
{ if (luf_enlarge_row(luf, i, vr_len[i] + 10))
{ /* overflow of the sparse vector area */
fhv->valid = 0;
luf->new_sva = luf->sv_size + luf->sv_size;
xassert(luf->new_sva > luf->sv_size);
ret = FHV_EROOM;
goto done;
}
}
/* add v[i,j] to i-th row */
i_ptr = vr_ptr[i] + vr_len[i];
sv_ind[i_ptr] = j;
sv_val[i_ptr] = cc_val[ptr];
vr_len[i]++;
/* adjust index k2 */
if (k2 < pp_col[i]) k2 = pp_col[i];
}
/* capacity of j-th column (which is currently empty) should be
not less than len locations */
if (vc_cap[j] < len)
{ if (luf_enlarge_col(luf, j, len))
{ /* overflow of the sparse vector area */
fhv->valid = 0;
luf->new_sva = luf->sv_size + luf->sv_size;
xassert(luf->new_sva > luf->sv_size);
ret = FHV_EROOM;
goto done;
}
}
/* add new elements of matrix V to j-th column list */
j_ptr = vc_ptr[j];
memmove(&sv_ind[j_ptr], &cc_ind[1], len * sizeof(int));
memmove(&sv_val[j_ptr], &cc_val[1], len * sizeof(double));
vc_len[j] = len;
luf->nnz_v += len;
/* if k1 > k2, diagonal element u[k2,k2] of matrix U is zero and
therefore the adjacent basis matrix is structurally singular */
if (k1 > k2)
{ fhv->valid = 0;
ret = FHV_ESING;
goto done;
}
/* perform implicit symmetric permutations of rows and columns of
matrix U */
i = pp_row[k1], j = qq_col[k1];
for (k = k1; k < k2; k++)
{ pp_row[k] = pp_row[k+1], pp_col[pp_row[k]] = k;
qq_col[k] = qq_col[k+1], qq_row[qq_col[k]] = k;
}
pp_row[k2] = i, pp_col[i] = k2;
qq_col[k2] = j, qq_row[j] = k2;
/* now i-th row of the matrix V is k2-th row of matrix U; since
no pivoting is used, only this row will be transformed */
/* copy elements of i-th row of matrix V to the working array and
remove these elements from matrix V */
for (j = 1; j <= m; j++) work[j] = 0.0;
i_beg = vr_ptr[i];
i_end = i_beg + vr_len[i] - 1;
for (i_ptr = i_beg; i_ptr <= i_end; i_ptr++)
{ /* get column index of v[i,j] */
j = sv_ind[i_ptr];
/* store v[i,j] to the working array */
work[j] = sv_val[i_ptr];
/* find v[i,j] in the j-th column */
j_beg = vc_ptr[j];
j_end = j_beg + vc_len[j] - 1;
for (j_ptr = j_beg; sv_ind[j_ptr] != i; j_ptr++) /* nop */;
xassert(j_ptr <= j_end);
/* remove v[i,j] from the j-th column */
sv_ind[j_ptr] = sv_ind[j_end];
sv_val[j_ptr] = sv_val[j_end];
vc_len[j]--;
}
/* now i-th row of matrix V is empty */
luf->nnz_v -= vr_len[i];
vr_len[i] = 0;
/* create the next row-like factor of the matrix H; this factor
corresponds to i-th (transformed) row */
fhv->hh_nfs++;
hh_ind[fhv->hh_nfs] = i;
/* hh_ptr[] will be set later */
hh_len[fhv->hh_nfs] = 0;
/* up to (k2 - k1) free locations are needed to add new elements
to the non-trivial row of the row-like factor */
if (luf->sv_end - luf->sv_beg < k2 - k1)
{ luf_defrag_sva(luf);
if (luf->sv_end - luf->sv_beg < k2 - k1)
{ /* overflow of the sparse vector area */
fhv->valid = luf->valid = 0;
luf->new_sva = luf->sv_size + luf->sv_size;
xassert(luf->new_sva > luf->sv_size);
ret = FHV_EROOM;
goto done;
}
}
/* eliminate subdiagonal elements of matrix U */
for (k = k1; k < k2; k++)
{ /* v[p,q] = u[k,k] */
p = pp_row[k], q = qq_col[k];
/* this is the crucial point, where even tiny non-zeros should
not be dropped */
if (work[q] == 0.0) continue;
/* compute gaussian multiplier f = v[i,q] / v[p,q] */
f = work[q] / vr_piv[p];
/* perform gaussian transformation:
(i-th row) := (i-th row) - f * (p-th row)
in order to eliminate v[i,q] = u[k2,k] */
p_beg = vr_ptr[p];
p_end = p_beg + vr_len[p] - 1;
for (p_ptr = p_beg; p_ptr <= p_end; p_ptr++)
work[sv_ind[p_ptr]] -= f * sv_val[p_ptr];
/* store new element (gaussian multiplier that corresponds to
p-th row) in the current row-like factor */
luf->sv_end--;
sv_ind[luf->sv_end] = p;
sv_val[luf->sv_end] = f;
hh_len[fhv->hh_nfs]++;
}
/* set pointer to the current row-like factor of the matrix H
(if no elements were added to this factor, it is unity matrix
and therefore can be discarded) */
if (hh_len[fhv->hh_nfs] == 0)
fhv->hh_nfs--;
else
{ hh_ptr[fhv->hh_nfs] = luf->sv_end;
fhv->nnz_h += hh_len[fhv->hh_nfs];
}
/* store new pivot which corresponds to u[k2,k2] */
vr_piv[i] = work[qq_col[k2]];
/* new elements of i-th row of matrix V (which are non-diagonal
elements u[k2,k2+1], ..., u[k2,m] of matrix U = P*V*Q) now are
contained in the working array; add them to matrix V */
len = 0;
for (k = k2+1; k <= m; k++)
{ /* get column index and value of v[i,j] = u[k2,k] */
j = qq_col[k];
temp = work[j];
/* if v[i,j] is close to zero, skip it */
if (fabs(temp) < eps_tol) continue;
/* at least one unused location is needed in j-th column */
if (vc_len[j] + 1 > vc_cap[j])
{ if (luf_enlarge_col(luf, j, vc_len[j] + 10))
{ /* overflow of the sparse vector area */
fhv->valid = 0;
luf->new_sva = luf->sv_size + luf->sv_size;
xassert(luf->new_sva > luf->sv_size);
ret = FHV_EROOM;
goto done;
}
}
/* add v[i,j] to j-th column */
j_ptr = vc_ptr[j] + vc_len[j];
sv_ind[j_ptr] = i;
sv_val[j_ptr] = temp;
vc_len[j]++;
/* also store v[i,j] to the auxiliary array */
len++, cc_ind[len] = j, cc_val[len] = temp;
}
/* capacity of i-th row (which is currently empty) should be not
less than len locations */
if (vr_cap[i] < len)
{ if (luf_enlarge_row(luf, i, len))
{ /* overflow of the sparse vector area */
fhv->valid = 0;
luf->new_sva = luf->sv_size + luf->sv_size;
xassert(luf->new_sva > luf->sv_size);
ret = FHV_EROOM;
goto done;
}
}
/* add new elements to i-th row list */
i_ptr = vr_ptr[i];
memmove(&sv_ind[i_ptr], &cc_ind[1], len * sizeof(int));
memmove(&sv_val[i_ptr], &cc_val[1], len * sizeof(double));
vr_len[i] = len;
luf->nnz_v += len;
/* updating is finished; check that diagonal element u[k2,k2] is
not very small in absolute value among other elements in k2-th
row and k2-th column of matrix U = P*V*Q */
/* temp = max(|u[k2,*]|, |u[*,k2]|) */
temp = 0.0;
/* walk through k2-th row of U which is i-th row of V */
i = pp_row[k2];
i_beg = vr_ptr[i];
i_end = i_beg + vr_len[i] - 1;
for (i_ptr = i_beg; i_ptr <= i_end; i_ptr++)
if (temp < fabs(sv_val[i_ptr])) temp = fabs(sv_val[i_ptr]);
/* walk through k2-th column of U which is j-th column of V */
j = qq_col[k2];
j_beg = vc_ptr[j];
j_end = j_beg + vc_len[j] - 1;
for (j_ptr = j_beg; j_ptr <= j_end; j_ptr++)
if (temp < fabs(sv_val[j_ptr])) temp = fabs(sv_val[j_ptr]);
/* check that u[k2,k2] is not very small */
if (fabs(vr_piv[i]) < upd_tol * temp)
{ /* the factorization seems to be inaccurate and therefore must
be recomputed */
fhv->valid = 0;
ret = FHV_ECHECK;
goto done;
}
/* the factorization has been successfully updated */
ret = 0;
done: /* return to the calling program */
return ret;
}
int fhv_ft_update(FHV *fhv, int q, int aq_len, const int aq_ind[],
const double aq_val[], int ind[/*1+n*/], double val[/*1+n*/],
double work[/*1+n*/])
{ LUF *luf = fhv->luf;
int n = luf->n;
SVA *sva = luf->sva;
int *sv_ind = sva->ind;
double *sv_val = sva->val;
int vr_ref = luf->vr_ref;
int *vr_ptr = &sva->ptr[vr_ref-1];
int *vr_len = &sva->len[vr_ref-1];
int *vr_cap = &sva->cap[vr_ref-1];
double *vr_piv = luf->vr_piv;
int vc_ref = luf->vc_ref;
int *vc_ptr = &sva->ptr[vc_ref-1];
int *vc_len = &sva->len[vc_ref-1];
int *vc_cap = &sva->cap[vc_ref-1];
int *pp_ind = luf->pp_ind;
int *pp_inv = luf->pp_inv;
int *qq_ind = luf->qq_ind;
int *qq_inv = luf->qq_inv;
int *hh_ind = fhv->hh_ind;
int hh_ref = fhv->hh_ref;
int *hh_ptr = &sva->ptr[hh_ref-1];
int *hh_len = &sva->len[hh_ref-1];
#if 1 /* FIXME */
const double eps_tol = DBL_EPSILON;
const double vpq_tol = 1e-5;
const double err_tol = 1e-10;
#endif
int end, i, i_end, i_ptr, j, j_end, j_ptr, k, len, nnz, p, p_end,
p_ptr, ptr, q_end, q_ptr, s, t;
double f, vpq, temp;
/*--------------------------------------------------------------*/
/* replace current q-th column of matrix V by new one */
/*--------------------------------------------------------------*/
xassert(1 <= q && q <= n);
/* convert new q-th column of matrix A to dense format */
for (i = 1; i <= n; i++)
val[i] = 0.0;
xassert(0 <= aq_len && aq_len <= n);
for (k = 1; k <= aq_len; k++)
{ i = aq_ind[k];
xassert(1 <= i && i <= n);
xassert(val[i] == 0.0);
xassert(aq_val[k] != 0.0);
val[i] = aq_val[k];
}
/* compute new q-th column of matrix V:
* new V[q] = inv(F * H) * (new A[q]) */
luf->pp_ind = fhv->p0_ind;
luf->pp_inv = fhv->p0_inv;
luf_f_solve(luf, val);
luf->pp_ind = pp_ind;
luf->pp_inv = pp_inv;
fhv_h_solve(fhv, val);
/* q-th column of V = s-th column of U */
s = qq_inv[q];
/* determine row number of element v[p,q] that corresponds to
* diagonal element u[s,s] */
p = pp_inv[s];
/* convert new q-th column of V to sparse format;
* element v[p,q] = u[s,s] is not included in the element list
* and stored separately */
vpq = 0.0;
len = 0;
for (i = 1; i <= n; i++)
{ temp = val[i];
#if 1 /* FIXME */
if (-eps_tol < temp && temp < +eps_tol)
#endif
/* nop */;
else if (i == p)
vpq = temp;
else
{ ind[++len] = i;
val[len] = temp;
}
}
/* clear q-th column of matrix V */
for (q_end = (q_ptr = vc_ptr[q]) + vc_len[q];
q_ptr < q_end; q_ptr++)
{ /* get row index of v[i,q] */
i = sv_ind[q_ptr];
/* find and remove v[i,q] from i-th row */
for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
sv_ind[i_ptr] != q; i_ptr++)
/* nop */;
xassert(i_ptr < i_end);
sv_ind[i_ptr] = sv_ind[i_end-1];
sv_val[i_ptr] = sv_val[i_end-1];
vr_len[i]--;
}
/* now q-th column of matrix V is empty */
vc_len[q] = 0;
/* put new q-th column of V (except element v[p,q] = u[s,s]) in
* column-wise format */
if (len > 0)
{ if (vc_cap[q] < len)
{ if (sva->r_ptr - sva->m_ptr < len)
{ sva_more_space(sva, len);
sv_ind = sva->ind;
sv_val = sva->val;
}
sva_enlarge_cap(sva, vc_ref-1+q, len, 0);
}
ptr = vc_ptr[q];
memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
vc_len[q] = len;
}
/* put new q-th column of V (except element v[p,q] = u[s,s]) in
* row-wise format, and determine largest row number t such that
* u[s,t] != 0 */
t = (vpq == 0.0 ? 0 : s);
for (k = 1; k <= len; k++)
{ /* get row index of v[i,q] */
i = ind[k];
/* put v[i,q] to i-th row */
if (vr_cap[i] == vr_len[i])
{ /* reserve extra locations in i-th row to reduce further
* relocations of that row */
#if 1 /* FIXME */
int need = vr_len[i] + 5;
#endif
if (sva->r_ptr - sva->m_ptr < need)
{ sva_more_space(sva, need);
sv_ind = sva->ind;
sv_val = sva->val;
}
sva_enlarge_cap(sva, vr_ref-1+i, need, 0);
}
sv_ind[ptr = vr_ptr[i] + (vr_len[i]++)] = q;
sv_val[ptr] = val[k];
/* v[i,q] is non-zero; increase t */
if (t < pp_ind[i])
t = pp_ind[i];
}
/*--------------------------------------------------------------*/
/* check if matrix U is already upper triangular */
/*--------------------------------------------------------------*/
/* check if there is a spike in s-th column of matrix U, which
* is q-th column of matrix V */
if (s >= t)
{ /* no spike; matrix U is already upper triangular */
/* store its diagonal element u[s,s] = v[p,q] */
vr_piv[p] = vpq;
if (s > t)
{ /* matrix U is structurally singular, because its diagonal
* element u[s,s] = v[p,q] is exact zero */
xassert(vpq == 0.0);
return 1;
}
#if 1 /* FIXME */
else if (-vpq_tol < vpq && vpq < +vpq_tol)
#endif
{ /* matrix U is not well conditioned, because its diagonal
* element u[s,s] = v[p,q] is too small in magnitude */
return 2;
}
else
{ /* normal case */
return 0;
}
}
/*--------------------------------------------------------------*/
/* perform implicit symmetric permutations of rows and columns */
/* of matrix U */
/*--------------------------------------------------------------*/
/* currently v[p,q] = u[s,s] */
xassert(p == pp_inv[s] && q == qq_ind[s]);
for (k = s; k < t; k++)
{ pp_ind[pp_inv[k] = pp_inv[k+1]] = k;
qq_inv[qq_ind[k] = qq_ind[k+1]] = k;
}
/* now v[p,q] = u[t,t] */
pp_ind[pp_inv[t] = p] = qq_inv[qq_ind[t] = q] = t;
/*--------------------------------------------------------------*/
/* check if matrix U is already upper triangular */
/*--------------------------------------------------------------*/
/* check if there is a spike in t-th row of matrix U, which is
* p-th row of matrix V */
for (p_end = (p_ptr = vr_ptr[p]) + vr_len[p];
p_ptr < p_end; p_ptr++)
{ if (qq_inv[sv_ind[p_ptr]] < t)
break; /* spike detected */
}
if (p_ptr == p_end)
{ /* no spike; matrix U is already upper triangular */
/* store its diagonal element u[t,t] = v[p,q] */
vr_piv[p] = vpq;
#if 1 /* FIXME */
if (-vpq_tol < vpq && vpq < +vpq_tol)
#endif
{ /* matrix U is not well conditioned, because its diagonal
* element u[t,t] = v[p,q] is too small in magnitude */
return 2;
}
else
{ /* normal case */
return 0;
}
}
/*--------------------------------------------------------------*/
/* copy p-th row of matrix V, which is t-th row of matrix U, to */
/* working array */
/*--------------------------------------------------------------*/
/* copy p-th row of matrix V, including element v[p,q] = u[t,t],
* to the working array in dense format and remove these elements
* from matrix V; since no pivoting is used, only this row will
* change during elimination */
for (j = 1; j <= n; j++)
work[j] = 0.0;
work[q] = vpq;
for (p_end = (p_ptr = vr_ptr[p]) + vr_len[p];
p_ptr < p_end; p_ptr++)
{ /* get column index of v[p,j] and store this element to the
* working array */
work[j = sv_ind[p_ptr]] = sv_val[p_ptr];
/* find and remove v[p,j] from j-th column */
for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
sv_ind[j_ptr] != p; j_ptr++)
/* nop */;
xassert(j_ptr < j_end);
sv_ind[j_ptr] = sv_ind[j_end-1];
sv_val[j_ptr] = sv_val[j_end-1];
vc_len[j]--;
}
/* now p-th row of matrix V is temporarily empty */
vr_len[p] = 0;
/*--------------------------------------------------------------*/
/* perform gaussian elimination */
/*--------------------------------------------------------------*/
/* transform p-th row of matrix V stored in working array, which
* is t-th row of matrix U, to eliminate subdiagonal elements
* u[t,s], ..., u[t,t-1]; corresponding gaussian multipliers will
* form non-trivial row of new row-like factor */
nnz = 0; /* number of non-zero gaussian multipliers */
for (k = s; k < t; k++)
{ /* diagonal element u[k,k] = v[i,j] is used as pivot */
i = pp_inv[k], j = qq_ind[k];
/* take subdiagonal element u[t,k] = v[p,j] */
temp = work[j];
#if 1 /* FIXME */
if (-eps_tol < temp && temp < +eps_tol)
continue;
#endif
/* compute and save gaussian multiplier:
* f := u[t,k] / u[k,k] = v[p,j] / v[i,j] */
ind[++nnz] = i;
val[nnz] = f = work[j] / vr_piv[i];
/* gaussian transformation to eliminate u[t,k] = v[p,j]:
* (p-th row of V) := (p-th row of V) - f * (i-th row of V) */
for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
i_ptr < i_end; i_ptr++)
work[sv_ind[i_ptr]] -= f * sv_val[i_ptr];
}
/* now matrix U is again upper triangular */
#if 1 /* FIXME */
if (-vpq_tol < work[q] && work[q] < +vpq_tol)
#endif
{ /* however, its new diagonal element u[t,t] = v[p,q] is too
* small in magnitude */
return 3;
}
/*--------------------------------------------------------------*/
/* create new row-like factor H[k] and add to eta file H */
/*--------------------------------------------------------------*/
/* (nnz = 0 means that all subdiagonal elements were too small
* in magnitude) */
if (nnz > 0)
{ if (fhv->nfs == fhv->nfs_max)
{ /* maximal number of row-like factors has been reached */
return 4;
}
k = ++(fhv->nfs);
hh_ind[k] = p;
/* store non-trivial row of H[k] in right (dynamic) part of
* SVA (diagonal unity element is not stored) */
if (sva->r_ptr - sva->m_ptr < nnz)
{ sva_more_space(sva, nnz);
sv_ind = sva->ind;
sv_val = sva->val;
}
sva_reserve_cap(sva, fhv->hh_ref-1+k, nnz);
ptr = hh_ptr[k];
memcpy(&sv_ind[ptr], &ind[1], nnz * sizeof(int));
memcpy(&sv_val[ptr], &val[1], nnz * sizeof(double));
hh_len[k] = nnz;
}
/*--------------------------------------------------------------*/
/* copy transformed p-th row of matrix V, which is t-th row of */
/* matrix U, from working array back to matrix V */
/*--------------------------------------------------------------*/
/* copy elements of transformed p-th row of matrix V, which are
* non-diagonal elements u[t,t+1], ..., u[t,n] of matrix U, from
* working array to corresponding columns of matrix V (note that
* diagonal element u[t,t] = v[p,q] not copied); also transform
* p-th row of matrix V to sparse format */
len = 0;
for (k = t+1; k <= n; k++)
{ /* j-th column of V = k-th column of U */
j = qq_ind[k];
/* take non-diagonal element v[p,j] = u[t,k] */
temp = work[j];
#if 1 /* FIXME */
if (-eps_tol < temp && temp < +eps_tol)
continue;
#endif
/* add v[p,j] to j-th column of matrix V */
if (vc_cap[j] == vc_len[j])
{ /* reserve extra locations in j-th column to reduce further
* relocations of that column */
#if 1 /* FIXME */
int need = vc_len[j] + 5;
#endif
if (sva->r_ptr - sva->m_ptr < need)
{ sva_more_space(sva, need);
sv_ind = sva->ind;
sv_val = sva->val;
}
sva_enlarge_cap(sva, vc_ref-1+j, need, 0);
}
sv_ind[ptr = vc_ptr[j] + (vc_len[j]++)] = p;
sv_val[ptr] = temp;
/* store element v[p,j] = u[t,k] to working sparse vector */
ind[++len] = j;
val[len] = temp;
}
/* copy elements from working sparse vector to p-th row of matrix
* V (this row is currently empty) */
if (vr_cap[p] < len)
{ if (sva->r_ptr - sva->m_ptr < len)
{ sva_more_space(sva, len);
sv_ind = sva->ind;
sv_val = sva->val;
}
sva_enlarge_cap(sva, vr_ref-1+p, len, 0);
}
ptr = vr_ptr[p];
memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
vr_len[p] = len;
/* store new diagonal element u[t,t] = v[p,q] */
vr_piv[p] = work[q];
/*--------------------------------------------------------------*/
/* perform accuracy test (only if new H[k] was added) */
/*--------------------------------------------------------------*/
if (nnz > 0)
{ /* copy p-th (non-trivial) row of row-like factor H[k] (except
* unity diagonal element) to working array in dense format */
for (j = 1; j <= n; j++)
work[j] = 0.0;
k = fhv->nfs;
for (end = (ptr = hh_ptr[k]) + hh_len[k]; ptr < end; ptr++)
work[sv_ind[ptr]] = sv_val[ptr];
/* compute inner product of p-th (non-trivial) row of matrix
* H[k] and q-th column of matrix V */
temp = vr_piv[p]; /* 1 * v[p,q] */
ptr = vc_ptr[q];
end = ptr + vc_len[q];
for (; ptr < end; ptr++)
temp += work[sv_ind[ptr]] * sv_val[ptr];
/* inner product should be equal to element v[p,q] *before*
* matrix V was transformed */
/* compute relative error */
temp = fabs(vpq - temp) / (1.0 + fabs(vpq));
#if 1 /* FIXME */
if (temp > err_tol)
#endif
{ /* relative error is too large */
return 5;
}
}
/* factorization has been successfully updated */
return 0;
}
int lpf_update_it(LPF *lpf, int j, int bh, int len, const int ind[],
const double val[])
{ int m0 = lpf->m0;
int m = lpf->m;
#if GLPLPF_DEBUG
double *B = lpf->B;
#endif
int n = lpf->n;
int *R_ptr = lpf->R_ptr;
int *R_len = lpf->R_len;
int *S_ptr = lpf->S_ptr;
int *S_len = lpf->S_len;
int *P_row = lpf->P_row;
int *P_col = lpf->P_col;
int *Q_row = lpf->Q_row;
int *Q_col = lpf->Q_col;
int v_ptr = lpf->v_ptr;
int *v_ind = lpf->v_ind;
double *v_val = lpf->v_val;
double *a = lpf->work2; /* new column */
double *fg = lpf->work1, *f = fg, *g = fg + m0;
double *vw = lpf->work2, *v = vw, *w = vw + m0;
double *x = g, *y = w, z;
int i, ii, k, ret;
xassert(bh == bh);
if (!lpf->valid)
xfault("lpf_update_it: the factorization is not valid\n");
if (!(1 <= j && j <= m))
xfault("lpf_update_it: j = %d; column number out of range\n",
j);
xassert(0 <= m && m <= m0 + n);
/* check if the basis factorization can be expanded */
if (n == lpf->n_max)
{ lpf->valid = 0;
ret = LPF_ELIMIT;
goto done;
}
/* convert new j-th column of B to dense format */
for (i = 1; i <= m; i++)
a[i] = 0.0;
for (k = 1; k <= len; k++)
{ i = ind[k];
if (!(1 <= i && i <= m))
xfault("lpf_update_it: ind[%d] = %d; row number out of rang"
"e\n", k, i);
if (a[i] != 0.0)
xfault("lpf_update_it: ind[%d] = %d; duplicate row index no"
"t allowed\n", k, i);
if (val[k] == 0.0)
xfault("lpf_update_it: val[%d] = %g; zero element not allow"
"ed\n", k, val[k]);
a[i] = val[k];
}
#if GLPLPF_DEBUG
/* change column in the basis matrix for debugging */
for (i = 1; i <= m; i++)
B[(i - 1) * m + j] = a[i];
#endif
/* (f g) := inv(P) * (a 0) */
for (i = 1; i <= m0+n; i++)
fg[i] = ((ii = P_col[i]) <= m ? a[ii] : 0.0);
/* (v w) := Q * (ej 0) */
for (i = 1; i <= m0+n; i++) vw[i] = 0.0;
vw[Q_col[j]] = 1.0;
/* f1 := inv(L0) * f (new column of R) */
#if 0 /* 06/VI-2013 */
luf_f_solve(lpf->luf, 0, f);
#else
luf_f_solve(lpf->lufint->luf, f);
#endif
/* v1 := inv(U'0) * v (new row of S) */
#if 0 /* 06/VI-2013 */
luf_v_solve(lpf->luf, 1, v);
#else
{ double *work = lpf->lufint->sgf->work;
luf_vt_solve(lpf->lufint->luf, v, work);
memcpy(&v[1], &work[1], m0 * sizeof(double));
}
#endif
/* we need at most 2 * m0 available locations in the SVA to store
new column of matrix R and new row of matrix S */
if (lpf->v_size < v_ptr + m0 + m0)
{ enlarge_sva(lpf, v_ptr + m0 + m0);
v_ind = lpf->v_ind;
v_val = lpf->v_val;
}
/* store new column of R */
R_ptr[n+1] = v_ptr;
for (i = 1; i <= m0; i++)
{ if (f[i] != 0.0)
v_ind[v_ptr] = i, v_val[v_ptr] = f[i], v_ptr++;
}
R_len[n+1] = v_ptr - lpf->v_ptr;
lpf->v_ptr = v_ptr;
/* store new row of S */
S_ptr[n+1] = v_ptr;
for (i = 1; i <= m0; i++)
{ if (v[i] != 0.0)
v_ind[v_ptr] = i, v_val[v_ptr] = v[i], v_ptr++;
}
S_len[n+1] = v_ptr - lpf->v_ptr;
lpf->v_ptr = v_ptr;
/* x := g - S * f1 (new column of C) */
s_prod(lpf, x, -1.0, f);
/* y := w - R' * v1 (new row of C) */
rt_prod(lpf, y, -1.0, v);
/* z := - v1 * f1 (new diagonal element of C) */
z = 0.0;
for (i = 1; i <= m0; i++) z -= v[i] * f[i];
/* update factorization of new matrix C */
switch (scf_update_exp(lpf->scf, x, y, z))
{ case 0:
break;
case SCF_ESING:
lpf->valid = 0;
ret = LPF_ESING;
goto done;
case SCF_ELIMIT:
xassert(lpf != lpf);
default:
xassert(lpf != lpf);
}
/* expand matrix P */
P_row[m0+n+1] = P_col[m0+n+1] = m0+n+1;
/* expand matrix Q */
Q_row[m0+n+1] = Q_col[m0+n+1] = m0+n+1;
/* permute j-th and last (just added) column of matrix Q */
i = Q_col[j], ii = Q_col[m0+n+1];
Q_row[i] = m0+n+1, Q_col[m0+n+1] = i;
Q_row[ii] = j, Q_col[j] = ii;
/* increase the number of additional rows and columns */
lpf->n++;
xassert(lpf->n <= lpf->n_max);
/* the factorization has been successfully updated */
ret = 0;
done: /* return to the calling program */
return ret;
}
