Sindbad~EG File Manager

/* M. Beeson, following ideas in Numerical Recipes pp. 108-109
  compute factorials, Gamma function, binomial coefficients
  producing decimal answers
  12.17.91 original date
  3.24.95  modified
  1.7.97  modified dbinomial to avoid warnings in VC
  5.13.13 modified dbinomial to compute 1 for x choose 0 and work on non-integer inputs
*/
#include <math.h>
#include <assert.h>

#include "terms.h"
#include "deval.h"
#include "baker.h"  /* for PI_DECIMAL */


#define BADVAL 2.0E300
double gammln(double);
int gamma2(double, double *);   /* called by deval.c */
int dfactorial(double, double *);
int dbinomial(double,double, double *);
static double factln(int n);
/*_____________________________________________________________________*/
#define TABLEDIM 33
int dfactorial(double x, double *ansp)
/* compute factorial of x if x > 0 -- integer or not */
/* if isn't an int, but is very close to an int k, will not fail but
will compute k factorial */
/* return 0 to indicate success */
/* return 18 if factorial would overflow a double */

{ static int ntop = 4;
  long k;
  static double a[TABLEDIM] = {1.0, 1.0, 2.0, 6.0, 24.0}; /* fill in as needed */
  int j;
  if(x<0)
     return 19;
  if(x > 170 )  /* determined by exact calculation of 170! */
     return 18;
  if(x > 32)
     { *ansp = exp(gammln(x + 1.0));
       return 0;
     }
  if(nearint(x,&k) && ((k >> 17) == 0))
     { x = (double) k;  /* fix a slight deviation from an integer,
                      which would probably be due to roundoff error.  */
       if(k < TABLEDIM)  /* fill in the static lookup table */
          { while(ntop < k)
               { j = ntop++;
                 a[ntop] = a[j]*ntop;
               }
            *ansp = a[(int) k];
            return 0;
          }
     }
  *ansp = exp(gammln(x+1.0));
  return 0;
}
/*___________________________________________________________________*/
#define NFTABLE 100  /* was 100 in Numerical Recipes; until 5.13.2013 was 25 in MathXpert */
static double factln(int n)
/* returns ln(n!) */
/* never overflows */
/* n is assumed to be positive */
{  static double a[NFTABLE];  /* table of function values */
   if(n <= 1)
      return 0.0;
   if(n < NFTABLE)  /* use or add to the table */
      return a[n] ? a[n] : (a[n]=gammln(n+1.0));
   return gammln(n+1.0);  /* out of range of the table */
}
#undef NFTABLE
/*___________________________________________________________________*/
int dbinomial( double x, double y, double *ansp)

/*  compute x choose y;  x and y do not have to be integers, but y has to be nonnegative */

{ double arg;
  long xx,yy;
  int err;
  if(fabs(y) < 1.0e-7)  //  y is zero within roundoff error
     { *ansp = 1.0;    //  x choose 0  is always 1 
        return 0;
     }
  if(y < 0.0 )
     return 1;
  if (x > y)
     y = x-y;  // take advantage of symmetry.  This is valid even if the arguments are not integers.
  if (nearint(x,&xx) &&  xx >= 0 && (xx >> 17) == 0  /* x has only 16 bits */
      && nearint(y,&yy) && (yy >> 17) == 0  /* and y also has only 16 bits */
     )
     { arg = factln((int) xx) - factln((int)yy) - factln((int)(xx-yy));
       if(arg >= 709)   /* 308 ln 10 */
          { *ansp = BADVAL;
            return 16;
          }
       *ansp = floor(0.5 + exp(arg));
       return 0;
     }
  else if(nearint(x,&xx) && xx < 0)
     { // then you can't use gammln because the gamma function has singularities at negative integers
       // but the answer is binomial(|xx| + y-1,y), up to sign
       if(!nearint(y,&yy))
           { *ansp = BADVAL;
             return 1;  
           }
       err =  dbinomial(-x + y-1,y,ansp);
       if(err)
          return err;
       if(yy % 2)
          *ansp = -*ansp;
       return 0;
     }
  else
     { arg = gammln(x+1) - gammln(y+1) - gammln(x-y+1);
       if(arg != arg)  // check for a QNaN error ("quiet NaN", causes no exception)
                       // such an error should only happen if the function is incorrectly called so that x-y+1 is negative
          { *ansp = BADVAL;
            return 16;
          }
       if(arg >= 709)   /* 308 ln 10 */
          { *ansp = BADVAL;
            return 16;
          }
       if(x-y+1 > 0 ||  (((int) floor(y-x-1 + 0.001)) % 2) ==1)
          *ansp = exp(arg);
       else *ansp = -exp(arg);
       if(*ansp != *ansp)   // check for a QNaN error
          { *ansp = BADVAL;
            return 16;
          }
       return 0;
     }
}
/* ______________________________________________________*/
double gammln(double xx)
/* computes ln of the gamma function, for xx > 1;
see Numerical Recipes in C, 2nd edition, pages 213--14.
For xx < 1  it computes ln |gamma(x)|, using formula 6.14, p. 213 of
Numerical Recipes, 2nd ed.  This is used in dbinomial (only). 
*/
{ double x,tmp,ser;
  static double cof[6]={76.18009172947146,-86.50532032941677,24.01409824083091,
                -1.23173951572450155,0.1208650973866179e-2,-0.5395239384953e-5};
  int j;
  long k;
  if(nearint(xx,&k) && k==1)
      { // gamma(1)= 0! = 1, so its log is 0
        return 0.0;
      }
  if(xx < 1.0)
     { double y = sin(PI_DECIMAL*xx);
       if(nearint(y,&k) && k==0)
          return BADVAL;  // gamma has singularities at negative integer values;
       if(xx > 0.0)
          return  log((1.0-xx)*PI_DECIMAL) - gammln(2.0-xx) - log(y);
       else /* xx < 0.0 */
          return log(PI_DECIMAL) - gammln(1.0-xx) - log(fabs(y)); 
       return 0;              
     } 
  x=xx-1.0;
  tmp=x+5.5;
  tmp -= (x+0.5)*log(tmp);
  ser=1.0;
  for (j=0;j<=5;j++)
     { x += 1.0;
       ser += cof[j]/x;
     }
  return -tmp+log(2.50662827465*ser);
}
/*_____________________________________________________________*/
int gamma2 (double x, double *ansp)
{ long k;
  double y;
  if( x > 1.0)
     { *ansp = exp(gammln(x));
       return 0;
     }
  if(nearint(x,&k) && k==1)
     { *ansp = 1.0;
       return 0;
     }
      /* and now for x<1 : Gamma(x) =  pi x/(Gamma(2-x)sin(pi x))
                                   or pi /(Gamma(1-x)sin( pi x))
             (p. 167 Numerical Recipes 1st ed., p. 213 2nd edition.)  */
  y = sin(PI_DECIMAL*x);
  if(nearint(y,&k) && k==0)
     { *ansp = BADVAL;
       return 26;
     }
  if(x > 0.0)
     *ansp = (1.0-x) * PI_DECIMAL * exp(- gammln(2.0-x))/y;
  else /* x < 0.0 */
     *ansp = PI_DECIMAL * exp(- gammln(1.0-x))/y;
  return 0;
}