void do_force(FILE *fplog,t_commrec *cr,
t_inputrec *inputrec,
int step,t_nrnb *nrnb,gmx_wallcycle_t wcycle,
gmx_localtop_t *top,
gmx_groups_t *groups,
matrix box,rvec x[],history_t *hist,
rvec f[],rvec buf[],
tensor vir_force,
t_mdatoms *mdatoms,
gmx_enerdata_t *enerd,t_fcdata *fcd,
real lambda,t_graph *graph,
t_forcerec *fr,gmx_vsite_t *vsite,rvec mu_tot,
real t,FILE *field,gmx_edsam_t ed,
int flags)
{
static rvec box_size;
int cg0,cg1,i,j;
int start,homenr;
static double mu[2*DIM];
rvec mu_tot_AB[2];
bool bSepDVDL,bStateChanged,bNS,bFillGrid,bCalcCGCM,bBS,bDoForces;
matrix boxs;
real e,v,dvdl;
t_pbc pbc;
float cycles_ppdpme,cycles_pme,cycles_force;
start = mdatoms->start;
homenr = mdatoms->homenr;
bSepDVDL = (fr->bSepDVDL && do_per_step(step,inputrec->nstlog));
clear_mat(vir_force);
if (PARTDECOMP(cr)) {
pd_cg_range(cr,&cg0,&cg1);
} else {
cg0 = 0;
if (DOMAINDECOMP(cr))
cg1 = cr->dd->ncg_tot;
else
cg1 = top->cgs.nr;
if (fr->n_tpi > 0)
cg1--;
}
bStateChanged = (flags & GMX_FORCE_STATECHANGED);
bNS = (flags & GMX_FORCE_NS);
bFillGrid = (bNS && bStateChanged);
bCalcCGCM = (bFillGrid && !DOMAINDECOMP(cr));
bDoForces = (flags & GMX_FORCE_FORCES);
if (bStateChanged) {
update_forcerec(fplog,fr,box);
/* Calculate total (local) dipole moment in a temporary common array.
* This makes it possible to sum them over nodes faster.
*/
calc_mu(start,homenr,
x,mdatoms->chargeA,mdatoms->chargeB,mdatoms->nChargePerturbed,
mu,mu+DIM);
}
if (fr->ePBC != epbcNONE) {
/* Compute shift vectors every step,
* because of pressure coupling or box deformation!
*/
if (DYNAMIC_BOX(*inputrec) && bStateChanged)
calc_shifts(box,fr->shift_vec);
if (bCalcCGCM) {
put_charge_groups_in_box(fplog,cg0,cg1,fr->ePBC,box,
&(top->cgs),x,fr->cg_cm);
inc_nrnb(nrnb,eNR_CGCM,homenr);
inc_nrnb(nrnb,eNR_RESETX,cg1-cg0);
}
else if (EI_ENERGY_MINIMIZATION(inputrec->eI) && graph) {
unshift_self(graph,box,x);
}
}
else if (bCalcCGCM) {
calc_cgcm(fplog,cg0,cg1,&(top->cgs),x,fr->cg_cm);
inc_nrnb(nrnb,eNR_CGCM,homenr);
}
if (bCalcCGCM) {
if (PAR(cr)) {
move_cgcm(fplog,cr,fr->cg_cm);
}
if (gmx_debug_at)
pr_rvecs(debug,0,"cgcm",fr->cg_cm,top->cgs.nr);
}
#ifdef GMX_MPI
if (!(cr->duty & DUTY_PME)) {
/* Send particle coordinates to the pme nodes.
* Since this is only implemented for domain decomposition
* and domain decomposition does not use the graph,
* we do not need to worry about shifting.
*/
wallcycle_start(wcycle,ewcPP_PMESENDX);
GMX_MPE_LOG(ev_send_coordinates_start);
bBS = (inputrec->nwall == 2);
if (bBS) {
copy_mat(box,boxs);
svmul(inputrec->wall_ewald_zfac,boxs[ZZ],boxs[ZZ]);
}
gmx_pme_send_x(cr,bBS ? boxs : box,x,mdatoms->nChargePerturbed,lambda);
GMX_MPE_LOG(ev_send_coordinates_finish);
wallcycle_stop(wcycle,ewcPP_PMESENDX);
}
#endif /* GMX_MPI */
/* Communicate coordinates and sum dipole if necessary */
if (PAR(cr)) {
wallcycle_start(wcycle,ewcMOVEX);
if (DOMAINDECOMP(cr)) {
dd_move_x(cr->dd,box,x,buf);
} else {
move_x(fplog,cr,GMX_LEFT,GMX_RIGHT,x,nrnb);
}
/* When we don't need the total dipole we sum it in global_stat */
if (NEED_MUTOT(*inputrec))
gmx_sumd(2*DIM,mu,cr);
wallcycle_stop(wcycle,ewcMOVEX);
}
for(i=0; i<2; i++)
for(j=0;j<DIM;j++)
mu_tot_AB[i][j] = mu[i*DIM + j];
if (fr->efep == efepNO)
copy_rvec(mu_tot_AB[0],mu_tot);
else
for(j=0; j<DIM; j++)
mu_tot[j] = (1.0 - lambda)*mu_tot_AB[0][j] + lambda*mu_tot_AB[1][j];
/* Reset energies */
reset_energies(&(inputrec->opts),fr,bNS,enerd,MASTER(cr));
if (bNS) {
wallcycle_start(wcycle,ewcNS);
if (graph && bStateChanged)
/* Calculate intramolecular shift vectors to make molecules whole */
mk_mshift(fplog,graph,fr->ePBC,box,x);
/* Reset long range forces if necessary */
if (fr->bTwinRange) {
clear_rvecs(fr->f_twin_n,fr->f_twin);
clear_rvecs(SHIFTS,fr->fshift_twin);
}
/* Do the actual neighbour searching and if twin range electrostatics
* also do the calculation of long range forces and energies.
*/
dvdl = 0;
ns(fplog,fr,x,f,box,groups,&(inputrec->opts),top,mdatoms,
cr,nrnb,step,lambda,&dvdl,&enerd->grpp,bFillGrid,bDoForces);
if (bSepDVDL)
fprintf(fplog,sepdvdlformat,"LR non-bonded",0,dvdl);
enerd->dvdl_lr = dvdl;
enerd->term[F_DVDL] += dvdl;
wallcycle_stop(wcycle,ewcNS);
}
if (DOMAINDECOMP(cr)) {
if (!(cr->duty & DUTY_PME)) {
wallcycle_start(wcycle,ewcPPDURINGPME);
dd_force_flop_start(cr->dd,nrnb);
}
}
/* Start the force cycle counter.
* This counter is stopped in do_forcelow_level.
* No parallel communication should occur while this counter is running,
* since that will interfere with the dynamic load balancing.
*/
wallcycle_start(wcycle,ewcFORCE);
if (bDoForces) {
/* Reset PME/Ewald forces if necessary */
if (fr->bF_NoVirSum)
{
GMX_BARRIER(cr->mpi_comm_mygroup);
if (fr->bDomDec)
clear_rvecs(fr->f_novirsum_n,fr->f_novirsum);
else
clear_rvecs(homenr,fr->f_novirsum+start);
GMX_BARRIER(cr->mpi_comm_mygroup);
}
/* Copy long range forces into normal buffers */
if (fr->bTwinRange) {
for(i=0; i<fr->f_twin_n; i++)
copy_rvec(fr->f_twin[i],f[i]);
for(i=0; i<SHIFTS; i++)
copy_rvec(fr->fshift_twin[i],fr->fshift[i]);
}
else {
if (DOMAINDECOMP(cr))
clear_rvecs(cr->dd->nat_tot,f);
else
clear_rvecs(mdatoms->nr,f);
clear_rvecs(SHIFTS,fr->fshift);
}
clear_rvec(fr->vir_diag_posres);
GMX_BARRIER(cr->mpi_comm_mygroup);
}
if (inputrec->ePull == epullCONSTRAINT)
clear_pull_forces(inputrec->pull);
/* update QMMMrec, if necessary */
if(fr->bQMMM)
update_QMMMrec(cr,fr,x,mdatoms,box,top);
if ((flags & GMX_FORCE_BONDED) && top->idef.il[F_POSRES].nr > 0) {
/* Position restraints always require full pbc */
set_pbc(&pbc,inputrec->ePBC,box);
v = posres(top->idef.il[F_POSRES].nr,top->idef.il[F_POSRES].iatoms,
top->idef.iparams_posres,
(const rvec*)x,fr->f_novirsum,fr->vir_diag_posres,
inputrec->ePBC==epbcNONE ? NULL : &pbc,lambda,&dvdl,
fr->rc_scaling,fr->ePBC,fr->posres_com,fr->posres_comB);
if (bSepDVDL) {
fprintf(fplog,sepdvdlformat,
interaction_function[F_POSRES].longname,v,dvdl);
}
enerd->term[F_POSRES] += v;
enerd->term[F_DVDL] += dvdl;
inc_nrnb(nrnb,eNR_POSRES,top->idef.il[F_POSRES].nr/2);
}
/* Compute the bonded and non-bonded forces */
do_force_lowlevel(fplog,step,fr,inputrec,&(top->idef),
cr,nrnb,wcycle,mdatoms,&(inputrec->opts),
x,hist,f,enerd,fcd,box,lambda,graph,&(top->excls),mu_tot_AB,
flags,&cycles_force);
GMX_BARRIER(cr->mpi_comm_mygroup);
if (ed) {
do_flood(fplog,cr,x,f,ed,box,step);
}
if (DOMAINDECOMP(cr)) {
dd_force_flop_stop(cr->dd,nrnb);
if (wcycle)
dd_cycles_add(cr->dd,cycles_force,ddCyclF);
}
if (bDoForces) {
/* Compute forces due to electric field */
calc_f_el(MASTER(cr) ? field : NULL,
start,homenr,mdatoms->chargeA,x,f,inputrec->ex,inputrec->et,t);
/* When using PME/Ewald we compute the long range virial there.
* otherwise we do it based on long range forces from twin range
* cut-off based calculation (or not at all).
*/
/* Communicate the forces */
if (PAR(cr)) {
wallcycle_start(wcycle,ewcMOVEF);
if (DOMAINDECOMP(cr)) {
dd_move_f(cr->dd,f,buf,fr->fshift);
/* Position restraint do not introduce inter-cg forces */
if (EEL_FULL(fr->eeltype) && cr->dd->n_intercg_excl)
dd_move_f(cr->dd,fr->f_novirsum,buf,NULL);
} else {
move_f(fplog,cr,GMX_LEFT,GMX_RIGHT,f,buf,nrnb);
}
wallcycle_stop(wcycle,ewcMOVEF);
}
}
if (bDoForces) {
if (vsite) {
wallcycle_start(wcycle,ewcVSITESPREAD);
spread_vsite_f(fplog,vsite,x,f,fr->fshift,nrnb,
&top->idef,fr->ePBC,fr->bMolPBC,graph,box,cr);
wallcycle_stop(wcycle,ewcVSITESPREAD);
}
/* Calculation of the virial must be done after vsites! */
calc_virial(fplog,mdatoms->start,mdatoms->homenr,x,f,
vir_force,graph,box,nrnb,fr,inputrec->ePBC);
}
if (inputrec->ePull == epullUMBRELLA || inputrec->ePull == epullCONST_F) {
/* Calculate the center of mass forces, this requires communication,
* which is why pull_potential is called close to other communication.
* The virial contribution is calculated directly,
* which is why we call pull_potential after calc_virial.
*/
set_pbc(&pbc,inputrec->ePBC,box);
dvdl = 0;
enerd->term[F_COM_PULL] =
pull_potential(inputrec->ePull,inputrec->pull,mdatoms,&pbc,
cr,t,lambda,x,f,vir_force,&dvdl);
if (bSepDVDL)
fprintf(fplog,sepdvdlformat,"Com pull",enerd->term[F_COM_PULL],dvdl);
enerd->term[F_DVDL] += dvdl;
}
if (!(cr->duty & DUTY_PME)) {
cycles_ppdpme = wallcycle_stop(wcycle,ewcPPDURINGPME);
dd_cycles_add(cr->dd,cycles_ppdpme,ddCyclPPduringPME);
}
#ifdef GMX_MPI
if (PAR(cr) && !(cr->duty & DUTY_PME)) {
/* In case of node-splitting, the PP nodes receive the long-range
* forces, virial and energy from the PME nodes here.
*/
wallcycle_start(wcycle,ewcPP_PMEWAITRECVF);
dvdl = 0;
gmx_pme_receive_f(cr,fr->f_novirsum,fr->vir_el_recip,&e,&dvdl,
&cycles_pme);
if (bSepDVDL)
fprintf(fplog,sepdvdlformat,"PME mesh",e,dvdl);
enerd->term[F_COUL_RECIP] += e;
enerd->term[F_DVDL] += dvdl;
if (wcycle)
dd_cycles_add(cr->dd,cycles_pme,ddCyclPME);
wallcycle_stop(wcycle,ewcPP_PMEWAITRECVF);
}
#endif
if (bDoForces && fr->bF_NoVirSum) {
if (vsite) {
/* Spread the mesh force on virtual sites to the other particles...
* This is parallellized. MPI communication is performed
* if the constructing atoms aren't local.
*/
wallcycle_start(wcycle,ewcVSITESPREAD);
spread_vsite_f(fplog,vsite,x,fr->f_novirsum,NULL,nrnb,
&top->idef,fr->ePBC,fr->bMolPBC,graph,box,cr);
wallcycle_stop(wcycle,ewcVSITESPREAD);
}
/* Now add the forces, this is local */
if (fr->bDomDec) {
sum_forces(0,fr->f_novirsum_n,f,fr->f_novirsum);
} else {
sum_forces(start,start+homenr,f,fr->f_novirsum);
}
if (EEL_FULL(fr->eeltype)) {
/* Add the mesh contribution to the virial */
m_add(vir_force,fr->vir_el_recip,vir_force);
}
if (debug)
pr_rvecs(debug,0,"vir_force",vir_force,DIM);
}
/* Sum the potential energy terms from group contributions */
sum_epot(&(inputrec->opts),enerd);
if (fr->print_force >= 0 && bDoForces)
print_large_forces(stderr,mdatoms,cr,step,fr->print_force,x,f);
}
int main(int argc, char *argv[])
{
int i, j; /* Loop control variables */
int bands; /* Number of image bands */
double *mu; /* Mean vector for image bands */
double **covar; /* Covariance Matrix */
double *eigval;
double **eigmat;
int *inp_fd;
int scale, scale_max, scale_min;
struct GModule *module;
struct Option *opt_in, *opt_out, *opt_scale;
/* initialize GIS engine */
G_gisinit(argv[0]);
module = G_define_module();
G_add_keyword(_("imagery"));
G_add_keyword(_("image transformation"));
G_add_keyword(_("PCA"));
module->description = _("Principal components analysis (PCA) "
"for image processing.");
/* Define options */
opt_in = G_define_standard_option(G_OPT_R_INPUTS);
opt_in->description = _("Name of two or more input raster maps");
opt_out = G_define_option();
opt_out->label = _("Base name for output raster maps");
opt_out->description =
_("A numerical suffix will be added for each component map");
opt_out->key = "output_prefix";
opt_out->type = TYPE_STRING;
opt_out->key_desc = "string";
opt_out->required = YES;
opt_scale = G_define_option();
opt_scale->key = "rescale";
opt_scale->type = TYPE_INTEGER;
opt_scale->key_desc = "min,max";
opt_scale->required = NO;
opt_scale->answer = "0,255";
opt_scale->label =
_("Rescaling range for output maps");
opt_scale->description =
_("For no rescaling use 0,0");
opt_scale->guisection = _("Rescale");
if (G_parser(argc, argv))
exit(EXIT_FAILURE);
/* determine number of bands passed in */
for (bands = 0; opt_in->answers[bands] != NULL; bands++) ;
if (bands < 2)
G_fatal_error(_("Sorry, at least 2 input bands must be provided"));
/* default values */
scale = 1;
scale_min = 0;
scale_max = 255;
/* get scale parameters */
set_output_scale(opt_scale, &scale, &scale_min, &scale_max);
/* allocate memory */
covar = G_alloc_matrix(bands, bands);
mu = G_alloc_vector(bands);
inp_fd = G_alloc_ivector(bands);
eigmat = G_alloc_matrix(bands, bands);
eigval = G_alloc_vector(bands);
/* open and check input/output files */
for (i = 0; i < bands; i++) {
char tmpbuf[128];
sprintf(tmpbuf, "%s.%d", opt_out->answer, i + 1);
G_check_input_output_name(opt_in->answers[i], tmpbuf, GR_FATAL_EXIT);
inp_fd[i] = Rast_open_old(opt_in->answers[i], "");
}
G_verbose_message(_("Calculating covariance matrix..."));
calc_mu(inp_fd, mu, bands);
calc_covariance(inp_fd, covar, mu, bands);
for (i = 0; i < bands; i++) {
for (j = 0; j < bands; j++) {
covar[i][j] =
covar[i][j] /
((double)((Rast_window_rows() * Rast_window_cols()) - 1));
G_debug(3, "covar[%d][%d] = %f", i, j, covar[i][j]);
}
}
G_math_d_copy(covar[0], eigmat[0], bands*bands);
G_debug(1, "Calculating eigenvalues and eigenvectors...");
G_math_eigen(eigmat, eigval, bands);
#ifdef PCA_DEBUG
/* dump eigen matrix and eigen values */
dump_eigen(bands, eigmat, eigval);
#endif
G_debug(1, "Ordering eigenvalues in descending order...");
G_math_egvorder(eigval, eigmat, bands);
G_debug(1, "Transposing eigen matrix...");
G_math_d_A_T(eigmat, bands);
/* write output images */
write_pca(eigmat, inp_fd, opt_out->answer, bands, scale, scale_min,
scale_max);
/* write colors and history to output */
for (i = 0; i < bands; i++) {
char outname[80];
sprintf(outname, "%s.%d", opt_out->answer, i + 1);
/* write colors and history to file */
write_support(bands, outname, eigmat, eigval);
/* close output file */
Rast_unopen(inp_fd[i]);
}
/* free memory */
G_free_matrix(covar);
G_free_vector(mu);
G_free_ivector(inp_fd);
G_free_matrix(eigmat);
G_free_vector(eigval);
exit(EXIT_SUCCESS);
}
/*
* 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 */
