METHOD get_default_method(void) {
int i, Xset, Vgm_set;
/*
* no no prediction locations or no data:
*/
if (get_n_vars() == 0)
return NSP;
if (valdata->id < 0 && gl_xvalid == 0 && data_area == NULL) {
return UIF;
}
/*
* check on X variables
*/
for (i = Xset = 0; i < get_n_vars(); i++)
if (!(data[i]->n_X == 1 && data[i]->colX[0] == 0))
Xset++;
/*
* check on variograms
*/
for (i = 0, Vgm_set = 0; i < get_n_vars(); i++)
if (vgm[LTI(i,i)] != NULL &&
(vgm[LTI(i,i)]->n_models > 0 || vgm[LTI(i,i)]->table != NULL))
/* was: ->id >= 0*/
Vgm_set++;
if (!(Vgm_set == 0 || Vgm_set == get_n_vars()))
ErrMsg(ER_SYNTAX, "set either all or no variograms");
if (Vgm_set > 0) {
if (get_n_beta_set() > 0)
return SKR;
else
return (Xset > 0 ? UKR : OKR);
} else
return (Xset > 0 ? LSLM : IDW);
}
void set_mode(void) {
int i, j, check_failed = 0;
if (method == NSP)
return;
/*
* simple, univariate:
*/
if (get_n_vars() <= 1) {
mode = SIMPLE;
return;
}
/*
* (get_n_vars() > 1):
* multivariable prediction if all cross variograms set parameters merge
*/
for (i = check_failed = 0; i < get_n_vars(); i++)
for (j = 0; j < i; j++)
if (vgm[LTI(i,j)] == NULL || vgm[LTI(i,j)]->id < 0)
check_failed = 1;
if (check_failed == 0) {
mode = MULTIVARIABLE;
return;
}
if (n_variograms_set() == 0) {
for (i = 0; i < get_n_vars(); i++)
if (data[i]->n_merge > 0) {
mode = MULTIVARIABLE;
return;
}
}
/*
* stratify? ONLY if:
* 0. get_n_vars() > 1; no cross variograms set ==>> has been checked.
* 1. no pred(): or var(): except for first variable;
* 2. No masks and valdata->what_is_u == U_ISSTRATUM
* 3. mask is a valid strata map, n categories > 1
*/
mode = (valdata->what_is_u == U_ISSTRATUM) ? STRATIFY : SIMPLE;
return;
}
static void do_variogram(int nvars, METHOD m) {
int i, j;
VARIOGRAM *vp = NULL;
if (nvars == 0)
return;
for (i = 0; i < nvars; i++) {
for (j = i; j >= 0; j--) {
vp = get_vgm(LTI(i,j)); /* */
vp->id1 = j;
vp->id2 = i;
if (m == COV)
vp->ev->evt = (i != j) ? CROSSCOVARIOGRAM : COVARIOGRAM;
else
vp->ev->evt = (i != j) ? CROSSVARIOGRAM : SEMIVARIOGRAM;
if (vp->fname != NULL || o_filename != NULL) {
calc_variogram(vp, vp->fname ? vp->fname : o_filename);
if (vp->n_models > 0 && gl_fit) {
vp->ev->fit = fit_int2enum(gl_fit);
if (fit_variogram(vp))
pr_warning("error during variogram fit");
else
logprint_variogram(vp, 1);
}
}
}
}
if (plotfile) {
if (nvars > 1)
ErrMsg(ER_IMPOSVAL, "plot file only works for single variable");
if (vp->ev->map)
ErrMsg(ER_IMPOSVAL, "cannot make plot file for variogram map");
if (gl_jgraph)
fprint_jgraph_variogram(plotfile, vp);
else
fprint_gnuplot_variogram(plotfile, vp, "gnuplot.out", GNUPLOT, 0);
}
}
/*
* 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 = MNULL, *R = MNULL;
static VEC *blup = VNULL, *tmpa = VNULL, *tmpb = VNULL;
PERM *piv = PNULL;
volatile unsigned int i, rows_C;
unsigned int j, k, l = 0, row, col, start_i, start_j, start_X, global,
one_nbh_empty;
VARIOGRAM *v = NULL;
static enum GLS_WHAT last_pred = GLS_INIT; /* the initial value */
double c_value, *X_ori;
int info;
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;
}
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));
ME(MSPE, i, j) = ME(MSPE, 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, one_nbh_empty = 0; i < n_vars; i++) {
rows_C += d[i]->n_sel;
if (d[i]->n_sel == 0)
one_nbh_empty = 1;
}
if (rows_C == 0 /* all selection lists empty */
|| one_nbh_empty == 1) { /* one selection list empty */
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
&& d[i]->n_list == d[i]->n_sel);
/*
* 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 || !global || rows_C > glm->C->m) {
/*
* fill y:
*/
glm->y = get_y(d, glm->y, n_vars);
if (pred != UPDATE) {
glm->C = m_resize(glm->C, rows_C, rows_C);
if (gl_choleski == 0) /* use LDL' decomposition, allocate piv: */
piv = px_resize(piv, rows_C);
m_zero(glm->C);
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;
ME(glm->C, col, row) = c_value; /* fill upper */
if (col != row)
ME(glm->C, row, col) = c_value; /* fill all */
} /* 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()]");
M_DEBUG(glm->C, "Covariances (x_i, x_j) matrix C (upper triangle)");
/*
* factorize C:
*/
CHfactor(glm->C, piv, &info);
if (info != 0) { /* singular: */
pr_warning("Covariance matrix 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 */
P_FREE(piv);
return;
}
if (piv == NULL)
M_DEBUG(glm->C, "glm->C, Choleski decomposed:")
else
M_DEBUG(glm->C, "glm->C, LDL' decomposed:")
} /* if (pred != UPDATE) */
int remove_id(const int id) {
/*
* remove id id, and reset data, vgm, ids, outfile_names
*/
int i, j, id_new, id_old;
VARIOGRAM *vp;
assert(id >= 0 && id < n_vars);
/* reset data */
free_data(data[id]);
data[id] = NULL;
for (i = id; i < n_vars - 1; i++) {
data[i] = data[i+1];
data[i]->id = i;
}
for (i = 0; i < n_vars; i++) {
j = LTI(i,id);
if (vgm[j]) {
free_variogram(vgm[j]);
vgm[j] = NULL;
}
}
/* copy variograms: */
for (i = id; i < n_vars - 1; i++) {
for (j = id; j <= i; j++) {
id_new = LTI(i,j);
id_old = LTI(i+1,j+1);
vp = vgm[id_new] = vgm[id_old];
if ((vp != NULL) && (vp->id1 >= 0 || vp->id2 >= 0)) {
vp->id1 = i;
vp->id2 = j;
vp->id = id_new;
}
}
}
/* reset identifiers: */
efree(ids[id]);
for (i = id; i < n_vars - 1; i++)
ids[i] = ids[i+1];
/* free outfilenames */
if (outfile_names[2 * id]) {
efree(outfile_names[2 * id]);
outfile_names[2 * id] = NULL;
}
if (outfile_names[2 * id + 1]) {
efree(outfile_names[2 * id + 1]);
outfile_names[2 * id + 1] = NULL;
}
/* shift pred(xx)/variances(xx) names: */
for (i = id; i < n_vars - 1; i++) {
outfile_names[2 * i] = outfile_names[2 * (i + 1)];
outfile_names[2 * i + 1] = outfile_names[2 * (i + 1) + 1];
}
/* shift covariances(xx): */
for (i = id; i < n_vars - 1; i++) {
id_old = 2 * n_vars + LTI2(i,id);
if (outfile_names[id_old]) {
efree(outfile_names[id_old]);
outfile_names[id_old] = NULL;
}
for (j = id; j < i; j++) {
id_new = 2 * (n_vars - 1) + LTI2(i,j);
id_old = 2 * n_vars + LTI2(i+1,j+1);
outfile_names[id_new] = outfile_names[id_old];
}
}
n_vars -= 1;
if (n_vars == 0)
clean_up();
init_gstat_data(n_vars); /* reset sizes */
return n_vars;
}
void check_global_variables(void) {
/*
* Purpose : check internal variable consistency, add some parameters
* Created by : Edzer J. Pebesma
* Date : april 13, 1992
* Prerequisites : none
* Returns : -
* Side effects : none
* also check Cauchy-Schwartz unequality on cross/variograms.
*/
int i, j, nposX, n_merge = 0;
METHOD m;
VARIOGRAM *v_tmp;
/* UK: check if n_masks equals total nr of unbiasedness cond. */
if (gl_nblockdiscr < 2)
ErrMsg(ER_RANGE, "nblockdiscr must be >= 2");
if (method == UKR || method == LSLM) {
nposX = 0;
for (i = 0; i < get_n_vars(); i++)
for (j = 0; j < data[i]->n_X; j++) {
if (data[i]->colX[j] > 0)
nposX++;
}
}
if (method == SPREAD) {
for (i = 0; i < get_n_vars(); i++)
if (data[i]->sel_rad == DBL_MAX)
data[i]->sel_rad *= 0.99; /* force distance calculation */
}
if (get_n_beta_set() != 0 && get_n_beta_set() != get_n_vars())
ErrMsg(ER_SYNTAX,
"set sk_mean or beta either for all or for no variables");
if (!(method == ISI || method == GSI)) {
if (gl_nsim > 1)
ErrMsg(ER_IMPOSVAL, "nsim only allowed for simulation");
}
if (method == ISI && max_block_dimension(0) > 0.0)
ErrMsg(ER_IMPOSVAL, "indicator simulation only for points");
/*
* check if both block and area are set
*/
if (data_area != NULL && (block.x > 0.0 || block.y > 0.0 || block.z > 0.0))
ErrMsg(ER_IMPOSVAL, "both block and area set: choose one");
/*
* check for equality of coordinate dimensions:
*/
for (i = 1; i < get_n_vars(); i++) {
if ((data[i]->mode & V_BIT_SET) != (data[0]->mode & V_BIT_SET)) {
message("data(%s) and data(%s):\n", name_identifier(0),
name_identifier(i));
ErrMsg(ER_IMPOSVAL, "data have different coordinate dimensions");
}
}
if (valdata->id > 0 && data[0]->dummy == 0 &&
((data[0]->mode | (V_BIT_SET | S_BIT_SET)) !=
(valdata->mode | (V_BIT_SET | S_BIT_SET)))) {
message("data() and data(%s):\n", name_identifier(0));
ErrMsg(ER_IMPOSVAL, "data have different coordinate dimensions");
for (i = 0; i < get_n_vars(); i++) {
if (data[i]->dummy) {
data[i]->mode = (valdata->mode | V_BIT_SET);
data[i]->minX = valdata->minX;
data[i]->minY = valdata->minY;
data[i]->minZ = valdata->minZ;
data[i]->maxX = valdata->maxX;
data[i]->maxY = valdata->maxY;
data[i]->maxZ = valdata->maxZ;
set_norm_fns(data[i]);
}
}
}
for (i = 0; i < get_n_vars(); i++) {
if (data[i]->fname == NULL && !data[i]->dummy) {
message("file name for data(%s) not set\n", name_identifier(i));
ErrMsg(ER_NULL, " ");
}
if (data[i]->id < 0) {
message("data(%s) not set\n", name_identifier(i));
ErrMsg(ER_NULL, " ");
}
if (data[i]->beta && data[i]->beta->size != data[i]->n_X) {
pr_warning("beta dimension (%d) should equal n_X (%d)",
data[i]->beta->size, data[i]->n_X);
ErrMsg(ER_IMPOSVAL, "sizes of beta and X don't match");
}
if (data[i]->sel_rad == DBL_MAX && data[i]->oct_max > 0)
ErrMsg(ER_IMPOSVAL,
"define maximum search radius (rad) for octant search");
if (data[i]->vdist && data[i]->sel_rad == DBL_MAX)
ErrMsg(ER_IMPOSVAL, "when using vdist, radius should be set");
if (! data[i]->dummy && ! (data[i]->mode & V_BIT_SET)) {
message("no v attribute set for data(%s)\n",
name_identifier(data[i]->id));
ErrMsg(ER_NULL, " ");
}
if (method != SEM && method != COV) {
/* check neighbourhood settings */
if (data[i]->sel_rad < 0.0 || data[i]->sel_min < 0 ||
data[i]->sel_max < 0 || (data[i]->sel_min > data[i]->sel_max)) {
message(
"invalid neighbourhood selection: radius %g max %d min %d\n",
data[i]->sel_rad, data[i]->sel_max, data[i]->sel_min);
ErrMsg(ER_IMPOSVAL, " ");
}
}
if (data[i]->id > -1 && (method == OKR || method == SKR ||
is_simulation(method) || method == UKR)) {
if (vgm[LTI(i,i)] == NULL || vgm[LTI(i,i)]->id < 0) {
message("variogram(%s) not set\n", name_identifier(i));
ErrMsg(ER_VARNOTSET, "variogram()");
}
}
n_merge += data[i]->n_merge;
}
if (n_merge && get_mode() != MULTIVARIABLE)
ErrMsg(ER_IMPOSVAL, "merge only works in multivariable mode");
if (mode == SIMPLE && get_method() != UIF) { /* check if it's clean: */
for (i = 0; i < get_n_vars(); i++)
for (j = 0; j < i; j++)
if (vgm[LTI(i,j)] != NULL && vgm[LTI(i,j)]->id > 0) {
message("variogram(%s, %s) %s\n", name_identifier(i),
name_identifier(j),
"can only be set for ck, cs, uk, sk, ok, sem or cov");
ErrMsg(ER_IMPOSVAL, "variogram()");
}
}
if ((m = get_default_method()) != get_method()) {
if (m == UKR && (get_method() == OKR || get_method() == SKR))
ErrMsg(ER_IMPOSVAL,
"\nremove X=... settings for ordinary or simple kriging");
if (m == OKR && get_method() == SKR)
ErrMsg(ER_IMPOSVAL, "method: something's terribly wrong!");
if (m == OKR && get_method() == UKR) {
message("I would recommend:\n");
message("Do not specify uk if ok is all you'll get\n");
}
}
if (mode == MULTIVARIABLE && get_method() != UIF && get_method() != SEM
&& get_method() != COV && n_variograms_set() > 0)
check_variography((const VARIOGRAM **) vgm, get_n_vars());
v_tmp = init_variogram(NULL);
free_variogram(v_tmp);
}
void check_variography(const VARIOGRAM **v, int n_vars)
/*
* check for intrinsic correlation, linear model of coregionalisation
* or else (with warning) Cauchy Swartz
*/
{
int i, j, k, ic = 0, lmc, posdef = 1;
MAT **a = NULL;
double b;
char *reason = NULL;
if (n_vars <= 1)
return;
/*
* find out if lmc (linear model of coregionalization) hold:
* all models must have equal base models (sequence and range)
*/
for (i = 1, lmc = 1; lmc && i < get_n_vgms(); i++) {
if (v[0]->n_models != v[i]->n_models) {
reason = "number of models differ";
lmc = 0;
}
for (k = 0; lmc && k < v[0]->n_models; k++) {
if (v[0]->part[k].model != v[i]->part[k].model) {
reason = "model types differ";
lmc = 0;
}
if (v[0]->part[k].range[0] != v[i]->part[k].range[0]) {
reason = "ranges differ";
lmc = 0;
}
}
for (k = 0; lmc && k < v[0]->n_models; k++)
if (v[0]->part[k].tm_range != NULL) {
if (v[i]->part[k].tm_range == NULL) {
reason = "anisotropy for part of models";
lmc = 0;
} else if (
v[0]->part[k].tm_range->ratio[0] != v[i]->part[k].tm_range->ratio[0] ||
v[0]->part[k].tm_range->ratio[1] != v[i]->part[k].tm_range->ratio[1] ||
v[0]->part[k].tm_range->angle[0] != v[i]->part[k].tm_range->angle[0] ||
v[0]->part[k].tm_range->angle[1] != v[i]->part[k].tm_range->angle[1] ||
v[0]->part[k].tm_range->angle[2] != v[i]->part[k].tm_range->angle[2]
) {
reason = "anisotropy parameters are not equal";
lmc = 0;
}
} else if (v[i]->part[k].tm_range != NULL) {
reason = "anisotropy for part of models";
lmc = 0;
}
}
if (lmc) {
/*
* check for ic:
*/
a = (MAT **) emalloc(v[0]->n_models * sizeof(MAT *));
for (k = 0; k < v[0]->n_models; k++)
a[k] = m_get(n_vars, n_vars);
for (i = 0; i < n_vars; i++) {
for (j = 0; j < n_vars; j++) { /* for all variogram triplets: */
for (k = 0; k < v[0]->n_models; k++)
ME(a[k], i, j) = v[LTI(i,j)]->part[k].sill;
}
}
/* for ic: a's must be scaled versions of each other: */
ic = 1;
for (k = 1, ic = 1; ic && k < v[0]->n_models; k++) {
b = ME(a[0], 0, 0)/ME(a[k], 0, 0);
for (i = 0; ic && i < n_vars; i++)
for (j = 0; ic && j < n_vars; j++)
if (fabs(ME(a[0], i, j) / ME(a[k], i, j) - b) > EPSILON)
ic = 0;
}
/* check posdef matrices */
for (i = 0, lmc = 1, posdef = 1; i < v[0]->n_models; i++) {
posdef = is_posdef(a[i]);
if (posdef == 0) {
reason = "coefficient matrix not positive definite";
if (DEBUG_COV) {
printlog("non-positive definite coefficient matrix %d:\n",
i);
m_logoutput(a[i]);
}
ic = lmc = 0;
}
if (! posdef)
printlog(
"non-positive definite coefficient matrix in structure %d",
i+1);
}
for (k = 0; k < v[0]->n_models; k++)
m_free(a[k]);
efree(a);
if (ic) {
printlog("Intrinsic Correlation found. Good.\n");
return;
} else if (lmc) {
printlog("Linear Model of Coregionalization found. Good.\n");
return;
}
}
/*
* lmc does not hold: check on Cauchy Swartz
*/
pr_warning("No Intrinsic Correlation or Linear Model of Coregionalization found\nReason: %s", reason ? reason : "unknown");
if (gl_nocheck == 0) {
pr_warning("[add `set = list(nocheck = 1)' to the gstat() or krige() to ignore the following error]\n");
ErrMsg(ER_IMPOSVAL, "variograms do not satisfy a legal model");
}
printlog("Now checking for Cauchy-Schwartz inequalities:\n");
for (i = 0; i < n_vars; i++)
for (j = 0; j < i; j++)
if (is_valid_cs(v[LTI(i,i)], v[LTI(j,j)], v[LTI(i,j)])) {
printlog("variogram(%s,%s) passed Cauchy-Schwartz\n",
name_identifier(j), name_identifier(i));
} else
pr_warning("Cauchy-Schwartz inequality found for variogram(%s,%s)",
name_identifier(j), name_identifier(i) );
return;
}
/*
* 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 */
