/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 * Copyright 2018 - Matteo Ragni, Matteo Cocetti - University of Trento
 *
 * Permission is hereby granted, free of charge, to any person obtaining a copy
 * of this software and associated documentation files (the "Software"), to deal
 * in the Software without restriction, including without limitation the rights
 * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
 * copies of the Software, and to permit persons to whom the Software is
 * furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
 * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

#include <cblas.h>
#include "libeuler.h"

/**
 * @brief Internal: Strut that will be passed to euler functions callbacks
 */
typedef struct euler_passthrough
{
  double ts;              /**< Integration steps. Taken from options struct */
  double alpha;           /**< Tustin coefficient. Taken from options struct */
  lapack_int u_offset;    /**< Input offset for \f$t+h\f$ callbacks. Taken from options struct */
  euler_ode_function f;   /**< Vector field to integrate. Taken from input struct */
  euler_ode_jacobian df;  /**< Jacobian of the vector field. Taken from options struct */
  const double *xk;       /**< Current state. Taken from parameters */
  lapack_int x_size;      /**< Ode dimension, taken from the input struct */
  double *work_f;         /**< Working space. Allocated in integration step */
  double *work_df;        /**< Working space. Allocated in integration step */
  void *data;             /**< User supplied data. Taken from parameters */
} euler_passtrough;

/**
 * @brief Euler implicit step wrapper
 *
 * The vector field wrapper implements the following:
 * \f{
 *   g(\cdot) = -x(t+h) + x(t) + (1-\alpha) h f(x(t), u_{1..u_{off}, p} +
 *            \alpha h f(x(t+h), u_{u_{off}..dim(u)}, p)
 * \f}
 * by using user supplied vector field callback. The implicit step search the root
 * of \f$g(\cdot)\f$.
 */
void euler_function_wrapper(double *f, const double t, const double *x, const double *u, const double **p, void *data);

/**
 * @brief Euler implicit step wrapper jacobian
 *
 * The vector field wrapper implements the following jacobian matrix:
 * \f{
 *   \nabla_{x(t+h)} g(\cdot) = -I + \alpha h \nabla_{x(t+h)} f(x(t+h), u_{u_{off}..dim(u)}, p)
 * \f}
 * by using user supplied vector field callback
 */
void euler_jacobian_wrapper(double *f, const double t, const double *x, const double *u, const double **p, void *data);

    euler_ret euler(const euler_options *opt, double *xp, const double t, const double *x, const double *u, const double **p, void *data)
{

  /* EXPLICIT IMPLEMENTATION */
/* Performin a very simple step if alpha == 0 */
if (opt->alpha == 0)
{
  opt->f(xp, t, x, u, p, opt->data);
  cblas_dscal(opt->x_size, opt->ts, xp, 1);
  cblas_daxpy(opt->x_size, 1, x, 1, xp, 1);
  return EULER_SUCCESS;
  }

  /* IMPLICIT IMPLEMENTTION */
  /* Allocating working memory */
  double *work_f = (double *)calloc(2 * opt->x_size, sizeof(double));
  if (!work_f)
    return EULER_EMALLOC;
  double *work_df = (double *)calloc(2 * opt->x_size * opt->x_size, sizeof(double));
  if(!work_df) {
    free(work_f);
    return EULER_EMALLOC;
  }
  /* Setting up the identity matrix in work_df second space, once forever */
  for (lapack_int i = 0; i < opt->x_size; i++)
    work_df[(opt->x_size * opt->x_size) + i + i * opt->x_size] = -1.0;

  /* Setting up options for Euler step */
  newton_options newton_opts = {
    opt->ordering, opt->x_size, opt->x_size,
    opt->s_tol, opt->x_tol, opt->max_iter,
    euler_function_wrapper,
    euler_jacobian_wrapper
  };

  euler_passtrough pt = {
    opt->ts, opt->alpha, opt->u_offset,
    opt->f, opt->df, x, opt->x_size,
    work_f, work_df,
    opt->data
  };

  cblas_dcopy(opt->x_size, x, 1, xp, 1);
  newton_ret nwt = newton_solve(&newton_opts, t, xp, u, p, ((void *)&pt));

  /* Freeing space */
  free(work_f);
  free(work_df);
  if (nwt > NEWTON_MAX_ITER)
    return EULER_GENERIC;
  return EULER_SUCCESS;
}

void euler_function_wrapper(double *f, const double t, const double *x, const double *u, const double **p, void *data) {
  euler_passtrough *_data = ((euler_passtrough *)data);

  /* Evaluating f(x(k), u(k)) and f(x(k+1), u(k+1)), storing result in work_f */
  _data->f(_data->work_f, t, _data->xk, u, p, _data->data);
  _data->f(_data->work_f + _data->x_size, t, x, u + _data->u_offset, p, _data->data);

  /* Computing: x(k) - x(k+1) + (1-alpha) ts f(x(k), u(k)) + alpha ts f(x(k+1), u(k+1)) */
  cblas_dscal(_data->x_size, (1 - _data->alpha) * _data->ts, _data->work_f, 1);
  cblas_dscal(_data->x_size, _data->alpha * _data->ts, _data->work_f + _data->x_size, 1);
  cblas_daxpy(_data->x_size, 1, _data->work_f + _data->x_size, 1, _data->work_f, 1);
  cblas_daxpy(_data->x_size, -1, x, 1, _data->work_f, 1);
  cblas_daxpy(_data->x_size, 1, _data->xk, 1, _data->work_f, 1);

  /* Copying result in output */
  cblas_dcopy(_data->x_size, _data->work_f, 1, f, 1);
}

void euler_jacobian_wrapper(double *df, const double t, const double *x, const double *u, const double **p, void *data) {
  euler_passtrough *_data = ((euler_passtrough *)data);

  /* Evaluating JAC(f)(x(k+1), u(k+1)) */
  _data->df(_data->work_df, t, x, u + _data->u_offset, p, _data->data);

  /* Computing: -I + alpha ts JAC(f)(x(k+1), u(k+1)) (still using level 1 Blas) */
  cblas_dscal(_data->x_size * _data->x_size, _data->alpha * _data->ts, _data->work_df, 1);
  cblas_daxpy(_data->x_size * _data->x_size, 1, _data->work_df + _data->x_size * _data->x_size, 1, _data->work_df, 1);

  /* Copying result in output */
  cblas_dcopy(_data->x_size * _data->x_size, _data->work_df, 1, df, 1);
}


/*
Multisteps: a program to get optime Runge-Kutta and multi-steps methods.

Copyright 2011-2019, Javier Burguete Tolosa.

Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:

	1. Redistributions of source code must retain the above copyright notice,
		this list of conditions and the following disclaimer.

	2. Redistributions in binary form must reproduce the above copyright notice,
		this list of conditions and the following disclaimer in the
		documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY Javier Burguete Tolosa ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT
SHALL Javier Burguete Tolosa OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/

/**
 * \file rk_4_4.c
 * \brief Source file to optimize Runge-Kutta 5 steps 4th order methods.
 * \author Javier Burguete Tolosa.
 * \copyright Copyright 2011-2019.
 */
#define _GNU_SOURCE
#include <string.h>
#include <math.h>
#include <libxml/parser.h>
#include <glib.h>
#include <libintl.h>
#include <gsl/gsl_rng.h>
#include "config.h"
#include "utils.h"
#include "optimize.h"
#include "rk.h"
#include "rk_4_4.h"

#define DEBUG_RK_4_4 0          ///< macro to debug.

/**
 * Function to obtain the coefficients of a 4 steps 4th order Runge-Kutta
 * method.
 */
int
rk_tb_4_4 (Optimize * optimize) ///< Optimize struct.
{
  long double *tb, *r;
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_tb_4_4: start\n");
#endif
  tb = optimize->coefficient;
  r = optimize->random_data;
  t4 (tb) = 1.L;
  t1 (tb) = r[0];
  t2 (tb) = r[1];
  t3 (tb) = 1.L;
  b43 (tb) = (0.25L - 1.L / 3.L * t1 (tb)
              - (1.L / 3.L - 0.5L * t1 (tb)) * t2 (tb))
    / (t3 (tb) * (t3 (tb) - t2 (tb)) * (t3 (tb) - t1 (tb)));
  if (isnan (b43 (tb)))
    return 0;
  b42 (tb) = (1.L / 3.L - 0.5L * t1 (tb)
              - b43 (tb) * t3 (tb) * (t3 (tb) - t1 (tb)))
    / (t2 (tb) * (t2 (tb) - t1 (tb)));
  if (isnan (b42 (tb)))
    return 0;
  b41 (tb) = (0.5L - b42 (tb) * t2 (tb) - b43 (tb) * t3 (tb)) / t1 (tb);
  if (isnan (b41 (tb)))
    return 0;
  b32 (tb) = (1.L / 12.L - 1.L / 6.L * t1 (tb))
    / (b43 (tb) * t2 (tb) * (t2 (tb) - t1 (tb)));
  if (isnan (b32 (tb)))
    return 0;
  b31 (tb) = ((0.125L - 1.L / 6.L * t2 (tb)) / (b43 (tb) * (t3 (tb) - t2 (tb)))
              - b32 (tb) * t2 (tb)) / t1 (tb);
  if (isnan (b31 (tb)))
    return 0;
  b21 (tb) = 1.L / 24.L / (t1 (tb) * b43 (tb) * b32 (tb));
  if (isnan (b21 (tb)))
    return 0;
  rk_b_4 (tb);
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_tb_4_4: end\n");
#endif
  return 1;
}

/**
 * Function to obtain the coefficients of a 4 steps 4th order, 5th order in
 * equations depending only in time, Runge-Kutta method.
 */
int
rk_tb_4_4t (Optimize * optimize)        ///< Optimize struct.
{
  long double *tb, *r;
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_tb_4_4t: start\n");
#endif
  tb = optimize->coefficient;
  r = optimize->random_data;
  t4 (tb) = 1.L;
  t1 (tb) = r[0];
  t2 (tb) = 0.5L * (t1 (tb) - 0.6L) / (t1 (tb) - 0.5L);
  t3 (tb) = 1.L;
  b43 (tb) = (0.25L - 1.L / 3.L * t1 (tb)
              - (1.L / 3.L - 0.5L * t1 (tb)) * t2 (tb))
    / (t3 (tb) * (t3 (tb) - t2 (tb)) * (t3 (tb) - t1 (tb)));
  if (isnan (b43 (tb)))
    return 0;
  b42 (tb) = (1.L / 3.L - 0.5L * t1 (tb)
              - b43 (tb) * t3 (tb) * (t3 (tb) - t1 (tb)))
    / (t2 (tb) * (t2 (tb) - t1 (tb)));
  if (isnan (b42 (tb)))
    return 0;
  b41 (tb) = (0.5L - b42 (tb) * t2 (tb) - b43 (tb) * t3 (tb)) / t1 (tb);
  if (isnan (b41 (tb)))
    return 0;
  b32 (tb) = (1.L / 12.L - 1.L / 6.L * t1 (tb))
    / (b43 (tb) * t2 (tb) * (t2 (tb) - t1 (tb)));
  if (isnan (b32 (tb)))
    return 0;
  b31 (tb) = ((0.125L - 1.L / 6.L * t2 (tb)) / (b43 (tb) * (t3 (tb) - t2 (tb)))
              - b32 (tb) * t2 (tb)) / t1 (tb);
  if (isnan (b31 (tb)))
    return 0;
  b21 (tb) = 1.L / 24.L / (t1 (tb) * b43 (tb) * b32 (tb));
  if (isnan (b21 (tb)))
    return 0;
  rk_b_4 (tb);
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_tb_4_4t: end\n");
#endif
  return 1;
}

/**
 * Function to calculate the objective function of a 4 steps 4th order
 * Runge-Kutta method.
 *
 * \return objective function value.
 */
long double
rk_objective_tb_4_4 (RK * rk)   ///< RK struct.
{
  long double *tb;
  long double o;
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_objective_tb_4_4: start\n");
#endif
  tb = rk->tb->coefficient;
  o = fminl (0.L, b20 (tb));
  if (b21 (tb) < 0.L)
    o += b21 (tb);
  if (b30 (tb) < 0.L)
    o += b30 (tb);
  if (b31 (tb) < 0.L)
    o += b31 (tb);
  if (b32 (tb) < 0.L)
    o += b32 (tb);
  if (b40 (tb) < 0.L)
    o += b40 (tb);
  if (b41 (tb) < 0.L)
    o += b41 (tb);
  if (b42 (tb) < 0.L)
    o += b42 (tb);
  if (b43 (tb) < 0.L)
    o += b43 (tb);
  if (o < 0.L)
    {
      o = 40.L - o;
      goto end;
    }
  o = 30.L + fmaxl (1.L, fmaxl (t1 (tb), fmaxl (t2 (tb), t3 (tb))));
  if (rk->strong)
    {
      rk_bucle_ac (rk);
      o = fminl (o, *rk->ac0->optimal);
    }
end:
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_objective_tb_4_4: optimal=%Lg\n", o);
  fprintf (stderr, "rk_objective_tb_4_4: end\n");
#endif
  return o;
}

/**
 * Function to calculate the objective function of a 4 steps 4th order, 5th
 * order in equations depending only in time, Runge-Kutta method.
 *
 * \return objective function value.
 */
long double
rk_objective_tb_4_4t (RK * rk)  ///< RK struct.
{
  long double *tb;
  long double o;
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_objective_tb_4_4: start\n");
#endif
  tb = rk->tb->coefficient;
  o = fminl (0.L, b20 (tb));
  if (b21 (tb) < 0.L)
    o += b21 (tb);
  if (b30 (tb) < 0.L)
    o += b30 (tb);
  if (b31 (tb) < 0.L)
    o += b31 (tb);
  if (b32 (tb) < 0.L)
    o += b32 (tb);
  if (b40 (tb) < 0.L)
    o += b40 (tb);
  if (b41 (tb) < 0.L)
    o += b41 (tb);
  if (b42 (tb) < 0.L)
    o += b42 (tb);
  if (b43 (tb) < 0.L)
    o += b43 (tb);
  if (o < 0.L)
    {
      o = 40.L - o;
      goto end;
    }
  o = 30.L + fmaxl (1.L, fmaxl (t1 (tb), fmaxl (t2 (tb), t3 (tb))));
  if (rk->strong)
    {
      rk_bucle_ac (rk);
      o = fminl (o, *rk->ac0->optimal);
    }
end:
#if DEBUG_RK_4_4
  fprintf (stderr, "rk_objective_tb_4_4: optimal=%Lg\n", o);
  fprintf (stderr, "rk_objective_tb_4_4: end\n");
#endif
  return o;
}


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

#pragma comment(lib,"gsl")

int main()
{
	printf("%g\n",gsl_sf_bessel_J0(5.0));
	return 0;
}


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

#include <gsl/gsl_spmatrix.h>

int
main()
{
  gsl_spmatrix *A = gsl_spmatrix_alloc(5, 4); /* triplet format */
  gsl_spmatrix *B, *C;
  size_t i, j;

  /* build the sparse matrix */
  gsl_spmatrix_set(A, 0, 2, 3.1);
  gsl_spmatrix_set(A, 0, 3, 4.6);
  gsl_spmatrix_set(A, 1, 0, 1.0);
  gsl_spmatrix_set(A, 1, 2, 7.2);
  gsl_spmatrix_set(A, 3, 0, 2.1);
  gsl_spmatrix_set(A, 3, 1, 2.9);
  gsl_spmatrix_set(A, 3, 3, 8.5);
  gsl_spmatrix_set(A, 4, 0, 4.1);

  printf("printing all matrix elements:\n");
  for (i = 0; i < 5; ++i)
    for (j = 0; j < 4; ++j)
      printf("A(%zu,%zu) = %g\n", i, j,
             gsl_spmatrix_get(A, i, j));

  /* print out elements in triplet format */
  printf("matrix in triplet format (i,j,Aij):\n");
  gsl_spmatrix_fprintf(stdout, A, "%.1f");

  /* convert to compressed column format */
  B = gsl_spmatrix_ccs(A);

  printf("matrix in compressed column format:\n");
  printf("i = [ ");
  for (i = 0; i < B->nz; ++i)
    printf("%d, ", B->i[i]);
  printf("]\n");

  printf("p = [ ");
  for (i = 0; i < B->size2 + 1; ++i)
    printf("%d, ", B->p[i]);
  printf("]\n");

  printf("d = [ ");
  for (i = 0; i < B->nz; ++i)
    printf("%g, ", B->data[i]);
  printf("]\n");

  /* convert to compressed row format */
  C = gsl_spmatrix_crs(A);

  printf("matrix in compressed row format:\n");
  printf("i = [ ");
  for (i = 0; i < C->nz; ++i)
    printf("%d, ", C->i[i]);
  printf("]\n");

  printf("p = [ ");
  for (i = 0; i < C->size1 + 1; ++i)
    printf("%d, ", C->p[i]);
  printf("]\n");

  printf("d = [ ");
  for (i = 0; i < C->nz; ++i)
    printf("%g, ", C->data[i]);
  printf("]\n");

  gsl_spmatrix_free(A);
  gsl_spmatrix_free(B);
  gsl_spmatrix_free(C);

  return 0;
}


/* specfunc/laguerre.c
 *
 * Copyright (C) 2007 Brian Gough
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * 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.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_sf_exp.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_sf_laguerre.h>

#include "error.h"

/*-*-*-*-*-*-*-*-*-*-*-* Private Section *-*-*-*-*-*-*-*-*-*-*-*/

/* based on the large 2b-4a asymptotic for 1F1
 * [Abramowitz+Stegun, 13.5.21]
 * L^a_n(x) = (a+1)_n / n! 1F1(-n,a+1,x)
 *
 * The second term (ser_term2) is from Slater,"The Confluent
 * Hypergeometric Function" p.73.  I think there may be an error in
 * the first term of the expression given there, comparing with AS
 * 13.5.21 (cf sin(a\pi+\Theta) vs sin(a\pi) + sin(\Theta)) - but the
 * second term appears correct.
 *
 */
static
int
laguerre_large_n(const int n, const double alpha, const double x,
                 gsl_sf_result * result)
{
  const double a = -n;
  const double b = alpha + 1.0;
  const double eta    = 2.0*b - 4.0*a;
  const double cos2th = x/eta;
  const double sin2th = 1.0 - cos2th;
  const double eps = asin(sqrt(cos2th));  /* theta = pi/2 - eps */
  const double pre_h  = 0.25*M_PI*M_PI*eta*eta*cos2th*sin2th;
  gsl_sf_result lg_b;
  gsl_sf_result lnfact;
  int stat_lg = gsl_sf_lngamma_e(b+n, &lg_b);
  int stat_lf = gsl_sf_lnfact_e(n, &lnfact);
  double pre_term1 = 0.5*(1.0-b)*log(0.25*x*eta);
  double pre_term2 = 0.25*log(pre_h);
  double lnpre_val = lg_b.val - lnfact.val + 0.5*x + pre_term1 - pre_term2;
  double lnpre_err = lg_b.err + lnfact.err + GSL_DBL_EPSILON * (fabs(pre_term1)+fabs(pre_term2));

  double phi1 = 0.25*eta*(2*eps + sin(2.0*eps));
  double ser_term1 = -sin(phi1);

  double A1 = (1.0/12.0)*(5.0/(4.0*sin2th)+(3.0*b*b-6.0*b+2.0)*sin2th - 1.0);
  double ser_term2 = -A1 * cos(phi1)/(0.25*eta*sin(2.0*eps));

  double ser_val = ser_term1 + ser_term2;
  double ser_err = ser_term2*ser_term2 + GSL_DBL_EPSILON * (fabs(ser_term1) + fabs(ser_term2));
  int stat_e = gsl_sf_exp_mult_err_e(lnpre_val, lnpre_err, ser_val, ser_err, result);
  result->err += 2.0 * GSL_SQRT_DBL_EPSILON * fabs(result->val);
  return GSL_ERROR_SELECT_3(stat_e, stat_lf, stat_lg);
}

/* Evaluate polynomial based on confluent hypergeometric representation.
 *
 * L^a_n(x) = (a+1)_n / n! 1F1(-n,a+1,x)
 *
 * assumes n > 0 and a != negative integer greater than -n
 */
static
int
laguerre_n_cp(const int n, const double a, const double x, gsl_sf_result * result)
{
  gsl_sf_result lnfact;
  gsl_sf_result lg1;
  gsl_sf_result lg2;
  double s1, s2;
  int stat_f = gsl_sf_lnfact_e(n, &lnfact);
  int stat_g1 = gsl_sf_lngamma_sgn_e(a+1.0+n, &lg1, &s1);
  int stat_g2 = gsl_sf_lngamma_sgn_e(a+1.0, &lg2, &s2);
  double poly_1F1_val = 1.0;
  double poly_1F1_err = 0.0;
  int stat_e;
  int k;

  double lnpre_val = (lg1.val - lg2.val) - lnfact.val;
  double lnpre_err = lg1.err + lg2.err + lnfact.err + 2.0 * GSL_DBL_EPSILON * fabs(lnpre_val);

  for(k=n-1; k>=0; k--) {
    double t = (-n+k)/(a+1.0+k) * (x/(k+1));
    double r = t + 1.0/poly_1F1_val;
    if(r > 0.9*GSL_DBL_MAX/poly_1F1_val) {
      /* internal error only, don't call the error handler */
      INTERNAL_OVERFLOW_ERROR(result);
    }
    else {
      /* Collect the Horner terms. */
      poly_1F1_val  = 1.0 + t * poly_1F1_val;
      poly_1F1_err += GSL_DBL_EPSILON + fabs(t) * poly_1F1_err;
    }
  }

  stat_e = gsl_sf_exp_mult_err_e(lnpre_val, lnpre_err,
                                    poly_1F1_val, poly_1F1_err,
                                    result);

  return GSL_ERROR_SELECT_4(stat_e, stat_f, stat_g1, stat_g2);
}

/* Evaluate the polynomial based on the confluent hypergeometric
 * function in a safe way, with no restriction on the arguments.
 *
 * assumes x != 0
 */
static
int
laguerre_n_poly_safe(const int n, const double a, const double x, gsl_sf_result * result)
{
  const double b = a + 1.0;
  const double mx = -x;
  const double tc_sgn = (x < 0.0 ? 1.0 : (GSL_IS_ODD(n) ? -1.0 : 1.0));
  gsl_sf_result tc;
  int stat_tc = gsl_sf_taylorcoeff_e(n, fabs(x), &tc);

  if(stat_tc == GSL_SUCCESS) {
    double term = tc.val * tc_sgn;
    double sum_val = term;
    double sum_err = tc.err;
    int k;
    for(k=n-1; k>=0; k--) {
      term *= ((b+k)/(n-k))*(k+1.0)/mx;
      sum_val += term;
      sum_err += 4.0 * GSL_DBL_EPSILON * fabs(term);
    }
    result->val = sum_val;
    result->err = sum_err + 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(stat_tc == GSL_EOVRFLW) {
    result->val = 0.0; /* FIXME: should be Inf */
    result->err = 0.0;
    return stat_tc;
  }
  else {
    result->val = 0.0;
    result->err = 0.0;
    return stat_tc;
  }
}

/*-*-*-*-*-*-*-*-*-*-*-* Functions with Error Codes *-*-*-*-*-*-*-*-*-*-*/

int
gsl_sf_laguerre_1_e(const double a, const double x, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  {
    result->val = 1.0 + a - x;
    result->err = 2.0 * GSL_DBL_EPSILON * (1.0 + fabs(a) + fabs(x));
    return GSL_SUCCESS;
  }
}

int
gsl_sf_laguerre_2_e(const double a, const double x, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(a == -2.0) {
    result->val = 0.5*x*x;
    result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else {
    double c0 = 0.5 * (2.0+a)*(1.0+a);
    double c1 = -(2.0+a);
    double c2 = -0.5/(2.0+a);
    result->val  = c0 + c1*x*(1.0 + c2*x);
    result->err  = 2.0 * GSL_DBL_EPSILON * (fabs(c0) + 2.0 * fabs(c1*x) * (1.0 + 2.0 * fabs(c2*x)));
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
}

int
gsl_sf_laguerre_3_e(const double a, const double x, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(a == -2.0) {
    double x2_6  = x*x/6.0;
    result->val  = x2_6 * (3.0 - x);
    result->err  = x2_6 * (3.0 + fabs(x)) * 2.0 * GSL_DBL_EPSILON;
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(a == -3.0) {
    result->val = -x*x/6.0;
    result->err = 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else {
    double c0 = (3.0+a)*(2.0+a)*(1.0+a) / 6.0;
    double c1 = -c0 * 3.0 / (1.0+a);
    double c2 = -1.0/(2.0+a);
    double c3 = -1.0/(3.0*(3.0+a));
    result->val  = c0 + c1*x*(1.0 + c2*x*(1.0 + c3*x));
    result->err  = 1.0 + 2.0 * fabs(c3*x);
    result->err  = 1.0 + 2.0 * fabs(c2*x) * result->err;
    result->err  = 2.0 * GSL_DBL_EPSILON * (fabs(c0) + 2.0 * fabs(c1*x) * result->err);
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
}

int
gsl_sf_laguerre_n_e(const int n, const double a, const double x, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(n < 0) {
    DOMAIN_ERROR(result);
  }
  else if(n == 0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(n == 1) {
    result->val = 1.0 + a - x;
    result->err = 2.0 * GSL_DBL_EPSILON * (1.0 + fabs(a) + fabs(x));
    return GSL_SUCCESS;
  }
  else if(x == 0.0) {
    double product = a + 1.0;
    int k;
    for(k=2; k<=n; k++) {
      product *= (a + k)/k;
    }
    result->val = product;
    result->err = 2.0 * (n + 1.0) * GSL_DBL_EPSILON * fabs(product) + GSL_DBL_EPSILON;
    return GSL_SUCCESS;
  }
  else if(x < 0.0 && a > -1.0) {
    /* In this case all the terms in the polynomial
     * are of the same sign. Note that this also
     * catches overflows correctly.
     */
    return laguerre_n_cp(n, a, x, result);
  }
  else if(n < 5 || (x > 0.0 && a < -n-1)) {
    /* Either the polynomial will not lose too much accuracy
     * or all the terms are negative. In any case,
     * the error estimate here is good. We try both
     * explicit summation methods, as they have different
     * characteristics. One may underflow/overflow while the
     * other does not.
     */
    if(laguerre_n_cp(n, a, x, result) == GSL_SUCCESS)
      return GSL_SUCCESS;
    else
      return laguerre_n_poly_safe(n, a, x, result);
  }
  else if(n > 1.0e+07 && x > 0.0 && a > -1.0 && x < 2.0*(a+1.0)+4.0*n) {
    return laguerre_large_n(n, a, x, result);
  }
  else if(a >= 0.0 || (x > 0.0 && a < -n-1)) {
    gsl_sf_result lg2;
    int stat_lg2 = gsl_sf_laguerre_2_e(a, x, &lg2);
    double Lkm1 = 1.0 + a - x;
    double Lk   = lg2.val;
    double Lkp1;
    int k;

    for(k=2; k<n; k++) {
      Lkp1 = (-(k+a)*Lkm1 + (2.0*k+a+1.0-x)*Lk)/(k+1.0);
      Lkm1 = Lk;
      Lk   = Lkp1;
    }
    result->val = Lk;
    result->err = (fabs(lg2.err/lg2.val) + GSL_DBL_EPSILON) * n * fabs(Lk);
    return stat_lg2;
  }
  else {
    /* Despair... or magic? */
    return laguerre_n_poly_safe(n, a, x, result);
  }
}

/*-*-*-*-*-*-*-*-*-* Functions w/ Natural Prototypes *-*-*-*-*-*-*-*-*-*-*/

#include "eval.h"

double gsl_sf_laguerre_1(double a, double x)
{
  EVAL_RESULT(gsl_sf_laguerre_1_e(a, x, &result));
}

double gsl_sf_laguerre_2(double a, double x)
{
  EVAL_RESULT(gsl_sf_laguerre_2_e(a, x, &result));
}

double gsl_sf_laguerre_3(double a, double x)
{
  EVAL_RESULT(gsl_sf_laguerre_3_e(a, x, &result));
}

double gsl_sf_laguerre_n(int n, double a, double x)
{
  EVAL_RESULT(gsl_sf_laguerre_n_e(n, a, x, &result));
}


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

#include <config.h>
#include <stdlib.h>
#include <stdio.h>
#include <gsl/gsl_histogram2d.h>
#include <gsl/gsl_test.h>
#include <gsl/gsl_ieee_utils.h>

#define M 107
#define N 239
#define M1 17
#define N1 23
#define MR 10
#define NR 5

int
main (void)
{
  double xr[MR + 1] =
  {0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0, 10.0};

  double yr[NR + 1] =
  {90.0, 91.0, 92.0, 93.0, 94.0, 95.0};

  gsl_histogram2d *h, *h1, *g, *hr;
  size_t i, j, k;

  gsl_ieee_env_setup ();

  h = gsl_histogram2d_calloc (M, N);
  h1 = gsl_histogram2d_calloc (M, N);
  g = gsl_histogram2d_calloc (M, N);

  gsl_test (h->xrange == 0,
	    "gsl_histogram2d_calloc returns valid xrange pointer");
  gsl_test (h->yrange == 0,
	    "gsl_histogram2d_calloc returns valid yrange pointer");
  gsl_test (h->bin == 0,
	    "gsl_histogram2d_calloc returns valid bin pointer");

  gsl_test (h->nx != M, "gsl_histogram2d_calloc returns valid nx");
  gsl_test (h->ny != N, "gsl_histogram2d_calloc returns valid ny");

  hr = gsl_histogram2d_calloc_range (MR, NR, xr, yr);

  gsl_test (hr->xrange == 0,
	    "gsl_histogram2d_calloc_range returns valid xrange pointer");
  gsl_test (hr->yrange == 0,
	    "gsl_histogram2d_calloc_range returns valid yrange pointer");
  gsl_test (hr->bin == 0,
	    "gsl_histogram2d_calloc_range returns valid bin pointer");

  gsl_test (hr->nx != MR, "gsl_histogram2d_calloc_range returns valid nx");
  gsl_test (hr->ny != NR, "gsl_histogram2d_calloc_range returns valid ny");

  {
    int status = 0;
    for (i = 0; i <= MR; i++)
      {
	if (hr->xrange[i] != xr[i])
	  {
	    status = 1;
	  }
      };

    gsl_test (status, "gsl_histogram2d_calloc_range creates xrange correctly");
  }

  {
    int status = 0;
    for (i = 0; i <= NR; i++)
      {
	if (hr->yrange[i] != yr[i])
	  {
	    status = 1;
	  }
      };

    gsl_test (status, "gsl_histogram2d_calloc_range creates yrange correctly");
  }

  for (i = 0; i <= MR; i++)
    {
      hr->xrange[i] = 0.0;
    }

  for (i = 0; i <= NR; i++)
    {
      hr->yrange[i] = 0.0;
    }

  {
    int status = gsl_histogram2d_set_ranges (hr, xr, MR+1, yr, NR+1);

    for (i = 0; i <= MR; i++)
      {
	if (hr->xrange[i] != xr[i])
	  {
	    status = 1;
	  }
      };

    gsl_test (status, "gsl_histogram2d_set_ranges sets xrange correctly");
  }

  {
    int status = 0;
    for (i = 0; i <= NR; i++)
      {
	if (hr->yrange[i] != yr[i])
	  {
	    status = 1;
	  }
      };

    gsl_test (status, "gsl_histogram2d_set_ranges sets yrange correctly");
  }

  k = 0;
  for (i = 0; i < M; i++)
    {
      for (j = 0; j < N; j++)
	{
	  k++;
	  gsl_histogram2d_accumulate (h, (double) i, (double) j, (double) k);
	};
    }

  {
    int status = 0;
    k = 0;
    for (i = 0; i < M; i++)
      {
	for (j = 0; j < N; j++)
	  {
	    k++;
	    if (h->bin[i * N + j] != (double) k)
	      {
		status = 1;
	      }
	  }
      }
    gsl_test (status,
	      "gsl_histogram2d_accumulate writes into array correctly");
  }

  {
    int status = 0;
    k = 0;
    for (i = 0; i < M; i++)
      {
	for (j = 0; j < N; j++)
	  {
	    k++;
	    if (gsl_histogram2d_get (h, i, j) != (double) k)
	      status = 1;
	  };
      }
    gsl_test (status, "gsl_histogram2d_get reads from array correctly");
  }

  for (i = 0; i <= M; i++)
    {
      h1->xrange[i] = 100.0 + i;
    }

  for (i = 0; i <= N; i++)
    {
      h1->yrange[i] = 900.0 + i*i;
    }

  gsl_histogram2d_memcpy (h1, h);

  {
    int status = 0;
    for (i = 0; i <= M; i++)
      {
	if (h1->xrange[i] != h->xrange[i])
	  status = 1;
      };
    gsl_test (status, "gsl_histogram2d_memcpy copies bin xranges correctly");
  }

  {
    int status = 0;
    for (i = 0; i <= N; i++)
      {
	if (h1->yrange[i] != h->yrange[i])
	  status = 1;
      };
    gsl_test (status, "gsl_histogram2d_memcpy copies bin yranges correctly");
  }

  {
    int status = 0;
    for (i = 0; i < M; i++)
      {
        for (j = 0; j < N; j++)
          {
            if (gsl_histogram2d_get (h1, i, j) != gsl_histogram2d_get (h, i, j))
              status = 1;
          }
      }
    gsl_test (status, "gsl_histogram2d_memcpy copies bin values correctly");
  }

  gsl_histogram2d_free (h1);

  h1 = gsl_histogram2d_clone (h);

  {
    int status = 0;
    for (i = 0; i <= M; i++)
      {
	if (h1->xrange[i] != h->xrange[i])
	  status = 1;
      };
    gsl_test (status, "gsl_histogram2d_clone copies bin xranges correctly");
  }

  {
    int status = 0;
    for (i = 0; i <= N; i++)
      {
	if (h1->yrange[i] != h->yrange[i])
	  status = 1;
      };
    gsl_test (status, "gsl_histogram2d_clone copies bin yranges correctly");
  }

  {
    int status = 0;
    for (i = 0; i < M; i++)
      {
        for (j = 0; j < N; j++)
          {
            if (gsl_histogram2d_get (h1, i, j) != gsl_histogram2d_get (h, i, j))
              status = 1;
          }
      }
    gsl_test (status, "gsl_histogram2d_clone copies bin values correctly");
  }

  gsl_histogram2d_reset (h);

  {
    int status = 0;

    for (i = 0; i < M * N; i++)
      {
	if (h->bin[i] != 0)
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_reset zeros array correctly");
  }

  gsl_histogram2d_free (h);
  h = gsl_histogram2d_calloc (M1, N1);

  {

    int status = 0;

    for (i = 0; i < M1; i++)
      {
	for (j = 0; j < N1; j++)
	  {
	    gsl_histogram2d_increment (h, (double) i, (double) j);

	    for (k = 0; k <= i * N1 + j; k++)
	      {
		if (h->bin[k] != 1)
		  {
		    status = 1;
		  }
	      }

	    for (k = i * N1 + j + 1; k < M1 * N1; k++)
	      {
		if (h->bin[k] != 0)
		  {
		    status = 1;
		  }
	      }
	  }
      }
    gsl_test (status, "gsl_histogram2d_increment works correctly");
  }

  gsl_histogram2d_free (h);
  h = gsl_histogram2d_calloc (M, N);

  {
    int status = 0;
    for (i = 0; i < M; i++)
      {
	double x0 = 0, x1 = 0;
	gsl_histogram2d_get_xrange (h, i, &x0, &x1);

	if (x0 != i || x1 != i + 1)
	  {
	    status = 1;
	  }
      }
    gsl_test (status,
      "gsl_histogram2d_get_xlowerlimit and xupperlimit works correctly");
  }

  {
    int status = 0;
    for (i = 0; i < N; i++)
      {
	double y0 = 0, y1 = 0;
	gsl_histogram2d_get_yrange (h, i, &y0, &y1);

	if (y0 != i || y1 != i + 1)
	  {
	    status = 1;
	  }
      }
    gsl_test (status, "gsl_histogram2d_get_ylowerlimit and yupperlimit works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_xmax (h) != M)
      status = 1;
    gsl_test (status, "gsl_histogram2d_xmax works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_xmin (h) != 0)
      status = 1;
    gsl_test (status, "gsl_histogram2d_xmin works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_nx (h) != M)
      status = 1;
    gsl_test (status, "gsl_histogram2d_nx works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_ymax (h) != N)
      status = 1;
    gsl_test (status, "gsl_histogram2d_ymax works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_ymin (h) != 0)
      status = 1;
    gsl_test (status, "gsl_histogram2d_ymin works correctly");
  }

  {
    int status = 0;
    if (gsl_histogram2d_ny (h) != N)
      status = 1;
    gsl_test (status, "gsl_histogram2d_ny works correctly");
  }

  h->bin[3*N+2] = 123456.0;
  h->bin[4*N+3] = -654321;

  {
    double max = gsl_histogram2d_max_val (h);
    gsl_test (max != 123456.0, "gsl_histogram2d_max_val finds maximum value");
  }

  {
    double min = gsl_histogram2d_min_val (h);
    gsl_test (min != -654321.0, "gsl_histogram2d_min_val finds minimum value");
  }

  {
    size_t imax, jmax;
    gsl_histogram2d_max_bin (h, &imax, &jmax);
    gsl_test (imax != 3 || jmax != 2, "gsl_histogram2d_max_bin finds maximum value bin");
  }

  {
    size_t imin, jmin;
    gsl_histogram2d_min_bin (h, &imin, &jmin);
    gsl_test (imin != 4 || jmin != 3, "gsl_histogram2d_min_bin find minimum value bin");
  }

  for (i = 0; i < M*N; i++)
    {
      h->bin[i] = i + 27;
      g->bin[i] = (i + 27) * (i + 1);
    }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_add (h1, h);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != g->bin[i] + h->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_add works correctly");
  }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_sub (h1, h);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != g->bin[i] - h->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_sub works correctly");
  }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_mul (h1, h);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != g->bin[i] * h->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_mul works correctly");
  }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_div (h1, h);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != g->bin[i] / h->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_div works correctly");
  }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_scale (h1, 0.5);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != 0.5 * g->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_scale works correctly");
  }

  gsl_histogram2d_memcpy (h1, g);
  gsl_histogram2d_shift (h1, 0.25);

  {
    int status = 0;
    for (i = 0; i < M*N; i++)
      {
	if (h1->bin[i] != 0.25 + g->bin[i])
	  status = 1;
      }
    gsl_test (status, "gsl_histogram2d_shift works correctly");
  }

  gsl_histogram2d_free (h);	/* free whatever is in h */

  h = gsl_histogram2d_calloc_uniform (M1, N1, 0.0, 5.0, 0.0, 5.0);

  gsl_test (h->xrange == 0,
	    "gsl_histogram2d_calloc_uniform returns valid range pointer");
  gsl_test (h->yrange == 0,
	    "gsl_histogram2d_calloc_uniform returns valid range pointer");
  gsl_test (h->bin == 0,
	    "gsl_histogram2d_calloc_uniform returns valid bin pointer");
  gsl_test (h->nx != M1,
	    "gsl_histogram2d_calloc_uniform returns valid nx");
  gsl_test (h->ny != N1,
	    "gsl_histogram2d_calloc_uniform returns valid ny");

  gsl_histogram2d_accumulate (h, 0.0, 3.01, 1.0);
  gsl_histogram2d_accumulate (h, 0.1, 2.01, 2.0);
  gsl_histogram2d_accumulate (h, 0.2, 1.01, 3.0);
  gsl_histogram2d_accumulate (h, 0.3, 0.01, 4.0);

  {
    size_t i1, i2, i3, i4;
    size_t j1, j2, j3, j4;
    double expected;
    int status;
    status = gsl_histogram2d_find (h, 0.0, 3.01, &i1, &j1);
    status = gsl_histogram2d_find (h, 0.1, 2.01, &i2, &j2);
    status = gsl_histogram2d_find (h, 0.2, 1.01, &i3, &j3);
    status = gsl_histogram2d_find (h, 0.3, 0.01, &i4, &j4);

    for (i = 0; i < M1; i++)
      {
	for (j = 0; j < N1; j++)
	  {
	    if (i == i1 && j == j1)
	      {
		expected = 1.0;
	      }
	    else if (i == i2 && j == j2)
	      {
		expected = 2.0;
	      }
	    else if (i == i3 && j == j3)
	      {
		expected = 3.0;
	      }
	    else if (i == i4 && j == j4)
	      {
		expected = 4.0;
	      }
	    else
	      {
		expected = 0.0;
	      }

	    if (h->bin[i * N1 + j] != expected)
	      {
		status = 1;
	      }
	  }
      }
    gsl_test (status, "gsl_histogram2d_find works correctly");
  }

  {
    FILE *f = fopen ("test.txt", "w");
    gsl_histogram2d_fprintf (f, h, "%.19g", "%.19g");
    fclose (f);
  }

  {
    FILE *f = fopen ("test.txt", "r");
    gsl_histogram2d *hh = gsl_histogram2d_calloc (M1, N1);
    int status = 0;

    gsl_histogram2d_fscanf (f, hh);

    for (i = 0; i <= M1; i++)
      {
	if (h->xrange[i] != hh->xrange[i])
	  {
	    printf ("xrange[%d] : %g orig vs %g\n",
		    (int)i, h->xrange[i], hh->xrange[i]);
	    status = 1;
	  }
      }

    for (j = 0; j <= N1; j++)
      {
	if (h->yrange[j] != hh->yrange[j])
	  {
	    printf ("yrange[%d] : %g orig vs %g\n",
		    (int)j, h->yrange[j], hh->yrange[j]);
	    status = 1;
	  }
      }

    for (i = 0; i < M1 * N1; i++)
      {
	if (h->bin[i] != hh->bin[i])
	  {
	    printf ("bin[%d] : %g orig vs %g\n",
		    (int)i, h->bin[i], hh->bin[i]);
	    status = 1;
	  }
      }

    gsl_test (status, "gsl_histogram2d_fprintf and fscanf work correctly");

    gsl_histogram2d_free (hh);
    fclose (f);
  }

  {
    FILE *f = fopen ("test.dat", "wb");
    gsl_histogram2d_fwrite (f, h);
    fclose (f);
  }

  {
    FILE *f = fopen ("test.dat", "rb");
    gsl_histogram2d *hh = gsl_histogram2d_calloc (M1, N1);
    int status = 0;

    gsl_histogram2d_fread (f, hh);

    for (i = 0; i <= M1; i++)
      {
	if (h->xrange[i] != hh->xrange[i])
	  {
	    printf ("xrange[%d] : %g orig vs %g\n",
		    (int)i, h->xrange[i], hh->xrange[i]);
	    status = 1;
	  }
      }

    for (j = 0; j <= N1; j++)
      {
	if (h->yrange[j] != hh->yrange[j])
	  {
	    printf ("yrange[%d] : %g orig vs %g\n",
		    (int)j, h->yrange[j], hh->yrange[j]);
	    status = 1;
	  }
      }

    for (i = 0; i < M1 * N1; i++)
      {
	if (h->bin[i] != hh->bin[i])
	  {
	    printf ("bin[%d] : %g orig vs %g\n",
		    (int)i, h->bin[i], hh->bin[i]);
	    status = 1;
	  }
      }

    gsl_test (status, "gsl_histogram2d_fwrite and fread work correctly");

    gsl_histogram2d_free (hh);
    fclose (f);
  }

  gsl_histogram2d_free (h);
  gsl_histogram2d_free (h1);
  gsl_histogram2d_free (g);
  gsl_histogram2d_free (hr);

  exit (gsl_test_summary ());
}


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

#include <config.h>

#include <stddef.h>
#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <float.h>

#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_multifit_nlin.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_permutation.h>

typedef struct
  {
    size_t iter;
    double xnorm;
    double fnorm;
    double delta;
    double par;
    gsl_matrix *J;             /* Jacobian matrix */
    gsl_matrix *r;             /* R matrix in J = Q R P^T */
    gsl_vector *tau;
    gsl_vector *diag;          /* scaling matrix D = diag(d1,...,dp) */
    gsl_vector *qtf;           /* Q^T f */
    gsl_vector *newton;
    gsl_vector *gradient;      /* gradient g = J^T f */
    gsl_vector *x_trial;       /* trial step x + dx */
    gsl_vector *f_trial;       /* trial function f(x + dx) */
    gsl_vector *df;
    gsl_vector *sdiag;
    gsl_vector *rptdx;
    const gsl_vector *weights; /* data weights */
    gsl_vector *w;
    gsl_vector *work1;
    gsl_permutation * perm;
  }
lmder_state_t;

static int lmder_alloc (void *vstate, size_t n, size_t p);
static int lmder_set (void *vstate, const gsl_vector * swts, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_vector * dx);
static int lmsder_set (void *vstate, const gsl_vector * swts, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_vector * dx);
static int set (void *vstate, const gsl_vector * swts, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale);
static int lmder_iterate (void *vstate, const gsl_vector * swts, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_vector * dx);
static void lmder_free (void *vstate);
static int iterate (void *vstate, const gsl_vector * swts, gsl_multifit_function_fdf * fdf, gsl_vector * x, gsl_vector * f, gsl_vector * dx, int scale);

#include "lmutil.c"
#include "lmpar.c"
#include "lmset.c"
#include "lmiterate.c"

static int
lmder_alloc (void *vstate, size_t n, size_t p)
{
  lmder_state_t *state = (lmder_state_t *) vstate;
  gsl_matrix *r, *J;
  gsl_vector *tau, *diag, *qtf, *newton, *gradient, *x_trial, *f_trial,
   *df, *sdiag, *rptdx, *w, *work1;
  gsl_permutation *perm;

  J = gsl_matrix_alloc (n, p);

  if (J == 0)
    {
      GSL_ERROR ("failed to allocate space for J", GSL_ENOMEM);
    }

  state->J = J;

  r = gsl_matrix_alloc (n, p);

  if (r == 0)
    {
      GSL_ERROR ("failed to allocate space for r", GSL_ENOMEM);
    }

  state->r = r;

  tau = gsl_vector_calloc (GSL_MIN(n, p));

  if (tau == 0)
    {
      gsl_matrix_free (r);

      GSL_ERROR ("failed to allocate space for tau", GSL_ENOMEM);
    }

  state->tau = tau;

  diag = gsl_vector_calloc (p);

  if (diag == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);

      GSL_ERROR ("failed to allocate space for diag", GSL_ENOMEM);
    }

  state->diag = diag;

  qtf = gsl_vector_calloc (n);

  if (qtf == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);

      GSL_ERROR ("failed to allocate space for qtf", GSL_ENOMEM);
    }

  state->qtf = qtf;

  newton = gsl_vector_calloc (p);

  if (newton == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);

      GSL_ERROR ("failed to allocate space for newton", GSL_ENOMEM);
    }

  state->newton = newton;

  gradient = gsl_vector_calloc (p);

  if (gradient == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);

      GSL_ERROR ("failed to allocate space for gradient", GSL_ENOMEM);
    }

  state->gradient = gradient;

  x_trial = gsl_vector_calloc (p);

  if (x_trial == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);

      GSL_ERROR ("failed to allocate space for x_trial", GSL_ENOMEM);
    }

  state->x_trial = x_trial;

  f_trial = gsl_vector_calloc (n);

  if (f_trial == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);

      GSL_ERROR ("failed to allocate space for f_trial", GSL_ENOMEM);
    }

  state->f_trial = f_trial;

  df = gsl_vector_calloc (n);

  if (df == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);

      GSL_ERROR ("failed to allocate space for df", GSL_ENOMEM);
    }

  state->df = df;

  sdiag = gsl_vector_calloc (p);

  if (sdiag == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);
      gsl_vector_free (df);

      GSL_ERROR ("failed to allocate space for sdiag", GSL_ENOMEM);
    }

  state->sdiag = sdiag;

  rptdx = gsl_vector_calloc (n);

  if (rptdx == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);
      gsl_vector_free (df);
      gsl_vector_free (sdiag);

      GSL_ERROR ("failed to allocate space for rptdx", GSL_ENOMEM);
    }

  state->rptdx = rptdx;

  w = gsl_vector_calloc (n);

  if (w == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);
      gsl_vector_free (df);
      gsl_vector_free (sdiag);
      gsl_vector_free (rptdx);

      GSL_ERROR ("failed to allocate space for w", GSL_ENOMEM);
    }

  state->w = w;

  work1 = gsl_vector_calloc (p);

  if (work1 == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);
      gsl_vector_free (df);
      gsl_vector_free (sdiag);
      gsl_vector_free (rptdx);
      gsl_vector_free (w);

      GSL_ERROR ("failed to allocate space for work1", GSL_ENOMEM);
    }

  state->work1 = work1;

  perm = gsl_permutation_calloc (p);

  if (perm == 0)
    {
      gsl_matrix_free (r);
      gsl_vector_free (tau);
      gsl_vector_free (diag);
      gsl_vector_free (qtf);
      gsl_vector_free (newton);
      gsl_vector_free (gradient);
      gsl_vector_free (x_trial);
      gsl_vector_free (f_trial);
      gsl_vector_free (df);
      gsl_vector_free (sdiag);
      gsl_vector_free (rptdx);
      gsl_vector_free (w);
      gsl_vector_free (work1);

      GSL_ERROR ("failed to allocate space for perm", GSL_ENOMEM);
    }

  state->perm = perm;

  return GSL_SUCCESS;
}

static int
lmder_set (void *vstate, const gsl_vector * swts,
           gsl_multifit_function_fdf * fdf, gsl_vector * x,
           gsl_vector * f, gsl_vector * dx)
{
  int status = set (vstate, swts, fdf, x, f, dx, 0);
  return status ;
}

static int
lmsder_set (void *vstate, const gsl_vector * swts,
            gsl_multifit_function_fdf * fdf, gsl_vector * x,
            gsl_vector * f, gsl_vector * dx)
{
  int status = set (vstate, swts, fdf, x, f, dx, 1);
  return status ;
}

static int
lmder_iterate (void *vstate, const gsl_vector * swts,
               gsl_multifit_function_fdf * fdf, gsl_vector * x,
               gsl_vector * f, gsl_vector * dx)
{
  int status = iterate (vstate, swts, fdf, x, f, dx, 0);
  return status;
}

static int
lmsder_iterate (void *vstate, const gsl_vector * swts,
                gsl_multifit_function_fdf * fdf, gsl_vector * x,
                gsl_vector * f, gsl_vector * dx)
{
  int status = iterate (vstate, swts, fdf, x, f, dx, 1);
  return status;
}

static int
lmder_gradient (void *vstate, gsl_vector * g)
{
  lmder_state_t *state = (lmder_state_t *) vstate;
  compute_gradient(state->r, state->qtf, g);
  return GSL_SUCCESS;
}

static int
lmder_jac (void *vstate, gsl_matrix * J)
{
  lmder_state_t *state = (lmder_state_t *) vstate;
  int s = gsl_matrix_memcpy(J, state->J);

  return s;
}

static void
lmder_free (void *vstate)
{
  lmder_state_t *state = (lmder_state_t *) vstate;

  if (state->perm)
    gsl_permutation_free (state->perm);

  if (state->work1)
    gsl_vector_free (state->work1);

  if (state->w)
    gsl_vector_free (state->w);

  if (state->rptdx)
    gsl_vector_free (state->rptdx);

  if (state->sdiag)
    gsl_vector_free (state->sdiag);

  if (state->df)
    gsl_vector_free (state->df);

  if (state->f_trial)
    gsl_vector_free (state->f_trial);

  if (state->x_trial)
    gsl_vector_free (state->x_trial);

  if (state->gradient)
    gsl_vector_free (state->gradient);

  if (state->newton)
    gsl_vector_free (state->newton);

  if (state->qtf)
    gsl_vector_free (state->qtf);

  if (state->diag)
    gsl_vector_free (state->diag);

  if (state->tau)
    gsl_vector_free (state->tau);

  if (state->r)
    gsl_matrix_free (state->r);

  if (state->J)
    gsl_matrix_free (state->J);
}

static const gsl_multifit_fdfsolver_type lmder_type =
{
  "lmder",                      /* name */
  sizeof (lmder_state_t),
  &lmder_alloc,
  &lmder_set,
  &lmder_iterate,
  &lmder_gradient,
  &lmder_jac,
  &lmder_free
};

static const gsl_multifit_fdfsolver_type lmsder_type =
{
  "lmsder",                     /* name */
  sizeof (lmder_state_t),
  &lmder_alloc,
  &lmsder_set,
  &lmsder_iterate,
  &lmder_gradient,
  &lmder_jac,
  &lmder_free
};

const gsl_multifit_fdfsolver_type *gsl_multifit_fdfsolver_lmder = &lmder_type;
const gsl_multifit_fdfsolver_type *gsl_multifit_fdfsolver_lmsder = &lmsder_type;


/* wavelet/dwt.c
 *
 * Copyright (C) 2004 Ivo Alxneit
 *
 * 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.
 */

/* function dwt_step is based on the public domain function pwt.c
 * available from http://www.numerical-recipes.com
 */

#include <config.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_wavelet.h>
#include <gsl/gsl_wavelet2d.h>

#define ELEMENT(a,stride,i) ((a)[(stride)*(i)])

static int binary_logn (const size_t n);
static void dwt_step (const gsl_wavelet * w, double *a, size_t stride, size_t n, gsl_wavelet_direction dir, gsl_wavelet_workspace * work);

static int
binary_logn (const size_t n)
{
  size_t ntest;
  size_t logn = 0;
  size_t k = 1;

  while (k < n)
    {
      k *= 2;
      logn++;
    }

  ntest = ((size_t)1 << logn);

  if (n != ntest)
    {
      return -1;                /* n is not a power of 2 */
    }

  return logn;
}

static void
dwt_step (const gsl_wavelet * w, double *a, size_t stride, size_t n,
          gsl_wavelet_direction dir, gsl_wavelet_workspace * work)
{
  double ai, ai1;
  size_t i, ii;
  size_t jf;
  size_t k;
  size_t n1, ni, nh, nmod;

  for (i = 0; i < work->n; i++)
    {
      work->scratch[i] = 0.0;
    }

  nmod = w->nc * n;
  nmod -= w->offset;            /* center support */

  n1 = n - 1;
  nh = n >> 1;

  if (dir == gsl_wavelet_forward)
    {
      for (ii = 0, i = 0; i < n; i += 2, ii++)
        {
          double h = 0, g = 0;

          ni = i + nmod;

          for (k = 0; k < w->nc; k++)
            {
              jf = n1 & (ni + k);
              h += w->h1[k] * ELEMENT (a, stride, jf);
              g += w->g1[k] * ELEMENT (a, stride, jf);
            }

          work->scratch[ii] += h;
          work->scratch[ii + nh] += g;
        }
    }
  else
    {
      for (ii = 0, i = 0; i < n; i += 2, ii++)
        {
          ai = ELEMENT (a, stride, ii);
          ai1 = ELEMENT (a, stride, ii + nh);
          ni = i + nmod;
          for (k = 0; k < w->nc; k++)
            {
              jf = (n1 & (ni + k));
              work->scratch[jf] += (w->h2[k] * ai + w->g2[k] * ai1);
            }
        }
    }

  for (i = 0; i < n; i++)
    {
      ELEMENT (a, stride, i) = work->scratch[i];
    }
}

int
gsl_wavelet_transform (const gsl_wavelet * w,
                       double *data, size_t stride, size_t n,
                       gsl_wavelet_direction dir,
                       gsl_wavelet_workspace * work)
{
  size_t i;

  if (work->n < n)
    {
      GSL_ERROR ("not enough workspace provided", GSL_EINVAL);
    }

  if (binary_logn (n) == -1)
    {
      GSL_ERROR ("n is not a power of 2", GSL_EINVAL);
    }

  if (n < 2)
    {
      return GSL_SUCCESS;
    }

  if (dir == gsl_wavelet_forward)
    {
      for (i = n; i >= 2; i >>= 1)
        {
          dwt_step (w, data, stride, i, dir, work);
        }
    }
  else
    {
      for (i = 2; i <= n; i <<= 1)
        {
          dwt_step (w, data, stride, i, dir, work);
        }
    }

  return GSL_SUCCESS;
}

int
gsl_wavelet_transform_forward (const gsl_wavelet * w,
                               double *data, size_t stride, size_t n,
                               gsl_wavelet_workspace * work)
{
  return gsl_wavelet_transform (w, data, stride, n, gsl_wavelet_forward, work);
}

int
gsl_wavelet_transform_inverse (const gsl_wavelet * w,
                               double *data, size_t stride, size_t n,
                               gsl_wavelet_workspace * work)
{
  return gsl_wavelet_transform (w, data, stride, n, gsl_wavelet_backward, work);
}

/* Leaving this out for now BJG */
#if 0
int
gsl_dwt_vector (const gsl_wavelet * w, gsl_vector *v, gsl_wavelet_direction
                dir, gsl_wavelet_workspace * work)
{
  return gsl_dwt (w, v->data, v->stride, v->size, dir, work);
}
#endif

int
gsl_wavelet2d_transform (const gsl_wavelet * w,
                         double *data, size_t tda, size_t size1,
                         size_t size2, gsl_wavelet_direction dir,
                         gsl_wavelet_workspace * work)
{
  size_t i;

  if (size1 != size2)
    {
      GSL_ERROR ("2d dwt works only with square matrix", GSL_EINVAL);
    }

  if (work->n < size1)
    {
      GSL_ERROR ("not enough workspace provided", GSL_EINVAL);
    }

  if (binary_logn (size1) == -1)
    {
      GSL_ERROR ("n is not a power of 2", GSL_EINVAL);
    }

  if (size1 < 2)
    {
      return GSL_SUCCESS;
    }

  if (dir == gsl_wavelet_forward)
    {
      for (i = 0; i < size1; i++)       /* for every row j */
        {
          gsl_wavelet_transform (w, &ELEMENT(data, tda, i), 1, size1, dir, work);
        }
      for (i = 0; i < size2; i++)       /* for every column j */
        {
          gsl_wavelet_transform (w, &ELEMENT(data, 1, i), tda, size2, dir, work);
        }
    }
  else
    {
      for (i = 0; i < size2; i++)       /* for every column j */
        {
          gsl_wavelet_transform (w, &ELEMENT(data, 1, i), tda, size2, dir, work);
        }
      for (i = 0; i < size1; i++)       /* for every row j */
        {
          gsl_wavelet_transform (w, &ELEMENT(data, tda, i), 1, size1, dir, work);
        }
    }

  return GSL_SUCCESS;
}

int
gsl_wavelet2d_nstransform (const gsl_wavelet * w,
                           double *data, size_t tda, size_t size1,
                           size_t size2, gsl_wavelet_direction dir,
                           gsl_wavelet_workspace * work)
{
  size_t i, j;

  if (size1 != size2)
    {
      GSL_ERROR ("2d dwt works only with square matrix", GSL_EINVAL);
    }

  if (work->n < size1)
    {
      GSL_ERROR ("not enough workspace provided", GSL_EINVAL);
    }

  if (binary_logn (size1) == -1)
    {
      GSL_ERROR ("n is not a power of 2", GSL_EINVAL);
    }

  if (size1 < 2)
    {
      return GSL_SUCCESS;
    }

  if (dir == gsl_wavelet_forward)
    {
      for (i = size1; i >= 2; i >>= 1)
        {
          for (j = 0; j < i; j++)       /* for every row j */
            {
              dwt_step (w, &ELEMENT(data, tda, j), 1, i, dir, work);
            }
          for (j = 0; j < i; j++)       /* for every column j */
            {
              dwt_step (w, &ELEMENT(data, 1, j), tda, i, dir, work);
            }
        }
    }
  else
    {
      for (i = 2; i <= size1; i <<= 1)
        {
          for (j = 0; j < i; j++)       /* for every column j */
            {
              dwt_step (w, &ELEMENT(data, 1, j), tda, i, dir, work);
            }
          for (j = 0; j < i; j++)       /* for every row j */
            {
              dwt_step (w, &ELEMENT(data, tda, j), 1, i, dir, work);
            }
        }
    }

  return GSL_SUCCESS;
}

int
gsl_wavelet2d_transform_forward (const gsl_wavelet * w,
                                 double *data, size_t tda, size_t size1,
                                 size_t size2, gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_transform (w, data, tda, size1, size2, gsl_wavelet_forward, work);
}

int
gsl_wavelet2d_transform_inverse (const gsl_wavelet * w,
                                  double *data, size_t tda, size_t size1,
                                  size_t size2, gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_transform (w, data, tda, size1, size2, gsl_wavelet_backward, work);
}

int
gsl_wavelet2d_nstransform_forward (const gsl_wavelet * w,
                                 double *data, size_t tda, size_t size1,
                                 size_t size2, gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_nstransform (w, data, tda, size1, size2, gsl_wavelet_forward, work);
}

int
gsl_wavelet2d_nstransform_inverse (const gsl_wavelet * w,
                                  double *data, size_t tda, size_t size1,
                                  size_t size2, gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_nstransform (w, data, tda, size1, size2, gsl_wavelet_backward, work);
}

int
gsl_wavelet2d_transform_matrix (const gsl_wavelet * w,
                                gsl_matrix * a,
                                gsl_wavelet_direction dir,
                                gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_transform (w, a->data,
                                  a->tda, a->size1, a->size2,
                                  dir, work);
}

int
gsl_wavelet2d_transform_matrix_forward (const gsl_wavelet * w,
                                        gsl_matrix * a,
                                        gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_transform (w, a->data,
                                  a->tda, a->size1, a->size2,
                                  gsl_wavelet_forward, work);
}

int
gsl_wavelet2d_transform_matrix_inverse (const gsl_wavelet * w,
                                        gsl_matrix * a,
                                        gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_transform (w, a->data,
                                  a->tda, a->size1, a->size2,
                                  gsl_wavelet_backward, work);
}

int
gsl_wavelet2d_nstransform_matrix (const gsl_wavelet * w,
                                gsl_matrix * a,
                                gsl_wavelet_direction dir,
                                gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_nstransform (w, a->data,
                                    a->tda, a->size1, a->size2,
                                    dir, work);
}

int
gsl_wavelet2d_nstransform_matrix_forward (const gsl_wavelet * w,
                                        gsl_matrix * a,
                                        gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_nstransform (w, a->data,
                                    a->tda, a->size1, a->size2,
                                    gsl_wavelet_forward, work);
}

int
gsl_wavelet2d_nstransform_matrix_inverse (const gsl_wavelet * w,
                                        gsl_matrix * a,
                                        gsl_wavelet_workspace * work)
{
  return gsl_wavelet2d_nstransform (w, a->data,
                                    a->tda, a->size1, a->size2,
                                    gsl_wavelet_backward, work);
}


#ifndef _MATH_FUNCTIONS_H_
#define _MATH_FUNCTIONS_H_

extern "C" {
#include <cblas.h>
}
#include <math.h>
#include <xmmintrin.h>
//#include <omp.h>
#include <cublas_v2.h>
#include "arena.h"

void cpu_rearrange(int batch_size, int input_dim, int num_blocks,
                  const float *T, float *X);
void gpu_rearrange(int batcch_size, int input_dim, int num_blocks,
                  const float *T, float *X);

void svd2x2(const float a[4], float u[4], float s[2], float v[4]);
void matmulcomplex2x2(const float A[8], const float B[8], float C[8]);
void conjugate_transpose2x2(float M[8]);
void conjugate_transpose2x2(const float M[8], float R[8]);
void cpu_complex_modulus_interleaved_relu(int M, int N, const float *X,
                                          const float* b, float* Y);

void cpu_permute_forward(int N,  const float*X, const int* PI,
                         float* Y);

void cpu_permute_backward(int N,  const float*X, const int* PI,
                          float* Y);

void cpu_diag_gemm(int M, int N, float alpha,  const float* X,
                   const float* W, float beta, float *Y );
void gpu_diag_gemm(int M, int N, float alpha, const float* X,
                   const float* W, float beta, float *Y );

void cpu_permute(int M, int N, const float* PI,
                const float* X, float* Y);

void gpu_permute(int M, int N, const float* PI,
                const float* X, float* Y);

float cpu_relative_error(int N,  const float* grad_ptr,
                         const float* numer_grad_ptr);

void gpu_real_svd(int M, int N, float *A,
                 float *U, float *S, float *V);
void gpu_unitary_svd(int M, int N, float *A,
                 float *U, float *S, float *V);
void gpu_random_orthogonal_matrix(int N, float *W);
void gpu_random_unitary_matrix(int N, float *W);

void cpu_initialize_svd2x2(int N, float* W);
void cpu_initialize_complexsvd2x2(int N, float* W);
void cpu_initialize_unitary(int NF, int* factor_sizes,  float *W);
void cpu_initialize_orthogonal(int NF, int* factor_sizes,  float *W);
void gpu_initialize_unitary(int NF, int* factor_sizes,  float *W);
void gpu_initialize_orthogonal(int NF, int* factor_sizes,  float *W);
void cpu_initialize_glorot10(int NF, int* factor_sizes,  float *W);
float cpu_complexdet2x2(const float W[8], float D[2]);
void cpu_gemm(const CBLAS_TRANSPOSE TransA,
              const CBLAS_TRANSPOSE TransB, int M, int N, int K,
              const float alpha, const float* A, const float* B, const float beta,
              float* C);
void gpu_gemm(const CBLAS_TRANSPOSE TransA,
              const CBLAS_TRANSPOSE TransB, int M, int N, int K,
              const float alpha, const float* A, const float* B, const float beta,
              float* C);

void cpu_complex_gemm(const CBLAS_TRANSPOSE TransA,
                      const CBLAS_TRANSPOSE TransB, int M, int N, int K,
                      const float alpha, const float* A, const float* B,
                      const float beta, float* C);

void cpu_real_complex_gemm(const CBLAS_TRANSPOSE TransA,
                           const CBLAS_TRANSPOSE TransB, int M, int N, int K,
                           const float alpha, const float* A, const float* B,
                           const float beta, float* C);

void gpu_complex_gemm(const CBLAS_TRANSPOSE TransA,
                      const CBLAS_TRANSPOSE TransB, int M, int N, int K,
                      const float alpha, const float* A, const float* B,
                      const float beta, float* C);

void gpu_real_complex_gemm(const CBLAS_TRANSPOSE TransA,
                           const CBLAS_TRANSPOSE TransB, int M, int N, int K,
                           const float alpha, const float* A, const float* B,
                           const float beta, float* C);

//Y = X + a * I
void gpu_apx(int N, float a,  const float* X, float* Y);

void gpu_complex_apx(int N, float a,  const float* X, float* Y);

void gpu_geam(const CBLAS_TRANSPOSE TransA, const CBLAS_TRANSPOSE TransB,
              int m, int n, const float *alpha, const float *A,
              const float *beta, const float *B, float *C);

void cpu_gemv(const CBLAS_TRANSPOSE TransA, int M, int N,
              const float alpha, const float* A, const float* x, const float beta,
              float* y);
void gpu_gemv(const CBLAS_TRANSPOSE TransA, int M, int N,
              const float alpha, const float* A, const float* x, const float beta,
              float* y);
void cpu_axpy(int N, const float alpha, const float* X,
              float* Y);
void gpu_axpy(int N, const float alpha, const float* X,
              float* Y);
void gpu_complex_axpy(int N, const float alpha, const float* X,
                      float* Y);
void cpu_addscalar(int N, const float alpha, const float* X,
                   float* Y);
void gpu_addscalar(int N, const float alpha, const float* X,
                   float* Y);
void cpu_axpby(int N, const float alpha, const float* X,
               const float beta, float* Y);
void gpu_axpby(int N, const float alpha, const float* X,
               const float beta, float* Y);
void cpu_copy(int N, const float *X, float *Y);
void gpu_copy(int N, const float *X, float *Y);
void cpu_scal(int N, const float alpha, float *X);
float cpu_max(int N, const float *X);
int cpu_max_index(int N, const float *X);
void cpu_exp(int N, const float *X, float *Y);
void gpu_exp(int N, const float *X, float *Y);
void cpu_dexp(int N, const float *in_data, const float *in_diff, float *out);
void cpu_tanh(int N, const float *X, float *Y);
void gpu_tanh(int N, const float *X, float *Y);

void cpu_sin(int N, const float *X, float *Y);
void gpu_sin(int N, const float *X, float *Y);

void cpu_cos(int N, const float *X, float *Y);
void gpu_cos(int N, const float *X, float *Y);

void cpu_dtanh(int N, const float *in_data, const float *in_diff, float *out);
void gpu_dtanh(int N, const float *in_data, const float *in_diff, float *out);

void cpu_sigmoid(int N, const float *X, float *Y);
void gpu_sigmoid(int N, const float *X, float *Y);
void cpu_dsigmoid(int N, const float *in_data, const float *in_diff, float *out);
void gpu_dsigmoid(int N, const float *in_data, const float *in_diff, float *out);

void cpu_hadamard(int M, int N, float *X);
void gpu_hadamard(int M, int N, float *X);

void cpu_complex_modulus_relu(int M, int N, const float  *X, const float* b, float* Y);
void cpu_complex_modulus_drelu(int M, int N, const float  *X,
                               const float* b, const float* gradY, float* gradX,
                               float* gradb);
void cpu_complex_modulus_tanh(int M, int N, const float  *X, const float* b, float* Y);
void cpu_complex_modulus_dtanh(int M, int N, const float  *X,
                               const float* b, const float* gradY, float* gradX,
                               float* gradb);
/*
    From Efficient backprop, Yann Lecun, Leon Bottou 1998
*/
void cpu_lecun98(int N, int fan_in, float *x);
void gpu_lecun98(int N, int fan_in, float *x);
/*
    From Understanding the diffcuilt of traing neural nets, Xavier Glorot, Yoshua Bengio : AISTATS 2010
*/
void cpu_glorot10(int fan_in, int fan_out, float *x);
void gpu_glorot10(int fan_in, int fan_out, float *x);
/*
    From Delving deep into rectifiers, Kaiming He Xiangyu Zhang Shaoqing Ren Jian Sun:  Arxiv 2015
*/

void cpu_he15(int N, int fan_in, float *x);
void cpu_allzero(int N, float *x);
void cpu_normal(int N, const float mean, const float stddev, float *x);
void cpu_uniform(int N, const float r1, const float r2, float *x);
void gpu_uniform(int N, const float r1, const float r2, float *x);
void gpu_he15(int N, int fan_in, float *x);
void gpu_allzero(int N, float *x);
void gpu_normal(int N, const float mean, const float stddev, float *x);
void cpu_log(int N, const float *X, float *Y);
void gpu_log(int N, const float *X, float *Y);
void cpu_sqr(int N, const float *X, float *Y);
void gpu_sqr(int N, const float *X, float *Y);
void cpu_abs(int N, const float *X, float *Y);
void cpu_clip(int N, const float *X, const float p, float *Y);
void gpu_clip(int N, const float *X, const float p, float *Y);
void cpu_pow(int N, const float *X, const float p, float *Y);
void gpu_pow(int N, const float *X, const float p, float *Y);
void gpu_scal(int N, const float alpha, float *X);
float cpu_dot(int n, const float* x, const float* y);
void cpu_add(int N, const float* a, const float* b, float* y);
void gpu_add(int N, const float* a, const float* b, float* y);
void gpu_mul(int N, const float* a, const float* b, float* y);
void cpu_mul(int N, const float* a, const float* b, float* y);
void gpu_div(int N, const float* a, const float* b, float* y);
void cpu_div(int N, const float* a, const float* b, float* y);
void gpu_fill(int N, const float a, float* y);
void cpu_fill(int N, const float a, float* y);
float cpu_max(int N, const float* y);
float cpu_nrm2(int N, const float* y);
float gpu_nrm2(int N, const float* y);
float cpu_min(int N, const float* y);
float gpu_dot(int n, const float* x, const float* y);

void cpu_chi(int N, int dof, float* x);
void gpu_chi(int N, int dof, float* x);

void cpu_rademacher(int N, float* x);
void gpu_rademacher(int N, float* x);

void cpu_permutation_array(int N, float* x);
void gpu_permutation_array(int N, float* x);

inline void cblas_saxpby(int N, const float alpha, const float* X,
                         int incX, const float beta, float* Y,
                         int incY) {
  cblas_sscal(N, beta, Y, incY);
  cblas_saxpy(N, alpha, X, incX, Y, incY);
}

#endif


#include <petsc.h>
#include <petscts2.h>

#if PETSC_VERSION_LE(3,3,0)
#define TSRegister(s,f) TSRegister(s,0,0,f)
#endif

typedef struct {
  PetscReal Omega; /* frequency */
  PetscReal Xi;    /* damping   */
} UserParams;

#undef  __FUNCT__
#define __FUNCT__ "Residual1"
PetscErrorCode Residual1(TS ts,PetscReal t,Vec X,Vec A,Vec R,void *ctx)
{
  UserParams *user = (UserParams *)ctx;
  PetscReal Omega = user->Omega;
  PetscScalar *x,*a,*r;
  PetscErrorCode ierr;
  PetscFunctionBegin;

  ierr = VecGetArray(X,&x);CHKERRQ(ierr);
  ierr = VecGetArray(A,&a);CHKERRQ(ierr);
  ierr = VecGetArray(R,&r);CHKERRQ(ierr);

  r[0] = a[0] + (Omega*Omega)*x[0];

  ierr = VecRestoreArray(X,&x);CHKERRQ(ierr);
  ierr = VecRestoreArray(A,&a);CHKERRQ(ierr);
  ierr = VecRestoreArray(R,&r);CHKERRQ(ierr);

  ierr = VecAssemblyBegin(R);CHKERRQ(ierr);
  ierr = VecAssemblyEnd  (R);CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

#undef  __FUNCT__
#define __FUNCT__ "Tangent1"
PetscErrorCode Tangent1(TS ts,PetscReal t,Vec X,Vec A,PetscReal shiftA,Mat J,Mat P,void *ctx)
{
  UserParams *user = (UserParams *)ctx;
  PetscReal Omega = user->Omega;
  PetscReal T = 0;
  PetscErrorCode ierr;
  PetscFunctionBegin;

  T = shiftA + (Omega*Omega);

  ierr = MatSetValue(P,0,0,T,INSERT_VALUES);CHKERRQ(ierr);
  ierr = MatAssemblyBegin(P,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  ierr = MatAssemblyEnd  (P,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  if (J != P) {
    ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
    ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  }

  PetscFunctionReturn(0);
}
#if PETSC_VERSION_LT(3,5,0)
PetscErrorCode Tangent1_Legacy(TS ts,PetscReal t,Vec U,Vec V,PetscReal shift,Mat *J,Mat *P,MatStructure *m,void *ctx)
{*m = SAME_NONZERO_PATTERN; return Tangent1(ts,t,U,V,shift,*J,*P,ctx);}
#define Tangent1 Tangent1_Legacy
#endif

#undef  __FUNCT__
#define __FUNCT__ "Residual2"
PetscErrorCode Residual2(TS ts,PetscReal t,Vec X,Vec V,Vec A,Vec R,void *ctx)
{
  UserParams *user = (UserParams *)ctx;
  PetscReal Omega = user->Omega, Xi = user->Xi;
  PetscScalar *x,*v,*a,*r;
  PetscErrorCode ierr;
  PetscFunctionBegin;

  ierr = VecGetArray(X,&x);CHKERRQ(ierr);
  ierr = VecGetArray(V,&v);CHKERRQ(ierr);
  ierr = VecGetArray(A,&a);CHKERRQ(ierr);
  ierr = VecGetArray(R,&r);CHKERRQ(ierr);

  r[0] = a[0] + (2*Xi*Omega)*v[0] + (Omega*Omega)*x[0];

  ierr = VecRestoreArray(X,&x);CHKERRQ(ierr);
  ierr = VecRestoreArray(V,&v);CHKERRQ(ierr);
  ierr = VecRestoreArray(A,&a);CHKERRQ(ierr);
  ierr = VecRestoreArray(R,&r);CHKERRQ(ierr);

  ierr = VecAssemblyBegin(R);CHKERRQ(ierr);
  ierr = VecAssemblyEnd  (R);CHKERRQ(ierr);

  PetscFunctionReturn(0);
}

#undef  __FUNCT__
#define __FUNCT__ "Tangent2"
PetscErrorCode Tangent2(TS ts,PetscReal t,Vec X,Vec V,Vec A,PetscReal shiftV,PetscReal shiftA,Mat J,Mat P,void *ctx)
{
  UserParams *user = (UserParams *)ctx;
  PetscReal Omega = user->Omega, Xi = user->Xi;
  PetscReal T = 0;
  PetscErrorCode ierr;
  PetscFunctionBegin;

  T = shiftA + shiftV * (2*Xi*Omega) + (Omega*Omega);

  ierr = MatSetValue(P,0,0,T,INSERT_VALUES);CHKERRQ(ierr);
  ierr = MatAssemblyBegin(P,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  ierr = MatAssemblyEnd  (P,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  if (J != P) {
    ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
    ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
  }

  PetscFunctionReturn(0);
}

#undef  __FUNCT__
#define __FUNCT__ "Monitor"
PetscErrorCode Monitor(TS ts,PetscInt i,PetscReal t,Vec U,void *ctx)
{
  const char *filename = (const char *)ctx;
  static FILE *fp = 0;
  Vec X,V;
  const PetscScalar *x,*v;
  TSConvergedReason reason;
  PetscErrorCode ierr;
  PetscFunctionBegin;
  if (i<0) PetscFunctionReturn(0); /*XXX temporary petsc-dev fix */

  if (!fp) {ierr = PetscFOpen(PETSC_COMM_SELF,filename,"w",&fp);CHKERRQ(ierr);}
  ierr = TSGetSolution2(ts,&X,&V);CHKERRQ(ierr);
  ierr = VecGetArrayRead(X,&x);CHKERRQ(ierr);
  ierr = VecGetArrayRead(V,&v);CHKERRQ(ierr);
  ierr = PetscFPrintf(PETSC_COMM_SELF,fp,"%g %g %g\n",(double)t,(double)x[0],(double)v[0]);CHKERRQ(ierr);
  ierr = VecRestoreArrayRead(X,&x);CHKERRQ(ierr);
  ierr = VecRestoreArrayRead(V,&v);CHKERRQ(ierr);
  ierr = TSGetConvergedReason(ts,&reason); CHKERRQ(ierr);
  if (reason) {ierr = PetscFClose(PETSC_COMM_SELF,fp);CHKERRQ(ierr); fp=0;}

  PetscFunctionReturn(0);
}

EXTERN_C_BEGIN
PetscErrorCode TSCreate_Alpha2(TS);
EXTERN_C_END

#undef  __FUNCT__
#define __FUNCT__ "main"
int main(int argc, char *argv[]) {

  TS             ts;
  Vec            R;
  Mat            J;
  Vec            X,V;
  PetscScalar    *x,*v;
  UserParams     user;
  PetscBool      out;
  char           output[PETSC_MAX_PATH_LEN] = {0};
  PetscErrorCode ierr;

  ierr = PetscInitialize(&argc,&argv,0,0);CHKERRQ(ierr);
  ierr = TSRegister(TSALPHA2,TSCreate_Alpha2);CHKERRQ(ierr);

  user.Omega = 1.0;
  user.Xi    = 0.0;
  ierr = PetscOptionsBegin(PETSC_COMM_SELF,"","Oscillator Options","TS");CHKERRQ(ierr);
  ierr = PetscOptionsReal("-frequency","Frequency",__FILE__,user.Omega,&user.Omega,NULL);CHKERRQ(ierr);
  ierr = PetscOptionsReal("-damping",  "Damping",  __FILE__,user.Xi,   &user.Xi,   NULL);CHKERRQ(ierr);
  ierr = PetscOptionsString("-output","Output",__FILE__,output,output,sizeof(output),&out);CHKERRQ(ierr);
  ierr = PetscOptionsEnd();CHKERRQ(ierr);
  if (out && !output[0]) {ierr = PetscStrcpy(output,"Oscillator.out");CHKERRQ(ierr);}

  ierr = TSCreate(PETSC_COMM_SELF,&ts);CHKERRQ(ierr);
  ierr = TSSetType(ts,TSALPHA2);CHKERRQ(ierr);
  ierr = TSSetDuration(ts,PETSC_MAX_INT,2*M_PI * 5);CHKERRQ(ierr);
  ierr = TSSetTimeStep(ts,0.01);CHKERRQ(ierr);

  ierr = VecCreateSeq(PETSC_COMM_SELF,1,&R);CHKERRQ(ierr);
  ierr = VecSetUp(R);CHKERRQ(ierr);
  ierr = MatCreateSeqDense(PETSC_COMM_SELF,1,1,NULL,&J);CHKERRQ(ierr);
  ierr = MatSetUp(J);CHKERRQ(ierr);
  if (user.Xi <= 0.0) {
    ierr = TSSetIFunction(ts,R,Residual1,&user);CHKERRQ(ierr);
    ierr = TSSetIJacobian(ts,J,J,Tangent1,&user);CHKERRQ(ierr);
  } else {
    ierr = TSSetIFunction2(ts,R,Residual2,&user);CHKERRQ(ierr);
    ierr = TSSetIJacobian2(ts,J,J,Tangent2,&user);CHKERRQ(ierr);
  }
  ierr = VecDestroy(&R);CHKERRQ(ierr);
  ierr = MatDestroy(&J);CHKERRQ(ierr);

  if (output[0]) {
    ierr = TSMonitorSet(ts,Monitor,output,NULL);CHKERRQ(ierr);
  }

  ierr = VecCreateSeq(PETSC_COMM_SELF,1,&X);CHKERRQ(ierr);
  ierr = VecCreateSeq(PETSC_COMM_SELF,1,&V);CHKERRQ(ierr);
  ierr = VecGetArray(X,&x);CHKERRQ(ierr);
  ierr = VecGetArray(V,&v);CHKERRQ(ierr);
  x[0] = 1.0;
  v[0] = 0.0;
  ierr = VecRestoreArray(X,&x);CHKERRQ(ierr);
  ierr = VecRestoreArray(V,&v);CHKERRQ(ierr);

  ierr = TSSetSolution2(ts,X,V);CHKERRQ(ierr);
  ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
  ierr = TSSolve2(ts,X,V);CHKERRQ(ierr);

  ierr = VecDestroy(&X);CHKERRQ(ierr);
  ierr = VecDestroy(&V);CHKERRQ(ierr);
  ierr = TSDestroy(&ts);CHKERRQ(ierr);
  ierr = PetscFinalize();CHKERRQ(ierr);

  return 0;
}


/**
 *
 * @file testing_ssygv.c
 *
 *  PLASMA testing routines
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Azzam Haidar
 * @author Hatem Ltaief
 * @date 2010-11-15
 * @generated s Tue Jan  7 11:45:18 2014
 *
 **/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>

#include <plasma.h>
#include <cblas.h>
#include <lapacke.h>
#include <core_blas.h>
#include "testing_smain.h"

#undef COMPLEX
#define REAL

static int check_orthogonality(int itype, int uplo, int N,
                               float *Z, int LDZ,
                               float *B, float *CHOLB, int LDB,
                               float eps);
static int check_reduction(int itype, int uplo, int N, float *D,
                           float *A, int LDA,
                           float *B, int LDB,
                           float *Z, int LDZ,
                           float eps );
static int check_solution(int N, float *E1, float *E2, float eps);

int testing_ssygv(int argc, char **argv)
{
    /* Check for number of arguments*/
    if (argc != 3) {
        USAGE("HEGV", "N LDA LDB",
              "   - N    : size of the matrices A and B\n"
              "   - LDA  : leading dimension of the matrix A\n"
              "   - LDB  : leading dimension of the matrix B\n");
        return -1;
    }

    float      eps = LAPACKE_slamch_work('e');
    PLASMA_enum vec = PlasmaVec;
    int    N        = atoi(argv[0]);
    int    LDA      = atoi(argv[1]);
    int    LDB      = atoi(argv[2]);
    int    LDQ      = LDA;
    int    LDAxN    = LDA*N;
    int    LDBxN    = LDB*N;
    int    LDQxN    = LDQ*N;

    int info_ortho     = 0;
    int info_solution  = 0;
    int info_reduction = 0;
    int i, u;

    float *A1    = (float *)malloc(LDAxN*sizeof(float));
    float *A2    = (float *)malloc(LDAxN*sizeof(float));
    float *B1    = (float *)malloc(LDBxN*sizeof(float));
    float *B2    = (float *)malloc(LDBxN*sizeof(float));
    float *Q     = (float *)malloc(LDQxN*sizeof(float));
    float *Ainit = (float *)malloc(LDAxN*sizeof(float));
    float *Binit = (float *)malloc(LDBxN*sizeof(float));
    float *W1 = (float *)malloc(N*sizeof(float));
    float *W2 = (float *)malloc(N*sizeof(float));
    float *work = (float *)malloc(3*N* sizeof(float));
    PLASMA_desc *T;

    /* Check if unable to allocate memory */
    if ((!A1)||(!A2)||(!B1)||(!B2)||(!Q)||(!Ainit)||(!Binit)){
        printf("Out of Memory \n ");
        return -2;
    }

    PLASMA_Disable(PLASMA_AUTOTUNING);
    PLASMA_Set(PLASMA_TILE_SIZE, 120);
    PLASMA_Set(PLASMA_INNER_BLOCK_SIZE, 20);

    PLASMA_Enable(PLASMA_WARNINGS);
    PLASMA_Enable(PLASMA_ERRORS);
    PLASMA_Alloc_Workspace_ssygv(N, N, &T);

    /*----------------------------------------------------------
    *  TESTING SSYGV
    */
    /* Initialize A1 and Ainit */
    PLASMA_splgsy(0., N, A1, LDA, 5198);
    PLASMA_slacpy(PlasmaUpperLower, N, N, A1, LDA, Ainit, LDA);

    /* Initialize B1 and Binit */
    PLASMA_splgsy((float)N, N, B1, LDB, 4321 );
    PLASMA_slacpy(PlasmaUpperLower, N, N, B1, LDB, Binit, LDB);

    printf("\n");
    printf("------ TESTS FOR PLASMA SSYGV ROUTINE -------  \n");
    printf("        Size of the Matrix %d by %d\n", N, N);
    printf("\n");
    printf(" The matrix A is randomly generated for each test.\n");
    printf("============\n");
    printf(" The relative machine precision (eps) is to be %e \n",eps);
    printf(" Computational tests pass if scaled residuals are less than 60.\n");

    /*----------------------------------------------------------
     *  TESTING SSYGV
     */

    for (i=0; i<3; i++) {
        for (u=0; u<2; u++) {
            memcpy(A2, Ainit, LDAxN*sizeof(float));
            memcpy(B2, Binit, LDBxN*sizeof(float));
            /* CALL SSYGV with itype= 1, 2, 3 and uplo= L,U */
            PLASMA_ssygv(itype[i], vec, uplo[u], N, A2, LDA, B2, LDB, W2, T, Q, LDQ);

            /* CALL LAPACK to compute eigenvalues. */
            memcpy(A1, Ainit, LDAxN*sizeof(float));
            memcpy(B1, Binit, LDBxN*sizeof(float));
            LAPACKE_ssygv( LAPACK_COL_MAJOR,
                     itype[i], lapack_const(vec), lapack_const(uplo[u]),
                     N, A1, LDA, B1, LDB, W1);

            /* CHECK */
            info_solution = check_solution(N, W1, W2, eps);
            /* Check the orthogonality, reduction and the eigen solutions */
            if (vec == PlasmaVec){
                info_ortho = check_orthogonality(itype[i], uplo[u], N, Q, LDQ, Binit, B1, LDB, eps);
                info_reduction = check_reduction(itype[i], uplo[u], N, W2, Ainit, LDA, Binit, LDB, Q, LDQ, eps );
            }

            if ( (info_ortho == 0) & (info_reduction == 0) & (info_solution == 0)) {
                printf("***************************************************\n");
                printf(" ---- TESTING SSYGV (%s, %s) ...................... PASSED !\n", itypestr[i], uplostr[u]);
                printf("***************************************************\n");
            }
            else {
                printf("************************************************\n");
                printf(" - TESTING SSYGV (%s, %s) ... FAILED !\n", itypestr[i], uplostr[u]);
                printf("************************************************\n");
            }
        }
    }

    PLASMA_Dealloc_Handle_Tile(&T);
    free(A1);
    free(A2);
    free(B1);
    free(B2);
    free(Q);
    free(Ainit);
    free(Binit);
    free(W1);
    free(W2);
    free(work);

    return 0;
}

/*-------------------------------------------------------------------
 * Check the orthogonality of Z
 */
static int check_orthogonality(int itype, int uplo, int N,
                               float *Z, int LDZ,
                               float *B, float *CHOLB, int LDB,
                               float eps)
{
    static float zone  =  1.0;
    static float mzone = -1.0;
    static float zzero =  0.0;
    static float             done  =  1.0;
    static float             mdone = -1.0;
    PLASMA_enum trans;
    float  normQ, result;
    int     info_ortho;
    float *work = (float *)malloc(N*sizeof(float));
    float *TEMP    = (float *)malloc(N*N*sizeof(float));
    float *Id = (float *) malloc(N*N*sizeof(float));
    char *str;

    /* Build the idendity matrix */
    LAPACKE_slaset_work(LAPACK_COL_MAJOR, 'A', N, N, 0., 1., Id, N);

    /* Perform orth test*/
    if ( itype == 3 ) {
        /*
         * if ITYPE = 3, Z**T*inv(B)*Z = I.
         * inv(B) = inv(L)**T * inv(L) or inv(U)*inv(U)**T
         */
        str = "Z**T*inv(B)*Z";

        if( uplo==PlasmaUpper ) {
            trans = PlasmaTrans;
        } else {
            trans = PlasmaNoTrans;
        }

        /* Compute inv(L)*Z or inv(U)**T*Z */
        LAPACKE_slacpy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaUpperLower),
                            N, N, Z, LDZ, TEMP, N);

        cblas_strsm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, (CBLAS_TRANSPOSE)trans,
                    CblasNonUnit, N, N,
                    (zone), CHOLB, LDB,
                                       TEMP,  N);

        /*
         * Compute Z**T*inv(B)*Z-Id = (Z**T*inv(L)**T) * (inv(L)*Z) - Id
         *
         * Note: Z**T*inv(L)**T is the ConjTranspose of the previous result, so we use SSYRK
         */
        cblas_ssyrk(CblasColMajor, (CBLAS_UPLO)uplo, CblasTrans,
                    N, N, done, TEMP, N, mdone, Id, N);
    } else {
        /*
         * if ITYPE = 1 or 2, Z**T*B*Z = I;
         */
        str = "Z**T*B*Z";
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  B,    LDB,
                                        Z,    LDZ,
                    (zzero), TEMP, N);
        cblas_sgemm(CblasColMajor, CblasTrans, CblasNoTrans, N, N, N,
                    (zone),  Z,    LDZ,
                                        TEMP, N,
                    (mzone), Id  , N);
    }

    normQ = LAPACKE_slansy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaInfNorm), 'U', N, Id, N, work);
    result = normQ / (N * eps);
    printf(" ======================================================\n");
    printf(" | Id-%s |_oo / (N*eps)          : %15.3E \n",str, result );
    printf(" ======================================================\n");

    if ( isnan(result) || isinf(result) || (result > 60.0) ) {
        printf("-- Orthogonality is suspicious ! \n");
        info_ortho=1;
    }
    else {
        printf("-- Orthogonality is CORRECT ! \n");
        info_ortho=0;
    }

    free(work); free(Id); free(TEMP);
    return info_ortho;
}

/*------------------------------------------------------------
 *  Check the reduction
 */
static int check_reduction(int itype, int uplo, int N, float *D,
                           float *A, int LDA,
                           float *B, int LDB,
                           float *Z, int LDZ,
                           float eps )
{
    float zone  =  1.0;
    float zzero =  0.0;
    float mzone = -1.0;
    float Anorm, Znorm, Rnorm, result;
    int info_reduction;
    int i;
    char *str;
    float *TEMP     = (float *)malloc(N*N*sizeof(float));
    float *Residual = (float *)malloc(N*N*sizeof(float));
    float *work = (float *)malloc(N*sizeof(float));

    if( itype == 1 ) {
        /*
         * | A Z - B Z D | / ( |A| |Z| n ulp )
         */
        str = " A Z - B Z D ";

        /* Compute TEMP = Z*D */
        LAPACKE_slacpy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaUpperLower),
                            N, N, Z, LDZ, TEMP, N);

        for (i=0; i<N; i++) {
            cblas_sscal(N, D[i], TEMP + i*N, 1);
        }

        /* Compute Residual = B*Z*D = B*TEMP */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  B,        LDB,
                                        TEMP,     N,
                    (zzero), Residual, N);

        /* Compute A*Z - B*Z*D */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  A,        LDA,
                                        Z,        LDZ,
                    (mzone), Residual, N);
    }
    else if( itype == 2 ) {
        /*
         * | A B Z - Z D | / ( |A| |Z| n ulp )
         */
        str = " A B Z - Z D ";

        /* Compute Residual = Z*D */
        LAPACKE_slacpy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaUpperLower),
                            N, N, Z, LDZ, Residual, N);

        for (i=0; i<N; i++) {
            cblas_sscal(N, D[i], Residual + i*N, 1);
        }

        /* Compute TEMP = B*Z */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  B,    LDB,
                                        Z,    LDZ,
                    (zzero), TEMP, N);

        /* Compute A*B*Z - Z*D = A*TEMP-Residual */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  A,        LDA,
                                        TEMP,     N,
                    (mzone), Residual, N);
    } else {
        /*
         * | B A Z - Z D | / ( |A| |Z| n ulp )
         */
        str = " B A Z - Z D ";

        /* Compute Residual = Z*D */
        LAPACKE_slacpy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaUpperLower),
                            N, N, Z, LDZ, Residual, N);

        for (i=0; i<N; i++) {
            cblas_sscal(N, D[i], Residual + i*N, 1);
        }

        /* Compute TEMP = A*Z */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  A,    LDA,
                                        Z,    LDZ,
                    (zzero), TEMP, N);

        /* Compute B*A*Z - Z*D = B*TEMP-Residual */
        cblas_ssymm(CblasColMajor, CblasLeft, (CBLAS_UPLO)uplo, N, N,
                    (zone),  B,        LDB,
                                        TEMP,     N,
                    (mzone), Residual, N);
    }

    Rnorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaOneNorm), N, N, Residual, N,   work);
    Anorm = LAPACKE_slansy_work(LAPACK_COL_MAJOR, lapack_const(PlasmaOneNorm), lapack_const(uplo), N, A,        LDA, work);
    Znorm = LAPACKE_slange_work(LAPACK_COL_MAJOR, lapack_const(PlasmaOneNorm), N, N, Z,        LDZ, work);

    result = Rnorm / ( Anorm * Znorm * N * eps);
    printf(" ======================================================\n");
    printf(" | %s |_oo/(|A|_oo.|Z|_oo.N.eps) : %15.3E \n", str, result );
    printf(" ======================================================\n");

    if ( isnan(result) || isinf(result) || (result > 60.0) ) {
        printf("-- Reduction is suspicious ! \n");
        info_reduction = 1;
    }
    else {
        printf("-- Reduction is CORRECT ! \n");
        info_reduction = 0;
    }

    free(TEMP); free(Residual); free(work);
    return info_reduction;
}
/*--------------------------------------------------------------
 * Check the solution
 */
static int check_solution(int N, float *E1, float *E2, float eps)
{
    int info_solution, i;
    float resid;
    float maxtmp;
    float maxel = fabs( fabs(E1[0]) - fabs(E2[0]) );
    float maxeig = max( fabs(E1[0]), fabs(E2[0]) );

    for (i=1; i<N; i++) {
        resid  = fabs(fabs(E1[i])-fabs(E2[i]));
        maxtmp = max(fabs(E1[i]), fabs(E2[i]));

        /* Update */
        maxeig = max(maxtmp, maxeig);
        maxel  = max(resid,  maxel );
    }

    maxel = maxel / (maxeig * N * eps);
    printf(" ======================================================\n");
    printf(" | D - eigcomputed | / (|D| * N * eps) : %15.3E \n",  maxel );
    printf(" ======================================================\n");

    printf("============\n");
    printf("Checking the eigenvalues of A\n");
    if ( isnan(maxel) || isinf(maxel) || (maxel > 100) ) {
        printf("-- The eigenvalues are suspicious ! \n");
        info_solution = 1;
    }
    else{
        printf("-- The eigenvalues are CORRECT ! \n");
        info_solution = 0;
    }
    return info_solution;
}


#ifndef LDA_TOPIC_WORD_PROB_MULTI_SELECT_H
#define LDA_TOPIC_WORD_PROB_MULTI_SELECT_H

#include "Lambda.h"
#include "LambdaCreationFunctions.h"
#include "MultiSelectionComp.h"
#include "PDBVector.h"
#include "LDATopicWordProb.h"
#include "TopicAssignment.h"
#include "LDATopicWordProb.h"
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <random>
#include <gsl/gsl_vector.h>

/* This class generates the entries for the topic probability for each word */
using namespace pdb;
class LDATopicWordProbMultiSelection
    : public MultiSelectionComp<LDATopicWordProb, TopicAssignment> {

private:
    Vector<double> prior;
    Handle<Vector<char>> myMem;
    int numTopics;

public:
    ENABLE_DEEP_COPY

    LDATopicWordProbMultiSelection() {}

    LDATopicWordProbMultiSelection(Vector<double>& fromPrior, unsigned numTopics) {

        this->prior = fromPrior;
        this->numTopics = numTopics;

	/* Set up the random number generator */
        gsl_rng* src = gsl_rng_alloc(gsl_rng_mt19937);
        std::random_device rd;
        std::mt19937 gen(rd());
        gsl_rng_set(src, gen());

        int spaceNeeded = sizeof(gsl_rng) + src->type->size;
        myMem = makeObject<Vector<char>>(spaceNeeded, spaceNeeded);

        memcpy(myMem->c_ptr(), src, sizeof(gsl_rng));
        memcpy(myMem->c_ptr() + sizeof(gsl_rng), src->state, src->type->size);

        gsl_rng_free(src);
    }

    Lambda<bool> getSelection(Handle<TopicAssignment> checkMe) override {
        return makeLambda(checkMe, [](Handle<TopicAssignment>& checkMe) { return true; });
    }

    Lambda<Vector<Handle<LDATopicWordProb>>> getProjection(
        Handle<TopicAssignment> checkMe) override {
        return makeLambda(checkMe, [&](Handle<TopicAssignment>& checkMe) {

            gsl_rng* rng = getRng();
            Vector<unsigned>& wordCount = checkMe->getVector();

            unsigned wordNum = prior.size();
            double* mySamples = new double[wordNum];
            double* totalProb = new double[wordNum];
            double* myPrior = prior.c_ptr();
            for (int i = 0; i < wordNum; i++) {
                totalProb[i] = myPrior[i] + wordCount[i];
            }

	    /* Sample the word probability */
            gsl_ran_dirichlet(rng, wordNum, totalProb, mySamples);

	    /* Create the topic probability for each word */
            Vector<Handle<LDATopicWordProb>> result(wordNum);
            for (int i = 0; i < wordNum; i++) {
                Handle<LDATopicWordProb> myTWP =
                    makeObject<LDATopicWordProb>(numTopics, i, checkMe->getKey(), mySamples[i]);
                result.push_back(myTWP);
            }

            delete[] mySamples;
            delete[] totalProb;

            return result;

        });
    }

    gsl_rng* getRng() {
        gsl_rng* dst = (gsl_rng*)myMem->c_ptr();
        dst->state = (void*)(myMem->c_ptr() + sizeof(gsl_rng));
        dst->type = gsl_rng_mt19937;
        return dst;
    }
};

#endif