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; }