/* specfunc/hyperg_2F1.c

 * 

 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004 Gerard Jungman

 * Copyright (C) 2009 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.

 */

/* Author:  G. Jungman */

#include <config.h>

#include <gsl/gsl_math.h>

#include <gsl/gsl_errno.h>

#include <gsl/gsl_sf_exp.h>

#include <gsl/gsl_sf_pow_int.h>

#include <gsl/gsl_sf_gamma.h>

#include <gsl/gsl_sf_psi.h>

#include <gsl/gsl_sf_hyperg.h>

#include "error.h"

#define locEPS (1000.0*GSL_DBL_EPSILON)

/* Assumes c != negative integer.

 */

static int

hyperg_2F1_series(const double a, const double b, const double c,

                  const double x, 

                  gsl_sf_result * result

                  )

{

  double sum_pos = 1.0;

  double sum_neg = 0.0;

  double del_pos = 1.0;

  double del_neg = 0.0;

  double del = 1.0;

  double del_prev;

  double k = 0.0;

  int i = 0;

  if(fabs(c) < GSL_DBL_EPSILON) {

    result->val = 0.0; /* FIXME: ?? */

    result->err = 1.0;

    GSL_ERROR ("error", GSL_EDOM);

  }

  do {

    if(++i > 30000) {

      result->val  = sum_pos - sum_neg;

      result->err  = del_pos + del_neg;

      result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);

      result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k)+1.0) * fabs(result->val);

      GSL_ERROR ("error", GSL_EMAXITER);

    }

    del_prev = del;

    del *= (a+k)*(b+k) * x / ((c+k) * (k+1.0));  /* Gauss series */

    if(del > 0.0) {

      del_pos  =  del;

      sum_pos +=  del;

    }

    else if(del == 0.0) {

      /* Exact termination (a or b was a negative integer).

       */

      del_pos = 0.0;

      del_neg = 0.0;

      break;

    }

    else {

      del_neg  = -del;

      sum_neg -=  del;

    }

    /*

     * This stopping criteria is taken from the thesis

     * "Computation of Hypergeometic Functions" by J. Pearson, pg. 31

     * (http://people.maths.ox.ac.uk/porterm/research/pearson_final.pdf)

     * and fixes bug #45926

     */

    if (fabs(del_prev / (sum_pos - sum_neg)) < GSL_DBL_EPSILON &&

        fabs(del / (sum_pos - sum_neg)) < GSL_DBL_EPSILON)

      break;

    k += 1.0;

  } while(fabs((del_pos + del_neg)/(sum_pos-sum_neg)) > GSL_DBL_EPSILON);

  result->val  = sum_pos - sum_neg;

  result->err  = del_pos + del_neg;

  result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);

  result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k) + 1.0) * fabs(result->val);

  return GSL_SUCCESS;

}

/* a = aR + i aI, b = aR - i aI */

static

int

hyperg_2F1_conj_series(const double aR, const double aI, const double c,

                       double x,

                       gsl_sf_result * result)

{

  if(c == 0.0) {

    result->val = 0.0; /* FIXME: should be Inf */

    result->err = 0.0;

    GSL_ERROR ("error", GSL_EDOM);

  }

  else {

    double sum_pos = 1.0;

    double sum_neg = 0.0;

    double del_pos = 1.0;

    double del_neg = 0.0;

    double del = 1.0;

    double k = 0.0;

    do {

      del *= ((aR+k)*(aR+k) + aI*aI)/((k+1.0)*(c+k)) * x;

      if(del >= 0.0) {

        del_pos  =  del;

        sum_pos +=  del;

      }

      else {

        del_neg  = -del;

        sum_neg -=  del;

      }

      if(k > 30000) {

        result->val  = sum_pos - sum_neg;

        result->err  = del_pos + del_neg;

        result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);

        result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k)+1.0) * fabs(result->val);

        GSL_ERROR ("error", GSL_EMAXITER);

      }

      k += 1.0;

    } while(fabs((del_pos + del_neg)/(sum_pos - sum_neg)) > GSL_DBL_EPSILON);

    result->val  = sum_pos - sum_neg;

    result->err  = del_pos + del_neg;

    result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg);

    result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k) + 1.0) * fabs(result->val);

    return GSL_SUCCESS;

  }

}

/* Luke's rational approximation. The most accesible

 * discussion is in [Kolbig, CPC 23, 51 (1981)].

 * The convergence is supposedly guaranteed for x < 0.

 * You have to read Luke's books to see this and other

 * results. Unfortunately, the stability is not so

 * clear to me, although it seems very efficient when

 * it works.

 */

static

int

hyperg_2F1_luke(const double a, const double b, const double c,

                const double xin, 

                gsl_sf_result * result)

{

  int stat_iter;

  const double RECUR_BIG = 1.0e+50;

  const int nmax = 20000;

  int n = 3;

  const double x  = -xin;

  const double x3 = x*x*x;

  const double t0 = a*b/c;

  const double t1 = (a+1.0)*(b+1.0)/(2.0*c);

  const double t2 = (a+2.0)*(b+2.0)/(2.0*(c+1.0));

  double F = 1.0;

  double prec;

  double Bnm3 = 1.0;                                  /* B0 */

  double Bnm2 = 1.0 + t1 * x;                         /* B1 */

  double Bnm1 = 1.0 + t2 * x * (1.0 + t1/3.0 * x);    /* B2 */

  double Anm3 = 1.0;                                                      /* A0 */

  double Anm2 = Bnm2 - t0 * x;                                            /* A1 */

  double Anm1 = Bnm1 - t0*(1.0 + t2*x)*x + t0 * t1 * (c/(c+1.0)) * x*x;   /* A2 */

  while(1) {

    double npam1 = n + a - 1;

    double npbm1 = n + b - 1;

    double npcm1 = n + c - 1;

    double npam2 = n + a - 2;

    double npbm2 = n + b - 2;

    double npcm2 = n + c - 2;

    double tnm1  = 2*n - 1;

    double tnm3  = 2*n - 3;

    double tnm5  = 2*n - 5;

    double n2 = n*n;

    double F1 =  (3.0*n2 + (a+b-6)*n + 2 - a*b - 2*(a+b)) / (2*tnm3*npcm1);

    double F2 = -(3.0*n2 - (a+b+6)*n + 2 - a*b)*npam1*npbm1/(4*tnm1*tnm3*npcm2*npcm1);

    double F3 = (npam2*npam1*npbm2*npbm1*(n-a-2)*(n-b-2)) / (8*tnm3*tnm3*tnm5*(n+c-3)*npcm2*npcm1);

    double E  = -npam1*npbm1*(n-c-1) / (2*tnm3*npcm2*npcm1);

    double An = (1.0+F1*x)*Anm1 + (E + F2*x)*x*Anm2 + F3*x3*Anm3;

    double Bn = (1.0+F1*x)*Bnm1 + (E + F2*x)*x*Bnm2 + F3*x3*Bnm3;

    double r = An/Bn;

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

    F = r;

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

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {

      An   /= RECUR_BIG;

      Bn   /= RECUR_BIG;

      Anm1 /= RECUR_BIG;

      Bnm1 /= RECUR_BIG;

      Anm2 /= RECUR_BIG;

      Bnm2 /= RECUR_BIG;

      Anm3 /= RECUR_BIG;

      Bnm3 /= RECUR_BIG;

    }

    else if(fabs(An) < 1.0/RECUR_BIG || fabs(Bn) < 1.0/RECUR_BIG) {

      An   *= RECUR_BIG;

      Bn   *= RECUR_BIG;

      Anm1 *= RECUR_BIG;

      Bnm1 *= RECUR_BIG;

      Anm2 *= RECUR_BIG;

      Bnm2 *= RECUR_BIG;

      Anm3 *= RECUR_BIG;

      Bnm3 *= RECUR_BIG;

    }

    n++;

    Bnm3 = Bnm2;

    Bnm2 = Bnm1;

    Bnm1 = Bn;

    Anm3 = Anm2;

    Anm2 = Anm1;

    Anm1 = An;

  }

  result->val  = F;

  result->err  = 2.0 * fabs(prec * F);

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

  /* FIXME: just a hack: there's a lot of shit going on here */

  result->err *= 8.0 * (fabs(a) + fabs(b) + 1.0);

  stat_iter = (n >= nmax ? GSL_EMAXITER : GSL_SUCCESS );

  return stat_iter;

}

/* Luke's rational approximation for the

 * case a = aR + i aI, b = aR - i aI.

 */

static

int

hyperg_2F1_conj_luke(const double aR, const double aI, const double c,

                     const double xin, 

                     gsl_sf_result * result)

{

  int stat_iter;

  const double RECUR_BIG = 1.0e+50;

  const int nmax = 10000;

  int n = 3;

  const double x = -xin;

  const double x3 = x*x*x;

  const double atimesb = aR*aR + aI*aI;

  const double apb     = 2.0*aR;

  const double t0 = atimesb/c;

  const double t1 = (atimesb +     apb + 1.0)/(2.0*c);

  const double t2 = (atimesb + 2.0*apb + 4.0)/(2.0*(c+1.0));

  double F = 1.0;

  double prec;

  double Bnm3 = 1.0;                                  /* B0 */

  double Bnm2 = 1.0 + t1 * x;                         /* B1 */

  double Bnm1 = 1.0 + t2 * x * (1.0 + t1/3.0 * x);    /* B2 */

  double Anm3 = 1.0;                                                      /* A0 */

  double Anm2 = Bnm2 - t0 * x;                                            /* A1 */

  double Anm1 = Bnm1 - t0*(1.0 + t2*x)*x + t0 * t1 * (c/(c+1.0)) * x*x;   /* A2 */

  while(1) {

    double nm1 = n - 1;

    double nm2 = n - 2;

    double npam1_npbm1 = atimesb + nm1*apb + nm1*nm1;

    double npam2_npbm2 = atimesb + nm2*apb + nm2*nm2;

    double npcm1 = nm1 + c;

    double npcm2 = nm2 + c;

    double tnm1  = 2*n - 1;

    double tnm3  = 2*n - 3;

    double tnm5  = 2*n - 5;

    double n2 = n*n;

    double F1 =  (3.0*n2 + (apb-6)*n + 2 - atimesb - 2*apb) / (2*tnm3*npcm1);

    double F2 = -(3.0*n2 - (apb+6)*n + 2 - atimesb)*npam1_npbm1/(4*tnm1*tnm3*npcm2*npcm1);

    double F3 = (npam2_npbm2*npam1_npbm1*(nm2*nm2 - nm2*apb + atimesb)) / (8*tnm3*tnm3*tnm5*(n+c-3)*npcm2*npcm1);

    double E  = -npam1_npbm1*(n-c-1) / (2*tnm3*npcm2*npcm1);

    double An = (1.0+F1*x)*Anm1 + (E + F2*x)*x*Anm2 + F3*x3*Anm3;

    double Bn = (1.0+F1*x)*Bnm1 + (E + F2*x)*x*Bnm2 + F3*x3*Bnm3;

    double r = An/Bn;

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

    F = r;

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

    if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) {

      An   /= RECUR_BIG;

      Bn   /= RECUR_BIG;

      Anm1 /= RECUR_BIG;

      Bnm1 /= RECUR_BIG;

      Anm2 /= RECUR_BIG;

      Bnm2 /= RECUR_BIG;

      Anm3 /= RECUR_BIG;

      Bnm3 /= RECUR_BIG;

    }

    else if(fabs(An) < 1.0/RECUR_BIG || fabs(Bn) < 1.0/RECUR_BIG) {

      An   *= RECUR_BIG;

      Bn   *= RECUR_BIG;

      Anm1 *= RECUR_BIG;

      Bnm1 *= RECUR_BIG;

      Anm2 *= RECUR_BIG;

      Bnm2 *= RECUR_BIG;

      Anm3 *= RECUR_BIG;

      Bnm3 *= RECUR_BIG;

    }

    n++;

    Bnm3 = Bnm2;

    Bnm2 = Bnm1;

    Bnm1 = Bn;

    Anm3 = Anm2;

    Anm2 = Anm1;

    Anm1 = An;

  }

  result->val  = F;

  result->err  = 2.0 * fabs(prec * F);

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

  /* FIXME: see above */

  result->err *= 8.0 * (fabs(aR) + fabs(aI) + 1.0);

  stat_iter = (n >= nmax ? GSL_EMAXITER : GSL_SUCCESS );

  return stat_iter;

}

/* Do the reflection described in [Moshier, p. 334].

 * Assumes a,b,c != neg integer.

 */

static

int

hyperg_2F1_reflect(const double a, const double b, const double c,

                   const double x, gsl_sf_result * result)

{

  const double d = c - a - b;

  const int intd  = floor(d+0.5);

  const int d_integer = ( fabs(d - intd) < locEPS );

  if(d_integer) {

    const double ln_omx = log(1.0 - x);

    const double ad = fabs(d);

    int stat_F2 = GSL_SUCCESS;

    double sgn_2;

    gsl_sf_result F1;

    gsl_sf_result F2;

    double d1, d2;

    gsl_sf_result lng_c;

    gsl_sf_result lng_ad2;

    gsl_sf_result lng_bd2;

    int stat_c;

    int stat_ad2;

    int stat_bd2;

    if(d >= 0.0) {

      d1 = d;

      d2 = 0.0;

    }

    else {

      d1 = 0.0;

      d2 = d;

    }

    stat_ad2 = gsl_sf_lngamma_e(a+d2, &lng_ad2);

    stat_bd2 = gsl_sf_lngamma_e(b+d2, &lng_bd2);

    stat_c   = gsl_sf_lngamma_e(c,    &lng_c);

    /* Evaluate F1.

     */

    if(ad < GSL_DBL_EPSILON) {

      /* d = 0 */

      F1.val = 0.0;

      F1.err = 0.0;

    }

    else {

      gsl_sf_result lng_ad;

      gsl_sf_result lng_ad1;

      gsl_sf_result lng_bd1;

      int stat_ad  = gsl_sf_lngamma_e(ad,   &lng_ad);

      int stat_ad1 = gsl_sf_lngamma_e(a+d1, &lng_ad1);

      int stat_bd1 = gsl_sf_lngamma_e(b+d1, &lng_bd1);

      if(stat_ad1 == GSL_SUCCESS && stat_bd1 == GSL_SUCCESS && stat_ad == GSL_SUCCESS) {

        /* Gamma functions in the denominator are ok.

         * Proceed with evaluation.

         */

        int i;

        double sum1 = 1.0;

        double term = 1.0;

        double ln_pre1_val = lng_ad.val + lng_c.val + d2*ln_omx - lng_ad1.val - lng_bd1.val;

        double ln_pre1_err = lng_ad.err + lng_c.err + lng_ad1.err + lng_bd1.err + GSL_DBL_EPSILON * fabs(ln_pre1_val);

        int stat_e;

        /* Do F1 sum.

         */

        for(i=1; i

          int j = i-1;

          term *= (a + d2 + j) * (b + d2 + j) / (1.0 + d2 + j) / i * (1.0-x);

          sum1 += term;

        }

        stat_e = gsl_sf_exp_mult_err_e(ln_pre1_val, ln_pre1_err,

                                       sum1, GSL_DBL_EPSILON*fabs(sum1),

                                       &F1;;

        if(stat_e == GSL_EOVRFLW) {

          OVERFLOW_ERROR(result);

        }

      }

      else {

        /* Gamma functions in the denominator were not ok.

         * So the F1 term is zero.

         */

        F1.val = 0.0;

        F1.err = 0.0;

      }

    } /* end F1 evaluation */

    /* Evaluate F2.

     */

    if(stat_ad2 == GSL_SUCCESS && stat_bd2 == GSL_SUCCESS) {

      /* Gamma functions in the denominator are ok.

       * Proceed with evaluation.

       */

      const int maxiter = 2000;

      double psi_1 = -M_EULER;

      gsl_sf_result psi_1pd; 

      gsl_sf_result psi_apd1;

      gsl_sf_result psi_bpd1;

      int stat_1pd  = gsl_sf_psi_e(1.0 + ad, &psi_1pd);

      int stat_apd1 = gsl_sf_psi_e(a + d1,   &psi_apd1);

      int stat_bpd1 = gsl_sf_psi_e(b + d1,   &psi_bpd1);

      int stat_dall = GSL_ERROR_SELECT_3(stat_1pd, stat_apd1, stat_bpd1);

      double psi_val = psi_1 + psi_1pd.val - psi_apd1.val - psi_bpd1.val - ln_omx;

      double psi_err = psi_1pd.err + psi_apd1.err + psi_bpd1.err + GSL_DBL_EPSILON*fabs(psi_val);

      double fact = 1.0;

      double sum2_val = psi_val;

      double sum2_err = psi_err;

      double ln_pre2_val = lng_c.val + d1*ln_omx - lng_ad2.val - lng_bd2.val;

      double ln_pre2_err = lng_c.err + lng_ad2.err + lng_bd2.err + GSL_DBL_EPSILON * fabs(ln_pre2_val);

      int stat_e;

      int j;

      /* Do F2 sum.

       */

      for(j=1; j

        /* values for psi functions use recurrence; Abramowitz+Stegun 6.3.5 */

        double term1 = 1.0/(double)j  + 1.0/(ad+j);

        double term2 = 1.0/(a+d1+j-1.0) + 1.0/(b+d1+j-1.0);

        double delta = 0.0;

        psi_val += term1 - term2;

        psi_err += GSL_DBL_EPSILON * (fabs(term1) + fabs(term2));

        fact *= (a+d1+j-1.0)*(b+d1+j-1.0)/((ad+j)*j) * (1.0-x);

        delta = fact * psi_val;

        sum2_val += delta;

        sum2_err += fabs(fact * psi_err) + GSL_DBL_EPSILON*fabs(delta);

        if(fabs(delta) < GSL_DBL_EPSILON * fabs(sum2_val)) break;

      }

      if(j == maxiter) stat_F2 = GSL_EMAXITER;

      if(sum2_val == 0.0) {

        F2.val = 0.0;

        F2.err = 0.0;

      }

      else {

        stat_e = gsl_sf_exp_mult_err_e(ln_pre2_val, ln_pre2_err,

                                       sum2_val, sum2_err,

                                       &F2;;

        if(stat_e == GSL_EOVRFLW) {

          result->val = 0.0;

          result->err = 0.0;

          GSL_ERROR ("error", GSL_EOVRFLW);

        }

      }

      stat_F2 = GSL_ERROR_SELECT_2(stat_F2, stat_dall);

    }

    else {

      /* Gamma functions in the denominator not ok.

       * So the F2 term is zero.

       */

      F2.val = 0.0;

      F2.err = 0.0;

    } /* end F2 evaluation */

    sgn_2 = ( GSL_IS_ODD(intd) ? -1.0 : 1.0 );

    result->val  = F1.val + sgn_2 * F2.val;

    result->err  = F1.err + F2. err;

    result->err += 2.0 * GSL_DBL_EPSILON * (fabs(F1.val) + fabs(F2.val));

    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);

    return stat_F2;

  }

  else {

    /* d not an integer */

    gsl_sf_result pre1, pre2;

    double sgn1, sgn2;

    gsl_sf_result F1, F2;

    int status_F1, status_F2;

    /* These gamma functions appear in the denominator, so we

     * catch their harmless domain errors and set the terms to zero.

     */

    gsl_sf_result ln_g1ca,  ln_g1cb,  ln_g2a,  ln_g2b;

    double sgn_g1ca, sgn_g1cb, sgn_g2a, sgn_g2b;

    int stat_1ca = gsl_sf_lngamma_sgn_e(c-a, &ln_g1ca, &sgn_g1ca);

    int stat_1cb = gsl_sf_lngamma_sgn_e(c-b, &ln_g1cb, &sgn_g1cb);

    int stat_2a  = gsl_sf_lngamma_sgn_e(a, &ln_g2a, &sgn_g2a);

    int stat_2b  = gsl_sf_lngamma_sgn_e(b, &ln_g2b, &sgn_g2b);

    int ok1 = (stat_1ca == GSL_SUCCESS && stat_1cb == GSL_SUCCESS);

    int ok2 = (stat_2a  == GSL_SUCCESS && stat_2b  == GSL_SUCCESS);

    gsl_sf_result ln_gc,  ln_gd,  ln_gmd;

    double sgn_gc, sgn_gd, sgn_gmd;

    gsl_sf_lngamma_sgn_e( c, &ln_gc,  &sgn_gc);

    gsl_sf_lngamma_sgn_e( d, &ln_gd,  &sgn_gd);

    gsl_sf_lngamma_sgn_e(-d, &ln_gmd, &sgn_gmd);

    sgn1 = sgn_gc * sgn_gd  * sgn_g1ca * sgn_g1cb;

    sgn2 = sgn_gc * sgn_gmd * sgn_g2a  * sgn_g2b;

    if(ok1 && ok2) {

      double ln_pre1_val = ln_gc.val + ln_gd.val  - ln_g1ca.val - ln_g1cb.val;

      double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val  - ln_g2b.val + d*log(1.0-x);

      double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err;

      double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err  + ln_g2b.err;

      if(ln_pre1_val < GSL_LOG_DBL_MAX && ln_pre2_val < GSL_LOG_DBL_MAX) {

        gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1;;

        gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2;;

        pre1.val *= sgn1;

        pre2.val *= sgn2;

      }

      else {

        OVERFLOW_ERROR(result);

      }

    }

    else if(ok1 && !ok2) {

      double ln_pre1_val = ln_gc.val + ln_gd.val - ln_g1ca.val - ln_g1cb.val;

      double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err;

      if(ln_pre1_val < GSL_LOG_DBL_MAX) {

        gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1;;

        pre1.val *= sgn1;

        pre2.val = 0.0;

        pre2.err = 0.0;

      }

      else {

        OVERFLOW_ERROR(result);

      }

    }

    else if(!ok1 && ok2) {

      double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val - ln_g2b.val + d*log(1.0-x);

      double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err + ln_g2b.err;

      if(ln_pre2_val < GSL_LOG_DBL_MAX) {

        pre1.val = 0.0;

        pre1.err = 0.0;

        gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2;;

        pre2.val *= sgn2;

      }

      else {

        OVERFLOW_ERROR(result);

      }

    }

    else {

      pre1.val = 0.0;

      pre2.val = 0.0;

      UNDERFLOW_ERROR(result);

    }

    status_F1 = hyperg_2F1_series(  a,   b, 1.0-d, 1.0-x, &F1;;

    status_F2 = hyperg_2F1_series(c-a, c-b, 1.0+d, 1.0-x, &F2;;

    result->val  = pre1.val*F1.val + pre2.val*F2.val;

    result->err  = fabs(pre1.val*F1.err) + fabs(pre2.val*F2.err);

    result->err += fabs(pre1.err*F1.val) + fabs(pre2.err*F2.val);

    result->err += 2.0 * GSL_DBL_EPSILON * (fabs(pre1.val*F1.val) + fabs(pre2.val*F2.val));

    result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val);

    if (status_F1)

      return status_F1;

    if (status_F2)

      return status_F2;

    return GSL_SUCCESS;

  }

}

static int pow_omx(const double x, const double p, gsl_sf_result * result)

{

  double ln_omx;

  double ln_result;

  if(fabs(x) < GSL_ROOT5_DBL_EPSILON) {

    ln_omx = -x*(1.0 + x*(1.0/2.0 + x*(1.0/3.0 + x/4.0 + x*x/5.0)));

  }

  else {

    ln_omx = log(1.0-x);

  }

  ln_result = p * ln_omx;

  return gsl_sf_exp_err_e(ln_result, GSL_DBL_EPSILON * fabs(ln_result), result);

}

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

int

gsl_sf_hyperg_2F1_e(double a, double b, const double c,

                       const double x,

                       gsl_sf_result * result)

{

  const double d = c - a - b;

  const double rinta = floor(a + 0.5);

  const double rintb = floor(b + 0.5);

  const double rintc = floor(c + 0.5);

  const int a_neg_integer = ( a < 0.0  &&  fabs(a - rinta) < locEPS );

  const int b_neg_integer = ( b < 0.0  &&  fabs(b - rintb) < locEPS );

  const int c_neg_integer = ( c < 0.0  &&  fabs(c - rintc) < locEPS );

  result->val = 0.0;

  result->err = 0.0;

   /* Handle x == 1.0 RJM */

  if (fabs (x - 1.0) < locEPS && (c - a - b) > 0 && c != 0 && !c_neg_integer) {

    gsl_sf_result lngamc, lngamcab, lngamca, lngamcb;

    double lngamc_sgn, lngamca_sgn, lngamcb_sgn;

    int status;

    int stat1 = gsl_sf_lngamma_sgn_e (c, &lngamc, &lngamc_sgn);

    int stat2 = gsl_sf_lngamma_e (c - a - b, &lngamcab);

    int stat3 = gsl_sf_lngamma_sgn_e (c - a, &lngamca, &lngamca_sgn);

    int stat4 = gsl_sf_lngamma_sgn_e (c - b, &lngamcb, &lngamcb_sgn);

    if (stat1 != GSL_SUCCESS || stat2 != GSL_SUCCESS

        || stat3 != GSL_SUCCESS || stat4 != GSL_SUCCESS)

      {

        DOMAIN_ERROR (result);

      }

    status =

      gsl_sf_exp_err_e (lngamc.val + lngamcab.val - lngamca.val - lngamcb.val,

                        lngamc.err + lngamcab.err + lngamca.err + lngamcb.err,

                        result);

    result->val *= lngamc_sgn / (lngamca_sgn * lngamcb_sgn);

      return status;

  }

  if(x < -1.0 || 1.0 <= x) {

    DOMAIN_ERROR(result);

  }

  if(c_neg_integer) {

    /* If c is a negative integer, then either a or b must be a

       negative integer of smaller magnitude than c to ensure

       cancellation of the series. */

    if(! (a_neg_integer && a > c + 0.1) && ! (b_neg_integer && b > c + 0.1)) {

      DOMAIN_ERROR(result);

    }

  }

  if(fabs(c-b) < locEPS || fabs(c-a) < locEPS) {

    return pow_omx(x, d, result);  /* (1-x)^(c-a-b) */

  }

  if(a >= 0.0 && b >= 0.0 && c >=0.0 && x >= 0.0 && x < 0.995) {

    /* Series has all positive definite

     * terms and x is not close to 1.

     */

    return hyperg_2F1_series(a, b, c, x, result);

  }

  if(fabs(a) < 10.0 && fabs(b) < 10.0) {

    /* a and b are not too large, so we attempt

     * variations on the series summation.

     */

    if(a_neg_integer) {

      return hyperg_2F1_series(rinta, b, c, x, result);

    }

    if(b_neg_integer) {

      return hyperg_2F1_series(a, rintb, c, x, result);

    }

    if(x < -0.25) {

      return hyperg_2F1_luke(a, b, c, x, result);

    }

    else if(x < 0.5) {

      return hyperg_2F1_series(a, b, c, x, result);

    }

    else {

      if(fabs(c) > 10.0) {

        return hyperg_2F1_series(a, b, c, x, result);

      }

      else {

        return hyperg_2F1_reflect(a, b, c, x, result);

      }

    }

  }

  else {

    /* Either a or b or both large.

     * Introduce some new variables ap,bp so that bp is

     * the larger in magnitude.

     */

    double ap, bp; 

    if(fabs(a) > fabs(b)) {

      bp = a;

      ap = b;

    }

    else {

      bp = b;

      ap = a;

    }

    if(x < 0.0) {

      /* What the hell, maybe Luke will converge.

       */

      return hyperg_2F1_luke(a, b, c, x, result);

    }

    if(GSL_MAX_DBL(fabs(ap),1.0)*fabs(bp)*fabs(x) < 2.0*fabs(c)) {

      /* If c is large enough or x is small enough,

       * we can attempt the series anyway.

       */

      return hyperg_2F1_series(a, b, c, x, result);

    }

    if(fabs(bp*bp*x*x) < 0.001*fabs(bp) && fabs(ap) < 10.0) {

      /* The famous but nearly worthless "large b" asymptotic.

       */

      int stat = gsl_sf_hyperg_1F1_e(ap, c, bp*x, result);

      result->err = 0.001 * fabs(result->val);

      return stat;

    }

    /* We give up. */

    result->val = 0.0;

    result->err = 0.0;

    GSL_ERROR ("error", GSL_EUNIMPL);

  }

}

int

gsl_sf_hyperg_2F1_conj_e(const double aR, const double aI, const double c,

                            const double x,

                            gsl_sf_result * result)

{

  const double ax = fabs(x);

  const double rintc = floor(c + 0.5);

  const int c_neg_integer = ( c < 0.0  &&  fabs(c - rintc) < locEPS );

  result->val = 0.0;

  result->err = 0.0;

  if(ax >= 1.0 || c_neg_integer || c == 0.0) {

    DOMAIN_ERROR(result);

  }

  if(   (ax < 0.25 && fabs(aR) < 20.0 && fabs(aI) < 20.0)

     || (c > 0.0 && x > 0.0)

    ) {

    return hyperg_2F1_conj_series(aR, aI, c, x, result);

  }

  else if(fabs(aR) < 10.0 && fabs(aI) < 10.0) {

    if(x < -0.25) {

      return hyperg_2F1_conj_luke(aR, aI, c, x, result);

    }

    else {

      return hyperg_2F1_conj_series(aR, aI, c, x, result);

    }

  }

  else {

    if(x < 0.0) {

      /* What the hell, maybe Luke will converge.

       */

      return hyperg_2F1_conj_luke(aR, aI, c, x, result); 

    }

    /* Give up. */

    result->val = 0.0;

    result->err = 0.0;

    GSL_ERROR ("error", GSL_EUNIMPL);

  }

}

int

gsl_sf_hyperg_2F1_renorm_e(const double a, const double b, const double c,

                              const double x,

                              gsl_sf_result * result

                              )

{

  const double rinta = floor(a + 0.5);

  const double rintb = floor(b + 0.5);

  const double rintc = floor(c + 0.5);

  const int a_neg_integer = ( a < 0.0  &&  fabs(a - rinta) < locEPS );

  const int b_neg_integer = ( b < 0.0  &&  fabs(b - rintb) < locEPS );

  const int c_neg_integer = ( c < 0.0  &&  fabs(c - rintc) < locEPS );

  if(c_neg_integer) {

    if((a_neg_integer && a > c+0.1) || (b_neg_integer && b > c+0.1)) {

      /* 2F1 terminates early */

      result->val = 0.0;

      result->err = 0.0;

      return GSL_SUCCESS;

    }

    else {

      /* 2F1 does not terminate early enough, so something survives */

      /* [Abramowitz+Stegun, 15.1.2] */

      gsl_sf_result g1, g2, g3, g4, g5;

      double s1, s2, s3, s4, s5;

      int stat = 0;

      stat += gsl_sf_lngamma_sgn_e(a-c+1, &g1, &s1;;

      stat += gsl_sf_lngamma_sgn_e(b-c+1, &g2, &s2;;

      stat += gsl_sf_lngamma_sgn_e(a, &g3, &s3;;

      stat += gsl_sf_lngamma_sgn_e(b, &g4, &s4;;

      stat += gsl_sf_lngamma_sgn_e(-c+2, &g5, &s5;;

      if(stat != 0) {

        DOMAIN_ERROR(result);

      }

      else {

        gsl_sf_result F;

        int stat_F = gsl_sf_hyperg_2F1_e(a-c+1, b-c+1, -c+2, x, &F);

        double ln_pre_val = g1.val + g2.val - g3.val - g4.val - g5.val;

        double ln_pre_err = g1.err + g2.err + g3.err + g4.err + g5.err;

        double sg  = s1 * s2 * s3 * s4 * s5;

        int stat_e = gsl_sf_exp_mult_err_e(ln_pre_val, ln_pre_err,

                                              sg * F.val, F.err,

                                              result);

        return GSL_ERROR_SELECT_2(stat_e, stat_F);

      }

    }

  }

  else {

    /* generic c */

    gsl_sf_result F;

    gsl_sf_result lng;

    double sgn;

    int stat_g = gsl_sf_lngamma_sgn_e(c, &lng, &sgn);

    int stat_F = gsl_sf_hyperg_2F1_e(a, b, c, x, &F);

    int stat_e = gsl_sf_exp_mult_err_e(-lng.val, lng.err,

                                          sgn*F.val, F.err,

                                          result);

    return GSL_ERROR_SELECT_3(stat_e, stat_F, stat_g);

  }