/* specfunc/hyperg_1F1.c
 *
 * 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 2 of the License, or (at
 * your option) any later version.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/* Author:  G. Jungman */

#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include "gsl_sf_elementary.h"
#include "gsl_sf_exp.h"
#include "gsl_sf_bessel.h"
#include "gsl_sf_gamma.h"
#include "gsl_sf_laguerre.h"
#include "gsl_sf_hyperg.h"

#include "error.h"
#include "hyperg.h"

#define _1F1_INT_THRESHOLD (100.0*GSL_DBL_EPSILON)

/* Asymptotic result for 1F1(a, b, x)  x -> -Infinity.
 * Assumes b-a != neg integer and b != neg integer.
 */
static
int
hyperg_1F1_asymp_negx(const double a, const double b, const double x,
                     gsl_sf_result * result)
{
  gsl_sf_result lg_b;
  gsl_sf_result lg_bma;
  double sgn_b;
  double sgn_bma;

  int stat_b   = gsl_sf_lngamma_sgn_e(b,   &lg_b,   &sgn_b);
  int stat_bma = gsl_sf_lngamma_sgn_e(b-a, &lg_bma, &sgn_bma);

  if(stat_b == GSL_SUCCESS && stat_bma == GSL_SUCCESS) {
    gsl_sf_result F;
    int stat_F = gsl_sf_hyperg_2F0_series_e(a, 1.0+a-b, -1.0/x, -1, &F);
    if(F.val != 0) {
      double ln_term_val = a*log(-x);
      double ln_term_err = 2.0 * GSL_DBL_EPSILON * (fabs(a) + fabs(ln_term_val));
      double ln_pre_val = lg_b.val - lg_bma.val - ln_term_val;
      double ln_pre_err = lg_b.err + lg_bma.err + ln_term_err;
      int stat_e = gsl_sf_exp_mult_err_e(ln_pre_val, ln_pre_err,
                                            sgn_bma*sgn_b*F.val, F.err,
                                            result);
      return GSL_ERROR_SELECT_2(stat_e, stat_F);
    }
    else {
      result->val = 0.0;
      result->err = 0.0;
      return stat_F;
    }
  }
  else {
    DOMAIN_ERROR(result);
  }
}

/* Asymptotic result for 1F1(a, b, x)  x -> +Infinity
 * Assumes b != neg integer and a != neg integer
 */
static
int
hyperg_1F1_asymp_posx(const double a, const double b, const double x,
                      gsl_sf_result * result)
{
  gsl_sf_result lg_b;
  gsl_sf_result lg_a;
  double sgn_b;
  double sgn_a;

  int stat_b = gsl_sf_lngamma_sgn_e(b, &lg_b, &sgn_b);
  int stat_a = gsl_sf_lngamma_sgn_e(a, &lg_a, &sgn_a);

  if(stat_a == GSL_SUCCESS && stat_b == GSL_SUCCESS) {
    gsl_sf_result F;
    int stat_F = gsl_sf_hyperg_2F0_series_e(b-a, 1.0-a, 1.0/x, -1, &F);
    if(stat_F == GSL_SUCCESS && F.val != 0) {
      double lnx = log(x);
      double ln_term_val = (a-b)*lnx;
      double ln_term_err = 2.0 * GSL_DBL_EPSILON * (fabs(a) + fabs(b)) * fabs(lnx)
                         + 2.0 * GSL_DBL_EPSILON * fabs(a-b);
      double ln_pre_val = lg_b.val - lg_a.val + ln_term_val + x;
      double ln_pre_err = lg_b.err + lg_a.err + ln_term_err + 2.0 * GSL_DBL_EPSILON * fabs(x);
      int stat_e = gsl_sf_exp_mult_err_e(ln_pre_val, ln_pre_err,
                                            sgn_a*sgn_b*F.val, F.err,
                                            result);
      return GSL_ERROR_SELECT_2(stat_e, stat_F);
    }
    else {
      result->val = 0.0;
      result->err = 0.0;
      return stat_F;
    }
  }
  else {
    DOMAIN_ERROR(result);
  }
}

/* Asymptotic result for x < 2b-4a, 2b-4a large.
 * [Abramowitz+Stegun, 13.5.21]
 *
 * assumes 0 <= x/(2b-4a) <= 1
 */
static
int
hyperg_1F1_large2bm4a(const double a, const double b, const double x, gsl_sf_result * result)
{
  double eta    = 2.0*b - 4.0*a;
  double cos2th = x/eta;
  double sin2th = 1.0 - cos2th;
  double th = acos(sqrt(cos2th));
  double pre_h  = 0.25*M_PI*M_PI*eta*eta*cos2th*sin2th;
  gsl_sf_result lg_b;
  int stat_lg = gsl_sf_lngamma_e(b, &lg_b);
  double t1 = 0.5*(1.0-b)*log(0.25*x*eta);
  double t2 = 0.25*log(pre_h);
  double lnpre_val = lg_b.val + 0.5*x + t1 - t2;
  double lnpre_err = lg_b.err + 2.0 * GSL_DBL_EPSILON * (fabs(0.5*x) + fabs(t1) + fabs(t2));
  double s1 = sin(a*M_PI);
  double s2 = sin(0.25*eta*(2.0*th - sin(2.0*th)) + 0.25*M_PI);
  double ser_val = s1 + s2;
  double ser_err = 2.0 * GSL_DBL_EPSILON * (fabs(s1) + fabs(s2));
  int stat_e = gsl_sf_exp_mult_err_e(lnpre_val, lnpre_err,
                                        ser_val, ser_err,
                                        result);
  return GSL_ERROR_SELECT_2(stat_e, stat_lg);
}

/* Luke's rational approximation.
 * See [Luke, Algorithms for the Computation of Mathematical Functions, p.182]
 *
 * Like the case of the 2F1 rational approximations, these are
 * probably guaranteed to converge for x < 0, barring gross
 * numerical instability in the pre-asymptotic regime.
 */
static
int
hyperg_1F1_luke(const double a, const double c, const double xin,
                gsl_sf_result * result)
{
  const double RECUR_BIG = 1.0e+50;
  const int nmax = 5000;
  int n = 3;
  const double x  = -xin;
  const double x3 = x*x*x;
  const double t0 = a/c;
  const double t1 = (a+1.0)/(2.0*c);
  const double t2 = (a+2.0)/(2.0*(c+1.0));
  double F = 1.0;
  double prec;

  double Bnm3 = 1.0;                                  /* B0 */
  double Bnm2 = 1.0 + t1 * x;                         /* B1 */
  double Bnm1 = 1.0 + t2 * x * (1.0 + t1/3.0 * x);    /* B2 */

  double Anm3 = 1.0;                                                      /* A0 */
  double Anm2 = Bnm2 - t0 * x;                                            /* A1 */
  double Anm1 = Bnm1 - t0*(1.0 + t2*x)*x + t0 * t1 * (c/(c+1.0)) * x*x;   /* A2 */

  while(1) {
    double npam1 = n + a - 1;
    double npcm1 = n + c - 1;
    double npam2 = n + a - 2;
    double npcm2 = n + c - 2;
    double tnm1  = 2*n - 1;
    double tnm3  = 2*n - 3;
    double tnm5  = 2*n - 5;
    double F1 =  (n-a-2) / (2*tnm3*npcm1);
    double F2 =  (n+a)*npam1 / (4*tnm1*tnm3*npcm2*npcm1);
    double F3 = -npam2*npam1*(n-a-2) / (8*tnm3*tnm3*tnm5*(n+c-3)*npcm2*npcm1);
    double E  = -npam1*(n-c-1) / (2*tnm3*npcm2*npcm1);

    double An = (1.0+F1*x)*Anm1 + (E + F2*x)*x*Anm2 + F3*x3*Anm3;
    double Bn = (1.0+F1*x)*Bnm1 + (E + F2*x)*x*Bnm2 + F3*x3*Bnm3;
    double r = An/Bn;

    prec = fabs((F - r)/F);
    F = r;

    if(prec < GSL_DBL_EPSILON || n > nmax) break;

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {
      An   /= RECUR_BIG;
      Bn   /= RECUR_BIG;
      Anm1 /= RECUR_BIG;
      Bnm1 /= RECUR_BIG;
      Anm2 /= RECUR_BIG;
      Bnm2 /= RECUR_BIG;
      Anm3 /= RECUR_BIG;
      Bnm3 /= RECUR_BIG;
    }
    else if(fabs(An) < 1.0/RECUR_BIG || fabs(Bn) < 1.0/RECUR_BIG) {
      An   *= RECUR_BIG;
      Bn   *= RECUR_BIG;
      Anm1 *= RECUR_BIG;
      Bnm1 *= RECUR_BIG;
      Anm2 *= RECUR_BIG;
      Bnm2 *= RECUR_BIG;
      Anm3 *= RECUR_BIG;
      Bnm3 *= RECUR_BIG;
    }

    n++;
    Bnm3 = Bnm2;
    Bnm2 = Bnm1;
    Bnm1 = Bn;
    Anm3 = Anm2;
    Anm2 = Anm1;
    Anm1 = An;
  }

  result->val  = F;
  result->err  = 2.0 * fabs(F * prec);
  result->err += 2.0 * GSL_DBL_EPSILON * (n-1.0) * fabs(F);

  return GSL_SUCCESS;
}

/* Series for 1F1(1,b,x)
 * b > 0
 */
static
int
hyperg_1F1_1_series(const double b, const double x, gsl_sf_result * result)
{
  double sum_val = 1.0;
  double sum_err = 0.0;
  double term = 1.0;
  double n    = 1.0;
  while(fabs(term/sum_val) > 2.0*GSL_DBL_EPSILON) {
    term *= x/(b+n-1);
    sum_val += term;
    sum_err += 2.0 * 4.0 * GSL_DBL_EPSILON * fabs(term);
    n += 1.0;
  }
  result->val  = sum_val;
  result->err  = sum_err;
  result->err += 2.0 * fabs(term);
  return GSL_SUCCESS;
}

/* 1F1(1,b,x)
 * b >= 1, b integer
 */
static
int
hyperg_1F1_1_int(const int b, const double x, gsl_sf_result * result)
{
  if(b < 1) {
    DOMAIN_ERROR(result);
  }
  else if(b == 1) {
    return gsl_sf_exp_e(x, result);
  }
  else if(b == 2) {
    return gsl_sf_exprel_e(x, result);
  }
  else if(b == 3) {
    return gsl_sf_exprel_2_e(x, result);
  }
  else {
    return gsl_sf_exprel_n_e(b-1, x, result);
  }
}

/* 1F1(1,b,x)
 * b >=1, b real
 *
 * checked OK: [GJ] Thu Oct  1 16:46:35 MDT 1998
 */
static
int
hyperg_1F1_1(const double b, const double x, gsl_sf_result * result)
{
  double ax = fabs(x);
  double ib = floor(b + 0.1);

  if(b < 1.0) {
    DOMAIN_ERROR(result);
  }
  else if(b == 1.0) {
    return gsl_sf_exp_e(x, result);
  }
  else if(b >= 1.4*ax) {
    return hyperg_1F1_1_series(b, x, result);
  }
  else if(fabs(b - ib) < _1F1_INT_THRESHOLD && ib < INT_MAX) {
    return hyperg_1F1_1_int((int)ib, x, result);
  }
  else if(x > 0.0) {
    if(x > 100.0 && b < 0.75*x) {
      return hyperg_1F1_asymp_posx(1.0, b, x, result);
    }
    else if(b < 1.0e+05) {
      /* Recurse backward on b, from a
       * chosen offset point. For x > 0,
       * which holds here, this should
       * be a stable direction.
       */
      const double off = ceil(1.4*x-b) + 1.0;
      double bp = b + off;
      gsl_sf_result M;
      int stat_s = hyperg_1F1_1_series(bp, x, &M);
      const double err_rat = M.err / fabs(M.val);
      while(bp > b+0.1) {
        /* M(1,b-1) = x/(b-1) M(1,b) + 1 */
        bp -= 1.0;
        M.val  = 1.0 + x/bp * M.val;
      }
      result->val  = M.val;
      result->err  = err_rat * fabs(M.val);
      result->err += 2.0 * GSL_DBL_EPSILON * (fabs(off)+1.0) * fabs(M.val);
      return stat_s;
    }
    else {
      return hyperg_1F1_large2bm4a(1.0, b, x, result);
    }
  }
  else {
    /* x <= 0 and b not large compared to |x|
     */
    if(ax < 10.0 && b < 10.0) {
      return hyperg_1F1_1_series(b, x, result);
    }
    else if(ax >= 100.0 && GSL_MAX_DBL(fabs(2.0-b),1.0) < 0.99*ax) {
      return hyperg_1F1_asymp_negx(1.0, b, x, result);
    }
    else {
      return hyperg_1F1_luke(1.0, b, x, result);
    }
  }
}

/* 1F1(a,b,x)/Gamma(b) for b->0
 * [limit of Abramowitz+Stegun 13.3.7]
 */
static
int
hyperg_1F1_renorm_b0(const double a, const double x, gsl_sf_result * result)
{
  double eta = a*x;
  if(eta > 0.0) {
    double root_eta = sqrt(eta);
    gsl_sf_result I1_scaled;
    int stat_I = gsl_sf_bessel_I1_scaled_e(2.0*root_eta, &I1_scaled);
    if(I1_scaled.val <= 0.0) {
      result->val = 0.0;
      result->err = 0.0;
      return GSL_ERROR_SELECT_2(stat_I, GSL_EDOM);
    }
    else {
      const double lnr_val = 0.5*x + 0.5*log(eta) + fabs(x) + log(I1_scaled.val);
      const double lnr_err = GSL_DBL_EPSILON * (1.5*fabs(x) + 1.0) + fabs(I1_scaled.err/I1_scaled.val);
      return gsl_sf_exp_err_e(lnr_val, lnr_err, result);
    }
  }
  else if(eta == 0.0) {
    result->val = 0.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else {
    /* eta < 0 */
    double root_eta = sqrt(-eta);
    gsl_sf_result J1;
    int stat_J = gsl_sf_bessel_J1_e(2.0*root_eta, &J1);
    if(J1.val <= 0.0) {
      result->val = 0.0;
      result->err = 0.0;
      return GSL_ERROR_SELECT_2(stat_J, GSL_EDOM);
    }
    else {
      const double t1 = 0.5*x;
      const double t2 = 0.5*log(-eta);
      const double t3 = fabs(x);
      const double t4 = log(J1.val);
      const double lnr_val = t1 + t2 + t3 + t4;
      const double lnr_err = GSL_DBL_EPSILON * (1.5*fabs(x) + 1.0) + fabs(J1.err/J1.val);
      gsl_sf_result ex;
      int stat_e = gsl_sf_exp_err_e(lnr_val, lnr_err, &ex);
      result->val = -ex.val;
      result->err =  ex.err;
      return stat_e;
    }
  }

}

/* 1F1'(a,b,x)/1F1(a,b,x)
 * Uses Gautschi's version of the CF.
 * [Gautschi, Math. Comp. 31, 994 (1977)]
 *
 * Supposedly this suffers from the "anomalous convergence"
 * problem when b < x. I have seen anomalous convergence
 * in several of the continued fractions associated with
 * 1F1(a,b,x). This particular CF formulation seems stable
 * for b > x. However, it does display a painful artifact
 * of the anomalous convergence; the convergence plateaus
 * unless b >>> x. For example, even for b=1000, x=1, this
 * method locks onto a ratio which is only good to about
 * 4 digits. Apparently the rest of the digits are hiding
 * way out on the plateau, but finite-precision lossage
 * means you will never get them.
 */
#if 0
static
int
hyperg_1F1_CF1_p(const double a, const double b, const double x, double * result)
{
  const double RECUR_BIG = GSL_SQRT_DBL_MAX;
  const int maxiter = 5000;
  int n = 1;
  double Anm2 = 1.0;
  double Bnm2 = 0.0;
  double Anm1 = 0.0;
  double Bnm1 = 1.0;
  double a1 = 1.0;
  double b1 = 1.0;
  double An = b1*Anm1 + a1*Anm2;
  double Bn = b1*Bnm1 + a1*Bnm2;
  double an, bn;
  double fn = An/Bn;

  while(n < maxiter) {
    double old_fn;
    double del;
    n++;
    Anm2 = Anm1;
    Bnm2 = Bnm1;
    Anm1 = An;
    Bnm1 = Bn;
    an = (a+n)*x/((b-x+n-1)*(b-x+n));
    bn = 1.0;
    An = bn*Anm1 + an*Anm2;
    Bn = bn*Bnm1 + an*Bnm2;

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {
      An /= RECUR_BIG;
      Bn /= RECUR_BIG;
      Anm1 /= RECUR_BIG;
      Bnm1 /= RECUR_BIG;
      Anm2 /= RECUR_BIG;
      Bnm2 /= RECUR_BIG;
    }

    old_fn = fn;
    fn = An/Bn;
    del = old_fn/fn;

    if(fabs(del - 1.0) < 10.0*GSL_DBL_EPSILON) break;
  }

  *result = a/(b-x) * fn;

  if(n == maxiter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_SUCCESS;
}
#endif /* 0 */

/* 1F1'(a,b,x)/1F1(a,b,x)
 * Uses Gautschi's series transformation of the
 * continued fraction. This is apparently the best
 * method for getting this ratio in the stable region.
 * The convergence is monotone and supergeometric
 * when b > x.
 * Assumes a >= -1.
 */
static
int
hyperg_1F1_CF1_p_ser(const double a, const double b, const double x, double * result)
{
  if(a == 0.0) {
    *result = 0.0;
    return GSL_SUCCESS;
  }
  else {
    const int maxiter = 5000;
    double sum  = 1.0;
    double pk   = 1.0;
    double rhok = 0.0;
    int k;
    for(k=1; k<maxiter; k++) {
      double ak = (a + k)*x/((b-x+k-1.0)*(b-x+k));
      rhok = -ak*(1.0 + rhok)/(1.0 + ak*(1.0+rhok));
      pk  *= rhok;
      sum += pk;
      if(fabs(pk/sum) < 2.0*GSL_DBL_EPSILON) break;
    }
    *result = a/(b-x) * sum;
    if(k == maxiter)
      GSL_ERROR ("error", GSL_EMAXITER);
    else
      return GSL_SUCCESS;
  }
}

/* 1F1(a+1,b,x)/1F1(a,b,x)
 *
 * I think this suffers from typical "anomalous convergence".
 * I could not find a region where it was truly useful.
 */
#if 0
static
int
hyperg_1F1_CF1(const double a, const double b, const double x, double * result)
{
  const double RECUR_BIG = GSL_SQRT_DBL_MAX;
  const int maxiter = 5000;
  int n = 1;
  double Anm2 = 1.0;
  double Bnm2 = 0.0;
  double Anm1 = 0.0;
  double Bnm1 = 1.0;
  double a1 = b - a - 1.0;
  double b1 = b - x - 2.0*(a+1.0);
  double An = b1*Anm1 + a1*Anm2;
  double Bn = b1*Bnm1 + a1*Bnm2;
  double an, bn;
  double fn = An/Bn;

  while(n < maxiter) {
    double old_fn;
    double del;
    n++;
    Anm2 = Anm1;
    Bnm2 = Bnm1;
    Anm1 = An;
    Bnm1 = Bn;
    an = (a + n - 1.0) * (b - a - n);
    bn = b - x - 2.0*(a+n);
    An = bn*Anm1 + an*Anm2;
    Bn = bn*Bnm1 + an*Bnm2;

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {
      An /= RECUR_BIG;
      Bn /= RECUR_BIG;
      Anm1 /= RECUR_BIG;
      Bnm1 /= RECUR_BIG;
      Anm2 /= RECUR_BIG;
      Bnm2 /= RECUR_BIG;
    }

    old_fn = fn;
    fn = An/Bn;
    del = old_fn/fn;

    if(fabs(del - 1.0) < 10.0*GSL_DBL_EPSILON) break;
  }

  *result = fn;
  if(n == maxiter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_SUCCESS;
}
#endif /* 0 */

/* 1F1(a,b+1,x)/1F1(a,b,x)
 *
 * This seemed to suffer from "anomalous convergence".
 * However, I have no theory for this recurrence.
 */
#if 0
static
int
hyperg_1F1_CF1_b(const double a, const double b, const double x, double * result)
{
  const double RECUR_BIG = GSL_SQRT_DBL_MAX;
  const int maxiter = 5000;
  int n = 1;
  double Anm2 = 1.0;
  double Bnm2 = 0.0;
  double Anm1 = 0.0;
  double Bnm1 = 1.0;
  double a1 = b + 1.0;
  double b1 = (b + 1.0) * (b - x);
  double An = b1*Anm1 + a1*Anm2;
  double Bn = b1*Bnm1 + a1*Bnm2;
  double an, bn;
  double fn = An/Bn;

  while(n < maxiter) {
    double old_fn;
    double del;
    n++;
    Anm2 = Anm1;
    Bnm2 = Bnm1;
    Anm1 = An;
    Bnm1 = Bn;
    an = (b + n) * (b + n - 1.0 - a) * x;
    bn = (b + n) * (b + n - 1.0 - x);
    An = bn*Anm1 + an*Anm2;
    Bn = bn*Bnm1 + an*Bnm2;

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {
      An /= RECUR_BIG;
      Bn /= RECUR_BIG;
      Anm1 /= RECUR_BIG;
      Bnm1 /= RECUR_BIG;
      Anm2 /= RECUR_BIG;
      Bnm2 /= RECUR_BIG;
    }

    old_fn = fn;
    fn = An/Bn;
    del = old_fn/fn;

    if(fabs(del - 1.0) < 10.0*GSL_DBL_EPSILON) break;
  }

  *result = fn;
  if(n == maxiter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_SUCCESS;
}
#endif /* 0 */

/* 1F1(a,b,x)
 * |a| <= 1, b > 0
 */
static
int
hyperg_1F1_small_a_bgt0(const double a, const double b, const double x, gsl_sf_result * result)
{
  const double bma = b-a;
  const double oma = 1.0-a;
  const double ap1mb = 1.0+a-b;
  const double abs_bma = fabs(bma);
  const double abs_oma = fabs(oma);
  const double abs_ap1mb = fabs(ap1mb);

  const double ax = fabs(x);

  if(a == 0.0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(a == 1.0) {
    return hyperg_1F1_1(b, x, result);
  }
  else if(a == -1.0) {
    result->val  = 1.0 + a/b * x;
    result->err  = GSL_DBL_EPSILON * (1.0 + fabs(a/b * x));
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return GSL_SUCCESS;
  }
  else if(b >= 1.4*ax) {
    return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
  }
  else if(x > 0.0) {
    if(x > 100.0 && abs_bma*abs_oma < 0.5*x) {
      return hyperg_1F1_asymp_posx(a, b, x, result);
    }
    else if(b < 5.0e+06) {
      /* Recurse backward on b from
       * a suitably high point.
       */
      const double b_del = ceil(1.4*x-b) + 1.0;
      double bp = b + b_del;
      gsl_sf_result r_Mbp1;
      gsl_sf_result r_Mb;
      double Mbp1;
      double Mb;
      double Mbm1;
      int stat_0 = gsl_sf_hyperg_1F1_series_e(a, bp+1.0, x, &r_Mbp1);
      int stat_1 = gsl_sf_hyperg_1F1_series_e(a, bp,     x, &r_Mb);
      const double err_rat = fabs(r_Mbp1.err/r_Mbp1.val) + fabs(r_Mb.err/r_Mb.val);
      Mbp1 = r_Mbp1.val;
      Mb   = r_Mb.val;
      while(bp > b+0.1) {
        /* Do backward recursion. */
        Mbm1 = ((x+bp-1.0)*Mb - x*(bp-a)/bp*Mbp1)/(bp-1.0);
        bp -= 1.0;
	Mbp1 = Mb;
	Mb   = Mbm1;
      }
      result->val  = Mb;
      result->err  = err_rat * (fabs(b_del)+1.0) * fabs(Mb);
      result->err += 2.0 * GSL_DBL_EPSILON * fabs(Mb);
      return GSL_ERROR_SELECT_2(stat_0, stat_1);
    }
    else {
      return hyperg_1F1_large2bm4a(a, b, x, result);
    }
  }
  else {
    /* x < 0 and b not large compared to |x|
     */
    if(ax < 10.0 && b < 10.0) {
      return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
    }
    else if(ax >= 100.0 && GSL_MAX(abs_ap1mb,1.0) < 0.99*ax) {
      return hyperg_1F1_asymp_negx(a, b, x, result);
    }
    else {
      return hyperg_1F1_luke(a, b, x, result);
    }
  }
}

/* 1F1(b+eps,b,x)
 * |eps|<=1, b > 0
 */
static
int
hyperg_1F1_beps_bgt0(const double eps, const double b, const double x, gsl_sf_result * result)
{
  if(b > fabs(x) && fabs(eps) < GSL_SQRT_DBL_EPSILON) {
    /* If b-a is very small and x/b is not too large we can
     * use this explicit approximation.
     *
     * 1F1(b+eps,b,x) = exp(ax/b) (1 - eps x^2 (v2 + v3 x + ...) + ...)
     *
     *   v2 = a/(2b^2(b+1))
     *   v3 = a(b-2a)/(3b^3(b+1)(b+2))
     *   ...
     *
     * See [Luke, Mathematical Functions and Their Approximations, p.292]
     *
     * This cannot be used for b near a negative integer or zero.
     * Also, if x/b is large the deviation from exp(x) behaviour grows.
     */
    double a = b + eps;
    gsl_sf_result exab;
    int stat_e = gsl_sf_exp_e(a*x/b, &exab);
    double v2 = a/(2.0*b*b*(b+1.0));
    double v3 = a*(b-2.0*a)/(3.0*b*b*b*(b+1.0)*(b+2.0));
    double v  = v2 + v3 * x;
    double f  = (1.0 - eps*x*x*v);
    result->val  = exab.val * f;
    result->err  = exab.err * fabs(f);
    result->err += fabs(exab.val) * GSL_DBL_EPSILON * (1.0 + fabs(eps*x*x*v));
    result->err += 4.0 * GSL_DBL_EPSILON * fabs(result->val);
    return stat_e;
  }
  else {
    /* Otherwise use a Kummer transformation to reduce
     * it to the small a case.
     */
    gsl_sf_result Kummer_1F1;
    int stat_K = hyperg_1F1_small_a_bgt0(-eps, b, -x, &Kummer_1F1);
    if(Kummer_1F1.val != 0.0) {
      int stat_e = gsl_sf_exp_mult_err_e(x, 2.0*GSL_DBL_EPSILON*fabs(x),
                                            Kummer_1F1.val, Kummer_1F1.err,
                                            result);
      return GSL_ERROR_SELECT_2(stat_e, stat_K);
    }
    else {
      result->val = 0.0;
      result->err = 0.0;
      return stat_K;
    }
  }
}

/* 1F1(a,2a,x) = Gamma(a + 1/2) E(x) (|x|/4)^(-a+1/2) scaled_I(a-1/2,|x|/2)
 *
 * E(x) = exp(x) x > 0
 *      = 1      x < 0
 *
 * a >= 1/2
 */
static
int
hyperg_1F1_beq2a_pos(const double a, const double x, gsl_sf_result * result)
{
  if(x == 0.0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else {
    gsl_sf_result I;
    int stat_I = gsl_sf_bessel_Inu_scaled_e(a-0.5, 0.5*fabs(x), &I);
    gsl_sf_result lg;
    int stat_g = gsl_sf_lngamma_e(a + 0.5, &lg);
    double ln_term   = (0.5-a)*log(0.25*fabs(x));
    double lnpre_val = lg.val + GSL_MAX_DBL(x,0.0) + ln_term;
    double lnpre_err = lg.err + GSL_DBL_EPSILON * (fabs(ln_term) + fabs(x));
    int stat_e = gsl_sf_exp_mult_err_e(lnpre_val, lnpre_err,
    					  I.val, I.err,
    					  result);
    return GSL_ERROR_SELECT_3(stat_e, stat_g, stat_I);
  }
}

/* Determine middle parts of diagonal recursion along b=2a
 * from two endpoints, i.e.
 *
 * given:  M(a,b)      and  M(a+1,b+2)
 * get:    M(a+1,b+1)  and  M(a,b+1)
 */
#if 0
inline
static
int
hyperg_1F1_diag_step(const double a, const double b, const double x,
                     const double Mab, const double Map1bp2,
                     double * Map1bp1, double * Mabp1)
{
  if(a == b) {
    *Map1bp1 = Mab;
    *Mabp1   = Mab - x/(b+1.0) * Map1bp2;
  }
  else {
    *Map1bp1 = Mab - x * (a-b)/(b*(b+1.0)) * Map1bp2;
    *Mabp1   = (a * *Map1bp1 - b * Mab)/(a-b);
  }
  return GSL_SUCCESS;
}
#endif /* 0 */

/* Determine endpoint of diagonal recursion.
 *
 * given:  M(a,b)    and  M(a+1,b+2)
 * get:    M(a+1,b)  and  M(a+1,b+1)
 */
#if 0
inline
static
int
hyperg_1F1_diag_end_step(const double a, const double b, const double x,
                         const double Mab, const double Map1bp2,
                         double * Map1b, double * Map1bp1)
{
  *Map1bp1 = Mab - x * (a-b)/(b*(b+1.0)) * Map1bp2;
  *Map1b   = Mab + x/b * *Map1bp1;
  return GSL_SUCCESS;
}
#endif /* 0 */

/* Handle the case of a and b both positive integers.
 * Assumes a > 0 and b > 0.
 */
static
int
hyperg_1F1_ab_posint(const int a, const int b, const double x, gsl_sf_result * result)
{
  double ax = fabs(x);

  if(a == b) {
    return gsl_sf_exp_e(x, result);             /* 1F1(a,a,x) */
  }
  else if(a == 1) {
    return gsl_sf_exprel_n_e(b-1, x, result);   /* 1F1(1,b,x) */
  }
  else if(b == a + 1) {
    gsl_sf_result K;
    int stat_K = gsl_sf_exprel_n_e(a, -x, &K);  /* 1F1(1,1+a,-x) */
    int stat_e = gsl_sf_exp_mult_err_e(x, 2.0 * GSL_DBL_EPSILON * fabs(x),
    					  K.val, K.err,
    					  result);
    return GSL_ERROR_SELECT_2(stat_e, stat_K);
  }
  else if(a == b + 1) {
    gsl_sf_result ex;
    int stat_e = gsl_sf_exp_e(x, &ex);
    result->val  = ex.val * (1.0 + x/b);
    result->err  = ex.err * (1.0 + x/b);
    result->err += ex.val * GSL_DBL_EPSILON * (1.0 + fabs(x/b));
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return stat_e;
  }
  else if(a == b + 2) {
    gsl_sf_result ex;
    int stat_e = gsl_sf_exp_e(x, &ex);
    double poly  = (1.0 + x/b*(2.0 + x/(b+1.0)));
    result->val  = ex.val * poly;
    result->err  = ex.err * fabs(poly);
    result->err += ex.val * GSL_DBL_EPSILON * (1.0 + fabs(x/b) * (2.0 + fabs(x/(b+1.0))));
    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);
    return stat_e;
  }
  else if(b == 2*a) {
    return hyperg_1F1_beq2a_pos(a, x, result);  /* 1F1(a,2a,x) */
  }
  else if(   ( b < 10 && a < 10 && ax < 5.0 )
          || ( b > a*ax )
	  || ( b > a && ax < 5.0 )
    ) {
    return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
  }
  else if(b > a && b >= 2*a + x) {
    /* Use the Gautschi CF series, then
     * recurse backward to a=0 for normalization.
     * This will work for either sign of x.
     */
    double rap;
    int stat_CF1 = hyperg_1F1_CF1_p_ser(a, b, x, &rap);
    double ra = 1.0 + x/a * rap;
    double Ma	= GSL_SQRT_DBL_MIN;
    double Map1 = ra * Ma;
    double Mnp1 = Map1;
    double Mn	= Ma;
    double Mnm1;
    int n;
    for(n=a; n>0; n--) {
      Mnm1 = (n * Mnp1 - (2*n-b+x) * Mn) / (b-n);
      Mnp1 = Mn;
      Mn   = Mnm1;
    }
    result->val = Ma/Mn;
    result->err = 2.0 * GSL_DBL_EPSILON * (fabs(a) + 1.0) * fabs(Ma/Mn);
    return stat_CF1;
  }
  else if(b > a && b < 2*a + x && b > x) {
    /* Use the Gautschi series representation of
     * the continued fraction. Then recurse forward
     * to the a=b line for normalization. This will
     * work for either sign of x, although we do need
     * to check for b > x, for when x is positive.
     */
    double rap;
    int stat_CF1 = hyperg_1F1_CF1_p_ser(a, b, x, &rap);
    double ra = 1.0 + x/a * rap;
    gsl_sf_result ex;
    int stat_ex;

    double Ma   = GSL_SQRT_DBL_MIN;
    double Map1 = ra * Ma;
    double Mnm1 = Ma;
    double Mn	= Map1;
    double Mnp1;
    int n;
    for(n=a+1; n<b; n++) {
      Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
      Mnm1 = Mn;
      Mn   = Mnp1;
    }

    stat_ex = gsl_sf_exp_e(x, &ex);  /* 1F1(b,b,x) */
    result->val  = ex.val * Ma/Mn;
    result->err  = ex.err * fabs(Ma/Mn);
    result->err += 4.0 * GSL_DBL_EPSILON * (fabs(b-a)+1.0) * fabs(result->val);
    return GSL_ERROR_SELECT_2(stat_ex, stat_CF1);
  }
  else if(x >= 0.0) {

    if(b < a) {
      /* The point b,b is below the b=2a+x line.
       * Forward recursion on a from b,b+1 is possible.
       * Note that a > b + 1 as well, since we already tried a = b + 1.
       */
      if(x + log(fabs(x/b)) < GSL_LOG_DBL_MAX-2.0) {
        double ex = exp(x);
        int n;
        double Mnm1 = ex;		  /* 1F1(b,b,x)   */
    	double Mn   = ex * (1.0 + x/b);   /* 1F1(b+1,b,x) */
    	double Mnp1;
        for(n=b+1; n<a; n++) {
          Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
          Mnm1 = Mn;
          Mn   = Mnp1;
        }
        result->val  = Mn;
	result->err  = (x + 1.0) * GSL_DBL_EPSILON * fabs(Mn);
	result->err *= fabs(a-b)+1.0;
        return GSL_SUCCESS;
      }
      else {
        OVERFLOW_ERROR(result);
      }
    }
    else {
      /* b > a
       * b < 2a + x
       * b <= x (otherwise we would have finished above)
       *
       * Gautschi anomalous convergence region. However, we can
       * recurse forward all the way from a=0,1 because we are
       * always underneath the b=2a+x line.
       */
      gsl_sf_result r_Mn;
      double Mnm1 = 1.0;    /* 1F1(0,b,x) */
      double Mn;	    /* 1F1(1,b,x)  */
      double Mnp1;
      int n;
      gsl_sf_exprel_n_e(b-1, x, &r_Mn);
      Mn = r_Mn.val;
      for(n=1; n<a; n++) {
        Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
     	Mnm1 = Mn;
     	Mn   = Mnp1;
      }
      result->val  = Mn;
      result->err  = fabs(Mn) * (1.0 + fabs(a)) * fabs(r_Mn.err / r_Mn.val);
      result->err += 2.0 * GSL_DBL_EPSILON * fabs(Mn);
      return GSL_SUCCESS;
    }
  }
  else {
    /* x < 0
     * b < a (otherwise we would have tripped one of the above)
     */

    if(a <= 0.5*(b-x) || a >= -x) {
      /* Gautschi continued fraction is in the anomalous region,
       * so we must find another way. We recurse down in b,
       * from the a=b line.
       */
      double ex = exp(x);
      double Manp1 = ex;
      double Man   = ex * (1.0 + x/(a-1.0));
      double Manm1;
      int n;
      for(n=a-1; n>b; n--) {
        Manm1 = (-n*(1-n-x)*Man - x*(n-a)*Manp1)/(n*(n-1.0));
        Manp1 = Man;
        Man = Manm1;
      }
      result->val  = Man;
      result->err  = (fabs(x) + 1.0) * GSL_DBL_EPSILON * fabs(Man);
      result->err *= fabs(b-a)+1.0;
      return GSL_SUCCESS;
    }
    else {
      /* Pick a0 such that b ~= 2a0 + x, then
       * recurse down in b from a0,a0 to determine
       * the values near the line b=2a+x. Then recurse
       * forward on a from a0.
       */
      int a0 = ceil(0.5*(b-x));
      double Ma0b;    /* M(a0,b)   */
      double Ma0bp1;  /* M(a0,b+1) */
      double Ma0p1b;  /* M(a0+1,b) */
      double Mnm1;
      double Mn;
      double Mnp1;
      int n;
      {
        double ex = exp(x);
    	double Ma0np1 = ex;
    	double Ma0n   = ex * (1.0 + x/(a0-1.0));
    	double Ma0nm1;
    	for(n=a0-1; n>b; n--) {
    	  Ma0nm1 = (-n*(1-n-x)*Ma0n - x*(n-a0)*Ma0np1)/(n*(n-1.0));
    	  Ma0np1 = Ma0n;
    	  Ma0n = Ma0nm1;
    	}
	Ma0bp1 = Ma0np1;
    	Ma0b   = Ma0n;
	Ma0p1b = (b*(a0+x)*Ma0b + x*(a0-b)*Ma0bp1)/(a0*b);
      }

      Mnm1 = Ma0b;
      Mn   = Ma0p1b;
      for(n=a0+1; n<a; n++) {
    	Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
    	Mnm1 = Mn;
    	Mn   = Mnp1;
      }
      result->val  = Mn;
      result->err  = (fabs(x) + 1.0) * GSL_DBL_EPSILON *  fabs(Mn);
      result->err *= fabs(b-a)+1.0;
      return GSL_SUCCESS;
    }
  }
}

/* Evaluate a <= 0, a integer, cases directly. (Polynomial; Horner)
 * When the terms are all positive, this
 * must work. We will assume this here.
 */
static
int
hyperg_1F1_a_negint_poly(const int a, const double b, const double x, gsl_sf_result * result)
{
  if(a == 0) {
    result->val = 1.0;
    result->err = 1.0;
    return GSL_SUCCESS;
  }
  else {
    int N = -a;
    double poly = 1.0;
    int k;
    for(k=N-1; k>=0; k--) {
      double t = (a+k)/(b+k) * (x/(k+1));
      double r = t + 1.0/poly;
      if(r > 0.9*GSL_DBL_MAX/poly) {
        OVERFLOW_ERROR(result);
      }
      else {
        poly *= r;  /* P_n = 1 + t_n P_{n-1} */
      }
    }
    result->val = poly;
    result->err = 2.0 * (sqrt(N) + 1.0) * GSL_DBL_EPSILON * fabs(poly);
    return GSL_SUCCESS;
  }
}

/* Evaluate negative integer a case by relation
 * to Laguerre polynomials. This is more general than
 * the direct polynomial evaluation, but is safe
 * for all values of x.
 *
 * 1F1(-n,b,x) = n!/(b)_n Laguerre[n,b-1,x]
 *	       = n B(b,n) Laguerre[n,b-1,x]
 *
 * assumes b is not a negative integer
 */
static
int
hyperg_1F1_a_negint_lag(const int a, const double b, const double x, gsl_sf_result * result)
{
  const int n = -a;

  gsl_sf_result lag;
  const int stat_l = gsl_sf_laguerre_n_e(n, b-1.0, x, &lag);
  if(b < 0.0) {
    gsl_sf_result lnfact;
    gsl_sf_result lng1;
    gsl_sf_result lng2;
    double s1, s2;
    const int stat_f  = gsl_sf_lnfact_e(n, &lnfact);
    const int stat_g1 = gsl_sf_lngamma_sgn_e(b + n, &lng1, &s1);
    const int stat_g2 = gsl_sf_lngamma_sgn_e(b, &lng2, &s2);
    const double lnpre_val = lnfact.val - (lng1.val - lng2.val);
    const double lnpre_err = lnfact.err + lng1.err + lng2.err
      + 2.0 * GSL_DBL_EPSILON * fabs(lnpre_val);
    const int stat_e = gsl_sf_exp_mult_err_e(lnpre_val, lnpre_err,
                                                s1*s2*lag.val, lag.err,
                                                result);
    return GSL_ERROR_SELECT_5(stat_e, stat_l, stat_g1, stat_g2, stat_f);
  }
  else {
    gsl_sf_result lnbeta;
    gsl_sf_lnbeta_e(b, n, &lnbeta);
    if(fabs(lnbeta.val) < 0.1) {
      /* As we have noted, when B(x,y) is near 1,
       * evaluating log(B(x,y)) is not accurate.
       * Instead we evaluate B(x,y) directly.
       */
      const double ln_term_val = log(1.25*n);
      const double ln_term_err = 2.0 * GSL_DBL_EPSILON * ln_term_val;
      gsl_sf_result beta;
      int stat_b = gsl_sf_beta_e(b, n, &beta);
      int stat_e = gsl_sf_exp_mult_err_e(ln_term_val, ln_term_err,
                                            lag.val, lag.err,
                                            result);
      result->val *= beta.val/1.25;
      result->err *= beta.val/1.25;
      return GSL_ERROR_SELECT_3(stat_e, stat_l, stat_b);
    }
    else {
      /* B(x,y) was not near 1, so it is safe to use
       * the logarithmic values.
       */
      const double ln_n = log(n);
      const double ln_term_val = lnbeta.val + ln_n;
      const double ln_term_err = lnbeta.err + 2.0 * GSL_DBL_EPSILON * fabs(ln_n);
      int stat_e = gsl_sf_exp_mult_err_e(ln_term_val, ln_term_err,
                                            lag.val, lag.err,
                                            result);
      return GSL_ERROR_SELECT_2(stat_e, stat_l);
    }
  }
}

/* Handle negative integer a case for x > 0 and
 * generic b.
 *
 * Combine [Abramowitz+Stegun, 13.6.9 + 13.6.27]
 * M(-n,b,x) = (-1)^n / (b)_n U(-n,b,x) = n! / (b)_n Laguerre^(b-1)_n(x)
 */
#if 0
static
int
hyperg_1F1_a_negint_U(const int a, const double b, const double x, gsl_sf_result * result)
{
  const int n = -a;
  const double sgn = ( GSL_IS_ODD(n) ? -1.0 : 1.0 );
  double sgpoch;
  gsl_sf_result lnpoch;
  gsl_sf_result U;
  const int stat_p = gsl_sf_lnpoch_sgn_e(b, n, &lnpoch, &sgpoch);
  const int stat_U = gsl_sf_hyperg_U_e(-n, b, x, &U);
  const int stat_e = gsl_sf_exp_mult_err_e(-lnpoch.val, lnpoch.err,
  					      sgn * sgpoch * U.val, U.err,
  					      result);
  return GSL_ERROR_SELECT_3(stat_e, stat_U, stat_p);
}
#endif

/* Assumes a <= -1,  b <= -1, and b <= a.
 */
static
int
hyperg_1F1_ab_negint(const int a, const int b, const double x, gsl_sf_result * result)
{
  if(x == 0.0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(x > 0.0) {
    return hyperg_1F1_a_negint_poly(a, b, x, result);
  }
  else {
    /* Apply a Kummer transformation to make x > 0 so
     * we can evaluate the polynomial safely. Of course,
     * this assumes b <= a, which must be true for
     * a<0 and b<0, since otherwise the thing is undefined.
     */
    gsl_sf_result K;
    int stat_K = hyperg_1F1_a_negint_poly(b-a, b, -x, &K);
    int stat_e = gsl_sf_exp_mult_err_e(x, 2.0 * GSL_DBL_EPSILON * fabs(x),
    					  K.val, K.err,
    					  result);
    return GSL_ERROR_SELECT_2(stat_e, stat_K);
  }
}

/* [Abramowitz+Stegun, 13.1.3]
 *
 * M(a,b,x) = Gamma(1+a-b)/Gamma(2-b) x^(1-b) *
 *            { Gamma(b)/Gamma(a) M(1+a-b,2-b,x) - (b-1) U(1+a-b,2-b,x) }
 *
 * b not an integer >= 2
 * a-b not a negative integer
 */
static
int
hyperg_1F1_U(const double a, const double b, const double x, gsl_sf_result * result)
{
  const double bp = 2.0 - b;
  const double ap = a - b + 1.0;

  gsl_sf_result lg_ap, lg_bp;
  double sg_ap;
  int stat_lg0 = gsl_sf_lngamma_sgn_e(ap, &lg_ap, &sg_ap);
  int stat_lg1 = gsl_sf_lngamma_e(bp, &lg_bp);
  int stat_lg2 = GSL_ERROR_SELECT_2(stat_lg0, stat_lg1);
  double t1 = (bp-1.0) * log(x);
  double lnpre_val = lg_ap.val - lg_bp.val + t1;
  double lnpre_err = lg_ap.err + lg_bp.err + 2.0 * GSL_DBL_EPSILON * fabs(t1);

  gsl_sf_result lg_2mbp, lg_1papmbp;
  double sg_2mbp, sg_1papmbp;
  int stat_lg3 = gsl_sf_lngamma_sgn_e(2.0-bp,    &lg_2mbp,    &sg_2mbp);
  int stat_lg4 = gsl_sf_lngamma_sgn_e(1.0+ap-bp, &lg_1papmbp, &sg_1papmbp);
  int stat_lg5 = GSL_ERROR_SELECT_2(stat_lg3, stat_lg4);
  double lnc1_val = lg_2mbp.val - lg_1papmbp.val;
  double lnc1_err = lg_2mbp.err + lg_1papmbp.err
                    + GSL_DBL_EPSILON * (fabs(lg_2mbp.val) + fabs(lg_1papmbp.val));

  gsl_sf_result M;
  gsl_sf_result_e10 U;
  int stat_F = gsl_sf_hyperg_1F1_e(ap, bp, x, &M);
  int stat_U = gsl_sf_hyperg_U_e10_e(ap, bp, x, &U);
  int stat_FU = GSL_ERROR_SELECT_2(stat_F, stat_U);

  gsl_sf_result_e10 term_M;
  int stat_e0 = gsl_sf_exp_mult_err_e10_e(lnc1_val, lnc1_err,
                                             sg_2mbp*sg_1papmbp*M.val, M.err,
                                             &term_M);

  const double ombp = 1.0 - bp;
  const double Uee_val = U.e10*M_LN10;
  const double Uee_err = 2.0 * GSL_DBL_EPSILON * fabs(Uee_val);
  const double Mee_val = term_M.e10*M_LN10;
  const double Mee_err = 2.0 * GSL_DBL_EPSILON * fabs(Mee_val);
  int stat_e1;

  /* Do a little dance with the exponential prefactors
   * to avoid overflows in intermediate results.
   */
  if(Uee_val > Mee_val) {
    const double factorM_val = exp(Mee_val-Uee_val);
    const double factorM_err = 2.0 * GSL_DBL_EPSILON * (fabs(Mee_val-Uee_val)+1.0) * factorM_val;
    const double inner_val = term_M.val*factorM_val - ombp*U.val;
    const double inner_err =
        term_M.err*factorM_val + fabs(ombp) * U.err
      + fabs(term_M.val) * factorM_err
      + GSL_DBL_EPSILON * (fabs(term_M.val*factorM_val) + fabs(ombp*U.val));
    stat_e1 = gsl_sf_exp_mult_err_e(lnpre_val+Uee_val, lnpre_err+Uee_err,
                                       sg_ap*inner_val, inner_err,
                                       result);
  }
  else {
    const double factorU_val = exp(Uee_val - Mee_val);
    const double factorU_err = 2.0 * GSL_DBL_EPSILON * (fabs(Mee_val-Uee_val)+1.0) * factorU_val;
    const double inner_val = term_M.val - ombp*factorU_val*U.val;
    const double inner_err =
        term_M.err + fabs(ombp*factorU_val*U.err)
      + fabs(ombp*factorU_err*U.val)
      + GSL_DBL_EPSILON * (fabs(term_M.val) + fabs(ombp*factorU_val*U.val));
    stat_e1 = gsl_sf_exp_mult_err_e(lnpre_val+Mee_val, lnpre_err+Mee_err,
                                       sg_ap*inner_val, inner_err,
                                       result);
  }

  return GSL_ERROR_SELECT_5(stat_e1, stat_e0, stat_FU, stat_lg5, stat_lg2);
}

/* Handle case of generic positive a, b.
 * Assumes b-a is not a negative integer.
 */
static
int
hyperg_1F1_ab_pos(const double a, const double b,
                  const double x,
                  gsl_sf_result * result)
{
  const double ax = fabs(x);

  if(   ( b < 10.0 && a < 10.0 && ax < 5.0 )
     || ( b > a*ax )
     || ( b > a && ax < 5.0 )
    ) {
    return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
  }
  else if(   x < -100.0
          && GSL_MAX_DBL(fabs(a),1.0)*GSL_MAX_DBL(fabs(1.0+a-b),1.0) < 0.7*fabs(x)
    ) {
    /* Large negative x asymptotic.
     */
    return hyperg_1F1_asymp_negx(a, b, x, result);
  }
  else if(   x > 100.0
          && GSL_MAX_DBL(fabs(b-a),1.0)*GSL_MAX_DBL(fabs(1.0-a),1.0) < 0.7*fabs(x)
    ) {
    /* Large positive x asymptotic.
     */
    return hyperg_1F1_asymp_posx(a, b, x, result);
  }
  else if(fabs(b-a) <= 1.0) {
    /* Directly handle b near a.
     */
    return hyperg_1F1_beps_bgt0(a-b, b, x, result);  /* a = b + eps */
  }

  else if(b > a && b >= 2*a + x) {
    /* Use the Gautschi CF series, then
     * recurse backward to a near 0 for normalization.
     * This will work for either sign of x.
     */
    double rap;
    int stat_CF1 = hyperg_1F1_CF1_p_ser(a, b, x, &rap);
    double ra = 1.0 + x/a * rap;

    double Ma	= GSL_SQRT_DBL_MIN;
    double Map1 = ra * Ma;
    double Mnp1 = Map1;
    double Mn	= Ma;
    double Mnm1;
    gsl_sf_result Mn_true;
    int stat_Mt;
    double n;
    for(n=a; n>0.5; n -= 1.0) {
      Mnm1 = (n * Mnp1 - (2.0*n-b+x) * Mn) / (b-n);
      Mnp1 = Mn;
      Mn   = Mnm1;
    }

    stat_Mt = hyperg_1F1_small_a_bgt0(n, b, x, &Mn_true);

    result->val  = (Ma/Mn) * Mn_true.val;
    result->err  = fabs(Ma/Mn) * Mn_true.err;
    result->err += 2.0 * GSL_DBL_EPSILON * (fabs(a)+1.0) * fabs(result->val);
    return GSL_ERROR_SELECT_2(stat_Mt, stat_CF1);
  }
  else if(b > a && b < 2*a + x && b > x) {
    /* Use the Gautschi series representation of
     * the continued fraction. Then recurse forward
     * to near the a=b line for normalization. This will
     * work for either sign of x, although we do need
     * to check for b > x, which is relevant when x is positive.
     */
    gsl_sf_result Mn_true;
    int stat_Mt;
    double rap;
    int stat_CF1 = hyperg_1F1_CF1_p_ser(a, b, x, &rap);
    double ra = 1.0 + x/a * rap;
    double Ma	= GSL_SQRT_DBL_MIN;
    double Mnm1 = Ma;
    double Mn	= ra * Mnm1;
    double Mnp1;
    double n;
    for(n=a+1.0; n<b-0.5; n += 1.0) {
      Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
      Mnm1 = Mn;
      Mn   = Mnp1;
    }
    stat_Mt = hyperg_1F1_beps_bgt0(n-b, b, x, &Mn_true);
    result->val  = Ma/Mn * Mn_true.val;
    result->err  = fabs(Ma/Mn) * Mn_true.err;
    result->err += 2.0 * GSL_DBL_EPSILON * (fabs(b-a)+1.0) * fabs(result->val);
    return GSL_ERROR_SELECT_2(stat_Mt, stat_CF1);
  }
  else if(x >= 0.0) {

    if(b < a) {
      /* Forward recursion on a from a=b+eps-1,b+eps.
       */
      double N   = floor(a-b);
      double eps = a - b - N;
      gsl_sf_result r_M0;
      gsl_sf_result r_M1;
      int stat_0 = hyperg_1F1_beps_bgt0(eps-1.0, b, x, &r_M0);
      int stat_1 = hyperg_1F1_beps_bgt0(eps,     b, x, &r_M1);
      double M0 = r_M0.val;
      double M1 = r_M1.val;

      double Mam1 = M0;
      double Ma   = M1;
      double Map1;
      double ap;
      double start_pair = fabs(M0) + fabs(M1);
      double minim_pair = GSL_DBL_MAX;
      double pair_ratio;
      double rat_0 = fabs(r_M0.err/r_M0.val);
      double rat_1 = fabs(r_M1.err/r_M1.val);
      for(ap=b+eps; ap<a-0.1; ap += 1.0) {
        Map1 = ((b-ap)*Mam1 + (2.0*ap-b+x)*Ma)/ap;
        Mam1 = Ma;
        Ma   = Map1;
        minim_pair = GSL_MIN_DBL(fabs(Mam1) + fabs(Ma), minim_pair);
      }
      pair_ratio = start_pair/minim_pair;
      result->val  = Ma;
      result->err  = 2.0 * (rat_0 + rat_1 + GSL_DBL_EPSILON) * (fabs(b-a)+1.0) * fabs(Ma);
      result->err += 2.0 * (rat_0 + rat_1) * pair_ratio*pair_ratio * fabs(Ma);
      result->err += 2.0 * GSL_DBL_EPSILON * fabs(Ma);
      return GSL_ERROR_SELECT_2(stat_0, stat_1);
    }
    else {
      /* b > a
       * b < 2a + x
       * b <= x
       *
       * Recurse forward on a from a=eps,eps+1.
       */
      double eps = a - floor(a);
      gsl_sf_result r_Mnm1;
      gsl_sf_result r_Mn;
      int stat_0 = hyperg_1F1_small_a_bgt0(eps,     b, x, &r_Mnm1);
      int stat_1 = hyperg_1F1_small_a_bgt0(eps+1.0, b, x, &r_Mn);
      double Mnm1 = r_Mnm1.val;
      double Mn   = r_Mn.val;
      double Mnp1;

      double n;
      double start_pair = fabs(Mn) + fabs(Mnm1);
      double minim_pair = GSL_DBL_MAX;
      double pair_ratio;
      double rat_0 = fabs(r_Mnm1.err/r_Mnm1.val);
      double rat_1 = fabs(r_Mn.err/r_Mn.val);
      for(n=eps+1.0; n<a-0.1; n++) {
        Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
        Mnm1 = Mn;
        Mn   = Mnp1;
        minim_pair = GSL_MIN_DBL(fabs(Mn) + fabs(Mnm1), minim_pair);
      }
      pair_ratio = start_pair/minim_pair;
      result->val  = Mn;
      result->err  = 2.0 * (rat_0 + rat_1 + GSL_DBL_EPSILON) * (fabs(a)+1.0) * fabs(Mn);
      result->err += 2.0 * (rat_0 + rat_1) * pair_ratio*pair_ratio * fabs(Mn);
      result->err += 2.0 * GSL_DBL_EPSILON * fabs(Mn);
      return GSL_ERROR_SELECT_2(stat_0, stat_1);
    }
  }
  else {
    /* x < 0
     * b < a
     */

    if(a <= 0.5*(b-x) || a >= -x) {
      /* Recurse down in b, from near the a=b line, b=a+eps,a+eps-1.
       */
      double N   = floor(a - b);
      double eps = 1.0 + N - a + b;
      gsl_sf_result r_Manp1;
      gsl_sf_result r_Man;
      int stat_0 = hyperg_1F1_beps_bgt0(-eps,    a+eps,     x, &r_Manp1);
      int stat_1 = hyperg_1F1_beps_bgt0(1.0-eps, a+eps-1.0, x, &r_Man);
      double Manp1 = r_Manp1.val;
      double Man   = r_Man.val;
      double Manm1;

      double n;
      double start_pair = fabs(Manp1) + fabs(Man);
      double minim_pair = GSL_DBL_MAX;
      double pair_ratio;
      double rat_0 = fabs(r_Manp1.err/r_Manp1.val);
      double rat_1 = fabs(r_Man.err/r_Man.val);
      for(n=a+eps-1.0; n>b+0.1; n -= 1.0) {
        Manm1 = (-n*(1-n-x)*Man - x*(n-a)*Manp1)/(n*(n-1.0));
        Manp1 = Man;
        Man = Manm1;
        minim_pair = GSL_MIN_DBL(fabs(Manp1) + fabs(Man), minim_pair);
      }

      /* FIXME: this is a nasty little hack; there is some
         (transient?) instability in this recurrence for some
	 values. I can tell when it happens, which is when
	 this pair_ratio is large. But I do not know how to
	 measure the error in terms of it. I guessed quadratic
	 below, but it is probably worse than that.
	 */
      pair_ratio = start_pair/minim_pair;
      result->val  = Man;
      result->err  = 2.0 * (rat_0 + rat_1 + GSL_DBL_EPSILON) * (fabs(b-a)+1.0) * fabs(Man);
      result->err *= pair_ratio*pair_ratio + 1.0;
      return GSL_ERROR_SELECT_2(stat_0, stat_1);
    }
    else {
      /* Pick a0 such that b ~= 2a0 + x, then
       * recurse down in b from a0,a0 to determine
       * the values near the line b=2a+x. Then recurse
       * forward on a from a0.
       */
      double epsa = a - floor(a);
      double a0   = floor(0.5*(b-x)) + epsa;
      double N    = floor(a0 - b);
      double epsb = 1.0 + N - a0 + b;
      double Ma0b;
      double Ma0bp1;
      double Ma0p1b;
      int stat_a0;
      double Mnm1;
      double Mn;
      double Mnp1;
      double n;
      double err_rat;
      {
    	gsl_sf_result r_Ma0np1;
    	gsl_sf_result r_Ma0n;
        int stat_0 = hyperg_1F1_beps_bgt0(-epsb,    a0+epsb,     x, &r_Ma0np1);
        int stat_1 = hyperg_1F1_beps_bgt0(1.0-epsb, a0+epsb-1.0, x, &r_Ma0n);
    	double Ma0np1 = r_Ma0np1.val;
    	double Ma0n   = r_Ma0n.val;
    	double Ma0nm1;

	err_rat = fabs(r_Ma0np1.err/r_Ma0np1.val) + fabs(r_Ma0n.err/r_Ma0n.val);

    	for(n=a0+epsb-1.0; n>b+0.1; n -= 1.0) {
    	  Ma0nm1 = (-n*(1-n-x)*Ma0n - x*(n-a0)*Ma0np1)/(n*(n-1.0));
          Ma0np1 = Ma0n;
          Ma0n = Ma0nm1;
        }
	Ma0bp1 = Ma0np1;
        Ma0b   = Ma0n;
	Ma0p1b = (b*(a0+x)*Ma0b+x*(a0-b)*Ma0bp1)/(a0*b); /* right-down hook */
	stat_a0 = GSL_ERROR_SELECT_2(stat_0, stat_1);
      }

      /* Initialise the recurrence correctly BJG */

      if (a0 >= a - 0.1)
        {
          Mn = Ma0b;
        }
      else if (a0 + 1>= a - 0.1)
        {
          Mn = Ma0p1b;
        }
      else
        {
          Mnm1 = Ma0b;
          Mn   = Ma0p1b;

          for(n=a0+1.0; n<a-0.1; n += 1.0) {
            Mnp1 = ((b-n)*Mnm1 + (2*n-b+x)*Mn)/n;
            Mnm1 = Mn;
            Mn   = Mnp1;
          }
        }

      result->val = Mn;
      result->err = (err_rat + GSL_DBL_EPSILON) * (fabs(b-a)+1.0) * fabs(Mn);
      return stat_a0;
    }
  }
}

/* Assumes b != integer
 * Assumes a != integer when x > 0
 * Assumes b-a != neg integer when x < 0
 */
static
int
hyperg_1F1_ab_neg(const double a, const double b, const double x,
                  gsl_sf_result * result)
{
  const double bma = b - a;
  const double abs_x = fabs(x);
  const double abs_a = fabs(a);
  const double abs_b = fabs(b);
  const double size_a = GSL_MAX(abs_a, 1.0);
  const double size_b = GSL_MAX(abs_b, 1.0);
  const int bma_integer = ( bma - floor(bma+0.5) < _1F1_INT_THRESHOLD );

  if(   (abs_a < 10.0 && abs_b < 10.0 && abs_x < 5.0)
     || (b > 0.8*GSL_MAX(fabs(a),1.0)*fabs(x))
    ) {
    return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
  }
  else if(   x > 0.0
          && size_b > size_a
          && size_a*log(M_E*x/size_b) < GSL_LOG_DBL_EPSILON+7.0
    ) {
    /* Series terms are positive definite up until
     * there is a sign change. But by then the
     * terms are small due to the last condition.
     */
    return gsl_sf_hyperg_1F1_series_e(a, b, x, result);
  }
  else if(   (abs_x < 5.0 && fabs(bma) < 10.0 && abs_b < 10.0)
          || (b > 0.8*GSL_MAX_DBL(fabs(bma),1.0)*abs_x)
    ) {
    /* Use Kummer transformation to render series safe.
     */
    gsl_sf_result Kummer_1F1;
    int stat_K = gsl_sf_hyperg_1F1_series_e(bma, b, -x, &Kummer_1F1);
    int stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
                                      Kummer_1F1.val, Kummer_1F1.err,
                                      result);
    return GSL_ERROR_SELECT_2(stat_e, stat_K);
  }
  else if(   x < -30.0
          && GSL_MAX_DBL(fabs(a),1.0)*GSL_MAX_DBL(fabs(1.0+a-b),1.0) < 0.99*fabs(x)
    ) {
    /* Large negative x asymptotic.
     * Note that we do not check if b-a is a negative integer.
     */
    return hyperg_1F1_asymp_negx(a, b, x, result);
  }
  else if(   x > 100.0
          && GSL_MAX_DBL(fabs(bma),1.0)*GSL_MAX_DBL(fabs(1.0-a),1.0) < 0.99*fabs(x)
    ) {
    /* Large positive x asymptotic.
     * Note that we do not check if a is a negative integer.
     */
    return hyperg_1F1_asymp_posx(a, b, x, result);
  }
  else if(x > 0.0 && !(bma_integer && bma > 0.0)) {
    return hyperg_1F1_U(a, b, x, result);
  }
  else {
    /* FIXME:  if all else fails, try the series... BJG */
    if (x < 0.0) {
      /* Apply Kummer Transformation */
      int status = gsl_sf_hyperg_1F1_series_e(b-a, b, -x, result);
      double K_factor = exp(x);
      result->val *= K_factor;
      result->err *= K_factor;
      return status;
    } else {
      int status = gsl_sf_hyperg_1F1_series_e(a, b, x, result);
      return status;
    }

    /* Sadness... */
    /* result->val = 0.0; */
    /* result->err = 0.0; */
    /* GSL_ERROR ("error", GSL_EUNIMPL); */
  }
}

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

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

  if(x == 0.0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(a == b) {
    return gsl_sf_exp_e(x, result);
  }
  else if(b == 0) {
    DOMAIN_ERROR(result);
  }
  else if(a == 0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(b < 0 && (a < b || a > 0)) {
    /* Standard domain error due to singularity. */
    DOMAIN_ERROR(result);
  }
  else if(x > 100.0  && GSL_MAX_DBL(1.0,fabs(b-a))*GSL_MAX_DBL(1.0,fabs(1-a)) < 0.5 * x) {
    /* x -> +Inf asymptotic */
    return hyperg_1F1_asymp_posx(a, b, x, result);
  }
  else if(x < -100.0 && GSL_MAX_DBL(1.0,fabs(a))*GSL_MAX_DBL(1.0,fabs(1+a-b)) < 0.5 * fabs(x)) {
    /* x -> -Inf asymptotic */
    return hyperg_1F1_asymp_negx(a, b, x, result);
  }
  else if(a < 0 && b < 0) {
    return hyperg_1F1_ab_negint(a, b, x, result);
  }
  else if(a < 0 && b > 0) {
    /* Use Kummer to reduce it to the positive integer case.
     * Note that b > a, strictly, since we already trapped b = a.
     */
    gsl_sf_result Kummer_1F1;
    int stat_K = hyperg_1F1_ab_posint(b-a, b, -x, &Kummer_1F1);
    int stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
                                      Kummer_1F1.val, Kummer_1F1.err,
                                      result);
    return GSL_ERROR_SELECT_2(stat_e, stat_K);
  }
  else {
    /* a > 0 and b > 0 */
    return hyperg_1F1_ab_posint(a, b, x, result);
  }
}

int
gsl_sf_hyperg_1F1_e(const double a, const double b, const double x,
                       gsl_sf_result * result
                       )
{
  const double bma = b - a;
  const double rinta = floor(a + 0.5);
  const double rintb = floor(b + 0.5);
  const double rintbma = floor(bma + 0.5);
  const int a_integer   = ( fabs(a-rinta) < _1F1_INT_THRESHOLD && rinta > INT_MIN && rinta < INT_MAX );
  const int b_integer   = ( fabs(b-rintb) < _1F1_INT_THRESHOLD && rintb > INT_MIN && rintb < INT_MAX );
  const int bma_integer = ( fabs(bma-rintbma) < _1F1_INT_THRESHOLD && rintbma > INT_MIN && rintbma < INT_MAX );
  const int b_neg_integer   = ( b < -0.1 && b_integer );
  const int a_neg_integer   = ( a < -0.1 && a_integer );
  const int bma_neg_integer = ( bma < -0.1 &&  bma_integer );

  /* CHECK_POINTER(result) */

  if(x == 0.0) {
    /* Testing for this before testing a and b
     * is somewhat arbitrary. The result is that
     * we have 1F1(a,0,0) = 1.
     */
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(b == 0.0) {
    DOMAIN_ERROR(result);
  }
  else if(a == 0.0) {
    result->val = 1.0;
    result->err = 0.0;
    return GSL_SUCCESS;
  }
  else if(a == b) {
    /* case: a==b; exp(x)
     * It's good to test exact equality now.
     * We also test approximate equality later.
     */
    return gsl_sf_exp_e(x, result);
  }
  else if(fabs(b) < _1F1_INT_THRESHOLD) {
    /* Note that neither a nor b is zero, since
     * we eliminated that with the above tests.
     */
    if(fabs(a) < _1F1_INT_THRESHOLD) {
      /* a and b near zero: 1 + a/b (exp(x)-1)
       */
      gsl_sf_result exm1;
      int stat_e = gsl_sf_expm1_e(x, &exm1);
      double sa = ( a > 0.0 ? 1.0 : -1.0 );
      double sb = ( b > 0.0 ? 1.0 : -1.0 );
      double lnab = log(fabs(a/b)); /* safe */
      gsl_sf_result hx;
      int stat_hx = gsl_sf_exp_mult_err_e(lnab, GSL_DBL_EPSILON * fabs(lnab),
        				     sa * sb * exm1.val, exm1.err,
        				     &hx);
      result->val = (hx.val == GSL_DBL_MAX ? hx.val : 1.0 + hx.val);  /* FIXME: excessive paranoia ? what is DBL_MAX+1 ?*/
      result->err = hx.err;
      return GSL_ERROR_SELECT_2(stat_hx, stat_e);
    }
    else {
      /* b near zero and a not near zero
       */
      const double m_arg = 1.0/(0.5*b);
      gsl_sf_result F_renorm;
      int stat_F = hyperg_1F1_renorm_b0(a, x, &F_renorm);
      int stat_m = gsl_sf_multiply_err_e(m_arg, 2.0 * GSL_DBL_EPSILON * m_arg,
                                            0.5*F_renorm.val, 0.5*F_renorm.err,
				            result);
      return GSL_ERROR_SELECT_2(stat_m, stat_F);
    }
  }
  else if(a_integer && b_integer) {
    /* Check for reduction to the integer case.
     * Relies on the arbitrary "near an integer" test.
     */
    return gsl_sf_hyperg_1F1_int_e((int)rinta, (int)rintb, x, result);
  }
  else if(b_neg_integer && !(a_neg_integer && a > b)) {
    /* Standard domain error due to
     * uncancelled singularity.
     */
    DOMAIN_ERROR(result);
  }
  else if(a_neg_integer) {
    return hyperg_1F1_a_negint_lag((int)rinta, b, x, result);
  }
  else if(b > 0.0) {
    if(-1.0 <= a && a <= 1.0) {
      /* Handle small a explicitly.
       */
      return hyperg_1F1_small_a_bgt0(a, b, x, result);
    }
    else if(bma_neg_integer) {
      /* Catch this now, to avoid problems in the
       * generic evaluation code.
       */
      gsl_sf_result Kummer_1F1;
      int stat_K = hyperg_1F1_a_negint_lag((int)rintbma, b, -x, &Kummer_1F1);
      int stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
        				    Kummer_1F1.val, Kummer_1F1.err,
        				    result);
      return GSL_ERROR_SELECT_2(stat_e, stat_K);
    }
    else if(a < 0.0) {
      /* Use Kummer to reduce it to the generic positive case.
       * Note that b > a, strictly, since we already trapped b = a.
       * Also b-(b-a)=a, and a is not a negative integer here,
       * so the generic evaluation is safe.
       */
      gsl_sf_result Kummer_1F1;
      int stat_K = hyperg_1F1_ab_pos(b-a, b, -x, &Kummer_1F1);
      int stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
        				    Kummer_1F1.val, Kummer_1F1.err,
        				    result);
      return GSL_ERROR_SELECT_2(stat_e, stat_K);
    }
    else {
      /* a > 0.0 */
      return hyperg_1F1_ab_pos(a, b, x, result);
    }
  }
  else {
    /* b < 0.0 */

    if(bma_neg_integer && x < 0.0) {
      /* Handle this now to prevent problems
       * in the generic evaluation.
       */
      gsl_sf_result K;
      int stat_K;
      int stat_e;
      if(a < 0.0) {
        /* Kummer transformed version of safe polynomial.
	 * The condition a < 0 is equivalent to b < b-a,
	 * which is the condition required for the series
	 * to be positive definite here.
         */
        stat_K = hyperg_1F1_a_negint_poly((int)rintbma, b, -x, &K);
      }
      else {
        /* Generic eval for negative integer a. */
	stat_K = hyperg_1F1_a_negint_lag((int)rintbma, b, -x, &K);
      }
      stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
                                        K.val, K.err,
                                        result);
      return GSL_ERROR_SELECT_2(stat_e, stat_K);
    }
    else if(a > 0.0) {
      /* Use Kummer to reduce it to the generic negative case.
       */
      gsl_sf_result K;
      int stat_K = hyperg_1F1_ab_neg(b-a, b, -x, &K);
      int stat_e = gsl_sf_exp_mult_err_e(x, GSL_DBL_EPSILON * fabs(x),
        				    K.val, K.err,
        				    result);
      return GSL_ERROR_SELECT_2(stat_e, stat_K);
    }
    else {
      return hyperg_1F1_ab_neg(a, b, x, result);
    }
  }
}

#if 0
    /* Luke in the canonical case.
   */
  if(x < 0.0 && !a_neg_integer && !bma_neg_integer) {
    double prec;
    return hyperg_1F1_luke(a, b, x, result, &prec);
  }

  /* Luke with Kummer transformation.
   */
  if(x > 0.0 && !a_neg_integer && !bma_neg_integer) {
    double prec;
    double Kummer_1F1;
    double ex;
    int stat_F = hyperg_1F1_luke(b-a, b, -x, &Kummer_1F1, &prec);
    int stat_e = gsl_sf_exp_e(x, &ex);
    if(stat_F == GSL_SUCCESS && stat_e == GSL_SUCCESS) {
      double lnr = log(fabs(Kummer_1F1)) + x;
      if(lnr < GSL_LOG_DBL_MAX) {
        *result = ex * Kummer_1F1;
	return GSL_SUCCESS;
      }
      else {
        *result = GSL_POSINF;
	GSL_ERROR ("overflow", GSL_EOVRFLW);
      }
    }
    else if(stat_F != GSL_SUCCESS) {
      *result = 0.0;
      return stat_F;
    }
    else {
      *result = 0.0;
      return stat_e;
    }
  }
#endif

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

#include "eval.h"

double gsl_sf_hyperg_1F1_int(const int m, const int n, double x)
{
  EVAL_RESULT(gsl_sf_hyperg_1F1_int_e(m, n, x, &result));
}

double gsl_sf_hyperg_1F1(double a, double b, double x)
{
  EVAL_RESULT(gsl_sf_hyperg_1F1_e(a, b, x, &result));
}


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

#include "allvars.h"
#include "proto.h"

#define WORKSIZE 100000

static double R8;
static double r_tophat;

static double AA, BB, CC;
static double nu;
static double Norm;

static int NPowerTable;

static struct pow_table
{
  double logk, logD;
}
 *PowerTable;

double PowerSpec(double k)
{
  double power = 0;

  switch (WhichSpectrum)
    {
    case 1:
      power = PowerSpec_EH(k);
      break;

    case 2:
      power = PowerSpec_Tabulated(k);
      break;

    default:
      power = PowerSpec_Efstathiou(k);
      break;
    }

  power *= pow(k, PrimordialIndex - 1.0);

  return power;
}

void read_power_table(void)
{
  FILE *fd;
  char buf[500];
  double k, p;

  sprintf(buf, FileWithInputSpectrum);

  if(!(fd = fopen(buf, "r")))
    {
      printf("can't read input spectrum in file '%s' on task %d\n", buf, ThisTask);
      FatalError(17);
    }

  NPowerTable = 0;
  do
    {
      if(fscanf(fd, " %lg %lg ", &k, &p) == 2)

	NPowerTable++;
      else
	break;
    }
  while(1);

  fclose(fd);

  if(ThisTask == 0)
    {
      printf("found %d rows in input spectrum table\n", NPowerTable);
      fflush(stdout);
    }

  PowerTable = malloc(NPowerTable * sizeof(struct pow_table));

  sprintf(buf, FileWithInputSpectrum);

  if(!(fd = fopen(buf, "r")))
    {
      printf("can't read input spectrum in file '%s' on task %d\n", buf, ThisTask);
      FatalError(18);
    }

  NPowerTable = 0;
  do
    {
      double p;

      if(fscanf(fd, " %lg %lg ", &k, &p) == 2)
	{
	  PowerTable[NPowerTable].logk = k;
	  PowerTable[NPowerTable].logD = p;
	  NPowerTable++;
	}
      else
	break;
    }
  while(1);

  fclose(fd);

  qsort(PowerTable, NPowerTable, sizeof(struct pow_table), compare_logk);
}

int compare_logk(const void *a, const void *b)
{
  if(((struct pow_table *) a)->logk < (((struct pow_table *) b)->logk))
    return -1;

  if(((struct pow_table *) a)->logk > (((struct pow_table *) b)->logk))
    return +1;

  return 0;
}

void initialize_powerspectrum(void)
{
  double res;

  InitTime = 1 / (1 + Redshift);

  AA = 6.4 / ShapeGamma * (3.085678e24 / UnitLength_in_cm);
  BB = 3.0 / ShapeGamma * (3.085678e24 / UnitLength_in_cm);
  CC = 1.7 / ShapeGamma * (3.085678e24 / UnitLength_in_cm);
  nu = 1.13;

  R8 = 8 * (3.085678e24 / UnitLength_in_cm);	/* 8 Mpc/h */

  if(WhichSpectrum == 2)
    read_power_table();

  if(ReNormalizeInputSpectrum == 0 && WhichSpectrum == 2)
    {
      Norm = 1.0;
      /* tabulated file is already at the initial redshift */
      Dplus = 1.0;
    }
  else
    {
      Norm = 1.0;
      res = TopHatSigma2(R8);
      if(ThisTask == 0 && WhichSpectrum == 2)
	printf("\nNormalization of spectrum in file:  Sigma8 = %g\n", sqrt(res));

      Norm = Sigma8 * Sigma8 / res;

      if(ThisTask == 0 && WhichSpectrum == 2)
	printf("Normalization adjusted to  Sigma8=%g   (Normfac=%g)\n\n", Sigma8, Norm);

      Dplus = GrowthFactor(InitTime, 1.0);
    }
}

double PowerSpec_Tabulated(double k)
{
  double logk, logD, P, kold, u, dlogk, Delta2;
  int binlow, binhigh, binmid;

  kold = k;

  k *= (InputSpectrum_UnitLength_in_cm / UnitLength_in_cm);	/* convert to h/Mpc */

  logk = log10(k);

  if(logk < PowerTable[0].logk || logk > PowerTable[NPowerTable - 1].logk)
    return 0;

  binlow = 0;
  binhigh = NPowerTable - 1;

  while(binhigh - binlow > 1)
    {
      binmid = (binhigh + binlow) / 2;
      if(logk < PowerTable[binmid].logk)
	binhigh = binmid;
      else
	binlow = binmid;
    }

  dlogk = PowerTable[binhigh].logk - PowerTable[binlow].logk;

  if(dlogk == 0)
    FatalError(777);

  u = (logk - PowerTable[binlow].logk) / dlogk;

  logD = (1 - u) * PowerTable[binlow].logD + u * PowerTable[binhigh].logD;

  Delta2 = pow(10.0, logD);

  P = Norm * Delta2 / (4 * M_PI * kold * kold * kold);

  return P;
}

double PowerSpec_Efstathiou(double k)
{
  return Norm * k / pow(1 + pow(AA * k + pow(BB * k, 1.5) + CC * CC * k * k, nu), 2 / nu);
}

double PowerSpec_EH(double k)	/* Eisenstein & Hu */
{
  return Norm * k * pow(tk_eh(k), 2);
}

double tk_eh(double k)		/* from Martin White */
{
  double q, theta, ommh2, a, s, gamma, L0, C0;
  double tmp;
  double omegam, ombh2, hubble;

  /* other input parameters */
  hubble = HubbleParam;

  omegam = Omega;
  ombh2 = OmegaBaryon * HubbleParam * HubbleParam;

  if(OmegaBaryon == 0)
    ombh2 = 0.04 * HubbleParam * HubbleParam;

  k *= (3.085678e24 / UnitLength_in_cm);	/* convert to h/Mpc */

  theta = 2.728 / 2.7;
  ommh2 = omegam * hubble * hubble;
  s = 44.5 * log(9.83 / ommh2) / sqrt(1. + 10. * exp(0.75 * log(ombh2))) * hubble;
  a = 1. - 0.328 * log(431. * ommh2) * ombh2 / ommh2
    + 0.380 * log(22.3 * ommh2) * (ombh2 / ommh2) * (ombh2 / ommh2);
  gamma = a + (1. - a) / (1. + exp(4 * log(0.43 * k * s)));
  gamma *= omegam * hubble;
  q = k * theta * theta / gamma;
  L0 = log(2. * exp(1.) + 1.8 * q);
  C0 = 14.2 + 731. / (1. + 62.5 * q);
  tmp = L0 / (L0 + C0 * q * q);
  return (tmp);
}

double TopHatSigma2(double R)
{
  double result, abserr;
  gsl_integration_workspace *workspace;
  gsl_function F;

  workspace = gsl_integration_workspace_alloc(WORKSIZE);

  F.function = &sigma2_int;

  r_tophat = R;

  gsl_integration_qag(&F, 0, 500.0 * 1 / R,
		      0, 1.0e-4, WORKSIZE, GSL_INTEG_GAUSS41, workspace, &result, &abserr);

  gsl_integration_workspace_free(workspace);

  return result;

  /* note: 500/R is here chosen as (effectively) infinity integration boundary */
}

double sigma2_int(double k, void *param)
{
  double kr, kr3, kr2, w, x;

  kr = r_tophat * k;
  kr2 = kr * kr;
  kr3 = kr2 * kr;

  if(kr < 1e-8)
    return 0;

  w = 3 * (sin(kr) / kr3 - cos(kr) / kr2);
  x = 4 * PI * k * k * w * w * PowerSpec(k);

  return x;
}

double GrowthFactor(double astart, double aend)
{
  return growth(aend) / growth(astart);
}

double growth(double a)
{
  double hubble_a;

  hubble_a = sqrt(Omega / (a * a * a) + (1 - Omega - OmegaLambda) / (a * a) + OmegaLambda);

  double result, abserr;
  gsl_integration_workspace *workspace;
  gsl_function F;

  workspace = gsl_integration_workspace_alloc(WORKSIZE);

  F.function = &growth_int;

  gsl_integration_qag(&F, 0, a, 0, 1.0e-8, WORKSIZE, GSL_INTEG_GAUSS41, workspace, &result, &abserr);

  gsl_integration_workspace_free(workspace);

  return hubble_a * result;
}

double growth_int(double a, void *param)
{
  return pow(a / (Omega + (1 - Omega - OmegaLambda) * a + OmegaLambda * a * a * a), 1.5);
}

double F_Omega(double a)
{
  double omega_a;

  omega_a = Omega / (Omega + a * (1 - Omega - OmegaLambda) + a * a * a * OmegaLambda);

  return pow(omega_a, 0.6);
}


// Sammlung verwendeter Funktionen
#include "global.h"
#include "steppmethods.h"
#include "targets.h"
#include <gsl/gsl_cblas.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_randist.h>
#include <gsl/gsl_sf_gamma.h>
#include <math.h>
#include <stdio.h>
#include "utility.h"
#include <string.h>
#include <time.h>
#include <omp.h>

double Norm_Diff(double *vec1,double *vec2, int dim, int p) //berechnet norm von || vec1-vec2 ||_p
{
	double result = 0.0d;
	double temp;
	if (p == 1)
	{
		for (int i = 0; i < DIM; i++)
		{
			result += fabs(vec1[i] - vec2[i]);
		}
		return(result);
	}
	if (p == 2)
	{
		for (int i = 0; i < DIM; i++)
		{
			result += pow(vec1[i] - vec2[i],2.0);
		}
		return(sqrt(result));
	}
	if (p == 0)
	{
		for (int i = 0; i < DIM; i++)
		{
			temp = fabs(vec1[i] - vec2[i]);
			if (result < temp)
			{
				result = temp;
			}
		}
		return(result);
	}
	return (0.0f);
}

void Lattice_Setup(double **positions,int  numbertoinf,int dim, double latticespacing) // puts coordinates into lattice matrix of dimension numbertoinf**dim, dim
{
	printf("setze Gitter auf \n");
	int m = -numbertoinf + 1;
	int l = -numbertoinf + 1;
	int count = 0;
	while(count<ipow(numbertoinf,dim))
	{
		if (m> (numbertoinf - 1) ) // if over line, restart
		{
			m = -numbertoinf +1;
			l = l + 2;
		}
		positions[count][0] = m * latticespacing/2;
		positions[count][1] = l * latticespacing/2;
		m = m + 2;
		count = count +1;
	}
	printf("Gitter aufgesetzt \n");
}

int ipow(int base, int exp) // I^p for integer i
{
	int result = 1;
	if(		(base < 0)\
		||	(exp < 0))
	{
		printf("wrong base or exponent, smaller zero!\n");
		exit;
	}
	while (exp)
	{
		if (exp & 1)
			result *= base;
		exp >>= 1;
		base *= base;
	}
	return result;
}

int Kahan_Sum(int N, double input[], double *ans){  // Add elements via Kahan summation, code is pretty much Wikipedia copy paste
	int i;
	double y,t,sum = 0.0d;
    double c = 0.0d;                 // A running compensation for lost low-order bits.
    for (i=0; i<N; i++){
        y = input[i] - c;	    // So far, so good: c is zero.
        t = sum + y;         	// Alas, sum is big, y small, so low-order digits of y are lost.
        c = (t - sum) - y;       // (t - sum) cancels the high-order part of y; subtracting y recovers negative (low part of y)
        sum = t;                 // Algebraically, c should always be zero. Beware overly-aggressive optimizing compilers!
    }                      		// Next time around, the lost low part will be added to y in a fresh attempt.
    *ans  = (sum);
    return 0;
}

int Sign_Sum(int N, double *input, double *ans){  // Add seperated by sign
	int i;
	double sum = 0.0, negsum = 0.0;
	for (i=0; i<N; i++){
		if(input[i]<0.0) negsum += input[i];
		if(input[i]>=0.0) sum += input[i];
	}
	*ans = sum + negsum;
	return 0;
}

int Neumaier_Sum(int N, double input[N], double *ans){  // Add elements of input by Neumaier summation
	int i;
	double t,sum = input[0];
    double c = 0.0;                 // A running compensation for lost low-order bits.
    for (i=1; i<N; i++){
    	t = sum + input[i];
    	if (fabs(sum)>=fabs(input[i]))
    	{
        	c += (sum - t) + input[i]; // If sum is bigger, low-order digits of input[i] are lost.
        } else
        {
            c += (input[i] - t) + sum; // Else low-order digits of sum are lost
        }
        sum = t;
    }                      // Next time around, the lost low part will be added to y in a fresh attempt.
    *ans = (sum + c);         // Correction only applied once in the very end
    return 0;
}

void deleteSpaces(char src[], char dst[]){      // deletes spaces from string
   // src is supposed to be zero ended
   // dst is supposed to be large enough to hold src
	int s, d=0;
	for (s=0; src[s] != 0; s++)
		if (src[s] != ' ')
		{
			dst[d] = src[s];
			if (dst[d] == ':')
			{
				dst[d] = '_';
			}
			d++;
		}

		dst[d] = 0;
	}

void vec_zero(double *v,int  N){ // zero target vector of double
	int i;
	for (i= 0 ; i < N; i++)
	{
		v[i] = 0.0;
	}

}
void vec_zero_i(int *v,int  N){ // zero target vector of ints
	int i;
	for (i= 0 ; i < N; i++)
	{
		v[i] = 0;
	}

}
void zero_Impuls(double *v)
{ 								// zero target vector of momenta
	double P[OSSZI + 1];
	double sum;
	double OS = OSSZI * 1.0;
	for (int j = 0; j < DIM; j++)
	{
		for (int i = 0; i < OSSZI; i++)
		{
			P[i] = v[DIM + i * DIM + j];
		}
		P[OSSZI] = v[j] * mass;
		Sum_Method(OSSZI+1,P,&sum);
		for (int i = 0; i < OSSZI; i++)
		{
			v[DIM + i * DIM + j] -= sum/( OS  + 1.0);
		}
		v[j] -= sum/( OS  + 1.0) /mass;
	}
}

int Update_Lattice_Position(int * pos, const  double *vec, const double lattice_spacing){ // updatet Int-Vector pos when leaving square lattice cell

	int ret_val = 0;			// return zero if no update neccessary, -1 if out of bounds
	for (int j = 0; j< DIM; j++)
	{
		int trigger = 1;
		while(trigger)
		{
			if (vec[j]< pos[j]*lattice_spacing - lattice_spacing/2.0)
			{
				pos[j]-=1;
				trigger = 1;
				ret_val = 1;
			}else
			{
				trigger = 0;
			}
			if (vec[j]> pos[j]*lattice_spacing + lattice_spacing/2.0)
			{
				pos[j]+=1;
				trigger = 1;
				ret_val = 1;
			}else
			{
				trigger = 0;
			}
		}
	}
	if ((abs(pos[0])> NUMBER_TO_INF) || (abs(pos[1])> NUMBER_TO_INF))
	{
		printf(" \n particle out of bounds");
		FLAG_DUMP_VALUE = 1;											// error occured
		return(-1);
	}
	return(ret_val);
}

void VVerlet(int N, double *y, double **ans, double *t,							// Velocity Verlet for Start y, return ans[LengthT][ORDER] to times T
				void (*derivmethod) (double *y, double *ans, double t, int N)){
	int i,j;
	for(i=0; i< N; i++){
	ans[0][i] = y[i];  				// give initial vec to answer
	}
	double x[N/2], v[N/2], a[N/2], z[N];
	vec_zero(x,N/2);
	vec_zero(v,N/2);
	vec_zero(a,N/2);
	vec_zero(z,N);
	int current_index = 0;
	double current_t = t[current_index];
	derivmethod(y, z, current_t, N); 				// get first derivative
	for (j = 0; j < DIM; j++ )						// bring y-p  Form to x-v-a
	{
		x[j] = y[j];
		v[j] = y[DIM + j]/mass;
		a[j] = z[DIM + j]/mass;
		#pragma omp parallel for
		for (i= 0 ; i < OSSZI; i++)
		{
					x[DIM + j + i*DIM] = y[2*DIM + j + i * 2*DIM];
					v[DIM + j + i*DIM] = y[3*DIM + j + i * 2*DIM]/massq[i];
					a[DIM + j + i*DIM] = z[3*DIM + j + i * 2*DIM]/massq[i];
		}
	}

	while(current_index < LENGTH_T-1)
	{
		while(fabs(current_t - t[current_index + 1])> MAXSTEPSIZE)
		{ 	//integrate till space till next time smaller than stepsize
			Stepper_Method(N, x, v, a, &current_t, derivmethod);
		}
												// get to y-Form
		current_index = current_index +1;
		for (j = 0; j < DIM; j++ )
		{
			ans[current_index][DIM + j] = mass * v[j];
			ans[current_index][j] 	    = x[j];
			#pragma omp parallel for
			for (i= 0 ; i < OSSZI; i++)
			{
						ans[current_index][2*DIM + j + i * 2*DIM] = x[DIM +j+  i*DIM];
						ans[current_index][3*DIM + j + i * 2*DIM] = v[DIM +j+  i*DIM] * massq[i]; // übergib SChritt an antwort
			}
		}
	}

}

void VVerlet_parallel(const int N, const  double *y, double **ans, double *t,							// Velocity Verlet for Start y, return ans[LengthT][ORDER] to times T
				void (*derivmethod) (double *y, double *ans, double t, int N)){
	int i,j;
	for(i=0; i< N; i++){
	ans[0][i] = y[i];  				// give initial vec to answer
	}
	TARGET_FLAG = 1;
	double x[N/2], v[N/2], a[N/2], z[N];
	vec_zero(x,N/2);
	vec_zero(v,N/2);
	vec_zero(a,N/2);
	vec_zero(z,N);
	int current_index = 0;
	double current_t = t[current_index];
	derivmethod(y, z, current_t, N); 						// giv f'
	int steps_in_intervall = 0;						// counts steps done in intervall  t, t+ dt
	int max_steps_in_intervall = 100000;			// after X steps, assume error occured
	for (j = 0; j < DIM; j++ )						//  y-p  --> x-v-a form
	{
		x[j] = y[j];
		VIRTUAL_X[j] = x[j];
		v[j] = y[DIM + j]/mass;
		VIRTUAL_V[j] = v[j];
		a[j] = z[DIM + j]/mass;
	}

	#pragma omp parallel for
	for (i= 0 ; i < OSSZI; i++)
	{
		for (j = 0; j < DIM; j++ )
		{
			x[DIM + j + i*DIM] = y[2*DIM + j + i * 2*DIM];
			v[DIM + j + i*DIM] = y[3*DIM + j + i * 2*DIM]/massq[i];
			a[DIM + j + i*DIM] = z[3*DIM + j + i * 2*DIM]/massq[i];
		}
	}
	LASTSTEPSIZE = MAXSTEPSIZE;
	while(current_index < LENGTH_T-1)
	{
		while(fabs(current_t - t[current_index + 1])> MAXSTEPSIZE)			//integrate till space till next time smaller than stepsize
		{
			Stepper_Method(N, x, v, a, &current_t, derivmethod);
			steps_in_intervall++;
			if(steps_in_intervall > max_steps_in_intervall)
			{
				FLAG_DUMP_VALUE  = 1;										// too many steps, error occured
				printf("too many steps taken to advance one time point \n");
			}
			if (FLAG_DUMP_VALUE) 											// if error occured somewhere leave calculation
			{
				return;
			}
		}
		steps_in_intervall = 0; 				// reset stepcount
		current_index = current_index +1;		// get  back to y-form
		for (j = 0; j < DIM; j++ )
		{
			if(VIRTUAL_FLAG)
			{
				ans[current_index][DIM + j] = mass * VIRTUAL_V[j];
				ans[current_index][j] 	    = VIRTUAL_X[j];
			}else
			{
				ans[current_index][DIM + j] = mass * v[j];
				ans[current_index][j] 	    = x[j];
			}
		}
		#pragma omp parallel for
		for (i= 0 ; i < OSSZI; i++)
		{
			for (j = 0; j < DIM; j++ )
			{
				ans[current_index][2*DIM + j + i * 2*DIM] = x[DIM +j+  i*DIM];
				ans[current_index][3*DIM + j + i * 2*DIM] = v[DIM +j+  i*DIM] * massq[i] ; // give step to answer
			}
		}
	}
	if (TARGET_FLAG)		// if no contact, give simulation length as contact time
	{
		time_first_contact += TIME_END;
		TARGET_FLAG = 0;
	}
}

void VVerlet_parallel_burn(const int N, const  double *y, double **ans, double *t,							// Velocity Verlet für Start y, Ausgabe ans[LengthT][ORDER] zu Zeiten T
				void (*derivmethod) (double *y, double *ans, double t, int N))
// always involes free particle for burning samples
{
	int i,j;
	for(i=0; i< N; i++){
	ans[0][i] = y[i];  				// übergib startvektor an antwort
	}
	TARGET_FLAG = 1;
	double x[N/2], v[N/2], a[N/2], z[N];
	vec_zero(x,N/2);
	vec_zero(v,N/2);
	vec_zero(a,N/2);
	vec_zero(z,N);
	int current_index = 0;
	double current_t = t[current_index];
	derivmethod(y, z, current_t, N); 				// übergib erste Ableitung
	// bringe aus y-p y Form auf x-v-a
	for (j = 0; j < DIM; j++ )
	{
		x[j] = y[j];
		v[j] = y[DIM + j]/mass;
		a[j] = z[DIM + j]/mass;
	}
	#pragma omp parallel for
	for (i= 0 ; i < OSSZI; i++)
	{
		for (j = 0; j < DIM; j++ )
		{
			x[DIM + j + i*DIM] = y[2*DIM + j + i * 2*DIM];
			v[DIM + j + i*DIM] = y[3*DIM + j + i * 2*DIM]/massq[i];
			a[DIM + j + i*DIM] = z[3*DIM + j + i * 2*DIM]/massq[i];
		}
	}

	while(current_index < LENGTH_T-1)
	{
		while(fabs(current_t - t[current_index + 1])> MAXSTEPSIZE)
		{ 	//integriere bis abstand zu  nächstem t kleiner schrittweite
			VVerlet_Step_deriv(N, x, v, a, &current_t, derivmethod);
			//printf ("%fx      %ft  \n", x[1], current_t);
		}
												// rechne wieder auf y-Form
		current_index = current_index +1;
		for (j = 0; j < DIM; j++ )
		{
			ans[current_index][DIM + j] = mass * v[j];
			ans[current_index][j] 	    = x[j];
		}
		#pragma omp parallel for
		for (i= 0 ; i < OSSZI; i++)
		{
			for (j = 0; j < DIM; j++ )
			{
				ans[current_index][2*DIM + j + i * 2*DIM] = x[DIM +j+  i*DIM];
				ans[current_index][3*DIM + j + i * 2*DIM] = v[DIM +j+  i*DIM] * massq[i]; // übergib SChritt an antwort
			}
		}
	}
	if (TARGET_FLAG)		// FAlls kein erstkontakt addiere gesamtzeit
	{
		time_first_contact += TIME_END;
		TARGET_FLAG = 0;
	}
}

void Bath_Setup(double *y, char *inputlabel, gsl_rng * r){
	int a,b,i;
	double u,P[OSSZI], sum=0.0;

	if (strcmp(inputlabel,"ZWANZIG")==0)
	{
		for (b = 0; b < DIM; b++)
		{
			y[b] = 0.0;					//massives particle seperatly
			y[DIM+b] = 0.0;
			for (a = 0; a < OSSZI; a++)
			{
				u = gsl_ran_gaussian(r, 1.0);
				y[2*DIM + a * 2*DIM + b] = sqrt(KBOLTZ * TEMP / massq[a]) / ommega[a] * u; 	//q = (k*T/m)^0.5/ommega * N(0,1)
				u = gsl_ran_gaussian(r, 1.0);
				y[3*DIM + a * 2*DIM + b] = sqrt(KBOLTZ * TEMP * massq[a]) * u;			//p_q = (k*T*m)^0.5 * N(0,1)
			}
		}
		return;
	}
	if (strcmp(inputlabel,"ZWANZIG_THERMALIZED")==0)
	{
		for (b = 0; b < DIM; b++)
		{
			y[b] = 0.0;					//massives particle seperatly
			u = gsl_ran_gaussian(r, 1.0);
			y[DIM+b] =  sqrt(KBOLTZ * TEMP * mass) * u;			//p_q = (k*T*m)^0.5 * N(0,1)
			for (a = 0; a < OSSZI; a++)
			{
				u = gsl_ran_gaussian(r, 1.0);
				y[2*DIM + a * 2*DIM + b] = sqrt(KBOLTZ * TEMP / massq[a]) / ommega[a] * u; 	//q = (k*T/m)^0.5/ommega * N(0,1)
				u = gsl_ran_gaussian(r, 1.0);
				y[3*DIM + a * 2*DIM + b] = sqrt(KBOLTZ * TEMP * massq[a]) * u;			//p_q = (k*T*m)^0.5 * N(0,1)
			}
		}
		return;
	}
	printf("FALSCHES BADLABEL");
	exit(1);
}

void Ommega_Setup(gsl_rng * r)
{

 															// draw uniformly nonrandom
	double nr_osszillators = 1.0 * OSSZI; 					// cast Osszi to double
	double higher_cutoff = 1.0/(0.5 * TIME_STEPS); 			//cleanly resolve smallest steps
	double lower_cutoff = 1.0/(1.6 * TIME_END); 			//cleanly resolve till end time

	higher_cutoff = 5.0* pow( (GAMMA/mass), 1.0/(2.0-ALPHA));
	lower_cutoff = 5E-5;
	double ommega_step = (higher_cutoff - lower_cutoff)/(nr_osszillators);
	for (int i = 0; i < OSSZI; i++)
	{
		ommega[i] = lower_cutoff + i * ommega_step;
	}
	printf("\nnonrandom bath ");
	printf ("Ommega_Max =   %1.3e  ", ommega[OSSZI-1] );
	printf ("Ommega_Min =   %1.3e\n", ommega[0] );
}

void Gamma_Setup(double *gamma){ 						//Set coupling for Exponent Alpha so that MSD s^2 prop to
														//t^ALPHA,  ALPHA = 1 (classical diff) seperately
														// put constants in gamma
	int i;
	double TOL = 1e-3;
	double nr_osz = (double) OSSZI;
	double delta_ommega = ommega[1]-ommega[0];
	if (! (KUPF_BINARY))
	{
		if (fabs(ALPHA-1.0)<TOL){  // Alpha = 1
		for(i = 0; i < OSSZI; i++)
		{
			gamma[i] = sqrt(GAMMA) * ommega[i] * sqrt(delta_ommega);
		}
		if (OUTPUT_FLAG)
		{
			printf("ALPHA rounded to 1 \n");
		}
		}
		if (fabs(ALPHA-1.0)>TOL){
			for(i = 0; i < OSSZI; i++)
			{
				gamma[i] = sqrt(GAMMA) * pow(ommega[i], 0.5 + ALPHA * 0.5)\
				* sqrt( 2/sqrt(M_PI * 2) * sin(M_PI * ALPHA/2.0) * gsl_sf_gamma(1 - ALPHA)) * sqrt(delta_ommega);
			}
		}
		if (OUTPUT_FLAG)
		{
			printf("Konstanten aufgesetzt für Alpha =  %f \n " , ALPHA);
		}
	}else
	{
		if (fabs(ALPHA-1.0)<TOL)	// Alpha = 1
		{
			for(i = 0; i < OSSZI; i++)
			{

				gamma[i] = 1.0 / sqrt(2.0 * M_PI) * GAMMA * (delta_ommega);
			}
			printf("Konstanten aufgesetzt für KUPF_A rounded to 1  \n " );
		}else
		{
			for(i = 0; i < OSSZI; i++)
			{

				gamma[i] = 1.0 / sqrt(2.0 * M_PI) * GAMMA  * gsl_sf_gamma(1 - ALPHA)\
				* sin(M_PI * ALPHA/2.0) * pow(ommega[i], ALPHA - 1.0) * (delta_ommega);
			}
			printf("Konstanten aufgesetzt für KUPF_A = %2.2f  \n ", ALPHA );
		}

	}
}

void deriv(double *yin, double *ans, double t, int N){ 		// Hamiltonian derivative

	int i,j;
	double P[OSSZI], Q[OSSZI], temp_vec[OSSZI];
	double sum;

	for(j = 0; j < DIM; j++)
	{
		#pragma omp parallel for
		for(i = 0; i < OSSZI; i++)
		{
			Q[i] = yin[(2 + i * 2)  * DIM  + j ];  //get P und Q for easier indexing
			P[i] = yin[(3 + i * 2)  * DIM  + j ];
		}
		sum = 0.0;
		#pragma omp parallel for
		for (i = 0 ; i < OSSZI; i++)
		{ // Sum
			if(KUPF_BINARY)
			{
				temp_vec[i] = -coupling[i] * (Q[i] - yin[j]);

			}else
			{
				temp_vec[i] = coupling[i] * Q[i] - pow(coupling[i],2.0)/pow(ommega[i],2.0) * yin[j];
			}

		}
		Sum_Method(OSSZI, temp_vec, &sum);
		ans[j] = yin[DIM+ j]/mass;  // dx/dx = p/m
		ans[DIM+j] = sum  ;   	//p-deriv
		#pragma omp parallel for
		for (i = 0 ; i < OSSZI; i++)
		{
			ans[(2 + i * 2)  * DIM  + j ] = P[i]/massq[i];      		// dq/dt = p_q/m_q
			if(KUPF_BINARY)
			{
				ans[(3 + i * 2)  * DIM  + j ] =  coupling[i] * (Q[i] - yin[j]); 		// dp_q/dt = -w^2 * q+ gamma * x

			}else
			{
				ans[(3 + i * 2)  * DIM  + j ] = - ommega[i] * ommega[i] * Q[i]  + coupling[i] * yin[j]; 		// dp_q/dt = -w^2 * q+ gamma * x

			}

		}
	}
}

void deriv_parallel(const double *yin, double *ans, double t, int N)		// deriv with i-j loops reversed for parralelization
{ 		// Ableitungsfunktion
	int i,j;
	double temp_vec[OSSZI];
	double sum;

	#pragma omp parallel for 		// Values for Bath particles parralized
	for (i = 0 ; i < OSSZI; i++)
	{
		for(j = 0; j < DIM; j++)
		{
			ans[(2 + i * 2)  * DIM  + j ] = yin[(3 + i * 2)  * DIM  + j ]/massq[i];      		// dq/dt = p_q/m_q
			if(KUPF_BINARY)
			{
				ans[(3 + i * 2)  * DIM  + j ] =  -coupling[i] *  (yin[(2 + i * 2)  * DIM  + j] - yin[j]); 		// dp_q/dt = -w^2 * q+ gamma * x
			}else
			{
				ans[(3 + i * 2)  * DIM  + j ] = - ommega[i] * ommega[i] * yin[(2 + i * 2)  * DIM  + j]\
										  + coupling[i] * yin[j]; 		// dp_q/dt = -w^2 * q+ gamma * x
			}
		}
	}

	for(j = 0; j < DIM; j++)		// Values for heavy particle
	{

		sum = 0.0;
		#pragma omp parallel for
		for (i = 0 ; i < OSSZI; i++)
		{ // berechne die Summe

			if(KUPF_BINARY)
			{
				temp_vec[i] =  coupling[i] *  (yin[(2 + i * 2)  * DIM  + j] - yin[j]); 		// dp_q/dt = -w^2 * q+ gamma * x
			}else
			{
				temp_vec[i] = coupling[i] * yin[(2 + i * 2)  * DIM  + j]\
						 - pow(coupling[i],2.0)/pow(ommega[i],2.0) * yin[j];  // for Kahan summation : vec gamma^2/ommega^2
			}
		}
		Sum_Method(OSSZI, temp_vec, &sum);
		ans[j] = yin[DIM+ j]/mass;  // dx/dx = p/m
		ans[DIM+j] = sum  ;   	//p-deriv
	}
}


// Copyright (c) 2017, Lawrence Livermore National Security, LLC. Produced at
// the Lawrence Livermore National Laboratory. LLNL-CODE-734707. All Rights
// reserved. See files LICENSE and NOTICE for details.
//
// This file is part of CEED, a collection of benchmarks, miniapps, software
// libraries and APIs for efficient high-order finite element and spectral
// element discretizations for exascale applications. For more information and
// source code availability see http://github.com/ceed.
//
// The CEED research is supported by the Exascale Computing Project 17-SC-20-SC,
// a collaborative effort of two U.S. Department of Energy organizations (Office
// of Science and the National Nuclear Security Administration) responsible for
// the planning and preparation of a capable exascale ecosystem, including
// software, applications, hardware, advanced system engineering and early
// testbed platforms, in support of the nation's exascale computing imperative.

//                        libCEED + PETSc Example: Surface Area
//
// This example demonstrates a simple usage of libCEED with PETSc to calculate
// the surface area of a simple closed surface, such as the one of a cube or a
// tensor-product discrete sphere via the mass operator.
//
// The code uses higher level communication protocols in DMPlex.
//
// Build with:
//
//     make area [PETSC_DIR=</path/to/petsc>] [CEED_DIR=</path/to/libceed>]
//
// Sample runs:
//   Sequential:
//
//     ./area -problem cube -degree 3 -dm_refine 2
//     ./area -problem sphere -degree 3 -dm_refine 2
//
//   In parallel:
//
//     mpiexec -n 4 ./area -problem cube -degree 3 -dm_refine 2
//     mpiexec -n 4 ./area -problem sphere -degree 3 -dm_refine 2
//
//   The above example runs use 2 levels of refinement for the mesh.
//   Use -dm_refine k, for k levels of uniform refinement.
//
//TESTARGS -ceed {ceed_resource} -test -degree 3 -dm_refine 1

/// @file
/// libCEED example using the mass operator to compute a cube or a cubed-sphere surface area using PETSc with DMPlex
static const char help[] =
  "Compute surface area of a cube or a cubed-sphere using DMPlex in PETSc\n";

#include <stdbool.h>
#include <string.h>
#include <ceed.h>
#include <petsc.h>
#include <petscdmplex.h>

#include "area.h"
#include "include/areaproblemdata.h"
#include "include/petscutils.h"
#include "include/petscversion.h"
#include "include/matops.h"
#include "include/structs.h"
#include "include/libceedsetup.h"

#if PETSC_VERSION_LT(3,12,0)
#ifdef PETSC_HAVE_CUDA
#include <petsccuda.h>
// Note: With PETSc prior to version 3.12.0, providing the source path to
//       include 'cublas_v2.h' will be needed to use 'petsccuda.h'.
#endif
#endif

#ifndef M_PI
#  define M_PI 3.14159265358979323846
#endif

int main(int argc, char **argv) {
  PetscInt ierr;
  MPI_Comm comm;
  char filename[PETSC_MAX_PATH_LEN],
       ceed_resource[PETSC_MAX_PATH_LEN] = "/cpu/self";
  PetscInt l_size, g_size, xl_size,
           q_extra     = 1, // default number of extra quadrature points
           num_comp_x  = 3, // number of components of 3D physical coordinates
           num_comp_u  = 1, // dimension of field to which apply mass operator
           topo_dim    = 2, // topological dimension of manifold
           degree      = 3; // default degree for finite element bases
  PetscBool read_mesh = PETSC_FALSE,
            test_mode = PETSC_FALSE,
            simplex = PETSC_FALSE;
  Vec U, U_loc, V, V_loc;
  DM  dm;
  UserO user;
  Ceed ceed;
  CeedData ceed_data;
  ProblemType problem_choice;
  VecType vec_type;
  PetscMemType mem_type;

  ierr = PetscInitialize(&argc, &argv, NULL, help);
  if (ierr) return ierr;
  comm = PETSC_COMM_WORLD;

  // Read command line options
  ierr = PetscOptionsBegin(comm, NULL, "CEED surface area problem with PETSc",
                           NULL);
  CHKERRQ(ierr);
  problem_choice = SPHERE;
  ierr = PetscOptionsEnum("-problem",
                          "Problem to solve", NULL,
                          problem_types, (PetscEnum)problem_choice,
                          (PetscEnum *)&problem_choice,
                          NULL); CHKERRQ(ierr);
  ierr = PetscOptionsInt("-q_extra", "Number of extra quadrature points",
                         NULL, q_extra, &q_extra, NULL); CHKERRQ(ierr);
  ierr = PetscOptionsString("-ceed", "CEED resource specifier",
                            NULL, ceed_resource, ceed_resource,
                            sizeof(ceed_resource), NULL); CHKERRQ(ierr);
  ierr = PetscOptionsBool("-test",
                          "Testing mode (do not print unless error is large)",
                          NULL, test_mode, &test_mode, NULL); CHKERRQ(ierr);
  ierr = PetscOptionsString("-mesh", "Read mesh from file", NULL,
                            filename, filename, sizeof(filename), &read_mesh);
  CHKERRQ(ierr);
  ierr = PetscOptionsBool("-simplex", "Use simplices, or tensor product cells",
                          NULL, simplex, &simplex, NULL); CHKERRQ(ierr);
  ierr = PetscOptionsInt("-degree", "Polynomial degree of tensor product basis",
                         NULL, degree, &degree, NULL); CHKERRQ(ierr);
  ierr = PetscOptionsEnd(); CHKERRQ(ierr);

  // Setup DM
  if (read_mesh) {
    ierr = DMPlexCreateFromFile(PETSC_COMM_WORLD, filename, NULL, PETSC_TRUE,
                                &dm);
    CHKERRQ(ierr);
  } else {
    // Create the mesh as a 0-refined sphere. This will create a cubic surface, not a box
    ierr = DMPlexCreateSphereMesh(PETSC_COMM_WORLD, topo_dim, simplex, 1., &dm);
    CHKERRQ(ierr);
    // Set the object name
    ierr = PetscObjectSetName((PetscObject)dm, problem_types[problem_choice]);
    CHKERRQ(ierr);
    // Distribute mesh over processes
    {
      DM dm_dist = NULL;
      PetscPartitioner part;

      ierr = DMPlexGetPartitioner(dm, &part); CHKERRQ(ierr);
      ierr = PetscPartitionerSetFromOptions(part); CHKERRQ(ierr);
      ierr = DMPlexDistribute(dm, 0, NULL, &dm_dist); CHKERRQ(ierr);
      if (dm_dist) {
        ierr = DMDestroy(&dm); CHKERRQ(ierr);
        dm  = dm_dist;
      }
    }
    // Refine DMPlex with uniform refinement using runtime option -dm_refine
    ierr = DMPlexSetRefinementUniform(dm, PETSC_TRUE); CHKERRQ(ierr);
    ierr = DMSetFromOptions(dm); CHKERRQ(ierr);
    if (problem_choice == SPHERE) {
      ierr = ProjectToUnitSphere(dm); CHKERRQ(ierr);
    }
    // View DMPlex via runtime option
    ierr = DMViewFromOptions(dm, NULL, "-dm_view"); CHKERRQ(ierr);
  }

  // Create DM
  ierr = SetupDMByDegree(dm, degree, num_comp_u, topo_dim, false,
                         (BCFunction)NULL);
  CHKERRQ(ierr);

  // Create vectors
  ierr = DMCreateGlobalVector(dm, &U); CHKERRQ(ierr);
  ierr = VecGetLocalSize(U, &l_size); CHKERRQ(ierr);
  ierr = VecGetSize(U, &g_size); CHKERRQ(ierr);
  ierr = DMCreateLocalVector(dm, &U_loc); CHKERRQ(ierr);
  ierr = VecGetSize(U_loc, &xl_size); CHKERRQ(ierr);
  ierr = VecDuplicate(U, &V); CHKERRQ(ierr);
  ierr = VecDuplicate(U_loc, &V_loc); CHKERRQ(ierr);

  // Setup user structure
  ierr = PetscMalloc1(1, &user); CHKERRQ(ierr);

  // Set up libCEED
  CeedInit(ceed_resource, &ceed);
  CeedMemType mem_type_backend;
  CeedGetPreferredMemType(ceed, &mem_type_backend);

  ierr = DMGetVecType(dm, &vec_type); CHKERRQ(ierr);
  if (!vec_type) { // Not yet set by user -dm_vec_type
    switch (mem_type_backend) {
    case CEED_MEM_HOST: vec_type = VECSTANDARD; break;
    case CEED_MEM_DEVICE: {
      const char *resolved;
      CeedGetResource(ceed, &resolved);
      if (strstr(resolved, "/gpu/cuda")) vec_type = VECCUDA;
      else if (strstr(resolved, "/gpu/hip/occa"))
        vec_type = VECSTANDARD; // https://github.com/CEED/libCEED/issues/678
      else if (strstr(resolved, "/gpu/hip")) vec_type = VECHIP;
      else vec_type = VECSTANDARD;
    }
    }
    ierr = DMSetVecType(dm, vec_type); CHKERRQ(ierr);
  }

  // Print summary
  if (!test_mode) {
    PetscInt P = degree + 1, Q = P + q_extra;
    const char *used_resource;
    CeedGetResource(ceed, &used_resource);
    ierr = PetscPrintf(comm,
                       "\n-- libCEED + PETSc Surface Area of a Manifold --\n"
                       "  libCEED:\n"
                       "    libCEED Backend                    : %s\n"
                       "    libCEED Backend MemType            : %s\n"
                       "  Mesh:\n"
                       "    Number of 1D Basis Nodes (p)       : %d\n"
                       "    Number of 1D Quadrature Points (q) : %d\n"
                       "    Global nodes                       : %D\n"
                       "    DoF per node                       : %D\n"
                       "    Global DoFs                        : %D\n",
                       used_resource, CeedMemTypes[mem_type_backend], P, Q,
                       g_size/num_comp_u, num_comp_u, g_size); CHKERRQ(ierr);
  }

  // Setup libCEED's objects and apply setup operator
  ierr = PetscMalloc1(1, &ceed_data); CHKERRQ(ierr);
  ierr = SetupLibceedByDegree(dm, ceed, degree, topo_dim, q_extra, num_comp_x,
                              num_comp_u, g_size, xl_size,
                              problem_options[problem_choice], ceed_data,
                              false, (CeedVector)NULL, (CeedVector *)NULL);
  CHKERRQ(ierr);

  // Setup output vector
  PetscScalar *v;
  ierr = VecZeroEntries(V_loc); CHKERRQ(ierr);
  ierr = VecGetArrayAndMemType(V_loc, &v, &mem_type); CHKERRQ(ierr);
  CeedVectorSetArray(ceed_data->y_ceed, MemTypeP2C(mem_type), CEED_USE_POINTER,
                     v);

  // Compute the mesh volume using the mass operator: area = 1^T \cdot M \cdot 1
  if (!test_mode) {
    ierr = PetscPrintf(comm,
                       "Computing the mesh area using the formula: area = 1^T M 1\n");
    CHKERRQ(ierr);
  }

  // Initialize u with ones
  CeedVectorSetValue(ceed_data->x_ceed, 1.0);

  // Apply the mass operator: 'u' -> 'v'
  CeedOperatorApply(ceed_data->op_apply, ceed_data->x_ceed, ceed_data->y_ceed,
                    CEED_REQUEST_IMMEDIATE);

  // Gather output vector
  CeedVectorTakeArray(ceed_data->y_ceed, CEED_MEM_HOST, NULL);
  ierr = VecRestoreArrayAndMemType(V_loc, &v); CHKERRQ(ierr);
  ierr = VecZeroEntries(V); CHKERRQ(ierr);
  ierr = DMLocalToGlobalBegin(dm, V_loc, ADD_VALUES, V); CHKERRQ(ierr);
  ierr = DMLocalToGlobalEnd(dm, V_loc, ADD_VALUES, V); CHKERRQ(ierr);

  // Compute and print the sum of the entries of 'v' giving the mesh surface area
  PetscScalar area;
  ierr = VecSum(V, &area); CHKERRQ(ierr);

  // Compute the exact surface area and print the result
  CeedScalar exact_surface_area = 4 * M_PI;
  if (problem_choice == CUBE) {
    PetscScalar l = 1.0/PetscSqrtReal(3.0); // half edge of the cube
    exact_surface_area = 6 * (2*l) * (2*l);
  }

  PetscReal error = fabs(area - exact_surface_area);
  PetscReal tol = 5e-6;
  if (!test_mode || error > tol) {
    ierr = PetscPrintf(comm, "Exact mesh surface area    : % .14g\n",
                       exact_surface_area);
    CHKERRQ(ierr);
    ierr = PetscPrintf(comm, "Computed mesh surface area : % .14g\n", area);
    CHKERRQ(ierr);
    ierr = PetscPrintf(comm, "Area error                 : % .14g\n", error);
    CHKERRQ(ierr);
  }

  // Cleanup
  ierr = DMDestroy(&dm); CHKERRQ(ierr);
  ierr = VecDestroy(&U); CHKERRQ(ierr);
  ierr = VecDestroy(&U_loc); CHKERRQ(ierr);
  ierr = VecDestroy(&V); CHKERRQ(ierr);
  ierr = VecDestroy(&V_loc); CHKERRQ(ierr);
  ierr = PetscFree(user); CHKERRQ(ierr);
  ierr = CeedDataDestroy(0, ceed_data); CHKERRQ(ierr);
  CeedDestroy(&ceed);
  return PetscFinalize();
}


#include <gsl/gsl_poly.h>

size_t remove_leading_zeros(double *h, size_t n)
{

    size_t m = 0;
    double small = 1e-5;
    size_t i;
    for(i=n; i>0; i--)
    {

        if (fabs(h[i-1]) > small)
        {
            m = i;
            break;
        }
    }

    return m;

}

size_t find_roots(double *z, double *h, size_t n)
{

    size_t m;
    m = remove_leading_zeros(&h[0], n);

    if (m > 1)
    {

        gsl_poly_complex_workspace *w = gsl_poly_complex_workspace_alloc(m);
        gsl_poly_complex_solve(h, m, w, z);
        gsl_poly_complex_workspace_free (w);

    }

    return m;

}


//popGen stuff for Next Gen Sequencing Data

#include "pgSummaryStats.h"
#include <math.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include "vector.h"
#include <gsl/gsl_randist.h>
#include <gsl/gsl_cdf.h>
#include <gsl/gsl_rng.h>
#include <gsl/gsl_matrix.h>

//Sampling Probability stuff

//prob_i returns the probability under SNM of a snp freq i
double prob_i(int i, int n){
	double tmp;
	tmp = 1.0 / (double) i;
	return(tmp/ a1f(n));
}

double prob_km(int k, int m, int n){
	double sum = 0.0;
	int i;
	double tmpFreq;

	for(i=1;i<n;i++){
		tmpFreq = (double) i / (double) n;
		sum += gsl_ran_binomial_pdf(k,tmpFreq,m) * prob_i(i,n);
	}
	return(sum);
}

//achaz system stuff
double achazSFS(gsl_matrix *sfsCount, gsl_matrix *weightMat){
	int i, j;
	double theta = 0.0;
	double weightSum, tmpTheta;

	//rows = sampleSizes
	for(i = 2; i < sfsCount->size1; i++){
		weightSum = 0.0;
		tmpTheta = 0.0;
		for(j = 1; j < i; j++){
			//size i freq j
			tmpTheta += gsl_matrix_get(sfsCount, i, j) * j * gsl_matrix_get(weightMat,i,j);
			weightSum += gsl_matrix_get(weightMat,i,j);
		}
		if(weightSum > 0){ theta += tmpTheta / weightSum; }
	}
	return(theta);
}

double achazSFSCorrected(gsl_matrix *sfsCount, gsl_matrix *weightMat,int nPool){
	int i, j;
	double theta = 0.0;
	double weightSum, tmpTheta;

	//rows = sampleSizes
	for(i = 2; i < sfsCount->size1; i++){
		weightSum = 0.0;
		tmpTheta = 0.0;
		for(j = 1; j < i; j++){
			//size i freq j
			tmpTheta += gsl_matrix_get(sfsCount, i, j) * gsl_matrix_get(weightMat,i,j) * (1.0/prob_km(j,i,nPool));
			weightSum += gsl_matrix_get(weightMat,i,j);
		}
		if(weightSum > 0){

			theta += tmpTheta / weightSum / a1f(nPool);
		}
	}
	return(theta);
}

// fillPiWeights -- returns the weight matrix for theta_pi
void fillPiWeights(gsl_matrix *weightMat, int minFreq){
	int i, j;
	gsl_matrix_set_zero(weightMat);
	for(i=minFreq+1; i < weightMat->size1; i++){
		for(j=minFreq;j<i;j++){
			gsl_matrix_set(weightMat,i,j,i-j);
		}
	}
}

// fillHWeights -- returns the weight matrix for theta_H
void fillHWeights(gsl_matrix *weightMat, int minFreq){
	int i, j;
	gsl_matrix_set_zero(weightMat);
	for(i=minFreq+1; i < weightMat->size1; i++){
		for(j=minFreq;j<i;j++){
			gsl_matrix_set(weightMat,i,j,j);
		}
	}
}

// fillWWeights -- returns the weight matrix for theta_w
void fillWWeights(gsl_matrix *weightMat, int minFreq){
	int i, j;
	gsl_matrix_set_zero(weightMat);
	for(i=minFreq+1; i < weightMat->size1; i++){
		for(j=minFreq;j<i;j++){
			gsl_matrix_set(weightMat,i,j,1/(double)j);
		}
	}
}


#include <cblas.h>
#include <assert.h>
#include <unistd.h>

#include "benchmark.hpp"

void dot_cblas(const double *A,
               const size_t A_m,
               const size_t A_n,
               const double *B,
               const size_t B_m,
               const size_t B_n,
               double *C) {
  UNUSED(B_m);
  assert(A != NULL && B != NULL && C != NULL);
  assert(A_m > 0 && A_n > 0 && B_m > 0 && B_n > 0);
  assert(A_n == B_m);

  cblas_dgemm(CblasColMajor, /* Matrix data arrangement */
              CblasNoTrans,  /* Transpose A */
              CblasNoTrans,  /* Transpose B */
              A_m,           /* Number of rows in A and C */
              B_n,           /* Number of cols in B and C */
              A_n,           /* Number of cols in A */
              1.0,           /* Scaling factor for the product of A and B */
              A,             /* Matrix A */
              A_n,           /* First dimension of A */
              B,             /* Matrix B */
              B_n,           /* First dimension of B */
              1.0,           /* Scale factor for C */
              C,             /* Output */
              A_m            /* First dimension of C */
  );
}

int main() {
  // Array - Blas
  for (size_t k = 10; k < 1000; k += 10) {
    size_t m = k;
    double *A = create_random_sq_matrix(m);
    double *B = create_random_sq_matrix(m);
    double *C = (double *) malloc(sizeof(double) * m * m);

    /* CBLAS dot() */
    /* sleep(1); */
    struct timespec t = tic();
    dot_cblas(A, m, m, B, m, m, C);
    printf("matrix_size: %ld\tdot_cblas(): %fs\n", m, toc(&t));

    free(A);
    free(B);
    free(C);
  }

  return 0;
}