/*This program evaluates the differential equations for a photon's geodesic in a perturbed spacetime in SPHERICAL coordinates.*/

/*This program solves the particular case for flat FRW perturbed spacetime with metric: $g_{ab} = {[g]}_{ab} + h_{ab}$. Where ${[g]}_{ab}$ corresponds to the flat FRW metric and $h_{ab}$ corresponds to the perturbation in the conformal Newtonian gauge. A Plummer potential with adequate parameters have been used to simulate the perturbation.
The equations are written in the form $\frac{d(x or p)^{\alpha}}{d\lambda}=f(x^{\alpha},p^{\alpha})$ and the indice $\alpha$ runs from 0 to 3.
Where $p^{\alpha}={\dot{x}}^{\alpha}$.
The coordinates for the photon's geodesics are: (ct,r,\theta,\phi) = (x0,x1,x2,x3).*/

#include <stdlib.h>
#include <stdio.h>
#include <math.h>
#include <gsl/gsl_errno.h>          //GSL error management module
#include <gsl/gsl_spline.h>         //GSL interpolation module

#define A 10.0     //Distance parameter of the perturbations
#define G 43007.01     //Gravitational constant
#define M 0.0     //Mass of the perturbation
#define C 299792.458  //Speed of light
#define NLINES 100000 //Number of lines in geodesic_solution.dat file
#define NSTEPS 40000000 //Number of steps for solving geodesics
#define NLINESFRW 10000 //Number of lines in frw.dat file
#define DLAMBDA 0.01   //Geodesics parameter step

typedef long double mydbl;

/*Interpolation of function inside *spline object evaluated at an abscisa 'x'.
Argument *spline is a pointer to a spline object which stores the type of interpolation to be made. x is the independent variable where the function is evaluated. *acc is a pointer to a lookup object for interpolations.*/
double interpolator(gsl_spline *spline, double x, gsl_interp_accel *acc)
{
  double a = gsl_spline_eval(spline, x, acc);  //Interpolates data to abcisa x using method in spline and acceleration object acc

  return a;  //Return value of interpolated function at x
}

/*Function for the gravitational potential to be used. Potential for Plummer model.*/
mydbl potential(mydbl r)
{
  return -G*M/(sqrtl(A*A + r*r));
}

/*Derivative of potential respecto to radial coordinate.*/
mydbl der_potential(mydbl r)
{
  return G*M*r/(powl(A*A+r*r, 1.5));
}

/*Function of the 0th momentum component differential equation for the geodesics.
${p0}^{dot} = f0(x^{\alpha},p^{\alpha})$.*/
mydbl geodesic_equation_0(gsl_spline *spline1, gsl_interp_accel *acc1, gsl_spline *spline2, gsl_interp_accel *acc2, mydbl p0, mydbl pr, mydbl ptheta, mydbl pphi, mydbl x0, mydbl r, mydbl theta)
{
  double t = (double)(1.0*x0/C);
  mydbl a = (mydbl) 1.0*interpolator(spline1, t, acc1);
  mydbl adot = (mydbl) 1.0*interpolator(spline2, t, acc2);
  mydbl f = -(2.0/(C*C))*der_potential(r)*p0*pr/(1.0 + 2.0*potential(r)/(C*C)) - (1.0 - 2.0*potential(r)/(C*C))*((a*adot)/C)*(pr*pr + r*r*(powl(sinl(theta),2.0)*pphi*pphi + ptheta*ptheta))/(1.0 + 2.0*potential(r)/(C*C));
  return f;
}

/*Function of the 1th (radial) momentum component differential equation for the geodesics.
${p1}^{dot} = f1(x^{\alpha},p^{\alpha})$.*/
mydbl geodesic_equation_r(gsl_spline *spline1, gsl_interp_accel *acc1, gsl_spline *spline2, gsl_interp_accel *acc2, mydbl p0, mydbl pr, mydbl ptheta, mydbl pphi, mydbl x0, mydbl r, mydbl theta)
{
  double t = (double)(1.0*x0/C);
  mydbl a = (mydbl) 1.0*interpolator(spline1, t, acc1);
  mydbl adot = (mydbl) 1.0*interpolator(spline2, t, acc2);
  mydbl f = - (der_potential(r)*p0*p0)/(a*a*C*C*(1.0 - 2.0*potential(r)/(C*C))) - (2.0*adot*p0*pr)/(C*a) + r*(ptheta*ptheta + sinl(theta)*sinl(theta)*pphi*pphi) - (der_potential(r)/(C*C))*(powl(r,2.0)*(powl(ptheta,2.0) + powl(sinl(theta)*pphi,2.0)) - pr*pr)/(1.0 - 2.0*potential(r)/(C*C));
  return f;
}

/*Function of the 2th (polar) momentum component differential equation for the geodesics.
${p2}^{dot} = f2(x^{\alpha},p^{\alpha})$.*/
mydbl geodesic_equation_theta(gsl_spline *spline1, gsl_interp_accel *acc1, gsl_spline *spline2, gsl_interp_accel *acc2, mydbl p0, mydbl pr, mydbl ptheta, mydbl pphi, mydbl x0, mydbl r, mydbl theta)
{
  double t = (double)(1.0*x0/C);
  mydbl a = (mydbl) 1.0*interpolator(spline1, t, acc1);
  mydbl adot = (mydbl) 1.0*interpolator(spline2, t, acc2);
  mydbl f = 0.5*sinl(2.0*theta)*pphi*pphi + 2.0*((der_potential(r)/powl(C,2.0))/(1.0 - 2.0*potential(r)/(C*C)) - 1.0/r)*pr*ptheta - (2.0*adot*p0*ptheta)/(C*a);
  return f;
}

/*Function of the 3th (azimuthal) momentum component differential equation for the geodesics.
${p3}^{dot} = f3(x^{\alpha},p^{\alpha})$.*/
mydbl geodesic_equation_phi(gsl_spline *spline1, gsl_interp_accel *acc1, gsl_spline *spline2, gsl_interp_accel *acc2, mydbl p0, mydbl pr, mydbl ptheta, mydbl pphi, mydbl x0, mydbl r, mydbl theta)
{
  double t = (double)(1.0*x0/C);
  mydbl a = (mydbl) 1.0*interpolator(spline1, t, acc1);
  mydbl adot = (mydbl) 1.0*interpolator(spline2, t, acc2);
  mydbl f = 2.0*( (der_potential(r)/powl(C,2.0))/(1.0 - 2.0*potential(r)/(C*C)) - 1.0/r)*pr*pphi - 2.0*(1.0/tanl(theta))*ptheta*pphi - (2.0*adot*p0*pphi)/(a*C);
  return f;
}

/*Function for solving the geodesics differential equations using 4th order Runge-Kutta method.
Arguments are pointer so variables in that memory addresses are changed every time this function is called.*/
void runge_kutta_4(gsl_spline *spline1, gsl_interp_accel *acc1, gsl_spline *spline2, gsl_interp_accel *acc2, mydbl *x0, mydbl *x1, mydbl *x2, mydbl *x3, mydbl *p0, mydbl *p1, mydbl *p2, mydbl *p3, mydbl *lambda)
{
  /*Increment in the variables of the differential equation we want to solve*/
  mydbl dx0, dx1, dx2, dx3, dp0, dp1, dp2, dp3;

  /*dxi = (k1,j + 2*k2,j + 2*k3,j + k4,j)/6. In this sections the ki,j are declared with i=1,2,3,4.*/
  mydbl k1x0, k1x1, k1x2, k1x3, k1p0, k1p1, k1p2, k1p3;
  mydbl k2x0, k2x1, k2x2, k2x3, k2p0, k2p1, k2p2, k2p3;
  mydbl k3x0, k3x1, k3x2, k3x3, k3p0, k3p1, k3p2, k3p3;
  mydbl k4x0, k4x1, k4x2, k4x3, k4p0, k4p1, k4p2, k4p3;

  /*This section calculates the k1 quantities*/
  k1x0 = *p0*DLAMBDA; k1x1 = *p1*DLAMBDA; k1x2 = *p2*DLAMBDA; k3x0 = *p3*DLAMBDA;
  k1p0 = DLAMBDA*geodesic_equation_0(spline1, acc1, spline2, acc2, *p0, *p1, *p2, *p3, *x0, *x1, *x2);
  k1p1 = DLAMBDA*geodesic_equation_r(spline1, acc1, spline2, acc2, *p0, *p1, *p2, *p3, *x0, *x1, *x2);
  k1p2 = DLAMBDA*geodesic_equation_theta(spline1, acc1, spline2, acc2, *p0, *p1, *p2, *p3, *x0, *x1, *x2);
  k1p3 = DLAMBDA*geodesic_equation_phi(spline1, acc1, spline2, acc2, *p0, *p1, *p2, *p3, *x0, *x1, *x2);

  /*This section calculates the k2 quantities*/
  k2x0 = DLAMBDA*(*p0 + 0.5*k1p0); k2x1 = DLAMBDA*(*p1 + 0.5*k1p1); k2x2 = DLAMBDA*(*p2 + 0.5*k1p2); k2x3 = DLAMBDA*(*p3 + 0.5*k1p3);
  k2p0 = DLAMBDA*geodesic_equation_0(spline1, acc1, spline2, acc2, *p0 + 0.5*k1p0, *p1 + 0.5*k1p1, *p2 + 0.5*k1p2, *p3 + 0.5*k1p3, *x0 + 0.5*k1x0, *x1 + 0.5*k1x1, *x2 + 0.5*k1x2);
  k2p1 = DLAMBDA*geodesic_equation_r(spline1, acc1, spline2, acc2, *p0 + 0.5*k1p0, *p1 + 0.5*k1p1, *p2 + 0.5*k1p2, *p3 + 0.5*k1p3, *x0 + 0.5*k1x0, *x1 + 0.5*k1x1, *x2 + 0.5*k1x2);
  k2p2 = DLAMBDA*geodesic_equation_theta(spline1, acc1, spline2, acc2, *p0 + 0.5*k1p0, *p1 + 0.5*k1p1, *p2 + 0.5*k1p2, *p3 + 0.5*k1p3, *x0 + 0.5*k1x0, *x1 + 0.5*k1x1, *x2 + 0.5*k1x2);
  k2p3 = DLAMBDA*geodesic_equation_phi(spline1, acc1, spline2, acc2, *p0 + 0.5*k1p0, *p1 + 0.5*k1p1, *p2 + 0.5*k1p2, *p3 + 0.5*k1p3, *x0 + 0.5*k1x0, *x1 + 0.5*k1x1, *x2 + 0.5*k1x2);

  /*This section calculates the k3 quantities*/
  k3x0 = DLAMBDA*(*p0 + 0.5*k2p0); k3x1 = DLAMBDA*(*p1 + 0.5*k2p1); k3x2 = DLAMBDA*(*p2 + 0.5*k2p2); k3x3 = DLAMBDA*(*p3 + 0.5*k2p3);
  k3p0 = DLAMBDA*geodesic_equation_0(spline1, acc1, spline2, acc2, *p0 + 0.5*k2p0, *p1 + 0.5*k2p1, *p2 + 0.5*k2p2, *p3 + 0.5*k2p3, *x0 + 0.5*k2x0, *x1 + 0.5*k2x1, *x2 + 0.5*k2x2);
  k3p1 = DLAMBDA*geodesic_equation_r(spline1, acc1, spline2, acc2, *p0 + 0.5*k2p0, *p1 + 0.5*k2p1, *p2 + 0.5*k2p2, *p3 + 0.5*k2p3, *x0 + 0.5*k2x0, *x1 + 0.5*k2x1, *x2 + 0.5*k2x2);
  k3p2 = DLAMBDA*geodesic_equation_theta(spline1, acc1, spline2, acc2, *p0 + 0.5*k2p0, *p1 + 0.5*k2p1, *p2 + 0.5*k2p2, *p3 + 0.5*k2p3, *x0 + 0.5*k2x0, *x1 + 0.5*k2x1, *x2 + 0.5*k2x2);
  k3p3 = DLAMBDA*geodesic_equation_phi(spline1, acc1, spline2, acc2, *p0 + 0.5*k2p0, *p1 + 0.5*k2p1, *p2 + 0.5*k2p2, *p3 + 0.5*k2p3, *x0 + 0.5*k2x0, *x1 + 0.5*k2x1, *x2 + 0.5*k2x2);

  /*This section calculates the k4 quantities*/
  k4x0 = DLAMBDA*(*p0 + k3p0); k4x1 = DLAMBDA*(*p1 + k3p1); k4x2 = DLAMBDA*(*p2 + k3p2); k4x3 = DLAMBDA*(*p3 + k3p3);
  k4p0 = DLAMBDA*geodesic_equation_0(spline1, acc1, spline2, acc2, *p0 + k3p0, *p1 + k3p1, *p2 + k3p2, *p3 + k3p3, *x0 + k3x0, *x1 + k3x1, *x2 + k3x2);
  k4p1 = DLAMBDA*geodesic_equation_r(spline1, acc1, spline2, acc2, *p0 + k3p0, *p1 + k3p1, *p2 + k3p2, *p3 + k3p3, *x0 + k3x0, *x1 + k3x1, *x2 + k3x2);
  k4p2 = DLAMBDA*geodesic_equation_theta(spline1, acc1, spline2, acc2, *p0 + k3p0, *p1 + k3p1, *p2 + k3p2, *p3 + k3p3, *x0 + k3x0, *x1 + k3x1, *x2 + k3x2);
  k4p3 = DLAMBDA*geodesic_equation_phi(spline1, acc1, spline2, acc2, *p0 + k3p0, *p1 + k3p1, *p2 + k3p2, *p3 + k3p3, *x0 + k3x0, *x1 + k3x1, *x2 + k3x2);

  /*Calculation of the increments*/
  dx0 = (k1x0 + 2.0*k2x0 + 2.0*k3x0 + k4x0)/6.0;
  dx1 = (k1x1 + 2.0*k2x1 + 2.0*k3x1 + k4x1)/6.0;
  dx2 = (k1x2 + 2.0*k2x2 + 2.0*k3x2 + k4x2)/6.0;
  dx3 = (k1x3 + 2.0*k2x3 + 2.0*k3x3 + k4x3)/6.0;
  dp0 = (k1p0 + 2.0*k2p0 + 2.0*k3p0 + k4p0)/6.0;
  dp1 = (k1p1 + 2.0*k2p1 + 2.0*k3p1 + k4p1)/6.0;
  dp2 = (k1p2 + 2.0*k2p2 + 2.0*k3p2 + k4p2)/6.0;
  dp3 = (k1p3 + 2.0*k2p3 + 2.0*k3p3 + k4p3)/6.0;

  /*New values of the variables of the differential equation. Since we are using pointers, when called the routine the value of variable change.*/
  *x0 = *x0 + dx0; *x1 = *x1 + dx1; *x2 = *x2 + dx2; *x3 = *x3 + dx3;
  *p0 = *p0 + dp0; *p1 = *p1 + dp1; *p2 = *p2 + dp2; *p3 = *p3 + dp3;

  /*Increment of parameter of geodesics*/
  *lambda = *lambda + DLAMBDA;
}

/*To set the initial value of pr, it must hold $g_{\mu\nu}p^{\mu}p^{\nu} = 0$.
This factor multiplies p0 to guarantee that p1 fulfill the null geodesic condition.*/
mydbl condition_factor(mydbl r, double a)
{
  return (mydbl)(1.0/a)*sqrtl((1.0+2.0*potential(r)/(C*C))/(1.0 - 2.0*potential(r)/(C*C)));
}

/*$cp^{0}$ multiplied by this factor allows to obtain the energy for a local inertial observer in this spacetime.*/
mydbl energy_factor(mydbl r)
{
  mydbl g = sqrtl(1.0 + 2.0*potential(r)/(C*C));
  return g;
}

/*Violation of null geodesics condition $g_{\mu\nu}p^{\mu}p^{\nu} = 0$.*/
mydbl violation(mydbl r, mydbl theta, mydbl p0, mydbl pr, mydbl ptheta, mydbl pphi, double a)
{
  mydbl f = -(1.0+2.0*potential(r)/(C*C))*p0*p0 + a*a*(1.0-2.0*potential(r)/(C*C))*(pr*pr + r*r*(powl(sinl(theta),2.0)*pphi*pphi + ptheta*ptheta));
  return f;
}

int main(void)
{
  /***READ SCALE FACTOR DATA AND PREPARE OBJECTS FOR INTERPOLATION ***/
  int i;            //For array manipulation

  /*Pointer to scale_factor.dat file*/
  FILE *frw;
  frw = fopen("scale_factor.dat","r");

  /*Variables and arrays to read the data*/
  double cosmictime[NLINESFRW], conftime, scale_factor[NLINESFRW], der_scale_factor[NLINESFRW];

  /*Reading the data*/
  for(i=0; i<NLINESFRW; i++)
    {
      fscanf(frw,"%lf %lf %lf %lf", &cosmictime[i], &conftime, &scale_factor[i], &der_scale_factor[i]);
    }

  /*Free space in memory*/
  fclose(frw);

  /*** Initializes objects for interpolation. 1 is for interpolation of scale factor, 2 is for interpolation of derivative of scale factor ***/

  /*Allocate space in memory*/
  gsl_interp_accel *acc1 = gsl_interp_accel_alloc();  //Acceleration type object (for index lookup)
  gsl_interp_accel *acc2 = gsl_interp_accel_alloc();
  gsl_spline *spline1 = gsl_spline_alloc(gsl_interp_cspline, NLINESFRW);  //Spline type object (define interpolation type and space in memory, works for both)
  gsl_spline *spline2 = gsl_spline_alloc(gsl_interp_cspline, NLINESFRW);

  /*Initializes objects for interpolation*/
  gsl_spline_init(spline1, cosmictime, scale_factor, NLINESFRW);  //Initializes spline object for data conf_time, scale_factor of size NLINES
  gsl_spline_init(spline2, cosmictime, der_scale_factor, NLINESFRW);  //Initializes spline object for data conf_time, der_scale_factor of size NLINES

  /************************************************************************************/

  /***SOLVES GEODESIC EQUATIONS FOR PERTURBED FRW UNIVERSE WITH STATIC PLUMMER POTENTIAL ***/

  /*Initial conditions*/
  mydbl ti = 7.0 ,x0, r = -200.0, theta = M_PI*0.5, phi = M_PI*0.5, p0 = 1.0e-3, pr, ptheta = 0.0, pphi = 0.0, lambda = 0.0, energy1, energy, v, difft, difference;
  double difftfrw, aem, aobs;
  x0 = C*ti;
  aem = interpolator(spline1, (double)(1.0*ti), acc1);
  pr = condition_factor(r, aem)*p0;
  energy1 = C*energy_factor(r)*p0;
  v = violation(r, theta, p0, pr, ptheta, pphi, aem);
  difft = (energy1 - energy1)/energy1;
  difftfrw = (aem/aem) - 1.0;
  difference = difft - (mydbl)(1.0*difftfrw);

  /*Pointer to file where solution of differential equation will be saved.*/
  FILE *geodesic;
  geodesic = fopen("../geodesic_solution.dat","w");

  /*Write line of initial values in file*/
  fprintf(geodesic, "%16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8e %16.8Le\n", lambda, x0, r, theta, phi, p0, pr, ptheta, pphi, energy1, v, difft, difftfrw, difference);

  long long int ii;

  /*Solution of the differential equation*/
  for(ii=0; ii<(1+ NSTEPS); ii++)
    {
      runge_kutta_4(spline1, acc1, spline2, acc2, &x0, &r, &theta, &phi, &p0, &pr, &ptheta, &pphi, &lambda);
      if((ii%(NSTEPS/NLINES)) == 0)
	{
	  energy = C*energy_factor(r)*p0;
	  difft = (energy - energy1)/energy1;
	  ti = x0/C;
	  aobs = interpolator(spline1, (double)(1.0*ti), acc1);
	  v = violation(r, theta, p0, pr, ptheta, pphi, aobs);
	  difftfrw = (aem/aobs) - 1.0;
	  difference = difft - (mydbl)(1.0*difftfrw);
	  fprintf(geodesic, "%16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8Le %16.8e %16.8Le\n", lambda, x0, r, theta, phi, p0, pr, ptheta, pphi, energy, v, difft, difftfrw, difference);
	}
    }

  /************************************************************************************/

  /*** Releasing all used space in memory ***/
  fclose(geodesic); //Close file storing the results
  gsl_spline_free(spline1);  //Free memory of spline object
  gsl_spline_free(spline2);
  gsl_interp_accel_free(acc1);  //Free memory of accel object
  gsl_interp_accel_free(acc2);
}


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

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

/* The logistic distribution has the form,

   p(x) dx = (1/a) exp(-x/a) / (1 + exp(-x/a))^2 dx

   for -infty < x < infty */

double
gsl_ran_logistic (const gsl_rng * r, const double a)
{
  double x, z;

  do
    {
      x = gsl_rng_uniform_pos (r);
    }
  while (x == 1);

  z = log (x / (1 - x));

  return a * z;
}

double
gsl_ran_logistic_pdf (const double x, const double a)
{
  double u = exp (-fabs(x)/a);
  double p = u / (fabs(a) * (1 + u) * (1 + u));
  return p;
}


/* specfunc/gsl_sf_expint.h
 *
 * Copyright (C) 1996, 1997, 1998, 1999, 2000 Gerard Jungman
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 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 */

#ifndef __GSL_SF_EXPINT_H__
#define __GSL_SF_EXPINT_H__

#include <gsl/gsl_sf_result.h>

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

__BEGIN_DECLS

/* E_1(x) := Re[ Integrate[ Exp[-xt]/t, {t,1,Infinity}] ]
 *
 * x != 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int     gsl_sf_expint_E1_e(const double x, gsl_sf_result * result);
double     gsl_sf_expint_E1(const double x);

/* E_2(x) := Re[ Integrate[ Exp[-xt]/t^2, {t,1,Infinity}] ]
 *
 * x != 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int     gsl_sf_expint_E2_e(const double x, gsl_sf_result * result);
double     gsl_sf_expint_E2(const double x);

/* Ei(x) := PV Integrate[ Exp[-t]/t, {t,-x,Infinity}]
 *
 * x != 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int     gsl_sf_expint_Ei_e(const double x, gsl_sf_result * result);
double     gsl_sf_expint_Ei(const double x);

/* Shi(x) := Integrate[ Sinh[t]/t, {t,0,x}]
 *
 * exceptions: GSL_EOVRFLW, GSL_EUNDRFLW
 */
int     gsl_sf_Shi_e(const double x, gsl_sf_result * result);
double     gsl_sf_Shi(const double x);

/* Chi(x) := Re[ M_EULER + log(x) + Integrate[(Cosh[t]-1)/t, {t,0,x}] ]
 *
 * x != 0.0
 * exceptions: GSL_EDOM, GSL_EOVRFLW, GSL_EUNDRFLW
 */
int     gsl_sf_Chi_e(const double x, gsl_sf_result * result);
double     gsl_sf_Chi(const double x);

/* Ei_3(x) := Integral[ Exp[-t^3], {t,0,x}]
 *
 * x >= 0.0
 * exceptions: GSL_EDOM
 */
int     gsl_sf_expint_3_e(const double x, gsl_sf_result * result);
double     gsl_sf_expint_3(double x);

/* Si(x) := Integrate[ Sin[t]/t, {t,0,x}]
 *
 * exceptions: none
 */
int     gsl_sf_Si_e(const double x, gsl_sf_result * result);
double     gsl_sf_Si(const double x);

/* Ci(x) := -Integrate[ Cos[t]/t, {t,x,Infinity}]
 *
 * x > 0.0
 * exceptions: GSL_EDOM
 */
int     gsl_sf_Ci_e(const double x, gsl_sf_result * result);
double     gsl_sf_Ci(const double x);

/* AtanInt(x) := Integral[ Arctan[t]/t, {t,0,x}]
 *
 *
 * exceptions:
 */
int gsl_sf_atanint_e(const double x, gsl_sf_result * result);
double gsl_sf_atanint(const double x);

__END_DECLS

#endif /* __GSL_SF_EXPINT_H__ */


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

/* Author: G. Jungman */

#ifndef __GSL_SF_ELLINT_H__
#define __GSL_SF_ELLINT_H__

#include <gsl/gsl_mode.h>
#include <gsl/gsl_sf_result.h>

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

__BEGIN_DECLS

/* Legendre form of complete elliptic integrals
 *
 * K(k) = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}]
 * E(k) = Integral[  Sqrt[1 - k^2 Sin[t]^2], {t, 0, Pi/2}]
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_ellint_Kcomp_e(double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_Kcomp(double k, gsl_mode_t mode);

int gsl_sf_ellint_Ecomp_e(double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_Ecomp(double k, gsl_mode_t mode);

int gsl_sf_ellint_Pcomp_e(double k, double n, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_Pcomp(double k, double n, gsl_mode_t mode);

int gsl_sf_ellint_Dcomp_e(double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_Dcomp(double k, gsl_mode_t mode);

/* Legendre form of incomplete elliptic integrals
 *
 * F(phi,k)   = Integral[1/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]
 * E(phi,k)   = Integral[  Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]
 * P(phi,k,n) = Integral[(1 + n Sin[t]^2)^(-1)/Sqrt[1 - k^2 Sin[t]^2], {t, 0, phi}]
 * D(phi,k,n) = R_D(1-Sin[phi]^2, 1-k^2 Sin[phi]^2, 1.0)
 *
 * F: [Carlson, Numerische Mathematik 33 (1979) 1, (4.1)]
 * E: [Carlson, ", (4.2)]
 * P: [Carlson, ", (4.3)]
 * D: [Carlson, ", (4.4)]
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_ellint_F_e(double phi, double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_F(double phi, double k, gsl_mode_t mode);

int gsl_sf_ellint_E_e(double phi, double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_E(double phi, double k, gsl_mode_t mode);

int gsl_sf_ellint_P_e(double phi, double k, double n, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_P(double phi, double k, double n, gsl_mode_t mode);

int gsl_sf_ellint_D_e(double phi, double k, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_D(double phi, double k, gsl_mode_t mode);

/* Carlson's symmetric basis of functions
 *
 * RC(x,y)   = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1)], {t,0,Inf}]
 * RD(x,y,z) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-3/2), {t,0,Inf}]
 * RF(x,y,z) = 1/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2), {t,0,Inf}]
 * RJ(x,y,z,p) = 3/2 Integral[(t+x)^(-1/2) (t+y)^(-1/2) (t+z)^(-1/2) (t+p)^(-1), {t,0,Inf}]
 *
 * exceptions: GSL_EDOM
 */
int gsl_sf_ellint_RC_e(double x, double y, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_RC(double x, double y, gsl_mode_t mode);

int gsl_sf_ellint_RD_e(double x, double y, double z, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_RD(double x, double y, double z, gsl_mode_t mode);

int gsl_sf_ellint_RF_e(double x, double y, double z, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_RF(double x, double y, double z, gsl_mode_t mode);

int gsl_sf_ellint_RJ_e(double x, double y, double z, double p, gsl_mode_t mode, gsl_sf_result * result);
double gsl_sf_ellint_RJ(double x, double y, double z, double p, gsl_mode_t mode);

__END_DECLS

#endif /* __GSL_SF_ELLINT_H__ */


/*
   LAPACKE Example : Calling DGELS using col-major layout
   =====================================================

   The program computes the solution to the system of linear
   equations with a square matrix A and multiple
   right-hand sides B, where A is the coefficient matrix
   and b is the right-hand side matrix:

   Description
   ===========

   In this example, we wish solve the least squares problem min_x || B - Ax ||
   for two right-hand sides using the LAPACK routine DGELS. For input we will
   use the 5-by-3 matrix

         ( 1  1  1 )
         ( 2  3  4 )
     A = ( 3  5  2 )
         ( 4  2  5 )
         ( 5  4  3 )
    and the 5-by-2 matrix

         ( -10 -3 )
         (  12 14 )
     B = (  14 12 )
         (  16 16 )
         (  18 16 )
    We will first store the input matrix as a static C two-dimensional array,
    which is stored in col-major layout, and let LAPACKE handle the work space
    array allocation. The LAPACK base name for this function is gels, and we
    will use double precision (d), so the LAPACKE function name is LAPACKE_dgels.

    lda=5 and ldb=5. The output for each right hand side is stored in b as
    consecutive vectors of length 3. The correct answer for this problem is
    the 3-by-2 matrix

         ( 2 1 )
         ( 1 1 )
         ( 1 2 )

    A complete C program for this example is given below. Note that when the arrays
     are passed to the LAPACK routine, they must be dereferenced, since LAPACK is
      expecting arrays of type double *, not double **.

   LAPACKE Interface
   =================

   LAPACKE_dgels (col-major, high-level) Example Program Results

  -- LAPACKE Example routine (version 3.7.0) --
  -- LAPACK is a software package provided by Univ. of Tennessee,    --
  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
     December 2016

*/
/* Calling DGELS using col-major layout */

/* Includes */
#include <stdio.h>
#include <lapacke.h>

 int main() {
   double A[5][3] = {{1,2,3},{4,5,1},{3,5,2},{4,1,4},{2,5,3}};
   double b[5][2] = {{-10,12},{14,16},{18,-3},{14,12},{16,16}};

   const lapack_int m = 5;
   const lapack_int n = 3;
   const lapack_int lda = 5;
   const lapack_int ldb = 5;
   const lapack_int nrhs = 2;

   printf("LAPACKE_dgels (col-major, high-level) Example Program Results\n" );
   const lapack_int info = LAPACKE_dgels(LAPACK_COL_MAJOR,'N',m, n, nrhs, *A, lda, *b, ldb);
   printf( "Solution: %d %d %lf %d\n", n, nrhs, b[0][0], ldb);

   return info;
}


// xll_roots.h - GSL 1-dim root finding
// http://www.gnu.org/software/gsl/manual/html_node/One-dimensional-Root_002dFinding.html#One-dimensional-Root_002dFinding
#pragma once
#include <functional>
#include <memory>
#include <stdexcept>
#include <tuple>
#include "gsl/gsl_errno.h"
#include "gsl/gsl_roots.h"
#include "xll_math.h"

namespace gsl {

namespace root {

	// root bracketing solvers
	class fsolver {
		gsl_root_fsolver* s;
		gsl::function f;
	public:
		explicit fsolver(const gsl_root_fsolver_type * type)
			: s{gsl_root_fsolver_alloc(type)}
		{ }
		fsolver(const fsolver&) = delete;
		fsolver& operator=(const fsolver&) = delete;
		~fsolver()
		{
			gsl_root_fsolver_free(s);
		}

		// needed for gsl_root_fsolver_* routines
		gsl_root_fsolver* get() const
		{
			return s;
		}
		// syntactic sugar
		operator gsl_root_fsolver*() const
		{
			return get();
		}

		int set(const std::function<double(double)>& f_, double lo, double hi)
		{
			f = f_;

			return gsl_root_fsolver_set(s, &f, lo, hi);
		}

		// forward to gsl_root_fsolver_* functions
		int iterate()
		{
			return gsl_root_fsolver_iterate(s);
		}
		double x_lower() const
		{
			return gsl_root_fsolver_x_lower(s);
		}
		double x_upper() const
		{
			return gsl_root_fsolver_x_upper(s);
		}
		double root() const
		{
			return gsl_root_fsolver_root(s);
		}

		// specify convergence condition
		double solve(const std::function<bool(const fsolver&)>& done)
		{
			while (GSL_SUCCESS == iterate()) {
				if (done(*this))
					break;
			}

			return root();
		}
	};

	// convergence helper functions
	inline auto test_interval(double epsabs, double epsrel)
	{
		return [epsabs,epsrel](const fsolver& s) {
			return GSL_SUCCESS == gsl_root_test_interval(s.x_lower(), s.x_upper(), epsabs, epsrel);
		};
	}

	// root finding using derivatives
	class fdfsolver {
		gsl_root_fdfsolver* s;

		// function and its derivative
		gsl::function_fdf FdF;
	public:
		fdfsolver(const gsl_root_fdfsolver_type * type)
			: s{gsl_root_fdfsolver_alloc(type)}
		{ }
		fdfsolver(const fdfsolver&) = delete;
		fdfsolver& operator=(const fdfsolver&) = delete;
		~fdfsolver()
		{
			gsl_root_fdfsolver_free(s);
		}
		// needed for gsl_root_fdfsolver_* routines
		gsl_root_fdfsolver* get() const
		{
			return s;
		}
		// syntactic sugar
		operator gsl_root_fdfsolver*() const
		{
			return s;
		}

		int set(const std::function<double(double)>& f, const std::function<double(double)>& df, double x0)
		{
			FdF = gsl::function_fdf(f, df);

			return gsl_root_fdfsolver_set(s, &FdF, x0);
		}

		// forward to gsl_root_fdfsolver_* functions
		int iterate()
		{
			return gsl_root_fdfsolver_iterate(s);
		}
		double root() const
		{
			return gsl_root_fdfsolver_root(s);
		}

		// specify convergence condition given previous root
		double solve(const std::function<bool(const fdfsolver&,double)>& done)
		{
			double x = root();
			while (GSL_SUCCESS == iterate()) {
				if (done(*this, x))
					break;
				x = root();
			}

			return root();
		}
	};

	// convergence helper functions
	inline auto test_delta(double epsabs, double epsrel)
	{
		return [epsabs,epsrel](const fdfsolver& s, double x) -> bool {
			return GSL_SUCCESS == gsl_root_test_delta(x, s.root(), epsabs, epsrel);
		};
	}

	} // root
} // gsl

#ifdef _DEBUG
#include <cassert>
#include <vector>
//#include <gsl/gsl_poly.h>

// http://www.gnu.org/software/gsl/manual/html_node/Root-Finding-Examples.html#Root-Finding-Examples

// a x^2 + b x + c
struct quadratic_params {
	double a, b, c;
};

// This is bad. Why???
inline double quadratic(double x, void *params)
{
	struct quadratic_params *p
		= (struct quadratic_params *) params;

	double a = p->a;
	double b = p->b;
	double c = p->c;

	return (a * x + b) * x + c;
}

inline double quadratic_deriv(double x, void *params)
{
	struct quadratic_params *p
		= (struct quadratic_params *) params;

	double a = p->a;
	double b = p->b;
//	double c = p->c;

	return 2.0 * a * x + b;
}

inline void quadratic_fdf(double x, void *params, double *y, double *dy)
{
	struct quadratic_params *p
		= (struct quadratic_params *) params;

	double a = p->a;
	double b = p->b;
	double c = p->c;

	*y = (a * x + b) * x + c;
	*dy = 2.0 * a * x + b;
}

inline void test_gsl_root_fsolver()
{
	// GSL example
	{
		gsl_root_fsolver* s = gsl_root_fsolver_alloc(gsl_root_fsolver_brent);

		quadratic_params params{1.,0.,-5.}; // x^2 - 5
		gsl_function F;
		F.function = quadratic;
		F.params = &params;
		double x_lo = 0.0, x_hi = 5.0;
		double epsabs = 0, epsrel = 1e-5;

		gsl_root_fsolver_set(s, &F, x_lo, x_hi);
		while (GSL_SUCCESS == gsl_root_fsolver_iterate(s)) {
			x_lo = gsl_root_fsolver_x_lower(s);
			x_hi = gsl_root_fsolver_x_upper(s);

			// |x_lo - x_hi| < epsabs + epsrel * min(|x_lo|, |x_hi|)
			if (GSL_SUCCESS == gsl_root_test_interval(x_lo, x_hi, epsabs, epsrel))
				break;
		}
		double root = gsl_root_fsolver_root(s);
		double sqrt5 = sqrt(5.);
		assert (fabs(root - sqrt5) < sqrt5*epsrel);

		gsl_root_fsolver_free(s);
	}
	// root_fsolver class with function<double(double)>
	{
		gsl::root::fsolver s(gsl_root_fsolver_brent);

		std::vector<double> params{-5,0,1}; // -5 + x^2
		auto F = [params](double x) { return params[0] + x*(params[1] + x*params[2]); };
		gsl::function F_(F);
		assert (F_(0) == -5);
		assert (F_.call(0) == -5);
		double x_lo = 0.0, x_hi = 5.0, epsrel = 1e-6;
		s.set(F, x_lo, x_hi);

		double root = s.solve(gsl::root::test_interval(0, epsrel));
		double sqrt5 = sqrt(5.);
		assert (fabs(root - sqrt5) < sqrt5*epsrel);
	}
}
inline void test_gsl_root_fdfsolver()
{
	// root_fdfsolver class with function<tuple<double,double>(double)>
	{
		gsl::root::fdfsolver s(gsl_root_fdfsolver_newton);

		// F(x) = x^2 - 5
		auto F = [](double x) {
			return x*x - 5;
		};
		auto dF = [](double x) {
			return 2*x;
		};
		double x = 5.0, epsrel = 1e-6;
		s.set(F, dF, x);

		double root = s.solve(gsl::root::test_delta(0, epsrel));
		double sqrt5 = sqrt(5.);
		assert (fabs(root - sqrt5) < sqrt5*epsrel);
	}
}

#endif // _DEBUG


/* specfunc/coulomb.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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 */

/* Author:  G. Jungman */

/* Evaluation of Coulomb wave functions F_L(eta, x), G_L(eta, x),
 * and their derivatives. A combination of Steed's method, asymptotic
 * results, and power series.
 *
 * Steed's method:
 *  [Barnett, CPC 21, 297 (1981)]
 * Power series and other methods:
 *  [Biedenharn et al., PR 97, 542 (1954)]
 *  [Bardin et al., CPC 3, 73 (1972)]
 *  [Abad+Sesma, CPC 71, 110 (1992)]
 */
#include <config.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_sf_exp.h>
#include <gsl/gsl_sf_psi.h>
#include <gsl/gsl_sf_airy.h>
#include <gsl/gsl_sf_pow_int.h>
#include <gsl/gsl_sf_gamma.h>
#include <gsl/gsl_sf_coulomb.h>

#include "error.h"

/* the L=0 normalization constant
 * [Abramowitz+Stegun 14.1.8]
 */
static
double
C0sq(double eta)
{
  double twopieta = 2.0*M_PI*eta;

  if(fabs(eta) < GSL_DBL_EPSILON) {
    return 1.0;
  }
  else if(twopieta > GSL_LOG_DBL_MAX) {
    return 0.0;
  }
  else {
    gsl_sf_result scale;
    gsl_sf_expm1_e(twopieta, &scale);
    return twopieta/scale.val;
  }
}

/* the full definition of C_L(eta) for any valid L and eta
 * [Abramowitz and Stegun 14.1.7]
 * This depends on the complex gamma function. For large
 * arguments the phase of the complex gamma function is not
 * very accurately determined. However the modulus is, and that
 * is all that we need to calculate C_L.
 *
 * This is not valid for L <= -3/2  or  L = -1.
 */
static
int
CLeta(double L, double eta, gsl_sf_result * result)
{
  gsl_sf_result ln1; /* log of numerator Gamma function */
  gsl_sf_result ln2; /* log of denominator Gamma function */
  double sgn = 1.0;
  double arg_val, arg_err;

  if(fabs(eta/(L+1.0)) < GSL_DBL_EPSILON) {
    gsl_sf_lngamma_e(L+1.0, &ln1);
  }
  else {
    gsl_sf_result p1;                 /* phase of numerator Gamma -- not used */
    gsl_sf_lngamma_complex_e(L+1.0, eta, &ln1, &p1); /* should be ok */
  }

  gsl_sf_lngamma_e(2.0*(L+1.0), &ln2);
  if(L < -1.0) sgn = -sgn;

  arg_val  = L*M_LN2 - 0.5*eta*M_PI + ln1.val - ln2.val;
  arg_err  = ln1.err + ln2.err;
  arg_err += GSL_DBL_EPSILON * (fabs(L*M_LN2) + fabs(0.5*eta*M_PI));
  return gsl_sf_exp_err_e(arg_val, arg_err, result);
}

int
gsl_sf_coulomb_CL_e(double lam, double eta, gsl_sf_result * result)
{
  /* CHECK_POINTER(result) */

  if(lam <= -1.0) {
    DOMAIN_ERROR(result);
  }
  else if(fabs(lam) < GSL_DBL_EPSILON) {
    /* saves a calculation of complex_lngamma(), otherwise not necessary */
    result->val = sqrt(C0sq(eta));
    result->err = 2.0 * GSL_DBL_EPSILON * result->val;
    return GSL_SUCCESS;
  }
  else {
    return CLeta(lam, eta, result);
  }
}

/* cl[0] .. cl[kmax] = C_{lam_min}(eta) .. C_{lam_min+kmax}(eta)
 */
int
gsl_sf_coulomb_CL_array(double lam_min, int kmax, double eta, double * cl)
{
  int k;
  gsl_sf_result cl_0;
  gsl_sf_coulomb_CL_e(lam_min, eta, &cl_0);
  cl[0] = cl_0.val;

  for(k=1; k<=kmax; k++) {
    double L = lam_min + k;
    cl[k] = cl[k-1] * hypot(L, eta)/(L*(2.0*L+1.0));
  }

  return GSL_SUCCESS;
}

/* Evaluate the series for Phi_L(eta,x) and Phi_L*(eta,x)
 * [Abramowitz+Stegun 14.1.5]
 * [Abramowitz+Stegun 14.1.13]
 *
 * The sequence of coefficients A_k^L is
 * manifestly well-controlled for L >= -1/2
 * and eta < 10.
 *
 * This makes sense since this is the region
 * away from threshold, and you expect
 * the evaluation to become easier as you
 * get farther from threshold.
 *
 * Empirically, this is quite well-behaved for
 *   L >= -1/2
 *   eta < 10
 *   x   < 10
 */
#if 0
static
int
coulomb_Phi_series(const double lam, const double eta, const double x,
                   double * result, double * result_star)
{
  int kmin =   5;
  int kmax = 200;
  int k;
  double Akm2 = 1.0;
  double Akm1 = eta/(lam+1.0);
  double Ak;

  double xpow = x;
  double sum  = Akm2 + Akm1*x;
  double sump = (lam+1.0)*Akm2 + (lam+2.0)*Akm1*x;
  double prev_abs_del   = fabs(Akm1*x);
  double prev_abs_del_p = (lam+2.0) * prev_abs_del;

  for(k=2; k<kmax; k++) {
    double del;
    double del_p;
    double abs_del;
    double abs_del_p;

    Ak = (2.0*eta*Akm1 - Akm2)/(k*(2.0*lam + 1.0 + k));

    xpow *= x;
    del   = Ak*xpow;
    del_p = (k+lam+1.0)*del;
    sum  += del;
    sump += del_p;

    abs_del   = fabs(del);
    abs_del_p = fabs(del_p);

    if(          abs_del/(fabs(sum)+abs_del)          < GSL_DBL_EPSILON
       &&   prev_abs_del/(fabs(sum)+prev_abs_del)     < GSL_DBL_EPSILON
       &&      abs_del_p/(fabs(sump)+abs_del_p)       < GSL_DBL_EPSILON
       && prev_abs_del_p/(fabs(sump)+prev_abs_del_p)  < GSL_DBL_EPSILON
       && k > kmin
       ) break;

    /* We need to keep track of the previous delta because when
     * eta is near zero the odd terms of the sum are very small
     * and this could lead to premature termination.
     */
    prev_abs_del   = abs_del;
    prev_abs_del_p = abs_del_p;

    Akm2 = Akm1;
    Akm1 = Ak;
  }

  *result      = sum;
  *result_star = sump;

  if(k==kmax) {
    GSL_ERROR ("error", GSL_EMAXITER);
  }
  else {
    return GSL_SUCCESS;
  }
}
#endif /* 0 */

/* Determine the connection phase, phi_lambda.
 * See coulomb_FG_series() below. We have
 * to be careful about sin(phi)->0. Note that
 * there is an underflow condition for large
 * positive eta in any case.
 */
static
int
coulomb_connection(const double lam, const double eta,
                   double * cos_phi, double * sin_phi)
{
  if(eta > -GSL_LOG_DBL_MIN/2.0*M_PI-1.0) {
    *cos_phi = 1.0;
    *sin_phi = 0.0;
    GSL_ERROR ("error", GSL_EUNDRFLW);
  }
  else if(eta > -GSL_LOG_DBL_EPSILON/(4.0*M_PI)) {
    const double eps = 2.0 * exp(-2.0*M_PI*eta);
    const double tpl = tan(M_PI * lam);
    const double dth = eps * tpl / (tpl*tpl + 1.0);
    *cos_phi = -1.0 + 0.5 * dth*dth;
    *sin_phi = -dth;
    return GSL_SUCCESS;
  }
  else {
    double X   = tanh(M_PI * eta) / tan(M_PI * lam);
    double phi = -atan(X) - (lam + 0.5) * M_PI;
    *cos_phi = cos(phi);
    *sin_phi = sin(phi);
    return GSL_SUCCESS;
  }
}

/* Evaluate the Frobenius series for F_lam(eta,x) and G_lam(eta,x).
 * Homegrown algebra. Evaluates the series for F_{lam} and
 * F_{-lam-1}, then uses
 *    G_{lam} = (F_{lam} cos(phi) - F_{-lam-1}) / sin(phi)
 * where
 *    phi = Arg[Gamma[1+lam+I eta]] - Arg[Gamma[-lam + I eta]] - (lam+1/2)Pi
 *        = Arg[Sin[Pi(-lam+I eta)] - (lam+1/2)Pi
 *        = atan2(-cos(lam Pi)sinh(eta Pi), -sin(lam Pi)cosh(eta Pi)) - (lam+1/2)Pi
 *
 *        = -atan(X) - (lam+1/2) Pi,  X = tanh(eta Pi)/tan(lam Pi)
 *
 * Not appropriate for lam <= -1/2, lam = 0, or lam >= 1/2.
 */
static
int
coulomb_FG_series(const double lam, const double eta, const double x,
                  gsl_sf_result * F, gsl_sf_result * G)
{
  const int max_iter = 800;
  gsl_sf_result ClamA;
  gsl_sf_result ClamB;
  int stat_A = CLeta(lam, eta, &ClamA);
  int stat_B = CLeta(-lam-1.0, eta, &ClamB);
  const double tlp1 = 2.0*lam + 1.0;
  const double pow_x = pow(x, lam);
  double cos_phi_lam;
  double sin_phi_lam;

  double uA_mm2 = 1.0;                  /* uA sum is for F_{lam} */
  double uA_mm1 = x*eta/(lam+1.0);
  double uA_m;
  double uB_mm2 = 1.0;                  /* uB sum is for F_{-lam-1} */
  double uB_mm1 = -x*eta/lam;
  double uB_m;
  double A_sum = uA_mm2 + uA_mm1;
  double B_sum = uB_mm2 + uB_mm1;
  double A_abs_del_prev = fabs(A_sum);
  double B_abs_del_prev = fabs(B_sum);
  gsl_sf_result FA, FB;
  int m = 2;

  int stat_conn = coulomb_connection(lam, eta, &cos_phi_lam, &sin_phi_lam);

  if(stat_conn == GSL_EUNDRFLW) {
    F->val = 0.0;  /* FIXME: should this be set to Inf too like G? */
    F->err = 0.0;
    OVERFLOW_ERROR(G);
  }

  while(m < max_iter) {
    double abs_dA;
    double abs_dB;
    uA_m = x*(2.0*eta*uA_mm1 - x*uA_mm2)/(m*(m+tlp1));
    uB_m = x*(2.0*eta*uB_mm1 - x*uB_mm2)/(m*(m-tlp1));
    A_sum += uA_m;
    B_sum += uB_m;
    abs_dA = fabs(uA_m);
    abs_dB = fabs(uB_m);
    if(m > 15) {
      /* Don't bother checking until we have gone out a little ways;
       * a minor optimization. Also make sure to check both the
       * current and the previous increment because the odd and even
       * terms of the sum can have very different behaviour, depending
       * on the value of eta.
       */
      double max_abs_dA = GSL_MAX(abs_dA, A_abs_del_prev);
      double max_abs_dB = GSL_MAX(abs_dB, B_abs_del_prev);
      double abs_A = fabs(A_sum);
      double abs_B = fabs(B_sum);
      if(   max_abs_dA/(max_abs_dA + abs_A) < 4.0*GSL_DBL_EPSILON
         && max_abs_dB/(max_abs_dB + abs_B) < 4.0*GSL_DBL_EPSILON
         ) break;
    }
    A_abs_del_prev = abs_dA;
    B_abs_del_prev = abs_dB;
    uA_mm2 = uA_mm1;
    uA_mm1 = uA_m;
    uB_mm2 = uB_mm1;
    uB_mm1 = uB_m;
    m++;
  }

  FA.val = A_sum * ClamA.val * pow_x * x;
  FA.err = fabs(A_sum) * ClamA.err * pow_x * x + 2.0*GSL_DBL_EPSILON*fabs(FA.val);
  FB.val = B_sum * ClamB.val / pow_x;
  FB.err = fabs(B_sum) * ClamB.err / pow_x + 2.0*GSL_DBL_EPSILON*fabs(FB.val);

  F->val = FA.val;
  F->err = FA.err;

  G->val = (FA.val * cos_phi_lam - FB.val)/sin_phi_lam;
  G->err = (FA.err * fabs(cos_phi_lam) + FB.err)/fabs(sin_phi_lam);

  if(m >= max_iter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_ERROR_SELECT_2(stat_A, stat_B);
}

/* Evaluate the Frobenius series for F_0(eta,x) and G_0(eta,x).
 * See [Bardin et al., CPC 3, 73 (1972), (14)-(17)];
 * note the misprint in (17): nu_0=1 is correct, not nu_0=0.
 */
static
int
coulomb_FG0_series(const double eta, const double x,
                   gsl_sf_result * F, gsl_sf_result * G)
{
  const int max_iter = 800;
  const double x2  = x*x;
  const double tex = 2.0*eta*x;
  gsl_sf_result C0;
  int stat_CL = CLeta(0.0, eta, &C0);
  gsl_sf_result r1pie;
  int psi_stat = gsl_sf_psi_1piy_e(eta, &r1pie);
  double u_mm2 = 0.0;  /* u_0 */
  double u_mm1 = x;    /* u_1 */
  double u_m;
  double v_mm2 = 1.0;                               /* nu_0 */
  double v_mm1 = tex*(2.0*M_EULER-1.0+r1pie.val);   /* nu_1 */
  double v_m;
  double u_sum = u_mm2 + u_mm1;
  double v_sum = v_mm2 + v_mm1;
  double u_abs_del_prev = fabs(u_sum);
  double v_abs_del_prev = fabs(v_sum);
  int m = 2;
  double u_sum_err = 2.0 * GSL_DBL_EPSILON * fabs(u_sum);
  double v_sum_err = 2.0 * GSL_DBL_EPSILON * fabs(v_sum);
  double ln2x = log(2.0*x);

  while(m < max_iter) {
    double abs_du;
    double abs_dv;
    double m_mm1 = m*(m-1.0);
    u_m = (tex*u_mm1 - x2*u_mm2)/m_mm1;
    v_m = (tex*v_mm1 - x2*v_mm2 - 2.0*eta*(2*m-1)*u_m)/m_mm1;
    u_sum += u_m;
    v_sum += v_m;
    abs_du = fabs(u_m);
    abs_dv = fabs(v_m);
    u_sum_err += 2.0 * GSL_DBL_EPSILON * abs_du;
    v_sum_err += 2.0 * GSL_DBL_EPSILON * abs_dv;
    if(m > 15) {
      /* Don't bother checking until we have gone out a little ways;
       * a minor optimization. Also make sure to check both the
       * current and the previous increment because the odd and even
       * terms of the sum can have very different behaviour, depending
       * on the value of eta.
       */
      double max_abs_du = GSL_MAX(abs_du, u_abs_del_prev);
      double max_abs_dv = GSL_MAX(abs_dv, v_abs_del_prev);
      double abs_u = fabs(u_sum);
      double abs_v = fabs(v_sum);
      if(   max_abs_du/(max_abs_du + abs_u) < 40.0*GSL_DBL_EPSILON
         && max_abs_dv/(max_abs_dv + abs_v) < 40.0*GSL_DBL_EPSILON
         ) break;
    }
    u_abs_del_prev = abs_du;
    v_abs_del_prev = abs_dv;
    u_mm2 = u_mm1;
    u_mm1 = u_m;
    v_mm2 = v_mm1;
    v_mm1 = v_m;
    m++;
  }

  F->val  = C0.val * u_sum;
  F->err  = C0.err * fabs(u_sum);
  F->err += fabs(C0.val) * u_sum_err;
  F->err += 2.0 * GSL_DBL_EPSILON * fabs(F->val);

  G->val  = (v_sum + 2.0*eta*u_sum * ln2x) / C0.val;
  G->err  = (fabs(v_sum) + fabs(2.0*eta*u_sum * ln2x)) / fabs(C0.val) * fabs(C0.err/C0.val);
  G->err += (v_sum_err + fabs(2.0*eta*u_sum_err*ln2x)) / fabs(C0.val);
  G->err += 2.0 * GSL_DBL_EPSILON * fabs(G->val);

  if(m == max_iter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return GSL_ERROR_SELECT_2(psi_stat, stat_CL);
}

/* Evaluate the Frobenius series for F_{-1/2}(eta,x) and G_{-1/2}(eta,x).
 * Homegrown algebra.
 */
static
int
coulomb_FGmhalf_series(const double eta, const double x,
                       gsl_sf_result * F, gsl_sf_result * G)
{
  const int max_iter = 800;
  const double rx  = sqrt(x);
  const double x2  = x*x;
  const double tex = 2.0*eta*x;
  gsl_sf_result Cmhalf;
  int stat_CL = CLeta(-0.5, eta, &Cmhalf);
  double u_mm2 = 1.0;                      /* u_0 */
  double u_mm1 = tex * u_mm2;              /* u_1 */
  double u_m;
  double v_mm2, v_mm1, v_m;
  double f_sum, g_sum;
  double tmp1;
  gsl_sf_result rpsi_1pe;
  gsl_sf_result rpsi_1p2e;
  int m = 2;

  gsl_sf_psi_1piy_e(eta,     &rpsi_1pe);
  gsl_sf_psi_1piy_e(2.0*eta, &rpsi_1p2e);

  v_mm2 = 2.0*M_EULER - M_LN2 - rpsi_1pe.val + 2.0*rpsi_1p2e.val;
  v_mm1 = tex*(v_mm2 - 2.0*u_mm2);

  f_sum = u_mm2 + u_mm1;
  g_sum = v_mm2 + v_mm1;

  while(m < max_iter) {
    double m2 = m*m;
    u_m = (tex*u_mm1 - x2*u_mm2)/m2;
    v_m = (tex*v_mm1 - x2*v_mm2 - 2.0*m*u_m)/m2;
    f_sum += u_m;
    g_sum += v_m;
    if(   f_sum != 0.0
       && g_sum != 0.0
       && (fabs(u_m/f_sum) + fabs(v_m/g_sum) < 10.0*GSL_DBL_EPSILON)) break;
    u_mm2 = u_mm1;
    u_mm1 = u_m;
    v_mm2 = v_mm1;
    v_mm1 = v_m;
    m++;
  }

  F->val = Cmhalf.val * rx * f_sum;
  F->err = Cmhalf.err * fabs(rx * f_sum) + 2.0*GSL_DBL_EPSILON*fabs(F->val);

  tmp1 = f_sum*log(x);
  G->val = -rx*(tmp1 + g_sum)/Cmhalf.val;
  G->err = fabs(rx)*(fabs(tmp1) + fabs(g_sum))/fabs(Cmhalf.val) * fabs(Cmhalf.err/Cmhalf.val);

  if(m == max_iter)
    GSL_ERROR ("error", GSL_EMAXITER);
  else
    return stat_CL;
}

/* Evolve the backwards recurrence for F,F'.
 *
 *    F_{lam-1}  = (S_lam F_lam + F_lam') / R_lam
 *    F_{lam-1}' = (S_lam F_{lam-1} - R_lam F_lam)
 * where
 *    R_lam = sqrt(1 + (eta/lam)^2)
 *    S_lam = lam/x + eta/lam
 *
 */
static
int
coulomb_F_recur(double lam_min, int kmax,
                double eta, double x,
                double F_lam_max, double Fp_lam_max,
                double * F_lam_min, double * Fp_lam_min
                )
{
  double x_inv = 1.0/x;
  double fcl = F_lam_max;
  double fpl = Fp_lam_max;
  double lam_max = lam_min + kmax;
  double lam = lam_max;
  int k;

  for(k=kmax-1; k>=0; k--) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el  + lam*x_inv;
    double fc_lm1;
    fc_lm1 = (fcl*sl + fpl)/rl;
    fpl    =  fc_lm1*sl - fcl*rl;
    fcl    =  fc_lm1;
    lam -= 1.0;
  }

  *F_lam_min  = fcl;
  *Fp_lam_min = fpl;
  return GSL_SUCCESS;
}

/* Evolve the forward recurrence for G,G'.
 *
 *   G_{lam+1}  = (S_lam G_lam - G_lam')/R_lam
 *   G_{lam+1}' = R_{lam+1} G_lam - S_lam G_{lam+1}
 *
 * where S_lam and R_lam are as above in the F recursion.
 */
static
int
coulomb_G_recur(const double lam_min, const int kmax,
                const double eta, const double x,
                const double G_lam_min, const double Gp_lam_min,
                double * G_lam_max, double * Gp_lam_max
                )
{
  double x_inv = 1.0/x;
  double gcl = G_lam_min;
  double gpl = Gp_lam_min;
  double lam = lam_min + 1.0;
  int k;

  for(k=1; k<=kmax; k++) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el + lam*x_inv;
    double gcl1 = (sl*gcl - gpl)/rl;
    gpl   = rl*gcl - sl*gcl1;
    gcl   = gcl1;
    lam += 1.0;
  }

  *G_lam_max  = gcl;
  *Gp_lam_max = gpl;
  return GSL_SUCCESS;
}

/* Evaluate the first continued fraction, giving
 * the ratio F'/F at the upper lambda value.
 * We also determine the sign of F at that point,
 * since it is the sign of the last denominator
 * in the continued fraction.
 */
static
int
coulomb_CF1(double lambda,
            double eta, double x,
            double * fcl_sign,
            double * result,
            int * count
            )
{
  const double CF1_small = 1.e-30;
  const double CF1_abort = 1.0e+05;
  const double CF1_acc   = 2.0*GSL_DBL_EPSILON;
  const double x_inv     = 1.0/x;
  const double px        = lambda + 1.0 + CF1_abort;

  double pk = lambda + 1.0;
  double F  = eta/pk + pk*x_inv;
  double D, C;
  double df;

  *fcl_sign = 1.0;
  *count = 0;

  if(fabs(F) < CF1_small) F = CF1_small;
  D = 0.0;
  C = F;

  do {
    double pk1 = pk + 1.0;
    double ek  = eta / pk;
    double rk2 = 1.0 + ek*ek;
    double tk  = (pk + pk1)*(x_inv + ek/pk1);
    D   =  tk - rk2 * D;
    C   =  tk - rk2 / C;
    if(fabs(C) < CF1_small) C = CF1_small;
    if(fabs(D) < CF1_small) D = CF1_small;
    D = 1.0/D;
    df = D * C;
    F  = F * df;
    if(D < 0.0) {
      /* sign of result depends on sign of denominator */
      *fcl_sign = - *fcl_sign;
    }
    pk = pk1;
    if( pk > px ) {
      *result = F;
      GSL_ERROR ("error", GSL_ERUNAWAY);
    }
    ++(*count);
  }
  while(fabs(df-1.0) > CF1_acc);

  *result = F;
  return GSL_SUCCESS;
}

#if 0
static
int
old_coulomb_CF1(const double lambda,
                double eta, double x,
                double * fcl_sign,
                double * result
                )
{
  const double CF1_abort = 1.e5;
  const double CF1_acc   = 10.0*GSL_DBL_EPSILON;
  const double x_inv     = 1.0/x;
  const double px        = lambda + 1.0 + CF1_abort;

  double pk = lambda + 1.0;

  double D;
  double df;

  double F;
  double p;
  double pk1;
  double ek;

  double fcl = 1.0;

  double tk;

  while(1) {
    ek = eta/pk;
    F = (ek + pk*x_inv)*fcl + (fcl - 1.0)*x_inv;
    pk1 = pk + 1.0;
    if(fabs(eta*x + pk*pk1) > CF1_acc) break;
    fcl = (1.0 + ek*ek)/(1.0 + eta*eta/(pk1*pk1));
    pk = 2.0 + pk;
  }

  D  = 1.0/((pk + pk1)*(x_inv + ek/pk1));
  df = -fcl*(1.0 + ek*ek)*D;

  if(fcl != 1.0) fcl = -1.0;
  if(D    < 0.0) fcl = -fcl;

  F = F + df;

  p = 1.0;
  do {
    pk = pk1;
    pk1 = pk + 1.0;
    ek  = eta / pk;
    tk  = (pk + pk1)*(x_inv + ek/pk1);
    D   =  tk - D*(1.0+ek*ek);
    if(fabs(D) < sqrt(CF1_acc)) {
      p += 1.0;
      if(p > 2.0) {
        printf("HELP............\n");
      }
    }
    D = 1.0/D;
    if(D < 0.0) {
      /* sign of result depends on sign of denominator */
      fcl = -fcl;
    }
    df = df*(D*tk - 1.0);
    F  = F + df;
    if( pk > px ) {
      GSL_ERROR ("error", GSL_ERUNAWAY);
    }
  }
  while(fabs(df) > fabs(F)*CF1_acc);

  *fcl_sign = fcl;
  *result = F;
  return GSL_SUCCESS;
}
#endif /* 0 */

/* Evaluate the second continued fraction to
 * obtain the ratio
 *    (G' + i F')/(G + i F) := P + i Q
 * at the specified lambda value.
 */
static
int
coulomb_CF2(const double lambda, const double eta, const double x,
            double * result_P, double * result_Q, int * count
            )
{
  int status = GSL_SUCCESS;

  const double CF2_acc   = 4.0*GSL_DBL_EPSILON;
  const double CF2_abort = 2.0e+05;

  const double wi    = 2.0*eta;
  const double x_inv = 1.0/x;
  const double e2mm1 = eta*eta + lambda*(lambda + 1.0);

  double ar = -e2mm1;
  double ai =  eta;

  double br =  2.0*(x - eta);
  double bi =  2.0;

  double dr =  br/(br*br + bi*bi);
  double di = -bi/(br*br + bi*bi);

  double dp = -x_inv*(ar*di + ai*dr);
  double dq =  x_inv*(ar*dr - ai*di);

  double A, B, C, D;

  double pk =  0.0;
  double P  =  0.0;
  double Q  =  1.0 - eta*x_inv;

  *count = 0;

  do {
    P += dp;
    Q += dq;
    pk += 2.0;
    ar += pk;
    ai += wi;
    bi += 2.0;
    D  = ar*dr - ai*di + br;
    di = ai*dr + ar*di + bi;
    C  = 1.0/(D*D + di*di);
    dr =  C*D;
    di = -C*di;
    A  = br*dr - bi*di - 1.;
    B  = bi*dr + br*di;
    C  = dp*A  - dq*B;
    dq = dp*B  + dq*A;
    dp = C;
    if(pk > CF2_abort) {
      status = GSL_ERUNAWAY;
      break;
    }
    ++(*count);
  }
  while(fabs(dp)+fabs(dq) > (fabs(P)+fabs(Q))*CF2_acc);

  if(Q < CF2_abort*GSL_DBL_EPSILON*fabs(P)) {
    status = GSL_ELOSS;
  }

  *result_P = P;
  *result_Q = Q;
  return status;
}

/* WKB evaluation of F, G. Assumes  0 < x < turning point.
 * Overflows are trapped, GSL_EOVRFLW is signalled,
 * and an exponent is returned such that:
 *
 *   result_F = fjwkb * exp(-exponent)
 *   result_G = gjwkb * exp( exponent)
 *
 * See [Biedenharn et al. Phys. Rev. 97, 542-554 (1955), Section IV]
 *
 * Unfortunately, this is not very accurate in general. The
 * test cases typically have 3-4 digits of precision. One could
 * argue that this is ok for general use because, for instance,
 * F is exponentially small in this region and so the absolute
 * accuracy is still roughly acceptable. But it would be better
 * to have a systematic method for improving the precision. See
 * the Abad+Sesma method discussion below.
 */
static
int
coulomb_jwkb(const double lam, const double eta, const double x,
             gsl_sf_result * fjwkb, gsl_sf_result * gjwkb,
             double * exponent)
{
  const double llp1      = lam*(lam+1.0) + 6.0/35.0;
  const double llp1_eff  = GSL_MAX(llp1, 0.0);
  const double rho_ghalf = sqrt(x*(2.0*eta - x) + llp1_eff);
  const double sinh_arg  = sqrt(llp1_eff/(eta*eta+llp1_eff)) * rho_ghalf / x;
  const double sinh_inv  = log(sinh_arg + hypot(1.0,sinh_arg));

  const double phi = fabs(rho_ghalf - eta*atan2(rho_ghalf,x-eta) - sqrt(llp1_eff) * sinh_inv);

  const double zeta_half = pow(3.0*phi/2.0, 1.0/3.0);
  const double prefactor = sqrt(M_PI*phi*x/(6.0 * rho_ghalf));

  double F = prefactor * 3.0/zeta_half;
  double G = prefactor * 3.0/zeta_half; /* Note the sqrt(3) from Bi normalization */
  double F_exp;
  double G_exp;

  const double airy_scale_exp = phi;
  gsl_sf_result ai;
  gsl_sf_result bi;
  gsl_sf_airy_Ai_scaled_e(zeta_half*zeta_half, GSL_MODE_DEFAULT, &ai);
  gsl_sf_airy_Bi_scaled_e(zeta_half*zeta_half, GSL_MODE_DEFAULT, &bi);
  F *= ai.val;
  G *= bi.val;
  F_exp = log(F) - airy_scale_exp;
  G_exp = log(G) + airy_scale_exp;

  if(G_exp >= GSL_LOG_DBL_MAX) {
    fjwkb->val = F;
    gjwkb->val = G;
    fjwkb->err = 1.0e-3 * fabs(F); /* FIXME: real error here ... could be smaller */
    gjwkb->err = 1.0e-3 * fabs(G);
    *exponent = airy_scale_exp;
    GSL_ERROR ("error", GSL_EOVRFLW);
  }
  else {
    fjwkb->val = exp(F_exp);
    gjwkb->val = exp(G_exp);
    fjwkb->err = 1.0e-3 * fabs(fjwkb->val);
    gjwkb->err = 1.0e-3 * fabs(gjwkb->val);
    *exponent = 0.0;
    return GSL_SUCCESS;
  }
}

/* Asymptotic evaluation of F and G below the minimal turning point.
 *
 * This is meant to be a drop-in replacement for coulomb_jwkb().
 * It uses the expressions in [Abad+Sesma]. This requires some
 * work because I am not sure where it is valid. They mumble
 * something about |x| < |lam|^(-1/2) or 8|eta x| > lam when |x| < 1.
 * This seems true, but I thought the result was based on a uniform
 * expansion and could be controlled by simply using more terms.
 */
#if 0
static
int
coulomb_AS_xlt2eta(const double lam, const double eta, const double x,
                   gsl_sf_result * f_AS, gsl_sf_result * g_AS,
                   double * exponent)
{
  /* no time to do this now... */
}
#endif /* 0 */

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

int
gsl_sf_coulomb_wave_FG_e(const double eta, const double x,
                            const double lam_F,
                            const int  k_lam_G,      /* lam_G = lam_F - k_lam_G */
                            gsl_sf_result * F, gsl_sf_result * Fp,
                            gsl_sf_result * G, gsl_sf_result * Gp,
                            double * exp_F, double * exp_G)
{
  const double lam_G = lam_F - k_lam_G;

  if(x < 0.0 || lam_F <= -0.5 || lam_G <= -0.5) {
    GSL_SF_RESULT_SET(F,  0.0, 0.0);
    GSL_SF_RESULT_SET(Fp, 0.0, 0.0);
    GSL_SF_RESULT_SET(G,  0.0, 0.0);
    GSL_SF_RESULT_SET(Gp, 0.0, 0.0);
    *exp_F = 0.0;
    *exp_G = 0.0;
    GSL_ERROR ("domain error", GSL_EDOM);
  }
  else if(x == 0.0) {
    gsl_sf_result C0;
    CLeta(0.0, eta, &C0);
    GSL_SF_RESULT_SET(F,  0.0, 0.0);
    GSL_SF_RESULT_SET(Fp, 0.0, 0.0);
    GSL_SF_RESULT_SET(G,  0.0, 0.0); /* FIXME: should be Inf */
    GSL_SF_RESULT_SET(Gp, 0.0, 0.0); /* FIXME: should be Inf */
    *exp_F = 0.0;
    *exp_G = 0.0;
    if(lam_F == 0.0){
      GSL_SF_RESULT_SET(Fp, C0.val, C0.err);
    }
    if(lam_G == 0.0) {
      GSL_SF_RESULT_SET(Gp, 1.0/C0.val, fabs(C0.err/C0.val)/fabs(C0.val));
    }
    GSL_ERROR ("domain error", GSL_EDOM);
    /* After all, since we are asking for G, this is a domain error... */
  }
  else if(x < 1.2 && 2.0*M_PI*eta < 0.9*(-GSL_LOG_DBL_MIN) && fabs(eta*x) < 10.0) {
    /* Reduce to a small lambda value and use the series
     * representations for F and G. We cannot allow eta to
     * be large and positive because the connection formula
     * for G_lam is badly behaved due to an underflow in sin(phi_lam)
     * [see coulomb_FG_series() and coulomb_connection() above].
     * Note that large negative eta is ok however.
     */
    const double SMALL = GSL_SQRT_DBL_EPSILON;
    const int N    = (int)(lam_F + 0.5);
    const int span = GSL_MAX(k_lam_G, N);
    const double lam_min = lam_F - N;    /* -1/2 <= lam_min < 1/2 */
    double F_lam_F, Fp_lam_F;
    double G_lam_G, Gp_lam_G;
    double F_lam_F_err, Fp_lam_F_err;
    double Fp_over_F_lam_F;
    double F_sign_lam_F;
    double F_lam_min_unnorm, Fp_lam_min_unnorm;
    double Fp_over_F_lam_min;
    gsl_sf_result F_lam_min;
    gsl_sf_result G_lam_min, Gp_lam_min;
    double F_scale;
    double Gerr_frac;
    double F_scale_frac_err;
    double F_unnorm_frac_err;

    /* Determine F'/F at lam_F. */
    int CF1_count;
    int stat_CF1 = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);

    int stat_ser;
    int stat_Fr;
    int stat_Gr;

    /* Recurse down with unnormalized F,F' values. */
    F_lam_F  = SMALL;
    Fp_lam_F = Fp_over_F_lam_F * F_lam_F;
    if(span != 0) {
      stat_Fr = coulomb_F_recur(lam_min, span, eta, x,
                                F_lam_F, Fp_lam_F,
                                &F_lam_min_unnorm, &Fp_lam_min_unnorm
                                );
    }
    else {
      F_lam_min_unnorm  =  F_lam_F;
      Fp_lam_min_unnorm = Fp_lam_F;
      stat_Fr = GSL_SUCCESS;
    }

    /* Determine F and G at lam_min. */
    if(lam_min == -0.5) {
      stat_ser = coulomb_FGmhalf_series(eta, x, &F_lam_min, &G_lam_min);
    }
    else if(lam_min == 0.0) {
      stat_ser = coulomb_FG0_series(eta, x, &F_lam_min, &G_lam_min);
    }
    else if(lam_min == 0.5) {
      /* This cannot happen. */
      F->val  = F_lam_F;
      F->err  = 2.0 * GSL_DBL_EPSILON * fabs(F->val);
      Fp->val = Fp_lam_F;
      Fp->err = 2.0 * GSL_DBL_EPSILON * fabs(Fp->val);
      G->val  = G_lam_G;
      G->err  = 2.0 * GSL_DBL_EPSILON * fabs(G->val);
      Gp->val = Gp_lam_G;
      Gp->err = 2.0 * GSL_DBL_EPSILON * fabs(Gp->val);
      *exp_F = 0.0;
      *exp_G = 0.0;
      GSL_ERROR ("error", GSL_ESANITY);
    }
    else {
      stat_ser = coulomb_FG_series(lam_min, eta, x, &F_lam_min, &G_lam_min);
    }

    /* Determine remaining quantities. */
    Fp_over_F_lam_min = Fp_lam_min_unnorm / F_lam_min_unnorm;
    Gp_lam_min.val  = Fp_over_F_lam_min*G_lam_min.val - 1.0/F_lam_min.val;
    Gp_lam_min.err  = fabs(Fp_over_F_lam_min)*G_lam_min.err;
    Gp_lam_min.err += fabs(1.0/F_lam_min.val) * fabs(F_lam_min.err/F_lam_min.val);
    F_scale     = F_lam_min.val / F_lam_min_unnorm;

    /* Apply scale to the original F,F' values. */
    F_scale_frac_err  = fabs(F_lam_min.err/F_lam_min.val);
    F_unnorm_frac_err = 2.0*GSL_DBL_EPSILON*(CF1_count+span+1);
    F_lam_F     *= F_scale;
    F_lam_F_err  = fabs(F_lam_F) * (F_unnorm_frac_err + F_scale_frac_err);
    Fp_lam_F    *= F_scale;
    Fp_lam_F_err = fabs(Fp_lam_F) * (F_unnorm_frac_err + F_scale_frac_err);

    /* Recurse up to get the required G,G' values. */
    stat_Gr = coulomb_G_recur(lam_min, GSL_MAX(N-k_lam_G,0), eta, x,
                              G_lam_min.val, Gp_lam_min.val,
                              &G_lam_G, &Gp_lam_G
                              );

    F->val  = F_lam_F;
    F->err  = F_lam_F_err;
    F->err += 2.0 * GSL_DBL_EPSILON * fabs(F_lam_F);

    Fp->val  = Fp_lam_F;
    Fp->err  = Fp_lam_F_err;
    Fp->err += 2.0 * GSL_DBL_EPSILON * fabs(Fp_lam_F);

    Gerr_frac = fabs(G_lam_min.err/G_lam_min.val) + fabs(Gp_lam_min.err/Gp_lam_min.val);

    G->val  = G_lam_G;
    G->err  = Gerr_frac * fabs(G_lam_G);
    G->err += 2.0 * (CF1_count+1) * GSL_DBL_EPSILON * fabs(G->val);

    Gp->val  = Gp_lam_G;
    Gp->err  = Gerr_frac * fabs(Gp->val);
    Gp->err += 2.0 * (CF1_count+1) * GSL_DBL_EPSILON * fabs(Gp->val);

    *exp_F = 0.0;
    *exp_G = 0.0;

    return GSL_ERROR_SELECT_4(stat_ser, stat_CF1, stat_Fr, stat_Gr);
  }
  else if(x < 2.0*eta) {
    /* Use WKB approximation to obtain F and G at the two
     * lambda values, and use the Wronskian and the
     * continued fractions for F'/F to obtain F' and G'.
     */
    gsl_sf_result F_lam_F, G_lam_F;
    gsl_sf_result F_lam_G, G_lam_G;
    double exp_lam_F, exp_lam_G;
    int stat_lam_F;
    int stat_lam_G;
    int stat_CF1_lam_F;
    int stat_CF1_lam_G;
    int CF1_count;
    double Fp_over_F_lam_F;
    double Fp_over_F_lam_G;
    double F_sign_lam_F;
    double F_sign_lam_G;

    stat_lam_F = coulomb_jwkb(lam_F, eta, x, &F_lam_F, &G_lam_F, &exp_lam_F);
    if(k_lam_G == 0) {
      stat_lam_G = stat_lam_F;
      F_lam_G = F_lam_F;
      G_lam_G = G_lam_F;
      exp_lam_G = exp_lam_F;
    }
    else {
      stat_lam_G = coulomb_jwkb(lam_G, eta, x, &F_lam_G, &G_lam_G, &exp_lam_G);
    }

    stat_CF1_lam_F = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);
    if(k_lam_G == 0) {
      stat_CF1_lam_G  = stat_CF1_lam_F;
      F_sign_lam_G    = F_sign_lam_F;
      Fp_over_F_lam_G = Fp_over_F_lam_F;
    }
    else {
      stat_CF1_lam_G = coulomb_CF1(lam_G, eta, x, &F_sign_lam_G, &Fp_over_F_lam_G, &CF1_count);
    }

    F->val = F_lam_F.val;
    F->err = F_lam_F.err;

    G->val = G_lam_G.val;
    G->err = G_lam_G.err;

    Fp->val  = Fp_over_F_lam_F * F_lam_F.val;
    Fp->err  = fabs(Fp_over_F_lam_F) * F_lam_F.err;
    Fp->err += 2.0*GSL_DBL_EPSILON*fabs(Fp->val);

    Gp->val  = Fp_over_F_lam_G * G_lam_G.val - 1.0/F_lam_G.val;
    Gp->err  = fabs(Fp_over_F_lam_G) * G_lam_G.err;
    Gp->err += fabs(1.0/F_lam_G.val) * fabs(F_lam_G.err/F_lam_G.val);

    *exp_F = exp_lam_F;
    *exp_G = exp_lam_G;

    if(stat_lam_F == GSL_EOVRFLW || stat_lam_G == GSL_EOVRFLW) {
      GSL_ERROR ("overflow", GSL_EOVRFLW);
    }
    else {
      return GSL_ERROR_SELECT_2(stat_lam_F, stat_lam_G);
    }
  }
  else {
    /* x > 2 eta, so we know that we can find a lambda value such
     * that x is above the turning point. We do this, evaluate
     * using Steed's method at that oscillatory point, then
     * use recursion on F and G to obtain the required values.
     *
     * lam_0   = a value of lambda such that x is below the turning point
     * lam_min = minimum of lam_0 and the requested lam_G, since
     *           we must go at least as low as lam_G
     */
    const double SMALL = GSL_SQRT_DBL_EPSILON;
    const double C = sqrt(1.0 + 4.0*x*(x-2.0*eta));
    const int N = ceil(lam_F - C + 0.5);
    const double lam_0   = lam_F - GSL_MAX(N, 0);
    const double lam_min = GSL_MIN(lam_0, lam_G);
    double F_lam_F, Fp_lam_F;
    double G_lam_G, Gp_lam_G;
    double F_lam_min_unnorm, Fp_lam_min_unnorm;
    double F_lam_min, Fp_lam_min;
    double G_lam_min, Gp_lam_min;
    double Fp_over_F_lam_F;
    double Fp_over_F_lam_min;
    double F_sign_lam_F, F_sign_lam_min;
    double P_lam_min, Q_lam_min;
    double alpha;
    double gamma;
    double F_scale;

    int CF1_count;
    int CF2_count;
    int stat_CF1 = coulomb_CF1(lam_F, eta, x, &F_sign_lam_F, &Fp_over_F_lam_F, &CF1_count);
    int stat_CF2;
    int stat_Fr;
    int stat_Gr;

    int F_recur_count;
    int G_recur_count;

    double err_amplify;

    F_lam_F  = F_sign_lam_F * SMALL;  /* unnormalized */
    Fp_lam_F = Fp_over_F_lam_F * F_lam_F;

    /* Backward recurrence to get F,Fp at lam_min */
    F_recur_count = GSL_MAX(k_lam_G, N);
    stat_Fr = coulomb_F_recur(lam_min, F_recur_count, eta, x,
                              F_lam_F, Fp_lam_F,
                              &F_lam_min_unnorm, &Fp_lam_min_unnorm
                              );
    Fp_over_F_lam_min = Fp_lam_min_unnorm / F_lam_min_unnorm;

    /* Steed evaluation to complete evaluation of F,Fp,G,Gp at lam_min */
    stat_CF2 = coulomb_CF2(lam_min, eta, x, &P_lam_min, &Q_lam_min, &CF2_count);
    alpha = Fp_over_F_lam_min - P_lam_min;
    gamma = alpha/Q_lam_min;

    F_sign_lam_min = GSL_SIGN(F_lam_min_unnorm) ;

    F_lam_min  = F_sign_lam_min / sqrt(alpha*alpha/Q_lam_min + Q_lam_min);
    Fp_lam_min = Fp_over_F_lam_min * F_lam_min;
    G_lam_min  = gamma * F_lam_min;
    Gp_lam_min = (P_lam_min * gamma - Q_lam_min) * F_lam_min;

    /* Apply scale to values of F,Fp at lam_F (the top). */
    F_scale = F_lam_min / F_lam_min_unnorm;
    F_lam_F  *= F_scale;
    Fp_lam_F *= F_scale;

    /* Forward recurrence to get G,Gp at lam_G (the top). */
    G_recur_count = GSL_MAX(N-k_lam_G,0);
    stat_Gr = coulomb_G_recur(lam_min, G_recur_count, eta, x,
                              G_lam_min, Gp_lam_min,
                              &G_lam_G, &Gp_lam_G
                              );

    err_amplify = CF1_count + CF2_count + F_recur_count + G_recur_count + 1;

    F->val  = F_lam_F;
    F->err  = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(F->val);

    Fp->val = Fp_lam_F;
    Fp->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(Fp->val);

    G->val  = G_lam_G;
    G->err  = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(G->val);

    Gp->val = Gp_lam_G;
    Gp->err = 8.0*err_amplify*GSL_DBL_EPSILON * fabs(Gp->val);

    *exp_F = 0.0;
    *exp_G = 0.0;

    return GSL_ERROR_SELECT_4(stat_CF1, stat_CF2, stat_Fr, stat_Gr);
  }
}

int
gsl_sf_coulomb_wave_F_array(double lam_min, int kmax,
                                 double eta, double x,
                                 double * fc_array,
                                 double * F_exp)
{
  if(x == 0.0) {
    int k;
    *F_exp = 0.0;
    for(k=0; k<=kmax; k++) {
      fc_array[k] = 0.0;
    }
    if(lam_min == 0.0){
      gsl_sf_result f_0;
      CLeta(0.0, eta, &f_0);
      fc_array[0] = f_0.val;
    }
    return GSL_SUCCESS;
  }
  else {
    const double x_inv = 1.0/x;
    const double lam_max = lam_min + kmax;
    gsl_sf_result F, Fp;
    gsl_sf_result G, Gp;
    double G_exp;

    int stat_FG = gsl_sf_coulomb_wave_FG_e(eta, x, lam_max, 0,
                                              &F, &Fp, &G, &Gp, F_exp, &G_exp);

    double fcl  = F.val;
    double fpl = Fp.val;
    double lam = lam_max;
    int k;

    fc_array[kmax] = F.val;

    for(k=kmax-1; k>=0; k--) {
      double el = eta/lam;
      double rl = hypot(1.0, el);
      double sl = el  + lam*x_inv;
      double fc_lm1 = (fcl*sl + fpl)/rl;
      fc_array[k]   = fc_lm1;
      fpl           =  fc_lm1*sl - fcl*rl;
      fcl           =  fc_lm1;
      lam -= 1.0;
    }

    return stat_FG;
  }
}

int
gsl_sf_coulomb_wave_FG_array(double lam_min, int kmax,
                                  double eta, double x,
                                  double * fc_array, double * gc_array,
                                  double * F_exp, double * G_exp)
{
  const double x_inv = 1.0/x;
  const double lam_max = lam_min + kmax;
  gsl_sf_result F, Fp;
  gsl_sf_result G, Gp;

  int stat_FG = gsl_sf_coulomb_wave_FG_e(eta, x, lam_max, kmax,
                                            &F, &Fp, &G, &Gp, F_exp, G_exp);

  double fcl  = F.val;
  double fpl = Fp.val;
  double lam = lam_max;
  int k;

  double gcl, gpl;

  fc_array[kmax] = F.val;

  for(k=kmax-1; k>=0; k--) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el  + lam*x_inv;
    double fc_lm1;
    fc_lm1 = (fcl*sl + fpl)/rl;
    fc_array[k] = fc_lm1;
    fpl         =  fc_lm1*sl - fcl*rl;
    fcl         =  fc_lm1;
    lam -= 1.0;
  }

  gcl = G.val;
  gpl = Gp.val;
  lam = lam_min + 1.0;

  gc_array[0] = G.val;

  for(k=1; k<=kmax; k++) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el + lam*x_inv;
    double gcl1 = (sl*gcl - gpl)/rl;
    gc_array[k] = gcl1;
    gpl         = rl*gcl - sl*gcl1;
    gcl         = gcl1;
    lam += 1.0;
  }

  return stat_FG;
}

int
gsl_sf_coulomb_wave_FGp_array(double lam_min, int kmax,
                                   double eta, double x,
                                   double * fc_array, double * fcp_array,
                                   double * gc_array, double * gcp_array,
                                   double * F_exp, double * G_exp)

{
  const double x_inv = 1.0/x;
  const double lam_max = lam_min + kmax;
  gsl_sf_result F, Fp;
  gsl_sf_result G, Gp;

  int stat_FG = gsl_sf_coulomb_wave_FG_e(eta, x, lam_max, kmax,
                                            &F, &Fp, &G, &Gp, F_exp, G_exp);

  double fcl  = F.val;
  double fpl = Fp.val;
  double lam = lam_max;
  int k;

  double gcl, gpl;

  fc_array[kmax]  = F.val;
  fcp_array[kmax] = Fp.val;

  for(k=kmax-1; k>=0; k--) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el  + lam*x_inv;
    double fc_lm1;
    fc_lm1 = (fcl*sl + fpl)/rl;
    fc_array[k]  = fc_lm1;
    fpl          = fc_lm1*sl - fcl*rl;
    fcp_array[k] = fpl;
    fcl          =  fc_lm1;
    lam -= 1.0;
  }

  gcl = G.val;
  gpl = Gp.val;
  lam = lam_min + 1.0;

  gc_array[0]  = G.val;
  gcp_array[0] = Gp.val;

  for(k=1; k<=kmax; k++) {
    double el = eta/lam;
    double rl = hypot(1.0, el);
    double sl = el + lam*x_inv;
    double gcl1 = (sl*gcl - gpl)/rl;
    gc_array[k]  = gcl1;
    gpl          = rl*gcl - sl*gcl1;
    gcp_array[k] = gpl;
    gcl          = gcl1;
    lam += 1.0;
  }

  return stat_FG;
}

int
gsl_sf_coulomb_wave_sphF_array(double lam_min, int kmax,
                                    double eta, double x,
                                    double * fc_array,
                                    double * F_exp)
{
  if(x < 0.0 || lam_min < -0.5) {
    GSL_ERROR ("domain error", GSL_EDOM);
  }
  else if(x < 10.0/GSL_DBL_MAX) {
    int k;
    for(k=0; k<=kmax; k++) {
      fc_array[k] = 0.0;
    }
    if(lam_min == 0.0) {
      fc_array[0] = sqrt(C0sq(eta));
    }
    *F_exp = 0.0;
    if(x == 0.0)
      return GSL_SUCCESS;
    else
      GSL_ERROR ("underflow", GSL_EUNDRFLW);
  }
  else {
    int k;
    int stat_F = gsl_sf_coulomb_wave_F_array(lam_min, kmax,
                                                  eta, x,
                                                  fc_array,
                                                  F_exp);

    for(k=0; k<=kmax; k++) {
      fc_array[k] = fc_array[k] / x;
    }
    return stat_F;
  }
}


#include <stdio.h>
#include <gsl/gsl_errno.h>
#include <gsl/gsl_roots.h>
#include <gsl/gsl_math.h>
#include "zero_crossing.h"

/* \fn double zero_crossing(double (*model)(double, void *), void *params, double *x_lo, double *x_hi)
 * \brief Find a zero crossing of the supplied model. */
double zero_crossing(double (*model)(double, void *), void *params, double *x_lo, double *x_hi)
{
	int status;
	int iter=0;
	int max_iter = 100;

	double x;	//root

	const gsl_root_fsolver_type *T;
	gsl_root_fsolver *s;

	gsl_function F;

	F.function = model;
	F.params   = params;

	T = gsl_root_fsolver_brent;
	s = gsl_root_fsolver_alloc(T);

	gsl_root_fsolver_set(s,&F, *x_lo, *x_hi);

	do{
		iter++;
		status = gsl_root_fsolver_iterate(s);
		x      = gsl_root_fsolver_root(s);

		*x_lo   = gsl_root_fsolver_x_lower(s);
		*x_hi   = gsl_root_fsolver_x_upper(s);

		status = gsl_root_test_interval(*x_lo, *x_hi,0,0.001);

		//printf("iter %d x_lo %e x %e x_hi %e\n",iter,*x_lo,x,*x_hi);

	}while((status==GSL_CONTINUE)&&(iter<max_iter));

	gsl_root_fsolver_free(s);

	return x;
}


/* Matrix Method Finite Difference Schrodinger/Poisson Solver 3.1*/
/* C.R.J. Fisher;
07_2012 */
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <error.h>
#include <gsl/gsl_math.h>
#include <gsl/gsl_eigen.h>
#include <gsl/gsl_linalg.h>

void Normalise(gsl_vector *Single_eigvector_ptr, int Dim, double dx, FILE *fp_2)
{
    int n;
    double temp;
    double norm_factor, vector_sum=0;
    for (n=0; n<Dim; n++){
        temp = gsl_vector_get(Single_eigvector_ptr, n);
        vector_sum = vector_sum + temp*temp*dx;
    }
    norm_factor = sqrt(vector_sum);
    for (n=0; n<Dim; n++){
        temp = (gsl_vector_get(Single_eigvector_ptr, n))/norm_factor;
        gsl_vector_set(Single_eigvector_ptr, n, temp);
        fprintf(fp_2, "n%E", gsl_vector_get(Single_eigvector_ptr, n));
        /*output mth value of nth eigenvector*/
    }
}

int Schrodinger_Solve(double dx, int Dim, int barrier_L, int barrier_R, double E_well, double *Meff_ptr, double *subband_ptr,
gsl_eigen_symmv_workspace *Workspace, gsl_matrix *Hamil_ptr, gsl_vector *Eigvalue_ptr, gsl_matrix *Eigvector_ptr,
gsl_vector *s_eigvector_ptr, gsl_vector *Potential_ptr, gsl_matrix *Norm_Eigvector_ptr, FILE *fp_1, FILE *fp_2 ){
    int n, m, N=0;
    double Hbar=1.054571E-34, Element;
    double t_0=(Hbar*Hbar)/(2*dx*dx);
    for (n = 0; n < Dim; n++)
    {
        for (m = 0; m < Dim; m++)
        {
            if (n == m) /*main diagonal*/
            {
                Element = t_0/Meff_ptr[n-1] + t_0/Meff_ptr[n+1] + gsl_vector_get(Potential_ptr, n);
            }
            else if (n == m-1) /*subdiagonal*/
            {
                Element = -1*t_0/Meff_ptr[n-1];
            }
            else if (n == m+1) /*superdiagonal*/
            {
                Element = -1*t_0/Meff_ptr[n+1];
            }
            else
            {
                Element = 0;
                /*all other matrix elements*/
            }
            gsl_matrix_set(Hamil_ptr, n, m, Element);
            /*transfer value to matrix*/
        }
    }
    gsl_eigen_symmv(Hamil_ptr, Eigvalue_ptr, Eigvector_ptr, Workspace);
    /*solve matrix*/
    gsl_eigen_symmv_sort(Eigvalue_ptr, Eigvector_ptr, GSL_EIGEN_SORT_VAL_ASC);
    /*re-order the results in ascending order*/
    /*output eigenvalues*/
    for (n = 0; n < Dim; n++){
        double eigenvalue = gsl_vector_get(Eigvalue_ptr, n);
        if (eigenvalue>E_well && eigenvalue<0) /*select confined states*/
        {
            fprintf(fp_1, "n%E", (eigenvalue/1.6E-22));
            /*output in meV*/
            subband_ptr[n] = eigenvalue; /*For Fermi-Dirac */
            N = N+1;
            /* sum the number of eigenstates*/
        }
    }
    /*output eigenvectors*/
    for (n = 0; n < N; n++){  /*retrieve eigenvectors for confined states only*/
        fprintf(fp_2, "nnnn");
        gsl_matrix_get_col(s_eigvector_ptr, Eigvector_ptr, n);
        /*retrieve nth eigenvector*/
        Normalise(s_eigvector_ptr, Dim, dx, fp_2);
        /*normalise eigenvector*/
        gsl_matrix_set_col(Norm_Eigvector_ptr, n, s_eigvector_ptr);
    }
    return N;
}

double FD_Bisect(double *Subband_f, double E_fermi_super, double E_fermi_diff, double c_doping_yz, double Meff, int N, int T)
{
    double n_sp = 0, n_s = 0;
    double Hbar=1.054571E-34, Kb = 1.38065E-23;
    int n, m;
    /*temperature set to 300K*/
    double DOS = Meff/(Hbar*Hbar*3.14159);
    double E_fermi_sub = E_fermi_super + E_fermi_diff;
    double E_fermi_mid = (E_fermi_sub + E_fermi_super)/2;
    for (n=0; n<50; n++){
        for (m = 0; m < N; m++){ /*add contributions from all subbands*/
            n_sp = DOS*Kb*T*log(exp((E_fermi_mid - Subband_f[m])/(Kb*T)) + 1);
            n_s = n_sp + n_s;
        }
        if (n_s > c_doping_yz){
            E_fermi_super = E_fermi_mid;
            E_fermi_mid = (E_fermi_super + E_fermi_sub)/2;
        }
        else {
            E_fermi_sub = E_fermi_mid;
            E_fermi_mid = (E_fermi_sub + E_fermi_super)/2;
        }
        n_s = 0;
    }
    printf("nPrecise Fermi energy is %E eV", E_fermi_mid);
    return E_fermi_mid;
}

double FermiDiracPopulate(double *Subband_f, double c_doping_yz, double Meff, double E_fermi, int N, int T)
{
    int m;
    double FL_precise, n_sp = 0, n_s = 0;
    /* initial fermi-energy roughly at intrinsic level (@300K)*/
    double Hbar=1.054571E-34, Kb = 1.38065E-23;
    double d_E_fermi = E_fermi/100;
    double DOS = Meff/(Hbar*Hbar*3.14159);
    for (n_s = 0; E_fermi < 0; E_fermi = E_fermi - d_E_fermi){
        printf("n%E", E_fermi);
        for (m = 0; m < N; m++){ /*add contributions from all subbands*/
            n_sp = DOS*Kb*T*log(exp((E_fermi - Subband_f[m])/(Kb*T)) + 1);
            /*NB. subband energies were calculated to be positive (should be negative)*/
            n_s = n_sp + n_s;
        }
        //printf("ncharge density for E_fermi of %E is %E per meter squared", E_fermi, n_s);
        if (n_s > c_doping_yz){
            printf("nRaw Fermi energy is %E eV", E_fermi);
            FL_precise = FD_Bisect(Subband_f, E_fermi, d_E_fermi, c_doping_yz, Meff, N, T);
            break;
        }
        n_s = 0;
    }
    return FL_precise;
}

double subband_contrib(double E_fermi, double E, double Meff, int T)
{
    double n_sp = 0;
    double Hbar=1.054571E-34, Kb = 1.38065E-23;
    double DOS = Meff/(Hbar*Hbar*3.14159);
    n_sp = DOS*Kb*T*log(exp((E_fermi + E)/(Kb*T)) + 1);
    return n_sp;
}

void Charge_Density(gsl_matrix *Norm_eigenvector_ptr, gsl_vector *s_eigvector_ptr, gsl_vector *Charge_Density_ptr, double *subband_ptr, double E_fermi, double dx, double c_doping_yz, double Meff, int Dim, int N, int T, FILE *fp_3)
{
    int n, m;
    double phi, n_sp, temp;
    double c_doping_xyz, q = 1.602176E-19;
    temp = sqrt(c_doping_yz);
    c_doping_xyz = temp*temp*temp;
    for (n=0; n<N; n++)
    {
        gsl_matrix_get_col(s_eigvector_ptr, Norm_eigenvector_ptr, n);
        n_sp = subband_contrib(E_fermi, subband_ptr[n], Meff, T);
        printf("ncharge contribution from subband %d is %E coulombs per meter squared", n, n_sp);
        for (m=0; m<Dim; m++)
        {
            phi = gsl_vector_get(s_eigvector_ptr, m);
            temp = gsl_vector_get(Charge_Density_ptr, m) - q*phi*phi*n_sp;
            gsl_vector_set(Charge_Density_ptr, m, temp);
        }
    }
    /*Output*/
    for(m=0; m<Dim; m++){
        //fprintf(fp_3, "n%E", gsl_vector_get(Charge_Density_ptr, m));
        temp = gsl_vector_get(Charge_Density_ptr, m) + q*c_doping_xyz;
        //temp = temp*dx*dx; /*for Poisson Solver*/
        gsl_vector_set(Charge_Density_ptr, m, temp);
        fprintf(fp_3, "n%E", gsl_vector_get(Charge_Density_ptr, m));
    }
}

double charge_density_check(gsl_vector *charge_density_ptr, int Dim)
{
    double charge_tot=0;
    int n;
    for(n=0; n<Dim; n++)
    {
        charge_tot = charge_tot + gsl_vector_get(charge_density_ptr, n);
    }
    return charge_tot;
}

//
//double Poisson_Solve(int Dim, int barrier_R, int barrier_L, double dx, gsl_vector *Main_Diagonal_ptr, gsl_vector *Super_Diagonal_ptr, gsl_vector *Sub_Diagonal_ptr,
//  gsl_vector *Charge_Density_ptr, gsl_vector *Elec_Potential_ptr, FILE *fp_3, FILE *fp_4){
    //
    //int n;
    //
    ///*constants*/
    //double dielectric_Ge = 16, dielectric_Si = 11.9, permitt_0 = 8.854187E-12;
    //double abs_permitt_Ge = dielectric_Ge*permitt_0, abs_permitt_Si = dielectric_Si*permitt_0;
    //
    //
    ///*assign vectors*/
    ////for(n=1; n<=Dim; n++){
        ////gsl_vector_set(Main_Diagonal_ptr, (n-1), -2);
    ////}
    ////for(n=1; n<=(Dim-1); n++){
        ////gsl_vector_set(Super_Sub_Diagonal_ptr, (n-1), 1);
    ////}
    ////for(n=1; n<=Dim; n++){
        ////double m=n/100;
        //////double temp = (1-(2*m*m));
        ////double temp = 1;
        ////gsl_vector_set(Charge_Density_ptr, (n-1), temp );
        /*/************************************************************\
        *
        \************************************************************/
        function 1-2x^2*/
        ////printf("%E", m);
        ////printf("ncharge density at point %E is %E", n, temp);
        ////
    ////}
    //
    //for (n=0; n<(Dim); n++) {
        // if(n>=barrier_R){
            // gsl_vector_set(Main_Diagonal_ptr, n, -2*abs_permitt_Si);
        // }
        // if(n<barrier_R && n>=barrier_L){
            // gsl_vector_set(Main_Diagonal_ptr, n, -2*abs_permitt_Ge);
        // }
        // if (n<barrier_L){
            // gsl_vector_set(Main_Diagonal_ptr, n, -2*abs_permitt_Si);
        // }
    //}
    //for (n=0; n<(Dim-1); n++) {
        // if(n>=(barrier_R-1)){
            // gsl_vector_set(Sub_Diagonal_ptr, n, 1*abs_permitt_Si);
        // }
        // if(n<(barrier_R-1) && n>(barrier_L-2)){
            // gsl_vector_set(Sub_Diagonal_ptr, n, 1*abs_permitt_Ge);
        // }
        // if (n<(barrier_L-1)){
            // gsl_vector_set(Sub_Diagonal_ptr, n, 1*abs_permitt_Si);
        // }
    //}
    //for (n=0; n<(Dim-1); n++) {
        // if(n>=barrier_R){
            // gsl_vector_set(Super_Diagonal_ptr, n, 1*abs_permitt_Si);
        // }
        //  if(n<barrier_R && n>=barrier_L){
            // gsl_vector_set(Super_Diagonal_ptr, n, 1*abs_permitt_Ge);
        // }
        //  if (n<barrier_L){
            // gsl_vector_set(Super_Diagonal_ptr, n, 1*abs_permitt_Si);
        // }
    //}
    //
    //
    /////*solve matrix*///
    //gsl_linalg_solve_tridiag(Main_Diagonal_ptr, Super_Diagonal_ptr, Sub_Diagonal_ptr, Charge_Density_ptr, Elec_Potential_ptr);
    //
    ////gsl_linalg_solve_symm_tridiag(Main_Diagonal_ptr, Super_Sub_Diagonal_ptr, Charge_Density_ptr, Potential_ptr);
    //
    //
    ///*output potential & charge distribution*/
    //for(n=0; n<Dim; n++){
        //fprintf(fp_4, "n%E", gsl_vector_get(Elec_Potential_ptr, n));
    //}
    //for(n=0; n<Dim; n++){
        //fprintf(fp_3, "n%E", gsl_vector_get(Charge_Density_ptr, n));
    //}
    //return 0;
//}

int main()
{
    int n=0, N=0;
    int Dim =800;
    int barrier_L=200, barrier_R=600;
    double dx=1E-10, E_well = -1.6022E-20, Meff_barrier = 1.73078256E-31, Meff_well = 6.1032E-32; /* Meff for Ge is [3.7348E-32]; Meff for GaAs is [6.1032E-32]; Meff for Si is [1.73078256E-31]*/
    double E_fermi, T=100;
    double c_doping_yz = 1E16;
    FILE *fp_1, *fp_2;
    FILE *fp_3, *fp_4;
    fp_1=fopen("//home//chuck/Documents//Project Code//MM Schrodinger Poisson Solver 3.1//eigenvalues.txt", "w+");
    fp_2=fopen("//home//chuck/Documents//Project Code//MM Schrodinger Poisson Solver 3.1//eigenvectors.txt", "w+");
    fp_3=fopen("//home//chuck/Documents//Project Code//MM Schrodinger Poisson Solver 3.1//charge_distribution.txt", "w+");
    fp_4=fopen("//home//chuck/Documents//Project Code//MM Schrodinger Poisson Solver 3.1//elec_potential.txt", "w+");
    double *Subband_ptr;
    Subband_ptr = calloc(Dim, sizeof(double));
    //double *Subband_prev_ptr;
    //Subband_prev_ptr = calloc(Dim, sizeof(double));
    double *Meff_ptr;
    Meff_ptr = calloc((Dim+1), sizeof(double));
    gsl_eigen_symmv_workspace *Workspace = gsl_eigen_symmv_alloc(Dim);
    gsl_matrix *Hamil_ptr = gsl_matrix_alloc(Dim, Dim);
    gsl_vector *Eigvalue_ptr = gsl_vector_alloc(Dim);
    gsl_matrix *Eigvector_ptr = gsl_matrix_alloc(Dim, Dim);
    gsl_vector *Potential_ptr = gsl_vector_alloc(Dim);
    gsl_matrix *Norm_Eigvector_ptr = gsl_matrix_alloc(Dim, Dim);
    gsl_vector *S_Eigvector_ptr = gsl_vector_alloc(Dim);
    gsl_vector *Charge_Density_ptr = gsl_vector_alloc(Dim);
    //gsl_vector *Main_Diagonal_ptr = gsl_vector_alloc(Dim);
    //gsl_vector *Super_Diagonal_ptr = gsl_vector_alloc(Dim-1);
    //gsl_vector *Sub_Diagonal_ptr = gsl_vector_alloc(Dim-1);
    ////gsl_vector *Super_Sub_Diagonal_ptr = gsl_vector_alloc(Dim-1);
    //gsl_vector *Elec_Potential_ptr = gsl_vector_alloc(Dim);
    /*initialise potential well*/
    for (n=0; n<(Dim); n++) {
        if(n>=barrier_R){
            gsl_vector_set(Potential_ptr, n, 0);
        }
        if(n<barrier_R && n>=barrier_L){
            gsl_vector_set(Potential_ptr, n, E_well);
        }
        if (n<barrier_L){
            gsl_vector_set(Potential_ptr, n, 0);
        }
    }
    /*initialise effective mass*/
    for (n=0; n<(Dim+1); n++) {
        if(n>barrier_R && n<Dim){
            Meff_ptr[n]=Meff_barrier;
        }
        if(n<(barrier_R-1) && n>barrier_L){
            Meff_ptr[n]=Meff_well;
        }
        if (n<(barrier_L) && n>0){
            Meff_ptr[n] = Meff_barrier;
        }
        if (n==0 || n==Dim){
            Meff_ptr[n]= Meff_barrier/2;
        }
        if (n==barrier_R || n==(barrier_R-1) || n==barrier_L || n==(barrier_L-1)){
            Meff_ptr[n]= (Meff_barrier+Meff_well)/2;
        }
    }
    N = Schrodinger_Solve(dx, Dim, barrier_L, barrier_R, E_well, Meff_ptr, Subband_ptr, Workspace, Hamil_ptr, Eigvalue_ptr, Eigvector_ptr, S_Eigvector_ptr, Potential_ptr, Norm_Eigvector_ptr, fp_1, fp_2);
    E_fermi = FermiDiracPopulate(Subband_ptr, c_doping_yz, Meff_well, E_well, N, T);
    Charge_Density(Norm_Eigvector_ptr, S_Eigvector_ptr, Charge_Density_ptr, Subband_ptr, E_fermi, dx, c_doping_yz, Meff_well, Dim, N, T, fp_3);
    double Charge_tot = charge_density_check(Charge_Density_ptr, Dim);
    printf("n%E", Charge_tot);
    //Poisson_Solve(Dim, barrier_R, barrier_L, dx, Main_Diagonal_ptr, Super_Diagonal_ptr, Sub_Diagonal_ptr, Charge_Density_ptr, Elec_Potential_ptr, fp_3, fp_4);
    //Convergence_Check()
    //Subband_store()
    /*free memory*/
    gsl_matrix_free(Eigvector_ptr);
    gsl_vector_free(Eigvalue_ptr);
    gsl_matrix_free(Hamil_ptr);
    gsl_eigen_symmv_free(Workspace);
    gsl_matrix_free(Norm_Eigvector_ptr);
    gsl_vector_free (S_Eigvector_ptr);
    free(Subband_ptr);
    free(Meff_ptr);
    gsl_vector_free(Charge_Density_ptr);
    //gsl_vector_free (Main_Diagonal_ptr);
    //gsl_vector_free (Super_Diagonal_ptr);
    //gsl_vector_free(Sub_Diagonal_ptr);
    //gsl_vector_free(Elec_Potential_ptr);
    //free(Subband_prev_ptr)
    return 0;
}


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

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

#include <gsl/gsl_linalg.h>

double
gsl_linalg_householder_transform (gsl_vector * v)
{
  /* replace v[0:n-1] with a householder vector (v[0:n-1]) and
     coefficient tau that annihilate v[1:n-1] */

  const size_t n = v->size ;

  if (n == 1)
    {
      return 0.0; /* tau = 0 */
    }
  else
    {
      double alpha, beta, tau ;

      gsl_vector_view x = gsl_vector_subvector (v, 1, n - 1) ;

      double xnorm = gsl_blas_dnrm2 (&x.vector);

      if (xnorm == 0)
        {
          return 0.0; /* tau = 0 */
        }

      alpha = gsl_vector_get (v, 0) ;
      beta = - (alpha >= 0.0 ? +1.0 : -1.0) * hypot(alpha, xnorm) ;
      tau = (beta - alpha) / beta ;

      {
        double s = (alpha - beta);

        if (fabs(s) > GSL_DBL_MIN)
          {
            gsl_blas_dscal (1.0 / s, &x.vector);
            gsl_vector_set (v, 0, beta) ;
          }
        else
          {
            gsl_blas_dscal (GSL_DBL_EPSILON / s, &x.vector);
            gsl_blas_dscal (1.0 / GSL_DBL_EPSILON, &x.vector);
            gsl_vector_set (v, 0, beta) ;
          }
      }

      return tau;
    }
}

int
gsl_linalg_householder_hm (double tau, const gsl_vector * v, gsl_matrix * A)
{
  /* applies a householder transformation v,tau to matrix m */

  if (tau == 0.0)
    {
      return GSL_SUCCESS;
    }

#ifdef USE_BLAS
  {
    gsl_vector_const_view v1 = gsl_vector_const_subvector (v, 1, v->size - 1);
    gsl_matrix_view A1 = gsl_matrix_submatrix (A, 1, 0, A->size1 - 1, A->size2);
    size_t j;

    for (j = 0; j < A->size2; j++)
      {
        double wj = 0.0;
        gsl_vector_view A1j = gsl_matrix_column(&A1.matrix, j);
        gsl_blas_ddot (&A1j.vector, &v1.vector, &wj);
        wj += gsl_matrix_get(A,0,j);

        {
          double A0j = gsl_matrix_get (A, 0, j);
          gsl_matrix_set (A, 0, j, A0j - tau *  wj);
        }

        gsl_blas_daxpy (-tau * wj, &v1.vector, &A1j.vector);
      }
  }
#else
  {
    size_t i, j;

    for (j = 0; j < A->size2; j++)
      {
        /* Compute wj = Akj vk */

        double wj = gsl_matrix_get(A,0,j);

        for (i = 1; i < A->size1; i++)  /* note, computed for v(0) = 1 above */
          {
            wj += gsl_matrix_get(A,i,j) * gsl_vector_get(v,i);
          }

        /* Aij = Aij - tau vi wj */

        /* i = 0 */
        {
          double A0j = gsl_matrix_get (A, 0, j);
          gsl_matrix_set (A, 0, j, A0j - tau *  wj);
        }

        /* i = 1 .. M-1 */

        for (i = 1; i < A->size1; i++)
          {
            double Aij = gsl_matrix_get (A, i, j);
            double vi = gsl_vector_get (v, i);
            gsl_matrix_set (A, i, j, Aij - tau * vi * wj);
          }
      }
  }
#endif

  return GSL_SUCCESS;
}

int
gsl_linalg_householder_mh (double tau, const gsl_vector * v, gsl_matrix * A)
{
  /* applies a householder transformation v,tau to matrix m from the
     right hand side in order to zero out rows */

  if (tau == 0)
    return GSL_SUCCESS;

  /* A = A - tau w v' */

#ifdef USE_BLAS
  {
    gsl_vector_const_view v1 = gsl_vector_const_subvector (v, 1, v->size - 1);
    gsl_matrix_view A1 = gsl_matrix_submatrix (A, 0, 1, A->size1, A->size2-1);
    size_t i;

    for (i = 0; i < A->size1; i++)
      {
        double wi = 0.0;
        gsl_vector_view A1i = gsl_matrix_row(&A1.matrix, i);
        gsl_blas_ddot (&A1i.vector, &v1.vector, &wi);
        wi += gsl_matrix_get(A,i,0);

        {
          double Ai0 = gsl_matrix_get (A, i, 0);
          gsl_matrix_set (A, i, 0, Ai0 - tau *  wi);
        }

        gsl_blas_daxpy(-tau * wi, &v1.vector, &A1i.vector);
      }
  }
#else
  {
    size_t i, j;

    for (i = 0; i < A->size1; i++)
      {
        double wi = gsl_matrix_get(A,i,0);

        for (j = 1; j < A->size2; j++)  /* note, computed for v(0) = 1 above */
          {
            wi += gsl_matrix_get(A,i,j) * gsl_vector_get(v,j);
          }

        /* j = 0 */

        {
          double Ai0 = gsl_matrix_get (A, i, 0);
          gsl_matrix_set (A, i, 0, Ai0 - tau *  wi);
        }

        /* j = 1 .. N-1 */

        for (j = 1; j < A->size2; j++)
          {
            double vj = gsl_vector_get (v, j);
            double Aij = gsl_matrix_get (A, i, j);
            gsl_matrix_set (A, i, j, Aij - tau * wi * vj);
          }
      }
  }
#endif

  return GSL_SUCCESS;
}

int
gsl_linalg_householder_hv (double tau, const gsl_vector * v, gsl_vector * w)
{
  /* applies a householder transformation v to vector w */
  const size_t N = v->size;

  if (tau == 0)
    return GSL_SUCCESS ;

  {
    /* compute d = v'w */

    double d0 = gsl_vector_get(w,0);
    double d1, d;

    gsl_vector_const_view v1 = gsl_vector_const_subvector(v, 1, N-1);
    gsl_vector_view w1 = gsl_vector_subvector(w, 1, N-1);

    gsl_blas_ddot (&v1.vector, &w1.vector, &d1);

    d = d0 + d1;

    /* compute w = w - tau (v) (v'w) */

    {
      double w0 = gsl_vector_get (w,0);
      gsl_vector_set (w, 0, w0 - tau * d);
    }

    gsl_blas_daxpy (-tau * d, &v1.vector, &w1.vector);
  }

  return GSL_SUCCESS;
}

int
gsl_linalg_householder_hm1 (double tau, gsl_matrix * A)
{
  /* applies a householder transformation v,tau to a matrix being
     build up from the identity matrix, using the first column of A as
     a householder vector */

  if (tau == 0)
    {
      size_t i,j;

      gsl_matrix_set (A, 0, 0, 1.0);

      for (j = 1; j < A->size2; j++)
        {
          gsl_matrix_set (A, 0, j, 0.0);
        }

      for (i = 1; i < A->size1; i++)
        {
          gsl_matrix_set (A, i, 0, 0.0);
        }

      return GSL_SUCCESS;
    }

  /* w = A' v */

#ifdef USE_BLAS
  {
    gsl_matrix_view A1 = gsl_matrix_submatrix (A, 1, 0, A->size1 - 1, A->size2);
    gsl_vector_view v1 = gsl_matrix_column (&A1.matrix, 0);
    size_t j;

    for (j = 1; j < A->size2; j++)
      {
        double wj = 0.0;   /* A0j * v0 */

        gsl_vector_view A1j = gsl_matrix_column(&A1.matrix, j);
        gsl_blas_ddot (&A1j.vector, &v1.vector, &wj);

        /* A = A - tau v w' */

        gsl_matrix_set (A, 0, j, - tau *  wj);

        gsl_blas_daxpy(-tau*wj, &v1.vector, &A1j.vector);
      }

    gsl_blas_dscal(-tau, &v1.vector);

    gsl_matrix_set (A, 0, 0, 1.0 - tau);
  }
#else
  {
    size_t i, j;

    for (j = 1; j < A->size2; j++)
      {
        double wj = 0.0;   /* A0j * v0 */

        for (i = 1; i < A->size1; i++)
          {
            double vi = gsl_matrix_get(A, i, 0);
            wj += gsl_matrix_get(A,i,j) * vi;
          }

        /* A = A - tau v w' */

        gsl_matrix_set (A, 0, j, - tau *  wj);

        for (i = 1; i < A->size1; i++)
          {
            double vi = gsl_matrix_get (A, i, 0);
            double Aij = gsl_matrix_get (A, i, j);
            gsl_matrix_set (A, i, j, Aij - tau * vi * wj);
          }
      }

    for (i = 1; i < A->size1; i++)
      {
        double vi = gsl_matrix_get(A, i, 0);
        gsl_matrix_set(A, i, 0, -tau * vi);
      }

    gsl_matrix_set (A, 0, 0, 1.0 - tau);
  }
#endif

  return GSL_SUCCESS;
}


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

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


#include <assert.h>
#include <math.h>
#include <gsl/gsl_randist.h>
#include "nmcalc.h"

void get_ab(struct variant_table *v, struct variant_counts **a, struct variant_counts **b);

// Convenience function to mimic MATLAB function
static inline double binopdf(unsigned int x, unsigned int n, double p) {
	return gsl_ran_binomial_pdf(x, p, n);
}

#define NONZERO_OR_NAN(X, NAN_CODE) ((X) == (X) ? (X) : nan(#NAN_CODE))

void nmcalc(struct context *context,
            struct variant_table *v,
            double prior_map_error,
            int ploidy,
            struct nm_entry *out)
{
	(void) context;

	double a_read_depth, b_read_depth;
	double a_mean_mq, b_mean_mq;

	double prior_hom, prior_het;
	double p_data_map_error, p_data_hom, p_data_het, p_data;
	double p_map_error;

	double per_read_pass, ab_frac;

	struct variant_counts *a, *b;

	get_ab(v, &a, &b);

	// Initialization of useful variables

	a_read_depth = (a->count_f + a->count_r) / 2.0;
	b_read_depth = (b->count_f + b->count_r) / 2.0;

	a_mean_mq = a->total_mq / NONZERO_OR_NAN(a_read_depth, 200);
	b_mean_mq = b->total_mq / NONZERO_OR_NAN(b_read_depth, 200);

	// Normal metrics calculation starts here

	// priors
	if (ploidy == 2) {
		prior_het = 2 * a->pop_af * b->pop_af;
	} else {
		prior_het = 0;
	}

	prior_hom = a->pop_af * a->pop_af;

	// likelihoods
	p_data_map_error = pow(10, -fmin(a_mean_mq, b_mean_mq)/10);
	p_data_hom = binopdf(b_read_depth, v->read_count_pass, pow(10, (-b_mean_mq / 10)));
	p_data_het = binopdf(b_read_depth, v->read_count_pass,  0.5);

	p_data = prior_map_error * p_data_map_error + prior_het * p_data_het + prior_hom * p_data_hom;

	// posteriors
	if (v->read_count_pass > 0) {
		p_map_error = prior_map_error * p_data_map_error / p_data;
	} else {
		p_map_error = nan("300");
	}

	// other metrics
	per_read_pass = v->read_count_pass / NONZERO_OR_NAN(v->read_count, 200);

	ab_frac = (a_read_depth + b_read_depth) / NONZERO_OR_NAN(v->read_count_pass, 200);

	out->pos = v->offset;

	if (ploidy == 1 || ploidy == 2) {
		out->norm_read_depth = (3-ploidy) * v->read_count_pass; // sneak
		out->prob_map_err = p_map_error;
		out->read_pass = per_read_pass;
		out->a_or_b = ab_frac;
	} else  {
		out->norm_read_depth = nan("101");
		out->prob_map_err = nan("102");
		out->read_pass = nan("103");
		out->a_or_b = nan("104");
	}
}