/**
 * File: trfit_utils.c
 *
 */
#include "trfit_utils.h"
#include <stdio.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_sort_vector.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_statistics.h>
#include "aXe_grism.h"
#include "aXe_utils.h"
#include "spce_sect.h"
#include "spce_fitting.h"
#include "spce_is_in.h"
#include "spc_back.h"
#include "spce_pathlength.h"
#include "lmmin.h"
#include "lm_eval.h"

#define MIN(x,y) (((x)<(y))?(x):(y))
#define MAX(x,y) (((x)>(y))?(x):(y))

int gauss_f(const gsl_vector * x, void *params, gsl_vector * f)
{
  int ndata      = ((struct function_data *)params)->n;
  double *x_data = ((struct function_data *)params)->x;
  double *y_data = ((struct function_data *)params)->y;
  //double *e_data = ((struct function_data *)params)->sig;

  double a  = gsl_vector_get (x, 0);
  double b  = gsl_vector_get (x, 1);
  double c  = gsl_vector_get (x, 2);
  double x0 = gsl_vector_get (x, 3);

  double Yi = 0.0;

  int i;

  for (i = 0; i < ndata; i++)
    {
      /* Model Yi = a * exp(-b*(Xi-X0) + c */
      Yi = a * exp (-b * (x_data[i]-x0)*(x_data[i]-x0)) + c;
      //      gsl_vector_set (f, i, (Yi - y_data[i])/e_data[i]);
      gsl_vector_set (f, i, Yi - y_data[i]);
      //      fprintf(stderr, "Yi: %e, f: %e\n", Yi, (Yi - y_data[i])/e_data[i]);
    }

  return GSL_SUCCESS;
}

int
gauss_df(const gsl_vector * x, void *params,
	 gsl_matrix * J)
{
  int ndata      = ((struct function_data *)params)->n;
  double *x_data = ((struct function_data *)params)->x;
  //double *y_data = ((struct function_data *)params)->y;
  //double *e_data = ((struct function_data *)params)->sig;

  double a  = gsl_vector_get (x, 0);
  double b  = gsl_vector_get (x, 1);
  //double c  = gsl_vector_get (x, 2);
  double x0 = gsl_vector_get (x, 3);

  int i;
  double value;
  double xdiff;

  for (i = 0; i < ndata; i++)
    {
      /* Jacobian matrix J(i,j) = dfi / dxj, */
      /* where fi = (Yi - yi)/sigma[i],      */
      /* Model Yi = a * exp(-b*(Xi-X0) + c   */
      /* and the xj are the parameters (a,b,c,x0) */

      xdiff = x_data[i]-x0;

      value = exp(-b*(xdiff)*(xdiff));

      gsl_matrix_set (J, i, 0, value);
      gsl_matrix_set (J, i, 1, -a*(xdiff)*(xdiff)*value);
      gsl_matrix_set (J, i, 2, 1.0);
      gsl_matrix_set (J, i, 3,a*b*value*2*xdiff);
    }
  return GSL_SUCCESS;
}

int
gauss_fdf (const gsl_vector * x, void *params, gsl_vector *f, gsl_matrix *J)
{
  gauss_f(x, params, f);
  gauss_df(x, params, J);

  return GSL_SUCCESS;
}

/**
 * Function: fit_beamtrace
 * The function determines a new trace solution for a given beam. A gaussian
 * is fitted to the pixel values around the nominal trace position.
 * A kappa-sigma-klipping algorithm eliminates fitted trace centers
 * which are off due to cosmics or similar.
 * Finally the a new trace solution is fitted to the set of trace centers
 * The new slope is directly written to the beam structure, the
 * new y-value of the reference point is returned.
 *
 * Parameters:
 * @param conf     - the aXe configuration structure
 * @param obs      - the current observation
 * @param beamID   - the ID of the current beam
 * @param act_beam - the beam to fit
 *
 * Returns:
 * @return yf - the y-value of the reference point for the fitted trace
 */

gsl_vector *
fit_beamtrace(const aperture_conf  *conf, observation *obs,
	      const int beamID, beam act_beam)
{
  //gsl_vector_int *yvec;
  gsl_vector     *fit_params;
  gsl_vector     *lin_fit;
  gsl_vector     *fit_result;
  trace_func     *tracefun;

  px_point        xborder;
  px_point        tpoint;

  fit_data       *f_data;

  double *x;
  double *y;
  double *w;

  double *trace;

  double yf, yf_err;

  int i;
  int index;

  // This is the return result
  fit_result = gsl_vector_alloc(5);
  gsl_vector_set(fit_result, 0, 0);
  gsl_vector_set(fit_result, 1, 0);
  gsl_vector_set(fit_result, 2, 0);
  gsl_vector_set(fit_result, 3, 0);
  gsl_vector_set(fit_result, 4, 0);

  // define the beam and the trace function
  tracefun = act_beam.spec_trace;
  trace = (double *)(tracefun->data);

  // If this beam's ignore flag is set to 1 then do nothing
  if (act_beam.ignore == 1)
    return fit_result;

  // determine the start and end point in x
  //xborder = get_fit_xrange(conf, obs, beamID, act_beam);
  xborder = get_fit_xrange(conf, obs, act_beam);

  // allocate arrays for the fitting
  x = (double*)malloc((xborder.y-xborder.x+1)*sizeof(double));
  y = (double*)malloc((xborder.y-xborder.x+1)*sizeof(double));
  w = (double*)malloc((xborder.y-xborder.x+1)*sizeof(double));

  // Loop over all columns
  index = 0;
  for (i = xborder.x; i < xborder.y; i++)
    //for (i=130; i < 150; i++)
    {
      // determine the pixel which is
      // closest to the nominal trace position
      tpoint.x = i;
      tpoint.y = (int)floor(tracefun->func((double)i-act_beam.refpoint.x,
					   tracefun->data)
			    + act_beam.refpoint.y+0.5);

      // get the data to be fitted
      // in the current column
      f_data = get_fitdata(obs, N_COLUMNS_FIT, tpoint);
      /*
      if (tpoint.x > 130 && tpoint.x < 150)
	{
	  fprintf(stdout, "x: %i\n", tpoint.x);
	  print_fit_data(f_data);
	  fprintf(stdout, "\n\n");
	}
      if (tpoint.x == 135)
      {*/
      //fprintf(stdout, "x: %i\n", tpoint.x);
      //print_fit_data(f_data);
      //fprintf(stdout, "\n\n");
	  // fit the gaussian to the data
	  fit_params = fit_wuttke(f_data);
	  /*	}
      else{
	fit_params = fit_wuttke_talk(f_data);
	}*/
      // check whether the fit was successful
      if (gsl_vector_get(fit_params, 4) == 1)
	{
	  // transfer the results of the fit
	  // to this column in the vector
	  // which contains all fit results
	  x[index] = (double)tpoint.x;
	  y[index] = gsl_vector_get(fit_params, 3);
	  w[index] = 1.0;
	  index++;
	}

      // freem memory
      free_fit_data(f_data);
      gsl_vector_free(fit_params);
    }

  //for (i=0; i < index; i++)
  //  fprintf(stdout, "%f %f %f\n", x[i], y[i], w[i]);

  // do a kappa-sigma klipping on
  // the array with the trace locations
  // to improve the robustness of the result
  comp_kappasigma_interp(x, y, w, index, 1, N_KAPPASIG_ITER,
			 N_KAPPASIG_SIG, obs, 0);

  // make a linear fit to the trace positions
  lin_fit = det_vector_linear(x, y, w, index, 0);
  //for (i=0; i < index; i++)
  //fprintf(stdout, "%f %f %f\n", x[i], y[i], w[i]);

  // compute the y-position of the beam reference position
  // according to the new trace solution
  gsl_fit_linear_est (act_beam.refpoint.x-gsl_vector_get(lin_fit, 0), gsl_vector_get(lin_fit, 1),
		      gsl_vector_get(lin_fit, 2), gsl_vector_get(lin_fit, 3),
		      gsl_vector_get(lin_fit, 4), gsl_vector_get(lin_fit, 5),
		      &yf, &yf_err);

  gsl_vector_set(fit_result, 0, yf);
  gsl_vector_set(fit_result, 1, yf_err);
  gsl_vector_set(fit_result, 2, gsl_vector_get(lin_fit, 2));
  gsl_vector_set(fit_result, 3, sqrt(gsl_vector_get(lin_fit, 5)));
  gsl_vector_set(fit_result, 4, gsl_vector_get(lin_fit, 6));

  fprintf(stdout, "\nFitting result XXX: xpos = %f , ypos = %f +- %f , slope = %f +- %f , chi^2 = %f, x_pivot = %f, y_abs = %f\n",
	  act_beam.refpoint.x, gsl_vector_get(fit_result, 0), gsl_vector_get(fit_result, 1),
	  gsl_vector_get(fit_result, 2), gsl_vector_get(fit_result, 3), gsl_vector_get(lin_fit, 6),
	  gsl_vector_get(lin_fit, 0), gsl_vector_get(lin_fit, 1));

  // copy the slope of the new trace solution
  // to the according position in the beam description
  trace[1] = gsl_vector_get(lin_fit, 2);
  trace[2] = sqrt(gsl_vector_get(lin_fit, 5));

  // free the memory
  gsl_vector_free(lin_fit);
  free(x);
  free(y);
  free(w);

  // return the new y-position of
  // the reference point
  //  return yf;
  return fit_result;
}

/**
 * Function: gagauss
 * The function computes and returns the value
 * of a gauss function y = a * exp(-b*(x-c)^2) - d
 * at a position x.
 *
 * Parameters:
 * @param x      - the x-poition to evaluate the function
 * @param params - the function parameters
 *
 * Returns:
 * @return - the function value
 */
double
gagauss(const double x, const double *params)
{
  // just compute and return the result
  return (params[0] * exp (-params[1] * (x-params[3])*(x-params[3])) + params[2]);
}

/**
 * Function: comp_shift
 *
 * Returns:
 * @return - the function value
 */
double
comp_shift(const double x, const double *params, const double *fpars)
{
  double dy;
  double tmp;

  // Parameters in the original
  // notation fo W. Freudling:
  // fpars[0] = 'contrast'
  // fpars[1] = 'exp'
  // fpars[2] = 'tan_ang'
  // gpars[0] = 'shift'

  // compute the shift for the
  // x-value
  dy = x * fpars[2] + params[0];

  // compute the sin()-expression
  tmp = (sin((2.0*dy-0.5)*M_PI) + fpars[1])/2.0;

  // compute and return the whole expression
  return tmp * tmp * fpars[0] + (1.0 - fpars[0]);
}

/**
 * Function: fit_wuttke
 * Fits a gaussian to the data given in the input structure.
 * Uses a library for nn-linear fits (made by Wuttke)
 *
 * Parameters:
 * @param f_data - the fit data
 *
 * Returns:
 * @return params - the fit results
 */
gsl_vector *
fit_wuttke(const fit_data *f_data)
{
  gsl_vector *params;

  int m_dat = f_data->n_data;
  int n_p =  4;

  double p[4];

  // auxiliary settings:
  lm_control_type control;
  lm_data_type data;

  // allocate the parameter vector
  params = gsl_vector_alloc(5);

  // give a first guess
  // for the gauss parameters
  p[0] = f_data->y_values[f_data->n_data / 2];
  p[1] = 1.0;
  p[2] = (f_data->y_values[f_data->n_data-1]-f_data->y_values[0])/2.0;
  p[3] = f_data->x_values[0] + (f_data->x_values[f_data->n_data-1]-f_data->x_values[0])/2.0;

  // initialize the fit
  lm_initialize_control( &control );

  // define the parameters for the fitting
  data.user_func = gagauss;
  data.user_t = f_data->x_values;
  data.user_y = f_data->y_values;

  // perform the fit:
  lm_minimize( m_dat, n_p, p, lm_evaluate_default, lm_print_nothing,
	       &data, &control );

  //fprintf(stdout, "Result: %i, amp: %f, width: %f, const:  %f, pos: %f\n", control.info, p[0], p[1], p[2], p[3]);

  // copy the fit results to the output structure
  gsl_vector_set(params, 0, p[0]);
  gsl_vector_set(params, 1, p[1]);
  gsl_vector_set(params, 2, p[2]);
  gsl_vector_set(params, 3, p[3]);
  gsl_vector_set(params, 4, (double)control.info);

  // return the output structure
  return params;
}
gsl_vector *
fit_wuttke_talk(const fit_data *f_data)
{
  gsl_vector *params;

  int m_dat = f_data->n_data;
  int n_p =  4;

  double p[4];

  // auxiliary settings:
  lm_control_type control;
  lm_data_type data;

  // allocate the parameter vector
  params = gsl_vector_alloc(5);

  // give a first guess
  // for the gauss parameters
  p[0] = 1.0;
  p[1] = 1.0;
  p[2] = 0.0;
  p[3] = f_data->x_values[0] + (f_data->x_values[f_data->n_data-1]-f_data->x_values[0])/2.0;

  // initialize the fit
  lm_initialize_control( &control );

  // define the parameters for the fitting
  data.user_func = gagauss;
  data.user_t = f_data->x_values;
  data.user_y = f_data->y_values;

  // perform the fit:
  lm_minimize( m_dat, n_p, p, lm_evaluate_default, lm_print_default,
	       &data, &control );

  // copy the fit results to the output structure
  gsl_vector_set(params, 0, p[0]);
  gsl_vector_set(params, 1, p[1]);
  gsl_vector_set(params, 2, p[2]);
  gsl_vector_set(params, 3, p[3]);
  gsl_vector_set(params, 4, (double)control.info);

  // return the output structure
  return params;
}

d_point
find_grav_center(const fit_data *f_data)
{
  d_point ret={0.0,0.0};

  int i=0;

  double sum    = 0.0;
  double w_sum    = 0.0;
  double weight = 0.0;

  for (i=0; i < f_data->n_data; i++)
    {
      weight = fabs(f_data->y_values[i]/f_data->e_values[i]);
      sum   += weight * f_data->x_values[i];
      w_sum += weight;
    }

  ret.x = sum/w_sum;
  ret.y = weight;

  return ret;
}

/*
 * Function: get_fit_xrange
 * The function determines and returns the mininmum
 * and the maximum x-values for a beam.
 *
 * Parameters:
 * @param conf     - the aXe configuration structure
 * @param obs      - the current observation
 * @param beamID   - the ID of the current beam
 * @param act_beam - the beam to fit
 *
 * Returns:
 * @return ret - x_min and x_max of the beam
 */
px_point
get_fit_xrange(const aperture_conf  *conf, const observation *obs,
	       beam act_beam)
  {
    px_point ret;

    // compute one extremum
    ret.x = (int)floor(act_beam.refpoint.x
		       + conf->beam[act_beam.ID].offset.dx0 +.5);

    // compute the secund extremum
    ret.y = (int)floor(act_beam.refpoint.x
		       + conf->beam[act_beam.ID].offset.dx1 +.5);

    // limit the start and end column
    // to the image size
    ret.x = MAX(ret.x, 0);
    ret.y = MIN(ret.y, (int)obs->grism->size1);

    // return the min and the max value
    return ret;
  }

gsl_vector *
fit_function(const fit_data *f_data)
{
  gsl_vector *fit_params = gsl_vector_alloc(4);

  const gsl_multifit_fdfsolver_type *T;
  gsl_multifit_fdfsolver *s;
  gsl_multifit_function_fdf f;
  gsl_vector *x_init = gsl_vector_alloc(4);

  int status;
  //size_t i,
  size_t iter = 0;

  const size_t n = f_data->n_data;
  const size_t p = 4;

  //gsl_matrix *covar = gsl_matrix_alloc (p, p);

  struct function_data d = {f_data->n_data, f_data->x_values,
			    f_data->y_values, f_data->e_values};

  fit_params = gsl_vector_alloc(p);

  gsl_vector_set(x_init, 0, 1.0);
  gsl_vector_set(x_init, 1, 1.0);
  gsl_vector_set(x_init, 2, 0.0);
  gsl_vector_set(x_init, 3,
		 f_data->x_values[0]
		 +(f_data->x_values[f_data->n_data-1]-f_data->x_values[0])/2.0);

  f.f      = gauss_f;
  f.df     = gauss_df;
  f.fdf    = gauss_fdf;
  f.n      = n;
  f.p      = p;
  f.params = &d;

  T = gsl_multifit_fdfsolver_lmsder;
  s = gsl_multifit_fdfsolver_alloc (T, n, p);
  gsl_multifit_fdfsolver_set (s, &f, x_init);

  print_fit_state (iter, s);

  do
    {
      iter++;
      status = gsl_multifit_fdfsolver_iterate (s);

      printf ("status %i = %s\n", status, gsl_strerror (status));

      print_fit_state (iter, s);

      if (status != GSL_CONTINUE)
       	break;

      status = gsl_multifit_test_delta (s->dx, s->x,
                                        1e-12, 1e-12);
      printf ("status  a = %s\n", gsl_strerror (status));
      fprintf(stdout, "stat: %i, GSL_CONT: %i\n", status, GSL_CONTINUE);
    }
  while (status == GSL_CONTINUE && iter < 500);

  gsl_multifit_fdfsolver_free (s);
  return fit_params;
}

/*
 * Function: get_fitdata
 * The function collects the pixel values of at most np pixels
 * on both sides of the nominal trace position and stores
 * these values in an apppropriate structure.
 *
 * Parameters:
 * @param obs      - the current observation
 * @param np       - the number of pixels to sample around the nominal position
 * @param tr_point - the nominal traxe pixel
 *
 * Returns:
 * @return f_data  - the pixel data around the nominal trace position
 *
 */
fit_data *
get_fitdata(observation *obs, int np, px_point tr_point)
{
  gsl_vector_int *tmp;

  fit_data *f_data;

  int np_act=0;

  //int y_low;
  //int y_upp;

  int l_space=1;
  int u_space=1;

  int l_act;
  int u_act;

  int l_np=0;
  int u_np=0;

  int ncols=obs->grism->size2;

  int ii;
  int index;

  // allocate the vector
  tmp = gsl_vector_int_alloc(2*np+2);
  gsl_vector_int_set_all(tmp, -1);

  // limit the starting ppoint of the search
  // to values within the image dimension
  tr_point.y = MAX(0,tr_point.y);
  tr_point.y = MIN((int)obs->grism->size2,tr_point.y);

  // initialize the row numbers
  // to search up- and downwards
  l_act = tr_point.y - 1;
  u_act = tr_point.y;

  // as long as interpolation points are missing
  // and one direction, either up or down,
  // is 'open', continue searching
  while (np_act < 2*np && (l_space || u_space))
    {

      // check whether the direction
      // downwards is still open
      if (l_space)
	{
	  // if you are at the end of the frame
	  if (l_act < 0)
	    {
	      // close the direction downwards
	      l_space=0;
	    }
	  else
	    {
	      if (!isnan(gsl_matrix_get(obs->grism, tr_point.x, l_act)))
		{
		  // else store the interpolation point,
		  // do the various increments
		  gsl_vector_int_set(tmp, np_act, l_act);
		  //		  fprintf(stderr, "put in %i\n", l_act);
		  np_act++;
		  l_np++;
		}
	      l_act--;
	    }
	}

      // check whether the direction
      // upwards is still open
      if (u_space)
	{
	  // if you are at the end of the frame
	  if (u_act >= ncols)
	    {
	      // close the direction upwards
	      u_space=0;
	    }
	  else
	    {
	      if (!isnan(gsl_matrix_get(obs->grism, tr_point.x, u_act)))
		{
		  // else store the interpolation point,
		  // do the various increments
		  gsl_vector_int_set(tmp, np_act, u_act);
		  np_act++;
		  u_np++;
		}
	      u_act++;
	    }
	}
    }

  // sort the pixel indices
  gsl_sort_vector_int(tmp);

  // allocate a data structure
  f_data = alloc_fit_data(np_act);

  // fill the pixel values into the data structure
  index = 0;
  for (ii=((int)tmp->size - np_act); ii < (int)tmp->size; ii++)
    {
      f_data->x_values[index] = (double)gsl_vector_int_get(tmp, ii);
      f_data->y_values[index] = gsl_matrix_get(obs->grism, tr_point.x,
					       gsl_vector_int_get(tmp, ii));
      f_data->e_values[index] = gsl_matrix_get(obs->pixerrs, tr_point.x,
					       gsl_vector_int_get(tmp, ii));
      index++;
    }

  // release memory
  gsl_vector_int_free(tmp);

  //  return the result
  return f_data;
}

/*
 * Function: get_ipc_coldata
 * The function checks for valid pixel data on both side of the trace.
 * The maximum distance away from the trace is given as a parameter.
 * Valid data is collected and returned in a vector.
 *
 * Parameters:
 * @param img_data - the current observation
 * @param np       - the number of pixels to sample around the nominal position
 * @param tr_point - the nominal traxe pixel
 *
 * Returns:
 * @return ipc_row  - the pixel data around the nominal trace position
 *
 */
gsl_vector *
get_ipc_coldata(gsl_matrix *img_data, int np, px_point tr_point)
{
  gsl_vector *tmp;

  gsl_vector *ipc_row = NULL;

  int np_act=0;

  int y_act;

  int ncols = img_data->size2;

  int ii;

  // check whether the central tracepoint
  // is in the image
  if (tr_point.y < 0 || tr_point.y > ncols-1)
    // give back the NULL array
    return ipc_row;

  // allocate the vector
  tmp = gsl_vector_alloc(2*np+1);
  gsl_vector_set_all(tmp, -1.0);

  // set the current y-position
  y_act = tr_point.y;

  // check whether there is good data
  // at the current position
  if (!isnan(gsl_matrix_get(img_data, tr_point.x, y_act)))
    {
      // store the data point and enhance the counter
      gsl_vector_set(tmp, np_act, gsl_matrix_get(img_data, tr_point.x, y_act));
      np_act++;
    }

  // check on both sides
  // of the central tracepoint
  for (ii=1; ii <= np; ii++)
    {
      // go down
      y_act = tr_point.y - ii;

      // check whether we are still inside the image and
      // whether we have valid data
      if (y_act > -1 && !isnan(gsl_matrix_get(img_data, tr_point.x, y_act)))
	{
	  // store the data point and enhance the counter
	  gsl_vector_set(tmp, np_act, gsl_matrix_get(img_data, tr_point.x, y_act));
	  np_act++;
	}

      // go up
      y_act = tr_point.y + ii;

      // check whether we are still inside the image and
      // whether we have valid data
      if (y_act < ncols && !isnan(gsl_matrix_get(img_data, tr_point.x, y_act)))
	{
	  // store the data point and enhance the counter
	  gsl_vector_set(tmp, np_act, gsl_matrix_get(img_data, tr_point.x, y_act));
	  np_act++;
	}
    }

  // check whether good data was found
  if (np_act > 0)
    {
      // allocate the return vector
      ipc_row = gsl_vector_alloc(np_act);

      // transfer the data to the
      // return vector
      for (ii=0; ii < np_act; ii++)
	gsl_vector_set(ipc_row, ii, gsl_vector_get(tmp, ii));
    }

  // release memory
  gsl_vector_free(tmp);

  //  return the vector
  return ipc_row;
}

/*
 * Function: alloc_fit_data
 * The function allocates memory for a fit-data structure
 *
 * Parameters:
 * @param n_data - the number of points to allocate
 *
 * Returns:
 * @return f_data - the allocated structure
 */
fit_data *
alloc_fit_data(const int n_data)
{
  fit_data *f_data;

  f_data = (fit_data *)malloc(sizeof(fit_data));

  f_data->x_values = (double *)malloc(n_data * sizeof(double));
  f_data->y_values = (double *)malloc(n_data * sizeof(double));
  f_data->e_values = (double *)malloc(n_data * sizeof(double));

  f_data->n_data = n_data;

  return f_data;
}

/*
 * Function: print_fit_data
 * The function prints the content of a fit-data structure
 * onto the screen (error-out).
 *
 * Parameters:
 * @param f_data - the allocated structure
 *
 * Returns:
 * @return -
 */
void
print_fit_data(fit_data *f_data)
{
  int i;

  for (i=0; i < f_data->n_data; i++)
    {
      fprintf(stdout, "%f %f %f\n", f_data->x_values[i],
	      f_data->y_values[i], f_data->e_values[i]);
      //      fprintf(stderr, "x: %f, y: %f, err: %f\n", f_data->x_values[i],
      //	      f_data->y_values[i], f_data->e_values[i]);
    }
}

/*
 * Function: print_fit_data
 * The function releases the memory allocated in
 * a fit-data structure
 *
 * Parameters:
 * @param f_data - the allocated structure
 *
 * Returns:
 * @return -
 */
void
free_fit_data(fit_data *f_data)
{
  free(f_data->x_values);
  free(f_data->y_values);
  free(f_data->e_values);

  free(f_data);

  f_data = NULL;
}

void
print_fit_state (size_t iter, gsl_multifit_fdfsolver * s)
{
  printf ("iter: %3zu x = %e %e %e %e "
          "|f(x)| = %g |dx| = %g\n\n", iter,
          gsl_vector_get (s->x, 0),
          gsl_vector_get (s->x, 1),
          gsl_vector_get (s->x, 2),
          gsl_vector_get (s->x, 3),
          gsl_blas_dnrm2 (s->f),
          gsl_blas_dnrm2 (s->dx));
}

/**
 * Function: comp_intrel_max
 *
 * Parameters:
 * @param f_data  - the input data
 *
 * Returns:
 * @return rel12 - "second brightes row pixel divided by brighest row pixel"
 */
double
comp_intrel_max(const fit_data *f_data)
{

  int i;
  double rel12=-100000.0;

  gsl_vector *val_vector;

  // check whether there is enough
  // data to make the relation
  if (f_data->n_data < 2)
    return rel12;

  // allocate a vector
  val_vector = gsl_vector_alloc(f_data->n_data);

  // fill in the data
  for (i=0; i < f_data->n_data; i++)
    gsl_vector_set(val_vector, i, f_data->y_values[i]);

  // sort the values
  gsl_sort_vector(val_vector);

  // prevent division by zero
  if (gsl_vector_get(val_vector, 0))
    // compute the quantity second brightes pixel
    // divided by brighest pixel
    rel12 = gsl_vector_get(val_vector, f_data->n_data-2) / gsl_vector_get(val_vector, f_data->n_data-1);

  // free the memory
  gsl_vector_free(val_vector);

  // return the result
  return rel12;
}

/**
 * Function: bcksub_observation
 *
 * Parameters:
 * @param obs           - the grism image
 * @param bck           - the background image
 *
 * Returns:
 * @return ret - background subtracted data
 */
gsl_matrix *
bcksub_observation(observation *obs, observation *bck)
{
  gsl_matrix *ret;

  int ii;
  int jj;

  // initialize the return
  ret = gsl_matrix_alloc(obs->grism->size1, obs->grism->size2);

  // set all values to NAN
  gsl_matrix_set_all(ret, GSL_NAN);

  // go over all cols
  for (ii=0; ii < (int)obs->grism->size1; ii++)
    // go over all rows
    for (jj=0; jj < (int)obs->grism->size2; jj++)
      {
	// check whether there is valid data in
	// object and background image
	if (!isnan(gsl_matrix_get(obs->grism, ii, jj))
	    && !isnan(gsl_matrix_get(bck->grism, ii, jj))
	    && gsl_matrix_get(bck->grism, ii, jj))

	  // compute and set the pixel
	  gsl_matrix_set(ret, ii, jj, gsl_matrix_get(obs->grism, ii, jj) - gsl_matrix_get(bck->grism, ii, jj));
      }

  // return matrix
  return ret;
}

/**
 * Function: evaluate_ipc_fit
 *
 * Parameters:
 * @param f_data  - the input for the independent values
 * @param gpars   - the fited parameters
 * @param fpars   - the fixed parameters
 *
 * Returns:
 * @return y_values - the function values
 */
double *
evaluate_ipc_fit(fit_data *f_data, double *gpars, double *fpars)
{
  int index;

  //double yvalue;

  double *y_values;

  // allocate memory for the function values
  y_values = (double *)malloc(f_data->n_data * sizeof(double));

  // go over all independent data
  for (index=0; index < f_data->n_data; index++)
      // compute and store a function value
      y_values[index] = comp_shift(f_data->x_values[index], gpars, fpars);

  // return the function values
  return y_values;
}

/**
 * Function: write_ipc_fit
 *
 * Parameters:
 * @param f_data   - the input data
 * @param y_values - the model values
 * @param ipc_file - name of the file to write to
 *
 * Returns:
 * @return -
 */
void
write_ipc_fit(fit_data *f_data, double *y_values, const char *ipc_file, const double qual, double *yfract)
{
  FILE *fout;
  char Buffer[MAXCHAR];

  int index;

  // open the file for the values
  fout = fopen (ipc_file, "w");

  // write norm (= quality of fit) to comment line
  sprintf (Buffer, "# norm of the residue vector: %e\n", qual);
  fputs (Buffer, fout);
  // write norm (= quality of fit) to comment line
  sprintf (Buffer, "#%e\n", qual);
  fputs (Buffer, fout);
  sprintf (Buffer, "# Wanderer kommst Du nach Sparta: %e\n", qual);
  fputs (Buffer, fout);
  sprintf (Buffer, "# berichtige dorten: %e\n", qual);
  fputs (Buffer, fout);
  sprintf (Buffer, "# Du habest uns hier liegen gesehen: %e\n", qual);
  fputs (Buffer, fout);
  sprintf (Buffer, "# wie es die Geschichte befahl. %e\n", qual);
  fputs (Buffer, fout);
  sprintf (Buffer, "#%e\n", qual);
  fputs (Buffer, fout);

  // go over the data
  for (index=0; index < f_data->n_data; index++)
    {
      // write the data point to the buffer
      sprintf (Buffer, "%e %e %e %e %e\n", f_data->x_values[index], f_data->y_values[index], y_values[index],  f_data->e_values[index], yfract[index]);
      // write the buffer to the file
      fputs (Buffer, fout);
    }

  // close the file
  fclose(fout);
}

/**
 * Function: fit_ipc_data
 *
 * Parameters:
 * @param f_data  - the input data
 * @param gpars   - the guess or fit parameters
 * @param n_gpars - number of guess or fit parameters
 * @param fpars   - the fixed parameters
 * @param n_fpars - number of fixed parameters
 *
 * Returns:
 * @return control.fnorm - goodness of the fit value
 */
double
fit_ipc_data(fit_data *f_data, double *gpars, int n_gpars,
	     double *fpars, int n_fpars)
{
  int m_dat = f_data->n_data;

  // auxiliary settings:
  lm_control_type control;
  lm_data_fpar_type data;

  // initialize the fit
  lm_initialize_control( &control );

  // define the parameters for the fitting
  data.user_func = comp_shift;
  data.user_t = f_data->x_values;
  data.user_y = f_data->y_values;
  data.fpars  = fpars;

  // print the initial
  // value
  fprintf(stdout, "input: %e, ", gpars[0]);

  // perform the fit:
  lm_minimize( m_dat, n_gpars, gpars, lm_evaluate_fpar, lm_print_nothing,
  	       &data, &control );

  // print the new value plus additional information
  fprintf(stdout, " output: %e, info: %i, niter: %i norm: %e\n",
	  gpars[0], control.info, control.nfev, control.fnorm);

  // return the variable
  // describing the goodness
  // of the fit
  return control.fnorm;
}

/**
 * Function: get_ipc_fdata
 *
 * Parameters:
 * @param conf          - the aXe configuratuion structure
 * @param obs           - the grism image
 * @param data_matrix   - background subtracted grism image
 * @param actbeam       - the beam to examine
 *
 * Returns:
 * @return f_final - the filled data structure
 */
fit_data *
get_ipc_fdata(const aperture_conf  *conf,  observation *obs,
	      gsl_matrix *data_vals, beam act_beam)
{
  trace_func     *tracefun;

  px_point        xborder;
  px_point        tpoint;

  gsl_vector      *ipc_data;

  double rel12;

  int i;
  int index;

  fit_data *fdata  = NULL;
  fit_data *f_final= NULL;

  // define the beam and the trace function
  tracefun = act_beam.spec_trace;

  // If this beam's ignore flag is set to 1 then do nothing
  if (act_beam.ignore == 1)
    return fdata;

  // determine the start and end point in x
  xborder = get_fit_xrange(conf, obs, act_beam);

  // an assertion to prevent
  // catastrophic failures
  if  (xborder.x > xborder.y)
    return fdata;
  // introduced after making release 1 reduction

  // allocate memory for the fitting structure
  fdata = alloc_fit_data(xborder.y-xborder.x);

  // Loop over all columns
  index = 0;
  for (i = xborder.x; i < xborder.y; i++)
    {
      // determine the pixel which is
      // closest to the nominal trace position
      tpoint.x = i;
      tpoint.y = (int)floor(tracefun->func((double)i-act_beam.refpoint.x,
					   tracefun->data)
			    + act_beam.refpoint.y+0.5);

      // collect pixel data
      ipc_data = get_ipc_coldata(data_vals, N_COLUMNS_FIT, tpoint);

      // go to the next
      // row if no data is available
      if (!ipc_data)
	continue;

      // sort the values
      gsl_sort_vector(ipc_data);

      // at least two values are needed;
      // prevent division by zero
      if (ipc_data->size > 1 && gsl_vector_get(ipc_data, ipc_data->size-1))
	{
	  // compute the relation
	  rel12 = gsl_vector_get(ipc_data, ipc_data->size-2) / gsl_vector_get(ipc_data, ipc_data->size-1);

	  fdata->x_values[index] = (double)i - act_beam.refpoint.x;
	  fdata->y_values[index] = rel12;
	  fdata->e_values[index] = 1.0;
	  index++;
	}

      // free the allocated memory
      gsl_vector_free(ipc_data);
    }

  // check whether the ipc data covers the minimum length
  if (fabs(fdata->x_values[fdata->n_data-1] - fdata->x_values[0]) > MIN_IPC_LENGTH)
    // reduce the data to what is necessary
    f_final = strip_fitdata(fdata, index);
  else
    fprintf(stdout, "beam tooo short\n");

  // release the original structure
  free_fit_data(fdata);

  // return the fit data
  return f_final;
}

/**
 * Function: get_wf_special
 *
 * Parameters:
 * @param conf          - the aXe configuratuion structure
 * @param obs           - the grism image
 * @param data_matrix   - background subtracted grism image
 * @param actbeam       - the beam to examine
 *
 * Returns:
 * @return f_final - the filled data structure
 */
double *
get_wf_special(const aperture_conf  *conf,  observation *obs,
	       gsl_matrix *data_vals, beam act_beam, double yoffs)
{
  trace_func     *tracefun;

  px_point        xborder;
  px_point        tpoint;

  gsl_vector      *ipc_data;

  double rel12;

  int i;
  int index;

  fit_data *fdata  = NULL;
  //fit_data *f_final= NULL;

  double yyy;

  double *yfract=NULL;
  double *yfinal = 0;

  // define the beam and the trace function
  tracefun = act_beam.spec_trace;

  // If this beam's ignore flag is set to 1 then do nothing
  if (act_beam.ignore == 1)
    return yfinal;

  // determine the start and end point in x
  xborder = get_fit_xrange(conf, obs, act_beam);

  // allocate memory for the fitting structure
  fdata = alloc_fit_data(xborder.y-xborder.x);

  // allocate memory
  yfract = (double *)malloc((xborder.y-xborder.x)*sizeof(double));

  // Loop over all columns
  index = 0;
  for (i = xborder.x; i < xborder.y; i++)
    {
      // determine the pixel which is
      // closest to the nominal trace position
      tpoint.x = i;
      tpoint.y = (int)floor(tracefun->func((double)i-act_beam.refpoint.x,
					   tracefun->data)
			    + act_beam.refpoint.y+0.5);

      yyy           = tracefun->func((double)i-act_beam.refpoint.x, tracefun->data) + act_beam.refpoint.y + yoffs;
      yfract[index] = yyy - floor(yyy);

      // collect pixel data
      ipc_data = get_ipc_coldata(data_vals, N_COLUMNS_FIT, tpoint);

      // go to the next
      // row if no data is available
      if (!ipc_data)
	continue;

      // sort the values
      gsl_sort_vector(ipc_data);

      // at least two values are needed;
      // prevent division by zero
      if (ipc_data->size > 1 && gsl_vector_get(ipc_data, ipc_data->size-1))
	{
	  // compute the relation
	  rel12 = gsl_vector_get(ipc_data, ipc_data->size-2) / gsl_vector_get(ipc_data, ipc_data->size-1);

	  fdata->x_values[index] = (double)i - act_beam.refpoint.x;
	  fdata->y_values[index] = rel12;
	  fdata->e_values[index] = 1.0;
	  index++;
	}

      // free the allocated memory
      gsl_vector_free(ipc_data);
    }

  yfinal = strip_wf_special(fdata, yfract, index);

  // release the original structure
  free_fit_data(fdata);
  if (yfract)
    free(yfract);

  // return the fit data
  return yfinal;
}

/**
 * Function: strip_wf_special
 *
 * Parameters:
 * @param old_fdata - the experimental data
 * @param i_max     - the maximum index to check for valid data
 *
 * Returns:
 * @return fdata - the new, completely filled data structure
 */
double *
strip_wf_special(fit_data *old_fdata, double *y_fract, int i_max)
{
  double *y_new=NULL;

  int ii;
  int i_count;

  // check that SOME values
  // are accepted
  if (i_max < 1)
    // return NULL if not
    return y_new;

  // count the number of
  // values with weight
  i_count=0;
  for (ii=0; ii < i_max; ii++)
    if (old_fdata->e_values[ii])
      i_count++;

  // check whether there
  // is data at all
  if (i_count < 1)
    // return NULL if not
    return y_new;

  // allocate a new structure
  y_new = (double *)malloc(i_count * sizeof(double));

  // set the counter
  i_count=0;

  // go over the old data
  // to the maximum index
  for (ii=0; ii < i_max; ii++)
    {
      // check whether the
      // data is valid
      if (old_fdata->e_values[ii])
	{
	  // transfer valid data
	  y_new[i_count] = y_fract[ii];

	  // enhance the counter
	  i_count++;
	}
    }

  // return the new structure
  return y_new;
}

/**
 * Function: strip_fitdata
 *
 * Parameters:
 * @param old_fdata - the experimental data
 * @param i_max     - the maximum index to check for valid data
 *
 * Returns:
 * @return fdata - the new, completely filled data structure
 */
fit_data *
strip_fitdata(fit_data *old_fdata, int i_max)
{
  fit_data *fdata = NULL;

  int ii;
  int i_count;

  // check that SOME values
  // are accepted
  if (i_max < 1)
    // return NULL if not
    return fdata;

  // count the number of
  // values with weight
  i_count=0;
  for (ii=0; ii < i_max; ii++)
    if (old_fdata->e_values[ii])
      i_count++;

  // check whether there
  // is data at all
  if (i_count < 1)
    // return NULL if not
    return fdata;

  // allocate a new structure
  fdata = alloc_fit_data(i_count);

  // set the counter
  i_count=0;

  // go over the old data
  // to the maximum index
  for (ii=0; ii < i_max; ii++)
    {
      // check whether the
      // data is valid
      if (old_fdata->e_values[ii])
	{
	  // transfer valid data
	  fdata->x_values[i_count] = old_fdata->x_values[ii];
	  fdata->y_values[i_count] = old_fdata->y_values[ii];
	  fdata->e_values[i_count] = old_fdata->e_values[ii];

	  // enhance the counter
	  i_count++;
	}
    }

  // return the new structure
  return fdata;
}

/**
 * Function: kappa_sigma_klipp_ipc
 *
 * Parameters:
 * @param conf          - the aXe configuratuion structure
 * @param obs           - the grism image
 * @param data_matrix   - background subtracted grism image
 * @param actbeam       - the beam to examine
 * @param ipc_file_path - file name for the phase data
 *
 * Returns:
 * @return ret - the change in y-shift and the goodness of the fit
 */
d_point
kappa_sigma_klipp_ipc(const aperture_conf  *conf, observation *obs,
		      gsl_matrix *data_matrix, beam act_beam,
		      const char *ipc_file)
{
  fit_data *f_data   = NULL;
  fit_data *f_work   = NULL;

  double   *y_values = NULL;
  //double   *test = NULL;
  double    sigma;

  d_point   ret;

  trace_func *tracefun  = act_beam.spec_trace;
  double     *tracedata =  (double *)(tracefun->data);

  double p[1];
  double f[3] = {0.6, 0.9, tracedata[2]};

  int index=0;
  int nold_data;

  // REMOVEME ASAP !!!!!
  double *yfract=NULL;

  // compute a first guess for the shift
  p[0] = act_beam.refpoint.y - floor(act_beam.refpoint.y + tracedata[1]);

  // remember the shift
  ret.x = p[0];

  // give infinity for
  // the goodness of the fit
  ret.y = 1.0e+20;

  // get the data for the fit
  f_data = get_ipc_fdata(conf, obs, data_matrix, act_beam);

  // check whether
  // there is data
  if (f_data)
    {

      // fix the number of initial data points
      nold_data= f_data->n_data;

      // make the frist fit
      ret.y = fit_ipc_data(f_data, p, 1, f, 3);

      // evaluate the fit; comute the sigma
      y_values = evaluate_ipc_fit(f_data, p, f);
      sigma = calculate_sigma(f_data, y_values);

      // start the iteration
      while (index < N_ITER_IPC)
	{

	  // reject points according to the sigma
	  // generate a new struct to work with
	  reject_kappasigma(f_data, y_values, KAPPA_IPC*sigma);
	  // free memory in the old work structure

	  if (f_work)
	    free_fit_data(f_work);
	  f_work = strip_fitdata(f_data, f_data->n_data);

	  // check whether there
	  // is still data
	  if (!f_work)
	    break;

	  // check whether data was rejected
	  // brek if 'yes' transfer the new number if 'no'
	  if (f_work->n_data == nold_data)
	    break;
	  else
	    nold_data = f_work->n_data;

	  // make a new fit
	  ret.y = fit_ipc_data(f_work, p, 1, f, 3);

	  // evaluate fit values; comute the sigma
	  if (y_values)
	    free(y_values);
	  y_values = evaluate_ipc_fit(f_data, p, f);
	  sigma = calculate_sigma(f_data, y_values);

	  // enhance
	  // the kappa counter
	  index++;
	}

      // evaluate the fit values
      if (y_values)
	free(y_values);
      y_values = evaluate_ipc_fit(f_data, p, f);

      // REMOVEME ASAP
      yfract = get_wf_special(conf, obs, data_matrix, act_beam, p[0] - ret.x);

      // CHANGEME back ASAP
      // write the phase shift file
      write_ipc_fit(f_data, y_values, ipc_file, ret.y, yfract);

      // release memory
      if (f_data)
	free_fit_data(f_data);
      if (f_work)
	free_fit_data(f_work);
      if (y_values)
	free(y_values);
      if (yfract)
	free(yfract);
    }

  // compute the
  // difference in y-shift
  ret.x = p[0] - ret.x;

  // return the result
  return ret;
}

/**
 * Function: reject_kappasigma
 *
 * Parameters:
 * @param f_data   - the experimental data
 * @param y_values - the model data
 * @param max_diff - the maximum allowed difference
 *                   between data and model
 *
 * Returns:
 * @return -
 */
void
reject_kappasigma(fit_data *f_data, double *y_values, double max_diff)
{
  int index;

  // go over all data
  for (index=0; index < f_data->n_data; index++)
    // check whether the data point is valid and OVER the maximum allowed difference
    if (f_data->e_values[index] && fabs(f_data->y_values[index] - y_values[index]) > max_diff)
      // make the data point INVALID
      f_data->e_values[index] = 0.0;
}

/**
 * Function: calculate_sigma
 *
 * Parameters:
 * @param f_data   - the experimental data
 * @param y_values - the model data
 *
 * Returns:
 * @return sigma - the standard deviation
 */
double
calculate_sigma(fit_data *f_data, double *y_values)
{
  double *tmp;

  double sigma;
  double mean=0.0;
  double diff;

  int n_data=0;
  int index;

  // count the number of valid data points
  for (index=0; index < f_data->n_data; index++)
    if (f_data->e_values[index])
      n_data++;

  // allocate a temporary vector for
  // the valid data
  tmp = (double *)malloc(n_data * sizeof(double));

  // re-set the counter;
  // go over all data points
  n_data=0;
  for (index=0; index < f_data->n_data; index++)
    {
      // check whether the data point
      // is valid
      if (f_data->e_values[index])
	{
	  // compute the difference between data and model
	  diff =  f_data->y_values[index] - y_values[index];

	  // store the difference
	  tmp[n_data] = diff;

	  // add to the mean
	  mean += diff;

	  // enhance the counter
	  n_data++;
	}
    }

  // comopute the mean
  mean /= (double)n_data;

  // compute standard deviation
  sigma = gsl_stats_sd_m(tmp, 1, n_data, mean);

  // relese the memory
  free(tmp);

  // return the sigma
  return sigma;
}


/**
 * @file bblas_daccuracy.c
 *
 * @brief BBLAS accuracy tests for double_Complex precision.
 *
 *  BBLAS is a software package provided by Univ. of Manchester,
 *  Univ. of Tennessee.
 *
 * @version 1.0.0
 * @author  Samuel  D. Relton
 * @author  Pedro   V. Lara
 * @author  Mawussi Zounon
 * @date    2016-02-20
 *
 **/

#ifndef DOXYGEN_SHOULD_SKIP_THIS
/**
 * Code generation
 * @generated from bblas_zaccuracy.c normal z -> d, Mon Jun  6 09:44:14 2016
 **/
#endif

#include "bblas_common.h"
#include <lapacke.h>
#include <cblas.h>

#define REAL

/**
 * bblas_dgemm_tolerance computes the forward error
 * @f[\|C - C_{\mathrm{seq}}\|_{\infty}/((K|\alpha|\|A\|_{\infty}\|B\|_{\infty} +
 *           |\beta|\|C_{\mathrm{init}}\|_{\infty})\epsilon).@f]
 *
 **/

void bblas_dgemm_tolerance(bblas_dtest_t *test, double **C_final)
{

    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, An, Bm, Bn, M, K, N, ldc;
    int max_work_size = max(test->maxK,max(test->maxM, test->maxN));
    double Anorm, Bnorm, Rnorm, result;
    double eps = LAPACKE_dlamch_work('e');
    double alpha =-1;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Temporary buffer to save (test-arrayC -C_final) */
    double **C_diff;
    C_diff = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayC in C_diff */
    bblas_dcopy_Cinit(test, C_diff);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    M = test->M[batch_iter];
	    K   = test->K[batch_iter];
	    N   = test->N[batch_iter];
	    ldc = test->ldc[batch_iter];

	    if (test->transA[batch_iter] == BblasNoTrans) {
		Am = M; An = K;
	    } else {
		Am = K; An = M;
	    }
	    if (test->transB[batch_iter] == BblasNoTrans) {
		Bm = K; Bn = N;
	    } else {
		Bm = N; Bn = K;
	    }

	    /*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

	    /*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', M, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

	    /*Compute the infinity norm of B */
	    Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    result = Rnorm / ((K*cabs(test->alpha[batch_iter])*Anorm*Bnorm + cabs(test->beta[batch_iter])*test->Cinitnorm[batch_iter])*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}

    }else  if( test->batch_opts == BBLAS_FIXED ) //fixed  size
    {
	M   = test->M[first_index];
	K   = test->K[first_index];
	ldc = test->ldc[first_index];
	N   = test->N[first_index];

	if (test->transA[first_index] == BblasNoTrans) {
	    Am = M; An = K;
	} else {
	    Am = K; An = M;
	}
	if (test->transB[first_index] == BblasNoTrans) {
	    Bm = K; Bn = N;
	} else {
	    Bm = N; Bn = K;
	}

	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
		/*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);
	    /*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', M, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

	    /*Compute the infinity norm of B */
	    Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    /*Compute the relative error */
	    result = Rnorm / ((K*cabs(test->alpha[first_index])*Anorm*Bnorm + cabs(test->beta[first_index])*test->Cinitnorm[batch_iter])*eps);

	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal: Fixed, Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}
    }else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

/*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(C_diff[index]);
    }
    free(C_diff);
    free(work);
}

/**
 * bblas_dstarmm_tolerance computes the forward error
 * @f[\|C - C_{\mathrm{seq}}\|_{\infty}/((K|\alpha|\|A\|_{\infty}\|B\|_{\infty} +
 * |\beta|\|C_{\mathrm{init}}\|_{\infty})\epsilon).@f]
 *
 **/

void bblas_dstarmm_tolerance(bblas_dtest_t *test, double **C_final)
{
    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, Bm, Bn, N, ldc;
    int max_work_size = max(test->maxM, test->maxN);
    double Anorm, Bnorm, Rnorm, result;
    double eps = LAPACKE_dlamch_work('e');
    double alpha =-1;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Temporary buffer to save (test-arrayC -C_final) */
    double **C_diff;
    C_diff = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayC in C_diff */
    bblas_dcopy_Cinit(test, C_diff);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    N = test->N[batch_iter];
	    ldc = test->ldc[batch_iter];

	    if(test->side[batch_iter] == BblasLeft )
	    {
		Am = test->M[batch_iter];
	    } else {
		Am = test->N[batch_iter];
	    }
	    Bm = test->ldb[batch_iter];
	    Bn = test->N[batch_iter];
	    /*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

		/*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldc, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, Am, test->arrayA[batch_iter], Am, work);

	    /*Compute the infinity norm of B */
	    Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    result = Rnorm / ((N*cabs(test->alpha[batch_iter])*Anorm*Bnorm + cabs(test->beta[batch_iter])*test->Cinitnorm[batch_iter])*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}

    }else  if( test->batch_opts == BBLAS_FIXED ) //fixed  size
    {
	N = test->N[first_index];
	ldc = test->ldc[first_index];

	if(test->side[first_index] == BblasLeft )
	{
	    Am = test->M[first_index];
	} else {
	    Am = test->N[first_index];
	}
	Bm = test->ldb[first_index];
	Bn = test->N[first_index];

	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    /*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

	    /*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldc, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, Am, test->arrayA[batch_iter], Am, work);

	    /*Compute the infinity norm of B */
	    Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    /*Compute the relative error */
	    result = Rnorm / ((N*cabs(test->alpha[first_index])*Anorm*Bnorm + cabs(test->beta[first_index])*test->Cinitnorm[batch_iter])*eps);

	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal: Fixed, Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}
    }else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

/*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(C_diff[index]);
    }
    free(C_diff);
    free(work);
}

/**
 * bblas_dstark_tolerance computes the forward error
 * @f[\|C - C_{\mathrm{seq}}\|_{\infty}/((K|\alpha|\|A\|_{\infty}\|A\|_1 +
 * |\beta|\|C_{\mathrm{init}}\|_{\infty})\epsilon).@f]
 *
 **/

void bblas_dstark_tolerance(bblas_dtest_t *test, double **C_final)
{
    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, An, N, K, ldc;
    char u;
    int max_work_size = max(test->maxK, test->maxN);
    double Anorm, ATnorm, Rnorm, result;
    double eps = LAPACKE_dlamch_work('e');
    double alpha_norm, beta_norm;
    double alpha =-1;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Temporary buffer to save (test-arrayC -C_final) */
    double **C_diff;
    C_diff = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayC in C_diff */
    bblas_dcopy_Cinit(test, C_diff);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    N = test->N[batch_iter];
	    K = test->K[batch_iter];
	    ldc = test->ldc[batch_iter];

	    if (test->trans[batch_iter] == BblasNoTrans) {
		Am = N; An = K;
	    } else {
		Am = K; An = N;
	    }

	    if(test->uplo[batch_iter] == BblasLower )
	      {
		u = 'L';
	      }else
	      {
		u = 'U';
	      }
	    /*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

	    /*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlansy_work(LAPACK_COL_MAJOR, 'I', u, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

	    /*Compute the one norm of A */
	    ATnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Am, An, test->arrayA[batch_iter], Am, work);

	    if (test->routine == BBLAS_HERK)
	    {
		beta_norm   = cabs(test->beta_herk[batch_iter]);
		alpha_norm  = cabs(test->alpha_herk[batch_iter]);
	    }else{
		beta_norm  = cabs(test->beta[batch_iter]);
		alpha_norm  = cabs(test->alpha[batch_iter]);
	    }

	    result = Rnorm / ((K*alpha_norm*Anorm*ATnorm + beta_norm*test->Cinitnorm[batch_iter])*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}

    }else  if( test->batch_opts == BBLAS_FIXED ) //fixed  size
    {
	    N = test->N[first_index];
	    K = test->K[first_index];
	    ldc = test->ldc[first_index];

	    if (test->trans[first_index] == BblasNoTrans) {
		Am = N; An = K;
	    } else {
		Am = K; An = N;
	    }
	    if(test->uplo[first_index] == BblasLower )
	      {
		u = 'L';
	      }else
	      {
		u = 'U';
	      }

	    for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	      {
		/*Compute the error C - C_finial */
		cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

		Rnorm = LAPACKE_dlansy_work(LAPACK_COL_MAJOR, 'I', u, N, C_diff[batch_iter], ldc, work);

		/*Compute the infinity norm of A */
		Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

		/*Compute the one norm of A */
		ATnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Am, An, test->arrayA[batch_iter], Am, work);

		if (test->routine == BBLAS_HERK)
		{
		    beta_norm   = cabs(test->beta_herk[first_index]);
		    alpha_norm  = cabs(test->alpha_herk[first_index]);
		}else{
		    beta_norm   = cabs(test->beta[first_index]);
		    alpha_norm  = cabs(test->alpha[first_index]);
		}

		/*Compute the relative error */
		result = Rnorm / ((K*alpha_norm*Anorm*ATnorm +
				   beta_norm*test->Cinitnorm[batch_iter])*eps);

		switch(test->target)
		{
		    case BBLAS_MKL:
			test->mkl_error[batch_iter] = result;
			break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		  test->device_error[batch_iter] = result;
		  break;

		    case BBLAS_OTHER:
			test->other_error[batch_iter] = result;
			break;
		    default:
			printf("In bblas_dcheck_Cfinal: Fixed, Target no defined\n");
			exit(EXIT_FAILURE);
		}
	    }
    }else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

/*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(C_diff[index]);
    }
    free(C_diff);
    free(work);
}

/**
 * bblas_dstar2k_tolerance computes the forward error
 * @f[\|C - C_{\mathrm{seq}}\|_{\infty}/((K|\alpha|\|A\|_{\infty}\|B\|_1 +
 * K|\alpha|\|B\|_{\infty}\|A\|_1  +
 * |\beta|\|C_{\mathrm{init}}\|_{\infty})\epsilon).@f]
 *
 **/

void bblas_dstar2k_tolerance(bblas_dtest_t *test, double **C_final)
{
    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, An, Bn, Bm, N, K, ldc;
    int max_work_size = max(test->maxK, test->maxN);
    double Anorm, Bnorm, ATnorm, BTnorm,  Rnorm, result;
    double beta_norm;
    double eps = LAPACKE_dlamch_work('e');
    double alpha =-1;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Temporary buffer to save (test-arrayC -C_final) */
    double **C_diff;
    C_diff = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayC in C_diff */
    bblas_dcopy_Cinit(test, C_diff);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    N = test->N[batch_iter];
	    K = test->K[batch_iter];
	    ldc = test->ldc[batch_iter];

	    if (test->trans[batch_iter] == BblasNoTrans) {
		Am = N; An = K;
		Bn = K;
	    } else {
		Am = K; An = N;
		Bn = N;
	    }
	    Bm = test->ldb[batch_iter];

	    /*Compute the error C - C_finial */
	    cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

		/*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldc, N, C_diff[batch_iter], ldc, work);

	    /*Compute the infinity norm of A */
	    Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

	    /*Compute the one norm of A */
	    ATnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Am, An, test->arrayA[batch_iter], Am, work);

	    /*Compute the infinity norm of B */
	    Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    /*Compute the one norm of B */
	    BTnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Bm, Bn, test->arrayB[batch_iter], Bm, work);

	    if(test->routine == BBLAS_HER2K)
	    {
		beta_norm = cabs(test->beta_herk[batch_iter]);
	    }else
	    {
		beta_norm = cabs(test->beta[batch_iter]);
	    }

	    result = Rnorm / ((K*cabs(test->alpha[batch_iter])*Anorm*BTnorm +
			       K*cabs(test->alpha[batch_iter])*Bnorm*ATnorm +
			       beta_norm*test->Cinitnorm[batch_iter])*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}

    }else  if( test->batch_opts == BBLAS_FIXED ) //fixed  size
    {
	N = test->N[first_index];
	K = test->K[first_index];
	ldc = test->ldc[first_index];

	if (test->trans[first_index] == BblasNoTrans) {
		Am = N; An = K;
		Bn = K;
	} else {
	    Am = K; An = N;
	    Bn = N;
	}
	Bm = test->ldb[first_index];

	    for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	    {
		/*Compute the error C - C_finial */
		cblas_daxpy (ldc*N, (alpha), C_final[batch_iter], 1, C_diff[batch_iter], 1);

		/*Compute  the infinity norm associated  with the error */
		Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldc, N, C_diff[batch_iter], ldc, work);

		/*Compute the infinity norm of A */
		Anorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Am, An, test->arrayA[batch_iter], Am, work);

		/*Compute the one norm of A */
		ATnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Am, An, test->arrayA[batch_iter], Am, work);

		/*Compute the infinity norm of B */
		Bnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', Bm, Bn, test->arrayB[batch_iter], Bm, work);

		/*Compute the one norm of B */
		BTnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'O', Bm, Bn, test->arrayB[batch_iter], Bm, work);

		if(test->routine == BBLAS_HER2K)
		{
		    beta_norm = cabs(test->beta_herk[first_index]);
		}else
		{
		    beta_norm = cabs(test->beta[first_index]);
		}

		/*Compute the relative error */
		result = Rnorm / ((K*cabs(test->alpha[first_index])*Anorm*BTnorm +
				   K*cabs(test->alpha[first_index])*Bnorm*ATnorm +
				   beta_norm*test->Cinitnorm[batch_iter])*eps);

		switch(test->target)
		{
		case BBLAS_MKL:
		  test->mkl_error[batch_iter] = result;
		  break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		  test->device_error[batch_iter] = result;
		  break;

		case BBLAS_OTHER:
		  test->other_error[batch_iter] = result;
		  break;
		default:
		  printf("In bblas_dcheck_Cfinal: Fixed, Target no defined\n");
		  exit(EXIT_FAILURE);
		}
	    }
    }else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

/*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(C_diff[index]);
    }
    free(C_diff);
    free(work);
}

/**
 * bblas_dtrmm_tolerance computes the forward error
 * @f[\|C - C_{\mathrm{seq}}\|_{\infty}/((|\alpha|\|A\|_{\infty}\|B\|_{\infty}N\epsilon).@f]
 *
 **/

void bblas_dtrmm_tolerance(bblas_dtest_t *test, double **B_final)
{
    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, An, ldb, N, M;
    int max_work_size = max(test->maxK, test->maxN);
    char u, diag;
    double Anorm, Rnorm, result;
    double eps = LAPACKE_dlamch_work('e');
    double alpha =-1;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Temporary buffer to save (test-arrayB -B_final) */
    double **B_diff;
    B_diff = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayB in B_diff */
    bblas_dcopy_Binit(test, B_diff);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    N = test->N[batch_iter];
	    M = test->M[batch_iter];
	    ldb = test->ldb[batch_iter];

	    Am = test->lda[batch_iter];

	    if(test->side[batch_iter] == BblasLeft )
	    {
		An = M;
	    }else
	    {
		An = N;
	    }

	    if(test->uplo[batch_iter] == BblasLower )
	    {
	       u = 'L';
	    }else
	    {
	       u = 'U';
	    }

	    if(test->diag[batch_iter] == BblasUnit )
	    {
		diag = 'U';
	    }else
	    {
		diag = 'N';
	    }

	    /*Compute the error B - B_finial */
	    cblas_daxpy (ldb*N, (alpha), B_final[batch_iter], 1, B_diff[batch_iter], 1);

		/*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, B_diff[batch_iter], ldb, work);

	    /*Infinity norm of the triangular matrix A */
	    Anorm = LAPACKE_dlantr_work(LAPACK_COL_MAJOR, 'I', u, diag, Am,
					An, test->arrayA[batch_iter], Am, work);

		result = Rnorm/(N*cabs(test->alpha[batch_iter])*Anorm*test->Binitnorm[batch_iter]*eps);
	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }

	}
    }else  if( test->batch_opts == BBLAS_FIXED )
    {

	N = test->N[first_index];
	M = test->M[first_index];
	ldb = test->ldb[first_index];

	Am = test->lda[first_index];

	if(test->side[first_index] == BblasLeft )
	{
	    An = M;
	}else
	{
	    An = N;
	}

	if(test->uplo[first_index] == BblasLower )
	{
	    u = 'L';
	}else
	{
	    u = 'U';
	}

	if(test->diag[first_index] == BblasUnit )
	{
	    diag = 'U';
	}else
	{
	    diag = 'N';
	}

	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    /*Compute the error B - B_finial */
	    cblas_daxpy (ldb*N, (alpha), B_final[batch_iter], 1, B_diff[batch_iter], 1);

		/*Compute  the infinity norm associated  with the error */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, B_diff[batch_iter], ldb, work);

	    /*Infinity norm of the triangular matrix A */
	    Anorm = LAPACKE_dlantr_work(LAPACK_COL_MAJOR, 'I', u, diag, Am,
					An, test->arrayA[batch_iter], Am, work);

	    result = Rnorm/(N*cabs(test->alpha[first_index])*Anorm*test->Binitnorm[batch_iter]*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}
    }
    else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

    /*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(B_diff[index]);
    }
    free(B_diff);
    free(work);
}

/**
 * bblas_dtrsm_tolerance computes the backward error
 * @f[\|\alpha B - AX \|_{\infty}/((\|A\|_{\infty}\|X\| + |\alpha|\|B\|_{\infty})N\epsilon).@f]
 *
 **/

void bblas_dtrsm_tolerance(bblas_dtest_t *test, double **B_final)
{
    /*Local variables */
    int batch_count = test->batch_count;
    int batch_iter, first_index = 0;
    int Am, An, ldb, N, M;
    int max_work_size = max(test->maxK, test->maxN);
    char u, diag;
    double Anorm, Rnorm, result, Xnorm;
    double eps = LAPACKE_dlamch_work('e');
    double alpha;
    double *work = (double *)malloc(max_work_size*sizeof(double));

    /*Variable to save the residual alphaB -AX */
    double **residual;
    residual = (double **) malloc(batch_count*sizeof(double *));

    /*Make a copy of test->arrayB (X) in residual */
    bblas_dcopy_Binit(test, residual);

    /*Variable size */
    if( test->batch_opts == BBLAS_VARIABLE )
    {
	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{
	    N = test->N[batch_iter];
	    M = test->M[batch_iter];
	    ldb = test->ldb[batch_iter];

	    Am = test->lda[batch_iter];

	    if(test->side[batch_iter] == BblasLeft )
	    {
		An = M;
	    }else
	    {
		An = N;
	    }

	    if(test->uplo[batch_iter] == BblasLower )
	    {
	       u = 'L';
	    }else
	    {
	       u = 'U';
	    }

	    if(test->diag[batch_iter] == BblasUnit )
	    {
		diag = 'U';
	    }else
	    {
		diag = 'N';
	    }

	    /*Compute residual <- AX  (dtrmm) */
	    alpha = 1;
	    cblas_dtrmm(BblasColMajor, test->side[batch_iter], test->uplo[batch_iter], test->transA[batch_iter],
			test->diag[batch_iter], M, N, (alpha), test->arrayA[batch_iter],
			test->lda[batch_iter], residual[batch_iter], ldb);

	    /*Compute Binit = alpha Binit */
	    for (int index=0;  index < ldb*N; index++)
	    {
		test->Binit[batch_iter][index] = test->alpha[batch_iter]*test->Binit[batch_iter][index];
	    }

	    /*Compute the  residual <- alpha B - Ax  */
	    alpha= -1;
	    cblas_daxpy (ldb*N, (alpha), test->Binit[batch_iter], 1, residual[batch_iter], 1);
		/*Compute  the infinity norm associated  with the residual */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, residual[batch_iter], ldb, work);

	    /*Infinity norm of the triangular matrix A */
	    Anorm = LAPACKE_dlantr_work(LAPACK_COL_MAJOR, 'I', u, diag, Am,
					An, test->arrayA[batch_iter], Am, work);

	    /*Compute  the infinity norm associated  with X (B) */
	    Xnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, test->arrayB[batch_iter], ldb, work);

	    result = Rnorm/(Anorm*Xnorm*N*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }

	}
    }else  if( test->batch_opts == BBLAS_FIXED )
    {

	N = test->N[first_index];
	M = test->M[first_index];
	ldb = test->ldb[first_index];

	Am = test->lda[first_index];

	if(test->side[first_index] == BblasLeft )
	{
	    An = M;
	}else
	{
	    An = N;
	}

	if(test->uplo[first_index] == BblasLower )
	{
	    u = 'L';
	}else
	{
	    u = 'U';
	}

	if(test->diag[first_index] == BblasUnit )
	{
	    diag = 'U';
	}else
	{
	    diag = 'N';
	}

	for( batch_iter =0; batch_iter < batch_count ; batch_iter++)
	{

	    /*Compute residual <- AX  (dtrmm) */
	    alpha = 1;
	    cblas_dtrmm(BblasColMajor, test->side[first_index], test->uplo[first_index], test->transA[first_index],
			test->diag[first_index], M, N, (alpha), (const double*) test->arrayA[batch_iter],
			test->lda[first_index], residual[batch_iter], ldb);

	    /*Compute Binit = alpha Binit */
	    for (int index=0;  index < ldb*N; index++)
	    {
		test->Binit[batch_iter][index] = test->alpha[first_index]*test->Binit[batch_iter][index];
	    }

	    /*Compute the  residual <- alpha B - Ax  */
	    alpha = -1;
	    cblas_daxpy (ldb*N, (alpha), test->Binit[batch_iter], 1, residual[batch_iter], 1);

		/*Compute  the infinity norm associated  with the residual */
	    Rnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, residual[batch_iter], ldb, work);

	    /*Infinity norm of the triangular matrix A */
	    Anorm = LAPACKE_dlantr_work(LAPACK_COL_MAJOR, 'I', u, diag, Am,
					An, test->arrayA[batch_iter], Am, work);

	    /*Compute  the infinity norm associated  with X (B) */
	    Xnorm = LAPACKE_dlange_work(LAPACK_COL_MAJOR, 'I', ldb, N, test->arrayB[batch_iter], ldb, work);

	    result = Rnorm/(Anorm*Xnorm*N*eps);

	    /*Compute the relative error */
	    switch(test->target)
	    {
		case BBLAS_MKL:
		    test->mkl_error[batch_iter] = result;
		    break;

		case BBLAS_CUBLAS:
		case BBLAS_MAGMA:
		    test->device_error[batch_iter] = result;
		    break;

		case BBLAS_OTHER:
		    test->other_error[batch_iter] = result;
		    break;
		default:
		    printf("In bblas_dcheck_Cfinal, Variable: Target no defined\n");
		    exit(EXIT_FAILURE);
	    }
	}
    }
    else
    {
	bblas_error("bblas_dtesting.c", "wrong batch_opts value");
    }

    /*Free allocated memory */
    for(int index =0; index < batch_count; index++)
    {
	free(residual[index]);
    }
    free(residual);
    free(work);
}

/**
 * Calls bblas_dstar2k_tolerance.
 **/
#ifdef COMPLEX
void bblas_dsyr2k_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstar2k_tolerance(test, C_final);

}
#endif
/**
 * Calls bblas_dstar2k_tolerance.
 **/

void bblas_dsyr2k_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstar2k_tolerance(test, C_final);
}

/**
 * Calls bblas_dstark_tolerance.
 **/

#ifdef COMPLEX
void bblas_dsyrk_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstark_tolerance(test, C_final);
}
#endif
/**
 * Calls bblas_dstark_tolerance.
 **/

void bblas_dsyrk_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstark_tolerance(test, C_final);
}

/**
 * Calls bblas_dstarmm_tolerance.
 **/

#ifdef COMPLEX
void bblas_dsymm_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstarmm_tolerance(test, C_final);
}
#endif
/**
 * Calls bblas_dstamm_tolerance.
 **/

void bblas_dsymm_tolerance(bblas_dtest_t *test, double **C_final)
{
    bblas_dstarmm_tolerance(test, C_final);
}


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <mpi.h>
#include "parmt_mtsearch.h"
#ifdef PARMT_USE_INTEL
#include <mkl_cblas.h>
#else
#include <cblas.h>
#endif
#include "iscl/array/array.h"
#include "iscl/memory/memory.h"
#include "iscl/signal/convolve.h"

int parmt_computeStackedCrossCorrelation_MPI(
    const MPI_Comm comm,
    const int npgrns,
    const double *__restrict__ Gxx,
    const double *__restrict__ Gyy,
    const double *__restrict__ Gzz,
    const double *__restrict__ Gxy,
    const double *__restrict__ Gxz,
    const double *__restrict__ Gyz,
    const int ldm, const int nmt, const double *__restrict__ mt,
    const int npts, const double *__restrict__ data,
    const int lxc, double *__restrict__ xc)
{
    double *xcwork;
    int ierr, lx;
    ierr = 0;
    lx = npts + npgrns - 1;
    xcwork = memory_calloc64f(lxc);
    ierr = parmt_computeStackedCrossCorrelation(npgrns,
                                                Gxx, Gyy, Gzz,
                                                Gxy, Gxz, Gyz,
                                                ldm, nmt, mt,
                                                npts, data,
                                                lx, xcwork);
    MPI_Allreduce(xcwork, xc, lxc, MPI_DOUBLE, MPI_SUM, comm);
    memory_free64f(&xcwork);
    return ierr;
}
//============================================================================//
/*!
 * @brief This is an alignment tool intended to optimize the lag by computing
 *
 *        \f[
 *           x_c = \frac{1}{n_{mt}} \sum_{i=1}^{n_{mt}} \textbf{u}_i \textbf{d}
 *        \f]
 *
 *        where the \f$ \star \f$ implies a normalized cross-correlation.
 *
 * @param[in] npgrns    number of points in Green's functions
 * @param[in] Gxx       Green's functions scaled by \f$ m_{xx} \f$ [npgrns]
 * @param[in] Gyy       Green's functions scaled by \f$ m_{yy} \f$ [npgrns]
 * @param[in] Gzz       Green's functions scaled by \f$ m_{zz} \f$ [npgrns]
 * @param[in] Gxy       Green's functions scaled by \f$ m_{xy} \f$ [npgrns]
 * @param[in] Gxz       Green's functions scaled by \f$ m_{xz} \f$ [npgrns]
 * @param[in] Gyz       Green's functions scaled by \f$ m_{yz} \f$ [npgrns]
 * @param[in] ldm       leading dimension of moment tensors (>= 6)
 * @param[in] nmt       number of moment tensors
 * @param[in] mt        moment tensors.  the i'th moment tensor begins at
 *                      i*ldm and the moment tensor terms are packed
 *                      \f$ \{ m_{xx}, m_{yy}, m_{zz},
 *                             m_{xy}, m_{xz}, m_{yz} \f$.
 * @param[in] npts      number of points in signal
 * @param[in] data      Observed data.  This is an array of dimension [npts].
 * @param[in] lxc       max size of xc (should be >= npts + npgrns - 1)
 *
 * @param[out] xc       stack of the observed and synthetic cross-correlations
 *                      [lxc].  the C indexed lag is computed:
 *                        npts - 1 + argmax(xc)
 *                      where the argmax takes values [0,lx-1]
 *
 * @result 0 indicates success
 *
 * @author Ben Baker
 *
 * @copyright ISTI distributed under Apache 2
 *
 */
int parmt_computeStackedCrossCorrelation(
    const int npgrns,
    const double *__restrict__ Gxx,
    const double *__restrict__ Gyy,
    const double *__restrict__ Gzz,
    const double *__restrict__ Gxy,
    const double *__restrict__ Gxz,
    const double *__restrict__ Gyz,
    const int ldm, const int nmt, const double *__restrict__ mt,
    const int npts, const double *__restrict__ data,
    const int lxc, double *__restrict__ xc)
{
    const char *fcnm = "parmt_computedStackedCrossCorrelation\0";
    double *Gmat, *Gxc, *xcorr, *xcw;
    double m6[8] __attribute__((aligned(64)));
    double dscal __attribute__((aligned(64))) = 0.0;
    double gscal __attribute__((aligned(64))) = 0.0;
    double xscal __attribute__((aligned(64))) = 0.0;
    double est __attribute__((aligned(64))) = 0.0;
    int i, ierr, j, lc;
    lc = npts + npgrns - 1;
    if (npts < 1 || npgrns < 1 ||
        Gxx == NULL || Gyy == NULL || Gzz == NULL ||
        Gxy == NULL || Gxz == NULL || Gyz == NULL ||
        data == NULL)
    {
        if (npts < 1){fprintf(stderr, "%s: no data points\n", __func__);}
        if (npgrns < 1){fprintf(stderr, "%s: no grns fns points\n", __func__);}
        if (data == NULL){fprintf(stderr, "%s: data is NULL\n", __func__);}
        if (Gxx == NULL){fprintf(stderr, "%s: Gxx is NULL\n", __func__);}
        if (Gyy == NULL){fprintf(stderr, "%s: Gyy is NULL\n", __func__);}
        if (Gzz == NULL){fprintf(stderr, "%s: Gzz is NULL\n", __func__);}
        if (Gxy == NULL){fprintf(stderr, "%s: Gxy is NULL\n", __func__);}
        if (Gxz == NULL){fprintf(stderr, "%s: Gxz is NULL\n", __func__);}
        if (Gyz == NULL){fprintf(stderr, "%s: Gyz is NULL\n", __func__);}
        return -1;
    }
    if (lc > lxc)
    {
        fprintf(stderr, "%s: Error xc is too small\n", __func__);
        return -1;
    }
    if (ldm < 6 || nmt < 1 || mt == NULL)
    {
        if (ldm < 6){fprintf(stderr, "%s: ldm must be >= 6\n", __func__);}
        if (nmt < 1){fprintf(stderr, "%s: no moment tensors\n", __func__);}
        if (mt == NULL){fprintf(stderr, "%s: mt is NULL\n", __func__);}
        return -1;
    }
    // Set space and correlate data with columns of G
    xcorr = memory_calloc64f(lc);
    Gmat = memory_calloc64f(8*npgrns);
    Gxc = memory_calloc64f(8*lc);
    dscal = cblas_dnrm2(npts, data, 1);
    dscal = dscal*dscal;
#ifdef __INTEL_COMPILER
__assume_aligned(Gxc, 64);
__assume_aligned(Gmat, 64);
__assume_aligned(xcorr, 64);
__assume_aligned(xc, 64);
#endif
    for (i=0; i<6; i++)
    {
        if (i == 0)
        {
            cblas_dcopy(npgrns, Gxx, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gxx,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        else if (i == 1)
        {
            cblas_dcopy(npgrns, Gyy, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gyy,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        else if (i == 2)
        {
            cblas_dcopy(npgrns, Gzz, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gzz,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        else if (i == 3)
        {
            cblas_dcopy(npgrns, Gxy, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gxy,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        else if (i == 4)
        {
            cblas_dcopy(npgrns, Gxz, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gxz,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        else if (i == 5)
        {
            cblas_dcopy(npgrns, Gyz, 1, &Gmat[i], 8);
            ierr = signal_convolve_correlate64f_work(npts, data,
                                                     npgrns,
                                                     Gyz,
                                                     CONVCOR_FULL,
                                                     lc, xcorr);
        }
        if (ierr != 0)
        {
            fprintf(stderr, "%s: Error correlating Greens fn: %d\n",
                    __func__, i+1);
            return -1;
        }
        cblas_dcopy(lc, xcorr, 1, &Gxc[i], 8);
    }
    array_zeros64f_work(lxc, xc);
    // Compute \f$ x_c = \sum_{i=1}^{n_{mt}} G \textbf{m} \star \textbf{d} \f$
#pragma omp parallel shared(Gxc, Gmat, mt, lc, xc) \
        firstprivate (dscal, xcorr) \
        private (est, gscal, xscal, i, j, m6, xcw) default(none)
{
    xcw = memory_calloc64f(lxc);
#ifdef __INTEL_COMILER
__assume_aligned(xcw, 64);
#endif
    #pragma omp for
    for (i=0; i<nmt; i++)
    {
        m6[0] = mt[ldm*i  ];
        m6[1] = mt[ldm*i+1];
        m6[2] = mt[ldm*i+2];
        m6[3] = mt[ldm*i+3];
        m6[4] = mt[ldm*i+4];
        m6[5] = mt[ldm*i+5];
        // compute the energy in the synthetic
        gscal = 0.0;
        for (j=0; j<npgrns; j++)
        {
            est = Gmat[8*j+0]*m6[0] + Gmat[8*j+1]*m6[1] + Gmat[8*j+2]*m6[2]
                + Gmat[8*j+3]*m6[3] + Gmat[8*j+4]*m6[4] + Gmat[8*j+5]*m6[5];
            gscal = gscal + est*est;
        }
        xscal = 1.0/sqrt(dscal*gscal);
        // compute the normalized cross-correlation
        for (j=0; j<lc; j++)
        {
            est = Gxc[8*j+0]*m6[0] + Gxc[8*j+1]*m6[1] + Gxc[8*j+2]*m6[2]
                + Gxc[8*j+3]*m6[3] + Gxc[8*j+4]*m6[4] + Gxc[8*j+5]*m6[5];
            xcw[j] = xcw[j] + xscal*est;
        }
        //cblas_dgemv(CblasRowMajor, CblasNoTrans,
        //            lc, 6, 1.0, G, 8, &mt[8*i], 1, 1.0, xcw, 1);
    }
    #pragma omp critical
    #pragma omp simd
    for (i=0; i<lxc; i++)
    {
        xc[i] = xc[i] + xcw[i];
    }
    memory_free64f(&xcw);
}
    // normalize by the number of moment tensors
    cblas_dscal(lc, 1.0/(double) nmt, xc, 1);
    // free memory
    memory_free64f(&Gxc);
    memory_free64f(&Gmat);
    memory_free64f(&xcorr);
    return 0;
}


/* sys/test.c
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2007 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 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 <stdio.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_test.h>
#include <gsl/gsl_ieee_utils.h>

int
main (void)
{
  double y, y_expected;
  int e, e_expected;

  gsl_ieee_env_setup ();

  /* Test for expm1 */

  y = gsl_expm1 (0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.0)");

  y = gsl_expm1 (1e-10);
  y_expected = 1.000000000050000000002e-10;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(1e-10)");

  y = gsl_expm1 (-1e-10);
  y_expected = -9.999999999500000000017e-11;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-1e-10)");

  y = gsl_expm1 (0.1);
  y_expected = 0.1051709180756476248117078264902;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(0.1)");

  y = gsl_expm1 (-0.1);
  y_expected = -0.09516258196404042683575094055356;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-0.1)");

  y = gsl_expm1 (10.0);
  y_expected = 22025.465794806716516957900645284;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(10.0)");

  y = gsl_expm1 (-10.0);
  y_expected = -0.99995460007023751514846440848444;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_expm1(-10.0)");

  /* Test for log1p */

  y = gsl_log1p (0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.0)");

  y = gsl_log1p (1e-10);
  y_expected = 9.9999999995000000000333333333308e-11;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(1e-10)");

  y = gsl_log1p (0.1);
  y_expected = 0.095310179804324860043952123280765;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(0.1)");

  y = gsl_log1p (10.0);
  y_expected = 2.3978952727983705440619435779651;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_log1p(10.0)");

  /* Test for gsl_hypot */

  y = gsl_hypot (0.0, 0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(0.0, 0.0)");

  y = gsl_hypot (1e-10, 1e-10);
  y_expected = 1.414213562373095048801688e-10;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, 1e-10)");

  y = gsl_hypot (1e-38, 1e-38);
  y_expected = 1.414213562373095048801688e-38;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-38, 1e-38)");

  y = gsl_hypot (1e-10, -1.0);
  y_expected = 1.000000000000000000005;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e-10, -1)");

  y = gsl_hypot (-1.0, 1e-10);
  y_expected = 1.000000000000000000005;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(-1, 1e-10)");

  y = gsl_hypot (1e307, 1e301);
  y_expected = 1.000000000000499999999999e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e301)");

  y = gsl_hypot (1e301, 1e307);
  y_expected = 1.000000000000499999999999e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e301, 1e307)");

  y = gsl_hypot (1e307, 1e307);
  y_expected = 1.414213562373095048801688e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1e307, 1e307)");

  /* Test +-Inf, finite */

  y = gsl_hypot (GSL_POSINF, 1.2);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_POSINF, 1.2)");

  y = gsl_hypot (GSL_NEGINF, 1.2);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NEGINF, 1.2)");

  y = gsl_hypot (1.2, GSL_POSINF);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_POSINF)");

  y = gsl_hypot (1.2, GSL_NEGINF);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_NEGINF)");

  /* Test NaN, finite */

  y = gsl_hypot (GSL_NAN, 1.2);
  y_expected = GSL_NAN;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, 1.2)");

  y = gsl_hypot (1.2, GSL_NAN);
  y_expected = GSL_NAN;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(1.2, GSL_NAN)");

  /* Test NaN, NaN */

  y = gsl_hypot (GSL_NAN, GSL_NAN);
  y_expected = GSL_NAN;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_NAN)");

  /* Test +Inf, NaN */

  y = gsl_hypot (GSL_POSINF, GSL_NAN);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_POSINF, GSL_NAN)");

  /* Test -Inf, NaN */

  y = gsl_hypot (GSL_NEGINF, GSL_NAN);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NEGINF, GSL_NAN)");

  /* Test NaN, +Inf */

  y = gsl_hypot (GSL_NAN, GSL_POSINF);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_POSINF)");

  /* Test NaN, -Inf */

  y = gsl_hypot (GSL_NAN, GSL_NEGINF);
  y_expected = GSL_POSINF;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot(GSL_NAN, GSL_NEGINF)");

  /* Test for gsl_hypot3 */

  y = gsl_hypot3 (0.0, 0.0, 0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(0.0, 0.0, 0.0)");

  y = gsl_hypot3 (1e-10, 1e-10, 1e-10);
  y_expected = 1.732050807568877293527446e-10;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, 1e-10, 1e-10)");

  y = gsl_hypot3 (1e-38, 1e-38, 1e-38);
  y_expected = 1.732050807568877293527446e-38;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-38, 1e-38, 1e-38)");

  y = gsl_hypot3 (1e-10, 1e-10, -1.0);
  y_expected = 1.000000000000000000099;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, 1e-10, -1)");

  y = gsl_hypot3 (1e-10, -1.0, 1e-10);
  y_expected = 1.000000000000000000099;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e-10, -1, 1e-10)");

  y = gsl_hypot3 (-1.0, 1e-10, 1e-10);
  y_expected = 1.000000000000000000099;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(-1, 1e-10, 1e-10)");

  y = gsl_hypot3 (1e307, 1e301, 1e301);
  y_expected = 1.0000000000009999999999995e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e301, 1e301)");

  y = gsl_hypot3 (1e307, 1e307, 1e307);
  y_expected = 1.732050807568877293527446e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e307, 1e307)");

  y = gsl_hypot3 (1e307, 1e-307, 1e-307);
  y_expected = 1.0e307;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_hypot3(1e307, 1e-307, 1e-307)");

  /* Test for acosh */

  y = gsl_acosh (1.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.0)");

  y = gsl_acosh (1.1);
  y_expected = 4.435682543851151891329110663525e-1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1.1)");

  y = gsl_acosh (10.0);
  y_expected = 2.9932228461263808979126677137742e0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(10.0)");

  y = gsl_acosh (1e10);
  y_expected = 2.3718998110500402149594646668302e1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_acosh(1e10)");

  /* Test for asinh */

  y = gsl_asinh (0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.0)");

  y = gsl_asinh (1e-10);
  y_expected = 9.9999999999999999999833333333346e-11;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");

  y = gsl_asinh (-1e-10);
  y_expected = -9.9999999999999999999833333333346e-11;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e-10)");

  y = gsl_asinh (0.1);
  y_expected = 9.983407889920756332730312470477e-2;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(0.1)");

  y = gsl_asinh (-0.1);
  y_expected = -9.983407889920756332730312470477e-2;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-0.1)");

  y = gsl_asinh (1.0);
  y_expected = 8.8137358701954302523260932497979e-1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1.0)");

  y = gsl_asinh (-1.0);
  y_expected = -8.8137358701954302523260932497979e-1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1.0)");

  y = gsl_asinh (10.0);
  y_expected = 2.9982229502979697388465955375965e0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(10)");

  y = gsl_asinh (-10.0);
  y_expected = -2.9982229502979697388465955375965e0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-10)");

  y = gsl_asinh (1e10);
  y_expected = 2.3718998110500402149599646668302e1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(1e10)");

  y = gsl_asinh (-1e10);
  y_expected = -2.3718998110500402149599646668302e1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_asinh(-1e10)");

  /* Test for atanh */

  y = gsl_atanh (0.0);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.0)");

  y = gsl_atanh (1e-20);
  y_expected = 1e-20;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(1e-20)");

  y = gsl_atanh (-1e-20);
  y_expected = -1e-20;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-1e-20)");

  y = gsl_atanh (0.1);
  y_expected = 1.0033534773107558063572655206004e-1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.1)");

  y = gsl_atanh (-0.1);
  y_expected = -1.0033534773107558063572655206004e-1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(-0.1)");

  y = gsl_atanh (0.9);
  y_expected = 1.4722194895832202300045137159439e0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");

  y = gsl_atanh (-0.9);
  y_expected = -1.4722194895832202300045137159439e0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_atanh(0.9)");

  /* Test for pow_int */

  y = gsl_pow_2 (-3.14);
  y_expected = pow (-3.14, 2.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_2(-3.14)");

  y = gsl_pow_3 (-3.14);
  y_expected = pow (-3.14, 3.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_3(-3.14)");

  y = gsl_pow_4 (-3.14);
  y_expected = pow (-3.14, 4.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_4(-3.14)");

  y = gsl_pow_5 (-3.14);
  y_expected = pow (-3.14, 5.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_5(-3.14)");

  y = gsl_pow_6 (-3.14);
  y_expected = pow (-3.14, 6.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_6(-3.14)");

  y = gsl_pow_7 (-3.14);
  y_expected = pow (-3.14, 7.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_7(-3.14)");

  y = gsl_pow_8 (-3.14);
  y_expected = pow (-3.14, 8.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_8(-3.14)");

  y = gsl_pow_9 (-3.14);
  y_expected = pow (-3.14, 9.0);
  gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_9(-3.14)");

  {
    int n;
    for (n = -9; n < 10; n++)
      {
        y = gsl_pow_int (-3.14, n);
        y_expected = pow (-3.14, n);
        gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_int(-3.14,%d)", n);
      }
  }

  {
    unsigned int n;
    for (n = 0; n < 10; n++)
      {
        y = gsl_pow_uint (-3.14, n);
        y_expected = pow (-3.14, n);
        gsl_test_rel (y, y_expected, 1e-15, "gsl_pow_uint(-3.14,%d)", n);
      }
  }

  /* Test case for n at INT_MAX, INT_MIN */

  {
    double u = 1.0000001;
    int n = INT_MAX;
    y = gsl_pow_int (u, n);
    y_expected = pow (u, n);
    gsl_test_rel (y, y_expected, 1e-6, "gsl_pow_int(%.7f,%d)", u, n);

    n = INT_MIN;
    y = gsl_pow_int (u, n);
    y_expected = pow (u, n);
    gsl_test_rel (y, y_expected, 1e-6, "gsl_pow_int(%.7f,%d)", u, n);
  }

  /* Test for ldexp */

  y = gsl_ldexp (M_PI, -2);
  y_expected = M_PI_4;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(pi,-2)");

  y = gsl_ldexp (1.0, 2);
  y_expected = 4.000000;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(1.0,2)");

  y = gsl_ldexp (0.0, 2);
  y_expected = 0.0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(0.0,2)");

  y = gsl_ldexp (9.999999999999998890e-01, 1024);
  y_expected = GSL_DBL_MAX;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp DBL_MAX");

  y = gsl_ldexp (1e308, -2000);
  y_expected = 8.7098098162172166755761e-295;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(1e308,-2000)");

  y = gsl_ldexp (GSL_DBL_MIN, 2000);
  y_expected = 2.554675596204441378334779940e294;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(DBL_MIN,2000)");

  /* Test subnormals */

  {
    int i = 0;
    volatile double x = GSL_DBL_MIN;
    y_expected = 2.554675596204441378334779940e294;

    x /= 2;
    while (x > 0)
      {
        i++ ;
        y = gsl_ldexp (x, 2000 + i);
        gsl_test_rel (y, y_expected, 1e-15, "gsl_ldexp(DBL_MIN/2**%d,%d)",i,2000+i);
        x /= 2;
      }
  }

  /* Test for frexp */

  y = gsl_frexp (0.0, &e);
  y_expected = 0;
  e_expected = 0;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(0) exponent");

  y = gsl_frexp (M_PI, &e);
  y_expected = M_PI_4;
  e_expected = 2;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(pi) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(pi) exponent");

  y = gsl_frexp (2.0, &e);
  y_expected = 0.5;
  e_expected = 2;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(2.0) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(2.0) exponent");

  y = gsl_frexp (1.0 / 4.0, &e);
  y_expected = 0.5;
  e_expected = -1;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(0.25) exponent");

  y = gsl_frexp (1.0 / 4.0 - 4.0 * GSL_DBL_EPSILON, &e);
  y_expected = 0.999999999999996447;
  e_expected = -2;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(0.25-eps) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(0.25-eps) exponent");

  y = gsl_frexp (GSL_DBL_MAX, &e);
  y_expected = 9.999999999999998890e-01;
  e_expected = 1024;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MAX) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(DBL_MAX) exponent");

  y = gsl_frexp (-GSL_DBL_MAX, &e);
  y_expected = -9.999999999999998890e-01;
  e_expected = 1024;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(-DBL_MAX) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(-DBL_MAX) exponent");

  y = gsl_frexp (GSL_DBL_MIN, &e);
  y_expected = 0.5;
  e_expected = -1021;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MIN) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(DBL_MIN) exponent");

  y = gsl_frexp (-GSL_DBL_MIN, &e);
  y_expected = -0.5;
  e_expected = -1021;
  gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(-DBL_MIN) fraction");
  gsl_test_int (e, e_expected, "gsl_frexp(-DBL_MIN) exponent");

  /* Test subnormals */

  {
    int i = 0;
    volatile double x = GSL_DBL_MIN;
    y_expected = 0.5;
    e_expected = -1021;

    x /= 2;

    while (x > 0)
      {
        e_expected--;
        i++ ;

        y = gsl_frexp (x, &e);
        gsl_test_rel (y, y_expected, 1e-15, "gsl_frexp(DBL_MIN/2**%d) fraction",i);
        gsl_test_int (e, e_expected, "gsl_frexp(DBL_MIN/2**%d) exponent", i);
        x /= 2;
      }
  }

  /* Test for approximate floating point comparison */
  {
    double x, y;
    int i;

    x = M_PI;
    y = 22.0 / 7.0;

    /* test the basic function */

    for (i = 0; i < 10; i++)
      {
        double tol = pow (10, -i);
        int res = gsl_fcmp (x, y, tol);
        gsl_test_int (res, -(i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", x, y, tol);
      }

    for (i = 0; i < 10; i++)
      {
        double tol = pow (10, -i);
        int res = gsl_fcmp (y, x, tol);
        gsl_test_int (res, (i >= 4), "gsl_fcmp(%.5f,%.5f,%g)", y, x, tol);
      }
  }

#if HAVE_IEEE_COMPARISONS
  /* Test for isinf, isnan, finite */

  {
    double zero, one, inf, nan;
    int s;

    zero = 0.0;
    one = 1.0;
    inf = exp (1.0e10);
    nan = inf / inf;

    s = gsl_isinf (zero);
    gsl_test_int (s, 0, "gsl_isinf(0)");

    s = gsl_isinf (one);
    gsl_test_int (s, 0, "gsl_isinf(1)");

    s = gsl_isinf (inf);
    gsl_test_int (s, 1, "gsl_isinf(inf)");

    s = gsl_isinf (-inf);
    gsl_test_int (s, -1, "gsl_isinf(-inf)");

    s = gsl_isinf (nan);
    gsl_test_int (s, 0, "gsl_isinf(nan)");

    s = gsl_isnan (zero);
    gsl_test_int (s, 0, "gsl_isnan(0)");

    s = gsl_isnan (one);
    gsl_test_int (s, 0, "gsl_isnan(1)");

    s = gsl_isnan (inf);
    gsl_test_int (s, 0, "gsl_isnan(inf)");

    s = gsl_isnan (-inf);
    gsl_test_int (s, 0, "gsl_isnan(-inf)");

    s = gsl_isnan (nan);
    gsl_test_int (s, 1, "gsl_isnan(nan)");

    s = gsl_finite (zero);
    gsl_test_int (s, 1, "gsl_finite(0)");

    s = gsl_finite (one);
    gsl_test_int (s, 1, "gsl_finite(1)");

    s = gsl_finite (inf);
    gsl_test_int (s, 0, "gsl_finite(inf)");

    s = gsl_finite (-inf);
    gsl_test_int (s, 0, "gsl_finite(-inf)");

    s = gsl_finite (nan);
    gsl_test_int (s, 0, "gsl_finite(nan)");
  }
#endif

  {
    double x = gsl_fdiv (2.0, 3.0);
    gsl_test_rel (x, 2.0 / 3.0, 4 * GSL_DBL_EPSILON, "gsl_fdiv(2,3)");
  }

  /* Test constants in gsl_math.h */

  {
    double x = log(M_E);
    gsl_test_rel (x, 1.0, 4 * GSL_DBL_EPSILON, "ln(M_E)");
  }

  {
    double x=pow(2.0,M_LOG2E);
    gsl_test_rel (x, exp(1.0), 4 * GSL_DBL_EPSILON, "2^M_LOG2E");
  }

  {
    double x=pow(10.0,M_LOG10E);
    gsl_test_rel (x, exp(1.0), 4 * GSL_DBL_EPSILON, "10^M_LOG10E");
  }

  {
    double x=pow(M_SQRT2, 2.0);
    gsl_test_rel (x, 2.0, 4 * GSL_DBL_EPSILON, "M_SQRT2^2");
  }

  {
    double x=pow(M_SQRT1_2, 2.0);
    gsl_test_rel (x, 1.0/2.0, 4 * GSL_DBL_EPSILON, "M_SQRT1_2");
  }

  {
    double x=pow(M_SQRT3, 2.0);
    gsl_test_rel (x, 3.0, 4 * GSL_DBL_EPSILON, "M_SQRT3^2");
  }

  {
    double x = M_PI;
    gsl_test_rel (x, 3.1415926535897932384626433832795, 4 * GSL_DBL_EPSILON, "M_PI");
  }

  {
    double x = 2 * M_PI_2;
    gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "2*M_PI_2");
  }

  {
    double x = 4 * M_PI_4;
    gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "4*M_PI_4");
  }

  {
    double x = pow(M_SQRTPI, 2.0);
    gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "M_SQRTPI^2");
  }

  {
    double x = pow(M_2_SQRTPI, 2.0);
    gsl_test_rel (x, 4/M_PI, 4 * GSL_DBL_EPSILON, "M_SQRTPI^2");
  }

  {
    double x = M_1_PI;
    gsl_test_rel (x, 1/M_PI, 4 * GSL_DBL_EPSILON, "M_1_SQRTPI");
  }

  {
    double x = M_2_PI;
    gsl_test_rel (x, 2.0/M_PI, 4 * GSL_DBL_EPSILON, "M_2_PI");
  }

  {
    double x = exp(M_LN10);
    gsl_test_rel (x, 10, 4 * GSL_DBL_EPSILON, "exp(M_LN10)");
  }

  {
    double x = exp(M_LN2);
    gsl_test_rel (x, 2, 4 * GSL_DBL_EPSILON, "exp(M_LN2)");
  }

  {
    double x = exp(M_LNPI);
    gsl_test_rel (x, M_PI, 4 * GSL_DBL_EPSILON, "exp(M_LNPI)");
  }

  {
    double x = M_EULER;
    gsl_test_rel (x, 0.5772156649015328606065120900824, 4 * GSL_DBL_EPSILON, "M_EULER");
  }

  exit (gsl_test_summary ());
}