#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <string.h>

#include <gsl/gsl_errno.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_integration.h>
#include <gsl/gsl_const_mksa.h>
#include <gsl/gsl_roots.h>

#include "ccl.h"

// Global variable to hold the neutrino phase-space spline
gsl_spline* nu_spline = NULL;

// these are NOT adjustable
// this phase space integral is only done once and the following is accurate
// enough according to tests done by the devs
/**
 * Absolute precision in neutrino root finding
 */
#define GSL_EPSABS_NU 1E-7

/**
 * Relative precision in neutrino root finding
 */
#define GSL_EPSREL_NU 1E-7

/**
 * Number of iterations for neutrino root finding
 */
#define GSL_N_ITERATION_NU 1000

/* ------- ROUTINE: nu_integrand ------
INPUTS: x: dimensionless momentum, *r: pointer to a dimensionless mass / temperature
TASK: Integrand of phase-space massive neutrino integral
*/
static double nu_integrand(double x, void *r) {
  double rat = *((double*)(r));
  double x2 = x*x;
  return sqrt(x2 + rat*rat) / (exp(x)+1.0) * x2;
}

/* ------- ROUTINE: ccl_calculate_nu_phasespace_spline ------
TASK: Get the spline of the result of the phase-space integral required for massive neutrinos.
*/

gsl_spline* calculate_nu_phasespace_spline(int *status) {
  int N = CCL_NU_MNUT_N;
  double *mnut = NULL;
  double *y = NULL;
  gsl_spline* spl = NULL;
  gsl_integration_cquad_workspace * workspace = NULL;
  int stat = 0, gslstatus;
  gsl_function F;

  mnut = ccl_linear_spacing(log(CCL_NU_MNUT_MIN), log(CCL_NU_MNUT_MAX), N);
  y = malloc(sizeof(double)*CCL_NU_MNUT_N);
  if ((y == NULL) || (mnut == NULL)) {
    // Not setting a status_message here because we can't easily pass a
    // cosmology to this function - message printed in ccl_error.c.
    *status = CCL_ERROR_NU_INT;
  }

  if (*status == 0) {
    workspace = gsl_integration_cquad_workspace_alloc(GSL_N_ITERATION_NU);
    if (workspace == NULL)
      *status = CCL_ERROR_NU_INT;
  }

  if (*status == 0) {
    F.function = &nu_integrand;
    for (int i=0; i < CCL_NU_MNUT_N; i++) {
      double mnut_ = exp(mnut[i]);
      F.params = &(mnut_);
      gslstatus = gsl_integration_cquad(&F, 0, 1000.0,
                                        GSL_EPSABS_NU,
                                        GSL_EPSREL_NU,
                                        workspace, &y[i], NULL, NULL);
      if (gslstatus != GSL_SUCCESS) {
        ccl_raise_gsl_warning(gslstatus, "ccl_neutrinos.c: calculate_nu_phasespace_spline():");
        stat |= gslstatus;
      }
    }

    double renorm = 1./y[0];
    for (int i=0; i < CCL_NU_MNUT_N; i++)
      y[i] *= renorm;

    if (stat) {
      *status = CCL_ERROR_NU_INT;
    }
  }

  if (*status == 0) {
    spl = gsl_spline_alloc(gsl_interp_akima, CCL_NU_MNUT_N);
    if (spl == NULL)
      *status = CCL_ERROR_NU_INT;
  }

  if (*status == 0) {
    stat |= gsl_spline_init(spl, mnut, y, CCL_NU_MNUT_N);
    if (stat) {
      ccl_raise_gsl_warning(gslstatus, "ccl_neutrinos.c: calculate_nu_phasespace_spline():");
      *status = CCL_ERROR_NU_INT;
    }
  }

  // Check for errors in creating the spline
  if (stat || (*status)) {
    // Not setting a status_message here because we can't easily pass a
    // cosmology to this function - message printed in ccl_error.c.
    *status = CCL_ERROR_NU_INT;
    gsl_spline_free(spl);
  }

  gsl_integration_cquad_workspace_free(workspace);
  free(mnut);
  free(y);

  return spl;
}

/* ------- ROUTINE: ccl_nu_phasespace_intg ------
INPUTS: mnuOT: the dimensionless mass / temperature of a single massive neutrino
TASK: Get the value of the phase space integral at mnuOT
*/
double nu_phasespace_intg(double mnuOT, int* status)
{
  // Check if the global variable for the phasespace spline has been defined yet:
  if (nu_spline == NULL)
    nu_spline = calculate_nu_phasespace_spline(status);

  if (*status) {
    return NAN;
  }

  double integral_value = 0.;

  // First check the cases where we are in the limits.
  if (mnuOT < CCL_NU_MNUT_MIN)
    return 7./8.;
  else if (mnuOT > CCL_NU_MNUT_MAX)
    return 0.2776566337 * mnuOT;

  int gslstatus = gsl_spline_eval_e(nu_spline, log(mnuOT), NULL, &integral_value);
  if (gslstatus != GSL_SUCCESS) {
    ccl_raise_gsl_warning(gslstatus, "ccl_neutrinos.c: nu_phasespace_intg():");
    *status |= gslstatus;
  }
  return integral_value * 7./8.;
}

/* -------- ROUTINE: Omeganuh2 ---------
INPUTS: a: scale factor, Nnumass: number of massive neutrino species,
        mnu: total mass in eV of neutrinos, T_CMB: CMB temperature, status: pointer to status integer.
TASK: Compute Omeganu * h^2 as a function of time.
!! To all practical purposes, Neff is simply N_nu_mass !!
*/
double ccl_Omeganuh2 (double a, int N_nu_mass, double* mnu, double T_CMB, int* status) {
  double Tnu, a4, prefix_massless, mnuone, OmNuh2;
  double Tnu_eff, mnuOT, intval, prefix_massive;
  double total_mass; // To check if this is the massless or massive case.

  // First check if N_nu_mass is 0
  if (N_nu_mass == 0) return 0.0;

  Tnu = T_CMB*pow(4./11.,1./3.);
  a4 = a*a*a*a;
  // Check if mnu=0. We assume that in the massless case mnu is a
  // pointer to a single element and that element is 0. This should in principle never be called.
  if (mnu[0] < 0.00017) {  // Limit taken from Lesgourges et al. 2012
    prefix_massless = NU_CONST  * Tnu * Tnu * Tnu * Tnu;
    return N_nu_mass*prefix_massless*7./8./a4;
  }

  // And the remaining massive case.
  // Tnu_eff is used in the massive case because CLASS uses an effective
  // temperature of nonLCDM components to match to mnu / Omeganu =93.14eV. Tnu_eff = T_ncdm * T_CMB = 0.71611 * T_CMB
  Tnu_eff = Tnu * ccl_constants.TNCDM / (pow(4./11.,1./3.));

  // Define the prefix using the effective temperature (to get mnu / Omega = 93.14 eV) for the massive case:
  prefix_massive = NU_CONST * Tnu_eff * Tnu_eff * Tnu_eff * Tnu_eff;

  OmNuh2 = 0.; // Initialize to 0 - we add to this for each massive neutrino species.
  for(int i=0; i < N_nu_mass; i++) {
    // Get mass over T (mass (eV) / ((kb eV/s/K) Tnu_eff (K))
    // This returns the density normalized so that we get nuh2 at a=0
    mnuOT = mnu[i] / (Tnu_eff/a) * (ccl_constants.EV_IN_J / (ccl_constants.KBOLTZ));

    // Get the value of the phase-space integral
    intval = nu_phasespace_intg(mnuOT, status);
    OmNuh2 = intval*prefix_massive/a4 + OmNuh2;
  }

  return OmNuh2;
}

/* -------- ROUTINE: Omeganuh2_to_Mnu ---------
INPUTS: OmNuh2: neutrino mass density today Omeganu * h^2,
        label: how you want to split up the masses, see ccl_neutrinos.h for options,
        T_CMB: CMB temperature, status: pointer to status integer.
TASK: Given Omeganuh2 today, the method of splitting into masses, and the temperature of the
      CMB, output a pointer to the array of neutrino masses (may be length 1 if label asks for sum)
*/
double* ccl_nu_masses(double OmNuh2, ccl_neutrino_mass_splits mass_split,
                      double T_CMB,  int* status) {
  double sumnu;
  double *mnu = NULL;

  sumnu = 93.14 * OmNuh2;

  // Now split the sum up into three masses depending on the label given:
  if (mass_split == ccl_nu_normal) {
    mnu = malloc(3*sizeof(double));
    if (mnu == NULL) {
      *status = CCL_ERROR_MEMORY;
    }

    if (*status == 0) {
      // See CCL note for how we get these expressions for the neutrino masses in
      // normal and inverted hierarchy.
      mnu[0] = (
        2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. * ccl_constants.DELTAM13_sq_pos + 4. * sumnu*sumnu, 0.5)
        - 0.25 * ccl_constants.DELTAM12_sq / (2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. *
        ccl_constants.DELTAM13_sq_pos + 4. * sumnu*sumnu, 0.5)));
      mnu[1] = (
        2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. * ccl_constants.DELTAM13_sq_pos + 4. * sumnu*sumnu, 0.5)
        + 0.25 * ccl_constants.DELTAM12_sq / (2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. *
        ccl_constants.DELTAM13_sq_pos + 4. * sumnu*sumnu, 0.5)));
      mnu[2] = (
        -1./3. * sumnu + 1./3 * pow(-6. * ccl_constants.DELTAM12_sq +
          12. * ccl_constants.DELTAM13_sq_pos + 4. * sumnu*sumnu, 0.5));

      if (mnu[0] < 0 || mnu[1] < 0 || mnu[2] < 0) {
        // The user has provided a sum that is below the physical limit.
        if (sumnu < 1e-14) {
          mnu[0] = 0.;
          mnu[1] = 0.;
          mnu[2] = 0.;
        }
        else {
          *status = CCL_ERROR_MNU_UNPHYSICAL;
          ccl_raise_warning(
              *status,
              "CCL_ERROR_MNU_UNPHYSICAL: Sum of neutrinos masses for this Omeganu "
              "value is incompatible with the requested mass hierarchy.");
        }
      }
    }
  }
  else if (mass_split == ccl_nu_inverted) {
    mnu = malloc(3*sizeof(double));
    if (mnu == NULL) {
      *status = CCL_ERROR_MEMORY;
    }

    if (*status == 0) {
      mnu[0] = (
        2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. * ccl_constants.DELTAM13_sq_neg + 4. * sumnu * sumnu, 0.5)
        - 0.25 * ccl_constants.DELTAM12_sq / (2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. *
        ccl_constants.DELTAM13_sq_neg + 4. * sumnu * sumnu, 0.5)));
      mnu[1] = (
        2./3.* sumnu - 1./6. * pow(-6. * ccl_constants.DELTAM12_sq + 12. * ccl_constants.DELTAM13_sq_neg + 4. * sumnu*sumnu, 0.5)
        + 0.25 * ccl_constants.DELTAM12_sq / (2./3.* sumnu - 1./6. * pow(-6. *
        ccl_constants.DELTAM12_sq + 12. * ccl_constants.DELTAM13_sq_neg + 4. * sumnu*sumnu, 0.5)));
      mnu[2] = (
        -1./3. * sumnu + 1./3 * pow(-6. * ccl_constants.DELTAM12_sq +
          12. * ccl_constants.DELTAM13_sq_neg + 4. * sumnu*sumnu, 0.5));

      if (mnu[0] < 0 || mnu[1] < 0 || mnu[2] < 0) {
        // The user has provided a sum that is below the physical limit.
        if (sumnu < 1e-14) {
          mnu[0] = 0.;
          mnu[1] = 0.;
          mnu[2] = 0.;;
        }
        else {
          *status = CCL_ERROR_MNU_UNPHYSICAL;
          ccl_raise_warning(
              *status,
              "CCL_ERROR_MNU_UNPHYSICAL: Sum of neutrinos masses for this Omeganu "
              "value is incompatible with the requested mass hierarchy.");
        }
      }
    }
  }
  else if (mass_split == ccl_nu_equal) {
    mnu = malloc(3*sizeof(double));
    if (mnu == NULL) {
      *status = CCL_ERROR_MEMORY;
    }

    if (*status == 0) {
      mnu[0] = sumnu/3.;
      mnu[1] = sumnu/3.;
      mnu[2] = sumnu/3.;
    }
  }
  else if (mass_split == ccl_nu_sum) {
    mnu = malloc(sizeof(double));
    if (mnu == NULL) {
      *status = CCL_ERROR_MEMORY;
    }

    if (*status == 0) {
      mnu[0] = sumnu;
    }
  }
  else {
    *status = CCL_ERROR_MNU_UNPHYSICAL;
    ccl_raise_warning(
        *status,
        "mass option = %d not yet supported!", mass_split);
  }

  return mnu;
}

#undef GSL_EPSABS_NU
#undef GSL_EPSREL_NU
#undef GSL_N_ITERATION_NU


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include "compearth.h"
#ifdef COMPEARTH_USE_MKL
#ifdef __clang__
#pragma clang diagnostic push
#pragma clang diagnostic ignored "-Wreserved-id-macro"
#pragma clang diagnostic ignored "-Wstrict-prototypes"
#endif
#include <mkl_cblas.h>
#ifdef __clang__
#pragma clang diagnostic pop
#endif
#else
#include <cblas.h>
#endif

/*!
 * @brief Computes the omega angles between two moment tensors.
 *
 * @param[in] nmt1    Number of moment tensors in M1.  This can be 1 otherwise
 *                    it must be equal to nmt2.  If it is 1 then the angle will
 *                    be between M1 and all the moment tensors in M2.
 * @param[in] M1      First array of moment tensors.  M1 is packed
 *                    \f$ M = \{M_{11} M_{22} M_{33} M_{12} M_{13} M_{23}\} \f$.
 *                    This is an array of dimension [6 x nmt1] with leading
 *                    dimension 6.
 * @param[in] nmt2    Number of moment tensors in M2.  This can be 1 otherwise
 *                    it must be equal to nmt1.  If it is 1 then the angle will
 *                    be between M2 and all the moment tensors in M1.
 * @param[in] M2      Second array of moment tensors.  M2 is packed
 *                    \f$ M = \{M_{11} M_{22} M_{33} M_{12} M_{13} M_{23}\} \f$.
 *                    This is an array of dimension [6 x nmt2] with leading
 *                    dimension 6.
 *
 * @param[out] omega  This is a measure between two moment tensors and combines
 *                    differences in eigenvalues (source types) and orientation
 *                    but not magnitude.
 *                    This is an array of dimension [MAX(nmt1, nmt2)].
 *
 * @author Carl Tape and translated to C by Ben Baker
 *
 * @copyright MIT
 *
 */
int compearth_CMT2omega(const int nmt1, const double *__restrict__ M1,
                        const int nmt2, const double *__restrict__ M2,
                        double *__restrict__ omega)
{
    double Mwork[6*CE_CHUNKSIZE] __attribute__((aligned(64)));
    int ierr, imt, nmtLoc;
    const double pi180i = 180.0/M_PI;
    ierr = 0;
    if (nmt1 < 1 || M1 == NULL || nmt2 < 1 || M2 == NULL || omega == NULL)
    {
        if (nmt1 < 1)
        {
            fprintf(stderr, "%s: Error nmt1 must be positive\n", __func__);
        }
        if (nmt2 < 1)
        {
            fprintf(stderr, "%s: Error nmt2 must be positive\n", __func__);
        }
        if (M1 == NULL){fprintf(stderr, "%s: Error M1 is NULL\n", __func__);}
        if (M2 == NULL){fprintf(stderr, "%s: Error M2 is NULL\n", __func__);}
        if (omega == NULL)
        {
            fprintf(stderr, "%s: Error omega is NULL\n", __func__);
        }
        return -1;
    }
    // Straight compuation
    if (nmt1 == nmt2)
    {
        ierr = compearth_angleMT(nmt1, M1, M2, omega);
        if (ierr != 0)
        {
            fprintf(stderr, "%s: Error computing angleMT 1\n", __func__);
        }
        // Convert to degrees
        cblas_dscal(nmt1, pi180i, omega, 1);
        return ierr;
    }
    else
    {
        if (nmt1 == 1 || nmt2 == 1)
        {
            // Copy nmt1 and repeat computation with it
            if (nmt1 == 1)
            {
                for (imt=0; imt<CE_CHUNKSIZE; imt++)
                {
                    cblas_dcopy(6, &M1[0], 1, &Mwork[6*imt], 1);
                }
                for (imt=0; imt<nmt2; imt=imt+CE_CHUNKSIZE)
                {
                    nmtLoc = MIN(CE_CHUNKSIZE, nmt2 - imt);
                    ierr = compearth_angleMT(nmtLoc, Mwork, &M2[6*imt],
                                             &omega[imt]);
                    if (ierr != 0)
                    {
                        fprintf(stderr, "%s: Error calling angleMT at %d\n",
                                __func__, __LINE__);
                        return ierr;
                    }
                    // Convert to degrees
                    cblas_dscal(nmtLoc, pi180i, &omega[imt], 1);
                }
            }
            // Copy nmt2 and repeat computation with it
            else
            {
                for (imt=0; imt<CE_CHUNKSIZE; imt++)
                {
                    cblas_dcopy(6, &M2[0], 1, &Mwork[6*imt], 1);
                }
                for (imt=0; imt<nmt1; imt=imt+CE_CHUNKSIZE)
                {
                    nmtLoc = MIN(CE_CHUNKSIZE, nmt1 - imt);
                    ierr = compearth_angleMT(nmtLoc, &M1[6*imt], Mwork,
                                             &omega[imt]);
                    if (ierr != 0)
                    {
                        fprintf(stderr, "%s: Error calling angleMT at %d\n",
                                __func__, __LINE__);
                        return ierr;
                    }
                    // Convert to degrees
                    cblas_dscal(nmtLoc, pi180i, &omega[imt], 1);
                }
            }
        }
        else
        {
            fprintf(stderr, "%s: nmt1=%d /= nmt2=%d; this is invalid\n",
                    __func__, nmt1, nmt2);
            return -1;
        }
    }
    return ierr;
}


#include <stdio.h>
#include <math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_odeiv2.h>
#include <cairo.h>
#include <gtk/gtk.h>

double globx;

double analytic(double w0, double t);

double spring_euler(double w0, double x);
void test_euler(GtkWidget *darea);

int func(double t, const double x[], double f[], void *params);
int jac(double t, const double x[], double *dfdy, double dfdt[], void *params);
int test_gsl(GtkWidget *darea);

void do_drawing(cairo_t *cr);
gboolean on_draw_event(GtkWidget *widget, cairo_t *cr, gpointer user_data);

gboolean terminate(GThread *thread);

void *thread_func(GtkWidget *entry) {
  //test_euler(entry);
  test_gsl(entry);

  gdk_threads_add_idle((GSourceFunc)terminate, g_thread_self());
  return NULL;
}

int main(int argc, char *argv[]) {
	GtkWidget *window;
	GtkWidget *darea;

    gtk_init(&argc, &argv);

	window = gtk_window_new(GTK_WINDOW_TOPLEVEL);

	darea = gtk_drawing_area_new();
	gtk_container_add(GTK_CONTAINER(window), darea);

	g_signal_connect(G_OBJECT(darea), "draw", G_CALLBACK(on_draw_event), NULL);
	g_signal_connect(window, "destroy",	G_CALLBACK(gtk_main_quit), NULL);

	gtk_window_set_position(GTK_WINDOW(window), GTK_WIN_POS_CENTER);
	gtk_window_set_default_size(GTK_WINDOW(window), 400, 300);
	gtk_window_set_title(GTK_WINDOW(window), "Spring simulation");

	gtk_widget_show_all(window);

  	g_thread_new("eval", (GThreadFunc)thread_func, darea);

	gtk_main();

	return 0;
}

double analytic(double w0, double t) {
	return cos(w0 * t);
}

// euler

double spring_euler(double w0, double x) {
	return -w0 * w0 * x;
}

void test_euler(GtkWidget *darea) {
	const int n = 1000;

	// x - position
	// v - speed
	// t - time
	// dt - step
	// w0 = sqrt(k/m)
	double x[n], v[n], t[n], dt;

	const double w0 = 1.0;
	x[0] = 1.0; v[0] = 0.0; t[0] = 0.0;
	dt = 0.05;

	int i;
	for (i = 0; i < n - 1 ; i++) {
		x[i+1] = x[i] + v[i] * dt;
		v[i+1] = v[i] + spring_euler(w0, x[i]) * dt;
		t[i+1] = t[i] + dt;
	}

	for (i = 0; i < n; i++) {
		// draw
		globx = x[i];
		gtk_widget_queue_draw(darea);
		printf("t: %f\tx: %f\tanalytic: \t%f\n", t[i], x[i], analytic(w0, t[i]));
		g_usleep(10000);
	}
}

// gsl

int func(double t, const double x[], double f[], void *params) {
	// x' = v
	// v' = -w0^2 * x
	double w0 = *(double *) params;
	f[0] = x[1];
	f[1] = -w0 * w0 * x[0];
	return GSL_SUCCESS;
}

int jac(double t, const double x[], double *dfdy, double dfdt[], void *params) {
	double w0 = *(double *)params;
	gsl_matrix_view dfdy_mat = gsl_matrix_view_array(dfdy, 2, 2);
	gsl_matrix * m = &dfdy_mat.matrix;
	gsl_matrix_set(m, 0, 0, 0.0);
	gsl_matrix_set(m, 0, 1, 1.0);
	gsl_matrix_set(m, 1, 0, -w0 * w0);
	gsl_matrix_set(m, 1, 1, 0.0);
	dfdt[0] = 0.0;
	dfdt[1] = 0.0;
	return GSL_SUCCESS;
}

int test_gsl(GtkWidget *darea) {
	double w0 = 1.0;
	gsl_odeiv2_system sys = { func, jac, 2, &w0 };

	gsl_odeiv2_driver *d = gsl_odeiv2_driver_alloc_y_new(&sys, gsl_odeiv2_step_rk4, 0.05, 1e-6, 1e-6);

	double t = 0.0;
	double x[2] = { 1.0, 0.0 };
	int i, s;

	for (i = 0; i < 1000; i++) {
		s = gsl_odeiv2_driver_apply_fixed_step(d, &t, 0.05, 1, x);

		if (s != GSL_SUCCESS) {
			printf ("error: driver returned %d\n", s);
			break;
		}

		// draw
		globx = x[0];
		gtk_widget_queue_draw(darea);
		printf("t: %.4f\tanalytic: %.8f\tx:%.8f\n", t, analytic(w0, t), x[0]);
		g_usleep(10000);
	}

	gsl_odeiv2_driver_free(d);
	return s;
}

// drawing

gboolean on_draw_event(GtkWidget *widget, cairo_t *cr, gpointer user_data) {
	do_drawing(cr);

	return FALSE;
}

void do_drawing(cairo_t *cr) {
	cairo_set_source_rgb(cr, 0, 0, 0);
	cairo_set_line_width(cr, 1);

	int k;
	int prevy = 0;
	cairo_move_to(cr, 200, 0);
	for (k = 0; k < 20; k++) {
		int j = k % 2 == 0 ? -1 : 1;
		cairo_line_to(cr, 200 + j * 20, k*5*(globx + 1) + prevy);
		prevy = k*2;
	}
	cairo_line_to(cr, 200, 100*(globx + 1) + prevy);
	//cairo_stroke(cr);
	cairo_rectangle(cr, 180, 100*(globx + 1) + prevy, 40, 40);
	//cairo_stroke_preserve(cr);
	//cairo_fill(cr);
	cairo_stroke(cr);
}

// threads

gboolean terminate(GThread *thread) {
  g_thread_join(thread);

  //g_thread_unref(thread);

  return FALSE;
}


//
//  herk.h
//  Linear Algebra Template Library
//
//  Created by Rodney James on 1/6/12.
//  Copyright (c) 2012 University of Colorado Denver. All rights reserved.
//

#ifndef _herk_h
#define _herk_h

/// @file herk.h Performs complex matrix-matrix multiplication operations resulting in Hermitian matrices.

#include <cctype>
#include "latl.h"

namespace LATL
{
   /// @brief Performs multiplcation of a complex matrix with its conjugate transpose.
   ///
   /// For complex matrix A, complex Hermitian matrix C, and real scalars alpha and beta
   ///
   ///        C := alpha*A*A'+beta*C  or  C := alpha*A'*A+beta*C
   /// is computed.
   /// @return 0 if success.
   /// @return -i if the ith argument is invalid.
   /// @tparam real_t Floating point type.
   /// @param uplo Specifies whether the upper or lower triangular part of the Hermitian matrix C
   /// is to be referenced:
   ///
   ///        if uplo = 'U' or 'u' then C is upper triangular,
   ///        if uplo = 'L' or 'l' then C is lower triangular.
   /// @param trans Specifies the operation to be perfomed as follows:
   ///
   ///        if trans = 'N' or 'n' then C := alpha*A*A'+beta*C
   ///        if trans = 'C' or 'c' then C := alpha*A'*A+beta*C
   /// @param n Specifies the order of the complex Hermitian matrix C.  n>=0
   /// @param k Specifies the other dimension of the complex matrix A (see below). k>=0
   /// @param alpha Real scalar.
   /// @param A Pointer to complex matrix.
   ///
   ///        if trans = 'N' or 'n' then A is n-by-k
   ///        if trans = 'C' or 'c' then A is k-by-n
   /// @param ldA Column length of the matrix A. If trans = 'N' or 'n' ldA>=n, otherwise ldA>=k.
   /// @param beta Real scalar.
   /// @param C Pointer to complex Hermitian n-by-n matrix C.
   /// Only the upper or lower triangular part of C is referenced, depending on the value of uplo above.
   /// @param ldC Column length of the matrix C.  ldC>=n
   /// @ingroup BLAS

   template <typename real_t>
   int HERK(char uplo, char trans, int_t n, int_t k, real_t alpha, complex<real_t> *A, int_t ldA, real_t beta, complex<real_t> *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      using std::real;
      using std::conj;
      const complex<real_t> zero(0.0,0.0);
      const real_t rzero=0.0;
      const real_t one=1.0;
      int_t i,j,l;
      complex<real_t> *a,*c,*at;
      complex<real_t> t;
      real_t s;

      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldC<n)
         return -10;
      else if((n==0)||(((alpha==rzero)||(k==0))&&(beta==one)))
         return 0;

      if(alpha==zero)
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<j;i++)
                  c[i]*=beta;
               c[j]=beta*real(c[j]);
               c+=ldC;
            }

         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               c[j]=beta*real(c[j]);
               for(i=j+1;i<n;i++)
                  c[i]*=beta;
               c+=ldC;
            }
         }
      }
      else if(trans=='N')
      {
         if(uplo=='U')
         {
            c=C;
            for(j=0;j<n;j++)
            {
               for(i=0;i<j;i++)
                  c[i]*=beta;
               c[j]=beta*real(c[j]);
               a=A;
               for(l=0;l<k;l++)
               {
                  t=alpha*conj(a[j]);
                  for(i=0;i<j;i++)
                     c[i]+=t*a[i];
                  c[j]=real(c[j])+real(t*a[i]);
                  a+=ldA;
               }
               c+=ldC;
            }
         }
         else
         {
            c=C;
            for(j=0;j<n;j++)
            {
               c[j]=beta*real(c[j]);
               for(i=j+1;i<n;i++)
                  c[i]*=beta;
               a=A;
               for(l=0;l<k;l++)
               {
                  t=alpha*conj(a[j]);
                  c[j]=real(c[j])+real(t*a[j]);
                  for(i=j+1;i<n;i++)
                     c[i]+=t*a[i];
                  a+=ldA;
               }
               c+=ldC;
            }
         }
      }
      else
      {
         if(uplo=='U')
         {
            c=C;
            at=A;
            for(j=0;j<n;j++)
            {
               a=A;
               for(i=0;i<j;i++)
               {
                  t=zero;
                  for(l=0;l<k;l++)
                     t+=conj(a[l])*at[l];
                  c[i]=alpha*t+beta*c[i];
                  a+=ldA;
               }
               s=rzero;
               for(l=0;l<k;l++)
                  s+=real(conj(at[l])*at[l]);
               c[j]=alpha*s+beta*real(c[j]);
               at+=ldA;
               c+=ldC;
            }
         }
         else
         {
            at=A;
            c=C;
            for(j=0;j<n;j++)
            {
               s=rzero;
               for(l=0;l<k;l++)
                  s+=real(conj(at[l])*at[l]);
               c[j]=alpha*s+beta*real(c[j]);
               a=A+(j+1)*ldA;
               for(i=j+1;i<n;i++)
               {
                  t=zero;
                  for(l=0;l<k;l++)
                     t+=conj(a[l])*at[l];
                  c[i]=alpha*t+beta*c[i];
                  a+=ldA;
               }
               at+=ldA;
               c+=ldC;
            }
         }
      }
      return 0;
   }
#ifdef __latl_cblas
#include <cblas.h>

   template <> int HERK<float>(char uplo, char trans, int_t n, int_t k, float alpha, complex<float> *A, int_t ldA, float beta, complex<float> *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldC<n)
         return -10;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_cherk(CblasColMajor,Uplo,Trans,n,k,alpha,A,ldA,beta,C,ldC);

      return 0;
   }

   template <> int HERK<double>(char uplo, char trans, int_t n, int_t k, double alpha, complex<double> *A, int_t ldA, double beta, complex<double> *C, int_t ldC)
   {
      using std::toupper;
      uplo=toupper(uplo);
      trans=toupper(trans);
      if((uplo!='U')&&(uplo!='L'))
         return -1;
      else if((trans!='N')&&(trans!='C'))
         return -2;
      else if(n<0)
         return -3;
      else if(k<0)
         return -4;
      else if(ldA<((trans=='N')?n:k))
         return -7;
      else if(ldC<n)
         return -10;

      const CBLAS_UPLO Uplo=(uplo=='U')?CblasUpper:CblasLower;
      const CBLAS_TRANSPOSE Trans=(trans=='N')?CblasNoTrans:((trans=='T')?CblasTrans:CblasConjTrans);

      cblas_zherk(CblasColMajor,Uplo,Trans,n,k,alpha,A,ldA,beta,C,ldC);

      return 0;
   }

#endif
}
#endif


#include <cblas.h>
#include <stdio.h>

/* compilar: gcc fonte.c -o exec -lblas */

int main( void ) {
  int lda = 3;
  float A[] = { 1, 0, -1,
                2, 3, 1 };

  int ldb = 2;
  float B[] = { 5, 1,
                6, -1,
                7, 2 };

  int ldc = 2;
  float C[] = { 0.00, 0.00,
                0.00, 0.00 };

  /* Compute C = A B */

  cblas_sgemm( CblasRowMajor, CblasNoTrans, CblasNoTrans, 2, 2, 3, 1.0, A, lda, B, ldb, 0.0, C, ldc );

  printf( "[ %g, %g\n", C[ 0 ], C[ 1 ] );
  printf( "  %g, %g ]\n", C[ 2 ], C[ 3 ] );

  return( 0 );
}


/* stable/stable_koutrouvelis.h
 *
 * Koutrouvelis method for parameter estimation of alpha-stable
 * distributions. Based on [1] and MATLAB code available in [2].
 *
 * [1] Koutrouvelis, I. A. An Iterative Procedure for the Estimation
 *     of the Parameters of Stable Laws Communications in Statistics
 *     - Simulation and Computation, 1981, 10, 17-28
 * [2] Mark S. Veillete. Alpha-Stable Distributions in MATLAB
 *     http://math.bu.edu/people/mveillet/research.html
 *
 * Copyright (C) 2013. Javier Royuela del Val
 *                     Federico Simmross Wattenberg
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; version 3 of the License.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; If not, see <http://www.gnu.org/licenses/>.
 *
 *
 *  Javier Royuela del Val.
 *  E.T.S.I. Telecomunicación
 *  Universidad de Valladolid
 *  Paseo de Belén 15, 47002 Valladolid, Spain.
 *  jroyval@lpi.tel.uva.es
 */
#include <stdio.h>
#include <math.h>
#include <float.h>
#include <gsl/gsl_complex.h>
#include <gsl/gsl_complex_math.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_fit.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_multifit.h>
#include "stable.h"

inline double sign(double x) {
  return ((.0 < x) - (x < .0));
}

double var(const double * data, const int N) {
  double acum = .0, acum2 = .0;
  double v;

  int i;
  for(i=0;i<N;i++) {
    acum  += data[i];
    acum2 += data[i]*data[i];
  }

  v = (1.0/(N-1.0)) * (acum2 - (1.0/N)*acum*acum);
  return v;
}

int chooseK(double,int);

int chooseL(double,int);

void setcovYY(const double * t, int K, int N, double alpha, double beta, double gam, double **covYY);

void setcovZZ(const double * t, int K, int N, double alpha, double beta, double gam, double **covZZ);

double ecfRoot(const double * data, const int N);

void stable_samplecharfunc(const double* x, const unsigned int Nx,
             const double* t, const unsigned int Nt, gsl_complex *z);

gsl_complex stable_samplecharfunc_point(const double* x,
            const unsigned int N, double t);

int stable_fit_koutrouvelis(StableDist * dist, const double * data, const unsigned int N) {

  int maxiter = 10;
  double xTol = 0.01;

  double * s = NULL;
  gsl_complex * phi = NULL;
  gsl_complex * phi2 = NULL;

  int i;

  double alpha = dist->alpha;
  double beta  = dist->beta;
  double sigma = dist->sigma;
  double mu1   = dist->mu_1;

  double alphaold = alpha;
  double mu1old   = mu1;

  double diff     = .0;
  double diffbest = DBL_MAX;
  double diffmax  = .0;

  double alphabest = alpha;
  double betabest  = beta;
  double sigmabest = sigma;
  double mu1best   = mu1;

  double * t = NULL;
  double * w = NULL;
  double * y = NULL;
  double * p = NULL;

  double * t2 = NULL;
  double * w2 = NULL;
  double * y2 = NULL;
  double * p2 = NULL;

  gsl_matrix * X;
  gsl_matrix * covmat;
  gsl_vector * cvout;
  gsl_vector * ydat;
  gsl_vector * weights;

  int stat;
  double sumsq = .0;
  double c0 = .0, c1 = .0;
  double cov00 = .0, cov01 = .0, cov11 = .0;
  double sigmanew = 0;

  double **covYY;// **covZZ;
  double **covZZ;

  int iter = 0;
  int K,L;
  int row;
  double t_0=0;
  double step_u=0;
  double estshift;

  gsl_multifit_linear_workspace * linws;

  if (sigma == 0) {
    sigma = sqrt(var(data,N));
	stable_setparams(dist,alpha,beta,sigma,mu1,1);
  }

  s = (double *) malloc(N*sizeof(double));
  for (i=0;i<N;i++) {
    s[i] = (data[i]-mu1)/sigma;
  }

  covmat = gsl_matrix_alloc(2,2);
  cvout = gsl_vector_alloc(2);

  for (iter = 0; iter<maxiter; iter ++) {
    if (iter <= 1) {
      K = chooseK(alpha,N);

      t = (double *) realloc(t,K*sizeof(double));
      p = (double *) realloc(p,K*sizeof(double));
      w = (double *) realloc(w,K*sizeof(double));
      y = (double *) realloc(y,K*sizeof(double));

      phi = (gsl_complex*) realloc(phi,K*sizeof(gsl_complex));

      for(i=0;i<K;i++) {
        t[i]=((double)i+1.0)*M_PI/25.0;
        w[i]=log(fabs(t[i]));
      }
    }

    if (iter==1) {
      covYY = (double **)malloc(K*sizeof(double *));
      covYY[0] = (double*)malloc(K*K*sizeof(double));
      for (row=1;row<K;row++) {
        covYY[row] = covYY[0] + row*K;
      }
    }

    stable_samplecharfunc(s,N,t,K,phi);

    for(i=0;i<K;i++) {
      y[i] = log(-2.0*gsl_complex_logabs(phi[i]));
    }

    if (iter==0) { //Use ordinary least squares regression
 //     printf("ordls: ");fflush(stdout);
      stat = gsl_fit_linear (w, 1, y, 1, K, &c0, &c1, &cov00, &cov01, &cov11, &sumsq);
      alpha = c1;
      sigmanew = pow(exp(c0)/2.0,1.0/alpha);
      sigma = sigma*sigmanew;
//      printf("stat = %d, alpha=%f, sigma=%f\n",stat,alpha,sigma);
    }
    else { //Use weighted least squares regression
//      printf("wls: ");fflush(stdout);
      setcovYY(t, K, N, alpha, beta, 1.0, covYY);
      for (i=0;i<K;i++) {
        p[i] = 1.0/covYY[i][i];
      }
      stat = gsl_fit_wlinear(w, 1, p, 1, y, 1, K, &c0, &c1, &cov00, &cov01, &cov11, &sumsq);
      alpha = c1;
      sigmanew = pow(exp(c0)/2.0,1.0/alpha);
      sigma = sigma*sigmanew;
 //     printf("stat = %d, alpha=%f, sigma=%f\n",stat,alpha,sigma);
    }

    /*************** rescale data ******************/
//    printf("rescale\n");fflush(stdout);
    for (i=0;i<N;i++) {
      s[i] = s[i]/sigmanew;
    }
    if (alpha<0) alpha = 0;
    if (alpha>2) alpha = 2;
    if (beta<-1) beta = -1;
    if (beta> 1) beta = 1;
    if (sigma<0) sigma = 0;

    /********** refine beta and mu **************/
 //   printf("refbetamu\n");fflush(stdout);
    if (iter <= 1) {
      L = chooseL(alpha,N);
//      printf("alpha = %f, N = %d, L = %d\n",alpha,N,L);fflush(stdout);
      t_0 = ecfRoot(s,N);
      step_u = M_PI/50;
      if (t_0/L<step_u) step_u = t_0/L;

      t2 = (double *) realloc(t2,L*sizeof(double));
      p2 = (double *) realloc(p2,L*sizeof(double));
      w2 = (double *) realloc(w2,L*sizeof(double));
      y2 = (double *) realloc(y2,L*sizeof(double));

      phi2 = (gsl_complex*)realloc(phi2,L*sizeof(gsl_complex));

      for(i=0;i<L;i++) {
        t2[i]=((double)i+1.0)*step_u;
        w2[i]=sign(t2[i])*pow(fabs(t2[i]),alpha);
      }
    }
    if (iter==0){
//      printf("multimin alloc L = %d\n",L);fflush(stdout);
      linws = gsl_multifit_linear_alloc (L,2);
    }
    else if (iter ==1) {
      //Reserve covariance matrix mem
      covZZ = (double **)malloc(L*sizeof(double *));
      covZZ[0] = (double*)malloc(L*L*sizeof(double));
      for (row=0;row<L;row++) {
        covZZ[row] = covZZ[0] + row*L;
      }
      gsl_multifit_linear_free(linws);
      linws = gsl_multifit_linear_alloc (L,2);
    }

 //   printf("Second charfunc iter %d\n",iter);fflush(stdout);
    stable_samplecharfunc(s,N,t2,L,phi2);
 //   printf("done\n");

    for(i=0;i<L;i++) {
      y2[i] = gsl_complex_arg(phi2[i]);
    }

    X    = gsl_matrix_alloc(L,2);
    ydat = gsl_vector_alloc(L);

    for(row=0;row<L;row++) {
      gsl_matrix_set(X,row,0,t2[row]);
      gsl_matrix_set(X,row,1,w2[row]);
      gsl_vector_set(ydat,row,y2[row]);
    }

    if (iter==0) {
 //     printf("multi ordls: ");
      stat   = gsl_multifit_linear(X,ydat,cvout,covmat,&sumsq,linws);
 //     printf("stat = %d, beta=%f\n",stat,beta);
    }
    else {
//      printf("multi wls: ");
      setcovZZ(t2, L, N, alpha,  beta,  1.0, covZZ);
      weights = gsl_vector_alloc(L);
      for (i=0;i<L;i++) {
        p2[i] = 1.0/covZZ[i][i];
        gsl_vector_set(weights,i,p2[i]);
      }
      stat  = gsl_multifit_wlinear(X,weights,ydat,cvout,covmat,&sumsq,linws);
//      printf("stat = %d, beta=%f\n",stat,beta);
    }
    if (alpha>1.98 || alpha < 0.05 || fabs(alpha-1.0)<0.05 || isnan(alpha)) {
        beta = 0.0;
    } else {
        beta = gsl_vector_get(cvout,1)/tan(alpha*M_PI*0.5);
    }
    estshift = gsl_vector_get(cvout,0);
    mu1    = mu1 + sigma * estshift;

//    printf("rem shift\n");
    /*** remove estimated shift ***/
    for (i=0;i<N;i++) {
      s[i] = s[i] - estshift;
    }

    if (isnan(alpha) || isnan(beta) || isnan(sigma) || isnan(mu1))
    {
      iter++;
      break;
    }

//    printf("check conv");
    /** check for convergence or blow up**/
    diff = pow(alpha - alphaold,2) + pow(mu1 - mu1old,2);
    if (iter <= 2 && diff > diffmax) {
      diffmax = diff;
    }
//    else if (diff > 2.0*diffmax) {
#ifdef DEBUG
      printf("blow up on iter %d\n",iter);
#endif
//      break;
//    }

//    printf("check best\n");
    if (fabs(diff) < diffbest) {
      alphabest = alpha;
      betabest  = beta;
      sigmabest = sigma;
      mu1best   = mu1;

      diffbest = diff;

      if (diff < xTol) {
        gsl_matrix_free(X);
        gsl_vector_free(ydat);
        if (iter>0) gsl_vector_free(weights);
        iter++;
        break;
      }
    }

    alphaold = alpha;
    mu1old   = mu1;

    gsl_matrix_free(X);
    gsl_vector_free(ydat);
    if (iter>0) {
      gsl_vector_free(weights);
    }
  }

  if (maxiter > 0 && iter >= 0) {
      alpha = alphabest;
      beta = betabest;
      sigma = sigmabest;
      mu1   = mu1best;
  }

  if (alpha<0) alpha = 0;
  if (alpha>2) alpha = 2;
  if (beta<-1) beta = -1;
  if (beta> 1) beta = 1;
  if (sigma<0) sigma = 0;

  stable_setparams(dist,alpha,beta,sigma,mu1,1);

  free(t);
  free(p);
  free(w);
  free(y);
  free(phi);
  free(t2);
  free(p2);
  free(w2);
  free(y2);
  free(phi2);
  gsl_matrix_free(covmat);
  gsl_vector_free(cvout);
  free(s);

  if (iter>1) {
    free(covYY[0]);
    free(covYY);
    free(covZZ[0]);
    free(covZZ);
  }

  gsl_multifit_linear_free(linws);

  //printf(" iter %d diff %f a %f b %f s %f m %f\n",iter,diff,alpha,beta,sigma,dist->mu_0);

  return 0;
}  // end stable_fit_koutrouvelis

int chooseK(double alpha, int N) {
  double a[]={1.9,1.5,1.3,1.1,.9,.7,.5,.3};
  int n[] = {200, 800, 1600};

  double Kmat[8][3]={{ 9, 9, 9},
                     {11,11,11},
                     {22,16,14},
                     {24,18,15},
                     {28,22,18},
                     {30,24,20},
                     {86,68,56},
                     {134,124,118}};

  int i,j;
  double xi;
  double xj;
  double Kp;

  if (alpha < 0.3) alpha = 0.3;
  if (alpha > 1.9) alpha = 1.9;
  if (N<200) N=200;
  if (N>1600) N=1600;

  i=1;
  j=1;
  while (i<7 && a[i]>=alpha) {
    ++i;
  }
  while (j<2 && n[j]<=N) {
    ++j;
  }

  xi = 1.0 - (alpha-a[i])/(a[i-1]-a[i]);
  xj = 1.0 - (double)(n[j]-N)/(double)(n[j]-n[j-1]);

//  printf("i,j = %d, %d; xi,xj = %f,  %f\n",i,j,xi,xj);

  /* bilinear interpolation */
  Kp =       xj * (xi * Kmat[i][ j ] + (1.0-xi) * Kmat[i-1][ j ] ) +
       (1.0-xj) * (xi * Kmat[i][j-1] + (1.0-xi) * Kmat[i-1][j-1] );

  Kp = floor(Kp+.5);

  return (int)Kp;
}

int chooseL(double alpha, int N) {
  double a[]={1.9,1.5,1.1,.9,.7,.5,.3};
  int n[] = {200, 800, 1600};

  double Lmat[7][3]={{ 9,10,11},
                     {12,14,15},
                     {16,18,17},
                     {14,14,14},
                     {24,16,16},
                     {40,38,36},
                     {70,68,66}};

  int i,j;
  double xi, xj;
  double Lp;

  if (alpha < 0.3) alpha = 0.3;
  if (alpha > 1.9) alpha = 1.9;
  if (N<200) N=200;
  if (N>1600) N=1600;

  i=1;
  j=1;
  while (i<6 && a[i]>=alpha) {
    ++i;
  }
  while (j<2 && n[j]<=N) {
    ++j;
  }

  xi = 1.0 - (alpha-a[i])/(a[i-1]-a[i]);
  xj = 1.0 - (double)(n[j]-N)/(double)(n[j]-n[j-1]);

//  printf("i,j = %d, %d; xi,xj = %f,  %f\n",i,j,xi,xj);
  /* bilinear interpolation */
  Lp =       xj * (xi * Lmat[i][ j ] + (1.0-xi) * Lmat[i-1][ j ] ) +
       (1.0-xj) * (xi * Lmat[i][j-1] + (1.0-xi) * Lmat[i-1][j-1] );

  Lp = floor(Lp + .5);

  return (int)Lp;
}

void setcovYY(const double * t, int K, int N, double alpha, double beta, double gam, double **covYY) {
  double w = tan(alpha*M_PI_2);
  double calpha = pow(gam,alpha);
  int    j = 0, k = 0;

  double * talpha = (double *)malloc(K*sizeof(double));

  for (j=0;j<K;j++) {
    talpha[j]=pow(fabs(t[j]),alpha);
  }

  double tj,tja,tk,tka;
  double tjmtka,tjptka,stj,stk;
  double A,B,D,E;//F,G,H;
  for (j=0;j<K;j++) {
    tj = t[j];
    tja = talpha[j];
    stj = sign(tj);
    for (k=0;k<K;k++) {
      tk  = t[k];
      tka = talpha[k];
      stk = sign(tk);
      tjmtka = pow(fabs(tj-tk),alpha);
      tjptka = pow(fabs(tj+tk),alpha);

      A =  calpha * (tja + tka - tjmtka);
      B =  calpha * beta * (-tja * stj * w + tka * stk * w + tjmtka * sign(tj - tk) * w );
      D =  calpha * (tja + tka - tjptka);
      E =  calpha * beta * ( tja * stj * w + tja * stk * w - tjptka * sign(tj + tk) * w );
//      F =  calpha * (tja + tka);
//      G = -calpha * tjmtka;
//      H = -calpha * tjptka;

//      printf("[j][k] = [%d][%d]",j,k);fflush(stdout);
      covYY[j][k] = (exp(A)*cos(B)+exp(D)*cos(E)-2.0) / ( 2.0 * N * pow(gam,2.0*alpha)*pow(fabs(tj*tk),alpha) );
//      covZZ[j][k] =  exp(F)*( exp(G)*cos(B)-exp(H)*cos(E) ) /(2.0*N);
    }
  }

  free(talpha);

  return;
}
void setcovZZ(const double * t, int K, int N, double alpha, double beta, double gam, double **covZZ) {
  double w = tan(alpha*M_PI_2);
  double calpha = pow(gam,alpha);
  int    j = 0, k = 0;

  double * talpha = (double *)malloc(K*sizeof(double));

  for (j=0;j<K;j++) {
    talpha[j]=pow(fabs(t[j]),alpha);
  }

  double tj,tja,tk,tka;
  double tjmtka,tjptka,stj,stk;
  double B,E,F,G,H;
  for (j=0;j<K;j++) {
    tj = t[j];
    tja = talpha[j];
    stj = sign(tj);
    for (k=0;k<K;k++) {
      tk  = t[k];
      tka = talpha[k];
      stk = sign(tk);
      tjmtka = pow(fabs(tj-tk),alpha);
      tjptka = pow(fabs(tj+tk),alpha);

//      A =  calpha * (tja + tka - tjmtka);
      B =  calpha * beta * (-tja * stj * w + tka * stk * w + tjmtka * sign(tj - tk) * w );
//      D =  calpha * (tja + tka - tjptka);
      E =  calpha * beta * ( tja * stj * w + tja * stk * w - tjptka * sign(tj + tk) * w );
      F =  calpha * (tja + tka);
      G = -calpha * tjmtka;
      H = -calpha * tjptka;

//      covYY[j][k] = (exp(A)*cos(B)+exp(D)*cos(E)-2.0) / ( 2.0 * N * pow(gam,2.0*alpha)*pow(fabs(tj*tk),alpha) );
      covZZ[j][k] =  exp(F)*( exp(G)*cos(B)-exp(H)*cos(E) ) /(2.0*N);
    }
  }

  free(talpha);

  return;
}

double ecfRoot(const double * data, int N) {

  double m=0;
  int i;
  for(i=0;i<N;i++) {
    m += fabs(data[i]);
  }
  m = m/N;

  double t = 0;
  gsl_complex val = stable_samplecharfunc_point(data, N, t);
  int iter=0;
  while (iter<10000 && fabs(GSL_REAL(val))>1e-3) {
    t += GSL_REAL(val)/m;
    val = stable_samplecharfunc_point(data, N, t);
  }

  return t;
}

gsl_complex stable_samplecharfunc_point(const double* x,
            const unsigned int N, double t)
{
  unsigned int i;
  double zr=0.0,zi=0.0;
  gsl_complex z;

  for(i=0;i<N;i++)
   {
      zr+=cos(t*x[i]);
      zi+=sin(t*x[i]);
    }

  GSL_SET_COMPLEX(&z,zr/N,zi/N);

  return z;
}

void stable_samplecharfunc(const double* x, const unsigned int Nx,
             const double* t, const unsigned int Nt, gsl_complex *z)
{
  unsigned int ix,it;
  double zr=0.0,zi=0.0,w;

  for(it=0;it<Nt;it++)
   {
     w = t[it];
     zr = .0;
     zi = .0;
     for(ix=0;ix<Nx;ix++)
       {
         zr+=cos(w*x[ix]);
         zi+=sin(w*x[ix]);
       }
//     if (isnan(zr*zi) || isinf(zr*zi)) {
//        printf("Bad cfuncpoint: z[%d] = z(%f) = %f +i%f",it,w,zr,zi);
//       }
     GSL_SET_COMPLEX(&z[it],zr/Nx,zi/Nx);
   }
  return;
}


/* statistics/gsl_statistics_long_double.h
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Jim Davies, Brian Gough
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#ifndef __GSL_STATISTICS_LONG_DOUBLE_H__
#define __GSL_STATISTICS_LONG_DOUBLE_H__

#include <stddef.h>
#include <gsl/gsl_types.h>

#undef __BEGIN_DECLS
#undef __END_DECLS
#ifdef __cplusplus
# define __BEGIN_DECLS extern "C" {
# define __END_DECLS }
#else
# define __BEGIN_DECLS /* empty */
# define __END_DECLS /* empty */
#endif

__BEGIN_DECLS

GSL_EXPORT double gsl_stats_long_double_mean (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_variance (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_sd (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_variance_with_fixed_mean (const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_sd_with_fixed_mean (const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_absdev (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_skew (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_kurtosis (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_lag1_autocorrelation (const long double data[], const size_t stride, const size_t n);

GSL_EXPORT double gsl_stats_long_double_covariance (const long double data1[], const size_t stride1,const long double data2[], const size_t stride2, const size_t n);

GSL_EXPORT double gsl_stats_long_double_variance_m (const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_sd_m (const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_absdev_m (const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_skew_m_sd (const long double data[], const size_t stride, const size_t n, const double mean, const double sd);
GSL_EXPORT double gsl_stats_long_double_kurtosis_m_sd (const long double data[], const size_t stride, const size_t n, const double mean, const double sd);
GSL_EXPORT double gsl_stats_long_double_lag1_autocorrelation_m (const long double data[], const size_t stride, const size_t n, const double mean);

GSL_EXPORT double gsl_stats_long_double_covariance_m (const long double data1[], const size_t stride1,const long double data2[], const size_t stride2, const size_t n, const double mean1, const double mean2);

/* DEFINED FOR FLOATING POINT TYPES ONLY */

GSL_EXPORT double gsl_stats_long_double_wmean (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_wvariance (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_wsd (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_wvariance_with_fixed_mean (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_wsd_with_fixed_mean (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double mean);
GSL_EXPORT double gsl_stats_long_double_wabsdev (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_wskew (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);
GSL_EXPORT double gsl_stats_long_double_wkurtosis (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n);

GSL_EXPORT double gsl_stats_long_double_wvariance_m (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double wmean);
GSL_EXPORT double gsl_stats_long_double_wsd_m (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double wmean);
GSL_EXPORT double gsl_stats_long_double_wabsdev_m (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double wmean);
GSL_EXPORT double gsl_stats_long_double_wskew_m_sd (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double wmean, const double wsd);
GSL_EXPORT double gsl_stats_long_double_wkurtosis_m_sd (const long double w[], const size_t wstride, const long double data[], const size_t stride, const size_t n, const double wmean, const double wsd);

/* END OF FLOATING POINT TYPES */

GSL_EXPORT double gsl_stats_long_double_pvariance (const long double data1[], const size_t stride1, const size_t n1, const long double data2[], const size_t stride2, const size_t n2);
GSL_EXPORT double gsl_stats_long_double_ttest (const long double data1[], const size_t stride1, const size_t n1, const long double data2[], const size_t stride2, const size_t n2);

GSL_EXPORT long double gsl_stats_long_double_max (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT long double gsl_stats_long_double_min (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT void gsl_stats_long_double_minmax (long double * min, long double * max, const long double data[], const size_t stride, const size_t n);

GSL_EXPORT size_t gsl_stats_long_double_max_index (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT size_t gsl_stats_long_double_min_index (const long double data[], const size_t stride, const size_t n);
GSL_EXPORT void gsl_stats_long_double_minmax_index (size_t * min_index, size_t * max_index, const long double data[], const size_t stride, const size_t n);

GSL_EXPORT double gsl_stats_long_double_median_from_sorted_data (const long double sorted_data[], const size_t stride, const size_t n) ;
GSL_EXPORT double gsl_stats_long_double_quantile_from_sorted_data (const long double sorted_data[], const size_t stride, const size_t n, const double f) ;

__END_DECLS

#endif /* __GSL_STATISTICS_LONG_DOUBLE_H__ */


/* linalg/tridiag.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2002, 2004 Gerard Jungman,
 * Brian Gough, David Necas
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author: G. Jungman */

#include <config.h>
#include <stdlib.h>
#include <math.h>
#include <gsl/gsl_errno.h>
#include "tridiag.h"
#include <gsl/gsl_linalg.h>

/* for description of method see [Engeln-Mullges + Uhlig, p. 92]
 *
 *     diag[0]  offdiag[0]             0   .....
 *  offdiag[0]     diag[1]    offdiag[1]   .....
 *           0  offdiag[1]       diag[2]
 *           0           0    offdiag[2]   .....
 */
static
int
solve_tridiag(
  const double diag[], size_t d_stride,
  const double offdiag[], size_t o_stride,
  const double b[], size_t b_stride,
  double x[], size_t x_stride,
  size_t N)
{
  int status;
  double *gamma = (double *) malloc (N * sizeof (double));
  double *alpha = (double *) malloc (N * sizeof (double));
  double *c = (double *) malloc (N * sizeof (double));
  double *z = (double *) malloc (N * sizeof (double));

  if (gamma == 0 || alpha == 0 || c == 0 || z == 0)
    {
      status = GSL_ENOMEM;
    }
  else
    {
      size_t i, j;

      /* Cholesky decomposition
         A = L.D.L^t
         lower_diag(L) = gamma
         diag(D) = alpha
       */
      alpha[0] = diag[0];
      gamma[0] = offdiag[0] / alpha[0];

      for (i = 1; i < N - 1; i++)
        {
          alpha[i] = diag[d_stride * i] - offdiag[o_stride*(i - 1)] * gamma[i - 1];
          gamma[i] = offdiag[o_stride * i] / alpha[i];
        }

      if (N > 1)
        {
          alpha[N - 1] = diag[d_stride * (N - 1)] - offdiag[o_stride*(N - 2)] * gamma[N - 2];
        }

      /* update RHS */
      z[0] = b[0];
      for (i = 1; i < N; i++)
        {
          z[i] = b[b_stride * i] - gamma[i - 1] * z[i - 1];
        }
      for (i = 0; i < N; i++)
        {
          c[i] = z[i] / alpha[i];
        }

      /* backsubstitution */
      x[x_stride * (N - 1)] = c[N - 1];
      if (N >= 2)
        {
          for (i = N - 2, j = 0; j <= N - 2; j++, i--)
            {
              x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)];
            }
        }

      status = GSL_SUCCESS;
    }

  if (z != 0)
    free (z);
  if (c != 0)
    free (c);
  if (alpha != 0)
    free (alpha);
  if (gamma != 0)
    free (gamma);

  return status;
}

/* plain gauss elimination, only not bothering with the zeroes
 *
 *       diag[0]  abovediag[0]             0   .....
 *  belowdiag[0]       diag[1]  abovediag[1]   .....
 *             0  belowdiag[1]       diag[2]
 *             0             0  belowdiag[2]   .....
 */
static
int
solve_tridiag_nonsym(
  const double diag[], size_t d_stride,
  const double abovediag[], size_t a_stride,
  const double belowdiag[], size_t b_stride,
  const double rhs[], size_t r_stride,
  double x[], size_t x_stride,
  size_t N)
{
  int status;
  double *alpha = (double *) malloc (N * sizeof (double));
  double *z = (double *) malloc (N * sizeof (double));

  if (alpha == 0 || z == 0)
    {
      status = GSL_ENOMEM;
    }
  else
    {
      size_t i, j;

      /* Bidiagonalization (eliminating belowdiag)
         & rhs update
         diag' = alpha
         rhs' = z
       */
      alpha[0] = diag[0];
      z[0] = rhs[0];

      for (i = 1; i < N; i++)
        {
          const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
          alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)];
          z[i] = rhs[r_stride*i] - t*z[i-1];
          /* FIXME!!! */
          if (alpha[i] == 0) {
            status = GSL_EZERODIV;
            goto solve_tridiag_nonsym_END;
          }
        }

      /* backsubstitution */
      x[x_stride * (N - 1)] = z[N - 1]/alpha[N - 1];
      if (N >= 2)
        {
          for (i = N - 2, j = 0; j <= N - 2; j++, i--)
            {
              x[x_stride * i] = (z[i] - abovediag[a_stride*i] * x[x_stride * (i + 1)])/alpha[i];
            }
        }

      status = GSL_SUCCESS;
    }

solve_tridiag_nonsym_END:
  if (z != 0)
    free (z);
  if (alpha != 0)
    free (alpha);

  return status;
}

/* for description of method see [Engeln-Mullges + Uhlig, p. 96]
 *
 *      diag[0]  offdiag[0]             0   .....  offdiag[N-1]
 *   offdiag[0]     diag[1]    offdiag[1]   .....
 *            0  offdiag[1]       diag[2]
 *            0           0    offdiag[2]   .....
 *          ...         ...
 * offdiag[N-1]         ...
 *
 */
static
int
solve_cyc_tridiag(
  const double diag[], size_t d_stride,
  const double offdiag[], size_t o_stride,
  const double b[], size_t b_stride,
  double x[], size_t x_stride,
  size_t N)
{
  int status;
  double * delta = (double *) malloc (N * sizeof (double));
  double * gamma = (double *) malloc (N * sizeof (double));
  double * alpha = (double *) malloc (N * sizeof (double));
  double * c = (double *) malloc (N * sizeof (double));
  double * z = (double *) malloc (N * sizeof (double));

  if (delta == 0 || gamma == 0 || alpha == 0 || c == 0 || z == 0)
    {
      status = GSL_ENOMEM;
    }
  else
    {
      size_t i, j;
      double sum = 0.0;

      /* factor */

      if (N == 1)
        {
          x[0] = b[0] / diag[0];
          return GSL_SUCCESS;
        }

      alpha[0] = diag[0];
      gamma[0] = offdiag[0] / alpha[0];
      delta[0] = offdiag[o_stride * (N-1)] / alpha[0];

      for (i = 1; i < N - 2; i++)
        {
          alpha[i] = diag[d_stride * i] - offdiag[o_stride * (i-1)] * gamma[i - 1];
          gamma[i] = offdiag[o_stride * i] / alpha[i];
          delta[i] = -delta[i - 1] * offdiag[o_stride * (i-1)] / alpha[i];
        }

      for (i = 0; i < N - 2; i++)
        {
          sum += alpha[i] * delta[i] * delta[i];
        }

      alpha[N - 2] = diag[d_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * gamma[N - 3];

      gamma[N - 2] = (offdiag[o_stride * (N - 2)] - offdiag[o_stride * (N - 3)] * delta[N - 3]) / alpha[N - 2];

      alpha[N - 1] = diag[d_stride * (N - 1)] - sum - alpha[(N - 2)] * gamma[N - 2] * gamma[N - 2];

      /* update */
      z[0] = b[0];
      for (i = 1; i < N - 1; i++)
        {
          z[i] = b[b_stride * i] - z[i - 1] * gamma[i - 1];
        }
      sum = 0.0;
      for (i = 0; i < N - 2; i++)
        {
          sum += delta[i] * z[i];
        }
      z[N - 1] = b[b_stride * (N - 1)] - sum - gamma[N - 2] * z[N - 2];
      for (i = 0; i < N; i++)
        {
          c[i] = z[i] / alpha[i];
        }

      /* backsubstitution */
      x[x_stride * (N - 1)] = c[N - 1];
      x[x_stride * (N - 2)] = c[N - 2] - gamma[N - 2] * x[x_stride * (N - 1)];
      if (N >= 3)
        {
          for (i = N - 3, j = 0; j <= N - 3; j++, i--)
            {
              x[x_stride * i] = c[i] - gamma[i] * x[x_stride * (i + 1)] - delta[i] * x[x_stride * (N - 1)];
            }
        }

      status = GSL_SUCCESS;
    }

  if (z != 0)
    free (z);
  if (c != 0)
    free (c);
  if (alpha != 0)
    free (alpha);
  if (gamma != 0)
    free (gamma);
  if (delta != 0)
    free (delta);

  return status;
}

/* solve following system w/o the corner elements and then use
 * Sherman-Morrison formula to compensate for them
 *
 *        diag[0]  abovediag[0]             0   .....  belowdiag[N-1]
 *   belowdiag[0]       diag[1]  abovediag[1]   .....
 *              0  belowdiag[1]       diag[2]
 *              0             0  belowdiag[2]   .....
 *            ...           ...
 * abovediag[N-1]           ...
 */
static
int solve_cyc_tridiag_nonsym(
  const double diag[], size_t d_stride,
  const double abovediag[], size_t a_stride,
  const double belowdiag[], size_t b_stride,
  const double rhs[], size_t r_stride,
  double x[], size_t x_stride,
  size_t N)
{
  int status;
  double *alpha = (double *) malloc (N * sizeof (double));
  double *zb = (double *) malloc (N * sizeof (double));
  double *zu = (double *) malloc (N * sizeof (double));
  double *w = (double *) malloc (N * sizeof (double));
  double beta;

  if (alpha == 0 || zb == 0 || zu == 0 || w == 0)
    {
      status = GSL_ENOMEM;
    }
  else
    {
      /* Bidiagonalization (eliminating belowdiag)
         & rhs update
         diag' = alpha
         rhs' = zb
         rhs' for Aq=u is zu
       */
      zb[0] = rhs[0];
      if (diag[0] != 0) beta = -diag[0]; else beta = 1;
      {
        const double q = 1 - abovediag[0]*belowdiag[0]/(diag[0]*diag[d_stride]);
        if (fabs(q/beta) > 0.5 && fabs(q/beta) < 2) {
          beta *= (fabs(q/beta) < 1) ? 0.5 : 2;
        }
      }
      zu[0] = beta;
      alpha[0] = diag[0] - beta;

      {
        size_t i;
        for (i = 1; i+1 < N; i++)
        {
          const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
          alpha[i] = diag[d_stride*i] - t*abovediag[a_stride*(i - 1)];
          zb[i] = rhs[r_stride*i] - t*zb[i-1];
          zu[i] = -t*zu[i-1];
          /* FIXME!!! */
          if (alpha[i] == 0) {
            status = GSL_EZERODIV;
            goto solve_cyc_tridiag_nonsym_END;
          }
        }
      }

      {
        const size_t i = N-1;
        const double t = belowdiag[b_stride*(i - 1)]/alpha[i-1];
        alpha[i] = diag[d_stride*i]
                   - abovediag[a_stride*i]*belowdiag[b_stride*i]/beta
                   - t*abovediag[a_stride*(i - 1)];
        zb[i] = rhs[r_stride*i] - t*zb[i-1];
        zu[i] = abovediag[a_stride*i] - t*zu[i-1];
        /* FIXME!!! */
        if (alpha[i] == 0) {
          status = GSL_EZERODIV;
          goto solve_cyc_tridiag_nonsym_END;
        }
      }

      /* backsubstitution */
      {
        size_t i, j;
        w[N-1] = zu[N-1]/alpha[N-1];
        x[N-1] = zb[N-1]/alpha[N-1];
        for (i = N - 2, j = 0; j <= N - 2; j++, i--)
          {
            w[i] = (zu[i] - abovediag[a_stride*i] * w[i+1])/alpha[i];
            x[i*x_stride] = (zb[i] - abovediag[a_stride*i] * x[x_stride*(i + 1)])/alpha[i];
          }
      }

      /* Sherman-Morrison */
      {
        const double vw = w[0] + belowdiag[b_stride*(N - 1)]/beta * w[N-1];
        const double vx = x[0] + belowdiag[b_stride*(N - 1)]/beta * x[x_stride*(N - 1)];
        /* FIXME!!! */
        if (vw + 1 == 0) {
          status = GSL_EZERODIV;
          goto solve_cyc_tridiag_nonsym_END;
        }

        {
          size_t i;
          for (i = 0; i < N; i++)
            x[i] -= vx/(1 + vw)*w[i];
        }
      }

      status = GSL_SUCCESS;
    }

solve_cyc_tridiag_nonsym_END:
  if (zb != 0)
    free (zb);
  if (zu != 0)
    free (zu);
  if (w != 0)
    free (w);
  if (alpha != 0)
    free (alpha);

  return status;
}

int
gsl_linalg_solve_symm_tridiag(
  const gsl_vector * diag,
  const gsl_vector * offdiag,
  const gsl_vector * rhs,
  gsl_vector * solution)
{
  if(diag->size != rhs->size)
    {
      GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN);
    }
  else if (offdiag->size != rhs->size-1)
    {
      GSL_ERROR ("size of offdiag must match rhs-1", GSL_EBADLEN);
    }
  else if (solution->size != rhs->size)
    {
      GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN);
    }
  else
    {
      return solve_tridiag(diag->data, diag->stride,
                           offdiag->data, offdiag->stride,
                           rhs->data, rhs->stride,
                           solution->data, solution->stride,
                           diag->size);
    }
}

int
gsl_linalg_solve_tridiag(
  const gsl_vector * diag,
  const gsl_vector * abovediag,
  const gsl_vector * belowdiag,
  const gsl_vector * rhs,
  gsl_vector * solution)
{
  if(diag->size != rhs->size)
    {
      GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN);
    }
  else if (abovediag->size != rhs->size-1)
    {
      GSL_ERROR ("size of abovediag must match rhs-1", GSL_EBADLEN);
    }
  else if (belowdiag->size != rhs->size-1)
    {
      GSL_ERROR ("size of belowdiag must match rhs-1", GSL_EBADLEN);
    }
  else if (solution->size != rhs->size)
    {
      GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN);
    }
  else
    {
      return solve_tridiag_nonsym(diag->data, diag->stride,
                                  abovediag->data, abovediag->stride,
                                  belowdiag->data, belowdiag->stride,
                                  rhs->data, rhs->stride,
                                  solution->data, solution->stride,
                                  diag->size);
    }
}

int
gsl_linalg_solve_symm_cyc_tridiag(
  const gsl_vector * diag,
  const gsl_vector * offdiag,
  const gsl_vector * rhs,
  gsl_vector * solution)
{
  if(diag->size != rhs->size)
    {
      GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN);
    }
  else if (offdiag->size != rhs->size)
    {
      GSL_ERROR ("size of offdiag must match rhs", GSL_EBADLEN);
    }
  else if (solution->size != rhs->size)
    {
      GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN);
    }
  else if (diag->size < 3)
    {
      GSL_ERROR ("size of cyclic system must be 3 or more", GSL_EBADLEN);
    }
  else
    {
      return solve_cyc_tridiag(diag->data, diag->stride,
                               offdiag->data, offdiag->stride,
                               rhs->data, rhs->stride,
                               solution->data, solution->stride,
                               diag->size);
    }
}

int
gsl_linalg_solve_cyc_tridiag(
  const gsl_vector * diag,
  const gsl_vector * abovediag,
  const gsl_vector * belowdiag,
  const gsl_vector * rhs,
  gsl_vector * solution)
{
  if(diag->size != rhs->size)
    {
      GSL_ERROR ("size of diag must match rhs", GSL_EBADLEN);
    }
  else if (abovediag->size != rhs->size)
    {
      GSL_ERROR ("size of abovediag must match rhs", GSL_EBADLEN);
    }
  else if (belowdiag->size != rhs->size)
    {
      GSL_ERROR ("size of belowdiag must match rhs", GSL_EBADLEN);
    }
  else if (solution->size != rhs->size)
    {
      GSL_ERROR ("size of solution must match rhs", GSL_EBADLEN);
    }
  else if (diag->size < 3)
    {
      GSL_ERROR ("size of cyclic system must be 3 or more", GSL_EBADLEN);
    }
  else
    {
      return solve_cyc_tridiag_nonsym(diag->data, diag->stride,
                                      abovediag->data, abovediag->stride,
                                      belowdiag->data, belowdiag->stride,
                                      rhs->data, rhs->stride,
                                      solution->data, solution->stride,
                                      diag->size);
    }
}


#include <stdio.h>
#include <math.h>
#include <gsl/gsl_sort.h>
#include <gsl/gsl_wavelet.h>

int
main (int argc, char **argv)
{
  (void)(argc); /* avoid unused parameter warning */
  int i, n = 256, nc = 20;
  double *orig_data = malloc (n * sizeof (double));
  double *data = malloc (n * sizeof (double));
  double *abscoeff = malloc (n * sizeof (double));
  size_t *p = malloc (n * sizeof (size_t));

  FILE * f;
  gsl_wavelet *w;
  gsl_wavelet_workspace *work;

  w = gsl_wavelet_alloc (gsl_wavelet_daubechies, 4);
  work = gsl_wavelet_workspace_alloc (n);

  f = fopen (argv[1], "r");
  for (i = 0; i < n; i++)
    {
      fscanf (f, "%lg", &orig_data[i]);
      data[i] = orig_data[i];
    }
  fclose (f);

  gsl_wavelet_transform_forward (w, data, 1, n, work);

  for (i = 0; i < n; i++)
    {
      abscoeff[i] = fabs (data[i]);
    }

  gsl_sort_index (p, abscoeff, 1, n);

  for (i = 0; (i + nc) < n; i++)
    data[p[i]] = 0;

  gsl_wavelet_transform_inverse (w, data, 1, n, work);

  for (i = 0; i < n; i++)
    {
      printf ("%g %g\n", orig_data[i], data[i]);
    }

  gsl_wavelet_free (w);
  gsl_wavelet_workspace_free (work);

  free (data);
  free (orig_data);
  free (abscoeff);
  free (p);
  return 0;
}


#include <stdlib.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_monte.h>
#include <gsl/gsl_monte_plain.h>
#include <gsl/gsl_monte_miser.h>
#include <gsl/gsl_monte_vegas.h>

/* Computation of the integral,

      I = int (dx dy dz)/(2pi)^3  1/(1-cos(x)cos(y)cos(z))

   over (-pi,-pi,-pi) to (+pi, +pi, +pi).  The exact answer
   is Gamma(1/4)^4/(4 pi^3).  This example is taken from
   C.Itzykson, J.M.Drouffe, "Statistical Field Theory -
   Volume 1", Section 1.1, p21, which cites the original
   paper M.L.Glasser, I.J.Zucker, Proc.Natl.Acad.Sci.USA 74
   1800 (1977) */

/* For simplicity we compute the integral over the region
   (0,0,0) -> (pi,pi,pi) and multiply by 8 */

double exact = 1.3932039296856768591842462603255;

double
g (double *k, size_t dim, void *params)
{
  double A = 1.0 / (M_PI * M_PI * M_PI);
  return A / (1.0 - cos (k[0]) * cos (k[1]) * cos (k[2]));
}

void
display_results (char *title, double result, double error)
{
  printf ("%s ==================\n", title);
  printf ("result = % .6f\n", result);
  printf ("sigma  = % .6f\n", error);
  printf ("exact  = % .6f\n", exact);
  printf ("error  = % .6f = %.2g sigma\n", result - exact,
          fabs (result - exact) / error);
}

int
main (void)
{
  double res, err;

  double xl[3] = { 0, 0, 0 };
  double xu[3] = { M_PI, M_PI, M_PI };

  const gsl_rng_type *T;
  gsl_rng *r;

  gsl_monte_function G = { &g, 3, 0 };

  size_t calls = 500000;

  gsl_rng_env_setup ();

  T = gsl_rng_default;
  r = gsl_rng_alloc (T);

  {
    gsl_monte_plain_state *s = gsl_monte_plain_alloc (3);
    gsl_monte_plain_integrate (&G, xl, xu, 3, calls, r, s,
                               &res, &err);
    gsl_monte_plain_free (s);

    display_results ("plain", res, err);
  }

  {
    gsl_monte_miser_state *s = gsl_monte_miser_alloc (3);
    gsl_monte_miser_integrate (&G, xl, xu, 3, calls, r, s,
                               &res, &err);
    gsl_monte_miser_free (s);

    display_results ("miser", res, err);
  }

  {
    gsl_monte_vegas_state *s = gsl_monte_vegas_alloc (3);

    gsl_monte_vegas_integrate (&G, xl, xu, 3, 10000, r, s,
                               &res, &err);
    display_results ("vegas warm-up", res, err);

    printf ("converging...\n");

    do
      {
        gsl_monte_vegas_integrate (&G, xl, xu, 3, calls/5, r, s,
                                   &res, &err);
        printf ("result = % .6f sigma = % .6f "
                "chisq/dof = %.1f\n", res, err, gsl_monte_vegas_chisq (s));
      }
    while (fabs (gsl_monte_vegas_chisq (s) - 1.0) > 0.5);

    display_results ("vegas final", res, err);

    gsl_monte_vegas_free (s);
  }

  gsl_rng_free (r);

  return 0;
}


/* linalg/test_cholesky.c
 *
 * Copyright (C) 2016 Patrick Alken
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_test.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_ieee_utils.h>
#include <gsl/gsl_permute_vector.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_permutation.h>

static int test_choleskyc_decomp_eps(const gsl_matrix_complex * m, const double eps, const char * desc);
static int test_choleskyc_decomp(gsl_rng * r);
static int test_choleskyc_invert(gsl_rng * r);

static int
test_choleskyc_decomp_eps(const gsl_matrix_complex * m, const double eps, const char * desc)
{
  int s = 0;
  const size_t M = m->size1;
  const size_t N = m->size2;
  size_t i, j;

  gsl_matrix_complex * v  = gsl_matrix_complex_alloc(M,N);
  gsl_matrix_complex * a  = gsl_matrix_complex_alloc(M,N);
  gsl_matrix_complex * l  = gsl_matrix_complex_alloc(M,N);
  gsl_matrix_complex * lh  = gsl_matrix_complex_alloc(N,N);

  gsl_matrix_complex_memcpy(v, m);
  gsl_matrix_complex_set_zero(l);
  gsl_matrix_complex_set_zero(lh);

  s += gsl_linalg_complex_cholesky_decomp(v);

  /* Compute L L^H */

  for (i = 0; i < N ; i++)
    {
      for (j = 0; j <= i; j++)
        {
          gsl_complex vij = gsl_matrix_complex_get(v, i, j);
          gsl_matrix_complex_set (l, i, j, vij);
          gsl_matrix_complex_set (lh, j, i, gsl_complex_conjugate(vij));
        }
    }

  /* compute a = l lh */
  gsl_blas_zgemm (CblasNoTrans,
                  CblasNoTrans,
                  GSL_COMPLEX_ONE,
                  l,
                  lh,
                  GSL_COMPLEX_ZERO,
                  a);

  for (i = 0; i < M; i++)
    {
      for (j = 0; j < N; j++)
        {
          gsl_complex aij = gsl_matrix_complex_get(a, i, j);
          gsl_complex mij = gsl_matrix_complex_get(m, i, j);

          gsl_test_rel(GSL_REAL(aij), GSL_REAL(mij), eps,
                       "%s: real (%3lu,%3lu)[%lu,%lu]: %22.18g   %22.18g\n",
                       desc, N, N, i, j, GSL_REAL(aij), GSL_REAL(mij));

          gsl_test_rel(GSL_IMAG(aij), GSL_IMAG(mij), eps,
                       "%s: imag (%3lu,%3lu)[%lu,%lu]: %22.18g   %22.18g\n",
                       desc, N, N, i, j, GSL_IMAG(aij), GSL_IMAG(mij));
        }
    }

  gsl_matrix_complex_free(v);
  gsl_matrix_complex_free(a);
  gsl_matrix_complex_free(l);
  gsl_matrix_complex_free(lh);

  return s;
}

static int
test_choleskyc_decomp(gsl_rng * r)
{
  int s = 0;
  const size_t N_max = 50;
  size_t N;

  for (N = 1; N <= N_max; ++N)
    {
      gsl_matrix_complex * m = gsl_matrix_complex_alloc(N, N);

      create_posdef_complex_matrix(m, r);
      test_choleskyc_decomp_eps(m, 1.0e6 * N * GSL_DBL_EPSILON, "cholesky_complex_decomp random");

      gsl_matrix_complex_free(m);
    }

  return s;
}

static int
test_choleskyc_invert_eps(const gsl_matrix_complex * m, const double eps, const char * desc)
{
  int s = 0;
  const size_t N = m->size1;
  size_t i, j;
  gsl_matrix_complex * v  = gsl_matrix_complex_alloc(N, N);
  gsl_matrix_complex * c  = gsl_matrix_complex_alloc(N, N);

  gsl_matrix_complex_memcpy(v, m);

  s += gsl_linalg_complex_cholesky_decomp(v);
  s += gsl_linalg_complex_cholesky_invert(v);

  gsl_blas_zhemm(CblasLeft, CblasUpper, GSL_COMPLEX_ONE, m, v, GSL_COMPLEX_ZERO, c);

  /* c should be the identity matrix */
  for (i = 0; i < N; ++i)
    {
      for (j = 0; j < N; ++j)
        {
          gsl_complex cij = gsl_matrix_complex_get(c, i, j);
          double expected = (i == j) ? 1.0 : 0.0;

          /* check real part */
          gsl_test_rel(GSL_REAL(cij), expected, eps,
                       "%s: real (%3lu,%3lu)[%lu,%lu]: %22.18g   %22.18g\n",
                       desc, N, N, i, j, GSL_REAL(cij), expected);

          /* check imaginary part */
          gsl_test_rel(GSL_IMAG(cij), 0.0, eps,
                       "%s: imag (%3lu,%3lu)[%lu,%lu]: %22.18g   %22.18g\n",
                       desc, N, N, i, j, GSL_IMAG(cij), 0.0);
        }
    }

  gsl_matrix_complex_free(v);
  gsl_matrix_complex_free(c);

  return s;
}

static int
test_choleskyc_invert(gsl_rng * r)
{
  int s = 0;
  const size_t N_max = 50;
  size_t N;

  for (N = 1; N <= N_max; ++N)
    {
      gsl_matrix_complex * m = gsl_matrix_complex_alloc(N, N);

      create_posdef_complex_matrix(m, r);
      test_choleskyc_invert_eps(m, 32.0 * N * GSL_DBL_EPSILON, "cholesky_complex_invert random");

      gsl_matrix_complex_free(m);
    }

  return s;
}


// Author:  Adam J. Robinson
// Summary: This file contains definition for the integral that
//          characterizes the interaction between nuclei and electrons,
//          as defined in the mathematical documentation.
// Performs the Electron Nuclei integral for the given
// Gaussian wavefunction.

#include <gsl/gsl_math.h>
#include <gsl/gsl_monte.h>
#include <gsl/gsl_monte_vegas.h>
#include <gsl/gsl_errno.h>

// Can't just include "gaussian.h", it will create a circular
// reference.
class GaussianWFN;

#ifndef INTEGRAL_EN
#define INTEGRAL_EN

class ENIntegrator {

public:

	gsl_monte_vegas_state * state;

	double * lowerBounds;
	double * upperBounds;
	GaussianWFN * wavefn;

	int    maxCalls;
	double width;
	double epsilon;

	// Initializes an integral calculator.
	//     fn     = The wavefunction that the computation is being carried
	//              out for.
	//     width  = The number of half width half maxes to
	//              limit the integral range to. Monte Carlo
	//              integration does not work for bounds at infinity.
	//              typically, 3 < width < 6
	//
	//     ncalls = The maximum number of calls to the integrand function
	//              that the integrator is permitted to make in order to
	//              calculate the integral. Higher values are slower and
	//              more accurate.
	ENIntegrator(GaussianWFN * fn, double width, int ncalls);

	~ENIntegrator();

	// These are set temporarily before an integral is performed.
	double A1;
	double A2;
	double A3;

	double s1;
	double s2;
	double s3;

	double R1;
	double R2;
	double R3;

	// Used to set the number of calls to the integrand that can be made.
	void setMaxCalls(int ncalls);

	// Given the three indices that define the integral being calculated,
	// sets the lowerBounds and upperBounds members of the class to
	// values appropriate for the given width, nuclei location, gaussian
	// center and gaussian width.
	void setBounds(int iu, int w, int l);

	double Integrate(int iu, int w, int l, double * error);

private:

	static double integrand(double * x, size_t dim, void * params);

};

#endif


#include <stdio.h>
#include <math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_fft_complex.h>

#define REAL(z,i) ((z)[2*(i)])
#define IMAG(z,i) ((z)[2*(i)+1])

int
main (void)
{
  int i; double data[2*128];

  for (i = 0; i < 128; i++)
    {
       REAL(data,i) = 0.0; IMAG(data,i) = 0.0;
    }

  REAL(data,0) = 1.0;

  for (i = 1; i <= 10; i++)
    {
       REAL(data,i) = REAL(data,128-i) = 1.0;
    }

  for (i = 0; i < 128; i++)
    {
      printf ("%d %e %e\n", i,
              REAL(data,i), IMAG(data,i));
    }
  printf ("\n");

  gsl_fft_complex_radix2_forward (data, 1, 128);

  for (i = 0; i < 128; i++)
    {
      printf ("%d %e %e\n", i,
              REAL(data,i)/sqrt(128),
              IMAG(data,i)/sqrt(128));
    }

  return 0;
}


/* cdf/cdf_beta.c
 *
 * Copyright (C) 2003 Brian Gough.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307, USA.
 */

#include <config.h>
#include <math.h>
#include <gsl/gsl_cdf.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_math.h>

#include "beta_inc.c"

double
gsl_cdf_beta_P (const double x, const double a, const double b)
{
  double P;

  if (x <= 0.0 )
    {
      return 0.0;
    }

  if ( x >= 1.0 )
    {
      return 1.0;
    }

  P = beta_inc_AXPY (1.0, 0.0, a, b, x);

  return P;
}

double
gsl_cdf_beta_Q (const double x, const double a, const double b)
{
  double Q;

  if ( x >= 1.0)
    {
      return 0.0;
    }

  if ( x <= 0.0 )
    {
      return 1.0;
    }

  Q = beta_inc_AXPY (-1.0, 1.0, a, b, x);

  return Q;
}


#include "benchmark.hpp"
#include <lapacke.h>

int svd(double *A, int m, int n, double *U, double *s, double *V_t) {
  const int lda = n;
  const int ldu = m;
  const int ldvt = n;
  const char jobu = 'A';
  const char jobvt = 'A';
  const int superb_size = (m < n) ? m : n;
  double *superb = malloc(sizeof(double) * (superb_size - 1));
  lapack_int retval = LAPACKE_dgesvd(LAPACK_ROW_MAJOR,
                                     jobu,
                                     jobvt,
                                     m,
                                     n,
                                     A,
                                     lda,
                                     s,
                                     U,
                                     ldu,
                                     V_t,
                                     ldvt,
                                     superb);
  if (retval > 0) {
    return -1;
  }

  /* Clean up */
  free(superb);

  return 0;
}

int main() {
  for (size_t k = 10; k <= 1000; k += 10) {
    size_t m = k;
    double *A = create_random_sq_matrix(m);
    double *U = malloc(sizeof(double) * m * m);
    double *d = malloc(sizeof(double) * m);
    double *V_t = malloc(sizeof(double) * m * m);

    sleep(0.1);
    struct timespec t = tic();
    svd(A, m, m, U, d, V_t);
    printf("matrix_size: %ld\t: dgesvd: %fs\n", m, toc(&t));
    free(A);
    free(U);
    free(d);
    free(V_t);
  }

  return 0;
}


/*#include <fftw.h>*/
#include <fftw3.h>
#include <stdio.h>
#include <stdlib.h>
#define N 16
main()
{
     int i;
     fftw_complex in[N], out[N];
     float fact;
     fftw_plan p,p2;
printf(" stuff in data\n");
     for (i=0;i<N;i++) {
/*      in[i].re=(i*i); in[i].im=1; */
     	in[i][0]=(i*i); in[i][1]=1;
     }
printf(" create plans\n");
     p  = (fftw_plan)fftw_plan_dft_1d(N,in,out,FFTW_FORWARD,FFTW_ESTIMATE);
     p2 = (fftw_plan)fftw_plan_dft_1d(N,out,in,FFTW_BACKWARD,FFTW_ESTIMATE);
printf(" do it\n");
     fftw_execute(p);
     for (i=0;i<N;i++) {
/*	printf("%12.4f %12.4f\n",out[i].re,out[i].im); */
  	printf("%12.4f %12.4f\n",out[i][0],out[i][1]);
     }
printf(" \n");
printf(" undo it\n");
     fftw_execute(p2);
     fact=1.0/(float)N;
     for (i=0;i<N;i++) {
/*	printf("%10.2f %10.2f\n",in[i].re*fact,in[i].im*fact); */
	printf("%10.2f %10.2f\n",in[i][0]*fact,in[i][1]*fact);
     }
printf(" clean up\n");
     fftw_destroy_plan(p);
     fftw_destroy_plan(p2);
}