//-------------------------------------------------------------------------
Prg_ASCEND::~Prg_ASCEND()
{
iv_free(_var_solver_idxs);
iv_free(_var_master_idxs);
v_free(_derivatives);
iv_free(_var_asc2hqp);
v_free(_var_ub);
v_free(_var_lb);
}
void
mrb_gc_free_iv(mrb_state *mrb, struct RObject *obj)
{
if (obj->iv) {
iv_free(mrb, obj->iv);
}
}
//--------------------------------------------------------------------------
Hqp_IpRedSpBKP::~Hqp_IpRedSpBKP()
{
sp_free(_CT);
sp_free(_J);
sp_free(_J_raw);
px_free(_QP2J);
px_free(_J2QP);
px_free(_pivot);
px_free(_blocks);
v_free(_zw);
v_free(_scale);
v_free(_r12);
v_free(_xy);
iv_free(_CTC_degree);
iv_free(_CTC_neigh_start);
iv_free(_CTC_neighs);
}
extern int iv_free_vars(IVEC **ipv,...)
{
va_list ap;
int i=1;
IVEC **par;
iv_free(*ipv);
*ipv = IVNULL;
va_start(ap, ipv);
while (par = va_arg(ap,IVEC **)) { /* NULL ends the list*/
iv_free(*par);
*par = IVNULL;
i++;
}
va_end(ap);
return i;
}
void
mrb_iv_copy(mrb_state *mrb, mrb_value dest, mrb_value src)
{
struct RObject *d = mrb_obj_ptr(dest);
struct RObject *s = mrb_obj_ptr(src);
if (d->iv) {
iv_free(mrb, d->iv);
d->iv = 0;
}
if (s->iv) {
d->iv = iv_copy(mrb, s->iv);
}
}
MRB_API void
mrb_iv_copy(mrb_state *mrb, mrb_value dest, mrb_value src)
{
struct RObject *d = mrb_obj_ptr(dest);
struct RObject *s = mrb_obj_ptr(src);
if (d->iv) {
iv_free(mrb, d->iv);
d->iv = 0;
}
if (s->iv) {
mrb_write_barrier(mrb, (struct RBasic*)d);
d->iv = iv_copy(mrb, s->iv);
}
}
void
mrb_gc_free_gv(mrb_state *mrb)
{
if (mrb->globals)
iv_free(mrb, mrb->globals);
}
//--------------------------------------------------------------------------
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);
}
~A() {
free(_string);
iv_free(_intVecp);
}
static int fit_GaussNewton(VARIOGRAM *vp, PERM *p, LM *lm, int iter, int *bounded) {
double s = 0.0, x, y, z;
int i, j, n_fit, model, fit_ranges = 0;
IVEC *fit = NULL;
VEC *start = NULL;
if (p->size == 0)
return 1;
fit = iv_resize(fit, 2 * vp->n_models);
/* index fit parameters: parameter fit->ive[j] corresponds to model i */
for (i = n_fit = 0; i < vp->n_models; i++) {
if (vp->part[i].fit_sill)
fit->ive[n_fit++] = i;
if (vp->part[i].fit_range) {
fit->ive[n_fit++] = i + vp->n_models; /* large -->> ranges */
fit_ranges = 1;
}
}
if (n_fit == 0) {
iv_free(fit);
return 0;
}
fit = iv_resize(fit, n_fit); /* shrink to fit */
lm->X = m_resize(lm->X, p->size, n_fit);
lm->y = v_resize(lm->y, p->size);
start = v_resize(start, n_fit);
for (i = 0; i < n_fit; i++) {
if (fit->ive[i] < vp->n_models) {
model = fit->ive[i];
start->ve[i] = vp->part[model].sill;
} else {
model = fit->ive[i] - vp->n_models;
start->ve[i] = vp->part[model].range[0];
}
}
for (i = 0; i < p->size; i++) {
x = vp->ev->direction.x * vp->ev->dist[p->pe[i]];
y = vp->ev->direction.y * vp->ev->dist[p->pe[i]];
z = vp->ev->direction.z * vp->ev->dist[p->pe[i]];
/* fill y with current residuals: */
if (is_variogram(vp))
s = get_semivariance(vp, x, y, z);
else
s = get_covariance(vp, x, y, z);
lm->y->ve[i] = vp->ev->gamma[p->pe[i]] - s;
/* fill X: */
for (j = 0; j < n_fit; j++) { /* cols */
if (fit->ive[j] < vp->n_models) {
model = fit->ive[j];
ME(lm->X, i, j) = (is_variogram(vp) ?
UnitSemivariance(vp->part[model],x,y,z) :
UnitCovariance(vp->part[model],x,y,z));
} else {
model = fit->ive[j] - vp->n_models;
ME(lm->X, i, j) = (is_variogram(vp) ?
da_Semivariance(vp->part[model],x,y,z) :
-da_Semivariance(vp->part[model],x,y,z));
}
}
}
if (iter == 0 && fill_weights(vp, p, lm)) {
iv_free(fit);
v_free(start);
return 1;
}
lm->has_intercept = 1; /* does not affect the fit */
lm = calc_lm(lm); /* solve WLS eqs. for beta */
if (DEBUG_FIT) {
Rprintf("beta: ");
v_logoutput(lm->beta);
}
if (lm->is_singular) {
iv_free(fit);
v_free(start);
return 1;
}
if (fit_ranges) {
s = v_norm2(lm->beta) / v_norm2(start);
if (s > 0.2) {
/* don't allow steps > 20% ---- */
sv_mlt(0.2 / s, lm->beta, lm->beta);
*bounded = 1;
} else
*bounded = 0; /* a `free', voluntary step */
} else /* we're basically doing linear regression here: */
*bounded = 0;
for (i = 0; i < n_fit; i++) {
if (fit->ive[i] < vp->n_models) {
model = fit->ive[i];
vp->part[model].sill = start->ve[i] + lm->beta->ve[i];
} else {
model = fit->ive[i] - vp->n_models;;
vp->part[model].range[0] = start->ve[i] + lm->beta->ve[i];
}
}
iv_free(fit);
v_free(start);
return 0;
}
