double d1mach(int i)
{
switch(i) {
case 1: return numeric_limits<double>::min();
case 2: return numeric_limits<double>::max();
case 3: /* = FLT_RADIX ^ - DBL_MANT_DIG
for IEEE: = 2^-53 = 1.110223e-16 = .5*numeric_limits<double>::epsilon() */
return pow((double)i1mach(10), -(double)i1mach(14));
case 4: /* = FLT_RADIX ^ (1- DBL_MANT_DIG) =
for IEEE: = 2^52 = 4503599627370496 = 1/numeric_limits<double>::epsilon() */
return pow((double)i1mach(10), 1-(double)i1mach(14));
case 5: return log10(2.0);/* = M_LOG10_2 in Bmath.hpp */
default: return 0.0;
}
}
void i1mach_prb ( void )
/******************************************************************************/
/*
Purpose:
I1MACH_PRB reports the constants returned by I1MACH.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
25 April 2007
Author:
John Burkardt
*/
{
printf ( "\n" );
printf ( "I1MACH_PRB\n" );
printf ( " I1MACH reports the value of constants associated\n" );
printf ( " with integer computer arithmetic.\n" );
printf ( "\n" );
printf ( " Numbers associated with input/output units:\n" );
printf ( "\n" );
printf ( " I1MACH(1) = the standard input unit.\n" );
printf ( "%d\n", i1mach(1) );
printf ( "\n" );
printf ( " I1MACH(2) = the standard output unit.\n" );
printf ( "%d\n", i1mach(2) );
printf ( "\n" );
printf ( " I1MACH(3) = the standard punch unit.\n" );
printf ( "%d\n", i1mach(3) );
printf ( "\n" );
printf ( " I1MACH(4) = the standard error message unit.\n" );
printf ( "%d\n", i1mach(4) );
printf ( "\n" );
printf ( " Numbers associated with words:\n" );
printf ( "\n" );
printf ( " I1MACH(5) = the number of bits per integer.\n" );
printf ( "%d\n", i1mach(5) );
printf ( "\n" );
printf ( " I1MACH(6) = the number of characters per integer.\n" );
printf ( "%d\n", i1mach(6) );
printf ( "\n" );
printf ( " Numbers associated with integer values:\n" );
printf ( "\n" );
printf ( " Assume integers are represented in the S digit \n" );
printf ( " base A form:\n" );
printf ( "\n" );
printf ( " Sign * (X(S-1)*A^(S-1) + ... + X(1)*A + X(0))\n" );
printf ( "\n" );
printf ( " where the digits X satisfy 0 <= X(1:S-1) < A.\n" );
printf ( "\n" );
printf ( " I1MACH(7) = A, the base.\n" );
printf ( "%d\n", i1mach(7) );
printf ( "\n" );
printf ( " I1MACH(8) = S, the number of base A digits.\n" );
printf ( "%d\n", i1mach(8) );
printf ( "\n" );
printf ( " I1MACH(9) = A^S-1, the largest integer.\n" );
printf ( "%d\n", i1mach(9) );
printf ( "\n" );
printf ( " Numbers associated with floating point values:\n" );
printf ( "\n" );
printf ( " Assume floating point numbers are represented \n" );
printf ( " in the T digit base B form:\n" );
printf ( "\n" );
printf ( " Sign * (B**E) * ((X(1)/B) + ... + (X(T)/B^T) )\n" );
printf ( "\n" );
printf ( " where\n" );
printf ( "\n" );
printf ( " 0 <= X(1:T) < B,\n" );
printf ( " 0 < X(1) (unless the value being represented is 0),\n" );
printf ( " EMIN <= E <= EMAX.\n" );
printf ( "\n" );
printf ( " I1MACH(10) = B, the base.\n" );
printf ( "%d\n", i1mach(10) );
printf ( "\n" );
printf ( " Numbers associated with single precision values:\n" );
printf ( "\n" );
printf ( " I1MACH(11) = T, the number of base B digits.\n" );
printf ( "%d\n", i1mach(11) );
printf ( "\n" );
printf ( " I1MACH(12) = EMIN, the smallest exponent E.\n" );
printf ( "%d\n", i1mach(12) );
printf ( "\n" );
printf ( " I1MACH(13) = EMAX, the largest exponent E.\n" );
printf ( "%d\n", i1mach(13) );
printf ( "\n" );
printf ( " Numbers associated with double precision values:\n" );
printf ( "\n" );
printf ( " I1MACH(14) = T, the number of base B digits.\n" );
printf ( "%d\n", i1mach(14) );
printf ( "\n" );
printf ( " I1MACH(15) = EMIN, the smallest exponent E.\n" );
printf ( "%d\n", i1mach(15) );
printf ( "\n" );
printf ( " I1MACH(16) = EMAX, the largest exponent E.\n" );
printf ( "%d\n", i1mach(16) );
return;
}
void dpsifn(double x, int n, int kode, int m, double *ans, int *nz, int *ierr)
{
const double bvalues[] = { /* Bernoulli Numbers */
1.00000000000000000e+00,
-5.00000000000000000e-01,
1.66666666666666667e-01,
-3.33333333333333333e-02,
2.38095238095238095e-02,
-3.33333333333333333e-02,
7.57575757575757576e-02,
-2.53113553113553114e-01,
1.16666666666666667e+00,
-7.09215686274509804e+00,
5.49711779448621554e+01,
-5.29124242424242424e+02,
6.19212318840579710e+03,
-8.65802531135531136e+04,
1.42551716666666667e+06,
-2.72982310678160920e+07,
6.01580873900642368e+08,
-1.51163157670921569e+10,
4.29614643061166667e+11,
-1.37116552050883328e+13,
4.88332318973593167e+14,
-1.92965793419400681e+16
};
const double *b = (double *)&bvalues -1; /* ==> b[1] = bvalues[0], etc */
const int nmax = n_max;
int i, j, k, mm, mx, nn, np, nx, fn;
double arg, den, elim, eps, fln, fx, rln, rxsq,
r1m4, r1m5, s, slope, t, ta, tk, tol, tols, tss, tst,
tt, t1, t2, wdtol, xdmln, xdmy, xinc, xln = 0.0 /* -Wall */,
xm, xmin, xq, yint;
double trm[23], trmr[n_max + 1];
*ierr = 0;
if (n < 0 || kode < 1 || kode > 2 || m < 1) {
*ierr = 1;
return;
}
if (x <= 0.) {
/* use Abramowitz & Stegun 6.4.7 "Reflection Formula"
* psi(k, x) = (-1)^k psi(k, 1-x) - pi^{n+1} (d/dx)^n cot(x)
*/
if (x == (long)x) {
/* non-positive integer : +Inf or NaN depends on n */
for(j=0; j < m; j++) /* k = j + n : */
ans[j] = ((j+n) % 2) ? ML_POSINF : ML_NAN;
return;
}
dpsifn(1. - x, n, /*kode = */ 1, m, ans, nz, ierr);
/* ans[j] == (-1)^(k+1) / gamma(k+1) * psi(k, 1 - x)
* for j = 0:(m-1) , k = n + j
*/
/* Cheat for now: only work for m = 1, n in {0,1,2,3} : */
if(m > 1 || n > 3) {/* doesn't happen for digamma() .. pentagamma() */
/* not yet implemented */
*ierr = 4; return;
}
x *= M_PI; /* pi * x */
if (n == 0)
tt = cos(x)/sin(x);
else if (n == 1)
tt = -1/pow(sin(x),2);
else if (n == 2)
tt = 2*cos(x)/pow(sin(x),3);
else if (n == 3)
tt = -2*(2*pow(cos(x),2) + 1)/pow(sin(x),4);
else /* can not happen! */
tt = ML_NAN;
/* end cheat */
s = (n % 2) ? -1. : 1.;/* s = (-1)^n */
/* t := pi^(n+1) * d_n(x) / gamma(n+1) , where
* d_n(x) := (d/dx)^n cot(x)*/
t1 = t2 = s = 1.;
for(k=0, j=k-n; j < m; k++, j++, s = -s) {
/* k == n+j , s = (-1)^k */
t1 *= M_PI;/* t1 == pi^(k+1) */
if(k >= 2)
t2 *= k;/* t2 == k! == gamma(k+1) */
if(j >= 0) /* by cheat above, tt === d_k(x) */
ans[j] = s*(ans[j] + t1/t2 * tt);
}
if (n == 0 && kode == 2)
ans[0] += xln;
return;
} /* x <= 0 */
*nz = 0;
mm = m;
nx = imin2(-i1mach(15), i1mach(16));/* = 1021 */
r1m5 = d1mach(5);
r1m4 = d1mach(4) * 0.5;
wdtol = fmax2(r1m4, 0.5e-18); /* 1.11e-16 */
/* elim = approximate exponential over and underflow limit */
elim = 2.302 * (nx * r1m5 - 3.0);/* = 700.6174... */
xln = log(x);
for(;;) {
nn = n + mm - 1;
fn = nn;
t = (fn + 1) * xln;
/* overflow and underflow test for small and large x */
if (fabs(t) > elim) {
if (t <= 0.0) {
*nz = 0;
*ierr = 2;
return;
}
}
else {
if (x < wdtol) {
ans[0] = pow(x, -n-1.0);
if (mm != 1) {
for(k = 1; k < mm ; k++)
ans[k] = ans[k-1] / x;
}
if (n == 0 && kode == 2)
ans[0] += xln;
return;
}
/* compute xmin and the number of terms of the series, fln+1 */
rln = r1m5 * i1mach(14);
rln = fmin2(rln, 18.06);
fln = fmax2(rln, 3.0) - 3.0;
yint = 3.50 + 0.40 * fln;
slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
xm = yint + slope * fn;
mx = (int)xm + 1;
xmin = mx;
if (n != 0) {
xm = -2.302 * rln - fmin2(0.0, xln);
arg = xm / n;
arg = fmin2(0.0, arg);
eps = exp(arg);
xm = 1.0 - eps;
if (fabs(arg) < 1.0e-3)
xm = -arg;
fln = x * xm / eps;
xm = xmin - x;
if (xm > 7.0 && fln < 15.0)
break;
}
xdmy = x;
xdmln = xln;
xinc = 0.0;
if (x < xmin) {
nx = (int)x;
xinc = xmin - nx;
xdmy = x + xinc;
xdmln = log(xdmy);
}
/* generate w(n+mm-1, x) by the asymptotic expansion */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
tk = fmax2(fabs(t), fmax2(fabs(t1), fabs(t2)));
if (tk <= elim)
goto L10;
}
nz++;
mm--;
ans[mm] = 0.;
if (mm == 0)
return;
}
nn = (int)fln + 1;
np = n + 1;
t1 = (n + 1) * xln;
t = exp(-t1);
s = t;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] = pow(den, (double)-np);
s += trm[i];
}
ans[0] = s;
if (n == 0 && kode == 2)
ans[0] = s + xln;
if (mm != 1) { /* generate higher derivatives, j > n */
tol = wdtol / 5.0;
for(j = 1; j < mm; j++) {
t /= x;
s = t;
tols = t * tol;
den = x;
for(i=1; i <= nn; i++) {
den += 1.;
trm[i] /= den;
s += trm[i];
if (trm[i] < tols)
break;
}
ans[j] = s;
}
}
return;
L10:
tss = exp(-t);
tt = 0.5 / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0)
t1 = tt + 1.0 / fn;
rxsq = 1.0 / (xdmy * xdmy);
ta = 0.5 * rxsq;
t = (fn + 1) * ta;
s = t * b[3];
if (fabs(s) >= tst) {
tk = 2.0;
for(k = 4; k <= 22; k++) {
t = t * ((tk + fn + 1)/(tk + 1.0))*((tk + fn)/(tk + 2.0)) * rxsq;
trm[k] = t * b[k];
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
/* backward recur from xdmy to x */
nx = (int)xinc;
np = nn + 1;
if (nx > nmax) {
*nz = 0;
*ierr = 3;
return;
}
else {
if (nn==0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
/* this loop should not be changed. fx is accurate when x is small */
for(i = 1; i <= nx; i++) {
trmr[i] = pow(fx, (double)-np);
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
}
ans[mm-1] = s;
if (fn == 0)
goto L30;
/* generate lower derivatives, j < n+mm-1 */
for(j = 2; j <= mm; j++) {
fn--;
tss *= xdmy;
t1 = tt;
if (fn!=0)
t1 = tt + 1.0 / fn;
t = (fn + 1) * ta;
s = t * b[3];
if (fabs(s) >= tst) {
tk = 4 + fn;
for(k=4; k <= 22; k++) {
trm[k] = trm[k] * (fn + 1) / tk;
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
if (fn == 0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
for(i=1 ; i<=nx ; i++) {
trmr[i] = trmr[i] * fx;
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
ans[mm - j] = s;
if (fn == 0)
goto L30;
}
return;
L20:
for(i = 1; i <= nx; i++)
s += 1. / (x + nx - i);
L30:
if (kode!=2)
ans[0] = s - xdmln;
else if (xdmy != x) {
xq = xdmy / x;
ans[0] = s - log(xq);
}
return;
} /* dpsifn() */
static
void dpsifn(double x, int n, int kode, int m, double *ans, int *nz, int *ierr)
{
const double bvalues[] = { /* Bernoulli Numbers */
1.00000000000000000e+00,
-5.00000000000000000e-01,
1.66666666666666667e-01,
-3.33333333333333333e-02,
2.38095238095238095e-02,
-3.33333333333333333e-02,
7.57575757575757576e-02,
-2.53113553113553114e-01,
1.16666666666666667e+00,
-7.09215686274509804e+00,
5.49711779448621554e+01,
-5.29124242424242424e+02,
6.19212318840579710e+03,
-8.65802531135531136e+04,
1.42551716666666667e+06,
-2.72982310678160920e+07,
6.01580873900642368e+08,
-1.51163157670921569e+10,
4.29614643061166667e+11,
-1.37116552050883328e+13,
4.88332318973593167e+14,
-1.92965793419400681e+16
};
const double *b = (double *)&bvalues -1; /* ==> b[1] = bvalues[0], etc */
const int nmax = 100;
int i, j, k, mm, mx, nn, np, nx, fn;
double arg, den, elim, eps, fln, fx, rln, rxsq,
r1m4, r1m5, s, slope, t, ta, tk, tol, tols, tss, tst,
tt, t1, t2, wdtol, xdmln, xdmy, xinc, xln, xm, xmin,
xq, yint;
double trm[23], trmr[101];
*ierr = 0;
if (x <= 0.0 || n < 0 || kode < 1 || kode > 2 || m < 1) {
*ierr = 1;
return;
}
/* fortran adjustment */
ans--;
*nz = 0;
mm = m;
nx = std::min(-i1mach(15), i1mach(16));
r1m5 = d1mach(5);
r1m4 = d1mach(4) * 0.5;
wdtol = std::max(r1m4, 0.5e-18);
/* elim = approximate exponential over and underflow limit */
elim = 2.302 * (nx * r1m5 - 3.0);
xln = log(x);
for(;;) {
nn = n + mm - 1;
fn = nn;
t = (fn + 1) * xln;
/* overflow and underflow test for small and large x */
if (fabs(t) > elim) {
if (t <= 0.0) {
*nz = 0;
*ierr = 2;
return;
}
}
else {
if (x < wdtol) {
ans[1] = pow(x, -n-1.0);
if (mm != 1) {
for(i = 2, k = 1; i <= mm ; i++, k++)
ans[k+1] = ans[k] / x;
}
if (n == 0 && kode == 2)
ans[1] += xln;
return;
}
/* compute xmin and the number of terms of the series, fln+1 */
rln = r1m5 * i1mach(14);
rln = std::min(rln, 18.06);
fln = std::max(rln, 3.0) - 3.0;
yint = 3.50 + 0.40 * fln;
slope = 0.21 + fln * (0.0006038 * fln + 0.008677);
xm = yint + slope * fn;
mx = (int)xm + 1;
xmin = mx;
if (n != 0) {
xm = -2.302 * rln - std::min(0.0, xln);
arg = xm / n;
arg = std::min(0.0, arg);
eps = exp(arg);
xm = 1.0 - eps;
if (fabs(arg) < 1.0e-3)
xm = -arg;
fln = x * xm / eps;
xm = xmin - x;
if (xm > 7.0 && fln < 15.0)
break;
}
xdmy = x;
xdmln = xln;
xinc = 0.0;
if (x < xmin) {
nx = (int)x;
xinc = xmin - nx;
xdmy = x + xinc;
xdmln = log(xdmy);
}
/* generate w(n+mm-1, x) by the asymptotic expansion */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
tk = std::max(fabs(t), std::max(fabs(t1), fabs(t2)));
if (tk <= elim)
goto L10;
}
nz++;
ans[mm] = 0.0;
mm--;
if (mm == 0)
return;
}
nn = (int)fln + 1;
np = n + 1;
t1 = (n + 1) * xln;
t = exp(-t1);
s = t;
den = x;
for(i=1 ; i<=nn ; i++) {
den += 1.;
trm[i] = pow(den, (double)-np);
s += trm[i];
}
ans[1] = s;
if (n == 0 && kode == 2)
ans[1] = s + xln;
if (mm != 1) { /* generate higher derivatives, j > n */
tol = wdtol / 5.0;
for(j = 2; j <= mm; j++) {
t = t / x;
s = t;
tols = t * tol;
den = x;
for(i=1 ; i<=nn ; i++) {
den += 1.;
trm[i] /= den;
s += trm[i];
if (trm[i] < tols)
break;
}
ans[j] = s;
}
}
return;
L10: tss = exp(-t);
tt = 0.5 / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0)
t1 = tt + 1.0 / fn;
rxsq = 1.0 / (xdmy * xdmy);
ta = 0.5 * rxsq;
t = (fn + 1) * ta;
s = t * b[3];
if (fabs(s) >= tst) {
tk = 2.0;
for(k = 4; k <= 22; k++) {
t = t * ((tk + fn + 1)/(tk + 1.0))*((tk + fn)/(tk + 2.0)) * rxsq;
trm[k] = t * b[k];
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
/* backward recur from xdmy to x */
nx = (int)xinc;
np = nn + 1;
if (nx > nmax) {
*nz = 0;
*ierr = 3;
return;
}
else {
if (nn==0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
/* this loop should not be changed. fx is accurate when x is small */
for(i = 1; i <= nx; i++) {
trmr[i] = pow(fx, (double)-np);
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
}
ans[mm] = s;
if (fn == 0)
goto L30;
/* generate lower derivatives, j < n+mm-1 */
for(j = 2; j <= mm; j++) {
fn--;
tss *= xdmy;
t1 = tt;
if (fn!=0)
t1 = tt + 1.0 / fn;
t = (fn + 1) * ta;
s = t * b[3];
if (fabs(s) >= tst) {
tk = 4 + fn;
for(k=4 ; k<=22 ; k++) {
trm[k] = trm[k] * (fn + 1) / tk;
if (fabs(trm[k]) < tst)
break;
s += trm[k];
tk += 2.;
}
}
s = (s + t1) * tss;
if (xinc != 0.0) {
if (fn == 0)
goto L20;
xm = xinc - 1.0;
fx = x + xm;
for(i=1 ; i<=nx ; i++) {
trmr[i] = trmr[i] * fx;
s += trmr[i];
xm -= 1.;
fx = x + xm;
}
}
mx = mm - j + 1;
ans[mx] = s;
if (fn == 0)
goto L30;
}
return;
L20:
for(i = 1; i <= nx; i++)
s += 1. / (x + nx - i);
L30:
if (kode!=2)
ans[1] = s - xdmln;
else if (xdmy != x) {
xq = xdmy / x;
ans[1] = s - log(xq);
}
return;
}
