static int reml(VEC *Y, MAT *X, MAT **Vk, int n_k, int max_iter,
double fit_limit, VEC *teta) {
volatile int n_iter = 0;
int i;
volatile double rel_step = DBL_MAX;
VEC *rhs = VNULL;
VEC *dteta = VNULL;
MAT *Vw = MNULL, *Tr_m = MNULL, *VinvIminAw = MNULL;
Vw = m_resize(Vw, X->m, X->m);
VinvIminAw = m_resize(VinvIminAw, X->m, X->m);
rhs = v_resize(rhs, n_k);
Tr_m = m_resize(Tr_m, n_k, n_k);
dteta = v_resize(dteta, n_k);
while (n_iter < max_iter && rel_step > fit_limit) {
print_progress(n_iter, max_iter);
n_iter++;
dteta = v_copy(teta, dteta);
/* fill Vw, calc VinvIminAw, rhs; */
for (i = 0, m_zero(Vw); i < n_k; i++)
ms_mltadd(Vw, Vk[i], teta->ve[i], Vw); /* Vw = Sum_i teta[i]*V[i] */
VinvIminAw = calc_VinvIminAw(Vw, X, VinvIminAw, n_iter == 1);
calc_rhs_Tr_m(n_k, Vk, VinvIminAw, Y, rhs, Tr_m);
/* Tr_m * teta = Rhs; symmetric, solve for teta: */
LDLfactor(Tr_m);
LDLsolve(Tr_m, rhs, teta);
if (DEBUG_VGMFIT) {
printlog("teta_%d [", n_iter);
for (i = 0; i < teta->dim; i++)
printlog(" %g", teta->ve[i]);
printlog("] -(log.likelyhood): %g\n",
calc_ll(Vw, X, Y, n_k));
}
v_sub(teta, dteta, dteta); /* dteta = teta_prev - teta_curr */
if (v_norm2(teta) == 0.0)
rel_step = 0.0;
else
rel_step = v_norm2(dteta) / v_norm2(teta);
} /* while (n_iter < gl_iter && rel_step > fit_limit) */
print_progress(max_iter, max_iter);
if (n_iter == gl_iter)
pr_warning("No convergence after %d iterations", n_iter);
if (DEBUG_VGMFIT) { /* calculate and report covariance matrix */
/* first, update to current est */
for (i = 0, m_zero(Vw); i < n_k; i++)
ms_mltadd(Vw, Vk[i], teta->ve[i], Vw); /* Vw = Sum_i teta[i]*V[i] */
VinvIminAw = calc_VinvIminAw(Vw, X, VinvIminAw, 0);
calc_rhs_Tr_m(n_k, Vk, VinvIminAw, Y, rhs, Tr_m);
m_inverse(Tr_m, Tr_m);
sm_mlt(2.0, Tr_m, Tr_m); /* Var(YAY)=2tr(AVAV) */
printlog("Lower bound of parameter covariance matrix:\n");
m_logoutput(Tr_m);
printlog("# Negative log-likelyhood: %g\n", calc_ll(Vw, X, Y, n_k));
}
m_free(Vw);
m_free(VinvIminAw);
m_free(Tr_m);
v_free(rhs);
v_free(dteta);
return (n_iter < max_iter && rel_step < fit_limit); /* converged? */
}
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;
}
