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

#include <config.h>
#include <stdlib.h>
#include <math.h>
#include <string.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_sort.h>
#include <gsl/gsl_statistics.h>
#include <gsl/gsl_test.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_sort.h>
#include <gsl/gsl_ieee_utils.h>
#include <gsl/gsl_filter.h>

/* compare two vectors */
static void
compare_vectors(const double tol, const gsl_vector * v, const gsl_vector * expected,
                const char * desc)
{
  const size_t n = v->size;
  size_t i;

  for (i = 0; i < n; ++i)
    {
      double vi = gsl_vector_get(v, i);
      double ui = gsl_vector_get(expected, i);

      gsl_test_rel(vi, ui, tol, "%s i=%zu", desc, i);
    }
}

/* generate random vector with elements in [-1,1] */
static void
random_vector(gsl_vector * v, gsl_rng * r)
{
  size_t i;

  for (i = 0; i < v->size; ++i)
    {
      double vi = 2.0 * gsl_rng_uniform(r) - 1.0; /* in [-1,1] */
      gsl_vector_set(v, i, vi);
    }
}

#include "test_impulse.c"
#include "test_gaussian.c"
#include "test_median.c"
#include "test_rmedian.c"

int
main()
{
  gsl_rng * r = gsl_rng_alloc(gsl_rng_default);

  test_gaussian(r);

  test_impulse(r);
  test_median(r);
  test_rmedian(r);

  gsl_rng_free(r);

  exit (gsl_test_summary());
}


/*
 * BRAINS
 * (B)LR (R)everberation-mapping (A)nalysis (I)n AGNs with (N)ested (S)ampling
 * Yan-Rong Li, liyanrong@ihep.ac.cn
 * Thu, Aug 4, 2016
 */

/*!
 *  \file reconstruct_sa.c
 *  \brief reconstruct sa and RM data.
 */

#ifdef SA

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <float.h>
#include <gsl/gsl_interp.h>

#include "brains.h"

void *best_model_sa;      /*!< best model */
void *best_model_std_sa;  /*!< standard deviation of the best model */

/*!
 * postprocessing.
 */
void postprocess_sa()
{
  char posterior_sample_file[BRAINS_MAX_STR_LENGTH];
  int num_ps, i, j, k;
  double *pm, *pmstd;
  void *posterior_sample, *post_model;
  int size_of_modeltype = num_params * sizeof(double);

  best_model_sa = malloc(size_of_modeltype);
  best_model_std_sa = malloc(size_of_modeltype);

  if(thistask == roottask)
  {
    // initialize smoothing workspace
    char fname[200];
    FILE *fp, *fline, *fsa;

    sa_smooth_init(n_vel_sa_data, vel_sa_data, parset.sa_InstRes);

    // get number of lines in posterior sample file
    get_posterior_sample_file(dnest_options_file, posterior_sample_file);

    //file for posterior sample
    fp = fopen(posterior_sample_file, "r");
    if(fp == NULL)
    {
      fprintf(stderr, "# Error: Cannot open file %s.\n", posterior_sample_file);
      exit(0);
    }

    //file for line reconstruction
    sprintf(fname, "%s/%s", parset.file_dir, "data/sa_line_rec.txt");
    fline = fopen(fname, "w");
    if(fline == NULL)
    {
      fprintf(stderr, "# Error: Cannot open file %s.\n", fname);
      exit(0);
    }

    //file for phase
    sprintf(fname, "%s/%s", parset.file_dir, "data/sa_phase_rec.txt");
    fsa = fopen(fname, "w");
    if(fsa == NULL)
    {
      fprintf(stderr, "# Error: Cannot open file %s.\n", fname);
      exit(0);
    }

    // read number of lines
    if(fscanf(fp, "# %d", &num_ps) < 1)
    {
      fprintf(stderr, "# Error: Cannot read file %s.\n", posterior_sample_file);
      exit(0);
    }
    printf("# Number of points in posterior sample: %d\n", num_ps);

    post_model = malloc(size_of_modeltype);
    posterior_sample = malloc(num_ps * size_of_modeltype);

    force_update = 1;
    which_parameter_update = -1; // force to update the transfer function
    which_particle_update = 0;

    for(i=0; i<num_ps; i++)
    {
      // read lines
      for(j=0; j<num_params; j++)
      {
        if(fscanf(fp, "%lf", (double *)post_model + j) < 1)
        {
          fprintf(stderr, "# Error: Cannot read file %s.\n", posterior_sample_file);
          exit(0);
        }
      }
      fscanf(fp, "\n");

      //store model
      memcpy(posterior_sample+i*size_of_modeltype, post_model, size_of_modeltype);

      calculate_sa_from_blrmodel(post_model, 0);

      //if( i % (num_ps/10+1) == 0)
      {
        // output sa line
        for(j=0; j<n_vel_sa_data; j++)
        {
          fprintf(fline, "%e %e\n", wave_sa_data[j], Fline_sa[j]);
        }
        fprintf(fline, "\n");

        // output sa phase
        for(k=0; k<n_base_sa_data; k++)
        {
          for(j=0; j<n_vel_sa_data; j++)
          {
            fprintf(fsa, "%e %e\n", wave_sa_data[j], phase_sa[k*n_vel_sa_data + j]/(PhaseFactor * wave_sa_data[j]) );
          }
        }
        fprintf(fsa, "\n");
      }
    }

    fclose(fp);
    fclose(fline);
    fclose(fsa);

    sa_smooth_end();

    pm = (double *)best_model_sa;
    pmstd = (double *)best_model_std_sa;
    for(j=0; j<num_params; j++)
    {
      pm[j] = pmstd[j] = 0.0;
    }
    for(i=0; i<num_ps; i++)
    {
      for(j =0; j<num_params; j++)
        pm[j] += *((double *)posterior_sample + i*num_params + j );
    }

    for(j=0; j<num_params; j++)
      pm[j] /= num_ps;

    for(i=0; i<num_ps; i++)
    {
      for(j=0; j<num_params; j++)
        pmstd[j] += pow( *((double *)posterior_sample + i*num_params + j ) - pm[j], 2.0 );
    }

    for(j=0; j<num_params; j++)
    {
      if(num_ps > 1)
        pmstd[j] = sqrt(pmstd[j]/(num_ps-1.0));
      else
        pmstd[j] = 0.0;
    }

    for(j = 0; j<num_params_sa; j++)
      printf("Best params %d %f +- %f\n", j, *((double *)best_model_sa + j),
                                             *((double *)best_model_std_sa+j) );

    free(post_model);
    free(posterior_sample);
  }
  return;
}

/*!
 * this function run dnest sampleing, reconstruct light curves using the best estimates for parameters.
 */
void reconstruct_sa()
{
  int i, argc=0;
  char **argv;

  //configure restart of dnest
  argv = malloc(9*sizeof(char *));
  for(i=0; i<9; i++)
  {
    argv[i] = malloc(BRAINS_MAX_STR_LENGTH*sizeof(char));
  }
  //setup argc and argv
  strcpy(argv[argc++], "dnest");
  strcpy(argv[argc++], "-s");
  strcpy(argv[argc], parset.file_dir);
  strcat(argv[argc++], "/data/restartsa_dnest.txt");

  if(parset.flag_restart == 1)
  {
    strcpy(argv[argc++], "-r");
    strcpy(argv[argc], parset.file_dir);
    strcat(argv[argc], "/");
    strcat(argv[argc++], "data/restartsa_dnest.txt");
  }
  if(parset.flag_postprc == 1)
  {
    strcpy(argv[argc++], "-p");
  }
  if(parset.flag_temp == 1)
  {
    sprintf(argv[argc++], "-t%f", parset.temperature);
  }
  if(parset.flag_sample_info == 1)
  {
    strcpy(argv[argc++], "-c");
  }

  //level-dependent sampling
  {
    strcpy(argv[argc++], "-l");
  }

  reconstruct_sa_init();

  sa_smooth_init(n_vel_sa_data, vel_sa_data, parset.sa_InstRes);
  dnest_sa(argc, argv);
  sa_smooth_end();

  if(parset.flag_exam_prior != 1 && parset.flag_para_name != 1)
  {
    postprocess_sa();

    if(thistask == roottask)
    {
      FILE *fp;
      char fname[200];
      int j, k;

      force_update = 1;
      which_parameter_update = -1; // force to update the transfer function
      which_particle_update = 0;

      sa_smooth_init(n_vel_sa_data, vel_sa_data, parset.sa_InstRes);
      calculate_sa_from_blrmodel(best_model_sa, 1);
      sa_smooth_end();

      sprintf(fname, "%s/%s", parset.file_dir, "data/psa_line.txt");
      fp = fopen(fname, "w");
      if(fp == NULL)
      {
        fprintf(stderr, "# Error: Cannot open file %s.\n", fname);
        exit(0);
      }
      // output sa line
      for(j=0; j<n_vel_sa_data; j++)
      {
        fprintf(fp, "%e %e\n", wave_sa_data[j], Fline_sa[j]);
      }
      fclose(fp);

      //file for phase
      sprintf(fname, "%s/%s", parset.file_dir, "data/psa_phase.txt");
      fp = fopen(fname, "w");
      if(fp == NULL)
      {
        fprintf(stderr, "# Error: Cannot open file %s.\n", fname);
        exit(0);
      }
      for(k=0; k<n_base_sa_data; k++)
      {
        for(j=0; j<n_vel_sa_data; j++)
        {
          fprintf(fp, "%e %e\n", wave_sa_data[j], phase_sa[k*n_vel_sa_data + j]/(PhaseFactor * wave_sa_data[j]) );
        }
        fprintf(fp, "\n");
      }
      fclose(fp);
    }
  }

  reconstruct_sa_end();

  //clear up argv
  for(i=0; i<9; i++)
  {
    free(argv[i]);
  }
  free(argv);

  return;
}

void reconstruct_sa_init()
{
  sprintf(dnest_options_file, "%s/%s", parset.file_dir, "src/OPTIONSSA");
  if(thistask == roottask)
  {
    get_num_particles(dnest_options_file);
  }
  MPI_Bcast(&parset.num_particles, 1, MPI_INT, roottask, MPI_COMM_WORLD);

  phase_sa = malloc(n_base_sa_data * n_vel_sa_data * sizeof(double));
  Fline_sa = malloc(n_vel_sa_data * sizeof(double));

  /* cloud sample related */
  clouds_weight = malloc(parset.n_cloud_per_task * sizeof(double));
  clouds_alpha = malloc(parset.n_cloud_per_task * sizeof(double));
  clouds_beta = malloc(parset.n_cloud_per_task * sizeof(double));
  clouds_vel = malloc(parset.n_cloud_per_task * parset.n_vel_per_cloud * sizeof(double));

  workspace_phase = malloc( (3*n_vel_sa_data)* sizeof(double));

  if(parset.flag_save_clouds && thistask == roottask)
  {
    if(parset.n_cloud_per_task <= 1000)
      icr_cloud_save = 1;
    else
      icr_cloud_save = parset.n_cloud_per_task/1000;

    char fname[200];
    sprintf(fname, "%s/%s", parset.file_dir, parset.cloud_out_file);
    fcloud_out = fopen(fname, "w");
    if(fcloud_out == NULL)
    {
      fprintf(stderr, "# Error: Cannot open file %s\n", fname);
      exit(-1);
    }
  }
  return;
}

void reconstruct_sa_end()
{
  int i;

  free(phase_sa);
  free(Fline_sa);

  for(i=0; i<num_params; i++)
  {
    free(par_range_model[i]);
    free(par_prior_gaussian[i]);
  }
  free(par_range_model);
  free(par_prior_gaussian);
  free(par_prior_model);

  free(par_fix);
  free(par_fix_val);
  free(best_model_sa);
  free(best_model_std_sa);

  /* clouds sample related */
  free(clouds_weight);
  free(clouds_alpha);
  free(clouds_beta);
  free(clouds_vel);

  free(workspace_phase);

  if(parset.flag_save_clouds && thistask==roottask)
  {
    fclose(fcloud_out);
  }
  if(thistask == roottask)
  {
    printf("Ends reconstruct_sa.\n");
  }
  return;
}

/*!
 * this function calculate probability.
 *
 * At each MCMC step, only one parameter is updated, which only changes some values; thus,
 * optimization that reuses the unchanged values can improve computation efficiency.
 */
double prob_sa(const void *model)
{
  double prob_sa = 0.0, var2, dy;
  int i, j;

  calculate_sa_from_blrmodel(model, 0);

  for(j=0; j<n_epoch_sa_data; j++)
  {
    for(i=0; i<n_vel_sa_data; i++)
    {
      dy = Fline_sa[i] - Fline_sa_data[i + j*n_vel_sa_data];
      var2 = Flerrs_sa_data[i+j*n_vel_sa_data]*Flerrs_sa_data[i+j*n_vel_sa_data];
      prob_sa += -0.5 * (dy*dy)/var2 - 0.5*log(var2 * 2.0*PI);
    }
  }

  for(j=0; j<n_base_sa_data; j++)
  {
    for(i=0; i<n_vel_sa_data; i++)
    {
      dy = phase_sa[j*n_vel_sa_data + i] - phase_sa_data[j*n_vel_sa_data + i];
      var2 = pherrs_sa_data[j*n_vel_sa_data + i] * pherrs_sa_data[j*n_vel_sa_data + i];
      prob_sa += -0.5 * (dy*dy)/var2 - 0.5*log(var2 * 2.0*PI);
    }
  }

  return prob_sa;
}

#endif


#include "linear.h"
#include <assert.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <float.h>
#include <lauxlib.h>
#include <cblas.h>
#include <lapacke.h>

/* matrix orders */
static const char * const ORDERS[] = { "row", "col", NULL };

/* checks an order */
static CBLAS_ORDER checkorder (lua_State *L, int index) {

	switch (luaL_checkoption(L, index, "row", ORDERS)) {
	case 0:
		return CblasRowMajor;

	case 1:
		return CblasColMajor;
	}

	/* not reached */
	assert(0);
	return (CBLAS_ORDER)0;
}

/* checks a transpose */
static CBLAS_TRANSPOSE checktranspose (lua_State *L, int index) {
	static const char * const TRANSPOSES[] = { "notrans", "trans", NULL };

	switch (luaL_checkoption(L, index, "notrans", TRANSPOSES)) {
	case 0:
		return CblasNoTrans;

	case 1:
		return CblasTrans;
	}

	/* not reached */
	assert(0);
	return (CBLAS_TRANSPOSE)0;
}

/* translates a transpose for LAPACK */
static char lapacktranspose (CBLAS_TRANSPOSE transpose) {
	switch (transpose) {
	case CblasNoTrans:
		return 'N';

	case CblasTrans:
		return 'T';

	default:
		/* not reached */
		assert(0);
		return '\0';
	}
}

/* returns an int value from a table */
static int intvalue (lua_State *L, const char *key, int dfl) {
	int result, isinteger;

	lua_getfield(L, -1, key);
	if (!lua_isnil(L, -1)) {
		result = lua_tointegerx(L, -1, &isinteger);
		if (!isinteger) {
			luaL_error(L, "bad field " LUA_QS, key);
		}
	} else {
		if (dfl < 0) {
			luaL_error(L, "missing field " LUA_QS, key);
		}
		result = dfl;
	}
	lua_pop(L, 1);
	return result;
}

/* returns an option value from a table */
static int optionvalue (lua_State *L, const char *key, const char *dfl,
		const char *options[]) {
	const char *str;
	int i;

	lua_getfield(L, -1, key);
	if (!lua_isnil(L, -1)) {
		str = lua_tostring(L, -1);
		if (str == NULL) {
			luaL_error(L, "bad field " LUA_QS, key);
		}
	} else {
		if (dfl == NULL) {
			luaL_error(L, "missing field " LUA_QS, key);
		}
		str = dfl;
	}
	lua_pop(L, 1);
	for (i = 0; options[i] != NULL; i++) {
		if (strcmp(options[i], str) == 0) {
			return i;
		}
	}
	luaL_error(L, "bad option " LUA_QS " in field " LUA_QS, str, key);
	return 0; /* not reached */
}

/* raises a linear argument error */
static int argerror (lua_State *L, int index) {
	return luaL_argerror(L, index, lua_pushfstring(L, "vector, or matrix "
			"expected, got %s", luaL_typename(L, index)));
}

/* pushes a new vector onto the stack */
static struct vector *newvector (lua_State *L, int size) {
	return lualinear_newvector(L, size);
}

/* pushes an existing vector onto the stack */
static struct vector *wrapvector (lua_State *L, int size, float *values) {
	return lualinear_wrapvector(L, size, values);
}

/* creates a new vector */
static int vector (lua_State *L) {
	int size;

	/* process arguments */
	size = luaL_checkinteger(L, 1);
	luaL_argcheck(L, size >= 1, 1, "bad dimension");

	/* create */
	newvector(L, size);
	return 1;
}

/* vector length implementation */
static int vector_len (lua_State *L) {
	struct vector *x;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	lua_pushinteger(L, x->size);
	return 1;
}

/* vector index implementation */
static int vector_index (lua_State *L) {
	struct vector *x;
	int index;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	index = luaL_checkinteger(L, 2);
	luaL_argcheck(L, index >= 1 && index <= x->size, 2, "bad index");
	lua_pushnumber(L, x->values[(size_t)(index - 1) * x->inc]);
	return 1;
}

/* matrix vector newindex implementation */
static int vector_newindex (lua_State *L) {
	struct vector *x;
	int index;
	float value;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	index = luaL_checkinteger(L, 2);
	luaL_argcheck(L, index >= 1 && index <= x->size, 2, "bad index");
	value = luaL_checknumber(L, 3);
	x->values[(size_t)(index - 1) * x->inc] = value;
	return 0;
}

/* vector next function */
static int vector_next (lua_State *L) {
	struct vector *x;
	int index;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	index = luaL_checkinteger(L, 2);
	if (index >= 0 && index < x->size) {
		lua_pushinteger(L, index + 1);
		lua_pushnumber(L, x->values[(size_t)index]);
		return 2;
	}
	lua_pushnil(L);
	return 1;
}

/* vector ipairs function */
static int vector_ipairs (lua_State *L) {
	luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	lua_pushcfunction(L, vector_next);
	lua_pushvalue(L, 1);
	lua_pushinteger(L, 0);
	return 3;
}

/* returns the string representation of a vector */
static int vector_tostring (lua_State *L) {
	struct vector *x;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	lua_pushfstring(L, "vector: %p", x);
	return 1;
}

/* frees a vector */
static int vector_free (lua_State *L) {
	struct vector *x;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x->ref == LUA_NOREF) {
		free(x->values);
	} else {
		luaL_unref(L, LUA_REGISTRYINDEX, x->ref);
	}
	return 0;
}

/* pushes a new matrix onto the stack */
static struct matrix *newmatrix (lua_State *L, int rows, int cols,
		CBLAS_ORDER order) {
	return lualinear_newmatrix(L, rows, cols, order);
}

/* pushes an existing matrix onto the stack */
static struct matrix *wrapmatrix (lua_State *L, int rows, int cols,
		CBLAS_ORDER order, float *values) {
	return lualinear_wrapmatrix(L, rows, cols, order, values);
}

/* creates a new matrix */
static int matrix (lua_State *L) {
	int rows, cols;
	CBLAS_ORDER order;

	/* process arguments */
	rows = luaL_checkinteger(L, 1);
	luaL_argcheck(L, rows >= 1, 1, "bad dimension");
	cols = luaL_checkinteger(L, 2);
	luaL_argcheck(L, cols >= 1, 2, "bad dimension");
	order = checkorder(L, 3);

	/* create */
	newmatrix(L, rows, cols, order);
	return 1;
}

/* returns the length of a matrix */
static int matrix_len (lua_State *L) {
	struct matrix *X;

	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	switch (X->order) {
	case CblasRowMajor:
		lua_pushinteger(L, X->rows);
		break;

	case CblasColMajor:
		lua_pushinteger(L, X->cols);
		break;
	}
	return 1;
}

/* matrix index implementation */
static int matrix_index (lua_State *L) {
	struct matrix *X;
	int index, size;
	struct vector *x;

	/* process arguments */
	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	index = luaL_checkinteger(L, 2);
	luaL_argcheck(L, index >= 1, 2, "bad index");
	switch (X->order) {
	case CblasRowMajor:
		luaL_argcheck(L, index <= X->rows, 2, "bad index");
		size = X->cols;
		break;

	case CblasColMajor:
		luaL_argcheck(L, index <= X->cols, 2, "bad index");
		size = X->rows;
		break;

	default:
		/* not reached */
		size = -1;
		assert(0);
	}

	/* create vector */
	x = wrapvector(L, size, &X->values[(size_t)(index - 1) * X->ld]);
	lua_pushvalue(L, 1);
	x->ref = luaL_ref(L, LUA_REGISTRYINDEX);
	return 1;
}

/* matrix next function */
static int matrix_next (lua_State *L) {
	struct matrix *X;
	int index, majorsize, minorsize;
	struct vector *x;

	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	index = luaL_checkinteger(L, 2);
	switch (X->order) {
	case CblasRowMajor:
		majorsize = X->rows;
		minorsize = X->cols;
		break;

	case CblasColMajor:
		majorsize = X->cols;
		minorsize = X->rows;
		break;

	default:
		/* not reached */
		assert(0);
		return 0;
	}
	if (index >= 0 && index < majorsize) {
		lua_pushinteger(L, index + 1);
		x = wrapvector(L, minorsize, &X->values[(size_t)index * X->ld]);
		lua_pushvalue(L, 1);
		x->ref = luaL_ref(L, LUA_REGISTRYINDEX);
		return 2;
	}
	lua_pushnil(L);
	return 1;
}

/* matrix ipairs function */
static int matrix_ipairs (lua_State *L) {
	luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	lua_pushcfunction(L, matrix_next);
	lua_pushvalue(L, 1);
	lua_pushinteger(L, 0);
	return 3;
}

/* returns the string representation of a matrix */
static int matrix_tostring (lua_State *L) {
	struct matrix *X;

	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	lua_pushfstring(L, "matrix: %p", X);
	return 1;
}

/* frees a matrix */
static int matrix_free (lua_State *L) {
	struct matrix *X;

	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X->ref == LUA_NOREF) {
		free(X->values);
	} else {
		luaL_unref(L, LUA_REGISTRYINDEX, X->ref);
	}
	return 0;
}

/* returns the type of a linear object */
static int type (lua_State *L) {
	if (luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE) != NULL) {
		lua_pushliteral(L, "vector");
		return 1;
	}
	if (luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE) != NULL) {
		lua_pushliteral(L, "matrix");
		return 1;
	}
	lua_pushnil(L);
	return 1;
}

/* returns the size of a linear object */
static int size (lua_State *L) {
	struct vector *x;
	struct matrix *X;

	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		lua_pushinteger(L, x->size);
		return 1;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		lua_pushinteger(L, X->rows);
		lua_pushinteger(L, X->cols);
		lua_pushstring(L, ORDERS[X->order == CblasRowMajor ? 0 : 1]);
		return 3;
	}
	return argerror(L, 1);
}

/* transposed vector */
static int tvector (lua_State *L) {
	struct matrix *X;
	int index, size;
	struct vector *x;

	/* process arguments */
	X = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	index = luaL_checkinteger(L, 2);
	luaL_argcheck(L, index >= 1, 2, "bad index");
	switch (X->order) {
	case CblasRowMajor:
		luaL_argcheck(L, index <= X->cols, 2, "bad index");
		size = X->rows;
		break;

	case CblasColMajor:
		luaL_argcheck(L, index <= X->rows, 2, "bad index");
		size = X->cols;
		break;

	default:
		/* not reached */
		size = -1;
		assert(0);
	}

	/* create vector */
	x = wrapvector(L, size, &X->values[index - 1]);
	x->inc = X->ld;
	lua_pushvalue(L, 1);
	x->ref = luaL_ref(L, LUA_REGISTRYINDEX);
	return 1;
}

/* subvector or submatrix */
static int sub (lua_State *L) {
	struct vector *x, *s;
	struct matrix *X, *S;

	/* process arguments */
	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		int start, end;

		start = luaL_optinteger(L, 2, 1);
		luaL_argcheck(L, start >= 1 && start <= x->size, 2,
				"bad index");
		end = luaL_optinteger(L, 3, x->size);
		luaL_argcheck(L, end >= start && end <= x->size, 3,
				"bad index");
		s = wrapvector(L, end - start + 1, &x->values[
				(size_t)(start - 1) * x->inc]);
		s->inc = x->inc;
		lua_pushvalue(L, 1);
		s->ref = luaL_ref(L, LUA_REGISTRYINDEX);
		return 1;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		int rowstart, rowend, colstart, colend;

		switch (X->order){
		case CblasRowMajor:
			rowstart = luaL_optinteger(L, 2, 1);
			luaL_argcheck(L, rowstart >= 1 && rowstart <= X->rows,
					2, "bad index");
			colstart = luaL_optinteger(L, 3, 1);
			luaL_argcheck(L, colstart >= 1 && colstart <= X->cols,
					3, "bad index");
			rowend = luaL_optinteger(L, 4, X->rows);
			luaL_argcheck(L, rowend >= rowstart && rowend
					<= X->rows, 4, "bad index");
			colend = luaL_optinteger(L, 5, X->cols);
			luaL_argcheck(L, colend >= colstart && colend
					<= X->cols, 5, "bad index");
			S = wrapmatrix(L, rowend - rowstart + 1, colend
					- colstart + 1, X->order, &X->values[
					(size_t)(rowstart - 1) * X->ld
					+ colstart - 1]);
			break;

		case CblasColMajor:
			colstart = luaL_optinteger(L, 2, 1);
			luaL_argcheck(L, colstart >= 1 && colstart <= X->cols,
					2, "bad index");
			rowstart = luaL_optinteger(L, 3, 1);
			luaL_argcheck(L, rowstart >= 1 && rowstart <= X->rows,
					3, "bad index");
			colend = luaL_optinteger(L, 4, X->cols);
			luaL_argcheck(L, colend >= colstart && colend
					<= X->cols, 4, "bad index");
			rowend = luaL_optinteger(L, 5, X->rows);
			luaL_argcheck(L, rowend >= rowstart && rowend
					<= X->rows, 5, "bad index");
			S = wrapmatrix(L, rowend - rowstart + 1, colend
					- colstart + 1, X->order, &X->values[
					(size_t)(colstart - 1) * X->ld
					+ rowstart - 1]);
			break;

		default:
			/* not reached */
			assert(0);
			return 0;
		}
		S->ld = X->ld;
		lua_pushvalue(L, 1);
		S->ref = luaL_ref(L, LUA_REGISTRYINDEX);
		return 1;
	}
	return argerror(L, 1);
}

/* unwinds matrices into a vector */
static int unwind (lua_State *L) {
	struct vector *x;
	int index, i, j, k;
	size_t base;
	struct matrix *X;

	if (lua_gettop(L) == 0) {
		return luaL_error(L, "wrong number of arguments");
	}
	x = luaL_checkudata(L, lua_gettop(L), LUALINEAR_VECTOR_METATABLE);
	index = 1;
	i = 0;
	while (i < x->size) {
		X = luaL_checkudata(L, index, LUALINEAR_MATRIX_METATABLE);
		luaL_argcheck(L, X->rows * X->cols <= x->size - i, index,
				"matrix too large");
		switch (X->order) {
		case CblasRowMajor:
			for (j = 0; j < X->rows; j++) {
				base = (size_t)j * X->ld;
				for (k = 0; k < X->cols; k++) {
					x->values[(size_t)i * x->inc]
							= X->values[base + k];
					i++;
				}
			}
			break;

		case CblasColMajor:
			for (j = 0; j < X->cols; j++) {
				base = (size_t)j * X->ld;
				for (k = 0; k < X->rows; k++) {
					x->values[(size_t)i * x->inc]
							= X->values[base + k];
					i++;
				}
			}
			break;
		}
		index++;
	}
	return 0;
}

/* reshapes a vector into matrices */
static int reshape (lua_State *L) {
	struct vector *x;
	int index, i, j, k;
	size_t base;
	struct matrix *X;

	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	index = 2;
	i = 0;
	while (i < x->size) {
		X = luaL_checkudata(L, index, LUALINEAR_MATRIX_METATABLE);
		luaL_argcheck(L, X->rows * X->cols <= x->size - i, index,
				"matrix too large");
		switch (X->order) {
		case CblasRowMajor:
			for (j = 0; j < X->rows; j++) {
				base = (size_t)j * X->ld;
				for (k = 0; k < X->cols; k++) {
					X->values[base + k] = x->values[
							(size_t)i * x->inc];
					i++;
				}
			}
			break;

		case CblasColMajor:
			for (j = 0; j < X->cols; j++) {
				base = (size_t)j * X->ld;
				for (k = 0; k < X->rows; k++) {
					X->values[base + k] = x->values[
							(size_t)i * x->inc];
					i++;
				}
			}
			break;
		}
		index++;
	}
	return 0;
}

/* converts a vector or matrix to a table */
static int totable (lua_State *L) {
	struct vector *x;
	struct matrix *X;
	int i, j;
	const float *value;

	/* check and process arguments */
	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		lua_createtable(L, 0, 3);
		lua_pushliteral(L, "vector");
		lua_setfield(L, -2, "type");
		lua_pushinteger(L, x->size);
		lua_setfield(L, -2, "length");
		lua_createtable(L, x->size, 0);
		value = x->values;
		for (i = 0; i < x->size; i++) {
			lua_pushnumber(L, *value);
			lua_rawseti(L, -2, i + 1);
			value += x->inc;
		}
		lua_setfield(L, -2, "values");
		return 1;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		lua_createtable(L, 0, 5);
		lua_pushliteral(L, "matrix");
		lua_setfield(L, -2, "type");
		lua_pushinteger(L, X->rows);
		lua_setfield(L, -2, "rows");
		lua_pushinteger(L, X->cols);
		lua_setfield(L, -2, "cols");
		switch (X->order) {
		case CblasRowMajor:
			lua_pushliteral(L, "rowmajor");
			lua_setfield(L, -2, "order");
			lua_createtable(L, X->rows, 0);
			for (i = 0; i < X->rows; i++) {
				lua_createtable(L, X->cols, 0);
				value = &X->values[(size_t)i * X->ld];
				for (j = 0; j < X->cols; j++) {
					lua_pushnumber(L, *value++);
					lua_rawseti(L, -2, j + 1);
				}
				lua_rawseti(L, -2, i + 1);
			}
			lua_setfield(L, -2, "values");
			break;

		case CblasColMajor:
			lua_pushliteral(L, "colmajor");
			lua_setfield(L, -2, "order");
			lua_createtable(L, X->cols, 0);
			for (i = 0; i < X->cols; i++) {
				lua_createtable(L, X->rows, 0);
				value = &X->values[(size_t)i * X->ld];
				for (j = 0; j < X->rows; j++) {
					lua_pushnumber(L, *value++);
					lua_rawseti(L, -2, j + 1);
				}
				lua_rawseti(L, -2, i + 1);
			}
			lua_setfield(L, -2, "values");
			break;
		}
		return 1;
	}
	return argerror(L, 1);
}

/* converts a table to a vector or matrix */
static int tolinear (lua_State *L) {
	static const char *types[] = { "vector", "matrix", NULL };
	static const char *orders[] = { "rowmajor", "colmajor", NULL };
	struct vector *x;
	struct matrix *X;
	int size, rows, cols, major, minor;
	CBLAS_ORDER order;
	int i, j;
	int isnum;
	float *value;

	/* check arguments */
	luaL_checktype(L, 1, LUA_TTABLE);
	lua_settop(L, 1);

	/* handle types */
	switch (optionvalue(L, "type", NULL, types)) {
	case 0: /* vector */
		size = intvalue(L, "length", -1);
		if (size < 1) {
			return luaL_error(L, "bad field " LUA_QS, "length");
		}
		x = newvector(L, size);
		lua_getfield(L, 1, "values");
		if (lua_type(L, -1) != LUA_TTABLE) {
			return luaL_error(L, "bad field " LUA_QS, "values");
		}
		value = x->values;
		for (i = 0; i < size; i++) {
			lua_rawgeti(L, -1, i + 1);
			*value++ = lua_tonumberx(L, -1, &isnum);
			if (!isnum) {
				return luaL_error(L, "bad value at index %d",
						i + 1);
			}
			lua_pop(L, 1);
		}
		lua_pop(L, 1);
		return 1;

	case 1: /* matrix */
		rows = intvalue(L, "rows", -1);
		if (rows < 1) {
			return luaL_error(L, "bad field " LUA_QS, "rows");
		}
		cols = intvalue(L, "cols", -1);
		if (cols < 1) {
			return luaL_error(L, "bad field " LUA_QS, "cols");
		}
		switch (optionvalue(L, "order", NULL, orders)) {
		case 0:
			order = CblasRowMajor;
			major = rows;
			minor = cols;
			break;

		case 1:
			order = CblasColMajor;
			major = cols;
			minor = rows;
			break;

		default:
			/* not reched */
			assert(0);
			return 0;
		}
		X = newmatrix(L, rows, cols, order);
		lua_getfield(L, 1, "values");
		if (lua_type(L, -1) != LUA_TTABLE) {
			return luaL_error(L, "bad field " LUA_QS, "values");
		}
		for (i = 0; i < major; i++) {
			value = &X->values[i * X->ld];
			lua_rawgeti(L, -1, i + 1);
			if (lua_type(L, -1) != LUA_TTABLE) {
				return luaL_error(L, "bad value at index %d",
						i + 1);
			}
			for (j = 0; j < minor; j++) {
				lua_rawgeti(L, -1, j + 1);
				*value++ = lua_tonumberx(L, -1, &isnum);
				if (!isnum) {
					return luaL_error(L, "bad value at "
							"index (%d,%d)", i + 1,
							j + 1);
				}
				lua_pop(L, 1);
			}
			lua_pop(L, 1);
		}
		lua_pop(L, 1);
		return 1;
	}

	/* not reached */
	assert(0);
	return 0;
}

/* invokes the DOT subprogram (x' y) */
static int dot (lua_State *L) {
	struct vector *x, *y;
	float dot;

	/* check and process arguments */
	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	y = luaL_checkudata(L, 2, LUALINEAR_VECTOR_METATABLE);
	luaL_argcheck(L, y->size == x->size, 2, "dimension mismatch");

	/* invoke subprogram */
	dot = cblas_sdot(x->size, x->values, x->inc, y->values, y->inc);
	lua_pushnumber(L, dot);
	return 1;
}

/* invokes the NRM2 subprogram (||x||_2) */
static int nrm2 (lua_State *L) {
	struct vector *x;
	float nrm2;

	/* check and process arguments */
	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);

	/* invoke subprogram */
	nrm2 = cblas_snrm2(x->size, x->values, x->inc);
	lua_pushnumber(L, nrm2);
	return 1;
}

/* invokes the ASUM subprogram (sigma |x|) */
static int asum (lua_State *L) {
	struct vector *x;
	float asum;

	/* check and process arguments */
	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);

	/* invoke subprogram */
	asum = cblas_sasum(x->size, x->values, x->inc);
	lua_pushnumber(L, asum);
	return 1;
}

/* invokes the IAMAX subprogram (argmax |x|) */
static int iamax (lua_State *L) {
	struct vector *x;
	int iamax;

	/* check and process arguments */
	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);

	/* invoke subprogram */
	iamax = cblas_isamax(x->size, x->values, x->inc);
	lua_pushinteger(L, iamax + 1);
	return 1;
}

/* sum implementation */
static float _sum (const float *values, int size, int inc) {
	float sum;
	int i;

	sum = 0.0;
	#pragma omp parallel for private(i) schedule(auto) \
			 if(size >= LUALINEAR_OMP_MINSIZE) reduction(+:sum)
	for (i = 0; i < size; i++) {
		sum += values[(size_t)i * inc];
	}
	return sum;
}

/* sum implementation (sigma x_i) */
static int sum (lua_State *L) {
	struct vector *x, *y;
	struct matrix *X;
	int i;

	/* check and process arguments */
	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		lua_pushnumber(L, _sum(x->values, x->size, x->inc));
		return 1;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		y = luaL_checkudata(L, 2, LUALINEAR_VECTOR_METATABLE);
		switch (checktranspose(L, 3)) {
		case CblasNoTrans:
			switch (X->order) {
			case CblasRowMajor:
				luaL_argcheck(L, y->size == X->rows, 2,
						"dimension mismatch");
				for (i = 0; i < X->rows; i++) {
					y->values[(size_t)i * y->inc] = _sum(
							&X->values[(size_t)i
							* X->ld], X->cols, 1);
				}
				break;

			case CblasColMajor:
				luaL_argcheck(L, y->size == X->cols, 2,
						"dimension mismatch");
				for (i = 0; i < X->cols; i++) {
					y->values[(size_t)i * y->inc] = _sum(
							&X->values[(size_t)i
							* X->ld], X->rows, 1);
				}
				break;
			}
			break;

		case CblasTrans:
			switch (X->order) {
			case CblasRowMajor:
				luaL_argcheck(L, y->size == X->cols, 2,
						"dimension mismatch");
				for (i = 0; i < X->cols; i++) {
					y->values[(size_t)i * y->inc] = _sum(
							&X->values[(size_t)i],
							X->rows, X->ld);
				}
				break;

			case CblasColMajor:
				luaL_argcheck(L, y->size == X->rows, 2,
						"dimension mismatch");
				for (i = 0; i < X->rows; i++) {
					y->values[(size_t)i * y->inc] = _sum(
							&X->values[(size_t)i],
							X->cols, X->ld);
				}
				break;
			}
			break;

		default:
			/* not reached */
			assert(0);
			break;
		}
		return 0;
	}
	return argerror(L, 1);
}

/* xy function */
typedef void(*xyfunction)(int, float *, int, float *, int, float);

/* invokes an (x,y) subproram */
static int xy (lua_State *L, xyfunction s, int hasy, int hasalpha) {
	int index, i;
	float alpha;
	struct vector *x, *y;
	struct matrix *X, *Y;

	/* check and process arguments */
	index = 2;
	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		if (hasy) {
			y = luaL_testudata(L, 2, LUALINEAR_VECTOR_METATABLE);
			Y = luaL_testudata(L, 2, LUALINEAR_MATRIX_METATABLE);
			if (y == NULL && Y == NULL) {
				return argerror(L, 2);
			}
			index++;
		} else {
			y = x;
			Y = NULL;
		}
		if (hasalpha) {
			alpha = luaL_optnumber(L, index, 1.0);
			index++;
		} else {
			alpha = 0.0;
		}
		if (y != NULL) {
			/* invoke subprogram on vector-vector */
			luaL_argcheck(L, y->size == x->size, 2,
					"dimension mismatch");
			s(x->size, x->values, x->inc, y->values, y->inc, alpha);
			return 0;
		}

		/* invoke subprogram on vector-matrix */
		switch (checktranspose(L, index)) {
		case CblasNoTrans:
			switch (Y->order) {
			case CblasRowMajor:
				luaL_argcheck(L, 1, x->size == Y->cols,
						"dimension mismatch");
				for (i = 0; i < Y->rows; i++) {
					s(x->size, x->values, x->inc,
							&Y->values[(size_t)i
							* Y->ld], 1, alpha);
				}
				break;

			case CblasColMajor:
				luaL_argcheck(L, 1, x->size == Y->rows,
						"dimension mismatch");
				for (i = 0; i < Y->cols; i++) {
					s(x->size, x->values, x->inc,
							&Y->values[(size_t)i
							* Y->ld], 1, alpha);
				}
				break;
			}
			break;

		case CblasTrans:
			switch (Y->order) {
			case CblasRowMajor:
				luaL_argcheck(L, 1, x->size == Y->rows,
						"dimension mismatch");
				for (i = 0; i < Y->rows; i++) {
					s(x->size, x->values, x->inc,
							&Y->values[(size_t)i],
							Y->ld, alpha);
				}
				break;

			case CblasColMajor:
				luaL_argcheck(L, 1, x->size == Y->cols,
						"dimension mismatch");
				for (i = 0; i < Y->cols; i++) {
					s(x->size, x->values, x->inc,
							&Y->values[(size_t)i],
							Y->ld, alpha);
				}
				break;
			}
			break;

		default:
			/* not reached */
			assert(0);
		}
		return 0;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		if (hasy) {
			Y = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
			luaL_argcheck(L, X->order == Y->order, 2,
					"order mismatch");
			luaL_argcheck(L, X->rows == Y->rows && X->cols
					== Y->cols, 2, "dimension mismatch");
			index++;
		} else {
			Y = X;
		}
		if (hasalpha) {
			alpha = luaL_optnumber(L, index, 1.0);
			index++;
		} else {
			alpha = 0.0;
		}

		/* invoke subprogram on matrix-matrix */
		switch (X->order) {
		case CblasRowMajor:
			for (i = 0; i < X->rows; i++) {
				s(X->cols, &X->values[(size_t)i * X->ld], 1,
						&Y->values[(size_t)i * Y->ld],
						1, alpha);
			}
			break;

		case CblasColMajor:
			for (i = 0; i < X->cols; i++) {
				s(X->rows, &X->values[(size_t)i * X->ld], 1,
						&Y->values[(size_t)i * Y->ld],
						1, alpha);
			}
			break;
		}
		return 0;
	}
	return argerror(L, 1);
}

/* wraps the SWAP subprogram */
static void _swap (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	(void)alpha;
	cblas_sswap(size, x, incx, y, incy);
}

/* invokes the SWAP subprogram (y <-> x) */
static int swap (lua_State *L) {
	return xy(L, _swap, 1, 0);
}

/* wraps the COPY subprogram */
static void _copy (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	(void)alpha;
	cblas_scopy(size, x, incx, y, incy);
}

/* invokes the COPY subprogram (y <- x) */
static int copy (lua_State *L) {
	return xy(L, _copy, 1, 0);
}

/* wraps the AXPY subprogram */
static void _axpy (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	cblas_saxpy(size, alpha, x, incx, y, incy);
}

/* invokes the AXPY subprogram (y <- alpha x + y) */
static int axpy (lua_State *L) {
	return xy(L, _axpy, 1, 1);
}

/* wraps the SCAL subprogram */
static void _scal (int size, float *x, int incx, float *y, int incy,
			float alpha) {
	(void)y;
	(void)incy;
	cblas_sscal(size, alpha, x, incx);
}

/* invokes the SCAL subprogram (x <- alpha x) */
static int scal (lua_State *L) {
	return xy(L, _scal, 0, 1);
}

/* set operation implementation */
static void _set (int size, float *x, int incx, float *y, int incy,
			float alpha) {
	int i;

	(void)y;
	(void)incy;
	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		x[(size_t)i * incx] = alpha;
	}
}

/* performs a set operation (x <- alpha) */
static int set (lua_State *L) {
	return xy(L, _set, 0, 1);
}

/* uniform RNG implementation */
static void _uniform (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	int i;

	(void)y;
	(void)incy;
	(void)alpha;
	for (i = 0; i < size; i++) {
		*x = (float)random() * (1.0 / ((float)RAND_MAX + 1.0));
		x += incx;
	}
}

/* performs a uniform operation (x <- uniform) */
static int uniform (lua_State *L) {
	return xy(L, _uniform, 0, 0);
}

/* normal RNG implementation */
static void _normal (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	int i;
	float u1, u2, r, s, c;

	(void)y;
	(void)incy;
	(void)alpha;
	for (i = 0; i < size - 1; i += 2) {
		do {
			u1 = (float)random() * (1.0 / (float)RAND_MAX);
			u2 = (float)random() * (1.0 / (float)RAND_MAX);
		} while (u1 <= -DBL_MAX);
		r = sqrt(-2.0 * logf(u1));
		sincosf(2 * M_PI * u2, &s, &c);
		*x = r * c;
		x += incx;
		*x = r * s;
		x += incx;
	}
	if (i < size) {
		do {
			u1 = (float)random() * (1.0 / (float)RAND_MAX);
			u2 = (float)random() * (1.0 / (float)RAND_MAX);
		} while (u1 <= -DBL_MAX);
		*x = sqrtf(-2.0 * logf(u1)) * cosf(2 * M_PI * u2);
		x += incx;
	}
}

/* performs a normal operation (x <- normal) */
static int normal (lua_State *L) {
	return xy(L, _normal, 0, 0);
}

/* inc operation implementation */
static void _inc (int size, float *x, int incx, float *y, int incy,
			float alpha) {
	int i;

	(void)y;
	(void)incy;
	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		x[(size_t)i * incx] += alpha;
	}
}

/* performs a inc operation (x <- x + alpha) */
static int inc (lua_State *L) {
	return xy(L, _inc, 0, 1);
}

/* element-wise multiplication implementation, alpha = 1 */
static void _mul1 (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	int i;

	(void)alpha;
	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		y[(size_t)i * incy] *= x[(size_t)i * incx];
	}
}

/* element-wise multiplication implementation, alpha = -1 */
static void _mulm1 (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	int i;

	(void)alpha;
	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		y[(size_t)i * incy] /= x[(size_t)i * incx];
	}
}

/* element-wise multiplication implementation, alpha = any */
static void _mul (int size, float *x, int incx, float *y, int incy,
		float alpha) {
	int i;

	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		y[(size_t)i * incy] *= pow(x[(size_t)i * incx], alpha);
	}
}

/* performs element-wise multiplication (y <- x^alpha .* y) */
static int mul (lua_State *L) {
	float alpha;

	alpha = luaL_optnumber(L, 3, 1.0);
	if (alpha == 1.0) {
		return xy(L, _mul1, 1, 1);
	}
	if (alpha == -1.0) {
		return xy(L, _mulm1, 1, 1);
	}
	return xy(L, _mul, 1, 1);
}

/* power raising operation implementation */
static void _pow (int size, float *x, int incx, float *y, int incy,
			float alpha) {
	int i;

	(void)y;
	(void)incy;
	#pragma omp parallel for private(i) schedule(auto) \
			if(size >= LUALINEAR_OMP_MINSIZE)
	for (i = 0; i < size; i++) {
		x[(size_t)i * incx] = pow(x[(size_t)i * incx], alpha);
	}
}

/* performs element-wise power raising (x <- x^alpha) */
static int powx (lua_State *L) {
	return xy(L, _pow, 0, 1);
}

/* apply function */
typedef float(*applyfunction)(float);

/* applies a function to a value */
static int apply (lua_State *L, applyfunction apply, int parallel) {
	struct vector *x;
	struct matrix *X;
	int i, j;
	size_t base;

	if (lua_type(L, 1) == LUA_TNUMBER) {
		lua_pushnumber(L, apply(lua_tonumber(L, 1)));
		return 1;
	}
	x = luaL_testudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	if (x != NULL) {
		#pragma omp parallel for private(i) schedule(auto) \
				if(parallel && x->size >= LUALINEAR_OMP_MINSIZE)
		for (i = 0; i < x->size; i++) {
			x->values[(size_t)i * x->inc] =
					apply(x->values[(size_t)i
					* x->inc]);
		}
		return 0;
	}
	X = luaL_testudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	if (X != NULL) {
		switch (X->order) {
		case CblasRowMajor:
			for (i = 0; i < X->rows; i++) {
				base = (size_t)i * X->ld;
				#pragma omp parallel for private(j) \
						schedule(auto) \
						if(parallel && X->cols \
						>= LUALINEAR_OMP_MINSIZE)
				for (j = 0; j < X->cols; j++) {
					X->values[base + j] = apply(
							X->values[base
							+ j]);
				}
			}
			break;

		case CblasColMajor:
			for (i = 0; i < X->cols; i++) {
				base = (size_t)i * X->ld;
				#pragma omp parallel for private(j) \
						schedule(auto) \
						if(parallel && X->rows \
						>= LUALINEAR_OMP_MINSIZE)
				for (j = 0; j < X->rows; j++) {
					X->values[base + j] = apply(
							X->values[base
							+ j]);
				}
			}
			break;
		}
		return 0;
	}
	return luaL_argerror(L, 1, lua_pushfstring(L, "number, vector, or "
			"matrix expected, got %s", luaL_typename(L, 1)));

}

/* sign function implementation */
static float _sign (float x) {
	if (x > 0) {
		return 1;
	}
	if (x < 0) {
		return -1;
	}
	return x;
}

/* sign function */
static int sign (lua_State *L) {
	return apply(L, _sign, 1);
}

/* abs function implementation */
static float _abs (float x) {
	return fabs(x);
}

/* abs function */
static int absx (lua_State *L) {
	return apply(L, _abs, 1);
}

/* exp function */
static int expx (lua_State *L) {
	return apply(L, expf, 1);
}

/* log function */
static int logx (lua_State *L) {
	return apply(L, logf, 1);
}

/* logistic function implementation */
static float _logistic (float z) {
	return 1.0 / (1.0 + expf(-z));
}

/* logistic function */
static int logistic (lua_State *L) {
	return apply(L, _logistic, 1);
}

/* tanh function */
static int tanhx (lua_State *L) {
	return apply(L, tanhf, 1);
}

/* softplus function implementation */
static float _softplus (float x) {
	return logf(1 + expf(x));
}

/* softplus function */
static int softplus (lua_State *L) {
	return apply(L, _softplus, 1);
}

/* rectifier function implementation */
static float _rectifier (float x) {
	return x > 0.0 ? x : 0.0;
}

/* rectifier function */
static int rectifier (lua_State *L) {
	return apply(L, _rectifier, 1);
}

/* current Lua state */
static __thread lua_State *TL;

/* apply function implementation */
static float _apply (float x) {
	float result;

	lua_pushvalue(TL, -1);
	lua_pushnumber(TL, x);
	lua_call(TL, 1, 1);
	result = lua_tonumber(TL, -1);
	lua_pop(TL, 1);
	return result;
}

/* apply function */
static int applyx (lua_State *L) {
	luaL_checktype(L, 2, LUA_TFUNCTION);
	lua_settop(L, 2);
	TL = L;
	return apply(L, _apply, 0);
}

/* invokes the GEMV subprogram (y <- alpha A x + b y) */
static int gemv (lua_State *L) {
	struct matrix *A;
	struct vector *x, *y;
	float alpha, beta;
	CBLAS_TRANSPOSE ta;
	int m, n;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	x = luaL_checkudata(L, 2, LUALINEAR_VECTOR_METATABLE);
	y = luaL_checkudata(L, 3, LUALINEAR_VECTOR_METATABLE);
	alpha = luaL_optnumber(L, 4, 1.0);
	beta = luaL_optnumber(L, 5, 0.0);
	ta = checktranspose(L, 6);
	m = ta == CblasNoTrans ? A->rows : A->cols;
	n = ta == CblasNoTrans ? A->cols : A->rows;
	luaL_argcheck(L, x->size == n, 2, "dimension mismatch");
	luaL_argcheck(L, y->size == m, 3, "dimension mismatch");

	/* invoke subprogram */
	cblas_sgemv(A->order, ta, A->rows, A->cols, alpha, A->values, A->ld,
			x->values, x->inc, beta, y->values, y->inc);
	return 0;
}

/* invokes the GER subprogram (A <- alpha x y' + A) */
static int ger (lua_State *L) {
	struct vector *x, *y;
	struct matrix *A;
	float alpha;

	/* check and process arguments */
	x = luaL_checkudata(L, 1, LUALINEAR_VECTOR_METATABLE);
	y = luaL_checkudata(L, 2, LUALINEAR_VECTOR_METATABLE);
	A = luaL_checkudata(L, 3, LUALINEAR_MATRIX_METATABLE);
	alpha = luaL_optnumber(L, 4, 1.0);
	luaL_argcheck(L, x->size == A->rows, 1, "dimension mismatch");
	luaL_argcheck(L, y->size == A->cols, 2, "dimension mismatch");

	/* invoke subprogram */
	cblas_sger(A->order, A->rows, A->cols, alpha, x->values, x->inc,
			y->values, y->inc, A->values, A->ld);
	return 0;
}

/* invokes the GEMM subprogram (C <- alpha A B + beta C) */
static int gemm (lua_State *L) {
	struct matrix *A, *B, *C;
	float alpha, beta;
	CBLAS_TRANSPOSE ta, tb;
	int m, n, ka, kb;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	B = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, B->order == A->order, 2, "order mismatch");
	C = luaL_checkudata(L, 3, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, C->order == A->order, 3, "order mismatch");
	alpha = luaL_optnumber(L, 4, 1.0);
	beta = luaL_optnumber(L, 5, 0.0);
	ta = checktranspose(L, 6);
	tb = checktranspose(L, 7);
	m = ta == CblasNoTrans ? A->rows : A->cols;
	n = tb == CblasNoTrans ? B->cols : B->rows;
	ka = ta == CblasNoTrans ? A->cols : A->rows;
	kb = tb == CblasNoTrans ? B->rows : B->cols;
	luaL_argcheck(L, ka == kb, 2, "dimension mismatch");

	/* invoke subprogramm */
	cblas_sgemm(A->order, ta, tb, m, n, ka, alpha, A->values, A->ld,
			B->values, B->ld, beta, C->values, C->ld);
	return 0;
}

/* invokes the GESV subprogram */
static int gesv (lua_State *L) {
	struct matrix *A, *B;
	int *ipiv, result;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, A->rows == A->cols, 1, "not square");
	B = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, B->order == A->order, 2, "order mismatch");
	luaL_argcheck(L, B->rows == A->rows, 2, "dimension mismatch");

	/* invoke subprogramm */
	ipiv = calloc(A->rows, sizeof(lapack_int));
	if (ipiv == NULL) {
		return luaL_error(L, "cannot allocate indexes");
	}
	result = LAPACKE_sgesv(A->order, A->rows, B->cols, A->values, A->ld,
			ipiv, B->values, B->ld);
	free(ipiv);
	lua_pushinteger(L, result);
	return 1;
}

/* invokes the GELS subprogram */
static int gels (lua_State *L) {
	struct matrix *A, *B;
	char ta;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	B = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, B->order == A->order, 2, "order mismatch");
	ta = lapacktranspose(checktranspose(L, 3));
	luaL_argcheck(L, B->rows == (A->rows >= A->cols ? A->rows : A->cols), 2,
			"dimension mismatch");

	/* invoke subprogramm */
	lua_pushinteger(L, LAPACKE_sgels(A->order, ta, A->rows, A->cols,
			B->cols, A->values, A->ld, B->values, B->ld));
	return 1;
}

/* calculates the inverse of a matrix */
static int inv (lua_State *L) {
	struct matrix *A;
	int *ipiv, result;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, A->rows == A->cols, 1, "not square");

	/* invoke subprograms */
	ipiv = calloc(A->rows, sizeof(lapack_int));
	if (ipiv == NULL) {
		return luaL_error(L, "cannot allocate indexes");
	}
	result = LAPACKE_sgetrf(A->order, A->rows, A->cols, A->values, A->ld,
			ipiv);
	if (result != 0) {
		free(ipiv);
		lua_pushinteger(L, result);
		return 1;
	}
	result = LAPACKE_sgetri(A->order, A->rows, A->values, A->ld, ipiv);
	free(ipiv);
	lua_pushinteger(L, result);
	return 1;
}

/* calculates the determinant of a matrix */
static int det (lua_State *L) {
	struct matrix *A;
	float *copy, *d, *s, det;
	int n, *ipiv, result, neg, i;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, A->rows == A->cols, 1, "not square");
	n = A->rows;

	/* copy matrix */
	copy = calloc((size_t)n * n, sizeof(float));
	if (copy == NULL) {
		return luaL_error(L, "cannot allocate values");
	}
	d = copy;
	s = A->values;
	for (i = 0; i < n; i++) {
		memcpy(d, s, (size_t)n * sizeof(float));
		d += n;
		s += A->ld;
	}

	/* invoke subprograms */
	ipiv = calloc(n, sizeof(lapack_int));
	if (ipiv == NULL) {
		free(copy);
		return luaL_error(L, "cannot allocate indexes");
	}
	result = LAPACKE_sgetrf(A->order, n, n, copy, n, ipiv);
	if (result != 0) {
		free(copy);
		free(ipiv);
		lua_pushnumber(L, 0.0);
		return 1;
	}

	/* calculate determinant */
	det = 1.0;
	neg = 0;
	for (i = 0; i < n; i++) {
		det *= copy[(size_t)i * n + i];
		if (ipiv[i] != i + 1) {
			neg = !neg;
		}
	}
	free(copy);
	free(ipiv);
	lua_pushnumber(L, neg ? -det : det);
	return 1;
}

/* calculates the covariance of a matrix */
static int cov (lua_State *L) {
	struct matrix *A, *B;
	int ddof, i, j, k;
	float *means, *v, *vi, *vj, sum;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	B = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, A->cols == B->rows, 2, "dimension mismatch");
	luaL_argcheck(L, B->rows == B->cols, 2, "not square");
	ddof = luaL_optinteger(L, 3, 0);
	luaL_argcheck(L, ddof >= 0 && ddof < A->rows, 3, "bad ddof");

	/* calculate means */
	means = calloc((size_t)A->cols, sizeof(float));
	if (means == NULL) {
		return luaL_error(L, "cannot allocate values");
	}
	switch (A->order) {
	case CblasRowMajor:
		#pragma omp parallel for private(i, j, sum, v) schedule(auto) \
				if(A->rows * A->cols >= LUALINEAR_OMP_MINSIZE)
		for (i = 0; i < A->cols; i++) {
			sum = 0.0;
			v = &A->values[i];
			for (j = 0; j < A->rows; j++) {
				sum += *v;
				v += A->ld;
			}
			means[i] = sum / A->rows;
		}
		break;

	case CblasColMajor:
		#pragma omp parallel for private(i, j, sum, v) schedule(auto) \
				if(A->rows * A->cols >= LUALINEAR_OMP_MINSIZE)
		for (i = 0; i < A->cols; i++) {
			sum = 0.0;
			v = &A->values[(size_t)i * A->ld];
			for (j = 0; j < A->rows; j++) {
				sum += *v;
				v++;
			}
			means[i] = sum / A->rows;
		}
		break;
	}

	/* calculate covariance */
	switch (A->order) {
	case CblasRowMajor:
		for (i = 0; i < A->cols; i++) {
			#pragma omp parallel for private(j, k, sum, vi, vj) \
					schedule(auto) if(A->rows * (A->cols \
					- i) >= LUALINEAR_OMP_MINSIZE)
			for (j = i; j < A->cols; j++) {
				sum = 0.0;
				vi = &A->values[i];
				vj = &A->values[j];
				for (k = 0; k < A->rows; k++) {
					sum += (*vi - means[i])
							* (*vj - means[j]);
					vi += A->ld;
					vj += A->ld;
				}
				B->values[(size_t)i * B->ld + j] = B->values[
						(size_t)j * B->ld + i]
						= sum / (A->rows - ddof);
			}
		}
		break;

	case CblasColMajor:
		for (i = 0; i < A->cols; i++) {
			#pragma omp parallel for private(j, k, sum, vi, vj) \
					schedule(auto) if(A->rows * (A->cols \
					- i) >= LUALINEAR_OMP_MINSIZE)
			for (j = i; j < A->cols; j++) {
				sum = 0.0;
				vi = &A->values[(size_t)i * A->ld];
				vj = &A->values[(size_t)j * A->ld];
				for (k = 0; k < A->rows; k++) {
					sum += (*vi - means[i])
							* (*vj - means[j]);
					vi++;
					vj++;
				}
				B->values[(size_t)i * B->ld + j] = B->values[
						(size_t)j * B->ld + i]
						= sum / (A->rows - ddof);
			}
		}
		break;
	}
	free(means);
	return 0;
}

/* calculates the correlation of a matrix */
static int corr (lua_State *L) {
	struct matrix *A, *B;
	int i, j, k;
	float *means, *stds, *v, *vi, *vj, sum;

	/* check and process arguments */
	A = luaL_checkudata(L, 1, LUALINEAR_MATRIX_METATABLE);
	B = luaL_checkudata(L, 2, LUALINEAR_MATRIX_METATABLE);
	luaL_argcheck(L, A->cols == B->rows, 2, "dimension mismatch");
	luaL_argcheck(L, B->rows == B->cols, 2, "not square");

	/* calculate means and stds */
	means = calloc((size_t)A->cols, sizeof(float));
	if (means == NULL) {
		return luaL_error(L, "cannot allocate values");
	}
	stds = calloc((size_t)A->cols, sizeof(float));
	if (stds == NULL) {
		free(means);
		return luaL_error(L, "cannot allocate values");
	}
	switch (A->order) {
	case CblasRowMajor:
		#pragma omp parallel for private(i, j, sum, v) schedule(auto) \
				if(A->rows * A->cols >= LUALINEAR_OMP_MINSIZE)
		for (i = 0; i < A->cols; i++) {
			sum = 0.0;
			v = &A->values[i];
			for (j = 0; j < A->rows; j++) {
				sum += *v;
				v += A->ld;
			}
			means[i] = sum / A->rows;
			sum = 0.0;
			v = &A->values[i];
			for (j = 0; j < A->rows; j++) {
				sum += (*v - means[i]) * (*v - means[i]);
				v += A->ld;
			}
			stds[i] = sqrt(sum);
		}
		break;

	case CblasColMajor:
		#pragma omp parallel for private(i, j, sum, v) schedule(auto) \
				if(A->rows * A->cols >= LUALINEAR_OMP_MINSIZE)
		for (i = 0; i < A->cols; i++) {
			sum = 0.0;
			v = &A->values[(size_t)i * A->ld];
			for (j = 0; j < A->rows; j++) {
				sum += *v;
				v++;
			}
			means[i] = sum / A->rows;
			sum = 0.0;
			v = &A->values[(size_t)i * A->ld];
			for (j = 0; j < A->rows; j++) {
				sum += (*v - means[i]) * (*v - means[i]);
				v++;
			}
			stds[i] = sqrt(sum);
		}
		break;
	}

	/* calculate correlation */
	switch (A->order) {
	case CblasRowMajor:
		for (i = 0; i < A->cols; i++) {
			#pragma omp parallel for private(j, k, sum, vi, vj) \
					schedule(auto) if(A->rows * (A->cols \
					- i) >= LUALINEAR_OMP_MINSIZE)
			for (j = i; j < A->cols; j++) {
				sum = 0.0;
				vi = &A->values[i];
				vj = &A->values[j];
				for (k = 0; k < A->rows; k++) {
					sum += (*vi - means[i])
							* (*vj - means[j]);
					vi += A->ld;
					vj += A->ld;
				}
				B->values[(size_t)i * B->ld + j] = B->values[
						(size_t)j * B->ld + i]
						= sum / (stds[i] * stds[j]);
			}
		}
		break;

	case CblasColMajor:
		for (i = 0; i < A->cols; i++) {
			#pragma omp parallel for private(j, k, sum, vi, vj) \
					schedule(auto) if(A->rows * (A->cols \
					- i) >= LUALINEAR_OMP_MINSIZE)
			for (j = i; j < A->cols; j++) {
				sum = 0.0;
				vi = &A->values[(size_t)i * A->ld];
				vj = &A->values[(size_t)j * A->ld];
				for (k = 0; k < A->rows; k++) {
					sum += (*vi - means[i])
							* (*vj - means[j]);
					vi++;
					vj++;
				}
				B->values[(size_t)i * B->ld + j] = B->values[
						(size_t)j * B->ld + i]
						= sum / (stds[i] * stds[j]);
			}
		}
		break;
	}
	free(means);
	free(stds);
	return 0;
}

/*
 * Exported functions.
 */

int luaopen_linear (lua_State *L) {
	static const luaL_Reg FUNCTIONS[] = {
		{ "vector", vector },
		{ "matrix", matrix },
		{ "type", type },
		{ "size", size },
		{ "tvector", tvector },
		{ "sub", sub },
		{ "unwind", unwind },
		{ "reshape", reshape },
		{ "totable", totable },
		{ "tolinear", tolinear },
		{ "dot", dot },
		{ "nrm2", nrm2 },
		{ "asum", asum },
		{ "iamax", iamax },
		{ "sum", sum },
		{ "swap", swap },
		{ "copy", copy },
		{ "axpy", axpy },
		{ "scal", scal },
		{ "set", set },
		{ "uniform", uniform },
		{ "normal", normal },
		{ "inc", inc },
		{ "mul", mul },
		{ "pow", powx },
		{ "sign", sign },
		{ "abs", absx },
		{ "exp", expx },
		{ "log", logx },
		{ "logistic", logistic },
		{ "tanh", tanhx },
		{ "softplus", softplus },
		{ "rectifier", rectifier },
		{ "apply", applyx },
		{ "gemv", gemv },
		{ "ger", ger },
		{ "gemm", gemm },
		{ "gesv", gesv },
		{ "gels", gels },
		{ "inv", inv },
		{ "det", det },
		{ "cov", cov },
		{ "corr", corr },
		{ NULL, NULL }
	};

	/* register functions */
	#if LUA_VERSION_NUM >= 502
	luaL_newlib(L, FUNCTIONS);
	#else
	luaL_register(L, luaL_checkstring(L, 1), FUNCTIONS);
	#endif

	/* vector metatable */
	luaL_newmetatable(L, LUALINEAR_VECTOR_METATABLE);
	lua_pushcfunction(L, vector_len);
	lua_setfield(L, -2, "__len");
	lua_pushcfunction(L, vector_index);
	lua_setfield(L, -2, "__index");
	lua_pushcfunction(L, vector_newindex);
	lua_setfield(L, -2, "__newindex");
	lua_pushcfunction(L, vector_ipairs);
	lua_setfield(L, -2, "__ipairs");
	lua_pushcfunction(L, vector_tostring);
	lua_setfield(L, -2, "__tostring");
	lua_pushcfunction(L, vector_free);
	lua_setfield(L, -2, "__gc");
	lua_pop(L, 1);

	/* matrix metatable */
	luaL_newmetatable(L, LUALINEAR_MATRIX_METATABLE);
	lua_pushcfunction(L, matrix_len);
	lua_setfield(L, -2, "__len");
	lua_pushcfunction(L, matrix_index);
	lua_setfield(L, -2, "__index");
	lua_pushcfunction(L, matrix_ipairs);
	lua_setfield(L, -2, "__ipairs");
	lua_pushcfunction(L, matrix_tostring);
	lua_setfield(L, -2, "__tostring");
	lua_pushcfunction(L, matrix_free);
	lua_setfield(L, -2, "__gc");
	lua_pop(L, 1);

	return 1;
}


/**
 */
#include <math.h>
#include "fitsio.h"
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_interp.h>
#include "spc_cfg.h"
#include "aXe_utils.h"
#include "aXe_errors.h"
#include "fringe_conf.h"

#define AXE_CONFIG_PATH "AXE_CONFIG_PATH"

/**
 * Function: load_CCD_layer
 * The function creates and returns a structure for an optical
 * CCD layer. The input parameters are interpreted, and
 * the data which defines the CCD layer is loaded.
 *
 * Parameters:
 * @param refr_table - the name of the refractive index table
 * @param thickness  - the value for the thicknes keyword
                       (number or image name)
 *
 * Returns:
 * @return opt_layer  - the optical layer created
 */
ccd_layer *
load_CCD_layer(const char refr_table[], const char thickness[])
{
  ccd_layer *opt_layer;

  float tvalue;

  char **t_err=NULL;

  char refr_table_path[MAXCHAR];
  char thickness_path[MAXCHAR];

  // build the full pathname to the refraction table
  build_path (AXE_CONFIG_PATH, refr_table, refr_table_path);

  // allocate an error array
  t_err = (char **) malloc(sizeof(char *)*1);

  // allocate space for the return structure;
  // complain if this fails
  opt_layer = (ccd_layer *)malloc(sizeof(ccd_layer));

  // initialize both, the single value
  // as well as the matrix to NULL;
  opt_layer->thickness   = 0.0;
  opt_layer->thickness2D = NULL;

  // convert the keyvalue to a float
  // tvalue = atof(thickness);
  tvalue = strtod(thickness,t_err);

  // in case the float value is NULL = 0.0
  // the conversion failed, and it must be a string
  //  if (tvalue)
  if (strcmp(thickness, t_err[0]))
    {
#ifdef DEBUGFCONF
      fprintf(stderr, "Setting the layer thickness to value: %f mum\n",tvalue);
#endif
      // set the fixed thickness value
      opt_layer->thickness = tvalue;
    }
  else
    {
#ifdef DEBUGFCONF
      fprintf(stderr, "Loading layer thickness image: %s\n", thickness);
#endif

      // build the full pathname to the thickness image
      build_path (AXE_CONFIG_PATH, thickness, thickness_path);

      // load the 2D image for the thickness
      opt_layer->thickness2D = FITSimage_to_gsl(thickness_path, 1, 1);
    }

#ifdef DEBUGFCONF
      fprintf(stderr, "Loading refractive index table: %s\n", refr_table);
#endif
  // load the real part of the refraction index
  opt_layer->re_refraction =
    create_interp_ftable(refr_table_path, 2, "WAVELENGTH", "N",
			 REFRAC_INTERP_TYPE);

  // load the real part of the refraction index
  opt_layer->im_refraction =
    create_interp_ftable(refr_table_path, 2, "WAVELENGTH", "K",
			 REFRAC_INTERP_TYPE);

  // return the optical layer
  return opt_layer;
}

/**
 * Function: free_CCD_layer
 * The function releases all the memory allocated
 * in a structure for a CCD layer.
 *
 * Parameters:
 * @param opt_layer - structure for CCD layer
 *
 * Returns:
 * @return -
 */
void
free_CCD_layer(ccd_layer *opt_layer)
{
  // free the thickness matrix
  if (opt_layer->thickness2D)
    gsl_matrix_free(opt_layer->thickness2D);

  // free both interpolators
  free_interp(opt_layer->re_refraction);
  free_interp(opt_layer->im_refraction);

  // free the rest
  free(opt_layer);

  // set the structure to NULL
  opt_layer = NULL;
}

/**
 * Function: load_CCD_layers
 * The function extracts from a fringe configuration file
 * all information on individual CCD layers. It creates
 * the appropriate structure for every CCD layer,
 * and creates and returns a structure which completely
 * describes all layers in a CCD.
 *
 * Parameters:
 * @param fring_conf_path - the name of a fringe configuration file
 *
 * Returns:
 * @return opt_layers - the structure for the optical layers created
 */
ccd_layers *
load_CCD_layers(char fring_conf_path[])
{
  ccd_layers *opt_layers;

  char layer[MAXCHAR];
  char refr_table[MAXCHAR];

  //int nlayers;
  int i=0;

  struct CfgStrings LayerConfig[] = {
    {NULL, NULL},
    {NULL, NULL}
  };

  LayerConfig[0].name = layer;

  // allocate space for the return structure;
  // complain if this fails
  opt_layers = malloc (sizeof (ccd_layers));

  // initialize the substrate
  opt_layers->substrate = NULL;

  // detemrine the number of layers
  // which are described in the
  //configuration file
  opt_layers->num_layers = 0;
  for (i = 0; i < MAX_BEAMS; i++)
    {
      sprintf (layer, "REFR_INDEX_%c", BEAM (i));
      CfgRead (fring_conf_path, LayerConfig);
      if (LayerConfig[0].data != NULL)
	{
	  opt_layers->num_layers += 1;
	  LayerConfig[0].data = NULL;
	}
    }

  //  if (opt_layers->num_layers < NLAYERS_MIN)
  //    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
  //		 "The number of layers in the configuration\n file is %i. "
  //		 "There must be at least: %i!\n",
  //		 opt_layers->num_layers, NLAYERS_MIN);

  // allocate space for the array to
  // the layers described in the
  // configuration file
  opt_layers->opt_layer =
    (ccd_layer **)malloc (opt_layers->num_layers*sizeof(ccd_layers));

  // successively find the
  // description and finally
  // load all layers
  for (i = 0; i < MAX_BEAMS; i++)
    {
      // chekc for the first relevant keyword
      sprintf (layer, "REFR_INDEX_%c", BEAM (i));
      CfgRead (fring_conf_path, LayerConfig);
      if (LayerConfig[0].data != NULL)
	{
	  sprintf (refr_table, "%s", LayerConfig[0].data);
	  LayerConfig[0].data = NULL;

	  // check for the second relevant keyword
	  sprintf (layer, "THICKNESS_%c", BEAM (i));
	  CfgRead (fring_conf_path, LayerConfig);
	  if (LayerConfig[0].data != NULL)
	    {
	      // load the layer
	      opt_layers->opt_layer[i] =
		load_CCD_layer(refr_table, LayerConfig[0].data);

	      LayerConfig[0].data = NULL;
	    }
	  else
	    {
	      // complain that a keyword is missing
	      // for a layer
	      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
			   "Could load index table %s,\n"
			   "but not thickness information "
			   "for beam %c\n", refr_table, BEAM (i));
	    }
	}
    }

  // return the whole structure
  return opt_layers;
}

/**
 * Function: free_CCD_layers
 * The function releases all memory allocated in a
 * CCD layers structure.
 *
 * Parameters:
 * @param opt_layers - the CCD layers structure
 *
 * Returns:
 * @return -
 */
void
free_CCD_layers(ccd_layers *opt_layers)
{
  int index=0;

  // free each layer individually
  for (index=0; index < opt_layers->num_layers; index++)
      free_CCD_layer(opt_layers->opt_layer[index]);

  // free the interpolator for the substrate
  //  free_linint(opt_layers->substrate);
  free_interp(opt_layers->substrate);

  // free everything
  free(opt_layers);

  // set the structure to NULL
  opt_layers = NULL;
}

/**
 * Function: load_fringe_conf
 * The function loads the fringe configuration file given as parameter.
 * All relevant data marked with keywords is extracted. A fringe
 * configuration structure is built up and returned from the
 * data given in the keyvalues.
 *
 * Parameters:
 * @param fring_conf_path - the complete path-name to a fringe configuration file
 *
 * Returns:
 * @return fconf - the fringe configuration structure created
 */
fringe_conf *
load_fringe_conf(char fring_conf_path[])
{
  char beam[MAXCHAR];

  char ffile_name[MAXCHAR];
  char ffile_name_path[MAXCHAR];

  int index=0;

  fringe_conf *fconf=NULL;

  gsl_vector *v=NULL;

  struct CfgStrings FringeConfig[] =
    {
      {"FRINGE_AMPLITUDE", NULL},
      {"FRINGE_PHASE", NULL},
      {"FRINGE_RANGE", NULL},
      {"MAX_DISPERSION", NULL},
      {"FILTER_NAME", NULL},
      {"FRINGE_STEP",NULL},
      {"NUM_STEPS",NULL},
      {"SUBSTR_TRANS",NULL},

      {NULL, NULL},
      {NULL, NULL}		/* array terminator. REQUIRED !!! */
    };

  FringeConfig[8].name = beam;

  // allocate space for the return structure;
  // complain if this fails
  fconf = malloc (sizeof (fringe_conf));
  if (fconf == NULL)
    {
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "Could not allocate memory for fringe configuration");
    }

  // load the optical layers directly from the file
  fconf->opt_layers = load_CCD_layers(fring_conf_path);

  // read in the file
  CfgRead (fring_conf_path, FringeConfig);

  // make some intitializations
  fconf->fringe_amp     = 0.0;
  fconf->fringe_phase   = 1.0e+32;
  fconf->fringe_step    = 0.0;
  fconf->num_steps      = 0;
  fconf->fringe_range   = NULL;
  fconf->max_dispersion = 0.0;
  fconf->filter_through = NULL;

  for (index = 0; index < 9; index++)
    {

      // read in the fringe amplitude
      if (!strcmp (FringeConfig[index].name, "FRINGE_AMPLITUDE"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      fconf->fringe_amp = atof(FringeConfig[index].data);
	    }
	}

      // read in the fringe phase
      if (!strcmp (FringeConfig[index].name, "FRINGE_PHASE"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      fconf->fringe_phase = atof(FringeConfig[index].data);
	    }
	}

      // read in the fringe step
      if (!strcmp (FringeConfig[index].name, "FRINGE_STEP"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      fconf->fringe_step = atof(FringeConfig[index].data);
	    }
	}

      // read in the number of steps
      if (!strcmp (FringeConfig[index].name, "NUM_STEPS"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      fconf->num_steps = atoi(FringeConfig[index].data);
	    }
	}

      // read in the fringe range
      if (!strcmp (FringeConfig[index].name, "FRINGE_RANGE"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      v = string_to_gsl_array (FringeConfig[index].data);
	      fconf->fringe_range = v;
	    }
	}

      // read in the fringe amplitude
      if (!strcmp (FringeConfig[index].name, "MAX_DISPERSION"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      fconf->max_dispersion = atof(FringeConfig[index].data);
	    }
	}

      // read in the filter name
      if (!strcmp (FringeConfig[index].name, "FILTER_NAME"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      sprintf (ffile_name, "%s", FringeConfig[index].data);

	      // build the full pathname to the refraction table
	      build_path (AXE_CONFIG_PATH, ffile_name, ffile_name_path);

	      fconf->filter_through =
		create_interp_ftable(ffile_name_path, 2, "WAVELENGTH",
				     "THROUGHPUT", FILTER_INTERP_TYPE);
	    }
	}

      // read in the substrate transmission
      if (!strcmp (FringeConfig[index].name, "SUBSTR_TRANS"))
	{
	  if (FringeConfig[index].data != NULL)
	    {
	      sprintf (ffile_name, "%s", FringeConfig[index].data);

	      // build the full pathname to the refraction table
	      build_path (AXE_CONFIG_PATH, ffile_name, ffile_name_path);

	      fconf->opt_layers->substrate =
		create_interp_ftable(ffile_name_path, 2, "WAVELENGTH",
				     "TRANSMISSION", REFRAC_INTERP_TYPE);
	    }
	}
    }

  return fconf;
}

/**
 * Function: check_fringe_conf
 *
 * Parameters:
 * @param fconf  - the fringe configuration structure
 *
 * Returns:
 * @return
 */
void
check_fringe_conf(fringe_conf *fconf)
{
  // make  sure the fringe amplitude is set
  if (!fconf->fringe_amp)
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "fringe_conf: The fringing amplitude must\n"
		 "be set to be able determining pixel fringing!\n");

  // make  sure the fringe phase is set
  if (fconf->fringe_phase > 1.0e+31)
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "fringe_conf: The fringing phase must\n"
		 "be set to be able determining pixel fringing!\n");

  // make  sure the transmission of the substrate
  // layer is given
  if (!fconf->opt_layers->substrate)
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "fringe_conf: The substrate transmission\n"
		 "must be given to be able determining pixel fringing!\n");

  // make sure that there is a minimum
  // number of layers.
  if (fconf->opt_layers->num_layers < NLAYERS_MIN)
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "The number of layers in the configuration\n file is %i. "
		 "There must be at least: %i!\n",
		 fconf->opt_layers->num_layers, NLAYERS_MIN);

  // if not defined, give a meaningfull
  // default for the fringing range
   if (!fconf->fringe_range)
    {
      fconf->fringe_range = gsl_vector_alloc(2);
      gsl_vector_set(fconf->fringe_range, 0, DEFAULT_MIN_LAMBDA);
      gsl_vector_set(fconf->fringe_range, 1, DEFAULT_MAX_LAMBDA);
      fprintf(stdout, "Setting the fringing range to defaults: [ %f, %f].\n",
	      DEFAULT_MIN_LAMBDA, DEFAULT_MAX_LAMBDA);
    }

   // give reasonable default for
   // the fringe step
   if (!fconf->fringe_step)
     {
       fconf->fringe_step = DEFAULT_FRINGE_STEP;
       fprintf(stdout, "Setting the fringing step to default: %f.\n",
	       DEFAULT_FRINGE_STEP);
     }

   // give a reasonable default for the
   // number of steps
   if (!fconf->num_steps)
     {
       fconf->num_steps = DEFAULT_NUM_STEPS;
       fprintf(stdout, "Setting the number of steps to default: %i.\n",
	       DEFAULT_NUM_STEPS);
     }

   // give a reasonable default for the
   // maximum dispersion to correct for
   if (!fconf->max_dispersion)
     {
       fconf->max_dispersion = DEFAULT_MAX_DISPERSION;
       fprintf(stdout, "Setting the maximal dispersion to default: %f.\n",
	       DEFAULT_MAX_DISPERSION);
     }
}

/**
 * Function: free_fringe_conf
 * The function deallocates all memory in a
 * fringe configuration structure.
 *
 * Parameters:
 * @param fconf  - the fringe configuration structure
 *
 * Returns:
 * @return -
 */
void
free_fringe_conf(fringe_conf *fconf)
{

  // free the filter throughput
  if (fconf->filter_through)
    free_interp(fconf->filter_through);

  // free the optical layers
  free_CCD_layers(fconf->opt_layers);

  // free the fringe range
  gsl_vector_free(fconf->fringe_range);
  fconf->fringe_range = NULL;

  // free everything
  free(fconf);
}

/**
 * Function: create_interp_ftable
 * This function cretaes an interpolator from data values stored
 * in a fits table. An interpolator is a structure to hold all
 * data to compute the interpolated data values for different
 * interpolation methods. Core of this structure is the interpolator
 * types offered in the gsl-library.
 * This function is a tool to extract the relevant data points from
 * a fits table and to set up and return the interpolator.
 *
 *
 * Parameters:
 * @param table_name  - the name of the fits table
 * @param hdunum      - the extension number with the data
 * @param xcol        - the column name with the indepenent values
 * @param ycol        - the column name with the dependent values
 * @param interp_type - the interpolation type
 *
 * Returns:
 * @return interp - the interpolation structure created
 */
interpolator *
create_interp_ftable(const char table_name[], const int hdunum,
		     char xcol[], char ycol[],
		     const gsl_interp_type *interp_type)
{

  interpolator *interp;

  double *x;
  double *y;
  int    f_status = 0;
  int hdutype, anynul;
  long nrows=0;
  int colnum=0;

  fitsfile *input;

  // allocate space for the return structure;
  // complain if this fails
  //    interp = (interpolator *)malloc (sizeof (interpolator));
  //   if (interp == NULL)
  //     {
  //        aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
  //  		   "Could not allocate memory for interpolator");
  //      }

#ifdef DEBUGFCONF
  fprintf(stderr, "Loading columns %s and %s of fitstable: %s\n", xcol, ycol, table_name);
#endif

  //  Open the file for reading
  fits_open_file (&input, table_name, READONLY, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "get_response_function_fromFITS: "
		   "Could not open" " file: %s",
		   table_name);
    }

  /* Move to the correct hdu */
  fits_movabs_hdu (input, hdunum, &hdutype, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable:"
		   "Could not read extention %d from file: %s",
		   hdunum, table_name);
    }

  /* Get number of rows */
  fits_get_num_rows (input, &nrows, &f_status);
  if (f_status) {
    ffrprt (stderr, f_status);
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "create_interp_ftable: "
		 "Could not determine the number of rows in"
		 " table %s",table_name);
  }

  /* Allocate temporary memory space */
  x = (double *) malloc(nrows*sizeof(double));
  if (!x) {
    aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		 "Memory allocation failed");
  }
  y = (double *) malloc(nrows*sizeof(double));
  if (!y) {
    aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		 "Memory allocation failed");
  }

  /**************************/
  /* Read the X-column      */
  /**************************/
  /* Get column number */
  fits_get_colnum (input, CASEINSEN, xcol, &colnum, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not determine column %s in "
		   " table %s", xcol, table_name);
    }

  /* Read the data */
  fits_read_col (input, TDOUBLE, colnum, 1, 1, nrows, NULL, x,
                    &anynul, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not read content of WAVELENGTH column "
		   " from BINARY table %s",table_name);
    }

  /**************************/
  /* Read the y-column      */
  /**************************/
  /* Get column number */
  fits_get_colnum (input, CASEINSEN, ycol, &colnum, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not determine column %s in "
		   " table %s", ycol, table_name);
    }

  /* Read the data */
  fits_read_col (input, TDOUBLE, colnum, 1, 1, nrows, NULL, y,
                    &anynul, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not read column %s"
		   " from BINARY table %s", ycol, table_name);
    }

  fits_close_file(input,&f_status);
  if (f_status) {
      aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		   "Could not close %s", table_name);
  }

  // create the interpolator
  interp = create_interp(nrows, interp_type, x, y);

  // return the interpolator
  return interp;
}

/**
 * Function: create_interp
 * The function creates, and intializes and returns an interpolator
 * from the basic input, which is the data, the number of data
 * items and the interpolator type requested.
 *
 * Parameters:
 * @param nvals       - the number of data values in the arrays
 * @param interp_type - the interpolation type
 * @param xvals       - the array with the independent data values
 * @param yvals       - the array with the dependent data values
 *
 * Returns:
 * @return interp - the interpolation structure created
 */
interpolator *
create_interp(const int nvals, const gsl_interp_type *interp_type,
	      double *xvals, double *yvals)
{
  interpolator *interp;

  // allocate space for the return structure;
  // complain if this fails
  interp = (interpolator *)malloc (sizeof (interpolator));
  if (interp == NULL)
    {
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "Could not allocate memory for interpolator");
    }

  // store the min and max values
  interp->xmin    = xvals[0];
  interp->xmax    = xvals[nvals-1];

  // check for ascending order in the
  // independent values
  if (interp->xmax < interp->xmin)
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "The independent data values to be stored\n"
		 " in an interplator must be in INCREASING order!\n");

  // store the number of data values
  interp->nvals   = nvals;

  // store the data arrays
  interp->xvals   = xvals;
  interp->yvals   = yvals;

  // create and intitialize the gsl inteprolator
  interp->acc     = gsl_interp_accel_alloc();
  interp->interp  = gsl_interp_alloc(interp_type, interp->nvals);
  gsl_interp_init(interp->interp, interp->xvals, interp->yvals, interp->nvals);

  // return the new structure
  return interp;
}

/**
 * Function: print_interp
 *
 * Parameters:
 * @param interp - the interpolator structure
 *
 * Returns:
 * @return -
 */
void
print_interp(interpolator *interp)
{
  int index;
  double x_typical;

  x_typical = interp->xmin+(interp->xmax-interp->xmin)/2.0;

  fprintf(stdout, "xmin: %e, xmax: %e\n",interp->xmin, interp->xmax);
  fprintf(stdout, "number of data values: %i\n",interp->nvals);
  fprintf(stdout, "Interpolation type: %s\n", gsl_interp_name(interp->interp));
  fprintf(stdout, "Characteristic value pair: (x,y) = (%e, %e)\n",
	  x_typical, gsl_interp_eval(interp->interp, interp->xvals,
				     interp->yvals, x_typical, interp->acc));

  fprintf(stdout, "Alternative value pair: (x,y) = (%e, %e)\n",
	  x_typical, eval_interp(interp, x_typical));
  for (index=0; index < interp->nvals; index++)
    fprintf(stdout, "xvalue: %e, yvalue: %e\n",interp->xvals[index], interp->yvals[index]);
  fprintf(stdout, "\n");
}

/**
 * Function: eval_interp
 * The function computes and returns the interpolated value
 * at a given position for an interpolater.
 *
 * Parameters:
 * @param interp - the interpolator
 * @param xval   - the position to evaluate the interpolator
 *
 * Returns:
 * @return (value) - the interpolated data value
 */
double
eval_interp(interpolator *interp, const double xval)
{
  // check whether the x-value is within
  // the range spanned by the data;
  // complain if the x-value is outside
  if (xval < interp->xmin || xval > interp->xmax)
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "independent interpolation value %f "
		   "is outside interval (%f, %f)\n", xval,
		   interp->xmin, interp->xmax);

  // evaluate and return the interpolated value
  // in on the spot
  return  gsl_interp_eval(interp->interp, interp->xvals, interp->yvals,
			  xval, interp->acc);
}

/**
 * Function: free_interp
 * the function frees all memory allocated in
 * an interpolator structure.
 *
 * Parameters:
 * @param interp - the interpolator structure
 *
 * Returns:
 * @return -
 */
void
free_interp(interpolator *interp)
{
  // free the data vectors
  free(interp->xvals);
  free(interp->yvals);

  // free the two gsl structures
  gsl_interp_accel_free(interp->acc);
  gsl_interp_free (interp->interp);

  // free the rest
  free(interp);

  // set it to NULL
  interp = NULL;
}

/**
 * Function: create_linint_ftable
 * This function creates a linear interpolator from data values stored
 * in a fits table. An linear interpolator is a structure to hold all
 * data to compute the linear interpolated data values at any
 * point bracketed by the data.
 * This function is a tool to extract the relevant data points from
 * a fits table and to set up and return the linear interpolator.
 *
 * Parameters:
 * @param table_name  - the name of the fits table
 * @param hdunum      - the extension number with the data
 * @param xcol        - the column name with the indepenent values
 * @param ycol        - the column name with the dependent values
 * @param interp_type - the interpolation type
 *
 * Returns:
 * @return lin_int - the linear interplator structure created
 */
linear_interp *
create_linint_ftable(const char table_name[], const int hdunum,
		     char xcol[], char ycol[])
{

  linear_interp *lin_int;

  double *x;
  double *y;
  int    f_status = 0;
  int hdutype, anynul;
  long nrows=0;
  int colnum;
  int index=0;

  gsl_vector *xvals;
  gsl_vector *yvals;

  fitsfile *input;

  // allocate space for the return structure;
  // complain if this fails
  lin_int = (linear_interp *)malloc (sizeof (linear_interp));
  if (lin_int == NULL)
    {
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "Could not allocate memory for linear interpolator");
    }

#ifdef DEBUGFCONF
  fprintf(stderr, "Loading columns %s and %s of fitstable: %s\n", xcol, ycol, table_name);
#endif

  //  Open the file for reading
  fits_open_file (&input, table_name, READONLY, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "get_response_function_fromFITS: "
		   "Could not open" " file: %s",
		   table_name);
    }

  /* Move to the correct hdu */
  fits_movabs_hdu (input, hdunum, &hdutype, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable:"
		   "Could not read extention %d from file: %s",
		   hdunum, table_name);
    }

  /* Get number of rows */
  fits_get_num_rows (input, &nrows, &f_status);
  if (f_status) {
    ffrprt (stderr, f_status);
    aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		 "create_interp_ftable: "
		 "Could not determine the number of rows in"
		 " table %s",table_name);
  }

  /* Allocate temporary memory space */
  x = (double *) malloc(nrows*sizeof(double));
  if (!x) {
    aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		 "Memory allocation failed");
  }
  y = (double *) malloc(nrows*sizeof(double));
  if (!y) {
    aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		 "Memory allocation failed");
  }

  /**************************/
  /* Read the X-column      */
  /**************************/
  /* Get column number */
  fits_get_colnum (input, CASEINSEN, xcol, &colnum, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not determine column %s in "
		   " table %s", xcol, table_name);
    }

  /* Read the data */
  fits_read_col (input, TDOUBLE, colnum, 1, 1, nrows, NULL, x,
                    &anynul, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not read content of WAVELENGTH column "
		   " from BINARY table %s",table_name);
    }

  /**************************/
  /* Read the y-column      */
  /**************************/
  /* Get column number */
  fits_get_colnum (input, CASEINSEN, ycol, &colnum, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not determine column %s in "
		   " table %s", ycol, table_name);
    }

  /* Read the data */
  fits_read_col (input, TDOUBLE, colnum, 1, 1, nrows, NULL, y,
                    &anynul, &f_status);
  if (f_status)
    {
      ffrprt (stderr, f_status);
      aXe_message (aXe_M_FATAL, __FILE__, __LINE__,
		   "create_interp_ftable: "
		   "Could not read column %s"
		   " from BINARY table %s", ycol, table_name);
    }

  fits_close_file(input,&f_status);
  if (f_status) {
      aXe_message (aXe_M_ERROR, __FILE__, __LINE__,
		   "Could not close %s", table_name);
  }

#ifdef DEBUGFCONF
  fprintf(stderr, "Number of rows: %i\n", nrows);
#endif

  // allocate space for the two vectors
  xvals = gsl_vector_alloc(nrows);
  yvals = gsl_vector_alloc(nrows);

  // transport the values from the
  // arrays to the gsl-arrays
  for (index=0; index < nrows; index++)
    {
      gsl_vector_set(xvals, index, x[index]);
      gsl_vector_set(yvals, index, y[index]);
    }

  // reverse both vectors if necessary
  if (gsl_vector_get(xvals, 0) > gsl_vector_get(xvals, nrows-1))
    {
      gsl_vector_reverse(xvals);
      gsl_vector_reverse(yvals);
    }

  // set the two helper elements
  lin_int->act_index = 0;
  lin_int->num_elem  = nrows;

  // set the minimum and maximum
  lin_int->xmin = gsl_vector_get(xvals, 0);
  lin_int->xmax = gsl_vector_get(xvals, nrows-1);

  // set the two vectors
  lin_int->xvals = xvals;
  lin_int->yvals = yvals;

  // release memory in the temp variables
  free(x);
  free(y);

  // return the new structure
  return lin_int;
}

/**
 * Function: free_linint
 * The function frees all memory allocated
 * in a linear interpolator structure.
 *
 * Parameters:
 * @param lin_int - the linear inteprolator
 *
 * Returns:
 * @return -
 */
void
free_linint(linear_interp *lin_int)
{
  // free the two gsl-vectors
  gsl_vector_free(lin_int->xvals);
  gsl_vector_free(lin_int->yvals);

  // free the whole structure
  free(lin_int);

  // set the structure to NULL
  lin_int = NULL;
}


#pragma once
#include "GradUtil.h"

#ifndef _NOGSL
#include <gsl/gsl_vector.h>
#include <gsl/gsl_blas.h>
#else
#include "CustomSolver.h"
#endif

#include <limits>
#include <math.h>
#include <vector>
#include "BasicError.h"
#include "Util.h"

using namespace std;

class ValueGrad;
class DistanceGrad {
public:
	double dist;
	gsl_vector* grad;
	bool set; // TODO: this bit is not necessary if the default dist is 0
	DistanceGrad(double d, gsl_vector* g): dist(d), grad(g), set(true) {}
	~DistanceGrad(void) {
		gsl_vector_free(grad);
	}
	string print() {
		stringstream str;
		if (set) {
			str << "Dist: " << dist;
		} else {
			str << "Dist: NOT SET";
		}
		return str.str();
	}
	string printFull() {
		stringstream str;
		if (set) {
			str << "Dist: " << dist << endl;
			str << "DGrads: ";
			for (int i = 0; i < grad->size; i++) {
				str << gsl_vector_get(grad, i) << ", ";
			}
            if (dist > 1e5 || gsl_blas_dnrm2(grad) > 1e5) {
                str << "LARGE VALUES" << endl;
            }
		} else {
			str << "Dist: NOT SET";
		}
		return str.str();
	}

	static void dg_and(DistanceGrad* m, DistanceGrad* f, DistanceGrad* d);
	static void dg_or(DistanceGrad* m, DistanceGrad* f, DistanceGrad* d);
	static void dg_not(DistanceGrad* m, DistanceGrad* d);
	static void dg_ite(DistanceGrad* b, DistanceGrad* m, DistanceGrad* f, DistanceGrad* d);

	static double dg_copy(DistanceGrad* m, gsl_vector* grad);
	static void dg_copy(DistanceGrad* m, DistanceGrad* o);

	static double dg_times(DistanceGrad* m, DistanceGrad* f, gsl_vector* grad);

    static void dg_ite(DistanceGrad* m, DistanceGrad* f, double dval, gsl_vector* dgrad, DistanceGrad* o);

    static bool same(DistanceGrad* m, DistanceGrad* f);

    static double dg_combine(DistanceGrad* m, DistanceGrad* f);
    static void dg_combine(DistanceGrad* m, DistanceGrad* f, DistanceGrad* o);

    static double dg_combine(DistanceGrad* m, DistanceGrad* f, double cval, gsl_vector* grad, int bv, gsl_vector* o);
    static double dg_combine(DistanceGrad* m, DistanceGrad* f, double cval, int bv);

    static void dg_combine(vector<DistanceGrad*>& cdists, DistanceGrad* vdist, vector<ValueGrad*>& cvals, int bv, DistanceGrad* o);
};


/* matrices.c */

// 8.4.13 Example programs for matrices of gsl-ref.pdf
// GNU GSL GNU Scientific Library reference book

#include <stdio.h>
#include <gsl/gsl_matrix.h>

int main (void) {
  int i, j;
  gsl_matrix * m = gsl_matrix_alloc (10, 3);

  for (i = 0; i < 10; i++)
    for (j = 0; j < 3; j++)
      gsl_matrix_set (m, i, j, 0.23 + 100*i + j);

  for (i = 0; i < 100; i++) /* OUT OF RANGE ERROR */
    for (j = 0; j < 3; j++)
      printf("m(%d,%d) = %g\n", i, j,
	     gsl_matrix_get (m, i, j));

  gsl_matrix_free(m);

  return 0;
}


#pragma once
#include "BooleanNodes.h"
#include "BooleanDAG.h"
#include "NodeVisitor.h"
#include "VarStore.h"
#include <map>
#include "FloatSupport.h"
#include <tuple>
#include <iostream>
#ifndef _NOGSL
#include <gsl/gsl_vector.h>
#else
#include "CustomSolver.h"
#endif
#include "Util.h"
#include "Interface.h"

using namespace std;

class SimpleEvaluator: NodeVisitor
{
    BooleanDAG& bdag;
    map<string, int>& floatCtrls; // Maps float ctrl names to indices with grad vectors
    gsl_vector* ctrls; // ctrl values
    vector<double> distances; // Keeps track of distance metric for boolean nodes
    double MIN_VALUE = 0.001;
    Interface* inputValues;
    int DEFAULT_INPUT = -32;

public:
    SimpleEvaluator(BooleanDAG& bdag_p, map<string, int>& floatCtrls_p);
	virtual ~SimpleEvaluator();

    virtual void visit( SRC_node& node );
    virtual void visit( DST_node& node );
    virtual void visit( CTRL_node& node );
    virtual void visit( PLUS_node& node );
    virtual void visit( TIMES_node& node );
    virtual void visit( ARRACC_node& node );
    virtual void visit( DIV_node& node );
    virtual void visit( MOD_node& node );
    virtual void visit( NEG_node& node );
    virtual void visit( CONST_node& node );
    virtual void visit( LT_node& node );
    virtual void visit( EQ_node& node );
    virtual void visit( AND_node& node );
    virtual void visit( OR_node& node );
    virtual void visit( NOT_node& node );
    virtual void visit( ARRASS_node& node );
    virtual void visit( UFUN_node& node );
    virtual void visit( TUPLE_R_node& node );
    virtual void visit( ASSERT_node& node );

    void setInputs(Interface* inputValues_p);
    void run(const gsl_vector* ctrls_p);

    double getErrorOnConstraint(int nodeid);
    double getSqrtError(bool_node* node);
    double getAssertError(bool_node* node);
    double getBoolCtrlError(bool_node* node);
    double getBoolExprError(bool_node* node);

    double dist(int nodeid) {
        return d(bdag[nodeid]);
    }

    void setvalue(bool_node& bn, double d) {
        distances[bn.id] = d;
    }

    double d(bool_node& bn) {
        return distances[bn.id];
    }

    double d(bool_node* bn) {
        return d(*bn);
    }

    void print() {
        for (int i = 0; i < bdag.size(); i++) {
            cout << bdag[i]->lprint() << endl;
            cout << d(bdag[i]) << endl;
        }
    }

    bool isFloat(bool_node& bn) {
        return (bn.getOtype() == OutType::FLOAT);
    }

    bool isFloat(bool_node* bn) {
        return (bn->getOtype() == OutType::FLOAT);
    }

    int getInputValue(bool_node& bn) {
        if (inputValues->hasValue(bn.id)) {
            int val = inputValues->getValue(bn.id);
            return val;
        } else {
            return DEFAULT_INPUT;
        }
    }

    int getInputValue(bool_node* bn) {
        return getInputValue(*bn);
    }

};


/*
 *            Copyright 2009-2017 The VOTCA Development Team
 *                       (http://www.votca.org)
 *
 *      Licensed under the Apache License, Version 2.0 (the "License")
 *
 * You may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 *              http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *
 */

#ifndef _VOTCA_XTP_DIIS__H
#define _VOTCA_XTP_DIIS__H

#include <gsl/gsl_multimin.h>
#include <gsl/gsl_vector.h>

#include <votca/tools/linalg.h>
#include <votca/xtp/aomatrix.h>
#include <votca/xtp/orbitals.h>
#include <votca/ctp/logger.h>

using namespace votca::tools;

namespace votca { namespace xtp {
 namespace ub = boost::numeric::ublas;

 class Diis{
public:

    Diis() {_maxerrorindex=0;
                _maxerror=0.0; };
   ~Diis() {
     for (std::vector< ub::matrix<double>* >::iterator it = _mathist.begin() ; it !=_mathist.end(); ++it){
         delete *it;
     }
     _mathist.clear();
      for (std::vector< ub::matrix<double>* >::iterator it = _dmathist.begin() ; it !=_dmathist.end(); ++it){
         delete *it;
     }
     _dmathist.clear();
     for (std::vector< ub::matrix<double>* >::iterator it = _errormatrixhist.begin() ; it !=_errormatrixhist.end(); ++it){
         delete *it;
     }
    _errormatrixhist.clear();

    for (std::vector< std::vector<double>* >::iterator it = _Diis_Bs.begin() ; it !=_Diis_Bs.end(); ++it){
         delete *it;
     }
    _Diis_Bs.clear();

   }

   void Configure(bool usediis,bool noisy, unsigned histlength, bool maxout, string diismethod, double adiis_start,double diis_start,double levelshift,double levelshiftend,unsigned nocclevels){

       _usediis=usediis;
       _noisy=noisy;
       _histlength=histlength;
       _maxout=maxout;
       _diismethod=diismethod;
       _adiis_start=adiis_start;
       _diis_start=diis_start;
       _levelshift=levelshift;
       _levelshiftend=levelshiftend;

       _nocclevels=nocclevels;

   }

   void setOverlap(ub::matrix<double>* _S){
       S=_S;
   }
   void setSqrtOverlap(ub::matrix<double>* _Sminusahalf){
       Sminusahalf=_Sminusahalf;
   }
    void setLogger(ctp::Logger *pLog){_pLog=pLog;}
    double Evolve(const ub::matrix<double>& dmat,const ub::matrix<double>& H,ub::vector<double> &MOenergies,ub::matrix<double> &MOs, int this_iter,double totE);
    void SolveFockmatrix(ub::vector<double>& MOenergies,ub::matrix<double>& MOs,ub::matrix<double>&H);
    void Levelshift(ub::matrix<double>& H,const ub::matrix<double>&MOs);
    unsigned gethistlength(){return _mathist.size();}

    double get_E_adiis(const gsl_vector * x) const;

    void get_dEdx_adiis(const gsl_vector * x, gsl_vector * dEdx) const;
    void get_E_dEdx_adiis(const gsl_vector * x, double * Eval, gsl_vector * dEdx) const;

 private:

    ctp::Logger *_pLog;
    ub::matrix<double>* S;
    ub::matrix<double>* Sminusahalf;
    bool                              _usediis;
    bool                              _noisy;
    unsigned                          _histlength;
    bool                              _maxout;
    string                            _diismethod;
    ub::matrix<double>                _Sminusonehalf;
    double                              _maxerror;
    double                              _adiis_start;
    double                              _diis_start;
    double                              _levelshiftend;
    unsigned                            _maxerrorindex;
    std::vector< ub::matrix<double>* >   _mathist;
    std::vector< ub::matrix<double>* >   _dmathist;
    std::vector< ub::matrix<double>* >   _errormatrixhist;
    std::vector< std::vector<double>* >  _Diis_Bs;

    std::vector<double>                 _totE;
    ub::vector<double>                  _DiF;
    ub::matrix<double>                  _DiFj;

    ub::vector<double> ADIIsCoeff();

 ub::vector<double> compute_c(const gsl_vector * x);
 /// Compute jacobian
 ub::matrix<double> compute_jac(const gsl_vector * x);
 /// Compute energy
 double min_f(const gsl_vector * x, void * params);
 /// Compute derivative
 void min_df(const gsl_vector * x, void * params, gsl_vector * g);
 /// Compute energy and derivative
void min_fdf(const gsl_vector * x, void * params, double * f, gsl_vector * g);

ub::vector<double> DIIsCoeff();

    unsigned _nocclevels;
    double _levelshift;

 };

 namespace adiis {
  /// Compute weights
  ub::vector<double> compute_c(const gsl_vector * x);
  /// Compute jacobian
  ub::matrix<double> compute_jac(const gsl_vector * x);

  /// Compute energy
  double min_f(const gsl_vector * x, void * params);
  /// Compute derivative
  void min_df(const gsl_vector * x, void * params, gsl_vector * g);
  /// Compute energy and derivative
  void min_fdf(const gsl_vector * x, void * params, double * f, gsl_vector * g);
};

}}

#endif


#ifndef __gslSpline_
#define __gslSpline__

#include "include/stdinc.h"
#include <gsl/gsl_errno.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_interp.h>
#include <gsl/gsl_integration.h>

class gslSpline {
protected:
  const gsl_interp_type *spline_type;
  gsl_interp_accel *acc;
  gsl_spline       *spl;
public:

  gslSpline(vector<double> &x, vector<double> &y) {
    spline_type = gsl_interp_cspline;
    spl = gsl_spline_alloc(spline_type, x.size());
    acc = gsl_interp_accel_alloc();
    gsl_spline_init(spl, &x[0], &y[0], x.size());
  }
  ~gslSpline() {
    gsl_interp_accel_free(acc);
    gsl_spline_free(spl);
  }
  void init(vector<double> &x, vector<double> &y) {
    gsl_interp_accel_free(acc);
    gsl_spline_free(spl);
    spl = gsl_spline_alloc(spline_type, x.size());
    acc = gsl_interp_accel_alloc();
    gsl_spline_init(spl, &x[0], &y[0], x.size());
  }

  inline real eval  (double xc)  {return gsl_spline_eval(spl, xc, acc);}
  inline real deriv (double xc)  {return gsl_spline_eval_deriv(spl, xc, acc);}
  inline real deriv2(double xc)  {return gsl_spline_eval_deriv2(spl, xc, acc);}
  inline real integ (double x_lo, double x_up)  {
    return gsl_spline_eval_integ(spl, x_lo, x_up, acc);
  }
};

#endif // __gslSpline__