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() */