示例#1
0
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;
    //}

}
示例#2
0
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;
}
示例#3
0
// 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;

}
示例#4
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;
}
示例#5
0
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;
}
示例#8
0
/* 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;
}
示例#9
0
文件: rvine.c 项目: yasserglez/dml
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);
}
示例#10
0
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;
}
示例#11
0
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;
}
示例#12
0
/** **************************************************************************************************************/
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 */
}
示例#13
0
/** *************************************************************************************
*****************************************************************************************
*****************************************************************************************/          
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);
      
  
  
} 
示例#14
0
/** *******************************************************************************************************************************************/
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;
}   
示例#15
0
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;

}
示例#18
0
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);
}
示例#20
0
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);
}
示例#21
0
 GSLVector::GSLVector(const GSLVector& v)
 {
   m_vector = gsl_vector_alloc(v.size());
   gsl_vector_memcpy(m_vector, v.gsl());
 }
示例#22
0
文件: em_weight.c 项目: b-k/tea
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);
}
示例#23
0
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);

}
示例#25
0
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;
}
示例#26
0
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);

}
示例#27
0
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;
}
示例#28
0
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;
    }
}
示例#29
0
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, &reg_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() */
示例#30
0
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;

}