/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
   @file pgp.c
   @brief Interface to pgplot

   Some usage of pgplot.Functionality goes like this: With filling the
   struct pgp_gdsc the user defines a layout of a plot, which consists
   of a number of viewgraphs with the same x-axis range. A default
   struct of that type is delivered by the routine pgp_default. A
   pgplot device is activated (and must be activated) by calling the
   routine pgp_opendev(). Then, a box is drawn by calling the routine
   pgp_openbox. With a call of that function an appropriate pgplot
   viewport is defined to enable the user to plot his viewgraph in the
   box by calling functions pgp_marker(), pgp_lines(), pgp_bars(), and
   pgp_errby(). With pgp_legend(), a string can be plotted to a legend
   line. The routine pgp_end() will terminate the plotting process
   properly.

   An example can be accessed with testpgp.c.

   $Source: /Volumes/DATA_J_II/data/CVS/tirific/src/pgp.c,v $
   $Date: 2011/05/25 22:25:26 $
   $Revision: 1.14 $
   $Author: jozsa $
   $Log: pgp.c,v $
   Revision 1.14  2011/05/25 22:25:26  jozsa
   Left work

   Revision 1.13  2011/05/10 00:30:16  jozsa
   Left work

   Revision 1.12  2009/05/26 07:56:41  jozsa
   Left work

   Revision 1.11  2007/08/22 15:58:43  gjozsa
   Left work

   Revision 1.10  2006/11/22 14:16:21  gjozsa
   Bugfix concerning RASH and horizontal/vertical lines

   Revision 1.9  2006/11/03 10:49:02  gjozsa
   Introduced logarithmic scaling, hms dms

   Revision 1.8  2006/10/05 12:39:58  gjozsa
   nasty bugfix

   Revision 1.7  2006/04/03 11:47:57  gjozsa
   Left work

   Revision 1.6  2006/02/08 16:13:17  gjozsa
   Extended graphics routines

   Revision 1.5  2005/10/12 14:51:25  gjozsa
   First point gets thick in the polar plot

   Revision 1.4  2005/10/12 09:53:09  gjozsa
   Included polar plot facility

   Revision 1.3  2005/06/24 12:00:29  gjozsa
   Left work

   Revision 1.2  2005/05/24 10:42:24  gjozsa
   Left work

   Revision 1.1  2005/05/17 12:58:15  gjozsa
   Added to cvs control

*/
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* EXTERNAL INCLUDES */
/* ------------------------------------------------------------ */
#include <stdio.h>
#include <cpgplot.h>
#include <math.h>
#include <string.h>
#include <float.h>
#include <stdlib.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_spline.h>

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* INTERNAL INCLUDES */
/* ------------------------------------------------------------ */
#include <pgp.h>
#include <maths.h>

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
   @def _MEMORY_HERE_ON
   @brief Controls the use of the memory_here module

   If you don't want to use the memory_here facility comment this
   define, otherways it will be included.

*/
/* ------------------------------------------------------------ */
/* #define _MEMORY_HERE_ON */
/* #include <memory_here.h> */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* PRIVATE SYMBOLIC CONSTANTS */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
   @define DEGTORAD
   @brief Conversion factor from deg to rad
*/
/* ------------------------------------------------------------ */
#define DEGTORAD 0.0174532925199433

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
   @define LOGFAULT
   @brief If a logarithm is asked for for a negative number or 0 this should be redurned
*/
/* ------------------------------------------------------------ */
#define LOGFAULT -40

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* PRIVATE MACROS */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* (PRIVATE) GLOBAL VARIABLES */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* PRIVATE TYPEDEFS */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* PRIVATE STRUCTS */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* PRIVATE FUNCTION DECLARATIONS */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
  @fn int putalabel(char where, char *overfrac, char underfrac, float charheight, float xmin, float xmax)
  @brief Puts a label at a viewgraph as a fraction

  Requires an open viewgraph, and the character height set to the axis
  numbering height. If both overfrac and underfrac are filled, then a fraction will be plotted. If one of both is an empty string (not NULL), then no fraction bar will be plotted.

  @param where      (char)   t, b, l, r position of the label
  @param overfrac   (char *) Text above the fraction bar
  @param underfrac  (char *) Text below the fraction bar
  @param charheight (float)  Character height relative to the actual character height, which should be set to the numbering height.
  @param dist       (float)  Distance from the axis baseline in units of the initial height
  @return (success) int putalabel: 1\\
          (error)   0

*/
/* ------------------------------------------------------------ */
int putalabel(char where, char *overfrac, char *underfrac, float charheight, float dist);

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
  @fn float pgp_logf10f(float x)
  @brief Returns the logarithm on basis 10 and LOGFAULT if x <= 0

  @param x (float) number to calculate the logarithm of
  @return logarithm of the number or, if impossible, LOGFAULT

*/
/* ------------------------------------------------------------ */
float pgp_logf10f(float x);

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/**
  @fn static int pgp_get_interparray(float *x, float *y, int npoints, int interptype, int nout, float **xout, float **yout)
  @brief Returns an array of interpolated values.

  Assumes an array of npoints x-y pairs as an input. Checks if x is strictly monotonically increasing. If *xout is not NULL, deallocates *xout. If *yout is not NULL, deallocates *yout. Allocates an array *xout of nout equally-spaced points with xout[0] = x[0] and xout[nout-1] = x[nout-1]. Allocates an array *yout of nout data points where the ith data point is an interpolation between x and y at the position xout[i]. interptype determines the interpolation type, which can be  PGP_I_LINEAR: linear; PGP_I_CSPLINE: cubic natural spline; PGP_I_AKIMA: Akima .

  @param x          (float * ) input data points, abscissae, must be strictly increasing
  @param y 	    (float * ) input data points, ordinate
  @param npoints    (  int   ) input number of data points
  @param interptype (  int   ) input interpolation type: PGP_I_LINEAR: linear; PGP_I_CSPLINE: cubic natural spline; PGP_I_AKIMA: Akima
  @param nout	    (  int   ) input number of output data points
  @param xout 	    (float **) output data array x-values (equally spaced)
  @param yout 	    (float **) output data array y-values

  @return logarithm of the number or, if impossible, LOGFAULT

*/
/* ------------------------------------------------------------ */
 static int pgp_get_interparray(float *x, float *y, int npoints, int interptype, int nout, float **xout, float **yout);

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */
/* FUNCTION CODE */
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Opens the pgplot device as specified */
int pgp_opendev(char *device_name)
{
  int val;

  if (device_name)
    if (device_name[0]) {
      val = cpgbeg(0,device_name,1,1);

      /* Has to be set 0 for use in gipsy */
      cpgask(1);
      return val;
    }

  return 0;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Returns a default pgp_gdsc struct */
pgp_gdsc *pgp_gdsc_default(int nplots, int legendcols, int legendrows, float charheight)
{
  pgp_gdsc *gdsc;
  /* int i;  Control variable */
  float chrhtx; /* Horizontal character width in x-map units, 1 is whole page */
  float chrhty; /* Vertical character height in y-map units, 1 is whole page */
  float chrhtxref; /* Reference charheight */
  float scalexy; /* scale from x size of numbers to y size of numbers
		    (is the same physical size, but in terms of window
		    size they are different) */
  float pltheight;

  /* Allocate */
  if (!(gdsc = (pgp_gdsc *) malloc(sizeof(pgp_gdsc))))
    return NULL;

  /* Find the reference */
  cpgsch(1.0);
  cpgqcs(0, &chrhtxref, &chrhty);

  /* This is a scale */
  scalexy = chrhty/chrhtxref;

  /* Now, the character height in window units is like this */
  chrhtx = chrhtxref*charheight;

  /* Fill with default values */

  /* Number of plots */
  gdsc -> nplots = nplots;

  /* Symbols and descriptors in charheight, but at most one
     third??? of the plot height until the numbering is finished */

  /* The height of the plot is 1.0 at the start */
  pltheight = 1.0;

  /* The number is reduced by the axis description + 1 character */
  pltheight = pltheight-12.3*chrhty;

  /* Then, for each legend line, two characters */
  pltheight = pltheight-2.0*legendrows*chrhty;

  /* Then, each plot has only 1/nplots height */
  pltheight = pltheight/nplots;

  /* At the end, each plot has a margin of 4 heights at the top for the numbering */
  pltheight = pltheight-4.0*chrhty;

  /* We could express this as: */
  /* (1.0-12.3*chrhty-2.0*legendrows*chrhty)/nplots-4.0*chrhty */

  /* If this leaves room for 3 (???) numbers, then we apply the character height else we adjust the height */
  if (chrhty*3 > pltheight)
    chrhty = 1/(12.3+2*legendrows+7.0*nplots);

  chrhtx= chrhty/scalexy;

  gdsc -> numberheight = chrhtx/chrhtxref;
  gdsc -> symbolheight = 1.0;
  gdsc -> legendheight = 1.0;
  gdsc -> axdescheight = 1.0;

  /* legend */
  gdsc -> legendcols = legendcols;
  gdsc -> legendrows = legendrows;

  /* Horizontal and vertical borders are 2 characters */
  gdsc -> verbord = 2.0;
  gdsc -> horbord = 2.0;

  /* Stop of the axis numbering is 2 characters, only for the top of the graph */
  gdsc -> leftnum = 0.0;
  gdsc -> rightnum = 0.0;
  gdsc -> botnum = 0.0;
  gdsc -> topnum = 1.0;

  /* Margins */
  gdsc -> leftmargin = 7.0;
  gdsc -> rightmargin = 7.0;
  gdsc -> bottommargin = 1.8;
  gdsc -> topmargin = 2.5;

  /* Linewidths */
  gdsc -> graphlw = 1;
  gdsc -> boxlw = 1;

  /* reserve and return an initialised array for the axis labelling */
/*   if (!(gdsc -> logarcsx = (int *) malloc(gdsc -> nplots*sizeof(int)))){ */
/*     free(gdsc); */
/*     return 0; */
/*   } */
/*   for (i = 0; i < gdsc -> nplots; ++i) */
/*     gdsc -> logarcsx[i] = 0; */

  /* reserve and return an initialised array for the axis labelling */
/*   if (!(gdsc -> logarcsy = (int *) malloc(gdsc -> nplots*sizeof(int)))){ */
/*     free(gdsc -> logarcsx); */
/*     free(gdsc); */
/*     return 0; */
/*   } */
/*   for (i = 0; i < gdsc -> nplots; ++i) */
/*     gdsc -> logarcsy[i] = 0; */
  gdsc -> logarcsx = 0;
  gdsc -> logarcsy = 0;
  gdsc -> interptype_lines = PGP_I_LINEAR;
  gdsc -> interp_numlines = 500;

  return gdsc;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Make a polar diagram on an open device */
void pgp_polar(int ndots, float *xarray, float *yarray, int nlines, float *xlarray, float *ylarray, int nradii, float *radiis, float *lineangle, int linewidth, int circlewidth, int symbolwidth, int colour)
{
  int i;
  float rmax = 0;
  float twopointsx[2];
  float twopointsy[2];
  float xv1,yv1;
  float *radii;
  rmax = 0;

  /* Allocte memory for radii */
  if (!(radii = (float *) malloc(nradii*sizeof(float))))
    return;

  /* First find out about the extent of the graph */
  for (i = 0; i < ndots; ++i) {
    if (rmax < fabs(xarray[i]))
      rmax = fabs(xarray[i]);
    if (rmax < fabs(yarray[i]))
      rmax = fabs(yarray[i]);
  }

  for (i = 0; i < nlines; ++i) {
    if (rmax < fabs(xlarray[i]))
      rmax = fabs(xlarray[i]);
    if (rmax < fabs(ylarray[i]))
      rmax = fabs(ylarray[i]);
  }

  /* We make a local copy of the radii */

  for (i = 0; i < nradii; ++i) {
    radii[i] = fabs(radiis[i]);
    if (rmax < radii[i])
      rmax = radii[i];
  }

  /* Now scale rmax a bit */
  rmax = rmax*1.02;

  /* Define a drawing area, must be quadratic */
  cpgenv(-rmax, rmax, -rmax, rmax, 1, -2);

  /* Check the linewidths */
  if (linewidth < 1)
    linewidth = 1;
  if (linewidth > 201)
    linewidth = 201;
  if (circlewidth < 1)
    circlewidth = 1;
  if (circlewidth > 201)
    circlewidth = 201;
  if (symbolwidth < 1)
    symbolwidth = 1;
  if (symbolwidth > 201)
    symbolwidth = 201;

  /* Set the colour index foreground */
  cpgsci(1);

  /* Draw the circles */
  if (nradii > 0) {
    cpgslw(circlewidth);

    /* Make the circles open */
    cpgsfs(2);

    /* Chose a dashed style */
    cpgsls(4);

    for (i = 0; i < (nradii-1); ++i)
      cpgcirc(0,0, radii[i]);

    /* Draw the last circle, solid line with double width, solid */
    cpgsls(1);

    if (circlewidth > 100)
      circlewidth = 201;
    else
      circlewidth = 2*circlewidth;

    cpgslw(circlewidth);

    cpgcirc(0,0, radii[nradii-1]);

    /* Now do the Briggs style thingies */
    twopointsx[0] = 0;
    twopointsx[1] = 0;
    twopointsy[0] = radii[nradii-1];
    twopointsy[1] = radii[nradii-1]-0.05*radii[nradii-1];
    cpgline(2, twopointsx, twopointsy);

    twopointsx[0] = 0;
    twopointsx[1] = 0;
    twopointsy[0] = -radii[nradii-1];
    twopointsy[1] = -radii[nradii-1]+0.05*radii[nradii-1];
    cpgline(2, twopointsx, twopointsy);

    twopointsy[0] = 0;
    twopointsy[1] = 0;
    twopointsx[0] = radii[nradii-1];
    twopointsx[1] = radii[nradii-1]-0.05*radii[nradii-1];
    cpgline(2, twopointsx, twopointsy);

    twopointsy[0] = 0;
    twopointsy[1] = 0;
    twopointsx[0] = -radii[nradii-1];
    twopointsx[1] = -radii[nradii-1]+0.05*radii[nradii-1];
    cpgline(2, twopointsx, twopointsy);

    /* Check whether to plot a point */
    for (i = 0; i < (nradii); ++i) {
      if (radii[i] == 0){
	xv1 = yv1 = 0;
	cpgpt(1, &xv1, &yv1, -1);
      }
    }
    }
    /* Draw the reference thing */
    if ((lineangle)) {
      cpgslw(linewidth);
      twopointsy[0] = 0;
      twopointsy[1] = cos(DEGTORAD*(*lineangle))*radii[nradii-1];
      twopointsx[0] = 0;
      twopointsx[1] = -sin(DEGTORAD*(*lineangle))*radii[nradii-1];
    cpgline(2, twopointsx, twopointsy);
    }

  /* Plot the points */

  /* Set the linewidth */
  cpgslw(symbolwidth);

  /* Set the colour */
  cpgsci(colour);

 /* Plot points, number of points, vectors for x and y, symbol */
  if (ndots > 0)
  cpgpt(ndots, xarray, yarray, -1);

  /* Make a first dot */
  symbolwidth *= 2;
  if (symbolwidth > 201)
    symbolwidth = 210;
  cpgslw(symbolwidth);

  cpgpt(1, xarray, yarray, -1);

  /* Draw the lines */
  /* Set the linewidth */
  if (nlines > 1) {
  cpgslw(linewidth);
  cpgline(nlines, xlarray, ylarray);
  }

  /* Finished */
  return;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Opens a box in an opened window with a few specifications */
int pgp_openbox(pgp_gdsc *gdsc, int nplot, float xmin, float xmax, float ymin, float ymax, char *leftdeschi, char *leftdesclo, char *rightdeschi, char *rightdesclo, char *bottomdeschi, char *bottomdesclo, char *topdeschi, char *topdesclo, float lrzero, float lrscale, float btzero, float btscale, int logarcsx, int logarcsy)
{
  float plotheight;
  float chrhtxref;    /* Horizontal character width in x-map units, 1 is whole page */
  float chrhtyref;    /* Vertical character height in y-map units, 1 is whole page */
  /* float scalexy; */    /* scale from x size of numbers to y size of numbers (or inverse scale of x to y size of area */
  float dummy1, dummy2;

  int slw; /* Standard linewidth */

  float xlo; /* Box in window coordinates */
  float xhi;
  float ylo;
  float yhi;

  float xulo; /* Box in user coordinates */
  float xuhi;
  float yulo;
  float yuhi;

  float xlo2; /* Another box in window coordinates */
  float xhi2;
  float ylo2;
  float yhi2;

  float xulo2; /* Another box in user coordinates */
  float xuhi2;
  float yulo2;
  float yuhi2;

  float ax, ay, bx, by; /* linear coefficients from window to user coordinates */

  void (* boxingx)(const char *xopt, float xtick, int nxsub, const char *yopt, float ytick, int nysub);
  void (* boxingy)(const char *xopt, float xtick, int nxsub, const char *yopt, float ytick, int nysub);
  char steringxt[8],steringxb[8],steringyl[8],steringyr[8],steribgxt[8],steribgxb[8],steribgyl[8],steribgyr[8];

  /* First calculate the symbol height and width in map units
		    (is the same physical size, but in terms of window
		    size they are different) */

  /* Check if there is anything to draw */
  if (nplot > gdsc -> nplots || nplot < 1)
    return 0;

  /* Check the scaling */
  if ((logarcsx < 0) || (logarcsx > 3))
    return 0;

  /* per default the function to draw the box is cpgbox */
  boxingx = cpgbox;
  boxingy = cpgbox;

  /* Default numbering style */
  sprintf(steringyr,"MV");
  sprintf(steringyl,"NV");
  sprintf(steringxt,"M");
  sprintf(steringxb,"N");

  sprintf(steribgyr,"CTS");
  sprintf(steribgyl,"BTS");
  sprintf(steribgxt,"CTS");
  sprintf(steribgxb,"BTS");

  /* Default scaling */
  gdsc -> logarcsx = 0;
  gdsc -> logarcsy = 0;

  /* If a different scaling was requested, redefine labelling */
  if (logarcsx == 1) {
    gdsc -> logarcsx = 1;
/*     if (xmin <= 0) */
/*       return 0; */
/*     if (xmax <= 0) */
/*       return 0; */
/*     if ((xmin*btscale+btzero) <= 0) */
/*       return 0; */
/*     if ((xmax*btscale+btzero) <= 0) */
/*       return 0; */

    /* Do a trick */
    dummy1 = pgp_logf10f(xmin*btscale+btzero);
    dummy2 = pgp_logf10f(xmax*btscale+btzero);

    xmin = pgp_logf10f(xmin);
    xmax = pgp_logf10f(xmax);

    if (xmin == xmax) {
      btzero = dummy1-xmin;
      btscale = 0;
    }
    else {
      btscale = (dummy2-dummy1)/(xmax-xmin);
      btzero = dummy2-btscale*xmax;
    }
    sprintf(steringxt,"ML2");
    sprintf(steringxb,"NL2");
    sprintf(steribgxt,"CTSL");
    sprintf(steribgxb,"BTSL");
  }

  if (logarcsy == 1) {
    gdsc -> logarcsy = 1;
/*     if (ymin <= 0) */
/*       return 0; */
/*     if (ymax <= 0) */
/*       return 0; */
/*     if ((ymin*btscale+btzero) <= 0) */
/*       return 0; */
/*     if ((ymax*btscale+btzero) <= 0) */
/*       return 0; */

    /* Do a trick */
    dummy1 = pgp_logf10f(ymin*lrscale+lrzero);
    dummy2 = pgp_logf10f(ymax*lrscale+lrzero);

    ymin = pgp_logf10f(ymin);
    ymax = pgp_logf10f(ymax);

    if (ymin == ymax) {
      lrzero = dummy1-ymin;
      lrscale = 0;
    }
    else {
      lrscale = (dummy2-dummy1)/(ymax-ymin);
      lrzero = dummy2-lrscale*ymax;
    }
    sprintf(steringyr,"MVL2");
    sprintf(steringyl,"NVL2");
    sprintf(steribgyr,"CTSL");
    sprintf(steribgyl,"BTSL");
  }

  /* hms */
  if (logarcsx == 2) {
    gdsc -> logarcsx = 2;
    /* convert to seconds of time, input is interpreted as deg */
    btzero = btzero/240.0;
    btscale = btscale/240.0;
    xmin = xmin*240.0;
    xmax = xmax*240.0;
    boxingx = cpgtbox;
    sprintf(steringxt,"M");
    sprintf(steringxb,"NZH");
    sprintf(steribgxt,"CTS");
    sprintf(steribgxb,"BTSZXYH");
  }
  if (logarcsy == 2) {
    gdsc -> logarcsy = 2;

    /* convert to seconds of time, input is interpreted as deg */
    ymin = ymin*240.0;
    ymax = ymax*240.0;

    /* I'm really not sure why this is not the case */
/*      lrzero = lrzero/240.0; */
     lrscale = lrscale/240.0;
    boxingy = cpgtbox;
    sprintf(steringyr,"MV");
    sprintf(steringyl,"NVZXYH");
    sprintf(steribgyr,"CTS");
    sprintf(steribgyl,"BTSZXYH");
  }

  /* dms */
  if (logarcsx == 3) {
    gdsc -> logarcsx = 3;

    /* convert to seconds of time, input is interpreted as deg */
    xmin = xmin*3600.0;
    xmax = xmax*3600.0;

    /* I'm really not sure why this is not the case */
/*     btzero = btzero/3600.0; */
    btscale = btscale/3600.0;
    boxingx = cpgtbox;
    sprintf(steringxt,"M");
    sprintf(steringxb,"NZD");
    sprintf(steribgxt,"CTS");
    sprintf(steribgxb,"BTSZYD");
  }
  if (logarcsy == 3) {
    gdsc -> logarcsy = 3;

    /* convert to seconds of time, input is interpreted as deg */
    ymin = ymin*3600.0;
    ymax = ymax*3600.0;
/*     lrzero = lrzero/3600.0; */
    lrscale = lrscale/3600.0;
    boxingy = cpgtbox;
    sprintf(steringyr,"MV");
    sprintf(steringyl,"NVZYD");
    sprintf(steribgyr,"CTS");
    sprintf(steribgyl,"BTSZYD");
  }

  /* Ensure that minimum and maximum are different */
  if(xmin == xmax) {
    if (xmin != 0.0) {
      xmin = xmin*0.9;
      xmax = xmax*1.1;
    }
    else {
      xmin = -1.0;
      xmax = 1.0;
    }
  }

  if (logarcsx > 1) {
    if ((xmin-xmax) < 1.0) {
      xmin = xmin-1.0;
      xmax = xmax+1.0;
    }
  }

  if(ymin == ymax) {
    if (ymin != 0.0) {
      ymin = ymin*0.9;
      ymax = ymax*1.1;
    }
    else {
      ymin = -1.0;
      ymax = 1.0;
    }
  }

  if (logarcsy > 1) {
    if ((ymin-ymax) < 1.0) {
      ymin = ymin-1.0;
      ymax = ymax+1.0;
    }
  }

  /**********/
  /* scales */
  /**********/

  /* Standard linewidth */
  cpgqlw(&slw);

  /* Find the reference */
  cpgsch(gdsc -> numberheight);
  cpgqcs(0, &chrhtxref, &chrhtyref);

  /* The physical size in x is scalexy times the physical size in y */
  /* scalexy = chrhtyref/chrhtxref; */

  /* plot height */
  plotheight = (1.0 - 2.0*(gdsc -> legendrows+1)*gdsc -> legendheight*chrhtyref - 6*gdsc -> axdescheight*chrhtyref-6*chrhtyref)/gdsc -> nplots;

  /* Position of the plot, whole box */
  xlo = gdsc -> leftmargin*chrhtxref+3*gdsc -> axdescheight*chrhtxref;

  /* changed from 3*gdsc -> axdescheight to 4*gdsc -> axdescheight */
  xhi = 1.0-4*gdsc -> axdescheight*chrhtxref-gdsc -> rightmargin*chrhtxref;
  ylo = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot);
  yhi = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot-1);

  /* Check if the specification is wrong and return 0 if it is */
  if (xlo >= xhi)
    return 0;
  if (ylo >= yhi)
    return 0;

  /* Define the linear dependencies of the window scaling and the user scaling */
  ax = (xmax-xmin)/((xhi-gdsc -> horbord*gdsc -> symbolheight*chrhtxref) - (xlo+gdsc -> horbord*gdsc -> symbolheight*chrhtxref));
  ay =  (ymax-ymin)/((yhi-gdsc -> verbord*gdsc -> symbolheight*chrhtyref) - (ylo+gdsc -> verbord*gdsc -> symbolheight*chrhtyref));
  bx = xmin-ax*(xlo+gdsc -> horbord*gdsc -> symbolheight*chrhtxref);
  by = ymin-ay*(ylo+gdsc -> verbord*gdsc -> symbolheight*chrhtyref);

  /*************/
  /* Numbering */
  /*************/

  /* Set the symbol size (again) */
  cpgsch(gdsc -> numberheight);

  /* Draw the numbers axis by axis */

  /* First define the plot region */
  xlo2 = gdsc -> leftmargin*chrhtxref+3*gdsc -> axdescheight*chrhtxref+gdsc -> leftnum*chrhtxref;
  xhi2 = 1.0-gdsc -> rightmargin*chrhtxref-4*gdsc -> axdescheight*chrhtxref-gdsc -> rightnum*chrhtxref;
  ylo2 = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot)+gdsc -> botnum*chrhtyref;
  yhi2 = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot-1)-gdsc -> topnum*chrhtyref;

  xulo2 = ax*xlo2+bx;
  xuhi2 = ax*xhi2+bx;
  yulo2 = ay*ylo2+by;
  yuhi2 = ay*yhi2+by;

  /* Top and bottom numbering */
  if (nplot == 1) {
    cpgsvp(xlo2, xhi2, ylo, yhi);
    cpgswin(xulo2*btscale+btzero, xuhi2*btscale+btzero, yulo2*lrscale+lrzero, yuhi2*lrscale+lrzero);

    if ((topdeschi) || topdesclo)
      (*boxingx)(steringxt, 0.0, 0, "", 0.0, 0);
  }

  if (nplot == gdsc -> nplots) {
    cpgsvp(xlo2, xhi2, ylo, yhi);

    /* BUGFIX: changed from (...,yulo, yuhi) to (...,yulo2, yuhi2) */
    cpgswin(xulo2, xuhi2, yulo2, yuhi2);

    if ((bottomdeschi) || bottomdesclo)
      (*boxingx)(steringxb, 0.0, 0, "", 0.0, 0);
  }

  /* Left and right numbering */
  cpgsvp(xlo, xhi, ylo2, yhi2);
  cpgswin(xulo2*btscale+btzero, xuhi2*btscale+btzero, yulo2*lrscale+lrzero, yuhi2*lrscale+lrzero);

  if ((rightdeschi) || (rightdesclo))
    (*boxingy)("", 0.0, 0, steringyr, 0.0, 0);
  cpgsvp(xlo, xhi, ylo2, yhi2);
  cpgswin(xulo2, xuhi2, yulo2, yuhi2);

  if ((leftdeschi) || (leftdesclo))
    (*boxingy)("", 0.0, 0, steringyl, 0.0, 0);

  /***************/
  /* Box drawing */
  /***************/

  /* Set the line width */
  cpgslw(gdsc -> boxlw);

  /* Define an area of operation PGSVP (XMIN, XMAX, YMIN, YMAX), 0 to 1,  y from bottom to top */
  cpgsvp(xlo, xhi, ylo, yhi);

  xulo = ax*xlo+bx;
  xuhi = ax*xhi+bx;
  yulo = ay*ylo+by;
  yuhi = ay*yhi+by;

  cpgswin(xulo, xuhi, yulo, yuhi);

/* draw the box with the tickmarks of the lower and left panel */
  (*boxingx)(steribgxb, 0.0, 0, "", 0.0, 0);
  (*boxingy)("", 0.0, 0, steribgyl, 0.0, 0);

  /* Now change the user coordinates */
  cpgswin(xulo*btscale+btzero, xuhi*btscale+btzero, yulo*lrscale+lrzero, yuhi*lrscale+lrzero);

  /* draw the box with the tickmarks of the upper and right panel */
  (*boxingx)(steribgxt, 0.0, 0, "", 0.0, 0);
  (*boxingy)("", 0.0, 0, steribgyr, 0.0, 0);

  /* Reset the linewidth */
  cpgslw(slw);

  /*************/
  /* Labelling */
  /*************/

  /* Set character height (again) to the number value */
  cpgsch(gdsc -> numberheight);

  /* Label top */
  if (nplot == 1)
    putalabel('t', topdeschi, topdesclo, gdsc -> axdescheight, gdsc -> topmargin);

  /* Label bottom */
  if (nplot == gdsc -> nplots)
    putalabel('b', bottomdeschi, bottomdesclo, gdsc -> axdescheight, gdsc -> bottommargin);

  /* Label left and right axis */
  putalabel('l', leftdeschi, leftdesclo, gdsc -> axdescheight, gdsc -> leftmargin);
  putalabel('r', rightdeschi, rightdesclo, gdsc -> axdescheight, gdsc -> rightmargin);

  /* At the end we put the viewport and the window at the right values */
  switch (logarcsx) {
  case 2:
    xmin = xmin/240.0;
    xmax = xmax/240.0;
    break;
  case 3:
    xmin = xmin/3600.0;
    xmax = xmax/3600.0;
    break;
  }
  switch (logarcsy) {
  case 2:
    ymin = ymin/240.0;
    ymax = ymax/240.0;
    break;
  case 3:
    ymin = ymin/3600.0;
    ymax = ymax/3600.0;
    break;
  }

  /* Redefine */
  xlo = gdsc -> leftmargin*chrhtxref+3*gdsc -> axdescheight*chrhtxref;
  xhi = 1.0-4*gdsc -> axdescheight*chrhtxref-gdsc -> rightmargin*chrhtxref;
  ylo = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot);
  yhi = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(nplot-1);

  ax = (xmax-xmin)/((xhi-gdsc -> horbord*gdsc -> symbolheight*chrhtxref) - (xlo+gdsc -> horbord*gdsc -> symbolheight*chrhtxref));
  ay =  (ymax-ymin)/((yhi-gdsc -> verbord*gdsc -> symbolheight*chrhtyref) - (ylo+gdsc -> verbord*gdsc -> symbolheight*chrhtyref));
  bx = xmin-ax*(xlo+gdsc -> horbord*gdsc -> symbolheight*chrhtxref);
  by = ymin-ay*(ylo+gdsc -> verbord*gdsc -> symbolheight*chrhtyref);

  xulo = ax*xlo+bx;
  xuhi = ax*xhi+bx;
  yulo = ay*ylo+by;
  yuhi = ay*yhi+by;

  /* Do the redefinition */
  cpgsvp(xlo, xhi, ylo, yhi);
  cpgswin(xulo, xuhi, yulo, yuhi);

  return 1;
}
/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts a label at a viewgraph as a fraction */

int putalabel(char where, char *overfrac, char *underfrac, float charheight, float dist)
{
  float oheight;    /* Character height at call time */
  int fraclength;
  char *fracbar;
  float ovpos;
  float unpos;
  float fracpos;

  char format[3];

  float frlen1;
  float frlen2;
  float xbox;
  float ybox;
  float chrhtxref;
  float chrhtyref;

  /* Check if there is anything to put */
  if ((overfrac == NULL) && (underfrac == NULL))
    return 1;

  /***********/
  /* scaling */
  /***********/

  /* Find the reference character height */
  cpgqch(&oheight);

  /* Set the character height to the required value */
  cpgsch(oheight*charheight);

  /* If the strings are empty we return a success */
  if (!(*overfrac)) {
    if (!(*underfrac))
      return 1;
    /* If only one of them is empty, we make the one not empty overfrac */
    else {
      fracbar = overfrac;
      overfrac = underfrac;
      underfrac = fracbar;
    }
  }

  /* A format string is required */
  switch (where) {
  case 'l':
    sprintf(format,"L");

    /* Calculate the maximum possible distance from the edge of the graph */
    ovpos = dist/charheight+2.0;
    fracpos = dist/charheight+1.4;
    unpos = dist/charheight;
    break;
  case 'r':
    sprintf(format,"R");

    /* Calculate the maximum possible distance from the edge of the graph */
    ovpos = dist/charheight+1;
    fracpos = dist/charheight+1.6;
    unpos = dist/charheight+3;
    break;

  case 't':
    sprintf(format,"T");
    ovpos = dist/charheight+2.0;
    fracpos = dist/charheight/charheight+1.4;
    unpos = dist/charheight/charheight+0.0;
    break;

  case 'b':
    sprintf(format,"B");
    ovpos = dist/charheight+1.0;
    fracpos = dist/charheight+1.6;
    unpos = dist/charheight+3.0;
    break;

  default:
    return 0;
  }

  /* To get the length of the fraction bar, first find a bounding box at an arbitrary position */
  cpglen(2, overfrac, &xbox, &ybox);
  frlen1 = ybox;
  cpglen(2, underfrac, &xbox, &ybox);
  frlen2 = ybox;
  frlen1= (frlen1 > frlen2)?frlen1:frlen2;

  /* Now frlen1 is the length of the string in world coordinates of the x axis, we get the character width of this axis in the same units */
  cpgqcs(2, &chrhtxref, &chrhtyref);

  /* Then, the length of the fraction bar is the uprounded fraction */
  fraclength = ((int) (frlen1/chrhtyref))+3;

  if (!(fracbar = (char *) malloc((fraclength+1)*sizeof(char))))
    return 0;

  fracbar[fraclength] = '\0';

  while (fraclength > 0) {
    fracbar[fraclength-1] = '_';
    --fraclength;
  }

  /************/
  /* plotting */
  /************/

  /* If there is a fraction bar to plot do this */
  if (*underfrac) {
  /* First plot the character string above the fraction bar */
  cpgmtxt(format, ovpos, 0.5, 0.5, overfrac);

  /* Now draw the fraction bar */
  cpgmtxt(format, fracpos, 0.5, 0.5, fracbar);

  /* At last put the argument below the fraction bar */
  cpgmtxt(format, unpos, 0.5, 0.5, underfrac);
  }

  /* No fraction bar */
  else {
    cpgmtxt(format, unpos, 0.5, 0.5, overfrac);
  }

  /* Deallocate */
  free(fracbar);

  /* Set the character height to the original value */
  cpgsch(oheight);

  return 1;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts a string to the specified legend position */
int pgp_legend(pgp_gdsc *gdsc, int nhor, int nver, char *string)
{
  float chrhtxref;    /* Horizontal character width in x-map units, 1 is whole page */
  float chrhtyref;    /* Vertical character height in y-map units, 1 is whole page */
  /* float charwidth; */
  float posix;
  float posiy;
  float plotheight;
  /* float boxwidth; */
  float xlo; /* Box in window coordinates */
  float xhi;
  float ylo;
  float yhi;

  /* First check if the intended legend position is available */
  if (nver < 1 || nver > gdsc -> legendrows || nhor < 1 || nhor > gdsc -> legendcols) {
    return 0;
  }

  /* Then open a box that nearly spans the whole surface at the bottom position of the graph */

  /* Find the reference */
  cpgsch(gdsc -> numberheight);
  cpgqcs(0, &chrhtxref, &chrhtyref);

  /* plot height */
  plotheight = (1.0 - 2.0*(gdsc -> legendrows+1)*gdsc -> legendheight*chrhtyref - 6*gdsc -> axdescheight*chrhtyref-6*chrhtyref)/gdsc -> nplots;
  ylo = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(gdsc -> nplots);
  yhi = 1.0-4*gdsc -> axdescheight*chrhtyref-gdsc -> topmargin*chrhtyref-plotheight*(gdsc -> nplots-1);

  /* At the left hand the box has the distance of one symbol to the border of the plotting surface */
  cpgsch(gdsc -> numberheight*gdsc -> legendheight);
  cpgqcs(0, &chrhtxref, &chrhtyref);

  xlo = chrhtxref;
  xhi = 1.0-chrhtxref;

  /* Check if the specification is wrong and return 0 if it is */
  if (xlo >= xhi)
    return 0;
  if (ylo >= yhi)
    return 0;

  /* Define the surface */
  cpgsvp(xlo, xhi, ylo, yhi);

  /* This is the length of a box element in units of the x-axis, spacing is one character between rows */
  /* boxwidth = (1-(gdsc -> legendcols-1)*charwidth)/gdsc -> legendcols; */

  /* This is the position of the string in x along the axis */
  posix = (nhor-0.5)/gdsc -> legendcols;

  /* Now in y */
  posiy = gdsc -> bottommargin/gdsc -> legendheight+3*gdsc -> axdescheight/gdsc -> legendheight+2*nver;

  /* Put it on the graph */
  cpgmtxt("B", posiy, posix, 0.5, string);

  /* Reset the character height */
  cpgsch(gdsc -> numberheight);

  return 1;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts markers on a predefined viewport */
int pgp_marker(pgp_gdsc *gdsc, int npoints, float *xpos, float *ypos, int colour, int empty, int symbol, float sizer)
{
  int colourbef;
  float chrhtxref, chrhtyref;
  int intlw;
  float *xposd = NULL;
  float *yposd = NULL;
  int i;

  /* Allocate space if necessary */
  if (gdsc -> logarcsx == 1) {
    if (!(xposd = (float *) malloc(npoints*sizeof(float))))
      return 1;
    for (i=0; i < npoints; ++i) {
	xposd[i] = pgp_logf10f(xpos[i]);
    }
    xpos = xposd;
  }
  if (gdsc -> logarcsy == 1) {
    if (!(yposd = (float *) malloc(npoints*sizeof(float)))) {
      if ((xposd))
	free(xposd);
      return 2;
    }
    for (i=0; i < npoints; ++i) {
	yposd[i] = pgp_logf10f(ypos[i]);
    }
    ypos = yposd;
  }

  /* Set the character height */
  if (symbol == -1)
    cpgsch(gdsc -> numberheight*gdsc -> symbolheight*sizer);
  else if (symbol == 3)
    cpgsch(gdsc -> numberheight*gdsc -> symbolheight*2*sizer*1.2);
  else
    cpgsch(gdsc -> numberheight*gdsc -> symbolheight*2*sizer);

  /* Inquire the character height in inches */
  cpgqcs(1, &chrhtxref, &chrhtyref);

  /* Set the linewidth as an equivalent */
  if (symbol == -1) {
    intlw = chrhtxref*200.0>201.0?201: (int) (chrhtxref*200.0);
  }
  else
    intlw = 1;
  cpgslw(intlw);

  /* Store the colour index */
  cpgqci(&colourbef);

  /* Set the colour index */
  cpgsci(colour);

 /* Plot points, number of points, vectors for x and y, symbol */
  cpgpt(npoints, xpos, ypos, symbol);

  /* If required, plot the same list on top of that with background colour and with a radius that is smaller */
  if ((empty)) {
    cpgslw(((intlw-4*gdsc -> graphlw) > 0)?(intlw-4*gdsc -> graphlw):0);
    cpgsci(0);
    cpgpt(npoints, xpos, ypos, symbol);
  }

  /* Reset the linewidth */
  cpgslw(gdsc -> graphlw);

  /* Reset the colour index */
  cpgsci(colourbef);

  /* Reset the character height */
  cpgsch(gdsc -> numberheight);

  /* Reset the linewidth */
  cpgslw(gdsc -> boxlw);

  /* Deallocate */

  if (gdsc -> logarcsy == 1) {
    free(yposd);
  }

  if (gdsc -> logarcsx == 1) {
    free(xposd);
  }

  return 0;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts lines on a predefined viewport */
int pgp_lines(pgp_gdsc *gdsc, int npoints, float *xpos, float *ypos, int colour)
{
  int i;
  int colourbef;
  float *xposd = NULL;
  float *yposd = NULL;

  if (gdsc -> interptype_lines != PGP_I_LINEAR) {
    if (pgp_get_interparray(xpos, ypos, npoints, gdsc -> interptype_lines, gdsc -> interp_numlines+1, &xposd, &yposd))
      goto error;
    npoints = gdsc -> interp_numlines+1;
    xpos = xposd;
    ypos = yposd;
  }

  /* Allocate space if necessary */
  if (gdsc -> logarcsx == 1) {
    if (!xposd) {
      if (!(xposd = (float *) malloc(npoints*sizeof(float))))
	goto error;
    }
    for (i=0; i < npoints; ++i) {
	xposd[i] = pgp_logf10f(xpos[i]);
    }
    xpos = xposd;
  }
  if (gdsc -> logarcsy == 1) {
    if (!yposd) {
      if (!(yposd = (float *) malloc(npoints*sizeof(float))))
	goto error;
    }
    for (i=0; i < npoints; ++i) {
	yposd[i] = pgp_logf10f(ypos[i]);
    }
    ypos = yposd;
  }

  /* Store the colour index */
  cpgqci(&colourbef);

  /* Set the colour index */
  cpgsci(colour);

  /* Set the linewidth */
  cpgslw(gdsc -> graphlw);

 /* Plot lines, number of points, vectors for x and y, symbol */
  cpgline(npoints, xpos, ypos);

  /* Reset the linewidth */
  cpgslw(gdsc -> graphlw);

  /* Reset the colour index */
  cpgsci(colourbef);

  /* Reset the linewidth */
  cpgslw(gdsc -> boxlw);

  /* Deallocate */
  if ((xposd))
    free(xposd);
  if ((yposd))
    free(yposd);
  return 0;

 error:
  if ((xposd))
    free(xposd);
  if ((yposd))
    free(yposd);
  return 1;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts lines on a predefined viewport */
int pgp_bars(pgp_gdsc *gdsc, int npoints, float *xpos, float *ypos, float width, int colour)
{
  int colourbef,i;
  float *xposd = NULL;
  float *yposd = NULL;

  /* Allocate space if necessary */
  if (gdsc -> logarcsx == 1) {
    if (!(xposd = (float *) malloc(npoints*sizeof(float))))
      return 1;
    for (i=0; i < npoints; ++i) {
      xposd[i] = pgp_logf10f(xpos[i]);
    }
    xpos = xposd;
  }
  if (gdsc -> logarcsy == 1) {
    if (!(yposd = (float *) malloc(npoints*sizeof(float)))) {
      if ((xposd))
	free(xposd);
      return 2;
    }
    for (i=0; i < npoints; ++i) {
	yposd[i] = pgp_logf10f(ypos[i]);
    }
    ypos = yposd;
  }

  /* Store the colour index */
  cpgqci(&colourbef);

  /* Set the colour index */
  cpgsci(colour);

  /* Set the linewidth */
  cpgslw(gdsc -> graphlw);

 /* Plot lines, number of points, vectors for x and y, symbol */
  for (i = 0; i < npoints; ++i)
  cpgerr1(5, xpos[i], ypos[i], width/2, 0.0);

  /* Reset the linewidth */
  cpgslw(gdsc -> graphlw);

  /* Reset the colour index */
  cpgsci(colourbef);

  /* Reset the linewidth */
  cpgslw(gdsc -> boxlw);

  /* Deallocate */
  if (gdsc -> logarcsy == 1) {
    free(yposd);
  }

  if (gdsc -> logarcsx == 1) {
    free(xposd);
  }

  return 0;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Puts lines on a predefined viewport */
int pgp_errby(pgp_gdsc *gdsc, int npoints, float *xpos, float *ypos, float *err, int colour)
{
  int colourbef, i;
  float *xposd = NULL;
  float *yposdl = NULL;
  float *yposdr = NULL;

  /* Allocate space if necessary */
  if (gdsc -> logarcsx == 1) {
    if (!(xposd = (float *) malloc(npoints*sizeof(float))))
      return 1;
    for (i=0; i < npoints; ++i) {
	xposd[i] = pgp_logf10f(xpos[i]);
    }
    xpos = xposd;
  }

  if (gdsc -> logarcsy == 1) {
    if (!(yposdl = (float *) malloc(npoints*sizeof(float)))) {
      if ((xposd))
	free(xposd);
      return 1;
    }
    if (!(yposdr = (float *) malloc(npoints*sizeof(float)))) {
      if ((xposd))
	free(xposd);
      free(yposdl);
      return 1;
    }
    for (i=0; i < npoints; ++i) {
	yposdr[i] = pgp_logf10f(ypos[i]+err[i]);
      }
    for (i=0; i < npoints; ++i) {
	yposdl[i] = pgp_logf10f(ypos[i]-err[i]);
    }
  }

  /* Store the colour index */
  cpgqci(&colourbef);

  /* Set the colour index */
  cpgsci(colour);

  /* Set the linewidth */
  cpgslw(gdsc -> graphlw);

 /* Plot lines, number of points, vectors for x and y, symbol */
  if (gdsc -> logarcsy == 1)
    cpgerry(npoints, xpos, yposdl, yposdr, 2.0);
  else
    cpgerrb(6, npoints, xpos, ypos, err, 2.0);

  /* Reset the linewidth */
  cpgslw(gdsc -> graphlw);

  /* Reset the colour index */
  cpgsci(colourbef);

  /* Reset the linewidth */
  cpgslw(gdsc -> boxlw);

  /* Clean up */
  if (gdsc -> logarcsx == 1)
    free(xposd);
  if (gdsc -> logarcsy == 1) {
    free(yposdl);
    free(yposdr);
  }

  return 0;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* End the plotting and close the device */
void pgp_end()
{
  cpgclos();
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Returns the logarithm on basis 10 and LOGFAULT if x <= 0 */
float pgp_logf10f(float x)
{
  if (x > 0)
    return log10f(x);
  else
    return LOGFAULT;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ */

/* Returns an array of interpolated values. */

static int pgp_get_interparray(float *x, float *y, int npoints, int interptype, int noutpoints, float **xout, float **yout)
{
  int i, pgp_get_interparray = 0;
  double *xdouble = NULL, *ydouble = NULL; /* input is float, but gsl requires double */
  gsl_interp *gsl_interpv = NULL; /* gsl structs */
  gsl_interp_accel *gsl_interp_accelv = NULL; /* gsl structs */
  const gsl_interp_type * intytype = NULL; /* interpolation type, internal to gsl */
  float dx;

  /* At least two data points */
  if (npoints < 2) {
    pgp_get_interparray |= 1;
    goto error;
  }

  /* Wipe the input, gone ... */
  if (*xout) {
    free(*xout);
    *xout = NULL;
  }
  if (*yout) {
    free(*yout);
    *yout = NULL;
  }

  /* Allocate arrays */
  if (!(xdouble = (double *) malloc(npoints*sizeof(double)))) {
    pgp_get_interparray |= 2;
    goto error;
  }
  if (!(ydouble = (double *) malloc(npoints*sizeof(double)))) {
    pgp_get_interparray |= 2;
    goto error;
  }
  for (i = 0; i < npoints; ++i) {
    xdouble[i] = x[i];
    ydouble[i] = y[i];
  }
  if (!(*xout = (float *) malloc(noutpoints*sizeof(float)))) {
    pgp_get_interparray |= 2;
    goto error;
  }
  if (!(*yout = (float *) malloc(noutpoints*sizeof(float)))) {
    pgp_get_interparray |= 2;
    goto error;
  }

  switch(interptype) {
    case PGP_I_LINEAR:
      intytype = gsl_interp_linear;
      break;

    case PGP_I_CSPLINE:
      if (npoints > 2)
	intytype = gsl_interp_cspline;
      else {
	printf("Must have at least 3 radii for spline, using linear\n");
	intytype = gsl_interp_linear;
      }
      break;

    case PGP_I_AKIMA:
      if (npoints > 4) {
	intytype = gsl_interp_akima;
      }
      else {
	printf("Must have at least 5 radii for Akima\n");
	if (npoints > 2) {
	  printf("Using natural cubic spline\n");
	  intytype = gsl_interp_cspline;
	}
	else {
	  printf("Using linear\n");
	  intytype = gsl_interp_linear;
	}
      }
      break;

    /* No real default, but we set linear */
    default:
      intytype = gsl_interp_linear;
      break;
    }

  /* Attempt to allocate all gsl structures */
  if (!(gsl_interpv = gsl_interp_alloc(intytype, npoints))) {
    pgp_get_interparray |= 2;
    goto error;
  }
  if (!(gsl_interp_accelv = gsl_interp_accel_alloc())) {
    pgp_get_interparray |= 2;
    goto error;
  }

  gsl_interp_init(gsl_interpv, xdouble, ydouble, npoints);

  (*xout)[0] = x[0];
  (*yout)[0] = y[0];

  dx = (x[npoints-1]-x[0])/((float)(noutpoints-1));

  /* Bugfix: rounding error could lead to failure of interpolation */
  --noutpoints;

  for (i = 1; i < noutpoints; ++i) {
    (*xout)[i] = (*xout)[i-1]+dx;
    (*yout)[i] = gsl_interp_eval(gsl_interpv, xdouble, ydouble, (*xout)[i], gsl_interp_accelv);
  }
  (*xout)[i] = x[npoints-1];
  (*yout)[i] = y[npoints-1];

  /* last points should be identical regardless of rounding errors */
    free(xdouble);
    free(ydouble);
    gsl_interp_free(gsl_interpv);
    gsl_interp_accel_free(gsl_interp_accelv);

  return pgp_get_interparray;

 error:
  if (xdouble)
    free(xdouble);
  if (ydouble)
    free(ydouble);
  if (*xout) {
    free(*xout);
    *xout = NULL;
  }
  if (*yout) {
    free(*yout);
    *yout = NULL;
  }
  if (gsl_interpv)
    gsl_interp_free(gsl_interpv);
  if (gsl_interp_accelv)
    gsl_interp_accel_free(gsl_interp_accelv);

  return pgp_get_interparray;
}

/* ------------------------------------------------------------ */

/* ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

   $Log: pgp.c,v $
   Revision 1.14  2011/05/25 22:25:26  jozsa
   Left work

   Revision 1.13  2011/05/10 00:30:16  jozsa
   Left work

   Revision 1.12  2009/05/26 07:56:41  jozsa
   Left work

   Revision 1.11  2007/08/22 15:58:43  gjozsa
   Left work

   Revision 1.10  2006/11/22 14:16:21  gjozsa
   Bugfix concerning RASH and horizontal/vertical lines

   Revision 1.9  2006/11/03 10:49:02  gjozsa
   Introduced logarithmic scaling, hms dms

   Revision 1.8  2006/10/05 12:39:58  gjozsa
   nasty bugfix

   Revision 1.7  2006/04/03 11:47:57  gjozsa
   Left work

   Revision 1.6  2006/02/08 16:13:17  gjozsa
   Extended graphics routines

   Revision 1.5  2005/10/12 14:51:25  gjozsa
   First point gets thick in the polar plot

   Revision 1.4  2005/10/12 09:53:09  gjozsa
   Included polar plot facility

   Revision 1.3  2005/06/24 12:00:29  gjozsa
   Left work

   Revision 1.2  2005/05/24 10:42:24  gjozsa
   Left work

   Revision 1.1  2005/05/17 12:58:15  gjozsa
   Added to cvs control

   ------------------------------------------------------------ */


/***************************************************************************/
/*                                                                         */
/* vector.c - Vector class for mruby                                       */
/* Copyright (C) 2015 Paolo Bosetti                                        */
/* paolo[dot]bosetti[at]unitn.it                                           */
/* Department of Industrial Engineering, University of Trento              */
/*                                                                         */
/* This library is free software.  You can redistribute it and/or          */
/* modify it under the terms of the GNU GENERAL PUBLIC LICENSE 2.0.        */
/*                                                                         */
/* This library 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           */
/* Artistic License 2.0 for more details.                                  */
/*                                                                         */
/* See the file LICENSE                                                    */
/*                                                                         */
/***************************************************************************/

#include <gsl/gsl_blas.h>
#include <gsl/gsl_statistics_double.h>
#include <gsl/gsl_sort_vector.h>
#include <gsl/gsl_rng.h>
#include "vector.h"

#pragma mark -
#pragma mark • Utilities

// Garbage collector handler, for play_data struct
// if play_data contains other dynamic data, free it too!
// Check it with GC.start
void vector_destructor(mrb_state *mrb, void *p_) {
  gsl_vector *v = (gsl_vector *)p_;
  gsl_vector_free(v);
};

// Creating data type and reference for GC, in a const struct
const struct mrb_data_type vector_data_type = {"vector_data",
                                               vector_destructor};

// Utility function for getting the struct out of the wrapping IV @data
void mrb_vector_get_data(mrb_state *mrb, mrb_value self, gsl_vector **data) {
  mrb_value data_value;
  data_value = mrb_iv_get(mrb, self, mrb_intern_lit(mrb, "@data"));

  // Loading data from data_value into p_data:
  Data_Get_Struct(mrb, data_value, &vector_data_type, *data);
  if (!*data)
    mrb_raise(mrb, E_RUNTIME_ERROR, "Could not access @data");
}

#pragma mark -
#pragma mark • Init and accessing

// Data Initializer C function (not exposed!)
static void mrb_vector_init(mrb_state *mrb, mrb_value self, mrb_int n) {
  mrb_value data_value; // this IV holds the data
  gsl_vector *p_data;   // pointer to the C struct

  data_value = mrb_iv_get(mrb, self, mrb_intern_lit(mrb, "@data"));

  // if @data already exists, free its content:
  if (!mrb_nil_p(data_value)) {
    Data_Get_Struct(mrb, data_value, &vector_data_type, p_data);
    free(p_data);
  }
  // Allocate and zero-out the data struct:
  p_data = gsl_vector_calloc(n);
  if (!p_data)
    mrb_raise(mrb, E_RUNTIME_ERROR, "Could not allocate @data");

  // Wrap struct into @data:
  mrb_iv_set(
      mrb, self, mrb_intern_lit(mrb, "@data"), // set @data
      mrb_obj_value(                           // with value hold in struct
          Data_Wrap_Struct(mrb, mrb->object_class, &vector_data_type, p_data)));
}

static mrb_value mrb_vector_initialize(mrb_state *mrb, mrb_value self) {
  mrb_int n;
  mrb_get_args(mrb, "i", &n);

  // Call strcut initializer:
  mrb_vector_init(mrb, self, n);
  mrb_iv_set(mrb, self, mrb_intern_lit(mrb, "@length"), mrb_fixnum_value(n));
  mrb_iv_set(mrb, self, mrb_intern_lit(mrb, "@format"),
             mrb_str_new_cstr(mrb, "%10.3f"));
  return mrb_nil_value();
}

static mrb_value mrb_vector_rnd_fill(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;
  const gsl_rng_type *T;
  gsl_rng *r;
  mrb_int h;

  mrb_vector_get_data(mrb, self, &p_vec);

  gsl_rng_env_setup();
  T = gsl_rng_default;
  r = gsl_rng_alloc(T);

  for (h = 0; h < p_vec->size; h++) {
    gsl_vector_set(p_vec, h, gsl_rng_uniform(r));
  }
  return self;
}

static mrb_value mrb_vector_dup(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec = NULL, *p_vec_other = NULL;
  mrb_value args[1];

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  args[0] = mrb_fixnum_value(p_vec->size);
  other = mrb_obj_new(mrb, mrb_class_get(mrb, "Vector"), 1, args);
  mrb_vector_get_data(mrb, other, &p_vec_other);
  gsl_vector_memcpy(p_vec_other, p_vec);
  return other;
}

static mrb_value mrb_vector_all(mrb_state *mrb, mrb_value self) {
  mrb_float v;
  gsl_vector *p_vec = NULL;

  mrb_get_args(mrb, "f", &v);
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  gsl_vector_set_all(p_vec, v);
  return self;
}

static mrb_value mrb_vector_zero(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  gsl_vector_set_zero(p_vec);
  return self;
}

static mrb_value mrb_vector_basis(mrb_state *mrb, mrb_value self) {
  mrb_int i;
  gsl_vector *p_vec = NULL;

  mrb_get_args(mrb, "i", &i);
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  gsl_vector_set_basis(p_vec, i);
  return self;
}

#pragma mark -
#pragma mark • Tests

static mrb_value mrb_vector_equal(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  mrb_vector_get_data(mrb, other, &p_vec_other);
  if (1 == gsl_vector_equal(p_vec, p_vec_other))
    return mrb_true_value();
  else
    return mrb_false_value();
}

#pragma mark -
#pragma mark • Accessors

static mrb_value mrb_vector_get_i(mrb_state *mrb, mrb_value self) {
  mrb_int i = 0;
  gsl_vector *p_vec = NULL;

  mrb_get_args(mrb, "i", &i);
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (i >= p_vec->size) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Vector index out of range!");
  }
  return mrb_float_value(mrb, gsl_vector_get(p_vec, (size_t)i));
}

static mrb_value mrb_vector_set_i(mrb_state *mrb, mrb_value self) {
  mrb_int i = 0;
  mrb_float f;
  gsl_vector *p_vec = NULL;

  mrb_get_args(mrb, "if", &i, &f);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (i >= p_vec->size) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Vector index out of range!");
  }
  gsl_vector_set(p_vec, (size_t)i, (double)f);
  return mrb_float_value(mrb, f);
}

static mrb_value mrb_vector_to_a(mrb_state *mrb, mrb_value self) {
  int i;
  mrb_value ary = mrb_nil_value();
  gsl_vector *p_vec = NULL;
  mrb_float e;
  mrb_vector_get_data(mrb, self, &p_vec);
  ary = mrb_ary_new_capa(mrb, p_vec->size);
  for (i = 0; i < p_vec->size; i++) {
    e = *(p_vec->data + i * p_vec->stride);
    mrb_ary_set(mrb, ary, i, mrb_float_value(mrb, e));
  }
  return ary;
}

#pragma mark -
#pragma mark • Properties

static mrb_value mrb_vector_max(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_float_value(mrb, gsl_vector_max(p_vec));
}

static mrb_value mrb_vector_min(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_float_value(mrb, gsl_vector_min(p_vec));
}

static mrb_value mrb_vector_max_index(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_fixnum_value(gsl_vector_max_index(p_vec));
}

static mrb_value mrb_vector_min_index(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL;
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_fixnum_value(gsl_vector_min_index(p_vec));
}

#pragma mark -
#pragma mark • Operations

static mrb_value mrb_vector_add(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);

  if (mrb_obj_is_kind_of(mrb, other, mrb_class_get(mrb, "Vector"))) {
    mrb_vector_get_data(mrb, other, &p_vec_other);
    if (p_vec->size != p_vec_other->size) {
      mrb_raise(mrb, E_VECTOR_ERROR, "Vector indexes don't match!");
    }
    gsl_vector_add(p_vec, p_vec_other);
  } else if (mrb_obj_is_kind_of(mrb, other, mrb_class_get(mrb, "Numeric"))) {
    gsl_vector_add_constant(p_vec, mrb_to_flo(mrb, other));
  }
  return self;
}

static mrb_value mrb_vector_sub(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  mrb_vector_get_data(mrb, other, &p_vec_other);
  if (p_vec->size != p_vec_other->size) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Vector dimensions don't match!");
  }
  gsl_vector_sub(p_vec, p_vec_other);
  return self;
}

static mrb_value mrb_vector_mul(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (mrb_obj_is_kind_of(mrb, other, mrb_class_get(mrb, "Vector"))) {
    mrb_vector_get_data(mrb, other, &p_vec_other);
    if (p_vec->size != p_vec_other->size) {
      mrb_raise(mrb, E_VECTOR_ERROR, "Vector indexes don't match!");
    }
    gsl_vector_mul(p_vec, p_vec_other);
  } else if (mrb_obj_is_kind_of(mrb, other, mrb_class_get(mrb, "Numeric"))) {
    gsl_vector_scale(p_vec, mrb_to_flo(mrb, other));
  }
  return self;
}

static mrb_value mrb_vector_div(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  mrb_vector_get_data(mrb, other, &p_vec_other);
  if (p_vec->size != p_vec_other->size) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Vector indexes don't match!");
  }
  gsl_vector_div(p_vec, p_vec_other);
  return self;
}

static mrb_value mrb_vector_prod(mrb_state *mrb, mrb_value self) {
  mrb_value other;
  gsl_vector *p_vec, *p_vec_other;
  mrb_float res;
  mrb_get_args(mrb, "o", &other);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  mrb_vector_get_data(mrb, other, &p_vec_other);
  if (!mrb_obj_is_kind_of(mrb, other, mrb_class_get(mrb, "Vector"))) {
    mrb_raise(mrb, E_ARGUMENT_ERROR, "Need a Vector!");
  }
  if (p_vec->size != p_vec_other->size) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Vector indexes don't match!");
  }
  if (gsl_blas_ddot(p_vec, p_vec_other, &res)) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Cannot multiply");
  }
  return mrb_float_value(mrb, res);
}

static mrb_value mrb_vector_norm(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_float_value(mrb, gsl_blas_dnrm2(p_vec));
}

static mrb_value mrb_vector_sum(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  return mrb_float_value(mrb, gsl_blas_dasum(p_vec));
}

static mrb_value mrb_vector_swap(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;
  mrb_int i, j;
  mrb_get_args(mrb, "ii", &i, &j);

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (gsl_vector_swap_elements(p_vec, i, j)) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Cannot swap");
  }
  return self;
}

static mrb_value mrb_vector_reverse(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;

  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (gsl_vector_reverse(p_vec)) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Cannot reverse");
  }
  return self;
}

#pragma mark -
#pragma mark • Statistics

static mrb_value mrb_vector_mean(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;
  mrb_float result;
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  result = gsl_stats_mean(p_vec->data, p_vec->stride, p_vec->size);
  return mrb_float_value(mrb, result);
}

static mrb_value mrb_vector_variance(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;
  mrb_float result;
  mrb_float m;
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (mrb_get_args(mrb, "|f", &m) == 1) {
    result = gsl_stats_variance_m(p_vec->data, p_vec->stride, p_vec->size, m);
  } else {
    result = gsl_stats_variance(p_vec->data, p_vec->stride, p_vec->size);
  }
  return mrb_float_value(mrb, result);
}

static mrb_value mrb_vector_sd(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;
  mrb_float result;
  mrb_float m;
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (mrb_get_args(mrb, "|f", &m) == 1) {
    result = gsl_stats_sd_m(p_vec->data, p_vec->stride, p_vec->size, m);
  } else {
    result = gsl_stats_sd(p_vec->data, p_vec->stride, p_vec->size);
  }
  return mrb_float_value(mrb, result);
}

static mrb_value mrb_vector_absdev(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec;
  mrb_float result;
  mrb_float m;
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  if (mrb_get_args(mrb, "|f", &m) == 1) {
    result = gsl_stats_absdev_m(p_vec->data, p_vec->stride, p_vec->size, m);
  } else {
    result = gsl_stats_absdev(p_vec->data, p_vec->stride, p_vec->size);
  }
  return mrb_float_value(mrb, result);
}

static mrb_value mrb_vector_quantile(mrb_state *mrb, mrb_value self) {
  gsl_vector *p_vec = NULL, *p_sort_vec = NULL;
  mrb_float result;
  mrb_float f;
  mrb_int n;
  // call utility for unwrapping @data into p_data:
  mrb_vector_get_data(mrb, self, &p_vec);
  n = mrb_get_args(mrb, "|f", &f);
  if (f < 0 || f > 1) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Quantile must be in [0,1]");
  }
  p_sort_vec = gsl_vector_calloc(p_vec->size);
  if (gsl_vector_memcpy(p_sort_vec, p_vec)) {
    mrb_raise(mrb, E_VECTOR_ERROR, "Cannot copy vector");
  }
  gsl_sort_vector(p_sort_vec);
  if (n == 1) {
    result = gsl_stats_quantile_from_sorted_data(
        p_sort_vec->data, p_sort_vec->stride, p_sort_vec->size, f);
  } else {
    result = gsl_stats_quantile_from_sorted_data(
        p_sort_vec->data, p_sort_vec->stride, p_sort_vec->size, 0.5);
  }
  return mrb_float_value(mrb, result);
}

#pragma mark -
#pragma mark • Gem setup

void mrb_gsl_vector_init(mrb_state *mrb) {
  struct RClass *gsl;

  mrb_load_string(mrb, "class VectorError < Exception; end");

  gsl = mrb_define_class(mrb, "Vector", mrb->object_class);
  mrb_define_method(mrb, gsl, "all", mrb_vector_all, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "zero", mrb_vector_zero, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "basis", mrb_vector_basis, MRB_ARGS_REQ(1));

  mrb_define_method(mrb, gsl, "initialize", mrb_vector_initialize,
                    MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "rnd_fill", mrb_vector_rnd_fill,
                    MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "dup", mrb_vector_dup, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "===", mrb_vector_equal, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "[]", mrb_vector_get_i, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "[]=", mrb_vector_set_i, MRB_ARGS_REQ(2));
  mrb_define_method(mrb, gsl, "to_a", mrb_vector_to_a, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "max", mrb_vector_max, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "min", mrb_vector_min, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "max_index", mrb_vector_max_index,
                    MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "min_index", mrb_vector_min_index,
                    MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "add!", mrb_vector_add, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "sub!", mrb_vector_sub, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "mul!", mrb_vector_mul, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "div!", mrb_vector_div, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "^", mrb_vector_prod, MRB_ARGS_REQ(1));
  mrb_define_method(mrb, gsl, "norm", mrb_vector_norm, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "sum", mrb_vector_sum, MRB_ARGS_NONE());
  mrb_define_method(mrb, gsl, "swap!", mrb_vector_swap, MRB_ARGS_REQ(2));
  mrb_define_method(mrb, gsl, "reverse!", mrb_vector_reverse, MRB_ARGS_NONE());

  mrb_define_method(mrb, gsl, "mean", mrb_vector_mean, MRB_ARGS_OPT(1));
  mrb_define_method(mrb, gsl, "variance", mrb_vector_variance, MRB_ARGS_OPT(1));
  mrb_define_method(mrb, gsl, "sd", mrb_vector_sd, MRB_ARGS_OPT(1));
  mrb_define_method(mrb, gsl, "absdev", mrb_vector_absdev, MRB_ARGS_OPT(1));
  mrb_define_method(mrb, gsl, "quantile", mrb_vector_quantile, MRB_ARGS_OPT(1));
}


/* interpolation/spline2d.c
 *
 * Copyright 2012 David Zaslavsky
 *
 * 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 <string.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_interp2d.h>
#include <gsl/gsl_spline2d.h>

gsl_spline2d *
gsl_spline2d_alloc(const gsl_interp2d_type * T, size_t xsize, size_t ysize)
{
  double * array_mem;
  gsl_spline2d * interp;

  if (xsize < T->min_size || ysize < T->min_size)
    {
      GSL_ERROR_NULL("insufficient number of points for interpolation type", GSL_EINVAL);
    }

  interp = calloc(1, sizeof(gsl_spline2d));
  if (interp == NULL)
    {
      GSL_ERROR_NULL("failed to allocate space for gsl_spline2d struct", GSL_ENOMEM);
    }

  interp->interp_object.type = T;
  interp->interp_object.xsize = xsize;
  interp->interp_object.ysize = ysize;
  if (interp->interp_object.type->alloc == NULL)
    {
      interp->interp_object.state = NULL;
    }
  else
    {
      interp->interp_object.state = interp->interp_object.type->alloc(xsize, ysize);
      if (interp->interp_object.state == NULL)
        {
          gsl_spline2d_free(interp);
          GSL_ERROR_NULL("failed to allocate space for gsl_spline2d state", GSL_ENOMEM);
        }
    }

  /*
   * Use one contiguous block of memory for all three data arrays.
   * That way the code fails immediately if there isn't sufficient space for everything,
   * rather than allocating one or two and then having to free them.
   */
  array_mem = (double *)calloc(xsize + ysize + xsize * ysize, sizeof(double));
  if (array_mem == NULL)
    {
      gsl_spline2d_free(interp);
      GSL_ERROR_NULL("failed to allocate space for data arrays", GSL_ENOMEM);
    }

  interp->xarr = array_mem;
  interp->yarr = array_mem + xsize;
  interp->zarr = array_mem + xsize + ysize;

  return interp;
} /* gsl_spline2d_alloc() */

int
gsl_spline2d_init(gsl_spline2d * interp, const double xarr[],
                  const double yarr[], const double zarr[],
                  size_t xsize, size_t ysize)
{
  int status = gsl_interp2d_init(&(interp->interp_object), xarr, yarr, zarr, xsize, ysize);

  memcpy(interp->xarr, xarr, xsize * sizeof(double));
  memcpy(interp->yarr, yarr, ysize * sizeof(double));
  memcpy(interp->zarr, zarr, xsize * ysize * sizeof(double));

  return status;
} /* gsl_spline2d_init() */

void
gsl_spline2d_free(gsl_spline2d * interp)
{
  RETURN_IF_NULL(interp);

  if (interp->interp_object.type->free)
    interp->interp_object.type->free(interp->interp_object.state);

  /*
   * interp->xarr points to the beginning of one contiguous block of memory
   * that holds interp->xarr, interp->yarr, and interp->zarr. So it all gets
   * freed with one call. cf. gsl_spline2d_alloc() implementation
   */
  if (interp->xarr)
    free(interp->xarr);

  free(interp);
} /* gsl_spline2d_free() */

double
gsl_spline2d_eval(const gsl_spline2d * interp, const double x,
                  const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval(&(interp->interp_object), interp->xarr, interp->yarr,
                           interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_e(const gsl_spline2d * interp, const double x,
                    const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                    double * z)
{
  return gsl_interp2d_eval_e(&(interp->interp_object), interp->xarr, interp->yarr,
                             interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_extrap(const gsl_spline2d * interp, const double x,
                         const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_extrap(&(interp->interp_object), interp->xarr, interp->yarr,
                                  interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_extrap_e(const gsl_spline2d * interp, const double x,
                           const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                           double * z)
{
  return gsl_interp2d_eval_extrap_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                    interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_deriv_x(const gsl_spline2d * interp, const double x,
                          const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_deriv_x(&(interp->interp_object), interp->xarr, interp->yarr,
                                   interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_deriv_x_e(const gsl_spline2d * interp, const double x,
                            const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                            double * z)
{
  return gsl_interp2d_eval_deriv_x_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                     interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_deriv_y(const gsl_spline2d * interp, const double x,
                          const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_deriv_y(&(interp->interp_object), interp->xarr, interp->yarr,
                                   interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_deriv_y_e(const gsl_spline2d * interp, const double x,
                            const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                            double * z)
{
  return gsl_interp2d_eval_deriv_y_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                     interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_deriv_xx(const gsl_spline2d * interp, const double x,
                           const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_deriv_xx(&(interp->interp_object), interp->xarr, interp->yarr,
                                    interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_deriv_xx_e(const gsl_spline2d * interp, const double x,
                             const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                             double * z)
{
  return gsl_interp2d_eval_deriv_xx_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                      interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_deriv_yy(const gsl_spline2d * interp, const double x,
                           const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_deriv_yy(&(interp->interp_object), interp->xarr, interp->yarr,
                                    interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_deriv_yy_e(const gsl_spline2d * interp, const double x,
                             const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                             double * z)
{
  return gsl_interp2d_eval_deriv_yy_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                      interp->zarr, x, y, xa, ya, z);
}

double
gsl_spline2d_eval_deriv_xy(const gsl_spline2d * interp, const double x,
                           const double y, gsl_interp_accel * xa, gsl_interp_accel * ya)
{
  return gsl_interp2d_eval_deriv_xy(&(interp->interp_object), interp->xarr, interp->yarr,
                                    interp->zarr, x, y, xa, ya);
}

int
gsl_spline2d_eval_deriv_xy_e(const gsl_spline2d * interp, const double x,
                             const double y, gsl_interp_accel * xa, gsl_interp_accel * ya,
                             double * z)
{
  return gsl_interp2d_eval_deriv_xy_e(&(interp->interp_object), interp->xarr, interp->yarr,
                                      interp->zarr, x, y, xa, ya, z);
}

size_t
gsl_spline2d_min_size(const gsl_spline2d * interp)
{
  return gsl_interp2d_min_size(&(interp->interp_object));
}

const char *
gsl_spline2d_name(const gsl_spline2d * interp)
{
  return gsl_interp2d_name(&(interp->interp_object));
}

int
gsl_spline2d_set(const gsl_spline2d * interp, double zarr[],
                 const size_t i, const size_t j, const double z)
{
  return gsl_interp2d_set(&(interp->interp_object), zarr, i, j, z);
} /* gsl_spline2d_set() */

double
gsl_spline2d_get(const gsl_spline2d * interp, const double zarr[],
                 const size_t i, const size_t j)
{
  return gsl_interp2d_get(&(interp->interp_object), zarr, i, j);
} /* gsl_spline2d_get() */


#ifndef setup_h
#define setup_h

#include <ceed.h>
#include <petsc.h>
#include <petscdmplex.h>
#include <petscfe.h>
#include <petscksp.h>
#include <stdbool.h>
#include <string.h>
#include "problems/problems.h"
#include "include/cl-options.h"
#include "include/matops.h"
#include "include/misc.h"
#include "include/structs.h"
#include "include/setup-dm.h"
#include "include/setup-libceed.h"
#include "include/utils.h"

#endif // setup_h


#ifndef OPENMC_TALLIES_TALLY_H
#define OPENMC_TALLIES_TALLY_H

#include "openmc/constants.h"
#include "openmc/memory.h" // for unique_ptr
#include "openmc/tallies/filter.h"
#include "openmc/tallies/trigger.h"
#include "openmc/vector.h"

#include <gsl/gsl>
#include "pugixml.hpp"
#include "xtensor/xfixed.hpp"
#include "xtensor/xtensor.hpp"

#include <string>
#include <unordered_map>

namespace openmc {

//==============================================================================
//! A user-specified flux-weighted (or current) measurement.
//==============================================================================

class Tally {
public:
  //----------------------------------------------------------------------------
  // Constructors, destructors, factory functions
  explicit Tally(int32_t id);
  explicit Tally(pugi::xml_node node);
  ~Tally();
  static Tally* create(int32_t id = -1);

  //----------------------------------------------------------------------------
  // Accessors

  void set_id(int32_t id);

  void set_active(bool active) { active_ = active; }

  void set_writable(bool writable) { writable_ = writable; }

  void set_scores(pugi::xml_node node);

  void set_scores(const vector<std::string>& scores);

  void set_nuclides(pugi::xml_node node);

  void set_nuclides(const vector<std::string>& nuclides);

  const vector<int32_t>& filters() const { return filters_; }

  int32_t filters(int i) const {return filters_[i];}

  void set_filters(gsl::span<Filter*> filters);

  int32_t strides(int i) const {return strides_[i];}

  int32_t n_filter_bins() const {return n_filter_bins_;}

  bool writable() const { return writable_;}

  //----------------------------------------------------------------------------
  // Other methods.

  void add_filter(Filter* filter) { set_filters({&filter, 1}); }

  void init_triggers(pugi::xml_node node);

  void init_results();

  void reset();

  void accumulate();

  //! A string representing the i-th score on this tally
  std::string score_name(int score_idx) const;

  //! A string representing the i-th nuclide on this tally
  std::string nuclide_name(int nuclide_idx) const;

  //----------------------------------------------------------------------------
  // Major public data members.

  int id_ {C_NONE}; //!< User-defined identifier

  std::string name_; //!< User-defined name

  TallyType type_ {TallyType::VOLUME}; //!< e.g. volume, surface current

  //! Event type that contributes to this tally
  TallyEstimator estimator_ {TallyEstimator::TRACKLENGTH};

  //! Whether this tally is currently being updated
  bool active_ {false};

  //! Number of realizations
  int n_realizations_ {0};

  vector<int> scores_; //!< Filter integrands (e.g. flux, fission)

  //! Index of each nuclide to be tallied.  -1 indicates total material.
  vector<int> nuclides_ {-1};

  //! True if this tally has a bin for every nuclide in the problem
  bool all_nuclides_ {false};

  //! Results for each bin -- the first dimension of the array is for the
  //! combination of filters (e.g. specific cell, specific energy group, etc.)
  //! and the second dimension of the array is for scores (e.g. flux, total
  //! reaction rate, fission reaction rate, etc.)
  xt::xtensor<double, 3> results_;

  //! True if this tally should be written to statepoint files
  bool writable_ {true};

  //----------------------------------------------------------------------------
  // Miscellaneous public members.

  // We need to have quick access to some filters.  The following gives indices
  // for various filters that could be in the tally or C_NONE if they are not
  // present.
  int energyout_filter_ {C_NONE};
  int delayedgroup_filter_ {C_NONE};

  vector<Trigger> triggers_;

  int deriv_ {C_NONE}; //!< Index of a TallyDerivative object for diff tallies.

private:
  //----------------------------------------------------------------------------
  // Private data.

  vector<int32_t> filters_; //!< Filter indices in global filters array

  //! Index strides assigned to each filter to support 1D indexing.
  vector<int32_t> strides_;

  int32_t n_filter_bins_ {0};

  gsl::index index_;
};

//==============================================================================
// Global variable declarations
//==============================================================================

namespace model {
  extern std::unordered_map<int, int> tally_map;
  extern vector<unique_ptr<Tally>> tallies;
  extern vector<int> active_tallies;
  extern vector<int> active_analog_tallies;
  extern vector<int> active_tracklength_tallies;
  extern vector<int> active_collision_tallies;
  extern vector<int> active_meshsurf_tallies;
  extern vector<int> active_surface_tallies;
}

namespace simulation {
  //! Global tallies (such as k-effective estimators)
  extern xt::xtensor_fixed<double, xt::xshape<N_GLOBAL_TALLIES, 3>> global_tallies;

  //! Number of realizations for global tallies
  extern "C" int32_t n_realizations;
}

extern double global_tally_absorption;
extern double global_tally_collision;
extern double global_tally_tracklength;
extern double global_tally_leakage;

//==============================================================================
// Non-member functions
//==============================================================================

//! Read tally specification from tallies.xml
void read_tallies_xml();

//! \brief Accumulate the sum of the contributions from each history within the
//! batch to a new random variable
void accumulate_tallies();

//! Determine which tallies should be active
void setup_active_tallies();

// Alias for the type returned by xt::adapt(...). N is the dimension of the
// multidimensional array
template <std::size_t N>
using adaptor_type = xt::xtensor_adaptor<xt::xbuffer_adaptor<double*&, xt::no_ownership>, N>;

#ifdef OPENMC_MPI
//! Collect all tally results onto master process
void reduce_tally_results();
#endif

void free_memory_tally();

} // namespace openmc

#endif // OPENMC_TALLIES_TALLY_H


/**
 * \file DelayInterface.h
 */

#ifndef ATK_DELAY_DELAYINTERFACE_H
#define ATK_DELAY_DELAYINTERFACE_H

#include <ATK/Delay/config.h>

#include <gsl/gsl>

#include <map>

namespace ATK
{
  /// Interface for a fixed filter
  class ATK_DELAY_EXPORT DelayInterface
  {
  public:
    virtual ~DelayInterface() = default;
    /// Sets the delay of the filter
  virtual void set_delay(gsl::index delay) = 0;
    /// Returns the delay
    virtual gsl::index get_delay() const = 0;
  };

  /// Interface for a universal filter
  template<class DataType>
  class ATK_DELAY_EXPORT UniversalDelayInterface
  {
  public:
    virtual ~UniversalDelayInterface() = default;

    /// Sets the blend of the filter
    virtual void set_blend(DataType blend) = 0;
    /// Returns the blend
    virtual DataType get_blend() const = 0;
    /// Sets the feedback of the filter
    virtual void set_feedback(DataType feedback) = 0;
    /// Returns the feedback
    virtual DataType get_feedback() const = 0;
    /// Sets the feedforward of the filter
    virtual void set_feedforward(DataType feedforward) = 0;
    /// Returns the feedforward
    virtual DataType get_feedforward() const = 0;
  };
}

#endif


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

#include <config.h>
#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_test.h>
#include <gsl/gsl_ieee_utils.h>

#define M 53
#define N 107

int status = 0;

#ifndef DESC
#define DESC ""
#endif

#define BASE_GSL_COMPLEX_LONG
#include "templates_on.h"
#include "test_complex_source.c"
#include "templates_off.h"
#undef  BASE_GSL_COMPLEX_LONG

#define BASE_GSL_COMPLEX
#include "templates_on.h"
#include "test_complex_source.c"
#include "templates_off.h"
#undef  BASE_GSL_COMPLEX

#define BASE_GSL_COMPLEX_FLOAT
#include "templates_on.h"
#include "test_complex_source.c"
#include "templates_off.h"
#undef  BASE_GSL_COMPLEX_FLOAT

#define BASE_LONG_DOUBLE
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_LONG_DOUBLE

#define BASE_DOUBLE
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_DOUBLE

#define BASE_FLOAT
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_FLOAT

#define BASE_ULONG
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_ULONG

#define BASE_LONG
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_LONG

#define BASE_UINT
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_UINT

#define BASE_INT
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_INT

#define BASE_USHORT
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_USHORT

#define BASE_SHORT
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_SHORT

#define BASE_UCHAR
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_UCHAR

#define BASE_CHAR
#include "templates_on.h"
#include "test_source.c"
#include "templates_off.h"
#undef  BASE_CHAR

void my_error_handler (const char *reason, const char *file,
		       int line, int err);

int
main (void)
{
  gsl_ieee_env_setup ();

  test_func ();
  test_float_func ();
  test_long_double_func ();
  test_ulong_func ();
  test_long_func ();
  test_uint_func ();
  test_int_func ();
  test_ushort_func ();
  test_short_func ();
  test_uchar_func ();
  test_char_func ();
  test_complex_func ();
  test_complex_float_func ();
  test_complex_long_double_func ();

  test_text ();
  test_float_text ();
#ifdef HAVE_PRINTF_LONGDOUBLE
  test_long_double_text ();
#endif
  test_ulong_text ();
  test_long_text ();
  test_uint_text ();
  test_int_text ();
  test_ushort_text ();
  test_short_text ();
  test_uchar_text ();
  test_char_text ();
  test_complex_text ();
  test_complex_float_text ();
#ifdef HAVE_PRINTF_LONGDOUBLE
  test_complex_long_double_text ();
#endif

  test_binary ();
  test_float_binary ();
  test_long_double_binary ();
  test_ulong_binary ();
  test_long_binary ();
  test_uint_binary ();
  test_int_binary ();
  test_ushort_binary ();
  test_short_binary ();
  test_uchar_binary ();
  test_char_binary ();
  test_complex_binary ();
  test_complex_float_binary ();
  test_complex_long_double_binary ();

  gsl_warnings_off = 1;

  gsl_set_error_handler (&my_error_handler);

  test_trap ();
  test_float_trap ();
  test_long_double_trap ();
  test_ulong_trap ();
  test_long_trap ();
  test_uint_trap ();
  test_int_trap ();
  test_ushort_trap ();
  test_short_trap ();
  test_uchar_trap ();
  test_char_trap ();
  test_complex_trap ();
  test_complex_float_trap ();
  test_complex_long_double_trap ();

  exit (gsl_test_summary ());
}

void
my_error_handler (const char *reason, const char *file, int line, int err)
{
  if (0)
    printf ("(caught [%s:%d: %s (%d)])\n", file, line, reason, err);
  status = 1;
}


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

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_combination.h>

gsl_combination *
gsl_combination_alloc (const size_t n, const size_t k)
{
  gsl_combination * c;

  if (n == 0)
    {
      GSL_ERROR_VAL ("combination parameter n must be positive integer",
                        GSL_EDOM, 0);
    }
  if (k > n)
    {
      GSL_ERROR_VAL ("combination length k must be an integer less than or equal to n",
                        GSL_EDOM, 0);
    }
  c = (gsl_combination *) malloc (sizeof (gsl_combination));

  if (c == 0)
    {
      GSL_ERROR_VAL ("failed to allocate space for combination struct",
                        GSL_ENOMEM, 0);
    }

  if (k > 0)
    {
      c->data = (size_t *) malloc (k * sizeof (size_t));

      if (c->data == 0)
        {
          free (c);             /* exception in constructor, avoid memory leak */

          GSL_ERROR_VAL ("failed to allocate space for combination data",
                         GSL_ENOMEM, 0);
        }
    }
  else
    {
      c->data = 0;
    }

  c->n = n;
  c->k = k;

  return c;
}

gsl_combination *
gsl_combination_calloc (const size_t n, const size_t k)
{
  size_t i;

  gsl_combination * c =  gsl_combination_alloc (n, k);

  if (c == 0)
    return 0;

  /* initialize combination to identity */

  for (i = 0; i < k; i++)
    {
      c->data[i] = i;
    }

  return c;
}

void
gsl_combination_init_first (gsl_combination * c)
{
  const size_t k = c->k ;
  size_t i;

  /* initialize combination to identity */

  for (i = 0; i < k; i++)
    {
      c->data[i] = i;
    }
}

void
gsl_combination_init_last (gsl_combination * c)
{
  const size_t k = c->k ;
  size_t i;
  size_t n = c->n;

  /* initialize combination to identity */

  for (i = 0; i < k; i++)
    {
      c->data[i] = n - k + i;
    }
}

void
gsl_combination_free (gsl_combination * c)
{
  if (c->k > 0) free (c->data);
  free (c);
}


#include "readArray_MPI.h"
#include "../include/paralleltt.h"

#include <mpi.h>
#include <stdio.h>
#include <stdlib.h>
#include <lapacke.h>
#include <time.h>
#include <math.h>

void* p_hilbert_init(int d, int* n){
    p_hilbert* parameters = (p_hilbert*) malloc(sizeof(p_hilbert));
    parameters->d = d;
    parameters->n = (int*) malloc(d*sizeof(int));
    for (int ii = 0; ii < d; ++ii){
        parameters->n[ii] = n[ii];
    }
    parameters->n_stream = (int*) calloc(d, sizeof(int));
    parameters->n_prod = (long*) malloc(d * sizeof(long));
    return (void*) parameters;
}

void p_hilbert_free(void* parameters){
    p_hilbert* p_casted = (p_hilbert*) parameters;
    free(p_casted->n); p_casted->n = NULL;
    free(p_casted->n_stream); p_casted->n_stream = NULL;
    free(p_casted->n_prod); p_casted->n_prod = NULL;
    free(p_casted);
}

void f_hilbert(double* restrict X, int* ind1, int* ind2, const void* parameters)
{
    p_hilbert* p_casted = (p_hilbert*) parameters;
    int d = p_casted->d;
    int* n = p_casted->n;
    int* n_stream = p_casted->n_stream;
    long* n_prod = p_casted->n_prod;

    long N_stream = 1;
    for (int ii = 0; ii < d; ++ii){
        n_stream[ii] = ind2[ii] - ind1[ii];
        N_stream = N_stream*n_stream[ii];
    }

    n_prod[0] = 1;
    for (int ii = 1; ii < d; ++ii){
        n_prod[ii] = (long) n_prod[ii-1] * n_stream[ii-1];
    }

    int bias = 1;
    for (int jj = 0; jj < d; ++jj){
        bias = bias + ind1[jj];
    }

    for (long ii = 0; ii < N_stream; ++ii){
        int xinv = bias;
		long tmp = ii;
		for (int jj = d-1; jj >= 0; jj--){
			xinv += tmp/n_prod[jj];
			tmp = tmp % n_prod[jj];
		}

        X[ii] = (double) 1/xinv;
    }
}

void* p_gaussian_bumps_init(int d, int* n, int M, double gamma, double* region, double* centers)
{
    p_gaussian_bumps* parameters = (p_gaussian_bumps*) malloc(sizeof(p_gaussian_bumps));
    parameters->d = d;
    parameters->n = (int*) calloc(d, sizeof(int));
    for (int ii = 0; ii < d; ++ii){
        parameters->n[ii] = n[ii];
    }

    parameters->M = M;
    parameters->gamma = gamma;

    parameters->region = (double*) calloc(2*d, sizeof(double));
    for (int ii = 0; ii < 2*d; ++ii){
        parameters->region[ii] = region[ii];
    }
    parameters->centers = (double*) calloc(d*M, sizeof(double));
    for (int ii = 0; ii < d*M; ++ii){
        parameters->centers[ii] = centers[ii];
    }

//    parameters->ten_ind_ii = (int*) calloc(d, sizeof(int));
    parameters->x_ii = (double*) calloc(d, sizeof(double));
    parameters->n_stream = (int*) calloc(d, sizeof(double));
    parameters->n_prod = (long*) calloc(d, sizeof(long));

    return (void*) parameters;
}

void* unit_random_p_gaussian_bumps_init(int d, int* n, int M, double gamma, int seed)
{
    p_gaussian_bumps* parameters = (p_gaussian_bumps*) malloc(sizeof(p_gaussian_bumps));
    parameters->d = d;
    parameters->n = (int*) calloc(d, sizeof(int));
    for (int ii = 0; ii < d; ++ii){
        parameters->n[ii] = n[ii];
    }

    parameters->M = M;
    parameters->gamma = gamma;

    parameters->region = (double*) calloc(2*d, sizeof(double));
    for (int ii = 0; ii < d; ++ii){
        parameters->region[2*ii] = -1.0;
        parameters->region[2*ii+1] = 1.0;
    }

    parameters->centers = (double*) calloc(d*M, sizeof(double));
    srand(seed);
    int r1 = rand()%4096, r2 = rand()%4096, r3 = rand()%4096, r4 = rand()%4096;
    int iseed[4] = {r1, r2, r3, r4+(r4%2 == 0?1:0)};
    LAPACKE_dlarnv(2, iseed, d*M, parameters->centers);

    parameters->x_ii = (double*) calloc(d, sizeof(double));
    parameters->n_stream = (int*) calloc(d, sizeof(double));
    parameters->n_prod = (long*) calloc(d, sizeof(long));

    return (void*) parameters;
}

void p_gaussian_bumps_free(void* parameters)
{
    p_gaussian_bumps* p_casted = (p_gaussian_bumps*) parameters;

    free(p_casted->n);          p_casted->n = NULL;
    free(p_casted->region);     p_casted->region = NULL;
    free(p_casted->centers);    p_casted->centers = NULL;
    free(p_casted->x_ii);       p_casted->x_ii = NULL;
    free(p_casted->n_stream);   p_casted->n_stream = NULL;
    free(p_casted->n_prod);     p_casted->n_prod = NULL;
    free(p_casted);
}

void f_gaussian_bumps(double* restrict X, int* ind1, int* ind2, const void* parameters)
{
    p_gaussian_bumps* p_casted = (p_gaussian_bumps*) parameters;
    int d = p_casted->d;
    int* n = p_casted->n;
    int M = p_casted->M;
    double gamma = p_casted->gamma;
    double* region = p_casted->region;
    double* centers = p_casted->centers;
    double* x_ii = p_casted->x_ii;
    int* n_stream = p_casted->n_stream;
    long* n_prod = p_casted->n_prod;

    long N_stream = 1;
    for (int ii = 0; ii < d; ++ii){
        n_stream[ii] = ind2[ii] - ind1[ii];
        N_stream = N_stream*n_stream[ii];
    }

    n_prod[0] = 1;
    for (int ii = 1; ii < d; ++ii){
        n_prod[ii] = (long) n_prod[ii-1] * n_stream[ii-1];
    }

    for (long ii = 0; ii < N_stream; ++ii){
        long tmp = ii;
        for (int jj = d-1; jj >= 0; jj--){
            int ind_jj = tmp/n_prod[jj];
            x_ii[jj] = region[2*jj] + (ind_jj + ind1[jj]) * (region[2*jj + 1] - region[2*jj]) / (n[jj] - 1);
			tmp = tmp % n_prod[jj];
		}

        X[ii] = 0;
        for (int kk = 0; kk < M; ++kk){
            double exponent = 0;
            for (int jj = 0; jj < d; ++jj){
                exponent += (x_ii[jj] - centers[kk*d + jj]) * (x_ii[jj] - centers[kk*d + jj]);
            }
            X[ii] += exp(-gamma * exponent);
        }
    }
}

void* p_arithmetic_init(int d, int* n)
{
    p_arithmetic* parameters = (p_arithmetic*) malloc(sizeof(p_arithmetic));
    parameters->d = d;
    parameters->n = (int*) malloc(d*sizeof(int));
    for (int ii = 0; ii < d; ++ii){
        parameters->n[ii] = n[ii];
    }
    return (void*) parameters;
}

void p_arithmetic_free(void* parameters)
{
    p_arithmetic* p_casted = (p_arithmetic*) parameters;
    free(p_casted->n); p_casted->n = NULL;
    free(p_casted);
}

void f_arithmetic(double* restrict X, int* ind1, int* ind2, const void* parameters)
{
    p_arithmetic* p_casted = (p_arithmetic*) parameters;
    int d = p_casted->d;
    int* n = p_casted->n;

    int* n_stream = (int*) calloc(d, sizeof(int));
    long N_stream = 1;
    for (int ii = 0; ii < d; ++ii){
        n_stream[ii] = ind2[ii] - ind1[ii];
        N_stream = N_stream*n_stream[ii];
    }

    int* ind_ii = (int*) calloc(d, sizeof(int));
    for (int ii = 0; ii < N_stream; ++ii){
        to_tensor_ind(ind_ii, ii, n_stream, d);
        for (int jj = 0; jj < d; ++jj){
            ind_ii[jj] = ind_ii[jj] + ind1[jj];
        }
        X[ii] = 1 + to_vec_ind(ind_ii, n, d);
//        X[ii] = X[ii] + (0.000000001 / X[ii]);
    }

    free(n_stream);
    free(ind_ii);
}

void* p_tt_init(tensor_train* tt)
{
    p_tt* parameters = (p_tt*) malloc(sizeof(p_tt));
    parameters->tt = tt;
    return (void*) parameters;
}

// Doesn't actually free the tensor train. You gotta do that yourself
void p_tt_free(void* parameters)
{
    p_tt* p_casted = (p_tt*) parameters;
    p_casted->tt = NULL;
    free(p_casted);
}

void f_tt(double* restrict X, int* ind1, int* ind2, const void* parameters)
{
    p_tt* p_casted = (p_tt*) parameters;
    tensor_train* tt = p_casted->tt;
    int d = tt->d;
    int* n = tt->n;
    int* r = tt->r;

    matrix_tt** train_submats = (matrix_tt**) calloc(d, sizeof(matrix_tt*));
    for (int ii = 0; ii < d; ++ii){
        matrix_tt* train_mat_ii = matrix_tt_wrap(r[ii]*n[ii], r[ii+1], tt->trains[ii]);
        train_submats[ii] = submatrix(train_mat_ii, ind1[ii]*r[ii], ind2[ii]*r[ii], 0, r[ii+1]);
        free(train_mat_ii);
    }

    matrix_tt* mult = submatrix_copy(train_submats[d-1]);
    matrix_tt_reshape(r[d-1], ind2[d-1] - ind1[d-1], mult);

    for (int jj = d-2; jj >= 1; --jj){
        matrix_tt* new_mult = matrix_tt_init(train_submats[jj]->m, mult->n);
        matrix_tt_dgemm(train_submats[jj], mult, new_mult, 1.0, 0.0);
        matrix_tt_reshape(r[jj], (new_mult->n) * (new_mult->m) / r[jj], new_mult);
        matrix_tt_free(mult); mult = new_mult;
    }

    long X_m = 1;
    for (int ii = 1; ii < d; ++ii){
        X_m = X_m*(ind2[ii] - ind1[ii]);
    }

    matrix_tt* X_mat = matrix_tt_wrap(ind2[0] - ind1[0], X_m, X);
    matrix_tt_dgemm(train_submats[0], mult, X_mat, 1.0, 0.0);

    for (int ii = 0; ii < d; ++ii){
        free(train_submats[ii]); train_submats[ii] = NULL;
    }

    free(train_submats); train_submats = NULL;
    matrix_tt_free(mult);   mult = NULL;
    free(X_mat);         X_mat = NULL;
}

double tt_error(tensor_train* tt, MPI_tensor* ten)
{
    MPI_Comm comm = ten->comm;
    tt_broadcast(comm, tt);

    void* parameters_tt = p_tt_init(tt);
    MPI_tensor* ten_tt = MPI_tensor_init(ten->d, ten->n, ten->nps, ten->comm, &f_tt, parameters_tt);
    int rank = ten_tt->rank;
    int* schedule_rank = ten_tt->schedule[rank];

    double true_norm_squared = 0;
    double diff_norm_squared = 0;

    flattening_info* fi = flattening_info_init(ten, 0, 1, 0);
    for (int ii = 0; ii < ten->n_schedule; ++ii){
        int block = schedule_rank[ii];

        if (block != -1){
            stream(ten, block);
            stream(ten_tt, block);

            flattening_info_update(fi, ten, block);
            long N = fi->t_N;

            for (int jj = 0; jj < N; ++jj){
                ten_tt->X[jj] = ten_tt->X[jj] - ten->X[jj];
            }

            matrix_tt* mat_true = matrix_tt_wrap(N, 1, ten->X);
            double tmp = frobenius_norm(mat_true);
            true_norm_squared = true_norm_squared + tmp*tmp;

            matrix_tt* mat_diff = matrix_tt_wrap(N, 1, ten_tt->X);
            tmp = frobenius_norm(mat_diff);
            diff_norm_squared = diff_norm_squared + tmp*tmp;
//            printf("r%d ii%d true_norm_squared = %e, diff_norm_squared = %e\n", rank, ii, true_norm_squared, diff_norm_squared);

            free(mat_true); mat_true = NULL;
            free(mat_diff); mat_diff = NULL;
        }
    }
    int head = 0;

    double true_norm_reduced;
    double diff_norm_reduced;
    MPI_Reduce(&true_norm_squared, &true_norm_reduced, 1, MPI_DOUBLE, MPI_SUM, head, comm);
    true_norm_reduced = sqrt(true_norm_reduced);

    MPI_Reduce(&diff_norm_squared, &diff_norm_reduced, 1, MPI_DOUBLE, MPI_SUM, head, comm);
    diff_norm_reduced = sqrt(diff_norm_reduced);

    double rel_err = diff_norm_reduced/true_norm_reduced;

    p_tt_free(parameters_tt); parameters_tt = NULL;
    flattening_info_free(fi); fi = NULL;
    MPI_tensor_free(ten_tt); ten_tt = NULL;

    return rel_err;
}