Sindbad~EG File Manager
/* code to compute the polygamma function(s)
Found by Google CodeSearch on the web, 8.24.07.
Translated from Fortran by
Peter Beerli 1996, Seattle
beerli@csit.fsu.edu
Beeson changed 'boolean' to int, TRUE to 1 and FALSE to 0,
replaced error messages by return values.
5.4.13 conditional include for XCODE; made d1mach and i1mach static
3.18.23 added (void) to silence a warning about comma operator
3.19.23 changes at lines 456-460 to silence a warning. Code was ok but confusing.
*/
#include <math.h>
#include <stdlib.h> // calloc
#include <memory.h> // memcpy
#include <ctype.h> // tolower, toupper
#include <assert.h>
#include <float.h> // DBL_MAX, etc.
#include <limits.h> // LONG_MAX
#include "baker.h" // PI_DECIMAL
#include "special.h"
extern int nearint(double, long *); // in deval.h but that needs terms, etc.
static double d1mach (long i);
static long i1mach (long i);
#define MIN(x,y) (((x) > (y)) ? (y) : (x))
#define MAX(x,y) (((x) > (y)) ? (x) : (y))
#define TWOPI (2 * PI_DECIMAL)
static int dpsifn (double *x, long *n, long kode, long m, double *ans, long *nz, long *ierr);
double polygamma (long n, double z)
{
double s = 0.0;
double t;
double ans;
long nz, ierr;
long k;
double nfactorial;
if(nearint(z,&k) && k <= 0)
return BADVAL;
if(z < -1000000)
return BADVAL;
if(z < 0)
{ dfactorial((double)n,&nfactorial);
t = nfactorial *pow(z, -(double)(n+1));
if(!(n&1))
t = -t;
do
{ s += t;
z += 1.0;
} while(z < 0.0);
}
dpsifn (&z, &n, 1, 1, &ans, &nz, &ierr);
if(ierr || nz)
return BADVAL;
ans += s;
if (n == 0)
return -ans;
else
return ans;
}
/* dpsifn.c -- translated by f2c (version 19950808).
and hand-patched by Peter Beerli Seattle, 1996
PURPOSE Compute derivatives of the Psi function.
LIBRARY SLATEC
CATEGORY C7C
AUTHOR Amos, D. E., (SNLA)
DPSIFN computes a sequence of SCALED derivatives of
the PSI function; i.e. for fixed X and M it computes
the M-member sequence
((-1)**(K+1)/GAMMA(K+1))*PSI(K,X)
for K = N,...,N+M-1
where PSI(K,X) is as defined above. For KODE=1, DPSIFN returns
the scaled derivatives as described. KODE=2 is operative only
when K=0 and in that case DPSIFN returns -PSI(X) + LN(X). That
is, the logarithmic behavior for large X is removed when KODE=2
and K=0. When sums or differences of PSI functions are computed
the logarithmic terms can be combined analytically and computed
separately to help retain significant digits.
Note that CALL DPSIFN(X,0,1,1,ANS) results in
ANS = -PSI(X)
Input X is double PRECISION
X - Argument, X .gt. 0.0D0
N - First member of the sequence, 0 .le. N .le. 100
N=0 gives ANS(1) = -PSI(X) for KODE=1
-PSI(X)+LN(X) for KODE=2
KODE - Selection parameter
KODE=1 returns scaled derivatives of the PSI
function.
KODE=2 returns scaled derivatives of the PSI
function EXCEPT when N=0. In this case,
ANS(1) = -PSI(X) + LN(X) is returned.
M - Number of members of the sequence, M.ge.1
Output ANS is double PRECISION
ANS - A vector of length at least M whose first M
components contain the sequence of derivatives
scaled according to KODE.
NZ - Underflow flag
NZ.eq.0, A normal return
NZ.ne.0, Underflow, last NZ components of ANS are
set to zero, ANS(M-K+1)=0.0, K=1,...,NZ
IERR - Error flag
IERR=0, A normal return, computation completed
IERR=1, Input error, no computation
IERR=2, Overflow, X too small or N+M-1 too
large or both
IERR=3, Error, N too large. Dimensioned
array TRMR(NMAX) is not large enough for N
The nominal computational accuracy is the maximum of unit
roundoff (=D1MACH(4)) and 1.0D-18 since critical constants
are given to only 18 digits.
PSIFN is the single precision version of DPSIFN.
*Long Description:
The basic method of evaluation is the asymptotic expansion
for large X.ge.XMIN followed by backward recursion on a two
term recursion relation
W(X+1) + X**(-N-1) = W(X).
This is supplemented by a series
SUM( (X+K)**(-N-1) , K=0,1,2,... )
which converges rapidly for large N. Both XMIN and the
number of terms of the series are calculated from the unit
roundoff of the machine environment.
REFERENCES Handbook of Mathematical Functions, National Bureau
of Standards Applied Mathematics Series 55, edited
by M. Abramowitz and I. A. Stegun, equations 6.3.5,
6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964.
D. E. Amos, A portable Fortran subroutine for
derivatives of the Psi function, Algorithm 610, ACM
Transactions on Mathematical Software 9, 4 (1983),
pp. 494-502.
*/
static double d1mach (long i)
{
switch (i)
{
case 1:
return DBL_MIN;
case 2:
return DBL_MAX;
case 3:
return DBL_EPSILON / FLT_RADIX;
case 4:
return DBL_EPSILON;
case 5:
return log10 ((double) FLT_RADIX);
default:
assert(0);
}
return 0; /* for compilers that complain of missing return values */
}
static long i1mach (long i)
{
switch (i)
{
case 1: return 5; /* standard input */
case 2: return 6; /* standard output */
case 3: return 7; /* standard punch */
case 4: return 0; /* standard error */
case 5: return 32; /* bits per integer */
case 6: return 1; /* Fortran 77 value */
case 7: return 2; /* base for integers */
case 8: return 31; /* digits of integer base */
case 9: return LONG_MAX;
case 10: return FLT_RADIX;
case 11: return FLT_MANT_DIG;
case 12: return FLT_MIN_EXP;
case 13: return FLT_MAX_EXP;
case 14: return DBL_MANT_DIG;
case 15: return DBL_MIN_EXP;
case 16: return DBL_MAX_EXP;
}
assert(0);
return 0; /* for compilers that complain of missing return values */
}
static int dpsifn (double *x, long *n, long kode, long m, double *ans, long *nz, long *ierr)
{
/* Initialized data */
/*static */ long nmax = 100;
/*static */
double b[22] = { 1., -.5, .166666666666666667,
-.0333333333333333333, .0238095238095238095, -.0333333333333333333,
.0757575757575757576, -.253113553113553114, 1.16666666666666667,
-7.09215686274509804, 54.9711779448621554, -529.124242424242424,
6192.1231884057971, -86580.2531135531136, 1425517.16666666667,
-27298231.067816092, 601580873.900642368, -15116315767.0921569,
429614643061.166667, -13711655205088.3328, 488332318973593.167,
-19296579341940068.1
};
/* System generated locals */
long i1, i2;
double d1, d2;
/* Local variables */
/*static */
double elim, xinc, xmin, tols, xdmy, yint, trmr[100], rxsq;
/*static */
long i__, j, k;
/*static */
double s, t, slope, xdmln, wdtol;
/*static */
double t1, t2;
/*static */
long fn;
/*static */
double ta;
/*static */
long mm, nn, np;
/*static */
double fx, tk;
/*static */
long mx, nx;
/*static */
double xm, tt, xq, den, arg, fln, r1m4, r1m5, eps, rln, tol,
xln, trm[22], tss, tst;
/* Parameter adjustments */
--ans;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* BERNOULLI NUMBERS */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT DPSIFN */
*ierr = 0;
*nz = 0;
if (*x <= 0.)
{
*ierr = 1;
}
if (*n < 0)
{
*ierr = 1;
}
if (kode < 1 || kode > 2)
{
*ierr = 1;
}
if (m < 1)
{
*ierr = 1;
}
if (*ierr != 0)
{
return 0;
}
mm = m;
/* Computing MIN */
i1 = -15L; i2 = 16L;
nx = MIN (-i1mach (15L), i1mach (16L));
r1m5 = d1mach (5L);
r1m4 = d1mach (4L) * .5;
wdtol = MAX (r1m4, 5e-19);
/* ----------------------------------------------------------------------- */
/* ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
elim = (nx * r1m5 - 3.) * 2.302;
xln = log (*x);
L41:
nn = *n + mm - 1;
fn = nn;
t = (fn + 1) * xln;
/* ----------------------------------------------------------------------- */
/* OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X */
/* ----------------------------------------------------------------------- */
if (fabs (t) > elim)
{
goto L290;
}
if (*x < wdtol)
{
goto L260;
}
/* ----------------------------------------------------------------------- */
/* COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 */
/* ----------------------------------------------------------------------- */
rln = r1m5 * i1mach (14L);
rln = MIN (rln, 18.06);
fln = MAX (rln, 3.) - 3.;
yint = fln * .4 + 3.5;
slope = fln * (fln * 6.038e-4 + .008677) + .21;
xm = yint + slope * fn;
mx = (long) xm + 1;
xmin = (double) mx;
if (*n == 0)
{
goto L50;
}
xm = rln * -2.302 - MIN (0., xln);
arg = xm / *n;
arg = MIN (0., arg);
eps = exp (arg);
xm = 1. - eps;
if (fabs (arg) < .001)
{
xm = -arg;
}
fln = *x * xm / eps;
xm = xmin - *x;
if (xm > 7. && fln < 15.)
{
goto L200;
}
L50:
xdmy = *x;
xdmln = xln;
xinc = 0.;
if (*x >= xmin)
{
goto L60;
}
nx = (long) (*x);
xinc = xmin - nx;
xdmy = *x + xinc;
xdmln = log (xdmy);
L60:
/* ----------------------------------------------------------------------- */
/* GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION */
/* ----------------------------------------------------------------------- */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
/* Computing MAX */
d1 = fabs (t); d2 = fabs (t1); d1 = MAX (d1, d2); d2 = fabs (t2);
tk = MAX (d1, d2);
if (tk > elim)
{
goto L380;
}
tss = exp(-t);
tt = .5 / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0)
{
t1 = tt + 1. / fn;
}
rxsq = 1. / (xdmy * xdmy);
ta = rxsq * .5;
t = (fn + 1) * ta;
s = t * b[2];
if (fabs (s) < tst)
{
goto L80;
}
tk = 2.;
for (k = 4; k <= 22; ++k)
{
t = t * ((tk + fn + 1) / (tk + 1.)) * ((tk + fn) / (tk + 2.)) * rxsq;
trm[k - 1] = t * b[k - 1];
if (((void)(d1 = trm[k - 1]), fabs (d1)) < tst)
{
goto L80;
}
s += trm[k - 1];
tk += 2.;
/* L70: */
}
L80:
s = (s + t1) * tss;
if (xinc == 0.)
{
goto L100;
}
/* ----------------------------------------------------------------------- */
/* BACKWARD RECUR FROM XDMY TO X */
/* ----------------------------------------------------------------------- */
nx = (long) xinc;
np = nn + 1;
if (nx > nmax)
{
goto L390;
}
if (nn == 0)
{
goto L160;
}
xm = xinc - 1.;
fx = *x + xm;
/* ----------------------------------------------------------------------- */
/* THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL */
/* ----------------------------------------------------------------------- */
i1 = nx;
for (i__ = 1; i__ <= i1; ++i__)
{
i2 = -np;
trmr[i__ - 1] = pow (fx, (double) i2);
s += trmr[i__ - 1];
xm += -1.;
fx = *x + xm;
/* L90: */
}
L100:
ans[mm] = s;
if (fn == 0)
{
goto L180;
}
/* ----------------------------------------------------------------------- */
/* GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 */
/* ----------------------------------------------------------------------- */
if (mm == 1)
{
return 0;
}
i1 = mm;
for (j = 2; j <= i1; ++j)
{
--fn;
tss *= xdmy;
t1 = tt;
if (fn != 0)
{
t1 = tt + 1. / fn;
}
t = (fn + 1) * ta;
s = t * b[2];
if (fabs (s) < tst)
{
goto L120;
}
tk = (double) (fn + 4);
for (k = 4; k <= 22; ++k)
{
trm[k - 1] = trm[k - 1] * (fn + 1) / tk;
d1 = trm[k-1];
if ( fabs (d1) < tst)
{
goto L120;
}
s += d1;
tk += 2.;
/* L110: */
}
L120:
s = (s + t1) * tss;
if (xinc == 0.)
{
goto L140;
}
if (fn == 0)
{
goto L160;
}
xm = xinc - 1.;
fx = *x + xm;
i2 = nx;
for (i__ = 1; i__ <= i2; ++i__)
{
trmr[i__ - 1] *= fx;
s += trmr[i__ - 1];
xm += -1.;
fx = *x + xm;
/* L130: */
}
L140:
mx = mm - j + 1;
ans[mx] = s;
if (fn == 0)
{
goto L180;
}
/* L150: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RECURSION FOR N = 0 */
/* ----------------------------------------------------------------------- */
L160:
i1 = nx;
for (i__ = 1; i__ <= i1; ++i__)
{
s += 1. / (*x + nx - i__);
/* L170: */
}
L180:
if (kode == 2)
{
goto L190;
}
ans[1] = s - xdmln;
return 0;
L190:
if (xdmy == *x)
{
return 0;
}
xq = xdmy / *x;
ans[1] = s - log (xq);
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... */
/* ----------------------------------------------------------------------- */
L200:
nn = (long) fln + 1;
np = *n + 1;
t1 = (*n + 1) * xln;
t = exp(-t1);
s = t;
den = *x;
i1 = nn;
for (i__ = 1; i__ <= i1; ++i__)
{
den += 1.;
i2 = -np;
trm[i__ - 1] = pow (den, (double) i2);
s += trm[i__ - 1];
/* L210: */
}
ans[1] = s;
if (*n != 0)
{
goto L220;
}
if (kode == 2)
{
ans[1] = s + xln;
}
L220:
if (mm == 1)
{
return 0;
}
/* ----------------------------------------------------------------------- */
/* GENERATE HIGHER DERIVATIVES, J.GT.N */
/* ----------------------------------------------------------------------- */
tol = wdtol / 5.;
i1 = mm;
for (j = 2; j <= i1; ++j)
{
t /= *x;
s = t;
tols = t * tol;
den = *x;
i2 = nn;
for (i__ = 1; i__ <= i2; ++i__)
{
den += 1.;
trm[i__ - 1] /= den;
s += trm[i__ - 1];
if (trm[i__ - 1] < tols)
{
goto L240;
}
/* L230: */
}
L240:
ans[j] = s;
/* L250: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* SMALL X.LT.UNIT ROUND OFF */
/* ----------------------------------------------------------------------- */
L260:
i1 = -(*n) - 1;
ans[1] = pow (*x, (double) i1);
if (mm == 1)
{
goto L280;
}
k = 1;
i1 = mm;
for (i__ = 2; i__ <= i1; ++i__)
{
ans[k + 1] = ans[k] / *x;
++k;
/* L270: */
}
L280:
if (*n != 0)
{
return 0;
}
if (kode == 2)
{
ans[1] += xln;
}
return 0;
L290:
if (t > 0.)
{
goto L380;
}
*nz = 0;
*ierr = 2;
return 0;
L380:
++(*nz);
ans[mm] = 0.;
--mm;
if (mm == 0)
{
return 0;
}
goto L41;
L390:
*nz = 0;
*ierr = 3;
return 0;
} /* dpsifn_ */
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists