/*
 * Copyright (c) 2015, Aleksas Mazeliauskas and Derek Teaney
 * All rights reserved.
 *
 * rnavier is distributed under MIT license;
 * see the LICENSE file that should be present in the root
 * of the source distribution, or alternately available at:
 * https://github.com/rnavier/rnavier/
 */
#ifndef RN_TEOSLats95p_h
#define RN_TEOSLats95p_h

#include <gsl/gsl_errno.h>
#include <gsl/gsl_spline.h>
#include "TEOS.h"
#include "numeric.h"

// Lattice EoS s95p_v0 by Huovinen and Petreczky. Data files are stored in /s95p, correspondingly
// in *par*.dat (T, \mu_1, \mu_2) and *dens*.dat (e, P, s, n_B, plasma ratio), with natural units,
// e.g., T-GeV, \mu-GeV, e-GeV/fm^3. Each file is
// particularly available in its range.
// file1: T~[0.0159,0.1801], e~[0.001,1.001]
// file2: T~[0.1801,0.2810], e~[1.001,11.00]
// file3: T~[0.2810,0.4243], e~[11.00,61.00]
// file4: T~[0.2423,0.6335], e~[61.00,311.0]
// There are also files avaiable for T<180MeV, with 28 non-zero chemical potential for baryon,
// strangeness, etc. For the time being, and for simplicity we ignore these files. So basically
// we have \mu = 0 and n_B = 0.

class TEOSs95p : public virtual TEOS {

   private:

      //minimum table values
      double fEmin;
      double fSmin;
      double fTmin;
      double fPmin;

      gsl_interp_accel *acc_eVSp;
      gsl_spline *eVSp;

      gsl_interp_accel *acc_tVSx;
      gsl_spline *tVSx;

      gsl_interp_accel *acc_eVSt;
      gsl_spline *eVSt;

      gsl_interp_accel *acc_eVSs;
      gsl_spline *eVSs;

      gsl_interp_accel *acc_sVSe;
      gsl_spline *sVSe;

      void eos(const double &e, double &p, double &cs)  ;
      void st(const double &e, double &s, double &t)  ;

      double fEtaOverS ;    //!< The Shear viscosity/entropy
      double fEtaOverSHad ; //!< The Shear viscosity/entropy
      double fSigmaOverS ;  //!< The Shear viscosity/entropy
      double fKappaTOverS ; //!< The Conductivity/entropy
      double fTPi_EtaST ;  //!< tau_pi / (eta/sT)
      double fL1_EtaTPi ;  //!< lambda_1 /(eta*tau_pi)
      double fL2_EtaTPi ;  //!< lambda_2 /(eta*tau_pi)

   public:

      TEOSs95p ();
      ~TEOSs95p ();

      virtual void read(std::istream &in)  ;

      virtual void write(std::ostream &out) ;

      virtual void eos(const double &e, const double &n,
            double &p, double &cs) ;

      virtual double eofs(const double &s, const double &n) ;

      virtual void stmu(const double &e, const double &n,
            double &s, double &t, double &mu) ;

      virtual void viscosity(const double &e, const double &n,
         double &sigma_overs, double &kappaT_overs, double &eta_overs) ;

      virtual void getBRSSSParams(const double &e, const double &n, double &tpi_etast, double &l1_ntpi, double &l2_ntpi)
      { tpi_etast =  fTPi_EtaST ; l1_ntpi = fL1_EtaTPi ; l2_ntpi = fL2_EtaTPi ; }

      void tmux(const double &e, const double &n, double &t, double &mub, double &mus, double &x) ;

} ;

std::unique_ptr<TEOS> make_eos_eoss95p(TRNavier3DBj *rn, const std::string &icname) ;
#endif


/* gsl_histogram2d_oper.c
 * Copyright (C) 2000  Simone Piccardi
 *
 * This library 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 library; if not, write to the
 * Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 */
/***************************************************************
 *
 * File gsl_histogram2d_oper.c:
 * Routine to make operation on 2D histograms.
 * Need GSL library and header.
 * Contains the routines:
 * gsl_histogram2d_same_binning check if two histograms have the same binning
 * gsl_histogram2d_add          add two histogram
 * gsl_histogram2d_sub          subctract two histogram
 * gsl_histogram2d_mult         multiply two histogram
 * gsl_histogram2d_div          divide two histogram
 * gsl_histogram2d_scale        scale histogram contents
 *
 * Author: S. Piccardi
 * Jan. 2000
 *
 ***************************************************************/
#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_histogram2d.h>

/*
 * gsl_histogram2d_same_binning:
 * control if two histogram have the
 * same binning
 */
int
gsl_histogram2d_equal_bins_p (const gsl_histogram2d * h1,
                              const gsl_histogram2d * h2)
{

  if ((h1->nx != h2->nx) || (h1->ny != h2->ny))
    {
      return 0;
    }
  {
    size_t i;
    /* init ranges */
    for (i = 0; i <= (h1->nx); i++)
      {
        if (h1->xrange[i] != h2->xrange[i])
          {
            return 0;
          }
      }
    for (i = 0; i <= (h1->ny); i++)
      {
        if (h1->yrange[i] != h2->yrange[i])
          {
            return 0;
          }
      }
  }
  return 1;
}

/*
 * gsl_histogram2d_add:
 * add two histogram
 */

int
gsl_histogram2d_add (gsl_histogram2d * h1, const gsl_histogram2d * h2)
{
  size_t i;

  if (!gsl_histogram2d_equal_bins_p (h1, h2))
    {
      GSL_ERROR ("histograms have different binning", GSL_EINVAL);
    }

  for (i = 0; i < (h1->nx) * (h1->ny); i++)
    {
      h1->bin[i] += h2->bin[i];
    }

  return GSL_SUCCESS;
}

/*
 * gsl_histogram2d_sub:
 * subtract two histogram
 */

int
gsl_histogram2d_sub (gsl_histogram2d * h1, const gsl_histogram2d * h2)
{
  size_t i;

  if (!gsl_histogram2d_equal_bins_p (h1, h2))
    {
      GSL_ERROR ("histograms have different binning", GSL_EINVAL);
    }

  for (i = 0; i < (h1->nx) * (h1->ny); i++)
    {
      h1->bin[i] -= h2->bin[i];
    }

  return GSL_SUCCESS;
}

/*
 * gsl_histogram2d_mult:
 * multiply two histogram
 */

int
gsl_histogram2d_mul (gsl_histogram2d * h1, const gsl_histogram2d * h2)
{
  size_t i;

  if (!gsl_histogram2d_equal_bins_p (h1, h2))
    {
      GSL_ERROR ("histograms have different binning", GSL_EINVAL);
    }

  for (i = 0; i < (h1->nx) * (h1->ny); i++)
    {
      h1->bin[i] *= h2->bin[i];
    }

  return GSL_SUCCESS;
}

/*
 * gsl_histogram2d_div:
 * divide two histogram
 */

int
gsl_histogram2d_div (gsl_histogram2d * h1, const gsl_histogram2d * h2)
{
  size_t i;

  if (!gsl_histogram2d_equal_bins_p (h1, h2))
    {
      GSL_ERROR ("histograms have different binning", GSL_EINVAL);
    }

  for (i = 0; i < (h1->nx) * (h1->ny); i++)
    {
      h1->bin[i] /= h2->bin[i];
    }

  return GSL_SUCCESS;
}

/*
 * gsl_histogram2d_scale:
 * scale a histogram by a numeric factor
 */

int
gsl_histogram2d_scale (gsl_histogram2d * h, double scale)
{
  size_t i;

  for (i = 0; i < (h->nx) * (h->ny); i++)
    {
      h->bin[i] *= scale;
    }

  return GSL_SUCCESS;
}

/*
 * gsl_histogram2d_shift:
 * shift a histogram by a numeric offset
 */

int
gsl_histogram2d_shift (gsl_histogram2d * h, double shift)
{
  size_t i;

  for (i = 0; i < (h->nx) * (h->ny); i++)
    {
      h->bin[i] += shift;
    }

  return GSL_SUCCESS;
}


#include <stdio.h>
#include <stdarg.h>
#include <string.h>
#include <math.h>
#include <gbpLib.h>
#include <gbpRNG.h>
#include <gbpMCMC.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_fit.h>
#include <gsl/gsl_interp.h>

void generate_MCMC_proposition(MCMC_info *MCMC, int flag_chain_init) {
    // Set the parameters for first trial parameters for the proposition
    switch(flag_chain_init) {
        case GBP_TRUE:
            memcpy(MCMC->P_new, MCMC->P_init, (size_t)MCMC->n_P * sizeof(double));
            memcpy(MCMC->P_last, MCMC->P_init, (size_t)MCMC->n_P * sizeof(double));
            memcpy(MCMC->P_chain, MCMC->P_init, (size_t)MCMC->n_P * sizeof(double));
            MCMC->flag_init_chain = GBP_FALSE;
            MCMC->n_success       = 0;
            MCMC->n_fail          = 0;
            MCMC->n_propositions  = 0;
            break;
        case GBP_FALSE:
            generate_MCMC_parameters(MCMC);
            break;
    }

    // Keep generating new parameter sets until the mapping function is satisfied
    while(MCMC->map_P_to_M(MCMC->P_new, MCMC, MCMC->M_new)) {
        MCMC->n_map_calls++;
        MCMC->first_map_call = GBP_FALSE;
        generate_MCMC_parameters(MCMC);
    }
    MCMC->first_map_call = GBP_FALSE;
    MCMC->n_map_calls++;

    // Produce likelihood for this proposition
    MCMC->compute_MCMC_ln_likelihood(
        MCMC, MCMC->M_new, MCMC->P_new, MCMC->ln_likelihood_DS, MCMC->n_DoF_DS, &(MCMC->ln_likelihood_new), &(MCMC->n_DoF));
    if(!SID_CHECK_BITFIELD_SWITCH(MCMC->mode, MCMC_MODE_PARALLEL)) {
        SID_Bcast(MCMC->ln_likelihood_DS, MCMC->n_DS, SID_DOUBLE, SID_MASTER_RANK, MCMC->comm);
        SID_Bcast(MCMC->n_DoF_DS, MCMC->n_DS, SID_INT, SID_MASTER_RANK, MCMC->comm);
        SID_Bcast(&(MCMC->ln_likelihood_new), 1, SID_DOUBLE, SID_MASTER_RANK, MCMC->comm);
        SID_Bcast(&(MCMC->n_DoF), 1, SID_INT, SID_MASTER_RANK, MCMC->comm);
    }

    MCMC->first_likelihood_call = GBP_FALSE;
    if(flag_chain_init) {
        MCMC->ln_likelihood_chain = MCMC->ln_likelihood_new;
        MCMC->ln_likelihood_best  = MCMC->ln_likelihood_new;
        memcpy(MCMC->P_best, MCMC->P_new, (size_t)MCMC->n_P * sizeof(double));
        MCMC->ln_Pr_chain = 0.;
        MCMC->ln_Pr_new   = 0.;
    }
    // Keep track of the best proposition
    else if(MCMC->ln_likelihood_new > MCMC->ln_likelihood_best) {
        MCMC->ln_likelihood_best = MCMC->ln_likelihood_new;
        memcpy(MCMC->P_best, MCMC->P_new, (size_t)MCMC->n_P * sizeof(double));
    }
}


/**
 *
 * @file zcposv.c
 *
 *  PLASMA computational routines
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Emmanuel Agullo
 * @date 2010-11-15
 * @precisions mixed zc -> ds
 *
 **/
#include <stdlib.h>
#include <math.h>
#include <lapacke.h>
#include "common.h"

#define PLASMA_zlag2c(_descA, _descSB)                \
  plasma_parallel_call_4(plasma_pzlag2c,              \
                         PLASMA_desc,      (_descA),  \
                         PLASMA_desc,      (_descSB), \
                         PLASMA_sequence*, sequence,  \
                         PLASMA_request*,  request)

#define PLASMA_clag2z(_descSA, _descB)                \
  plasma_parallel_call_4(plasma_pclag2z,              \
                         PLASMA_desc,      (_descSA), \
                         PLASMA_desc,      (_descB),  \
                         PLASMA_sequence*, sequence,  \
                         PLASMA_request*,  request)

#define PLASMA_zlange(_norm, _descA, _result, _work)   \
  _result = 0;                                         \
  plasma_parallel_call_6(plasma_pzlange,               \
                         PLASMA_enum,      (_norm),    \
                         PLASMA_desc,      (_descA),   \
                         double*,          (_work),    \
                         double*,          &(_result), \
                         PLASMA_sequence*, sequence,   \
                         PLASMA_request*,  request);

#define PLASMA_zlanhe(_norm, _uplo, _descA, _result, _work) \
  _result = 0;                                              \
  plasma_parallel_call_7(plasma_pzlanhe,                    \
                         PLASMA_enum,      (_norm),         \
                         PLASMA_enum,      (_uplo),         \
                         PLASMA_desc,      (_descA),        \
                         double*,          (_work),         \
                         double*,          &(_result),      \
                         PLASMA_sequence*, sequence,        \
                         PLASMA_request*,  request);

#define PLASMA_zlacpy(_descA, _descB)                        \
  plasma_parallel_call_5(plasma_pzlacpy,                     \
                         PLASMA_enum,      PlasmaUpperLower, \
                         PLASMA_desc,      (_descA),         \
                         PLASMA_desc,      (_descB),         \
                         PLASMA_sequence*, sequence,         \
                         PLASMA_request*,  request)

#define PLASMA_zgeadd(_alpha, _descA, _descB)           \
  plasma_parallel_call_5(plasma_pzgeadd,                \
                         PLASMA_Complex64_t, (_alpha),  \
                         PLASMA_desc,        (_descA),  \
                         PLASMA_desc,        (_descB),  \
                         PLASMA_sequence*,   sequence,  \
                         PLASMA_request*,    request)

/***************************************************************************//**
 *
 * @ingroup PLASMA_Complex64_t
 *
 *  PLASMA_zcposv - Computes the solution to a system of linear equations A * X = B,
 *  where A is an N-by-N symmetric positive definite (or Hermitian positive definite
 *  in the complex case) matrix and X and B are N-by-NRHS matrices.
 *  The Cholesky decomposition is used to factor A as
 *
 *    A = U**H * U, if uplo = PlasmaUpper, or
 *    A = L * L**H, if uplo =  PlasmaLower,
 *
 *  where U is an upper triangular matrix and  L is a lower triangular matrix.
 *  The factored form of A is then used to solve the system of equations A * X = B.
 *
 *  PLASMA_zcposv first attempts to factorize the matrix in COMPLEX and use this
 *  factorization within an iterative refinement procedure to produce a
 *  solution with COMPLEX*16 normwise backward error quality (see below).
 *  If the approach fails the method switches to a COMPLEX*16
 *  factorization and solve.
 *
 *  The iterative refinement is not going to be a winning strategy if
 *  the ratio COMPLEX performance over COMPLEX*16 performance is too
 *  small. A reasonable strategy should take the number of right-hand
 *  sides and the size of the matrix into account. This might be done
 *  with a call to ILAENV in the future. Up to now, we always try
 *  iterative refinement.
 *
 *  The iterative refinement process is stopped if ITER > ITERMAX or
 *  for all the RHS we have: RNRM < N*XNRM*ANRM*EPS*BWDMAX
 *  where:
 *
 *  - ITER is the number of the current iteration in the iterative refinement process
 *  - RNRM is the infinity-norm of the residual
 *  - XNRM is the infinity-norm of the solution
 *  - ANRM is the infinity-operator-norm of the matrix A
 *  - EPS is the machine epsilon returned by DLAMCH('Epsilon').
 *
 *  Actually, in its current state (PLASMA 2.1.0), the test is slightly relaxed.
 *
 *  The values ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively.
 *
 *******************************************************************************
 *
 * @param[in] uplo
 *          Specifies whether the matrix A is upper triangular or lower triangular:
 *          = PlasmaUpper: Upper triangle of A is stored;
 *          = PlasmaLower: Lower triangle of A is stored.
 *
 * @param[in] N
 *          The number of linear equations, i.e., the order of the matrix A. N >= 0.
 *
 * @param[in] NRHS
 *          The number of right hand sides, i.e., the number of columns of the matrix B.
 *          NRHS >= 0.
 *
 * @param[in] A
 *          The N-by-N symmetric positive definite (or Hermitian) coefficient matrix A.
 *          If uplo = PlasmaUpper, the leading N-by-N upper triangular part of A
 *          contains the upper triangular part of the matrix A, and the strictly lower triangular
 *          part of A is not referenced.
 *          If UPLO = 'L', the leading N-by-N lower triangular part of A contains the lower
 *          triangular part of the matrix A, and the strictly upper triangular part of A is not
 *          referenced.
 *          This matrix is not modified.
 *
 * @param[in] LDA
 *          The leading dimension of the array A. LDA >= max(1,N).
 *
 * @param[in] B
 *          The N-by-NRHS matrix of right hand side matrix B.
 *
 * @param[in] LDB
 *          The leading dimension of the array B. LDB >= max(1,N).
 *
 * @param[out] X
 *          If return value = 0, the N-by-NRHS solution matrix X.
 *
 * @param[in] LDX
 *          The leading dimension of the array B. LDX >= max(1,N).
 *
 * @param[out] ITER
 *          The number of the current iteration in the iterative refinement process
 *
 *******************************************************************************
 *
 * @return
 *          \retval PLASMA_SUCCESS successful exit
 *          \retval <0 if -i, the i-th argument had an illegal value
 *          \retval >0 if i, the leading minor of order i of A is not positive definite, so the
 *               factorization could not be completed, and the solution has not been computed.
 *
 *******************************************************************************
 *
 * @sa PLASMA_zcposv_Tile
 * @sa PLASMA_zcposv_Tile_Async
 * @sa PLASMA_dsposv
 * @sa PLASMA_zposv
 *
 ******************************************************************************/
int PLASMA_zcposv(PLASMA_enum uplo, int N, int NRHS,
                  PLASMA_Complex64_t *A, int LDA,
                  PLASMA_Complex64_t *B, int LDB,
                  PLASMA_Complex64_t *X, int LDX, int *ITER)
{
    int NB;
    int status;
    PLASMA_desc  descA;
    PLASMA_desc  descB;
    PLASMA_desc  descX;
    plasma_context_t *plasma;
    PLASMA_sequence *sequence = NULL;
    PLASMA_request request = PLASMA_REQUEST_INITIALIZER;

    plasma = plasma_context_self();
    if (plasma == NULL) {
        plasma_fatal_error("PLASMA_zcposv", "PLASMA not initialized");
        return PLASMA_ERR_NOT_INITIALIZED;
    }

    *ITER = 0;

    /* Check input arguments */
    if (uplo != PlasmaUpper && uplo != PlasmaLower) {
        plasma_error("PLASMA_zcposv", "illegal value of uplo");
        return -1;
    }
    if (N < 0) {
        plasma_error("PLASMA_zcposv", "illegal value of N");
        return -2;
    }
    if (NRHS < 0) {
        plasma_error("PLASMA_zcposv", "illegal value of NRHS");
        return -3;
    }
    if (LDA < max(1, N)) {
        plasma_error("PLASMA_zcposv", "illegal value of LDA");
        return -5;
    }
    if (LDB < max(1, N)) {
        plasma_error("PLASMA_zcposv", "illegal value of LDB");
        return -7;
    }
    if (LDX < max(1, N)) {
        plasma_error("PLASMA_zcposv", "illegal value of LDX");
        return -9;
    }
    /* Quick return - currently NOT equivalent to LAPACK's
     * LAPACK does not have such check for ZCPOSV */
    if (min(N, NRHS) == 0)
        return PLASMA_SUCCESS;

    /* Tune NB depending on M, N & NRHS; Set NBNBSIZE */
    status = plasma_tune(PLASMA_FUNC_ZCPOSV, N, N, NRHS);
    if (status != PLASMA_SUCCESS) {
        plasma_error("PLASMA_zcposv", "plasma_tune() failed");
        return status;
    }

    NB = PLASMA_NB;

    plasma_sequence_create(plasma, &sequence);

    /* DOUBLE PRECISION INITIALIZATION */
    if ( PLASMA_TRANSLATION == PLASMA_OUTOFPLACE ) {
        plasma_zooplap2tile( descA, A, NB, NB, LDA, N,    0, 0, N, N,    sequence, &request,
                             plasma_desc_mat_free(&(descA)) );
        plasma_zooplap2tile( descB, B, NB, NB, LDB, NRHS, 0, 0, N, NRHS, sequence, &request,
                             plasma_desc_mat_free(&(descA)); plasma_desc_mat_free(&(descB)) );
        plasma_zdesc_alloc(  descX, NB, NB, N, NRHS, 0, 0, N, NRHS, plasma_desc_mat_free(&(descA)); plasma_desc_mat_free(&(descB)); plasma_desc_mat_free(&(descX)) );
    } else {
        plasma_ziplap2tile( descA, A, NB, NB, LDA, N,    0, 0, N, N,
                            sequence, &request);
        plasma_ziplap2tile( descB, B, NB, NB, LDB, NRHS, 0, 0, N, NRHS,
                            sequence, &request);

        descX = plasma_desc_init(
            PlasmaComplexDouble, NB, NB, (NB*NB),
            LDX, NRHS, 0, 0, N, NRHS);
        descX.mat = X;
    }

    /* Call the native interface */
    status = PLASMA_zcposv_Tile_Async(uplo, &descA, &descB, &descX, ITER, sequence, &request);

    if (status == PLASMA_SUCCESS) {
        if ( PLASMA_TRANSLATION == PLASMA_OUTOFPLACE ) {
            plasma_zooptile2lap( descX, X, NB, NB, LDX, NRHS,  sequence, &request);
            plasma_dynamic_sync();
            plasma_desc_mat_free(&descA);
            plasma_desc_mat_free(&descB);
            plasma_desc_mat_free(&descX);
        } else {
            plasma_ziptile2lap( descA, A, NB, NB, LDA, N,     sequence, &request);
            plasma_ziptile2lap( descB, B, NB, NB, LDB, NRHS,  sequence, &request);
            plasma_ziptile2lap( descX, X, NB, NB, LDX, NRHS,  sequence, &request);
            plasma_dynamic_sync();
        }
    }

    status = sequence->status;
    plasma_sequence_destroy(plasma, sequence);
    return status;
}

/***************************************************************************//**
 *
 * @ingroup PLASMA_Complex64_t_Tile
 *
 *  PLASMA_zcposv_Tile - Solves a symmetric positive definite or Hermitian positive definite
 *  system of linear equations using the Cholesky factorization and mixed-precision iterative refinement.
 *  Tile equivalent of PLASMA_zcposv().
 *  Operates on matrices stored by tiles.
 *  All matrices are passed through descriptors.
 *  All dimensions are taken from the descriptors.
 *
 *******************************************************************************
 *
 * @param[in] uplo
 *          Specifies whether the matrix A is upper triangular or lower triangular:
 *          = PlasmaUpper: Upper triangle of A is stored;
 *          = PlasmaLower: Lower triangle of A is stored.
 *
 * @param[in,out] A
 *          On entry, the N-by-N symmetric positive definite (or Hermitian) coefficient matrix A.
 *          If uplo = PlasmaUpper, the leading N-by-N upper triangular part of A
 *          contains the upper triangular part of the matrix A, and the strictly lower triangular
 *          part of A is not referenced.
 *          If UPLO = 'L', the leading N-by-N lower triangular part of A contains the lower
 *          triangular part of the matrix A, and the strictly upper triangular part of A is not
 *          referenced.
 *          - If the iterative refinement converged, A is not modified;
 *          - otherwise, it falled backed to double precision solution,
 *
 * @param[in] B
 *          On entry, the N-by-NRHS matrix of right hand side matrix B.
 *
 * @param[out] X
 *          On exit, if return value = 0, the N-by-NRHS solution matrix X.
 *
 * @param[out] ITER
 *          The number of the current iteration in the iterative refinement process
 *
 *******************************************************************************
 *
 * @return
 *          \retval PLASMA_SUCCESS successful exit
 *          \retval >0 if i, the leading minor of order i of A is not positive definite, so the
 *               factorization could not be completed, and the solution has not been computed.
 *
 *******************************************************************************
 *
 * @sa PLASMA_zcposv
 * @sa PLASMA_zcposv_Tile_Async
 * @sa PLASMA_dsposv_Tile
 * @sa PLASMA_zposv_Tile
 *
 ******************************************************************************/
int PLASMA_zcposv_Tile(PLASMA_enum uplo, PLASMA_desc *A, PLASMA_desc *B,
                       PLASMA_desc *X, int *ITER)
{
    plasma_context_t *plasma;
    PLASMA_sequence *sequence = NULL;
    PLASMA_request request = PLASMA_REQUEST_INITIALIZER;
    int status;

    plasma = plasma_context_self();
    if (plasma == NULL) {
        plasma_fatal_error("PLASMA_zcposv_Tile", "PLASMA not initialized");
        return PLASMA_ERR_NOT_INITIALIZED;
    }
    plasma_sequence_create(plasma, &sequence);
    status = PLASMA_zcposv_Tile_Async(uplo, A, B, X, ITER, sequence, &request);
    if (status != PLASMA_SUCCESS)
        return status;
    plasma_dynamic_sync();
    status = sequence->status;
    plasma_sequence_destroy(plasma, sequence);
    return status;
}

/***************************************************************************//**
 *
 * @ingroup PLASMA_Complex64_t_Tile_Async
 *
 *  PLASMA_zcposv_Tile_Async - Solves a symmetric positive definite or Hermitian
 *  positive definite system of linear equations using the Cholesky factorization
 *  and mixed-precision iterative refinement.
 *  Non-blocking equivalent of PLASMA_zcposv_Tile().
 *  May return before the computation is finished.
 *  Allows for pipelining of operations at runtime.
 *
 *******************************************************************************
 *
 * @param[in] sequence
 *          Identifies the sequence of function calls that this call belongs to
 *          (for completion checks and exception handling purposes).
 *
 * @param[out] request
 *          Identifies this function call (for exception handling purposes).
 *
 *******************************************************************************
 *
 * @sa PLASMA_zcposv
 * @sa PLASMA_zcposv_Tile
 * @sa PLASMA_dsposv_Tile_Async
 * @sa PLASMA_zposv_Tile_Async
 *
 ******************************************************************************/
int PLASMA_zcposv_Tile_Async(PLASMA_enum uplo, PLASMA_desc *A, PLASMA_desc *B,
                             PLASMA_desc *X, int *ITER,
                             PLASMA_sequence *sequence, PLASMA_request *request)
{
    int N, NB;
    PLASMA_desc descA;
    PLASMA_desc descB;
    PLASMA_desc descX;
    plasma_context_t *plasma;
    double *work;
    PLASMA_desc descR, descSA, descSX;

    const int itermax = 30;
    const double bwdmax = 1.0;
    const PLASMA_Complex64_t negone = -1.0;
    const PLASMA_Complex64_t one = 1.0;
    int iiter;
    double Anorm, cte, eps, Rnorm, Xnorm;
    *ITER=0;

    plasma = plasma_context_self();
    if (plasma == NULL) {
        plasma_fatal_error("PLASMA_zcposv_Tile_Async", "PLASMA not initialized");
        return PLASMA_ERR_NOT_INITIALIZED;
    }
    if (sequence == NULL) {
        plasma_fatal_error("PLASMA_zcposv_Tile_Async", "NULL sequence");
        return PLASMA_ERR_UNALLOCATED;
    }
    if (request == NULL) {
        plasma_fatal_error("PLASMA_zcposv_Tile_Async", "NULL request");
        return PLASMA_ERR_UNALLOCATED;
    }
    /* Check sequence status */
    if (sequence->status == PLASMA_SUCCESS)
        request->status = PLASMA_SUCCESS;
    else
        return plasma_request_fail(sequence, request, PLASMA_ERR_SEQUENCE_FLUSHED);

    /* Check descriptors for correctness */
    if (plasma_desc_check(A) != PLASMA_SUCCESS) {
        plasma_error("PLASMA_zcposv_Tile_Async", "invalid first descriptor");
        return PLASMA_ERR_ILLEGAL_VALUE;
    } else {
        descA = *A;
    }
    if (plasma_desc_check(B) != PLASMA_SUCCESS) {
        plasma_error("PLASMA_zcposv_Tile_Async", "invalid second descriptor");
        return PLASMA_ERR_ILLEGAL_VALUE;
    } else {
        descB = *B;
    }
    if (plasma_desc_check(X) != PLASMA_SUCCESS) {
        plasma_error("PLASMA_zcposv_Tile_Async", "invalid third descriptor");
        return PLASMA_ERR_ILLEGAL_VALUE;
    } else {
        descX = *X;
    }
    /* Check input arguments */
    if (descA.nb != descA.mb || descB.nb != descB.mb || descX.nb != descX.mb) {
        plasma_error("PLASMA_zcposv_Tile_Async", "only square tiles supported");
        return PLASMA_ERR_ILLEGAL_VALUE;
    }
    if (uplo != PlasmaUpper && uplo != PlasmaLower) {
        plasma_error("PLASMA_zcposv_Tile_Async", "illegal value of uplo");
        return -1;
    }
    /* Quick return - currently NOT equivalent to LAPACK's
     * LAPACK does not have such check for DPOSV */

/*
    if (min(N, NRHS) == 0)
        return PLASMA_SUCCESS;
*/

    /* Set N, NRHS */
    N  = descA.m;
    NB = descA.nb;

    work = (double *)plasma_shared_alloc(plasma, PLASMA_SIZE, PlasmaRealDouble);
    if (work == NULL) {
        plasma_error("PLASMA_zcposv_Tile_Async", "plasma_shared_alloc() failed");
        plasma_shared_free(plasma, work);
        return PLASMA_ERR_OUT_OF_RESOURCES;
    }

    plasma_zdesc_alloc( descR,  NB, NB, descB.m, descB.n, 0, 0, descB.m, descB.n, plasma_shared_free( plasma, work ); plasma_desc_mat_free(&descR) );
    plasma_cdesc_alloc( descSA, NB, NB, descA.m, descA.n, 0, 0, descA.m, descA.n, plasma_shared_free( plasma, work ); plasma_desc_mat_free(&descR); plasma_desc_mat_free(&descSA) );
    plasma_cdesc_alloc( descSX, NB, NB, descX.m, descX.n, 0, 0, descX.m, descX.n, plasma_shared_free( plasma, work ); plasma_desc_mat_free(&descR); plasma_desc_mat_free(&descSA); plasma_desc_mat_free(&descSX) );

    /* Compute some constants */
    PLASMA_zlanhe(PlasmaInfNorm, uplo, descA, Anorm, work);
    eps = LAPACKE_dlamch_work('e');

    /* Convert B from double precision to single precision and store
       the result in SX. */
    PLASMA_zlag2c(descB, descSX);
    if (sequence->status != PLASMA_SUCCESS)
        return plasma_request_fail(sequence, request, PLASMA_ERR_SEQUENCE_FLUSHED);

    /* Convert A from double precision to single precision and store
       the result in SA. */
    PLASMA_zlag2c(descA, descSA);
    if (sequence->status != PLASMA_SUCCESS)
        return plasma_request_fail(sequence, request, PLASMA_ERR_SEQUENCE_FLUSHED);

    /* Compute the Cholesky factorization of SA */
    plasma_parallel_call_4(plasma_pcpotrf,
        PLASMA_enum, uplo,
        PLASMA_desc, descSA,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    /* Solve the system SA*SX = SB */
    /* Forward substitution */
    plasma_parallel_call_9(plasma_pctrsm,
        PLASMA_enum, PlasmaLeft,
        PLASMA_enum, uplo,
        PLASMA_enum, uplo == PlasmaUpper ? PlasmaConjTrans : PlasmaNoTrans,
        PLASMA_enum, PlasmaNonUnit,
        PLASMA_Complex32_t, 1.0,
        PLASMA_desc, descSA,
        PLASMA_desc, descSX,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    /* Backward substitution */
    plasma_parallel_call_9(plasma_pctrsm,
        PLASMA_enum, PlasmaLeft,
        PLASMA_enum, uplo,
        PLASMA_enum, uplo == PlasmaUpper ? PlasmaNoTrans : PlasmaConjTrans,
        PLASMA_enum, PlasmaNonUnit,
        PLASMA_Complex32_t, 1.0,
        PLASMA_desc, descSA,
        PLASMA_desc, descSX,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    /* Convert SX back to double precision */
    PLASMA_clag2z(descSX, descX);

    /* Compute R = B - AX. */
    PLASMA_zlacpy(descB,descR);
    plasma_parallel_call_9(plasma_pzhemm,
        PLASMA_enum, PlasmaLeft,
        PLASMA_enum, uplo,
        PLASMA_Complex64_t, negone,
        PLASMA_desc, descA,
        PLASMA_desc, descX,
        PLASMA_Complex64_t, one,
        PLASMA_desc, descR,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    /* Check whether the NRHS normwise backward error satisfies the
       stopping criterion. If yes return. Note that ITER=0 (already set). */
    PLASMA_zlange(PlasmaInfNorm, descX, Xnorm, work);
    PLASMA_zlange(PlasmaInfNorm, descR, Rnorm, work);

    /* Wait for the end of Anorm, Xnorm and Bnorm computations */
    plasma_dynamic_sync();

    cte = Anorm*eps*((double) N)*bwdmax;
    if (Rnorm < Xnorm * cte){
        /* The NRHS normwise backward errors satisfy the
           stopping criterion. We are good to exit. */
        plasma_desc_mat_free(&descSA);
        plasma_desc_mat_free(&descSX);
        plasma_desc_mat_free(&descR);
        plasma_shared_free(plasma, work);
        return PLASMA_SUCCESS;
    }

    /* Iterative refinement */
    for (iiter = 0; iiter < itermax; iiter++){

        /* Convert R from double precision to single precision
           and store the result in SX. */
        PLASMA_zlag2c(descR, descSX);

        /* Solve the system SA*SX = SR */
        /* Forward substitution */
        plasma_parallel_call_9(plasma_pctrsm,
            PLASMA_enum, PlasmaLeft,
            PLASMA_enum, uplo,
            PLASMA_enum, uplo == PlasmaUpper ? PlasmaConjTrans : PlasmaNoTrans,
            PLASMA_enum, PlasmaNonUnit,
            PLASMA_Complex32_t, 1.0,
            PLASMA_desc, descSA,
            PLASMA_desc, descSX,
            PLASMA_sequence*, sequence,
            PLASMA_request*, request);

        /* Backward substitution */
        plasma_parallel_call_9(plasma_pctrsm,
            PLASMA_enum, PlasmaLeft,
            PLASMA_enum, uplo,
            PLASMA_enum, uplo == PlasmaUpper ? PlasmaNoTrans : PlasmaConjTrans,
            PLASMA_enum, PlasmaNonUnit,
            PLASMA_Complex32_t, 1.0,
            PLASMA_desc, descSA,
            PLASMA_desc, descSX,
            PLASMA_sequence*, sequence,
            PLASMA_request*, request);

        /* Convert SX back to double precision and update the current
           iterate. */
        PLASMA_clag2z(descSX, descR);
        PLASMA_zgeadd(one, descR, descX);

        /* Compute R = B - AX. */
        PLASMA_zlacpy(descB,descR);
        plasma_parallel_call_9(plasma_pzhemm,
            PLASMA_enum, PlasmaLeft,
            PLASMA_enum, uplo,
            PLASMA_Complex64_t, negone,
            PLASMA_desc, descA,
            PLASMA_desc, descX,
            PLASMA_Complex64_t, one,
            PLASMA_desc, descR,
            PLASMA_sequence*, sequence,
            PLASMA_request*, request);

        /* Check whether the NRHS normwise backward errors satisfy the
           stopping criterion. If yes, set ITER=IITER>0 and return. */
        PLASMA_zlange(PlasmaInfNorm, descX, Xnorm, work);
        PLASMA_zlange(PlasmaInfNorm, descR, Rnorm, work);

        /* Wait for the end of Xnorm and Bnorm computations */
        plasma_dynamic_sync();

        if (Rnorm < Xnorm * cte){
            /* The NRHS normwise backward errors satisfy the
               stopping criterion. We are good to exit. */
            *ITER = iiter;

            plasma_desc_mat_free(&descSA);
            plasma_desc_mat_free(&descSX);
            plasma_desc_mat_free(&descR);
            plasma_shared_free(plasma, work);
            return PLASMA_SUCCESS;
        }
    }

    /* We have performed ITER=itermax iterations and never satisified
       the stopping criterion, set up the ITER flag accordingly and
       follow up on double precision routine. */
    *ITER = -itermax - 1;

    plasma_desc_mat_free(&descSA);
    plasma_desc_mat_free(&descSX);
    plasma_desc_mat_free(&descR);
    plasma_shared_free(plasma, work);

    /* Single-precision iterative refinement failed to converge to a
       satisfactory solution, so we resort to double precision. */

    plasma_parallel_call_4(plasma_pzpotrf,
        PLASMA_enum, uplo,
        PLASMA_desc, descA,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    PLASMA_zlacpy(descB,descX);

    plasma_parallel_call_9(plasma_pztrsm,
        PLASMA_enum, PlasmaLeft,
        PLASMA_enum, uplo,
        PLASMA_enum, uplo == PlasmaUpper ? PlasmaConjTrans : PlasmaNoTrans,
        PLASMA_enum, PlasmaNonUnit,
        PLASMA_Complex64_t, 1.0,
        PLASMA_desc, descA,
        PLASMA_desc, descX,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    plasma_parallel_call_9(plasma_pztrsm,
        PLASMA_enum, PlasmaLeft,
        PLASMA_enum, uplo,
        PLASMA_enum, uplo == PlasmaUpper ? PlasmaNoTrans : PlasmaConjTrans,
        PLASMA_enum, PlasmaNonUnit,
        PLASMA_Complex64_t, 1.0,
        PLASMA_desc, descA,
        PLASMA_desc, descX,
        PLASMA_sequence*, sequence,
        PLASMA_request*, request);

    return PLASMA_SUCCESS;
}


/*
 * Implement Heap sort -- direct and indirect sorting
 * Based on descriptions in Sedgewick "Algorithms in C"
 *
 * Copyright (C) 1999  Thomas Walter
 *
 * 18 February 2000: Modified for GSL by Brian Gough
 *
 * This is free software; you can redistribute it and/or modify it
 * under the terms of the GNU General Public License as published by the
 * Free Software Foundation; either version 2, or (at your option) any
 * later version.
 *
 * This source 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.
 */

#include <config.h>
#include <stdlib.h>
#include <gsl/gsl_heapsort.h>

static inline void swap (void *base, size_t size, size_t i, size_t j);
static inline void downheap (void *data, const size_t size, const size_t N, size_t k, gsl_comparison_fn_t compare);

/* Inline swap function for moving objects around */

static inline void
swap (void *base, size_t size, size_t i, size_t j)
{
  register char *a = size * i + (char *) base;
  register char *b = size * j + (char *) base;
  register size_t s = size;

  if (i == j)
    return;

  do
    {
      char tmp = *a;
      *a++ = *b;
      *b++ = tmp;
    }
  while (--s > 0);
}

#define CMP(data,size,j,k) (compare((char *)(data) + (size) * (j), (char *)(data) + (size) * (k)))

static inline void
downheap (void *data, const size_t size, const size_t N, size_t k, gsl_comparison_fn_t compare)
{
  while (k <= N / 2)
    {
      size_t j = 2 * k;

      if (j < N && CMP (data, size, j, j + 1) < 0)
        {
          j++;
        }

      if (CMP (data, size, k, j) < 0)
        {
          swap (data, size, j, k);
        }
      else
        {
          break;
        }

      k = j;
    }
}

void
gsl_heapsort (void *data, size_t count, size_t size, gsl_comparison_fn_t compare)
{
  /* Sort the array in ascending order. This is a true inplace
     algorithm with N log N operations. Worst case (an already sorted
     array) is something like 20% slower */

  size_t N;
  size_t k;

  if (count == 0)
    {
      return;                   /* No data to sort */
    }

  /* We have n_data elements, last element is at 'n_data-1', first at
     '0' Set N to the last element number. */

  N = count - 1;

  k = N / 2;
  k++;                          /* Compensate the first use of 'k--' */
  do
    {
      k--;
      downheap (data, size, N, k, compare);
    }
  while (k > 0);

  while (N > 0)
    {
      /* first swap the elements */
      swap (data, size, 0, N);

      /* then process the heap */
      N--;

      downheap (data, size, N, 0, compare);
    }
}


/**
 * @file      DiscreteRangeDecorators.h
 *
 * @brief     This file contains some decorator functions for DiscreteRange
 * types
 *
 * @author    Stefan Reinhold
 * @copyright Copyright (C) 2018 Stefan Reinhold  -- All Rights Reserved.
 * You may use, distribute and modify this code under the terms of the
 * AFL 3.0 license; see LICENSE for full license details.
 */

#include "DiscreteRange.h"

#include <Eigen/Core>
#include <gsl/gsl>

namespace CortidQCT {
namespace Internal {

/**
 * @brief Returns all element of the given discrete range as a vector
 * @param range DiscreteRange object
 * @return An Eigen vector containing all element of `range`
 */
template <class T>
Eigen::Matrix<T, Eigen::Dynamic, 1>
discreteRangeElementVector(DiscreteRange<T> const &range) {
  using Vector = Eigen::Matrix<T, Eigen::Dynamic, 1>;

  Vector t(gsl::narrow<Eigen::Index>(range.numElements()));

  for (auto i = 0; i < t.rows(); ++i) {
    t(i) = range.min + static_cast<T>(i) * range.stride;
  }

  return t;
}

} // namespace Internal
} // namespace CortidQCT


/* -*- linux-c -*- */
/* binsingle.c

   Copyright (C) 2002-2004 John M. Fregeau

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*/

#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <math.h>
#include <time.h>
#include <getopt.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_rng.h>
#include "fewbody.h"
#include "binsingle_simple.h"

/* calculate the units used */
int calc_units(fb_obj_t *single, fb_obj_t *binary, fb_units_t *units)
{
	units->v = sqrt(FB_CONST_G*(single->m + binary->m)/(single->m * binary->m) * \
			(binary->obj[0]->m * binary->obj[1]->m / binary->a));
	units->l = binary->a;
	units->t = units->l / units->v;
	units->m = units->l * fb_sqr(units->v) / FB_CONST_G;
	units->E = units->m * fb_sqr(units->v);

	return(0);
}

/* the main attraction */
int main(int argc, char *argv[])
{
	int i, n;
	unsigned long int seed;
	double m0, m10, m11, r0, r10, r11, a1, e1;
	double rtid, vinf, b, m1, M, mu, Ei, t;
	fb_hier_t hier;
	fb_input_t input;
	fb_ret_t retval;
	fb_units_t units;
	char string1[FB_MAX_STRING_LENGTH], string2[FB_MAX_STRING_LENGTH];
	gsl_rng *rng;
	const gsl_rng_type *rng_type=gsl_rng_mt19937;

	/* set parameters to default values */
	m0 = FB_M0;
	m10 = FB_M10;
	m11 = FB_M11;
	r0 = FB_R0;
	r10 = FB_R10;
	r11 = FB_R11;
	a1 = FB_A1;
	e1 = FB_E1;
	vinf = FB_VINF;
	b = FB_B;
	input.ks = FB_KS;
	input.tstop = FB_TSTOP;
	input.Dflag = 0;
	input.dt = FB_DT;
	input.tcpustop = FB_TCPUSTOP;
	input.absacc = FB_ABSACC;
	input.relacc = FB_RELACC;
	input.ncount = FB_NCOUNT;
	input.tidaltol = FB_TIDALTOL;
	input.fexp = FB_FEXP;
	seed = FB_SEED;
	fb_debug = FB_DEBUG;

	/* initialize a few things for integrator */
	t = 0.0;
	fbui_new_hier(&hier, 3);

	/* initialize GSL rng */
	gsl_rng_env_setup();
	rng = gsl_rng_alloc(rng_type);
	gsl_rng_set(rng, seed);

	/* create binary */
	fbui_make_pair(fbui_hierarchy_binary(&hier, 0),
		       fbui_hierarchy_single(&hier, 1), fbui_hierarchy_single(&hier, 2));
	fbui_obj_t_set(fbui_hierarchy_binary(&hier, 0), t);

	/* give the objects some properties */
	fbui_initialize_single(fbui_hierarchy_single(&hier, 0), 0, "0");
	fbui_initialize_single(fbui_hierarchy_single(&hier, 1), 1, "1");
	fbui_initialize_single(fbui_hierarchy_single(&hier, 2), 2, "2");

	fbui_obj_radius_set(fbui_hierarchy_single(&hier, 0), r0);
	fbui_obj_radius_set(fbui_hierarchy_single(&hier, 1), r10);
	fbui_obj_radius_set(fbui_hierarchy_single(&hier, 2), r11);

	fbui_obj_mass_set(fbui_hierarchy_single(&hier, 0), m0);
	fbui_obj_mass_set(fbui_hierarchy_single(&hier, 1), m10);
	fbui_obj_mass_set(fbui_hierarchy_single(&hier, 2), m11);

	fbui_obj_mass_set(fbui_hierarchy_binary(&hier, 0), m10+m11);

	fbui_obj_a_set(fbui_hierarchy_binary(&hier, 0), a1);
	fbui_obj_e_set(fbui_hierarchy_binary(&hier, 0), e1);

	/* get the units and normalize */
	calc_units(fbui_hierarchy_single(&hier, 0), fbui_hierarchy_binary(&hier, 0), &units);
	fb_normalize(&hier, units);

	/* move hierarchies analytically in from infinity along hyperbolic orbit */
	m0 = fbui_obj_mass_get(fbui_hierarchy_single(&hier, 0));
	m1 = fbui_obj_mass_get(fbui_hierarchy_binary(&hier, 0));
	M = m0 + m1;
	mu = m0 * m1 / M;

	Ei = 0.5 * mu * fb_sqr(vinf);

	a1 = fbui_obj_a_get(fbui_hierarchy_binary(&hier, 0));
	e1 = fbui_obj_e_get(fbui_hierarchy_binary(&hier, 0));
	m10 = fbui_obj_mass_get(fbui_obj_left_child_get(fbui_hierarchy_binary(&hier, 0)));
	m11 = fbui_obj_mass_get(fbui_obj_right_child_get(fbui_hierarchy_binary(&hier, 0)));

	rtid = pow(2.0*(m0+m1)/(m1*input.tidaltol), 1.0/3.0) * a1 * (1.0+e1);

	fb_init_scattering(fbui_hierarchy_single(&hier, 0), fbui_hierarchy_binary(&hier, 0), vinf, b, rtid);

	/* trickle down the binary properties, then back up */
	fb_randorient(fbui_hierarchy_binary(&hier, 0), rng);
	fb_downsync(fbui_hierarchy_binary(&hier, 0), t);

	/* call fewbody! */
	retval = fewbody(input, &hier, &t);

	/* print information to screen */
	fprintf(stderr, "OUTCOME:\n");
	if (retval.retval == 1) {
		fprintf(stderr, "  encounter complete:  t=%.6g (%.6g yr)  %s  (%s)\n\n",
			t, t * units.t/FB_CONST_YR,
			fb_sprint_hier(hier, string1),
			fb_sprint_hier_hr(hier, string2));
	} else {
		fprintf(stderr, "  encounter NOT complete:  t=%.6g (%.6g yr)  %s  (%s)\n\n",
			t, t * units.t/FB_CONST_YR,
			fb_sprint_hier(hier, string1),
			fb_sprint_hier_hr(hier, string2));
	}

	fb_dprintf("there were %ld integration steps\n", retval.count);
	fb_dprintf("fb_classify() was called %ld times\n", retval.iclassify);

	fprintf(stderr, "FINAL:\n");
	fprintf(stderr, "  t_final=%.6g (%.6g yr)  t_cpu=%.6g s\n", \
		t, t*units.t/FB_CONST_YR, retval.tcpu);

	fprintf(stderr, "  DeltaL/L0=%.6g  DeltaL=%.6g\n", retval.DeltaLfrac, retval.DeltaL);
	fprintf(stderr, "  DeltaE/E0=%.6g  DeltaE=%.6g\n", retval.DeltaEfrac, retval.DeltaE);
	fprintf(stderr, "  Rmin=%.6g (%.6g RSUN)  Rmin_i=%d  Rmin_j=%d\n", \
		retval.Rmin, retval.Rmin*units.l/FB_CONST_RSUN, retval.Rmin_i, retval.Rmin_j);
	fprintf(stderr, "  Nosc=%d (%s)\n", retval.Nosc, (retval.Nosc>=1?"resonance":"non-resonance"));

	fprintf(stderr, "Resulting objects:\n");
	for (i=0; i<hier.nobj; i++) {
		n = fbui_obj_n_get(fbui_tree(&hier, i));
		if (n == 1) {
			fprintf(stderr, "  single: m=%g idstring=%s\n",
				fbui_obj_mass_get(fbui_tree(&hier, i)) * units.m / FB_CONST_MSUN,
				fbui_obj_idstring_get(fbui_tree(&hier, i)));
		} else if (n == 2) {
			fprintf(stderr, "  binary: m_i=%g,%g a=%g e=%g idstring=%s\n",
				fbui_obj_mass_get(fbui_obj_left_child_get(fbui_tree(&hier, i))) * units.m / FB_CONST_MSUN,
				fbui_obj_mass_get(fbui_obj_right_child_get(fbui_tree(&hier, i))) * units.m / FB_CONST_MSUN,
				fbui_obj_a_get(fbui_tree(&hier, i)) * units.l / FB_CONST_AU,
				fbui_obj_e_get(fbui_tree(&hier, i)),
				fbui_obj_idstring_get(fbui_tree(&hier, i)));
		}
	}

	/* free GSL stuff */
	gsl_rng_free(rng);

	/* free our own stuff */
	fbui_delete_hier(&hier);

	/* done! */
	return(0);
}


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

Copyright 2011-2019, Javier Burguete Tolosa.

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

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

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

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

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

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

/**
 * Function to obtain the coefficients of a 5 steps 4th order Runge-Kutta
 * method.
 */
int
rk_tb_5_4 (Optimize * optimize) ///< Optimize struct.
{
  long double A[4], B[4], C[4], D[4], E[4];
  long double *tb, *r;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4: start\n");
#endif
  tb = optimize->coefficient;
  r = optimize->random_data;
  t5 (tb) = 1.L;
  t1 (tb) = r[0];
  t2 (tb) = r[1];
  b21 (tb) = r[2];
  t3 (tb) = r[3];
  b31 (tb) = r[4];
  b32 (tb) = r[5];
  t4 (tb) = r[6];
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = t4 (tb);
  E[0] = 0.5L;
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = D[0] * t4 (tb);
  E[1] = 1.L / 3.L;
  A[2] = A[1] * t1 (tb);
  B[2] = B[1] * t2 (tb);
  C[2] = C[1] * t3 (tb);
  D[2] = D[1] * t4 (tb);
  E[2] = 0.25L;
  A[3] = D[3] = 0.L;
  B[3] = b21 (tb) * t1 (tb) * (t2 (tb) - t4 (tb));
  C[3] = (b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb)) * (t3 (tb) - t4 (tb));
  E[3] = 0.125L - 1.L / 6.L * t4 (tb);
  solve_4 (A, B, C, D, E);
  if (isnan (E[0]) || isnan (E[1]) || isnan (E[2]) || isnan (E[3]))
    return 0;
  b54 (tb) = E[3];
  b53 (tb) = E[2];
  b52 (tb) = E[1];
  b51 (tb) = E[0];
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = 1.L / 6.L - b52 (tb) * b21 (tb) * t1 (tb)
    - b53 (tb) * (b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb));
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = 1.L / 12.L - b52 (tb) * b21 (tb) * sqr (t1 (tb))
    - b53 (tb) * (b31 (tb) * sqr (t1 (tb)) + b32 (tb) * sqr (t2 (tb)));
  A[2] = 0.L;
  B[2] = b21 (tb) * t1 (tb);
  C[2] = b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb);
  D[2] = 1.L / 24.L - b53 (tb) * b32 (tb) * b21 (tb) * t1 (tb);
  solve_3 (A, B, C, D);
  b43 (tb) = D[2] / b54 (tb);
  if (isnan (b43 (tb)))
    return 0;
  b42 (tb) = D[1] / b54 (tb);
  if (isnan (b42 (tb)))
    return 0;
  b41 (tb) = D[0] / b54 (tb);
  if (isnan (b41 (tb)))
    return 0;
  rk_b_5 (tb);
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4: end\n");
#endif
  return 1;
}

/**
 * Function to obtain the coefficients of a 5 steps 4th order, 5th order in
 * equations depending only on time, Runge-Kutta method.
 */
int
rk_tb_5_4t (Optimize * optimize)        ///< Optimize struct.
{
  long double A[4], B[4], C[4], D[4], E[4];
  long double *tb, *r;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4t: start\n");
#endif
  tb = optimize->coefficient;
  r = optimize->random_data;
  t5 (tb) = 1.L;
  t1 (tb) = r[0];
  t2 (tb) = r[1];
  t3 (tb) = r[2];
  t4 (tb) = r[3];
  b31 (tb) = r[4];
  b21 (tb) = r[5];
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = t4 (tb);
  E[0] = 0.5L;
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = D[0] * t4 (tb);
  E[1] = 1.L / 3.L;
  A[2] = A[1] * t1 (tb);
  B[2] = B[1] * t2 (tb);
  C[2] = C[1] * t3 (tb);
  D[2] = D[1] * t4 (tb);
  E[2] = 0.25L;
  A[3] = A[2] * t1 (tb);
  B[3] = B[2] * t2 (tb);
  C[3] = C[2] * t3 (tb);
  D[3] = D[2] * t4 (tb);
  E[3] = 0.2L;
  solve_4 (A, B, C, D, E);
  if (isnan (E[0]) || isnan (E[1]) || isnan (E[2]) || isnan (E[3]))
    return 0;
  b54 (tb) = E[3];
  b53 (tb) = E[2];
  b52 (tb) = E[1];
  b51 (tb) = E[0];
  b32 (tb) = (1.L / 6.L * t4 (tb) - 0.125L
              - t1 (tb) * (b52 (tb) * b21 (tb) * (t4 (tb) - t2 (tb))
                           + b53 (tb) * b31 (tb) * (t4 (tb) - t3 (tb))))
    / (b53 (tb) * t2 (tb) * (t4 (tb) - t3 (tb)));
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = 1.L / 6.L - b52 (tb) * b21 (tb) * t1 (tb)
    - b53 (tb) * (b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb));
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = 1.L / 12.L - b52 (tb) * b21 (tb) * sqr (t1 (tb))
    - b53 (tb) * (b31 (tb) * sqr (t1 (tb)) + b32 (tb) * sqr (t2 (tb)));
  A[2] = 0.L;
  B[2] = b21 (tb) * t1 (tb);
  C[2] = b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb);
  D[2] = 1.L / 24.L - b53 (tb) * b32 (tb) * b21 (tb) * t1 (tb);
  solve_3 (A, B, C, D);
  b43 (tb) = D[2] / b54 (tb);
  if (isnan (b43 (tb)))
    return 0;
  b42 (tb) = D[1] / b54 (tb);
  if (isnan (b42 (tb)))
    return 0;
  b41 (tb) = D[0] / b54 (tb);
  if (isnan (b41 (tb)))
    return 0;
  rk_b_5 (tb);
#if DEBUG_RK_5_4
  rk_print_tb (optimize, "rk_tb_5_4t", stderr);
  fprintf (stderr, "rk_tb_5_4t: end\n");
#endif
  return 1;
}

/**
 * Function to obtain the coefficients of a 5 steps 3rd-4th order Runge-Kutta
 * pair.
 */
int
rk_tb_5_4p (Optimize * optimize)        ///< Optimize struct.
{
  long double A[3], B[3], C[3], D[3];
  long double *tb;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4p: start\n");
#endif
  if (!rk_tb_5_4 (optimize))
    return 0;
  tb = optimize->coefficient;
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = 0.5L;
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = 1.L / 3.L;
  A[2] = 0.L;
  B[2] = b21 (tb) * t1 (tb);
  C[2] = b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb);
  D[2] = 1.L / 6.L;
  solve_3 (A, B, C, D);
  if (isnan (D[0]) || isnan (D[1]) || isnan (D[2]))
    return 0;
  e53 (tb) = D[2];
  e52 (tb) = D[1];
  e51 (tb) = D[0];
  rk_e_5 (tb);
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4p: end\n");
#endif
  return 1;
}

/**
 * Function to obtain the coefficients of a 5 steps 3th-4th order, 4th-5th order
 * in equations depending only on time, Runge-Kutta pair.
 */
int
rk_tb_5_4tp (Optimize * optimize)       ///< Optimize struct.
{
  long double A[4], B[4], C[4], D[4], E[4];
  long double *tb, *r;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_tb_5_4tp: start\n");
#endif
  tb = optimize->coefficient;
  r = optimize->random_data;
  t5 (tb) = 1.L;
  t1 (tb) = r[0];
  t2 (tb) = r[1];
  t3 (tb) = r[2];
  t4 (tb) = r[3];
  b31 (tb) = r[4];
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = t4 (tb);
  E[0] = 0.5L;
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = D[0] * t4 (tb);
  E[1] = 1.L / 3.L;
  A[2] = A[1] * t1 (tb);
  B[2] = B[1] * t2 (tb);
  C[2] = C[1] * t3 (tb);
  D[2] = D[1] * t4 (tb);
  E[2] = 0.25L;
  A[3] = A[2] * t1 (tb);
  B[3] = B[2] * t2 (tb);
  C[3] = C[2] * t3 (tb);
  D[3] = D[2] * t4 (tb);
  E[3] = 0.2L;
  solve_4 (A, B, C, D, E);
  if (isnan (E[0]) || isnan (E[1]) || isnan (E[2]) || isnan (E[3]))
    return 0;
  b54 (tb) = E[3];
  b53 (tb) = E[2];
  b52 (tb) = E[1];
  b51 (tb) = E[0];
  e53 (tb) = (0.25L - 1.L / 3.L * t1 (tb)
              - (1.L / 3.L - 0.5L * t1 (tb)) * t2 (tb))
    / (t3 (tb) * (t3 (tb) - t2 (tb)) * (t3 (tb) - t1 (tb)));
  if (isnan (e53 (tb)))
    return 0;
  e52 (tb) = (1.L / 3.L - 0.5L * t1 (tb)
              - t3 (tb) * (t3 (tb) - t1 (tb)) * e53 (tb))
    / (t2 (tb) * (t2 (tb) - t1 (tb)));
  if (isnan (e52 (tb)))
    return 0;
  e51 (tb) = (0.5L - t2 (tb) * e52 (tb) - t3 (tb) * e53 (tb)) / t1 (tb);
  if (isnan (e51 (tb)))
    return 0;
  b21 (tb) = (1.L / 6.L * b53 (tb) * (t4 (tb) - t3 (tb))
              + e53 (tb) * (0.125L - 1.L / 6.L * t4 (tb)))
    / (t1 (tb) * (e52 (tb) * b53 (tb) * (t4 (tb) - t3 (tb))
                  - e53 (tb) * b52 (tb) * (t4 (tb) - t2 (tb))));
  if (isnan (b21 (tb)))
    return 0;
  b32 (tb) = (1.L / 6.L * t4 (tb) - 0.125L
              - t1 (tb) * (b52 (tb) * b21 (tb) * (t4 (tb) - t2 (tb))
                           + b53 (tb) * b31 (tb) * (t4 (tb) - t3 (tb))))
    / (b53 (tb) * t2 (tb) * (t4 (tb) - t3 (tb)));
  if (isnan (b32 (tb)))
    return 0;
  A[0] = t1 (tb);
  B[0] = t2 (tb);
  C[0] = t3 (tb);
  D[0] = 1.L / 6.L - b52 (tb) * b21 (tb) * t1 (tb)
    - b53 (tb) * (b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb));
  A[1] = A[0] * t1 (tb);
  B[1] = B[0] * t2 (tb);
  C[1] = C[0] * t3 (tb);
  D[1] = 1.L / 12.L - b52 (tb) * b21 (tb) * sqr (t1 (tb))
    - b53 (tb) * (b31 (tb) * sqr (t1 (tb)) + b32 (tb) * sqr (t2 (tb)));
  A[2] = 0.L;
  B[2] = b21 (tb) * t1 (tb);
  C[2] = b31 (tb) * t1 (tb) + b32 (tb) * t2 (tb);
  D[2] = 1.L / 24.L - b53 (tb) * b32 (tb) * b21 (tb) * t1 (tb);
  solve_3 (A, B, C, D);
  b43 (tb) = D[2] / b54 (tb);
  if (isnan (b43 (tb)))
    return 0;
  b42 (tb) = D[1] / b54 (tb);
  if (isnan (b42 (tb)))
    return 0;
  b41 (tb) = D[0] / b54 (tb);
  if (isnan (b41 (tb)))
    return 0;
  rk_b_5 (tb);
  rk_e_5 (tb);
#if DEBUG_RK_5_4
  rk_print_tb (optimize, "rk_tb_5_4tp", stderr);
  fprintf (stderr, "rk_tb_5_4tp: end\n");
#endif
  return 1;
}

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

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

/**
 * Function to calculate the objective function of a 5 steps 3rd-4th order
 * Runge-Kutta pair.
 *
 * \return objective function value.
 */
long double
rk_objective_tb_5_4p (RK * rk)  ///< RK struct.
{
  long double *tb;
  long double o;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_objective_tb_5_4p: start\n");
#endif
  tb = rk->tb->coefficient;
  o = fminl (0.L, b20 (tb));
  if (b30 (tb) < 0.L)
    o += b30 (tb);
  if (b40 (tb) < 0.L)
    o += b40 (tb);
  if (b41 (tb) < 0.L)
    o += b41 (tb);
  if (b42 (tb) < 0.L)
    o += b42 (tb);
  if (b43 (tb) < 0.L)
    o += b43 (tb);
  if (b50 (tb) < 0.L)
    o += b50 (tb);
  if (b51 (tb) < 0.L)
    o += b51 (tb);
  if (b52 (tb) < 0.L)
    o += b52 (tb);
  if (b53 (tb) < 0.L)
    o += b53 (tb);
  if (b54 (tb) < 0.L)
    o += b54 (tb);
  if (e50 (tb) < 0.L)
    o += e50 (tb);
  if (e51 (tb) < 0.L)
    o += e51 (tb);
  if (e52 (tb) < 0.L)
    o += e52 (tb);
  if (e53 (tb) < 0.L)
    o += e53 (tb);
  if (o < 0.L)
    {
      o = 40.L - o;
      goto end;
    }
  o = 30.L
    + fmaxl (1.L, fmaxl (t1 (tb), fmaxl (t2 (tb), fmaxl (t3 (tb), t4 (tb)))));
  if (rk->strong)
    {
      rk_bucle_ac (rk);
      o = fminl (o, *rk->ac0->optimal);
    }
end:
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_objective_tb_5_4p: optimal=%Lg\n", o);
  fprintf (stderr, "rk_objective_tb_5_4p: end\n");
#endif
  return o;
}

/**
 * Function to calculate the objective function of a 5 steps 3th-4th order,
 * 4th-5th order in equations depending only on time, Runge-Kutta pair.
 *
 * \return objective function value.
 */
long double
rk_objective_tb_5_4tp (RK * rk) ///< RK struct.
{
  long double *tb;
  long double o;
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_objective_tb_5_4t: start\n");
#endif
  tb = rk->tb->coefficient;
#if DEBUG_RK_5_4
  rk_print_tb (optimize, "rk_objective_tb_5_4tp", stderr);
#endif
  o = fminl (0.L, b20 (tb));
  if (b21 (tb) < 0.L)
    o += b21 (tb);
  if (b30 (tb) < 0.L)
    o += b30 (tb);
  if (b32 (tb) < 0.L)
    o += b32 (tb);
  if (b40 (tb) < 0.L)
    o += b40 (tb);
  if (b41 (tb) < 0.L)
    o += b41 (tb);
  if (b42 (tb) < 0.L)
    o += b42 (tb);
  if (b43 (tb) < 0.L)
    o += b43 (tb);
  if (b50 (tb) < 0.L)
    o += b50 (tb);
  if (b51 (tb) < 0.L)
    o += b51 (tb);
  if (b52 (tb) < 0.L)
    o += b52 (tb);
  if (b53 (tb) < 0.L)
    o += b53 (tb);
  if (b54 (tb) < 0.L)
    o += b54 (tb);
  if (e50 (tb) < 0.L)
    o += e50 (tb);
  if (e51 (tb) < 0.L)
    o += e51 (tb);
  if (e52 (tb) < 0.L)
    o += e52 (tb);
  if (e53 (tb) < 0.L)
    o += e53 (tb);
  if (o < 0.L)
    {
      o = 40.L - o;
      goto end;
    }
  o = 30.L
    + fmaxl (1.L, fmaxl (t1 (tb), fmaxl (t2 (tb), fmaxl (t3 (tb), t4 (tb)))));
  if (rk->strong)
    {
      rk_bucle_ac (rk);
      o = fminl (o, *rk->ac0->optimal);
    }
end:
#if DEBUG_RK_5_4
  fprintf (stderr, "rk_objective_tb_5_4tp: optimal=%Lg\n", o);
  fprintf (stderr, "rk_objective_tb_5_4tp: end\n");
#endif
  return o;
}


/* Utility functions for working with GSL data types. */

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

#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_permutation.h>
#include <gsl/gsl_sort_vector.h>
#include <gsl/gsl_spmatrix.h>
#include <gsl/gsl_statistics.h>
#include <hdf5.h>
#include <hdf5_hl.h>
#include <osqp/osqp.h>

#include "qdm.h"

gsl_vector *
qdm_vector_seq(double from, double to, double by)
{
  size_t size = fabs(to - from) / by;
  gsl_vector *s = gsl_vector_alloc(size + 1);

  double value = from;
  for (size_t i = 0; i < s->size; i++) {
    gsl_vector_set(s, i, value);
    value += by;
  }

  return s;
}

void
qdm_vector_set_seq(gsl_vector *v, double from, double to)
{
  double by = (to - from) / (double)(v->size - 1);

  double value = from;
  for (size_t i = 0; i < v->size; i++) {
    gsl_vector_set(v, i, value);
    value += by;
  }
}

size_t
qdm_vector_search(const gsl_vector *v, double needle)
{
  double x = 0;
  size_t i = v->size - 1;

  for (; i > 0; i--) {
    x = gsl_vector_get(v, i);

    if (needle >= x) {
      break;
    }
  }

  return i;
}

void
qdm_vector_csv_fwrite(FILE *f, const gsl_vector *v)
{
  for (size_t i = 0; i < v->size; i++) {
    fprintf(f, "%.17g", gsl_vector_get(v, i));
    if (i < v->size - 1) {
      fprintf(f, ",");
    }
  }
  fprintf(f, "\n");
}

void
qdm_matrix_csv_fwrite(FILE *f, const gsl_matrix *m)
{
  if (m != NULL) {
    for (size_t i = 0; i < m->size1; i++) {
      gsl_vector_const_view row = gsl_matrix_const_row(m, i);
      qdm_vector_csv_fwrite(f, &row.vector);
    }
  }
}

/* Compute M^T * M */
int
qdm_matrix_tmm(gsl_matrix *m, gsl_matrix *result)
{
  return gsl_blas_dgemm(
      CblasTrans , CblasNoTrans , 1.0 ,
      m          , m            ,
      0.0        , result
  );
}

/* Compute det(M^T * M) */
int
qdm_matrix_det_tmm(gsl_matrix *m, double *det)
{
  int status = 0;
  gsl_matrix *c = gsl_matrix_alloc(m->size2, m->size2);
  gsl_permutation *p = gsl_permutation_alloc(c->size1);

  status = gsl_blas_dgemm(
      CblasTrans , CblasNoTrans , 1.0 ,
      m          , m            ,
      0.0        , c
  );
  if (status != 0) {
    goto cleanup;
  }

  int signum = 0;
  status = gsl_linalg_LU_decomp(c, p, &signum);
  if (status != 0) {
    goto cleanup;
  }

  *det = gsl_linalg_LU_det(c, signum);

cleanup:
  gsl_permutation_free(p);
  gsl_matrix_free(c);

  return status;
}

/* Create a sorted copy of the vector v. */
gsl_vector *
qdm_vector_sorted(const gsl_vector *v)
{
  gsl_vector *s = gsl_vector_alloc(v->size);

  gsl_vector_memcpy(s, v);
  gsl_sort_vector(s);

  return s;
}

gsl_vector *
qdm_vector_quantile(gsl_vector *data, gsl_vector *probs)
{
  gsl_vector *sorted = qdm_vector_sorted(data);
  gsl_vector *quantiles = gsl_vector_alloc(probs->size);

  for (size_t i = 0; i < probs->size; i++) {
    double q = gsl_stats_quantile_from_sorted_data(
        sorted->data,
        sorted->stride,
        sorted->size,
        gsl_vector_get(probs, i)
    );

    gsl_vector_set(quantiles, i, q);
  }

  free(sorted);

  return quantiles;
}

/* Compute the residual sum of squares:
 *
 * sum((y[i] - f(x[i])) ^ 2)
 */
double
qdm_vector_rss(const gsl_vector *y, const gsl_vector *fx)
{
  int status = 0;
  double rss = 0.0;

  gsl_vector *se = gsl_vector_alloc(y->size);
  status = gsl_vector_memcpy(se, y);
  if (status != 0) {
    goto cleanup;
  }

  status = gsl_vector_sub(se, fx);
  if (status != 0) {
    goto cleanup;
  }

  status = gsl_vector_mul(se, se);
  if (status != 0) {
    goto cleanup;
  }

  rss = qdm_vector_sum(se);

cleanup:
  gsl_vector_free(se);

  return rss;
}

/* Compute the summation of the vector.
 *
 * This uses the "iterative Kahan-Babuska algorithm" (aka Klein summation) as
 * outlined here:
 *
 * https://en.wikipedia.org/wiki/Kahan_summation_algorithm
 */
double
qdm_vector_sum(gsl_vector *v)
{
  double s = 0.0;
  double cs = 0.0;
  double ccs = 0.0;

  for (size_t i = 0; i < v->size; i++) {
    double t = s + gsl_vector_get(v, i);

    double c;
    if (fabs(s) >= fabs(gsl_vector_get(v, i))) {
      c = (s - t) + gsl_vector_get(v, i);
    } else {
      c = (gsl_vector_get(v, i) - t) + s;
    }

    s = t;
    t = cs + c;

    double cc;
    if (fabs(cs) >= fabs(c)) {
      cc = (cs - t) + c;
    } else {
      cc = (c - t) + cs;
    }

    cs = t;
    ccs = ccs + cc;
  }

  return s + cs + ccs;
}

/* Return the first index with a value greater than the value. */
size_t
qdm_vector_greater_than(const gsl_vector *v, double value)
{
  for (size_t i = 0; i < v->size; i++) {
    if (gsl_vector_get(v, i) > value) {
      return i;
    }
  }

  return 0;
}

/* Select the elements in the upper triangle of the matrix. All other elements
 * will be set to zero.
 */
void
qdm_matrix_select_upper_triangle(gsl_matrix *m)
{
  for (size_t i = 0; i < m->size1; i++) {
    for (size_t j = 0; j < m->size2; j++) {
      if (j < i) {
        gsl_matrix_set(m, i, j, 0);
      }
    }
  }
}

int
qdm_matrix_to_csc_matrix(csc **result, gsl_matrix *input)
{
  int status = 0;

  gsl_spmatrix *sm = gsl_spmatrix_alloc(input->size1, input->size2);

  status = gsl_spmatrix_d2sp(sm, input);
  if (status != 0) {
    goto cleanup_sm;
  }

  gsl_spmatrix *sm_csc = gsl_spmatrix_compress(sm, GSL_SPMATRIX_CSC);

  int m = sm_csc->size1;
  int n = sm_csc->size2;
  int nzmax = gsl_spmatrix_nnz(sm_csc);

  size_t x_size = sizeof(double) * nzmax;
  double *x = malloc(x_size);
  memcpy(x, sm_csc->data, x_size);

  size_t i_size = sizeof(int) * nzmax;
  int *i = malloc(i_size);
  memcpy(i, sm_csc->i, i_size);

  size_t p_size = sizeof(int) * (n + 1);
  int *p = malloc(p_size);
  memcpy(p, sm_csc->p, p_size);

  *result = csc_matrix(
      m,     // m     First dimension (rows)
      n,     // n     Second dimension (columns)
      nzmax, // nzmax Maximum number of nonzero elements
      x,     // x     Vector of data (size nzmax)
      i,     // i     Vector of row indices (size nzmax)
      p      // p     Vector of column pointers (size n+1)
  );

  gsl_spmatrix_free(sm_csc);

cleanup_sm:
  gsl_spmatrix_free(sm);

  return status;
}

gsl_vector *
qdm_vector_copy(const gsl_vector *src)
{
  gsl_vector *dst = gsl_vector_alloc(src->size);
  gsl_vector_memcpy(dst, src);

  return dst;
}

gsl_matrix *
qdm_matrix_copy(const gsl_matrix *src)
{
  gsl_matrix *dst = gsl_matrix_alloc(src->size1, src->size2);
  gsl_matrix_memcpy(dst, src);

  return dst;
}

int create_hd5(
    const char *file_path,
    const char *group_path
)
{
  int status = 0;

  hid_t file  = -1;
  hid_t group = -1;
  hid_t gcpl  = -1;

  /* Save old error handler */
  herr_t (*old_func)(hid_t, void*) = NULL;
  void *old_client_data = NULL;
  H5Eget_auto(H5E_DEFAULT, &old_func, &old_client_data);

  /* Turn off error handling */
  H5Eset_auto(H5E_DEFAULT, NULL, NULL);

  file = H5Fopen(file_path, H5F_ACC_RDWR, H5P_DEFAULT);
  if (file < 0) {
    file = H5Fcreate(file_path, H5F_ACC_TRUNC, H5P_DEFAULT, H5P_DEFAULT);
  }
  if (file < 0) {
    status = file;
    goto cleanup;
  }

  group = H5Gopen(file, group_path, H5P_DEFAULT);
  if (group < 0) {
    gcpl = H5Pcreate(H5P_LINK_CREATE);
    if (gcpl < 0) {
      status = gcpl;
      goto cleanup;
    }

    status = H5Pset_create_intermediate_group(gcpl, 1);
    if (status < 0) {
      goto cleanup;
    }

    group = H5Gcreate(file, group_path, gcpl, H5P_DEFAULT, H5P_DEFAULT);

    if (group < 0) {
      status = group;
      goto cleanup;
    }
  }

cleanup:
  if (gcpl >= 0) {
    H5Pclose(gcpl);
  }

  if (group >= 0) {
    H5Gclose(group);
  }

  if (file >= 0) {
    H5Fclose(file);
  }

  /* Restore previous error handler */
  H5Eset_auto(H5E_DEFAULT, old_func, old_client_data);

  if (status < 0) {
    H5Eprint(H5E_DEFAULT, stderr);
  }

  return status;
}

int
qdm_vector_hd5_read(
    hid_t id,
    const char *name,
    gsl_vector **v
)
{
  int status = 0;

  int rank = 0;

  status = H5LTget_dataset_ndims(id, name, &rank);
  if (status < 0) {
    return status;
  }

  hsize_t dims[rank];

  status = H5LTget_dataset_info(id, name, dims, NULL, NULL);
  if (status < 0) {
    return status;
  }

  size_t size = 1;
  for (int i = 0; i < rank; i++) {
    size *= dims[i];
  }

  gsl_vector *tmp = gsl_vector_alloc(size);

  status = H5LTread_dataset_double(id, name, tmp->data);
  if (status < 0) {
    gsl_vector_free(tmp);

    return status;
  }

  *v = tmp;

  return status;
}

int
qdm_vector_hd5_write(
    hid_t id,
    const char *name,
    const gsl_vector *v
)
{
  int status = 0;

  hid_t datatype  = -1;
  hid_t dataspace = -1;
  hid_t dataset   = -1;
  hid_t dcpl      = -1;

  if (v == NULL) {
    goto cleanup;
  }

  datatype = H5Tcopy(H5T_NATIVE_DOUBLE);

  status = H5Tset_order(datatype, H5T_ORDER_LE);
  if (status != 0) {
    goto cleanup;
  }

  hsize_t dims[1] = {
    v->size,
  };
  dataspace = H5Screate_simple(1, dims, NULL);
  if (dataspace < 0) {
    status = dataspace;
    goto cleanup;
  }

  dcpl = H5Pcreate(H5P_DATASET_CREATE);
  if (dcpl < 0) {
    status = dcpl;

    goto cleanup;
  }

  /* Only enable compression on larger vectors. */
  /*
  if (v->size > 1024) {
    status = H5Pset_deflate(dcpl, 9);
    if (status != 0) {
      goto cleanup;
    }

    hsize_t chunk_dims[1] = {
      v->size,
    };
    status = H5Pset_chunk(dcpl, 1, chunk_dims);
    if (status != 0) {
      goto cleanup;
    }
  }
  */

  dataset = H5Dcreate(id, name, datatype, dataspace, H5P_DEFAULT, dcpl, H5P_DEFAULT);
  if (dataset < 0) {
    status = dataset;
    goto cleanup;
  }

  status = H5Dwrite(dataset, H5T_NATIVE_DOUBLE, H5S_ALL, H5S_ALL, H5P_DEFAULT, v->data);
  if (status != 0) {
    goto cleanup;
  }

cleanup:
  if (dcpl >= 0) {
    H5Pclose(dcpl);
  }

  if (dataset >= 0) {
    H5Dclose(dataset);
  }

  if (dataspace >= 0) {
    H5Sclose(dataspace);
  }

  if (datatype >= 0) {
    H5Tclose(datatype);
  }

  H5Oflush(id);

  return status;
}

int
qdm_matrix_hd5_read(
    hid_t id,
    const char *name,
    gsl_matrix **m
)
{
  int status = 0;

  int rank = 0;

  status = H5LTget_dataset_ndims(id, name, &rank);
  if (status < 0) {
    return status;
  }

  if (rank < 2) {
    return -1;
  }

  hsize_t dims[rank];

  status = H5LTget_dataset_info(id, name, dims, NULL, NULL);
  if (status < 0) {
    return status;
  }

  size_t size1 = dims[0];
  size_t size2 = 1;
  for (int i = 1; i < rank; i++) {
    size2 *= dims[i];
  }

  gsl_matrix *tmp = gsl_matrix_alloc(size1, size2);

  status = H5LTread_dataset_double(id, name, tmp->data);
  if (status < 0) {
    gsl_matrix_free(tmp);

    return status;
  }

  *m = tmp;

  return status;
}

int
qdm_matrix_hd5_write(
    hid_t id,
    const char *name,
    const gsl_matrix *m
)
{
  int status = 0;

  hid_t datatype  = -1;
  hid_t dataspace = -1;
  hid_t dataset   = -1;
  hid_t dcpl      = -1;

  if (m == NULL) {
    goto cleanup;
  }

  datatype = H5Tcopy(H5T_NATIVE_DOUBLE);

  status = H5Tset_order(datatype, H5T_ORDER_LE);
  if (status != 0) {
    goto cleanup;
  }

  hsize_t dims[2] = {
    m->size1,
    m->size2,
  };
  dataspace = H5Screate_simple(2, dims, NULL);
  if (dataspace < 0) {
    status = dataspace;

    goto cleanup;
  }

  dcpl = H5Pcreate(H5P_DATASET_CREATE);
  if (dcpl < 0) {
    status = dcpl;

    goto cleanup;
  }

  /* Only enable compression on larger matrices. */
  /*
  if (m->size1 * m->size2 > 1024) {
    status = H5Pset_deflate(dcpl, 9);
    if (status != 0) {
      goto cleanup;
    }

    hsize_t chunk_dims[2] = {
      m->size1,
      m->size2
    };
    status = H5Pset_chunk(dcpl, 2, chunk_dims);
    if (status != 0) {
      goto cleanup;
    }
  }
  */

  dataset = H5Dcreate(id, name, datatype, dataspace, H5P_DEFAULT, dcpl, H5P_DEFAULT);
  if (dataset < 0) {
    status = dataset;

    goto cleanup;
  }

  status = H5Dwrite(dataset, H5T_NATIVE_DOUBLE, H5S_ALL, H5S_ALL, H5P_DEFAULT, m->data);
  if (status != 0) {
    goto cleanup;
  }

cleanup:
  if (dcpl >= 0) {
    H5Pclose(dcpl);
  }

  if (dataset >= 0) {
    H5Dclose(dataset);
  }

  if (dataspace >= 0) {
    H5Sclose(dataspace);
  }

  if (datatype >= 0) {
    H5Tclose(datatype);
  }

  H5Oflush(id);

  return status;
}

gsl_vector *
qdm_matrix_filter(
    const gsl_matrix *m,
    size_t needle_column,
    double needle_value,
    size_t select_column
)
{
  size_t size = 0;

  for (size_t i = 0; i < m->size1; i++) {
    if (gsl_matrix_get(m, i, needle_column) == needle_value) {
      size++;
    }
  }

  gsl_vector *v = gsl_vector_alloc(size);

  size_t j = 0;
  for (size_t i = 0; i < m->size1; i++) {
    double select_value = gsl_matrix_get(m, i, select_column);

    if (gsl_matrix_get(m, i, needle_column) == needle_value) {
      gsl_vector_set(v, j, select_value);
      j++;
    }
  }

  return v;
}


#include <stdio.h>
#include <math.h>
#include <stdlib.h>
#include <nlopt.h>
#include <unistd.h>
#include <sys/time.h>

void quadbezier(const double *a, const double *b, const double *c,
		double t, double *out)
{
  double onemt = 1.0 - t;
  out[0] = onemt * (onemt * a[0] + t * b[0]) + t * (onemt * b[0] + t * c[0]);
  out[1] = onemt * (onemt * a[1] + t * b[1]) + t * (onemt * b[1] + t * c[1]);
}

void linearinterp(const double *a, const double *b,
		  double t, double *out)
{
  out[0] = (b[0] - a[0]) * t + a[0];
  out[1] = (b[1] - a[1]) * t + a[1];
}

typedef struct {
  int N;
  int steps;
  double *starts;
  double *stops;
  double *scratch;
} problem_t;

double randd()
{
  int n = rand() % (1<<24);
  return ((double)n) / ((double)(1<<24));
}

double distance(const double *a, const double *b)
{
  return sqrt((b[0] - a[0]) * (b[0] - a[0]) +
	      (b[1] - a[1]) * (b[1] - a[1]));
}

#define RADIUS 5.0

double errorf(unsigned n, const double *pts, double *grad,
	      void *data)
{
  problem_t *setup = (problem_t *)data;
  double error = 0.0;

  for(int step=0; step<setup->steps; step++) {
    double t = (1.0+step) / (1.0+setup->steps);
    for(int i=0; i<setup->N; i++)
      quadbezier(&setup->starts[2*i],
		 &pts[2*i],
		 &setup->stops[2*i],
		 t,
		 &setup->scratch[2*i]);

    for(int i=0; i<setup->N; i++)
      for(int j=i+1; j<setup->N; j++) {
	double d = distance(&setup->scratch[2*i],
			    &setup->scratch[2*j]);
	d /= RADIUS;
	error += (1.0/d) * (1.0/d);
      }
  }

  return error / setup->steps;
}

int main(int argc, char *argv[])
{
  int N = 12;

  double *starts = (double *)malloc(sizeof(double)*N*2);
  double *stops = (double *)malloc(sizeof(double)*N*2);

  srand(2);
  nlopt_srand(1);

  double scaling = 100.0;
  for(int i=0; i<N; i++) {
    starts[2*i+0] = scaling * randd();
    starts[2*i+1] = scaling * randd();
    stops[2*i+0]  = scaling * randd();
    stops[2*i+1]  = scaling * randd();
  }

  double hs = scaling / 2.0;
  for(int i=0; i<N; i++) {
    double theta = ((double)i)/N * 2 * 3.141592;
    starts[2*i+0] = hs * cos(theta) + hs;
    starts[2*i+1] = hs * sin(theta) + hs;
    stops[2*i+0]  = hs * cos(theta + 3.141592) + hs;
    stops[2*i+1]  = hs * sin(theta + 3.141592) + hs;
  }

  struct timeval start, stop;

  double *guesses = (double *)malloc(sizeof(double)*N*2);

  gettimeofday(&start, NULL);
  for(int i=0; i<N; i++) {
    linearinterp(&starts[2*i], &stops[2*i], 0.5, &guesses[2*i]);
  }

  nlopt_opt global = nlopt_create(NLOPT_GN_ISRES, 2*N);
  nlopt_opt local = nlopt_create(NLOPT_LN_SBPLX, 2*N);

  problem_t *setup = (problem_t *)malloc(sizeof(problem_t));
  setup->N = N;
  setup->starts = starts;
  setup->stops = stops;
  setup->steps = 50;
  setup->scratch = (double *)malloc(sizeof(double)*N*2);

  nlopt_result res;

  res = nlopt_set_min_objective(global, errorf, setup);
  if(res!=1) { exit(-1); }

  res = nlopt_set_lower_bounds1(global, -25.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_upper_bounds1(global, 125.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_stopval(global, 1.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_maxeval(global, 100);
  if(res!=1) { exit(-1); }

  double final_error;
  res = nlopt_optimize(global, guesses, &final_error);

  res = nlopt_set_min_objective(local, errorf, setup);
  if(res!=1) { exit(-1); }

  res = nlopt_set_lower_bounds1(local, -25.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_upper_bounds1(local, 125.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_stopval(local, 1.0);
  if(res!=1) { exit(-1); }

  res = nlopt_set_maxeval(local, 1000);
  if(res!=1) { exit(-1); }

  res = nlopt_optimize(local, guesses, &final_error);
  gettimeofday(&stop, NULL);

  fprintf(stderr, "final: %f\n", final_error);

  for(int i=0; i<N; i++) {
    printf("%f %f %f %f %f %f\n",
	   starts[2*i+0], starts[2*i+1],
	   guesses[2*i+0], guesses[2*i+1],
	   stops[2*i+0], stops[2*i+1]);
  }

  double startd, stopd;
  startd = start.tv_sec;
  startd += ((double)(start.tv_usec)) / 1e6;
  stopd = stop.tv_sec;
  stopd += ((double)(stop.tv_usec)) / 1e6;

  //printf("%f\n", stopd - startd);
}


#include <errno.h>
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/time.h>
#include <time.h>
#include <clapack.h>
#include <cblas.h>
#include <omp.h>

#define DIM 16
#define NB 256

//#define DIM 96
//#define NB 128

extern void spotrf_(char *, int *, float *, int *, int *);

/*#pragma css task input(NB) inout(A[NB][NB]) highpriority */
void smpSs_spotrf_tile(float *A)
{

unsigned char LO='L';
int INFO;
int nn=NB;
   spotrf_(&LO,
          &nn,
          A,&nn,
          &INFO);
}

/*#pragma css task input(A[NB][NB], B[NB][NB], NB) inout(C[NB][NB])*/
void smpSs_sgemm_tile(float  *A, float *B, float *C)
{
unsigned char TR='T', NT='N';
float DONE=1.0, DMONE=-1.0;
    cblas_sgemm(
        CblasColMajor,
        CblasNoTrans, CblasTrans,
        NB, NB, NB,
        -1.0, A, NB,
              B, NB,
         1.0, C, NB);

}

/*#pragma css task input(T[NB][NB], NB) inout(B[NB][NB])*/
void smpSs_strsm_tile(float *T, float *B)
{
unsigned char LO='L', TR='T', NU='N', RI='R';
float DONE=1.0;

    cblas_strsm(
        CblasColMajor,
        CblasRight, CblasLower, CblasTrans, CblasNonUnit,
        NB, NB,
        1.0, T, NB,
             B, NB);

}

/*#pragma css task input(A[NB][NB], NB) inout(C[NB][NB])*/
void smpSs_ssyrk_tile( float *A, float *C)
{
unsigned char LO='L', NT='N';
float DONE=1.0, DMONE=-1.0;

    cblas_ssyrk(
        CblasColMajor,
        CblasLower,CblasNoTrans,
        NB, NB,
        -1.0, A, NB,
         1.0, C, NB);

}

void compute(struct timeval *start, struct timeval *stop, float *A[DIM][DIM])
{
#pragma omp parallel num_threads(48)
#pragma omp single
{
 gettimeofday(start,NULL);
  double t1 = omp_get_wtime();

  long j,k,i;
  for (j = 0; j < DIM; j++)
  {
    for (k= 0; k< j; k++)
    {
      for (i = j+1; i < DIM; i++)
      {
      #pragma omp task shared(A) firstprivate(i,k,j)  depend(in : A[i][k], A[j][k]) depend(inout:A[i][j])
        smpSs_sgemm_tile(  A[i][k], A[j][k], A[i][j]);
      }
    }
    for (i = 0; i < j; i++)
    {
    #pragma omp task shared(A) firstprivate(i,j) depend (in : A[j][i]) depend(inout : A[j][j])
      smpSs_ssyrk_tile( A[j][i], A[j][j]);
    }

   #pragma omp task shared(A) firstprivate(j) depend(inout : A[j][j])
    smpSs_spotrf_tile( A[j][j]);

    for (i = j+1; i < DIM; i++)
    {
  #pragma omp task shared(A) firstprivate(i,j) depend(in : A[j][j]) depend (inout : A[i][j])
      smpSs_strsm_tile( A[j][j], A[i][j]);
    }

  }
#pragma omp taskwait

  double t2 = omp_get_wtime();
  fprintf(stderr,"Time: %f\n",t2-t1);
}
 gettimeofday(stop,NULL);
 exit(0);
}

static void init(int argc, char **argv,  long *N_p);

float **A;
float * Alin;

long N;

int
main(int argc, char *argv[])
{

unsigned char LO='L';
int  INFO;

  struct timeval start;
  struct timeval stop;
  unsigned long elapsed;

  init(argc, argv, &N);
  fprintf(stderr,"Computing cholesky...\n");

  compute(&start, &stop, (void *)A);

  int nn=N;

  elapsed = 1000000 * (stop.tv_sec - start.tv_sec);
  elapsed += stop.tv_usec - start.tv_usec;

  printf ("%lu;\t", elapsed);
  printf("%d\n", (int)((0.33*N*N*N+0.5*N*N+0.17*N)/elapsed));

  printf("par_sec_time_us:%lu\n",elapsed);
  return 0;
}

static void convert_to_blocks(long N, float *Alin, float *A[DIM][DIM])
{
  long i,j;
  for (i = 0; i < N; i++)
  {
    for (j = 0; j < N; j++)
    {
      A[j/NB][i/NB][(i%NB)*NB+j%NB] = Alin[i*N+j];
    }
  }

}

void fill_random(float *Alin, int NN)
{
  int i;
  for (i = 0; i < NN; i++)
  {
    Alin[i]=((float)rand())/((float)RAND_MAX);
  }
}

static void init(int argc, char **argv,  long *N_p)
{
  long ISEED[4] = {0,0,0,1};
  long IONE=1;

  long N = NB*DIM;
  long NN = N * N;

  *N_p = N;

   Alin = (float *) malloc(NN * sizeof(float));

  fill_random(Alin,NN);
  long i;
  for(i=0; i<N; i++)
  {
    Alin[i*N + i] += N;
  }

  A = (float **) malloc(DIM*DIM*sizeof(float *));
  for ( i = 0; i < DIM*DIM; i++)
    {
//     #pragma omp memory
     A[i] = (float *) malloc(NB*NB*sizeof(float));
      int z;
      for (z=0;z<DIM*DIM;z++)
	   { float *zz = (float *) A[i];
	     zz[z] = Alin[(DIM*DIM)*i + z]; }
    }

  convert_to_blocks(N, Alin, (void *)A);

}


/* tt.h:
 /   This file contains everything related to the tensor_train struct
*/

#ifndef TENSOR_TRAIN_H
#define TENSOR_TRAIN_H

#include <lapacke.h>
#include <mpi.h>
#include "tensor.h"

typedef struct tensor_train {
    int d;           // dimension of tensor
    int* n;          // tensor size of each dimension
    int* r;          // tensor-train ranks

    double** trains; // array of pointers storing the address of the trains
} tensor_train;

tensor_train* TT_init(const int d, const int* restrict n);
tensor_train* TT_init_rank(const int d, const int* restrict n, const int* restrict r);
tensor_train* TT_copy(tensor_train* X);
void TT_free(tensor_train* sim);
void TT_print(tensor_train* tt);

// Broadcast a tensor train to all nodes
void tt_broadcast(MPI_Comm comm, tensor_train* tt);

// Find how much the tensor_train has compressed the tensor
double get_compression(const tensor_train* tt);

#endif


#ifndef TFDH_GSL_WRAPPERS_H
#define TFDH_GSL_WRAPPERS_H

#include <gsl/gsl_spline.h>
#include <vector>

namespace GSL {

  // simple functor class to help interfacing with gsl_function.
  // derived classes representing a function f(x) should hold any needed
  // parameters as member variables, and operator()(double x) should evaluate
  // the function f(x).
  //
  // NOTE: the GSL wrappers below could in principle take C++11 lambdas instead
  //       of this custom function object, however i did not find an elegant
  //       way to call these lambdas using GSL's C interfaces...
  class FunctionObject {
    public:
      virtual ~FunctionObject() = default;
      virtual double operator()(double x) const = 0;
  };

  // simple wrapper class around GSL splines
  class Spline {
    private:
      gsl_interp_accel* acc;
      gsl_spline* spline;
    public:
      Spline(const std::vector<double>& x, const std::vector<double>& f);
      ~Spline();
      double eval(double r) const;
  };

  // find a root of func in the interval x1 to x2
  // one of (x1,x2) or (x2,x1) MUST bracket a root
  // implemented using GSL's Brent rootfinder method
  double findRoot(const GSL::FunctionObject& func, double x1, double x2,
      double eps_abs, double eps_rel);

  // definite integral of func from x1 to x2
  // implemented using GSL's adaptive Gauss quadrature
  double integrate(const GSL::FunctionObject& func, double x1, double x2,
      double eps_abs, double eps_rel);

}

#endif // TFDH_GSL_WRAPPERS_H


#pragma once

#include <memory>

#include <gsl/gsl_rng.h>

extern std::unique_ptr<gsl_rng, decltype(&gsl_rng_free)> rng;


#ifndef bfkl_H_INCLUDED
#define bfkl_H_INCLUDED

#include <stdio.h>
#include <math.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_integration.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include "cubature.h"
#include "string.h"
#include "alphas.h"
#include "wf.h"

//number of tabulated points in z and x for BFKL Kernel
#define Nz 94
#define Nx 1201
#define Nhar 24
#define ZMIN (0.15)
#define ZMAX (4.8)
#define XMAX (100.00)

void ReadInBFKL();
double BFKLfunc(double z, double x, int n);
double d2N_BFKL(double pT, double qT, double phi, double yp, double yq, double rts);

struct bfkl_params {
	double pT;
	double qT;
	double phi;
	double x1, x2;
    double dy;
	} ;

#endif


#include <assert.h>
#include <stdio.h>
#include <string.h>
#include <gsl/gsl_permutation.h>
#include <gsl/gsl_sf_gamma.h>

int
main(int argc, char *argv[]){
	gsl_permutation *P;
	size_t l;

	if(2!=argc){
		return 1;
	}

	l=strlen(argv[1]);

	if(GSL_SF_FACT_NMAX<l){
		printf("String too long\n");
		return 1;
	}

	P=gsl_permutation_calloc(l);
	assert(NULL!=P);

	do{
		size_t *d=gsl_permutation_data(P),i;

		for(i=0;i<l;i++)
			printf("%c",argv[1][d[i]]);

		printf("\n");
	}while(GSL_SUCCESS==gsl_permutation_next(P));

	return 0;
}


/**
 *
 * @file core_stsmlq_corner.c
 *
 *  PLASMA core_blas kernel
 *  PLASMA is a software package provided by Univ. of Tennessee,
 *  Univ. of California Berkeley and Univ. of Colorado Denver
 *
 * @version 2.6.0
 * @author Hatem Ltaief
 * @author Mathieu Faverge
 * @author Azzam Haidar
 * @date 2010-11-15
 * @generated s Tue Jan  7 11:44:48 2014
 *
 **/
#include <lapacke.h>
#include "common.h"
#undef COMPLEX
#define REAL

/***************************************************************************//**
 *
 * @ingroup CORE_float
 *
 *  CORE_stsmlq_corner: see CORE_stsmlq
 *
 * This kernel applies left and right transformations as depicted below:
 * |I -VTV'| * | A1  A2 | * |I - VT'V'|
 *             | A2' A3 |
 * where A1 and A3 are symmetric matrices.
 * Only the lower part is referenced.
 * This is an adhoc implementation, can be further optimized...
 *
 *******************************************************************************
 *
 * @param[in] m1
 *         The number of rows of the tile A1. m1 >= 0.
 *
 * @param[in] n1
 *         The number of columns of the tile A1. n1 >= 0.
 *
 * @param[in] m2
 *         The number of rows of the tile A2. m2 >= 0.
 *
 * @param[in] n2
 *         The number of columns of the tile A2. n2 >= 0.
 *
 * @param[in] m3
 *         The number of rows of the tile A3. m3 >= 0.
 *
 * @param[in] n3
 *         The number of columns of the tile A3. n3 >= 0.
 *
 * @param[in] k
 *         The number of elementary reflectors whose product defines
 *         the matrix Q.
 *
 * @param[in] ib
 *         The inner-blocking size.  ib >= 0.
 *
 * @param[in] nb
 *         The blocking size.  nb >= 0.
 *
 * @param[in,out] A1
 *         On entry, the m1-by-n1 tile A1.
 *         On exit, A1 is overwritten by the application of Q.
 *
 * @param[in] lda1
 *         The leading dimension of the array A1. lda1 >= max(1,m1).
 *
 * @param[in,out] A2
 *         On entry, the m2-by-n2 tile A2.
 *         On exit, A2 is overwritten by the application of Q.
 *
 * @param[in] lda2
 *         The leading dimension of the tile A2. lda2 >= max(1,m2).
 *
 * @param[in,out] A3
 *         On entry, the m3-by-n3 tile A3.
 *
 * @param[in] lda3
 *         The leading dimension of the tile A3. lda3 >= max(1,m3).
 *
 * @param[in] V
 *         The i-th row must contain the vector which defines the
 *         elementary reflector H(i), for i = 1,2,...,k, as returned by
 *         CORE_STSLQT in the first k rows of its array argument V.
 *
 * @param[in] ldv
 *         The leading dimension of the array V. ldv >= max(1,K).
 *
 * @param[in] T
 *         The IB-by-n1 triangular factor T of the block reflector.
 *         T is upper triangular by block (economic storage);
 *         The rest of the array is not referenced.
 *
 * @param[in] ldt
 *         The leading dimension of the array T. ldt >= IB.
 *
 * @param[out] WORK
 *         Workspace array of size
 *             LDWORK-by-m1 if side == PlasmaLeft
 *             LDWORK-by-IB if side == PlasmaRight
 *
 * @param[in] ldwork
 *         The leading dimension of the array WORK.
 *             LDWORK >= max(1,IB) if side == PlasmaLeft
 *             LDWORK >= max(1,n1) if side == PlasmaRight
 *
 *******************************************************************************
 *
 * @return
 *          \retval PLASMA_SUCCESS successful exit
 *          \retval <0 if -i, the i-th argument had an illegal value
 *
 ******************************************************************************/
#if defined(PLASMA_HAVE_WEAK)
#pragma weak CORE_stsmlq_corner = PCORE_stsmlq_corner
#define CORE_stsmlq_corner PCORE_stsmlq_corner
#define CORE_stsmlq PCORE_stsmlq
int  CORE_stsmlq(PLASMA_enum side, PLASMA_enum trans,
                 int m1, int n1, int m2, int n2, int K, int IB,
                 float *A1, int lda1,
                 float *A2, int lda2,
                 const float *V, int ldv,
                 const float *T, int ldt,
                 float *WORK, int LDWORK);
#endif
int CORE_stsmlq_corner( int m1, int n1, int m2, int n2, int m3, int n3,
                        int k, int ib, int nb,
                        float *A1, int lda1,
                        float *A2, int lda2,
                        float *A3, int lda3,
                        const float *V, int ldv,
                        const float *T, int ldt,
                        float *WORK, int ldwork)
{
    PLASMA_enum side;
    PLASMA_enum trans;
    int i, j;

    if ( m1 != n1 ) {
        coreblas_error(1, "Illegal value of M1, N1");
        return -1;
    }

    /* Rebuild the symmetric block: WORK <- A1 */
    for (i = 0; i < m1; i++)
        for (j = i; j < n1; j++){
            *(WORK + i + j*ldwork) = *(A1 + i + j*lda1);
            if (j > i){
                *(WORK + j + i*ldwork) =  ( *(WORK + i + j*ldwork) );
            }
        }

    /*  Copy the transpose of A2: WORK+nb*ldwork <- A2' */
    for (j = 0; j < n2; j++)
        for (i = 0; i < m2; i++){
            *(WORK + j + (i + nb) * ldwork) = ( *(A2 + i + j*lda2) );
        }

    side = PlasmaRight;
    trans = PlasmaTrans;

    /*  Right application on |A1 A2| */
    CORE_stsmlq(side, trans, m1, n1, m2, n2, k, ib,
                WORK, ldwork, A2, lda2,
                V, ldv, T, ldt,
                WORK+3*nb*ldwork, ldwork);

    /*  Rebuild the symmetric block: WORK+2*nb*ldwork <- A3 */
    for (i = 0; i < m3; i++)
        for (j = i; j < n3; j++){
            *(WORK + i + (j + 2*nb) * ldwork) = *(A3 + i + j*lda3);
            if (j > i){
                *(WORK + j + (i + 2*nb) * ldwork) =   ( *(WORK + i + (j + 2*nb) * ldwork) );
            }
        }

    /*  Right application on | A2' A3 | */
    CORE_stsmlq(side, trans, n2, m2, m3, n3, k, ib,
                WORK+nb*ldwork, ldwork, WORK+2*nb*ldwork, ldwork,
                V, ldv, T, ldt,
                WORK + 3*nb*ldwork, ldwork);

    side = PlasmaLeft;
    trans = PlasmaNoTrans;

    /*  Left application on | A1  | */
    /*                      | A2' | */
    CORE_stsmlq(side, trans, m1, n1, n2, m2, k, ib,
                WORK, ldwork, WORK+nb*ldwork, ldwork,
                V, ldv, T, ldt,
                WORK + 3*nb*ldwork, ldwork);

    /*  Copy back the final result to the upper part of A1 */
    /*  A1 = WORK */
    for (i = 0; i < m1; i++)
        for (j = i; j < n1; j++)
            *(A1 + i + j*lda1) = *(WORK + i + j*ldwork);

    /*  Left application on | A2 | */
    /*                      | A3 | */
    CORE_stsmlq(side, trans, m2, n2, m3, n3, k, ib,
                A2, lda2, WORK+2*nb*ldwork, ldwork,
                V, ldv, T, ldt,
                WORK + 3*nb*ldwork, ldwork);

    /*  Copy back the final result to the upper part of A3 */
    /*  A3 = WORK+2*nb*ldwork */
    for (i = 0; i < m3; i++)
        for (j = i; j < n3; j++)
            *(A3 + i + j*lda3) = *(WORK + i + (j+ 2*nb) * ldwork);

    return PLASMA_SUCCESS;
}