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); } }
int ossfim(int argc, char *argv[]) { int c, n = 25, dx = 9, dy = 9, i, j, plot_vgm = 0; double b = 1, B = 10, s = 1, S = 10, blocksize, samplespacing, est[2], **table; DATA **d = NULL; DPOINT *block = NULL, where; char *vgm_str = "1Exp(10)", *map_name = NULL; VARIOGRAM *vgm; while ((c = getopt(argc, argv, "n:m:B:b:S:s:V:v:x:y:")) != EOF) { switch (c) { case 'n': if (read_int(optarg, &n) || n <= 0) ErrMsg(ER_ARGOPT, "n"); break; case 'b': if (read_double(optarg, &b) || b < 0) ErrMsg(ER_ARGOPT, "b"); break; case 'B': if (read_double(optarg, &B) || B <= 0) ErrMsg(ER_ARGOPT, "B"); break; case 's': if (read_double(optarg, &s) || s <= 0) ErrMsg(ER_ARGOPT, "s"); break; case 'S': if (read_double(optarg, &S) || S <= 0) ErrMsg(ER_ARGOPT, "S"); break; case 'x': if (read_int(optarg, &dx) || dx <= 0) ErrMsg(ER_ARGOPT, "x"); break; case 'y': if (read_int(optarg, &dy) || dy <= 0) ErrMsg(ER_ARGOPT, "y"); break; case 'v': vgm_str = optarg; break; case 'V': plot_vgm = 1; vgm_str = optarg; break; case 'm': map_name = optarg; break; default: ErrClo(optopt); break; } } which_identifier("dummy grid"); d = get_gstat_data(); init_one_data(d[0]); d[0]->id = 0; d[0]->n_list = d[0]->n_max = 0; d[0]->mode = X_BIT_SET | Y_BIT_SET | V_BIT_SET; set_norm_fns(d[0]); vgm = get_vgm(0); if (read_variogram(vgm, vgm_str)) ErrMsg(ER_SYNTAX, vgm_str); vgm->ev->evt = SEMIVARIOGRAM; vgm->id1 = vgm->id2 = d[0]->id; block = get_block_p(); block->z = 0.0; block->x = block->y = -1.0; est[0] = 0.0; est[1] = -1.0; where.x = where.y = where.z = 0.0; where.X = (double *) emalloc(sizeof(double)); where.X[0] = 1.0; if (plot_vgm) return fprint_gnuplot_variogram(stdout, vgm, "", GIF, 0); table = (double **) emalloc((dy + 1) * sizeof(double *)); for (i = 0; i <= dy; i++) table[i] = (double *) emalloc((dx + 1) * sizeof(double)); /* do it: */ for (i = 0; i <= dx; i++) { /* sample spacing loop */ samplespacing = s + (i / (1.0 * dx)) * (S - s); generate_grid(d[0], samplespacing, n); select_at(d[0], &where); for (j = 0; j <= dy; j++) { /* block sizes loop */ reset_block_discr(); vgm_init_block_values(vgm); blocksize = b + (j / (1.0 * dy)) * (B - b); block->x = block->y = blocksize; if (blocksize == 0.0) SET_POINT(&where); else SET_BLOCK(&where); gls(d, 1, GLS_BLUP, &where, est); if (map_name) table[i][j] = sqrt(est[1]); else printlog("%g %g %g\n", samplespacing, blocksize, sqrt(est[1])); } } if (map_name) ossfim2map(table, map_name, s, S, b, B, dx, dy); return 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) */
/* * 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 */