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

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

#include <config.h>
#include <gsl/gsl_eigen.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_vector_complex.h>
#include <gsl/gsl_matrix.h>

/*
 * This module computes the eigenvalues of a real generalized
 * eigensystem A x = \lambda B x. Left and right Schur vectors
 * are optionally computed as well.
 *
 * Based on the algorithm from Moler and Stewart
 * [1] C. Moler, G. Stewart, "An Algorithm for Generalized Matrix
 *     Eigenvalue Problems", SIAM J. Numer. Anal., Vol 10, No 2, 1973.
 *
 * This algorithm is also described in the book
 * [2] Golub & Van Loan, "Matrix Computations" (3rd ed), algorithm 7.7.3
 *
 * This file contains routines based on original code from LAPACK
 * which is distributed under the modified BSD license.
 */

#define GEN_ESHIFT_COEFF     (1.736)

static void gen_schur_decomp(gsl_matrix *H, gsl_matrix *R,
                             gsl_vector_complex *alpha, gsl_vector *beta,
                             gsl_eigen_gen_workspace *w);
static inline int gen_qzstep(gsl_matrix *H, gsl_matrix *R,
                             gsl_eigen_gen_workspace *w);
static inline void gen_qzstep_d(gsl_matrix *H, gsl_matrix *R,
                                gsl_eigen_gen_workspace *w);
static void gen_tri_split_top(gsl_matrix *H, gsl_matrix *R,
                              gsl_eigen_gen_workspace *w);
static inline void gen_tri_chase_zero(gsl_matrix *H, gsl_matrix *R,
                                      size_t q,
                                      gsl_eigen_gen_workspace *w);
static inline void gen_tri_zero_H(gsl_matrix *H, gsl_matrix *R,
                                  gsl_eigen_gen_workspace *w);
static inline size_t gen_search_small_elements(gsl_matrix *H,
                                               gsl_matrix *R,
                                               int *flag,
                                               gsl_eigen_gen_workspace *w);
static int gen_schur_standardize1(gsl_matrix *A, gsl_matrix *B,
                                  double *alphar, double *beta,
                                  gsl_eigen_gen_workspace *w);
static int gen_schur_standardize2(gsl_matrix *A, gsl_matrix *B,
                                  gsl_complex *alpha1,
                                  gsl_complex *alpha2,
                                  double *beta1, double *beta2,
                                  gsl_eigen_gen_workspace *w);
static int gen_compute_eigenvals(gsl_matrix *A, gsl_matrix *B,
                                 gsl_complex *alpha1,
                                 gsl_complex *alpha2, double *beta1,
                                 double *beta2);
static void gen_store_eigval1(const gsl_matrix *H, const double a,
                              const double b, gsl_vector_complex *alpha,
                              gsl_vector *beta,
                              gsl_eigen_gen_workspace *w);
static void gen_store_eigval2(const gsl_matrix *H,
                              const gsl_complex *alpha1,
                              const double beta1,
                              const gsl_complex *alpha2,
                              const double beta2,
                              gsl_vector_complex *alpha,
                              gsl_vector *beta,
                              gsl_eigen_gen_workspace *w);
static inline size_t gen_get_submatrix(const gsl_matrix *A,
                                       const gsl_matrix *B);

/*FIX**/
inline static double normF (gsl_matrix * A);
inline static void create_givens (const double a, const double b, double *c, double *s);

/*
gsl_eigen_gen_alloc()

Allocate a workspace for solving the generalized eigenvalue problem.
The size of this workspace is O(n)

Inputs: n - size of matrices

Return: pointer to workspace
*/

gsl_eigen_gen_workspace *
gsl_eigen_gen_alloc(const size_t n)
{
  gsl_eigen_gen_workspace *w;

  if (n == 0)
    {
      GSL_ERROR_NULL ("matrix dimension must be positive integer",
                      GSL_EINVAL);
    }

  w = (gsl_eigen_gen_workspace *) calloc (1, sizeof (gsl_eigen_gen_workspace));

  if (w == 0)
    {
      GSL_ERROR_NULL ("failed to allocate space for workspace", GSL_ENOMEM);
    }

  w->size = n;
  w->max_iterations = 30 * n;
  w->n_evals = 0;
  w->n_iter = 0;
  w->needtop = 0;
  w->atol = 0.0;
  w->btol = 0.0;
  w->ascale = 0.0;
  w->bscale = 0.0;
  w->eshift = 0.0;
  w->H = NULL;
  w->R = NULL;
  w->compute_s = 0;
  w->compute_t = 0;
  w->Q = NULL;
  w->Z = NULL;

  w->work = gsl_vector_alloc(n);

  if (w->work == 0)
    {
      gsl_eigen_gen_free(w);
      GSL_ERROR_NULL ("failed to allocate space for additional workspace", GSL_ENOMEM);
    }

  return (w);
} /* gsl_eigen_gen_alloc() */

/*
gsl_eigen_gen_free()
  Free workspace w
*/

void
gsl_eigen_gen_free (gsl_eigen_gen_workspace * w)
{
  RETURN_IF_NULL (w);

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

  free(w);
} /* gsl_eigen_gen_free() */

/*
gsl_eigen_gen_params()
  Set parameters which define how we solve the eigenvalue problem

Inputs: compute_s - 1 if we want to compute S, 0 if not
        compute_t - 1 if we want to compute T, 0 if not
        balance   - 1 if we want to balance matrices, 0 if not
        w         - gen workspace

Return: none
*/

void
gsl_eigen_gen_params (const int compute_s, const int compute_t,
                      const int balance, gsl_eigen_gen_workspace *w)
{
  w->compute_s = compute_s;
  w->compute_t = compute_t;
} /* gsl_eigen_gen_params() */

/*
gsl_eigen_gen()

Solve the generalized eigenvalue problem

A x = \lambda B x

for the eigenvalues \lambda.

Inputs: A     - general real matrix
        B     - general real matrix
        alpha - where to store eigenvalue numerators
        beta  - where to store eigenvalue denominators
        w     - workspace

Return: success or error
*/

int
gsl_eigen_gen (gsl_matrix * A, gsl_matrix * B, gsl_vector_complex * alpha,
               gsl_vector * beta, gsl_eigen_gen_workspace * w)
{
  const size_t N = A->size1;

  /* check matrix and vector sizes */

  if (N != A->size2)
    {
      GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
    }
  else if ((N != B->size1) || (N != B->size2))
    {
      GSL_ERROR ("B matrix dimensions must match A", GSL_EBADLEN);
    }
  else if (alpha->size != N || beta->size != N)
    {
      GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
    }
  else if (w->size != N)
    {
      GSL_ERROR ("matrix size does not match workspace", GSL_EBADLEN);
    }
  else
    {
      double anorm, bnorm;

      /* compute the Hessenberg-Triangular reduction of (A, B) */
      gsl_linalg_hesstri_decomp(A, B, w->Q, w->Z, w->work);

      /* save pointers to original matrices */
      w->H = A;
      w->R = B;

      w->n_evals = 0;
      w->n_iter = 0;
      w->eshift = 0.0;

      /* determine if we need to compute top indices in QZ step */
      w->needtop = w->Q != 0 || w->Z != 0 || w->compute_t || w->compute_s;

      /* compute matrix norms */
      anorm = normF(A);
      bnorm = normF(B);

      /* compute tolerances and scaling factors */
      w->atol = GSL_MAX(GSL_DBL_MIN, GSL_DBL_EPSILON * anorm);
      w->btol = GSL_MAX(GSL_DBL_MIN, GSL_DBL_EPSILON * bnorm);
      w->ascale = 1.0 / GSL_MAX(GSL_DBL_MIN, anorm);
      w->bscale = 1.0 / GSL_MAX(GSL_DBL_MIN, bnorm);

      /* compute the generalized Schur decomposition and eigenvalues */
      gen_schur_decomp(A, B, alpha, beta, w);

      if (w->n_evals != N)
        return GSL_EMAXITER;

      return GSL_SUCCESS;
    }
} /* gsl_eigen_gen() */

/*
gsl_eigen_gen_QZ()

Solve the generalized eigenvalue problem

A x = \lambda B x

for the eigenvalues \lambda. Optionally compute left and/or right
Schur vectors Q and Z which satisfy:

A = Q S Z^t
B = Q T Z^t

where (S, T) is the generalized Schur form of (A, B)

Inputs: A     - general real matrix
        B     - general real matrix
        alpha - where to store eigenvalue numerators
        beta  - where to store eigenvalue denominators
        Q     - if non-null, where to store left Schur vectors
        Z     - if non-null, where to store right Schur vectors
        w     - workspace

Return: success or error
*/

int
gsl_eigen_gen_QZ (gsl_matrix * A, gsl_matrix * B,
                  gsl_vector_complex * alpha, gsl_vector * beta,
                  gsl_matrix * Q, gsl_matrix * Z,
                  gsl_eigen_gen_workspace * w)
{
  if (Q && (A->size1 != Q->size1 || A->size1 != Q->size2))
    {
      GSL_ERROR("Q matrix has wrong dimensions", GSL_EBADLEN);
    }
  else if (Z && (A->size1 != Z->size1 || A->size1 != Z->size2))
    {
      GSL_ERROR("Z matrix has wrong dimensions", GSL_EBADLEN);
    }
  else
    {
      int s;

      w->Q = Q;
      w->Z = Z;

      s = gsl_eigen_gen(A, B, alpha, beta, w);

      w->Q = NULL;
      w->Z = NULL;

      return s;
    }
} /* gsl_eigen_gen_QZ() */

/********************************************
 *           INTERNAL ROUTINES              *
 ********************************************/

/*
gen_schur_decomp()
  Compute the generalized Schur decomposition of the matrix pencil
(H, R) which is in Hessenberg-Triangular form

Inputs: H     - upper hessenberg matrix
        R     - upper triangular matrix
        alpha - (output) where to store eigenvalue numerators
        beta  - (output) where to store eigenvalue denominators
        w     - workspace

Return: none

Notes: 1) w->n_evals is updated to keep track of how many eigenvalues
          are found
*/

static void
gen_schur_decomp(gsl_matrix *H, gsl_matrix *R, gsl_vector_complex *alpha,
                 gsl_vector *beta, gsl_eigen_gen_workspace *w)
{
  size_t N;
  gsl_matrix_view h, r;
  gsl_matrix_view vh, vr;
  size_t q;             /* index of small subdiagonal element */
  gsl_complex z1, z2;   /* complex values */
  double a, b;
  int s;
  int flag;

  N = H->size1;

  h = gsl_matrix_submatrix(H, 0, 0, N, N);
  r = gsl_matrix_submatrix(R, 0, 0, N, N);

  while ((N > 1) && (w->n_iter)++ < w->max_iterations)
    {
      q = gen_search_small_elements(&h.matrix, &r.matrix, &flag, w);

      if (flag == 0)
        {
          /* no small elements found - do a QZ sweep */
          s = gen_qzstep(&h.matrix, &r.matrix, w);

          if (s == GSL_CONTINUE)
            {
              /*
               * (h, r) is a 2-by-2 block with complex eigenvalues -
               * standardize and read off eigenvalues
               */
              s = gen_schur_standardize2(&h.matrix,
                                         &r.matrix,
                                         &z1,
                                         &z2,
                                         &a,
                                         &b,
                                         w);
              if (s != GSL_SUCCESS)
                {
                  /*
                   * if we get here, then the standardization process
                   * perturbed the eigenvalues onto the real line -
                   * continue QZ iteration to break them into 1-by-1
                   * blocks
                   */
                  continue;
                }

              gen_store_eigval2(&h.matrix, &z1, a, &z2, b, alpha, beta, w);
              N = 0;
            } /* if (s) */

          continue;
        } /* if (flag == 0) */
      else if (flag == 2)
        {
          if (q == 0)
            {
              /*
               * the leading element of R is zero, split off a block
               * at the top
               */
              gen_tri_split_top(&h.matrix, &r.matrix, w);
            }
          else
            {
              /*
               * we found a small element on the diagonal of R - chase the
               * zero to the bottom of the active block and then zero
               * H(n, n - 1) to split off a 1-by-1 block
               */

              if (q != N - 1)
                gen_tri_chase_zero(&h.matrix, &r.matrix, q, w);

              /* now zero H(n, n - 1) */
              gen_tri_zero_H(&h.matrix, &r.matrix, w);
            }

          /* continue so the next iteration detects the zero in H */
          continue;
        }

      /*
       * a small subdiagonal element of H was found - one or two
       * eigenvalues have converged or the matrix has split into
       * two smaller matrices
       */

      if (q == (N - 1))
        {
          /*
           * the last subdiagonal element of the hessenberg matrix is 0 -
           * H_{NN} / R_{NN} is a real eigenvalue - standardize so
           * R_{NN} > 0
           */

          vh = gsl_matrix_submatrix(&h.matrix, q, q, 1, 1);
          vr = gsl_matrix_submatrix(&r.matrix, q, q, 1, 1);
          gen_schur_standardize1(&vh.matrix, &vr.matrix, &a, &b, w);

          gen_store_eigval1(&vh.matrix, a, b, alpha, beta, w);

          --N;
          h = gsl_matrix_submatrix(&h.matrix, 0, 0, N, N);
          r = gsl_matrix_submatrix(&r.matrix, 0, 0, N, N);
        }
      else if (q == (N - 2))
        {
          /* bottom right 2-by-2 block may have converged */

          vh = gsl_matrix_submatrix(&h.matrix, q, q, 2, 2);
          vr = gsl_matrix_submatrix(&r.matrix, q, q, 2, 2);
          s = gen_schur_standardize2(&vh.matrix,
                                     &vr.matrix,
                                     &z1,
                                     &z2,
                                     &a,
                                     &b,
                                     w);
          if (s != GSL_SUCCESS)
            {
              /*
               * this 2-by-2 block contains real eigenvalues that
               * have not yet separated into 1-by-1 blocks -
               * recursively call gen_schur_decomp() to finish off
               * this block
               */
              gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
            }
          else
            {
              /* we got 2 complex eigenvalues */

              gen_store_eigval2(&vh.matrix, &z1, a, &z2, b, alpha, beta, w);
            }

          N -= 2;
          h = gsl_matrix_submatrix(&h.matrix, 0, 0, N, N);
          r = gsl_matrix_submatrix(&r.matrix, 0, 0, N, N);
        }
      else if (q == 1)
        {
          /* H_{11} / R_{11} is an eigenvalue */

          vh = gsl_matrix_submatrix(&h.matrix, 0, 0, 1, 1);
          vr = gsl_matrix_submatrix(&r.matrix, 0, 0, 1, 1);
          gen_schur_standardize1(&vh.matrix, &vr.matrix, &a, &b, w);

          gen_store_eigval1(&vh.matrix, a, b, alpha, beta, w);

          --N;
          h = gsl_matrix_submatrix(&h.matrix, 1, 1, N, N);
          r = gsl_matrix_submatrix(&r.matrix, 1, 1, N, N);
        }
      else if (q == 2)
        {
          /* upper left 2-by-2 block may have converged */

          vh = gsl_matrix_submatrix(&h.matrix, 0, 0, 2, 2);
          vr = gsl_matrix_submatrix(&r.matrix, 0, 0, 2, 2);
          s = gen_schur_standardize2(&vh.matrix,
                                     &vr.matrix,
                                     &z1,
                                     &z2,
                                     &a,
                                     &b,
                                     w);
          if (s != GSL_SUCCESS)
            {
              /*
               * this 2-by-2 block contains real eigenvalues that
               * have not yet separated into 1-by-1 blocks -
               * recursively call gen_schur_decomp() to finish off
               * this block
               */
              gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);
            }
          else
            {
              /* we got 2 complex eigenvalues */
              gen_store_eigval2(&vh.matrix, &z1, a, &z2, b, alpha, beta, w);
            }

          N -= 2;
          h = gsl_matrix_submatrix(&h.matrix, 2, 2, N, N);
          r = gsl_matrix_submatrix(&r.matrix, 2, 2, N, N);
        }
      else
        {
          /*
           * There is a zero element on the subdiagonal somewhere
           * in the middle of the matrix - we can now operate
           * separately on the two submatrices split by this
           * element. q is the row index of the zero element.
           */

          /* operate on lower right (N - q)-by-(N - q) block first */
          vh = gsl_matrix_submatrix(&h.matrix, q, q, N - q, N - q);
          vr = gsl_matrix_submatrix(&r.matrix, q, q, N - q, N - q);
          gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);

          /* operate on upper left q-by-q block */
          vh = gsl_matrix_submatrix(&h.matrix, 0, 0, q, q);
          vr = gsl_matrix_submatrix(&r.matrix, 0, 0, q, q);
          gen_schur_decomp(&vh.matrix, &vr.matrix, alpha, beta, w);

          N = 0;
        }
    } /* while ((N > 1) && (w->n_iter)++ < w->max_iterations) */

  /* handle special case of N = 1 */

  if (N == 1)
    {
      gen_schur_standardize1(&h.matrix, &r.matrix, &a, &b, w);
      gen_store_eigval1(&h.matrix, a, b, alpha, beta, w);
    }
} /* gen_schur_decomp() */

/*
gen_qzstep()
  This routine determines what type of QZ step to perform on
the generalized matrix pair (H, R). If the pair is 3-by-3 or bigger,
we look at the bottom right 2-by-2 block. If this block has complex
eigenvalues, we perform a Francis double shift QZ sweep. If it
has real eigenvalues, we perform an implicit single shift QZ sweep.

If the pair is 2-by-2 with real eigenvalues, we perform a single
shift sweep. If it has complex eigenvalues, we return GSL_CONTINUE
to notify the calling function that a 2-by-2 block with complex
eigenvalues has converged, so that it may then call
gen_schur_standardize2(). In the real eigenvalue case, we want to
continue doing QZ sweeps to break it up into two 1-by-1 blocks.

See LAPACK routine DHGEQZ and [1] for more information.

Inputs: H - upper Hessenberg matrix (at least 2-by-2)
        R - upper triangular matrix (at least 2-by-2)
        w - workspace

Return: GSL_SUCCESS on normal completion
        GSL_CONTINUE if we detect a 2-by-2 block with complex eigenvalues
*/

static inline int
gen_qzstep(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  gsl_matrix_view vh, vr; /* views of bottom right 2-by-2 block */
  double wr1, wr2, wi;
  double scale1, scale2, scale;
  double cs, sn;          /* givens rotation */
  double temp,            /* temporary variables */
         temp2;
  size_t j;               /* looping */
  gsl_vector_view xv, yv; /* temporary views */
  size_t top;
  size_t rows;

  if (w->n_iter % 10 == 0)
    {
      /*
       * Exceptional shift - we have gone 10 iterations without finding
       * a new eigenvalue, do a single shift sweep with an
       * exceptional shift
       */

      if ((GSL_DBL_MIN * w->max_iterations) *
          fabs(gsl_matrix_get(H, N - 2, N - 1)) <
          fabs(gsl_matrix_get(R, N - 2, N - 2)))
        {
          w->eshift += gsl_matrix_get(H, N - 2, N - 1) /
                       gsl_matrix_get(R, N - 2, N - 2);
        }
      else
        w->eshift += 1.0 / (GSL_DBL_MIN * w->max_iterations);

      if ((w->eshift < GSL_DBL_EPSILON) &&
          (GSL_DBL_MIN * w->max_iterations) *
          fabs(gsl_matrix_get(H, N - 1, N - 2)) <
          fabs(gsl_matrix_get(R, N - 2, N - 2)))
        {
          w->eshift = GEN_ESHIFT_COEFF *
                      (w->ascale * gsl_matrix_get(H, N - 1, N - 2)) /
                      (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
        }

      scale1 = 1.0;
      wr1 = w->eshift;
    }
  else
    {
      /*
       * Compute generalized eigenvalues of bottom right 2-by-2 block
       * to be used as shifts - wr1 is the Wilkinson shift
       */

      vh = gsl_matrix_submatrix(H, N - 2, N - 2, 2, 2);
      vr = gsl_matrix_submatrix(R, N - 2, N - 2, 2, 2);
      gsl_schur_gen_eigvals(&vh.matrix,
                            &vr.matrix,
                            &wr1,
                            &wr2,
                            &wi,
                            &scale1,
                            &scale2);

      if (wi != 0.0)
        {
          /* complex eigenvalues */

          if (N == 2)
            {
              /*
               * its a 2-by-2 block with complex eigenvalues - notify
               * the calling function to deflate
               */
              return (GSL_CONTINUE);
            }
          else
            {
              /* do a francis double shift sweep */
              gen_qzstep_d(H, R, w);
            }

          return GSL_SUCCESS;
        }
    }

  /* real eigenvalues - perform single shift QZ step */

  temp = GSL_MIN(w->ascale, 1.0) * (0.5 / GSL_DBL_MIN);
  if (scale1 > temp)
    scale = temp / scale1;
  else
    scale = 1.0;

  temp = GSL_MIN(w->bscale, 1.0) * (0.5 / GSL_DBL_MIN);
  if (fabs(wr1) > temp)
    scale = GSL_MIN(scale, temp / fabs(wr1));

  scale1 *= scale;
  wr1 *= scale;

  if (w->needtop)
    {
      /* get absolute index of this matrix relative to original matrix */
      top = gen_get_submatrix(w->H, H);
    }

  temp = scale1*gsl_matrix_get(H, 0, 0) - wr1*gsl_matrix_get(R, 0, 0);
  temp2 = scale1*gsl_matrix_get(H, 1, 0);

  create_givens(temp, temp2, &cs, &sn);
  sn = -sn;

  for (j = 0; j < N - 1; ++j)
    {
      if (j > 0)
        {
          temp = gsl_matrix_get(H, j, j - 1);
          temp2 = gsl_matrix_get(H, j + 1, j - 1);
          create_givens(temp, temp2, &cs, &sn);
          sn = -sn;

          /* apply to column (j - 1) */
          temp = cs * gsl_matrix_get(H, j, j - 1) +
                 sn * gsl_matrix_get(H, j + 1, j - 1);
          gsl_matrix_set(H, j, j - 1, temp);
          gsl_matrix_set(H, j + 1, j - 1, 0.0);
        }

      /* apply G to H(j:j+1,:) and T(j:j+1,:) */

      if (w->compute_s)
        {
          xv = gsl_matrix_subrow(w->H, top + j, top + j, w->size - top - j);
          yv = gsl_matrix_subrow(w->H, top + j + 1, top + j, w->size - top - j);
        }
      else
        {
          xv = gsl_matrix_subrow(H, j, j, N - j);
          yv = gsl_matrix_subrow(H, j + 1, j, N - j);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      if (w->compute_t)
        {
          xv = gsl_matrix_subrow(w->R, top + j, top + j, w->size - top - j);
          yv = gsl_matrix_subrow(w->R, top + j + 1, top + j, w->size - top - j);
        }
      else
        {
          xv = gsl_matrix_subrow(R, j, j, N - j);
          yv = gsl_matrix_subrow(R, j + 1, j, N - j);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      if (w->Q)
        {
          /* accumulate Q: Q -> QG */
          xv = gsl_matrix_column(w->Q, top + j);
          yv = gsl_matrix_column(w->Q, top + j + 1);
          gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
        }

      temp = gsl_matrix_get(R, j + 1, j + 1);
      temp2 = gsl_matrix_get(R, j + 1, j);
      create_givens(temp, temp2, &cs, &sn);

      rows = GSL_MIN(j + 3, N);

      if (w->compute_s)
        {
          xv = gsl_matrix_subcolumn(w->H, top + j, 0, top + rows);
          yv = gsl_matrix_subcolumn(w->H, top + j + 1, 0, top + rows);
        }
      else
        {
          xv = gsl_matrix_subcolumn(H, j, 0, rows);
          yv = gsl_matrix_subcolumn(H, j + 1, 0, rows);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      rows = GSL_MIN(j + 2, N);

      if (w->compute_t)
        {
          xv = gsl_matrix_subcolumn(w->R, top + j, 0, top + rows);
          yv = gsl_matrix_subcolumn(w->R, top + j + 1, 0, top + rows);
        }
      else
        {
          xv = gsl_matrix_subcolumn(R, j, 0, rows);
          yv = gsl_matrix_subcolumn(R, j + 1, 0, rows);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      if (w->Z)
        {
          /* accumulate Z: Z -> ZG */
          xv = gsl_matrix_column(w->Z, top + j);
          yv = gsl_matrix_column(w->Z, top + j + 1);
          gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
        }
    } /* for (j = 0; j < N - 1; ++j) */

  return GSL_SUCCESS;
} /* gen_qzstep() */

/*
gen_qzstep_d()
  Perform an implicit double shift QZ step.

See Golub & Van Loan, "Matrix Computations" (3rd ed), algorithm 7.7.2

Inputs: H - upper Hessenberg matrix (at least 3-by-3)
        R - upper triangular matrix (at least 3-by-3)
        w - workspace
*/

static inline void
gen_qzstep_d(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  size_t j;               /* looping */
  double dat[3];          /* householder vector */
  double tau;             /* householder coefficient */
  gsl_vector_view v2, v3; /* views into 'dat' */
  gsl_matrix_view m;      /* temporary view */
  double tmp;
  size_t q, r;
  size_t top;             /* location of H in original matrix */
  double scale;
  double AB11,            /* various matrix element ratios */
         AB22,
         ABNN,
         ABMM,
         AMNBNN,
         ANMBMM,
         A21B11,
         A12B22,
         A32B22,
         B12B22,
         BMNBNN;

  v2 = gsl_vector_view_array(dat, 2);
  v3 = gsl_vector_view_array(dat, 3);

  if (w->needtop)
    {
      /* get absolute index of this matrix relative to original matrix */
      top = gen_get_submatrix(w->H, H);
    }

  /*
   * Similar to the QR method, we take the shifts to be the two
   * zeros of the problem
   *
   * det[H(n-1:n,n-1:n) - s*R(n-1:n,n-1:n)] = 0
   *
   * The initial householder vector elements are then given by
   * Eq. 4.1 of [1], which are designed to reduce errors when
   * off diagonal elements are small.
   */

  ABMM = (w->ascale * gsl_matrix_get(H, N - 2, N - 2)) /
         (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
  ABNN = (w->ascale * gsl_matrix_get(H, N - 1, N - 1)) /
         (w->bscale * gsl_matrix_get(R, N - 1, N - 1));
  AB11 = (w->ascale * gsl_matrix_get(H, 0, 0)) /
         (w->bscale * gsl_matrix_get(R, 0, 0));
  AB22 = (w->ascale * gsl_matrix_get(H, 1, 1)) /
         (w->bscale * gsl_matrix_get(R, 1, 1));
  AMNBNN = (w->ascale * gsl_matrix_get(H, N - 2, N - 1)) /
           (w->bscale * gsl_matrix_get(R, N - 1, N - 1));
  ANMBMM = (w->ascale * gsl_matrix_get(H, N - 1, N - 2)) /
           (w->bscale * gsl_matrix_get(R, N - 2, N - 2));
  BMNBNN = gsl_matrix_get(R, N - 2, N - 1) /
           gsl_matrix_get(R, N - 1, N - 1);
  A21B11 = (w->ascale * gsl_matrix_get(H, 1, 0)) /
           (w->bscale * gsl_matrix_get(R, 0, 0));
  A12B22 = (w->ascale * gsl_matrix_get(H, 0, 1)) /
           (w->bscale * gsl_matrix_get(R, 1, 1));
  A32B22 = (w->ascale * gsl_matrix_get(H, 2, 1)) /
           (w->bscale * gsl_matrix_get(R, 1, 1));
  B12B22 = gsl_matrix_get(R, 0, 1) / gsl_matrix_get(R, 1, 1);

  /*
   * These are the Eqs (4.1) of [1], just multiplied by the factor
   * (A_{21} / B_{11})
   */
  dat[0] = (ABMM - AB11) * (ABNN - AB11) - (AMNBNN * ANMBMM) +
           (ANMBMM * BMNBNN * AB11) + (A12B22 - (AB11 * B12B22)) * A21B11;
  dat[1] = ((AB22 - AB11) - (A21B11 * B12B22) - (ABMM - AB11) -
            (ABNN - AB11) + (ANMBMM * BMNBNN)) * A21B11;
  dat[2] = A32B22 * A21B11;

  scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
  if (scale != 0.0)
    {
      dat[0] /= scale;
      dat[1] /= scale;
      dat[2] /= scale;
    }

  for (j = 0; j < N - 2; ++j)
    {
      r = GSL_MIN(j + 4, N);

      /*
       * Find householder Q so that
       *
       * Q [x y z]^t = [ * 0 0 ]^t
       */

      tau = gsl_linalg_householder_transform(&v3.vector);

      if (tau != 0.0)
        {
          /*
           * q is the initial column to start applying the householder
           * transformation. The GSL_MAX() simply ensures we don't
           * try to apply it to column (-1), since we are zeroing out
           * column (j - 1) except for the first iteration which
           * introduces the bulge.
           */
          q = (size_t) GSL_MAX(0, (int)j - 1);

          /* H -> QH, R -> QR */

          if (w->compute_s)
            {
              /*
               * We are computing the Schur form S, so we need to
               * transform the whole matrix H
               */
              m = gsl_matrix_submatrix(w->H,
                                       top + j,
                                       top + q,
                                       3,
                                       w->size - top - q);
              gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
            }
          else
            {
              /* just transform the active block */
              m = gsl_matrix_submatrix(H, j, q, 3, N - q);
              gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
            }

          if (w->compute_t)
            {
              /*
               * We are computing the Schur form T, so we need to
               * transform the whole matrix R
               */
              m = gsl_matrix_submatrix(w->R,
                                       top + j,
                                       top + j,
                                       3,
                                       w->size - top - j);
              gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
            }
          else
            {
              /* just transform the active block */
              m = gsl_matrix_submatrix(R, j, j, 3, N - j);
              gsl_linalg_householder_hm(tau, &v3.vector, &m.matrix);
            }

          if (w->Q)
            {
              /* accumulate the transformation into Q */
              m = gsl_matrix_submatrix(w->Q, 0, top + j, w->size, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }
        } /* if (tau != 0.0) */

      /*
       * Find householder Z so that
       *
       * [ r_{j+2,j} r_{j+2, j+1}, r_{j+2, j+2} ] Z = [ 0 0 * ]
       *
       * This isn't exactly what gsl_linalg_householder_transform
       * does, so we need to rotate the input vector so it preserves
       * the last element, and then rotate it back afterwards.
       *
       * So instead of transforming [x y z], we transform [z x y],
       * and the resulting HH vector [1 v2 v3] -> [v2 v3 1] but
       * then needs to be scaled to have the first element = 1, so
       * it becomes [1 v3/v2 1/v2] (tau must also be scaled accordingly).
       */

      dat[0] = gsl_matrix_get(R, j + 2, j + 2);
      dat[1] = gsl_matrix_get(R, j + 2, j);
      dat[2] = gsl_matrix_get(R, j + 2, j + 1);
      scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
      if (scale != 0.0)
        {
          dat[0] /= scale;
          dat[1] /= scale;
          dat[2] /= scale;
        }

      tau = gsl_linalg_householder_transform(&v3.vector);

      if (tau != 0.0)
        {
          /* rotate back */
          tmp = gsl_vector_get(&v3.vector, 1);
          gsl_vector_set(&v3.vector, 1, gsl_vector_get(&v3.vector, 2)/tmp);
          gsl_vector_set(&v3.vector, 2, 1.0 / tmp);
          tau *= tmp * tmp;

          /* H -> HZ, R -> RZ */

          if (w->compute_s)
            {
              m = gsl_matrix_submatrix(w->H, 0, top + j, top + r, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }
          else
            {
              m = gsl_matrix_submatrix(H, 0, j, r, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }

          if (w->compute_t)
            {
              m = gsl_matrix_submatrix(w->R, 0, top + j, top + j + 3, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }
          else
            {
              m = gsl_matrix_submatrix(R, 0, j, j + 3, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }

          if (w->Z)
            {
              /* accumulate transformation into Z */
              m = gsl_matrix_submatrix(w->Z, 0, top + j, w->size, 3);
              gsl_linalg_householder_mh(tau, &v3.vector, &m.matrix);
            }
        } /* if (tau != 0.0) */

      /*
       * Find householder Z so that
       *
       * [ r_{j+1,j} r_{j+1, j+1} ] Z = [ 0 * ]
       */

      dat[0] = gsl_matrix_get(R, j + 1, j + 1);
      dat[1] = gsl_matrix_get(R, j + 1, j);
      scale = fabs(dat[0]) + fabs(dat[1]);
      if (scale != 0.0)
        {
          dat[0] /= scale;
          dat[1] /= scale;
        }

      tau = gsl_linalg_householder_transform(&v2.vector);

      if (tau != 0.0)
        {
          /* rotate back */
          tmp = gsl_vector_get(&v2.vector, 1);
          gsl_vector_set(&v2.vector, 1, 1.0 / tmp);
          tau *= tmp * tmp;

          /* H -> HZ, R -> RZ */

          if (w->compute_s)
            {
              m = gsl_matrix_submatrix(w->H, 0, top + j, top + r, 2);
              gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
            }
          else
            {
              m = gsl_matrix_submatrix(H, 0, j, r, 2);
              gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
            }

          if (w->compute_t)
            {
              m = gsl_matrix_submatrix(w->R, 0, top + j, top + j + 3, 2);
              gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
            }
          else
            {
              m = gsl_matrix_submatrix(R, 0, j, j + 3, 2);
              gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
            }

          if (w->Z)
            {
              /* accumulate transformation into Z */
              m = gsl_matrix_submatrix(w->Z, 0, top + j, w->size, 2);
              gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
            }
        } /* if (tau != 0.0) */

      dat[0] = gsl_matrix_get(H, j + 1, j);
      dat[1] = gsl_matrix_get(H, j + 2, j);
      if (j < N - 3)
        dat[2] = gsl_matrix_get(H, j + 3, j);

      scale = fabs(dat[0]) + fabs(dat[1]) + fabs(dat[2]);
      if (scale != 0.0)
        {
          dat[0] /= scale;
          dat[1] /= scale;
          dat[2] /= scale;
        }
    } /* for (j = 0; j < N - 2; ++j) */

  /*
   * Find Householder Q so that
   *
   * Q [ x y ]^t = [ * 0 ]^t
   */

  scale = fabs(dat[0]) + fabs(dat[1]);
  if (scale != 0.0)
    {
      dat[0] /= scale;
      dat[1] /= scale;
    }

  tau = gsl_linalg_householder_transform(&v2.vector);

  if (w->compute_s)
    {
      m = gsl_matrix_submatrix(w->H,
                               top + N - 2,
                               top + N - 3,
                               2,
                               w->size - top - N + 3);
      gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
    }
  else
    {
      m = gsl_matrix_submatrix(H, N - 2, N - 3, 2, 3);
      gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
    }

  if (w->compute_t)
    {
      m = gsl_matrix_submatrix(w->R,
                               top + N - 2,
                               top + N - 2,
                               2,
                               w->size - top - N + 2);
      gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
    }
  else
    {
      m = gsl_matrix_submatrix(R, N - 2, N - 2, 2, 2);
      gsl_linalg_householder_hm(tau, &v2.vector, &m.matrix);
    }

  if (w->Q)
    {
      /* accumulate the transformation into Q */
      m = gsl_matrix_submatrix(w->Q, 0, top + N - 2, w->size, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }

  /*
   * Find Householder Z so that
   *
   * [ b_{n,n-1} b_{nn} ] Z = [ 0 * ]
   */

  dat[0] = gsl_matrix_get(R, N - 1, N - 1);
  dat[1] = gsl_matrix_get(R, N - 1, N - 2);
  scale = fabs(dat[0]) + fabs(dat[1]);
  if (scale != 0.0)
    {
      dat[0] /= scale;
      dat[1] /= scale;
    }

  tau = gsl_linalg_householder_transform(&v2.vector);

  /* rotate back */
  tmp = gsl_vector_get(&v2.vector, 1);
  gsl_vector_set(&v2.vector, 1, 1.0 / tmp);
  tau *= tmp * tmp;

  if (w->compute_s)
    {
      m = gsl_matrix_submatrix(w->H, 0, top + N - 2, top + N, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }
  else
    {
      m = gsl_matrix_submatrix(H, 0, N - 2, N, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }

  if (w->compute_t)
    {
      m = gsl_matrix_submatrix(w->R, 0, top + N - 2, top + N, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }
  else
    {
      m = gsl_matrix_submatrix(R, 0, N - 2, N, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }

  if (w->Z)
    {
      /* accumulate the transformation into Z */
      m = gsl_matrix_submatrix(w->Z, 0, top + N - 2, w->size, 2);
      gsl_linalg_householder_mh(tau, &v2.vector, &m.matrix);
    }
} /* gen_qzstep_d() */

/*
gen_tri_split_top()
  This routine is called when the leading element on the diagonal of R
has become negligible. Split off a 1-by-1 block at the top.

Inputs: H - upper hessenberg matrix
        R - upper triangular matrix
        w - workspace
*/

static void
gen_tri_split_top(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  size_t j, top;
  double cs, sn;
  gsl_vector_view xv, yv;

  if (w->needtop)
    top = gen_get_submatrix(w->H, H);

  j = 0;

  create_givens(gsl_matrix_get(H, j, j),
                gsl_matrix_get(H, j + 1, j),
                &cs,
                &sn);
  sn = -sn;

  if (w->compute_s)
    {
      xv = gsl_matrix_subrow(w->H, top + j, top, w->size - top);
      yv = gsl_matrix_subrow(w->H, top + j + 1, top, w->size - top);
    }
  else
    {
      xv = gsl_matrix_row(H, j);
      yv = gsl_matrix_row(H, j + 1);
    }

  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
  gsl_matrix_set(H, j + 1, j, 0.0);

  if (w->compute_t)
    {
      xv = gsl_matrix_subrow(w->R, top + j, top + 1, w->size - top - 1);
      yv = gsl_matrix_subrow(w->R, top + j + 1, top + 1, w->size - top - 1);
    }
  else
    {
      xv = gsl_matrix_subrow(R, j, 1, N - 1);
      yv = gsl_matrix_subrow(R, j + 1, 1, N - 1);
    }

  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

  if (w->Q)
    {
      xv = gsl_matrix_column(w->Q, top + j);
      yv = gsl_matrix_column(w->Q, top + j + 1);
      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
    }
} /* gen_tri_split_top() */

/*
gen_tri_chase_zero()
  This routine is called when an element on the diagonal of R
has become negligible. Chase the zero to the bottom of the active
block so we can split off a 1-by-1 block.

Inputs: H - upper hessenberg matrix
        R - upper triangular matrix
        q - index such that R(q,q) = 0 (q must be > 0)
        w - workspace
*/

static inline void
gen_tri_chase_zero(gsl_matrix *H, gsl_matrix *R, size_t q,
                   gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  size_t j, top;
  double cs, sn;
  gsl_vector_view xv, yv;

  if (w->needtop)
    top = gen_get_submatrix(w->H, H);

  for (j = q; j < N - 1; ++j)
    {
      create_givens(gsl_matrix_get(R, j, j + 1),
                    gsl_matrix_get(R, j + 1, j + 1),
                    &cs,
                    &sn);
      sn = -sn;

      if (w->compute_t)
        {
          xv = gsl_matrix_subrow(w->R, top + j, top + j + 1, w->size - top - j - 1);
          yv = gsl_matrix_subrow(w->R, top + j + 1, top + j + 1, w->size - top - j - 1);
        }
      else
        {
          xv = gsl_matrix_subrow(R, j, j + 1, N - j - 1);
          yv = gsl_matrix_subrow(R, j + 1, j + 1, N - j - 1);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
      gsl_matrix_set(R, j + 1, j + 1, 0.0);

      if (w->compute_s)
        {
          xv = gsl_matrix_subrow(w->H, top + j, top + j - 1, w->size - top - j + 1);
          yv = gsl_matrix_subrow(w->H, top + j + 1, top + j - 1, w->size - top - j + 1);
        }
      else
        {
          xv = gsl_matrix_subrow(H, j, j - 1, N - j + 1);
          yv = gsl_matrix_subrow(H, j + 1, j - 1, N - j + 1);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      if (w->Q)
        {
          /* accumulate Q */
          xv = gsl_matrix_column(w->Q, top + j);
          yv = gsl_matrix_column(w->Q, top + j + 1);
          gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
        }

      create_givens(gsl_matrix_get(H, j + 1, j),
                    gsl_matrix_get(H, j + 1, j - 1),
                    &cs,
                    &sn);
      sn = -sn;

      if (w->compute_s)
        {
          xv = gsl_matrix_subcolumn(w->H, top + j, 0, top + j + 2);
          yv = gsl_matrix_subcolumn(w->H, top + j - 1, 0, top + j + 2);
        }
      else
        {
          xv = gsl_matrix_subcolumn(H, j, 0, j + 2);
          yv = gsl_matrix_subcolumn(H, j - 1, 0, j + 2);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
      gsl_matrix_set(H, j + 1, j - 1, 0.0);

      if (w->compute_t)
        {
          xv = gsl_matrix_subcolumn(w->R, top + j, 0, top + j + 1);
          yv = gsl_matrix_subcolumn(w->R, top + j - 1, 0, top + j + 1);
        }
      else
        {
          xv = gsl_matrix_subcolumn(R, j, 0, j + 1);
          yv = gsl_matrix_subcolumn(R, j - 1, 0, j + 1);
        }

      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

      if (w->Z)
        {
          /* accumulate Z */
          xv = gsl_matrix_column(w->Z, top + j);
          yv = gsl_matrix_column(w->Z, top + j - 1);
          gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
        }
    }
} /* gen_tri_chase_zero() */

/*
gen_tri_zero_H()
  Companion function to get_tri_chase_zero(). After the zero on
the diagonal of R has been chased to the bottom, we zero the element
H(n, n - 1) in order to split off a 1-by-1 block.
*/

static inline void
gen_tri_zero_H(gsl_matrix *H, gsl_matrix *R, gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  size_t top;
  double cs, sn;
  gsl_vector_view xv, yv;

  if (w->needtop)
    top = gen_get_submatrix(w->H, H);

  create_givens(gsl_matrix_get(H, N - 1, N - 1),
                gsl_matrix_get(H, N - 1, N - 2),
                &cs,
                &sn);
  sn = -sn;

  if (w->compute_s)
    {
      xv = gsl_matrix_subcolumn(w->H, top + N - 1, 0, top + N);
      yv = gsl_matrix_subcolumn(w->H, top + N - 2, 0, top + N);
    }
  else
    {
      xv = gsl_matrix_column(H, N - 1);
      yv = gsl_matrix_column(H, N - 2);
    }

  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

  gsl_matrix_set(H, N - 1, N - 2, 0.0);

  if (w->compute_t)
    {
      xv = gsl_matrix_subcolumn(w->R, top + N - 1, 0, top + N - 1);
      yv = gsl_matrix_subcolumn(w->R, top + N - 2, 0, top + N - 1);
    }
  else
    {
      xv = gsl_matrix_subcolumn(R, N - 1, 0, N - 1);
      yv = gsl_matrix_subcolumn(R, N - 2, 0, N - 1);
    }

  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

  if (w->Z)
    {
      /* accumulate Z */
      xv = gsl_matrix_column(w->Z, top + N - 1);
      yv = gsl_matrix_column(w->Z, top + N - 2);
      gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
    }
} /* gen_tri_zero_H() */

/*
gen_search_small_elements()
  This routine searches for small elements in the matrix pencil
(H, R) to determine if any eigenvalues have converged.

Tests:

1. Test if the Hessenberg matrix has a small subdiagonal element:
   H(i, i - 1) < tolerance

2. Test if the Triangular matrix has a small diagonal element:
   R(i, i) < tolerance

Possible outcomes:

(A) Neither test passed: in this case 'flag' is set to 0 and the
    function returns 0

(B) Test 1 passes and 2 does not: in this case 'flag' is set to 1
    and we return the row index i such that H(i, i - 1) < tol

(C) Test 2 passes and 1 does not: in this case 'flag' is set to 2
    and we return the index i such that R(i, i) < tol

(D) Tests 1 and 2 both pass: in this case 'flag' is set to 3 and
    we return the index i such that H(i, i - 1) < tol and R(i, i) < tol

Inputs: H    - upper Hessenberg matrix
        R    - upper Triangular matrix
        flag - (output) flag set on output (see above)
        w    - workspace

Return: see above
*/

static inline size_t
gen_search_small_elements(gsl_matrix *H, gsl_matrix *R,
                          int *flag, gsl_eigen_gen_workspace *w)
{
  const size_t N = H->size1;
  int k;
  size_t i;
  int pass1 = 0;
  int pass2 = 0;

  for (k = (int) N - 1; k >= 0; --k)
    {
      i = (size_t) k;

      if (i != 0 && fabs(gsl_matrix_get(H, i, i - 1)) <= w->atol)
        {
          gsl_matrix_set(H, i, i - 1, 0.0);
          pass1 = 1;
        }

      if (fabs(gsl_matrix_get(R, i, i)) < w->btol)
        {
          gsl_matrix_set(R, i, i, 0.0);
          pass2 = 1;
        }

      if (pass1 && !pass2)      /* case B */
        {
          *flag = 1;
          return (i);
        }
      else if (!pass1 && pass2) /* case C */
        {
          *flag = 2;
          return (i);
        }
      else if (pass1 && pass2)  /* case D */
        {
          *flag = 3;
          return (i);
        }
    }

  /* neither test passed: case A */

  *flag = 0;
  return (0);
} /* gen_search_subdiag_small_elements() */

/*
gen_schur_standardize1()
  This function is called when a 1-by-1 block has converged -
convert the block to standard form and update the Schur forms and
vectors if required. Standard form here means that the diagonal
element of B is positive.

Inputs: A      - 1-by-1 matrix in Schur form S
        B      - 1-by-1 matrix in Schur form T
        alphar - where to store real part of eigenvalue numerator
        beta   - where to store eigenvalue denominator
        w      - workspace

Return: success
*/

static int
gen_schur_standardize1(gsl_matrix *A, gsl_matrix *B, double *alphar,
                       double *beta, gsl_eigen_gen_workspace *w)
{
  size_t i;
  size_t top;

  /*
   * it is a 1-by-1 block - the only requirement is that
   * B_{00} is > 0, so if it isn't apply a -I transformation
   */
  if (gsl_matrix_get(B, 0, 0) < 0.0)
    {
      if (w->needtop)
        top = gen_get_submatrix(w->H, A);

      if (w->compute_t)
        {
          for (i = 0; i <= top; ++i)
            gsl_matrix_set(w->R, i, top, -gsl_matrix_get(w->R, i, top));
        }
      else
        gsl_matrix_set(B, 0, 0, -gsl_matrix_get(B, 0, 0));

      if (w->compute_s)
        {
          for (i = 0; i <= top; ++i)
            gsl_matrix_set(w->H, i, top, -gsl_matrix_get(w->H, i, top));
        }
      else
        gsl_matrix_set(A, 0, 0, -gsl_matrix_get(A, 0, 0));

      if (w->Z)
        {
          for (i = 0; i < w->size; ++i)
            gsl_matrix_set(w->Z, i, top, -gsl_matrix_get(w->Z, i, top));
        }
    }

  *alphar = gsl_matrix_get(A, 0, 0);
  *beta = gsl_matrix_get(B, 0, 0);

  return GSL_SUCCESS;
} /* gen_schur_standardize1() */

/*
gen_schur_standardize2()
  This function is called when a 2-by-2 generalized block has
converged. Convert the block to standard form, which means B
is rotated so that

B = [ B11  0  ] with B11, B22 non-negative
    [  0  B22 ]

If the resulting block (A, B) has complex eigenvalues, they are
computed. Otherwise, the function will return GSL_CONTINUE to
notify caller that we need to do more single shift sweeps to
convert the 2-by-2 block into two 1-by-1 blocks.

Inputs: A      - 2-by-2 submatrix of schur form S
        B      - 2-by-2 submatrix of schur form T
        alpha1 - (output) where to store eigenvalue 1 numerator
        alpha2 - (output) where to store eigenvalue 2 numerator
        beta1  - (output) where to store eigenvalue 1 denominator
        beta2  - (output) where to store eigenvalue 2 denominator
        w      - workspace

Return: GSL_SUCCESS if block has complex eigenvalues (they are computed)
        GSL_CONTINUE if block has real eigenvalues (they are not computed)
*/

static int
gen_schur_standardize2(gsl_matrix *A, gsl_matrix *B, gsl_complex *alpha1,
                       gsl_complex *alpha2, double *beta1, double *beta2,
                       gsl_eigen_gen_workspace *w)
{
  double datB[4],
         datV[4],
         datS[2],
         work[2];
  gsl_matrix_view uv = gsl_matrix_view_array(datB, 2, 2);
  gsl_matrix_view vv = gsl_matrix_view_array(datV, 2, 2);
  gsl_vector_view sv = gsl_vector_view_array(datS, 2);
  gsl_vector_view wv = gsl_vector_view_array(work, 2);
  double B11, B22;
  size_t top;
  double det;
  double cr, sr, cl, sl;
  gsl_vector_view xv, yv;
  int s;

  if (w->needtop)
    top = gen_get_submatrix(w->H, A);

  /*
   * Rotate B so that
   *
   * B = [ B11  0  ]
   *     [  0  B22 ]
   *
   * with B11 non-negative
   */

  gsl_matrix_memcpy(&uv.matrix, B);
  gsl_linalg_SV_decomp(&uv.matrix, &vv.matrix, &sv.vector, &wv.vector);

  /*
   * Right now, B = U S V^t, where S = diag(s)
   *
   * The SVD routine may have computed reflection matrices U and V,
   * but it would be much nicer to have rotations since we won't have
   * to use BLAS mat-mat multiplications to update our matrices,
   * and can instead use drot. So convert them to rotations if
   * necessary
   */

  det = gsl_matrix_get(&vv.matrix, 0, 0) * gsl_matrix_get(&vv.matrix, 1, 1) -
        gsl_matrix_get(&vv.matrix, 0, 1) * gsl_matrix_get(&vv.matrix, 1, 0);
  if (det < 0.0)
    {
      /* V is a reflection, convert it to a rotation by inserting
       * F = [1 0; 0 -1] so that:
       *
       * B = U S [1  0] [1  0] V^t
       *         [0 -1] [0 -1]
       *
       * so S -> S F and V -> V F where F is the reflection matrix
       * We just need to invert S22 since the first column of V
       * will remain unchanged and we can just read off the CS and SN
       * parameters.
       */
      datS[1] = -datS[1];
    }

  cr = gsl_matrix_get(&vv.matrix, 0, 0);
  sr = gsl_matrix_get(&vv.matrix, 1, 0);

  /* same for U */
  det = gsl_matrix_get(&uv.matrix, 0, 0) * gsl_matrix_get(&uv.matrix, 1, 1) -
        gsl_matrix_get(&uv.matrix, 0, 1) * gsl_matrix_get(&uv.matrix, 1, 0);
  if (det < 0.0)
    datS[1] = -datS[1];

  cl = gsl_matrix_get(&uv.matrix, 0, 0);
  sl = gsl_matrix_get(&uv.matrix, 1, 0);

  B11 = gsl_vector_get(&sv.vector, 0);
  B22 = gsl_vector_get(&sv.vector, 1);

  /* make sure B11 is positive */
  if (B11 < 0.0)
    {
      B11 = -B11;
      B22 = -B22;
      cr = -cr;
      sr = -sr;
    }

  /*
   * At this point,
   *
   * [ S11  0  ] = [ CSL  SNL ] B [ CSR -SNR ]
   * [  0  S22 ]   [-SNL  CSL ]   [ SNR  CSR ]
   *
   * apply rotations to H and rest of R
   */

  if (w->compute_s)
    {
      xv = gsl_matrix_subrow(w->H, top, top, w->size - top);
      yv = gsl_matrix_subrow(w->H, top + 1, top, w->size - top);
      gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);

      xv = gsl_matrix_subcolumn(w->H, top, 0, top + 2);
      yv = gsl_matrix_subcolumn(w->H, top + 1, 0, top + 2);
      gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
    }
  else
    {
      xv = gsl_matrix_row(A, 0);
      yv = gsl_matrix_row(A, 1);
      gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);

      xv = gsl_matrix_column(A, 0);
      yv = gsl_matrix_column(A, 1);
      gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
    }

  if (w->compute_t)
    {
      if (top != (w->size - 2))
        {
          xv = gsl_matrix_subrow(w->R, top, top + 2, w->size - top - 2);
          yv = gsl_matrix_subrow(w->R, top + 1, top + 2, w->size - top - 2);
          gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
        }

      if (top != 0)
        {
          xv = gsl_matrix_subcolumn(w->R, top, 0, top);
          yv = gsl_matrix_subcolumn(w->R, top + 1, 0, top);
          gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
        }
    }

  if (w->Q)
    {
      xv = gsl_matrix_column(w->Q, top);
      yv = gsl_matrix_column(w->Q, top + 1);
      gsl_blas_drot(&xv.vector, &yv.vector, cl, sl);
    }

  if (w->Z)
    {
      xv = gsl_matrix_column(w->Z, top);
      yv = gsl_matrix_column(w->Z, top + 1);
      gsl_blas_drot(&xv.vector, &yv.vector, cr, sr);
    }

  gsl_matrix_set(B, 0, 0, B11);
  gsl_matrix_set(B, 0, 1, 0.0);
  gsl_matrix_set(B, 1, 0, 0.0);
  gsl_matrix_set(B, 1, 1, B22);

  /* if B22 is < 0, make it positive by negating its column */
  if (B22 < 0.0)
    {
      size_t i;

      if (w->compute_s)
        {
          for (i = 0; i < top + 2; ++i)
            gsl_matrix_set(w->H, i, top + 1, -gsl_matrix_get(w->H, i, top + 1));
        }
      else
        {
          gsl_matrix_set(A, 0, 1, -gsl_matrix_get(A, 0, 1));
          gsl_matrix_set(A, 1, 1, -gsl_matrix_get(A, 1, 1));
        }

      if (w->compute_t)
        {
          for (i = 0; i < top + 2; ++i)
            gsl_matrix_set(w->R, i, top + 1, -gsl_matrix_get(w->R, i, top + 1));
        }
      else
        {
          gsl_matrix_set(B, 0, 1, -gsl_matrix_get(B, 0, 1));
          gsl_matrix_set(B, 1, 1, -gsl_matrix_get(B, 1, 1));
        }

      if (w->Z)
        {
          xv = gsl_matrix_column(w->Z, top + 1);
          gsl_vector_scale(&xv.vector, -1.0);
        }
    }

  /* our block is now in standard form - compute eigenvalues */

  s = gen_compute_eigenvals(A, B, alpha1, alpha2, beta1, beta2);

  return s;
} /* gen_schur_standardize2() */

/*
gen_compute_eigenvals()
  Compute the complex eigenvalues of a 2-by-2 block

Return: GSL_CONTINUE if block contains real eigenvalues (they are not
        computed)
        GSL_SUCCESS on normal completion
*/

static int
gen_compute_eigenvals(gsl_matrix *A, gsl_matrix *B, gsl_complex *alpha1,
                      gsl_complex *alpha2, double *beta1, double *beta2)
{
  double wr1, wr2, wi, scale1, scale2;
  double s1inv;
  double A11, A12, A21, A22;
  double B11, B22;
  double c11r, c11i, c12, c21, c22r, c22i;
  double cz, cq;
  double szr, szi, sqr, sqi;
  double a1r, a1i, a2r, a2i, b1r, b1i, b1a, b2r, b2i, b2a;
  double alphar, alphai;
  double t1, an, bn, tempr, tempi, wabs;

  /*
   * This function is called from gen_schur_standardize2() and
   * its possible the standardization has perturbed the eigenvalues
   * onto the real line - so check for this before computing them
   */

  gsl_schur_gen_eigvals(A, B, &wr1, &wr2, &wi, &scale1, &scale2);
  if (wi == 0.0)
    return GSL_CONTINUE; /* real eigenvalues - continue QZ iteration */

  /* complex eigenvalues - compute alpha and beta */

  s1inv = 1.0 / scale1;

  A11 = gsl_matrix_get(A, 0, 0);
  A12 = gsl_matrix_get(A, 0, 1);
  A21 = gsl_matrix_get(A, 1, 0);
  A22 = gsl_matrix_get(A, 1, 1);

  B11 = gsl_matrix_get(B, 0, 0);
  B22 = gsl_matrix_get(B, 1, 1);

  c11r = scale1 * A11 - wr1 * B11;
  c11i = -wi * B11;
  c12 = scale1 * A12;
  c21 = scale1 * A21;
  c22r = scale1 * A22 - wr1 * B22;
  c22i = -wi * B22;

  if (fabs(c11r) + fabs(c11i) + fabs(c12) >
      fabs(c21) + fabs(c22r) + fabs(c22i))
    {
      t1 = gsl_hypot3(c12, c11r, c11i);
      if (t1 != 0.0)
        {
          cz = c12 / t1;
          szr = -c11r / t1;
          szi = -c11i / t1;
        }
      else
        {
          cz = 0.0;
          szr = 1.0;
          szi = 0.0;
        }
    }
  else
    {
      cz = hypot(c22r, c22i);
      if (cz <= GSL_DBL_MIN)
        {
          cz = 0.0;
          szr = 1.0;
          szi = 0.0;
        }
      else
        {
          tempr = c22r / cz;
          tempi = c22i / cz;
          t1 = hypot(cz, c21);
          cz /= t1;
          szr = -c21*tempr / t1;
          szi = c21*tempi / t1;
        }
    }

  an = fabs(A11) + fabs(A12) + fabs(A21) + fabs(A22);
  bn = fabs(B11) + fabs(B22);
  wabs = fabs(wr1) + fabs(wi);
  if (scale1*an > wabs*bn)
    {
      cq = cz * B11;
      if (cq <= GSL_DBL_MIN)
        {
          cq = 0.0;
          sqr = 1.0;
          sqi = 0.0;
        }
      else
        {
          sqr = szr * B22;
          sqi = -szi * B22;
        }
    }
  else
    {
      a1r = cz * A11 + szr * A12;
      a1i = szi * A12;
      a2r = cz * A21 + szr * A22;
      a2i = szi * A22;
      cq = hypot(a1r, a1i);
      if (cq <= GSL_DBL_MIN)
        {
          cq = 0.0;
          sqr = 1.0;
          sqi = 0.0;
        }
      else
        {
          tempr = a1r / cq;
          tempi = a1i / cq;
          sqr = tempr * a2r + tempi * a2i;
          sqi = tempi * a2r - tempr * a2i;
        }
    }

  t1 = gsl_hypot3(cq, sqr, sqi);
  cq /= t1;
  sqr /= t1;
  sqi /= t1;

  tempr = sqr*szr - sqi*szi;
  tempi = sqr*szi + sqi*szr;
  b1r = cq*cz*B11 + tempr*B22;
  b1i = tempi*B22;
  b1a = hypot(b1r, b1i);
  b2r = cq*cz*B22 + tempr*B11;
  b2i = -tempi*B11;
  b2a = hypot(b2r, b2i);

  *beta1 = b1a;
  *beta2 = b2a;

  alphar = (wr1 * b1a) * s1inv;
  alphai = (wi * b1a) * s1inv;
  GSL_SET_COMPLEX(alpha1, alphar, alphai);

  alphar = (wr1 * b2a) * s1inv;
  alphai = -(wi * b2a) * s1inv;
  GSL_SET_COMPLEX(alpha2, alphar, alphai);

  return GSL_SUCCESS;
} /* gen_compute_eigenvals() */

/*
gen_store_eigval1()
  Store eigenvalue of a 1-by-1 block into the alpha and beta
output vectors. This routine ensures that eigenvalues are stored
in the same order as they appear in the Schur form and updates
various internal workspace quantities.
*/

static void
gen_store_eigval1(const gsl_matrix *H, const double a, const double b,
                  gsl_vector_complex *alpha,
                  gsl_vector *beta, gsl_eigen_gen_workspace *w)
{
  size_t top = gen_get_submatrix(w->H, H);
  gsl_complex z;

  GSL_SET_COMPLEX(&z, a, 0.0);

  gsl_vector_complex_set(alpha, top, z);
  gsl_vector_set(beta, top, b);

  w->n_evals += 1;
  w->n_iter = 0;
  w->eshift = 0.0;
} /* gen_store_eigval1() */

/*
gen_store_eigval2()
  Store eigenvalues of a 2-by-2 block into the alpha and beta
output vectors. This routine ensures that eigenvalues are stored
in the same order as they appear in the Schur form and updates
various internal workspace quantities.
*/

static void
gen_store_eigval2(const gsl_matrix *H, const gsl_complex *alpha1,
                  const double beta1, const gsl_complex *alpha2,
                  const double beta2, gsl_vector_complex *alpha,
                  gsl_vector *beta, gsl_eigen_gen_workspace *w)
{
  size_t top = gen_get_submatrix(w->H, H);

  gsl_vector_complex_set(alpha, top, *alpha1);
  gsl_vector_set(beta, top, beta1);

  gsl_vector_complex_set(alpha, top + 1, *alpha2);
  gsl_vector_set(beta, top + 1, beta2);

  w->n_evals += 2;
  w->n_iter = 0;
  w->eshift = 0.0;
} /* gen_store_eigval2() */

/*
gen_get_submatrix()
  B is a submatrix of A. The goal of this function is to
compute the indices in A of where the matrix B resides
*/

static inline size_t
gen_get_submatrix(const gsl_matrix *A, const gsl_matrix *B)
{
  size_t diff;
  double ratio;
  size_t top;

  diff = (size_t) (B->data - A->data);

  /* B is on the diagonal of A, so measure distance in units of
     tda+1 */

  ratio = (double)diff / ((double) (A->tda + 1));

  top = (size_t) floor(ratio);

  return top;
} /* gen_get_submatrix() */

/* Frobenius norm */
inline static double
normF (gsl_matrix * A)
{
  size_t i, j, M = A->size1, N = A->size2;
  double sum = 0.0, scale = 0.0, ssq = 1.0;

  for (i = 0; i < M; i++)
    {
      for (j = 0; j < N; j++)
        {
          double Aij = gsl_matrix_get (A, i, j);

          if (Aij != 0.0)
            {
              double ax = fabs (Aij);

              if (scale < ax)
                {
                  ssq = 1.0 + ssq * (scale / ax) * (scale / ax);
                  scale = ax;
                }
              else
                {
                  ssq += (ax / scale) * (ax / scale);
                }
            }

        }
    }

  sum = scale * sqrt (ssq);

  return sum;
}

/* Generate a Givens rotation (cos,sin) which takes v=(x,y) to (|v|,0)

   From Golub and Van Loan, "Matrix Computations", Section 5.1.8 */

inline static void
create_givens (const double a, const double b, double *c, double *s)
{
  if (b == 0)
    {
      *c = 1;
      *s = 0;
    }
  else if (fabs (b) > fabs (a))
    {
      double t = -a / b;
      double s1 = 1.0 / sqrt (1 + t * t);
      *s = s1;
      *c = s1 * t;
    }
  else
    {
      double t = -b / a;
      double c1 = 1.0 / sqrt (1 + t * t);
      *c = c1;
      *s = c1 * t;
    }
}


#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <math.h>
#include "cconfigspace_internal.h"
#include "distribution_internal.h"

struct _ccs_distribution_roulette_data_s {
	_ccs_distribution_common_data_t  common_data;
	size_t                           num_areas;
	ccs_float_t                     *areas;
};
typedef struct _ccs_distribution_roulette_data_s _ccs_distribution_roulette_data_t;

static ccs_result_t
_ccs_distribution_del(ccs_object_t o) {
	(void)o;
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_roulette_get_bounds(_ccs_distribution_data_t *data,
                                      ccs_interval_t           *interval_ret);

static ccs_result_t
_ccs_distribution_roulette_samples(_ccs_distribution_data_t *data,
                                   ccs_rng_t                 rng,
                                   size_t                    num_values,
                                   ccs_numeric_t            *values);

static ccs_result_t
_ccs_distribution_roulette_strided_samples(_ccs_distribution_data_t *data,
                                           ccs_rng_t                 rng,
                                           size_t                    num_values,
                                           size_t                    stride,
                                           ccs_numeric_t            *values);

static ccs_result_t
_ccs_distribution_roulette_soa_samples(_ccs_distribution_data_t  *data,
                                       ccs_rng_t                  rng,
                                       size_t                     num_values,
                                       ccs_numeric_t            **values);

static _ccs_distribution_ops_t _ccs_distribution_roulette_ops = {
	{ &_ccs_distribution_del },
	&_ccs_distribution_roulette_samples,
	&_ccs_distribution_roulette_get_bounds,
	&_ccs_distribution_roulette_strided_samples,
	&_ccs_distribution_roulette_soa_samples
};

static ccs_result_t
_ccs_distribution_roulette_get_bounds(_ccs_distribution_data_t *data,
                                      ccs_interval_t           *interval_ret) {
	_ccs_distribution_roulette_data_t *d = (_ccs_distribution_roulette_data_t *)data;

	interval_ret->type = CCS_NUM_INTEGER;
	interval_ret->lower = CCSI(INT64_C(0));
	interval_ret->upper = CCSI((ccs_int_t)(d->num_areas));
	interval_ret->lower_included = CCS_TRUE;
	interval_ret->upper_included = CCS_FALSE;
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_roulette_samples(_ccs_distribution_data_t *data,
                                   ccs_rng_t                 rng,
                                   size_t                    num_values,
                                   ccs_numeric_t            *values) {
	_ccs_distribution_roulette_data_t *d = (_ccs_distribution_roulette_data_t *)data;

	gsl_rng *grng;
	CCS_VALIDATE(ccs_rng_get_gsl_rng(rng, &grng));

	for (size_t i = 0; i < num_values; i++) {
		ccs_float_t rnd = gsl_rng_uniform(grng);
		ccs_int_t index = ccs_dichotomic_search(d->num_areas, d->areas, rnd);
		values[i].i = index;
	}
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_roulette_strided_samples(_ccs_distribution_data_t *data,
                                           ccs_rng_t                 rng,
                                           size_t                    num_values,
                                           size_t                    stride,
                                           ccs_numeric_t            *values) {
	_ccs_distribution_roulette_data_t *d = (_ccs_distribution_roulette_data_t *)data;

	gsl_rng *grng;
	CCS_VALIDATE(ccs_rng_get_gsl_rng(rng, &grng));

	for (size_t i = 0; i < num_values; i++) {
		ccs_float_t rnd = gsl_rng_uniform(grng);
		ccs_int_t index = ccs_dichotomic_search(d->num_areas, d->areas, rnd);
		values[i*stride].i = index;
	}
	return CCS_SUCCESS;
}

static ccs_result_t
_ccs_distribution_roulette_soa_samples(_ccs_distribution_data_t  *data,
                                     ccs_rng_t                  rng,
                                     size_t                     num_values,
                                     ccs_numeric_t            **values) {
	if (*values)
		return _ccs_distribution_roulette_samples(data, rng, num_values, *values);
	return CCS_SUCCESS;
}

ccs_result_t
ccs_create_roulette_distribution(size_t              num_areas,
                                 ccs_float_t        *areas,
                                 ccs_distribution_t *distribution_ret) {
	CCS_CHECK_ARY(num_areas, areas);
	CCS_CHECK_PTR(distribution_ret);
	if (!num_areas || num_areas > INT64_MAX)
		return -CCS_INVALID_VALUE;
	ccs_float_t sum = 0.0;

	for(size_t i = 0; i < num_areas; i++) {
		if (areas[i] < 0.0)
			return -CCS_INVALID_VALUE;
		sum += areas[i];
	}
	if (sum == 0.0)
		return -CCS_INVALID_VALUE;
	ccs_float_t inv_sum = 1.0/sum;
	if (isnan(inv_sum) || !isfinite(inv_sum))
		return -CCS_INVALID_VALUE;

	uintptr_t mem = (uintptr_t)calloc(1, sizeof(struct _ccs_distribution_s) + sizeof(_ccs_distribution_roulette_data_t) + sizeof(ccs_float_t)*(num_areas + 1) + sizeof(ccs_numeric_type_t));

	if (!mem)
		return -CCS_OUT_OF_MEMORY;

	ccs_distribution_t distrib = (ccs_distribution_t)mem;
	_ccs_object_init(&(distrib->obj), CCS_DISTRIBUTION, (_ccs_object_ops_t *)&_ccs_distribution_roulette_ops);
	_ccs_distribution_roulette_data_t * distrib_data = (_ccs_distribution_roulette_data_t *)(mem + sizeof(struct _ccs_distribution_s));
	distrib_data->common_data.data_types    = (ccs_numeric_type_t *)(mem + sizeof(struct _ccs_distribution_s) + sizeof(_ccs_distribution_roulette_data_t) + sizeof(ccs_float_t)*(num_areas + 1));
	distrib_data->common_data.type          = CCS_ROULETTE;
	distrib_data->common_data.dimension     = 1;
	distrib_data->common_data.data_types[0] = CCS_NUM_INTEGER;
	distrib_data->num_areas                 = num_areas;
	distrib_data->areas                     = (ccs_float_t *)(mem + sizeof(struct _ccs_distribution_s) + sizeof(_ccs_distribution_roulette_data_t));

	distrib_data->areas[0] = 0.0;
	for(size_t i = 1; i <= num_areas; i++) {
		distrib_data->areas[i] = distrib_data->areas[i-1] + areas[i-1] * inv_sum;
	}
	distrib_data->areas[num_areas] = 1.0;
	if (distrib_data->areas[num_areas] < distrib_data->areas[num_areas-1]) {
		free((void *)mem);
		return -CCS_INVALID_VALUE;
	}
	distrib->data = (_ccs_distribution_data_t *)distrib_data;
	*distribution_ret = distrib;
	return CCS_SUCCESS;
}

ccs_result_t
ccs_roulette_distribution_get_num_areas(ccs_distribution_t  distribution,
                                        size_t             *num_areas_ret) {
	CCS_CHECK_DISTRIBUTION(distribution, CCS_ROULETTE);
	CCS_CHECK_PTR(num_areas_ret);
	_ccs_distribution_roulette_data_t * data = (_ccs_distribution_roulette_data_t *)distribution->data;
	*num_areas_ret = data->num_areas;
	return CCS_SUCCESS;
}

ccs_result_t
ccs_roulette_distribution_get_areas(ccs_distribution_t  distribution,
                                    size_t              num_areas,
                                    ccs_float_t        *areas,
                                    size_t             *num_areas_ret) {
	CCS_CHECK_DISTRIBUTION(distribution, CCS_ROULETTE);
	CCS_CHECK_ARY(num_areas, areas);
	if (!areas && !num_areas_ret)
		return -CCS_INVALID_VALUE;
	_ccs_distribution_roulette_data_t * data = (_ccs_distribution_roulette_data_t *)distribution->data;
	if (areas) {
		if (num_areas < data->num_areas)
			return -CCS_INVALID_VALUE;
		for (size_t i = 0; i < data->num_areas; i++)
			areas[i] = data->areas[i+1] - data->areas[i];
		for (size_t i = data->num_areas; i < num_areas; i++)
			areas[i] = 0.0;
	}
	if (num_areas_ret)
		*num_areas_ret = data->num_areas;
	return CCS_SUCCESS;
}


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

#include "Lambda.h"
#include "LambdaCreationFunctions.h"
#include "SelectionComp.h"
#include "PDBVector.h"
#include "SumResult.h"
#include "IntDoubleVectorPair.h"
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <random>
#include <gsl/gsl_vector.h>

/* The class for initializing the topic-probability for a document */
using namespace pdb;
class LDAInitialTopicProbSelection : public SelectionComp<IntDoubleVectorPair, SumResult> {

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

public:
    ENABLE_DEEP_COPY

    LDAInitialTopicProbSelection() {}
    LDAInitialTopicProbSelection(Vector<double>& fromPrior) {

        this->prior = fromPrior;

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

        /* Allocate space needed for myRand */
        int spaceNeeded = sizeof(gsl_rng) + src->type->size;
        myMem = makeObject<Vector<char>>(spaceNeeded, spaceNeeded);

        /* Copy src over */
        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<SumResult> checkMe) override {
        return makeLambda(checkMe, [](Handle<SumResult>& checkMe) { return true; });
    }

    Lambda<Handle<IntDoubleVectorPair>> getProjection(Handle<SumResult> checkMe) override {
        return makeLambda(checkMe, [&](Handle<SumResult>& checkMe) {

            gsl_rng* rng = getRng();
            Handle<IntDoubleVectorPair> result = makeObject<IntDoubleVectorPair>();
            int topicNum = this->prior.size();
            result->setInt(checkMe->getKey());
            Handle<Vector<double>> mySamples = makeObject<Vector<double>>(topicNum, topicNum);

	    /* Sample for the topic-probability */
            gsl_ran_dirichlet(rng, topicNum, this->prior.c_ptr(), mySamples->c_ptr());

            result->setVector(mySamples);

            return result;
        });
    }

    /* Get the GSL RNG from myMem */
    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;
    }

    Vector<double> getPrior() {
        return this->prior;
    }
};

#endif


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

#include <gsl/gsl_sf_bessel.h>

int main(void) {
    double x = 5.0;
    printf("J0(%g) = %.18e\n", x, gsl_sf_bessel_J0(x));
    return EXIT_SUCCESS;
}


#include <gsl/gsl_math.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_multifit.h>

/* Fit
 *
 * y = X c
 *
 * where X is an n x p matrix of n observations for p variables.
 *
 * The solution includes a possible standard form Tikhonov regularization:
 *
 * c = (X^T X + lambda^2 I)^{-1} X^T y
 *
 * where lambda^2 is the Tikhonov regularization parameter.
 *
 * The function multifit_linear_svd() must first be called to
 * compute the SVD decomposition of X
 *
 * Inputs: X        - least squares matrix
 *         y        - right hand side vector
 *         tol      - singular value tolerance
 *         lambda   - Tikhonov regularization parameter lambda;
 *                    ignored if <= 0
 *         rank     - (output) effective rank
 *         c        - (output) model coefficient vector
 *         rnorm    - (output) residual norm ||y - X c||
 *         snorm    - (output) solution norm ||c||
 *         work     - workspace
 *
 * Notes:
 * 1) The dimensions of X must match work->n and work->p which are set
 *    by multifit_linear_svd()
 * 2) On input:
 *    work->A contains U
 *    work->Q contains Q
 *    work->S contains singular values
 * 3) If this function is called from gsl_multifit_wlinear(), then
 *    the input y points to work->t, which contains sqrt(W) y. Since
 *    work->t is also used as scratch workspace by this function, we
 *    do the necessary computations with y first to avoid problems.
 * 4) When lambda <= 0, singular values are truncated when:
 *    s_j <= tol * s_0
 */

static int
multifit_linear_solve (const gsl_matrix * X,
                       const gsl_vector * y,
                       const double tol,
                       const double lambda,
                       size_t * rank,
                       gsl_vector * c,
                       double *rnorm,
                       double *snorm,
                       gsl_multifit_linear_workspace * work)
{
  const size_t n = X->size1;
  const size_t p = X->size2;

  if (n != work->n || p != work->p)
    {
      GSL_ERROR("observation matrix does not match workspace", GSL_EBADLEN);
    }
  else if (n != y->size)
    {
      GSL_ERROR("number of observations in y does not match matrix",
                GSL_EBADLEN);
    }
  else if (p != c->size)
    {
      GSL_ERROR ("number of parameters c does not match matrix",
                 GSL_EBADLEN);
    }
  else if (tol <= 0)
    {
      GSL_ERROR ("tolerance must be positive", GSL_EINVAL);
    }
  else
    {
      const double lambda_sq = lambda * lambda;

      double rho_ls = 0.0;     /* contribution to rnorm from OLS */

      size_t j, p_eff;

      /* these inputs are previously computed by multifit_linear_svd() */
      gsl_matrix_view A = gsl_matrix_submatrix(work->A, 0, 0, n, p);
      gsl_matrix_view Q = gsl_matrix_submatrix(work->Q, 0, 0, p, p);
      gsl_vector_view S = gsl_vector_subvector(work->S, 0, p);

      /* workspace */
      gsl_matrix_view QSI = gsl_matrix_submatrix(work->QSI, 0, 0, p, p);
      gsl_vector_view xt = gsl_vector_subvector(work->xt, 0, p);
      gsl_vector_view D = gsl_vector_subvector(work->D, 0, p);
      gsl_vector_view t = gsl_vector_subvector(work->t, 0, n);

      /*
       * Solve y = A c for c
       * c = Q diag(s_i / (s_i^2 + lambda_i^2)) U^T y
       */

      /* compute xt = U^T y */
      gsl_blas_dgemv (CblasTrans, 1.0, &A.matrix, y, 0.0, &xt.vector);

      if (n > p)
        {
          /*
           * compute OLS residual norm = || y - U U^T y ||;
           * for n = p, U U^T = I, so no need to calculate norm
           */
          gsl_vector_memcpy(&t.vector, y);
          gsl_blas_dgemv(CblasNoTrans, -1.0, &A.matrix, &xt.vector, 1.0, &t.vector);
          rho_ls = gsl_blas_dnrm2(&t.vector);
        }

      if (lambda > 0.0)
        {
          /* xt <-- [ s(i) / (s(i)^2 + lambda^2) ] .* U^T y */
          for (j = 0; j < p; ++j)
            {
              double sj = gsl_vector_get(&S.vector, j);
              double f = (sj * sj) / (sj * sj + lambda_sq);
              double *ptr = gsl_vector_ptr(&xt.vector, j);

              /* use D as workspace for residual norm */
              gsl_vector_set(&D.vector, j, (1.0 - f) * (*ptr));

              *ptr *= sj / (sj*sj + lambda_sq);
            }

          /* compute regularized solution vector */
          gsl_blas_dgemv (CblasNoTrans, 1.0, &Q.matrix, &xt.vector, 0.0, c);

          /* compute solution norm */
          *snorm = gsl_blas_dnrm2(c);

          /* compute residual norm */
          *rnorm = gsl_blas_dnrm2(&D.vector);

          if (n > p)
            {
              /* add correction to residual norm (see eqs 6-7 of [1]) */
              *rnorm = sqrt((*rnorm) * (*rnorm) + rho_ls * rho_ls);
            }

          /* reset D vector */
          gsl_vector_set_all(&D.vector, 1.0);
        }
      else
        {
          /* Scale the matrix Q, QSI = Q S^{-1} */

          gsl_matrix_memcpy (&QSI.matrix, &Q.matrix);

          {
            double s0 = gsl_vector_get (&S.vector, 0);
            p_eff = 0;

            for (j = 0; j < p; j++)
              {
                gsl_vector_view column = gsl_matrix_column (&QSI.matrix, j);
                double sj = gsl_vector_get (&S.vector, j);
                double alpha;

                if (sj <= tol * s0)
                  {
                    alpha = 0.0;
                  }
                else
                  {
                    alpha = 1.0 / sj;
                    p_eff++;
                  }

                gsl_vector_scale (&column.vector, alpha);
              }

            *rank = p_eff;
          }

          gsl_blas_dgemv (CblasNoTrans, 1.0, &QSI.matrix, &xt.vector, 0.0, c);

          /* Unscale the balancing factors */
          gsl_vector_div (c, &D.vector);

          *snorm = gsl_blas_dnrm2(c);
          *rnorm = rho_ls;
        }

      return GSL_SUCCESS;
    }
}


/**
 * \file FFT.h
 */

#ifndef ATK_UTILITY_FFT_H
#define ATK_UTILITY_FFT_H

#include <complex>
#include <cstdint>
#include <memory>
#include <vector>

#include <gsl/gsl>

#include <ATK/Utility/config.h>

namespace ATK
{
  /// An FFT class
  template<class DataType_>
  class ATK_UTILITY_EXPORT FFT
  {
  public:
    /// Builds the wrapper class
    FFT();
    /// Destructor
    ~FFT();

    FFT(const FFT&) = delete;
    FFT& operator=(const FFT&) = delete;

    /*!
     * @brief Sets a new size for the FFT and creates an associated plan for it
     * @ size is the new size of the plan
     */
    void set_size(gsl::index size);
    gsl::index get_size() const;
    /*!
     * @brief Processes a FFT from a real input array and stores it internally
     * @param input is the real input array of data to process
     * @param input_size is the size of the input array
     */
    void process(const DataType_* input, gsl::index input_size) const;
    /*!
    * @brief Processes a FFT from a real input to a complex output
    * @param input is the real input array of data to process
    * @param output is the complex output array
    * @param input_size is the size of both input and output arrays
    */
    void process_forward(const DataType_* input, std::complex<DataType_>* output, gsl::index input_size) const;
    /*!
    * @brief Processes an inverse FFT from a complex input to a real output
    * @param input is the complex input array of data to process
    * @param output is the real output array
    * @param input_size is the size of both input and output arrays
    */
    void process_backward(const std::complex<DataType_>* input, DataType_* output, gsl::index input_size) const;
    /*!
    * @brief Processes a FFT from a complex input array and stores it internally
    * @param input is the real input array of data to process
    * @param input_size is the size of the input array
    */
    void process(const std::complex<DataType_>* input, gsl::index input_size) const;
    /*!
    * @brief Processes a FFT from a complex input to a complex output
    * @param input is the real input array of data to process
    * @param output is the complex output array
    * @param input_size is the size of both input and output arrays
    */
    void process_forward(const std::complex<DataType_>* input, std::complex<DataType_>* output, gsl::index input_size) const;
    /*!
    * @brief Processes an inverse FFT from a complex input to a complex output
    * @param input is the complex input array of data to process
    * @param output is the real output array
    * @param input_size is the size of both input and output arrays
    */
    void process_backward(const std::complex<DataType_>* input, std::complex<DataType_>* output, gsl::index input_size) const;
    /*!
    * @brief Computes the amplitude of the resulting spectrum
    * @param amp is the output angle container
    */
    void get_amp(std::vector<DataType_>& amp) const;
    /*!
    * @brief Computes the angle of the resulting spectrum
    * @param angle is the output angle container
    */
    void get_angle(std::vector<DataType_>& angle) const;

  protected:
	  gsl::index size;

    class FFTImpl;
    std::unique_ptr<FFTImpl> impl;
  };
}

#endif


/*
** Implementation of LISA algorithm
** for statistical inference of fMRI images
**
** generic plug-in.
** A file containing a list of all 3D permutation images must be supplied.
**
** G.Lohmann, April 2017
*/

#include <viaio/Vlib.h>
#include <viaio/file.h>
#include <viaio/mu.h>
#include <viaio/option.h>
#include <viaio/os.h>
#include <viaio/VImage.h>
#include <via/via.h>

#include <gsl/gsl_cdf.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_histogram.h>

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

#ifdef _OPENMP
#include <omp.h>
#endif /*_OPENMP*/

#define ABS(x) ((x) > 0 ? (x) : -(x))

extern void VIsolatedVoxels(VImage src,float threshold);
extern void VHistogram(gsl_histogram *histogram,VString filename);
extern void VCheckImage(VImage src);
extern void FDR(VImage src,VImage dest,gsl_histogram *nullhist,gsl_histogram *realhist,double alpha);
extern void ImageStats(VImage src,double *,double *,double *hmin,double *hmax);
extern void VBilateralFilter(VImage src,VImage dest,int radius,double var1,double var2,int);
extern double VImageVar(VImage src);
extern void  VImageCount(VImage src);
extern void  VGetHistRange(VImage src,double *hmin,double *hmax);
extern float VGetMode(VImage src);
extern void  VZScale(VImage src,float mode,float stddev);
extern void HistoUpdate(VImage,gsl_histogram *);

/* make sure all input images are in float and have the same number of pixels */
void CheckImageTypes(VImage zmap,VImage *permimages,int numperm)
{
  size_t npixels = VImageNPixels(zmap);
  int i;
  for (i=0; i<numperm; i++) {
    if (npixels != VImageNPixels(permimages[i]))
      VError(" inconsistent number of pixels in permutation image %d",i);
    if (VPixelRepn(permimages[i]) != VFloatRepn) VError(" perm image %d is not in float repn");
  }
}

int main (int argc, char *argv[])
{
  static VString  filename = "";
  static VFloat   alpha = 0.05;
  static VShort   radius = 2;
  static VFloat   rvar = 2.0;
  static VFloat   svar = 2.0;
  static VShort   numiter = 2;
  static VBoolean centering = FALSE;
  static VBoolean cleanup = TRUE;
  static VShort   nproc = 0;
  static VOptionDescRec  options[] = {
    {"permutations",VStringRepn,1,(VPointer) &filename,VRequiredOpt,NULL,"List of all permutation images"},
    {"alpha",VFloatRepn,1,(VPointer) &alpha,VOptionalOpt,NULL,"FDR significance level"},
    {"radius",VShortRepn,1,(VPointer) &radius,VOptionalOpt,NULL,"Bilateral parameter (radius in voxels)"},
    {"rvar",VFloatRepn,1,(VPointer) &rvar,VOptionalOpt,NULL,"Bilateral parameter (radiometric)"},
    {"svar",VFloatRepn,1,(VPointer) &svar,VOptionalOpt,NULL,"Bilateral parameter (spatial)"},
    {"filteriterations",VShortRepn,1,(VPointer) &numiter,VOptionalOpt,NULL,"Bilateral parameter (number of iterations)"},
    {"cleanup",VBooleanRepn,1,(VPointer) &cleanup,VOptionalOpt,NULL,"Whether to remove isolated voxels"},
    {"j",VShortRepn,1,(VPointer) &nproc,VOptionalOpt,NULL,"Number of processors to use, '0' to use all"},
  };
  FILE *out_file=NULL,*in_file=NULL;
  VString in_filename=NULL;
  char *prg_name=GetLipsiaName("vlisa_generic");
  fprintf (stderr, "%s\n", prg_name);
  gsl_set_error_handler_off ();

  /* Parse command line arguments and identify files: */
  VParseFilterCmdZ (VNumber (options), options, argc, argv,&in_file,&out_file,&in_filename);

  /* Read the input zmap file: */
  VAttrList list = VReadAttrListZ(in_file,in_filename,0L,TRUE,FALSE);
  VImage zmap1 = VReadImage(list);
  if (zmap1 == NULL) VError(" no input zmap image found");
  if (VPixelRepn(zmap1) != VFloatRepn) VError(" input pixel repn must be float");
  VAttrList geolist = VGetGeoInfo(list);

  /* Read permutation file containing a list of 3D images */
  VAttrList listperm = VReadAttrList(filename,0L,FALSE,FALSE);
  int numperm  = VAttrListNumImages(listperm);
  VImage *zmap = VAttrListGetImages(listperm,numperm);
  CheckImageTypes(zmap1,zmap,numperm);
  fprintf(stderr," Number of permutation images: %d\n",(int)numperm);

  /* estimate null variance to adjust radiometric parameter, use first 30 permutations */
  double zvar=0,hmin=0,hmax=0;
  float stddev=1.0;
  int nperm=0;
  if (numperm > 0) {
    int tstperm = 30;
    if (tstperm > numperm) tstperm = numperm;
    double varsum=0,nx=0;
    for (nperm = 0; nperm < tstperm; nperm++) {
      zvar = VImageVar(zmap[nperm]);
      varsum += zvar;
      nx++;
    }
    double meanvar = varsum/nx;
    stddev = sqrt(meanvar);
  }

  /* get non-permuted hotspot map */
  float mode=0;
  if (centering) mode = VGetMode(zmap1);
  if (numperm > 0) VZScale(zmap1,mode,stddev);

  VImage dst1 = VCreateImageLike(zmap1);
  VBilateralFilter(zmap1,dst1,(int)radius,(double)rvar,(double)svar,(int)numiter);

  /* ini histograms */
  VGetHistRange(dst1,&hmin,&hmax);
  size_t nbins = 20000;
  gsl_histogram *hist0 = gsl_histogram_alloc (nbins);
  gsl_histogram_set_ranges_uniform (hist0,hmin,hmax);
  gsl_histogram *histz = gsl_histogram_alloc (nbins);
  gsl_histogram_set_ranges_uniform (histz,hmin,hmax);
  HistoUpdate(dst1,histz);

  /* omp-stuff */
#ifdef _OPENMP
  int num_procs=omp_get_num_procs();
  if (nproc > 0 && nproc < num_procs) num_procs = nproc;
  fprintf(stderr," using %d cores\n",(int)num_procs);
  omp_set_num_threads(num_procs);
#endif /* _OPENMP */

  /* do random permutations */
#pragma omp parallel for shared(zmap) schedule(dynamic)
  for (nperm = 0; nperm < numperm; nperm++) {
    if (nperm%20 == 0) fprintf(stderr," perm  %4d  of  %d\r",nperm,(int)numperm);

    float mode=0;
    if (centering) mode = VGetMode(zmap[nperm]);
    VZScale(zmap[nperm],mode,stddev);

    VImage dst = VCreateImageLike (zmap1);
    VBilateralFilter(zmap[nperm],dst,(int)radius,(double)rvar,(double)svar,(int)numiter);

    #pragma omp critical
    {
      HistoUpdate(dst,hist0);
    }
    VDestroyImage(dst);
  }

  /* apply fdr */
  VImage fdrimage = VCopyImage (dst1,NULL,VAllBands);
  if (numperm > 0) {
    FDR(dst1,fdrimage,hist0,histz,(double)alpha);

    if (cleanup && alpha < 1.0) {
      VIsolatedVoxels(fdrimage,(float)(1.0-alpha));
    }
  }

  /* output */
  VAttrList out_list = VCreateAttrList ();
  VHistory(VNumber(options),options,prg_name,&list,&out_list);
  VSetGeoInfo(geolist,out_list);
  VAppendAttr (out_list,"image",NULL,VImageRepn,fdrimage);
  if (! VWriteFile (out_file, out_list)) exit (1);
  fprintf (stderr, "\n%s: done.\n", argv[0]);
  exit(0);
}


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

/* #include <cblas.h> */
#include <lapacke_utils.h>

#include <jni.h>
#include "org_bitbucket_ioplus_openblas_Lapacke.h"

/*
 * Class:     org_bitbucket_ioplus_openblas_Lapacke
 * Method:    sgetrf
 * Signature: (II[FI[I)V
 */
    JNIEXPORT void JNICALL Java_org_bitbucket_ioplus_openblas_Lapacke_sgetrf
    (JNIEnv * env, jclass class,
     jint m, jint n, jfloatArray a, jint lda, jintArray ipiv){

        float *A;
        A = (*env)->GetPrimitiveArrayCritical(env, a, 0);
        int *IPIV;
        IPIV = (*env)->GetPrimitiveArrayCritical(env, ipiv, 0);

        LAPACKE_sgetrf(LAPACK_ROW_MAJOR,
                       m, n, A, lda, IPIV);

        (*env)->ReleasePrimitiveArrayCritical(env, a, A, 0);
        (*env)->ReleasePrimitiveArrayCritical(env, ipiv, IPIV, 0);

    }

/*
 * Class:     org_bitbucket_ioplus_openblas_Lapacke
 * Method:    sgetri
 * Signature: (I[FI[I)V
 */
    JNIEXPORT void JNICALL
    Java_org_bitbucket_ioplus_openblas_Lapacke_sgetri
    (JNIEnv * env, jclass class,
     jint n, jfloatArray a, jint lda, jintArray ipiv){

        float *A;
        A = (*env)->GetPrimitiveArrayCritical(env, a, 0);
        int *IPIV;
        IPIV = (*env)->GetPrimitiveArrayCritical(env, ipiv, 0);

        LAPACKE_sgetri(LAPACK_ROW_MAJOR,
                       n, A, lda, IPIV);

        (*env)->ReleasePrimitiveArrayCritical(env, a, A, 0);
        (*env)->ReleasePrimitiveArrayCritical(env, ipiv, IPIV, 0);

    }

/*
 * Class:     org_bitbucket_ioplus_openblas_Lapacke
 * Method:    sdeev
 * Signature: (CCI[FI[F[F[FI[FI)V
 */
JNIEXPORT void JNICALL Java_org_bitbucket_ioplus_openblas_Lapacke_sdeev
(JNIEnv * env, jclass class,
 jchar jobvl,
 jchar jobvr,
 jint n,
 jfloatArray a,
 jint lda,
 jfloatArray wr,
 jfloatArray wi,
 jfloatArray vl,
 jint ldvl,
 jfloatArray vr,
 jint ldvr){
    /* jni args -> c mapping  */

    float *A;
    float *WR;
    float *WI;
    float *VL;
    float *VR;

    A = (*env)->GetPrimitiveArrayCritical(env, a, 0);
    WR = (*env)->GetPrimitiveArrayCritical(env, wr, 0);
    WI = (*env)->GetPrimitiveArrayCritical(env, wi, 0);
    VL = (*env)->GetPrimitiveArrayCritical(env, vl, 0);
    VR = (*env)->GetPrimitiveArrayCritical(env, vr, 0);

    LAPACKE_sgeev(LAPACK_ROW_MAJOR,
                  jobvl,
                  jobvr,
                  n,
                  A,
                  lda,
                  WR, // values
                  WI,
                  VL,
                  ldvl,
                  VR, // vectors
                  ldvr);

    (*env)->ReleasePrimitiveArrayCritical(env, a, A, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, wr, WR, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, wi, WI, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, vr, VR, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, vl, VL, 0);

}

/*
 * Class:     org_bitbucket_ioplus_openblas_Lapacke
 * Method:    sgehrd
 * Signature: (III[FI[F)V
 */
JNIEXPORT void JNICALL Java_org_bitbucket_ioplus_openblas_Lapacke_sgehrd
(JNIEnv * env, jclass class,
 jint n,
 jint ilo,
 jint ihi,
 jfloatArray a,
 jint lda,
 jfloatArray tau
    ){
    float *A  = (*env)->GetPrimitiveArrayCritical(env, a, NULL);
    float *TAU = (*env)->GetPrimitiveArrayCritical(env, tau, NULL);
    LAPACKE_sgehrd(LAPACK_ROW_MAJOR,n, ilo, ihi, A, lda, TAU);
    (*env)->ReleasePrimitiveArrayCritical(env, a, A, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, tau, TAU, 0);
}

/*
 * Class:     org_bitbucket_ioplus_openblas_Lapacke
 * Method:    shseqr
 * Signature: (CCIII[FI[F[F[FI)V
 */
JNIEXPORT void JNICALL Java_org_bitbucket_ioplus_openblas_Lapacke_shseqr
(JNIEnv * env, jclass class,
 jchar job,
 jchar compz,
 jint n,
 jint ilo,
 jint ihi,
 jfloatArray h,
 jint ldh,
 jfloatArray wr,
 jfloatArray wi,
 jfloatArray z,
 jint ldz){

    float *H = (*env)->GetPrimitiveArrayCritical(env, h, 0);
    float *WR = (*env)->GetPrimitiveArrayCritical(env, wr, 0);
    float *WI = (*env)->GetPrimitiveArrayCritical(env, wi, 0);
    float *Z = (*env)->GetPrimitiveArrayCritical(env, z, 0);

    LAPACKE_shseqr(LAPACK_ROW_MAJOR,
                   job,
                   compz,
                   n,
                   ilo,
                   ihi,
                   H,
                   ldh,
                   WR,
                   WI,
                   Z,
                   ldz);

    (*env)->ReleasePrimitiveArrayCritical(env, h, H, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, wr, WR, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, wi, WI, 0);
    (*env)->ReleasePrimitiveArrayCritical(env, z, Z, 0);

}


#include <gsl/gsl_test.h>
#include <gsl/gsl_ieee_utils.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_cblas.h>

#include "tests.h"

void
test_asum (void) {
const double flteps = 1e-4, dbleps = 1e-6;
  {
   int N = 1;
   float X[] = { 0.239f };
   int incX = -1;
   float expected = 0.0f;
   float f;
   f = cblas_sasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "sasum(case 40)");
  };

  {
   int N = 1;
   double X[] = { -0.413 };
   int incX = -1;
   double expected = 0;
   double f;
   f = cblas_dasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dasum(case 41)");
  };

  {
   int N = 1;
   float X[] = { 0.1f, 0.017f };
   int incX = -1;
   float expected = 0.0f;
   float f;
   f = cblas_scasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "scasum(case 42)");
  };

  {
   int N = 1;
   double X[] = { -0.651, 0.079 };
   int incX = -1;
   double expected = 0;
   double f;
   f = cblas_dzasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dzasum(case 43)");
  };

  {
   int N = 2;
   float X[] = { 0.899f, -0.72f };
   int incX = 1;
   float expected = 1.619f;
   float f;
   f = cblas_sasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "sasum(case 44)");
  };

  {
   int N = 2;
   double X[] = { 0.271, -0.012 };
   int incX = 1;
   double expected = 0.283;
   double f;
   f = cblas_dasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dasum(case 45)");
  };

  {
   int N = 2;
   float X[] = { -0.567f, -0.645f, 0.098f, 0.256f };
   int incX = 1;
   float expected = 1.566f;
   float f;
   f = cblas_scasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "scasum(case 46)");
  };

  {
   int N = 2;
   double X[] = { -0.046, -0.671, -0.323, 0.785 };
   int incX = 1;
   double expected = 1.825;
   double f;
   f = cblas_dzasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dzasum(case 47)");
  };

  {
   int N = 2;
   float X[] = { 0.169f, 0.833f };
   int incX = -1;
   float expected = 0.0f;
   float f;
   f = cblas_sasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "sasum(case 48)");
  };

  {
   int N = 2;
   double X[] = { -0.586, -0.486 };
   int incX = -1;
   double expected = 0;
   double f;
   f = cblas_dasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dasum(case 49)");
  };

  {
   int N = 2;
   float X[] = { -0.314f, -0.318f, -0.835f, -0.807f };
   int incX = -1;
   float expected = 0.0f;
   float f;
   f = cblas_scasum(N, X, incX);
   gsl_test_rel(f, expected, flteps, "scasum(case 50)");
  };

  {
   int N = 2;
   double X[] = { -0.927, 0.152, -0.554, -0.844 };
   int incX = -1;
   double expected = 0;
   double f;
   f = cblas_dzasum(N, X, incX);
   gsl_test_rel(f, expected, dbleps, "dzasum(case 51)");
  };

}