SPMAT *comp_AAT(SPMAT *A) #endif { SPMAT *AAT; SPROW *r, *r2; row_elt *elts, *elts2; int i, idx, idx2, j, m, minim, n, num_scan, tmp1; Real ip; if ( ! A ) error(E_NULL,"comp_AAT"); m = A->m; n = A->n; /* set up column access paths */ if ( ! A->flag_col ) sp_col_access(A); AAT = sp_get(m,m,10); for ( i = 0; i < m; i++ ) { /* initialisation */ r = &(A->row[i]); elts = r->elt; /* set up scan lists for this row */ if ( r->len > scan_len ) set_scan(r->len); for ( j = 0; j < r->len; j++ ) { col_list[j] = elts[j].col; scan_row[j] = elts[j].nxt_row; scan_idx[j] = elts[j].nxt_idx; } num_scan = r->len; /* scan down the rows for next non-zero not associated with a diagonal entry */ for ( ; ; ) { minim = m; for ( idx = 0; idx < num_scan; idx++ ) { tmp1 = scan_row[idx]; minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; } if ( minim >= m ) break; r2 = &(A->row[minim]); if ( minim > i ) { ip = sprow_ip(r,r2,n); sp_set_val(AAT,minim,i,ip); sp_set_val(AAT,i,minim,ip); } /* update scan entries */ elts2 = r2->elt; for ( idx = 0; idx < num_scan; idx++ ) { if ( scan_row[idx] != minim || scan_idx[idx] < 0 ) continue; idx2 = scan_idx[idx]; scan_row[idx] = elts2[idx2].nxt_row; scan_idx[idx] = elts2[idx2].nxt_idx; } } /* set the diagonal entry */ sp_set_val(AAT,i,i,sprow_sqr(r,n)); } return AAT; }
SPMAT *spCHsymb(SPMAT *A) #endif { register int i; int idx, k, m, minim, n, num_scan, diag_idx, tmp1; SPROW *r_piv, *r_op; row_elt *elt_piv, *elt_op, *old_elt; if ( A == SMNULL ) error(E_NULL,"spCHsymb"); if ( A->m != A->n ) error(E_SQUARE,"spCHsymb"); /* set up access paths if not already done so */ if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); /* printf("spCHsymb() -- checkpoint 1\n"); */ m = A->m; n = A->n; for ( k = 0; k < m; k++ ) { r_piv = &(A->row[k]); if ( r_piv->len > scan_len ) set_scan(r_piv->len); elt_piv = r_piv->elt; diag_idx = sprow_idx2(r_piv,k,r_piv->diag); if ( diag_idx < 0 ) error(E_POSDEF,"spCHsymb"); old_elt = &(elt_piv[diag_idx]); for ( i = 0; i < r_piv->len; i++ ) { if ( elt_piv[i].col > k ) break; col_list[i] = elt_piv[i].col; scan_row[i] = elt_piv[i].nxt_row; scan_idx[i] = elt_piv[i].nxt_idx; } /* printf("spCHsymb() -- checkpoint 2\n"); */ num_scan = i; /* number of actual entries in scan_row etc. */ /* printf("num_scan = %d\n",num_scan); */ /* now set the k-th column of the Cholesky factors */ /* printf("k = %d\n",k); */ for ( ; ; ) /* forever do... */ { /* printf("spCHsymb() -- checkpoint 3\n"); */ /* find next row where something (non-trivial) happens i.e. find min(scan_row) */ minim = n; for ( i = 0; i < num_scan; i++ ) { tmp1 = scan_row[i]; /* printf("%d ",tmp1); */ minim = ( tmp1 >= 0 && tmp1 < minim ) ? tmp1 : minim; } if ( minim >= n ) break; /* nothing more to do for this column */ r_op = &(A->row[minim]); elt_op = r_op->elt; /* set next entry in column k of Cholesky factors */ idx = sprow_idx2(r_op,k,scan_idx[num_scan-1]); if ( idx < 0 ) { /* fill-in */ sp_set_val(A,minim,k,0.0); /* in case a realloc() has occurred... */ elt_op = r_op->elt; /* now set up column access path again */ idx = sprow_idx2(r_op,k,-(idx+2)); tmp1 = old_elt->nxt_row; old_elt->nxt_row = minim; r_op->elt[idx].nxt_row = tmp1; tmp1 = old_elt->nxt_idx; old_elt->nxt_idx = idx; r_op->elt[idx].nxt_idx = tmp1; } /* printf("spCHsymb() -- checkpoint 4\n"); */ /* remember current element in column k for column chain */ idx = sprow_idx2(r_op,k,idx); old_elt = &(r_op->elt[idx]); /* update scan_row */ /* printf("spCHsymb() -- checkpoint 5\n"); */ /* printf("minim = %d\n",minim); */ for ( i = 0; i < num_scan; i++ ) { if ( scan_row[i] != minim ) continue; idx = sprow_idx2(r_op,col_list[i],scan_idx[i]); if ( idx < 0 ) { scan_row[i] = -1; continue; } scan_row[i] = elt_op[idx].nxt_row; scan_idx[i] = elt_op[idx].nxt_idx; /* printf("scan_row[%d] = %d\n",i,scan_row[i]); */ /* printf("scan_idx[%d] = %d\n",i,scan_idx[i]); */ } } /* printf("spCHsymb() -- checkpoint 6\n"); */ } return A; }
//-------------------------------------------------------------------------- void Hqp_IpRedSpBKP::init(const Hqp_Program *qp) { IVEC *degree, *neigh_start, *neighs; SPMAT *QCTC; SPROW *r1, *r2; int i, j; int len, dim; Real sum; _n = qp->c->dim; _me = qp->b->dim; _m = qp->d->dim; dim = _n + _me; // reallocations _pivot = px_resize(_pivot, dim); _blocks = px_resize(_blocks, dim); _zw = v_resize(_zw, _m); _scale = v_resize(_scale, _n); _r12 = v_resize(_r12, dim); _xy = v_resize(_xy, dim); // store C' for further computations // analyze structure of C'*C _CT = sp_transp(qp->C, _CT); sp_ones(_CT); v_ones(_zw); QCTC = sp_get(_n, _n, 10); r1 = _CT->row; for (i=0; i<_n; i++, r1++) { r2 = r1; for (j=i; j<_n; j++, r2++) { sum = sprow_inprod(r1, _zw, r2); if (sum != 0.0) { sp_set_val(QCTC, i, j, sum); if (i != j) sp_set_val(QCTC, j, i, sum); } } } _CTC_degree = iv_resize(_CTC_degree, _n); _CTC_neigh_start = iv_resize(_CTC_neigh_start, _n + 1); _CTC_neighs = sp_rcm_scan(QCTC, SMNULL, SMNULL, _CTC_degree, _CTC_neigh_start, _CTC_neighs); // initialize structure of reduced qp QCTC = sp_add(qp->Q, QCTC, QCTC); // determine RCM ordering degree = iv_get(dim); neigh_start = iv_get(dim + 1); neighs = sp_rcm_scan(QCTC, qp->A, SMNULL, degree, neigh_start, IVNULL); _QP2J = sp_rcm_order(degree, neigh_start, neighs, _QP2J); _sbw = sp_rcm_sbw(neigh_start, neighs, _QP2J); _J2QP = px_inv(_QP2J, _J2QP); iv_free(degree); iv_free(neigh_start); iv_free(neighs); len = 1 + (int)(log((double)dim) / log(2.0)); sp_free(_J); sp_free(_J_raw); _J_raw = sp_get(dim, dim, len); _J = SMNULL; // fill up data (to allocate _J_raw) sp_into_symsp(QCTC, -1.0, _J_raw, _QP2J, 0, 0); spT_into_symsp(qp->A, 1.0, _J_raw, _QP2J, 0, _n); sp_into_symsp(qp->A, 1.0, _J_raw, _QP2J, _n, 0); sp_free(QCTC); // prepare iterations update(qp); }
SPMAT *spLUfactor(SPMAT *A, PERM *px, double alpha) #endif { int i, best_i, k, idx, len, best_len, m, n; SPROW *r, *r_piv, tmp_row; STATIC SPROW *merge = (SPROW *)NULL; Real max_val, tmp; STATIC VEC *col_vals=VNULL; if ( ! A || ! px ) error(E_NULL,"spLUfctr"); if ( alpha <= 0.0 || alpha > 1.0 ) error(E_RANGE,"alpha in spLUfctr"); if ( px->size <= A->m ) px = px_resize(px,A->m); px_ident(px); col_vals = v_resize(col_vals,A->m); MEM_STAT_REG(col_vals,TYPE_VEC); m = A->m; n = A->n; if ( ! A->flag_col ) sp_col_access(A); if ( ! A->flag_diag ) sp_diag_access(A); A->flag_col = A->flag_diag = FALSE; if ( ! merge ) { merge = sprow_get(20); MEM_STAT_REG(merge,TYPE_SPROW); } for ( k = 0; k < n; k++ ) { /* find pivot row/element for partial pivoting */ /* get first row with a non-zero entry in the k-th column */ max_val = 0.0; for ( i = k; i < m; i++ ) { r = &(A->row[i]); idx = sprow_idx(r,k); if ( idx < 0 ) tmp = 0.0; else tmp = r->elt[idx].val; if ( fabs(tmp) > max_val ) max_val = fabs(tmp); col_vals->ve[i] = tmp; } if ( max_val == 0.0 ) continue; best_len = n+1; /* only if no possibilities */ best_i = -1; for ( i = k; i < m; i++ ) { tmp = fabs(col_vals->ve[i]); if ( tmp == 0.0 ) continue; if ( tmp >= alpha*max_val ) { r = &(A->row[i]); idx = sprow_idx(r,k); len = (r->len) - idx; if ( len < best_len ) { best_len = len; best_i = i; } } } /* swap row #best_i with row #k */ MEM_COPY(&(A->row[best_i]),&tmp_row,sizeof(SPROW)); MEM_COPY(&(A->row[k]),&(A->row[best_i]),sizeof(SPROW)); MEM_COPY(&tmp_row,&(A->row[k]),sizeof(SPROW)); /* swap col_vals entries */ tmp = col_vals->ve[best_i]; col_vals->ve[best_i] = col_vals->ve[k]; col_vals->ve[k] = tmp; px_transp(px,k,best_i); r_piv = &(A->row[k]); for ( i = k+1; i < n; i++ ) { /* compute and set multiplier */ tmp = col_vals->ve[i]/col_vals->ve[k]; if ( tmp != 0.0 ) sp_set_val(A,i,k,tmp); else continue; /* perform row operations */ merge->len = 0; r = &(A->row[i]); sprow_mltadd(r,r_piv,-tmp,k+1,merge,TYPE_SPROW); idx = sprow_idx(r,k+1); if ( idx < 0 ) idx = -(idx+2); /* see if r needs expanding */ if ( r->maxlen < idx + merge->len ) sprow_xpd(r,idx+merge->len,TYPE_SPMAT); r->len = idx+merge->len; MEM_COPY((char *)(merge->elt),(char *)&(r->elt[idx]), merge->len*sizeof(row_elt)); } } #ifdef THREADSAFE sprow_free(merge); V_FREE(col_vals); #endif return A; }
/* * n_vars is the number of variables to be considered, * d is the data array of variables d[0],...,d[n_vars-1], * pred determines which estimate is required: BLUE, BLUP, or BLP */ void gls(DATA **d /* pointer to DATA array */, int n_vars, /* length of DATA array (to consider) */ enum GLS_WHAT pred, /* what type of prediction is requested */ DPOINT *where, /* prediction location */ double *est /* output: array that holds the predicted values and variances */) { GLM *glm = NULL; /* to be copied to/from d */ static MAT *X0 = MNULL, *C0 = MNULL, *MSPE = MNULL, *CinvC0 = MNULL, *Tmp1 = MNULL, *Tmp2 = MNULL, *Tmp3, *R = MNULL; static VEC *blup = VNULL, *tmpa = VNULL, *tmpb = VNULL; volatile unsigned int i, rows_C; unsigned int j, k, l = 0, row, col, start_i, start_j, start_X, global; VARIOGRAM *v = NULL; static enum GLS_WHAT last_pred = GLS_INIT; /* the initial value */ double c_value, *X_ori; if (d == NULL) { /* clean up */ if (X0 != MNULL) M_FREE(X0); if (C0 != MNULL) M_FREE(C0); if (MSPE != MNULL) M_FREE(MSPE); if (CinvC0 != MNULL) M_FREE(CinvC0); if (Tmp1 != MNULL) M_FREE(Tmp1); if (Tmp2 != MNULL) M_FREE(Tmp2); if (Tmp3 != MNULL) M_FREE(Tmp3); if (R != MNULL) M_FREE(R); if (blup != VNULL) V_FREE(blup); if (tmpa != VNULL) V_FREE(tmpa); if (tmpb != VNULL) V_FREE(tmpb); last_pred = GLS_INIT; return; } #ifndef HAVE_SPARSE if (gl_sparse) { pr_warning("sparse matrices not supported: compile with --with-sparse"); gl_sparse = 0; } #endif if (DEBUG_COV) { printlog("we're at %s X: %g Y: %g Z: %g\n", IS_BLOCK(where) ? "block" : "point", where->x, where->y, where->z); } if (pred != UPDATE) /* it right away: */ last_pred = pred; assert(last_pred != GLS_INIT); if (d[0]->glm == NULL) { /* allocate and initialize: */ glm = new_glm(); d[0]->glm = (void *) glm; } else glm = (GLM *) d[0]->glm; glm->mu0 = v_resize(glm->mu0, n_vars); MSPE = m_resize(MSPE, n_vars, n_vars); if (pred == GLS_BLP || UPDATE_BLP) { X_ori = where->X; for (i = 0; i < n_vars; i++) { /* mu(0) */ glm->mu0->ve[i] = calc_mu(d[i], where); blup = v_copy(glm->mu0, v_resize(blup, glm->mu0->dim)); where->X += d[i]->n_X; /* shift to next x0 entry */ } where->X = X_ori; /* ... and set back */ for (i = 0; i < n_vars; i++) { /* Cij(0,0): */ for (j = 0; j <= i; j++) { v = get_vgm(LTI(d[i]->id,d[j]->id)); MSPE->me[i][j] = MSPE->me[j][i] = COVARIANCE0(v, where, where, d[j]->pp_norm2); } } fill_est(NULL, blup, MSPE, n_vars, est); /* in case of empty neighbourhood */ } /* xxx */ /* logprint_variogram(v, 1); */ /* * selection dependent problem dimensions: */ for (i = rows_C = 0; i < n_vars; i++) rows_C += d[i]->n_sel; if (rows_C == 0) { /* empty selection list(s) */ if (pred == GLS_BLP || UPDATE_BLP) debug_result(blup, MSPE, pred); return; } for (i = 0, global = 1; i < n_vars && global; i++) global = (d[i]->sel == d[i]->list && d[i]->n_list == d[i]->n_original); /* * global things: enter whenever (a) first time, (b) local selections or * (c) the size of the problem grew since the last call (e.g. simulation) */ if ((glm->C == NULL && glm->spC == NULL) || !global || rows_C > glm->C->m) { /* * fill y: */ glm->y = get_y(d, glm->y, n_vars); if (pred != UPDATE) { if (! gl_sparse) { glm->C = m_resize(glm->C, rows_C, rows_C); m_zero(glm->C); } #ifdef HAVE_SPARSE else { if (glm->C == NULL) { glm->spC = sp_get(rows_C, rows_C, gl_sparse); /* d->spLLT = spLLT = sp_get(rows_C, rows_C, gl_sparse); */ } else { glm->spC = sp_resize(glm->spC, rows_C, rows_C); /* d->spLLT = spLLT = sp_resize(spLLT, rows_C, rows_C); */ } sp_zero(glm->spC); } #endif glm->X = get_X(d, glm->X, n_vars); M_DEBUG(glm->X, "X"); glm->CinvX = m_resize(glm->CinvX, rows_C, glm->X->n); glm->XCinvX = m_resize(glm->XCinvX, glm->X->n, glm->X->n); glm->beta = v_resize(glm->beta, glm->X->n); for (i = start_X = start_i = 0; i < n_vars; i++) { /* row var */ /* fill C, mu: */ for (j = start_j = 0; j <= i; j++) { /* col var */ v = get_vgm(LTI(d[i]->id,d[j]->id)); for (k = 0; k < d[i]->n_sel; k++) { /* rows */ row = start_i + k; for (l = 0, col = start_j; col <= row && l < d[j]->n_sel; l++, col++) { if (pred == GLS_BLUP) c_value = GCV(v, d[i]->sel[k], d[j]->sel[l]); else c_value = COVARIANCE(v, d[i]->sel[k], d[j]->sel[l]); /* on the diagonal, if necessary, add measurement error variance */ if (d[i]->colnvariance && i == j && k == l) c_value += d[i]->sel[k]->variance; if (! gl_sparse) glm->C->me[row][col] = c_value; #ifdef HAVE_SPARSE else { if (c_value != 0.0) sp_set_val(glm->spC, row, col, c_value); } #endif } /* for l */ } /* for k */ start_j += d[j]->n_sel; } /* for j */ start_i += d[i]->n_sel; if (d[i]->n_sel > 0) start_X += d[i]->n_X - d[i]->n_merge; } /* for i */ /* if (d[0]->colnvmu) glm->C = convert_vmuC(glm->C, d[0]); */ if (d[0]->variance_fn) { glm->mu = get_mu(glm->mu, glm->y, d, n_vars); convert_C(glm->C, glm->mu, d[0]->variance_fn); } if (DEBUG_COV && pred == GLS_BLUP) printlog("[using generalized covariances: max_val - semivariance()]"); if (! gl_sparse) { M_DEBUG(glm->C, "Covariances (x_i, x_j) matrix C (lower triangle only)"); } #ifdef HAVE_SPARSE else { SM_DEBUG(glm->spC, "Covariances (x_i, x_j) sparse matrix C (lower triangle only)") } #endif /* check for singular C: */ if (! gl_sparse && gl_cn_max > 0.0) { for (i = 0; i < rows_C; i++) /* row */ for (j = i+1; j < rows_C; j++) /* col > row */ glm->C->me[i][j] = glm->C->me[j][i]; /* fill symmetric */ if (is_singular(glm->C, gl_cn_max)) { pr_warning("Covariance matrix (nearly) singular at location [%g,%g,%g]: skipping...", where->x, where->y, where->z); m_free(glm->C); glm->C = MNULL; /* assure re-entrance if global */ return; } } /* * factorize C: */ if (! gl_sparse) LDLfactor(glm->C); #ifdef HAVE_SPARSE else { sp_compact(glm->spC, 0.0); spCHfactor(glm->spC); } #endif } /* if (pred != UPDATE) */ if (pred != GLS_BLP && !UPDATE_BLP) { /* C-1 X and X'C-1 X, beta */ /* * calculate CinvX: */ tmpa = v_resize(tmpa, rows_C); for (i = 0; i < glm->X->n; i++) { tmpa = get_col(glm->X, i, tmpa); if (! gl_sparse) tmpb = LDLsolve(glm->C, tmpa, tmpb); #ifdef HAVE_SPARSE else tmpb = spCHsolve(glm->spC, tmpa, tmpb); #endif set_col(glm->CinvX, i, tmpb); } /* * calculate X'C-1 X: */ glm->XCinvX = mtrm_mlt(glm->X, glm->CinvX, glm->XCinvX); /* X'C-1 X */ M_DEBUG(glm->XCinvX, "X'C-1 X"); if (gl_cn_max > 0.0 && is_singular(glm->XCinvX, gl_cn_max)) { pr_warning("X'C-1 X matrix (nearly) singular at location [%g,%g,%g]: skipping...", where->x, where->y, where->z); m_free(glm->C); glm->C = MNULL; /* assure re-entrance if global */ return; } m_inverse(glm->XCinvX, glm->XCinvX); /* * calculate beta: */ tmpa = vm_mlt(glm->CinvX, glm->y, tmpa); /* X'C-1 y */ glm->beta = vm_mlt(glm->XCinvX, tmpa, glm->beta); /* (X'C-1 X)-1 X'C-1 y */ V_DEBUG(glm->beta, "beta"); M_DEBUG(glm->XCinvX, "Cov(beta), (X'C-1 X)-1"); M_DEBUG(R = get_corr_mat(glm->XCinvX, R), "Corr(beta)"); } /* if pred != GLS_BLP */ } /* if redo the heavy part */
//------------------------------------------------------------------------- void Prg_ASCEND::setup() { int n, me, m; int i, j, row_idx, idx; SPMAT *J; int nincidences; const struct var_variable **incidences; // obtain ASCEND system // todo: should check that system can be solved with HQP (e.g. no integers) _nvars = slv_get_num_solvers_vars(_slv_system); _vars = slv_get_solvers_var_list(_slv_system); _nrels = slv_get_num_solvers_rels(_slv_system); _rels = slv_get_solvers_rel_list(_slv_system); _obj = slv_get_obj_relation(_slv_system); // count number of optimization variables and bounds _var_lb = v_resize(_var_lb, _nvars); _var_ub = v_resize(_var_ub, _nvars); _var_asc2hqp = iv_resize(_var_asc2hqp, _nvars); _derivatives = v_resize(_derivatives, _nvars); _var_master_idxs = iv_resize(_var_master_idxs, _nvars); _var_solver_idxs = iv_resize(_var_solver_idxs, _nvars); n = 0; me = 0; m = 0; for (i = 0; i < _nvars; i++) { _var_lb[i] = var_lower_bound(_vars[i]); _var_ub[i] = var_upper_bound(_vars[i]); /* var_write_name(_slv_system, _vars[i], stderr); fprintf(stderr, ":\t%i,\t%g,\t%g\n", var_fixed(_vars[i]), _var_lb[i], _var_ub[i]); */ if (var_fixed(_vars[i])) { _var_asc2hqp[i] = -1; } else { _var_asc2hqp[i] = n++; if (_var_lb[i] == _var_ub[i]) ++me; else { if (_var_lb[i] > -_Inf) ++m; if (_var_ub[i] < _Inf) ++m; } } } // consider bounds as linear constraints (i.e. no Jacobian update) _me_bounds = me; _m_bounds = m; // count number of HQP constraints for (i = 0; i < _nrels; i++) { if (rel_equal(_rels[i])) ++me; // equality constraint else ++m; // inequality constraint } // allocate QP approximation and optimization variables vector _qp->resize(n, me, m); _x = v_resize(_x, n); // allocate sparse structure for bounds // (write constant elements in Jacobians) me = m = 0; for (i = 0; i < _nvars; i++) { idx = _var_asc2hqp[i]; if (idx < 0) continue; if (_var_lb[i] == _var_ub[i]) { row_idx = me++; sp_set_val(_qp->A, row_idx, idx, 1.0); } else { if (_var_lb[i] > -_Inf) { row_idx = m++; sp_set_val(_qp->C, row_idx, idx, 1.0); } if (_var_ub[i] < _Inf) { row_idx = m++; sp_set_val(_qp->C, row_idx, idx, -1.0); } } } // allocate sparse structure for general constraints // (just insert dummy values; actual values are set in update method) for (i = 0; i < _nrels; i++) { if (rel_equal(_rels[i])) { row_idx = me++; J = _qp->A; } else { row_idx = m++; J = _qp->C; } nincidences = rel_n_incidences(_rels[i]); incidences = rel_incidence_list(_rels[i]); for (j = 0; j < nincidences; j++) { idx = _var_asc2hqp[var_sindex(incidences[j])]; if (idx >= 0) sp_set_val(J, row_idx, idx, 1.0); } } // todo: setup sparse structure of Hessian // for now initialize something resulting in dense BFGS update for (j = 0; j < n-1; j++) { sp_set_val(_qp->Q, j, j, 0.0); sp_set_val(_qp->Q, j, j+1, 0.0); } sp_set_val(_qp->Q, j, j, 0.0); }