void AT_single_impact_local_dose_distrib(
const long n,
const double E_MeV_u[],
const long particle_no[],
const double fluence_cm2_or_dose_Gy[],
const long material_no,
const long rdd_model,
const double rdd_parameter[],
const long er_model,
const long N2,
const long n_bins_f1,
const double f1_parameters[],
const long stopping_power_source_no,
double f1_d_Gy[],
double f1_dd_Gy[],
double frequency_1_Gy_f1[])
{
long i, j;
/*
* Get relative fluence for beam components
* Convert dose to fluence if necessary
*/
double* fluence_cm2 = (double*)calloc(n, sizeof(double));
if(fluence_cm2_or_dose_Gy[0] < 0){
double* dose_Gy = (double*)calloc(n, sizeof(double));
for (i = 0; i < n; i++){
dose_Gy[i] = -1.0 * fluence_cm2_or_dose_Gy[i];
}
AT_fluence_cm2_from_dose_Gy( n,
E_MeV_u,
particle_no,
dose_Gy,
material_no,
stopping_power_source_no,
fluence_cm2);
free( dose_Gy );
}else{
for (i = 0; i < n; i++){
fluence_cm2[i] = fluence_cm2_or_dose_Gy[i];
}
}
double* norm_fluence = (double*)calloc(n, sizeof(double));
AT_normalize( n,
fluence_cm2,
norm_fluence);
free( fluence_cm2 );
/*
* Prepare single impact local dose distribution histogram
*/
if(n_bins_f1 > 0){
const double step = AT_N2_to_step(N2);
const long histo_type = AT_histo_log;
// Find lowest and highest dose (looking at ALL particles)
// TODO: redundant, already used in finding number of bins, replace
double d_min_f1 = f1_parameters[0*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 3];
double d_max_f1 = f1_parameters[0*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 4];
for (i = 1; i < n; i++){
d_min_f1 = GSL_MIN(f1_parameters[i*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 3], d_min_f1);
d_max_f1 = GSL_MAX(f1_parameters[i*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 4], d_max_f1);
}
double lowest_left_limit_f1 = d_min_f1;
AT_histo_midpoints(n_bins_f1,
lowest_left_limit_f1,
step,
histo_type,
f1_d_Gy);
AT_histo_bin_widths(n_bins_f1,
lowest_left_limit_f1,
step,
histo_type,
f1_dd_Gy);
for (i = 0; i < n_bins_f1; i++){
frequency_1_Gy_f1[i] = 0.0;
}
/*
* Fill histogram with single impact distribution(s) from individual components
*/
// loop over all components (i.e. particles and energies), compute contribution to f1
long n_bins_used = 1;
for (i = 0; i < n; i++){
// Find lowest and highest dose for component
double d_min_f1_comp = f1_parameters[i*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 3];
double d_max_f1_comp = f1_parameters[i*AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 4];
// Find position and number of bins for component f1 in overall f1
long lowest_bin_no_comp = AT_histo_bin_no(n_bins_f1,
lowest_left_limit_f1,
step,
histo_type,
d_min_f1_comp);
long highest_bin_no_comp = AT_histo_bin_no(n_bins_f1,
lowest_left_limit_f1,
step,
histo_type,
d_max_f1_comp);
long n_bins_f1_comp = highest_bin_no_comp - lowest_bin_no_comp + 1;
if (n_bins_f1_comp > 1){
/*
* Compute component F1 (accumulated single impact density)
* Computation is done with bin limits as sampling points and later differential
* f1 will be computed (therefore we need one bin more)
* The lowest and highest value for F1 have however to be adjusted as they might
* not coincide with the actual min/max values for dose, r, and F1 resp.
* They bin widths have to be the same though to assure the integral to be 1
*
* At the limits F1 will be set to 0 and 1, resp. This enable to account for all
* dose, e.g. also in the core, where many radii have the same dose. This procedure,
* however, will only work with monotonously falling RDDs which we can assume for all
* realistic cases.
*/
double* dose_left_limits_Gy_F1_comp = (double*)calloc(n_bins_f1_comp + 1, sizeof(double));
double* r_m_comp = (double*)calloc(n_bins_f1_comp + 1, sizeof(double));
double* F1_comp = (double*)calloc(n_bins_f1_comp + 1, sizeof(double));
// left limit of lowest bin for component
double lowest_left_limit_f1_comp = 0.0;
AT_histo_left_limit(n_bins_f1,
lowest_left_limit_f1,
step,
histo_type,
lowest_bin_no_comp,
&lowest_left_limit_f1_comp);
// get all left limits
AT_histo_left_limits(n_bins_f1_comp + 1,
lowest_left_limit_f1_comp,
step,
histo_type,
dose_left_limits_Gy_F1_comp);
// compute radius as function of dose (inverse RDD),
// but not for lowest and highest value (i.e. 'n_bins_f1_comp - 1'
// instead of 'n_bins_f1_comp + 1' and &dose_left_limits_Gy_F1_comp[1]
// as entry point instead of dose_left_limits_Gy_F1_comp
// exit in case of problems
int inverse_RDD_status_code = AT_r_RDD_m ( n_bins_f1_comp - 1,
&dose_left_limits_Gy_F1_comp[1],
E_MeV_u[i],
particle_no[i],
material_no,
rdd_model,
rdd_parameter,
er_model,
stopping_power_source_no,
&r_m_comp[1]);
if( inverse_RDD_status_code != 0 ){
#ifndef NDEBUG
printf("Problem in evaluating inverse RDD in AT_SC_get_f1, probably wrong combination of ER and RDD used\n");
#endif
char rdd_model_name[100];
AT_RDD_name_from_number(rdd_model, rdd_model_name);
char er_model_name[100];
getERName( er_model, er_model_name);
#ifndef NDEBUG
printf("rdd_model: %ld (%s), er_model: %ld (%s)\n", rdd_model, rdd_model_name, er_model, er_model_name);
exit(EXIT_FAILURE);
#endif
}
// compute F1 as function of radius
// use F1 - 1 instead of F1 to avoid numeric cut-off problems
double r_max_m_comp = f1_parameters[i * AT_SC_F1_PARAMETERS_SINGLE_LENGTH + 2];
for (j = 1; j < n_bins_f1_comp; j++){
F1_comp[j] = square(r_m_comp[j] / r_max_m_comp);
}
// Set extreme values of F1
F1_comp[0] = 1.0;
F1_comp[n_bins_f1_comp] = 0.0;
FILE* output = fopen("F_output.csv", "w");
fprintf(output, "bin.no;r.m;d.Gy;F1\n");
for (j = 0; j < n_bins_f1_comp + 1; j++){
fprintf(output,
"%ld;%7.6e;%7.6e;%7.6e\n",
j, r_m_comp[j], dose_left_limits_Gy_F1_comp[j], F1_comp[j]);
}
fclose(output);
// now compute f1 as the derivative of F1 and add to overall f1
double f1_comp;
for (j = 0; j < n_bins_f1_comp; j++){
f1_comp = (F1_comp[j] - F1_comp[j + 1]) / (dose_left_limits_Gy_F1_comp[j + 1] - dose_left_limits_Gy_F1_comp[j]);
frequency_1_Gy_f1[lowest_bin_no_comp + j] += norm_fluence[i] * f1_comp;
}
// adjust the density in first and last bin, because upper limit is not d.max.Gy and lower not d.min.Gy
free(dose_left_limits_Gy_F1_comp);
free(r_m_comp);
free(F1_comp);
}
else{ // in case of n_bins_df == 1 (all doses fall into single bin, just add a value of 1.0
frequency_1_Gy_f1[lowest_bin_no_comp ] += norm_fluence[i] * 1.0 / f1_dd_Gy[lowest_bin_no_comp];
}
// remember highest bin used
n_bins_used = GSL_MAX(n_bins_used, highest_bin_no_comp);
}
// normalize f1 (should be ok anyway but there could be small round-off errors)
double f1_norm = 0.0;
for (i = 0; i < n_bins_f1; i++){
f1_norm += frequency_1_Gy_f1[i] * f1_dd_Gy[i];
}
for (i = 0; i < n_bins_f1; i++){
frequency_1_Gy_f1[i] /= f1_norm;
}
} // if(f1_d_Gy != NULL)
free( norm_fluence );
}
static void
test_getset(const size_t M, const size_t N,
const double density, const gsl_rng *r)
{
int status;
size_t i, j;
/* test triplet versions of _get and _set */
{
const double val = 0.75;
size_t k = 0;
gsl_spmatrix *m = gsl_spmatrix_alloc(M, N);
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double x = (double) ++k;
double y;
gsl_spmatrix_set(m, i, j, x);
y = gsl_spmatrix_get(m, i, j);
if (x != y)
status = 1;
}
}
gsl_test(status, "test_getset: M="F_ZU" N="F_ZU" _get != _set", M, N);
/* test setting an element to 0 */
gsl_spmatrix_set(m, 0, 0, 1.0);
gsl_spmatrix_set(m, 0, 0, 0.0);
status = gsl_spmatrix_get(m, 0, 0) != 0.0;
gsl_test(status, "test_getset: M="F_ZU" N="F_ZU" m(0,0) = %f",
M, N, gsl_spmatrix_get(m, 0, 0));
/* test gsl_spmatrix_set_zero() */
gsl_spmatrix_set(m, 0, 0, 1.0);
gsl_spmatrix_set_zero(m);
status = gsl_spmatrix_get(m, 0, 0) != 0.0;
gsl_test(status, "test_getset: M="F_ZU" N="F_ZU" set_zero m(0,0) = %f",
M, N, gsl_spmatrix_get(m, 0, 0));
/* resassemble matrix to ensure nz is calculated correctly */
k = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double x = (double) ++k;
gsl_spmatrix_set(m, i, j, x);
}
}
status = gsl_spmatrix_nnz(m) != M * N;
gsl_test(status, "test_getset: M="F_ZU" N="F_ZU" set_zero nz = "F_ZU,
M, N, gsl_spmatrix_nnz(m));
/* test gsl_spmatrix_ptr() */
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double mij = gsl_spmatrix_get(m, i, j);
double *ptr = gsl_spmatrix_ptr(m, i, j);
*ptr += val;
if (gsl_spmatrix_get(m, i, j) != mij + val)
status = 2;
}
}
gsl_test(status == 2, "test_getset: M="F_ZU" N="F_ZU" triplet ptr", M, N);
gsl_spmatrix_free(m);
}
/* test duplicate values are handled correctly */
{
size_t min = GSL_MIN(M, N);
size_t expected_nnz = min;
size_t nnz;
size_t k = 0;
gsl_spmatrix *m = gsl_spmatrix_alloc(M, N);
status = 0;
for (i = 0; i < min; ++i)
{
for (j = 0; j < 5; ++j)
{
double x = (double) ++k;
double y;
gsl_spmatrix_set(m, i, i, x);
y = gsl_spmatrix_get(m, i, i);
if (x != y)
status = 1;
}
}
gsl_test(status, "test_getset: duplicate test M="F_ZU" N="F_ZU" _get != _set", M, N);
nnz = gsl_spmatrix_nnz(m);
status = nnz != expected_nnz;
gsl_test(status, "test_getset: duplicate test M="F_ZU" N="F_ZU" nnz="F_ZU", expected="F_ZU,
M, N, nnz, expected_nnz);
gsl_spmatrix_free(m);
}
/* test CCS version of gsl_spmatrix_get() */
{
const double val = 0.75;
gsl_spmatrix *T = create_random_sparse(M, N, density, r);
gsl_spmatrix *C = gsl_spmatrix_ccs(T);
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double Tij = gsl_spmatrix_get(T, i, j);
double Cij = gsl_spmatrix_get(C, i, j);
double *ptr = gsl_spmatrix_ptr(C, i, j);
if (Tij != Cij)
status = 1;
if (ptr)
{
*ptr += val;
Cij = gsl_spmatrix_get(C, i, j);
if (Tij + val != Cij)
status = 2;
}
}
}
gsl_test(status == 1, "test_getset: M="F_ZU" N="F_ZU" CCS get", M, N);
gsl_test(status == 2, "test_getset: M="F_ZU" N="F_ZU" CCS ptr", M, N);
gsl_spmatrix_free(T);
gsl_spmatrix_free(C);
}
/* test CRS version of gsl_spmatrix_get() */
{
const double val = 0.75;
gsl_spmatrix *T = create_random_sparse(M, N, density, r);
gsl_spmatrix *C = gsl_spmatrix_crs(T);
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double Tij = gsl_spmatrix_get(T, i, j);
double Cij = gsl_spmatrix_get(C, i, j);
double *ptr = gsl_spmatrix_ptr(C, i, j);
if (Tij != Cij)
status = 1;
if (ptr)
{
*ptr += val;
Cij = gsl_spmatrix_get(C, i, j);
if (Tij + val != Cij)
status = 2;
}
}
}
gsl_test(status == 1, "test_getset: M="F_ZU" N="F_ZU" CRS get", M, N);
gsl_test(status == 2, "test_getset: M="F_ZU" N="F_ZU" CRS ptr", M, N);
gsl_spmatrix_free(T);
gsl_spmatrix_free(C);
}
} /* test_getset() */
int
gsl_linalg_SV_decomp (gsl_matrix * A, gsl_matrix * V, gsl_vector * S,
gsl_vector * work)
{
size_t a, b, i, j, iter;
const size_t M = A->size1;
const size_t N = A->size2;
const size_t K = GSL_MIN (M, N);
if (M < N)
{
GSL_ERROR ("svd of MxN matrix, M<N, is not implemented", GSL_EUNIMPL);
}
else if (V->size1 != N)
{
GSL_ERROR ("square matrix V must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (V->size1 != V->size2)
{
GSL_ERROR ("matrix V must be square", GSL_ENOTSQR);
}
else if (S->size != N)
{
GSL_ERROR ("length of vector S must match second dimension of matrix A",
GSL_EBADLEN);
}
else if (work->size != N)
{
GSL_ERROR ("length of workspace must match second dimension of matrix A",
GSL_EBADLEN);
}
/* Handle the case of N = 1 (SVD of a column vector) */
if (N == 1)
{
gsl_vector_view column = gsl_matrix_column (A, 0);
double norm = gsl_blas_dnrm2 (&column.vector);
gsl_vector_set (S, 0, norm);
gsl_matrix_set (V, 0, 0, 1.0);
if (norm != 0.0)
{
gsl_blas_dscal (1.0/norm, &column.vector);
}
return GSL_SUCCESS;
}
{
gsl_vector_view f = gsl_vector_subvector (work, 0, K - 1);
/* bidiagonalize matrix A, unpack A into U S V */
gsl_linalg_bidiag_decomp (A, S, &f.vector);
gsl_linalg_bidiag_unpack2 (A, S, &f.vector, V);
/* apply reduction steps to B=(S,Sd) */
chop_small_elements (S, &f.vector);
/* Progressively reduce the matrix until it is diagonal */
b = N - 1;
iter = 0;
while (b > 0)
{
double fbm1 = gsl_vector_get (&f.vector, b - 1);
if (fbm1 == 0.0 || gsl_isnan (fbm1))
{
b--;
continue;
}
/* Find the largest unreduced block (a,b) starting from b
and working backwards */
a = b - 1;
while (a > 0)
{
double fam1 = gsl_vector_get (&f.vector, a - 1);
if (fam1 == 0.0 || gsl_isnan (fam1))
{
break;
}
a--;
}
iter++;
if (iter > 100 * N)
{
GSL_ERROR("SVD decomposition failed to converge", GSL_EMAXITER);
}
{
const size_t n_block = b - a + 1;
gsl_vector_view S_block = gsl_vector_subvector (S, a, n_block);
gsl_vector_view f_block = gsl_vector_subvector (&f.vector, a, n_block - 1);
gsl_matrix_view U_block =
gsl_matrix_submatrix (A, 0, a, A->size1, n_block);
gsl_matrix_view V_block =
gsl_matrix_submatrix (V, 0, a, V->size1, n_block);
qrstep (&S_block.vector, &f_block.vector, &U_block.matrix, &V_block.matrix);
/* remove any small off-diagonal elements */
chop_small_elements (&S_block.vector, &f_block.vector);
}
}
}
/* Make singular values positive by reflections if necessary */
for (j = 0; j < K; j++)
{
double Sj = gsl_vector_get (S, j);
if (Sj < 0.0)
{
for (i = 0; i < N; i++)
{
double Vij = gsl_matrix_get (V, i, j);
gsl_matrix_set (V, i, j, -Vij);
}
gsl_vector_set (S, j, -Sj);
}
}
/* Sort singular values into decreasing order */
for (i = 0; i < K; i++)
{
double S_max = gsl_vector_get (S, i);
size_t i_max = i;
for (j = i + 1; j < K; j++)
{
double Sj = gsl_vector_get (S, j);
if (Sj > S_max)
{
S_max = Sj;
i_max = j;
}
}
if (i_max != i)
{
/* swap eigenvalues */
gsl_vector_swap_elements (S, i, i_max);
/* swap eigenvectors */
gsl_matrix_swap_columns (A, i, i_max);
gsl_matrix_swap_columns (V, i, i_max);
}
}
return GSL_SUCCESS;
}
int
gsl_sf_lnbeta_sgn_e(const double x, const double y, gsl_sf_result * result, double * sgn)
{
/* CHECK_POINTER(result) */
if(x == 0.0 || y == 0.0) {
*sgn = 0.0;
DOMAIN_ERROR(result);
} else if (isnegint(x) || isnegint(y)) {
*sgn = 0.0;
DOMAIN_ERROR(result); /* not defined for negative integers */
}
/* See if we can handle the postive case with min/max < 0.2 */
if (x > 0 && y > 0) {
const double max = GSL_MAX(x,y);
const double min = GSL_MIN(x,y);
const double rat = min/max;
if(rat < 0.2) {
/* min << max, so be careful
* with the subtraction
*/
double lnpre_val;
double lnpre_err;
double lnpow_val;
double lnpow_err;
double t1, t2, t3;
gsl_sf_result lnopr;
gsl_sf_result gsx, gsy, gsxy;
gsl_sf_gammastar_e(x, &gsx);
gsl_sf_gammastar_e(y, &gsy);
gsl_sf_gammastar_e(x+y, &gsxy);
gsl_sf_log_1plusx_e(rat, &lnopr);
lnpre_val = log(gsx.val*gsy.val/gsxy.val * M_SQRT2*M_SQRTPI);
lnpre_err = gsx.err/gsx.val + gsy.err/gsy.val + gsxy.err/gsxy.val;
t1 = min*log(rat);
t2 = 0.5*log(min);
t3 = (x+y-0.5)*lnopr.val;
lnpow_val = t1 - t2 - t3;
lnpow_err = GSL_DBL_EPSILON * (fabs(t1) + fabs(t2) + fabs(t3));
lnpow_err += fabs(x+y-0.5) * lnopr.err;
result->val = lnpre_val + lnpow_val;
result->err = lnpre_err + lnpow_err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
*sgn = 1.0;
return GSL_SUCCESS;
}
}
/* General case - Fallback */
{
gsl_sf_result lgx, lgy, lgxy;
double sgx, sgy, sgxy, xy = x+y;
int stat_gx = gsl_sf_lngamma_sgn_e(x, &lgx, &sgx);
int stat_gy = gsl_sf_lngamma_sgn_e(y, &lgy, &sgy);
int stat_gxy = gsl_sf_lngamma_sgn_e(xy, &lgxy, &sgxy);
*sgn = sgx * sgy * sgxy;
result->val = lgx.val + lgy.val - lgxy.val;
result->err = lgx.err + lgy.err + lgxy.err;
result->err += GSL_DBL_EPSILON * (fabs(lgx.val) + fabs(lgy.val) + fabs(lgxy.val));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_3(stat_gx, stat_gy, stat_gxy);
}
}
static void *
gmres_alloc(const size_t n, const size_t m)
{
gmres_state_t *state;
if (n == 0)
{
GSL_ERROR_NULL("matrix dimension n must be a positive integer",
GSL_EINVAL);
}
state = calloc(1, sizeof(gmres_state_t));
if (!state)
{
GSL_ERROR_NULL("failed to allocate gmres state", GSL_ENOMEM);
}
state->n = n;
/* compute size of Krylov subspace */
if (m == 0)
state->m = GSL_MIN(n, 10);
else
state->m = GSL_MIN(n, m);
state->r = gsl_vector_alloc(n);
if (!state->r)
{
gmres_free(state);
GSL_ERROR_NULL("failed to allocate r vector", GSL_ENOMEM);
}
state->H = gsl_matrix_alloc(n, state->m + 1);
if (!state->H)
{
gmres_free(state);
GSL_ERROR_NULL("failed to allocate H matrix", GSL_ENOMEM);
}
state->tau = gsl_vector_alloc(state->m + 1);
if (!state->tau)
{
gmres_free(state);
GSL_ERROR_NULL("failed to allocate tau vector", GSL_ENOMEM);
}
state->y = gsl_vector_alloc(state->m + 1);
if (!state->y)
{
gmres_free(state);
GSL_ERROR_NULL("failed to allocate y vector", GSL_ENOMEM);
}
state->c = malloc(state->m * sizeof(double));
state->s = malloc(state->m * sizeof(double));
if (!state->c || !state->s)
{
gmres_free(state);
GSL_ERROR_NULL("failed to allocate Givens vectors", GSL_ENOMEM);
}
state->normr = 0.0;
return state;
} /* gmres_alloc() */
int
lls(const gsl_matrix *A, const gsl_vector *c, gsl_vector *x)
{
int m = (int) A->size1;
int n = (int) A->size2;
int nrhs = 1;
int info;
int lwork;
gsl_matrix *aa, *bb;
gsl_vector *s;
gsl_vector *work;
double q[1];
int ldb = GSL_MAX(m, n);
int lda = m;
double rcond = 1.0e-12;
int rank;
int *iwork = 0;
gsl_vector_view v;
gsl_vector *rhs;
rhs = gsl_vector_alloc(c->size);
aa = gsl_matrix_alloc(A->size2, A->size1);
bb = gsl_matrix_alloc(nrhs, GSL_MAX(m, n));
s = gsl_vector_alloc(GSL_MIN(m, n));
gsl_matrix_transpose_memcpy(aa, A);
gsl_vector_memcpy(rhs, c);
v = gsl_matrix_subrow(bb, 0, 0, m);
gsl_vector_memcpy(&v.vector, rhs);
lwork = -1;
dgelsd_(&m,
&n,
&nrhs,
aa->data,
&lda,
bb->data,
&ldb,
s->data,
&rcond,
&rank,
q,
&lwork,
iwork,
&info);
lwork = (int) q[0];
work = gsl_vector_alloc((size_t) lwork);
iwork = malloc(sizeof(int) * m);
dgelsd_(&m,
&n,
&nrhs,
aa->data,
&lda,
bb->data,
&ldb,
s->data,
&rcond,
&rank,
work->data,
&lwork,
iwork,
&info);
v = gsl_matrix_subrow(bb, 0, 0, n);
gsl_vector_memcpy(x, &v.vector);
gsl_matrix_free(aa);
gsl_matrix_free(bb);
gsl_vector_free(s);
gsl_vector_free(rhs);
gsl_vector_free(work);
free(iwork);
if (info)
fprintf(stderr, "ERROR: lls: info = %d\n", info);
return (info);
} /* lls() */
int
gsl_sf_coulomb_wave_FG_e(const double eta, const double x,
const double lam_F,
const int k_lam_G, /* lam_G = lam_F - k_lam_G */
gsl_sf_result * F, gsl_sf_result * Fp,
gsl_sf_result * G, gsl_sf_result * Gp,
double * exp_F, double * exp_G)
{
const double lam_G = lam_F - k_lam_G;
if(x < 0.0 || lam_F <= -0.5 || lam_G <= -0.5) {
GSL_SF_RESULT_SET(F, 0.0, 0.0);
GSL_SF_RESULT_SET(Fp, 0.0, 0.0);
GSL_SF_RESULT_SET(G, 0.0, 0.0);
GSL_SF_RESULT_SET(Gp, 0.0, 0.0);
*exp_F = 0.0;
*exp_G = 0.0;
GSL_ERROR ("domain error", GSL_EDOM);
}
else if(x == 0.0) {
gsl_sf_result C0;
CLeta(0.0, eta, &C0);
GSL_SF_RESULT_SET(F, 0.0, 0.0);
GSL_SF_RESULT_SET(Fp, 0.0, 0.0);
GSL_SF_RESULT_SET(G, 0.0, 0.0); /* FIXME: should be Inf */
GSL_SF_RESULT_SET(Gp, 0.0, 0.0); /* FIXME: should be Inf */
*exp_F = 0.0;
*exp_G = 0.0;
if(lam_F == 0.0){
GSL_SF_RESULT_SET(Fp, C0.val, C0.err);
}
if(lam_G == 0.0) {
GSL_SF_RESULT_SET(Gp, 1.0/C0.val, fabs(C0.err/C0.val)/fabs(C0.val));
}
GSL_ERROR ("domain error", GSL_EDOM);
/* After all, since we are asking for G, this is a domain error... */
}
else if(x < 1.2 && 2.0*M_PI*eta < 0.9*(-GSL_LOG_DBL_MIN) && fabs(eta*x) < 10.0) {
/* Reduce to a small lambda value and use the series
* representations for F and G. We cannot allow eta to
* be large and positive because the connection formula
* for G_lam is badly behaved due to an underflow in sin(phi_lam)
* [see coulomb_FG_series() and coulomb_connection() above].
* Note that large negative eta is ok however.
*/
const double SMALL = GSL_SQRT_DBL_EPSILON;
const int N = (int)(lam_F + 0.5);
const int span = GSL_MAX(k_lam_G, N);
const double lam_min = lam_F - N; /* -1/2 <= lam_min < 1/2 */
double F_lam_F, Fp_lam_F;
double G_lam_G, Gp_lam_G;
double F_lam_F_err, Fp_lam_F_err;
double Fp_over_F_lam_F;
double F_sign_lam_F;
double F_lam_min_unnorm, Fp_lam_min_unnorm;
double Fp_over_F_lam_min;
gsl_sf_result F_lam_min;
gsl_sf_result G_lam_min, Gp_lam_min;
double F_scale;
double Gerr_frac;
double F_scale_frac_err;
double F_unnorm_frac_err;
/* Determine F'/F at lam_F. */
int CF1_count;
int stat_CF1 = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);
int stat_ser;
int stat_Fr;
int stat_Gr;
/* Recurse down with unnormalized F,F' values. */
F_lam_F = SMALL;
Fp_lam_F = Fp_over_F_lam_F * F_lam_F;
if(span != 0) {
stat_Fr = coulomb_F_recur(lam_min, span, eta, x,
F_lam_F, Fp_lam_F,
&F_lam_min_unnorm, &Fp_lam_min_unnorm
);
}
else {
F_lam_min_unnorm = F_lam_F;
Fp_lam_min_unnorm = Fp_lam_F;
stat_Fr = GSL_SUCCESS;
}
/* Determine F and G at lam_min. */
if(lam_min == -0.5) {
stat_ser = coulomb_FGmhalf_series(eta, x, &F_lam_min, &G_lam_min);
}
else if(lam_min == 0.0) {
stat_ser = coulomb_FG0_series(eta, x, &F_lam_min, &G_lam_min);
}
else if(lam_min == 0.5) {
/* This cannot happen. */
F->val = F_lam_F;
F->err = 2.0 * GSL_DBL_EPSILON * fabs(F->val);
Fp->val = Fp_lam_F;
Fp->err = 2.0 * GSL_DBL_EPSILON * fabs(Fp->val);
G->val = G_lam_G;
G->err = 2.0 * GSL_DBL_EPSILON * fabs(G->val);
Gp->val = Gp_lam_G;
Gp->err = 2.0 * GSL_DBL_EPSILON * fabs(Gp->val);
*exp_F = 0.0;
*exp_G = 0.0;
GSL_ERROR ("error", GSL_ESANITY);
}
else {
stat_ser = coulomb_FG_series(lam_min, eta, x, &F_lam_min, &G_lam_min);
}
/* Determine remaining quantities. */
Fp_over_F_lam_min = Fp_lam_min_unnorm / F_lam_min_unnorm;
Gp_lam_min.val = Fp_over_F_lam_min*G_lam_min.val - 1.0/F_lam_min.val;
Gp_lam_min.err = fabs(Fp_over_F_lam_min)*G_lam_min.err;
Gp_lam_min.err += fabs(1.0/F_lam_min.val) * fabs(F_lam_min.err/F_lam_min.val);
F_scale = F_lam_min.val / F_lam_min_unnorm;
/* Apply scale to the original F,F' values. */
F_scale_frac_err = fabs(F_lam_min.err/F_lam_min.val);
F_unnorm_frac_err = 2.0*GSL_DBL_EPSILON*(CF1_count+span+1);
F_lam_F *= F_scale;
F_lam_F_err = fabs(F_lam_F) * (F_unnorm_frac_err + F_scale_frac_err);
Fp_lam_F *= F_scale;
Fp_lam_F_err = fabs(Fp_lam_F) * (F_unnorm_frac_err + F_scale_frac_err);
/* Recurse up to get the required G,G' values. */
stat_Gr = coulomb_G_recur(lam_min, GSL_MAX(N-k_lam_G,0), eta, x,
G_lam_min.val, Gp_lam_min.val,
&G_lam_G, &Gp_lam_G
);
F->val = F_lam_F;
F->err = F_lam_F_err;
F->err += 2.0 * GSL_DBL_EPSILON * fabs(F_lam_F);
Fp->val = Fp_lam_F;
Fp->err = Fp_lam_F_err;
Fp->err += 2.0 * GSL_DBL_EPSILON * fabs(Fp_lam_F);
Gerr_frac = fabs(G_lam_min.err/G_lam_min.val) + fabs(Gp_lam_min.err/Gp_lam_min.val);
G->val = G_lam_G;
G->err = Gerr_frac * fabs(G_lam_G);
G->err += 2.0 * (CF1_count+1) * GSL_DBL_EPSILON * fabs(G->val);
Gp->val = Gp_lam_G;
Gp->err = Gerr_frac * fabs(Gp->val);
Gp->err += 2.0 * (CF1_count+1) * GSL_DBL_EPSILON * fabs(Gp->val);
*exp_F = 0.0;
*exp_G = 0.0;
return GSL_ERROR_SELECT_4(stat_ser, stat_CF1, stat_Fr, stat_Gr);
}
else if(x < 2.0*eta) {
/* Use WKB approximation to obtain F and G at the two
* lambda values, and use the Wronskian and the
* continued fractions for F'/F to obtain F' and G'.
*/
gsl_sf_result F_lam_F, G_lam_F;
gsl_sf_result F_lam_G, G_lam_G;
double exp_lam_F, exp_lam_G;
int stat_lam_F;
int stat_lam_G;
int stat_CF1_lam_F;
int stat_CF1_lam_G;
int CF1_count;
double Fp_over_F_lam_F;
double Fp_over_F_lam_G;
double F_sign_lam_F;
double F_sign_lam_G;
stat_lam_F = coulomb_jwkb(lam_F, eta, x, &F_lam_F, &G_lam_F, &exp_lam_F);
if(k_lam_G == 0) {
stat_lam_G = stat_lam_F;
F_lam_G = F_lam_F;
G_lam_G = G_lam_F;
exp_lam_G = exp_lam_F;
}
else {
stat_lam_G = coulomb_jwkb(lam_G, eta, x, &F_lam_G, &G_lam_G, &exp_lam_G);
}
stat_CF1_lam_F = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);
if(k_lam_G == 0) {
stat_CF1_lam_G = stat_CF1_lam_F;
F_sign_lam_G = F_sign_lam_F;
Fp_over_F_lam_G = Fp_over_F_lam_F;
}
else {
stat_CF1_lam_G = coulomb_CF1(lam_G, eta, x, &F_sign_lam_G, &Fp_over_F_lam_G, &CF1_count);
}
F->val = F_lam_F.val;
F->err = F_lam_F.err;
G->val = G_lam_G.val;
G->err = G_lam_G.err;
Fp->val = Fp_over_F_lam_F * F_lam_F.val;
Fp->err = fabs(Fp_over_F_lam_F) * F_lam_F.err;
Fp->err += 2.0*GSL_DBL_EPSILON*fabs(Fp->val);
Gp->val = Fp_over_F_lam_G * G_lam_G.val - 1.0/F_lam_G.val;
Gp->err = fabs(Fp_over_F_lam_G) * G_lam_G.err;
Gp->err += fabs(1.0/F_lam_G.val) * fabs(F_lam_G.err/F_lam_G.val);
*exp_F = exp_lam_F;
*exp_G = exp_lam_G;
if(stat_lam_F == GSL_EOVRFLW || stat_lam_G == GSL_EOVRFLW) {
GSL_ERROR ("overflow", GSL_EOVRFLW);
}
else {
return GSL_ERROR_SELECT_2(stat_lam_F, stat_lam_G);
}
}
else {
/* x > 2 eta, so we know that we can find a lambda value such
* that x is above the turning point. We do this, evaluate
* using Steed's method at that oscillatory point, then
* use recursion on F and G to obtain the required values.
*
* lam_0 = a value of lambda such that x is below the turning point
* lam_min = minimum of lam_0 and the requested lam_G, since
* we must go at least as low as lam_G
*/
const double SMALL = GSL_SQRT_DBL_EPSILON;
const double C = sqrt(1.0 + 4.0*x*(x-2.0*eta));
const int N = ceil(lam_F - C + 0.5);
const double lam_0 = lam_F - GSL_MAX(N, 0);
const double lam_min = GSL_MIN(lam_0, lam_G);
double F_lam_F, Fp_lam_F;
double G_lam_G, Gp_lam_G;
double F_lam_min_unnorm, Fp_lam_min_unnorm;
double F_lam_min, Fp_lam_min;
double G_lam_min, Gp_lam_min;
double Fp_over_F_lam_F;
double Fp_over_F_lam_min;
double F_sign_lam_F;
double P_lam_min, Q_lam_min;
double alpha;
double gamma;
double F_scale;
int CF1_count;
int CF2_count;
int stat_CF1 = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);
int stat_CF2;
int stat_Fr;
int stat_Gr;
int F_recur_count;
int G_recur_count;
double err_amplify;
F_lam_F = SMALL;
Fp_lam_F = Fp_over_F_lam_F * F_lam_F;
/* Backward recurrence to get F,Fp at lam_min */
F_recur_count = GSL_MAX(k_lam_G, N);
stat_Fr = coulomb_F_recur(lam_min, F_recur_count, eta, x,
F_lam_F, Fp_lam_F,
&F_lam_min_unnorm, &Fp_lam_min_unnorm
);
Fp_over_F_lam_min = Fp_lam_min_unnorm / F_lam_min_unnorm;
/* Steed evaluation to complete evaluation of F,Fp,G,Gp at lam_min */
stat_CF2 = coulomb_CF2(lam_min, eta, x, &P_lam_min, &Q_lam_min, &CF2_count);
alpha = Fp_over_F_lam_min - P_lam_min;
gamma = alpha/Q_lam_min;
F_lam_min = F_sign_lam_F / sqrt(alpha*alpha/Q_lam_min + Q_lam_min);
Fp_lam_min = Fp_over_F_lam_min * F_lam_min;
G_lam_min = gamma * F_lam_min;
Gp_lam_min = (P_lam_min * gamma - Q_lam_min) * F_lam_min;
/* Apply scale to values of F,Fp at lam_F (the top). */
F_scale = F_lam_min / F_lam_min_unnorm;
F_lam_F *= F_scale;
Fp_lam_F *= F_scale;
/* Forward recurrence to get G,Gp at lam_G (the top). */
G_recur_count = GSL_MAX(N-k_lam_G,0);
stat_Gr = coulomb_G_recur(lam_min, G_recur_count, eta, x,
G_lam_min, Gp_lam_min,
&G_lam_G, &Gp_lam_G
);
err_amplify = CF1_count + CF2_count + F_recur_count + G_recur_count + 1;
F->val = F_lam_F;
F->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(F->val);
Fp->val = Fp_lam_F;
Fp->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(Fp->val);
G->val = G_lam_G;
G->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(G->val);
Gp->val = Gp_lam_G;
Gp->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(Gp->val);
*exp_F = 0.0;
*exp_G = 0.0;
return GSL_ERROR_SELECT_4(stat_CF1, stat_CF2, stat_Fr, stat_Gr);
}
}
double gsl_min (double a, double b)
{
return GSL_MIN (a, b);
}
void SimulEpidPoissPerGroup(parameters *param, gsl_matrix *Incid, gsl_matrix *IncidPerGroup, gsl_vector *Incid0PerGroup)
{
int k, t, g, i, s;
int tMin, tMax;
double lambda;
double prov;
gsl_vector * vectProv = gsl_vector_calloc(param->NbGroups);
int poiss;
for (k=0 ; k<param->NbGroups*param->NbGroups ; k++)
{
gsl_matrix_set(IncidPerGroup,k,0,gsl_vector_get(Incid0PerGroup,k));
}
for (k=0 ; k<param->NbGroups ; k++)
{
prov=0;
for (g=0 ; g<param->NbGroups ; g++)
{
prov+=gsl_matrix_get(IncidPerGroup,g*param->NbGroups+k,0);
}
gsl_matrix_set(Incid,k,0,prov);
}
for (i=0 ; i<param->p+1 ; i++)
{
if(i==0)
{
tMin=1;
}else
{
tMin=gsl_vector_get(param->tau,i-1);
}
if(i==param->p)
{
tMax=param->T;
}else
{
tMax=gsl_vector_get(param->tau,i);
}
for (t=tMin ; t<tMax ; t++)
{
//printf("t %d\n",t);
//fflush(stdout);
for(k=0 ; k<param->NbGroups ; k++)
{
//printf("k %d\n",k);
//fflush(stdout);
lambda=0;
for(g=0 ; g<param->NbGroups ; g++)
{
//printf("g %d\n",g);
//fflush(stdout);
prov=0;
for(s=1 ; s<=GSL_MIN(t,param->S) ; s++)
{
prov+=gsl_matrix_get(Incid,g,t-s)*gsl_matrix_get(param->GTdistr,g,s-1);
//printf("s %d %lg\n",s,prov);
//fflush(stdout);
}
prov*=gsl_matrix_get(param->K[i],g,k);
gsl_vector_set(vectProv,g,prov);
//printf("prov %lg\n",prov);
//fflush(stdout);
lambda+=prov;
//printf("lambda %lg\n",lambda);
//fflush(stdout);
}
poiss=gsl_ran_poisson(rng,lambda);
//printf("lambda %lg inci %d\n",lambda,poiss);
//fflush(stdout);
gsl_matrix_set(Incid,k,t,poiss);
for(g=0 ; g<param->NbGroups ; g++)
{
gsl_matrix_set(IncidPerGroup,g*param->NbGroups+k,t,(double)poiss*gsl_vector_get(vectProv,g)/lambda);
}
}
}
}
}
double
GSL_MIN_DBL (double a, double b)
{
return GSL_MIN (a, b);
}
long double
GSL_MIN_LDBL (long double a, long double b)
{
return GSL_MIN (a, b);
}
int
GSL_MIN_INT (int a, int b)
{
return GSL_MIN (a, b);
}
int
geocode_dem (projection_type_t projection_type, // What we are projection to.
project_parameters_t *pp, // Parameters we project to.
datum_type_t datum, // Datum we project to.
// Pixel size of output image, in output projection units
// (meters or possibly degrees, if we decide to support
// projecting to pseudoprojected form).
double pixel_size,
resample_method_t resample_method, // How to resample pixels.
const char *input_image, // Base name of input image.
const meta_parameters *imd, // Input DEM image metadata.
const char *output_image // Base name of output image.
)
{
int return_code; // Holds return codes from functions.
// Function to use to project or unproject between latlon and input
// or output coordinates.
projector_t project_input; // latlon => input image map projection
projector_t unproject_input; // input image_map_projection => latlon
projector_t project_output; // latlon => output image map projection
projector_t unproject_output; // output image map projection => latlon
// Like the above, but act on arrays.
array_projector_t array_project_input, array_unproject_input;
array_projector_t array_project_output, array_unproject_output;
// We only deal with reprojection map projected DEMs.
g_assert (imd->projection != NULL);
// FIXME: what to do with background value is something that still
// needs to be determined (probably in consultation with the guys
// working on terrain correction).
const float background_value = 0.0;
// Geocoding to pseudoprojected form presents issues, for example
// with the meaning of the pixel_size argument, which is taken as a
// distance in map projection coordinates for all other projections
// (deciding how to interpret it when projecting to pseudoprojected
// form is tough), and since there probably isn't much need, we
// don't allow it.
g_assert (projection_type != LAT_LONG_PSEUDO_PROJECTION);
// Get the functions we want to use for projecting and unprojecting.
set_projection_functions (imd->projection->type, &project_input,
&unproject_input, &array_project_input,
&array_unproject_input);
set_projection_functions (projection_type, &project_output,
&unproject_output, &array_project_output,
&array_unproject_output);
// Input image dimensions in pixels in x and y directions.
size_t ii_size_x = imd->general->sample_count;
size_t ii_size_y = imd->general->line_count;
// Convenience aliases.
meta_projection *ipb = imd->projection;
project_parameters_t *ipp = &imd->projection->param;
// First we march around the entire outside of the image and compute
// projection coordinates for every pixel, keeping track of the
// minimum and maximum projection coordinates in each dimension.
// This lets us determine the exact extent of the DEM in
// output projection coordinates.
asfPrintStatus ("Determining input image extent in projection coordinate "
"space... ");
double min_x = DBL_MAX;
double max_x = -DBL_MAX;
double min_y = DBL_MAX;
double max_y = -DBL_MAX;
// In going around the edge, we are just trying to determine the
// extent of the image in the horizontal, so we don't care about
// height yet.
{ // Scoping block.
// Number of pixels in the edge of the image.
size_t edge_point_count = 2 * ii_size_x + 2 * ii_size_y - 4;
double *lats = g_new0 (double, edge_point_count);
double *lons = g_new0 (double, edge_point_count);
size_t current_edge_point = 0;
size_t ii = 0, jj = 0;
for ( ; ii < ii_size_x - 1 ; ii++ ) {
return_code = get_pixel_lat_long (imd, unproject_input, ii, jj,
&(lats[current_edge_point]),
&(lons[current_edge_point]));
g_assert (return_code);
current_edge_point++;
}
for ( ; jj < ii_size_y - 1 ; jj++ ) {
return_code = get_pixel_lat_long (imd, unproject_input, ii, jj,
&(lats[current_edge_point]),
&(lons[current_edge_point]));
g_assert (return_code);
current_edge_point++;
}
for ( ; ii > 0 ; ii-- ) {
return_code = get_pixel_lat_long (imd, unproject_input, ii, jj,
&(lats[current_edge_point]),
&(lons[current_edge_point]));
g_assert (return_code);
current_edge_point++;
}
for ( ; jj > 0 ; jj-- ) {
return_code = get_pixel_lat_long (imd, unproject_input, ii, jj,
&(lats[current_edge_point]),
&(lons[current_edge_point]));
g_assert (return_code);
current_edge_point++;
}
g_assert (current_edge_point == edge_point_count);
// Pointers to arrays of projected coordinates to be filled in.
// The projection function will allocate this memory itself.
double *x = NULL, *y = NULL;
// Project all the edge pixels.
return_code = array_project_output (pp, lats, lons, NULL, &x, &y, NULL,
edge_point_count, datum);
g_assert (return_code == TRUE);
// Find the extents of the image in projection coordinates.
for ( ii = 0 ; ii < edge_point_count ; ii++ ) {
if ( x[ii] < min_x ) { min_x = x[ii]; }
if ( x[ii] > max_x ) { max_x = x[ii]; }
if ( y[ii] < min_y ) { min_y = y[ii]; }
if ( y[ii] > max_y ) { max_y = y[ii]; }
}
free (y);
free (x);
g_free (lons);
g_free (lats);
}
asfPrintStatus ("done.\n\n");
// Issue a warning when the chosen pixel size is smaller than the
// input pixel size. FIXME: this condition will really never fire
// for pseudoprojected image, since the pixels size of the input is
// tiny (degrees per pixel) and the pixel_size has already been
// computed in asf_geocode function itself as an arc length on the
// ground.
if ( GSL_MIN(imd->general->x_pixel_size,
imd->general->y_pixel_size) > pixel_size ) {
asfPrintWarning
("Requested pixel size %f is smaller then the input image resolution "
"(%le meters).\n", pixel_size,
GSL_MIN (imd->general->x_pixel_size, imd->general->y_pixel_size));
}
// The pixel size requested by the user better not oversample by the
// factor of 2. Specifying --force will skip this check. FIXME:
// same essential problem as the above condition, but in this case
// it always goes off.
// if (!force_flag && GSL_MIN(imd->general->x_pixel_size,
// imd->general->y_pixel_size) > (2*pixel_size) ) {
// report_func
// ("Requested pixel size %f is smaller then the minimum implied by half \n"
// "the input image resolution (%le meters), this is not supported.\n",
// pixel_size, GSL_MIN (imd->general->x_pixel_size,
// imd->general->y_pixel_size));
// }
asfPrintStatus ("Opening input DEM image... ");
char *input_data_file = (char *) MALLOC(sizeof(char)*(strlen(input_image)+5));
sprintf(input_data_file, "%s.img", input_image);
FloatImage *iim
= float_image_new_from_file (ii_size_x, ii_size_y, input_data_file, 0,
FLOAT_IMAGE_BYTE_ORDER_BIG_ENDIAN);
FREE(input_data_file);
asfPrintStatus ("done.\n\n");
// Maximum pixel indicies in output image.
size_t oix_max = ceil ((max_x - min_x) / pixel_size);
size_t oiy_max = ceil ((max_y - min_y) / pixel_size);
// Output image dimensions.
size_t oi_size_x = oix_max + 1;
size_t oi_size_y = oiy_max + 1;
// Output image.
FloatImage *oim = float_image_new (oi_size_x, oi_size_y);
// Translate the command line notion of the resampling method into
// the lingo known by the float_image class. The compiler is
// reassured with a default.
float_image_sample_method_t float_image_sample_method
= FLOAT_IMAGE_SAMPLE_METHOD_BILINEAR;
switch ( resample_method ) {
case RESAMPLE_NEAREST_NEIGHBOR:
float_image_sample_method = FLOAT_IMAGE_SAMPLE_METHOD_NEAREST_NEIGHBOR;
break;
case RESAMPLE_BILINEAR:
float_image_sample_method = FLOAT_IMAGE_SAMPLE_METHOD_BILINEAR;
break;
case RESAMPLE_BICUBIC:
float_image_sample_method = FLOAT_IMAGE_SAMPLE_METHOD_BICUBIC;
break;
default:
g_assert_not_reached ();
}
// We need to find the z coordinates in the output projection of all
// the pixels in the input DEM. We store these values in their own
// FloatImage instance.
//FloatImage *x_coords = float_image_new (ii_size_x, ii_size_y);
//FloatImage *y_coords = float_image_new (ii_size_x, ii_size_y);
FloatImage *z_coords = float_image_new (ii_size_x, ii_size_y);
// We transform the points using the array transformation function
// for efficiency, but we don't want to do them all at once, since
// that would require huge gobs of memory.
const size_t max_transform_chunk_pixels = 5000000;
size_t rows_per_chunk = max_transform_chunk_pixels / ii_size_x;
size_t chunk_pixels = rows_per_chunk * ii_size_x;
double *chunk_x = g_new0 (double, chunk_pixels);
double *chunk_y = g_new0 (double, chunk_pixels);
double *chunk_z = g_new0 (double, chunk_pixels);
double *lat = g_new0 (double, chunk_pixels);
double *lon = g_new0 (double, chunk_pixels);
double *height = g_new0 (double, chunk_pixels);
asfPrintStatus ("Determining Z coordinates of input pixels in output "
"projection space... ");
// Transform all the chunks, storing results in the z coordinate image.
size_t ii, jj, kk; // Index variables.
for ( ii = 0 ; ii < ii_size_y ; ) {
size_t rows_remaining = ii_size_y - ii;
size_t rows_to_load
= rows_per_chunk < rows_remaining ? rows_per_chunk : rows_remaining;
for ( jj = 0 ; jj < rows_to_load ; jj++ ) {
size_t current_image_row = ii + jj;
for ( kk = 0 ; kk < ii_size_x ; kk++ ) {
size_t current_chunk_pixel = jj * ii_size_x + kk;
chunk_x[current_chunk_pixel] = ipb->startX + kk * ipb->perX;
chunk_y[current_chunk_pixel]
= ipb->startY + current_image_row * ipb->perY;
if ( imd->projection->type == LAT_LONG_PSEUDO_PROJECTION ) {
chunk_x[current_chunk_pixel] *= D2R;
chunk_y[current_chunk_pixel] *= D2R;
}
chunk_z[current_chunk_pixel]
= float_image_get_pixel (iim, kk, current_image_row);
}
}
long current_chunk_pixels = rows_to_load * ii_size_x;
array_unproject_input (ipp, chunk_x, chunk_y, chunk_z, &lat, &lon,
&height, current_chunk_pixels, ipb->datum);
array_project_output (pp, lat, lon, height, &chunk_x, &chunk_y, &chunk_z,
current_chunk_pixels, datum);
for ( jj = 0 ; jj < rows_to_load ; jj++ ) {
size_t current_image_row = ii + jj;
for ( kk = 0 ; kk < ii_size_x ; kk++ ) {
size_t current_chunk_pixel = jj * ii_size_x + kk;
// Current pixel x, y, z coordinates.
//float cp_x = (float) chunk_x[current_chunk_pixel];
//float cp_y = (float) chunk_y[current_chunk_pixel];
float cp_z = (float) chunk_z[current_chunk_pixel];
//float_image_set_pixel (x_coords, kk, current_image_row, cp_x);
//float_image_set_pixel (y_coords, kk, current_image_row, cp_y);
float_image_set_pixel (z_coords, kk, current_image_row, cp_z);
}
}
ii += rows_to_load;
}
asfPrintStatus ("done.\n\n");
#ifdef DEBUG_GEOCODE_DEM_Z_COORDS_IMAGE_AS_JPEG
// Take a look at the z_coordinate image (for debugging).
float_image_export_as_jpeg_with_mask_interval (z_coords, "z_coords.jpg",
GSL_MAX (z_coords->size_x,
z_coords->size_y),
-FLT_MAX, -100);
#endif
g_free (chunk_x);
g_free (chunk_y);
g_free (chunk_z);
g_free (lat);
g_free (lon);
g_free (height);
// Now we want to determine the pixel coordinates in the input which
// correspond to each of the output pixels. We can then sample the
// new height value already computed for that input pixel to
// determine the pixel value to use as output.
// We want to proceed in chunks as we did when going in the other
// direction.
rows_per_chunk = max_transform_chunk_pixels / oi_size_x;
chunk_pixels = rows_per_chunk * oi_size_x;
chunk_x = g_new0 (double, chunk_pixels);
chunk_y = g_new0 (double, chunk_pixels);
// We don't have height information in this direction, nor do we care.
chunk_z = NULL;
lat = g_new0 (double, chunk_pixels);
lon = g_new0 (double, chunk_pixels);
// We don't have height information in this direction, nor do we care.
height = NULL;
asfPrintStatus ("Sampling Z coordinates to form pixels in output projection "
"space... ");
// Transform all the chunks, using the results to form the output image.
for ( ii = 0 ; ii < oi_size_y ; ) {
size_t rows_remaining = oi_size_y - ii;
size_t rows_to_load
= rows_per_chunk < rows_remaining ? rows_per_chunk : rows_remaining;
for ( jj = 0 ; jj < rows_to_load ; jj++ ) {
size_t current_image_row = ii + jj;
for ( kk = 0 ; kk < oi_size_x ; kk++ ) {
size_t current_chunk_pixel = jj * oi_size_x + kk;
chunk_x[current_chunk_pixel] = min_x + kk * pixel_size;
chunk_y[current_chunk_pixel] = max_y - current_image_row * pixel_size;
}
}
long current_chunk_pixels = rows_to_load * oi_size_x;
array_unproject_output (pp, chunk_x, chunk_y, NULL, &lat, &lon, NULL,
current_chunk_pixels, datum);
array_project_input (ipp, lat, lon, NULL, &chunk_x, &chunk_y, NULL,
current_chunk_pixels, ipb->datum);
if ( imd->projection->type == LAT_LONG_PSEUDO_PROJECTION ) {
ssize_t ll; // For (semi)clarity we don't reuse index variable :)
for ( ll = 0 ; ll < current_chunk_pixels ; ll++ ) {
chunk_x[ll] *= R2D;
chunk_y[ll] *= R2D;
}
}
for ( jj = 0 ; jj < rows_to_load ; jj++ ) {
size_t current_image_row = ii + jj;
for ( kk = 0 ; kk < oi_size_x ; kk++ ) {
size_t current_chunk_pixel = jj * oi_size_x + kk;
// Compute pixel coordinates in input image.
ssize_t in_x
= (chunk_x[current_chunk_pixel] - ipb->startX) / ipb->perX;
ssize_t in_y
= (chunk_y[current_chunk_pixel] - ipb->startY) / ipb->perY;
if ( in_image (z_coords, in_x, in_y) ) {
// FIXME: something needs to be done somewhere about
// propogating no data values.
float_image_set_pixel (oim, kk, current_image_row,
float_image_sample (z_coords, in_x, in_y,
resample_method));
}
else {
float_image_set_pixel (oim, kk, current_image_row, background_value);
}
}
}
ii += rows_to_load;
}
asfPrintStatus ("done.\n\n");
g_free (chunk_x);
g_free (chunk_y);
g_free (lat);
g_free (lon);
#ifdef DEBUG_GEOCODE_DEM_OUTPUT_IMAGE_AS_JPEG
// Take a look at the output image (for debugging).
float_image_export_as_jpeg_with_mask_interval (oim, "oim.jpg",
GSL_MAX (oim->size_x,
oim->size_y),
-FLT_MAX, -100);
#endif
// Store the output image.
asfPrintStatus ("Storing output image... ");
char *output_data_file =
(char *) MALLOC(sizeof(char)*(strlen(output_image)+5));
sprintf(output_data_file, "%s.img", output_image);
return_code = float_image_store (oim, output_data_file,
FLOAT_IMAGE_BYTE_ORDER_BIG_ENDIAN);
g_assert (return_code == 0);
asfPrintStatus ("done.\n\n");
// Now we need some metadata for the output image. We will just
// start with the metadata from the input image and add the
// geocoding parameters.
char *input_meta_file = (char *) MALLOC(sizeof(char)*(strlen(input_image)+6));
sprintf(input_meta_file, "%s.meta", input_image);
char *output_meta_file =
(char *) MALLOC(sizeof(char)*(strlen(output_image)+6));
sprintf(output_meta_file, "%s.meta", output_image);
meta_parameters *omd = meta_read (input_meta_file);
// Adjust the metadata to correspond to the output image instead of
// the input image.
omd->general->x_pixel_size = pixel_size;
omd->general->y_pixel_size = pixel_size;
omd->general->line_count = oi_size_y;
omd->general->sample_count = oi_size_x;
// SAR block is not really appropriate for map projected images, but
// since it ended up with this value that can signify map
// projectedness in it somehow, we fill it in for safety.
omd->sar->image_type = 'P';
// Note that we have already verified that the input image is
// projected, and since we initialize the output metadata from there
// we know we will have a projection block.
omd->projection->type = projection_type;
omd->projection->startX = min_x;
omd->projection->startY = max_y;
omd->projection->perX = pixel_size;
omd->projection->perY = -pixel_size;
strcpy (omd->projection->units, "meters");
// Set the spheroid axes lengths as appropriate for the output datum.
spheroid_axes_lengths (datum_spheroid (datum), &(omd->projection->re_major),
&(omd->projection->re_minor));
// What the heck, might as well set the ones in the general block as
// well.
spheroid_axes_lengths (datum_spheroid (datum), &(omd->general->re_major),
&(omd->general->re_minor));
// Latitude and longitude at center of the output image. We will
// set these relative to the spheroid underlying the datum in use
// for the projected image. Yeah, that seems appropriate.
double lat_0, lon_0;
double center_x = omd->projection->startX + (omd->projection->perX
* omd->general->line_count / 2);
double center_y = (omd->projection->startY
+ (omd->projection->perY
* omd->general->sample_count / 2));
unproject_output (pp, center_x, center_y, ASF_PROJ_NO_HEIGHT, &lat_0, &lon_0,
NULL, datum);
omd->general->center_latitude = R2D * lat_0;
omd->general->center_longitude = R2D * lon_0;
// FIXME: We are ignoring the meta_location fields for now since I'm
// not sure whether they are supposed to refer to the corner pixels
// or the corners of the data itself.
if ( lat_0 > 0.0 ) {
omd->projection->hem = 'N';
}
else {
omd->projection->hem = 'S';
}
// Convert the projection parameter values back into degrees.
to_degrees (projection_type, pp);
omd->projection->param = *pp;
meta_write (omd, output_meta_file);
float_image_free (oim);
FREE(output_data_file);
meta_free (omd);
FREE(input_meta_file);
FREE(output_meta_file);
return 0;
}
static void
test_getset(const size_t M, const size_t N, const gsl_rng *r)
{
int status;
size_t i, j;
/* test triplet versions of _get and _set */
{
size_t k = 0;
gsl_spmatrix *m = gsl_spmatrix_alloc(M, N);
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double x = (double) ++k;
double y;
gsl_spmatrix_set(m, i, j, x);
y = gsl_spmatrix_get(m, i, j);
if (x != y)
status = 1;
}
}
gsl_test(status, "test_getset: M=%zu N=%zu _get != _set", M, N);
/* test setting an element to 0 */
gsl_spmatrix_set(m, 0, 0, 1.0);
gsl_spmatrix_set(m, 0, 0, 0.0);
status = gsl_spmatrix_get(m, 0, 0) != 0.0;
gsl_test(status, "test_getset: M=%zu N=%zu m(0,0) = %f",
M, N, gsl_spmatrix_get(m, 0, 0));
/* test gsl_spmatrix_set_zero() */
gsl_spmatrix_set(m, 0, 0, 1.0);
gsl_spmatrix_set_zero(m);
status = gsl_spmatrix_get(m, 0, 0) != 0.0;
gsl_test(status, "test_getset: M=%zu N=%zu set_zero m(0,0) = %f",
M, N, gsl_spmatrix_get(m, 0, 0));
/* resassemble matrix to ensure nz is calculated correctly */
k = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double x = (double) ++k;
gsl_spmatrix_set(m, i, j, x);
}
}
status = gsl_spmatrix_nnz(m) != M * N;
gsl_test(status, "test_getset: M=%zu N=%zu set_zero nz = %zu",
M, N, gsl_spmatrix_nnz(m));
gsl_spmatrix_free(m);
}
/* test duplicate values are handled correctly */
{
size_t min = GSL_MIN(M, N);
size_t expected_nnz = min;
size_t nnz;
size_t k = 0;
gsl_spmatrix *m = gsl_spmatrix_alloc(M, N);
status = 0;
for (i = 0; i < min; ++i)
{
for (j = 0; j < 5; ++j)
{
double x = (double) ++k;
double y;
gsl_spmatrix_set(m, i, i, x);
y = gsl_spmatrix_get(m, i, i);
if (x != y)
status = 1;
}
}
gsl_test(status, "test_getset: duplicate test M=%zu N=%zu _get != _set", M, N);
nnz = gsl_spmatrix_nnz(m);
status = nnz != expected_nnz;
gsl_test(status, "test_getset: duplicate test M=%zu N=%zu nnz=%zu, expected=%zu",
M, N, nnz, expected_nnz);
gsl_spmatrix_free(m);
}
/* test compressed version of gsl_spmatrix_get() */
{
gsl_spmatrix *T = create_random_sparse(M, N, 0.3, r);
gsl_spmatrix *C = gsl_spmatrix_compcol(T);
status = 0;
for (i = 0; i < M; ++i)
{
for (j = 0; j < N; ++j)
{
double Tij = gsl_spmatrix_get(T, i, j);
double Cij = gsl_spmatrix_get(C, i, j);
if (Tij != Cij)
status = 1;
}
}
gsl_test(status, "test_getset: M=%zu N=%zu compressed _get", M, N);
gsl_spmatrix_free(T);
gsl_spmatrix_free(C);
}
} /* test_getset() */
int main(int argc, char **argv) {
gsl_rng *rng;
gsl_rng_env_setup();
const gsl_rng_type *rngType = gsl_rng_default;
rng = gsl_rng_alloc(rngType);
const size_t M = SIZE1;
const size_t N = SIZE2;
gsl_matrix *A = gsl_matrix_alloc(M, N);
int i = 0;
int j = 0;
int sigNum = 0;
for (i = 0; i < M; i++) {
for (j = 0; j < N; j++) {
gsl_matrix_set(A, i, j, gsl_ran_ugaussian(rng));
}
}
gsl_matrix *B = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(B, A);
gsl_matrix *C = gsl_matrix_alloc(M, N);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, B, 0.0, C);
gsl_matrix *D = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(D, C); // will be used in QTQ' decompostion
gsl_linalg_cholesky_decomp(C);
printf("%e\n", gsl_matrix_get(C, M/2, N/2));
gsl_matrix_free(B);
gsl_matrix *A1 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A1, A);
gsl_permutation *P = gsl_permutation_alloc(M); // will be used in
// other cases
gsl_permutation_init(P);
gsl_ran_shuffle (rng, P->data, M, sizeof(size_t));
gsl_linalg_LU_decomp(A1, P, &sigNum);
printf("%e\n", gsl_matrix_get(A1, M/2, N/2));
gsl_matrix *A2 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A2, A);
gsl_vector *tau = gsl_vector_alloc(GSL_MIN(M, N));
gsl_linalg_QR_decomp(A2, tau);
printf("%e\n", gsl_matrix_get(A2, M/2, N/2));
gsl_vector_free(tau);
gsl_matrix *A3 = gsl_matrix_alloc(M, N);
gsl_matrix_memcpy(A3, A);
gsl_matrix *svdV = gsl_matrix_alloc(N, N);
gsl_vector *svdS = gsl_vector_alloc(N);
gsl_vector *svdWorkspace = gsl_vector_alloc(N);
gsl_linalg_SV_decomp(A3, svdV, svdS, svdWorkspace);
printf("%e\n", gsl_vector_get(svdS, N/2));
gsl_vector *tau2 = gsl_vector_alloc(N - 1);
gsl_linalg_symmtd_decomp(D, tau2);
printf("%e\n", gsl_matrix_get(D, N/2, N/2));
return 0;
}
void SimulEpidNegBin(double VarDivMean, parameters *param, gsl_matrix *Incid, gsl_vector *Incid0)
{
// VarDivMean = Variance/Mean of the negative binomial considered
int k, t, g, i, s;
int tMin, tMax;
double lambda;
double prov;
int poiss;
for (k=0 ; k<param->NbGroups ; k++)
{
gsl_matrix_set(Incid,k,0,gsl_vector_get(Incid0,k));
}
for (i=0 ; i<param->p+1 ; i++)
{
if(i==0)
{
tMin=1;
}else
{
tMin=gsl_vector_get(param->tau,i-1);
}
if(i==param->p)
{
tMax=param->T;
}else
{
tMax=gsl_vector_get(param->tau,i);
}
for (t=tMin ; t<tMax ; t++)
{
//printf("t %d\n",t);
//fflush(stdout);
for(k=0 ; k<param->NbGroups ; k++)
{
//printf("k %d\n",k);
//fflush(stdout);
lambda=0;
for(g=0 ; g<param->NbGroups ; g++)
{
//printf("g %d\n",g);
//fflush(stdout);
prov=0;
for(s=1 ; s<=GSL_MIN(t,param->S) ; s++)
{
prov+=gsl_matrix_get(Incid,g,t-s)*gsl_matrix_get(param->GTdistr,g,s-1);
//printf("s %d %lg\n",s,prov);
//fflush(stdout);
}
prov*=gsl_matrix_get(param->K[i],g,k);
//printf("prov %lg\n",prov);
//fflush(stdout);
lambda+=prov;
//printf("lambda %lg\n",lambda);
//fflush(stdout);
}
poiss=gsl_ran_negative_binomial(rng,1/VarDivMean,lambda/(VarDivMean-1));
//printf("lambda %lg inci %d\n",lambda,poiss);
//fflush(stdout);
gsl_matrix_set(Incid,k,t,poiss);
}
}
}
}
static int
brent_iterate (void * vstate, gsl_function * f, double * root, double * x_lower, double * x_upper)
{
brent_state_t * state = (brent_state_t *) vstate;
double tol, m;
int ac_equal = 0;
double a = state->a, b = state->b, c = state->c;
double fa = state->fa, fb = state->fb, fc = state->fc;
double d = state->d, e = state->e;
if ((fb < 0 && fc < 0) || (fb > 0 && fc > 0))
{
ac_equal = 1;
c = a;
fc = fa;
d = b - a;
e = b - a;
}
if (fabs (fc) < fabs (fb))
{
ac_equal = 1;
a = b;
b = c;
c = a;
fa = fb;
fb = fc;
fc = fa;
}
tol = 0.5 * GSL_DBL_EPSILON * fabs (b);
m = 0.5 * (c - b);
if (fb == 0)
{
*root = b;
*x_lower = b;
*x_upper = b;
return GSL_SUCCESS;
}
if (fabs (m) <= tol)
{
*root = b;
if (b < c)
{
*x_lower = b;
*x_upper = c;
}
else
{
*x_lower = c;
*x_upper = b;
}
return GSL_SUCCESS;
}
if (fabs (e) < tol || fabs (fa) <= fabs (fb))
{
d = m; /* use bisection */
e = m;
}
else
{
double p, q, r; /* use inverse cubic interpolation */
double s = fb / fa;
if (ac_equal)
{
p = 2 * m * s;
q = 1 - s;
}
else
{
q = fa / fc;
r = fb / fc;
p = s * (2 * m * q * (q - r) - (b - a) * (r - 1));
q = (q - 1) * (r - 1) * (s - 1);
}
if (p > 0)
{
q = -q;
}
else
{
p = -p;
}
if (2 * p < GSL_MIN (3 * m * q - fabs (tol * q), fabs (e * q)))
{
e = d;
d = p / q;
}
else
{
/* interpolation failed, fall back to bisection */
d = m;
e = m;
}
}
a = b;
fa = fb;
if (fabs (d) > tol)
{
b += d;
}
else
{
b += (m > 0 ? +tol : -tol);
}
SAFE_FUNC_CALL (f, b, &fb);
state->a = a ;
state->b = b ;
state->c = c ;
state->d = d ;
state->e = e ;
state->fa = fa ;
state->fb = fb ;
state->fc = fc ;
/* Update the best estimate of the root and bounds on each
iteration */
*root = b;
if ((fb < 0 && fc < 0) || (fb > 0 && fc > 0))
{
c = a;
}
if (b < c)
{
*x_lower = b;
*x_upper = c;
}
else
{
*x_lower = c;
*x_upper = b;
}
return GSL_SUCCESS ;
}
int
main(int argc, char *argv[])
{
const size_t nmax = 60;
const size_t mmax = GSL_MIN(nmax, 30);
const double R = R_EARTH_KM;
green_workspace *green_p = green_alloc(nmax, mmax, R);
char *knm_file = "data/stage1_knm.dat";
char *sval_file = "data/stage2b_sval.dat";
char *U_file = "data/stage2b_U.dat";
char *variance_file = "variance_time.txt";
char *pc_file = "pc_time.txt";
char *recon_file = "recon_time.txt";
const double var_thresh = 0.99;
gsl_vector *S; /* singular values of SDM */
gsl_matrix *U; /* left singular vectors of SDM */
gsl_matrix *alpha; /* alpha matrix, P-by-nt */
gsl_matrix *knmt; /* knm~ = U*alpha, nnm-by-nt */
gsl_matrix *knm; /* knm(t) matrix */
size_t nnm;
size_t nt; /* number of time stamps */
size_t P; /* number of principal eigenvectors to use (<= T) */
while (1)
{
int c;
int option_index = 0;
static struct option long_options[] =
{
{ 0, 0, 0, 0 }
};
c = getopt_long(argc, argv, "", long_options, &option_index);
if (c == -1)
break;
switch (c)
{
default:
fprintf(stderr, "Usage: %s <-i stage1_matrix_file>\n", argv[0]);
break;
}
}
fprintf(stderr, "main: reading knm matrix from %s...", knm_file);
knm = pca_read_matrix(knm_file);
fprintf(stderr, "done (%zu-by-%zu matrix read)\n", knm->size1, knm->size2);
fprintf(stderr, "main: reading singular values from %s...", sval_file);
S = pca_read_vector(sval_file);
fprintf(stderr, "done (%zu singular values read)\n", S->size);
fprintf(stderr, "main: reading left singular vectors from %s...", U_file);
U = pca_read_matrix(U_file);
fprintf(stderr, "done (%zu-by-%zu matrix read)\n", U->size1, U->size2);
/* plot a variance curve to help decide how many eigenvectors to keep */
fprintf(stderr, "main: writing variance curve to %s...", variance_file);
print_variance(variance_file, S, var_thresh, &P);
fprintf(stderr, "done (%zu singular vectors needed to explain %.1f%% of variance)\n",
P, var_thresh * 100.0);
nnm = U->size1;
nt = knm->size2;
fprintf(stderr, "main: using %zu largest eigenvectors\n", P);
alpha = gsl_matrix_alloc(P, nt);
knmt = gsl_matrix_alloc(nnm, nt);
/* find alpha such that || knm - U*alpha || is
* minimized in a least squares sense */
solve_PCA(P, knm, U, alpha, knmt);
/* plot reconstructed time series using dominant PCs */
{
const size_t n = 3;
const int m = 1;
const size_t cidx = green_nmidx(n, m, green_p);
FILE *fp = fopen(recon_file, "w");
size_t i;
fprintf(stderr, "main: writing reconstructed (%zu,%d) time series to %s...",
n, m, recon_file);
for (i = 0; i < nt; ++i)
{
double t = (double) i;
fprintf(fp, "%f %f %f\n",
t / 24.0,
gsl_matrix_get(knm, cidx, i),
gsl_matrix_get(knmt, cidx, i));
}
fprintf(stderr, "done\n");
fclose(fp);
}
fprintf(stderr, "main: printing principle component maps to %s...",
pc_file);
print_pc_maps(pc_file, U, green_p);
fprintf(stderr, "done\n");
gsl_matrix_free(U);
gsl_matrix_free(alpha);
gsl_matrix_free(knmt);
gsl_matrix_free(knm);
gsl_vector_free(S);
green_free(green_p);
return 0;
}
int
solve_system(const gsl_multilarge_linear_type * T,
const double lambda, const size_t n, const size_t p,
gsl_vector * c)
{
const size_t nblock = 5; /* number of blocks to accumulate */
const size_t nrows = n / nblock; /* number of rows per block */
gsl_multilarge_linear_workspace * w =
gsl_multilarge_linear_alloc(T, p);
gsl_matrix *X = gsl_matrix_alloc(nrows, p);
gsl_vector *y = gsl_vector_alloc(nrows);
gsl_rng *r = gsl_rng_alloc(gsl_rng_default);
size_t rowidx = 0;
double rnorm, snorm, rcond;
double t = 10.0;
double dt = 1.0 / (n - 1.0);
while (rowidx < n)
{
size_t nleft = n - rowidx; /* number of rows left to accumulate */
size_t nr = GSL_MIN(nrows, nleft); /* number of rows in this block */
gsl_matrix_view Xv = gsl_matrix_submatrix(X, 0, 0, nr, p);
gsl_vector_view yv = gsl_vector_subvector(y, 0, nr);
size_t i;
/* build (X,y) block with 'nr' rows */
for (i = 0; i < nr; ++i)
{
gsl_vector_view row = gsl_matrix_row(&Xv.matrix, i);
double yi = func(t);
double ei = gsl_ran_gaussian (r, 0.3 * yi); /* noise */
/* construct this row of LS matrix */
build_row(t, &row.vector);
/* set right hand side value with added noise */
gsl_vector_set(&yv.vector, i, yi + ei);
t += dt;
}
/* accumulate (X,y) block into LS system */
gsl_multilarge_linear_accumulate(&Xv.matrix, &yv.vector, w);
rowidx += nr;
}
/* solve large LS system and store solution in c */
gsl_multilarge_linear_solve(lambda, c, &rnorm, &snorm, w);
/* compute reciprocal condition number */
gsl_multilarge_linear_rcond(&rcond, w);
fprintf(stderr, "=== Method %s ===\n", gsl_multilarge_linear_name(w));
if (rcond != 0.0)
fprintf(stderr, "matrix condition number = %e\n", 1.0 / rcond);
fprintf(stderr, "residual norm = %e\n", rnorm);
fprintf(stderr, "solution norm = %e\n", snorm);
gsl_matrix_free(X);
gsl_vector_free(y);
gsl_multilarge_linear_free(w);
gsl_rng_free(r);
return 0;
}
int gsl_sf_bessel_il_scaled_e(const int l, double x, gsl_sf_result * result)
{
double sgn = 1.0;
double ax = fabs(x);
if(x < 0.0) {
/* i_l(-x) = (-1)^l i_l(x) */
sgn = ( GSL_IS_ODD(l) ? -1.0 : 1.0 );
x = -x;
}
if(l < 0) {
DOMAIN_ERROR(result);
}
else if(x == 0.0) {
result->val = ( l == 0 ? 1.0 : 0.0 );
result->err = 0.0;
return GSL_SUCCESS;
}
else if(l == 0) {
gsl_sf_result il;
int stat_il = gsl_sf_bessel_i0_scaled_e(x, &il);
result->val = sgn * il.val;
result->err = il.err;
return stat_il;
}
else if(l == 1) {
gsl_sf_result il;
int stat_il = gsl_sf_bessel_i1_scaled_e(x, &il);
result->val = sgn * il.val;
result->err = il.err;
return stat_il;
}
else if(l == 2) {
gsl_sf_result il;
int stat_il = gsl_sf_bessel_i2_scaled_e(x, &il);
result->val = sgn * il.val;
result->err = il.err;
return stat_il;
}
else if(x*x < 10.0*(l+1.5)/M_E) {
gsl_sf_result b;
int stat = gsl_sf_bessel_IJ_taylor_e(l+0.5, x, 1, 50, GSL_DBL_EPSILON, &b);
double pre = exp(-ax) * sqrt((0.5*M_PI)/x);
result->val = sgn * pre * b.val;
result->err = pre * b.err;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return stat;
}
else if(l < 150) {
gsl_sf_result i0_scaled;
int stat_i0 = gsl_sf_bessel_i0_scaled_e(ax, &i0_scaled);
double rat;
int stat_CF1 = bessel_il_CF1(l, ax, GSL_DBL_EPSILON, &rat);
double iellp1 = rat * GSL_SQRT_DBL_MIN;
double iell = GSL_SQRT_DBL_MIN;
double iellm1;
int ell;
for(ell = l; ell >= 1; ell--) {
iellm1 = iellp1 + (2*ell + 1)/x * iell;
iellp1 = iell;
iell = iellm1;
}
result->val = sgn * i0_scaled.val * (GSL_SQRT_DBL_MIN / iell);
result->err = i0_scaled.err * (GSL_SQRT_DBL_MIN / iell);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_i0, stat_CF1);
}
else if(GSL_MIN(0.29/(l*l+1.0), 0.5/(l*l+1.0+x*x)) < 0.5*GSL_ROOT3_DBL_EPSILON) {
int status = gsl_sf_bessel_Inu_scaled_asymp_unif_e(l + 0.5, x, result);
double pre = sqrt((0.5*M_PI)/x);
result->val *= sgn * pre;
result->err *= pre;
return status;
}
else {
/* recurse down from safe values */
double rt_term = sqrt((0.5*M_PI)/x);
const int LMAX = 2 + (int) (1.2 / GSL_ROOT6_DBL_EPSILON);
gsl_sf_result r_iellp1;
gsl_sf_result r_iell;
int stat_a1 = gsl_sf_bessel_Inu_scaled_asymp_unif_e(LMAX + 1 + 0.5, x, &r_iellp1);
int stat_a2 = gsl_sf_bessel_Inu_scaled_asymp_unif_e(LMAX + 0.5, x, &r_iell);
double iellp1 = r_iellp1.val;
double iell = r_iell.val;
double iellm1 = 0.0;
int ell;
iellp1 *= rt_term;
iell *= rt_term;
for(ell = LMAX; ell >= l+1; ell--) {
iellm1 = iellp1 + (2*ell + 1)/x * iell;
iellp1 = iell;
iell = iellm1;
}
result->val = sgn * iellm1;
result->err = fabs(result->val)*(GSL_DBL_EPSILON + fabs(r_iellp1.err/r_iellp1.val) + fabs(r_iell.err/r_iell.val));
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
return GSL_ERROR_SELECT_2(stat_a1, stat_a2);
}
}
main (int argc,char *argv[])
{
int ia,ib,ic,id,it,inow,ineigh,icont;
int in,ia2,ia3,irun,icurrent,ORTOGONALFLAG;
int RP, P,L,N,NRUNS,next,sweep,SHOWFLAG;
double u,field1,field2,field0,q,aux1,aux2;
double alfa,aux,Q1,Q2,QZ,RZQ,rho,R;
double pm,D,wmax,mQ,wx,wy,h_sigma,h_mean;
double TOL,MINLOGF,E;
double DELTA;
double E_new,Ex,DeltaE,ER;
double EW,meanhist,hvalue,wE,aratio;
double logG_old,logG_new,lf;
size_t i_old,i_new;
long seed;
double lGvR,lGv,DlG;
size_t iL,iR,i1,i2;
int I_endpoint[NBINS];
double lower,upper;
size_t i0;
FILE * wlsrange;
FILE * dos;
FILE * thermodynamics;
FILE * canonical;
FILE * logfile;
//FILE * pajek;
//***********************************
// Help
//***********************************
if (argc<15){
help();
return(1);
}
else{
DELTA = atof(argv[1]);
P = atoi(argv[2]);
RP = atoi(argv[3]);
L = atoi(argv[4]);
N = atoi(argv[5]);
TOL = atof(argv[6]);
MINLOGF = atof(argv[7]);
}
wlsrange=fopen(argv[8],"w");
dos=fopen(argv[9],"w");
thermodynamics=fopen(argv[10],"w");
canonical=fopen(argv[11],"w");
logfile=fopen(argv[12],"w");
SHOWFLAG = atoi(argv[13]);
ORTOGONALFLAG = atoi(argv[14]);
if ((ORTOGONALFLAG==1) && (P>L)) P=L;
//maximum number of orthogonal issues
if (SHOWFLAG==1){
printf("# parameters are DELTA=%1.2f P=%d ",DELTA,P);
printf("D=%d L=%d M=%d TOL=%1.2f MINLOGF=%g \n",L,N,RP,TOL,MINLOGF);
}
fprintf(logfile,"# parameters are DELTA=%1.2f P=%d D=%d",DELTA,P,L);
fprintf(logfile,"L=%d M=%d TOL=%1.2f MINLOGF=%g\n",L,RP,TOL,MINLOGF);
//**********************************************************************
// Alocate matrices
//**********************************************************************
gsl_matrix * sociedade = gsl_matrix_alloc(SIZE,L);
gsl_matrix * issue = gsl_matrix_alloc(P,L);
gsl_vector * current_issue = gsl_vector_alloc(L);
gsl_vector * v0 = gsl_vector_alloc(L);
gsl_vector * v1 = gsl_vector_alloc(L);
gsl_vector * Z = gsl_vector_alloc(L);
gsl_vector * E_borda = gsl_vector_alloc(NBINS);
//**********************************************************************
// Inicialization
//**********************************************************************
const gsl_rng_type * T;
gsl_rng * r;
gsl_rng_env_setup();
T = gsl_rng_default;
r=gsl_rng_alloc (T);
seed = time (NULL) * getpid();
//seed = 13188839657852;
gsl_rng_set(r,seed);
igraph_t graph;
igraph_vector_t neighbors;
igraph_vector_t result;
igraph_vector_t dim_vector;
igraph_real_t res;
igraph_bool_t C;
igraph_vector_init(&neighbors,1000);
igraph_vector_init(&result,0);
igraph_vector_init(&dim_vector,DIMENSION);
for(ic=0;ic<DIMENSION;ic++) VECTOR(dim_vector)[ic]=N;
gsl_histogram * HE = gsl_histogram_alloc (NBINS);
gsl_histogram * logG = gsl_histogram_alloc (NBINS);
gsl_histogram * LG = gsl_histogram_alloc (NBINS);
//********************************************************************
// Social Graph
//********************************************************************
//Barabasi-Alberts network
igraph_barabasi_game(&graph,SIZE,RP,&result,1,0);
/* for (inow=0;inow<SIZE;inow++){
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
printf("%d ",inow);
for(ic=0;ic<igraph_vector_size(&neighbors);ic++)
{
ineigh=(int)VECTOR(neighbors)[ic];
printf("%d ",ineigh);
}
printf("\n");
}*/
//pajek=fopen("graph.xml","w");
// igraph_write_graph_graphml(&graph,pajek);
//igraph_write_graph_pajek(&graph, pajek);
//fclose(pajek);
//**********************************************************************
//Quenched issues set and Zeitgeist
//**********************************************************************
gsl_vector_set_zero(Z);
gera_config(Z,issue,P,L,r,1.0);
if (ORTOGONALFLAG==1) gsl_matrix_set_identity(issue);
for (ib=0;ib<P;ib++)
{
gsl_matrix_get_row(current_issue,issue,ib);
gsl_blas_ddot(current_issue,current_issue,&Q1);
gsl_vector_scale(current_issue,1/sqrt(Q1));
gsl_vector_add(Z,current_issue);
}
gsl_blas_ddot(Z,Z,&QZ);
gsl_vector_scale(Z,1/sqrt(QZ));
//**********************************************************************
// Ground state energy
//**********************************************************************
double E0;
gera_config(Z,sociedade,SIZE,L,r,0);
E0 = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
double EMIN=E0;
double EMAX=-E0;
double E_old=E0;
gsl_histogram_set_ranges_uniform (HE,EMIN,EMAX);
gsl_histogram_set_ranges_uniform (logG,EMIN,EMAX);
if (SHOWFLAG==1) printf("# ground state: %3.0f\n",E0);
fprintf(logfile,"# ground state: %3.0f\n",E0);
//**********************************************************************
// Find sampling interval
//**********************************************************************
//printf("#finding the sampling interval...\n");
lf=1;
sweep=0;
icont=0;
int iflag=0;
int TMAX=NSWEEPS;
while(sweep<=TMAX){
if (icont==10000) {
//printf("%d sweeps\n",sweep);
icont=0;
}
for(it=0;it<SIZE;it++){
igraph_vector_init(&neighbors,SIZE);
//choose a random site
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v1,sociedade,inow);
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
//generates a random vector v1
gsl_vector_memcpy(v0,v1);
gera_vetor(v1,L,r);
//calculates energy change when v0->v1
// in site inow
DeltaE=variacaoE(v0,v1,inow,sociedade,
issue,N,L,P,DELTA,graph,neighbors);
E_new=E_old+DeltaE;
//WL: accepts in [EMIN,EMAX]
if ((E_new>EMIN) && (E_new<EMAX))
{
gsl_histogram_find(logG,E_old,&i_old);
logG_old=gsl_histogram_get(logG,i_old);
gsl_histogram_find(logG,E_new,&i_new);
logG_new=gsl_histogram_get(logG,i_new);
wE = GSL_MIN(exp(logG_old-logG_new),1);
if (gsl_rng_uniform(r)<wE){
E_old=E_new;
gsl_matrix_set_row(sociedade,inow,v1);
}
}
//WL: update histograms
gsl_histogram_increment(HE,E_old);
gsl_histogram_accumulate(logG,E_old,lf);
igraph_vector_destroy(&neighbors);
}
sweep++;
icont++;
}
gsl_histogram_fprintf(wlsrange,HE,"%g","%g");
double maxH=gsl_histogram_max_val(HE);
//printf("ok\n");
Ex=0;
hvalue=maxH;
while((hvalue>TOL*maxH)&&(Ex>EMIN)){
gsl_histogram_find(HE,Ex,&i0);
hvalue=gsl_histogram_get(HE,i0);
Ex-=1;
if(Ex<=EMAX)TMAX+=10000;
}
EMIN=Ex;
Ex=0;
hvalue=maxH;
while((hvalue>TOL*maxH)&&(Ex<EMAX)) {
gsl_histogram_find(HE,Ex,&i0);
hvalue=gsl_histogram_get(HE,i0);
Ex+=1;
if(Ex>=EMAX)TMAX+=10000;
}
EMAX=Ex;
EMAX=GSL_MIN(10.0,Ex);
if (SHOWFLAG==1)
printf("# the sampling interval is [%3.0f,%3.0f] found in %d sweeps \n\n"
,EMIN,EMAX,sweep);
fprintf(logfile,
"# the sampling interval is [%3.0f,%3.0f] found in %d sweeps \n\n"
,EMIN,EMAX,sweep);
gsl_histogram_set_ranges_uniform (HE,EMIN-1,EMAX+1);
gsl_histogram_set_ranges_uniform (logG,EMIN-1,EMAX+1);
gsl_histogram_set_ranges_uniform (LG,EMIN-1,EMAX+1);
//**********************************************************************
// WLS
//**********************************************************************
int iE,itera=0;
double endpoints[NBINS];
double w = WINDOW; //(EMAX-EMIN)/10.0;
//printf("W=%f\n",w);
lf=1;
//RESOLUTION ----> <------RESOLUTION*****
do{
int iverify=0,iborda=0,flat=0;
sweep=0;
Ex=EMAX;
EW=EMAX;
E_old=EMAX+1;
iE=0;
endpoints[iE]=EMAX;
iE++;
gsl_histogram_reset(LG);
//WINDOWS --> <--WINDOWS*******
while((Ex>EMIN)&&(sweep<MAXSWEEPS)){
//initial config
gera_config(Z,sociedade,SIZE,L,r,0);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
while( (E_old<EMIN+1)||(E_old>Ex) ){
//printf("%d %3.1f\n",E_old);
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v0,sociedade,inow);
gera_vetor(v1,L,r);
gsl_matrix_set_row(sociedade,inow,v1);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
if (E_old>Ex){
gsl_matrix_set_row(sociedade,inow,v0);
E_old = hamiltoneana(sociedade,issue,SIZE,L,P,DELTA,graph);
}
//printf("%3.1f %3.1f %3.1f\n",EMIN+1,E_old, Ex);
}
if (SHOWFLAG==1){
printf("# sampling [%f,%f]\n",EMIN,Ex);
printf("# walking from E=%3.0f\n",E_old);
}
fprintf(logfile,"# sampling [%f,%f]\n",EMIN,Ex);
fprintf(logfile,"# walking from E=%3.0f\n",E_old);
do{ //FLAT WINDOW------> <------FLAT WINDOW*****
//MC sweep ----> <------MC sweep********
for(it=0;it<SIZE;it++){
igraph_vector_init(&neighbors,SIZE);
//escolhe sítio aleatoriamente
do{
inow=gsl_rng_uniform_int(r,SIZE);
}while((inow<0)||(inow>=SIZE));
gsl_matrix_get_row(v1,sociedade,inow);
igraph_neighbors(&graph,&neighbors,inow,IGRAPH_OUT);
//gera vetor aleatorio v1
gsl_vector_memcpy(v0,v1);
gera_vetor(v1,L,r);
//calculates energy change when
//v0->v1 in site inow
DeltaE=variacaoE(v0,v1,inow,sociedade,issue,
N,L,P,DELTA,graph,neighbors);
E_new=E_old+DeltaE;
//WL: accepts in [EMIN,Ex]
if ((E_new>EMIN) && (E_new<Ex))
{
gsl_histogram_find(logG,E_old,&i_old);
logG_old=gsl_histogram_get(logG,i_old);
gsl_histogram_find(logG,E_new,&i_new);
logG_new=gsl_histogram_get(logG,i_new);
wE = GSL_MIN(exp(logG_old-logG_new),1);
if (gsl_rng_uniform(r)<wE){
E_old=E_new;
gsl_matrix_set_row(sociedade,inow,v1);
}
}
//WL: updates histograms
gsl_histogram_increment(HE,E_old);
gsl_histogram_accumulate(logG,E_old,lf);
itera++;
igraph_vector_destroy(&neighbors);
}
//MC sweep ----> <--------MC sweep****
sweep++; iverify++;
if( (EMAX-EMIN)<NDE*DE ) {
EW=EMIN;
}else{
EW=GSL_MAX(Ex-w,EMIN);
}
if (iverify==CHECK){//Verify flatness
if (SHOWFLAG==1)
printf(" #verificando flatness em [%f,%f]\n",EW,Ex);
fprintf(logfile," #verificando flatness em [%f,%f]\n"
,EW,Ex);
iverify=0;
flat=flatness(HE,EW,Ex,TOL,itera,meanhist,hvalue);
if (SHOWFLAG==1)
printf("#minH= %8.0f\t k<H>=%8.0f\t %d sweeps\t ",
hvalue,TOL*meanhist,sweep,flat);
fprintf(logfile,
"#minH= %8.0f\t k<H>=%8.0f\t %d sweeps\t ",
hvalue,TOL*meanhist,sweep,flat);
}
}while(flat==0);// <------FLAT WINDOW******
flat=0;
//Find ER
//printf("# EMAX=%f EMIN = %f Ex =%f\n",EMAX, EMIN, Ex);
if( (EMAX-EMIN)<NDE*DE ) {
Ex=EMIN;
endpoints[iE]=EMIN;
}
else {
if (EW>EMIN){
ER=flatwindow(HE,EW,TOL,meanhist);
if (SHOWFLAG==1)
printf("# extending flatness to[%f,%f]\n",ER,Ex);
fprintf(logfile,
"# extending flatness to [%f,%f]\n",ER,Ex);
if((ER-EMIN)<1){
ER=EMIN;
Ex=EMIN;
endpoints[iE]=EMIN;
}else{
endpoints[iE]=GSL_MIN(ER+DE,EMAX);
Ex=GSL_MIN(ER+2*DE,EMAX);
}
}
else{
endpoints[iE]=EMIN;
Ex=EMIN;
ER=EMIN;
}
}
if (SHOWFLAG==1)
printf("# window %d [%3.0f,%3.0f] is flat after %d sweeps \n",
iE,endpoints[iE],endpoints[iE-1],sweep);
fprintf(logfile,"# window %d [%3.0f,%3.0f] is flat after %d sweeps\n",
iE,endpoints[iE],endpoints[iE-1],sweep);
//saves histogram
if (iE==1){
gsl_histogram_find(logG,endpoints[iE],&i1);
gsl_histogram_find(logG,endpoints[iE-1],&i2);
for(i0=i1;i0<=i2;i0++){
lGv=gsl_histogram_get(logG,i0);
gsl_histogram_get_range(logG,i0,&lower,&upper);
E=0.5*(upper+lower);
gsl_histogram_accumulate(LG,E,lGv);
}
}else{
gsl_histogram_find(logG,endpoints[iE],&i1);
gsl_histogram_find(logG,endpoints[iE-1],&i2);
lGv=gsl_histogram_get(logG,i2);
lGvR=gsl_histogram_get(LG,i2);
DlG=lGvR-lGv;
//printf("i1=%d i2=%d lGv=%f lGvR=%f DlG=%f\n",i1,i2,lGv,lGvR,DlG);
for(i0=i1;i0<i2;i0++){
lGv=gsl_histogram_get(logG,i0);
lGv=lGv+DlG;
gsl_histogram_get_range(logG,i0,&lower,&upper);
E=(upper+lower)*0.5;
//printf("i0=%d E=%f lGv=%f\n",i0,E,lGv);
gsl_histogram_accumulate(LG,E,lGv);
}
}
//printf("#########################################\n");
//gsl_histogram_fprintf(stdout,LG,"%g","%g");
//printf("#########################################\n");
iE++;
if((Ex-EMIN)>NDE*DE) {
if (SHOWFLAG==1)
printf("# random walk is now restricted to [%3.0f,%3.0f]\n"
,EMIN,Ex);
fprintf(logfile,"# random walk is now restricted to [%3.0f,%3.0f]\n"
,EMIN,Ex);
}
gsl_histogram_reset(HE);
}
//WINDOWS -->
if(sweep<MAXSWEEPS){
if (SHOWFLAG==1)
printf("# log(f)=%f converged within %d sweeps\n\n",lf,sweep);
fprintf(logfile,"# log(f)=%f converged within %d sweeps\n\n",lf,sweep);
lf=lf/2.0;
gsl_histogram_reset(HE);
gsl_histogram_memcpy(logG,LG);
}else {
if (SHOWFLAG==1)
printf("# FAILED: no convergence has been attained.");
fprintf(logfile,
"# FAILED: no convergence has been attained. Simulation ABANDONED.");
return(1);
}
}while(lf>MINLOGF);
//RESOLUTION --> <-----RESOLUTION****
//*****************************************************************
//Density of states
//*****************************************************************
double minlogG=gsl_histogram_min_val(logG);
gsl_histogram_shift(logG,-minlogG);
gsl_histogram_fprintf(dos,logG,"%g","%g");
//*****************************************************************
//Thermodynamics
//*****************************************************************
double beta,A,wT,Zmin_beta;
double lGvalue,maxA,betaC,CTMAX=0;
double Z_beta,U,U2,CT,F,S;
for (beta=0.01;beta<=30;beta+=0.01)
{
//******************************************************************
//Energy, free-energy, entropy, specific heat and Tc
//******************************************************************
maxA=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E;
if (A>maxA) maxA=A;
}
gsl_histogram_find(logG,EMIN,&i0);
Z_beta=0;U=0;U2=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E-maxA;
Z_beta+=exp(A);
U+=E*exp(A);
U2+=E*E*exp(A);
if(ia2==i0) Zmin_beta=exp(A);
}
wT=Zmin_beta/Z_beta;
F=-log(Z_beta)/beta - maxA/beta;
U=U/Z_beta;
S= (U-F)*beta;
U2=U2/Z_beta;
CT=(U2-U*U)*beta*beta;
if(CT>CTMAX){
CTMAX=CT;
betaC=beta;
}
fprintf(thermodynamics,"%f %f %f %f %f %f %f \n"
,beta,1/beta,F/(double)(SIZE),S/(double)(SIZE),
U/(double)(SIZE),CT/(double)(SIZE),wT);
}
if (SHOWFLAG==1) printf("# BETAc: %f Tc:%f \n",betaC,1/betaC);
fprintf(logfile,"# BETAc: %f Tc:%f \n",betaC,1/betaC);
//******************************************************************
//canonical distribuition at Tc
//******************************************************************
beta=betaC;
double distr_canonica;
maxA=0;
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E;
if (A>maxA) maxA=A;
}
for (ia2=0; ia2<NBINS;ia2++)
{
lGvalue=gsl_histogram_get(logG,ia2);
gsl_histogram_get_range(logG,ia2,&lower,&upper);
E=(lower+upper)/2;
A=lGvalue-beta*E-maxA;
distr_canonica=exp(A);
fprintf(canonical,"%f %f %f\n",
E/(double)(SIZE),distr_canonica,A);
}
//*****************************************************************
// Finalization
//*****************************************************************
igraph_destroy(&graph);
igraph_vector_destroy(&neighbors);
igraph_vector_destroy(&result);
gsl_matrix_free(issue);
gsl_vector_free(current_issue);
gsl_vector_free(v1);
gsl_vector_free(v0);
gsl_matrix_free(sociedade);
gsl_rng_free(r);
fclose(wlsrange);
fclose(dos);
fclose(thermodynamics);
fclose(canonical);
fclose(logfile);
return(0);
}
int AT_KatzModel_inactivation_cross_section_m2(
const long n,
const double E_MeV_u[],
const long particle_no,
const long material_no,
const long rdd_model,
const double rdd_parameters[],
const long er_model,
const double gamma_parameters[],
const long stop_power_source,
double inactivation_cross_section_m2[]){
const double D0_characteristic_dose_Gy = gamma_parameters[1];
const double c_hittedness = gamma_parameters[2];
const double m_number_of_targets = gamma_parameters[3];
if( rdd_model == RDD_KatzExtTarget ){
long i;
for( i = 0 ; i < n ; i++){
const double max_electron_range_m = AT_max_electron_range_m( E_MeV_u[i], (int)material_no, (int)er_model);
const double a0_m = rdd_parameters[1];
const double KatzPoint_r_min_m = AT_RDD_r_min_m( max_electron_range_m, rdd_model, rdd_parameters );
const double Katz_point_coeff_Gy = AT_RDD_Katz_coeff_Gy_general( E_MeV_u[i], particle_no, material_no, er_model);
const double r_max_m = GSL_MIN(a0_m, max_electron_range_m);
double Katz_plateau_Gy = 0.0;
double alpha = 0.0;
if( (er_model == ER_Waligorski) || (er_model == ER_Edmund) ){ // "new" Katz RDD
alpha = AT_ER_PowerLaw_alpha(E_MeV_u[i]);
Katz_plateau_Gy = AT_RDD_Katz_PowerLawER_Daverage_Gy( KatzPoint_r_min_m, r_max_m, max_electron_range_m, alpha, Katz_point_coeff_Gy );
} else if (er_model == ER_ButtsKatz){ // "old" Katz RDD
Katz_plateau_Gy = AT_RDD_Katz_LinearER_Daverage_Gy( KatzPoint_r_min_m, r_max_m, max_electron_range_m, Katz_point_coeff_Gy );
}
inactivation_cross_section_m2[i] = AT_KatzModel_KatzExtTarget_inactivation_cross_section_m2(
a0_m,
KatzPoint_r_min_m,
max_electron_range_m,
er_model,
alpha,
Katz_plateau_Gy,
Katz_point_coeff_Gy,
D0_characteristic_dose_Gy,
c_hittedness,
m_number_of_targets);
}
return EXIT_SUCCESS;
}
if( rdd_model == RDD_CucinottaExtTarget ){
long i;
const double density_g_cm3 = AT_density_g_cm3_from_material_no( material_no );
const double density_kg_m3 = density_g_cm3 * 1000.0;
for( i = 0 ; i < n ; i++){
const double max_electron_range_m = AT_max_electron_range_m( E_MeV_u[i], (int)material_no, (int)er_model);
const double a0_m = rdd_parameters[1]; // AT_RDD_a0_m( max_electron_range_m, rdd_model, rdd_parameters );
const double KatzPoint_r_min_m = AT_RDD_r_min_m( max_electron_range_m, rdd_model, rdd_parameters );
const double Katz_point_coeff_Gy = AT_RDD_Katz_coeff_Gy_general( E_MeV_u[i], particle_no, material_no, er_model);
const double r_max_m = GSL_MIN(a0_m, max_electron_range_m);
double LET_MeV_cm2_g;
AT_Mass_Stopping_Power_with_no( stop_power_source,
n,
&E_MeV_u[i],
&particle_no,
material_no,
&LET_MeV_cm2_g);
const double LET_J_m = LET_MeV_cm2_g * density_g_cm3 * 100.0 * MeV_to_J; // [MeV / cm] -> [J/m]
const double beta = AT_beta_from_E_single( E_MeV_u[i] );
const double C_norm = AT_RDD_Cucinotta_Cnorm(KatzPoint_r_min_m, max_electron_range_m, beta, density_kg_m3, LET_J_m, Katz_point_coeff_Gy);
double Cucinotta_plateau_Gy = AT_RDD_Cucinotta_Ddelta_average_Gy( KatzPoint_r_min_m, r_max_m, max_electron_range_m, beta, Katz_point_coeff_Gy);
Cucinotta_plateau_Gy += C_norm * AT_RDD_Cucinotta_Dexc_average_Gy( KatzPoint_r_min_m, r_max_m, max_electron_range_m, beta, Katz_point_coeff_Gy);
inactivation_cross_section_m2[i] = AT_KatzModel_CucinottaExtTarget_inactivation_cross_section_m2(
a0_m,
KatzPoint_r_min_m,
max_electron_range_m,
beta,
C_norm,
Cucinotta_plateau_Gy,
Katz_point_coeff_Gy,
D0_characteristic_dose_Gy,
c_hittedness,
m_number_of_targets);
}
return EXIT_SUCCESS;
}
char rdd_name[200];
AT_RDD_name_from_number(rdd_model, rdd_name);
#ifndef NDEBUG
fprintf(stderr, "RDD model %ld [%s] not supported\n", rdd_model, rdd_name);
#endif
return EXIT_FAILURE;
}
int
gsl_linalg_QRPT_decomp (gsl_matrix * A, gsl_vector * tau, gsl_permutation * p, int *signum, gsl_vector * norm)
{
const size_t M = A->size1;
const size_t N = A->size2;
if (tau->size != GSL_MIN (M, N))
{
GSL_ERROR ("size of tau must be MIN(M,N)", GSL_EBADLEN);
}
else if (p->size != N)
{
GSL_ERROR ("permutation size must be N", GSL_EBADLEN);
}
else if (norm->size != N)
{
GSL_ERROR ("norm size must be N", GSL_EBADLEN);
}
else
{
size_t i;
*signum = 1;
gsl_permutation_init (p); /* set to identity */
/* Compute column norms and store in workspace */
for (i = 0; i < N; i++)
{
gsl_vector_view c = gsl_matrix_column (A, i);
double x = gsl_blas_dnrm2 (&c.vector);
gsl_vector_set (norm, i, x);
}
for (i = 0; i < GSL_MIN (M, N); i++)
{
/* Bring the column of largest norm into the pivot position */
double max_norm = gsl_vector_get(norm, i);
size_t j, kmax = i;
for (j = i + 1; j < N; j++)
{
double x = gsl_vector_get (norm, j);
if (x > max_norm)
{
max_norm = x;
kmax = j;
}
}
if (kmax != i)
{
gsl_matrix_swap_columns (A, i, kmax);
gsl_permutation_swap (p, i, kmax);
gsl_vector_swap_elements(norm,i,kmax);
(*signum) = -(*signum);
}
/* Compute the Householder transformation to reduce the j-th
column of the matrix to a multiple of the j-th unit vector */
{
gsl_vector_view c_full = gsl_matrix_column (A, i);
gsl_vector_view c = gsl_vector_subvector (&c_full.vector,
i, M - i);
double tau_i = gsl_linalg_householder_transform (&c.vector);
gsl_vector_set (tau, i, tau_i);
/* Apply the transformation to the remaining columns */
if (i + 1 < N)
{
gsl_matrix_view m = gsl_matrix_submatrix (A, i, i + 1, M - i, N - (i+1));
gsl_linalg_householder_hm (tau_i, &c.vector, &m.matrix);
}
}
/* Update the norms of the remaining columns too */
if (i + 1 < M)
{
for (j = i + 1; j < N; j++)
{
double y = 0;
double x = gsl_vector_get (norm, j);
if (x > 0.0)
{
double temp= gsl_matrix_get (A, i, j) / x;
if (fabs (temp) >= 1)
y = 0.0;
else
y = y * sqrt (1 - temp * temp);
/* recompute norm to prevent loss of accuracy */
if (fabs (y / x) < sqrt (20.0) * GSL_SQRT_DBL_EPSILON)
{
gsl_vector_view c_full = gsl_matrix_column (A, j);
gsl_vector_view c =
gsl_vector_subvector(&c_full.vector,
i+1, M - (i+1));
y = gsl_blas_dnrm2 (&c.vector);
}
gsl_vector_set (norm, j, y);
}
}
}
}
return GSL_SUCCESS;
}
}
int
gsl_monte_vegas_integrate (gsl_monte_function * f,
double xl[], double xu[],
size_t dim, size_t calls,
gsl_rng * r,
gsl_monte_vegas_state * state,
double *result, double *abserr)
{
double cum_int, cum_sig;
size_t i, k, it;
if (dim != state->dim)
{
GSL_ERROR ("number of dimensions must match allocated size", GSL_EINVAL);
}
for (i = 0; i < dim; i++)
{
if (xu[i] <= xl[i])
{
GSL_ERROR ("xu must be greater than xl", GSL_EINVAL);
}
if (xu[i] - xl[i] > GSL_DBL_MAX)
{
GSL_ERROR ("Range of integration is too large, please rescale",
GSL_EINVAL);
}
}
if (state->stage == 0)
{
init_grid (state, xl, xu, dim);
if (state->verbose >= 0)
{
print_lim (state, xl, xu, dim);
}
}
if (state->stage <= 1)
{
state->wtd_int_sum = 0;
state->sum_wgts = 0;
state->chi_sum = 0;
state->it_num = 1;
state->samples = 0;
state->chisq = 0;
}
if (state->stage <= 2)
{
unsigned int bins = state->bins_max;
unsigned int boxes = 1;
if (state->mode != GSL_VEGAS_MODE_IMPORTANCE_ONLY)
{
/* shooting for 2 calls/box */
boxes = floor (pow (calls / 2.0, 1.0 / dim));
state->mode = GSL_VEGAS_MODE_IMPORTANCE;
if (2 * boxes >= state->bins_max)
{
/* if bins/box < 2 */
int box_per_bin = GSL_MAX (boxes / state->bins_max, 1);
bins = GSL_MIN(boxes / box_per_bin, state->bins_max);
boxes = box_per_bin * bins;
state->mode = GSL_VEGAS_MODE_STRATIFIED;
}
}
{
double tot_boxes = gsl_pow_int ((double) boxes, dim);
state->calls_per_box = GSL_MAX (calls / tot_boxes, 2);
calls = state->calls_per_box * tot_boxes;
}
/* total volume of x-space/(avg num of calls/bin) */
state->jac = state->vol * pow ((double) bins, (double) dim) / calls;
state->boxes = boxes;
/* If the number of bins changes from the previous invocation, bins
are expanded or contracted accordingly, while preserving bin
density */
if (bins != state->bins)
{
resize_grid (state, bins);
if (state->verbose > 1)
{
print_grid (state, dim);
}
}
if (state->verbose >= 0)
{
print_head (state,
dim, calls, state->it_num, state->bins, state->boxes);
}
}
state->it_start = state->it_num;
cum_int = 0.0;
cum_sig = 0.0;
for (it = 0; it < state->iterations; it++)
{
double intgrl = 0.0, intgrl_sq = 0.0;
double tss = 0.0;
double wgt, var, sig;
size_t calls_per_box = state->calls_per_box;
double jacbin = state->jac;
double *x = state->x;
coord *bin = state->bin;
state->it_num = state->it_start + it;
reset_grid_values (state);
init_box_coord (state, state->box);
do
{
volatile double m = 0, q = 0;
double f_sq_sum = 0.0;
for (k = 0; k < calls_per_box; k++)
{
volatile double fval;
double bin_vol;
random_point (x, bin, &bin_vol, state->box, xl, xu, state, r);
fval = jacbin * bin_vol * GSL_MONTE_FN_EVAL (f, x);
/* recurrence for mean and variance (sum of squares) */
{
double d = fval - m;
m += d / (k + 1.0);
q += d * d * (k / (k + 1.0));
}
if (state->mode != GSL_VEGAS_MODE_STRATIFIED)
{
double f_sq = fval * fval;
accumulate_distribution (state, bin, f_sq);
}
}
intgrl += m * calls_per_box;
f_sq_sum = q * calls_per_box;
tss += f_sq_sum;
if (state->mode == GSL_VEGAS_MODE_STRATIFIED)
{
accumulate_distribution (state, bin, f_sq_sum);
}
}
while (change_box_coord (state, state->box));
/* Compute final results for this iteration */
var = tss / (calls_per_box - 1.0) ;
if (var > 0)
{
wgt = 1.0 / var;
}
else if (state->sum_wgts > 0)
{
wgt = state->sum_wgts / state->samples;
}
else
{
wgt = 0.0;
}
intgrl_sq = intgrl * intgrl;
sig = sqrt (var);
state->result = intgrl;
state->sigma = sig;
if (wgt > 0.0)
{
double sum_wgts = state->sum_wgts;
double wtd_int_sum = state->wtd_int_sum;
double m = (sum_wgts > 0) ? (wtd_int_sum / sum_wgts) : 0;
double q = intgrl - m;
state->samples++ ;
state->sum_wgts += wgt;
state->wtd_int_sum += intgrl * wgt;
state->chi_sum += intgrl_sq * wgt;
cum_int = state->wtd_int_sum / state->sum_wgts;
cum_sig = sqrt (1 / state->sum_wgts);
#if USE_ORIGINAL_CHISQ_FORMULA
/* This is the chisq formula from the original Lepage paper. It
computes the variance from <x^2> - <x>^2 and can suffer from
catastrophic cancellations, e.g. returning negative chisq. */
if (state->samples > 1)
{
state->chisq = (state->chi_sum - state->wtd_int_sum * cum_int) /
(state->samples - 1.0);
}
#else
/* The new formula below computes exactly the same quantity as above
but using a stable recurrence */
if (state->samples == 1) {
state->chisq = 0;
} else {
state->chisq *= (state->samples - 2.0);
state->chisq += (wgt / (1 + (wgt / sum_wgts))) * q * q;
state->chisq /= (state->samples - 1.0);
}
#endif
}
else
{
cum_int += (intgrl - cum_int) / (it + 1.0);
cum_sig = 0.0;
}
if (state->verbose >= 0)
{
print_res (state,
state->it_num, intgrl, sig, cum_int, cum_sig,
state->chisq);
if (it + 1 == state->iterations && state->verbose > 0)
{
print_grid (state, dim);
}
}
if (state->verbose > 1)
{
print_dist (state, dim);
}
refine_grid (state);
if (state->verbose > 1)
{
print_grid (state, dim);
}
}
/* By setting stage to 1 further calls will generate independent
estimates based on the same grid, although it may be rebinned. */
state->stage = 1;
*result = cum_int;
*abserr = cum_sig;
return GSL_SUCCESS;
}
int
gsl_linalg_QR_update (gsl_matrix * Q, gsl_matrix * R,
gsl_vector * w, const gsl_vector * v)
{
const size_t M = R->size1;
const size_t N = R->size2;
if (Q->size1 != M || Q->size2 != M)
{
GSL_ERROR ("Q matrix must be M x M if R is M x N", GSL_ENOTSQR);
}
else if (w->size != M)
{
GSL_ERROR ("w must be length M if R is M x N", GSL_EBADLEN);
}
else if (v->size != N)
{
GSL_ERROR ("v must be length N if R is M x N", GSL_EBADLEN);
}
else
{
size_t j, k;
double w0;
/* Apply Given's rotations to reduce w to (|w|, 0, 0, ... , 0)
J_1^T .... J_(n-1)^T w = +/- |w| e_1
simultaneously applied to R, H = J_1^T ... J^T_(n-1) R
so that H is upper Hessenberg. (12.5.2) */
for (k = M - 1; k > 0; k--) /* loop from k = M-1 to 1 */
{
double c, s;
double wk = gsl_vector_get (w, k);
double wkm1 = gsl_vector_get (w, k - 1);
gsl_linalg_givens (wkm1, wk, &c, &s);
gsl_linalg_givens_gv (w, k - 1, k, c, s);
apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
}
w0 = gsl_vector_get (w, 0);
/* Add in w v^T (Equation 12.5.3) */
for (j = 0; j < N; j++)
{
double r0j = gsl_matrix_get (R, 0, j);
double vj = gsl_vector_get (v, j);
gsl_matrix_set (R, 0, j, r0j + w0 * vj);
}
/* Apply Givens transformations R' = G_(n-1)^T ... G_1^T H
Equation 12.5.4 */
for (k = 1; k < GSL_MIN(M,N+1); k++)
{
double c, s;
double diag = gsl_matrix_get (R, k - 1, k - 1);
double offdiag = gsl_matrix_get (R, k, k - 1);
gsl_linalg_givens (diag, offdiag, &c, &s);
apply_givens_qr (M, N, Q, R, k - 1, k, c, s);
gsl_matrix_set (R, k, k - 1, 0.0); /* exact zero of G^T */
}
return GSL_SUCCESS;
}
}
int
gsl_multifit_linear_wstdform2 (const gsl_matrix * LQR,
const gsl_vector * Ltau,
const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
gsl_matrix * Xs,
gsl_vector * ys,
gsl_matrix * M,
gsl_multifit_linear_workspace * work)
{
const size_t m = LQR->size1;
const size_t n = X->size1;
const size_t p = X->size2;
if (n > work->nmax || p > work->pmax)
{
GSL_ERROR("observation matrix larger than workspace", GSL_EBADLEN);
}
else if (p != LQR->size2)
{
GSL_ERROR("LQR and X matrices have different numbers of columns", GSL_EBADLEN);
}
else if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("weights vector must be length n", GSL_EBADLEN);
}
else if (m >= p) /* square or tall L matrix */
{
/* the sizes of Xs and ys depend on whether m >= p or m < p */
if (n != Xs->size1 || p != Xs->size2)
{
GSL_ERROR("Xs matrix must be n-by-p", GSL_EBADLEN);
}
else if (n != ys->size)
{
GSL_ERROR("ys vector must have length n", GSL_EBADLEN);
}
else
{
int status;
size_t i;
gsl_matrix_const_view R = gsl_matrix_const_submatrix(LQR, 0, 0, p, p);
/* compute Xs = sqrt(W) X and ys = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, Xs, ys);
if (status)
return status;
/* compute X~ = X R^{-1} using QR decomposition of L */
for (i = 0; i < n; ++i)
{
gsl_vector_view v = gsl_matrix_row(Xs, i);
/* solve: R^T y = X_i */
gsl_blas_dtrsv(CblasUpper, CblasTrans, CblasNonUnit, &R.matrix, &v.vector);
}
return GSL_SUCCESS;
}
}
else /* L matrix with m < p */
{
const size_t pm = p - m;
const size_t npm = n - pm;
/*
* This code closely follows section 2.6.1 of Hansen's
* "Regularization Tools" manual
*/
if (npm != Xs->size1 || m != Xs->size2)
{
GSL_ERROR("Xs matrix must be (n-p+m)-by-m", GSL_EBADLEN);
}
else if (npm != ys->size)
{
GSL_ERROR("ys vector must be of length (n-p+m)", GSL_EBADLEN);
}
else if (n != M->size1 || p != M->size2)
{
GSL_ERROR("M matrix must be n-by-p", GSL_EBADLEN);
}
else
{
int status;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view b = gsl_vector_subvector(work->t, 0, n);
gsl_matrix_view LTQR = gsl_matrix_view_array(LQR->data, p, m); /* qr(L^T) */
gsl_matrix_view Rp = gsl_matrix_view_array(LQR->data, m, m); /* R factor of L^T */
gsl_vector_const_view LTtau = gsl_vector_const_subvector(Ltau, 0, m);
/*
* M(:,1:p-m) will hold QR decomposition of A K_o; M(:,p) will hold
* Householder scalars
*/
gsl_matrix_view MQR = gsl_matrix_submatrix(M, 0, 0, n, pm);
gsl_vector_view Mtau = gsl_matrix_subcolumn(M, p - 1, 0, GSL_MIN(n, pm));
gsl_matrix_view AKo, AKp, HqTAKp;
gsl_vector_view v;
size_t i;
/* compute A = sqrt(W) X and b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, &A.matrix, &b.vector);
if (status)
return status;
/* compute: A <- A K = [ A K_p ; A K_o ] */
gsl_linalg_QR_matQ(<QR.matrix, <tau.vector, &A.matrix);
AKp = gsl_matrix_submatrix(&A.matrix, 0, 0, n, m);
AKo = gsl_matrix_submatrix(&A.matrix, 0, m, n, pm);
/* compute QR decomposition [H,T] = qr(A * K_o) and store in M */
gsl_matrix_memcpy(&MQR.matrix, &AKo.matrix);
gsl_linalg_QR_decomp(&MQR.matrix, &Mtau.vector);
/* AKp currently contains A K_p; apply H^T from the left to get H^T A K_p */
gsl_linalg_QR_QTmat(&MQR.matrix, &Mtau.vector, &AKp.matrix);
/* the last npm rows correspond to H_q^T A K_p */
HqTAKp = gsl_matrix_submatrix(&AKp.matrix, pm, 0, npm, m);
/* solve: Xs R_p^T = H_q^T A K_p for Xs */
gsl_matrix_memcpy(Xs, &HqTAKp.matrix);
for (i = 0; i < npm; ++i)
{
gsl_vector_view x = gsl_matrix_row(Xs, i);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &Rp.matrix, &x.vector);
}
/*
* compute: ys = H_q^T b; this is equivalent to computing
* the last q elements of H^T b (q = npm)
*/
v = gsl_vector_subvector(&b.vector, pm, npm);
gsl_linalg_QR_QTvec(&MQR.matrix, &Mtau.vector, &b.vector);
gsl_vector_memcpy(ys, &v.vector);
return GSL_SUCCESS;
}
}
}
static int
lmder_alloc (void *vstate, size_t n, size_t p)
{
lmder_state_t *state = (lmder_state_t *) vstate;
gsl_matrix *r;
gsl_vector *tau, *diag, *qtf, *newton, *gradient, *x_trial, *f_trial,
*df, *sdiag, *rptdx, *w, *work1;
gsl_permutation *perm;
r = gsl_matrix_calloc (n, p);
if (r == 0)
{
GSL_ERROR ("failed to allocate space for r", GSL_ENOMEM);
}
state->r = r;
tau = gsl_vector_calloc (GSL_MIN(n, p));
if (tau == 0)
{
gsl_matrix_free (r);
GSL_ERROR ("failed to allocate space for tau", GSL_ENOMEM);
}
state->tau = tau;
diag = gsl_vector_calloc (p);
if (diag == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
GSL_ERROR ("failed to allocate space for diag", GSL_ENOMEM);
}
state->diag = diag;
qtf = gsl_vector_calloc (n);
if (qtf == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
GSL_ERROR ("failed to allocate space for qtf", GSL_ENOMEM);
}
state->qtf = qtf;
newton = gsl_vector_calloc (p);
if (newton == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
GSL_ERROR ("failed to allocate space for newton", GSL_ENOMEM);
}
state->newton = newton;
gradient = gsl_vector_calloc (p);
if (gradient == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
GSL_ERROR ("failed to allocate space for gradient", GSL_ENOMEM);
}
state->gradient = gradient;
x_trial = gsl_vector_calloc (p);
if (x_trial == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
GSL_ERROR ("failed to allocate space for x_trial", GSL_ENOMEM);
}
state->x_trial = x_trial;
f_trial = gsl_vector_calloc (n);
if (f_trial == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
GSL_ERROR ("failed to allocate space for f_trial", GSL_ENOMEM);
}
state->f_trial = f_trial;
df = gsl_vector_calloc (n);
if (df == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
GSL_ERROR ("failed to allocate space for df", GSL_ENOMEM);
}
state->df = df;
sdiag = gsl_vector_calloc (p);
if (sdiag == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
GSL_ERROR ("failed to allocate space for sdiag", GSL_ENOMEM);
}
state->sdiag = sdiag;
rptdx = gsl_vector_calloc (n);
if (rptdx == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (sdiag);
GSL_ERROR ("failed to allocate space for rptdx", GSL_ENOMEM);
}
state->rptdx = rptdx;
w = gsl_vector_calloc (n);
if (w == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (sdiag);
gsl_vector_free (rptdx);
GSL_ERROR ("failed to allocate space for w", GSL_ENOMEM);
}
state->w = w;
work1 = gsl_vector_calloc (p);
if (work1 == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (sdiag);
gsl_vector_free (rptdx);
gsl_vector_free (w);
GSL_ERROR ("failed to allocate space for work1", GSL_ENOMEM);
}
state->work1 = work1;
perm = gsl_permutation_calloc (p);
if (perm == 0)
{
gsl_matrix_free (r);
gsl_vector_free (tau);
gsl_vector_free (diag);
gsl_vector_free (qtf);
gsl_vector_free (newton);
gsl_vector_free (gradient);
gsl_vector_free (x_trial);
gsl_vector_free (f_trial);
gsl_vector_free (df);
gsl_vector_free (sdiag);
gsl_vector_free (rptdx);
gsl_vector_free (w);
gsl_vector_free (work1);
GSL_ERROR ("failed to allocate space for perm", GSL_ENOMEM);
}
state->perm = perm;
return GSL_SUCCESS;
}
int
gsl_multifit_linear_wgenform2 (const gsl_matrix * LQR,
const gsl_vector * Ltau,
const gsl_matrix * X,
const gsl_vector * w,
const gsl_vector * y,
const gsl_vector * cs,
const gsl_matrix * M,
gsl_vector * c,
gsl_multifit_linear_workspace * work)
{
const size_t m = LQR->size1;
const size_t n = X->size1;
const size_t p = X->size2;
if (n > work->nmax || p > work->pmax)
{
GSL_ERROR("X matrix does not match workspace", GSL_EBADLEN);
}
else if (p != LQR->size2)
{
GSL_ERROR("LQR matrix does not match X", GSL_EBADLEN);
}
else if (p != c->size)
{
GSL_ERROR("c vector does not match X", GSL_EBADLEN);
}
else if (w != NULL && n != w->size)
{
GSL_ERROR("w vector does not match X", GSL_EBADLEN);
}
else if (n != y->size)
{
GSL_ERROR("y vector does not match X", GSL_EBADLEN);
}
else if (m >= p) /* square or tall L matrix */
{
if (p != cs->size)
{
GSL_ERROR("cs vector must be length p", GSL_EBADLEN);
}
else
{
int s;
gsl_matrix_const_view R = gsl_matrix_const_submatrix(LQR, 0, 0, p, p); /* R factor of L */
/* solve R c = cs for true solution c, using QR decomposition of L */
gsl_vector_memcpy(c, cs);
s = gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, c);
return s;
}
}
else /* rectangular L matrix with m < p */
{
if (m != cs->size)
{
GSL_ERROR("cs vector must be length m", GSL_EBADLEN);
}
else if (n != M->size1 || p != M->size2)
{
GSL_ERROR("M matrix must be size n-by-p", GSL_EBADLEN);
}
else
{
int status;
const size_t pm = p - m;
gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
gsl_vector_view b = gsl_vector_subvector(work->t, 0, n);
gsl_matrix_view Rp = gsl_matrix_view_array(LQR->data, m, m); /* R_p */
gsl_matrix_view LTQR = gsl_matrix_view_array(LQR->data, p, m);
gsl_vector_const_view LTtau = gsl_vector_const_subvector(Ltau, 0, m);
gsl_matrix_const_view MQR = gsl_matrix_const_submatrix(M, 0, 0, n, pm);
gsl_vector_const_view Mtau = gsl_matrix_const_subcolumn(M, p - 1, 0, GSL_MIN(n, pm));
gsl_matrix_const_view To = gsl_matrix_const_submatrix(&MQR.matrix, 0, 0, pm, pm);
gsl_vector_view workp = gsl_vector_subvector(work->xt, 0, p);
gsl_vector_view v1, v2;
/* compute A = sqrt(W) X and b = sqrt(W) y */
status = gsl_multifit_linear_applyW(X, w, y, &A.matrix, &b.vector);
if (status)
return status;
/* initialize c to zero */
gsl_vector_set_zero(c);
/* compute c = L_inv cs = K_p R_p^{-T} cs */
/* set c(1:m) = R_p^{-T} cs */
v1 = gsl_vector_subvector(c, 0, m);
gsl_vector_memcpy(&v1.vector, cs);
gsl_blas_dtrsv(CblasUpper, CblasTrans, CblasNonUnit, &Rp.matrix, &v1.vector);
/* c <- K R_p^{-T} cs = [ K_p R_p^{_T} cs ; 0 ] */
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, c);
/* compute: b1 = b - A L_inv cs */
gsl_blas_dgemv(CblasNoTrans, -1.0, &A.matrix, c, 1.0, &b.vector);
/* compute: b2 = H^T b1 */
gsl_linalg_QR_QTvec(&MQR.matrix, &Mtau.vector, &b.vector);
/* compute: b3 = T_o^{-1} b2 */
v1 = gsl_vector_subvector(&b.vector, 0, pm);
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &To.matrix, &v1.vector);
/* compute: b4 = K_o b3 */
gsl_vector_set_zero(&workp.vector);
v2 = gsl_vector_subvector(&workp.vector, m, pm);
gsl_vector_memcpy(&v2.vector, &v1.vector);
gsl_linalg_QR_Qvec(<QR.matrix, <tau.vector, &workp.vector);
/* final solution vector */
gsl_vector_add(c, &workp.vector);
return GSL_SUCCESS;
}
}
}
int
gsl_sf_bessel_In_scaled_e(int n, const double x, gsl_sf_result * result)
{
const double ax = fabs(x);
n = abs(n); /* I(-n, z) = I(n, z) */
/* CHECK_POINTER(result) */
if(n == 0) {
return gsl_sf_bessel_I0_scaled_e(x, result);
}
else if(n == 1) {
return gsl_sf_bessel_I1_scaled_e(x, result);
}
else if(x == 0.0) {
result->val = 0.0;
result->err = 0.0;
return GSL_SUCCESS;
}
else if(x*x < 10.0*(n+1.0)/M_E) {
gsl_sf_result t;
double ex = exp(-ax);
int stat_In = gsl_sf_bessel_IJ_taylor_e((double)n, ax, 1, 50, GSL_DBL_EPSILON, &t);
result->val = t.val * ex;
result->err = t.err * ex;
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
if(x < 0.0 && GSL_IS_ODD(n)) result->val = -result->val;
return stat_In;
}
else if(n < 150 && ax < 1e7) {
gsl_sf_result I0_scaled;
int stat_I0 = gsl_sf_bessel_I0_scaled_e(ax, &I0_scaled);
double rat;
int stat_CF1 = gsl_sf_bessel_I_CF1_ser((double)n, ax, &rat);
double Ikp1 = rat * GSL_SQRT_DBL_MIN;
double Ik = GSL_SQRT_DBL_MIN;
double Ikm1;
int k;
for(k=n; k >= 1; k--) {
Ikm1 = Ikp1 + 2.0*k/ax * Ik;
Ikp1 = Ik;
Ik = Ikm1;
}
result->val = I0_scaled.val * (GSL_SQRT_DBL_MIN / Ik);
result->err = I0_scaled.err * (GSL_SQRT_DBL_MIN / Ik);
result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
if(x < 0.0 && GSL_IS_ODD(n)) result->val = -result->val;
return GSL_ERROR_SELECT_2(stat_I0, stat_CF1);
}
else if( GSL_MIN( 0.29/(n*n), 0.5/(n*n + x*x) ) < 0.5*GSL_ROOT3_DBL_EPSILON) {
int stat_as = gsl_sf_bessel_Inu_scaled_asymp_unif_e((double)n, ax, result);
if(x < 0.0 && GSL_IS_ODD(n)) result->val = -result->val;
return stat_as;
}
else {
const int nhi = 2 + (int) (1.2 / GSL_ROOT6_DBL_EPSILON);
gsl_sf_result r_Ikp1;
gsl_sf_result r_Ik;
int stat_a1 = gsl_sf_bessel_Inu_scaled_asymp_unif_e(nhi+1.0, ax, &r_Ikp1);
int stat_a2 = gsl_sf_bessel_Inu_scaled_asymp_unif_e((double)nhi, ax, &r_Ik);
double Ikp1 = r_Ikp1.val;
double Ik = r_Ik.val;
double Ikm1;
int k;
for(k=nhi; k > n; k--) {
Ikm1 = Ikp1 + 2.0*k/ax * Ik;
Ikp1 = Ik;
Ik = Ikm1;
}
result->val = Ik;
result->err = Ik * (r_Ikp1.err/r_Ikp1.val + r_Ik.err/r_Ik.val);
if(x < 0.0 && GSL_IS_ODD(n)) result->val = -result->val;
return GSL_ERROR_SELECT_2(stat_a1, stat_a2);
}
}
int
main(int argc, char *argv[])
{
size_t nmax_int = 60;
size_t mmax_int = 6;
size_t nmax_ext = 0;
size_t mmax_ext = 0;
size_t nmax_sh = 60;
size_t mmax_sh = 5;
size_t nmax_tor = 60;
size_t mmax_tor = 5;
double alpha_int = 1.0;
double alpha_sh = 1.0;
double alpha_tor = 1.0;
size_t robust_maxit = 5;
const double R = R_EARTH_KM;
const double b = R + 110.0; /* radius of internal current shell (Sq+EEJ) */
const double d = R + 350.0; /* radius of current shell for gravity/diamag */
double universal_time = 11.0; /* UT in hours for data selection */
char *datamap_file = "datamap.dat";
char *data_file = "data.dat";
char *spectrum_file = "poltor.s";
char *corr_file = "corr.dat";
char *residual_file = NULL;
char *output_file = NULL;
char *chisq_file = NULL;
char *lls_file = NULL;
char *Lcurve_file = NULL;
magdata *mdata = NULL;
poltor_workspace *poltor_p;
poltor_parameters params;
struct timeval tv0, tv1;
int print_data = 0;
#if POLTOR_SYNTH_DATA
nmax_int = 30;
mmax_int = 10;
nmax_ext = 2;
mmax_ext = 2;
nmax_sh = 20;
mmax_sh = 10;
nmax_tor = 30;
mmax_tor = 10;
#endif
while (1)
{
int c;
int option_index = 0;
static struct option long_options[] =
{
{ "nmax_int", required_argument, NULL, 'n' },
{ "mmax_int", required_argument, NULL, 'm' },
{ "nmax_tor", required_argument, NULL, 'a' },
{ "mmax_tor", required_argument, NULL, 'b' },
{ "nmax_sh", required_argument, NULL, 'e' },
{ "mmax_sh", required_argument, NULL, 'f' },
{ "nmax_ext", required_argument, NULL, 'g' },
{ "mmax_ext", required_argument, NULL, 'h' },
{ "residual_file", required_argument, NULL, 'r' },
{ "output_file", required_argument, NULL, 'o' },
{ "chisq_file", required_argument, NULL, 'p' },
{ "universal_time", required_argument, NULL, 't' },
{ "lls_file", required_argument, NULL, 'l' },
{ "lcurve_file", required_argument, NULL, 'k' },
{ "alpha_int", required_argument, NULL, 'c' },
{ "alpha_sh", required_argument, NULL, 'd' },
{ "alpha_tor", required_argument, NULL, 'j' },
{ "maxit", required_argument, NULL, 'q' },
{ "print_data", no_argument, NULL, 'u' },
{ 0, 0, 0, 0 }
};
c = getopt_long(argc, argv, "a:b:c:d:e:f:g:h:j:k:l:m:n:o:p:q:r:t:u", long_options, &option_index);
if (c == -1)
break;
switch (c)
{
case 'n':
nmax_int = (size_t) atoi(optarg);
break;
case 'm':
mmax_int = (size_t) atoi(optarg);
break;
case 'a':
nmax_tor = (size_t) atoi(optarg);
break;
case 'b':
mmax_tor = (size_t) atoi(optarg);
break;
case 'e':
nmax_sh = (size_t) atoi(optarg);
break;
case 'f':
mmax_sh = (size_t) atoi(optarg);
break;
case 'g':
nmax_ext = (size_t) atoi(optarg);
break;
case 'h':
mmax_ext = (size_t) atoi(optarg);
break;
case 'c':
alpha_int = atof(optarg);
break;
case 'd':
alpha_sh = atof(optarg);
break;
case 'j':
alpha_tor = atof(optarg);
break;
case 'r':
residual_file = optarg;
break;
case 'k':
Lcurve_file = optarg;
break;
case 'o':
output_file = optarg;
break;
case 't':
universal_time = atof(optarg);
break;
case 'p':
chisq_file = optarg;
break;
case 'l':
lls_file = optarg;
break;
case 'q':
robust_maxit = (size_t) atoi(optarg);
break;
case 'u':
print_data = 1;
break;
default:
break;
}
}
while (optind < argc)
{
fprintf(stderr, "main: reading %s...", argv[optind]);
gettimeofday(&tv0, NULL);
mdata = magdata_read(argv[optind], mdata);
gettimeofday(&tv1, NULL);
if (!mdata)
exit(1);
fprintf(stderr, "done (%zu data total, %g seconds)\n",
mdata->n, time_diff(tv0, tv1));
++optind;
}
if (!mdata)
{
print_help(argv);
exit(1);
}
mmax_int = GSL_MIN(mmax_int, nmax_int);
mmax_ext = GSL_MIN(mmax_ext, nmax_ext);
mmax_sh = GSL_MIN(mmax_sh, nmax_sh);
mmax_tor = GSL_MIN(mmax_tor, nmax_tor);
fprintf(stderr, "main: universal time = %.1f\n", universal_time);
fprintf(stderr, "main: nmax_int = %zu\n", nmax_int);
fprintf(stderr, "main: mmax_int = %zu\n", mmax_int);
fprintf(stderr, "main: nmax_ext = %zu\n", nmax_ext);
fprintf(stderr, "main: mmax_ext = %zu\n", mmax_ext);
fprintf(stderr, "main: nmax_sh = %zu\n", nmax_sh);
fprintf(stderr, "main: mmax_sh = %zu\n", mmax_sh);
fprintf(stderr, "main: nmax_tor = %zu\n", nmax_tor);
fprintf(stderr, "main: mmax_tor = %zu\n", mmax_tor);
fprintf(stderr, "main: alpha_int = %g\n", alpha_int);
fprintf(stderr, "main: alpha_sh = %g\n", alpha_sh);
fprintf(stderr, "main: alpha_tor = %g\n", alpha_tor);
if (residual_file)
fprintf(stderr, "main: residual file = %s\n", residual_file);
if (Lcurve_file)
fprintf(stderr, "main: L-curve file = %s\n", Lcurve_file);
/*
* re-compute flags for fitting components / gradient, etc;
* must be called before magdata_init()
*/
set_flags(mdata);
fprintf(stderr, "main: initializing spatial weighting histogram...");
gettimeofday(&tv0, NULL);
magdata_init(mdata);
gettimeofday(&tv1, NULL);
fprintf(stderr, "done (%g seconds)\n", time_diff(tv0, tv1));
/* re-compute weights, nvec, nres based on flags update */
fprintf(stderr, "main: computing spatial weighting of data...");
gettimeofday(&tv0, NULL);
magdata_calc(mdata);
gettimeofday(&tv1, NULL);
fprintf(stderr, "done (%g seconds)\n", time_diff(tv0, tv1));
#if POLTOR_SYNTH_DATA
fprintf(stderr, "main: setting unit spatial weights...");
magdata_unit_weights(mdata);
fprintf(stderr, "done\n");
#endif
fprintf(stderr, "main: print_data = %d\n", print_data);
if (print_data)
{
fprintf(stderr, "main: writing data to %s...", data_file);
magdata_print(data_file, mdata);
fprintf(stderr, "done\n");
fprintf(stderr, "main: writing data map to %s...", datamap_file);
magdata_map(datamap_file, mdata);
fprintf(stderr, "done\n");
}
fprintf(stderr, "main: satellite rmin = %.1f (%.1f) [km]\n",
mdata->rmin, mdata->rmin - mdata->R);
fprintf(stderr, "main: satellite rmax = %.1f (%.1f) [km]\n",
mdata->rmax, mdata->rmax - mdata->R);
params.R = R;
params.b = b;
params.d = d;
params.rmin = GSL_MAX(mdata->rmin, mdata->R + 250.0);
params.rmax = GSL_MIN(mdata->rmax, mdata->R + 450.0);
params.nmax_int = nmax_int;
params.mmax_int = mmax_int;
params.nmax_ext = nmax_ext;
params.mmax_ext = mmax_ext;
params.nmax_sh = nmax_sh;
params.mmax_sh = mmax_sh;
params.nmax_tor = nmax_tor;
params.mmax_tor = mmax_tor;
params.shell_J = 0;
params.data = mdata;
params.alpha_int = alpha_int;
params.alpha_sh = alpha_sh;
params.alpha_tor = alpha_tor;
#if POLTOR_QD_HARMONICS
params.flags = POLTOR_FLG_QD_HARMONICS;
#else
params.flags = 0;
#endif
poltor_p = poltor_alloc(¶ms);
fprintf(stderr, "main: poltor rmin = %.1f (%.1f) [km]\n",
params.rmin, params.rmin - mdata->R);
fprintf(stderr, "main: poltor rmax = %.1f (%.1f) [km]\n",
params.rmax, params.rmax - mdata->R);
#if POLTOR_SYNTH_DATA
fprintf(stderr, "main: replacing with synthetic data...");
gettimeofday(&tv0, NULL);
poltor_synth(poltor_p);
gettimeofday(&tv1, NULL);
fprintf(stderr, "done (%g seconds)\n", time_diff(tv0, tv1));
#endif
if (lls_file)
{
/* use previously computed LS system from file */
fprintf(stderr, "main: loading LS system from %s...", lls_file);
lls_complex_load(lls_file, poltor_p->lls_workspace_p);
fprintf(stderr, "done\n");
/* solve LS system */
poltor_solve(poltor_p);
}
else
{
size_t maxiter = robust_maxit;
size_t iter = 0;
char buf[2048];
#if POLTOR_SYNTH_DATA
maxiter = 1;
#endif
while (iter++ < maxiter)
{
fprintf(stderr, "main: ROBUST ITERATION %zu/%zu\n", iter, maxiter);
/* build LS system */
poltor_calc(poltor_p);
/* solve LS system */
poltor_solve(poltor_p);
sprintf(buf, "%s.iter%zu", spectrum_file, iter);
fprintf(stderr, "main: printing spectrum to %s...", buf);
poltor_print_spectrum(buf, poltor_p);
fprintf(stderr, "done\n");
}
}
print_coefficients(poltor_p);
fprintf(stderr, "main: printing correlation data to %s...", corr_file);
print_correlation(corr_file, poltor_p);
fprintf(stderr, "done\n");
fprintf(stderr, "main: printing spectrum to %s...", spectrum_file);
poltor_print_spectrum(spectrum_file, poltor_p);
fprintf(stderr, "done\n");
if (Lcurve_file)
{
fprintf(stderr, "main: writing L-curve data to %s...", Lcurve_file);
print_Lcurve(Lcurve_file, poltor_p);
fprintf(stderr, "done\n");
}
if (output_file)
{
fprintf(stderr, "main: writing output coefficients to %s...", output_file);
poltor_write(output_file, poltor_p);
fprintf(stderr, "done\n");
}
if (residual_file)
{
fprintf(stderr, "main: printing residuals to %s...", residual_file);
print_residuals(residual_file, poltor_p);
fprintf(stderr, "done\n");
}
if (chisq_file)
{
fprintf(stderr, "main: printing chisq/dof to %s...", chisq_file);
print_chisq(chisq_file, poltor_p);
fprintf(stderr, "done\n");
}
magdata_free(mdata);
poltor_free(poltor_p);
return 0;
} /* main() */
