int main(){ const int max_mu_size=601; const int zero_pad_size=pow(2,15); FILE *in; in= fopen("mean.chi", "r"); gsl_matrix *e = gsl_matrix_alloc(max_mu_size, 4); gsl_vector * kvar=gsl_vector_alloc(max_mu_size); gsl_vector * muvar=gsl_vector_alloc(max_mu_size); gsl_vector * mu_0pad=gsl_vector_alloc(zero_pad_size); gsl_vector * r_0pad=gsl_vector_alloc(zero_pad_size/2); //half of lenght gsl_vector * kvar_0pad=gsl_vector_alloc(zero_pad_size); gsl_matrix_fscanf(in, e); fclose(in); gsl_matrix_get_col(kvar,e,0); gsl_matrix_get_col(muvar,e,1); gsl_vector_set_zero(mu_0pad); gsl_matrix_free(e); double dk=gsl_vector_get (kvar, 1)-gsl_vector_get (kvar, 0); double dr=M_PI/float(zero_pad_size-1)/dk; for (int i = 0; i < zero_pad_size; i++) { gsl_vector_set (kvar_0pad, i, dk*i); } for (int i = 0; i < zero_pad_size/2; i++) { gsl_vector_set (r_0pad, i, dr*i); } for (int i = 0; i < max_mu_size; i++) { gsl_vector_set (mu_0pad, i, gsl_vector_get (muvar, i)); } gsl_vector *mu_widowed=gsl_vector_alloc(zero_pad_size); gsl_vector_memcpy (mu_widowed, mu_0pad); double kmin=4.0, kmax=17.0, dwk=0.8; hanning(mu_widowed, kvar_0pad, kmin, kmax, dwk); //FFT transform double *data = (double *) malloc(zero_pad_size*sizeof(double)); //new double [zero_pad_size] ; memcpy(data, mu_widowed->data, zero_pad_size*sizeof(double)); gsl_fft_real_radix2_transform(data, 1, zero_pad_size); //Unpack complex vector gsl_vector_complex *fourier_data = gsl_vector_complex_alloc (zero_pad_size); gsl_fft_halfcomplex_radix2_unpack(data, fourier_data->data, 1, zero_pad_size); gsl_vector *fftR_real = gsl_vector_alloc(fourier_data->size/2); gsl_vector *fftR_imag = gsl_vector_alloc(fourier_data->size/2); gsl_vector *fftR_abs = gsl_vector_alloc(fourier_data->size/2); complex_vector_parts(fourier_data, fftR_real, fftR_imag); complex_vector_abs(fftR_abs, fftR_real, fftR_imag); gsl_vector *first_shell=gsl_vector_alloc(fftR_abs->size); gsl_vector_memcpy (first_shell, fftR_abs); double rmin=0.2, rmax=3.0, dwr=0.1; hanning(first_shell, r_0pad, rmin, rmax, dwr); //feff0001.dat const int path_lines=68; e = gsl_matrix_alloc(path_lines, 7); gsl_vector * k_p =gsl_vector_alloc(path_lines); gsl_vector * phc_p=gsl_vector_alloc(path_lines); gsl_vector * mag_p=gsl_vector_alloc(path_lines); gsl_vector * pha_p=gsl_vector_alloc(path_lines); gsl_vector * lam_p=gsl_vector_alloc(path_lines); in= fopen("feff0001.dat", "r"); gsl_matrix_fscanf(in, e); fclose(in); gsl_matrix_get_col(k_p ,e,0); gsl_matrix_get_col(phc_p,e,1); gsl_matrix_get_col(mag_p,e,2); gsl_matrix_get_col(pha_p,e,3); gsl_matrix_get_col(lam_p,e,5); gsl_matrix_free(e); gsl_interp_accel *acc = gsl_interp_accel_alloc (); gsl_spline *k_spline = gsl_spline_alloc (gsl_interp_cspline, path_lines); gsl_spline *phc_spline = gsl_spline_alloc (gsl_interp_cspline, path_lines); gsl_spline *mag_spline = gsl_spline_alloc (gsl_interp_cspline, path_lines); gsl_spline *pha_spline = gsl_spline_alloc (gsl_interp_cspline, path_lines); gsl_spline *lam_spline = gsl_spline_alloc (gsl_interp_cspline, path_lines); gsl_spline_init (k_spline , k_p->data, k_p->data , path_lines); gsl_spline_init (phc_spline, k_p->data, phc_p->data, path_lines); gsl_spline_init (mag_spline, k_p->data, mag_p->data, path_lines); gsl_spline_init (pha_spline, k_p->data, pha_p->data, path_lines); gsl_spline_init (lam_spline, k_p->data, lam_p->data, path_lines); gsl_vector * mu_p =gsl_vector_alloc(path_lines); //struct fit_params { student_params t; double kshift; double S02; double N; inter_path splines; }; //student_params t = {2.45681867, 0.02776907, -21.28920008, 9.44741797, 0.0, 0.0, 0.0}; splines.acc=acc; splines.phc_spline=phc_spline; splines.mag_spline=mag_spline; splines.pha_spline=pha_spline; splines.lam_spline=lam_spline; fit_params fp = { 2.45681867, 0.02776907, -21.28920008, 9.44741797, 1.0, 0.0}; compute_itegral(k_p, &fp, mu_p); //mu_data_fit params = { k_p, mu_p}; mu_data.k = kvar_0pad; mu_data.mu = mu_0pad; mu_data.mu_ft = first_shell; mu_data.r = r_0pad; mu_data.kmin = kmin; mu_data.kmax = kmax; mu_data.rmin = rmin; mu_data.rmax = rmax; mu_data.dwk = dwk; mu_data.dwr = dwr; // initialize the solver size_t Nparams=6; gsl_vector *guess0 = gsl_vector_alloc(Nparams); gsl_vector_set(guess0, 0, 2.4307); gsl_vector_set(guess0, 1, 0.040969); gsl_vector_set(guess0, 2, 0.001314); gsl_vector_set(guess0, 3, 7835); gsl_vector_set(guess0, 4, 1.0); gsl_vector_set(guess0, 5, 0.0); gsl_vector *fit_r = gsl_vector_alloc(r_0pad->size); compute_itegral_r(&mu_data, fp, fit_r); gsl_matrix *plotting = gsl_matrix_calloc(r_0pad->size, 3); gsl_matrix_set_col (plotting, 0, r_0pad); gsl_matrix_set_col (plotting, 1, first_shell); gsl_matrix_set_col (plotting, 2, fit_r); plot_matplotlib(plotting); gsl_matrix_free (plotting); gsl_multifit_function_fdf fit_mu_k; fit_mu_k.f = &resudial_itegral_r; fit_mu_k.n = MAX_FIT_POINTS; fit_mu_k.p = Nparams; fit_mu_k.params = &mu_data; fit_mu_k.df = NULL; fit_mu_k.fdf = NULL; gsl_multifit_fdfsolver *solver = gsl_multifit_fdfsolver_alloc(gsl_multifit_fdfsolver_lmsder, MAX_FIT_POINTS, Nparams); gsl_multifit_fdfsolver_set(solver, &fit_mu_k, guess0); size_t iter=0, status; do{ iter++; //cout << solver->x->data[0] << " " << solver->x->data[1] <<endl; status = gsl_multifit_fdfsolver_iterate (solver); //printf("%12.4f %12.4f %12.4f\n", solver->J->data[0,0], solver->J->data[1,1], solver->J->data[2,2] ); //gsl_multifit_fdfsolver_dif_df (k_p, &fit_mu_k, mu_p, solver->J); //gsl_multifit_fdfsolver_dif_fdf (k_p, &fit_mu_k, mu_p, solver->J); for (int i =0; i< solver->x->size; i++){ printf("%14.5f", gsl_vector_get (solver->x, i)) ; } printf("\n") ; if (status) break; status = gsl_multifit_test_delta (solver->dx, solver->x, 1e-4, 1e-4); }while (status == GSL_CONTINUE && iter < 100); gsl_vector * mu_fit =gsl_vector_alloc(path_lines); fit_params fitp = { solver->x->data[0], solver->x->data[1],\ solver->x->data[2], solver->x->data[3],\ solver->x->data[4], solver->x->data[5]}; compute_itegral(k_p, &fitp, mu_fit); fp.mu=gsl_vector_get (solver->x, 0); fp.sig=gsl_vector_get (solver->x, 1); fp.skew=gsl_vector_get (solver->x, 2); fp.nu=gsl_vector_get (solver->x, 3); fp.S02=gsl_vector_get (solver->x, 4); fp.kshift=gsl_vector_get (solver->x, 5); compute_itegral_r(&mu_data, fp, fit_r); //gsl_matrix *plotting = gsl_matrix_calloc(r_0pad->size, 3); gsl_matrix_set_col (plotting, 0, r_0pad); gsl_matrix_set_col (plotting, 1, first_shell); gsl_matrix_set_col (plotting, 2, fit_r); int min_r=search_max(r_0pad, 0.); int max_r=search_max(r_0pad, 4.); gsl_matrix_view plotting_lim = gsl_matrix_submatrix (plotting, min_r, 0, max_r-min_r, plotting->size2); plot_matplotlib(&plotting_lim.matrix); gsl_matrix_free (plotting); //cout << gsl_spline_eval (k_spline, 1.333, acc) << endl; //cout << gsl_spline_eval (phc_spline, 1.333, acc) << endl; //cout << data[0] << "\t" << data[1] << "\t" << data[2] << "\t" << endl; //cout << fourier_data->data[0] << "\t" << fourier_data->data[1] << "\t" << fourier_data->data[2] << "\t" << endl; //Plotting /* gsl_matrix *plotting = gsl_matrix_calloc(zero_pad_size, 3); gsl_matrix_set_col (plotting, 0, kvar_0pad); gsl_matrix_set_col (plotting, 1, mu_0pad); gsl_matrix_set_col (plotting, 2, mu_widowed); int max_k=search_max(kvar_0pad, 35.); int min_k=search_max(kvar_0pad, 1.0); gsl_matrix_view plotting_lim = gsl_matrix_submatrix (plotting, min_k, 0, max_k-min_k, 3); plot_matplotlib(&plotting_lim.matrix); gsl_matrix_free (plotting); */ /* gsl_matrix *plotting = gsl_matrix_calloc(zero_pad_size, 2); gsl_matrix_set_col (plotting, 0, r_0pad); gsl_matrix_set_col (plotting, 1, mu_0pad); int max_k=search_max(kvar_0pad, 35.); int min_k=search_max(kvar_0pad, 1.0); gsl_matrix_view plotting_lim = gsl_matrix_submatrix (plotting, min_k, 0, max_k-min_k, 3); plot_matplotlib(&plotting_lim.matrix); gsl_matrix_free (plotting); */ /* gsl_matrix *plotting = gsl_matrix_calloc(r_0pad->size, 5); gsl_matrix_set_col (plotting, 0, r_0pad); gsl_matrix_set_col (plotting, 1, fftR_abs); gsl_matrix_set_col (plotting, 2, fftR_real); gsl_matrix_set_col (plotting, 3, fftR_imag); gsl_matrix_set_col (plotting, 4, first_shell); int min_r=search_max(r_0pad, 0.); int max_r=search_max(r_0pad, 5.); gsl_matrix_view plotting_lim = gsl_matrix_submatrix (plotting, min_r, 0, max_r-min_r, plotting->size2); plot_matplotlib(&plotting_lim.matrix); //plot_matplotlib(plotting); gsl_matrix_free (plotting); */ //cout << "Done" << endl; //cout << data[1] <<"\t" << data[2] << endl; //for (int i = 0; i < kvar->size; i++) //{ // cout << gsl_vector_get (kvar, i) <<"\t" << gsl_vector_get (muvar, i) << endl; //} }
static int steepest_descent_iterate (void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx) { steepest_descent_state_t *state = (steepest_descent_state_t *) vstate; gsl_vector *x1 = state->x1; gsl_vector *g1 = state->g1; double f0 = *f; double f1; double step = state->step, tol = state->tol; int failed = 0; /* compute new trial point at x1= x - step * dir, where dir is the normalized gradient */ double gnorm = gsl_blas_dnrm2 (gradient); if (gnorm == 0.0) { gsl_vector_set_zero (dx); return GSL_ENOPROG; } trial: gsl_vector_set_zero (dx); gsl_blas_daxpy (-step / gnorm, gradient, dx); gsl_vector_memcpy (x1, x); gsl_blas_daxpy (1.0, dx, x1); /* evaluate function and gradient at new point x1 */ GSL_MULTIMIN_FN_EVAL_F_DF (fdf, x1, &f1, g1); if (f1 > f0) { /* downhill step failed, reduce step-size and try again */ failed = 1; step *= tol; goto trial; } if (failed) step *= tol; else step *= 2.0; state->step = step; gsl_vector_memcpy (x, x1); gsl_vector_memcpy (gradient, g1); *f = f1; return GSL_SUCCESS; }
// Initializes the program. int main(int argc, char *argv[]) { int opt, min_fails, eigen_follow, eigen_num, examining; unsigned n, N, ord, size, params, j, M; double d, c, dc0, dc, g0, g, eigen_thres, approach_thres, eps, eps2, state, old_state, h, bound, da, w, ss; char *in_filename, *out_filename, *k_filename, *a_filename, *phi_filename, str[19], in; bool subcrit, reset, rand, verbose, fixed, well; // Setting default values. gsl_vector *z, *k, *a, *phi, *old_z; rand = false; fixed = false; well = false; verbose = false; j=0; ss=1; while ((opt = getopt(argc, argv, "n:c:i:o:O:K:A:P:e:g:N:b:rvd:M:a:fws:W:j:")) != -1) { switch (opt) { case 'n': n = atoi(optarg); break; case 'b': bound = atof(optarg); break; case 'c': c = atof(optarg); break; case 'i': in_filename = optarg; break; case 'o': out_filename = optarg; break; case 'O': ord = atoi(optarg); break; case 'K': k_filename = optarg; break; case 'A': a_filename = optarg; break; case 'P': phi_filename = optarg; break; case 'g': g0 = atof(optarg); break; case 'N': N = atoi(optarg); break; case 'j': j = atoi(optarg); break; case 'M': M = atoi(optarg); break; case 'e': eps = atof(optarg); break; case 'd': dc0 = atof(optarg); break; case 'a': da = atof(optarg); break; case 'r': rand = true; break; case 'f': fixed = true; break; case 'w': well = true; break; case 'W': w = atof(optarg); break; case 's': ss = atof(optarg); break; case 'v': verbose = true; break; default: exit(EXIT_FAILURE); } } if (rand || !fixed) { size = 3 * n + 2; params = 2 * n + 1; } else { size = 3 * n + 3; params = 2 * n; } z = gsl_vector_alloc(size); old_z = gsl_vector_alloc(size); if (rand) { k = gsl_vector_alloc(2 * ord); a = gsl_vector_alloc(ord); phi = gsl_vector_alloc(ord); } FILE *in_file = fopen(in_filename, "r"); gsl_vector_fscanf(in_file, z); fclose(in_file); if (rand) { FILE *k_file = fopen(k_filename, "r"); gsl_vector_fscanf(k_file, k); fclose(k_file); FILE *a_file = fopen(a_filename, "r"); gsl_vector_fscanf(a_file, a); fclose(a_file); FILE *phi_file = fopen(phi_filename, "r"); gsl_vector_fscanf(phi_file, phi); fclose(phi_file); } g = g0; dc = dc0; double beta = 0.9; double s = 1; double sigma = 0.5; if (rand && well) min_fails = domain_minimize_randWell(z, n, c, ord, k, a, phi, w, ss, eps, N, beta, s, sigma, g, bound, verbose); else if (rand) min_fails = domain_minimize_rand(z, n, c, ord, k, a, phi, eps, N, beta, s, sigma, g, bound, verbose); else { if (fixed) min_fails = domain_minimize_fixedmin(z, n, c, eps, N, beta, ss, sigma, g, bound, verbose); else { if (well) min_fails = domain_minimize_nakedWell(z, n, c, w, ss, eps, N, beta, s, sigma, g, bound, verbose); else min_fails = domain_minimize_naked(z, n, c, eps, N, beta, s, sigma, g, bound, verbose); } } if (min_fails) { printf("BIFUR: Initial relaxation failed, exiting.\n"); FILE *out_file = fopen(out_filename, "w"); gsl_vector_fprintf(out_file, z, "%.10e"); fclose(out_file); return 1; } while (j < M) { j += 1; c += dc; g = g0; if (rand) gsl_vector_scale(a, da); gsl_vector_memcpy(old_z, z); printf("EVOLVE: Step %05d, starting with c = %f.\n", j, c); while (true) { if (rand && well) min_fails = domain_minimize_randWell(z, n, c, ord, k, a, phi, w, ss, eps, N, beta, s, sigma, g, bound, verbose); else if (rand) min_fails = domain_minimize_rand(z, n, c, ord, k, a, phi, eps, N, beta, s, sigma, g, bound, verbose); else if (fixed) min_fails = domain_minimize_fixedmin(z, n, c, eps, N, beta, s, sigma, g, bound, verbose); else if (well) min_fails = domain_minimize_nakedWell(z, n, c, w, ss, eps, N, beta, s, sigma, g, bound, verbose); else min_fails = domain_minimize_naked(z, n, c, eps, N, beta, s, sigma, g, bound, verbose); if (!min_fails) break; printf("EVOLVE: Newton's method failed to converge, reducing gamma.\n"); gsl_vector_memcpy(z, old_z); g *= 0.1; } sprintf(str, "output/out-%05d.dat", j); FILE *fout = fopen(str, "w"); fprintf(fout, "%.10e\n", c); gsl_vector_fprintf(fout, z, "%.10e"); fclose(fout); } FILE *out_file = fopen(out_filename, "w"); gsl_vector_fprintf(out_file, z, "%.10e"); fclose(out_file); gsl_vector_free(z); return 0; }
static int iterate (void *vstate, gsl_multiroot_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx, int scale) { hybridj_state_t *state = (hybridj_state_t *) vstate; const double fnorm = state->fnorm; gsl_matrix *q = state->q; gsl_matrix *r = state->r; gsl_vector *tau = state->tau; gsl_vector *diag = state->diag; gsl_vector *qtf = state->qtf; gsl_vector *x_trial = state->x_trial; gsl_vector *f_trial = state->f_trial; gsl_vector *df = state->df; gsl_vector *qtdf = state->qtdf; gsl_vector *rdx = state->rdx; gsl_vector *w = state->w; gsl_vector *v = state->v; double prered, actred; double pnorm, fnorm1, fnorm1p; double ratio; double p1 = 0.1, p5 = 0.5, p001 = 0.001, p0001 = 0.0001; /* Compute qtf = Q^T f */ compute_qtf (q, f, qtf); /* Compute dogleg step */ dogleg (r, qtf, diag, state->delta, state->newton, state->gradient, dx); /* Take a trial step */ compute_trial_step (x, dx, state->x_trial); pnorm = scaled_enorm (diag, dx); if (state->iter == 1) { if (pnorm < state->delta) { state->delta = pnorm; } } /* Evaluate function at x + p */ { int status = GSL_MULTIROOT_FN_EVAL_F (fdf, x_trial, f_trial); if (status != GSL_SUCCESS) { return GSL_EBADFUNC; } } /* Set df = f_trial - f */ compute_df (f_trial, f, df); /* Compute the scaled actual reduction */ fnorm1 = enorm (f_trial); actred = compute_actual_reduction (fnorm, fnorm1); /* Compute rdx = R dx */ compute_rdx (r, dx, rdx); /* Compute the scaled predicted reduction phi1p = |Q^T f + R dx| */ fnorm1p = enorm_sum (qtf, rdx); prered = compute_predicted_reduction (fnorm, fnorm1p); /* Compute the ratio of the actual to predicted reduction */ if (prered > 0) { ratio = actred / prered; } else { ratio = 0; } /* Update the step bound */ if (ratio < p1) { state->ncsuc = 0; state->ncfail++; state->delta *= p5; } else { state->ncfail = 0; state->ncsuc++; if (ratio >= p5 || state->ncsuc > 1) state->delta = GSL_MAX (state->delta, pnorm / p5); if (fabs (ratio - 1) <= p1) state->delta = pnorm / p5; } /* Test for successful iteration */ if (ratio >= p0001) { gsl_vector_memcpy (x, x_trial); gsl_vector_memcpy (f, f_trial); state->fnorm = fnorm1; state->iter++; } /* Determine the progress of the iteration */ state->nslow1++; if (actred >= p001) state->nslow1 = 0; if (actred >= p1) state->nslow2 = 0; if (state->ncfail == 2) { { int status = GSL_MULTIROOT_FN_EVAL_DF (fdf, x, J); if (status != GSL_SUCCESS) { return GSL_EBADFUNC; } } state->nslow2++; if (state->iter == 1) { if (scale) compute_diag (J, diag); state->delta = compute_delta (diag, x); } else { if (scale) update_diag (J, diag); } /* Factorize J into QR decomposition */ gsl_linalg_QR_decomp (J, tau); gsl_linalg_QR_unpack (J, tau, q, r); return GSL_SUCCESS; } /* Compute qtdf = Q^T df, w = (Q^T df - R dx)/|dx|, v = D^2 dx/|dx| */ compute_qtf (q, df, qtdf); compute_wv (qtdf, rdx, dx, diag, pnorm, w, v); /* Rank-1 update of the jacobian Q'R' = Q(R + w v^T) */ gsl_linalg_QR_update (q, r, w, v); /* No progress as measured by jacobian evaluations */ if (state->nslow2 == 5) { return GSL_ENOPROGJ; } /* No progress as measured by function evaluations */ if (state->nslow1 == 10) { return GSL_ENOPROG; } return GSL_SUCCESS; }
static int dogleg (const gsl_matrix * r, const gsl_vector * qtf, const gsl_vector * diag, double delta, gsl_vector * newton, gsl_vector * gradient, gsl_vector * p) { double qnorm, gnorm, sgnorm, bnorm, temp; newton_direction (r, qtf, newton); #ifdef DEBUG printf("newton = "); gsl_vector_fprintf(stdout, newton, "%g"); printf("\n"); #endif qnorm = scaled_enorm (diag, newton); if (qnorm <= delta) { gsl_vector_memcpy (p, newton); #ifdef DEBUG printf("took newton (qnorm = %g <= delta = %g)\n", qnorm, delta); #endif return GSL_SUCCESS; } gradient_direction (r, qtf, diag, gradient); #ifdef DEBUG printf("grad = "); gsl_vector_fprintf(stdout, gradient, "%g"); printf("\n"); #endif gnorm = enorm (gradient); if (gnorm == 0) { double alpha = delta / qnorm; double beta = 0; scaled_addition (alpha, newton, beta, gradient, p); #ifdef DEBUG printf("took scaled newton because gnorm = 0\n"); #endif return GSL_SUCCESS; } minimum_step (gnorm, diag, gradient); compute_Rg (r, gradient, p); /* Use p as temporary space to compute Rg */ #ifdef DEBUG printf("mingrad = "); gsl_vector_fprintf(stdout, gradient, "%g"); printf("\n"); printf("Rg = "); gsl_vector_fprintf(stdout, p, "%g"); printf("\n"); #endif temp = enorm (p); sgnorm = (gnorm / temp) / temp; if (sgnorm > delta) { double alpha = 0; double beta = delta; scaled_addition (alpha, newton, beta, gradient, p); #ifdef DEBUG printf("took gradient\n"); #endif return GSL_SUCCESS; } bnorm = enorm (qtf); { double bg = bnorm / gnorm; double bq = bnorm / qnorm; double dq = delta / qnorm; double dq2 = dq * dq; double sd = sgnorm / delta; double sd2 = sd * sd; double t1 = bg * bq * sd; double u = t1 - dq; double t2 = t1 - dq * sd2 + sqrt (u * u + (1-dq2) * (1 - sd2)); double alpha = dq * (1 - sd2) / t2; double beta = (1 - alpha) * sgnorm; #ifdef DEBUG printf("bnorm = %g\n", bnorm); printf("gnorm = %g\n", gnorm); printf("qnorm = %g\n", qnorm); printf("delta = %g\n", delta); printf("alpha = %g beta = %g\n", alpha, beta); printf("took scaled combination of newton and gradient\n"); #endif scaled_addition (alpha, newton, beta, gradient, p); } return GSL_SUCCESS; }
int main(int argc, char** argv) { //--Foodweb Struktur mit Standardwerten aufstellen------------------------------------------------------------------------------------------ struct simuParams simParams = {0.3, 0.65, 0.35, 0.5, 6.0}; // Diese Parameter sind konstant struct simuMemory simMem = {NULL, NULL, NULL, NULL, NULL}; // Größe der Vektoren liegt noch nicht fest gsl_vector* fixpunkte = gsl_vector_calloc(9); struct foodweb nicheweb = {NULL, fixpunkte, NULL,&simParams, &simMem, 18, 3, 1, 5, 0, 0, -7., 0.0, 0, 1}; // Reihenfolge: network, fxpkt, migrPara, AllMus, AllNus, S, B, Rnum, Y, T, Tchoice, d, x, M, Z struct migration stochastic = {NULL, NULL, NULL, NULL, NULL, NULL, 0.00001, NULL, NULL, NULL, NULL, NULL}; struct resource res = {500.0, 0.0}; // Resource: Größe, Wachstum //--Konsoleneingabe------------------------------------------------------------------------------------------------------------------------- int L = 5; // Statistik int i = 0,j; // Counter char aims6[255] = ORT; FILE* RobustnessEachRun; int checksum = getArgs(argc, argv, &(nicheweb.S), &(nicheweb.B), &(nicheweb.T), &(nicheweb.d), &L, &(nicheweb.Y), &(nicheweb.x), &(nicheweb.M), &(res.size), &(nicheweb.Z), &(stochastic.Bmigr)); if (checksum != 11 && checksum!=(int)(argc-1)/2) // Alles gesetzt? { printf("Bitte gültige Eingabe für Parameter machen!\nProgramm wird beendet.\n"); return(0); } /* int length = ((nicheweb.Rnum+nicheweb.S)*(nicheweb.S+nicheweb.Rnum)+1+nicheweb.Y*nicheweb.Y+1+(nicheweb.Rnum+nicheweb.S)+nicheweb.S+1); // Länge des Rückabewerts nicheweb.network = gsl_vector_calloc(length); */ // Speicher belegen, nachdem die Größe des Systems durch die Konsoleneingabe bekannt ist CallocFoodwebMem(&nicheweb); CallocStochasticMem(&stochastic, nicheweb.Y, nicheweb.S); printf("Z = %i\n",nicheweb.Z); nicheweb.migrPara = gsl_vector_calloc(7); // Reihenfolge: tau, mu, nu, SpeciesNumber, momentanes t, ymigr, migrationEventNumber // stochastic.SpeciesNumbers = gsl_vector_calloc(nicheweb.Z); // stochastic.AllMus = gsl_vector_calloc(nicheweb.Z); // stochastic.AllNus = gsl_vector_calloc(nicheweb.Z); // stochastic.Biomass_SpeciesNumbers = gsl_vector_calloc(nicheweb.Z); // stochastic.Biomass_AllMus = gsl_vector_calloc(nicheweb.Z); // stochastic.Biomass_AllNus = gsl_vector_calloc(nicheweb.Z); //--Zufallszahlengenerator initialisieren-------------------------------------------------------------------------------- const gsl_rng_type *rng1_T; // **** gsl_rng *rng1; // initialize random number generator gsl_rng_env_setup(); // ermöglicht Konsolenparameter rng1_T = gsl_rng_default; // default random number generator (so called mt19937) gsl_rng_default_seed = 0; // default seed for rng // gsl_rng_default_seed = ((unsigned)time(NULL)); // random starting seed for rng rng1 = gsl_rng_alloc(rng1_T); //--Struct initialisieren für patchweise Ausgabe---------------------------------------------------------------------------------------- struct data patchwise[nicheweb.Y]; for(i=0; i<nicheweb.Y; i++) { gsl_vector* sini = gsl_vector_calloc(6); gsl_vector* sfini = gsl_vector_calloc(6); gsl_vector* bini = gsl_vector_calloc(6); gsl_vector* bfini = gsl_vector_calloc(6); gsl_vector* robness = gsl_vector_calloc(2); //struct data tempo = {sini,sfini,bini,bfini,robness}; struct data temp = {sini,sfini,bini,bfini,robness}; patchwise[i] = temp; } //printf("test"); //--Initialisierungen--------------------------------------------------------------------------------------------------- nicheweb.Tchoice = nicheweb.T; nicheweb.T = 0; nicheweb.d = nicheweb.d/10; printf("d ist %f\n",nicheweb.d); res.size = res.size/10; stochastic.Bmigr = 2.5*stochastic.Bmigr*pow(10,nicheweb.d); nicheweb.Z = pow(10,nicheweb.Z); printf("Bmigr ist %f\n",stochastic.Bmigr); printf("Z ist %i\n",nicheweb.Z); printf("x ist %f\n",nicheweb.x); //int len = ((nicheweb.Rnum+nicheweb.S)*(nicheweb.S+nicheweb.Rnum)+1+nicheweb.Y*nicheweb.Y+1+(nicheweb.Rnum+nicheweb.S)+nicheweb.S); // Länge des Rückabewerts gsl_vector *populationFIN = gsl_vector_calloc((nicheweb.Rnum + nicheweb.S)*(nicheweb.Y)*5 + (nicheweb.S) + 3); // Gleiche Länge wie Rückgabe von evolveNetwork gsl_vector *robustness = gsl_vector_calloc(63); gsl_vector *resultEvolveWeb = gsl_vector_calloc((nicheweb.Rnum+nicheweb.S)*nicheweb.Y*5 + 3 + nicheweb.S); // y[Simulation], y0, ymax, ymin, yavg, fixp, TL gsl_vector *resultRobustness = gsl_vector_calloc(63); gsl_matrix *D = gsl_matrix_calloc(nicheweb.Y,nicheweb.Y); gsl_matrix* Dchoice = gsl_matrix_calloc(nicheweb.Y,nicheweb.Y); gsl_vector *robustnesstemp = gsl_vector_calloc(63); gsl_vector *meanSquOfDataAll = gsl_vector_calloc(63); gsl_vector *meanSquOfDataAlltemp = gsl_vector_calloc(63); gsl_vector *standardDeviationAll = gsl_vector_calloc(63); gsl_vector *meanOfData = gsl_vector_calloc((6*4+2)*nicheweb.Y); gsl_vector *meanOfDatatemp = gsl_vector_calloc((6*4+2)*nicheweb.Y); gsl_vector *meanSquOfData = gsl_vector_calloc((6*4+2)*nicheweb.Y); gsl_vector *standardDeviation = gsl_vector_calloc((6*4+2)*nicheweb.Y); gsl_vector_set_zero(robustness); gsl_vector_set_zero(meanOfData); gsl_vector_set_zero(meanSquOfData); gsl_vector_set_zero(nicheweb.migrPara); gsl_vector_set_zero(meanSquOfDataAll); // double SpeciesNumber[L*nicheweb.Z][2]; // double AllMu[L*nicheweb.Z][2]; // double AllNu[L*nicheweb.Z][2]; double ymigr = 0; double mu = 0; double nu = 0; double ymigrtemp; double ymigrSqu = 0; double ymigrDeviation; double migrationEventNumber = 0; double migrationEventNumbertemp; double migrationEventNumberSqu = 0.0; double migrationEventNumberDeviation; int lastMigrationEventNumber = 0; //--Simulation--------------------------------------------------------------------------------------------------------------------- //SetTopology(nicheweb.Y, nicheweb.T, D); SetTopology(nicheweb.Y, nicheweb.Tchoice, Dchoice); // for(i = 0; i<nicheweb.Y; i++) // { // for(j = 0 ; j<nicheweb.Y; j++) // { // printf("%f\t",gsl_matrix_get(Dchoice,i,j)); // } // printf("\n"); // } for(i = 0; i < L; i++) { // const gsl_rng_type *rng1_T; // **** // gsl_rng *rng1; // initialize random number generator // gsl_rng_env_setup(); // ermöglicht Konsolenparameter // rng1_T = gsl_rng_default; // default random number generator (so called mt19937) // gsl_rng_default_seed = 0; // default seed for rng // //gsl_rng_default_seed = ((unsigned)time(NULL)); // random starting seed for rng // rng1 = gsl_rng_alloc(rng1_T); printf("\nStarte Durchlauf L = %i\n", i); //--Starte Simulation----------------------------------------------------------------------------------------------- SetNicheNetwork(nicheweb, stochastic, res, rng1, rng1_T, D); gsl_vector_set_zero(resultEvolveWeb); populationFIN = EvolveNetwork(nicheweb, stochastic, rng1, rng1_T, Dchoice, resultEvolveWeb); gsl_vector_set_zero(resultRobustness); gsl_vector_memcpy(robustnesstemp, EvaluateRobustness(populationFIN, nicheweb, patchwise, resultRobustness)); // Robustness Analyse //--Standardabweichung für Mittelung vorbereiten----------------------------------------------------------------------------------------- determineMean(robustnesstemp, 63, robustness); determineMeanSqu(robustnesstemp, 63, meanSquOfDataAll); //--Ausgabewerte---------------------------------------------------------------------------------------------------------- ymigrtemp = gsl_vector_get(nicheweb.migrPara, 5); migrationEventNumbertemp = gsl_vector_get(nicheweb.migrPara, 6); // for(int j= 0; j<migrationEventNumbertemp; j++) // { // AllMu[lastMigrationEventNumber+j][0] = gsl_vector_get(stochastic.AllMus, j); // AllNu[lastMigrationEventNumber+j][0] = gsl_vector_get(stochastic.AllNus, j); // SpeciesNumber[lastMigrationEventNumber+j][0] = gsl_vector_get(stochastic.SpeciesNumbers,j); // // AllMu[lastMigrationEventNumber+j][1] = gsl_vector_get(stochastic.Biomass_AllMus, j); // AllNu[lastMigrationEventNumber+j][1] = gsl_vector_get(stochastic.Biomass_AllNus, j); // SpeciesNumber[lastMigrationEventNumber+j][1] = gsl_vector_get(stochastic.Biomass_SpeciesNumbers,j); // } lastMigrationEventNumber += migrationEventNumbertemp; //printf("SpeciesNumber ist %f\n",SpeciesNumber[i]); ymigr += ymigrtemp; migrationEventNumber += migrationEventNumbertemp; ymigrSqu += (ymigrtemp*ymigrtemp); migrationEventNumberSqu = (migrationEventNumberSqu*(i)+(migrationEventNumbertemp*migrationEventNumbertemp))/(i+1); // printf("Additionsteil ist %f\n",(migrationEventNumberSqu*(i)+(migrationEventNumbertemp*migrationEventNumbertemp))/(i+1)); //--Mittelwert und Vorbereitungen für Standardabweichung für die patchweise Ausgabe berechnen-------------------------------- linkElements(patchwise, nicheweb.Y, meanOfDatatemp); determineMean(meanOfDatatemp, (6*4+2)*nicheweb.Y, meanOfData); determineMeanSqu(meanOfDatatemp, (6*4+2)*nicheweb.Y, meanSquOfData); createOutputRobustnessPatchwiseEachRun(nicheweb,patchwise,aims6,RobustnessEachRun,i); printf("\nBeende Durchlauf L = %i\n", i); } //-- Standardabweichung berechnen-------------------------------------------------------------------------------------- ymigrSqu = ymigrSqu/L; ymigr = ymigr/L; ymigrDeviation = sqrt(ymigrSqu - ymigr*ymigr); //migrationEventNumberSqu = migrationEventNumberSqu/L; migrationEventNumber = migrationEventNumber/L; migrationEventNumberDeviation = sqrt(migrationEventNumberSqu - migrationEventNumber*migrationEventNumber); // printf("migrationEventNumber ist %f\n",migrationEventNumber); // printf("migrationEventNumberSqu ist %f\n",migrationEventNumberSqu); // printf("migrationEventNumberDeviation ist %f\n",migrationEventNumberDeviation); // //-- Für patchweise Ausgabe------------------------------------------------------------------------------------------- standardDeviation = determineStandardDeviation((6*4+2)*nicheweb.Y, meanOfData, meanSquOfData, L, standardDeviation); standardDeviationAll = determineStandardDeviation(63, robustness, meanSquOfDataAll, L, standardDeviationAll); //printf("der 3. Eintrag in standardDeviationAll ist %f\n", gsl_vector_get(standardDeviationAll,3)); // printf("S ist %f\n", gsl_vector_get(robustness,3)); // printf("Standardabweichung von S ist %f\n", gsl_vector_get(standardDeviationAll,3)); // printf("meanOfDataSqu ist %f\n", gsl_vector_get(meanOfDataSquAll,3)); // printf("meanSquOfData ist %f\n", gsl_vector_get(meanSquOfDataAll,3)); printf("L=%i\tspeciesini=%f\tspeciesfinal=%f\n", L, gsl_vector_get(robustness, 3)/L, gsl_vector_get(robustness, 9)/L); //--Abspeichern in File------------------------------------------------------------------------------------- char aims[255] = ORT; createOutputGeneral(nicheweb, res, stochastic, aims, robustness, standardDeviationAll, L, mu, nu, ymigr, ymigrDeviation, migrationEventNumber, migrationEventNumberDeviation); // Datei schließen //--Daten patchweise abspeichern---------------------------------------------------------------------- // printf("population ist %f\n",gsl_vector_get(stochastic.Biomass_AllMus,0)); for(int l = 0 ; l< nicheweb.Y; l++) { //char name[100]; char aims2[255] = ORT2; createOutputPatchwise(nicheweb, res, stochastic, aims2, meanOfData, standardDeviation, L, l); } // if(nicheweb.Tchoice != 0) // { //--Ausgewählte Spezies rausschreiben, die migrieren darf--------------------------------------------------------------------------- // char aims3[255] = ORT; // // //createOutputSpeciesNumber(nicheweb, res, aims3, SpeciesNumber, L, migrationEventNumber); // // // //--Ausgewählte Verbindung rausschreiben, über die migriert werden darf--------------------------------------------------------------------------- // // char aims4[255] = ORT; // // // createOutputPatchlink(nicheweb, res, aims4, AllMu, AllNu, L, migrationEventNumber); // } printf("\nSimulation abgespeichert\n\n"); //--free---------------------------------------------------------------------------------------------------------------- free(nicheweb.network); gsl_vector_free(fixpunkte); for(i=0; i<nicheweb.Y; i++) { gsl_vector_free(patchwise[i].sini); gsl_vector_free(patchwise[i].sfini); gsl_vector_free(patchwise[i].bini); gsl_vector_free(patchwise[i].bfini); gsl_vector_free(patchwise[i].robness); } FreeFoodwebMem(&nicheweb); // eigene Funktion FreeStochasticMem(&stochastic); gsl_vector_free(nicheweb.migrPara); // gsl_vector_free(stochastic.AllMus); // gsl_vector_free(stochastic.AllNus); // gsl_vector_free(stochastic.SpeciesNumbers); // gsl_vector_free(stochastic.Biomass_AllMus); // gsl_vector_free(stochastic.Biomass_AllNus); // gsl_vector_free(stochastic.Biomass_SpeciesNumbers); gsl_vector_free(populationFIN); gsl_vector_free(robustness); gsl_vector_free(meanOfData); gsl_vector_free(meanOfDatatemp); gsl_vector_free(meanSquOfData); gsl_vector_free(standardDeviation); gsl_vector_free(standardDeviationAll); gsl_vector_free(meanSquOfDataAll); gsl_vector_free(meanSquOfDataAlltemp); gsl_matrix_free(D); gsl_matrix_free(Dchoice); //gsl_vector_free(resultEvolveWeb); gsl_vector_free(robustnesstemp); gsl_rng_free(rng1); return(0); }
long double apop_linear_constraint(gsl_vector *beta, apop_data * constraint, double margin){ #else apop_varad_head(long double, apop_linear_constraint){ static threadlocal apop_data *default_constraint; gsl_vector * apop_varad_var(beta, NULL); double apop_varad_var(margin, 0); apop_data * apop_varad_var(constraint, NULL); Apop_assert(beta, "The vector to be checked is NULL."); if (!constraint){ if (default_constraint && beta->size != default_constraint->vector->size){ apop_data_free(default_constraint); default_constraint = NULL; } if (!default_constraint){ default_constraint = apop_data_alloc(0,beta->size, beta->size); default_constraint->vector = gsl_vector_calloc(beta->size); gsl_matrix_set_identity(default_constraint->matrix); } constraint = default_constraint; } return apop_linear_constraint_base(beta, constraint, margin); } long double apop_linear_constraint_base(gsl_vector *beta, apop_data * constraint, double margin){ #endif static threadlocal gsl_vector *closest_pt = NULL; static threadlocal gsl_vector *candidate = NULL; static threadlocal gsl_vector *fix = NULL; int constraint_ct = constraint->matrix->size1; int bindlist[constraint_ct]; int i, bound = 0; /* For added efficiency, keep a scratch vector or two on hand. */ if (closest_pt==NULL || closest_pt->size != constraint->matrix->size2){ closest_pt = gsl_vector_calloc(beta->size); candidate = gsl_vector_alloc(beta->size); fix = gsl_vector_alloc(beta->size); closest_pt->data[0] = GSL_NEGINF; } /* Do any constraints bind?*/ memset(bindlist, 0, sizeof(int)*constraint_ct); for (i=0; i< constraint_ct; i++){ Apop_row_v(constraint, i, c); bound += bindlist[i] = binds(beta, apop_data_get(constraint, i, -1), c, margin); } if (!bound) return 0; //All constraints met. gsl_vector *base_beta = apop_vector_copy(beta); /* With only one constraint, it's easy. */ if (constraint->vector->size==1){ Apop_row_v(constraint, 0, c); find_nearest_point(base_beta, constraint->vector->data[0], c, beta); goto add_margin; } /* Finally, multiple constraints, at least one binding. For each surface, pick a candidate point. Check whether the point meets the other constraints. if not, translate to a new point that works. [Do this by maintaining a pseudopoint that translates by the necessary amount.] Once you have a candidate point, compare its distance to the current favorite; keep the best. */ for (i=0; i< constraint_ct; i++) if (bindlist[i]){ get_candiate(base_beta, constraint, i, candidate, margin); if(apop_vector_distance(base_beta, candidate) < apop_vector_distance(base_beta, closest_pt)) gsl_vector_memcpy(closest_pt, candidate); } gsl_vector_memcpy(beta, closest_pt); add_margin: for (i=0; i< constraint_ct; i++){ if(bindlist[i]){ Apop_row_v(constraint, i, c); gsl_vector_memcpy(fix, c); gsl_vector_scale(fix, magnitude(fix)); gsl_vector_scale(fix, margin); gsl_vector_add(beta, fix); } } long double out = apop_vector_distance(base_beta, beta); gsl_vector_free(base_beta); return out; }
/* solve: min ||b - A x||^2 + lambda^2 ||x||^2 */ static int test_COD_lssolve2_eps(const double lambda, const gsl_matrix * A, const gsl_vector * b, const double eps, const char *desc) { int s = 0; size_t i, M = A->size1, N = A->size2; gsl_vector * lhs = gsl_vector_alloc(M); gsl_matrix * QRZT = gsl_matrix_alloc(M, N); gsl_vector * tau_Q = gsl_vector_alloc(GSL_MIN(M, N)); gsl_vector * tau_Z = gsl_vector_alloc(GSL_MIN(M, N)); gsl_vector * work = gsl_vector_alloc(N); gsl_vector * x = gsl_vector_alloc(N); gsl_vector * x_aug = gsl_vector_alloc(N); gsl_vector * r = gsl_vector_alloc(M); gsl_vector * res = gsl_vector_alloc(M); gsl_permutation * perm = gsl_permutation_alloc(N); size_t rank; /* form full rank augmented system B = [ A ; lambda*I_N ], f = [ rhs ; 0 ] and solve with QRPT */ { gsl_vector_view v; gsl_matrix_view m; gsl_permutation *p = gsl_permutation_alloc(N); gsl_matrix * B = gsl_matrix_calloc(M + N, N); gsl_vector * f = gsl_vector_calloc(M + N); gsl_vector * tau = gsl_vector_alloc(N); gsl_vector * residual = gsl_vector_alloc(M + N); int signum; m = gsl_matrix_submatrix(B, 0, 0, M, N); gsl_matrix_memcpy(&m.matrix, A); m = gsl_matrix_submatrix(B, M, 0, N, N); v = gsl_matrix_diagonal(&m.matrix); gsl_vector_set_all(&v.vector, lambda); v = gsl_vector_subvector(f, 0, M); gsl_vector_memcpy(&v.vector, b); /* solve: [ A ; lambda*I ] x_aug = [ b ; 0 ] */ gsl_linalg_QRPT_decomp(B, tau, p, &signum, work); gsl_linalg_QRPT_lssolve(B, tau, p, f, x_aug, residual); gsl_permutation_free(p); gsl_matrix_free(B); gsl_vector_free(f); gsl_vector_free(tau); gsl_vector_free(residual); } gsl_matrix_memcpy(QRZT, A); s += gsl_linalg_COD_decomp(QRZT, tau_Q, tau_Z, perm, &rank, work); { gsl_matrix *S = gsl_matrix_alloc(rank, rank); gsl_vector *workr = gsl_vector_alloc(rank); s += gsl_linalg_COD_lssolve2(lambda, QRZT, tau_Q, tau_Z, perm, rank, b, x, res, S, workr); gsl_matrix_free(S); gsl_vector_free(workr); } for (i = 0; i < N; i++) { double xi = gsl_vector_get(x, i); double yi = gsl_vector_get(x_aug, i); gsl_test_rel(xi, yi, eps, "%s (%3lu,%3lu)[%lu]: %22.18g %22.18g\n", desc, M, N, i, xi, yi); } /* compute residual r = b - A x */ if (M == N) { gsl_vector_set_zero(r); } else { gsl_vector_memcpy(r, b); gsl_blas_dgemv(CblasNoTrans, -1.0, A, x, 1.0, r); } for (i = 0; i < N; i++) { double xi = gsl_vector_get(res, i); double yi = gsl_vector_get(r, i); gsl_test_rel(xi, yi, sqrt(eps), "%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n", desc, M, N, i, xi, yi); } gsl_vector_free(r); gsl_vector_free(res); gsl_vector_free(x); gsl_vector_free(x_aug); gsl_vector_free(tau_Q); gsl_vector_free(tau_Z); gsl_matrix_free(QRZT); gsl_vector_free(lhs); gsl_vector_free(work); gsl_permutation_free(perm); return s; }
static void vine_ran_rvine(const dml_vine_t *vine, const gsl_rng *rng, gsl_matrix *data) { size_t n, m; gsl_vector ***vdirect, ***vindirect; gsl_vector *z1 = NULL, *z2 = NULL, *hinv = NULL; // Initialized to avoid GCC warnings. size_t **M; n = vine->dim; m = data->size1; vdirect = g_malloc_n(n, sizeof(gsl_vector **)); vindirect = g_malloc_n(n, sizeof(gsl_vector **)); for (size_t i = 0; i < n; i++) { vdirect[i] = g_malloc0_n(n, sizeof(gsl_vector *)); vindirect[i] = g_malloc0_n(n, sizeof(gsl_vector *)); } M = g_malloc_n(n, sizeof(size_t *)); for (size_t i = 0; i < n; i++) { M[i] = g_malloc0_n(i + 1, sizeof(size_t)); } // Line 4. for (size_t k = 0; k < n; k++) { vdirect[n - 1][k] = gsl_vector_alloc(m); for (size_t i = 0; i < m; i++) { gsl_vector_set(vdirect[n - 1][k], i, gsl_rng_uniform(rng)); } } // Line 5. for (size_t k = 0; k < n; k++) { M[k][k] = vine->matrix[k][k]; M[n - 1][k] = vine->matrix[n - 1][k]; for (size_t i = n - 2; i > k; i--) { if (vine->matrix[i][k] > M[i + 1][k]) { M[i][k] = vine->matrix[i][k]; } else { M[i][k] = M[i + 1][k]; } } } // Line 6. gsl_matrix_set_col(data, vine->order[0], vdirect[n - 1][n - 1]); // for loop in line 7. for (size_t k = n - 2; /* See break call. */; k--) { // for loop in line 8. for (size_t i = k + 1; i < n; i++) { // Line 14. if (vine->matrix[i][k] != 0 && dml_copula_type(vine->copulas[i][k]) != DML_COPULA_INDEP) { if (M[i][k] == vine->matrix[i][k]) { z2 = vdirect[i][n - M[i][k]]; } else { z2 = vindirect[i][n - M[i][k]]; } hinv = gsl_vector_alloc(m); dml_copula_hinv(vine->copulas[i][k], vdirect[n - 1][k], z2, hinv); gsl_vector_free(vdirect[n - 1][k]); vdirect[n - 1][k] = hinv; } } // Line 16. gsl_matrix_set_col(data, vine->order[n - k - 1], vdirect[n - 1][k]); if (k == 0) break; // Avoid problems decrementing the unsigned k if k is 0. // for loop in line 17. for (size_t i = n - 1; i > k; i--) { // Line 18. z1 = vdirect[i][k]; // Line 19. if (vdirect[i - 1][k] == NULL) { vdirect[i - 1][k] = gsl_vector_alloc(m); } if (vine->matrix[i][k] == 0 || dml_copula_type(vine->copulas[i][k]) == DML_COPULA_INDEP) { // Vine truncated or independence copula. gsl_vector_memcpy(vdirect[i - 1][k], z1); } else { dml_copula_h(vine->copulas[i][k], z1, z2, vdirect[i - 1][k]); } if (vindirect[i - 1][k] == NULL) { vindirect[i - 1][k] = gsl_vector_alloc(m); } gsl_vector_memcpy(vindirect[i - 1][k], vdirect[i - 1][k]); } } // Freeing memory. for (size_t i = 0; i < n; i++) { g_free(M[i]); } g_free(M); for (size_t i = 0; i < n; i++) { for (size_t j = 0; j < n; j++) { if (vdirect[i][j] != NULL) { gsl_vector_free(vdirect[i][j]); } if (vindirect[i][j] != NULL) { gsl_vector_free(vindirect[i][j]); } } g_free(vdirect[i]); g_free(vindirect[i]); } g_free(vdirect); g_free(vindirect); }
static int conjugate_pr_iterate (void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx) { conjugate_pr_state_t *state = (conjugate_pr_state_t *) vstate; gsl_vector *x1 = state->x1; gsl_vector *dx1 = state->dx1; gsl_vector *x2 = state->x2; gsl_vector *p = state->p; gsl_vector *g0 = state->g0; double pnorm = state->pnorm; double g0norm = state->g0norm; double fa = *f, fb, fc; double dir; double stepa = 0.0, stepb, stepc = state->step, tol = state->tol; double g1norm; double pg; if (pnorm == 0.0 || g0norm == 0.0) { gsl_vector_set_zero (dx); return GSL_ENOPROG; } /* Determine which direction is downhill, +p or -p */ gsl_blas_ddot (p, gradient, &pg); dir = (pg >= 0.0) ? +1.0 : -1.0; /* Compute new trial point at x_c= x - step * p, where p is the current direction */ take_step (x, p, stepc, dir / pnorm, x1, dx); /* Evaluate function and gradient at new point xc */ fc = GSL_MULTIMIN_FN_EVAL_F (fdf, x1); if (fc < fa) { /* Success, reduced the function value */ state->step = stepc * 2.0; *f = fc; gsl_vector_memcpy (x, x1); GSL_MULTIMIN_FN_EVAL_DF (fdf, x1, gradient); return GSL_SUCCESS; } #ifdef DEBUG printf ("got stepc = %g fc = %g\n", stepc, fc); #endif /* Do a line minimisation in the region (xa,fa) (xc,fc) to find an intermediate (xb,fb) satisifying fa > fb < fc. Choose an initial xb based on parabolic interpolation */ intermediate_point (fdf, x, p, dir / pnorm, pg, stepa, stepc, fa, fc, x1, dx1, gradient, &stepb, &fb); if (stepb == 0.0) { return GSL_ENOPROG; } minimize (fdf, x, p, dir / pnorm, stepa, stepb, stepc, fa, fb, fc, tol, x1, dx1, x2, dx, gradient, &(state->step), f, &g1norm); gsl_vector_memcpy (x, x2); /* Choose a new conjugate direction for the next step */ state->iter = (state->iter + 1) % x->size; if (state->iter == 0) { gsl_vector_memcpy (p, gradient); state->pnorm = g1norm; } else { /* p' = g1 - beta * p */ double g0g1, beta; gsl_blas_daxpy (-1.0, gradient, g0); /* g0' = g0 - g1 */ gsl_blas_ddot(g0, gradient, &g0g1); /* g1g0 = (g0-g1).g1 */ beta = g0g1 / (g0norm*g0norm); /* beta = -((g1 - g0).g1)/(g0.g0) */ gsl_blas_dscal (-beta, p); gsl_blas_daxpy (1.0, gradient, p); state->pnorm = gsl_blas_dnrm2 (p); } state->g0norm = g1norm; gsl_vector_memcpy (g0, gradient); #ifdef DEBUG printf ("updated conjugate directions\n"); printf ("p: "); gsl_vector_fprintf (stdout, p, "%g"); printf ("g: "); gsl_vector_fprintf (stdout, gradient, "%g"); #endif return GSL_SUCCESS; }
static int test_COD_lssolve_eps(const gsl_matrix * m, const double * actual, const double eps, const char *desc) { int s = 0; size_t i, M = m->size1, N = m->size2; gsl_vector * lhs = gsl_vector_alloc(M); gsl_vector * rhs = gsl_vector_alloc(M); gsl_matrix * QRZT = gsl_matrix_alloc(M, N); gsl_vector * tau_Q = gsl_vector_alloc(GSL_MIN(M, N)); gsl_vector * tau_Z = gsl_vector_alloc(GSL_MIN(M, N)); gsl_vector * work = gsl_vector_alloc(N); gsl_vector * x = gsl_vector_alloc(N); gsl_vector * r = gsl_vector_alloc(M); gsl_vector * res = gsl_vector_alloc(M); gsl_permutation * perm = gsl_permutation_alloc(N); size_t rank; gsl_matrix_memcpy(QRZT, m); for (i = 0; i < M; i++) gsl_vector_set(rhs, i, i + 1.0); s += gsl_linalg_COD_decomp(QRZT, tau_Q, tau_Z, perm, &rank, work); s += gsl_linalg_COD_lssolve(QRZT, tau_Q, tau_Z, perm, rank, rhs, x, res); for (i = 0; i < N; i++) { double xi = gsl_vector_get(x, i); gsl_test_rel(xi, actual[i], eps, "%s (%3lu,%3lu)[%lu]: %22.18g %22.18g\n", desc, M, N, i, xi, actual[i]); } /* compute residual r = b - m x */ if (M == N) { gsl_vector_set_zero(r); } else { gsl_vector_memcpy(r, rhs); gsl_blas_dgemv(CblasNoTrans, -1.0, m, x, 1.0, r); } for (i = 0; i < N; i++) { double r1 = gsl_vector_get(res, i); double r2 = gsl_vector_get(r, i); if (fabs(r2) < 1.0e3 * GSL_DBL_EPSILON) { gsl_test_abs(r1, r2, 10.0 * eps, "%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n", desc, M, N, i, r1, r2); } else { gsl_test_rel(r1, r2, eps, "%s res (%3lu,%3lu)[%lu]: %22.18g %22.18g\n", desc, M, N, i, r1, r2); } } gsl_vector_free(r); gsl_vector_free(res); gsl_vector_free(x); gsl_vector_free(tau_Q); gsl_vector_free(tau_Z); gsl_matrix_free(QRZT); gsl_vector_free(rhs); gsl_vector_free(lhs); gsl_vector_free(work); gsl_permutation_free(perm); return s; }
/** **************************************************************************************************************/ double g_outer_gaus_single (double x, void *params) { int i,j; double term1=0.0; const datamatrix *designdata = ((struct fnparams *) params)->designdata;/** all design data inc Y and priors **/ gsl_vector *betaincTau = ((struct fnparams *) params)->betaincTau;/** include precision */ int fixed_beta =((struct fnparams *) params)->fixed_index;/** which parameter is to be treated as fixed */ const gsl_vector *priormean = designdata->priormean; const gsl_vector *priorsd = designdata->priorsd; const gsl_vector *priorgamshape = designdata->priorgamshape; const gsl_vector *priorgamscale = designdata->priorgamscale; gsl_vector *beta = ((struct fnparams *) params)->beta;/** does not include precision */ gsl_vector *vectmp1= ((struct fnparams *) params)->vectmp1;/** numparams long*/ gsl_vector *vectmp2 =((struct fnparams *) params)->vectmp2;/** numparams long*/ double epsabs_inner=((struct fnparams *) params)->epsabs_inner;/** absolute error in internal laplace est */ int maxiters_inner=((struct fnparams *) params)->maxiters_inner;/** number of steps for inner root finder */ int verbose=((struct fnparams *) params)->verbose;/** */ int n_betas= (designdata->datamatrix_noRV)->size2;/** number of mean terms excl rv and precision **/ int n=(designdata->datamatrix_noRV)->size1;/** total number of obs **/ double term2=0.0,term3=0.0,term4=0.0,gval=0.0, term5=0.0; /*Rprintf("%d %d\n",n_betas,betaincTau->size);*/ double tau_rv,tau_resid, copyBeta=0.0; /** need to replace variable fixed_beta with x **/ copyBeta=gsl_vector_get(betaincTau,fixed_beta);/** store value so can reset later */ gsl_vector_set(betaincTau,fixed_beta,x); tau_rv=gsl_vector_get(betaincTau,betaincTau->size-2);/** extract the tau-precision from *beta - last entry */ /*Rprintf("g_outer_rv tau=%f\n",tau_rv);*/ tau_resid=gsl_vector_get(betaincTau,betaincTau->size-1);/** extract the tau-precision from *beta - last entry */ /*Rprintf("g_outer_resid tau=%f\n",tau_resid);*/ if(tau_rv<=0.0){/*Rprintf("tau_rv negative=%e in g_outer_gaus_single!\n",tau_rv);*/ /** aborting so re-copy value of beta changed back to what it was since passed by memory **/ /** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */ gsl_vector_set(betaincTau,fixed_beta,copyBeta); return(GSL_NAN); /*error("");*/} if(tau_resid<=0.0){/*Rprintf("tau_resid negative=%e in g_outer_gaus_single!\n",tau_resid);*/ /** aborting so re-copy value of beta changed back to what it was since passed by memory **/ /** this might legitimately occur when trying to use a central difference - which is caught by testing for isnan */ gsl_vector_set(betaincTau,fixed_beta,copyBeta); return(GSL_NAN); /*error("");*/} /** beta are the parameters values at which the function is to be evaluated **/ /** gvalue is the return value - a single double */ /** STOP - NEED TO copy betaincTau into shorter beta since last two entries are group precision then residual precision */ for(i=0;i<n_betas;i++){gsl_vector_set(beta,i,gsl_vector_get(betaincTau,i));/*Rprintf("passed beta=%f\n",gsl_vector_get(beta,i));*/ } /** part 1 - the integrals over each group of observations - use laplace for this and that is taken care of in g_inner */ /** first we want to evaluate each of the integrals for each data group **/ for(j=0;j<designdata->numUnqGrps;j++){/** for each data group **/ /*j=0;*/ /*Rprintf("processing group %d\n",j+1);*/ term1+= g_inner_gaus(betaincTau,designdata,j, epsabs_inner,maxiters_inner,verbose); } /*Rprintf("term1 in g_outer=%f\n",term1);*/ /** part 2 the priors for the means **/ term2=0; for(i=0;i<n_betas;i++){term2+=-log(sqrt(2.0*M_PI)*gsl_vector_get(priorsd,i));} /** Calc this in parts: R code "term3<- sum( (-1/(2*sd.loc*sd.loc))*(mybeta-mean.loc)*(mybeta-mean.loc) );" **/ gsl_vector_memcpy(vectmp1,beta);/** copy beta to temp vec */ gsl_vector_memcpy(vectmp2,priormean); gsl_vector_scale(vectmp2,-1.0); gsl_vector_add(vectmp1,vectmp2);/** vectmp1= beta-mean**/ gsl_vector_memcpy(vectmp2,vectmp1);/** copy vectmp1 to vectmp2 **/ gsl_vector_mul(vectmp2,vectmp1);/** square all elements in vectmp1 and store in vectmp2 */ gsl_vector_memcpy(vectmp1,priorsd); gsl_vector_mul(vectmp1,priorsd);/** square all elements in priorsd and store in vectmp1 */ gsl_vector_div(vectmp2,vectmp1);/** vectmp2/vectmp1 and store in vectmp2 **/ gsl_vector_scale(vectmp2,-0.5); /** scale by -1/2 */ gsl_vector_set_all(vectmp1,1.0); /** ones vector */ gsl_blas_ddot (vectmp2, vectmp1, &term3);/** DOT product simply to calcu sum value */ /** part 3 the prior for the group precision tau_rv **/ term4= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau_rv) -(tau_rv/gsl_vector_get(priorgamscale,0)); /** part 4 the prior for the residual precision tau_resid **/ term5= -gsl_vector_get(priorgamshape,0)*log(gsl_vector_get(priorgamscale,0)) -gsl_sf_lngamma(gsl_vector_get(priorgamshape,0)) +(gsl_vector_get(priorgamshape,0)-1)*log(tau_resid) -(tau_resid/gsl_vector_get(priorgamscale,0)); gval=(-1.0/n)*(term1+term2+term3+term4+term5); /** NO PRIOR */ /* Rprintf("WARNING - NO PRIOR\n");*/ #ifdef NOPRIOR gval=(-1.0/n)*(term1); #endif /** finally re-copy value of beta changed back to what it was since passed by memory **/ gsl_vector_set(betaincTau,fixed_beta,copyBeta); if(gsl_isnan(gval)){error("g_outer_gaus_single\n");} /*Rprintf("g_outer_final=%f term1=%f term2=%f term3=%f term4=%f term5=%f total=%f %d\n",gval,term1,term2,term3,term4,term5,term1+term2+term3+term4,n);*/ return(gval);/** negative since its a minimiser */ }
/** ************************************************************************************* ***************************************************************************************** *****************************************************************************************/ double g_inner_gaus( gsl_vector *beta, const datamatrix *designdata, int groupid, double epsabs, int maxiters, int verbose){ /** this function perform a Laplace approx on a single data group given fixed beta, so only integrate over single term epsilon **/ /* const gsl_multiroot_fdfsolver_type *T; gsl_multiroot_fdfsolver *s; gsl_multiroot_function_fdf FDF;*/ struct fnparams gparams;/** for passing to the gsl zero finding functions */ /*double epsilon=0;*//** the variable we want to find the root of **/ gsl_vector *epsilon = gsl_vector_alloc (1); gsl_vector *dgvalues = gsl_vector_alloc (1); gsl_matrix *hessgvalue = gsl_matrix_alloc (1,1); /*int iter=0;*/ /*int status;*/ /*double epsabs=1e-5; int maxiters=100;*/ /*int verbose=1;*/ gsl_vector *vectmp1 = gsl_vector_alloc (designdata->numparams+1);/** scratch space same length as number of params inc precision **/ gsl_vector *vectmp1long = gsl_vector_alloc ( ((designdata->array_of_Y)[groupid])->size);/** scratch space same length as number of obs in group j**/ gsl_vector *vectmp2long = gsl_vector_alloc ( ((designdata->array_of_Y)[groupid])->size); double logscore; double gvalue;int n,m; /*for(i=0;i<beta->size;i++){Rprintf("g_inner_gaus=%f\n",gsl_vector_get(beta,i));}*/ /*Rprintf("I HAVE epsabs_inner=%f maxiters_inner=%d verbose=%d\n",epsabs,maxiters,verbose);*/ /* FDF.f = &rv_dg_inner_gaus; FDF.df = &rv_hessg_inner_gaus; FDF.fdf = &wrapper_rv_fdf_inner_gaus; FDF.n = 1; FDF.params = &gparams; */ gparams.Y=designdata->array_of_Y[groupid]; gparams.X=designdata->array_of_designs[groupid]; gparams.beta=beta;/** inc group and residual precision **/ /*Rprintf("tau in g_inner=%f\n",gsl_vector_get(beta,beta->size-1)); if(gsl_vector_get(beta,beta->size-1)<0.0){Rprintf("got negative tau!!=%f\n",gsl_vector_get(beta,beta->size-1));error("");}*/ gparams.vectmp1=vectmp1;/** same length as beta but used as scratch space */ gparams.vectmp1long=vectmp1long; gparams.vectmp2long=vectmp2long; /** ******************** FIRST TRY for a root using hybridsj *******************************************************/ #ifdef NO iter=0; /*T = gsl_root_fdfsolver_newton; s = gsl_root_fdfsolver_alloc (T);*/ T = gsl_multiroot_fdfsolver_hybridsj; s = gsl_multiroot_fdfsolver_alloc (T, 1); status=GSL_FAILURE;/** just set it to something not equal to GSL_SUCCESS */ /*status_inits=generate_inits_rv_n(x,&gparams);*/ gsl_vector_set(epsilon,0,0.0);/** initial guess */ /*gsl_root_fdfsolver_set (s, &FDF, epsilon);*/ gsl_multiroot_fdfsolver_set (s, &FDF, epsilon); /*Rprintf ("using %s method\n", gsl_root_fdfsolver_name (s)); Rprintf ("%-5s %10s %10s %10s\n", "iter", "root", "err", "err(est)"); */ /*print_state (iter, s);*/ iter=0; do { iter++; status = gsl_multiroot_fdfsolver_iterate (s); /*print_state (iter, s);*/ if (status) break; status = gsl_multiroot_test_residual (s->f, epsabs); } while (status == GSL_CONTINUE && iter < maxiters); if( status != GSL_SUCCESS){Rprintf ("Zero finding warning: internal--- epsilon status = %s\n", gsl_strerror (status)); /*for(i=0;i<s->x->size;i++){Rprintf("0epsilon=%f ",gsl_vector_get(s->x,i));}Rprintf("\n");*/} gsl_vector_memcpy(epsilon,s->x); Rprintf("modes: %f\n",gsl_vector_get(epsilon,0)); gsl_multiroot_fdfsolver_free(s); /*Rprintf("x=%5.10f f=%5.10f\n",gsl_root_fdfsolver_root(s),rv_dg_inner(gsl_root_fdfsolver_root(s),&gparams));*/ /* if(status != GSL_SUCCESS){*//*error("no root\n");*//*Rprintf("binary no root at node %d\n",groupid+1);*//*logscore= DBL_MAX;*/ /** root finding failed so discard model by setting fit to worst possible */ /*} else {*/ /*gsl_vector_set(epsilon,0,0.3);*/ #endif rv_dg_inner_gaus(epsilon,&gparams, dgvalues);/** value is returned in dgvalues - first entry **/ gsl_vector_memcpy(epsilon,dgvalues);/** copy value dgvalues into epsilon */ /*Rprintf("mode for epsilon=%f\n",gsl_vector_get(epsilon,0));*/ rv_g_inner_gaus(epsilon,&gparams, &gvalue);/*Rprintf("==>g()=%e %f tau=%f\n",gvalue,gsl_vector_get(epsilon,0),gsl_vector_get(beta,2));*/ /*if(status != GSL_SUCCESS){Rprintf("1epsilon=%f %f\n",gsl_vector_get(epsilon,0), gvalue);}*/ rv_hessg_inner_gaus(epsilon,&gparams, hessgvalue); /* Rprintf("node=%d hessian at g\n",nodeid+1); for(j=0;j<myBeta->size;j++){Rprintf("%f ",gsl_vector_get(myBeta,j));}Rprintf("\n"); for(j=0;j<hessgvalue->size1;j++){ for(k=0;k<hessgvalue->size2;k++){Rprintf("%f ",gsl_matrix_get(hessgvalue,j,k));} Rprintf("\n");}*/ /*Rprintf("epsilon=%f\n",epsilon);*/ n=((designdata->array_of_designs)[groupid])->size1;/** number of obs in group */ m=1;/** number of params */ /*Rprintf("gvalue in g_inner=|%f| n=|%d| |%f|\n",gvalue,n,-n*gvalue);*/ /*if(status != GSL_SUCCESS){Rprintf("2epsilon=%f %f\n",gsl_vector_get(epsilon,0), gvalue);}*/ logscore= -n*gvalue-0.5*log(gsl_matrix_get(hessgvalue,0,0))+(m/2.0)*log((2.0*M_PI)/n); /** this is the final value */ if(gsl_isnan(logscore)){error("nan in g_inner hessmat=%f epsilon=%f gvalue=%f\n",gsl_matrix_get(hessgvalue,0,0),gsl_vector_get(epsilon,0),gvalue);} /*}*/ /*Rprintf("group=%d logscore=%f\n",groupid+1,logscore);*/ gsl_vector_free(dgvalues); gsl_vector_free(epsilon); gsl_matrix_free(hessgvalue); gsl_vector_free(vectmp1); gsl_vector_free(vectmp1long); gsl_vector_free(vectmp2long); return(logscore); }
/** *******************************************************************************************************************************************/ int generate_gaus_rv_inits(gsl_vector *myBeta,struct fnparams *gparams){ /** this is the SAME CODE as in the Gaussian case */ /** beta_hat= (X^T X)^{-1} X^T y **/ const datamatrix *designdata = ((struct fnparams *) gparams)->designdata;/** all design data inc Y and priors **/ const gsl_vector *Y = designdata->Y;/** response vector **/ const gsl_matrix *X = designdata->datamatrix_noRV ;/** design matrix - with one too few cols! **/ gsl_vector *vectmp1= gparams->vectmp1;/** numparams long*/ gsl_vector *vectmp2 = gparams->vectmp2;/** numparams long*/ gsl_matrix *mattmp2 = gparams->mattmp2;/** same dim as X*/ gsl_matrix *mattmp3 = gparams->mattmp3;/** p x p **/ gsl_matrix *mattmp4 = gparams->mattmp4;/** p x p **/ gsl_vector *vectmp1long = gparams->vectmp1long;/** scratch space **/ gsl_vector *vectmp2long = gparams->vectmp2long;/** scratch space **/ gsl_permutation *perm = gparams->perm; unsigned int i; int ss; int haveError; double variance=0.0; double n=Y->size;/** no. observations **/ double m=X->size2;/** number of coefficients excluding tau-precision */ /*Rprintf("X: %d %d %d %d %d %d\n",X->size1,X->size2,mattmp2->size1,mattmp2->size2,mattmp3->size1,mattmp3->size2); */ gsl_matrix_memcpy(mattmp2,X); gsl_blas_dgemm (CblasTrans, CblasNoTrans, /** mattmp3 is p x p matrix X^T X **/ 1.0, X, mattmp2, 0.0, mattmp3); gsl_permutation_init(perm);/** reset - might not be needed */ gsl_linalg_LU_decomp(mattmp3,perm,&ss); gsl_set_error_handler_off();/**Turning off GSL Error handler as this may fail as mattmp3 may be singular */ haveError=gsl_linalg_LU_invert (mattmp3, perm, mattmp4);/** mattmp4 is now inv (X^T X) */ if(!haveError){/** no error */ /** copy Y into vectmp1long and +1 and take logs since poisson has log link - this is a fudge */ /*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(Y,i)+DBL_MIN)/(log(1-gsl_vector_get(Y,i)+DBL_MIN)));} */ /*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(Y,i)+1)/(log(1-gsl_vector_get(Y,i)+1)));} */ gsl_blas_dgemv (CblasTrans, 1.0, X, Y, 0.0, vectmp1); /** X^T Y */ gsl_blas_dgemv (CblasNoTrans, 1.0, mattmp4, vectmp1, 0.0, vectmp2); for(i=0;i<myBeta->size-2;i++){gsl_vector_set(myBeta,i,gsl_vector_get(vectmp2,i));} /** size myBeta->size-2 as last two entries are precisions **/ } else {/** singular to set initial values all to zero **/ Rprintf("caught gsl error - singular matrix in initial guess estimates\n"); for(i=0;i<myBeta->size;i++){gsl_vector_set(myBeta,i,0.01);}} gsl_set_error_handler (NULL);/** restore the error handler*/ /*Rprintf("inits\n");for(i=0;i<myBeta->size;i++){Rprintf("%10.15e ",gsl_vector_get(myBeta,i));} Rprintf("\n");*//** set to Least squares estimate */ /** now for variance estimate */ /** first get y_hat estimate */ gsl_blas_dgemv (CblasNoTrans, 1.0, X, vectmp2, 0.0, vectmp1long); /** vectmp1 is y_hat */ /*for(i=0;i<vectmp1long->size;i++){Rprintf("y_hat=%f\n",gsl_vector_get(vectmp1long,i));}*/ /*error("");*/ gsl_vector_scale(vectmp1long,-1.0);/** - y_hat */ gsl_vector_add(vectmp1long,Y);/** now have Y-y_hat (or -y_hat + Y) */ /*for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,fabs(gsl_vector_get(vectmp1long,i)));} for(i=0;i<vectmp1long->size;i++){Rprintf("y_hat=%f\n",gsl_vector_get(vectmp1long,i));} for(i=0;i<vectmp1long->size;i++){gsl_vector_set(vectmp1long,i,log(gsl_vector_get(vectmp1long,i))/log(1-gsl_vector_get(vectmp1long,i)));}*/ /** errors on logit scale **/ /*gsl_vector_set_all(vectmp2long,1);*/ gsl_vector_memcpy(vectmp2long,vectmp1long); gsl_blas_ddot (vectmp1long, vectmp2long, &variance);/** got sum((Y-Y_hat)^2) */ variance=variance/(n-m);/** unbiased estimator using denominator n-#term in regression equation **/ /* Rprintf("variance estimator=%f precision=%f\n",variance,1/variance);*/ /* variance=0.086;*/ /*variance=exp(gsl_vector_get(myBeta,0))/(1+exp(gsl_vector_get(myBeta,0)));*/ /** variance here is for plain glm - just split this 50/50 between residual error and group level variance **/ gsl_vector_set(myBeta,myBeta->size-2,1.0/(0.5*variance));/** - estimate for rv precision **/ gsl_vector_set(myBeta,myBeta->size-1,1.0/(0.5*variance));/** - estimate for residual precision **/ /*gsl_vector_set(myBeta,myBeta->size-1,1.0/variance); */ /*gsl_vector_set(myBeta,0,0.9 );gsl_vector_set(myBeta,1,0.9);gsl_vector_set(myBeta,2,1.5);*/ #ifdef junk Rprintf("------------ TEMP: Using Fixed initial values from LME4----------------\n"); gsl_vector_set(myBeta,0,0.062044233);/** intercept */ gsl_vector_set(myBeta,1,-0.1229382094322);/** slope g2 */ gsl_vector_set(myBeta,2,1.0/0.1570366587829);/** group level precision */ gsl_vector_set(myBeta,3,1.0/0.8628565204966);/** residual precision */ #endif /*Rprintf("inits\n");for(i=0;i<myBeta->size;i++){Rprintf("%10.15e ",gsl_vector_get(myBeta,i));} Rprintf("\n");*//** set to Least squares estimate */ return GSL_SUCCESS; }
int main(int argc, char **argv) { const int MAX_ITER = 50; const double RELTOL = 1e-2; const double ABSTOL = 1e-4; /* * Some bookkeeping variables for MPI. The 'rank' of a process is its numeric id * in the process pool. For example, if we run a program via `mpirun -np 4 foo', then * the process ranks are 0 through 3. Here, N and size are the total number of processes * running (in this example, 4). */ int rank; int size; MPI_Init(&argc, &argv); // Initialize the MPI execution environment MPI_Comm_rank(MPI_COMM_WORLD, &rank); // Determine current running process MPI_Comm_size(MPI_COMM_WORLD, &size); // Total number of processes double N = (double) size; // Number of subsystems/slaves for ADMM /* Read in local data */ int skinny; // A flag indicating whether the matrix A is fat or skinny FILE *f; int m, n; int row, col; double entry; /* * Subsystem n will look for files called An.dat and bn.dat * in the current directory; these are its local data and do not need to be * visible to any other processes. Note that * m and n here refer to the dimensions of the *local* coefficient matrix. */ /* Read A */ char s[20]; sprintf(s, "data/A%d.dat", rank + 1); printf("[%d] reading %s\n", rank, s); f = fopen(s, "r"); if (f == NULL) { printf("[%d] ERROR: %s does not exist, exiting.\n", rank, s); exit(EXIT_FAILURE); } mm_read_mtx_array_size(f, &m, &n); gsl_matrix *A = gsl_matrix_calloc(m, n); for (int i = 0; i < m*n; i++) { row = i % m; col = floor(i/m); fscanf(f, "%lf", &entry); gsl_matrix_set(A, row, col, entry); } fclose(f); /* Read b */ sprintf(s, "data/b%d.dat", rank + 1); printf("[%d] reading %s\n", rank, s); f = fopen(s, "r"); if (f == NULL) { printf("[%d] ERROR: %s does not exist, exiting.\n", rank, s); exit(EXIT_FAILURE); } mm_read_mtx_array_size(f, &m, &n); gsl_vector *b = gsl_vector_calloc(m); for (int i = 0; i < m; i++) { fscanf(f, "%lf", &entry); gsl_vector_set(b, i, entry); } fclose(f); m = A->size1; n = A->size2; skinny = (m >= n); /* * These are all variables related to ADMM itself. There are many * more variables than in the Matlab implementation because we also * require vectors and matrices to store various intermediate results. * The naming scheme follows the Matlab version of this solver. */ double rho = 1.0; gsl_vector *x = gsl_vector_calloc(n); gsl_vector *u = gsl_vector_calloc(n); gsl_vector *z = gsl_vector_calloc(n); gsl_vector *y = gsl_vector_calloc(n); gsl_vector *r = gsl_vector_calloc(n); gsl_vector *zprev = gsl_vector_calloc(n); gsl_vector *zdiff = gsl_vector_calloc(n); gsl_vector *q = gsl_vector_calloc(n); gsl_vector *w = gsl_vector_calloc(n); gsl_vector *Aq = gsl_vector_calloc(m); gsl_vector *p = gsl_vector_calloc(m); gsl_vector *Atb = gsl_vector_calloc(n); double send[3]; // an array used to aggregate 3 scalars at once double recv[3]; // used to receive the results of these aggregations double nxstack = 0; double nystack = 0; double prires = 0; double dualres = 0; double eps_pri = 0; double eps_dual = 0; /* Precompute and cache factorizations */ gsl_blas_dgemv(CblasTrans, 1, A, b, 0, Atb); // Atb = A^T b /* * The lasso regularization parameter here is just hardcoded * to 0.5 for simplicity. Using the lambda_max heuristic would require * network communication, since it requires looking at the *global* A^T b. */ double lambda = 0.5; if (rank == 0) { printf("using lambda: %.4f\n", lambda); } gsl_matrix *L; /* Use the matrix inversion lemma for efficiency; see section 4.2 of the paper */ if (skinny) { /* L = chol(AtA + rho*I) */ L = gsl_matrix_calloc(n,n); gsl_matrix *AtA = gsl_matrix_calloc(n,n); gsl_blas_dsyrk(CblasLower, CblasTrans, 1, A, 0, AtA); gsl_matrix *rhoI = gsl_matrix_calloc(n,n); gsl_matrix_set_identity(rhoI); gsl_matrix_scale(rhoI, rho); gsl_matrix_memcpy(L, AtA); gsl_matrix_add(L, rhoI); gsl_linalg_cholesky_decomp(L); gsl_matrix_free(AtA); gsl_matrix_free(rhoI); } else { /* L = chol(I + 1/rho*AAt) */ L = gsl_matrix_calloc(m,m); gsl_matrix *AAt = gsl_matrix_calloc(m,m); gsl_blas_dsyrk(CblasLower, CblasNoTrans, 1, A, 0, AAt); gsl_matrix_scale(AAt, 1/rho); gsl_matrix *eye = gsl_matrix_calloc(m,m); gsl_matrix_set_identity(eye); gsl_matrix_memcpy(L, AAt); gsl_matrix_add(L, eye); gsl_linalg_cholesky_decomp(L); gsl_matrix_free(AAt); gsl_matrix_free(eye); } /* Main ADMM solver loop */ int iter = 0; if (rank == 0) { printf("%3s %10s %10s %10s %10s %10s\n", "#", "r norm", "eps_pri", "s norm", "eps_dual", "objective"); } double startAllTime, endAllTime; startAllTime = MPI_Wtime(); while (iter < MAX_ITER) { /* u-update: u = u + x - z */ gsl_vector_sub(x, z); gsl_vector_add(u, x); /* x-update: x = (A^T A + rho I) \ (A^T b + rho z - y) */ gsl_vector_memcpy(q, z); gsl_vector_sub(q, u); gsl_vector_scale(q, rho); gsl_vector_add(q, Atb); // q = A^T b + rho*(z - u) double tmp, tmpq; gsl_blas_ddot(x, x, &tmp); gsl_blas_ddot(q, q, &tmpq); if (skinny) { /* x = U \ (L \ q) */ gsl_linalg_cholesky_solve(L, q, x); } else { /* x = q/rho - 1/rho^2 * A^T * (U \ (L \ (A*q))) */ gsl_blas_dgemv(CblasNoTrans, 1, A, q, 0, Aq); gsl_linalg_cholesky_solve(L, Aq, p); gsl_blas_dgemv(CblasTrans, 1, A, p, 0, x); /* now x = A^T * (U \ (L \ (A*q)) */ gsl_vector_scale(x, -1/(rho*rho)); gsl_vector_scale(q, 1/rho); gsl_vector_add(x, q); } /* * Message-passing: compute the global sum over all processors of the * contents of w and t. Also, update z. */ gsl_vector_memcpy(w, x); gsl_vector_add(w, u); // w = x + u gsl_blas_ddot(r, r, &send[0]); gsl_blas_ddot(x, x, &send[1]); gsl_blas_ddot(u, u, &send[2]); send[2] /= pow(rho, 2); gsl_vector_memcpy(zprev, z); // could be reduced to a single Allreduce call by concatenating send to w MPI_Allreduce(w->data, z->data, n, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); MPI_Allreduce(send, recv, 3, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); prires = sqrt(recv[0]); /* sqrt(sum ||r_i||_2^2) */ nxstack = sqrt(recv[1]); /* sqrt(sum ||x_i||_2^2) */ nystack = sqrt(recv[2]); /* sqrt(sum ||y_i||_2^2) */ gsl_vector_scale(z, 1/N); soft_threshold(z, lambda/(N*rho)); /* Termination checks */ /* dual residual */ gsl_vector_memcpy(zdiff, z); gsl_vector_sub(zdiff, zprev); dualres = sqrt(N) * rho * gsl_blas_dnrm2(zdiff); /* ||s^k||_2^2 = N rho^2 ||z - zprev||_2^2 */ /* compute primal and dual feasibility tolerances */ eps_pri = sqrt(n*N)*ABSTOL + RELTOL * fmax(nxstack, sqrt(N)*gsl_blas_dnrm2(z)); eps_dual = sqrt(n*N)*ABSTOL + RELTOL * nystack; if (rank == 0) { printf("%3d %10.4f %10.4f %10.4f %10.4f %10.4f\n", iter, prires, eps_pri, dualres, eps_dual, objective(A, b, lambda, z)); } if (prires <= eps_pri && dualres <= eps_dual) { break; } /* Compute residual: r = x - z */ gsl_vector_memcpy(r, x); gsl_vector_sub(r, z); iter++; } /* Have the master write out the results to disk */ if (rank == 0) { endAllTime = MPI_Wtime(); printf("Elapsed time is: %lf \n", endAllTime - startAllTime); f = fopen("data/solution.dat", "w"); gsl_vector_fprintf(f, z, "%lf"); fclose(f); } MPI_Finalize(); /* Shut down the MPI execution environment */ /* Clear memory */ gsl_matrix_free(A); gsl_matrix_free(L); gsl_vector_free(b); gsl_vector_free(x); gsl_vector_free(u); gsl_vector_free(z); gsl_vector_free(y); gsl_vector_free(r); gsl_vector_free(w); gsl_vector_free(zprev); gsl_vector_free(zdiff); gsl_vector_free(q); gsl_vector_free(Aq); gsl_vector_free(Atb); gsl_vector_free(p); return EXIT_SUCCESS; }
// measurement update (correction) bool DiscreteExtendedKalmanFilter::updateMeasurement(const size_t step, const gsl_vector *actualMeasurement, const gsl_vector *input) { if (!x_hat_ || /*!y_hat_ ||*/ !P_ || !K_) return false; const gsl_vector *h_eval = system_.evaluateMeasurementEquation(step, x_hat_, input, NULL); // h = h(k, x(k), u(k), 0) const gsl_matrix *Cd = system_.getOutputMatrix(step, x_hat_); // Cd(k) = dh(k, x-(k), u(k), 0)/dx #if 0 const gsl_matrix *V = system_.getMeasurementNoiseCouplingMatrix(step); // V(k) = dh(k, x-(k), u(k), 0)/dv const gsl_matrix *R = system_.getMeasurementNoiseCovarianceMatrix(step); // R(k) #else const gsl_matrix *Rd = system_.getMeasurementNoiseCovarianceMatrix(step); // Rd(k) = V(k) * R(k) * V(k)^T #endif if (!Cd || !Rd || !h_eval || !actualMeasurement) return false; // 1. calculate Kalman gain: K(k) = P-(k) * Cd(k)^T * (Cd(k) * P-(k) * Cd(k)^T + Rd(k))^-1 where Cd(k) = dh(k, x-(k), u(k), 0)/dx, Rd(k) = V(k) * R(k) * V(k)^T, V(k) = dh(k, x-(k), u(k), 0)/dv // inverse of matrix using LU decomposition gsl_matrix_memcpy(RR_, Rd); if (GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, P_, Cd, 0.0, PCt_) || GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Cd, PCt_, 1.0, RR_)) return false; int signum; if (GSL_SUCCESS != gsl_linalg_LU_decomp(RR_, permutation_, &signum) || GSL_SUCCESS != gsl_linalg_LU_invert(RR_, permutation_, invRR_)) return false; if (GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, PCt_, invRR_, 0.0, K_)) // calculate Kalman gain return false; // 2. update measurement: x(k) = x-(k) + K(k) * (y_tilde(k) - y_hat(k)) where y_hat(k) = h(k, x-(k), u(k), 0) #if 0 // save an estimated measurement, y_hat gsl_vector_memcpy(y_hat_, h_eval); gsl_vector_memcpy(residual_, y_hat_); if (GSL_SUCCESS != gsl_vector_sub(residual_, actualMeasurement) || // calculate residual = y_tilde(k) - y_hat(k) GSL_SUCCESS != gsl_blas_dgemv(CblasNoTrans, -1.0, K_, residual_, 1.0, x_hat_)) // calculate x_hat(k) return false; #else gsl_vector_memcpy(residual_, h_eval); if (GSL_SUCCESS != gsl_vector_sub(residual_, actualMeasurement) || // calculate residual = y_tilde(k) - y_hat(k) GSL_SUCCESS != gsl_blas_dgemv(CblasNoTrans, -1.0, K_, residual_, 1.0, x_hat_)) // calculate x_hat(k) return false; #endif // 3. update covariance: P(k) = (I - K(k) * Cd(k)) * P-(k) #if 0 // not working gsl_matrix_set_identity(M_); if (GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, K_, Cd, 1.0, M_) || GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, M_, P_, 0.0, P_)) return false; #else gsl_matrix_set_identity(M_); if (GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, -1.0, K_, Cd, 1.0, M_) || GSL_SUCCESS != gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, M_, P_, 0.0, M2_)) return false; gsl_matrix_memcpy(P_, M2_); #endif // preserve symmetry of P gsl_matrix_transpose_memcpy(M_, P_); gsl_matrix_add(P_, M_); gsl_matrix_scale(P_, 0.5); return true; }
int Holling2(double t, const double y[], double ydot[], void *params){ double alpha = 0.3; // respiration double lambda = 0.65; // ecologic efficiency double hand = 0.35; // handling time double beta = 0.5; // intraspecific competition double aij = 6.0; // attack rate int i, j,l = 0; // Hilfsvariablen double rowsum = 0; double colsum = 0; //-- Struktur zerlegen------------------------------------------------------------------------------------------------------------------------------- struct foodweb *nicheweb = (struct foodweb *)params; // pointer cast from (void*) to (struct foodweb*) //printf("t in Holling 2=%f\n", t); gsl_vector *network = (nicheweb->network); // Inhalt: A+linksA+Y+linksY+Massen+Trophische_Level = (Rnum+S)²+1+Y²+1+(Rnum+S)+S int S = nicheweb->S; int Y = nicheweb->Y; int Rnum = nicheweb->Rnum; double d = nicheweb->d; int Z = nicheweb->Z; double dij = pow(10, d); double nu,mu, tau; int SpeciesNumber; tau = gsl_vector_get(nicheweb->migrPara,0); mu = gsl_vector_get(nicheweb->migrPara,1); if((int)nu!=0) { //printf("nu ist nicht null sondern %f\n",nu); } nu = gsl_vector_get(nicheweb->migrPara,2); SpeciesNumber = gsl_vector_get(nicheweb->migrPara,3); double tlast = gsl_vector_get(nicheweb->migrPara,4); if(SpeciesNumber!= 0) { //printf("SpeciesNumber %i\n", SpeciesNumber); } //printf("t oben %f\n",t); //int len = (Rnum+S)*(Rnum+S)+2+Y*Y+(Rnum+S)+S; gsl_vector_view A_view = gsl_vector_subvector(network, 0, (Rnum+S)*(Rnum+S)); // Fressmatrix A als Vektor gsl_matrix_view EA_mat = gsl_matrix_view_vector(&A_view.vector, (Rnum+S), (Rnum+S)); // A als Matrix_view gsl_matrix *EAmat = &EA_mat.matrix; // A als Matrix gsl_vector_view D_view = gsl_vector_subvector(network, (Rnum+S)*(Rnum+S)+1, Y*Y); // Migrationsmatrix D als Vektor gsl_matrix_view ED_mat = gsl_matrix_view_vector(&D_view.vector, Y, Y); // D als Matrixview gsl_matrix *EDmat = &ED_mat.matrix; // D als Matrix gsl_vector_view M_vec = gsl_vector_subvector(network, ((Rnum+S)*(Rnum+S))+1+(Y*Y)+1, (Rnum+S)); // Massenvektor gsl_vector *Mvec = &M_vec.vector; //-- verändere zu dem gewünschten Zeitpunkt Migrationsmatrix if( (t > tau) && (tlast < tau)) { //printf("mu ist %f\n", gsl_vector_get(nicheweb->migrPara,1)); //printf("nu ist %f\n", nu); gsl_vector_set(nicheweb->migrPara,4,t); //printf("Setze Link für gewünschte Migration\n"); //printf("t oben %f\n",t); gsl_matrix_set(EDmat, nu, mu, 1.); int m; // for(l = 0; l< Y;l++) // { // for(m=0;m<Y;m++) // { // printf("%f\t",gsl_matrix_get(EDmat,l,m)); // } // printf("\n"); // } } else { gsl_matrix_set_zero(EDmat); } // printf("\ncheckpoint Holling2 I\n"); // printf("\nS = %i\n", S); // printf("\nS + Rnum = %i\n", S+Rnum); // // printf("\nSize A_view = %i\n", (int)A_view.vector.size); // printf("\nSize D_view = %i\n", (int)D_view.vector.size); // printf("\nSize M_vec = %i\n", (int)M_vec.vector.size); // for(i=0; i<(Rnum+S)*Y; i++){ // printf("\ny = %f\n", y[i]); // } // for(i=0; i<(Rnum+S)*Y; i++){ // printf("\nydot = %f\n", ydot[i]); // } //--zusätzliche Variablen anlegen------------------------------------------------------------------------------------------------------------- double ytemp[(Rnum+S)*Y]; for(i=0; i<(Rnum+S)*Y; i++) ytemp[i] = y[i]; // temp array mit Kopie der Startwerte for(i=0; i<(Rnum+S)*Y; i++) ydot[i] = 0; // Ergebnis, in das evolve_apply schreibt gsl_vector_view yfddot_vec = gsl_vector_view_array(ydot, (Rnum+S)*Y); //Notiz: vector_view_array etc. arbeiten auf den original Daten der ihnen zugeordneten Arrays/Vektoren! gsl_vector *yfddotvec = &yfddot_vec.vector; // zum einfacheren Rechnen ydot über vector_view_array ansprechen gsl_vector_view yfd_vec = gsl_vector_view_array(ytemp, (Rnum+S)*Y); gsl_vector *yfdvec = &yfd_vec.vector; // Startwerte der Populationen //-- neue Objekte zum Rechnen anlegen-------------------------------------------------------------------------------------------------------- gsl_matrix *AFgsl = gsl_matrix_calloc(Rnum+S, Rnum+S); // matrix of foraging efforts gsl_matrix *ADgsl = gsl_matrix_calloc(Y,Y); // matrix of migration efforts gsl_matrix *Emat = gsl_matrix_calloc(Rnum+S, Rnum+S); // gsl objects for calculations of populations gsl_vector *tvec = gsl_vector_calloc(Rnum+S); gsl_vector *rvec = gsl_vector_calloc(Rnum+S); gsl_vector *svec = gsl_vector_calloc(Rnum+S); gsl_matrix *Dmat = gsl_matrix_calloc(Y,Y); // gsl objects for calculations of migration gsl_vector *d1vec = gsl_vector_calloc(Y); gsl_vector *d2vec = gsl_vector_calloc(Y); gsl_vector *d3vec = gsl_vector_calloc(Y); // printf("\ncheckpoint Holling2 III\n"); //-- Einzelne Patches lösen------------------------------------------------------------------------------------------------------------ for(l=0; l<Y; l++) // start of patch solving { gsl_matrix_set_zero(AFgsl); // Objekte zum Rechnen vor jedem Patch nullen gsl_matrix_set_zero(Emat); gsl_vector_set_zero(tvec); gsl_vector_set_zero(rvec); gsl_vector_set_zero(svec); gsl_vector_view ydot_vec = gsl_vector_subvector(yfddotvec, (Rnum+S)*l, (Rnum+S)); // enthält ydot von Patch l gsl_vector *ydotvec = &ydot_vec.vector; gsl_vector_view y_vec = gsl_vector_subvector(yfdvec, (Rnum+S)*l, (Rnum+S)); // enthält Startwerte der Population in l gsl_vector *yvec = &y_vec.vector; gsl_matrix_memcpy(AFgsl, EAmat); for(i=0; i<Rnum+S; i++) { gsl_vector_view rowA = gsl_matrix_row(AFgsl,i); rowsum = gsl_blas_dasum(&rowA.vector); if(rowsum !=0 ) { for(j=0; j<Rnum+S; j++) gsl_matrix_set(AFgsl, i, j, (gsl_matrix_get(AFgsl,i,j)/rowsum)); // normiere Beute Afgsl = A(Beutelinks auf 1 normiert) = f(i,j) } } gsl_matrix_memcpy(Emat, EAmat); // Emat = A gsl_matrix_scale(Emat, aij); // Emat(i,j) = a(i,j) gsl_matrix_mul_elements(Emat, AFgsl); // Emat(i,j) = a(i,j)*f(i,j) gsl_vector_memcpy(svec, yvec); // s(i) = y(i) gsl_vector_scale(svec, hand); // s(i) = y(i)*h gsl_blas_dgemv(CblasNoTrans, 1, Emat, svec, 0, rvec); // r(i) = Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_add_constant(rvec, 1); // r(i) = 1+Sum_k h*a(i,k)*f(i,k)*y(k) gsl_vector_memcpy(tvec, Mvec); // t(i) = masse(i)^(-0.25) gsl_vector_div(tvec, rvec); // t(i) = masse(i)^(-0.25)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_vector_mul(tvec, yvec); // t(i) = masse(i)^(-0.25)*y(i)/(1+Sum_k h*a(i,k)*f(i,k)*y(k)) gsl_blas_dgemv(CblasTrans, 1, Emat, tvec, 0, rvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j) gsl_vector_mul(rvec, yvec); // r(i) = Sum_j a(j,i)*f(j,i)*t(j)*y(i) [rvec: Praedation] gsl_blas_dgemv(CblasNoTrans, lambda, Emat, yvec, 0, ydotvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j) gsl_vector_mul(ydotvec, tvec); // ydot(i) = Sum_j lambda*a(i,j)*f(i,j)*y(j)*t(i) gsl_vector_memcpy(svec, Mvec); gsl_vector_scale(svec, alpha); // s(i) = alpha*masse^(-0.25) [svec=Respiration bzw. Mortalitaet] gsl_vector_memcpy(tvec, Mvec); gsl_vector_scale(tvec, beta); // t(i) = beta*masse^(-0.25) gsl_vector_mul(tvec, yvec); // t(i) = beta*y(i) gsl_vector_add(svec, tvec); // s(i) = alpha*masse^(-0.25)+beta*y(i) gsl_vector_mul(svec, yvec); // s(i) = alpha*masse^(-0.25)*y(i)+beta*y(i)*y(i) gsl_vector_add(svec, rvec); // [svec: Respiration, competition und Praedation] gsl_vector_sub(ydotvec, svec); // ydot(i) = Fressen-Respiration-Competition-Praedation for(i=0; i<Rnum; i++) gsl_vector_set(ydotvec, i, 0.0); // konstante Ressourcen }// Ende Einzelpatch, Ergebnis steht in ydotvec // printf("\ncheckpoint Holling2 IV\n"); //-- Migration lösen--------------------------------------------------------------------------------------------------------- gsl_vector *ydottest = gsl_vector_calloc(Y); double ydotmigr = gsl_vector_get(nicheweb->migrPara, 5); int count=0,m; for(l = 0; l< Y;l++) { for(m=0;m<Y;m++) { count += gsl_matrix_get(EDmat,l,m); } } // if(count!=0) // { // //printf("count %i\n",count); // //printf("t unten %f\n",t); // //printf("tau %f\n",tau); // for(l = 0; l< Y;l++) // { // for(m=0;m<Y;m++) // { // printf("%f\t",gsl_matrix_get(EDmat,l,m)); // } // printf("\n"); // } // } double max = gsl_matrix_max(EDmat); for(l = Rnum; l< Rnum+S; l++) // start of migration solving { if(l == SpeciesNumber+Rnum && max !=0) { //printf("max ist %f\n",max); //printf("l ist %i\n",l); gsl_matrix_set_zero(ADgsl); // reset gsl objects for every patch gsl_matrix_set_zero(Dmat); gsl_vector_set_zero(d1vec); gsl_vector_set_zero(d2vec); gsl_vector_set_zero(d3vec); gsl_vector_set_zero(ydottest); // Untervektor von yfddot (enthält ydot[]) mit offset l (Rnum...Rnum+S) und Abstand zwischen den Elementen (stride) von Rnum+S. // Dies ergibt gerade die Größe einer Spezies in jedem Patch in einem Vektor gsl_vector_view dydot_vec = gsl_vector_subvector_with_stride(yfddotvec, l, (Rnum+S), Y); // ydot[] gsl_vector *dydotvec = &dydot_vec.vector; gsl_vector_view dy_vec = gsl_vector_subvector_with_stride(yfdvec, l, (Rnum+S), Y); // Startgrößen der Spezies pro Patch gsl_vector *dyvec = &dy_vec.vector; gsl_matrix_memcpy(ADgsl, EDmat); // ADgsl = D if(nicheweb->M == 1) // umschalten w: patchwise (Abwanderung aus jedem Patch gleich), sonst linkwise (Abwanderung pro link gleich) { for(i=0; i<Y; i++) { gsl_vector_view colD = gsl_matrix_column(ADgsl, i); // Spalte i aus Migrationsmatrix colsum = gsl_blas_dasum(&colD.vector); if(colsum!=0) { for(j=0;j<Y;j++) gsl_matrix_set(ADgsl,j,i,(gsl_matrix_get(ADgsl,j,i)/colsum)); // ADgsl: D mit normierten Links } } } gsl_matrix_memcpy(Dmat, EDmat); // Dmat = D gsl_matrix_scale(Dmat, dij); // Dmat(i,j) = d(i,j) (Migrationsstärke) gsl_matrix_mul_elements(Dmat, ADgsl); // Dmat(i,j) = d(i,j)*xi(i,j) (skalierte und normierte Migrationsmatrix) gsl_vector_set_all(d1vec, 1/gsl_vector_get(Mvec, l)); // d1(i)= m(l)^0.25 gsl_vector_mul(d1vec, dyvec); // d1(i)= m(l)^0.25*y(i) gsl_blas_dgemv(CblasNoTrans, 1, Dmat, d1vec, 0, d2vec); // d2(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j) gsl_vector_set_all(d1vec, 1); // d1(i)= 1 gsl_blas_dgemv(CblasTrans, 1, Dmat, d1vec, 0, d3vec); // d3(i)= Sum_j d(i,j)*xi(i,j) gsl_vector_scale(d3vec, 1/gsl_vector_get(Mvec,l)); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25 gsl_vector_mul(d3vec, dyvec); // d3(i)= Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i) gsl_vector_add(ydottest,d2vec); gsl_vector_sub(ydottest,d3vec); //printf("d2vec ist %f\n",gsl_vector_get(d2vec,0)); //printf("d3vec ist %f\n",gsl_vector_get(d3vec,0)); //if(gsl_vector_get(ydottest,mu)!=0) //{ ydotmigr += gsl_vector_get(ydottest,nu); gsl_vector_set(nicheweb->migrPara,5,ydotmigr); //printf("ydotmigr ist %f\n",gsl_vector_get(nicheweb->migrPara,5)); // if(ydotmigr !=0) // { // printf("ydottest aufaddiert ist %f\n",ydotmigr); // printf("ydottest aufaddiert ist %f\n",gsl_vector_get(nicheweb->migrPara,5)); // } gsl_vector_add(dydotvec, d2vec); // gsl_vector_sub(dydotvec, d3vec); // Ergebnis in dydotvec (also ydot[]) = Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(j) - Sum_j d(i,j)*xi(i,j)*m(l)^0.25*y(i) } }// Patch i gewinnt das was aus allen j Patches zuwandert und verliert was von i auswandert //printf("ydot ist %f\n",gsl_vector_get(ydottest,0)); //printf("\ncheckpoint Holling2 V\n"); /* for(i=0; i<(Rnum+S)*Y; i++){ printf("\ny = %f\tydot=%f\n", y[i], ydot[i]); } */ //--check for fixed point attractor----------------------------------------------------------------------------------- if(t>7800){ gsl_vector_set(nicheweb->fixpunkte, 0, 0); gsl_vector_set(nicheweb->fixpunkte, 1, 0); gsl_vector_set(nicheweb->fixpunkte, 2, 0); int fix0 = (int)gsl_vector_get(nicheweb->fixpunkte, 0); int fix1 = (int)gsl_vector_get(nicheweb->fixpunkte, 1); int fix2 = (int)gsl_vector_get(nicheweb->fixpunkte, 2); //printf("t unten = %f\n", t); for(i=0; i<(Rnum+S)*Y; i++) { if(y[i] <= 0) { fix0++; fix1++; fix2++; } else { if((ydot[i]/y[i]<0.0001) || (ydot[i]<0.0001)) fix0++; if(ydot[i]/y[i]<0.0001) fix1++; if(ydot[i]<0.0001) fix2++; } } if(fix0==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 3, 1); if(fix1==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 4, 1); if(fix2==(Rnum+S)*Y) gsl_vector_set(nicheweb->fixpunkte, 5, 1); } //--Speicher leeren----------------------------------------------------------------------------------------------------- gsl_matrix_free(Emat); gsl_matrix_free(Dmat); gsl_matrix_free(AFgsl); gsl_matrix_free(ADgsl); gsl_vector_free(tvec); gsl_vector_free(rvec); gsl_vector_free(svec); gsl_vector_free(d1vec); gsl_vector_free(d2vec); gsl_vector_free(d3vec); gsl_vector_free(ydottest); // printf("\nCheckpoint Holling2 VI\n"); return GSL_SUCCESS; }
int func_all_ode(double t, const double x[], double f[], void *params) { struct_all_ode *s = (struct_all_ode *) params; struct_inputs_fly_dynamics *sif = &(s->inputs_fly_dynamics); struct_outputs_fly_dynamics *sof = &(s->outputs_fly_dynamics); struct_inputs_sol_dynamics *sis = &(s->inputs_sol_dynamics); struct_outputs_sol_dynamics *sos = &(s->outputs_sol_dynamics); struct_inputs_extremity_fly *sie = &(s->inputs_extremity_fly); struct_outputs_extremity_fly *soe = &(s->outputs_extremity_fly); struct_inputs_fly_trajectory *sift = &s->inputs_fly_trajectory; struct_outputs_fly_trajectory *soft = &s->outputs_fly_trajectory; struct_inputs_spring_force *sisf = &(s->inputs_spring_force); struct_outputs_spring_force *sosf = &(s->outputs_spring_force); double z_ext, dx_crossing_zero; int i = 0, i_f = 0, NQ; int s_LU; gsl_matrix_view mqq; gsl_vector_view H, RHS_EQU; gsl_vector *b, *d2qsurdt2; gsl_permutation * p; /* compute accelerations so.Mqq,so.H,so.RHS_EQU */ switch (s->mode) { case MODE_FLY: case MODE_SOL_TO_FLY: sif->ph = x[INDX_PH]; sie->th = sif->th = x[INDX_TH]; sie->x = sif->x = x[INDX_X]; sie->z = sif->z = x[INDX_Z]; sie->r = sif->r = x[INDX_R]; f[i_f++] = sif->vph = x[INDX_VPH]; f[i_f++] = sif->vth = x[INDX_VTH]; f[i_f++] = sif->vx = x[INDX_VX]; f[i_f++] = sif->vz = x[INDX_VZ]; f[i_f++] = sif->vr = x[INDX_VR]; fly_dynamics(sof, sif); NQ = sof->NQ; mqq = sci_2_gsl_db_matrix(sof->Mqq, NQ, NQ); // gsl_matrix_fprintf (stdout, &mqq.matrix, "%g"); H = sci_2_gsl_db_vector(sof->Hqvq, NQ); RHS_EQU = sci_2_gsl_db_vector(sof->RHS_EQU, NQ); break; case MODE_SOL: sisf->ph = sie->ph = sis->ph = x[INDX_PH]; sisf->th = sie->th = sis->th = x[INDX_TH]; sisf->x = sie->x = sis->x = x[INDX_X]; sisf->z = sie->z = sis->z = x[INDX_Z]; sisf->r = sie->r = sis->r = x[INDX_R]; f[i_f++] = sis->vph = x[INDX_VPH]; f[i_f++] = sis->vth = x[INDX_VTH]; f[i_f++] = sis->vx = x[INDX_VX]; f[i_f++] = sis->vz = x[INDX_VZ]; f[i_f++] = sis->vr = x[INDX_VR]; sol_dynamics(sos, sis); NQ = sos->NQ; mqq = sci_2_gsl_db_matrix(sos->Mqq, NQ, NQ); // gsl_matrix_fprintf (stdout, &mqq.matrix, "%g"); H = sci_2_gsl_db_vector(sos->Hqvq, NQ); RHS_EQU = sci_2_gsl_db_vector(sos->RHS_EQU, NQ); break; default: for (i = 0; i < s->NX; i++) { f[i] = 0; } return GSL_SUCCESS; } /* compute accelerations d2qsurdt2=Mqq^-1.[RHS_EQU-H] */ b = gsl_vector_alloc(NQ); gsl_vector_memcpy(b, &RHS_EQU.vector); gsl_vector_sub(b, &H.vector); d2qsurdt2 = gsl_vector_alloc(NQ); p = gsl_permutation_alloc(NQ); gsl_linalg_LU_decomp(&mqq.matrix, p, &s_LU); gsl_linalg_LU_solve(&mqq.matrix, p, b, d2qsurdt2); // gsl_vector_fprintf (stdout, d2qsurdt2, "%g"); for (i = 0; i < NQ; i++) { f[i_f++] = gsl_vector_get(d2qsurdt2, i); } gsl_permutation_free(p); gsl_vector_free(d2qsurdt2); gsl_vector_free(b); switch (s->mode) { case MODE_FLY: /* compute integral of extremity if near zero*/ extremity_fly(soe, sie); z_ext = soe->ext[2]; // correspond to y if ((z_ext>-s->eps_abs) && (z_ext < s->eps_abs)) { dx_crossing_zero = 0; if (sif->vz < 0) { s->mode = MODE_FLY_TO_SOL; return GSL_FAILURE; } } else { dx_crossing_zero = 1 / z_ext; } break; case MODE_SOL_TO_FLY: /* compute integral of extremity if near zero*/ dx_crossing_zero = 0; extremity_fly(soe, sie); z_ext = soe->ext[2]; // correspond to y if (z_ext > s->eps_abs) { s->mode = MODE_FLY; } break; case MODE_SOL: /* compute integral of extremity if near zero*/ //spring_force(sosf, sisf); z_ext = s->r0 - sis->r; // correspond to y component of force // z_ext=1; if ((z_ext>-s->eps_abs) && (z_ext < s->eps_abs)) { dx_crossing_zero = 0; if (sis->vr > 0) { s->mode = MODE_SOL_TO_FLY; return GSL_FAILURE; } } else { dx_crossing_zero = 1 / z_ext; } break; default:dx_crossing_zero = 0; } f[i_f++] = dx_crossing_zero; return GSL_SUCCESS; }
// Least-squares temporal difference (LSTD). // REF [paper] >> "Least-Squares Temporal Difference Learning", J. A. Boyan, ICML 1999. // REF [paper] >> "Linear Least-Squares Algorithms for Temporal Difference Learning", S. J. Bradtke and A. G. Barto , ML 1996. // REF [file] >> ${RLlib_HOME}/examples/example-002-001-boyan-lstd.cc. void boyan_chain_lstd_example() { local::Simulator simulator; local::TransitionSet transitions; int episode_length; local::Feature phi; gsl_vector* theta = gsl_vector_alloc(phi.dimension()); gsl_vector_set_zero(theta); gsl_vector* tmp = gsl_vector_alloc(phi.dimension()); gsl_vector_set_zero(tmp); auto v_parametrized = [&phi, tmp](const gsl_vector* th, local::State s) -> local::Reward { double res; phi(tmp, s); // phi_s = phi(s). gsl_blas_ddot(th, tmp, &res); // res = th^T . phi_s. return res; }; auto grad_v_parametrized = [&phi, tmp](const gsl_vector* th, gsl_vector* grad_th_s, local::State s) -> void { phi(tmp, s); // phi_s = phi(s). gsl_vector_memcpy(grad_th_s, tmp); // grad_th_s = phi_s. }; try { // Fill a set of transitions from successive episodes. for (int episode = 0; episode < local::NB_OF_EPISODES; ++episode) { simulator.initPhase(); rl::episode::run( simulator, [](local::State s) -> local::Action { return rl::problem::boyan_chain::actionNone; }, // This is the policy. std::back_inserter(transitions), [](local::State s, local::Action a, local::Reward r, local::State s_) -> local::Transition { return {s, r, s_,false}; }, [](local::State s, local::Action a, local::Reward r) -> local::Transition { return {s, r, s ,true}; }, 0 ); } // Apply LSTD to the transition database. rl::lstd( theta, local::paramGAMMA, local::paramREG, transitions.begin(), transitions.end(), grad_v_parametrized, [](const local::Transition& t) -> local::State { return t.s; }, [](const local::Transition& t) -> local::State { return t.s_; }, [](const local::Transition& t) -> local::Reward { return t.r; }, [](const local::Transition& t) -> bool { return t.is_terminal; } ); // Display the result. std::cout << std::endl << "LSTD estimation : (" << std::setw(15) << gsl_vector_get(theta, 0) << ',' << std::setw(15) << gsl_vector_get(theta, 1) << ',' << std::setw(15) << gsl_vector_get(theta, 2) << ',' << std::setw(15) << gsl_vector_get(theta, 3) << ')' << std::endl; //Learn the same by using TD. auto td = rl::gsl::td<local::State>( theta, local::paramGAMMA, local::paramALPHA, v_parametrized, grad_v_parametrized ); // The learning can be done offline since we have collected transitions. gsl_vector_set_zero(theta); for (auto& t : transitions) if (t.is_terminal) td.learn(t.s, t.r); else td.learn(t.s, t.r, t.s_); std::cout << "TD (offline) estimation : (" << std::setw(15) << gsl_vector_get(theta, 0) << ',' << std::setw(15) << gsl_vector_get(theta, 1) << ',' << std::setw(15) << gsl_vector_get(theta, 2) << ',' << std::setw(15) << gsl_vector_get(theta, 3) << ')' << std::endl; // But this can be done on-line, directly from episodes. gsl_vector_set_zero(theta); for (int episode = 0; episode < local::NB_OF_EPISODES; ++episode) { simulator.initPhase(); rl::episode::learn( simulator, [](local::State s) -> local::Action { return rl::problem::boyan_chain::actionNone; }, // This is the policy. td, 0 ); } std::cout << "TD (online) estimation : (" << std::setw(15) << gsl_vector_get(theta, 0) << ',' << std::setw(15) << gsl_vector_get(theta, 1) << ',' << std::setw(15) << gsl_vector_get(theta, 2) << ',' << std::setw(15) << gsl_vector_get(theta, 3) << ')' << std::endl; // With the boyan chain, the value function is known analytically. std::cout << "Optimal one should be : (" << std::setw(15) << -24 << ',' << std::setw(15) << -16 << ',' << std::setw(15) << -8 << ',' << std::setw(15) << 0 << ')' << std::endl; } catch (const rl::exception::Any& e) { std::cerr << "Exception caught : " << e.what() << std::endl; } gsl_vector_free(theta); gsl_vector_free(tmp); }
void Testrapt(CuTest* tc) { gsl_vector* x = gsl_vector_alloc(DIM); gsl_vector_set_all(x, 0.0); gsl_rng* rng = gsl_rng_alloc(gsl_rng_default); gsl_matrix* sigma_whole = gsl_matrix_alloc(DIM, DIM); gsl_matrix_set_identity(sigma_whole); gsl_matrix* sigma_local[K]; for(int k=0; k<K; k++) { sigma_local[k] = gsl_matrix_alloc(DIM, DIM); gsl_matrix_set_identity(sigma_local[k]); } double means[K]; double variances[K]; double nk[K]; for(int k=0; k<K; k++) { means[k] = 0.0; variances[k] = 0.0; nk[k] = 0.0; } double mean = 0.0; double variance = 0.0; mcmclib_amh* s = mcmclib_rapt_alloc(rng, dunif, NULL, /*target distrib.*/ x, T0, sigma_whole, K, sigma_local, which_region, NULL, NULL); rapt_suff* suff = (rapt_suff*) s->suff; /*Main MCMC loop*/ gsl_matrix* X = gsl_matrix_alloc(N, DIM); gsl_vector* which_region_n = gsl_vector_alloc(N); for(size_t n=0; n<N; n++) { mcmclib_amh_update(s); gsl_vector_view Xn = gsl_matrix_row(X, n); gsl_vector_memcpy(&(Xn.vector), x); gsl_vector_set(which_region_n, n, (double) which_region(NULL, x)); means[which_region(NULL, x)] += x0; variances[which_region(NULL, x)] += x0 * x0; nk[which_region(NULL, x)] += 1.0; mean += x0; variance += x0 * x0; } /*compute means and variances*/ mean /= (double) N; variance = variance / ((double) N) - (mean * mean); for(size_t k=0; k<K; k++) { means[k] /= nk[k]; variances[k] = (variances[k] / nk[k]) - (means[k] * means[k]); } /*check results*/ CuAssertDblEquals(tc, mean, v0(suff->global_mean), TOL); CuAssertDblEquals(tc, variance, m00(suff->global_variance), TOL); static char kmsg[3]; for(size_t k=0; k<K; k++) { sprintf(kmsg, "%zd", k); CuAssertDblEquals_Msg(tc, kmsg, nk[k], gsl_vector_get(suff->n, k), TOL); CuAssertDblEquals_Msg(tc, kmsg, means[k], v0(suff->means[k]), TOL); CuAssertDblEquals_Msg(tc, kmsg, variances[k], m00(suff->variances[k]), TOL); } /*free memory*/ gsl_matrix_free(X); for(int k=0; k<K; k++) gsl_matrix_free(sigma_local[k]); gsl_matrix_free(sigma_whole); gsl_vector_free(x); mcmclib_amh_free(s); gsl_rng_free(rng); gsl_vector_free(which_region_n); }
GSLVector::GSLVector(const GSLVector& v) { m_vector = gsl_vector_alloc(v.size()); gsl_vector_memcpy(m_vector, v.gsl()); }
void prep_a_copy(apop_data **cp, apop_data *prior_candidate){ if (!*cp) *cp = apop_data_copy(prior_candidate); else gsl_vector_memcpy((*cp)->weights, prior_candidate->weights); }
int gsl_linalg_hessenberg_decomp(gsl_matrix *A, gsl_vector *tau) { const size_t N = A->size1; if (N != A->size2) { GSL_ERROR ("Hessenberg reduction requires square matrix", GSL_ENOTSQR); } else if (N != tau->size) { GSL_ERROR ("tau vector must match matrix size", GSL_EBADLEN); } else if (N < 3) { /* nothing to do */ return GSL_SUCCESS; } else { size_t i; /* looping */ gsl_vector_view c, /* matrix column */ hv; /* householder vector */ gsl_matrix_view m; double tau_i; /* beta in algorithm 7.4.2 */ for (i = 0; i < N - 2; ++i) { /* * make a copy of A(i + 1:n, i) and store it in the section * of 'tau' that we haven't stored coefficients in yet */ c = gsl_matrix_subcolumn(A, i, i + 1, N - i - 1); hv = gsl_vector_subvector(tau, i + 1, N - (i + 1)); gsl_vector_memcpy(&hv.vector, &c.vector); /* compute householder transformation of A(i+1:n,i) */ tau_i = gsl_linalg_householder_transform(&hv.vector); /* apply left householder matrix (I - tau_i v v') to A */ m = gsl_matrix_submatrix(A, i + 1, i, N - (i + 1), N - i); gsl_linalg_householder_hm(tau_i, &hv.vector, &m.matrix); /* apply right householder matrix (I - tau_i v v') to A */ m = gsl_matrix_submatrix(A, 0, i + 1, N, N - (i + 1)); gsl_linalg_householder_mh(tau_i, &hv.vector, &m.matrix); /* save Householder coefficient */ gsl_vector_set(tau, i, tau_i); /* * store Householder vector below the subdiagonal in column * i of the matrix. hv(1) does not need to be stored since * it is always 1. */ c = gsl_vector_subvector(&c.vector, 1, c.vector.size - 1); hv = gsl_vector_subvector(&hv.vector, 1, hv.vector.size - 1); gsl_vector_memcpy(&c.vector, &hv.vector); } return GSL_SUCCESS; } } /* gsl_linalg_hessenberg_decomp() */
void updateR(gsl_matrix* R,double* factor,gsl_vector* p,gsl_vector* z, double* tau) { *factor = (*factor) / (1.0 - (*tau)); My_dscal(p,sqrt(GSL_MAX(*tau,- *tau)*(*factor))); My_dscal(z,sqrt(GSL_MAX(*tau,- *tau)*(*factor))); gsl_vector* w = gsl_vector_alloc(z->size); gsl_vector_memcpy(w, z); gsl_vector* s = gsl_vector_calloc(w->size+1); int n = w->size; gsl_vector_set(s, n-1, gsl_vector_get(p, n-1)*gsl_vector_get(p, n-1)); for (int i=n-2; i>=0; i--) { gsl_vector_set(s, i, gsl_vector_get(s, i+1)+gsl_vector_get(p, i)*gsl_vector_get(p, i)); } double a = 1.0; if (*tau < 0.0) { a = -1.0; } double sigma = a/(1.0+sqrt(1.0+a*gsl_vector_get(s, 0))); double q; double theta; double sigma1; double beta; double rho; gsl_vector* d2 = gsl_vector_alloc(n); gsl_vector_view d22 = gsl_matrix_diagonal(R); gsl_vector_memcpy(d2, &d22.vector); for (int j=0; j<n; j++) { q = gsl_pow_2(gsl_vector_get(p, j)); theta = 1.0 + sigma * q; gsl_vector_set(s, j+1, gsl_vector_get(s, j)-q); rho = sqrt(theta*theta+sigma*sigma*q*gsl_vector_get(s, j+1)); beta = a * gsl_vector_get(p, j) * gsl_matrix_get(R, j, j); gsl_matrix_set(R, j, j, rho * gsl_matrix_get(R, j, j)); beta = beta/gsl_matrix_get(R, j, j)/gsl_matrix_get(R, j, j); a = a / rho/rho; sigma1 = sigma* (1.0 + rho)/(rho*(theta + rho)); sigma = sigma1; //for (int r = j+1; r<n; r++) { // gsl_vector_set(w, r, gsl_vector_get(w, r)-gsl_vector_get(p, j)*gsl_matrix_get(R, r, j)); // gsl_matrix_set(R, r, j, gsl_matrix_get(R, r, j)/gsl_vector_get(d2, j)+beta*gsl_vector_get(w, r)); // gsl_matrix_set(R, r, j, gsl_matrix_get(R, r, j)*gsl_matrix_get(R, j, j)); //} if (j<n-1) { gsl_vector_view wr = gsl_vector_subvector(w, j+1, n-j-1); gsl_vector_view Rr = gsl_matrix_subcolumn(R, j, j+1, n-j-1); My_daxpy(&wr.vector, &Rr.vector, -gsl_vector_get(p, j)); My_dscal(&Rr.vector, 1.0/gsl_vector_get(d2, j)); My_daxpy(&Rr.vector, &wr.vector, beta); My_dscal(&Rr.vector, gsl_matrix_get(R, j, j)); } } //clean up gsl_vector_free(w); gsl_vector_free(s); gsl_vector_free(d2); }
static int gnewton_iterate (void * vstate, gsl_multiroot_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_matrix * J, gsl_vector * dx) { gnewton_state_t * state = (gnewton_state_t *) vstate; int signum ; double t, phi0, phi1; size_t i; size_t n = fdf->n ; gsl_matrix_memcpy (state->lu, J); gsl_linalg_LU_decomp (state->lu, state->permutation, &signum); gsl_linalg_LU_solve (state->lu, state->permutation, f, state->d); t = 1; phi0 = state->phi; new_step: for (i = 0; i < n; i++) { double di = gsl_vector_get (state->d, i); double xi = gsl_vector_get (x, i); gsl_vector_set (state->x_trial, i, xi - t*di); } { int status = GSL_MULTIROOT_FN_EVAL_F (fdf, state->x_trial, f); if (status != GSL_SUCCESS) { return GSL_EBADFUNC; } } phi1 = enorm (f); if (phi1 > phi0 && t > GSL_DBL_EPSILON) { /* full step goes uphill, take a reduced step instead */ double theta = phi1 / phi0; double u = (sqrt(1.0 + 6.0 * theta) - 1.0) / (3.0 * theta); t *= u ; goto new_step; } /* copy x_trial into x */ gsl_vector_memcpy (x, state->x_trial); for (i = 0; i < n; i++) { double di = gsl_vector_get (state->d, i); gsl_vector_set (dx, i, -t*di); } { int status = GSL_MULTIROOT_FN_EVAL_DF (fdf, x, J); if (status != GSL_SUCCESS) { return GSL_EBADFUNC; } } state->phi = phi1; return GSL_SUCCESS; }
void multimin(size_t n,double *x,double *fun, const unsigned *type, const double *xmin,const double *xmax, void (*f) (const size_t,const double *,void *,double *), void (* df) (const size_t,const double *, void *,double *), void (* fdf) (const size_t,const double *, void *,double *,double *), void *fparams, const struct multimin_params oparams) { unsigned iter=0; int status; size_t i; double dtmp1; const gsl_multimin_fdfminimizer_type *Tfdf; const gsl_multimin_fminimizer_type *Tf; const char *Tname; gsl_vector * y = gsl_vector_alloc (n); /* set the algorithm */ switch(oparams.method){ case 0:/* Fletcher-Reeves conjugate gradient */ Tfdf = gsl_multimin_fdfminimizer_conjugate_fr; Tname = Tfdf->name; break; case 1:/* Polak-Ribiere conjugate gradient */ Tfdf = gsl_multimin_fdfminimizer_conjugate_pr; Tname = Tfdf->name; break; case 2:/* Vector Broyden-Fletcher-Goldfarb-Shanno method */ Tfdf = gsl_multimin_fdfminimizer_vector_bfgs; Tname = Tfdf->name; break; case 3:/* Steepest descent algorithm */ Tfdf =gsl_multimin_fdfminimizer_steepest_descent; Tname = Tfdf->name; break; case 4:/* Simplex */ Tf = gsl_multimin_fminimizer_nmsimplex2; Tname = Tf->name; break; case 5:/* Vector Broyden-Fletcher-Goldfarb-Shanno2 method */ Tfdf = gsl_multimin_fdfminimizer_vector_bfgs2; Tname = Tfdf->name; break; default: fprintf(stderr,"Optimization method not recognized. Try -h\n"); exit(EXIT_FAILURE); } /* --- OUPUT ---------------------------------- */ if(oparams.verbosity>0){ fprintf(stderr,"#--- MULTIMIN START\n"); fprintf(stderr,"# method %s\n",Tname); if(oparams.method<4 || oparams.method==5){ fprintf(stderr,"# initial step size %g\n", oparams.step_size); fprintf(stderr,"# line minimization tolerance %g\n",oparams.tol); fprintf(stderr,"# maximum number of iterations %u\n",oparams.maxiter); fprintf(stderr,"# precision %g\n",oparams.epsabs); } else{ fprintf(stderr,"# maximum number of iterations %u\n",oparams.maxiter); fprintf(stderr,"# maximum simplex size %g\n",oparams.maxsize); } } /* -------------------------------------------- */ /* compute values of y for initial condition */ for(i=0;i<n;i++){ if(type==NULL) SET(y,i,x[i]); else switch(type[i]){ case 0:/* (-inf,+inf) */ SET(y,i,x[i]); break; case 1:/* [a,+inf) */ SET(y,i,sqrt( x[i]-xmin[i] )); break; case 2:/* (-inf,a] */ SET(y,i,sqrt( xmax[i]-x[i] )); break; case 3:/* [a,b] */ dtmp1 = (xmax[i]>xmin[i]? (2.*x[i]-xmax[i]-xmin[i])/(xmax[i]-xmin[i]) : 0); /* dtmp1 = (2.*x[i]-xmax[i]-xmin[i])/(xmax[i]-xmin[i]); */ SET(y,i,asin( dtmp1 )); break; case 4:/* (a,+inf) */ SET(y,i,log( x[i]-xmin[i] )); break; case 5:/* (-inf,a) */ SET(y,i,log( xmax[i]-x[i] )); break; case 6:/* (a,b) */ dtmp1 = (2.*x[i]-xmax[i]-xmin[i])/(xmax[i]-xmin[i]); SET(y,i,gsl_atanh ( dtmp1 )); break; case 7:/* (a,b) second approach */ dtmp1 = (2.*x[i]-xmax[i]-xmin[i])/(xmax[i]-xmin[i]); SET(y,i, dtmp1/sqrt(1-dtmp1*dtmp1)); break; case 8:/* (a,+inf) second approach */ dtmp1 = x[i]-xmin[i]; SET(y,i, dtmp1-1./(4.*dtmp1)); break; } } /* --- OUPUT ---------------------------------- */ if(oparams.verbosity>1){ fprintf(stderr,"# - variables initial value and boundaries\n"); for(i=0;i<n;i++){ if(type==NULL) fprintf(stderr,"# x[%d]=%e (-inf,+inf) -> %e\n",(int) i,x[i],GET(y,i)); else switch(type[i]){ case 0:/* (-inf,+inf) */ fprintf(stderr,"# x[%d]=%e (-inf,+inf) -> %e\n",(int) i,x[i],GET(y,i)); break; case 1:/* [a,+inf) */ fprintf(stderr,"# x[%d]=%e [%g,+inf) -> %e\n",(int) i,x[i],xmin[i],GET(y,i)); break; case 2:/* (-inf,a] */ fprintf(stderr,"# x[%d]=%e (-inf,%g] -> %e\n",(int) i,x[i],xmax[i],GET(y,i)); break; case 3:/* [a,b] */ fprintf(stderr,"# x[%d]=%e [%g,%g] -> %e\n",(int) i,x[i],xmin[i],xmax[i],GET(y,i)); break; case 4:/* (a,+inf) */ fprintf(stderr,"# x[%d]=%e (%g,+inf) -> %e\n",(int) i,x[i],xmin[i],GET(y,i)); break; case 5:/* (-inf,a) */ fprintf(stderr,"# x[%d]=%e (-inf,%g) -> %e\n",(int) i,x[i],xmax[i],GET(y,i)); break; case 6:/* (a,b) */ case 7: fprintf(stderr,"# x[%d]=%e (%g,%g) -> %e\n",(int) i,x[i],xmin[i],xmax[i],GET(y,i)); break; case 8:/* [a,+inf) */ fprintf(stderr,"# x[%d]=%e (%g,+inf) -> %e\n",(int) i,x[i],xmin[i],GET(y,i)); break; } } { double res; fprintf(stderr,"# - function initial value\n"); f(n,x,fparams,&res); fprintf(stderr,"# f=%e\n",res); } } /* -------------------------------------------- */ if(oparams.method<4 || oparams.method==5){/* methods with derivatives */ struct g_params gparams; gsl_multimin_function_fdf GdG; gsl_multimin_fdfminimizer *s = gsl_multimin_fdfminimizer_alloc (Tfdf,n); /* set the parameters of the new function */ gparams.n = n; gparams.type = type; gparams.xmin = xmin; gparams.xmax = xmax; gparams.f = f; gparams.df = df; gparams.fdf = fdf; gparams.fparams = fparams; /* set the function to solve */ GdG.f=g; GdG.df=dg; GdG.fdf=gdg; GdG.n=n; GdG.params=(void *) &gparams; /* initialize minimizer */ status=gsl_multimin_fdfminimizer_set(s,&GdG,y,oparams.step_size,oparams.tol); if(status) { fprintf(stderr,"#ERROR: %s\n",gsl_strerror (status)); exit(EXIT_FAILURE); } /* +++++++++++++++++++++++++++++++++++++++++++++++ */ if(oparams.verbosity>2) fprintf(stderr,"# - start minimization \n"); /* +++++++++++++++++++++++++++++++++++++++++++++++ */ do { iter++; status = gsl_multimin_fdfminimizer_iterate (s); /* +++++++++++++++++++++++++++++++++++++++++++++++ */ if(oparams.verbosity>2){ fprintf(stderr,"# [%d]",iter); fprintf(stderr," g=%+12.6e y=( ",s->f); for(i=0;i<n;i++) fprintf(stderr,"%+12.6e ",GET(s->x,i)); fprintf(stderr,") dg=( "); for(i=0;i<n;i++) fprintf(stderr,"%+12.6e ",GET(s->gradient,i)); fprintf(stderr,") |dg|=%12.6e ",gsl_blas_dnrm2 (s->gradient)); fprintf(stderr,"|dx|=%12.6e\n",gsl_blas_dnrm2 (s->dx)); } /* +++++++++++++++++++++++++++++++++++++++++++++++ */ if(status == GSL_ENOPROG){ fprintf(stderr,"# status: %s\n",gsl_strerror (status)); break; } if(status){ fprintf(stderr,"#WARNING: %s\n", gsl_strerror (status)); break; } /* { */ /* const double eps = oparams.epsabs; */ /* const double norm_x = gsl_blas_dnrm2 (s->x); */ /* const double norm_dx = gsl_blas_dnrm2 (s->dx); */ /* const double norm_g = gsl_blas_dnrm2 (s->gradient); */ /* if( norm_dx < eps && norm_dx < norm_x*eps && norm_g < eps ) */ /* status = GSL_SUCCESS; */ /* else */ /* status = GSL_CONTINUE; */ /* fprintf(stderr,"|x|=%f |dx|=%f |dg|=%f\n",norm_x,norm_dx,norm_g); */ /* } */ status = gsl_multimin_test_gradient (s->gradient,oparams.epsabs); } while (status == GSL_CONTINUE && iter < oparams.maxiter); gsl_vector_memcpy (y,s->x); *fun=s->f; gsl_multimin_fdfminimizer_free (s); } else{ /* methods without derivatives */ gsl_vector *ss = gsl_vector_alloc (n); struct g_params gparams; gsl_multimin_function G; gsl_multimin_fminimizer *s=gsl_multimin_fminimizer_alloc (Tf,n); /* set the parameters of the new function */ gparams.n = n; gparams.type = type; gparams.xmin = xmin; gparams.xmax = xmax; gparams.f = f; gparams.fparams = fparams; /* set the function to solve */ G.f=g; G.n=n; G.params=(void *) &gparams; /* Initial vertex size vector */ { /* size_t i; */ /* dg(y,&gparams,ss); */ /* gsl_vector_set_all (ss,1); */ /* for(i=0;i<n;i++) */ /* SET(ss,i,fabs(GET(ss,i))); */ /* gsl_vector_add_constant (ss,oparams.maxsize); */ gsl_vector_set_all (ss,oparams.step_size+oparams.maxsize); } /* --- OUPUT ---------------------------------- */ if(oparams.verbosity>0){ size_t i; fprintf(stderr,"# initial simplex sizes\n"); fprintf(stderr,"# "); for(i=0;i<n;i++) fprintf(stderr," %g", GET(ss,i)); fprintf(stderr,"\n"); } /* -------------------------------------------- */ /* Initialize minimizer */ status=gsl_multimin_fminimizer_set(s,&G,y,ss); do { status = gsl_multimin_fminimizer_iterate(s); const double size = gsl_multimin_fminimizer_size (s); iter++; /* +++++++++++++++++++++++++++++++++++++++++++++++ */ if(oparams.verbosity>2){ fprintf(stderr,"# g=%g y=( ",s->fval); for(i=0;i<n;i++) fprintf(stderr,"%g ",GET(s->x,i)); fprintf(stderr,") "); fprintf(stderr," simplex size=%g ",size); fprintf(stderr,"\n"); } /* +++++++++++++++++++++++++++++++++++++++++++++++ */ status=gsl_multimin_test_size (size,oparams.maxsize); } while (status == GSL_CONTINUE && iter < oparams.maxiter); gsl_vector_memcpy (y, s->x); *fun=s->fval; gsl_multimin_fminimizer_free (s); gsl_vector_free(ss); } /* compute values of x */ for(i=0;i<n;i++){ if(type==NULL) /* (-inf,+inf) */ x[i]=GET(y,i); else switch(type[i]){ case 0:/* (-inf,+inf) */ x[i]=GET(y,i); break; case 1:/* [a,+inf) */ x[i]=xmin[i]+GET(y,i)*GET(y,i); break; case 2:/* (-inf,a] */ x[i]=xmax[i]-GET(y,i)*GET(y,i); break; case 3:/* [a,b] */ dtmp1 = sin( GET(y,i) ); x[i]=.5*(xmin[i]*(1-dtmp1) +xmax[i]*(1+dtmp1)); break; case 4:/* (a,+inf) */ dtmp1 = exp( GET(y,i) ); x[i]=xmin[i]+dtmp1; break; case 5:/* (-inf,a) */ dtmp1 = -exp( GET(y,i) ); x[i]=xmax[i]+dtmp1; break; case 6:/* (a,b) */ dtmp1 = tanh( GET(y,i) ); x[i]=.5*(xmin[i]*(1-dtmp1) +xmax[i]*(1+dtmp1)); break; case 7:/* (a,b) second approach */ dtmp1 = GET(y,i) ; dtmp1 = dtmp1/sqrt(1.+dtmp1*dtmp1); x[i]=.5*(xmin[i]*(1-dtmp1) +xmax[i]*(1+dtmp1)); break; case 8:/* (a,+inf) second approach */ dtmp1 = sqrt(1.+GET(y,i)*GET(y,i)); x[i]= xmin[i] + .5*(dtmp1+GET(y,i)); break; } } /* --- OUPUT ---------------------------------- */ if(oparams.verbosity>0){ fprintf(stderr,"# - end minimization\n"); fprintf(stderr,"# iterations %u\n",iter); for(i=0;i<n;i++) fprintf(stderr,"# %e -> x[%zd]=%e\n",GET(y,i),i,x[i]); fprintf(stderr,"#--- MULTIMIN END --- \n"); } /* -------------------------------------------- */ gsl_vector_free (y); }
static int vector_bfgs_iterate (void *vstate, gsl_multimin_function_fdf * fdf, gsl_vector * x, double *f, gsl_vector * gradient, gsl_vector * dx) { vector_bfgs_state_t *state = (vector_bfgs_state_t *) vstate; gsl_vector *x1 = state->x1; gsl_vector *dx1 = state->dx1; gsl_vector *x2 = state->x2; gsl_vector *p = state->p; gsl_vector *g0 = state->g0; gsl_vector *x0 = state->x0; double pnorm = state->pnorm; double g0norm = state->g0norm; double fa = *f, fb, fc; double dir; double stepa = 0.0, stepb, stepc = state->step, tol = state->tol; double g1norm; double pg; if (pnorm == 0.0 || g0norm == 0.0) { gsl_vector_set_zero (dx); return GSL_ENOPROG; } /* Determine which direction is downhill, +p or -p */ gsl_blas_ddot (p, gradient, &pg); dir = (pg >= 0.0) ? +1.0 : -1.0; /* Compute new trial point at x_c= x - step * p, where p is the current direction */ take_step (x, p, stepc, dir / pnorm, x1, dx); /* Evaluate function and gradient at new point xc */ fc = GSL_MULTIMIN_FN_EVAL_F (fdf, x1); if (fc < fa) { /* Success, reduced the function value */ state->step = stepc * 2.0; *f = fc; gsl_vector_memcpy (x, x1); GSL_MULTIMIN_FN_EVAL_DF (fdf, x1, gradient); return GSL_SUCCESS; } #ifdef DEBUG printf ("got stepc = %g fc = %g\n", stepc, fc); #endif /* Do a line minimisation in the region (xa,fa) (xc,fc) to find an intermediate (xb,fb) satisifying fa > fb < fc. Choose an initial xb based on parabolic interpolation */ intermediate_point (fdf, x, p, dir / pnorm, pg, stepa, stepc, fa, fc, x1, dx1, gradient, &stepb, &fb); if (stepb == 0.0) { return GSL_ENOPROG; } minimize (fdf, x, p, dir / pnorm, stepa, stepb, stepc, fa, fb, fc, tol, x1, dx1, x2, dx, gradient, &(state->step), f, &g1norm); gsl_vector_memcpy (x, x2); /* Choose a new conjugate direction for the next step */ state->iter = (state->iter + 1) % x->size; if (state->iter == 0) { gsl_vector_memcpy (p, gradient); state->pnorm = g1norm; } else { /* This is the BFGS update: */ /* p' = g1 - A dx - B dg */ /* A = - (1+ dg.dg/dx.dg) B + dg.g/dx.dg */ /* B = dx.g/dx.dg */ gsl_vector *dx0 = state->dx0; gsl_vector *dg0 = state->dg0; double dxg, dgg, dxdg, dgnorm, A, B; /* dx0 = x - x0 */ gsl_vector_memcpy (dx0, x); gsl_blas_daxpy (-1.0, x0, dx0); /* dg0 = g - g0 */ gsl_vector_memcpy (dg0, gradient); gsl_blas_daxpy (-1.0, g0, dg0); gsl_blas_ddot (dx0, gradient, &dxg); gsl_blas_ddot (dg0, gradient, &dgg); gsl_blas_ddot (dx0, dg0, &dxdg); dgnorm = gsl_blas_dnrm2 (dg0); if (dxdg != 0) { B = dxg / dxdg; A = -(1.0 + dgnorm * dgnorm / dxdg) * B + dgg / dxdg; } else { B = 0; A = 0; } gsl_vector_memcpy (p, gradient); gsl_blas_daxpy (-A, dx0, p); gsl_blas_daxpy (-B, dg0, p); state->pnorm = gsl_blas_dnrm2 (p); } gsl_vector_memcpy (g0, gradient); gsl_vector_memcpy (x0, x); state->g0norm = gsl_blas_dnrm2 (g0); #ifdef DEBUG printf ("updated conjugate directions\n"); printf ("p: "); gsl_vector_fprintf (stdout, p, "%g"); printf ("g: "); gsl_vector_fprintf (stdout, gradient, "%g"); #endif return GSL_SUCCESS; }
int gsl_eigen_symm (gsl_matrix * A, gsl_vector * eval, gsl_eigen_symm_workspace * w) { if (A->size1 != A->size2) { GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR); } else if (eval->size != A->size1) { GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN); } else { const size_t N = A->size1; double *const d = w->d; double *const sd = w->sd; size_t a, b; /* handle special case */ if (N == 1) { double A00 = gsl_matrix_get (A, 0, 0); gsl_vector_set (eval, 0, A00); return GSL_SUCCESS; } /* use sd as the temporary workspace for the decomposition, since we can discard the tau result immediately if we are not computing eigenvectors */ { gsl_vector_view d_vec = gsl_vector_view_array (d, N); gsl_vector_view sd_vec = gsl_vector_view_array (sd, N - 1); gsl_vector_view tau = gsl_vector_view_array (sd, N - 1); gsl_linalg_symmtd_decomp (A, &tau.vector); gsl_linalg_symmtd_unpack_T (A, &d_vec.vector, &sd_vec.vector); } /* Make an initial pass through the tridiagonal decomposition to remove off-diagonal elements which are effectively zero */ chop_small_elements (N, d, sd); /* Progressively reduce the matrix until it is diagonal */ b = N - 1; while (b > 0) { if (sd[b - 1] == 0.0 || isnan(sd[b - 1])) { b--; continue; } /* Find the largest unreduced block (a,b) starting from b and working backwards */ a = b - 1; while (a > 0) { if (sd[a - 1] == 0.0) { break; } a--; } { const size_t n_block = b - a + 1; double *d_block = d + a; double *sd_block = sd + a; /* apply QR reduction with implicit deflation to the unreduced block */ qrstep (n_block, d_block, sd_block, NULL, NULL); /* remove any small off-diagonal elements */ chop_small_elements (n_block, d_block, sd_block); } } { gsl_vector_view d_vec = gsl_vector_view_array (d, N); gsl_vector_memcpy (eval, &d_vec.vector); } return GSL_SUCCESS; } }
static int test_shaw_system(gsl_rng *rng_p, const size_t n, const size_t p, const double lambda_expected, gsl_vector *rhs) { const size_t npoints = 1000; /* number of points on L-curve */ const double tol1 = 1.0e-12; const double tol2 = 1.0e-10; const double tol3 = 1.0e-5; gsl_vector * reg_param = gsl_vector_alloc(npoints); gsl_vector * rho = gsl_vector_alloc(npoints); gsl_vector * eta = gsl_vector_alloc(npoints); gsl_matrix * X = gsl_matrix_alloc(n, p); gsl_matrix * cov = gsl_matrix_alloc(p, p); gsl_vector * c = gsl_vector_alloc(p); gsl_vector * ytmp = gsl_vector_alloc(n); gsl_vector * y; gsl_vector * r = gsl_vector_alloc(n); gsl_multifit_linear_workspace * work = gsl_multifit_linear_alloc (n, p); size_t reg_idx, i; double lambda, rnorm, snorm; /* build design matrix */ shaw_system(X, ytmp); if (rhs) y = rhs; else { y = ytmp; /* add random noise to exact rhs vector */ test_random_vector_noise(rng_p, y); } /* SVD decomposition */ gsl_multifit_linear_svd(X, work); /* calculate L-curve */ gsl_multifit_linear_lcurve(y, reg_param, rho, eta, work); /* test rho and eta vectors */ for (i = 0; i < npoints; ++i) { double rhoi = gsl_vector_get(rho, i); double etai = gsl_vector_get(eta, i); double lami = gsl_vector_get(reg_param, i); /* solve regularized system and check for consistent rho/eta values */ gsl_multifit_linear_solve(lami, X, y, c, &rnorm, &snorm, work); gsl_test_rel(rhoi, rnorm, tol3, "shaw rho n="F_ZU" p="F_ZU" lambda=%e", n, p, lami); gsl_test_rel(etai, snorm, tol1, "shaw eta n="F_ZU" p="F_ZU" lambda=%e", n, p, lami); } /* calculate corner of L-curve */ gsl_multifit_linear_lcorner(rho, eta, ®_idx); lambda = gsl_vector_get(reg_param, reg_idx); /* test against known lambda value if given */ if (lambda_expected > 0.0) { gsl_test_rel(lambda, lambda_expected, tol1, "shaw: n="F_ZU" p="F_ZU" L-curve corner lambda", n, p); } /* compute regularized solution with optimal lambda */ gsl_multifit_linear_solve(lambda, X, y, c, &rnorm, &snorm, work); /* compute residual norm ||y - X c|| */ gsl_vector_memcpy(r, y); gsl_blas_dgemv(CblasNoTrans, 1.0, X, c, -1.0, r); /* test rnorm value */ gsl_test_rel(rnorm, gsl_blas_dnrm2(r), tol2, "shaw: n="F_ZU" p="F_ZU" rnorm", n, p); /* test snorm value */ gsl_test_rel(snorm, gsl_blas_dnrm2(c), tol2, "shaw: n="F_ZU" p="F_ZU" snorm", n, p); gsl_matrix_free(X); gsl_matrix_free(cov); gsl_vector_free(reg_param); gsl_vector_free(rho); gsl_vector_free(eta); gsl_vector_free(r); gsl_vector_free(c); gsl_vector_free(ytmp); gsl_multifit_linear_free(work); return 0; } /* test_shaw_system() */
int main( int argc, char * argv[] ) { Libnucnet__Net * p_net; Libnucnet__Species * p_species; size_t i, i_size_old, i_size_new; std::string line, name, source; std::ifstream infile; unsigned int i_z, i_a; double d_j0, d_tmp; gsl_vector * p_t9_old, * p_log10_partf_old; gsl_vector * p_t9_new, * p_log10_partf_new; gsl_vector * p_t9_update, * p_log10_partf_update; gsl_vector_view view; double d_t9[] = { 12., 14., 16., 18., 20., 22., 24., 26., 28., 30., 35., 40., 45., 50., 55., 60., 65., 70., 75., 80., 85., 90., 95.,100., 105.,110.,115.,120.,125.,130.,135.,140.,145.,150.,155.,160., 165.,170.,175.,180.,190.,200.,210.,220.,230.,240.,250.,275. }; //============================================================================ // Check input. //============================================================================ check_input( argc, argv ); //============================================================================ // Read and store input. //============================================================================ p_net = Libnucnet__Net__new_from_xml( argv[1], NULL, NULL ); p_t9_new = gsl_vector_alloc( I_RAUSCHER ); p_t9_new->data = d_t9; p_log10_partf_new = gsl_vector_alloc( I_RAUSCHER ); //============================================================================ // Open input partf file. //============================================================================ infile.open( argv[2] ); //============================================================================ // Skip information lines. //============================================================================ for( i = 0; i < 63; i++ ) std::getline( infile, line, '\n' ); //============================================================================ // Loop over lines to end. //============================================================================ while( infile >> name >> i_z >> i_a >> d_j0 ) { for( i = 0; i < 48; i++ ) { infile >> d_tmp; gsl_vector_set( p_log10_partf_new, i, log10( d_tmp ) ); } p_species = Libnucnet__Nuc__getSpeciesByName( Libnucnet__Net__getNuc( p_net ), name.c_str() ); if( p_species ) { p_t9_old = Libnucnet__Species__getPartitionFunctionT9( p_species ); p_log10_partf_old = Libnucnet__Species__getPartitionFunctionLog10( p_species ); if( p_t9_old && p_log10_partf_old ) { i_size_old = WnMatrix__get_gsl_vector_size( p_t9_old ); i_size_new = i_size_old + I_RAUSCHER; p_t9_update = gsl_vector_alloc( i_size_new ); p_log10_partf_update = gsl_vector_alloc( i_size_new ); view = gsl_vector_subvector( p_t9_update, 0, i_size_old ); gsl_vector_memcpy( &view.vector, p_t9_old ); view = gsl_vector_subvector( p_t9_update, i_size_old, I_RAUSCHER ); gsl_vector_memcpy( &view.vector, p_t9_new ); view = gsl_vector_subvector( p_log10_partf_update, 0, i_size_old ); gsl_vector_memcpy( &view.vector, p_log10_partf_old ); view = gsl_vector_subvector( p_log10_partf_update, i_size_old, I_RAUSCHER ); gsl_vector_memcpy( &view.vector, p_log10_partf_new ); Libnucnet__Species__updatePartitionFunctionData( p_species, p_t9_update, p_log10_partf_update ); gsl_vector_free( p_t9_update ); gsl_vector_free( p_log10_partf_update ); } else { Libnucnet__Species__updatePartitionFunctionData( p_species, p_t9_new, p_log10_partf_new ); } source = std::string( Libnucnet__Species__getSource( p_species ) ); source += " + Rauscher high-temperature partition function data"; Libnucnet__Species__updateSource( p_species, source.c_str() ); } } //============================================================================ // Write to output. //============================================================================ Libnucnet__Net__writeToXmlFile( p_net, argv[3] ); //============================================================================ // Clean up and exit. //============================================================================ infile.close(); gsl_vector_free( p_t9_new ); gsl_vector_free( p_log10_partf_new ); Libnucnet__Net__free( p_net ); return EXIT_SUCCESS; }