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

#include <config.h>
#include <math.h>
#include <float.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_integration.h>

static double rescale_error (double err, const double result_abs, const double result_asc) ;

static double
rescale_error (double err, const double result_abs, const double result_asc)
{
  err = fabs(err) ;

  if (result_asc != 0 && err != 0)
      {
        double scale = pow((200 * err / result_asc), 1.5) ;

        if (scale < 1)
          {
            err = result_asc * scale ;
          }
        else
          {
            err = result_asc ;
          }
      }
  if (result_abs > GSL_DBL_MIN / (50 * GSL_DBL_EPSILON))
    {
      double min_err = 50 * GSL_DBL_EPSILON * result_abs ;

      if (min_err > err)
        {
          err = min_err ;
        }
    }

  return err ;
}


#include "compute_signal.h"
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_histogram.h>
#include <stdio.h>
#include <stdlib.h>
#include <math.h>

#include "parameters.h"

void compute_signal(double * signal, const size_t length, const double delta,
    gsl_rng * r, gsl_histogram * hist){

  static double x0 = XINIT;

  puts("Building signal ...");

  double x = x0;
  double t_begin = 0.0; //Distance from the beginning of time discretization
                        //interval to current point in time

  for(size_t j=0; j<length; j++){
    //Perfom integration using method of rectangles.
    double sum = 0.0;         //Sum of signal areas
    double delta_t = t_begin; //part of time step in the new interval

    while(t_begin < delta) {
      sum += x*delta_t;

      double z = gsl_ran_gaussian_ziggurat(r,1.0);
      //Milstein approximation:
      x += 0.5*KAPPA*KAPPA*XMIN + KAPPA*x*z + 0.5*KAPPA*KAPPA*x*(z*z-1.0);
      //Euler-Marujama approximation:
      //x += 0.5*KAPPA*KAPPA*XMIN + KAPPA*x*z

      if(x > XOVER) {x = XINIT; puts("Too large");}
      if(x < 0) {x = -x; puts("Negative");}

      delta_t = KAPPA*KAPPA/(SIGMA*SIGMA*x);

      gsl_histogram_accumulate(hist, x, delta_t);

      t_begin += delta_t; //increase distance from the beginning
    }

    t_begin -= delta;

    /* remaining part of the time step is equal to the difference of the full
     * time step and of the part of the time step outside the interval.
     * Part outside the interval is t_begin */
    sum += x*(delta_t - t_begin);
    signal[j] = sum/delta; //assign effective height to the signal.
  }

  x0 = x;
}


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

/* Author:  G. Jungman */

#ifndef __GSL_SF_ERF_H__
#define __GSL_SF_ERF_H__

#include <gsl/gsl_sf_result.h>

#undef __BEGIN_DECLS
#undef __END_DECLS
#ifdef __cplusplus
# define __BEGIN_DECLS extern "C" {
# define __END_DECLS }
#else
# define __BEGIN_DECLS /* empty */
# define __END_DECLS /* empty */
#endif

__BEGIN_DECLS

/* Complementary Error Function
 * erfc(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,x,Infinity}]
 *
 * exceptions: none
 */
int gsl_sf_erfc_e(double x, gsl_sf_result * result);
double gsl_sf_erfc(double x);

/* Log Complementary Error Function
 *
 * exceptions: none
 */
int gsl_sf_log_erfc_e(double x, gsl_sf_result * result);
double gsl_sf_log_erfc(double x);

/* Error Function
 * erf(x) := 2/Sqrt[Pi] Integrate[Exp[-t^2], {t,0,x}]
 *
 * exceptions: none
 */
int gsl_sf_erf_e(double x, gsl_sf_result * result);
double gsl_sf_erf(double x);

/* Probability functions:
 * Z(x) :  Abramowitz+Stegun 26.2.1
 * Q(x) :  Abramowitz+Stegun 26.2.3
 *
 * exceptions: none
 */
int gsl_sf_erf_Z_e(double x, gsl_sf_result * result);
int gsl_sf_erf_Q_e(double x, gsl_sf_result * result);
double gsl_sf_erf_Z(double x);
double gsl_sf_erf_Q(double x);

/* Hazard function, also known as the inverse Mill's ratio.
 *
 *   H(x) := Z(x)/Q(x)
 *         = Sqrt[2/Pi] Exp[-x^2 / 2] / Erfc[x/Sqrt[2]]
 *
 * exceptions: GSL_EUNDRFLW
 */
int gsl_sf_hazard_e(double x, gsl_sf_result * result);
double gsl_sf_hazard(double x);

__END_DECLS

#endif /* __GSL_SF_ERF_H__ */


/*****************************************************************************
*
* Rokko: Integrated Interface for libraries of eigenvalue decomposition
*
* Copyright (C) 2012-2014 by Synge Todo <wistaria@phys.s.u-tokyo.ac.jp>
*
* Distributed under the Boost Software License, Version 1.0. (See accompanying
* file LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt)
*
*****************************************************************************/

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

#define N 5

int main() {
  int i, j, info;
  double w[N];
  double a[N][N] = {
    5, 4, 3, 2, 1,
    4, 4, 3, 2, 1,
    3, 3, 3, 2, 1,
    2, 2, 2, 2, 1,
    1, 1, 1, 1, 1
  };
  info = LAPACKE_dsyev(LAPACK_ROW_MAJOR, 'V', 'U', N, a[0], N, w);
  printf("Eigenvalues of Frank matrix: ");
  for (i = 0; i < N; ++i) {
    printf(" %6.2f", w[i]);
  }
  printf("\n");
  printf("Eigenvectors of Frank matrix (column by column):\n");
  for (i = 0; i < N; ++i) {
    for (j = 0; j < N; ++j) {
      printf(" %6.2f", a[i][j]);
    }
    printf("\n");
  }
  return 0;
}


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

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

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

#include "givens.c"

/*
 * This module contains routines related to the Hessenberg-Triangular
 * reduction of two general real matrices
 *
 * See Golub & Van Loan, "Matrix Computations", 3rd ed, sec 7.7.4
 */

/*
gsl_linalg_hesstri_decomp()
  Perform a reduction to generalized upper Hessenberg form.
Given A and B, this function overwrites A with an upper Hessenberg
matrix H = U^T A V and B with an upper triangular matrix R = U^T B V
with U and V orthogonal.

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

Inputs: A    - real square matrix
        B    - real square matrix
        U    - (output) if non-null, U is stored here on output
        V    - (output) if non-null, V is stored here on output
        work - workspace (length n)

Return: success or error
*/

int
gsl_linalg_hesstri_decomp(gsl_matrix * A, gsl_matrix * B, gsl_matrix * U,
                          gsl_matrix * V, gsl_vector * work)
{
  const size_t N = A->size1;

  if ((N != A->size2) || (N != B->size1) || (N != B->size2))
    {
      GSL_ERROR ("Hessenberg-triangular reduction requires square matrices",
                 GSL_ENOTSQR);
    }
  else if (N != work->size)
    {
      GSL_ERROR ("length of workspace must match matrix dimension",
                 GSL_EBADLEN);
    }
  else
    {
      double cs, sn;          /* rotation parameters */
      size_t i, j;            /* looping */
      gsl_vector_view xv, yv; /* temporary views */

      /* B -> Q^T B = R (upper triangular) */
      gsl_linalg_QR_decomp(B, work);

      /* A -> Q^T A */
      gsl_linalg_QR_QTmat(B, work, A);

      /* initialize U and V if desired */

      if (U)
        {
          gsl_linalg_QR_unpack(B, work, U, B);
        }
      else
        {
          /* zero out lower triangle of B */
          for (j = 0; j < N - 1; ++j)
            {
              for (i = j + 1; i < N; ++i)
                gsl_matrix_set(B, i, j, 0.0);
            }
        }

      if (V)
        gsl_matrix_set_identity(V);

      if (N < 3)
        return GSL_SUCCESS; /* nothing more to do */

      /* reduce A and B */
      for (j = 0; j < N - 2; ++j)
        {
          for (i = N - 1; i >= (j + 2); --i)
            {
              /* step 1: rotate rows i - 1, i to kill A(i,j) */

              /*
               * compute G = [ CS SN ] so that G^t [ A(i-1,j) ] = [ * ]
               *             [-SN CS ]             [ A(i, j)  ]   [ 0 ]
               */
              create_givens(gsl_matrix_get(A, i - 1, j),
                            gsl_matrix_get(A, i, j),
                            &cs,
                            &sn);
              /* invert so drot() works correctly (G -> G^t) */
              sn = -sn;

              /* compute G^t A(i-1:i, j:n) */
              xv = gsl_matrix_subrow(A, i - 1, j, N - j);
              yv = gsl_matrix_subrow(A, i, j, N - j);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              /* compute G^t B(i-1:i, i-1:n) */
              xv = gsl_matrix_subrow(B, i - 1, i - 1, N - i + 1);
              yv = gsl_matrix_subrow(B, i, i - 1, N - i + 1);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              if (U)
                {
                  /* accumulate U: U -> U G */
                  xv = gsl_matrix_column(U, i - 1);
                  yv = gsl_matrix_column(U, i);
                  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
                }

              /* step 2: rotate columns i, i - 1 to kill B(i, i - 1) */

              create_givens(-gsl_matrix_get(B, i, i),
                            gsl_matrix_get(B, i, i - 1),
                            &cs,
                            &sn);
              /* invert so drot() works correctly (G -> G^t) */
              sn = -sn;

              /* compute B(1:i, i-1:i) G */
              xv = gsl_matrix_subcolumn(B, i - 1, 0, i + 1);
              yv = gsl_matrix_subcolumn(B, i, 0, i + 1);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              /* apply to A(1:n, i-1:i) */
              xv = gsl_matrix_column(A, i - 1);
              yv = gsl_matrix_column(A, i);
              gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);

              if (V)
                {
                  /* accumulate V: V -> V G */
                  xv = gsl_matrix_column(V, i - 1);
                  yv = gsl_matrix_column(V, i);
                  gsl_blas_drot(&xv.vector, &yv.vector, cs, sn);
                }
            }
        }

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


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

#include <gsl/gsl_linalg.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_matrix_double.h>
#include <gsl/gsl_vector_double.h>
#include <gsl/gsl_blas.h>

int main() {
	int ret;
	int i, j;
	gsl_vector* tau;
	gsl_matrix *A;
	gsl_matrix *Q, *R, *RTR;
	gsl_matrix_view Rtop;
	int M = 4;
	int N = 3;

	/*
	  gsl_matrix A;
	  double data[9];
	  memset(&A, 0, sizeof(gsl_matrix));
	  A.size1 = 3;
	  A.size2 = 3;
	  A.tda = 3;
	  A.data = data;
	  gsl_matrix_set(&A, 0, 0, 34.0);
	  gsl_matrix_set(&A, 0, 1, 4.0);
	  gsl_matrix_set(&A, 0, 2, 14.0);
	  gsl_matrix_set(&A, 1, 0, 1.0);
	  gsl_matrix_set(&A, 1, 1, 8.0);
	  gsl_matrix_set(&A, 1, 2, 3.0);
	  gsl_matrix_set(&A, 2, 0, 7.0);
	  gsl_matrix_set(&A, 2, 1, 1.0);
	  gsl_matrix_set(&A, 2, 2, 8.0);
	*/

	A = gsl_matrix_alloc(M, N);

	for (i=0; i<M; i++)
		for (j=0; j<N; j++)
			gsl_matrix_set(A, i, j, (double)rand()/(double)RAND_MAX);

	for (i=0; i<A->size1; i++) {
		printf((i==0) ? "A = (" : "    (");
		for (j=0; j<A->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(A, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	tau = gsl_vector_alloc(N);

	ret = gsl_linalg_QR_decomp(A, tau);

	Q = gsl_matrix_alloc(M, M);
	R = gsl_matrix_alloc(M, N);

	ret = gsl_linalg_QR_unpack(A, tau, Q, R);

	for (i=0; i<Q->size1; i++) {
		printf((i==0) ? "Q = (" : "    (");
		for (j=0; j<Q->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(Q, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	for (i=0; i<R->size1; i++) {
		printf((i==0) ? "R = (" : "    (");
		for (j=0; j<R->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(R, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	Rtop = gsl_matrix_submatrix(R, 0, 0, N, N);
	RTR = gsl_matrix_alloc(N, N);
	gsl_matrix_memcpy(RTR, &(Rtop.matrix));
	ret = gsl_blas_dtrmm(CblasLeft, CblasUpper, CblasTrans, CblasNonUnit,
						 1.0, RTR, RTR);
	//(Rtop.matrix), &(Rtop.matrix));

	for (i=0; i<RTR->size1; i++) {
		printf((i==0) ? "RTR = (" : "      (");
		for (j=0; j<RTR->size2; j++) {
			printf(" %12.5g ", gsl_matrix_get(RTR, i, j));
		}
		printf(")\n");
	}
	printf("\n");

	gsl_matrix_free(RTR);

	gsl_matrix_free(Q);
	gsl_matrix_free(R);
	gsl_vector_free(tau);

	gsl_matrix_free(A);

	return 0;
}


// Copyright (c) 2021 Stig Rune Sellevag
//
// This file is distributed under the MIT License. See the accompanying file
// LICENSE.txt or http://www.opensource.org/licenses/mit-license.php for terms
// and conditions.

#ifndef SCILIB_LINALG_EIGENVALUE_H
#define SCILIB_LINALG_EIGENVALUE_H

#ifdef USE_MKL
#include <mkl.h>
#else
#include <lapacke.h>
#endif

#include <scilib/mdarray.h>
#include <scilib/linalg_impl/lapack_types.h>
#include <exception>
#include <cassert>
#include <complex>
#include <type_traits>

namespace Sci {
namespace Linalg {

// Compute eigenvalues and eigenvectors of a real symmetric matrix.
template <class Layout>
inline void eigs(Sci::Matrix_view<double, Layout> a,
                 Sci::Vector_view<double, Layout> w,
                 double abstol = -1.0 /* use default value */)
{
    static_assert(a.is_contiguous());
    static_assert(w.is_contiguous());

    assert(a.extent(0) == a.extent(1));
    assert(w.extent(0) == a.extent(0));

    const BLAS_INT n = static_cast<BLAS_INT>(a.extent(0));
    const BLAS_INT nselect = n;
    const BLAS_INT lda = n;
    const BLAS_INT ldz = nselect;

    BLAS_INT il = 1;
    BLAS_INT iu = n;
    BLAS_INT m;
    BLAS_INT info;

    double vl = 0.0;
    double vu = 0.0;

    Sci::Vector<BLAS_INT, Layout> isuppz(2 * n);
    Sci::Matrix<double, Layout> z(ldz, n);

    auto matrix_layout = LAPACK_ROW_MAJOR;
    if constexpr (std::is_same_v<Layout, stdex::layout_left>) {
        matrix_layout = LAPACK_COL_MAJOR;
    }

    info = LAPACKE_dsyevr(matrix_layout, 'V', 'A', 'U', n, a.data(), lda, vl,
                          vu, il, iu, abstol, &m, w.data(), z.data(), ldz,
                          isuppz.data());
    if (info != 0) {
        throw std::runtime_error("dsyevr failed");
    }
    Sci::copy(z.view(), a);
}

template <class Layout, class Allocator>
inline void eigs(Sci::Matrix<double, Layout, Allocator>& a,
                 Sci::Vector<double, Layout, Allocator>& w,
                 double abstol = -1.0 /* use default value */)
{
    eigs(a.view(), w.view(), abstol);
}

// Compute eigenvalues and eigenvectors of a real non-symmetric matrix.
template <class Layout>
void eig(Sci::Matrix_view<double, Layout> a,
         Sci::Matrix_view<std::complex<double>, Layout> evec,
         Sci::Vector_view<std::complex<double>, Layout> eval)
{
    using namespace Sci;

    static_assert(a.is_contiguous());
    static_assert(evec.is_contiguous());
    static_assert(eval.is_contiguous());

    assert(a.extent(0) == a.extent(1));
    assert(a.extent(0) == eval.extent(0));
    assert(a.extent(0) == evec.extent(0));
    assert(a.extent(1) == evec.extent(1));

    const BLAS_INT n = static_cast<BLAS_INT>(a.extent(1));

    Sci::Vector<double, Layout> wr(n);
    Sci::Vector<double, Layout> wi(n);
    Sci::Matrix<double, Layout> vr(n, n);
    Sci::Matrix<double, Layout> vl(n, n);

    auto matrix_layout = LAPACK_ROW_MAJOR;
    if constexpr (std::is_same_v<Layout, stdex::layout_left>) {
        matrix_layout = LAPACK_COL_MAJOR;
    }
    BLAS_INT info =
        LAPACKE_dgeev(matrix_layout, 'N', 'V', n, a.data(), n, wr.data(),
                      wi.data(), vl.data(), n, vr.data(), n);
    if (info != 0) {
        throw std::runtime_error("dgeev failed");
    }
    for (BLAS_INT i = 0; i < n; ++i) {
        std::complex<double> wii(wr(i), wi(i));
        eval(i) = wii;
        BLAS_INT j = 0;
        while (j < n) {
            if (wi(j) == 0.0) {
                evec(i, j) = std::complex<double>{vr(i, j), 0.0};
                ++j;
            }
            else {
                evec(i, j) = std::complex<double>{vr(i, j), vr(i, j + 1)};
                evec(i, j + 1) = std::complex<double>{vr(i, j), -vr(i, j + 1)};
                j += 2;
            }
        }
    }
}

template <class Layout,
          class Allocator_a,
          class Allocator_evec,
          class Allocator_eval>
void eig(Sci::Matrix<double, Layout, Allocator_a>& a,
         Sci::Matrix<std::complex<double>, Layout, Allocator_evec>& evec,
         Sci::Vector<std::complex<double>, Layout, Allocator_eval>& eval)
{
    eig(a.view(), evec.view(), eval.view());
}

} // namespace Linalg
} // namespace Sci

#endif // SCILIB_LINALG_EIGENVALUE_H


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

#include <config.h>
#include <math.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_sf_gamma.h>

/* The Dirichlet probability distribution of order K-1 is

     p(\theta_1,...,\theta_K) d\theta_1 ... d\theta_K =
        (1/Z) \prod_i=1,K \theta_i^{alpha_i - 1} \delta(1 -\sum_i=1,K \theta_i)

   The normalization factor Z can be expressed in terms of gamma functions:

      Z = {\prod_i=1,K \Gamma(\alpha_i)} / {\Gamma( \sum_i=1,K \alpha_i)}

   The K constants, \alpha_1,...,\alpha_K, must be positive. The K parameters,
   \theta_1,...,\theta_K are nonnegative and sum to 1.

   The random variates are generated by sampling K values from gamma
   distributions with parameters a=\alpha_i, b=1, and renormalizing.
   See A.M. Law, W.D. Kelton, Simulation Modeling and Analysis (1991).

   Gavin E. Crooks <gec@compbio.berkeley.edu> (2002)
*/

void
gsl_ran_dirichlet (const gsl_rng * r, const size_t K,
                   const double alpha[], double theta[])
{
  size_t i;
  double norm = 0.0;

  for (i = 0; i < K; i++)
    {
      theta[i] = gsl_ran_gamma (r, alpha[i], 1.0);
    }

  for (i = 0; i < K; i++)
    {
      norm += theta[i];
    }

  for (i = 0; i < K; i++)
    {
      theta[i] /= norm;
    }
}

double
gsl_ran_dirichlet_pdf (const size_t K,
                       const double alpha[], const double theta[])
{
  return exp (gsl_ran_dirichlet_lnpdf (K, alpha, theta));
}

double
gsl_ran_dirichlet_lnpdf (const size_t K,
                         const double alpha[], const double theta[])
{
  /*We calculate the log of the pdf to minimize the possibility of overflow */
  size_t i;
  double log_p = 0.0;
  double sum_alpha = 0.0;

  for (i = 0; i < K; i++)
    {
      log_p += (alpha[i] - 1.0) * log (theta[i]);
    }

  for (i = 0; i < K; i++)
    {
      sum_alpha += alpha[i];
    }

  log_p += gsl_sf_lngamma (sum_alpha);

  for (i = 0; i < K; i++)
    {
      log_p -= gsl_sf_lngamma (alpha[i]);
    }

  return log_p;
}


/*
** gsl routines for float data type
**
** G.Lohmann, July 2004
*/
#include <viaio/Vlib.h>

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

#include <gsl/gsl_cblas.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_vector.h>
#include <gsl/gsl_blas.h>
#include <gsl/gsl_linalg.h>
#include <gsl/gsl_sort_vector.h>
#include "gsl_utils.h"

/*
** y = Ax
*/
gsl_vector_float *fmat_x_vector(gsl_matrix_float *A, gsl_vector_float *x, gsl_vector_float *y)
{
  if (y == NULL) {
    y = gsl_vector_float_alloc (A->size1);
  }

  gsl_blas_sgemv(CblasNoTrans, 1.0, A, x, 0.0, y);

  return y;
}

/*
**    C = A x B^T
*/
gsl_matrix_float *fmat_x_matT(gsl_matrix_float *A,gsl_matrix_float *B,gsl_matrix_float *C)
{
  if (C == NULL) {
    C = gsl_matrix_float_alloc( A->size1, B->size1 );
  }

  gsl_blas_sgemm( CblasNoTrans, CblasTrans, 1.0, A, B, 0.0, C );

  return C;
}

/*
**    C = A^T x B
*/
gsl_matrix_float *fmatT_x_mat(gsl_matrix_float *A,gsl_matrix_float *B,gsl_matrix_float *C)
{
  if (C == NULL) {
    C = gsl_matrix_float_alloc( A->size2, B->size2 );
  }

  gsl_blas_sgemm( CblasTrans, CblasNoTrans, 1.0, A, B, 0.0, C );

  return C;
}

/*
**    C = A x B
*/
gsl_matrix_float *fmat_x_mat(gsl_matrix_float *A,gsl_matrix_float *B,gsl_matrix_float *C)
{
  if (C == NULL) {
    C = gsl_matrix_float_alloc( A->size1, B->size2 );
  }

  gsl_blas_sgemm( CblasNoTrans, CblasNoTrans, 1.0, A, B, 0.0, C );

  return C;
}

/*
**  y = Ax,  A double, x float
*/
gsl_vector_float *dmat_x_fvector(gsl_matrix *A, gsl_vector_float *x, gsl_vector_float *y)
{
  int i,j,nrows,ncols;
  float *ptr2,*ptr3,sum;
  double *ptr1;

  nrows = A->size1;
  ncols = A->size2;

  if (y == NULL) {
     y = gsl_vector_float_alloc (nrows);
  }

  if (x->size != ncols || y->size != nrows) {
    fprintf(stderr," fmat_x_vect: incongruent dimensions\n");
    exit(0);
  }

  ptr1 = A->data;
  ptr3 = y->data;

  for (i=0; i<nrows; i++) {
    sum = 0;
    ptr2 = x->data;
    for (j=0; j<ncols; j++) {
      sum += (*ptr1++) * (*ptr2++);
    }
    *ptr3++ = sum;
  }
  return y;
}

/*
**  z = x^T y
*/
float fskalarproduct(gsl_vector_float *x,gsl_vector_float *y)
{
  int i,n;
  float *ptr1,*ptr2,sum;

  n = x->size;
  if (y->size != n) {
    fprintf(stderr," fskalarproduct: incongruent vector sizes: %d %ld",n,y->size);
    exit(0);
  }

  ptr1 = x->data;
  ptr2 = y->data;
  sum = 0;
  for (i=0; i<n; i++) {
    sum += (*ptr1) * (*ptr2);
    ptr1++;
    ptr2++;
  }
  return sum;
}

/*
**    printout
*/
void fmatprint(FILE *fp,gsl_matrix_float *A,const char *format)
{
  int i,j;
  for (i=0; i<A->size1; i++) {
    for (j=0; j<A->size2; j++) {
      fprintf(fp,format,fmget(A,i,j));
    }
    fprintf(fp,"\n");
  }
  fprintf(fp,"\n");

}

/*
**    B = A^T
*/
gsl_matrix_float *ftranspose(gsl_matrix_float *A,gsl_matrix_float *B)
{
  int i,j,n,m;

  n = A->size1;
  m = A->size2;

  if (B == NULL) {
    B = gsl_matrix_float_alloc(m,n);
  }
  else if (B->size1 != m || B->size2 != n) {
    gsl_matrix_float_free(B);
    B = gsl_matrix_float_alloc(m,n);
  }

  for (i=0; i<n; i++) {
    for (j=0; j<m; j++) {
      fmset(B,j,i,fmget(A,i,j));
    }
  }
  return B;
}

/*
**    B = A^-1 = A^+
*/
gsl_matrix_float *fmat_PseudoInv(gsl_matrix_float *A,gsl_matrix_float *B)
{
  int i,j,k,l,n,m;
  double u,x;
  double *dbl_pp;
  float *flt_pp;

  m = A->size1;
  n = A->size2;

  if (B == NULL) {
    B = gsl_matrix_float_alloc (n,m);
  }
  else if (B->size1 != n || B->size2 != m) {
    gsl_matrix_float_free(B);
    B = gsl_matrix_float_alloc (n, m);
  }

  gsl_matrix *U = gsl_matrix_alloc (m, n);
  gsl_matrix *V = gsl_matrix_alloc (n, n);
  gsl_matrix *X = gsl_matrix_alloc (n, n);
  gsl_vector *w = gsl_vector_alloc (n);
  gsl_vector *work = gsl_vector_alloc (n);

  /* singular value decomposition */
  flt_pp = A->data;
  dbl_pp = U->data;
  for (i=0; i<A->size1 * A->size2; i++)
    *dbl_pp++ = *flt_pp++;

  /* gsl_linalg_SV_decomp_jacobi(U,V,w); */
  gsl_linalg_SV_decomp_mod (U,X,V,w,work);

  /* check if singular */
  k=0;
  for (j=0; j<n; j++) {
    if (fabs(w->data[j]) > 1.0e-6) k++;
  }
  if (k < 2) VError(" Design matrix is singular");

  /* exception from Gaby */
  int j0 = 0;
  double xmin, xmax, tiny=10.0e-6;
  xmax = gsl_vector_get(w,0);
  xmin = tiny;
  for (j=n-1; j >= 0; j--) {
    u = gsl_vector_get(w,j);
    if (u > 0 && u/xmax > tiny) {
      j0 = j;
      goto skip;
    }
  }
 skip: ;
  if (j0 < n-1) {
    fprintf(stderr," Warning: Matrix almost singular\n");
    xmin = gsl_vector_get(w,j0) - tiny;
    if (xmin < 0) xmin = 0;
  }

  /* Fill the result matrix */
  gsl_matrix_float_set_zero(B);
  for (k=0; k<n; k++) {
    for (l=0; l<m; l++) {
      for (j=0; j<n; j++) {
	u = gsl_vector_get(w,j);
        if (fabs(u) > xmin) {
          x = gsl_matrix_float_get(B,k,l);
	  x += gsl_matrix_get(V,k,j)*gsl_matrix_get(U,l,j)/u;
          gsl_matrix_float_set(B,k,l,x);
        }
      }
    }
  }
  gsl_matrix_free(U);
  gsl_matrix_free(V);
  gsl_matrix_free(X);
  gsl_vector_free(w);
  gsl_vector_free(work);
  return B;
}

/*
** returns the trace of a matrix M
*/
float trace(gsl_matrix_float *M)
{
  gsl_vector_float_view diag = gsl_matrix_float_diagonal(M);
  float sum = 0;
  int i = 0;
  for(i = 0; i<diag.vector.size; i++) {
    sum += gsl_vector_float_get(&diag.vector,i);
  }
  return sum;
}

/*
**  rank(A)
*/
int rank(gsl_matrix_float* mat)
{
  int m = mat->size1;
  int n = mat->size2;
  int i;

  /* Create matrix buffer from source matrix. This prevents the overwriting of
   * matrix mat by gsl_linalg_SV_decomp().*/
  gsl_matrix* U = gsl_matrix_alloc(m,n);
  double* dpU =  U->data;
  float* fpMat = mat->data;
  for(i=0;i<mat->size1* mat->size2;i++) {
    *dpU++ = *fpMat++;
  }

  /* create additional matrix buffers */
  gsl_matrix *V;
  gsl_matrix *X;
  gsl_vector *S;
  gsl_vector *work;
  S = gsl_vector_alloc(n);
  V = gsl_matrix_alloc(n,n);
  X = gsl_matrix_alloc (n, n);
  work = gsl_vector_alloc (n);

  /* SVD */
  /* gsl_linalg_SV_decomp_jacobi(U,V,S); */
  gsl_linalg_SV_decomp_mod (U,X,V,S,work);

  int rank = 0;
  /* counting the nonzero singular values with a tolerance of EPSILON*/
  for(i=0;i<S->size;i++){
    if(S->data[i] > EPSILON) {
      rank++;
    }
  }

  gsl_matrix_free(U);
  gsl_matrix_free(V);
  gsl_matrix_free(X);
  gsl_vector_free(S);
  gsl_vector_free(work);

  return rank;
}

/*
**  fsum
*/
gsl_vector_float *fsum(gsl_matrix_float *matrix, int dim,gsl_vector_float *v)
{

  int row,col;
  float sum=0;

  /* build sum over all columns */
  if (dim == 1) {

    if (v == NULL) {
      v = gsl_vector_float_alloc(matrix->size2);
    }
    if(v->size != matrix->size2) {
      fprintf(stderr, "Warning in fsum: vector size doesn't match related matrix dimension. Resizing ..");
      gsl_vector_float_free(v);
      v = gsl_vector_float_alloc(matrix->size2);
    }

    for (col=0;col<matrix->size2;col++){
      sum=0;
      for(row=0;row<matrix->size1;row++) {
	sum+=matrix->data[col+row*matrix->size2];
      }
      v->data[col] = sum;
    }
  }

  /* build sum over all rows */
  else {

    if (v == NULL) {
      v = gsl_vector_float_alloc(matrix->size1);
    }

    if (v->size != matrix->size1) {
      fprintf(stderr, "Warning in fsum: vector size doesn't match related matrix dimension. Resizing ..");
      gsl_vector_float_free(v);
      v = gsl_vector_float_alloc(matrix->size1);
    }

    for (row = 0;row<matrix->size1;row++) {
      sum = 0;
      for(col=0;col<matrix->size2;col++) {
	sum += matrix->data[col+row*matrix->size2];
      }
      v->data[row] = sum;
    }
  }
  return v;
}

/*
**  funique
*/
gsl_vector_float *funique(gsl_vector_float* V)
{

  /* working copy */
  gsl_vector_float* v = gsl_vector_float_alloc(V->size);
  /* pointer to result */
  gsl_vector_float* res;
  /* holds value of last saved element */
  float max=0;
  /* counter */
  int i;

  gsl_vector_float_memcpy(v,V);

  /* sort elements from V. */
  gsl_sort_vector_float(v);

  /* count number of different elements */
  int nelements = 0;

  /* first run: count different values */
  float* p = v->data;
  for(i=0;i<v->size;i++) {
    /* the first element in the list is special */
    if(i==0) {
      max = *p;
      nelements++;
    }
    else {
      if(*p > max) {
	max = *p;
	nelements++;
      }
    }
    p++;
  }

  /* second run: allocate mem & copy every value exactly once. */
  res = gsl_vector_float_alloc(nelements);
  p = v->data;
  float *s = res->data;
  for(i=0;i<v->size;i++) {
    if(i==0) {
      max = *p;
      *s++ = *p;
    }
    else {
      if(*p > max) {
	max = *p;
	*s++ = *p;
      }
    }
    p++;
  }

  gsl_vector_float_free(v);

  return res;
}

/*
**  subcols
*/
gsl_matrix_float *fmat_subcols(gsl_matrix_float* mat,gsl_vector_float* cols)
{

  /* some tests */

  if((cols->size < 0) || (cols->size > mat->size2)) {
    fprintf(stderr,"column vector: invalid dimensions");
    exit(-1);
  }

  float min, max;
  gsl_vector_float_minmax(cols, &min, &max);

  if((min < 0) || (max > mat->size2)) {
    fprintf(stderr,"column vector values exceed matrix dimensions!");
    exit(-1);
  }

  /* TODO reduce column vector to unique values with funique. We will omit
   * this due to performance reasons. */

  /* the return value */
  gsl_matrix_float* ret = gsl_matrix_float_alloc(mat->size1, cols->size);
  /* the copy buffer */
  gsl_vector_float* buff = gsl_vector_float_alloc(mat->size1);
  /* counter */
  int i;

  /* copy columns from matrix to return buffer */
  for (i = 0; i < cols->size; ++i) {
    gsl_matrix_float_get_col(buff, mat, (int)cols->data[i]);
    gsl_matrix_float_set_col(ret, i, buff);
  }

  gsl_vector_float_free(buff);

  return ret;
}

/*
**  toeplitz
*/
gsl_matrix_float *fmat_toeplitz(gsl_vector_float* v, gsl_matrix_float* A)
{
  int i,j;

  if(A == NULL)
    A = gsl_matrix_float_alloc(v->size, v->size);
  else {
    if((A->size1 != v->size)  || (A->size2 != v->size)) {
      fprintf(stderr, "Warning fmat_toeplitz: incongruent matrix dimensions. Trying to\
                    correct it.");
      gsl_matrix_float_free(A);
      A = gsl_matrix_float_alloc(v->size, v->size);
    }
  }

  for(i=0;i<A->size1;i++){
    for(j=0;j<A->size2;j++) {
      gsl_matrix_float_set(A,i,j,gsl_vector_float_get(v, fabs(i-j)));
    }
  }

  return A;
}

/*
**  A^-1
*/
gsl_matrix_float *fInv(gsl_matrix_float *M, gsl_matrix_float *result)
{
  int s; /*permutation signum for LU-Decomposition*/
  int i;

  int m = M->size1;
  int n = M->size2;

  if(m != n) {
    fprintf(stderr, "dInv: not a square matrix\n");
    exit(0);
  }

  if(result == NULL) {
    result = gsl_matrix_float_alloc(m,m);
  }
  if((result->size1 != m) || (result->size2 != n)) {
    fprintf(stderr,"dInv: incongruent matrix dimensions.\n");
    exit(0);
  }

  gsl_matrix *ludecomp = gsl_matrix_alloc(m,m);
  gsl_permutation *perm = gsl_permutation_alloc(m);
  gsl_matrix *res = gsl_matrix_alloc(m,m);

  /* convert from float to double */
  double *d_ptr = ludecomp->data;
  float *f_ptr = M->data;
  for(i=0;i<M->size1*M->size2;i++) {
    *d_ptr = (double)*f_ptr;
    d_ptr++;f_ptr++;
  }

  /* LU decomposition */
  gsl_linalg_LU_decomp(ludecomp,perm,&s);

  /* inverting matrix */
  gsl_linalg_LU_invert(ludecomp,perm,res);

  /* convert from double to float */
  d_ptr = res->data;
  f_ptr = result->data;
  for(i=0;i<res->size1*res->size2;i++) {
    *f_ptr = (float)*d_ptr;
    d_ptr++;f_ptr++;
  }

  gsl_matrix_free(ludecomp);
  gsl_matrix_free(res);
  gsl_permutation_free(perm);
  return result;
}


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

#include <gsl/gsl_errno.h>
#include <gsl/gsl_odeiv2.h>
#include <gsl/gsl_spline.h>
#include <gsl/gsl_integration.h>
#include <gsl/gsl_roots.h>

#include "ccl.h"
#include "ccl_params.h"

/* --------- ROUTINE: h_over_h0 ---------
INPUT: scale factor, cosmology
TASK: Compute E(a)=H(a)/H0
*/
static double h_over_h0(double a, ccl_cosmology * cosmo, int *status)
{
  // Check if massive neutrinos are present - if not, we don't need to
  // compute their contribution
  double Om_mass_nu;
  if ((cosmo->params.N_nu_mass)>1e-12) {
    Om_mass_nu = ccl_Omeganuh2(
      a, cosmo->params.N_nu_mass, cosmo->params.mnu, cosmo->params.T_CMB,
      cosmo->data.accelerator, status) / (cosmo->params.h) / (cosmo->params.h);
    ccl_check_status(cosmo, status);
  }
  else {
    Om_mass_nu = 0;
  }

  /* Calculate h^2 using the formula (eqn 2 in the CCL paper):
    E(a)^2 = Omega_m a^-3 +
             Omega_l a^(-3*(1+w0+wa)) exp(3*wa*(a-1)) +
             Omega_k a^-2 +
             (Omega_g + Omega_n_rel) a^-4 +
             Om_mass_nu
  */
  return sqrt(
    (cosmo->params.Omega_m +
     cosmo->params.Omega_l *
       pow(a,-3*(cosmo->params.w0+cosmo->params.wa)) *
       exp(3*cosmo->params.wa*(a-1)) +
     cosmo->params.Omega_k * a +
     (cosmo->params.Omega_g + cosmo->params.Omega_n_rel) / a +
     Om_mass_nu * a*a*a) / (a*a*a));
}

/* --------- ROUTINE: ccl_omega_x ---------
INPUT: cosmology object, scale factor, species label
TASK: Compute the density relative to critical, Omega(a) for a given species.
Possible values for "label":
ccl_species_crit_label <- critical (physical)
ccl_species_m_label <- matter
ccl_species_l_label <- DE
ccl_species_g_label <- radiation
ccl_species_k_label <- curvature
ccl_species_ur_label <- massless neutrinos
ccl_species_nu_label <- massive neutrinos
*/
double ccl_omega_x(ccl_cosmology * cosmo, double a, ccl_species_x_label label, int *status)
{
  // If massive neutrinos are present, compute the phase-space integral and
  // get OmegaNuh2. If not, set OmegaNuh2 to zero.
  double OmNuh2;
  if ((cosmo->params.N_nu_mass) > 0.0001) {
    // Call the massive neutrino density function just once at this redshift.
    OmNuh2 = ccl_Omeganuh2(a, cosmo->params.N_nu_mass, cosmo->params.mnu,
		       cosmo->params.T_CMB, cosmo->data.accelerator, status);
    ccl_check_status(cosmo, status);
  }
  else {
    OmNuh2 = 0.;
  }

  double hnorm = h_over_h0(a, cosmo, status);

  switch(label) {
    case ccl_species_crit_label :
      return 1.;
    case ccl_species_m_label :
      return cosmo->params.Omega_m / (a*a*a) / hnorm / hnorm;
    case ccl_species_l_label :
      return
        cosmo->params.Omega_l *
        pow(a,-3 * (1 + cosmo->params.w0 + cosmo->params.wa)) *
        exp(3 * cosmo->params.wa * (a-1)) / hnorm / hnorm;
    case ccl_species_g_label :
      return cosmo->params.Omega_g / (a*a*a*a) / hnorm / hnorm;
    case ccl_species_k_label :
      return cosmo->params.Omega_k / (a*a) / hnorm / hnorm;
    case ccl_species_ur_label :
      return cosmo->params.Omega_n_rel / (a*a*a*a) / hnorm / hnorm;
    case ccl_species_nu_label :
      return OmNuh2 / (cosmo->params.h) / (cosmo->params.h) / hnorm / hnorm;
    default:
      *status = CCL_ERROR_PARAMETERS;
      ccl_cosmology_set_status_message(
        cosmo, "ccl_background.c: ccl_omega_x(): Species %d not supported\n", label);
      return NAN;
  }
}

/* --------- ROUTINE: ccl_rho_x ---------
INPUT: cosmology object, scale factor, species label
TASK: Compute rho_x(a), with x defined by species label.
Possible values for "label":
ccl_species_crit_label <- critical (physical)
ccl_species_m_label <- matter (physical)
ccl_species_l_label <- DE (physical)
ccl_species_g_label <- radiation (physical)
ccl_species_k_label <- curvature (physical)
ccl_species_ur_label <- massless neutrinos (physical)
ccl_species_nu_label <- massive neutrinos (physical)
*/
double ccl_rho_x(ccl_cosmology * cosmo, double a, ccl_species_x_label label, int is_comoving, int *status)
{
  double comfac;
  if (is_comoving) {
     comfac = a*a*a;
  } else {
      comfac = 1.0;
  }
  double hnorm = h_over_h0(a, cosmo, status);
  double rhocrit =
    RHO_CRITICAL *
    (cosmo->params.h) *
    (cosmo->params.h) * hnorm * hnorm * comfac;

  return rhocrit * ccl_omega_x(cosmo, a, label, status);
}

// Structure to hold parameters of chi_integrand
typedef struct {
  ccl_cosmology *cosmo;
  int * status;
} chipar;

/* --------- ROUTINE: chi_integrand ---------
INPUT: scale factor
TASK: compute the integrand of the comoving distance
*/
static double chi_integrand(double a, void * params_void)
{
  ccl_cosmology * cosmo = ((chipar *)params_void)->cosmo;
  int *status = ((chipar *)params_void)->status;

  return CLIGHT_HMPC/(a*a*h_over_h0(a, cosmo, status));
}

/* --------- ROUTINE: growth_ode_system ---------
INPUT: scale factor
TASK: Define the ODE system to be solved in order to compute the growth (of the density)
*/
static int growth_ode_system(double a,const double y[],double dydt[],void *params)
{
  int status = 0;
  ccl_cosmology * cosmo = params;

  double hnorm=h_over_h0(a,cosmo, &status);
  double om=ccl_omega_x(cosmo, a, ccl_species_m_label, &status);

  dydt[0]=y[1]/(a*a*a*hnorm);
  dydt[1]=1.5*hnorm*a*om*y[0];

  return status;
}

/* --------- ROUTINE: df_integrand ---------
INPUT: scale factor, spline object
TASK: Compute integrand from modified growth function
*/
static double df_integrand(double a,void * spline_void)
{
  if(a<=0)
    return 0;
  else {
    gsl_spline *df_a_spline=(gsl_spline *)spline_void;

    return gsl_spline_eval(df_a_spline,a,NULL)/a;
  }
}

/* --------- ROUTINE: growth_factor_and_growth_rate ---------
INPUT: scale factor, cosmology
TASK: compute the growth (D(z)) and the growth rate, logarithmic derivative (f?)
*/

static int  growth_factor_and_growth_rate(double a,double *gf,double *fg,ccl_cosmology *cosmo, int *stat)
{
  if(a<EPS_SCALEFAC_GROWTH) {
    *gf=a;
    *fg=1;
    return 0;
  }
  else {
    int gslstatus;
    double y[2];
    double ainit=EPS_SCALEFAC_GROWTH;
    gsl_odeiv2_system sys={growth_ode_system,NULL,2,cosmo};
    gsl_odeiv2_driver *d=
      gsl_odeiv2_driver_alloc_y_new(&sys,gsl_odeiv2_step_rkck,0.1*EPS_SCALEFAC_GROWTH,0,ccl_gsl->ODE_GROWTH_EPSREL);

    y[0]=EPS_SCALEFAC_GROWTH;
    y[1]=EPS_SCALEFAC_GROWTH*EPS_SCALEFAC_GROWTH*EPS_SCALEFAC_GROWTH*
      h_over_h0(EPS_SCALEFAC_GROWTH,cosmo, stat);

    gslstatus=gsl_odeiv2_driver_apply(d,&ainit,a,y);
    gsl_odeiv2_driver_free(d);

    if(gslstatus != GSL_SUCCESS) {
      ccl_raise_gsl_warning(gslstatus, "ccl_background.c: growth_factor_and_growth_rate():");
      return NAN;
    }

    *gf=y[0];
    *fg=y[1]/(a*a*h_over_h0(a,cosmo, stat)*y[0]);
    return 0;
  }
}

/* --------- ROUTINE: compute_chi ---------
INPUT: scale factor, cosmology
OUTPUT: chi -> radial comoving distance
TASK: compute radial comoving distance at a
*/
static void compute_chi(double a, ccl_cosmology *cosmo, double * chi, int * stat)
{
  int gslstatus;
  double result;
  chipar p;

  p.cosmo=cosmo;
  p.status=stat;

  gsl_integration_cquad_workspace * workspace = gsl_integration_cquad_workspace_alloc(ccl_gsl->N_ITERATION);
  gsl_function F;
  F.function = &chi_integrand;
  F.params = &p;
  //TODO: CQUAD is great, but slower than other methods. This could be sped up if it becomes an issue.
  gslstatus=gsl_integration_cquad(
    &F, a, 1.0, 0.0, ccl_gsl->INTEGRATION_DISTANCE_EPSREL, workspace, &result, NULL, NULL);
  *chi=result/cosmo->params.h;
  gsl_integration_cquad_workspace_free(workspace);

  if (gslstatus != GSL_SUCCESS) {
    ccl_raise_gsl_warning(gslstatus, "ccl_background.c: compute_chi():");
    *stat = CCL_ERROR_COMPUTECHI;
  }
}

//Root finding for a(chi)
typedef struct {
  double chi;
  ccl_cosmology *cosmo;
  int * status;
} Fpar;

static double fzero(double a,void *params)
{
  double chi,chia,a_use=a;

  chi=((Fpar *)params)->chi;
  compute_chi(a_use,((Fpar *)params)->cosmo,&chia, ((Fpar *)params)->status);

  return chi-chia;
}

static double dfzero(double a,void *params)
{
  ccl_cosmology *cosmo=((Fpar *)params)->cosmo;
  int *stat = ((Fpar *)params)->status;

  chipar p;
  p.cosmo=cosmo;
  p.status=stat;

  return chi_integrand(a,&p)/cosmo->params.h;
}

static void fdfzero(double a,void *params,double *f,double *df)
{
  *f=fzero(a,params);
  *df=dfzero(a,params);
}

/* --------- ROUTINE: a_of_chi ---------
INPUT: comoving distance chi, cosmology, stat, a_old, gsl_root_fdfsolver
OUTPUT: scale factor
TASK: compute the scale factor that corresponds to a given comoving distance chi
Note: This routine uses a root solver to find an a such that compute_chi(a) = chi.
The root solver uses the derivative of compute_chi (which is chi_integrand) and
the value itself.
*/
static void a_of_chi(double chi, ccl_cosmology *cosmo, int* stat, double *a_old, gsl_root_fdfsolver *s)
{
  if(chi==0) {
    *a_old=1;
  }
  else {
    Fpar p;
    gsl_function_fdf FDF;
    double a_previous,a_current=*a_old;

    p.cosmo=cosmo;
    p.chi=chi;
    p.status=stat;
    FDF.f=&fzero;
    FDF.df=&dfzero;
    FDF.fdf=&fdfzero;
    FDF.params=&p;
    gsl_root_fdfsolver_set(s,&FDF,a_current);

    int iter=0, gslstatus;
    do {
      iter++;
      gslstatus=gsl_root_fdfsolver_iterate(s);
      if(gslstatus!=GSL_SUCCESS) ccl_raise_gsl_warning(gslstatus, "ccl_background.c: a_of_chi():");
      a_previous=a_current;
      a_current=gsl_root_fdfsolver_root(s);
      gslstatus=gsl_root_test_delta(a_current, a_previous, 0, ccl_gsl->ROOT_EPSREL);
    } while(gslstatus==GSL_CONTINUE && iter <= ccl_gsl->ROOT_N_ITERATION);

    *a_old=a_current;

    // Allows us to pass a status to h_over_h0 for the neutrino integral calculation.
    if(gslstatus==GSL_SUCCESS) {
      *stat = *(p.status);
    }
    else {
      ccl_raise_gsl_warning(gslstatus, "ccl_background.c: a_of_chi():");
      *stat = CCL_ERROR_COMPUTECHI;
    }
  }
}

/* ----- ROUTINE: ccl_cosmology_compute_distances ------
INPUT: cosmology
TASK: if not already there, make a table of comoving distances and of E(a)
*/

void ccl_cosmology_compute_distances(ccl_cosmology * cosmo, int *status)
{

  //Do nothing if everything is computed already
  if(cosmo->computed_distances)
    return;

  if(ccl_splines->A_SPLINE_MAX>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    return;
  }

  // Create logarithmically and then linearly-spaced values of the scale factor
  int na = ccl_splines->A_SPLINE_NA+ccl_splines->A_SPLINE_NLOG-1;
  double * a = ccl_linlog_spacing(ccl_splines->A_SPLINE_MINLOG, ccl_splines->A_SPLINE_MIN,
				  ccl_splines->A_SPLINE_MAX, ccl_splines->A_SPLINE_NLOG,
				  ccl_splines->A_SPLINE_NA);
  // Allocate arrays for all three of E(a), chi(a), and a(chi)
  double *E_a = malloc(sizeof(double)*na);
  double *chi_a = malloc(sizeof(double)*na);
  // Allocate E(a) and chi(a) splines
  gsl_spline * E = gsl_spline_alloc(A_SPLINE_TYPE, na);
  gsl_spline * chi = gsl_spline_alloc(A_SPLINE_TYPE, na);
  // a(chi) spline allocated below

  //Check for too little memory
  if (a==NULL || E_a==NULL || chi_a==NULL){
    *status=CCL_ERROR_MEMORY;

    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): ran out of memory\n");
  }

  //Check for messed up scale factor conditions
  if (!*status){
    if ((fabs(a[0]-ccl_splines->A_SPLINE_MINLOG)>1e-5) ||
	(fabs(a[na-1]-ccl_splines->A_SPLINE_MAX)>1e-5) ||
	(a[na-1]>1.0)) {
      *status = CCL_ERROR_LINSPACE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): Error creating first logarithmic and then linear spacing in a\n");
    }
  }

  // Fill in E(a) - note, this step cannot change the status variable
  if (!*status)
    for (int i=0; i<na; i++)
      E_a[i] = h_over_h0(a[i], cosmo, status);

  // Create a E(a) spline
  if (!*status){
    if (gsl_spline_init(E, a, E_a, na)){
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): Error creating  E(a) spline\n");
    }
  }

  // Compute chi(a)
  if (!*status){
    for (int i=0; i<na; i++)
      compute_chi(a[i], cosmo, &chi_a[i], status);
    if (*status){
      *status = CCL_ERROR_INTEG;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): chi(a) integration error \n");
    }
  }

  // Initialize chi(a) spline
  if (!*status){
    if (gsl_spline_init(chi, a, chi_a, na)){//in Mpc
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): Error creating  chi(a) spline\n");
    }
  }

  if (*status){//If there was an error, free the GSL splines and return
    gsl_spline_free(E); //Note: you are allowed to call gsl_free() on NULL
    gsl_spline_free(chi);
  }

  // Set up the boundaries for the a(chi) spline
  double dchi, chi0, chif, a0, af;
  if(!*status){
    dchi=5.;
    chi0=chi_a[na-1];
    chif=chi_a[0];
    a0=a[na-1];
    af=a[0];
  }

  //TODO: The interval in chi (5. Mpc) should be made a macro
  free(a); //Free these, in preparation for making a(chi) splines
  free(E_a);
  free(chi_a);
  //Note: you are allowed to call free() on NULL

  ////////////////////////////////////////////////////////////////////////////////////////////////////
  //Below here na (length of some arrays) changes, so this function has to be split at this point.
  ////////////////////////////////////////////////////////////////////////////////////////////////////

  na = (int)((chif-chi0)/dchi);
  dchi  = (chif-chi0)/na; // <=5, since na is an integer
  //Allocate new arrays for a and chi(a)
  chi_a = ccl_linear_spacing(chi0, chif, na);
  a     = malloc(sizeof(double)*na);
  //Allocate space for GSL root finders
  const gsl_root_fdfsolver_type *T=gsl_root_fdfsolver_newton;
  gsl_root_fdfsolver *s=gsl_root_fdfsolver_alloc(T);
  gsl_spline *achi;

  //Check for too little memory
  if (!*status){
    achi=gsl_spline_alloc(A_SPLINE_TYPE, na);
    if (a==NULL || chi_a==NULL){
      *status=CCL_ERROR_MEMORY;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): ran out of memory\n");
    }else if(fabs(chi_a[0]-chi0)>1e-5 || fabs(chi_a[na-1]-chif)>1e-5) { //Check for messed up chi conditions
      *status = CCL_ERROR_LINSPACE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): Error creating linear spacing in chi\n");
    }
  }

  // Calculate a(chi)
  if (!*status){
    a[0]=a0; a[na-1]=af;
    for(int i=1;i<na-1;i++) {
      // we are using the previous value as a guess here to help the root finder
      // as long as we use small steps in a this should be fine
      a_of_chi(chi_a[i],cosmo, status, &a0, s);
      a[i]=a0;
    }
    if(*status) {
      *status = CCL_ERROR_ROOT;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): a(chi) root-finding error \n");
    }
  }

  // Initialize the a(chi) spline
  if (!*status){
    if(gsl_spline_init(achi, chi_a, a, na)){
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): Error creating  a(chi) spline\n");
    }
  }

  free(a);
  free(chi_a); //Note: you are allowed to call free() on NULL
  gsl_root_fdfsolver_free(s);
  if (*status){//If there was an error, free the GSL splines and return
    gsl_spline_free(E); //Note: you are allowed to call gsl_free() on NULL
    gsl_spline_free(chi);
    gsl_spline_free(achi);
    return;
  }

  //If there were no errors, attach the splines to the cosmo struct and end the function.
  if(cosmo->data.accelerator==NULL)
    cosmo->data.accelerator=gsl_interp_accel_alloc();
  cosmo->data.E             = E;
  cosmo->data.chi           = chi;
  cosmo->data.achi          = achi;
  cosmo->computed_distances = true;
}

/* ----- ROUTINE: ccl_cosmology_compute_growth ------
INPUT: cosmology
TASK: if not already there, make a table of growth function and growth rate
      normalize growth to input parameter growth0
*/

void ccl_cosmology_compute_growth(ccl_cosmology * cosmo, int * status)
{

  // This is not valid for massive neutrinos; if we have massive neutrinos, exit.
  if (cosmo->params.N_nu_mass>0){
	  *status = CCL_ERROR_NOT_IMPLEMENTED;
	  ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Support for the growth rate in cosmologies with massive neutrinos is not yet implemented.\n");
	  return;
  }

  if(cosmo->computed_growth)
    return;

  // Create logarithmically and then linearly-spaced values of the scale factor
  int  chistatus = 0, na = ccl_splines->A_SPLINE_NA+ccl_splines->A_SPLINE_NLOG-1;
  double * a = ccl_linlog_spacing(ccl_splines->A_SPLINE_MINLOG, ccl_splines->A_SPLINE_MIN, ccl_splines->A_SPLINE_MAX, ccl_splines->A_SPLINE_NLOG, ccl_splines->A_SPLINE_NA);
  if (a==NULL ||
      (fabs(a[0]-ccl_splines->A_SPLINE_MINLOG)>1e-5) ||
      (fabs(a[na-1]-ccl_splines->A_SPLINE_MAX)>1e-5) ||
      (a[na-1]>1.0)
      ) {
    free(a);
    *status = CCL_ERROR_LINSPACE;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error creating logarithmically and then linear spacing in a\n");
    return;
  }

  gsl_integration_cquad_workspace * workspace=NULL;
  gsl_function F;
  gsl_spline *df_a_spline=NULL;
  if(cosmo->params.has_mgrowth) {
    double *df_arr=malloc(na*sizeof(double));
    if(df_arr==NULL) {
      free(a);
      *status=CCL_ERROR_MEMORY;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): ran out of memory\n");
      return;
    }
    //Generate spline for Delta f(z) that we will then interpolate into an array of a
    gsl_spline *df_z_spline=gsl_spline_alloc(A_SPLINE_TYPE,cosmo->params.nz_mgrowth);
    chistatus=gsl_spline_init(df_z_spline,cosmo->params.z_mgrowth,cosmo->params.df_mgrowth,
			      cosmo->params.nz_mgrowth);

    if(chistatus) {
      free(a);
      free(df_arr);
      gsl_spline_free(df_z_spline);
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error creating Delta f(z) spline\n");
      return;
    }
    for (int i=0; i<na; i++) {
      if(a[i]>0) {
        double z=1./a[i]-1.;

        if(z<=cosmo->params.z_mgrowth[0])
          df_arr[i]=cosmo->params.df_mgrowth[0];
        else if(z>cosmo->params.z_mgrowth[cosmo->params.nz_mgrowth-1])
          df_arr[i]=cosmo->params.df_mgrowth[cosmo->params.nz_mgrowth-1];
        else
	       chistatus |= gsl_spline_eval_e(df_z_spline,z,NULL,&df_arr[i]);
      } else {
	     df_arr[i]=0;
      }
    }
    if(chistatus) {
      free(a);
      free(df_arr);
      gsl_spline_free(df_z_spline);
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error evaluating Delta f(z) spline\n");
      return;
    }
    gsl_spline_free(df_z_spline);

    //Generate Delta(f) spline
    df_a_spline=gsl_spline_alloc(A_SPLINE_TYPE,na);
    chistatus=gsl_spline_init(df_a_spline,a,df_arr,na);
    free(df_arr);
    if (chistatus) {
      free(a);
      gsl_spline_free(df_a_spline);
      *status = CCL_ERROR_SPLINE;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error creating Delta f(a) spline\n");
      return;
    }

    workspace=gsl_integration_cquad_workspace_alloc(ccl_gsl->N_ITERATION);
    F.function=&df_integrand;
    F.params=df_a_spline;
  }

  // allocate space for y, which will be all three
  // of E(a), chi(a), D(a) and f(a) in turn.
  int  status_mg=0, gslstatus;
  double growth0,fgrowth0;
  double *y = malloc(sizeof(double)*na);
  if(y==NULL) {
    free(a);
    *status=CCL_ERROR_MEMORY;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): ran out of memory\n");
    return;
  }
  double *y2 = malloc(sizeof(double)*na);
  if(y2==NULL) {
    free(a);
    free(y);
    *status=CCL_ERROR_MEMORY;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_distances(): ran out of memory\n");
    return;
  }

  chistatus|=growth_factor_and_growth_rate(1.,&growth0,&fgrowth0,cosmo, status);
  for(int i=0; i<na; i++) {
    chistatus|=growth_factor_and_growth_rate(a[i],&(y[i]),&(y2[i]),cosmo, status);
    if(cosmo->params.has_mgrowth) {
      if(a[i]>0) {
	double df,integ;
	//Add modification to f
	gslstatus = gsl_spline_eval_e(df_a_spline,a[i],NULL,&df);
  if(gslstatus != GSL_SUCCESS) {
    ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_cosmology_compute_growth():");
    status_mg |= gslstatus;
  }
	y2[i]+=df;
	//Multiply D by exp(-int(df))
	gslstatus = gsl_integration_cquad(&F,a[i],1.0,0.0,ccl_gsl->INTEGRATION_DISTANCE_EPSREL,workspace,&integ,NULL,NULL);
	if(gslstatus != GSL_SUCCESS) {
    ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_cosmology_compute_growth():");
    status_mg |= gslstatus;
  }
  y[i]*=exp(-integ);
      }
    }
    y[i]/=growth0;
  }
  if(chistatus || status_mg || *status) {
    free(a);
    free(y);
    free(y2);
    if(df_a_spline!=NULL)
      gsl_spline_free(df_a_spline);
    if(workspace!=NULL)
      gsl_integration_cquad_workspace_free(workspace);
    if (chistatus) {
      *status = CCL_ERROR_INTEG;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): integral for linear growth factor didn't converge\n");
    }
    if(status_mg) {
      *status = CCL_ERROR_INTEG;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): integral for MG growth factor didn't converge\n");
    }
    return;
  }

  if(cosmo->params.has_mgrowth) {
    gsl_spline_free(df_a_spline);
    gsl_integration_cquad_workspace_free(workspace);
  }

  gsl_spline * growth = gsl_spline_alloc(A_SPLINE_TYPE, na);
  chistatus = gsl_spline_init(growth, a, y, na);
  if(chistatus) {
    free(a);
    free(y);
    free(y2);
    gsl_spline_free(growth);
    *status = CCL_ERROR_SPLINE;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error creating D(a) spline\n");
    return;
  }

  gsl_spline * fgrowth = gsl_spline_alloc(A_SPLINE_TYPE, na);
  chistatus = gsl_spline_init(fgrowth, a, y2, na);
  if(chistatus) {
    free(a);
    free(y);
    free(y2);
    gsl_spline_free(growth);
    gsl_spline_free(fgrowth);
    *status = CCL_ERROR_SPLINE;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_cosmology_compute_growth(): Error creating f(a) spline\n");
    return;
  }

  // Initialize the accelerator which speeds the splines and
  // assign all the splines we've just made to the structure.
  if(cosmo->data.accelerator==NULL)
    cosmo->data.accelerator=gsl_interp_accel_alloc();
  cosmo->data.growth = growth;
  cosmo->data.fgrowth = fgrowth;
  cosmo->data.growth0 = growth0;
  cosmo->computed_growth = true;

  free(a);
  free(y);
  free(y2);

  return;
}

//Expansion rate normalized to 1 today

double ccl_h_over_h0(ccl_cosmology * cosmo, double a, int* status)
{

  if(!cosmo->computed_distances) {
    ccl_cosmology_compute_distances(cosmo,status);
    ccl_check_status(cosmo, status);
  }

  double h_over_h0;
  int gslstatus = gsl_spline_eval_e(cosmo->data.E, a, cosmo->data.accelerator,&h_over_h0);
  if(gslstatus != GSL_SUCCESS) {
    ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_h_over_h0():");
    *status = gslstatus;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_h_over_h0(): Scale factor outside interpolation range.\n");
    return NAN;
  }

  return h_over_h0;
}

void ccl_h_over_h0s(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_h_over_h0(cosmo, a[i], &_status);
    *status |= _status;
  }
}

// Distance-like function examples, all in Mpc
double ccl_comoving_radial_distance(ccl_cosmology * cosmo, double a, int * status)
{
  if((a > (1.0 - 1.e-8)) && (a<=1.0)) {
    return 0.;
  }
  else if(a>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  }
  else {
    if(!cosmo->computed_distances) {
      ccl_cosmology_compute_distances(cosmo, status);
      ccl_check_status(cosmo,status);
    }

    double crd;
    int gslstatus = gsl_spline_eval_e(cosmo->data.chi, a, cosmo->data.accelerator, &crd);
    if(gslstatus != GSL_SUCCESS) {
      ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_comoving_radial_distance():");
      *status = gslstatus;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_comoving_radial_distance(): Scale factor outside interpolation range.\n");
      return NAN;
    }
    return crd;
  }
}

void ccl_comoving_radial_distances(ccl_cosmology * cosmo, int na, double a[], double output[], int* status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_comoving_radial_distance(cosmo, a[i], &_status);
    *status |= _status;
  }
}

double ccl_sinn(ccl_cosmology *cosmo, double chi, int *status)
{
  //////
  //         { sin(x)  , if k==1
  // sinn(x)={  x      , if k==0
  //         { sinh(x) , if k==-1
  switch(cosmo->params.k_sign) {
  case -1:
    return sinh(cosmo->params.sqrtk * chi) / cosmo->params.sqrtk;
  case 1:
    return sin(cosmo->params.sqrtk*chi) / cosmo->params.sqrtk;
  case 0:
    return chi;
  default:
    *status = CCL_ERROR_PARAMETERS;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_sinn: ill-defined cosmo->params.k_sign = %d",
	    cosmo->params.k_sign);
    return NAN;
  }
}

double ccl_comoving_angular_distance(ccl_cosmology * cosmo, double a, int* status)
{
  if((a > (1.0 - 1.e-8)) && (a<=1.0)) {
    return 0.;
  }
  else if(a>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  }
  else {
    if (!cosmo->computed_distances) {
      ccl_cosmology_compute_distances(cosmo, status);
      ccl_check_status(cosmo, status);
    }

    double chi;
    int gslstatus = gsl_spline_eval_e(cosmo->data.chi, a,
                                      cosmo->data.accelerator,&chi);
    if(gslstatus != GSL_SUCCESS) {
      ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_comoving_angular_distance():");
      *status |= gslstatus;
      ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_comoving_angular_distance(): Scale factor outside interpolation range.\n");
      return NAN;
    }
    return ccl_sinn(cosmo,chi,status);
  }
}

void ccl_comoving_angular_distances(ccl_cosmology * cosmo, int na, double a[],
                                    double output[], int* status)
{
  int _status;

  for (int i=0; i < na; i++) {
    _status = 0;
    output[i] = ccl_comoving_angular_distance(cosmo, a[i], &_status);
    *status |= _status;
  }
}

double ccl_luminosity_distance(ccl_cosmology * cosmo, double a, int* status)
{
  return ccl_comoving_angular_distance(cosmo, a, status) / a;
}

void ccl_luminosity_distances(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_luminosity_distance(cosmo, a[i], &_status);
    *status |= _status;
  }
}

double ccl_distance_modulus(ccl_cosmology * cosmo, double a, int* status)
{
  if((a > (1.0 - 1.e-8)) && (a<=1.0)) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: distance_modulus undefined for a=1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  } else if(a>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  } else {
    if (!cosmo->computed_distances) {
      ccl_cosmology_compute_distances(cosmo, status);
      ccl_check_status(cosmo, status);
    }
    /* distance modulus = 5 * log10(d) - 5
       Since d in CCL is in Mpc, you get
         5*log10(10^6) - 5 = 30 - 5 = 25
      for the constant.
    */
    return 5 * log10(ccl_luminosity_distance(cosmo, a, status)) + 25;
  }
}

void ccl_distance_moduli(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_distance_modulus(cosmo, a[i], &_status);
    *status |= _status;
  }
}

//Scale factor for a given distance
double ccl_scale_factor_of_chi(ccl_cosmology * cosmo, double chi, int * status)
{
  if((chi < 1.e-8) && (chi>=0.)) {
    return 1.;
  }
  else if(chi<0.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: distance cannot be smaller than 0.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  }
  else {
    if (!cosmo->computed_distances) {
      ccl_cosmology_compute_distances(cosmo,status);
      ccl_check_status(cosmo,status);
    }
    double a;
    int gslstatus = gsl_spline_eval_e(cosmo->data.achi, chi,cosmo->data.accelerator_achi, &a);
    if(gslstatus != GSL_SUCCESS) {
      ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_scale_factor_of_chi():");
      *status |= gslstatus;
    }
    return a;
  }
}

//
void ccl_scale_factor_of_chis(ccl_cosmology * cosmo, int nchi, double chi[], double output[], int * status)
{
  int _status;

  for (int i=0; i<nchi; i++) {
    _status = 0;
    output[i] = ccl_scale_factor_of_chi(cosmo, chi[i], &_status);
    *status |= _status;
  }
}

double ccl_growth_factor(ccl_cosmology * cosmo, double a, int * status)
{
  if(a==1.){
    return 1.;
  }
  else if(a>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  }
  else {
    if (!cosmo->computed_growth) {
      ccl_cosmology_compute_growth(cosmo, status);
      ccl_check_status(cosmo, status);
    }
    if (*status!= CCL_ERROR_NOT_IMPLEMENTED) {
      double D;
      int gslstatus = gsl_spline_eval_e(cosmo->data.growth, a, cosmo->data.accelerator,&D);
      if(gslstatus != GSL_SUCCESS) {
        ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_growth_factor():");
        *status |= gslstatus;
        ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_growth_factor(): Scale factor outside interpolation range.\n");
        return NAN;
      }
      return D;
    }
    else {
      return NAN;
    }
  }
}

void ccl_growth_factors(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_growth_factor(cosmo, a[i], &_status);
    *status |= _status;
  }
}

double ccl_growth_factor_unnorm(ccl_cosmology * cosmo, double a, int * status)
{

  if (!cosmo->computed_growth) {
    ccl_cosmology_compute_growth(cosmo, status);
    ccl_check_status(cosmo, status);
  }

  if (*status != CCL_ERROR_NOT_IMPLEMENTED) {
      return cosmo->data.growth0 * ccl_growth_factor(cosmo, a, status);
  } else {
    return NAN;
  }
}

void ccl_growth_factors_unnorm(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_growth_factor_unnorm(cosmo, a[i], &_status);
    *status |= _status;
  }
}

double ccl_growth_rate(ccl_cosmology * cosmo, double a, int * status)
{
  if(a>1.) {
    *status = CCL_ERROR_COMPUTECHI;
    ccl_cosmology_set_status_message(cosmo, "ccl_background.c: scale factor cannot be larger than 1.\n");
    ccl_check_status(cosmo,status);
    return NAN;
  } else {
    if (!cosmo->computed_growth) {
      ccl_cosmology_compute_growth(cosmo, status);
      ccl_check_status(cosmo, status);
    }
    if(*status != CCL_ERROR_NOT_IMPLEMENTED) {
      double g;
      int gslstatus = gsl_spline_eval_e(cosmo->data.fgrowth, a, cosmo->data.accelerator,&g);
      if(gslstatus != GSL_SUCCESS) {
        ccl_raise_gsl_warning(gslstatus, "ccl_background.c: ccl_growth_rate():");
        *status |= gslstatus;
        ccl_cosmology_set_status_message(cosmo, "ccl_background.c: ccl_growth_rate(): Scale factor outside interpolation range.\n");
        return NAN;
      }
      return g;
    } else {
	    return NAN;
	  }
  }
}

void ccl_growth_rates(ccl_cosmology * cosmo, int na, double a[], double output[], int * status)
{
  int _status;

  for (int i=0; i<na; i++) {
    _status = 0;
    output[i] = ccl_growth_rate(cosmo, a[i], &_status);
    *status |= _status;
  }
}


/*
This files contains some generic utilities
 */

/* ----- System includes -----*/
#include <stdlib.h>
#include <stdio.h>
#include <math.h>

/* ----- IFU and GSL includes -----*/
#include <gsl/gsl_statistics.h>
#include <gsl/gsl_sort.h>
#include "IFU_io.h"
// #include "IFU_math.h"
/* ----- Specific IFU includes ----- */
#include "data_io.h"
#ifdef FITS
#include <fitsio.h>
#endif

/* Removing MIDAS by hand - not really clean, but should allow to compile with an IFU with --disable-midas enabled*/
#undef MIDAS

#ifdef MIDAS
#include "midas_defs.h"
#include "tbldef.h"
#include "fctext.h"
#include "ldbext.h"
#include "proto_st.h"

#endif
extern IO_Format InputIO, OutputIO;

/* ----- local includes ----- */
#include "utils.h"

/* ----- static functions ---------------------------------------- */
static int ascending(const void *a, const void*b) {
  if (*(double*)a==*(double*)b) return 0;
  return (*(double*)a > *(double*)b ) ? 1 : -1;
}

/* ----- ut_median ---------------------------------------- */
void ut_sort_ascending(double* values, int n)
     /* median of unsorted values */
{
  qsort(values,n,sizeof(double),&ascending);
}

/* ----- ut_median ---------------------------------------- */
double ut_median(double* values, int n)
     /* median of unsorted values */
{
  qsort(values,n,sizeof(double),&ascending);
  /* alternatively, I could have used  gsl_stats_median_from_sorted_data
     but it is fucking the flies ! */
  /* i saw also something usable in mathlib : the names might conflict !*/
  if (n%2)
    return values[n/2];
  else
    return (values[n/2-1]+values[n/2])/2;

}

/* ----- ut_min ---------------------------------------- */
double ut_min(double* values, int n)
     /* min of array */
{
  double min = values[0];
  int i;

  for (i=1;i<n;i++) {
    if (values[i]<min)
      min=values[i];
  }
  return min;
}

/* ----------------------------- ut_trunc_sigma_known -------------- */
void ut_trunc_sigma_known(double** values, int * nitems, double sigma, double sigcut){
     /* trunc the data set, removing any value outside +/- sigcut sigma
       if sigcut<0, does noting .
       it works iteratively by removing too far away values. => slow if
       the sigcut is too low !

       values : pointer to array of values - modified
       nitems : number of values -> modified
       sigcut : if <0, does nothing

       Beware : the number of remaining items might be 0 !

     */
  int ok=0;

  if (sigcut<0)
    return;

  qsort(*values,*nitems,sizeof(double),ascending);

  while (!ok && *nitems>1) {

    double mean=ut_mean(*values,*nitems);
    double valinf = (mean-(*values)[0])/sigma;
    double valsup = ((*values)[*nitems-1]-mean)/sigma;
    if (valsup>sigcut && valsup>=valinf) {
      double bound = MAX(sigcut,valinf);
      /* remove more than one for efficiency */
      while(valsup>=bound && *nitems>1) {
        (*nitems)--;
        valsup = ((*values)[*nitems-1]-mean)/sigma;
      }
    } else if (valinf>sigcut && valinf>=valsup) {
      double bound = MAX(sigcut,valinf);
      while(valinf>=bound && *nitems>1 ){
        (*nitems)--;
        (*values)++;
        valinf = (mean-(*values)[0])/sigma;
      }
    } else {
      ok=1;
    }
  }
}

/* ------------------------------- ut_trunc_sigma_unknown ------------------ */
void ut_trunc_sigma_unknown(double** values, int * nitems, double sigcut){
     /* trunc the data set, removing any value outside +/- sigcut sigma
       if sigcut<0, does noting .
       it works iteratively by removing too far away values. => slow if
       the sigcut is too low !
       Beware : sigma is computed from the distribution itself.
       Points far away will push the sigma towards greater values.

       values : pointer to array of values - modified
       nitems : number of values -> modified
       sigcut : if <0, does nothing

       Beware : the number of remaining items might be 0 !

     */
  int ok=0;

  if (sigcut<0)
    return;

  qsort(*values,*nitems,sizeof(double),ascending);

  while (!ok && *nitems>1) {
    double mean,sigma,valinf,valsup;

    mean = ut_mean((*values),*nitems);
    sigma = gsl_stats_sd_m(*values,1,*nitems,mean);
    valinf = (mean-(*values)[0])/sigma;
    valsup = ((*values)[*nitems-1]-mean)/sigma;
    if (valsup>sigcut && valsup>=valinf) {
      (*nitems)--;
    } else if (valinf>sigcut && valinf>=valsup) {
      (*nitems)--;
      (*values)++;
    } else {
      ok=1;
    }
  }
}

/* ------------------------------- ut_trunc_sigma_unknown ------------------ */
void ut_trunc_sigma_unknown_fast_sorted(double** values, int * nitems, double sigcut){
     /* trunc the data set, removing any value outside +/- sigcut sigma
       if sigcut<0, does noting .
       it works grossly, removing each time all what is outside the window,
       which is not accurate

       Beware : sigma is computed from the distribution itself.
       Points far away will push the sigma towards greater values.

       values : pointer to array of values - modified
       nitems : number of values -> modified
       sigcut : if <0, does nothing

       Beware : the number of remaining items might be 0 !

     */
  int ok=0;

  if (sigcut<0)
    return;

  /*  qsort(*values,*nitems,sizeof(double),ascending); */

  while (!ok && *nitems>1) {

    double mean,sigma,valinf,valsup;
    int nitems_old = *nitems;

    mean = ut_mean((*values),*nitems);
    sigma = gsl_stats_sd_m(*values,1,*nitems,mean);
    valinf = mean-sigma*sigcut;
    valsup = mean + sigma*sigcut;
    while ((*values)[0] < valinf && *nitems>1) {
      (*nitems)--;
      (*values)++;
    }
    while ((*values)[*nitems-1] > valsup && *nitems>1) {
      (*nitems)--;
    }
    if (nitems_old == (*nitems))
      ok=1;
  }
}

/*-------------------- ut_fraction_sigcut ----------------------*/
double ut_fraction_sigcut(double fraction) {
  /* given a distribution with fraction outliers, at infinite
   distance with respect to normal values,
  returns the standard deviation of the outliers, when the
  RMS is computed with it included.*/

  /* the computation is performed with fraction values at 1 and
   1-fraction at 0 */
  double sigcut,rms;
  /* mean = fraction */
  rms = sqrt(fraction*fraction*(1-fraction) + (1-fraction)*(1-fraction)*fraction);

  sigcut = (1-fraction)/rms;
  return sigcut;
}

/*-------------------- ut_mean ----------------------*/
double ut_mean(double* val,int n){

  int i;
  double sum = 0;
  for (i=0;i<n;i++)
    sum += val[i];
  return sum/n;
}

/*-------------------- ut_mean ----------------------*/
double ut_mode(double* val,int n){
  /* This function returns the highest probability density a set of
  datas. This only works reliabely if there is only 1 maximum,
  and in the limit where the data is sufficiently sampled.
  No error computation is performed ...*/
  /* The search is dyadic and iterative, each step looking for the part
  where the median is the narrower. The time is O(NlnN) (+ the time to run
  indexx)*/
  /* This is a fast and inaccurate algorithm. For a general algorithm, see the
  Parzenwindow method - the drawback is that it depends on a window size
  a priori*/

  size_t * index;
  double med;
  int nmin=0;
  int nmax=n; /*  out of the table */

  index = malloc(n*sizeof(size_t));

  /* test */

  gsl_sort_index(index,val,1,n);

  do {

    /* median computation */
    if ((nmax-nmin) % 2 == 0)
      med = (val[index[ (nmin + nmax )/2 ]] + val[index[ (nmin+nmax)/2 -1 ]])/2;
    else
      med = val[index[ (nmin + nmax)/2 ]];

    /* The density is higher for the upper part */
    if ( fabs(med - val[index[nmin]])  > fabs (med - val[index[nmax-1]]) )
      nmin =(nmin + nmax - 1 )/2;
    else if ( fabs(med - val[index[nmin]])  < fabs (med - val[index[nmax-1]]) )
      /* rounding in the good direction  in order to include the median place */
      nmax =  ( nmin + nmax)/2 + 1;
    else /* stop in case of equality */
      nmax = nmin;
  } while (nmax-nmin > 2);

  return med;
}

/*-------------------- ut_mean ----------------------*/
double ut_mode2(double* val,int n){
  /* This function returns the highest probability density a set of
  datas. This only works reliabely if there is only 1 maximum,
  and in the limit where the data is sufficiently sampled.
  No error computation is performed ...*/
  /* The search is dyadic and iterative, each step looking for the part
  which contains most of the data with respect to the highest value.
  The time is O(NlnN) (+ the time to run indexx)*/
  /* This is a fast and inaccurate algorithm. For a general algorithm, see the
  Parzenwindow method - the drawback is that it depends on a window size
  a priori*/

  size_t * index;
  double half;
  int nmin=0;
  int nmax=n; /*  out of the table */

  index = malloc(n*sizeof(size_t));

  /* test */

  gsl_sort_index(index,val,1,n);

  do {
    int i;
    /* half window computation */
    half=(val[index[nmin]]+val[index[nmax-1]])/2;
    for (i=nmin;i<nmax;i++) {
      if (val[index[i]]>half)
        break;
    }
    if (i==nmax)
      return half;
    else if (i<nmin+(nmax-nmin)/2)
      nmin=i;
    else if (i>nmin+(nmax-nmin)/2 || ((nmax-nmin)%2) )
      nmax=i;
    else {
      nmin++;
      nmax--;
    }
  } while (nmax-nmin>2);
  return half;
}

/*-------------------- ut_autocovariance ----------------------*/
void ut_autocovariance(double* data, double* autocorr, int n) {
/* data is of dim n, autocorr of dim n */
  int decal,i;
  double mean;
  /*  double var; */
  double *mdata = malloc(sizeof(double)*n);

  /* compute the mean */
  mean = ut_mean(data,n);

  /* substract it (n computations) */
  for (i=0;i<n;i++)
    mdata[i] = data[i]-mean;

  /* compute variance and what is needed for decal=0*/
  decal=0;
  autocorr[0]=0;
  for (i=0;i<n;i++) {
    autocorr[0]+=mdata[i]*mdata[i];
  }
  autocorr[0] /= n;
  /* var = autocorr[0]; */
  /* autocorr[0] = 1.0; */

  /* n^2 part */
  for (decal=1; decal<n; decal ++) {
    autocorr[decal]=0;
    for (i=0;i<n-decal;i++) {
      autocorr[decal]+=mdata[i]*mdata[i+decal];
    }
    autocorr[decal] /= (n-decal);
    /*    autocorr[decal] /= var; */
  }
  free(mdata);

}

/*-------------------- ut_varname_from_imname ----------------------*/
void ut_varname_from_imname(char* imname,char* varname){
  /* returns the name of the variance image from the name of
   the image */

  /* check standard name */
  char extname[lg_name+1];
  extname[0]='\0';
  varname[0]='\0';
  if (strstr(imname,"[chip00]"))
    strcpy(extname,"[var00]");
  if (strstr(imname,"[chip01]"))
    strcpy(extname,"[var01]");
  if (strstr(imname,"[chip02]"))
    strcpy(extname,"[var02]");
  if (strstr(imname,"[chip03]"))
    strcpy(extname,"[var03]");
  if (strstr(imname,"[image]"))
    strcpy(extname,"[variance]");

  if (extname[0]) {
    /* builds the variance name */
    char *ptName;
    strcpy(varname,imname);
    ptName = strchr(varname,'[');
    strcpy(ptName,extname);
  }
}

/*-------------------- ut_open_check_name ----------------------*/
char* ut_open_check_name(char* name){
  /* if name is a name without extension, tries to see if a
     [image] exists */

  if (!strchr(name,'[')) {
    char new_name[lg_name+1];
    sprintf(new_name,"%s[image]",name);
    if (exist(new_name))
      strcpy(name,new_name);
  }
  return name;
}

/*-------------------- ut_open_check_name ----------------------*/
char* ut_create_check_name(char* name){
  /* if name is a name without extension, appends an [image]
     by default */

  if (!strchr(name,'[')) {
    char new_name[lg_name+1];
    sprintf(new_name,"%s[image]",name);
    strcpy(name,new_name);
  }
  return name;
}

/*-------------------- ut_varname_from_imname ----------------------*/
int ut_is_bichip_detcom(char* filename){
  /* returns 1 if the name corresponds to a detcom image */

  char testName[lg_name+1];
  if (strstr(filename,"%d"))
    return 1;
  if (strrchr(filename,'['))
    return 0;
  // .fits file extension default
  if (strstr(filename,".fits"))
    sprintf(testName,"%s[chip00]",filename);
  else
    sprintf(testName,"%s.fits[chip00]",filename);
  if (exist(testName))
    return 1;
  else {
    if (strstr(filename,".fits"))
      sprintf(testName,"%s[CHIP00]",filename);
    else
      sprintf(testName,"%s.fits[CHIP00]",filename);
    if (exist(testName))
      return 1;
    else
      return 0;
  }
}

/*-------------------- ut_build_tmp_name ----------------------*/
void ut_build_tmp_name(char* filename, char* tmp_prefix){
  /* builds a temporary memory file name from the image name and a
  prefix */
  char imname[lg_name+1], *pt_name;

  if (!(pt_name = strrchr(filename,'/')))
    pt_name = filename;
  else
    pt_name = pt_name+1;
  sprintf(imname,"mem://%s_%s",tmp_prefix,pt_name);
  //  sprintf(imname,"%s_%s",tmp_prefix,pt_name);
  strcpy(filename,imname);
}

/*-------------------- ut_primary_header_name ----------------------*/
void ut_primary_header_name(char* full_name, char* primary_name){
  /* the primary header is the image name without any extension*/

  char* pt_name;
  strcpy(primary_name,full_name);

  if ((pt_name = strchr(primary_name,'[')))
    pt_name[0]='\0';

}

/* ===== IFU lib disagreement ======================================== */

/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!.func                        open_frame_fast()
!
!.purp          opens a 2D frame and updates the image structure items
!.desc
! open_frame(frame,name,mode)
!
! IMAGE2D *frame;       image structure
! char *name;           frame name
! char *mode;           open mode (Input,Ouput,IO)
!.ed
-------------------------------------------------------------------- */
int
open_frame_fast(IMAGE2D *frame, char *name, char *mode)
{
  char errtext[132], filename[lg_name+1];
  int status, nbaxes, iomode, int_datatype;
  float cuts[4];
  int info[5];
#ifdef IRAF
  int two_dim=2;
  int len;
#endif
#ifdef FITS
  fitsfile *fptr;
  int nbread;
  int npix;
  int group = 0;
  double pixref;
#endif

  memset(frame->ident,' ',lg_ident);
  frame->ident[lg_ident] = '\0';
  memset(frame->cunit,' ',lg_unit);
  frame->cunit[lg_unit] = '\0';
  memset(frame->history,' ',lg_hist);
  frame->history[lg_hist] = '\0';
  frame->external_info = NULL;
  frame->file_type = T_IMA2D;
  frame->data_format = InputIO.basic_io;

  strcpy(filename,name);
  first_blk(filename);
  strcpy(frame->name,filename);
  append_ima_extension(frame->name,InputIO.basic_io);

  strcpy(filename,frame->name);

  if (!exist(filename)) { /* check if fil exists */
    status = ERR_OPEN;
    sprintf(errtext,"open_frame: frame %s",filename);
    Handle_Error(errtext,status);
    return(status);
  }

  switch(mode[0]) {
  case 'I' :
    if (mode[1] == 'O')
      frame->iomode = (int)IO_MODE;
    else
      frame->iomode = (int)I_MODE;
    break;
  case 'O' : frame->iomode = (int)O_MODE;
    break;
  default  : frame->iomode = (int)I_MODE;
    break;
  }

  iomode = get_iomode_code(InputIO.basic_io,frame->iomode);

  switch (InputIO.basic_io) {

#ifdef MIDAS
  case MIDAS_FORMAT :
    status = SCFINF(filename,2,info);
    if (status == 0) {
      status = SCIGET(filename, info[1], iomode, F_IMA_TYPE, 2,
                      &nbaxes, &(frame->nx), &(frame->startx), &(frame->stepx),
                      frame->ident, frame->cunit, (char **)(&(frame->data)),
                      &(frame->imno));
      frame->data_type = info[1];
      frame->data_type = decode_datatype(InputIO.basic_io,frame->data_type);

      if (nbaxes!=2) /* We open a spectrum like an image, and that's not good */
        status = ERR_OPEN;

    }
    break;
#endif
#ifdef IRAF
  case IRAF_FORMAT :
  case STSDAS_FORMAT :
    len = strlen(filename);
    uimopn(filename,&iomode,&(frame->imno),&status,len);
    if (status != 0)
      break;
    uimgid(&(frame->imno),&int_datatype,&two_dim,&(frame->nx),&status);
    frame->data_type = decode_datatype(InputIO.basic_io,(short)(int_datatype));
    if (status != 0)
      break;
    alloc_frame_mem(frame, datatype);
    switch(frame->data_type) {
    case SHORT :
      uigs2s(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.s_data,&status);
      break;
    case INT :
    case LONG :
      uigs2l(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.l_data,&status);
      break;
    case FLOAT :
      uigs2r(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.f_data,&status);
      break;
    case DOUBLE :
      uigs2d(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.d_data,&status);
      break;
    }
    disable_user_warnings();
    RD_desc(frame,"IDENT",CHAR,lg_ident,frame->ident);
    restore_user_warnings();
    break;
#endif
#ifdef FITS
  case FITS_A_FORMAT :
  case FITS_B_FORMAT :
    status =0;
    if (fits_open_file(&fptr,filename,iomode,&status)) {
      status = ERR_ACCESS; break;
    }
    frame->external_info = (void *)fptr;
    if (fits_read_key(fptr, TINT,"NAXIS", &nbaxes,NULL, &status)) {
      status = ERR_READ; break;
    }
    if (nbaxes != 2) {
      status = ERR_IMA_HEAD; break;
    }
    if (fits_read_key(fptr, TINT, "NAXIS1",
                      &(frame->nx), NULL, &status)) {
      status = ERR_READ; break;
    }
    if (fits_read_key(fptr, TINT, "NAXIS2",
                      &(frame->ny), NULL, &status)) {
      status = ERR_READ; break;
    }
    if (status == 0) {
      pixref = 1.0;
      fits_read_key(fptr, TDOUBLE, "CRPIX1", &pixref, NULL, &status);
      if (status) { status = 0; pixref = 1; }
      fits_read_key(fptr, TDOUBLE, "CRVAL1", &(frame->startx), NULL, &status);
      if (status) { status = 0; frame->startx = (double)1; }
      fits_read_key(fptr, TDOUBLE, "CDELT1", &(frame->stepx), NULL, &status);
      if (status) { status = 0; frame->stepx = (double)1; }
      frame->startx -= (pixref-1)*frame->stepx;
      pixref = 1.0;
      fits_read_key(fptr, TDOUBLE, "CRPIX2", &pixref, NULL, &status);
      if (status) { status = 0; pixref = 1; }
      fits_read_key(fptr, TDOUBLE, "CRVAL2", &(frame->starty), NULL, &status);
      if (status) { status = 0; frame->starty = (double)1; }
      fits_read_key(fptr, TDOUBLE, "CDELT2", &(frame->stepy), NULL, &status);
      if (status) { status = 0; frame->stepy = (double)1; }
      frame->starty -= (pixref-1)*frame->stepy;
    }
    else
      break;

    int_datatype = (fptr->Fptr->tableptr)->tdatatype;
    frame->data_type = decode_datatype(InputIO.basic_io,(short)int_datatype);
    if (frame->data_type == SHORT) {
      if (fptr->Fptr->tableptr[1].tscale == 1 && fptr->Fptr->tableptr[1].tzero == 32768)
        /* unsigned short !!! */
        frame->data_type = LONG;
    }

    if (alloc_frame_mem(frame, frame->data_type) < 0) {
      fits_close_file(fptr,&status);
      status = ERR_ALLOC;
      break;
    }

    npix = frame->nx*frame->ny;
    switch (frame->data_type) {
    case SHORT :
      if (fits_read_img_sht(fptr,group,1L,npix,(short)0,
                            frame->data.s_data,&nbread,&status)) {
        status = ERR_READ; break;
      }
      break;
    case LONG :
    case INT :
      if (fits_read_img_lng(fptr,group,1L,npix,(int)0,
                            frame->data.l_data,&nbread,&status)) {
        status = ERR_READ; break;
      }
      break;
    case FLOAT :
      if (fits_read_img_flt(fptr,group,1L,npix,(float)0,
                            frame->data.f_data,&nbread,&status)) {
        status = ERR_READ; break;
      }
      break;
    case DOUBLE :
      if (fits_read_img_dbl(fptr,group,1L,npix,(double)0,
                            frame->data.d_data,&nbread,&status)) {
        status = ERR_READ; break;
      }
      break;
    }
    break;
#endif
  }

  if (status) {
    sprintf(errtext,"open_frame: frame %s",filename);
    status = get_tiger_errcode(frame->data_format,status);
    Handle_Error(errtext,status);
  }
  else {
    disable_user_warnings();
    status = RD_desc(frame,"LHCUTS",FLOAT,4,cuts);
    RD_desc(frame,"HISTORY",CHAR,lg_hist,frame->history);
    restore_user_warnings();

    frame->endx = frame->startx + (frame->nx -1)*frame->stepx;
    frame->endy = frame->starty + (frame->ny -1)*frame->stepy;
    if (status <= 0) {
      /* image_minmax is a really slow routine, and most of the time useless */
      frame->min = -ut_big_value;
      frame->max = +ut_big_value;
      /*			image_minmax(frame); */
    }
    else {
      frame->min = cuts[2];
      frame->max = cuts[3];
    }
    status = 0;
    /* parse wcs if contained in file */
    status = parse_wcs(frame);
  }
  return(status);
}

/*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!.func                       close_frame_fast()
!
!.purp             closes a currently active 2D frame
!.desc
! close_frame(frame)
!
! IMAGE2D *frame;       image structure
!.ed
-------------------------------------------------------------------- */
int
close_frame_fast(IMAGE2D *frame)			/* close active frame */
{
  char  errtext[132], filename[lg_name+1];
  int   stat, int_datatype;
  float cuts[4];
#ifdef IRAF
  int one=1;
#endif
#ifdef FITS
  fitsfile *fptr;
  int npix;
#endif

  strcpy(filename,frame->name);

  if (frame->iomode == (int)I_MODE) {
    switch (frame->data_format) {
#ifdef MIDAS
    case MIDAS_FORMAT :
      stat = SCFCLO(frame->imno);
      break;
#endif
#ifdef IRAF
    case IRAF_FORMAT :
    case STSDAS_FORMAT :
      uimclo(&(frame->imno),&stat);
      break;
#endif
#ifdef FITS
    case FITS_A_FORMAT :
    case FITS_B_FORMAT :
      stat =0;
      fptr = (fitsfile *)frame->external_info;
      fits_close_file(fptr,&stat);
      free_frame_mem(frame);
      frame->external_info = NULL;
      break;
#endif
    }
    if (stat) {
      sprintf(errtext,"close_frame: frame %s",filename);
      stat = get_tiger_errcode(frame->data_format,stat);
      Handle_Error(errtext,stat);
    }
    return(stat);
  }

  /*
  if (frame->data.d_data != NULL) {
    image_minmax(frame);

    cuts[0]=(float)frame->min; cuts[2]=(float)frame->min;
    cuts[1]=(float)frame->max; cuts[3]=(float)frame->max;
    stat = WR_desc(frame,"LHCUTS",FLOAT,4,cuts);
  }
  */

  WR_history(frame, (Anyfile *)0);

  switch (frame->data_format) {
#ifdef MIDAS
  case MIDAS_FORMAT :
    stat = SCFCLO(frame->imno);
    break;
#endif
#ifdef IRAF
  case IRAF_FORMAT :
  case STSDAS_FORMAT :
    switch(frame->data_type) {
    case SHORT :
      uips2s(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.s_data,&stat);
      break;
    case INT :
    case LONG :
      uips2l(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.l_data,&stat);
      break;
    case FLOAT :
      uips2r(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.f_data,&stat);
      break;
    case DOUBLE :
      uips2d(&(frame->imno),&one,&(frame->nx),&one,&(frame->ny),
             frame->data.d_data,&stat);
      break;
    }
    if (stat == 0)
      uimclo(&(frame->imno),&stat);
    free_frame_mem(frame);
    break;
#endif
#ifdef FITS
  case FITS_A_FORMAT :
  case FITS_B_FORMAT :
    stat = 0;
    fptr = (fitsfile *)frame->external_info;
    if (frame->iomode != (int)I_MODE) {
      if (frame->data.d_data != NULL) {
        int_datatype = get_datatype_code(OutputIO.basic_io,frame->data_type);
        npix = frame->nx*frame->ny;
        if (fits_write_img(fptr,int_datatype,1L,npix,
                           frame->data.s_data,&stat)) {
          stat = ERR_WRIT;
        }
      }
    }
    if (! stat) {
      fits_close_file(fptr,&stat);
      stat = wcs_free(frame);
    }
    free_frame_mem(frame);
    frame->external_info = NULL;
    break;
#endif
  }
  if (stat) {
    sprintf(errtext,"close_frame: frame %s",filename);
    stat = get_tiger_errcode(frame->data_format,stat);
    Handle_Error(errtext,stat);
  } else {
    if (TK && (frame->iomode == O_MODE || frame->iomode == IO_MODE))
      {
        printf("@ N {%s}\n",filename);
      }
  }

  return(stat);
}

/* ----- juldat --------------------------------------------------------- */
/*C
C       FUNCTION JULDAT RETURNS THE JULIAN DATE AS A DOUBLE
C       PRECISION NUMBER.
C       ALGORITHM FROM "ALAMANAC FOR COMPUTERS" p.B2
C*/
double juldat( int year, int month, int day, double ut)
     /* year, month, day, ut are the UTC ones
      ut is the fractional hour */
{
        double tmp;
        tmp = 367.0*year + 0.5 + ut/24.0;
        tmp = tmp - ((7*(year+((month+9)/12)))/4) + ((275*month)/9) + day + 1721013;
        return tmp;
}

/* =====  string utilities ===== */

int ut_parse_line(char* line, char** tokens) {
  /* the token strings will contain the line elements separated by spaces */
  /* the original line will be modified (some '/0' char added)*/
  char* pt_line = line;
  int itoken=0;

  while (pt_line && pt_line[0]!='\0') {
    tokens[itoken++] = pt_line;
    pt_line = strchr(pt_line,' ');
    if (pt_line)
      while((pt_line)[0]==' ') {
        pt_line[0]='\0';
        pt_line++;
      }
  }
  return itoken;
}


#include <stdio.h>
#include <stdlib.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_matrix.h>
#include <gsl/gsl_odeiv2.h>

typedef struct {
    double l, g;
} Params;

int func (double t, const double y[], double f[], void *params) {
    Params *p = (Params *) params;
    double l = p->l;
    double g = p->g;
    f[0] = y[1];
    f[1] = -(g/l)*y[0];
    return GSL_SUCCESS;
}

int jac (double t, const double y[], double *dfdy, double dfdt[],
         void *params) {
    Params *p = (Params *) params;
    double l = p->l;
    double g = p->g;
    gsl_matrix_view dfdy_mat = gsl_matrix_view_array (dfdy, 2, 2);
    gsl_matrix * m = &(dfdy_mat.matrix);
    gsl_matrix_set (m, 0, 0, 0.0);
    gsl_matrix_set (m, 0, 1, 1.0);
    gsl_matrix_set (m, 1, 0, -(g/l));
    gsl_matrix_set (m, 1, 1, 0.0);
    dfdt[0] = 0.0;
    dfdt[1] = 0.0;
    return GSL_SUCCESS;
}

int main (void) {
    Params params;
    params.l = 1.0;
    params.g = 9.81;
    gsl_odeiv2_system sys = {func, jac, 2, &params};

    gsl_odeiv2_driver * d = gsl_odeiv2_driver_alloc_y_new (
            &sys, gsl_odeiv2_step_rk8pd, 1e-6, 1e-6, 0.0
    );
    int i;
    double t = 0.0, t1 = 100.0;
    double y[2] = { 0.1, 0.0 };

    for (i = 1; i <= 1000; i++) {
        double ti = i*t1/1000.0;
        int status = gsl_odeiv2_driver_apply (d, &t, ti, y);

        if (status != GSL_SUCCESS) {
            fprintf(stderr, "error, return value=%d\n", status);
            break;
        }

        printf ("%.5le %.5le %.5le\n", t, y[0], y[1]);
    }

    gsl_odeiv2_driver_free (d);
    return EXIT_SUCCESS;
}