/** The main function.
The function implementing the algorithm described in
arXiv:hep-lat/0306017 v1 13 Jun 2003 \em Wolff, U. \em Monte Carlo errors with less errors.
*/
int UWerr_f(Tcl_Interp *interp, Tcl_CmdInfo * cmdInfo, int argc, char ** argv,
double ** data, int rows, int cols,
int * n_rep, int len, double s_tau, int plot)
{
struct UWerr_t ret;
int a, k, i, sum = 0, W_opt = 0, W_max = 0;
double Fbb = 0, bF = 0, Fb = 0, * abb = 0L, tau = 0, tmp;
double ** abr = 0L, * Fbr = 0L, * fgrad = 0L, * delpro = 0L;
double * gFbb = 0L, CFbb_opt = 0, G_int = 0, std_a;
char flag = 0;
char * str = 0L;
char * tcl_vector = 0L;
char ** my_argv;
FILE * plotDataf, * plotScriptf;
ret.Q_val = 0;
if (!data) {
Tcl_AppendElement(interp, "No data matrix given.");
return TCL_ERROR;
}
if (rows < 1) {
Tcl_AppendElement(interp, "Data matrix has no rows.");
return TCL_ERROR;
}
if (cols < 1) {
Tcl_AppendElement(interp, "Data matrix has no columns.");
return TCL_ERROR;
}
if(!cmdInfo && !cmdInfo->proc) {
Tcl_AppendElement(interp, "No function to call given.");
return TCL_ERROR;
}
if (!n_rep) {
Tcl_AppendElement(interp, "No representations vector given.");
return TCL_ERROR;
}
if (len < 1) {
Tcl_AppendElement(interp, "Representations vector is empty.");
return TCL_ERROR;
}
/* \sum_{i=1}^{len} n_rep[i-1] = rows */
k = rows; /* for now k is going to be min(n_rep) */
for (i = 0; i < len; ++i) {
sum += n_rep[i];
if (n_rep[i] < k)
k = n_rep[i];
}
if (sum != rows || k <= 0) {
Tcl_AppendElement(interp, "Representations vector is invalid.");
return TCL_ERROR;
}
if (s_tau > 0) {
W_max = (int)rint(k/2.); /* until here: k = min(n_rep) */
flag = 1;
if (W_max < 1) W_max = 1;
}
/* string for output of numbers */
str = (char *)malloc((TCL_INTEGER_SPACE + TCL_DOUBLE_SPACE)*sizeof(char));
if (!(delpro = (double*)malloc(rows*sizeof(double)))) {
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
free(str);
return TCL_ERROR;
}
if (!(Fbr = (double*)malloc(len*sizeof(double)))) {
free(delpro);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(fgrad = (double*)malloc(cols*sizeof(double)))) {
free(delpro);
free(Fbr);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(abb = (double*)malloc(cols*sizeof(double)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
/* abr \in (\Real)_{len, cols} */
if (!(abr = (double**)malloc(len*sizeof(double*)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
for (i = 0; i < len; ++i)
if (!(abr[i] = (double*)malloc(cols*sizeof(double)))) {
for (k = 0; k < i; ++k)
free(abr[k]);
free(abr);
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (W_max > 0) {
if (!(gFbb = (double*)malloc((W_max+1)*sizeof(double)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
}
if (uwerr_create_tcl_vector(&tcl_vector, cols)) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(gFbb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(my_argv=(char**)malloc((argc+1)*sizeof(char*)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(gFbb);
free(str);
uwerr_free_tcl_vector(tcl_vector);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
my_argv[0] = argv[0];
my_argv[1] = tcl_vector;
for (i = 1; i < argc; ++i)
my_argv[i+1] = argv[i];
/* first we calculate N_r\bar{a}_\alpha^r \forall r, alpha */
sum = 0;
for (k = 0; k < len; ++k) {
for (i = 0; i < n_rep[k]; ++i) {
for (a = 0; a < cols; ++a) {
if (i > 0)
abr[k][a] += data[sum + i][a];
else
abr[k][a] = data[sum][a];
}
}
sum += n_rep[k];
}
/* now we calculate \bar{\bar{a}}_\alpha \forall \alpha */
for (k = 0; k < len; ++k) {
for (a = 0; a < cols; ++a) {
if (k > 0)
abb[a] += abr[k][a];
else
abb[a] = abr[k][a];
}
}
for (a =0; a < cols; ++a)
abb[a] /= rows;
/* now we calculate \bar{a}_\alpha^r with \forall \alpha */
for (k = 0; k < len; ++k)
for (a = 0; a < cols; ++a)
abr[k][a] /= n_rep[k];
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
Fbb = strtod(Tcl_GetStringResult(interp),0);
for (k = 0; k < len; ++k) {
uwerr_write_tcl_vector(interp, abr[k], cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
Fbr[k] = strtod(Tcl_GetStringResult(interp),0);
}
Fb = UWerr_dsum_int(n_rep, Fbr, len);
Fb /= rows;
for (a = 0; a < cols; ++a) {
std_a = 0;
for (k = 0; k < rows; ++k)
std_a += (data[k][a]-abb[a])*(data[k][a]-abb[a]);
std_a = sqrt(std_a)/rows;
/* calc the gradient of f using df/da ~ (f(a+h)-f(a-h))/2*h
where h is the standard deviation divided by the sqrt of the
number of samples (= rows).
Remember: abb[a] is the average for column a of data */
if (std_a == 0)
fgrad[a] = 0;
else {
tmp = abb[a];
abb[a] += std_a;
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
fgrad[a] = strtod(Tcl_GetStringResult(interp),0);
abb[a] = tmp - std_a;
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
fgrad[a] -= strtod(Tcl_GetStringResult(interp),0);
abb[a] = tmp;
fgrad[a] /= 2*std_a;
}
}
/* calc delpro = data*fgrad - abb.*fgrad and
the mean of delpro.^2 = gFbb[0] */
tmp = UWerr_dsum_double(abb, fgrad, cols);
gFbb[0] = 0;
for (i = 0; i < rows; ++i) {
delpro[i] = 0;
for (a = 0; a < cols; a++) {
delpro[i] += data[i][a]*fgrad[a];
}
delpro[i] -= tmp;
gFbb[0] += delpro[i]*delpro[i];
}
gFbb[0] /= rows;
i = 0;
while(i < W_max) {
gFbb[i+1] = 0;
sum = 0;
for (k = 0; k < len; ++k) {
gFbb[i+1] += UWerr_dsum_double(delpro + sum, delpro + sum + i + 1, n_rep[k]-i-1);
sum += n_rep[k];
}
gFbb[i+1] /= rows-(i+1)*len;
if (flag) {
G_int += gFbb[i+1]/gFbb[0];
if (G_int <= 0)
tau = UW_EPS;
else
tau = s_tau/log((G_int+1)/G_int);
if (exp(-(i+1)/tau)-tau/sqrt((i+1)*rows) < 0) {
W_opt = i+1;
W_max = (W_max < 2*W_opt) ? W_max : 2*W_opt;
flag = 0;
}
}
++i;
}
--i;
if (flag) {
W_opt = W_max;
sprintf(str, "%d", W_max);
Tcl_AppendResult(interp, "Windowing condition failed up to W = ", str, ".\n", (char *)NULL);
}
ret.W = W_opt;
CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt))/rows;
for (k = 0; k < i; ++k)
gFbb[k] += CFbb_opt;
CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt));
ret.dvalue = sqrt(CFbb_opt/rows); /* sigmaF */
if (len >= 2) {
bF = (Fb-Fbb)/(len-1);
Fbb -= bF;
if (fabs(bF) > ret.dvalue/4) {
Tcl_PrintDouble(interp, bF/ret.dvalue, str);
Tcl_AppendResult(interp, "A ", str, " sigma bias of the mean has been cancelled./n", (char *)NULL);
}
for (i = 0; i < len; ++i)
Fbr[i] -= bF*rows/n_rep[i];
Fb -= bF*len;
ret.bias = bF/ret.dvalue;
}
ret.tau_int = 0;
for (i = 0; i <= W_opt; ++i)
ret.tau_int += gFbb[i];
ret.tau_int /= gFbb[0];
ret.tau_int -= .5;
ret.value = Fbb;
ret.ddvalue = ret.dvalue*sqrt((W_opt + .5)/rows);
ret.dtau_int = 2 * ret.tau_int * sqrt((W_opt + .5 - ret.tau_int)/rows);
if (len > 1) {
for (i = 0; i < len; ++i)
Fbr[i] = (Fbr[i] - Fb)*(Fbr[i] - Fb)*n_rep[i];
ret.Q_val = UWerr_sum(Fbr, len);
ret.Q_val /= CFbb_opt;
ret.Q_val = gammaq((len-1)/2., ret.Q_val/2.);
}
if (plot) {
plotScriptf = fopen("uwerr_plot_script", "w");
fprintf(plotScriptf, "set ylabel \"Gamma\"; set xlabel \"W\"; set label \"W_opt=%d\" at %d,0 center; plot f(x) = 0, f(x) notitle, 'uwerr_plot_data' using 1:2 title \"normalized autocorrelation\" with lines; show label; pause -1\n", W_opt, W_opt);
fprintf(plotScriptf, "set ylabel \"tau_int\"; plot f(x) = %.3f, 'uwerr_plot_data' using 1:3 title \"tau_int with statistical errors\" with lines,", ret.tau_int);
fprintf(plotScriptf, " 'uwerr_plot_data' using 1:3:4 notitle with errorbars, f(x) title \"estimate\"; pause -1\n");
fclose(plotScriptf);
plotDataf = fopen("uwerr_plot_data", "w");
tmp = 0;
for (i = 0; i < W_max; ++i) {
tmp += gFbb[i];
/* print values for x-Axis, Gamma/Gamma[0], tau_int, and its errors */
fprintf(plotDataf, "%d %.3f %.3f %.3f\n", i, gFbb[i]/gFbb[0],
tmp/gFbb[0]-.5, 2*sqrt((i+tmp/gFbb[0])/rows));
}
fclose(plotDataf);
puts("Press Return to continue ...");
Tcl_Eval(interp, "[exec gnuplot uwerr_plot_script]");
}
Tcl_ResetResult(interp);
Tcl_PrintDouble(interp, ret.value, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.dvalue, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.ddvalue, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.tau_int, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.dtau_int, str);
Tcl_AppendResult(interp, str, (char *)NULL);
if (len > 1) {
Tcl_PrintDouble(interp, ret.Q_val, str);
Tcl_AppendResult(interp, " ", str, (char *)NULL);
}
err_exit:
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(delpro);
free(gFbb);
free(Fbr);
free(fgrad);
free(str);
free(my_argv);
uwerr_free_tcl_vector(tcl_vector);
return TCL_OK;
}
double cumpoisson(double k,double mean)
{
return gammaq(k+1,mean);
}