diff options
| author | Eric Andersen <andersen@codepoet.org> | 2001-05-10 00:40:28 +0000 |
|---|---|---|
| committer | Eric Andersen <andersen@codepoet.org> | 2001-05-10 00:40:28 +0000 |
| commit | 1077fa4d772832f77a677ce7fb7c2d513b959e3f (patch) | |
| tree | 579bee13fb0b58d2800206366ec2caecbb15f3fc /libm/ldouble | |
| parent | 22358dd7ce7bb49792204b698f01a6f69b9c8e08 (diff) | |
uClibc now has a math library. muahahahaha!
-Erik
Diffstat (limited to 'libm/ldouble')
69 files changed, 27634 insertions, 0 deletions
diff --git a/libm/ldouble/Makefile b/libm/ldouble/Makefile new file mode 100644 index 000000000..43395a140 --- /dev/null +++ b/libm/ldouble/Makefile @@ -0,0 +1,123 @@ +# Makefile for uClibc's math library +# +# Copyright (C) 2001 by Lineo, inc. +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of the GNU Library 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 Library General Public License for more +# details. +# +# You should have received a copy of the GNU Library General Public License +# along with this program; if not, write to the Free Software Foundation, Inc., +# 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# Derived in part from the Linux-8086 C library, the GNU C Library, and several +# other sundry sources. Files within this library are copyright by their +# respective copyright holders. + +TOPDIR=../../ +include $(TOPDIR)Rules.mak + +LIBM=../libm.a +TARGET_CC= $(TOPDIR)/extra/gcc-uClibc/$(TARGET_ARCH)-uclibc-gcc + +CSRC=acoshl.c asinhl.c asinl.c atanhl.c atanl.c bdtrl.c btdtrl.c cbrtl.c \ + chdtrl.c coshl.c ellpel.c ellpkl.c elliel.c ellikl.c ellpjl.c \ + exp10l.c exp2l.c expl.c fdtrl.c gammal.c gdtrl.c igamil.c igaml.c \ + incbetl.c incbil.c isnanl.c j0l.c j1l.c jnl.c ldrand.c log10l.c log2l.c \ + logl.c nbdtrl.c ndtril.c ndtrl.c pdtrl.c powl.c powil.c sinhl.c sinl.c \ + sqrtl.c stdtrl.c tanhl.c tanl.c unityl.c ynl.c \ + floorl.c polevll.c mtherr.c #cmplxl.c clogl.c +COBJS=$(patsubst %.c,%.o, $(CSRC)) + + +OBJS=$(COBJS) + +all: $(OBJS) $(LIBM) + +$(LIBM): ar-target + +ar-target: $(OBJS) + $(AR) $(ARFLAGS) $(LIBM) $(OBJS) + +$(COBJS): %.o : %.c + $(TARGET_CC) $(CFLAGS) -c $< -o $@ + $(STRIPTOOL) -x -R .note -R .comment $*.o + +$(OBJ): Makefile + +clean: + rm -f *.[oa] *~ core + + + +#----------------------------------------- + + +#all: mtstl lparanoi lcalc fltestl nantst testvect monotl libml.a + +mtstl: libml.a mtstl.o $(OBJS) + $(CC) $(CFLAGS) -o mtstl mtstl.o libml.a $(LIBS) + +mtstl.o: mtstl.c + +lparanoi: libml.a lparanoi.o setprec.o ieee.o econst.o $(OBJS) + $(CC) $(CFLAGS) -o lparanoi lparanoi.o setprec.o ieee.o econst.o libml.a $(LIBS) + +lparanoi.o: lparanoi.c + $(CC) $(CFLAGS) -Wno-implicit -c lparanoi.c + +econst.o: econst.c ehead.h + +lcalc: libml.a lcalc.o ieee.o econst.o $(OBJS) + $(CC) $(CFLAGS) -o lcalc lcalc.o ieee.o econst.o libml.a $(LIBS) + +lcalc.o: lcalc.c lcalc.h ehead.h + +ieee.o: ieee.c ehead.h + +# Use $(OBJS) in ar command for libml.a if possible; else *.o +libml.a: $(OBJS) mconf.h + ar -rv libml.a $(OBJS) + ranlib libml.a + + +fltestl: fltestl.c libml.a + $(CC) $(CFLAGS) -o fltestl fltestl.c libml.a + +fltestl.o: fltestl.c + +flrtstl: flrtstl.c libml.a + $(CC) $(CFLAGS) -o flrtstl flrtstl.c libml.a + +flrtstl.o: flrtstl.c + +nantst: nantst.c libml.a + $(CC) $(CFLAGS) -o nantst nantst.c libml.a + +nantst.o: nantst.c + +testvect: testvect.o libml.a + $(CC) $(CFLAGS) -o testvect testvect.o libml.a + +testvect.o: testvect.c + $(CC) -g -c -o testvect.o testvect.c + +monotl: monotl.o libml.a + $(CC) $(CFLAGS) -o monotl monotl.o libml.a + +monotl.o: monotl.c + $(CC) -g -c -o monotl.o monotl.c + +# Run test programs +check: mtstl fltestl testvect monotl libml.a + -mtstl + -fltestl + -testvect + -monotl + diff --git a/libm/ldouble/README.txt b/libm/ldouble/README.txt new file mode 100644 index 000000000..30fcaad36 --- /dev/null +++ b/libm/ldouble/README.txt @@ -0,0 +1,3502 @@ +/* acoshl.c + * + * Inverse hyperbolic cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, acoshl(); + * + * y = acoshl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a rational approximation + * + * sqrt(2z) * P(z)/Q(z) + * + * where z = x-1, is used. Otherwise, + * + * acosh(x) = log( x + sqrt( (x-1)(x+1) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,3 30000 2.0e-19 3.9e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acoshl domain |x| < 1 0.0 + * + */ + +/* asinhl.c + * + * Inverse hyperbolic sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, asinhl(); + * + * y = asinhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic sine of argument. + * + * If |x| < 0.5, the function is approximated by a rational + * form x + x**3 P(x)/Q(x). Otherwise, + * + * asinh(x) = log( x + sqrt(1 + x*x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -3,3 30000 1.7e-19 3.5e-20 + * + */ + +/* asinl.c + * + * Inverse circular sine, long double precision + * + * + * + * SYNOPSIS: + * + * double x, y, asinl(); + * + * y = asinl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose sine is x. + * + * A rational function of the form x + x**3 P(x**2)/Q(x**2) + * is used for |x| in the interval [0, 0.5]. If |x| > 0.5 it is + * transformed by the identity + * + * asin(x) = pi/2 - 2 asin( sqrt( (1-x)/2 ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1, 1 30000 2.7e-19 4.8e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 0.0 + * + */ + /* acosl() + * + * Inverse circular cosine, long double precision + * + * + * + * SYNOPSIS: + * + * double x, y, acosl(); + * + * y = acosl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose cosine + * is x. + * + * Analytically, acos(x) = pi/2 - asin(x). However if |x| is + * near 1, there is cancellation error in subtracting asin(x) + * from pi/2. Hence if x < -0.5, + * + * acos(x) = pi - 2.0 * asin( sqrt((1+x)/2) ); + * + * or if x > +0.5, + * + * acos(x) = 2.0 * asin( sqrt((1-x)/2) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1, 1 30000 1.4e-19 3.5e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 0.0 + */ + +/* atanhl.c + * + * Inverse hyperbolic tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, atanhl(); + * + * y = atanhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOGL to MAXLOGL. + * + * If |x| < 0.5, the rational form x + x**3 P(x)/Q(x) is + * employed. Otherwise, + * atanh(x) = 0.5 * log( (1+x)/(1-x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1,1 30000 1.1e-19 3.3e-20 + * + */ + +/* atanl.c + * + * Inverse circular tangent, long double precision + * (arctangent) + * + * + * + * SYNOPSIS: + * + * long double x, y, atanl(); + * + * y = atanl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose tangent + * is x. + * + * Range reduction is from four intervals into the interval + * from zero to tan( pi/8 ). The approximant uses a rational + * function of degree 3/4 of the form x + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 150000 1.3e-19 3.0e-20 + * + */ + /* atan2l() + * + * Quadrant correct inverse circular tangent, + * long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, z, atan2l(); + * + * z = atan2l( y, x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle whose tangent is y/x. + * Define compile time symbol ANSIC = 1 for ANSI standard, + * range -PI < z <= +PI, args (y,x); else ANSIC = 0 for range + * 0 to 2PI, args (x,y). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 60000 1.7e-19 3.2e-20 + * See atan.c. + * + */ + +/* bdtrl.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtrl(); + * + * y = bdtrl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms 0 through k of the Binomial + * probability density: + * + * k + * -- ( n ) j n-j + * > ( ) p (1-p) + * -- ( j ) + * j=0 + * + * The terms are not summed directly; instead the incomplete + * beta integral is employed, according to the formula + * + * y = bdtr( k, n, p ) = incbet( n-k, k+1, 1-p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * Tested at random points (k,n,p) with a and b between 0 + * and 10000 and p between 0 and 1. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10000 3000 1.6e-14 2.2e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrl domain k < 0 0.0 + * n < k + * x < 0, x > 1 + * + */ + /* bdtrcl() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtrcl(); + * + * y = bdtrcl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 through n of the Binomial + * probability density: + * + * n + * -- ( n ) j n-j + * > ( ) p (1-p) + * -- ( j ) + * j=k+1 + * + * The terms are not summed directly; instead the incomplete + * beta integral is employed, according to the formula + * + * y = bdtrc( k, n, p ) = incbet( k+1, n-k, p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * See incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrcl domain x<0, x>1, n<k 0.0 + */ + /* bdtril() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtril(); + * + * p = bdtril( k, n, y ); + * + * + * + * DESCRIPTION: + * + * Finds the event probability p such that the sum of the + * terms 0 through k of the Binomial probability density + * is equal to the given cumulative probability y. + * + * This is accomplished using the inverse beta integral + * function and the relation + * + * 1 - p = incbi( n-k, k+1, y ). + * + * ACCURACY: + * + * See incbi.c. + * Tested at random k, n between 1 and 10000. The "domain" refers to p: + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 3500 2.0e-15 8.2e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtril domain k < 0, n <= k 0.0 + * x < 0, x > 1 + */ + + +/* btdtrl.c + * + * Beta distribution + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, btdtrl(); + * + * y = btdtrl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from zero to x under the beta density + * function: + * + * + * x + * - - + * | (a+b) | | a-1 b-1 + * P(x) = ---------- | t (1-t) dt + * - - | | + * | (a) | (b) - + * 0 + * + * + * The mean value of this distribution is a/(a+b). The variance + * is ab/[(a+b)^2 (a+b+1)]. + * + * This function is identical to the incomplete beta integral + * function, incbetl(a, b, x). + * + * The complemented function is + * + * 1 - P(1-x) = incbetl( b, a, x ); + * + * + * ACCURACY: + * + * See incbetl.c. + * + */ + +/* cbrtl.c + * + * Cube root, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cbrtl(); + * + * y = cbrtl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the cube root of the argument, which may be negative. + * + * Range reduction involves determining the power of 2 of + * the argument. A polynomial of degree 2 applied to the + * mantissa, and multiplication by the cube root of 1, 2, or 4 + * approximates the root to within about 0.1%. Then Newton's + * iteration is used three times to converge to an accurate + * result. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE .125,8 80000 7.0e-20 2.2e-20 + * IEEE exp(+-707) 100000 7.0e-20 2.4e-20 + * + */ + +/* chdtrl.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double df, x, y, chdtrl(); + * + * y = chdtrl( df, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area under the left hand tail (from 0 to x) + * of the Chi square probability density function with + * v degrees of freedom. + * + * + * inf. + * - + * 1 | | v/2-1 -t/2 + * P( x | v ) = ----------- | t e dt + * v/2 - | | + * 2 | (v/2) - + * x + * + * where x is the Chi-square variable. + * + * The incomplete gamma integral is used, according to the + * formula + * + * y = chdtr( v, x ) = igam( v/2.0, x/2.0 ). + * + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igam(). + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtr domain x < 0 or v < 1 0.0 + */ + /* chdtrcl() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double v, x, y, chdtrcl(); + * + * y = chdtrcl( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area under the right hand tail (from x to + * infinity) of the Chi square probability density function + * with v degrees of freedom: + * + * + * inf. + * - + * 1 | | v/2-1 -t/2 + * P( x | v ) = ----------- | t e dt + * v/2 - | | + * 2 | (v/2) - + * x + * + * where x is the Chi-square variable. + * + * The incomplete gamma integral is used, according to the + * formula + * + * y = chdtr( v, x ) = igamc( v/2.0, x/2.0 ). + * + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igamc(). + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrc domain x < 0 or v < 1 0.0 + */ + /* chdtril() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double df, x, y, chdtril(); + * + * x = chdtril( df, y ); + * + * + * + * + * DESCRIPTION: + * + * Finds the Chi-square argument x such that the integral + * from x to infinity of the Chi-square density is equal + * to the given cumulative probability y. + * + * This is accomplished using the inverse gamma integral + * function and the relation + * + * x/2 = igami( df/2, y ); + * + * + * + * + * ACCURACY: + * + * See igami.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtri domain y < 0 or y > 1 0.0 + * v < 1 + * + */ + +/* clogl.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clogl(); + * cmplxl z, w; + * + * clogl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Returns complex logarithm to the base e (2.718...) of + * the complex argument x. + * + * If z = x + iy, r = sqrt( x**2 + y**2 ), + * then + * w = log(r) + i arctan(y/x). + * + * The arctangent ranges from -PI to +PI. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 7000 8.5e-17 1.9e-17 + * IEEE -10,+10 30000 5.0e-15 1.1e-16 + * + * Larger relative error can be observed for z near 1 +i0. + * In IEEE arithmetic the peak absolute error is 5.2e-16, rms + * absolute error 1.0e-16. + */ + + /* cexpl() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexpl(); + * cmplxl z, w; + * + * cexpl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Returns the exponential of the complex argument z + * into the complex result w. + * + * If + * z = x + iy, + * r = exp(x), + * + * then + * + * w = r cos y + i r sin y. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8700 3.7e-17 1.1e-17 + * IEEE -10,+10 30000 3.0e-16 8.7e-17 + * + */ + /* csinl() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csinl(); + * cmplxl z, w; + * + * csinl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * w = sin x cosh y + i cos x sinh y. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8400 5.3e-17 1.3e-17 + * IEEE -10,+10 30000 3.8e-16 1.0e-16 + * Also tested by csin(casin(z)) = z. + * + */ + /* ccosl() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccosl(); + * cmplxl z, w; + * + * ccosl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * w = cos x cosh y - i sin x sinh y. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8400 4.5e-17 1.3e-17 + * IEEE -10,+10 30000 3.8e-16 1.0e-16 + */ + /* ctanl() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctanl(); + * cmplxl z, w; + * + * ctanl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * sin 2x + i sinh 2y + * w = --------------------. + * cos 2x + cosh 2y + * + * On the real axis the denominator is zero at odd multiples + * of PI/2. The denominator is evaluated by its Taylor + * series near these points. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5200 7.1e-17 1.6e-17 + * IEEE -10,+10 30000 7.2e-16 1.2e-16 + * Also tested by ctan * ccot = 1 and catan(ctan(z)) = z. + */ + /* ccotl() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccotl(); + * cmplxl z, w; + * + * ccotl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * sin 2x - i sinh 2y + * w = --------------------. + * cosh 2y - cos 2x + * + * On the real axis, the denominator has zeros at even + * multiples of PI/2. Near these points it is evaluated + * by a Taylor series. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 3000 6.5e-17 1.6e-17 + * IEEE -10,+10 30000 9.2e-16 1.2e-16 + * Also tested by ctan * ccot = 1 + i0. + */ + + /* casinl() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casinl(); + * cmplxl z, w; + * + * casinl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Inverse complex sine: + * + * 2 + * w = -i clog( iz + csqrt( 1 - z ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 10100 2.1e-15 3.4e-16 + * IEEE -10,+10 30000 2.2e-14 2.7e-15 + * Larger relative error can be observed for z near zero. + * Also tested by csin(casin(z)) = z. + */ + /* cacosl() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacosl(); + * cmplxl z, w; + * + * cacosl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * w = arccos z = PI/2 - arcsin z. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5200 1.6e-15 2.8e-16 + * IEEE -10,+10 30000 1.8e-14 2.2e-15 + */ + + /* catanl() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catanl(); + * cmplxl z, w; + * + * catanl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * 1 ( 2x ) + * Re w = - arctan(-----------) + k PI + * 2 ( 2 2) + * (1 - x - y ) + * + * ( 2 2) + * 1 (x + (y+1) ) + * Im w = - log(------------) + * 4 ( 2 2) + * (x + (y-1) ) + * + * Where k is an arbitrary integer. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5900 1.3e-16 7.8e-18 + * IEEE -10,+10 30000 2.3e-15 8.5e-17 + * The check catan( ctan(z) ) = z, with |x| and |y| < PI/2, + * had peak relative error 1.5e-16, rms relative error + * 2.9e-17. See also clog(). + */ + +/* cmplxl.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * long double r; real part + * long double i; imaginary part + * }cmplxl; + * + * cmplxl *a, *b, *c; + * + * caddl( a, b, c ); c = b + a + * csubl( a, b, c ); c = b - a + * cmull( a, b, c ); c = b * a + * cdivl( a, b, c ); c = b / a + * cnegl( c ); c = -c + * cmovl( b, c ); c = b + * + * + * + * DESCRIPTION: + * + * Addition: + * c.r = b.r + a.r + * c.i = b.i + a.i + * + * Subtraction: + * c.r = b.r - a.r + * c.i = b.i - a.i + * + * Multiplication: + * c.r = b.r * a.r - b.i * a.i + * c.i = b.r * a.i + b.i * a.r + * + * Division: + * d = a.r * a.r + a.i * a.i + * c.r = (b.r * a.r + b.i * a.i)/d + * c.i = (b.i * a.r - b.r * a.i)/d + * ACCURACY: + * + * In DEC arithmetic, the test (1/z) * z = 1 had peak relative + * error 3.1e-17, rms 1.2e-17. The test (y/z) * (z/y) = 1 had + * peak relative error 8.3e-17, rms 2.1e-17. + * + * Tests in the rectangle {-10,+10}: + * Relative error: + * arithmetic function # trials peak rms + * DEC cadd 10000 1.4e-17 3.4e-18 + * IEEE cadd 100000 1.1e-16 2.7e-17 + * DEC csub 10000 1.4e-17 4.5e-18 + * IEEE csub 100000 1.1e-16 3.4e-17 + * DEC cmul 3000 2.3e-17 8.7e-18 + * IEEE cmul 100000 2.1e-16 6.9e-17 + * DEC cdiv 18000 4.9e-17 1.3e-17 + * IEEE cdiv 100000 3.7e-16 1.1e-16 + */ + +/* cabsl() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * long double cabsl(); + * cmplxl z; + * long double a; + * + * a = cabs( &z ); + * + * + * + * DESCRIPTION: + * + * + * If z = x + iy + * + * then + * + * a = sqrt( x**2 + y**2 ). + * + * Overflow and underflow are avoided by testing the magnitudes + * of x and y before squaring. If either is outside half of + * the floating point full scale range, both are rescaled. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -30,+30 30000 3.2e-17 9.2e-18 + * IEEE -10,+10 100000 2.7e-16 6.9e-17 + */ + /* csqrtl() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrtl(); + * cmplxl z, w; + * + * csqrtl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * If z = x + iy, r = |z|, then + * + * 1/2 + * Im w = [ (r - x)/2 ] , + * + * Re w = y / 2 Im w. + * + * + * Note that -w is also a square root of z. The root chosen + * is always in the upper half plane. + * + * Because of the potential for cancellation error in r - x, + * the result is sharpened by doing a Heron iteration + * (see sqrt.c) in complex arithmetic. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 25000 3.2e-17 9.6e-18 + * IEEE -10,+10 100000 3.2e-16 7.7e-17 + * + * 2 + * Also tested by csqrt( z ) = z, and tested by arguments + * close to the real axis. + */ + +/* coshl.c + * + * Hyperbolic cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, coshl(); + * + * y = coshl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOGL to + * MAXLOGL. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-10000 30000 1.1e-19 2.8e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cosh overflow |x| > MAXLOGL MAXNUML + * + * + */ + +/* elliel.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * long double phi, m, y, elliel(); + * + * y = elliel( phi, m ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * phi + * - + * | | + * | 2 + * E(phi_\m) = | sqrt( 1 - m sin t ) dt + * | + * | | + * - + * 0 + * + * of amplitude phi and modulus m, using the arithmetic - + * geometric mean algorithm. + * + * + * + * ACCURACY: + * + * Tested at random arguments with phi in [-10, 10] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 50000 2.7e-18 2.3e-19 + * + * + */ + +/* ellikl.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * long double phi, m, y, ellikl(); + * + * y = ellikl( phi, m ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * + * phi + * - + * | | + * | dt + * F(phi_\m) = | ------------------ + * | 2 + * | | sqrt( 1 - m sin t ) + * - + * 0 + * + * of amplitude phi and modulus m, using the arithmetic - + * geometric mean algorithm. + * + * + * + * + * ACCURACY: + * + * Tested at random points with m in [0, 1] and phi as indicated. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 30000 3.6e-18 4.1e-19 + * + * + */ + +/* ellpel.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * long double m1, y, ellpel(); + * + * y = ellpel( m1 ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * pi/2 + * - + * | | 2 + * E(m) = | sqrt( 1 - m sin t ) dt + * | | + * - + * 0 + * + * Where m = 1 - m1, using the approximation + * + * P(x) - x log x Q(x). + * + * Though there are no singularities, the argument m1 is used + * rather than m for compatibility with ellpk(). + * + * E(1) = 1; E(0) = pi/2. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 1 10000 1.1e-19 3.5e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpel domain x<0, x>1 0.0 + * + */ + +/* ellpjl.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * long double u, m, sn, cn, dn, phi; + * int ellpjl(); + * + * ellpjl( u, m, _&sn, _&cn, _&dn, _&phi ); + * + * + * + * DESCRIPTION: + * + * + * Evaluates the Jacobian elliptic functions sn(u|m), cn(u|m), + * and dn(u|m) of parameter m between 0 and 1, and real + * argument u. + * + * These functions are periodic, with quarter-period on the + * real axis equal to the complete elliptic integral + * ellpk(1.0-m). + * + * Relation to incomplete elliptic integral: + * If u = ellik(phi,m), then sn(u|m) = sin(phi), + * and cn(u|m) = cos(phi). Phi is called the amplitude of u. + * + * Computation is by means of the arithmetic-geometric mean + * algorithm, except when m is within 1e-12 of 0 or 1. In the + * latter case with m close to 1, the approximation applies + * only for phi < pi/2. + * + * ACCURACY: + * + * Tested at random points with u between 0 and 10, m between + * 0 and 1. + * + * Absolute error (* = relative error): + * arithmetic function # trials peak rms + * IEEE sn 10000 1.7e-18 2.3e-19 + * IEEE cn 20000 1.6e-18 2.2e-19 + * IEEE dn 10000 4.7e-15 2.7e-17 + * IEEE phi 10000 4.0e-19* 6.6e-20* + * + * Accuracy deteriorates when u is large. + * + */ + +/* ellpkl.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * long double m1, y, ellpkl(); + * + * y = ellpkl( m1 ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * + * pi/2 + * - + * | | + * | dt + * K(m) = | ------------------ + * | 2 + * | | sqrt( 1 - m sin t ) + * - + * 0 + * + * where m = 1 - m1, using the approximation + * + * P(x) - log x Q(x). + * + * The argument m1 is used rather than m so that the logarithmic + * singularity at m = 1 will be shifted to the origin; this + * preserves maximum accuracy. + * + * K(0) = pi/2. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 10000 1.1e-19 3.3e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpkl domain x<0, x>1 0.0 + * + */ + +/* exp10l.c + * + * Base 10 exponential function, long double precision + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * long double x, y, exp10l() + * + * y = exp10l( x ); + * + * + * + * DESCRIPTION: + * + * Returns 10 raised to the x power. + * + * Range reduction is accomplished by expressing the argument + * as 10**x = 2**n 10**f, with |f| < 0.5 log10(2). + * The Pade' form + * + * 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + * + * is used to approximate 10**f. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4900 30000 1.0e-19 2.7e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10l underflow x < -MAXL10 0.0 + * exp10l overflow x > MAXL10 MAXNUM + * + * IEEE arithmetic: MAXL10 = 4932.0754489586679023819 + * + */ + +/* exp2l.c + * + * Base 2 exponential function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, exp2l(); + * + * y = exp2l( x ); + * + * + * + * DESCRIPTION: + * + * Returns 2 raised to the x power. + * + * Range reduction is accomplished by separating the argument + * into an integer k and fraction f such that + * x k f + * 2 = 2 2. + * + * A Pade' form + * + * 1 + 2x P(x**2) / (Q(x**2) - x P(x**2) ) + * + * approximates 2**x in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-16300 300000 9.1e-20 2.6e-20 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp2l underflow x < -16382 0.0 + * exp2l overflow x >= 16384 MAXNUM + * + */ + +/* expl.c + * + * Exponential function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, expl(); + * + * y = expl( x ); + * + * + * + * DESCRIPTION: + * + * Returns e (2.71828...) raised to the x power. + * + * Range reduction is accomplished by separating the argument + * into an integer k and fraction f such that + * + * x k f + * e = 2 e. + * + * A Pade' form of degree 2/3 is used to approximate exp(f) - 1 + * in the basic range [-0.5 ln 2, 0.5 ln 2]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-10000 50000 1.12e-19 2.81e-20 + * + * + * Error amplification in the exponential function can be + * a serious matter. The error propagation involves + * exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), + * which shows that a 1 lsb error in representing X produces + * a relative error of X times 1 lsb in the function. + * While the routine gives an accurate result for arguments + * that are exactly represented by a long double precision + * computer number, the result contains amplified roundoff + * error for large arguments not exactly represented. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < MINLOG 0.0 + * exp overflow x > MAXLOG MAXNUM + * + */ + +/* fabsl.c + * + * Absolute value + * + * + * + * SYNOPSIS: + * + * long double x, y; + * + * y = fabsl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the absolute value of the argument. + * + */ + +/* fdtrl.c + * + * F distribution, long double precision + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, y, fdtrl(); + * + * y = fdtrl( df1, df2, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from zero to x under the F density + * function (also known as Snedcor's density or the + * variance ratio density). This is the density + * of x = (u1/df1)/(u2/df2), where u1 and u2 are random + * variables having Chi square distributions with df1 + * and df2 degrees of freedom, respectively. + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbetl( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x + * x is nonnegative. + * + * ACCURACY: + * + * Tested at random points (a,b,x) in the indicated intervals. + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 1,100 10000 9.3e-18 2.9e-19 + * IEEE 0,1 1,10000 10000 1.9e-14 2.9e-15 + * IEEE 1,5 1,10000 10000 5.8e-15 1.4e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrl domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrcl() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, y, fdtrcl(); + * + * y = fdtrcl( df1, df2, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from x to infinity under the F density + * function (also known as Snedcor's density or the + * variance ratio density). + * + * + * inf. + * - + * 1 | | a-1 b-1 + * 1-P(x) = ------ | t (1-t) dt + * B(a,b) | | + * - + * x + * + * (See fdtr.c.) + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). + * + * + * ACCURACY: + * + * See incbet.c. + * Tested at random points (a,b,x). + * + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 0,100 10000 4.2e-18 3.3e-19 + * IEEE 0,1 1,10000 10000 7.2e-15 2.6e-16 + * IEEE 1,5 1,10000 10000 1.7e-14 3.0e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrcl domain a<0, b<0, x<0 0.0 + * + */ + /* fdtril() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, p, fdtril(); + * + * x = fdtril( df1, df2, p ); + * + * DESCRIPTION: + * + * Finds the F density argument x such that the integral + * from x to infinity of the F density is equal to the + * given probability p. + * + * This is accomplished using the inverse beta integral + * function and the relations + * + * z = incbi( df2/2, df1/2, p ) + * x = df2 (1-z) / (df1 z). + * + * Note: the following relations hold for the inverse of + * the uncomplemented F distribution: + * + * z = incbi( df1/2, df2/2, p ) + * x = df2 z / (df1 (1-z)). + * + * ACCURACY: + * + * See incbi.c. + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between .001 and 1: + * IEEE 1,100 40000 4.6e-18 2.7e-19 + * IEEE 1,10000 30000 1.7e-14 1.4e-16 + * For p between 10^-6 and .001: + * IEEE 1,100 20000 1.9e-15 3.9e-17 + * IEEE 1,10000 30000 2.7e-15 4.0e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtril domain p <= 0 or p > 1 0.0 + * v < 1 + */ + +/* ceill() + * floorl() + * frexpl() + * ldexpl() + * fabsl() + * + * Floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * long double x, y; + * long double ceill(), floorl(), frexpl(), ldexpl(), fabsl(); + * int expnt, n; + * + * y = floorl(x); + * y = ceill(x); + * y = frexpl( x, &expnt ); + * y = ldexpl( x, n ); + * y = fabsl( x ); + * + * + * + * DESCRIPTION: + * + * All four routines return a long double precision floating point + * result. + * + * floorl() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * ceill() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * frexpl() extracts the exponent from x. It returns an integer + * power of two to expnt and the significand between 0.5 and 1 + * to y. Thus x = y * 2**expn. + * + * ldexpl() multiplies x by 2**n. + * + * fabsl() returns the absolute value of its argument. + * + * These functions are part of the standard C run time library + * for some but not all C compilers. The ones supplied are + * written in C for IEEE arithmetic. They should + * be used only if your compiler library does not already have + * them. + * + * The IEEE versions assume that denormal numbers are implemented + * in the arithmetic. Some modifications will be required if + * the arithmetic has abrupt rather than gradual underflow. + */ + +/* gammal.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * long double x, y, gammal(); + * extern int sgngam; + * + * y = gammal( x ); + * + * + * + * DESCRIPTION: + * + * Returns gamma function of the argument. The result is + * correctly signed, and the sign (+1 or -1) is also + * returned in a global (extern) variable named sgngam. + * This variable is also filled in by the logarithmic gamma + * function lgam(). + * + * Arguments |x| <= 13 are reduced by recurrence and the function + * approximated by a rational function of degree 7/8 in the + * interval (2,3). Large arguments are handled by Stirling's + * formula. Large negative arguments are made positive using + * a reflection formula. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -40,+40 10000 3.6e-19 7.9e-20 + * IEEE -1755,+1755 10000 4.8e-18 6.5e-19 + * + * Accuracy for large arguments is dominated by error in powl(). + * + */ +/* lgaml() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * long double x, y, lgaml(); + * extern int sgngam; + * + * y = lgaml( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base e (2.718...) logarithm of the absolute + * value of the gamma function of the argument. + * The sign (+1 or -1) of the gamma function is returned in a + * global (extern) variable named sgngam. + * + * For arguments greater than 33, the logarithm of the gamma + * function is approximated by the logarithmic version of + * Stirling's formula using a polynomial approximation of + * degree 4. Arguments between -33 and +33 are reduced by + * recurrence to the interval [2,3] of a rational approximation. + * The cosecant reflection formula is employed for arguments + * less than -33. + * + * Arguments greater than MAXLGML (10^4928) return MAXNUML. + * + * + * + * ACCURACY: + * + * + * arithmetic domain # trials peak rms + * IEEE -40, 40 100000 2.2e-19 4.6e-20 + * IEEE 10^-2000,10^+2000 20000 1.6e-19 3.3e-20 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * + */ + +/* gdtrl.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, gdtrl(); + * + * y = gdtrl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the integral from zero to x of the gamma probability + * density function: + * + * + * x + * b - + * a | | b-1 -at + * y = ----- | t e dt + * - | | + * | (b) - + * 0 + * + * The incomplete gamma integral is used, according to the + * relation + * + * y = igam( b, ax ). + * + * + * ACCURACY: + * + * See igam(). + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrl domain x < 0 0.0 + * + */ + /* gdtrcl.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, gdtrcl(); + * + * y = gdtrcl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the integral from x to infinity of the gamma + * probability density function: + * + * + * inf. + * b - + * a | | b-1 -at + * y = ----- | t e dt + * - | | + * | (b) - + * x + * + * The incomplete gamma integral is used, according to the + * relation + * + * y = igamc( b, ax ). + * + * + * ACCURACY: + * + * See igamc(). + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrcl domain x < 0 0.0 + * + */ + +/* +C +C .................................................................. +C +C SUBROUTINE GELS +C +C PURPOSE +C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH +C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH +C IS ASSUMED TO BE STORED COLUMNWISE. +C +C USAGE +C CALL GELS(R,A,M,N,EPS,IER,AUX) +C +C DESCRIPTION OF PARAMETERS +C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) +C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. +C A - UPPER TRIANGULAR PART OF THE SYMMETRIC +C M BY M COEFFICIENT MATRIX. (DESTROYED) +C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. +C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. +C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE +C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. +C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS +C IER=0 - NO ERROR, +C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR +C PIVOT ELEMENT AT ANY ELIMINATION STEP +C EQUAL TO 0, +C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- +C CANCE INDICATED AT ELIMINATION STEP K+1, +C WHERE PIVOT ELEMENT WAS LESS THAN OR +C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES +C ABSOLUTELY GREATEST MAIN DIAGONAL +C ELEMENT OF MATRIX A. +C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. +C +C REMARKS +C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED +C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT +C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE +C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE +C TOO. +C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS +C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS +C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - +C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL +C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE +C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS +C GIVEN IN CASE M=1. +C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT +C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS +C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH +C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C +C METHOD +C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH +C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE +C SYMMETRY IN REMAINING COEFFICIENT MATRICES. +C +C .................................................................. +C +*/ + +/* igamil() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igamil(); + * + * x = igamil( a, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * igamc( a, x ) = y. + * + * Starting with the approximate value + * + * 3 + * x = a t + * + * where + * + * t = 1 - d - ndtri(y) sqrt(d) + * + * and + * + * d = 1/9a, + * + * the routine performs up to 10 Newton iterations to find the + * root of igamc(a,x) - y = 0. + * + * + * ACCURACY: + * + * Tested for a ranging from 0.5 to 30 and x from 0 to 0.5. + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,0.5 3400 8.8e-16 1.3e-16 + * IEEE 0,0.5 10000 1.1e-14 1.0e-15 + * + */ + +/* igaml.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igaml(); + * + * y = igaml( a, x ); + * + * + * + * DESCRIPTION: + * + * The function is defined by + * + * x + * - + * 1 | | -t a-1 + * igam(a,x) = ----- | e t dt. + * - | | + * | (a) - + * 0 + * + * + * In this implementation both arguments must be positive. + * The integral is evaluated by either a power series or + * continued fraction expansion, depending on the relative + * values of a and x. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 4000 4.4e-15 6.3e-16 + * IEEE 0,30 10000 3.6e-14 5.1e-15 + * + */ + /* igamcl() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igamcl(); + * + * y = igamcl( a, x ); + * + * + * + * DESCRIPTION: + * + * The function is defined by + * + * + * igamc(a,x) = 1 - igam(a,x) + * + * inf. + * - + * 1 | | -t a-1 + * = ----- | e t dt. + * - | | + * | (a) - + * x + * + * + * In this implementation both arguments must be positive. + * The integral is evaluated by either a power series or + * continued fraction expansion, depending on the relative + * values of a and x. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 2.7e-15 4.0e-16 + * IEEE 0,30 60000 1.4e-12 6.3e-15 + * + */ + +/* incbetl.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * long double a, b, x, y, incbetl(); + * + * y = incbetl( a, b, x ); + * + * + * DESCRIPTION: + * + * Returns incomplete beta integral of the arguments, evaluated + * from zero to x. The function is defined as + * + * x + * - - + * | (a+b) | | a-1 b-1 + * ----------- | t (1-t) dt. + * - - | | + * | (a) | (b) - + * 0 + * + * The domain of definition is 0 <= x <= 1. In this + * implementation a and b are restricted to positive values. + * The integral from x to 1 may be obtained by the symmetry + * relation + * + * 1 - incbet( a, b, x ) = incbet( b, a, 1-x ). + * + * The integral is evaluated by a continued fraction expansion + * or, when b*x is small, by a power series. + * + * ACCURACY: + * + * Tested at random points (a,b,x) with x between 0 and 1. + * arithmetic domain # trials peak rms + * IEEE 0,5 20000 4.5e-18 2.4e-19 + * IEEE 0,100 100000 3.9e-17 1.0e-17 + * Half-integer a, b: + * IEEE .5,10000 100000 3.9e-14 4.4e-15 + * Outputs smaller than the IEEE gradual underflow threshold + * were excluded from these statistics. + * + * ERROR MESSAGES: + * + * message condition value returned + * incbetl domain x<0, x>1 0.0 + */ + +/* incbil() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, incbil(); + * + * x = incbil( a, b, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * incbet( a, b, x ) = y. + * + * the routine performs up to 10 Newton iterations to find the + * root of incbet(a,b,x) - y = 0. + * + * + * ACCURACY: + * + * Relative error: + * x a,b + * arithmetic domain domain # trials peak rms + * IEEE 0,1 .5,10000 10000 1.1e-14 1.4e-16 + */ + +/* j0l.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * long double x, y, j0l(); + * + * y = j0l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of first kind, order zero of the argument. + * + * The domain is divided into the intervals [0, 9] and + * (9, infinity). In the first interval the rational approximation + * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) P7(x^2) / Q8(x^2), + * where r, s, t are the first three zeros of the function. + * In the second interval the expansion is in terms of the + * modulus M0(x) = sqrt(J0(x)^2 + Y0(x)^2) and phase P0(x) + * = atan(Y0(x)/J0(x)). M0 is approximated by sqrt(1/x)P7(1/x)/Q7(1/x). + * The approximation to J0 is M0 * cos(x - pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 2.8e-19 7.4e-20 + * + * + */ + /* y0l.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y0l(); + * + * y = y0l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 5>, [5,9> and + * [9, infinity). In the first interval a rational approximation + * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). + * + * In the second interval, the approximation is + * (x - p)(x - q)(x - r)(x - s)P7(x)/Q7(x) + * where p, q, r, s are zeros of y0(x). + * + * The third interval uses the same approximations to modulus + * and phase as j0(x), whence y0(x) = modulus * sin(phase). + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 3.4e-19 7.6e-20 + * + */ + +/* j1l.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * long double x, y, j1l(); + * + * y = j1l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 9] and + * (9, infinity). In the first interval the rational approximation + * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) x P8(x^2) / Q8(x^2), + * where r, s, t are the first three zeros of the function. + * In the second interval the expansion is in terms of the + * modulus M1(x) = sqrt(J1(x)^2 + Y1(x)^2) and phase P1(x) + * = atan(Y1(x)/J1(x)). M1 is approximated by sqrt(1/x)P7(1/x)/Q8(1/x). + * The approximation to j1 is M1 * cos(x - 3 pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 40000 1.8e-19 5.0e-20 + * + * + */ + /* y1l.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y1l(); + * + * y = y1l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 4.5>, [4.5,9> and + * [9, infinity). In the first interval a rational approximation + * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). + * + * In the second interval, the approximation is + * (x - p)(x - q)(x - r)(x - s)P9(x)/Q10(x) + * where p, q, r, s are zeros of y1(x). + * + * The third interval uses the same approximations to modulus + * and phase as j1(x), whence y1(x) = modulus * sin(phase). + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 36000 2.7e-19 5.3e-20 + * + */ + +/* jnl.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * long double x, y, jnl(); + * + * y = jnl( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order n, where n is a + * (possibly negative) integer. + * + * The ratio of jn(x) to j0(x) is computed by backward + * recurrence. First the ratio jn/jn-1 is found by a + * continued fraction expansion. Then the recurrence + * relating successive orders is applied until j0 or j1 is + * reached. + * + * If n = 0 or 1 the routine for j0 or j1 is called + * directly. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE -30, 30 5000 3.3e-19 4.7e-20 + * + * + * Not suitable for large n or x. + * + */ + +/* ldrand.c + * + * Pseudorandom number generator + * + * + * + * SYNOPSIS: + * + * double y; + * int ldrand(); + * + * ldrand( &y ); + * + * + * + * DESCRIPTION: + * + * Yields a random number 1.0 <= y < 2.0. + * + * The three-generator congruential algorithm by Brian + * Wichmann and David Hill (BYTE magazine, March, 1987, + * pp 127-8) is used. + * + * Versions invoked by the different arithmetic compile + * time options IBMPC, and MIEEE, produce the same sequences. + * + */ + +/* log10l.c + * + * Common logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, log10l(); + * + * y = log10l( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base 10 logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the logarithm + * of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 9.0e-20 2.6e-20 + * IEEE exp(+-10000) 30000 6.0e-20 2.3e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOG + * log domain: x < 0; returns MINLOG + */ + +/* log2l.c + * + * Base 2 logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, log2l(); + * + * y = log2l( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base 2 logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the (natural) + * logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 9.8e-20 2.7e-20 + * IEEE exp(+-10000) 70000 5.4e-20 2.3e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOG + * log domain: x < 0; returns MINLOG + */ + +/* logl.c + * + * Natural logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, logl(); + * + * y = logl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base e (2.718...) logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the logarithm + * of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 150000 8.71e-20 2.75e-20 + * IEEE exp(+-10000) 100000 5.39e-20 2.34e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOG + * log domain: x < 0; returns MINLOG + */ + +/* mtherr.c + * + * Library common error handling routine + * + * + * + * SYNOPSIS: + * + * char *fctnam; + * int code; + * int mtherr(); + * + * mtherr( fctnam, code ); + * + * + * + * DESCRIPTION: + * + * This routine may be called to report one of the following + * error conditions (in the include file mconf.h). + * + * Mnemonic Value Significance + * + * DOMAIN 1 argument domain error + * SING 2 function singularity + * OVERFLOW 3 overflow range error + * UNDERFLOW 4 underflow range error + * TLOSS 5 total loss of precision + * PLOSS 6 partial loss of precision + * EDOM 33 Unix domain error code + * ERANGE 34 Unix range error code + * + * The default version of the file prints the function name, + * passed to it by the pointer fctnam, followed by the + * error condition. The display is directed to the standard + * output device. The routine then returns to the calling + * program. Users may wish to modify the program to abort by + * calling exit() under severe error conditions such as domain + * errors. + * + * Since all error conditions pass control to this function, + * the display may be easily changed, eliminated, or directed + * to an error logging device. + * + * SEE ALSO: + * + * mconf.h + * + */ + +/* nbdtrl.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtrl(); + * + * y = nbdtrl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms 0 through k of the negative + * binomial distribution: + * + * k + * -- ( n+j-1 ) n j + * > ( ) p (1-p) + * -- ( j ) + * j=0 + * + * In a sequence of Bernoulli trials, this is the probability + * that k or fewer failures precede the nth success. + * + * The terms are not computed individually; instead the incomplete + * beta integral is employed, according to the formula + * + * y = nbdtr( k, n, p ) = incbet( n, k+1, p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * Tested at random points (k,n,p) with k and n between 1 and 10,000 + * and p between 0 and 1. + * + * arithmetic domain # trials peak rms + * Absolute error: + * IEEE 0,10000 10000 9.8e-15 2.1e-16 + * + */ + /* nbdtrcl.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtrcl(); + * + * y = nbdtrcl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 to infinity of the negative + * binomial distribution: + * + * inf + * -- ( n+j-1 ) n j + * > ( ) p (1-p) + * -- ( j ) + * j=k+1 + * + * The terms are not computed individually; instead the incomplete + * beta integral is employed, according to the formula + * + * y = nbdtrc( k, n, p ) = incbet( k+1, n, 1-p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * See incbetl.c. + * + */ + /* nbdtril + * + * Functional inverse of negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtril(); + * + * p = nbdtril( k, n, y ); + * + * + * + * DESCRIPTION: + * + * Finds the argument p such that nbdtr(k,n,p) is equal to y. + * + * ACCURACY: + * + * Tested at random points (a,b,y), with y between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 + * See also incbil.c. + */ + +/* ndtril.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * long double x, y, ndtril(); + * + * x = ndtril( y ); + * + * + * + * DESCRIPTION: + * + * Returns the argument, x, for which the area under the + * Gaussian probability density function (integrated from + * minus infinity to x) is equal to y. + * + * + * For small arguments 0 < y < exp(-2), the program computes + * z = sqrt( -2 log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . + * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , + * where w = y - 0.5 . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * Arguments uniformly distributed: + * IEEE 0, 1 5000 7.8e-19 9.9e-20 + * Arguments exponentially distributed: + * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtril domain x <= 0 -MAXNUML + * ndtril domain x >= 1 MAXNUML + * + */ + +/* ndtril.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * long double x, y, ndtril(); + * + * x = ndtril( y ); + * + * + * + * DESCRIPTION: + * + * Returns the argument, x, for which the area under the + * Gaussian probability density function (integrated from + * minus infinity to x) is equal to y. + * + * + * For small arguments 0 < y < exp(-2), the program computes + * z = sqrt( -2 log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . + * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , + * where w = y - 0.5 . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * Arguments uniformly distributed: + * IEEE 0, 1 5000 7.8e-19 9.9e-20 + * Arguments exponentially distributed: + * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtril domain x <= 0 -MAXNUML + * ndtril domain x >= 1 MAXNUML + * + */ + +/* pdtrl.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrl(); + * + * y = pdtrl( k, m ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the first k terms of the Poisson + * distribution: + * + * k j + * -- -m m + * > e -- + * -- j! + * j=0 + * + * The terms are not summed directly; instead the incomplete + * gamma integral is employed, according to the relation + * + * y = pdtr( k, m ) = igamc( k+1, m ). + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igamc(). + * + */ + /* pdtrcl() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrcl(); + * + * y = pdtrcl( k, m ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 to infinity of the Poisson + * distribution: + * + * inf. j + * -- -m m + * > e -- + * -- j! + * j=k+1 + * + * The terms are not summed directly; instead the incomplete + * gamma integral is employed, according to the formula + * + * y = pdtrc( k, m ) = igam( k+1, m ). + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igam.c. + * + */ + /* pdtril() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrl(); + * + * m = pdtril( k, y ); + * + * + * + * + * DESCRIPTION: + * + * Finds the Poisson variable x such that the integral + * from 0 to x of the Poisson density is equal to the + * given probability y. + * + * This is accomplished using the inverse gamma integral + * function and the relation + * + * m = igami( k+1, y ). + * + * + * + * + * ACCURACY: + * + * See igami.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * pdtri domain y < 0 or y >= 1 0.0 + * k < 0 + * + */ + +/* polevll.c + * p1evll.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * long double x, y, coef[N+1], polevl[]; + * + * y = polevll( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates polynomial of degree N: + * + * 2 N + * y = C + C x + C x +...+ C x + * 0 1 2 N + * + * Coefficients are stored in reverse order: + * + * coef[0] = C , ..., coef[N] = C . + * N 0 + * + * The function p1evll() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevll(). + * + * This module also contains the following globally declared constants: + * MAXNUML = 1.189731495357231765021263853E4932L; + * MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; + * MAXLOGL = 1.1356523406294143949492E4L; + * MINLOGL = -1.1355137111933024058873E4L; + * LOGE2L = 6.9314718055994530941723E-1L; + * LOG2EL = 1.4426950408889634073599E0L; + * PIL = 3.1415926535897932384626L; + * PIO2L = 1.5707963267948966192313L; + * PIO4L = 7.8539816339744830961566E-1L; + * + * SPEED: + * + * In the interest of speed, there are no checks for out + * of bounds arithmetic. This routine is used by most of + * the functions in the library. Depending on available + * equipment features, the user may wish to rewrite the + * program in microcode or assembly language. + * + */ + +/* powil.c + * + * Real raised to integer power, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, powil(); + * int n; + * + * y = powil( x, n ); + * + * + * + * DESCRIPTION: + * + * Returns argument x raised to the nth power. + * The routine efficiently decomposes n as a sum of powers of + * two. The desired power is a product of two-to-the-kth + * powers of x. Thus to compute the 32767 power of x requires + * 28 multiplications instead of 32767 multiplications. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic x domain n domain # trials peak rms + * IEEE .001,1000 -1022,1023 50000 4.3e-17 7.8e-18 + * IEEE 1,2 -1022,1023 20000 3.9e-17 7.6e-18 + * IEEE .99,1.01 0,8700 10000 3.6e-16 7.2e-17 + * + * Returns MAXNUM on overflow, zero on underflow. + * + */ + +/* powl.c + * + * Power function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, z, powl(); + * + * z = powl( x, y ); + * + * + * + * DESCRIPTION: + * + * Computes x raised to the yth power. Analytically, + * + * x**y = exp( y log(x) ). + * + * Following Cody and Waite, this program uses a lookup table + * of 2**-i/32 and pseudo extended precision arithmetic to + * obtain several extra bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * The relative error of pow(x,y) can be estimated + * by y dl ln(2), where dl is the absolute error of + * the internally computed base 2 logarithm. At the ends + * of the approximation interval the logarithm equal 1/32 + * and its relative error is about 1 lsb = 1.1e-19. Hence + * the predicted relative error in the result is 2.3e-21 y . + * + * Relative error: + * arithmetic domain # trials peak rms + * + * IEEE +-1000 40000 2.8e-18 3.7e-19 + * .001 < x < 1000, with log(x) uniformly distributed. + * -1000 < y < 1000, y uniformly distributed. + * + * IEEE 0,8700 60000 6.5e-18 1.0e-18 + * 0.99 < x < 1.01, 0 < y < 8700, uniformly distributed. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * pow overflow x**y > MAXNUM MAXNUM + * pow underflow x**y < 1/MAXNUM 0.0 + * pow domain x<0 and y noninteger 0.0 + * + */ + +/* sinhl.c + * + * Hyperbolic sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sinhl(); + * + * y = sinhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOGL to + * MAXLOGL. + * + * The range is partitioned into two segments. If |x| <= 1, a + * rational function of the form x + x**3 P(x)/Q(x) is employed. + * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 10000 1.5e-19 3.9e-20 + * IEEE +-10000 30000 1.1e-19 2.8e-20 + * + */ + +/* sinl.c + * + * Circular sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sinl(); + * + * y = sinl( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of pi/4. The reduction + * error is nearly eliminated by contriving an extended precision + * modular arithmetic. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by the Cody + * and Waite polynomial form + * x + x**3 P(x**2) . + * Between pi/4 and pi/2 the cosine is represented as + * 1 - .5 x**2 + x**4 Q(x**2) . + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-5.5e11 200,000 1.2e-19 2.9e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2**39 0.0 + * + * Loss of precision occurs for x > 2**39 = 5.49755813888e11. + * The routine as implemented flags a TLOSS error for + * x > 2**39 and returns 0.0. + */ + /* cosl.c + * + * Circular cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cosl(); + * + * y = cosl( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of pi/4. The reduction + * error is nearly eliminated by contriving an extended precision + * modular arithmetic. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - .5 x**2 + x**4 Q(x**2) . + * Between pi/4 and pi/2 the sine is represented by the Cody + * and Waite polynomial form + * x + x**3 P(x**2) . + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-5.5e11 50000 1.2e-19 2.9e-20 + */ + +/* sqrtl.c + * + * Square root, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sqrtl(); + * + * y = sqrtl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the square root of x. + * + * Range reduction involves isolating the power of two of the + * argument and using a polynomial approximation to obtain + * a rough value for the square root. Then Heron's iteration + * is used three times to converge to an accurate value. + * + * Note, some arithmetic coprocessors such as the 8087 and + * 68881 produce correctly rounded square roots, which this + * routine will not. + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 30000 8.1e-20 3.1e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrt domain x < 0 0.0 + * + */ + +/* stdtrl.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * long double p, t, stdtrl(); + * int k; + * + * p = stdtrl( k, t ); + * + * + * DESCRIPTION: + * + * Computes the integral from minus infinity to t of the Student + * t distribution with integer k > 0 degrees of freedom: + * + * t + * - + * | | + * - | 2 -(k+1)/2 + * | ( (k+1)/2 ) | ( x ) + * ---------------------- | ( 1 + --- ) dx + * - | ( k ) + * sqrt( k pi ) | ( k/2 ) | + * | | + * - + * -inf. + * + * Relation to incomplete beta integral: + * + * 1 - stdtr(k,t) = 0.5 * incbet( k/2, 1/2, z ) + * where + * z = k/(k + t**2). + * + * For t < -1.6, this is the method of computation. For higher t, + * a direct method is derived from integration by parts. + * Since the function is symmetric about t=0, the area under the + * right tail of the density is found by calling the function + * with -t instead of t. + * + * ACCURACY: + * + * Tested at random 1 <= k <= 100. The "domain" refers to t. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -100,-1.6 10000 5.7e-18 9.8e-19 + * IEEE -1.6,100 10000 3.8e-18 1.0e-19 + */ + +/* stdtril.c + * + * Functional inverse of Student's t distribution + * + * + * + * SYNOPSIS: + * + * long double p, t, stdtril(); + * int k; + * + * t = stdtril( k, p ); + * + * + * DESCRIPTION: + * + * Given probability p, finds the argument t such that stdtrl(k,t) + * is equal to p. + * + * ACCURACY: + * + * Tested at random 1 <= k <= 100. The "domain" refers to p: + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 3500 4.2e-17 4.1e-18 + */ + +/* tanhl.c + * + * Hyperbolic tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, tanhl(); + * + * y = tanhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOGL to + * MAXLOGL. + * + * A rational function is used for |x| < 0.625. The form + * x + x**3 P(x)/Q(x) of Cody _& Waite is employed. + * Otherwise, + * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 30000 1.3e-19 2.4e-20 + * + */ + +/* tanl.c + * + * Circular tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, tanl(); + * + * y = tanl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is modulo pi/4. A rational function + * x + x**3 P(x**2)/Q(x**2) + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-1.07e9 30000 1.9e-19 4.8e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * tan total loss x > 2^39 0.0 + * + */ + /* cotl.c + * + * Circular cotangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cotl(); + * + * y = cotl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the radian argument x. + * + * Range reduction is modulo pi/4. A rational function + * x + x**3 P(x**2)/Q(x**2) + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-1.07e9 30000 1.9e-19 5.1e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^39 0.0 + * cot singularity x = 0 MAXNUM + * + */ + +/* unityl.c + * + * Relative error approximations for function arguments near + * unity. + * + * log1p(x) = log(1+x) + * expm1(x) = exp(x) - 1 + * cos1m(x) = cos(x) - 1 + * + */ + +/* ynl.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * long double x, y, ynl(); + * int n; + * + * y = ynl( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order n, where n is a + * (possibly negative) integer. + * + * The function is evaluated by forward recurrence on + * n, starting with values computed by the routines + * y0l() and y1l(). + * + * If n = 0 or 1 the routine for y0l or y1l is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative error when y > 1. + * x >= 0, -30 <= n <= +30. + * arithmetic domain # trials peak rms + * IEEE -30, 30 10000 1.3e-18 1.8e-19 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ynl singularity x = 0 MAXNUML + * ynl overflow MAXNUML + * + * Spot checked against tables for x, n between 0 and 100. + * + */ diff --git a/libm/ldouble/acoshl.c b/libm/ldouble/acoshl.c new file mode 100644 index 000000000..96c46bf22 --- /dev/null +++ b/libm/ldouble/acoshl.c @@ -0,0 +1,167 @@ +/* acoshl.c + * + * Inverse hyperbolic cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, acoshl(); + * + * y = acoshl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a rational approximation + * + * sqrt(2z) * P(z)/Q(z) + * + * where z = x-1, is used. Otherwise, + * + * acosh(x) = log( x + sqrt( (x-1)(x+1) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,3 30000 2.0e-19 3.9e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acoshl domain |x| < 1 0.0 + * + */ + +/* acosh.c */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + + +/* acosh(1+x) = sqrt(2x) * R(x), interval 0 < x < 0.5 */ + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 2.9071989653343333587238E-5L, + 3.2906030801088967279449E-3L, + 6.3034445964862182128388E-2L, + 4.1587081802731351459504E-1L, + 1.0989714347599256302467E0L, + 9.9999999999999999999715E-1L, +}; +static long double Q[] = { + 1.0443462486787584738322E-4L, + 6.0085845375571145826908E-3L, + 8.7750439986662958343370E-2L, + 4.9564621536841869854584E-1L, + 1.1823047680932589605190E0L, + 1.0000000000000000000028E0L, +}; +#endif + + +#ifdef IBMPC +static unsigned short P[] = { +0x4536,0x4dba,0x9f55,0xf3df,0x3fef, XPD +0x23a5,0xf9aa,0x289c,0xd7a7,0x3ff6, XPD +0x7e8b,0x8645,0x341f,0x8118,0x3ffb, XPD +0x0fd5,0x937f,0x0515,0xd4ed,0x3ffd, XPD +0x2364,0xc41b,0x1891,0x8cab,0x3fff, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +static short Q[] = { +0x1e7c,0x4f16,0xe98c,0xdb03,0x3ff1, XPD +0xc319,0xc272,0xa90a,0xc4e3,0x3ff7, XPD +0x2f83,0x9e5e,0x80af,0xb3b6,0x3ffb, XPD +0xe1e0,0xc97c,0x573a,0xfdc5,0x3ffd, XPD +0xcdf2,0x6ec5,0xc33c,0x9755,0x3fff, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3fef0000,0xf3df9f55,0x4dba4536, +0x3ff60000,0xd7a7289c,0xf9aa23a5, +0x3ffb0000,0x8118341f,0x86457e8b, +0x3ffd0000,0xd4ed0515,0x937f0fd5, +0x3fff0000,0x8cab1891,0xc41b2364, +0x3fff0000,0x80000000,0x00000000, +}; +static long Q[] = { +0x3ff10000,0xdb03e98c,0x4f161e7c, +0x3ff70000,0xc4e3a90a,0xc272c319, +0x3ffb0000,0xb3b680af,0x9e5e2f83, +0x3ffd0000,0xfdc5573a,0xc97ce1e0, +0x3fff0000,0x9755c33c,0x6ec5cdf2, +0x3fff0000,0x80000000,0x00000000, +}; +#endif + +extern long double LOGE2L; +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif +#ifdef ANSIPROT +extern long double logl ( long double ); +extern long double sqrtl ( long double ); +extern long double polevll ( long double, void *, int ); +extern int isnanl ( long double ); +#else +long double logl(), sqrtl(), polevll(), isnanl(); +#endif + +long double acoshl(x) +long double x; +{ +long double a, z; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +if( x < 1.0L ) + { + mtherr( "acoshl", DOMAIN ); +#ifdef NANS + return(NANL); +#else + return(0.0L); +#endif + } + +if( x > 1.0e10 ) + { +#ifdef INFINITIES + if( x == INFINITYL ) + return( INFINITYL ); +#endif + return( logl(x) + LOGE2L ); + } + +z = x - 1.0L; + +if( z < 0.5L ) + { + a = sqrtl(2.0L*z) * (polevll(z, P, 5) / polevll(z, Q, 5) ); + return( a ); + } + +a = sqrtl( z*(x+1.0L) ); +return( logl(x + a) ); +} diff --git a/libm/ldouble/arcdotl.c b/libm/ldouble/arcdotl.c new file mode 100644 index 000000000..952f027c6 --- /dev/null +++ b/libm/ldouble/arcdotl.c @@ -0,0 +1,108 @@ +/* arcdot.c + * + * Angle between two vectors + * + * + * + * + * SYNOPSIS: + * + * long double p[3], q[3], arcdotl(); + * + * y = arcdotl( p, q ); + * + * + * + * DESCRIPTION: + * + * For two vectors p, q, the angle A between them is given by + * + * p.q / (|p| |q|) = cos A . + * + * where "." represents inner product, "|x|" the length of vector x. + * If the angle is small, an expression in sin A is preferred. + * Set r = q - p. Then + * + * p.q = p.p + p.r , + * + * |p|^2 = p.p , + * + * |q|^2 = p.p + 2 p.r + r.r , + * + * p.p^2 + 2 p.p p.r + p.r^2 + * cos^2 A = ---------------------------- + * p.p (p.p + 2 p.r + r.r) + * + * p.p + 2 p.r + p.r^2 / p.p + * = --------------------------- , + * p.p + 2 p.r + r.r + * + * sin^2 A = 1 - cos^2 A + * + * r.r - p.r^2 / p.p + * = -------------------- + * p.p + 2 p.r + r.r + * + * = (r.r - p.r^2 / p.p) / q.q . + * + * ACCURACY: + * + * About 1 ULP. See arcdot.c. + * + */ + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double acosl ( long double ); +extern long double asinl ( long double ); +extern long double atanl ( long double ); +#else +long double sqrtl(), acosl(), asinl(), atanl(); +#endif +extern long double PIL; + +long double arcdotl(p,q) +long double p[], q[]; +{ +long double pp, pr, qq, rr, rt, pt, qt, pq; +int i; + +pq = 0.0L; +qq = 0.0L; +pp = 0.0L; +pr = 0.0L; +rr = 0.0L; +for (i=0; i<3; i++) + { + pt = p[i]; + qt = q[i]; + pq += pt * qt; + qq += qt * qt; + pp += pt * pt; + rt = qt - pt; + pr += pt * rt; + rr += rt * rt; + } +if (rr == 0.0L || pp == 0.0L || qq == 0.0L) + return 0.0L; +rt = (rr - (pr * pr) / pp) / qq; +if (rt <= 0.75L) + { + rt = sqrtl(rt); + qt = asinl(rt); + if (pq < 0.0L) + qt = PIL - qt; + } +else + { + pt = pq / sqrtl(pp*qq); + qt = acosl(pt); + } +return qt; +} diff --git a/libm/ldouble/asinhl.c b/libm/ldouble/asinhl.c new file mode 100644 index 000000000..025dfc29d --- /dev/null +++ b/libm/ldouble/asinhl.c @@ -0,0 +1,156 @@ +/* asinhl.c + * + * Inverse hyperbolic sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, asinhl(); + * + * y = asinhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic sine of argument. + * + * If |x| < 0.5, the function is approximated by a rational + * form x + x**3 P(x)/Q(x). Otherwise, + * + * asinh(x) = log( x + sqrt(1 + x*x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -3,3 30000 1.7e-19 3.5e-20 + * + */ + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +static long double P[] = { +-7.2157234864927687427374E-1L, +-1.3005588097490352458918E1L, +-5.9112383795679709212744E1L, +-9.5372702442289028811361E1L, +-4.9802880260861844539014E1L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ + 2.8754968540389640419671E1L, + 2.0990255691901160529390E2L, + 5.9265075560893800052658E2L, + 7.0670399135805956780660E2L, + 2.9881728156517107462943E2L, +}; +#endif + + +#ifdef IBMPC +static short P[] = { +0x8f42,0x2584,0xf727,0xb8b8,0xbffe, XPD +0x9d56,0x7f7c,0xe38b,0xd016,0xc002, XPD +0xc518,0xdc2d,0x14bc,0xec73,0xc004, XPD +0x99fe,0xc18a,0xd2da,0xbebe,0xc005, XPD +0xb46c,0x3c05,0x263e,0xc736,0xc004, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0xdfed,0x33db,0x2cf2,0xe60a,0x4003, XPD +0xf109,0x61ee,0x0df8,0xd1e7,0x4006, XPD +0xf21e,0xda84,0xa5fa,0x9429,0x4008, XPD +0x13fc,0xc4e2,0x0e31,0xb0ad,0x4008, XPD +0x485c,0xad04,0x9cae,0x9568,0x4007, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0xbffe0000,0xb8b8f727,0x25848f42, +0xc0020000,0xd016e38b,0x7f7c9d56, +0xc0040000,0xec7314bc,0xdc2dc518, +0xc0050000,0xbebed2da,0xc18a99fe, +0xc0040000,0xc736263e,0x3c05b46c, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40030000,0xe60a2cf2,0x33dbdfed, +0x40060000,0xd1e70df8,0x61eef109, +0x40080000,0x9429a5fa,0xda84f21e, +0x40080000,0xb0ad0e31,0xc4e213fc, +0x40070000,0x95689cae,0xad04485c, +}; +#endif + +extern long double LOGE2L; +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef ANSIPROT +extern long double logl ( long double ); +extern long double sqrtl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +extern int isfinitel ( long double ); +#else +long double logl(), sqrtl(), polevll(), p1evll(), isnanl(), isfinitel(); +#endif + +long double asinhl(x) +long double x; +{ +long double a, z; +int sign; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +#ifdef INFINITIES + if( !isfinitel(x) ) + return(x); +#endif +if( x < 0.0L ) + { + sign = -1; + x = -x; + } +else + sign = 1; + +if( x > 1.0e10L ) + { + return( sign * (logl(x) + LOGE2L) ); + } + +z = x * x; +if( x < 0.5L ) + { + a = ( polevll(z, P, 4)/p1evll(z, Q, 5) ) * z; + a = a * x + x; + if( sign < 0 ) + a = -a; + return(a); + } + +a = sqrtl( z + 1.0L ); +return( sign * logl(x + a) ); +} diff --git a/libm/ldouble/asinl.c b/libm/ldouble/asinl.c new file mode 100644 index 000000000..163f01055 --- /dev/null +++ b/libm/ldouble/asinl.c @@ -0,0 +1,249 @@ +/* asinl.c + * + * Inverse circular sine, long double precision + * + * + * + * SYNOPSIS: + * + * double x, y, asinl(); + * + * y = asinl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose sine is x. + * + * A rational function of the form x + x**3 P(x**2)/Q(x**2) + * is used for |x| in the interval [0, 0.5]. If |x| > 0.5 it is + * transformed by the identity + * + * asin(x) = pi/2 - 2 asin( sqrt( (1-x)/2 ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1, 1 30000 2.7e-19 4.8e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asinl domain |x| > 1 NANL + * + */ + /* acosl() + * + * Inverse circular cosine, long double precision + * + * + * + * SYNOPSIS: + * + * double x, y, acosl(); + * + * y = acosl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose cosine + * is x. + * + * Analytically, acos(x) = pi/2 - asin(x). However if |x| is + * near 1, there is cancellation error in subtracting asin(x) + * from pi/2. Hence if x < -0.5, + * + * acos(x) = pi - 2.0 * asin( sqrt((1+x)/2) ); + * + * or if x > +0.5, + * + * acos(x) = 2.0 * asin( sqrt((1-x)/2) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1, 1 30000 1.4e-19 3.5e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acosl domain |x| > 1 NANL + */ + +/* asin.c */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1990, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 3.7769340062433674871612E-3L, +-6.1212919176969202969441E-1L, + 5.9303993515791417710775E0L, +-1.8631697621590161441592E1L, + 2.3314603132141795720634E1L, +-1.0087146579384916260197E1L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ +-1.5684335624873146511217E1L, + 7.8702951549021104258866E1L, +-1.7078401170625864261444E2L, + 1.6712291455718995937376E2L, +-6.0522879476309497128868E1L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0x59d1,0x3509,0x7009,0xf786,0x3ff6, XPD +0xbe97,0x93e6,0x7fab,0x9cb4,0xbffe, XPD +0x8bf5,0x6810,0xd4dc,0xbdc5,0x4001, XPD +0x9bd4,0x8d86,0xb77b,0x950d,0xc003, XPD +0x3b0f,0x9e25,0x4ea5,0xba84,0x4003, XPD +0xea38,0xc6a9,0xf3cf,0xa164,0xc002, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x1229,0x8516,0x09e9,0xfaf3,0xc002, XPD +0xb5c3,0xf36f,0xe943,0x9d67,0x4005, XPD +0xe11a,0xbe0f,0xb4fd,0xaac8,0xc006, XPD +0x4c69,0x1355,0x7754,0xa71f,0x4006, XPD +0xded7,0xa9fe,0x6db7,0xf217,0xc004, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3ff60000,0xf7867009,0x350959d1, +0xbffe0000,0x9cb47fab,0x93e6be97, +0x40010000,0xbdc5d4dc,0x68108bf5, +0xc0030000,0x950db77b,0x8d869bd4, +0x40030000,0xba844ea5,0x9e253b0f, +0xc0020000,0xa164f3cf,0xc6a9ea38, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0020000,0xfaf309e9,0x85161229, +0x40050000,0x9d67e943,0xf36fb5c3, +0xc0060000,0xaac8b4fd,0xbe0fe11a, +0x40060000,0xa71f7754,0x13554c69, +0xc0040000,0xf2176db7,0xa9feded7, +}; +#endif +#ifdef NANS +extern long double NANL; +#endif +#ifdef ANSIPROT +extern long double ldexpl ( long double, int ); +extern long double sqrtl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +long double asinl ( long double ); +#else +long double ldexpl(), sqrtl(), polevll(), p1evll(); +long double asinl(); +#endif + +long double asinl(x) +long double x; +{ +long double a, p, z, zz; +short sign, flag; +extern long double PIO2L; + +if( x > 0 ) + { + sign = 1; + a = x; + } +else + { + sign = -1; + a = -x; + } + +if( a > 1.0L ) + { + mtherr( "asinl", DOMAIN ); +#ifdef NANS + return( NANL ); +#else + return( 0.0L ); +#endif + } + +if( a < 1.0e-8L ) + { + z = a; + goto done; + } + +if( a > 0.5L ) + { + zz = 0.5L -a; + zz = ldexpl( zz + 0.5L, -1 ); + z = sqrtl( zz ); + flag = 1; + } +else + { + z = a; + zz = z * z; + flag = 0; + } + +p = zz * polevll( zz, P, 5)/p1evll( zz, Q, 5); +z = z * p + z; +if( flag != 0 ) + { + z = z + z; + z = PIO2L - z; + } +done: +if( sign < 0 ) + z = -z; +return(z); +} + + +extern long double PIO2L, PIL; + +long double acosl(x) +long double x; +{ + +if( x < -1.0L ) + goto domerr; + +if( x < -0.5L) + return( PIL - 2.0L * asinl( sqrtl(0.5L*(1.0L+x)) ) ); + +if( x > 1.0L ) + { +domerr: mtherr( "acosl", DOMAIN ); +#ifdef NANS + return( NANL ); +#else + return( 0.0L ); +#endif + } + +if( x > 0.5L ) + return( 2.0L * asinl( sqrtl(0.5L*(1.0L-x) ) ) ); + +return( PIO2L - asinl(x) ); +} diff --git a/libm/ldouble/atanhl.c b/libm/ldouble/atanhl.c new file mode 100644 index 000000000..3dc7bd2eb --- /dev/null +++ b/libm/ldouble/atanhl.c @@ -0,0 +1,163 @@ +/* atanhl.c + * + * Inverse hyperbolic tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, atanhl(); + * + * y = atanhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOGL to MAXLOGL. + * + * If |x| < 0.5, the rational form x + x**3 P(x)/Q(x) is + * employed. Otherwise, + * atanh(x) = 0.5 * log( (1+x)/(1-x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1,1 30000 1.1e-19 3.3e-20 + * + */ + + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright (C) 1987, 1991, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 2.9647757819596835680719E-3L, +-8.0026596513099094380633E-1L, + 7.7920941408493040219831E0L, +-2.4330686602187898836837E1L, + 3.0204265014595622991082E1L, +-1.2961142942114056581210E1L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ +-1.3729634163247557081869E1L, + 6.2320841104088512332185E1L, +-1.2469344457045341444078E2L, + 1.1394285233959210574352E2L, +-3.8883428826342169425890E1L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0x3aa2,0x036b,0xaf06,0xc24c,0x3ff6, XPD +0x528e,0x56e8,0x3af4,0xccde,0xbffe, XPD +0x9d89,0xc9a1,0xd5cf,0xf958,0x4001, XPD +0xa653,0x6cfa,0x3f04,0xc2a5,0xc003, XPD +0xc651,0x2b3d,0x55b2,0xf1a2,0x4003, XPD +0xd76d,0xf293,0xd76b,0xcf60,0xc002, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0xd1b9,0x5314,0x94df,0xdbac,0xc002, XPD +0x3caa,0x0517,0x8a92,0xf948,0x4004, XPD +0x535e,0xaf5f,0x0b2a,0xf963,0xc005, XPD +0xa6f9,0xb702,0xbd8a,0xe3e2,0x4005, XPD +0xe136,0xf5ee,0xa190,0x9b88,0xc004, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3ff60000,0xc24caf06,0x036b3aa2, +0xbffe0000,0xccde3af4,0x56e8528e, +0x40010000,0xf958d5cf,0xc9a19d89, +0xc0030000,0xc2a53f04,0x6cfaa653, +0x40030000,0xf1a255b2,0x2b3dc651, +0xc0020000,0xcf60d76b,0xf293d76d, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0020000,0xdbac94df,0x5314d1b9, +0x40040000,0xf9488a92,0x05173caa, +0xc0050000,0xf9630b2a,0xaf5f535e, +0x40050000,0xe3e2bd8a,0xb702a6f9, +0xc0040000,0x9b88a190,0xf5eee136, +}; +#endif + +extern long double MAXNUML; +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double logl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +#else +long double fabsl(), logl(), polevll(), p1evll(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double atanhl(x) +long double x; +{ +long double s, z; + +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +z = fabsl(x); +if( z >= 1.0L ) + { + if( x == 1.0L ) + { +#ifdef INFINITIES + return( INFINITYL ); +#else + return( MAXNUML ); +#endif + } + if( x == -1.0L ) + { +#ifdef INFINITIES + return( -INFINITYL ); +#else + return( -MAXNUML ); +#endif + } + mtherr( "atanhl", DOMAIN ); +#ifdef NANS + return( NANL ); +#else + return( MAXNUML ); +#endif + } + +if( z < 1.0e-8L ) + return(x); + +if( z < 0.5L ) + { + z = x * x; + s = x + x * z * (polevll(z, P, 5) / p1evll(z, Q, 5)); + return(s); + } + +return( 0.5L * logl((1.0L+x)/(1.0L-x)) ); +} diff --git a/libm/ldouble/atanl.c b/libm/ldouble/atanl.c new file mode 100644 index 000000000..9e6d9af3c --- /dev/null +++ b/libm/ldouble/atanl.c @@ -0,0 +1,376 @@ +/* atanl.c + * + * Inverse circular tangent, long double precision + * (arctangent) + * + * + * + * SYNOPSIS: + * + * long double x, y, atanl(); + * + * y = atanl( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose tangent + * is x. + * + * Range reduction is from four intervals into the interval + * from zero to tan( pi/8 ). The approximant uses a rational + * function of degree 3/4 of the form x + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 150000 1.3e-19 3.0e-20 + * + */ + /* atan2l() + * + * Quadrant correct inverse circular tangent, + * long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, z, atan2l(); + * + * z = atan2l( y, x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle whose tangent is y/x. + * Define compile time symbol ANSIC = 1 for ANSI standard, + * range -PI < z <= +PI, args (y,x); else ANSIC = 0 for range + * 0 to 2PI, args (x,y). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 60000 1.7e-19 3.2e-20 + * See atan.c. + * + */ + +/* atan.c */ + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1990, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +static long double P[] = { +-8.6863818178092187535440E-1L, +-1.4683508633175792446076E1L, +-6.3976888655834347413154E1L, +-9.9988763777265819915721E1L, +-5.0894116899623603312185E1L, +}; +static long double Q[] = { +/* 1.00000000000000000000E0L,*/ + 2.2981886733594175366172E1L, + 1.4399096122250781605352E2L, + 3.6144079386152023162701E2L, + 3.9157570175111990631099E2L, + 1.5268235069887081006606E2L, +}; + +/* tan( 3*pi/8 ) */ +static long double T3P8 = 2.41421356237309504880169L; + +/* tan( pi/8 ) */ +static long double TP8 = 4.1421356237309504880169e-1L; +#endif + + +#ifdef IBMPC +static unsigned short P[] = { +0x8ece,0xce53,0x1266,0xde5f,0xbffe, XPD +0x07e6,0xa061,0xa6bf,0xeaef,0xc002, XPD +0x53ee,0xf291,0x557f,0xffe8,0xc004, XPD +0xf9d6,0xeda6,0x3f3e,0xc7fa,0xc005, XPD +0xb6c3,0x6abc,0x9361,0xcb93,0xc004, XPD +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x54d4,0x894e,0xe76e,0xb7da,0x4003, XPD +0x76b9,0x7a46,0xafa2,0x8ffd,0x4006, XPD +0xe3a9,0xe9c0,0x6bee,0xb4b8,0x4007, XPD +0xabc1,0x50a7,0xb098,0xc3c9,0x4007, XPD +0x891c,0x100d,0xae89,0x98ae,0x4006, XPD +}; + +/* tan( 3*pi/8 ) = 2.41421356237309504880 */ +static unsigned short T3P8A[] = {0x3242,0xfcef,0x7999,0x9a82,0x4000, XPD}; +#define T3P8 *(long double *)T3P8A + +/* tan( pi/8 ) = 0.41421356237309504880 */ +static unsigned short TP8A[] = {0x9211,0xe779,0xcccf,0xd413,0x3ffd, XPD}; +#define TP8 *(long double *)TP8A +#endif + +#ifdef MIEEE +static unsigned long P[] = { +0xbffe0000,0xde5f1266,0xce538ece, +0xc0020000,0xeaefa6bf,0xa06107e6, +0xc0040000,0xffe8557f,0xf29153ee, +0xc0050000,0xc7fa3f3e,0xeda6f9d6, +0xc0040000,0xcb939361,0x6abcb6c3, +}; +static unsigned long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40030000,0xb7dae76e,0x894e54d4, +0x40060000,0x8ffdafa2,0x7a4676b9, +0x40070000,0xb4b86bee,0xe9c0e3a9, +0x40070000,0xc3c9b098,0x50a7abc1, +0x40060000,0x98aeae89,0x100d891c, +}; + +/* tan( 3*pi/8 ) = 2.41421356237309504880 */ +static long T3P8A[] = {0x40000000,0x9a827999,0xfcef3242}; +#define T3P8 *(long double *)T3P8A + +/* tan( pi/8 ) = 0.41421356237309504880 */ +static long TP8A[] = {0x3ffd0000,0xd413cccf,0xe7799211}; +#define TP8 *(long double *)TP8A +#endif + +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double fabsl ( long double ); +extern int signbitl ( long double ); +extern int isnanl ( long double ); +long double atanl ( long double ); +#else +long double polevll(), p1evll(), fabsl(), signbitl(), isnanl(); +long double atanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif +#ifdef MINUSZERO +extern long double NEGZEROL; +#endif + +long double atanl(x) +long double x; +{ +extern long double PIO2L, PIO4L; +long double y, z; +short sign; + +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITYL ) + return( PIO2L ); +if( x == -INFINITYL ) + return( -PIO2L ); +#endif +/* make argument positive and save the sign */ +sign = 1; +if( x < 0.0L ) + { + sign = -1; + x = -x; + } + +/* range reduction */ +if( x > T3P8 ) + { + y = PIO2L; + x = -( 1.0L/x ); + } + +else if( x > TP8 ) + { + y = PIO4L; + x = (x-1.0L)/(x+1.0L); + } +else + y = 0.0L; + +/* rational form in x**2 */ +z = x * x; +y = y + ( polevll( z, P, 4 ) / p1evll( z, Q, 5 ) ) * z * x + x; + +if( sign < 0 ) + y = -y; + +return(y); +} + +/* atan2 */ + + +extern long double PIL, PIO2L, MAXNUML; + +#if ANSIC +long double atan2l( y, x ) +#else +long double atan2l( x, y ) +#endif +long double x, y; +{ +long double z, w; +short code; + +code = 0; + +if( x < 0.0L ) + code = 2; +if( y < 0.0L ) + code |= 1; + +#ifdef NANS +if( isnanl(x) ) + return(x); +if( isnanl(y) ) + return(y); +#endif +#ifdef MINUSZERO +if( y == 0.0L ) + { + if( signbitl(y) ) + { + if( x > 0.0L ) + z = y; + else if( x < 0.0L ) + z = -PIL; + else + { + if( signbitl(x) ) + z = -PIL; + else + z = y; + } + } + else /* y is +0 */ + { + if( x == 0.0L ) + { + if( signbitl(x) ) + z = PIL; + else + z = 0.0L; + } + else if( x > 0.0L ) + z = 0.0L; + else + z = PIL; + } + return z; + } +if( x == 0.0L ) + { + if( y > 0.0L ) + z = PIO2L; + else + z = -PIO2L; + return z; + } +#endif /* MINUSZERO */ +#ifdef INFINITIES +if( x == INFINITYL ) + { + if( y == INFINITYL ) + z = 0.25L * PIL; + else if( y == -INFINITYL ) + z = -0.25L * PIL; + else if( y < 0.0L ) + z = NEGZEROL; + else + z = 0.0L; + return z; + } +if( x == -INFINITYL ) + { + if( y == INFINITYL ) + z = 0.75L * PIL; + else if( y == -INFINITYL ) + z = -0.75L * PIL; + else if( y >= 0.0L ) + z = PIL; + else + z = -PIL; + return z; + } +if( y == INFINITYL ) + return( PIO2L ); +if( y == -INFINITYL ) + return( -PIO2L ); +#endif /* INFINITIES */ + +#ifdef INFINITIES +if( x == 0.0L ) +#else +if( fabsl(x) <= (fabsl(y) / MAXNUML) ) +#endif + { + if( code & 1 ) + { +#if ANSIC + return( -PIO2L ); +#else + return( 3.0L*PIO2L ); +#endif + } + if( y == 0.0L ) + return( 0.0L ); + return( PIO2L ); + } + +if( y == 0.0L ) + { + if( code & 2 ) + return( PIL ); + return( 0.0L ); + } + + +switch( code ) + { + default: +#if ANSIC + case 0: + case 1: w = 0.0L; break; + case 2: w = PIL; break; + case 3: w = -PIL; break; +#else + case 0: w = 0.0L; break; + case 1: w = 2.0L * PIL; break; + case 2: + case 3: w = PIL; break; +#endif + } + +z = w + atanl( y/x ); +#ifdef MINUSZERO +if( z == 0.0L && y < 0.0L ) + z = NEGZEROL; +#endif +return( z ); +} diff --git a/libm/ldouble/bdtrl.c b/libm/ldouble/bdtrl.c new file mode 100644 index 000000000..aca9577d1 --- /dev/null +++ b/libm/ldouble/bdtrl.c @@ -0,0 +1,260 @@ +/* bdtrl.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtrl(); + * + * y = bdtrl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms 0 through k of the Binomial + * probability density: + * + * k + * -- ( n ) j n-j + * > ( ) p (1-p) + * -- ( j ) + * j=0 + * + * The terms are not summed directly; instead the incomplete + * beta integral is employed, according to the formula + * + * y = bdtr( k, n, p ) = incbet( n-k, k+1, 1-p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * Tested at random points (k,n,p) with a and b between 0 + * and 10000 and p between 0 and 1. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10000 3000 1.6e-14 2.2e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrl domain k < 0 0.0 + * n < k + * x < 0, x > 1 + * + */ + /* bdtrcl() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtrcl(); + * + * y = bdtrcl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 through n of the Binomial + * probability density: + * + * n + * -- ( n ) j n-j + * > ( ) p (1-p) + * -- ( j ) + * j=k+1 + * + * The terms are not summed directly; instead the incomplete + * beta integral is employed, according to the formula + * + * y = bdtrc( k, n, p ) = incbet( k+1, n-k, p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * See incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrcl domain x<0, x>1, n<k 0.0 + */ + /* bdtril() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, bdtril(); + * + * p = bdtril( k, n, y ); + * + * + * + * DESCRIPTION: + * + * Finds the event probability p such that the sum of the + * terms 0 through k of the Binomial probability density + * is equal to the given cumulative probability y. + * + * This is accomplished using the inverse beta integral + * function and the relation + * + * 1 - p = incbi( n-k, k+1, y ). + * + * ACCURACY: + * + * See incbi.c. + * Tested at random k, n between 1 and 10000. The "domain" refers to p: + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 3500 2.0e-15 8.2e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtril domain k < 0, n <= k 0.0 + * x < 0, x > 1 + */ + +/* bdtr() */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double incbetl ( long double, long double, long double ); +extern long double incbil ( long double, long double, long double ); +extern long double powl ( long double, long double ); +extern long double expm1l ( long double ); +extern long double log1pl ( long double ); +#else +long double incbetl(), incbil(), powl(), expm1l(), log1pl(); +#endif + +long double bdtrcl( k, n, p ) +int k, n; +long double p; +{ +long double dk, dn; + +if( (p < 0.0L) || (p > 1.0L) ) + goto domerr; +if( k < 0 ) + return( 1.0L ); + +if( n < k ) + { +domerr: + mtherr( "bdtrcl", DOMAIN ); + return( 0.0L ); + } + +if( k == n ) + return( 0.0L ); +dn = n - k; +if( k == 0 ) + { + if( p < .01L ) + dk = -expm1l( dn * log1pl(-p) ); + else + dk = 1.0L - powl( 1.0L-p, dn ); + } +else + { + dk = k + 1; + dk = incbetl( dk, dn, p ); + } +return( dk ); +} + + + +long double bdtrl( k, n, p ) +int k, n; +long double p; +{ +long double dk, dn, q; + +if( (p < 0.0L) || (p > 1.0L) ) + goto domerr; +if( (k < 0) || (n < k) ) + { +domerr: + mtherr( "bdtrl", DOMAIN ); + return( 0.0L ); + } + +if( k == n ) + return( 1.0L ); + +q = 1.0L - p; +dn = n - k; +if( k == 0 ) + { + dk = powl( q, dn ); + } +else + { + dk = k + 1; + dk = incbetl( dn, dk, q ); + } +return( dk ); +} + + +long double bdtril( k, n, y ) +int k, n; +long double y; +{ +long double dk, dn, p; + +if( (y < 0.0L) || (y > 1.0L) ) + goto domerr; +if( (k < 0) || (n <= k) ) + { +domerr: + mtherr( "bdtril", DOMAIN ); + return( 0.0L ); + } + +dn = n - k; +if( k == 0 ) + { + if( y > 0.8L ) + p = -expm1l( log1pl(y-1.0L) / dn ); + else + p = 1.0L - powl( y, 1.0L/dn ); + } +else + { + dk = k + 1; + p = incbetl( dn, dk, y ); + if( p > 0.5 ) + p = incbil( dk, dn, 1.0L-y ); + else + p = 1.0 - incbil( dn, dk, y ); + } +return( p ); +} diff --git a/libm/ldouble/btdtrl.c b/libm/ldouble/btdtrl.c new file mode 100644 index 000000000..cbc4515da --- /dev/null +++ b/libm/ldouble/btdtrl.c @@ -0,0 +1,68 @@ + +/* btdtrl.c + * + * Beta distribution + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, btdtrl(); + * + * y = btdtrl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from zero to x under the beta density + * function: + * + * + * x + * - - + * | (a+b) | | a-1 b-1 + * P(x) = ---------- | t (1-t) dt + * - - | | + * | (a) | (b) - + * 0 + * + * + * The mean value of this distribution is a/(a+b). The variance + * is ab/[(a+b)^2 (a+b+1)]. + * + * This function is identical to the incomplete beta integral + * function, incbetl(a, b, x). + * + * The complemented function is + * + * 1 - P(1-x) = incbetl( b, a, x ); + * + * + * ACCURACY: + * + * See incbetl.c. + * + */ + +/* btdtrl() */ + + +/* +Cephes Math Library Release 2.0: April, 1987 +Copyright 1984, 1995 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ +#include <math.h> +#ifdef ANSIPROT +extern long double incbetl ( long double, long double, long double ); +#else +long double incbetl(); +#endif + +long double btdtrl( a, b, x ) +long double a, b, x; +{ + +return( incbetl( a, b, x ) ); +} diff --git a/libm/ldouble/cbrtl.c b/libm/ldouble/cbrtl.c new file mode 100644 index 000000000..89ed11a06 --- /dev/null +++ b/libm/ldouble/cbrtl.c @@ -0,0 +1,143 @@ +/* cbrtl.c + * + * Cube root, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cbrtl(); + * + * y = cbrtl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the cube root of the argument, which may be negative. + * + * Range reduction involves determining the power of 2 of + * the argument. A polynomial of degree 2 applied to the + * mantissa, and multiplication by the cube root of 1, 2, or 4 + * approximates the root to within about 0.1%. Then Newton's + * iteration is used three times to converge to an accurate + * result. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE .125,8 80000 7.0e-20 2.2e-20 + * IEEE exp(+-707) 100000 7.0e-20 2.4e-20 + * + */ + + +/* +Cephes Math Library Release 2.2: January, 1991 +Copyright 1984, 1991 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +static long double CBRT2 = 1.2599210498948731647672L; +static long double CBRT4 = 1.5874010519681994747517L; +static long double CBRT2I = 0.79370052598409973737585L; +static long double CBRT4I = 0.62996052494743658238361L; + +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +#else +long double frexpl(), ldexpl(); +extern int isnanl(); +#endif + +#ifdef INFINITIES +extern long double INFINITYL; +#endif + +long double cbrtl(x) +long double x; +{ +int e, rem, sign; +long double z; + + +#ifdef NANS +if(isnanl(x)) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITYL) + return(x); +if( x == -INFINITYL) + return(x); +#endif +if( x == 0 ) + return( x ); +if( x > 0 ) + sign = 1; +else + { + sign = -1; + x = -x; + } + +z = x; +/* extract power of 2, leaving + * mantissa between 0.5 and 1 + */ +x = frexpl( x, &e ); + +/* Approximate cube root of number between .5 and 1, + * peak relative error = 1.2e-6 + */ +x = (((( 1.3584464340920900529734e-1L * x + - 6.3986917220457538402318e-1L) * x + + 1.2875551670318751538055e0L) * x + - 1.4897083391357284957891e0L) * x + + 1.3304961236013647092521e0L) * x + + 3.7568280825958912391243e-1L; + +/* exponent divided by 3 */ +if( e >= 0 ) + { + rem = e; + e /= 3; + rem -= 3*e; + if( rem == 1 ) + x *= CBRT2; + else if( rem == 2 ) + x *= CBRT4; + } +else + { /* argument less than 1 */ + e = -e; + rem = e; + e /= 3; + rem -= 3*e; + if( rem == 1 ) + x *= CBRT2I; + else if( rem == 2 ) + x *= CBRT4I; + e = -e; + } + +/* multiply by power of 2 */ +x = ldexpl( x, e ); + +/* Newton iteration */ + +x -= ( x - (z/(x*x)) )*0.3333333333333333333333L; +x -= ( x - (z/(x*x)) )*0.3333333333333333333333L; + +if( sign < 0 ) + x = -x; +return(x); +} diff --git a/libm/ldouble/chdtrl.c b/libm/ldouble/chdtrl.c new file mode 100644 index 000000000..e55361e1f --- /dev/null +++ b/libm/ldouble/chdtrl.c @@ -0,0 +1,200 @@ +/* chdtrl.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double df, x, y, chdtrl(); + * + * y = chdtrl( df, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area under the left hand tail (from 0 to x) + * of the Chi square probability density function with + * v degrees of freedom. + * + * + * inf. + * - + * 1 | | v/2-1 -t/2 + * P( x | v ) = ----------- | t e dt + * v/2 - | | + * 2 | (v/2) - + * x + * + * where x is the Chi-square variable. + * + * The incomplete gamma integral is used, according to the + * formula + * + * y = chdtr( v, x ) = igam( v/2.0, x/2.0 ). + * + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igam(). + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtr domain x < 0 or v < 1 0.0 + */ + /* chdtrcl() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double v, x, y, chdtrcl(); + * + * y = chdtrcl( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area under the right hand tail (from x to + * infinity) of the Chi square probability density function + * with v degrees of freedom: + * + * + * inf. + * - + * 1 | | v/2-1 -t/2 + * P( x | v ) = ----------- | t e dt + * v/2 - | | + * 2 | (v/2) - + * x + * + * where x is the Chi-square variable. + * + * The incomplete gamma integral is used, according to the + * formula + * + * y = chdtr( v, x ) = igamc( v/2.0, x/2.0 ). + * + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igamc(). + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrc domain x < 0 or v < 1 0.0 + */ + /* chdtril() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * long double df, x, y, chdtril(); + * + * x = chdtril( df, y ); + * + * + * + * + * DESCRIPTION: + * + * Finds the Chi-square argument x such that the integral + * from x to infinity of the Chi-square density is equal + * to the given cumulative probability y. + * + * This is accomplished using the inverse gamma integral + * function and the relation + * + * x/2 = igami( df/2, y ); + * + * + * + * + * ACCURACY: + * + * See igami.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtri domain y < 0 or y > 1 0.0 + * v < 1 + * + */ + +/* chdtr() */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double igamcl ( long double, long double ); +extern long double igaml ( long double, long double ); +extern long double igamil ( long double, long double ); +#else +long double igamcl(), igaml(), igamil(); +#endif + +long double chdtrcl(df,x) +long double df, x; +{ + +if( (x < 0.0L) || (df < 1.0L) ) + { + mtherr( "chdtrcl", DOMAIN ); + return(0.0L); + } +return( igamcl( 0.5L*df, 0.5L*x ) ); +} + + + +long double chdtrl(df,x) +long double df, x; +{ + +if( (x < 0.0L) || (df < 1.0L) ) + { + mtherr( "chdtrl", DOMAIN ); + return(0.0L); + } +return( igaml( 0.5L*df, 0.5L*x ) ); +} + + + +long double chdtril( df, y ) +long double df, y; +{ +long double x; + +if( (y < 0.0L) || (y > 1.0L) || (df < 1.0L) ) + { + mtherr( "chdtril", DOMAIN ); + return(0.0L); + } + +x = igamil( 0.5L * df, y ); +return( 2.0L * x ); +} diff --git a/libm/ldouble/clogl.c b/libm/ldouble/clogl.c new file mode 100644 index 000000000..b3e6b25fb --- /dev/null +++ b/libm/ldouble/clogl.c @@ -0,0 +1,720 @@ +/* clogl.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clogl(); + * cmplxl z, w; + * + * clogl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Returns complex logarithm to the base e (2.718...) of + * the complex argument x. + * + * If z = x + iy, r = sqrt( x**2 + y**2 ), + * then + * w = log(r) + i arctan(y/x). + * + * The arctangent ranges from -PI to +PI. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 7000 8.5e-17 1.9e-17 + * IEEE -10,+10 30000 5.0e-15 1.1e-16 + * + * Larger relative error can be observed for z near 1 +i0. + * In IEEE arithmetic the peak absolute error is 5.2e-16, rms + * absolute error 1.0e-16. + */ + +#include <math.h> +#ifdef ANSIPROT +static void cchshl ( long double x, long double *c, long double *s ); +static long double redupil ( long double x ); +static long double ctansl ( cmplxl *z ); +long double cabsl ( cmplxl *x ); +void csqrtl ( cmplxl *x, cmplxl *y ); +void caddl ( cmplxl *x, cmplxl *y, cmplxl *z ); +extern long double fabsl ( long double ); +extern long double sqrtl ( long double ); +extern long double logl ( long double ); +extern long double expl ( long double ); +extern long double atan2l ( long double, long double ); +extern long double coshl ( long double ); +extern long double sinhl ( long double ); +extern long double asinl ( long double ); +extern long double sinl ( long double ); +extern long double cosl ( long double ); +void clogl ( cmplxl *, cmplxl *); +void casinl ( cmplxl *, cmplxl *); +#else +static void cchshl(); +static long double redupil(); +static long double ctansl(); +long double cabsl(), fabsl(), sqrtl(); +lnog double logl(), expl(), atan2l(), coshl(), sinhl(); +long double asinl(), sinl(), cosl(); +void caddl(), csqrtl(), clogl(), casinl(); +#endif + +extern long double MAXNUML, MACHEPL, PIL, PIO2L; + +void clogl( z, w ) +register cmplxl *z, *w; +{ +long double p, rr; + +/*rr = sqrt( z->r * z->r + z->i * z->i );*/ +rr = cabsl(z); +p = logl(rr); +#if ANSIC +rr = atan2l( z->i, z->r ); +#else +rr = atan2l( z->r, z->i ); +if( rr > PIL ) + rr -= PIL + PIL; +#endif +w->i = rr; +w->r = p; +} + /* cexpl() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexpl(); + * cmplxl z, w; + * + * cexpl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Returns the exponential of the complex argument z + * into the complex result w. + * + * If + * z = x + iy, + * r = exp(x), + * + * then + * + * w = r cos y + i r sin y. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8700 3.7e-17 1.1e-17 + * IEEE -10,+10 30000 3.0e-16 8.7e-17 + * + */ + +void cexpl( z, w ) +register cmplxl *z, *w; +{ +long double r; + +r = expl( z->r ); +w->r = r * cosl( z->i ); +w->i = r * sinl( z->i ); +} + /* csinl() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csinl(); + * cmplxl z, w; + * + * csinl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * w = sin x cosh y + i cos x sinh y. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8400 5.3e-17 1.3e-17 + * IEEE -10,+10 30000 3.8e-16 1.0e-16 + * Also tested by csin(casin(z)) = z. + * + */ + +void csinl( z, w ) +register cmplxl *z, *w; +{ +long double ch, sh; + +cchshl( z->i, &ch, &sh ); +w->r = sinl( z->r ) * ch; +w->i = cosl( z->r ) * sh; +} + + + +/* calculate cosh and sinh */ + +static void cchshl( x, c, s ) +long double x, *c, *s; +{ +long double e, ei; + +if( fabsl(x) <= 0.5L ) + { + *c = coshl(x); + *s = sinhl(x); + } +else + { + e = expl(x); + ei = 0.5L/e; + e = 0.5L * e; + *s = e - ei; + *c = e + ei; + } +} + + /* ccosl() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccosl(); + * cmplxl z, w; + * + * ccosl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * w = cos x cosh y - i sin x sinh y. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 8400 4.5e-17 1.3e-17 + * IEEE -10,+10 30000 3.8e-16 1.0e-16 + */ + +void ccosl( z, w ) +register cmplxl *z, *w; +{ +long double ch, sh; + +cchshl( z->i, &ch, &sh ); +w->r = cosl( z->r ) * ch; +w->i = -sinl( z->r ) * sh; +} + /* ctanl() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctanl(); + * cmplxl z, w; + * + * ctanl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * sin 2x + i sinh 2y + * w = --------------------. + * cos 2x + cosh 2y + * + * On the real axis the denominator is zero at odd multiples + * of PI/2. The denominator is evaluated by its Taylor + * series near these points. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5200 7.1e-17 1.6e-17 + * IEEE -10,+10 30000 7.2e-16 1.2e-16 + * Also tested by ctan * ccot = 1 and catan(ctan(z)) = z. + */ + +void ctanl( z, w ) +register cmplxl *z, *w; +{ +long double d; + +d = cosl( 2.0L * z->r ) + coshl( 2.0L * z->i ); + +if( fabsl(d) < 0.25L ) + d = ctansl(z); + +if( d == 0.0L ) + { + mtherr( "ctan", OVERFLOW ); + w->r = MAXNUML; + w->i = MAXNUML; + return; + } + +w->r = sinl( 2.0L * z->r ) / d; +w->i = sinhl( 2.0L * z->i ) / d; +} + /* ccotl() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccotl(); + * cmplxl z, w; + * + * ccotl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * + * sin 2x - i sinh 2y + * w = --------------------. + * cosh 2y - cos 2x + * + * On the real axis, the denominator has zeros at even + * multiples of PI/2. Near these points it is evaluated + * by a Taylor series. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 3000 6.5e-17 1.6e-17 + * IEEE -10,+10 30000 9.2e-16 1.2e-16 + * Also tested by ctan * ccot = 1 + i0. + */ + +void ccotl( z, w ) +register cmplxl *z, *w; +{ +long double d; + +d = coshl(2.0L * z->i) - cosl(2.0L * z->r); + +if( fabsl(d) < 0.25L ) + d = ctansl(z); + +if( d == 0.0L ) + { + mtherr( "ccot", OVERFLOW ); + w->r = MAXNUML; + w->i = MAXNUML; + return; + } + +w->r = sinl( 2.0L * z->r ) / d; +w->i = -sinhl( 2.0L * z->i ) / d; +} + +/* Program to subtract nearest integer multiple of PI */ +/* extended precision value of PI: */ +#ifdef UNK +static double DP1 = 3.14159265160560607910E0; +static double DP2 = 1.98418714791870343106E-9; +static double DP3 = 1.14423774522196636802E-17; +#endif + +#ifdef DEC +static unsigned short P1[] = {0040511,0007732,0120000,0000000,}; +static unsigned short P2[] = {0031010,0055060,0100000,0000000,}; +static unsigned short P3[] = {0022123,0011431,0105056,0001560,}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +#ifdef IBMPC +static unsigned short P1[] = {0x0000,0x5400,0x21fb,0x4009}; +static unsigned short P2[] = {0x0000,0x1000,0x0b46,0x3e21}; +static unsigned short P3[] = {0xc06e,0x3145,0x6263,0x3c6a}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +#ifdef MIEEE +static unsigned short P1[] = { +0x4009,0x21fb,0x5400,0x0000 +}; +static unsigned short P2[] = { +0x3e21,0x0b46,0x1000,0x0000 +}; +static unsigned short P3[] = { +0x3c6a,0x6263,0x3145,0xc06e +}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +static long double redupil(x) +long double x; +{ +long double t; +long i; + +t = x/PIL; +if( t >= 0.0L ) + t += 0.5L; +else + t -= 0.5L; + +i = t; /* the multiple */ +t = i; +t = ((x - t * DP1) - t * DP2) - t * DP3; +return(t); +} + +/* Taylor series expansion for cosh(2y) - cos(2x) */ + +static long double ctansl(z) +cmplxl *z; +{ +long double f, x, x2, y, y2, rn, t; +long double d; + +x = fabsl( 2.0L * z->r ); +y = fabsl( 2.0L * z->i ); + +x = redupil(x); + +x = x * x; +y = y * y; +x2 = 1.0L; +y2 = 1.0L; +f = 1.0L; +rn = 0.0; +d = 0.0; +do + { + rn += 1.0L; + f *= rn; + rn += 1.0L; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 + x2; + t /= f; + d += t; + + rn += 1.0L; + f *= rn; + rn += 1.0L; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 - x2; + t /= f; + d += t; + } +while( fabsl(t/d) > MACHEPL ); +return(d); +} + /* casinl() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casinl(); + * cmplxl z, w; + * + * casinl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Inverse complex sine: + * + * 2 + * w = -i clog( iz + csqrt( 1 - z ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 10100 2.1e-15 3.4e-16 + * IEEE -10,+10 30000 2.2e-14 2.7e-15 + * Larger relative error can be observed for z near zero. + * Also tested by csin(casin(z)) = z. + */ + +void casinl( z, w ) +cmplxl *z, *w; +{ +static cmplxl ca, ct, zz, z2; +long double x, y; + +x = z->r; +y = z->i; + +if( y == 0.0L ) + { + if( fabsl(x) > 1.0L ) + { + w->r = PIO2L; + w->i = 0.0L; + mtherr( "casinl", DOMAIN ); + } + else + { + w->r = asinl(x); + w->i = 0.0L; + } + return; + } + +/* Power series expansion */ +/* +b = cabsl(z); +if( b < 0.125L ) +{ +z2.r = (x - y) * (x + y); +z2.i = 2.0L * x * y; + +cn = 1.0L; +n = 1.0L; +ca.r = x; +ca.i = y; +sum.r = x; +sum.i = y; +do + { + ct.r = z2.r * ca.r - z2.i * ca.i; + ct.i = z2.r * ca.i + z2.i * ca.r; + ca.r = ct.r; + ca.i = ct.i; + + cn *= n; + n += 1.0L; + cn /= n; + n += 1.0L; + b = cn/n; + + ct.r *= b; + ct.i *= b; + sum.r += ct.r; + sum.i += ct.i; + b = fabsl(ct.r) + fabs(ct.i); + } +while( b > MACHEPL ); +w->r = sum.r; +w->i = sum.i; +return; +} +*/ + + +ca.r = x; +ca.i = y; + +ct.r = -ca.i; /* iz */ +ct.i = ca.r; + + /* sqrt( 1 - z*z) */ +/* cmul( &ca, &ca, &zz ) */ +zz.r = (ca.r - ca.i) * (ca.r + ca.i); /*x * x - y * y */ +zz.i = 2.0L * ca.r * ca.i; + +zz.r = 1.0L - zz.r; +zz.i = -zz.i; +csqrtl( &zz, &z2 ); + +caddl( &z2, &ct, &zz ); +clogl( &zz, &zz ); +w->r = zz.i; /* mult by 1/i = -i */ +w->i = -zz.r; +return; +} + /* cacosl() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacosl(); + * cmplxl z, w; + * + * cacosl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * w = arccos z = PI/2 - arcsin z. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5200 1.6e-15 2.8e-16 + * IEEE -10,+10 30000 1.8e-14 2.2e-15 + */ + +void cacosl( z, w ) +cmplxl *z, *w; +{ + +casinl( z, w ); +w->r = PIO2L - w->r; +w->i = -w->i; +} + /* catanl() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catanl(); + * cmplxl z, w; + * + * catanl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * If + * z = x + iy, + * + * then + * 1 ( 2x ) + * Re w = - arctan(-----------) + k PI + * 2 ( 2 2) + * (1 - x - y ) + * + * ( 2 2) + * 1 (x + (y+1) ) + * Im w = - log(------------) + * 4 ( 2 2) + * (x + (y-1) ) + * + * Where k is an arbitrary integer. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 5900 1.3e-16 7.8e-18 + * IEEE -10,+10 30000 2.3e-15 8.5e-17 + * The check catan( ctan(z) ) = z, with |x| and |y| < PI/2, + * had peak relative error 1.5e-16, rms relative error + * 2.9e-17. See also clog(). + */ + +void catanl( z, w ) +cmplxl *z, *w; +{ +long double a, t, x, x2, y; + +x = z->r; +y = z->i; + +if( (x == 0.0L) && (y > 1.0L) ) + goto ovrf; + +x2 = x * x; +a = 1.0L - x2 - (y * y); +if( a == 0.0L ) + goto ovrf; + +#if ANSIC +t = atan2l( 2.0L * x, a ) * 0.5L; +#else +t = atan2l( a, 2.0 * x ) * 0.5L; +#endif +w->r = redupil( t ); + +t = y - 1.0L; +a = x2 + (t * t); +if( a == 0.0L ) + goto ovrf; + +t = y + 1.0L; +a = (x2 + (t * t))/a; +w->i = logl(a)/4.0; +return; + +ovrf: +mtherr( "catanl", OVERFLOW ); +w->r = MAXNUML; +w->i = MAXNUML; +} diff --git a/libm/ldouble/cmplxl.c b/libm/ldouble/cmplxl.c new file mode 100644 index 000000000..ef130618d --- /dev/null +++ b/libm/ldouble/cmplxl.c @@ -0,0 +1,461 @@ +/* cmplxl.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * long double r; real part + * long double i; imaginary part + * }cmplxl; + * + * cmplxl *a, *b, *c; + * + * caddl( a, b, c ); c = b + a + * csubl( a, b, c ); c = b - a + * cmull( a, b, c ); c = b * a + * cdivl( a, b, c ); c = b / a + * cnegl( c ); c = -c + * cmovl( b, c ); c = b + * + * + * + * DESCRIPTION: + * + * Addition: + * c.r = b.r + a.r + * c.i = b.i + a.i + * + * Subtraction: + * c.r = b.r - a.r + * c.i = b.i - a.i + * + * Multiplication: + * c.r = b.r * a.r - b.i * a.i + * c.i = b.r * a.i + b.i * a.r + * + * Division: + * d = a.r * a.r + a.i * a.i + * c.r = (b.r * a.r + b.i * a.i)/d + * c.i = (b.i * a.r - b.r * a.i)/d + * ACCURACY: + * + * In DEC arithmetic, the test (1/z) * z = 1 had peak relative + * error 3.1e-17, rms 1.2e-17. The test (y/z) * (z/y) = 1 had + * peak relative error 8.3e-17, rms 2.1e-17. + * + * Tests in the rectangle {-10,+10}: + * Relative error: + * arithmetic function # trials peak rms + * DEC cadd 10000 1.4e-17 3.4e-18 + * IEEE cadd 100000 1.1e-16 2.7e-17 + * DEC csub 10000 1.4e-17 4.5e-18 + * IEEE csub 100000 1.1e-16 3.4e-17 + * DEC cmul 3000 2.3e-17 8.7e-18 + * IEEE cmul 100000 2.1e-16 6.9e-17 + * DEC cdiv 18000 4.9e-17 1.3e-17 + * IEEE cdiv 100000 3.7e-16 1.1e-16 + */ + /* cmplx.c + * complex number arithmetic + */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + + +#include <math.h> + +/* +typedef struct + { + long double r; + long double i; + }cmplxl; +*/ + +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double cabsl ( cmplxl * ); +extern long double sqrtl ( long double ); +extern long double atan2l ( long double, long double ); +extern long double cosl ( long double ); +extern long double sinl ( long double ); +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +void cdivl ( cmplxl *, cmplxl *, cmplxl * ); +void caddl ( cmplxl *, cmplxl *, cmplxl * ); +#else +long double fabsl(), cabsl(), sqrtl(), atan2l(), cosl(), sinl(); +long double frexpl(), ldexpl(); +int isnanl(); +void cdivl(), caddl(); +#endif + + +extern double MAXNUML, MACHEPL, PIL, PIO2L, INFINITYL, NANL; +cmplx czerol = {0.0L, 0.0L}; +cmplx conel = {1.0L, 0.0L}; + + +/* c = b + a */ + +void caddl( a, b, c ) +register cmplxl *a, *b; +cmplxl *c; +{ + +c->r = b->r + a->r; +c->i = b->i + a->i; +} + + +/* c = b - a */ + +void csubl( a, b, c ) +register cmplxl *a, *b; +cmplxl *c; +{ + +c->r = b->r - a->r; +c->i = b->i - a->i; +} + +/* c = b * a */ + +void cmull( a, b, c ) +register cmplxl *a, *b; +cmplxl *c; +{ +long double y; + +y = b->r * a->r - b->i * a->i; +c->i = b->r * a->i + b->i * a->r; +c->r = y; +} + + + +/* c = b / a */ + +void cdivl( a, b, c ) +register cmplxl *a, *b; +cmplxl *c; +{ +long double y, p, q, w; + + +y = a->r * a->r + a->i * a->i; +p = b->r * a->r + b->i * a->i; +q = b->i * a->r - b->r * a->i; + +if( y < 1.0L ) + { + w = MAXNUML * y; + if( (fabsl(p) > w) || (fabsl(q) > w) || (y == 0.0L) ) + { + c->r = INFINITYL; + c->i = INFINITYL; + mtherr( "cdivl", OVERFLOW ); + return; + } + } +c->r = p/y; +c->i = q/y; +} + + +/* b = a + Caution, a `short' is assumed to be 16 bits wide. */ + +void cmovl( a, b ) +void *a, *b; +{ +register short *pa, *pb; +int i; + +pa = (short *) a; +pb = (short *) b; +i = 16; +do + *pb++ = *pa++; +while( --i ); +} + + +void cnegl( a ) +register cmplxl *a; +{ + +a->r = -a->r; +a->i = -a->i; +} + +/* cabsl() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * long double cabsl(); + * cmplxl z; + * long double a; + * + * a = cabs( &z ); + * + * + * + * DESCRIPTION: + * + * + * If z = x + iy + * + * then + * + * a = sqrt( x**2 + y**2 ). + * + * Overflow and underflow are avoided by testing the magnitudes + * of x and y before squaring. If either is outside half of + * the floating point full scale range, both are rescaled. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -30,+30 30000 3.2e-17 9.2e-18 + * IEEE -10,+10 100000 2.7e-16 6.9e-17 + */ + + +/* +Cephes Math Library Release 2.1: January, 1989 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +/* +typedef struct + { + long double r; + long double i; + }cmplxl; +*/ + +#ifdef UNK +#define PRECL 32 +#define MAXEXPL 16384 +#define MINEXPL -16384 +#endif +#ifdef IBMPC +#define PRECL 32 +#define MAXEXPL 16384 +#define MINEXPL -16384 +#endif +#ifdef MIEEE +#define PRECL 32 +#define MAXEXPL 16384 +#define MINEXPL -16384 +#endif + + +long double cabsl( z ) +register cmplxl *z; +{ +long double x, y, b, re, im; +int ex, ey, e; + +#ifdef INFINITIES +/* Note, cabs(INFINITY,NAN) = INFINITY. */ +if( z->r == INFINITYL || z->i == INFINITYL + || z->r == -INFINITYL || z->i == -INFINITYL ) + return( INFINITYL ); +#endif + +#ifdef NANS +if( isnanl(z->r) ) + return(z->r); +if( isnanl(z->i) ) + return(z->i); +#endif + +re = fabsl( z->r ); +im = fabsl( z->i ); + +if( re == 0.0 ) + return( im ); +if( im == 0.0 ) + return( re ); + +/* Get the exponents of the numbers */ +x = frexpl( re, &ex ); +y = frexpl( im, &ey ); + +/* Check if one number is tiny compared to the other */ +e = ex - ey; +if( e > PRECL ) + return( re ); +if( e < -PRECL ) + return( im ); + +/* Find approximate exponent e of the geometric mean. */ +e = (ex + ey) >> 1; + +/* Rescale so mean is about 1 */ +x = ldexpl( re, -e ); +y = ldexpl( im, -e ); + +/* Hypotenuse of the right triangle */ +b = sqrtl( x * x + y * y ); + +/* Compute the exponent of the answer. */ +y = frexpl( b, &ey ); +ey = e + ey; + +/* Check it for overflow and underflow. */ +if( ey > MAXEXPL ) + { + mtherr( "cabsl", OVERFLOW ); + return( INFINITYL ); + } +if( ey < MINEXPL ) + return(0.0L); + +/* Undo the scaling */ +b = ldexpl( b, e ); +return( b ); +} + /* csqrtl() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrtl(); + * cmplxl z, w; + * + * csqrtl( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * If z = x + iy, r = |z|, then + * + * 1/2 + * Im w = [ (r - x)/2 ] , + * + * Re w = y / 2 Im w. + * + * + * Note that -w is also a square root of z. The root chosen + * is always in the upper half plane. + * + * Because of the potential for cancellation error in r - x, + * the result is sharpened by doing a Heron iteration + * (see sqrt.c) in complex arithmetic. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10,+10 25000 3.2e-17 9.6e-18 + * IEEE -10,+10 100000 3.2e-16 7.7e-17 + * + * 2 + * Also tested by csqrt( z ) = z, and tested by arguments + * close to the real axis. + */ + + +void csqrtl( z, w ) +cmplxl *z, *w; +{ +cmplxl q, s; +long double x, y, r, t; + +x = z->r; +y = z->i; + +if( y == 0.0L ) + { + if( x < 0.0L ) + { + w->r = 0.0L; + w->i = sqrtl(-x); + return; + } + else + { + w->r = sqrtl(x); + w->i = 0.0L; + return; + } + } + + +if( x == 0.0L ) + { + r = fabsl(y); + r = sqrtl(0.5L*r); + if( y > 0.0L ) + w->r = r; + else + w->r = -r; + w->i = r; + return; + } + +/* Approximate sqrt(x^2+y^2) - x = y^2/2x - y^4/24x^3 + ... . + * The relative error in the first term is approximately y^2/12x^2 . + */ +if( (fabsl(y) < 2.e-4L * fabsl(x)) + && (x > 0) ) + { + t = 0.25L*y*(y/x); + } +else + { + r = cabsl(z); + t = 0.5L*(r - x); + } + +r = sqrtl(t); +q.i = r; +q.r = y/(2.0L*r); +/* Heron iteration in complex arithmetic */ +cdivl( &q, z, &s ); +caddl( &q, &s, w ); +w->r *= 0.5L; +w->i *= 0.5L; + +cdivl( &q, z, &s ); +caddl( &q, &s, w ); +w->r *= 0.5L; +w->i *= 0.5L; +} + + +long double hypotl( x, y ) +long double x, y; +{ +cmplxl z; + +z.r = x; +z.i = y; +return( cabsl(&z) ); +} diff --git a/libm/ldouble/coshl.c b/libm/ldouble/coshl.c new file mode 100644 index 000000000..46212ae44 --- /dev/null +++ b/libm/ldouble/coshl.c @@ -0,0 +1,89 @@ +/* coshl.c + * + * Hyperbolic cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, coshl(); + * + * y = coshl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOGL to + * MAXLOGL. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-10000 30000 1.1e-19 2.8e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cosh overflow |x| > MAXLOGL+LOGE2L INFINITYL + * + * + */ + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1985, 1991, 1998 by Stephen L. Moshier +*/ + +#include <math.h> +extern long double MAXLOGL, MAXNUML, LOGE2L; +#ifdef ANSIPROT +extern long double expl ( long double ); +extern int isnanl ( long double ); +#else +long double expl(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double coshl(x) +long double x; +{ +long double y; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +if( x < 0 ) + x = -x; +if( x > (MAXLOGL + LOGE2L) ) + { + mtherr( "coshl", OVERFLOW ); +#ifdef INFINITIES + return( INFINITYL ); +#else + return( MAXNUML ); +#endif + } +if( x >= (MAXLOGL - LOGE2L) ) + { + y = expl(0.5L * x); + y = (0.5L * y) * y; + return(y); + } +y = expl(x); +y = 0.5L * (y + 1.0L / y); +return( y ); +} diff --git a/libm/ldouble/econst.c b/libm/ldouble/econst.c new file mode 100644 index 000000000..cfddbe3e2 --- /dev/null +++ b/libm/ldouble/econst.c @@ -0,0 +1,96 @@ +/* econst.c */ +/* e type constants used by high precision check routines */ + +#include "ehead.h" + + +#if NE == 10 +/* 0.0 */ +unsigned short ezero[NE] = + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x0000, 0x0000,}; + +/* 5.0E-1 */ +unsigned short ehalf[NE] = + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x3ffe,}; + +/* 1.0E0 */ +unsigned short eone[NE] = + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x3fff,}; + +/* 2.0E0 */ +unsigned short etwo[NE] = + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x4000,}; + +/* 3.2E1 */ +unsigned short e32[NE] = + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x8000, 0x4004,}; + +/* 6.93147180559945309417232121458176568075500134360255E-1 */ +unsigned short elog2[NE] = + {0x40f3, 0xf6af, 0x03f2, 0xb398, + 0xc9e3, 0x79ab, 0150717, 0013767, 0130562, 0x3ffe,}; + +/* 1.41421356237309504880168872420969807856967187537695E0 */ +unsigned short esqrt2[NE] = + {0x1d6f, 0xbe9f, 0x754a, 0x89b3, + 0x597d, 0x6484, 0174736, 0171463, 0132404, 0x3fff,}; + +/* 3.14159265358979323846264338327950288419716939937511E0 */ +unsigned short epi[NE] = + {0x2902, 0x1cd1, 0x80dc, 0x628b, + 0xc4c6, 0xc234, 0020550, 0155242, 0144417, 0040000,}; + +/* 5.7721566490153286060651209008240243104215933593992E-1 */ +unsigned short eeul[NE] = { +0xd1be,0xc7a4,0076660,0063743,0111704,0x3ffe,}; + +#else + +/* 0.0 */ +unsigned short ezero[NE] = { +0, 0000000,0000000,0000000,0000000,0000000,}; +/* 5.0E-1 */ +unsigned short ehalf[NE] = { +0, 0000000,0000000,0000000,0100000,0x3ffe,}; +/* 1.0E0 */ +unsigned short eone[NE] = { +0, 0000000,0000000,0000000,0100000,0x3fff,}; +/* 2.0E0 */ +unsigned short etwo[NE] = { +0, 0000000,0000000,0000000,0100000,0040000,}; +/* 3.2E1 */ +unsigned short e32[NE] = { +0, 0000000,0000000,0000000,0100000,0040004,}; +/* 6.93147180559945309417232121458176568075500134360255E-1 */ +unsigned short elog2[NE] = { +0xc9e4,0x79ab,0150717,0013767,0130562,0x3ffe,}; +/* 1.41421356237309504880168872420969807856967187537695E0 */ +unsigned short esqrt2[NE] = { +0x597e,0x6484,0174736,0171463,0132404,0x3fff,}; +/* 2/sqrt(PI) = + * 1.12837916709551257389615890312154517168810125865800E0 */ +unsigned short eoneopi[NE] = { +0x71d5,0x688d,0012333,0135202,0110156,0x3fff,}; +/* 3.14159265358979323846264338327950288419716939937511E0 */ +unsigned short epi[NE] = { +0xc4c6,0xc234,0020550,0155242,0144417,0040000,}; +/* 5.7721566490153286060651209008240243104215933593992E-1 */ +unsigned short eeul[NE] = { +0xd1be,0xc7a4,0076660,0063743,0111704,0x3ffe,}; +#endif +extern unsigned short ezero[]; +extern unsigned short ehalf[]; +extern unsigned short eone[]; +extern unsigned short etwo[]; +extern unsigned short e32[]; +extern unsigned short elog2[]; +extern unsigned short esqrt2[]; +extern unsigned short eoneopi[]; +extern unsigned short epi[]; +extern unsigned short eeul[]; + diff --git a/libm/ldouble/ehead.h b/libm/ldouble/ehead.h new file mode 100644 index 000000000..785396dce --- /dev/null +++ b/libm/ldouble/ehead.h @@ -0,0 +1,45 @@ + +/* Include file for extended precision arithmetic programs. + */ + +/* Number of 16 bit words in external x type format */ +#define NE 6 +/* #define NE 10 */ + +/* Number of 16 bit words in internal format */ +#define NI (NE+3) + +/* Array offset to exponent */ +#define E 1 + +/* Array offset to high guard word */ +#define M 2 + +/* Number of bits of precision */ +#define NBITS ((NI-4)*16) + +/* Maximum number of decimal digits in ASCII conversion + * = NBITS*log10(2) + */ +#define NDEC (NBITS*8/27) + +/* The exponent of 1.0 */ +#define EXONE (0x3fff) + + +void eadd(), esub(), emul(), ediv(); +int ecmp(), enormlz(), eshift(); +void eshup1(), eshup8(), eshup6(), eshdn1(), eshdn8(), eshdn6(); +void eabs(), eneg(), emov(), eclear(), einfin(), efloor(); +void eldexp(), efrexp(), eifrac(), ltoe(); +void esqrt(), elog(), eexp(), etanh(), epow(); +void asctoe(), asctoe24(), asctoe53(), asctoe64(); +void etoasc(), e24toasc(), e53toasc(), e64toasc(); +void etoe64(), etoe53(), etoe24(), e64toe(), e53toe(), e24toe(); +int mtherr(); + +extern unsigned short ezero[], ehalf[], eone[], etwo[]; +extern unsigned short elog2[], esqrt2[]; + + +/* by Stephen L. Moshier. */ diff --git a/libm/ldouble/elliel.c b/libm/ldouble/elliel.c new file mode 100644 index 000000000..851914454 --- /dev/null +++ b/libm/ldouble/elliel.c @@ -0,0 +1,146 @@ +/* elliel.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * long double phi, m, y, elliel(); + * + * y = elliel( phi, m ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * phi + * - + * | | + * | 2 + * E(phi_\m) = | sqrt( 1 - m sin t ) dt + * | + * | | + * - + * 0 + * + * of amplitude phi and modulus m, using the arithmetic - + * geometric mean algorithm. + * + * + * + * ACCURACY: + * + * Tested at random arguments with phi in [-10, 10] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 50000 2.7e-18 2.3e-19 + * + * + */ + + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1984, 1987, 1993, 1995 by Stephen L. Moshier +*/ + +/* Incomplete elliptic integral of second kind */ + +#include <math.h> +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double fabsl ( long double ); +extern long double logl ( long double ); +extern long double sinl ( long double ); +extern long double tanl ( long double ); +extern long double atanl ( long double ); +extern long double floorl ( long double ); +extern long double ellpel ( long double ); +extern long double ellpkl ( long double ); +long double elliel ( long double, long double ); +#else +long double sqrtl(), fabsl(), logl(), sinl(), tanl(), atanl(), floorl(); +long double ellpel(), ellpkl(), elliel(); +#endif +extern long double PIL, PIO2L, MACHEPL; + + +long double elliel( phi, m ) +long double phi, m; +{ +long double a, b, c, e, temp, lphi, t, E; +int d, mod, npio2, sign; + +if( m == 0.0L ) + return( phi ); +lphi = phi; +npio2 = floorl( lphi/PIO2L ); +if( npio2 & 1 ) + npio2 += 1; +lphi = lphi - npio2 * PIO2L; +if( lphi < 0.0L ) + { + lphi = -lphi; + sign = -1; + } +else + { + sign = 1; + } +a = 1.0L - m; +E = ellpel( a ); +if( a == 0.0L ) + { + temp = sinl( lphi ); + goto done; + } +t = tanl( lphi ); +b = sqrtl(a); +if( fabsl(t) > 10.0L ) + { + /* Transform the amplitude */ + e = 1.0L/(b*t); + /* ... but avoid multiple recursions. */ + if( fabsl(e) < 10.0L ) + { + e = atanl(e); + temp = E + m * sinl( lphi ) * sinl( e ) - elliel( e, m ); + goto done; + } + } +c = sqrtl(m); +a = 1.0L; +d = 1; +e = 0.0L; +mod = 0; + +while( fabsl(c/a) > MACHEPL ) + { + temp = b/a; + lphi = lphi + atanl(t*temp) + mod * PIL; + mod = (lphi + PIO2L)/PIL; + t = t * ( 1.0L + temp )/( 1.0L - temp * t * t ); + c = 0.5L*( a - b ); + temp = sqrtl( a * b ); + a = 0.5L*( a + b ); + b = temp; + d += d; + e += c * sinl(lphi); + } + +temp = E / ellpkl( 1.0L - m ); +temp *= (atanl(t) + mod * PIL)/(d * a); +temp += e; + +done: + +if( sign < 0 ) + temp = -temp; +temp += npio2 * E; +return( temp ); +} diff --git a/libm/ldouble/ellikl.c b/libm/ldouble/ellikl.c new file mode 100644 index 000000000..4eeffe0f5 --- /dev/null +++ b/libm/ldouble/ellikl.c @@ -0,0 +1,148 @@ +/* ellikl.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * long double phi, m, y, ellikl(); + * + * y = ellikl( phi, m ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * + * phi + * - + * | | + * | dt + * F(phi_\m) = | ------------------ + * | 2 + * | | sqrt( 1 - m sin t ) + * - + * 0 + * + * of amplitude phi and modulus m, using the arithmetic - + * geometric mean algorithm. + * + * + * + * + * ACCURACY: + * + * Tested at random points with m in [0, 1] and phi as indicated. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 30000 3.6e-18 4.1e-19 + * + * + */ + + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1984, 1987, 1995 by Stephen L. Moshier +*/ + +/* Incomplete elliptic integral of first kind */ + +#include <math.h> +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double fabsl ( long double ); +extern long double logl ( long double ); +extern long double tanl ( long double ); +extern long double atanl ( long double ); +extern long double floorl ( long double ); +extern long double ellpkl ( long double ); +long double ellikl ( long double, long double ); +#else +long double sqrtl(), fabsl(), logl(), tanl(), atanl(), floorl(), ellpkl(); +long double ellikl(); +#endif +extern long double PIL, PIO2L, MACHEPL, MAXNUML; + +long double ellikl( phi, m ) +long double phi, m; +{ +long double a, b, c, e, temp, t, K; +int d, mod, sign, npio2; + +if( m == 0.0L ) + return( phi ); +a = 1.0L - m; +if( a == 0.0L ) + { + if( fabsl(phi) >= PIO2L ) + { + mtherr( "ellikl", SING ); + return( MAXNUML ); + } + return( logl( tanl( 0.5L*(PIO2L + phi) ) ) ); + } +npio2 = floorl( phi/PIO2L ); +if( npio2 & 1 ) + npio2 += 1; +if( npio2 ) + { + K = ellpkl( a ); + phi = phi - npio2 * PIO2L; + } +else + K = 0.0L; +if( phi < 0.0L ) + { + phi = -phi; + sign = -1; + } +else + sign = 0; +b = sqrtl(a); +t = tanl( phi ); +if( fabsl(t) > 10.0L ) + { + /* Transform the amplitude */ + e = 1.0L/(b*t); + /* ... but avoid multiple recursions. */ + if( fabsl(e) < 10.0L ) + { + e = atanl(e); + if( npio2 == 0 ) + K = ellpkl( a ); + temp = K - ellikl( e, m ); + goto done; + } + } +a = 1.0L; +c = sqrtl(m); +d = 1; +mod = 0; + +while( fabsl(c/a) > MACHEPL ) + { + temp = b/a; + phi = phi + atanl(t*temp) + mod * PIL; + mod = (phi + PIO2L)/PIL; + t = t * ( 1.0L + temp )/( 1.0L - temp * t * t ); + c = 0.5L * ( a - b ); + temp = sqrtl( a * b ); + a = 0.5L * ( a + b ); + b = temp; + d += d; + } + +temp = (atanl(t) + mod * PIL)/(d * a); + +done: +if( sign < 0 ) + temp = -temp; +temp += npio2 * K; +return( temp ); +} diff --git a/libm/ldouble/ellpel.c b/libm/ldouble/ellpel.c new file mode 100644 index 000000000..6965db066 --- /dev/null +++ b/libm/ldouble/ellpel.c @@ -0,0 +1,173 @@ +/* ellpel.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * long double m1, y, ellpel(); + * + * y = ellpel( m1 ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * pi/2 + * - + * | | 2 + * E(m) = | sqrt( 1 - m sin t ) dt + * | | + * - + * 0 + * + * Where m = 1 - m1, using the approximation + * + * P(x) - x log x Q(x). + * + * Though there are no singularities, the argument m1 is used + * rather than m for compatibility with ellpk(). + * + * E(1) = 1; E(0) = pi/2. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 1 10000 1.1e-19 3.5e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpel domain x<0, x>1 0.0 + * + */ + +/* ellpe.c */ + +/* Elliptic integral of second kind */ + +/* +Cephes Math Library, Release 2.3: October, 1995 +Copyright 1984, 1987, 1989, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +#if UNK +static long double P[12] = { + 3.198937812032341294902E-5L, + 7.742523238588775116241E-4L, + 4.140384701571542000550E-3L, + 7.963509564694454269086E-3L, + 7.280911706839967541799E-3L, + 5.044067167184043853799E-3L, + 5.076832243257395296304E-3L, + 7.155775630578315248130E-3L, + 1.154485760526450950611E-2L, + 2.183137319801117971860E-2L, + 5.680519271556930583433E-2L, + 4.431471805599467050354E-1L, +}; +static long double Q[12] = { + 6.393938134301205485085E-6L, + 2.741404591220851603273E-4L, + 2.480876752984331133799E-3L, + 8.770638497964078750003E-3L, + 1.676835725889463343319E-2L, + 2.281970801531577700830E-2L, + 2.767367465121309044166E-2L, + 3.364167778770018154356E-2L, + 4.272453406734691973083E-2L, + 5.859374951483909267451E-2L, + 9.374999999923942267270E-2L, + 2.499999999999998643587E-1L, +}; +#endif +#if IBMPC +static short P[] = { +0x7a78,0x5a02,0x554d,0x862c,0x3ff0, XPD +0x34db,0xa965,0x31a3,0xcaf7,0x3ff4, XPD +0xca6c,0x6c00,0x1071,0x87ac,0x3ff7, XPD +0x4cdb,0x125d,0x6149,0x8279,0x3ff8, XPD +0xadbd,0x3d8f,0xb6d5,0xee94,0x3ff7, XPD +0x8189,0xcd0e,0xb3c2,0xa548,0x3ff7, XPD +0x32b5,0xdd64,0x8e39,0xa65b,0x3ff7, XPD +0x0344,0xc9db,0xff27,0xea7a,0x3ff7, XPD +0xba2d,0x806a,0xa476,0xbd26,0x3ff8, XPD +0xc3e0,0x30fa,0xb53d,0xb2d7,0x3ff9, XPD +0x23b8,0x4d33,0x8fcf,0xe8ac,0x3ffa, XPD +0xbc79,0xa39f,0x2fef,0xe2e4,0x3ffd, XPD +}; +static short Q[] = { +0x89f1,0xe234,0x82a6,0xd68b,0x3fed, XPD +0x202a,0x96b3,0x8273,0x8fba,0x3ff3, XPD +0xc183,0xfc45,0x3484,0xa296,0x3ff6, XPD +0x683e,0xe201,0xb960,0x8fb2,0x3ff8, XPD +0x721a,0x1b6a,0xcb41,0x895d,0x3ff9, XPD +0x4eee,0x295f,0x6574,0xbaf0,0x3ff9, XPD +0x3ade,0xc98f,0xe6f2,0xe2b3,0x3ff9, XPD +0xd470,0x1784,0xdb1e,0x89cb,0x3ffa, XPD +0xa649,0xe5c1,0xebc8,0xaeff,0x3ffa, XPD +0x84c0,0xa8f5,0xffde,0xefff,0x3ffa, XPD +0x5506,0xf94f,0xffff,0xbfff,0x3ffb, XPD +0xd8e7,0xffff,0xffff,0xffff,0x3ffc, XPD +}; +#endif +#if MIEEE +static long P[36] = { +0x3ff00000,0x862c554d,0x5a027a78, +0x3ff40000,0xcaf731a3,0xa96534db, +0x3ff70000,0x87ac1071,0x6c00ca6c, +0x3ff80000,0x82796149,0x125d4cdb, +0x3ff70000,0xee94b6d5,0x3d8fadbd, +0x3ff70000,0xa548b3c2,0xcd0e8189, +0x3ff70000,0xa65b8e39,0xdd6432b5, +0x3ff70000,0xea7aff27,0xc9db0344, +0x3ff80000,0xbd26a476,0x806aba2d, +0x3ff90000,0xb2d7b53d,0x30fac3e0, +0x3ffa0000,0xe8ac8fcf,0x4d3323b8, +0x3ffd0000,0xe2e42fef,0xa39fbc79, +}; +static long Q[36] = { +0x3fed0000,0xd68b82a6,0xe23489f1, +0x3ff30000,0x8fba8273,0x96b3202a, +0x3ff60000,0xa2963484,0xfc45c183, +0x3ff80000,0x8fb2b960,0xe201683e, +0x3ff90000,0x895dcb41,0x1b6a721a, +0x3ff90000,0xbaf06574,0x295f4eee, +0x3ff90000,0xe2b3e6f2,0xc98f3ade, +0x3ffa0000,0x89cbdb1e,0x1784d470, +0x3ffa0000,0xaeffebc8,0xe5c1a649, +0x3ffa0000,0xefffffde,0xa8f584c0, +0x3ffb0000,0xbfffffff,0xf94f5506, +0x3ffc0000,0xffffffff,0xffffd8e7, +}; +#endif + +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double logl ( long double ); +#else +long double polevll(), logl(); +#endif + +long double ellpel(x) +long double x; +{ + +if( (x <= 0.0L) || (x > 1.0L) ) + { + if( x == 0.0L ) + return( 1.0L ); + mtherr( "ellpel", DOMAIN ); + return( 0.0L ); + } +return( 1.0L + x * polevll(x,P,11) - logl(x) * (x * polevll(x,Q,11)) ); +} diff --git a/libm/ldouble/ellpjl.c b/libm/ldouble/ellpjl.c new file mode 100644 index 000000000..bb57fe6a1 --- /dev/null +++ b/libm/ldouble/ellpjl.c @@ -0,0 +1,164 @@ +/* ellpjl.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * long double u, m, sn, cn, dn, phi; + * int ellpjl(); + * + * ellpjl( u, m, _&sn, _&cn, _&dn, _&phi ); + * + * + * + * DESCRIPTION: + * + * + * Evaluates the Jacobian elliptic functions sn(u|m), cn(u|m), + * and dn(u|m) of parameter m between 0 and 1, and real + * argument u. + * + * These functions are periodic, with quarter-period on the + * real axis equal to the complete elliptic integral + * ellpk(1.0-m). + * + * Relation to incomplete elliptic integral: + * If u = ellik(phi,m), then sn(u|m) = sin(phi), + * and cn(u|m) = cos(phi). Phi is called the amplitude of u. + * + * Computation is by means of the arithmetic-geometric mean + * algorithm, except when m is within 1e-12 of 0 or 1. In the + * latter case with m close to 1, the approximation applies + * only for phi < pi/2. + * + * ACCURACY: + * + * Tested at random points with u between 0 and 10, m between + * 0 and 1. + * + * Absolute error (* = relative error): + * arithmetic function # trials peak rms + * IEEE sn 10000 1.7e-18 2.3e-19 + * IEEE cn 20000 1.6e-18 2.2e-19 + * IEEE dn 10000 4.7e-15 2.7e-17 + * IEEE phi 10000 4.0e-19* 6.6e-20* + * + * Accuracy deteriorates when u is large. + * + */ + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1984, 1987, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double fabsl ( long double ); +extern long double sinl ( long double ); +extern long double cosl ( long double ); +extern long double asinl ( long double ); +extern long double tanhl ( long double ); +extern long double sinhl ( long double ); +extern long double coshl ( long double ); +extern long double atanl ( long double ); +extern long double expl ( long double ); +#else +long double sqrtl(), fabsl(), sinl(), cosl(), asinl(), tanhl(); +long double sinhl(), coshl(), atanl(), expl(); +#endif +extern long double PIO2L, MACHEPL; + +int ellpjl( u, m, sn, cn, dn, ph ) +long double u, m; +long double *sn, *cn, *dn, *ph; +{ +long double ai, b, phi, t, twon; +long double a[9], c[9]; +int i; + + +/* Check for special cases */ + +if( m < 0.0L || m > 1.0L ) + { + mtherr( "ellpjl", DOMAIN ); + *sn = 0.0L; + *cn = 0.0L; + *ph = 0.0L; + *dn = 0.0L; + return(-1); + } +if( m < 1.0e-12L ) + { + t = sinl(u); + b = cosl(u); + ai = 0.25L * m * (u - t*b); + *sn = t - ai*b; + *cn = b + ai*t; + *ph = u - ai; + *dn = 1.0L - 0.5L*m*t*t; + return(0); + } + +if( m >= 0.999999999999L ) + { + ai = 0.25L * (1.0L-m); + b = coshl(u); + t = tanhl(u); + phi = 1.0L/b; + twon = b * sinhl(u); + *sn = t + ai * (twon - u)/(b*b); + *ph = 2.0L*atanl(expl(u)) - PIO2L + ai*(twon - u)/b; + ai *= t * phi; + *cn = phi - ai * (twon - u); + *dn = phi + ai * (twon + u); + return(0); + } + + +/* A. G. M. scale */ +a[0] = 1.0L; +b = sqrtl(1.0L - m); +c[0] = sqrtl(m); +twon = 1.0L; +i = 0; + +while( fabsl(c[i]/a[i]) > MACHEPL ) + { + if( i > 7 ) + { + mtherr( "ellpjl", OVERFLOW ); + goto done; + } + ai = a[i]; + ++i; + c[i] = 0.5L * ( ai - b ); + t = sqrtl( ai * b ); + a[i] = 0.5L * ( ai + b ); + b = t; + twon *= 2.0L; + } + +done: + +/* backward recurrence */ +phi = twon * a[i] * u; +do + { + t = c[i] * sinl(phi) / a[i]; + b = phi; + phi = 0.5L * (asinl(t) + phi); + } +while( --i ); + +*sn = sinl(phi); +t = cosl(phi); +*cn = t; +*dn = t/cosl(phi-b); +*ph = phi; +return(0); +} diff --git a/libm/ldouble/ellpkl.c b/libm/ldouble/ellpkl.c new file mode 100644 index 000000000..dd42ac861 --- /dev/null +++ b/libm/ldouble/ellpkl.c @@ -0,0 +1,203 @@ +/* ellpkl.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * long double m1, y, ellpkl(); + * + * y = ellpkl( m1 ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * + * + * pi/2 + * - + * | | + * | dt + * K(m) = | ------------------ + * | 2 + * | | sqrt( 1 - m sin t ) + * - + * 0 + * + * where m = 1 - m1, using the approximation + * + * P(x) - log x Q(x). + * + * The argument m1 is used rather than m so that the logarithmic + * singularity at m = 1 will be shifted to the origin; this + * preserves maximum accuracy. + * + * K(0) = pi/2. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 10000 1.1e-19 3.3e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpkl domain x<0, x>1 0.0 + * + */ + +/* ellpkl.c */ + + +/* +Cephes Math Library, Release 2.3: October, 1995 +Copyright 1984, 1987, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +#if UNK +static long double P[13] = { + 1.247539729154838838628E-6L, + 2.149421654232011240659E-4L, + 2.265267575136470585139E-3L, + 6.723088676584254248821E-3L, + 8.092066790639263075808E-3L, + 5.664069509748147028621E-3L, + 4.579865994050801042865E-3L, + 5.797368411662027645234E-3L, + 8.767698209432225911803E-3L, + 1.493761594388688915057E-2L, + 3.088514457872042326871E-2L, + 9.657359027999314232753E-2L, + 1.386294361119890618992E0L, +}; +static long double Q[12] = { + 5.568631677757315398993E-5L, + 1.036110372590318802997E-3L, + 5.500459122138244213579E-3L, + 1.337330436245904844528E-2L, + 2.033103735656990487115E-2L, + 2.522868345512332304268E-2L, + 3.026786461242788135379E-2L, + 3.738370118296930305919E-2L, + 4.882812208418620146046E-2L, + 7.031249999330222751046E-2L, + 1.249999999999978263154E-1L, + 4.999999999999999999924E-1L, +}; +static long double C1 = 1.386294361119890618834L; /* log(4) */ +#endif +#if IBMPC +static short P[] = { +0xf098,0xad01,0x2381,0xa771,0x3feb, XPD +0xd6ed,0xea22,0x1922,0xe162,0x3ff2, XPD +0x3733,0xe2f1,0xe226,0x9474,0x3ff6, XPD +0x3031,0x3c9d,0x5aff,0xdc4d,0x3ff7, XPD +0x9a46,0x4310,0x968e,0x8494,0x3ff8, XPD +0xbe4c,0x3ff2,0xa8a7,0xb999,0x3ff7, XPD +0xf35c,0x0eaf,0xb355,0x9612,0x3ff7, XPD +0xbc56,0x8fd4,0xd9dd,0xbdf7,0x3ff7, XPD +0xc01e,0x867f,0x6444,0x8fa6,0x3ff8, XPD +0x4ba3,0x6392,0xe6fd,0xf4bc,0x3ff8, XPD +0x62c3,0xbb12,0xd7bc,0xfd02,0x3ff9, XPD +0x08fe,0x476c,0x5fdf,0xc5c8,0x3ffb, XPD +0x79ad,0xd1cf,0x17f7,0xb172,0x3fff, XPD +}; +static short Q[] = { +0x96a4,0x8474,0xba33,0xe990,0x3ff0, XPD +0xe5a7,0xa50e,0x1854,0x87ce,0x3ff5, XPD +0x8999,0x72e3,0x3205,0xb43d,0x3ff7, XPD +0x3255,0x13eb,0xb438,0xdb1b,0x3ff8, XPD +0xb717,0x497f,0x4691,0xa68d,0x3ff9, XPD +0x30be,0x8c6b,0x624b,0xceac,0x3ff9, XPD +0xa858,0x2a0d,0x5014,0xf7f4,0x3ff9, XPD +0x8615,0xbfa6,0xa6df,0x991f,0x3ffa, XPD +0x103c,0xa076,0xff37,0xc7ff,0x3ffa, XPD +0xf508,0xc515,0xffff,0x8fff,0x3ffb, XPD +0x1af5,0xfffb,0xffff,0xffff,0x3ffb, XPD +0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD +}; +static unsigned short ac1[] = { +0x79ac,0xd1cf,0x17f7,0xb172,0x3fff, XPD +}; +#define C1 (*(long double *)ac1) +#endif + +#ifdef MIEEE +static long P[39] = { +0x3feb0000,0xa7712381,0xad01f098, +0x3ff20000,0xe1621922,0xea22d6ed, +0x3ff60000,0x9474e226,0xe2f13733, +0x3ff70000,0xdc4d5aff,0x3c9d3031, +0x3ff80000,0x8494968e,0x43109a46, +0x3ff70000,0xb999a8a7,0x3ff2be4c, +0x3ff70000,0x9612b355,0x0eaff35c, +0x3ff70000,0xbdf7d9dd,0x8fd4bc56, +0x3ff80000,0x8fa66444,0x867fc01e, +0x3ff80000,0xf4bce6fd,0x63924ba3, +0x3ff90000,0xfd02d7bc,0xbb1262c3, +0x3ffb0000,0xc5c85fdf,0x476c08fe, +0x3fff0000,0xb17217f7,0xd1cf79ad, +}; +static long Q[36] = { +0x3ff00000,0xe990ba33,0x847496a4, +0x3ff50000,0x87ce1854,0xa50ee5a7, +0x3ff70000,0xb43d3205,0x72e38999, +0x3ff80000,0xdb1bb438,0x13eb3255, +0x3ff90000,0xa68d4691,0x497fb717, +0x3ff90000,0xceac624b,0x8c6b30be, +0x3ff90000,0xf7f45014,0x2a0da858, +0x3ffa0000,0x991fa6df,0xbfa68615, +0x3ffa0000,0xc7ffff37,0xa076103c, +0x3ffb0000,0x8fffffff,0xc515f508, +0x3ffb0000,0xffffffff,0xfffb1af5, +0x3ffe0000,0x80000000,0x00000000, +}; +static unsigned long ac1[] = { +0x3fff0000,0xb17217f7,0xd1cf79ac +}; +#define C1 (*(long double *)ac1) +#endif + + +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double logl ( long double ); +#else +long double polevll(), logl(); +#endif +extern long double MACHEPL, MAXNUML; + +long double ellpkl(x) +long double x; +{ + +if( (x < 0.0L) || (x > 1.0L) ) + { + mtherr( "ellpkl", DOMAIN ); + return( 0.0L ); + } + +if( x > MACHEPL ) + { + return( polevll(x,P,12) - logl(x) * polevll(x,Q,11) ); + } +else + { + if( x == 0.0L ) + { + mtherr( "ellpkl", SING ); + return( MAXNUML ); + } + else + { + return( C1 - 0.5L * logl(x) ); + } + } +} diff --git a/libm/ldouble/exp10l.c b/libm/ldouble/exp10l.c new file mode 100644 index 000000000..b837571b4 --- /dev/null +++ b/libm/ldouble/exp10l.c @@ -0,0 +1,192 @@ +/* exp10l.c + * + * Base 10 exponential function, long double precision + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * long double x, y, exp10l() + * + * y = exp10l( x ); + * + * + * + * DESCRIPTION: + * + * Returns 10 raised to the x power. + * + * Range reduction is accomplished by expressing the argument + * as 10**x = 2**n 10**f, with |f| < 0.5 log10(2). + * The Pade' form + * + * 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + * + * is used to approximate 10**f. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4900 30000 1.0e-19 2.7e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10l underflow x < -MAXL10 0.0 + * exp10l overflow x > MAXL10 MAXNUM + * + * IEEE arithmetic: MAXL10 = 4932.0754489586679023819 + * + */ + +/* +Cephes Math Library Release 2.2: January, 1991 +Copyright 1984, 1991 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 3.1341179396892496811523E1L, + 4.5618283154904699073999E3L, + 1.3433113468542797218610E5L, + 7.6025447914440301593592E5L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0,*/ + 4.7705440288425157637739E2L, + 2.9732606548049614870598E4L, + 4.0843697951001026189583E5L, + 6.6034865026929015925608E5L, +}; +/*static long double LOG102 = 3.0102999566398119521373889e-1L;*/ +static long double LOG210 = 3.3219280948873623478703L; +static long double LG102A = 3.01025390625e-1L; +static long double LG102B = 4.6050389811952137388947e-6L; +#endif + + +#ifdef IBMPC +static short P[] = { +0x399a,0x7dc7,0xbc43,0xfaba,0x4003, XPD +0xb526,0xdf32,0xa063,0x8e8e,0x400b, XPD +0x18da,0xafa1,0xc89e,0x832e,0x4010, XPD +0x503d,0x9352,0xe7aa,0xb99b,0x4012, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x947d,0x7855,0xf6ac,0xee86,0x4007, XPD +0x18cf,0x7749,0x368d,0xe849,0x400d, XPD +0x85be,0x2560,0x9f58,0xc76e,0x4011, XPD +0x6d3c,0x80c5,0xca67,0xa137,0x4012, XPD +}; +/* +static short L102[] = {0xf799,0xfbcf,0x9a84,0x9a20,0x3ffd, XPD}; +#define LOG102 *(long double *)L102 +*/ +static short L210[] = {0x8afe,0xcd1b,0x784b,0xd49a,0x4000, XPD}; +#define LOG210 *(long double *)L210 +static short L102A[] = {0x0000,0x0000,0x0000,0x9a20,0x3ffd, XPD}; +#define LG102A *(long double *)L102A +static short L102B[] = {0x8f89,0xf798,0xfbcf,0x9a84,0x3fed, XPD}; +#define LG102B *(long double *)L102B +#endif + +#ifdef MIEEE +static long P[] = { +0x40030000,0xfababc43,0x7dc7399a, +0x400b0000,0x8e8ea063,0xdf32b526, +0x40100000,0x832ec89e,0xafa118da, +0x40120000,0xb99be7aa,0x9352503d, +}; +static long Q[] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40070000,0xee86f6ac,0x7855947d, +0x400d0000,0xe849368d,0x774918cf, +0x40110000,0xc76e9f58,0x256085be, +0x40120000,0xa137ca67,0x80c56d3c, +}; +/* +static long L102[] = {0x3ffd0000,0x9a209a84,0xfbcff799}; +#define LOG102 *(long double *)L102 +*/ +static long L210[] = {0x40000000,0xd49a784b,0xcd1b8afe}; +#define LOG210 *(long double *)L210 +static long L102A[] = {0x3ffd0000,0x9a200000,0x00000000}; +#define LG102A *(long double *)L102A +static long L102B[] = {0x3fed0000,0x9a84fbcf,0xf7988f89}; +#define LG102B *(long double *)L102B +#endif + +static long double MAXL10 = 4.9320754489586679023819e3L; +extern long double MAXNUML; +#ifdef ANSIPROT +extern long double floorl ( long double ); +extern long double ldexpl ( long double, int ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +#else +long double floorl(), ldexpl(), polevll(), p1evll(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif + +long double exp10l(x) +long double x; +{ +long double px, xx; +short n; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +if( x > MAXL10 ) + { +#ifdef INFINITIES + return( INFINITYL ); +#else + mtherr( "exp10l", OVERFLOW ); + return( MAXNUML ); +#endif + } + +if( x < -MAXL10 ) /* Would like to use MINLOG but can't */ + { +#ifndef INFINITIES + mtherr( "exp10l", UNDERFLOW ); +#endif + return(0.0L); + } + +/* Express 10**x = 10**g 2**n + * = 10**g 10**( n log10(2) ) + * = 10**( g + n log10(2) ) + */ +px = floorl( LOG210 * x + 0.5L ); +n = px; +x -= px * LG102A; +x -= px * LG102B; + +/* rational approximation for exponential + * of the fractional part: + * 10**x = 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + */ +xx = x * x; +px = x * polevll( xx, P, 3 ); +x = px/( p1evll( xx, Q, 4 ) - px ); +x = 1.0L + ldexpl( x, 1 ); + +/* multiply by power of 2 */ +x = ldexpl( x, n ); +return(x); +} diff --git a/libm/ldouble/exp2l.c b/libm/ldouble/exp2l.c new file mode 100644 index 000000000..076f8bca5 --- /dev/null +++ b/libm/ldouble/exp2l.c @@ -0,0 +1,166 @@ +/* exp2l.c + * + * Base 2 exponential function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, exp2l(); + * + * y = exp2l( x ); + * + * + * + * DESCRIPTION: + * + * Returns 2 raised to the x power. + * + * Range reduction is accomplished by separating the argument + * into an integer k and fraction f such that + * x k f + * 2 = 2 2. + * + * A Pade' form + * + * 1 + 2x P(x**2) / (Q(x**2) - x P(x**2) ) + * + * approximates 2**x in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-16300 300000 9.1e-20 2.6e-20 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp2l underflow x < -16382 0.0 + * exp2l overflow x >= 16384 MAXNUM + * + */ + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + + + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 6.0614853552242266094567E1L, + 3.0286971917562792508623E4L, + 2.0803843631901852422887E6L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0,*/ + 1.7492876999891839021063E3L, + 3.2772515434906797273099E5L, + 6.0027204078348487957118E6L, +}; +#endif + + +#ifdef IBMPC +static short P[] = { +0xffd8,0x6ad6,0x9c2b,0xf275,0x4004, XPD +0x3426,0x2dc5,0xf19f,0xec9d,0x400d, XPD +0x7ec0,0xd041,0x02e7,0xfdf4,0x4013, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x575b,0x9b93,0x34d6,0xdaa9,0x4009, XPD +0xe38d,0x6d74,0xa4f0,0xa005,0x4011, XPD +0xb37e,0xcfba,0x40d0,0xb730,0x4015, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x40040000,0xf2759c2b,0x6ad6ffd8, +0x400d0000,0xec9df19f,0x2dc53426, +0x40130000,0xfdf402e7,0xd0417ec0, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40090000,0xdaa934d6,0x9b93575b, +0x40110000,0xa005a4f0,0x6d74e38d, +0x40150000,0xb73040d0,0xcfbab37e, +}; +#endif + +#define MAXL2L 16384.0L +#define MINL2L -16382.0L + + +extern long double MAXNUML; +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double floorl ( long double ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +#else +long double polevll(), p1evll(), floorl(), ldexpl(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif + +long double exp2l(x) +long double x; +{ +long double px, xx; +int n; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +if( x > MAXL2L) + { +#ifdef INFINITIES + return( INFINITYL ); +#else + mtherr( "exp2l", OVERFLOW ); + return( MAXNUML ); +#endif + } + +if( x < MINL2L ) + { +#ifndef INFINITIES + mtherr( "exp2l", UNDERFLOW ); +#endif + return(0.0L); + } + +xx = x; /* save x */ +/* separate into integer and fractional parts */ +px = floorl(x+0.5L); +n = px; +x = x - px; + +/* rational approximation + * exp2(x) = 1.0 + 2xP(xx)/(Q(xx) - P(xx)) + * where xx = x**2 + */ +xx = x * x; +px = x * polevll( xx, P, 2 ); +x = px / ( p1evll( xx, Q, 3 ) - px ); +x = 1.0L + ldexpl( x, 1 ); + +/* scale by power of 2 */ +x = ldexpl( x, n ); +return(x); +} diff --git a/libm/ldouble/expl.c b/libm/ldouble/expl.c new file mode 100644 index 000000000..524246987 --- /dev/null +++ b/libm/ldouble/expl.c @@ -0,0 +1,183 @@ +/* expl.c + * + * Exponential function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, expl(); + * + * y = expl( x ); + * + * + * + * DESCRIPTION: + * + * Returns e (2.71828...) raised to the x power. + * + * Range reduction is accomplished by separating the argument + * into an integer k and fraction f such that + * + * x k f + * e = 2 e. + * + * A Pade' form of degree 2/3 is used to approximate exp(f) - 1 + * in the basic range [-0.5 ln 2, 0.5 ln 2]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-10000 50000 1.12e-19 2.81e-20 + * + * + * Error amplification in the exponential function can be + * a serious matter. The error propagation involves + * exp( X(1+delta) ) = exp(X) ( 1 + X*delta + ... ), + * which shows that a 1 lsb error in representing X produces + * a relative error of X times 1 lsb in the function. + * While the routine gives an accurate result for arguments + * that are exactly represented by a long double precision + * computer number, the result contains amplified roundoff + * error for large arguments not exactly represented. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < MINLOG 0.0 + * exp overflow x > MAXLOG MAXNUM + * + */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1990, 1998 by Stephen L. Moshier +*/ + + +/* Exponential function */ + +#include <math.h> + +#ifdef UNK +static long double P[3] = { + 1.2617719307481059087798E-4L, + 3.0299440770744196129956E-2L, + 9.9999999999999999991025E-1L, +}; +static long double Q[4] = { + 3.0019850513866445504159E-6L, + 2.5244834034968410419224E-3L, + 2.2726554820815502876593E-1L, + 2.0000000000000000000897E0L, +}; +static long double C1 = 6.9314575195312500000000E-1L; +static long double C2 = 1.4286068203094172321215E-6L; +#endif + +#ifdef DEC +not supported in long double precision +#endif + +#ifdef IBMPC +static short P[] = { +0x424e,0x225f,0x6eaf,0x844e,0x3ff2, XPD +0xf39e,0x5163,0x8866,0xf836,0x3ff9, XPD +0xfffe,0xffff,0xffff,0xffff,0x3ffe, XPD +}; +static short Q[] = { +0xff1e,0xb2fc,0xb5e1,0xc975,0x3fec, XPD +0xff3e,0x45b5,0xcda8,0xa571,0x3ff6, XPD +0x9ee1,0x3f03,0x4cc4,0xe8b8,0x3ffc, XPD +0x0000,0x0000,0x0000,0x8000,0x4000, XPD +}; +static short sc1[] = {0x0000,0x0000,0x0000,0xb172,0x3ffe, XPD}; +#define C1 (*(long double *)sc1) +static short sc2[] = {0x4f1e,0xcd5e,0x8e7b,0xbfbe,0x3feb, XPD}; +#define C2 (*(long double *)sc2) +#endif + +#ifdef MIEEE +static long P[9] = { +0x3ff20000,0x844e6eaf,0x225f424e, +0x3ff90000,0xf8368866,0x5163f39e, +0x3ffe0000,0xffffffff,0xfffffffe, +}; +static long Q[12] = { +0x3fec0000,0xc975b5e1,0xb2fcff1e, +0x3ff60000,0xa571cda8,0x45b5ff3e, +0x3ffc0000,0xe8b84cc4,0x3f039ee1, +0x40000000,0x80000000,0x00000000, +}; +static long sc1[] = {0x3ffe0000,0xb1720000,0x00000000}; +#define C1 (*(long double *)sc1) +static long sc2[] = {0x3feb0000,0xbfbe8e7b,0xcd5e4f1e}; +#define C2 (*(long double *)sc2) +#endif + +extern long double LOG2EL, MAXLOGL, MINLOGL, MAXNUML; +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double floorl ( long double ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +#else +long double polevll(), floorl(), ldexpl(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif + +long double expl(x) +long double x; +{ +long double px, xx; +int n; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +if( x > MAXLOGL) + { +#ifdef INFINITIES + return( INFINITYL ); +#else + mtherr( "expl", OVERFLOW ); + return( MAXNUML ); +#endif + } + +if( x < MINLOGL ) + { +#ifndef INFINITIES + mtherr( "expl", UNDERFLOW ); +#endif + return(0.0L); + } + +/* Express e**x = e**g 2**n + * = e**g e**( n loge(2) ) + * = e**( g + n loge(2) ) + */ +px = floorl( LOG2EL * x + 0.5L ); /* floor() truncates toward -infinity. */ +n = px; +x -= px * C1; +x -= px * C2; + + +/* rational approximation for exponential + * of the fractional part: + * e**x = 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + */ +xx = x * x; +px = x * polevll( xx, P, 2 ); +x = px/( polevll( xx, Q, 3 ) - px ); +x = 1.0L + ldexpl( x, 1 ); + +x = ldexpl( x, n ); +return(x); +} diff --git a/libm/ldouble/fdtrl.c b/libm/ldouble/fdtrl.c new file mode 100644 index 000000000..da2f8910a --- /dev/null +++ b/libm/ldouble/fdtrl.c @@ -0,0 +1,237 @@ +/* fdtrl.c + * + * F distribution, long double precision + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, y, fdtrl(); + * + * y = fdtrl( df1, df2, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from zero to x under the F density + * function (also known as Snedcor's density or the + * variance ratio density). This is the density + * of x = (u1/df1)/(u2/df2), where u1 and u2 are random + * variables having Chi square distributions with df1 + * and df2 degrees of freedom, respectively. + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbetl( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x + * x is nonnegative. + * + * ACCURACY: + * + * Tested at random points (a,b,x) in the indicated intervals. + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 1,100 10000 9.3e-18 2.9e-19 + * IEEE 0,1 1,10000 10000 1.9e-14 2.9e-15 + * IEEE 1,5 1,10000 10000 5.8e-15 1.4e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrl domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrcl() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, y, fdtrcl(); + * + * y = fdtrcl( df1, df2, x ); + * + * + * + * DESCRIPTION: + * + * Returns the area from x to infinity under the F density + * function (also known as Snedcor's density or the + * variance ratio density). + * + * + * inf. + * - + * 1 | | a-1 b-1 + * 1-P(x) = ------ | t (1-t) dt + * B(a,b) | | + * - + * x + * + * (See fdtr.c.) + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). + * + * + * ACCURACY: + * + * See incbet.c. + * Tested at random points (a,b,x). + * + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 0,100 10000 4.2e-18 3.3e-19 + * IEEE 0,1 1,10000 10000 7.2e-15 2.6e-16 + * IEEE 1,5 1,10000 10000 1.7e-14 3.0e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrcl domain a<0, b<0, x<0 0.0 + * + */ + /* fdtril() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * long double x, p, fdtril(); + * + * x = fdtril( df1, df2, p ); + * + * DESCRIPTION: + * + * Finds the F density argument x such that the integral + * from x to infinity of the F density is equal to the + * given probability p. + * + * This is accomplished using the inverse beta integral + * function and the relations + * + * z = incbi( df2/2, df1/2, p ) + * x = df2 (1-z) / (df1 z). + * + * Note: the following relations hold for the inverse of + * the uncomplemented F distribution: + * + * z = incbi( df1/2, df2/2, p ) + * x = df2 z / (df1 (1-z)). + * + * ACCURACY: + * + * See incbi.c. + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between .001 and 1: + * IEEE 1,100 40000 4.6e-18 2.7e-19 + * IEEE 1,10000 30000 1.7e-14 1.4e-16 + * For p between 10^-6 and .001: + * IEEE 1,100 20000 1.9e-15 3.9e-17 + * IEEE 1,10000 30000 2.7e-15 4.0e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtril domain p <= 0 or p > 1 0.0 + * v < 1 + */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + + +#include <math.h> +#ifdef ANSIPROT +extern long double incbetl ( long double, long double, long double ); +extern long double incbil ( long double, long double, long double ); +#else +long double incbetl(), incbil(); +#endif + +long double fdtrcl( ia, ib, x ) +int ia, ib; +long double x; +{ +long double a, b, w; + +if( (ia < 1) || (ib < 1) || (x < 0.0L) ) + { + mtherr( "fdtrcl", DOMAIN ); + return( 0.0L ); + } +a = ia; +b = ib; +w = b / (b + a * x); +return( incbetl( 0.5L*b, 0.5L*a, w ) ); +} + + + +long double fdtrl( ia, ib, x ) +int ia, ib; +long double x; +{ +long double a, b, w; + +if( (ia < 1) || (ib < 1) || (x < 0.0L) ) + { + mtherr( "fdtrl", DOMAIN ); + return( 0.0L ); + } +a = ia; +b = ib; +w = a * x; +w = w / (b + w); +return( incbetl(0.5L*a, 0.5L*b, w) ); +} + + +long double fdtril( ia, ib, y ) +int ia, ib; +long double y; +{ +long double a, b, w, x; + +if( (ia < 1) || (ib < 1) || (y <= 0.0L) || (y > 1.0L) ) + { + mtherr( "fdtril", DOMAIN ); + return( 0.0L ); + } +a = ia; +b = ib; +/* Compute probability for x = 0.5. */ +w = incbetl( 0.5L*b, 0.5L*a, 0.5L ); +/* If that is greater than y, then the solution w < .5. + Otherwise, solve at 1-y to remove cancellation in (b - b*w). */ +if( w > y || y < 0.001L) + { + w = incbil( 0.5L*b, 0.5L*a, y ); + x = (b - b*w)/(a*w); + } +else + { + w = incbil( 0.5L*a, 0.5L*b, 1.0L - y ); + x = b*w/(a*(1.0L-w)); + } +return(x); +} diff --git a/libm/ldouble/floorl.c b/libm/ldouble/floorl.c new file mode 100644 index 000000000..1abdfb2cd --- /dev/null +++ b/libm/ldouble/floorl.c @@ -0,0 +1,432 @@ +/* ceill() + * floorl() + * frexpl() + * ldexpl() + * fabsl() + * signbitl() + * isnanl() + * isfinitel() + * + * Floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * long double ceill(), floorl(), frexpl(), ldexpl(), fabsl(); + * int signbitl(), isnanl(), isfinitel(); + * long double x, y; + * int expnt, n; + * + * y = floorl(x); + * y = ceill(x); + * y = frexpl( x, &expnt ); + * y = ldexpl( x, n ); + * y = fabsl( x ); + * n = signbitl(x); + * n = isnanl(x); + * n = isfinitel(x); + * + * + * + * DESCRIPTION: + * + * The following routines return a long double precision floating point + * result: + * + * floorl() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * ceill() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * frexpl() extracts the exponent from x. It returns an integer + * power of two to expnt and the significand between 0.5 and 1 + * to y. Thus x = y * 2**expn. + * + * ldexpl() multiplies x by 2**n. + * + * fabsl() returns the absolute value of its argument. + * + * These functions are part of the standard C run time library + * for some but not all C compilers. The ones supplied are + * written in C for IEEE arithmetic. They should + * be used only if your compiler library does not already have + * them. + * + * The IEEE versions assume that denormal numbers are implemented + * in the arithmetic. Some modifications will be required if + * the arithmetic has abrupt rather than gradual underflow. + */ + + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1987, 1988, 1992, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +/* This is defined in mconf.h. */ +/* #define DENORMAL 1 */ + +#ifdef UNK +/* Change UNK into something else. */ +#undef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +#endif + +#ifdef IBMPC +#define EXPMSK 0x800f +#define MEXP 0x7ff +#define NBITS 64 +#endif + +#ifdef MIEEE +#define EXPMSK 0x800f +#define MEXP 0x7ff +#define NBITS 64 +#endif + +extern double MAXNUML; + +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double floorl ( long double ); +extern int isnanl ( long double ); +#else +long double fabsl(), floorl(); +int isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double fabsl(x) +long double x; +{ +union + { + long double d; + short i[6]; + } u; + +u.d = x; +#ifdef IBMPC + u.i[4] &= 0x7fff; +#endif +#ifdef MIEEE + u.i[0] &= 0x7fff; +#endif +return( u.d ); +} + + + +long double ceill(x) +long double x; +{ +long double y; + +#ifdef UNK +mtherr( "ceill", DOMAIN ); +return(0.0L); +#endif +#ifdef INFINITIES +if(x == -INFINITYL) + return(x); +#endif +#ifdef MINUSZERO +if(x == 0.0L) + return(x); +#endif +y = floorl(x); +if( y < x ) + y += 1.0L; +return(y); +} + + + + +/* Bit clearing masks: */ + +static unsigned short bmask[] = { +0xffff, +0xfffe, +0xfffc, +0xfff8, +0xfff0, +0xffe0, +0xffc0, +0xff80, +0xff00, +0xfe00, +0xfc00, +0xf800, +0xf000, +0xe000, +0xc000, +0x8000, +0x0000, +}; + + + + +long double floorl(x) +long double x; +{ +unsigned short *p; +union + { + long double y; + unsigned short sh[6]; + } u; +int e; + +#ifdef UNK +mtherr( "floor", DOMAIN ); +return(0.0L); +#endif +#ifdef INFINITIES +if( x == INFINITYL ) + return(x); +#endif +#ifdef MINUSZERO +if(x == 0.0L) + return(x); +#endif +u.y = x; +/* find the exponent (power of 2) */ +#ifdef IBMPC +p = (unsigned short *)&u.sh[4]; +e = (*p & 0x7fff) - 0x3fff; +p -= 4; +#endif + +#ifdef MIEEE +p = (unsigned short *)&u.sh[0]; +e = (*p & 0x7fff) - 0x3fff; +p += 5; +#endif + +if( e < 0 ) + { + if( u.y < 0.0L ) + return( -1.0L ); + else + return( 0.0L ); + } + +e = (NBITS -1) - e; +/* clean out 16 bits at a time */ +while( e >= 16 ) + { +#ifdef IBMPC + *p++ = 0; +#endif + +#ifdef MIEEE + *p-- = 0; +#endif + e -= 16; + } + +/* clear the remaining bits */ +if( e > 0 ) + *p &= bmask[e]; + +if( (x < 0) && (u.y != x) ) + u.y -= 1.0L; + +return(u.y); +} + + + +long double frexpl( x, pw2 ) +long double x; +int *pw2; +{ +union + { + long double y; + unsigned short sh[6]; + } u; +int i, k; +short *q; + +u.y = x; + +#ifdef NANS +if(isnanl(x)) + { + *pw2 = 0; + return(x); + } +#endif +#ifdef INFINITIES +if(x == -INFINITYL) + { + *pw2 = 0; + return(x); + } +#endif +#ifdef MINUSZERO +if(x == 0.0L) + { + *pw2 = 0; + return(x); + } +#endif + +#ifdef UNK +mtherr( "frexpl", DOMAIN ); +return(0.0L); +#endif + +/* find the exponent (power of 2) */ +#ifdef IBMPC +q = (short *)&u.sh[4]; +i = *q & 0x7fff; +#endif + +#ifdef MIEEE +q = (short *)&u.sh[0]; +i = *q & 0x7fff; +#endif + +if( i == 0 ) + { + if( u.y == 0.0L ) + { + *pw2 = 0; + return(0.0L); + } +/* Number is denormal or zero */ +#ifdef DENORMAL +/* Handle denormal number. */ +do + { + u.y *= 2.0L; + i -= 1; + k = *q & 0x7fff; + } +while( (k == 0) && (i > -66) ); +i = i + k; +#else + *pw2 = 0; + return(0.0L); +#endif /* DENORMAL */ + } + +*pw2 = i - 0x3ffe; +/* *q = 0x3ffe; */ +/* Preserve sign of argument. */ +*q &= 0x8000; +*q |= 0x3ffe; +return( u.y ); +} + + + + + + +long double ldexpl( x, pw2 ) +long double x; +int pw2; +{ +union + { + long double y; + unsigned short sh[6]; + } u; +unsigned short *q; +long e; + +#ifdef UNK +mtherr( "ldexp", DOMAIN ); +return(0.0L); +#endif + +u.y = x; +#ifdef IBMPC +q = (unsigned short *)&u.sh[4]; +#endif +#ifdef MIEEE +q = (unsigned short *)&u.sh[0]; +#endif +while( (e = (*q & 0x7fffL)) == 0 ) + { +#ifdef DENORMAL + if( u.y == 0.0L ) + { + return( 0.0L ); + } +/* Input is denormal. */ + if( pw2 > 0 ) + { + u.y *= 2.0L; + pw2 -= 1; + } + if( pw2 < 0 ) + { + if( pw2 < -64 ) + return(0.0L); + u.y *= 0.5L; + pw2 += 1; + } + if( pw2 == 0 ) + return(u.y); +#else + return( 0.0L ); +#endif + } + +e = e + pw2; + +/* Handle overflow */ +if( e > 0x7fffL ) + { + return( MAXNUML ); + } +*q &= 0x8000; +/* Handle denormalized results */ +if( e < 1 ) + { +#ifdef DENORMAL + if( e < -64 ) + return(0.0L); + +#ifdef IBMPC + *(q-1) |= 0x8000; +#endif +#ifdef MIEEE + *(q+2) |= 0x8000; +#endif + + while( e < 1 ) + { + u.y *= 0.5L; + e += 1; + } + e = 0; +#else + return(0.0L); +#endif + } + +*q |= (unsigned short) e & 0x7fff; +return(u.y); +} + diff --git a/libm/ldouble/flrtstl.c b/libm/ldouble/flrtstl.c new file mode 100644 index 000000000..77a389324 --- /dev/null +++ b/libm/ldouble/flrtstl.c @@ -0,0 +1,104 @@ +long double floorl(), ldexpl(), frexpl(); + +#define N 16382 +void prnum(); +int printf(); +void exit(); + +void main() +{ +long double x, f, y, last, z, z0, y1; +int i, k, e, e0, errs; + +errs = 0; +f = 0.1L; +x = f; +last = x; +z0 = frexpl( x, &e0 ); +printf( "frexpl(%.2Le) = %.5Le, %d\n", x, z0, e0 ); +k = 0; +for( i=0; i<N+5; i++ ) + { + y = ldexpl( f, k ); + if( y != x ) + { + printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", + f, k, y, x ); + ++errs; + } + z = frexpl( y, &e ); + if( (e != k+e0) || (z != z0) ) + { + printf( "frexpl(%.1Le) = %.5Le, %d; s.b. %.5Le, %d\n", + y, z, e, z0, k+e0 ); + ++errs; + } + x += x; + if( x == last ) + break; + last = x; + k += 1; + } +printf( "i = %d\n", k ); +prnum( "last y =", &y ); +printf("\n"); + +f = 0.1L; +x = f; +last = x; +k = 0; +for( i=0; i<N+64; i++ ) + { + y = ldexpl( f, k ); + if( y != x ) + { + printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", + f, k, y, x ); + ++errs; + } + z = frexpl( y, &e ); + if( +#if 1 + (e > -N+1) && +#endif + ((e != k+e0) || (z != z0)) ) + { + printf( "frexpl(%.1Le) = %.5Le, %d; s.b. %.5Le, %d\n", + y, z, e, z0, k+e0 ); + ++errs; + } + y1 = ldexpl( z, e ); + if( y1 != y ) + { + printf( "ldexpl(%.1Le, %d) = %.5Le, s.b. %.5Le\n", + z, e, y1, y ); + ++errs; + } + + x *= 0.5L; + if( x == 0.0L ) + break; + if( x == last ) + break; + last = x; + k -= 1; + } +printf( "i = %d\n", k ); +prnum( "last y =", &y ); + +printf( "\n%d errors\n", errs ); +exit(0); +} + + +void prnum(str, x) +char *str; +unsigned short *x; +{ +int i; + +printf( "%s ", str ); +printf( "%.5Le = ", *(long double *)x ); +for( i=0; i<5; i++ ) + printf( "%04x ", *x++ ); +} diff --git a/libm/ldouble/fltestl.c b/libm/ldouble/fltestl.c new file mode 100644 index 000000000..963e92467 --- /dev/null +++ b/libm/ldouble/fltestl.c @@ -0,0 +1,265 @@ +/* fltest.c + * Test program for floor(), frexp(), ldexp() + */ + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier (moshier@world.std.com) +*/ + + + +/*#include <math.h>*/ +#define MACHEPL 5.42101086242752217003726400434970855712890625E-20L +#define N 16300 + +void flierr(); +int printf(); +void exit(); + +int +main() +{ +long double x, y, y0, z, f, x00, y00; +int i, j, e, e0; +int errfr, errld, errfl, underexp, err, errth, e00; +long double frexpl(), ldexpl(), floorl(); + + +/* +if( 1 ) + goto flrtst; +*/ + +printf( "Testing frexpl() and ldexpl().\n" ); +errth = 0.0L; +errfr = 0; +errld = 0; +underexp = 0; +f = 1.0L; +x00 = 2.0L; +y00 = 0.5L; +e00 = 2; + +for( j=0; j<20; j++ ) +{ +if( j == 10 ) + { + f = 1.0L; + x00 = 2.0L; + e00 = 1; +/* Find 2**(2**14) / 2 */ + for( i=0; i<13; i++ ) + { + x00 *= x00; + e00 += e00; + } + y00 = x00/2.0L; + x00 = x00 * y00; + e00 += e00; + y00 = 0.5L; + } +x = x00 * f; +y0 = y00 * f; +e0 = e00; + +#if 1 +/* If ldexp, frexp support denormal numbers, this should work. */ +for( i=0; i<16448; i++ ) +#else +for( i=0; i<16383; i++ ) +#endif + { + x /= 2.0L; + e0 -= 1; + if( x == 0.0L ) + { + if( f == 1.0L ) + underexp = e0; + y0 = 0.0L; + e0 = 0; + } + y = frexpl( x, &e ); + if( (e0 < -16383) && (e != e0) ) + { + if( e == (e0 - 1) ) + { + e += 1; + y /= 2.0L; + } + if( e == (e0 + 1) ) + { + e -= 1; + y *= 2.0L; + } + } + err = y - y0; + if( y0 != 0.0L ) + err /= y0; + if( err < 0.0L ) + err = -err; + if( e0 > -1023 ) + errth = 0.0L; + else + {/* Denormal numbers may have rounding errors */ + if( e0 == -16383 ) + { + errth = 2.0L * MACHEPL; + } + else + { + errth *= 2.0L; + } + } + + if( (x != 0.0L) && ((err > errth) || (e != e0)) ) + { + printf( "Test %d: ", j+1 ); + printf( " frexpl( %.20Le) =?= %.20Le * 2**%d;", x, y, e ); + printf( " should be %.20Le * 2**%d\n", y0, e0 ); + errfr += 1; + } + y = ldexpl( x, 1-e0 ); + err = y - 1.0L; + if( err < 0.0L ) + err = -err; + if( (err > errth) && ((x == 0.0L) && (y != 0.0L)) ) + { + printf( "Test %d: ", j+1 ); + printf( "ldexpl( %.15Le, %d ) =?= %.15Le;", x, 1-e0, y ); + if( x != 0.0L ) + printf( " should be %.15Le\n", f ); + else + printf( " should be %.15Le\n", 0.0L ); + errld += 1; + } + if( x == 0.0L ) + { + break; + } + } +f = f * 1.08005973889L; +} + +if( (errld == 0) && (errfr == 0) ) + { + printf( "No errors found.\n" ); + } + +/*flrtst:*/ + +printf( "Testing floorl().\n" ); +errfl = 0; + +f = 1.0L/MACHEPL; +x00 = 1.0L; +for( j=0; j<57; j++ ) +{ +x = x00 - 1.0L; +for( i=0; i<128; i++ ) + { + y = floorl(x); + if( y != x ) + { + flierr( x, y, j ); + errfl += 1; + } +/* Warning! the if() statement is compiler dependent, + * since x-0.49 may be held in extra precision accumulator + * so would never compare equal to x! The subroutine call + * y = floor() forces z to be stored as a double and reloaded + * for the if() statement. + */ + z = x - 0.49L; + y = floorl(z); + if( z == x ) + break; + if( y != (x - 1.0L) ) + { + flierr( z, y, j ); + errfl += 1; + } + + z = x + 0.49L; + y = floorl(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + y = floorl(x); + if( z != x ) + { + if( y != x ) + { + flierr( x, y, j ); + errfl += 1; + } + } + z = x + 0.49L; + y = floorl(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + z = x - 0.49L; + y = floorl(z); + if( z != x ) + { + if( y != (x - 1.0L) ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + x += 1.0L; + } +x00 = x00 + x00; +} +y = floorl(0.0L); +if( y != 0.0L ) + { + flierr( 0.0L, y, 57 ); + errfl += 1; + } +y = floorl(-0.0L); +if( y != 0.0L ) + { + flierr( -0.0L, y, 58 ); + errfl += 1; + } +y = floorl(-1.0L); +if( y != -1.0L ) + { + flierr( -1.0L, y, 59 ); + errfl += 1; + } +y = floorl(-0.1L); +if( y != -1.0l ) + { + flierr( -0.1L, y, 60 ); + errfl += 1; + } + +if( errfl == 0 ) + printf( "No errors found in floorl().\n" ); +exit(0); +return 0; +} + +void flierr( x, y, k ) +long double x, y; +int k; +{ +printf( "Test %d: ", k+1 ); +printf( "floorl(%.15Le) =?= %.15Le\n", x, y ); +} diff --git a/libm/ldouble/gammal.c b/libm/ldouble/gammal.c new file mode 100644 index 000000000..de7ed89a2 --- /dev/null +++ b/libm/ldouble/gammal.c @@ -0,0 +1,764 @@ +/* gammal.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * long double x, y, gammal(); + * extern int sgngam; + * + * y = gammal( x ); + * + * + * + * DESCRIPTION: + * + * Returns gamma function of the argument. The result is + * correctly signed, and the sign (+1 or -1) is also + * returned in a global (extern) variable named sgngam. + * This variable is also filled in by the logarithmic gamma + * function lgam(). + * + * Arguments |x| <= 13 are reduced by recurrence and the function + * approximated by a rational function of degree 7/8 in the + * interval (2,3). Large arguments are handled by Stirling's + * formula. Large negative arguments are made positive using + * a reflection formula. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -40,+40 10000 3.6e-19 7.9e-20 + * IEEE -1755,+1755 10000 4.8e-18 6.5e-19 + * + * Accuracy for large arguments is dominated by error in powl(). + * + */ +/* lgaml() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * long double x, y, lgaml(); + * extern int sgngam; + * + * y = lgaml( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base e (2.718...) logarithm of the absolute + * value of the gamma function of the argument. + * The sign (+1 or -1) of the gamma function is returned in a + * global (extern) variable named sgngam. + * + * For arguments greater than 33, the logarithm of the gamma + * function is approximated by the logarithmic version of + * Stirling's formula using a polynomial approximation of + * degree 4. Arguments between -33 and +33 are reduced by + * recurrence to the interval [2,3] of a rational approximation. + * The cosecant reflection formula is employed for arguments + * less than -33. + * + * Arguments greater than MAXLGML (10^4928) return MAXNUML. + * + * + * + * ACCURACY: + * + * + * arithmetic domain # trials peak rms + * IEEE -40, 40 100000 2.2e-19 4.6e-20 + * IEEE 10^-2000,10^+2000 20000 1.6e-19 3.3e-20 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * + */ + +/* gamma.c */ +/* gamma function */ + +/* +Copyright 1994 by Stephen L. Moshier +*/ + + +#include <math.h> +/* +gamma(x+2) = gamma(x+2) P(x)/Q(x) +0 <= x <= 1 +Relative error +n=7, d=8 +Peak error = 1.83e-20 +Relative error spread = 8.4e-23 +*/ +#if UNK +static long double P[8] = { + 4.212760487471622013093E-5L, + 4.542931960608009155600E-4L, + 4.092666828394035500949E-3L, + 2.385363243461108252554E-2L, + 1.113062816019361559013E-1L, + 3.629515436640239168939E-1L, + 8.378004301573126728826E-1L, + 1.000000000000000000009E0L, +}; +static long double Q[9] = { +-1.397148517476170440917E-5L, + 2.346584059160635244282E-4L, +-1.237799246653152231188E-3L, +-7.955933682494738320586E-4L, + 2.773706565840072979165E-2L, +-4.633887671244534213831E-2L, +-2.243510905670329164562E-1L, + 4.150160950588455434583E-1L, + 9.999999999999999999908E-1L, +}; +#endif +#if IBMPC +static short P[] = { +0x434a,0x3f22,0x2bda,0xb0b2,0x3ff0, XPD +0xf5aa,0xe82f,0x335b,0xee2e,0x3ff3, XPD +0xbe6c,0x3757,0xc717,0x861b,0x3ff7, XPD +0x7f43,0x5196,0xb166,0xc368,0x3ff9, XPD +0x9549,0x8eb5,0x8c3a,0xe3f4,0x3ffb, XPD +0x8d75,0x23af,0xc8e4,0xb9d4,0x3ffd, XPD +0x29cf,0x19b3,0x16c8,0xd67a,0x3ffe, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +static short Q[] = { +0x5473,0x2de8,0x1268,0xea67,0xbfee, XPD +0x334b,0xc2f0,0xa2dd,0xf60e,0x3ff2, XPD +0xbeed,0x1853,0xa691,0xa23d,0xbff5, XPD +0x296e,0x7cb1,0x5dfd,0xd08f,0xbff4, XPD +0x0417,0x7989,0xd7bc,0xe338,0x3ff9, XPD +0x3295,0x3698,0xd580,0xbdcd,0xbffa, XPD +0x75ef,0x3ab7,0x4ad3,0xe5bc,0xbffc, XPD +0xe458,0x2ec7,0xfd57,0xd47c,0x3ffd, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +#endif +#if MIEEE +static long P[24] = { +0x3ff00000,0xb0b22bda,0x3f22434a, +0x3ff30000,0xee2e335b,0xe82ff5aa, +0x3ff70000,0x861bc717,0x3757be6c, +0x3ff90000,0xc368b166,0x51967f43, +0x3ffb0000,0xe3f48c3a,0x8eb59549, +0x3ffd0000,0xb9d4c8e4,0x23af8d75, +0x3ffe0000,0xd67a16c8,0x19b329cf, +0x3fff0000,0x80000000,0x00000000, +}; +static long Q[27] = { +0xbfee0000,0xea671268,0x2de85473, +0x3ff20000,0xf60ea2dd,0xc2f0334b, +0xbff50000,0xa23da691,0x1853beed, +0xbff40000,0xd08f5dfd,0x7cb1296e, +0x3ff90000,0xe338d7bc,0x79890417, +0xbffa0000,0xbdcdd580,0x36983295, +0xbffc0000,0xe5bc4ad3,0x3ab775ef, +0x3ffd0000,0xd47cfd57,0x2ec7e458, +0x3fff0000,0x80000000,0x00000000, +}; +#endif +/* +static long double P[] = { +-3.01525602666895735709e0L, +-3.25157411956062339893e1L, +-2.92929976820724030353e2L, +-1.70730828800510297666e3L, +-7.96667499622741999770e3L, +-2.59780216007146401957e4L, +-5.99650230220855581642e4L, +-7.15743521530849602425e4L +}; +static long double Q[] = { + 1.00000000000000000000e0L, +-1.67955233807178858919e1L, + 8.85946791747759881659e1L, + 5.69440799097468430177e1L, +-1.98526250512761318471e3L, + 3.31667508019495079814e3L, + 1.60577839621734713377e4L, +-2.97045081369399940529e4L, +-7.15743521530849602412e4L +}; +*/ +#define MAXGAML 1755.455L +/*static long double LOGPI = 1.14472988584940017414L;*/ + +/* Stirling's formula for the gamma function +gamma(x) = sqrt(2 pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) +z(x) = x +13 <= x <= 1024 +Relative error +n=8, d=0 +Peak error = 9.44e-21 +Relative error spread = 8.8e-4 +*/ +#if UNK +static long double STIR[9] = { + 7.147391378143610789273E-4L, +-2.363848809501759061727E-5L, +-5.950237554056330156018E-4L, + 6.989332260623193171870E-5L, + 7.840334842744753003862E-4L, +-2.294719747873185405699E-4L, +-2.681327161876304418288E-3L, + 3.472222222230075327854E-3L, + 8.333333333333331800504E-2L, +}; +#endif +#if IBMPC +static short STIR[] = { +0x6ede,0x69f7,0x54e3,0xbb5d,0x3ff4, XPD +0xc395,0x0295,0x4443,0xc64b,0xbfef, XPD +0xba6f,0x7c59,0x5e47,0x9bfb,0xbff4, XPD +0x5704,0x1a39,0xb11d,0x9293,0x3ff1, XPD +0x30b7,0x1a21,0x98b2,0xcd87,0x3ff4, XPD +0xbef3,0x7023,0x6a08,0xf09e,0xbff2, XPD +0x3a1c,0x5ac8,0x3478,0xafb9,0xbff6, XPD +0xc3c9,0x906e,0x38e3,0xe38e,0x3ff6, XPD +0xa1d5,0xaaaa,0xaaaa,0xaaaa,0x3ffb, XPD +}; +#endif +#if MIEEE +static long STIR[27] = { +0x3ff40000,0xbb5d54e3,0x69f76ede, +0xbfef0000,0xc64b4443,0x0295c395, +0xbff40000,0x9bfb5e47,0x7c59ba6f, +0x3ff10000,0x9293b11d,0x1a395704, +0x3ff40000,0xcd8798b2,0x1a2130b7, +0xbff20000,0xf09e6a08,0x7023bef3, +0xbff60000,0xafb93478,0x5ac83a1c, +0x3ff60000,0xe38e38e3,0x906ec3c9, +0x3ffb0000,0xaaaaaaaa,0xaaaaa1d5, +}; +#endif +#define MAXSTIR 1024.0L +static long double SQTPI = 2.50662827463100050242E0L; + +/* 1/gamma(x) = z P(z) + * z(x) = 1/x + * 0 < x < 0.03125 + * Peak relative error 4.2e-23 + */ +#if UNK +static long double S[9] = { +-1.193945051381510095614E-3L, + 7.220599478036909672331E-3L, +-9.622023360406271645744E-3L, +-4.219773360705915470089E-2L, + 1.665386113720805206758E-1L, +-4.200263503403344054473E-2L, +-6.558780715202540684668E-1L, + 5.772156649015328608253E-1L, + 1.000000000000000000000E0L, +}; +#endif +#if IBMPC +static short S[] = { +0xbaeb,0xd6d3,0x25e5,0x9c7e,0xbff5, XPD +0xfe9a,0xceb4,0xc74e,0xec9a,0x3ff7, XPD +0x9225,0xdfef,0xb0e9,0x9da5,0xbff8, XPD +0x10b0,0xec17,0x87dc,0xacd7,0xbffa, XPD +0x6b8d,0x7515,0x1905,0xaa89,0x3ffc, XPD +0xf183,0x126b,0xf47d,0xac0a,0xbffa, XPD +0x7bf6,0x57d1,0xa013,0xa7e7,0xbffe, XPD +0xc7a9,0x7db0,0x67e3,0x93c4,0x3ffe, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +#endif +#if MIEEE +static long S[27] = { +0xbff50000,0x9c7e25e5,0xd6d3baeb, +0x3ff70000,0xec9ac74e,0xceb4fe9a, +0xbff80000,0x9da5b0e9,0xdfef9225, +0xbffa0000,0xacd787dc,0xec1710b0, +0x3ffc0000,0xaa891905,0x75156b8d, +0xbffa0000,0xac0af47d,0x126bf183, +0xbffe0000,0xa7e7a013,0x57d17bf6, +0x3ffe0000,0x93c467e3,0x7db0c7a9, +0x3fff0000,0x80000000,0x00000000, +}; +#endif +/* 1/gamma(-x) = z P(z) + * z(x) = 1/x + * 0 < x < 0.03125 + * Peak relative error 5.16e-23 + * Relative error spread = 2.5e-24 + */ +#if UNK +static long double SN[9] = { + 1.133374167243894382010E-3L, + 7.220837261893170325704E-3L, + 9.621911155035976733706E-3L, +-4.219773343731191721664E-2L, +-1.665386113944413519335E-1L, +-4.200263503402112910504E-2L, + 6.558780715202536547116E-1L, + 5.772156649015328608727E-1L, +-1.000000000000000000000E0L, +}; +#endif +#if IBMPC +static short SN[] = { +0x5dd1,0x02de,0xb9f7,0x948d,0x3ff5, XPD +0x989b,0xdd68,0xc5f1,0xec9c,0x3ff7, XPD +0x2ca1,0x18f0,0x386f,0x9da5,0x3ff8, XPD +0x783f,0x41dd,0x87d1,0xacd7,0xbffa, XPD +0x7a5b,0xd76d,0x1905,0xaa89,0xbffc, XPD +0x7f64,0x1234,0xf47d,0xac0a,0xbffa, XPD +0x5e26,0x57d1,0xa013,0xa7e7,0x3ffe, XPD +0xc7aa,0x7db0,0x67e3,0x93c4,0x3ffe, XPD +0x0000,0x0000,0x0000,0x8000,0xbfff, XPD +}; +#endif +#if MIEEE +static long SN[27] = { +0x3ff50000,0x948db9f7,0x02de5dd1, +0x3ff70000,0xec9cc5f1,0xdd68989b, +0x3ff80000,0x9da5386f,0x18f02ca1, +0xbffa0000,0xacd787d1,0x41dd783f, +0xbffc0000,0xaa891905,0xd76d7a5b, +0xbffa0000,0xac0af47d,0x12347f64, +0x3ffe0000,0xa7e7a013,0x57d15e26, +0x3ffe0000,0x93c467e3,0x7db0c7aa, +0xbfff0000,0x80000000,0x00000000, +}; +#endif + +int sgngaml = 0; +extern int sgngaml; +extern long double MAXLOGL, MAXNUML, PIL; +/* #define PIL 3.14159265358979323846L */ +/* #define MAXNUML 1.189731495357231765021263853E4932L */ + +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double lgaml ( long double ); +extern long double logl ( long double ); +extern long double expl ( long double ); +extern long double gammal ( long double ); +extern long double sinl ( long double ); +extern long double floorl ( long double ); +extern long double powl ( long double, long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +extern int isfinitel ( long double ); +static long double stirf ( long double ); +#else +long double fabsl(), lgaml(), logl(), expl(), gammal(), sinl(); +long double floorl(), powl(), polevll(), p1evll(), isnanl(), isfinitel(); +static long double stirf(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +/* Gamma function computed by Stirling's formula. + */ +static long double stirf(x) +long double x; +{ +long double y, w, v; + +w = 1.0L/x; +/* For large x, use rational coefficients from the analytical expansion. */ +if( x > 1024.0L ) + w = (((((6.97281375836585777429E-5L * w + + 7.84039221720066627474E-4L) * w + - 2.29472093621399176955E-4L) * w + - 2.68132716049382716049E-3L) * w + + 3.47222222222222222222E-3L) * w + + 8.33333333333333333333E-2L) * w + + 1.0L; +else + w = 1.0L + w * polevll( w, STIR, 8 ); +y = expl(x); +if( x > MAXSTIR ) + { /* Avoid overflow in pow() */ + v = powl( x, 0.5L * x - 0.25L ); + y = v * (v / y); + } +else + { + y = powl( x, x - 0.5L ) / y; + } +y = SQTPI * y * w; +return( y ); +} + + + +long double gammal(x) +long double x; +{ +long double p, q, z; +int i; + +sgngaml = 1; +#ifdef NANS +if( isnanl(x) ) + return(NANL); +#endif +#ifdef INFINITIES +if(x == INFINITYL) + return(INFINITYL); +#ifdef NANS +if(x == -INFINITYL) + goto gamnan; +#endif +#endif +q = fabsl(x); + +if( q > 13.0L ) + { + if( q > MAXGAML ) + goto goverf; + if( x < 0.0L ) + { + p = floorl(q); + if( p == q ) + { +gamnan: +#ifdef NANS + mtherr( "gammal", DOMAIN ); + return (NANL); +#else + goto goverf; +#endif + } + i = p; + if( (i & 1) == 0 ) + sgngaml = -1; + z = q - p; + if( z > 0.5L ) + { + p += 1.0L; + z = q - p; + } + z = q * sinl( PIL * z ); + z = fabsl(z) * stirf(q); + if( z <= PIL/MAXNUML ) + { +goverf: +#ifdef INFINITIES + return( sgngaml * INFINITYL); +#else + mtherr( "gammal", OVERFLOW ); + return( sgngaml * MAXNUML); +#endif + } + z = PIL/z; + } + else + { + z = stirf(x); + } + return( sgngaml * z ); + } + +z = 1.0L; +while( x >= 3.0L ) + { + x -= 1.0L; + z *= x; + } + +while( x < -0.03125L ) + { + z /= x; + x += 1.0L; + } + +if( x <= 0.03125L ) + goto small; + +while( x < 2.0L ) + { + z /= x; + x += 1.0L; + } + +if( x == 2.0L ) + return(z); + +x -= 2.0L; +p = polevll( x, P, 7 ); +q = polevll( x, Q, 8 ); +return( z * p / q ); + +small: +if( x == 0.0L ) + { + goto gamnan; + } +else + { + if( x < 0.0L ) + { + x = -x; + q = z / (x * polevll( x, SN, 8 )); + } + else + q = z / (x * polevll( x, S, 8 )); + } +return q; +} + + + +/* A[]: Stirling's formula expansion of log gamma + * B[], C[]: log gamma function between 2 and 3 + */ + + +/* log gamma(x) = ( x - 0.5 ) * log(x) - x + LS2PI + 1/x A(1/x^2) + * x >= 8 + * Peak relative error 1.51e-21 + * Relative spread of error peaks 5.67e-21 + */ +#if UNK +static long double A[7] = { + 4.885026142432270781165E-3L, +-1.880801938119376907179E-3L, + 8.412723297322498080632E-4L, +-5.952345851765688514613E-4L, + 7.936507795855070755671E-4L, +-2.777777777750349603440E-3L, + 8.333333333333331447505E-2L, +}; +#endif +#if IBMPC +static short A[] = { +0xd984,0xcc08,0x91c2,0xa012,0x3ff7, XPD +0x3d91,0x0304,0x3da1,0xf685,0xbff5, XPD +0x3bdc,0xaad1,0xd492,0xdc88,0x3ff4, XPD +0x8b20,0x9fce,0x844e,0x9c09,0xbff4, XPD +0xf8f2,0x30e5,0x0092,0xd00d,0x3ff4, XPD +0x4d88,0x03a8,0x60b6,0xb60b,0xbff6, XPD +0x9fcc,0xaaaa,0xaaaa,0xaaaa,0x3ffb, XPD +}; +#endif +#if MIEEE +static long A[21] = { +0x3ff70000,0xa01291c2,0xcc08d984, +0xbff50000,0xf6853da1,0x03043d91, +0x3ff40000,0xdc88d492,0xaad13bdc, +0xbff40000,0x9c09844e,0x9fce8b20, +0x3ff40000,0xd00d0092,0x30e5f8f2, +0xbff60000,0xb60b60b6,0x03a84d88, +0x3ffb0000,0xaaaaaaaa,0xaaaa9fcc, +}; +#endif + +/* log gamma(x+2) = x B(x)/C(x) + * 0 <= x <= 1 + * Peak relative error 7.16e-22 + * Relative spread of error peaks 4.78e-20 + */ +#if UNK +static long double B[7] = { +-2.163690827643812857640E3L, +-8.723871522843511459790E4L, +-1.104326814691464261197E6L, +-6.111225012005214299996E6L, +-1.625568062543700591014E7L, +-2.003937418103815175475E7L, +-8.875666783650703802159E6L, +}; +static long double C[7] = { +/* 1.000000000000000000000E0L,*/ +-5.139481484435370143617E2L, +-3.403570840534304670537E4L, +-6.227441164066219501697E5L, +-4.814940379411882186630E6L, +-1.785433287045078156959E7L, +-3.138646407656182662088E7L, +-2.099336717757895876142E7L, +}; +#endif +#if IBMPC +static short B[] = { +0x9557,0x4995,0x0da1,0x873b,0xc00a, XPD +0xfe44,0x9af8,0x5b8c,0xaa63,0xc00f, XPD +0x5aa8,0x7cf5,0x3684,0x86ce,0xc013, XPD +0x259a,0x258c,0xf206,0xba7f,0xc015, XPD +0xbe18,0x1ca3,0xc0a0,0xf80a,0xc016, XPD +0x168f,0x2c42,0x6717,0x98e3,0xc017, XPD +0x2051,0x9d55,0x92c8,0x876e,0xc016, XPD +}; +static short C[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xaa77,0xcf2f,0xae76,0x807c,0xc008, XPD +0xb280,0x0d74,0xb55a,0x84f3,0xc00e, XPD +0xa505,0xcd30,0x81dc,0x9809,0xc012, XPD +0x3369,0x4246,0xb8c2,0x92f0,0xc015, XPD +0x63cf,0x6aee,0xbe6f,0x8837,0xc017, XPD +0x26bb,0xccc7,0xb009,0xef75,0xc017, XPD +0x462b,0xbae8,0xab96,0xa02a,0xc017, XPD +}; +#endif +#if MIEEE +static long B[21] = { +0xc00a0000,0x873b0da1,0x49959557, +0xc00f0000,0xaa635b8c,0x9af8fe44, +0xc0130000,0x86ce3684,0x7cf55aa8, +0xc0150000,0xba7ff206,0x258c259a, +0xc0160000,0xf80ac0a0,0x1ca3be18, +0xc0170000,0x98e36717,0x2c42168f, +0xc0160000,0x876e92c8,0x9d552051, +}; +static long C[21] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0080000,0x807cae76,0xcf2faa77, +0xc00e0000,0x84f3b55a,0x0d74b280, +0xc0120000,0x980981dc,0xcd30a505, +0xc0150000,0x92f0b8c2,0x42463369, +0xc0170000,0x8837be6f,0x6aee63cf, +0xc0170000,0xef75b009,0xccc726bb, +0xc0170000,0xa02aab96,0xbae8462b, +}; +#endif + +/* log( sqrt( 2*pi ) ) */ +static long double LS2PI = 0.91893853320467274178L; +#define MAXLGM 1.04848146839019521116e+4928L + + +/* Logarithm of gamma function */ + + +long double lgaml(x) +long double x; +{ +long double p, q, w, z, f, nx; +int i; + +sgngaml = 1; +#ifdef NANS +if( isnanl(x) ) + return(NANL); +#endif +#ifdef INFINITIES +if( !isfinitel(x) ) + return(INFINITYL); +#endif +if( x < -34.0L ) + { + q = -x; + w = lgaml(q); /* note this modifies sgngam! */ + p = floorl(q); + if( p == q ) + { +#ifdef INFINITIES + mtherr( "lgaml", SING ); + return (INFINITYL); +#else + goto loverf; +#endif + } + i = p; + if( (i & 1) == 0 ) + sgngaml = -1; + else + sgngaml = 1; + z = q - p; + if( z > 0.5L ) + { + p += 1.0L; + z = p - q; + } + z = q * sinl( PIL * z ); + if( z == 0.0L ) + goto loverf; +/* z = LOGPI - logl( z ) - w; */ + z = logl( PIL/z ) - w; + return( z ); + } + +if( x < 13.0L ) + { + z = 1.0L; + nx = floorl( x + 0.5L ); + f = x - nx; + while( x >= 3.0L ) + { + nx -= 1.0L; + x = nx + f; + z *= x; + } + while( x < 2.0L ) + { + if( fabsl(x) <= 0.03125 ) + goto lsmall; + z /= nx + f; + nx += 1.0L; + x = nx + f; + } + if( z < 0.0L ) + { + sgngaml = -1; + z = -z; + } + else + sgngaml = 1; + if( x == 2.0L ) + return( logl(z) ); + x = (nx - 2.0L) + f; + p = x * polevll( x, B, 6 ) / p1evll( x, C, 7); + return( logl(z) + p ); + } + +if( x > MAXLGM ) + { +loverf: +#ifdef INFINITIES + return( sgngaml * INFINITYL ); +#else + mtherr( "lgaml", OVERFLOW ); + return( sgngaml * MAXNUML ); +#endif + } + +q = ( x - 0.5L ) * logl(x) - x + LS2PI; +if( x > 1.0e10L ) + return(q); +p = 1.0L/(x*x); +q += polevll( p, A, 6 ) / x; +return( q ); + + +lsmall: +if( x == 0.0L ) + goto loverf; +if( x < 0.0L ) + { + x = -x; + q = z / (x * polevll( x, SN, 8 )); + } +else + q = z / (x * polevll( x, S, 8 )); +if( q < 0.0L ) + { + sgngaml = -1; + q = -q; + } +else + sgngaml = 1; +q = logl( q ); +return(q); +} diff --git a/libm/ldouble/gdtrl.c b/libm/ldouble/gdtrl.c new file mode 100644 index 000000000..9a41790cb --- /dev/null +++ b/libm/ldouble/gdtrl.c @@ -0,0 +1,130 @@ +/* gdtrl.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, gdtrl(); + * + * y = gdtrl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the integral from zero to x of the gamma probability + * density function: + * + * + * x + * b - + * a | | b-1 -at + * y = ----- | t e dt + * - | | + * | (b) - + * 0 + * + * The incomplete gamma integral is used, according to the + * relation + * + * y = igam( b, ax ). + * + * + * ACCURACY: + * + * See igam(). + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrl domain x < 0 0.0 + * + */ + /* gdtrcl.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, gdtrcl(); + * + * y = gdtrcl( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Returns the integral from x to infinity of the gamma + * probability density function: + * + * + * inf. + * b - + * a | | b-1 -at + * y = ----- | t e dt + * - | | + * | (b) - + * x + * + * The incomplete gamma integral is used, according to the + * relation + * + * y = igamc( b, ax ). + * + * + * ACCURACY: + * + * See igamc(). + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrcl domain x < 0 0.0 + * + */ + +/* gdtrl() */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double igaml ( long double, long double ); +extern long double igamcl ( long double, long double ); +#else +long double igaml(), igamcl(); +#endif + +long double gdtrl( a, b, x ) +long double a, b, x; +{ + +if( x < 0.0L ) + { + mtherr( "gdtrl", DOMAIN ); + return( 0.0L ); + } +return( igaml( b, a * x ) ); +} + + + +long double gdtrcl( a, b, x ) +long double a, b, x; +{ + +if( x < 0.0L ) + { + mtherr( "gdtrcl", DOMAIN ); + return( 0.0L ); + } +return( igamcl( b, a * x ) ); +} diff --git a/libm/ldouble/gelsl.c b/libm/ldouble/gelsl.c new file mode 100644 index 000000000..d66ad55e9 --- /dev/null +++ b/libm/ldouble/gelsl.c @@ -0,0 +1,240 @@ +/* +C +C .................................................................. +C +C SUBROUTINE GELS +C +C PURPOSE +C TO SOLVE A SYSTEM OF SIMULTANEOUS LINEAR EQUATIONS WITH +C SYMMETRIC COEFFICIENT MATRIX UPPER TRIANGULAR PART OF WHICH +C IS ASSUMED TO BE STORED COLUMNWISE. +C +C USAGE +C CALL GELS(R,A,M,N,EPS,IER,AUX) +C +C DESCRIPTION OF PARAMETERS +C R - M BY N RIGHT HAND SIDE MATRIX. (DESTROYED) +C ON RETURN R CONTAINS THE SOLUTION OF THE EQUATIONS. +C A - UPPER TRIANGULAR PART OF THE SYMMETRIC +C M BY M COEFFICIENT MATRIX. (DESTROYED) +C M - THE NUMBER OF EQUATIONS IN THE SYSTEM. +C N - THE NUMBER OF RIGHT HAND SIDE VECTORS. +C EPS - AN INPUT CONSTANT WHICH IS USED AS RELATIVE +C TOLERANCE FOR TEST ON LOSS OF SIGNIFICANCE. +C IER - RESULTING ERROR PARAMETER CODED AS FOLLOWS +C IER=0 - NO ERROR, +C IER=-1 - NO RESULT BECAUSE OF M LESS THAN 1 OR +C PIVOT ELEMENT AT ANY ELIMINATION STEP +C EQUAL TO 0, +C IER=K - WARNING DUE TO POSSIBLE LOSS OF SIGNIFI- +C CANCE INDICATED AT ELIMINATION STEP K+1, +C WHERE PIVOT ELEMENT WAS LESS THAN OR +C EQUAL TO THE INTERNAL TOLERANCE EPS TIMES +C ABSOLUTELY GREATEST MAIN DIAGONAL +C ELEMENT OF MATRIX A. +C AUX - AN AUXILIARY STORAGE ARRAY WITH DIMENSION M-1. +C +C REMARKS +C UPPER TRIANGULAR PART OF MATRIX A IS ASSUMED TO BE STORED +C COLUMNWISE IN M*(M+1)/2 SUCCESSIVE STORAGE LOCATIONS, RIGHT +C HAND SIDE MATRIX R COLUMNWISE IN N*M SUCCESSIVE STORAGE +C LOCATIONS. ON RETURN SOLUTION MATRIX R IS STORED COLUMNWISE +C TOO. +C THE PROCEDURE GIVES RESULTS IF THE NUMBER OF EQUATIONS M IS +C GREATER THAN 0 AND PIVOT ELEMENTS AT ALL ELIMINATION STEPS +C ARE DIFFERENT FROM 0. HOWEVER WARNING IER=K - IF GIVEN - +C INDICATES POSSIBLE LOSS OF SIGNIFICANCE. IN CASE OF A WELL +C SCALED MATRIX A AND APPROPRIATE TOLERANCE EPS, IER=K MAY BE +C INTERPRETED THAT MATRIX A HAS THE RANK K. NO WARNING IS +C GIVEN IN CASE M=1. +C ERROR PARAMETER IER=-1 DOES NOT NECESSARILY MEAN THAT +C MATRIX A IS SINGULAR, AS ONLY MAIN DIAGONAL ELEMENTS +C ARE USED AS PIVOT ELEMENTS. POSSIBLY SUBROUTINE GELG (WHICH +C WORKS WITH TOTAL PIVOTING) WOULD BE ABLE TO FIND A SOLUTION. +C +C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED +C NONE +C +C METHOD +C SOLUTION IS DONE BY MEANS OF GAUSS-ELIMINATION WITH +C PIVOTING IN MAIN DIAGONAL, IN ORDER TO PRESERVE +C SYMMETRY IN REMAINING COEFFICIENT MATRICES. +C +C .................................................................. +C +*/ + +#include <stdio.h> +#define fabsl(x) ( (x) < 0.0L ? -(x) : (x) ) + +int gels( A, R, M, EPS, AUX ) +long double A[],R[]; +int M; +long double EPS; +long double AUX[]; +{ +int I, J, K, L, IER; +int II, LL, LLD, LR, LT, LST, LLST, LEND; +long double tb, piv, tol, pivi; + +IER = 0; +if( M <= 0 ) + { +fatal: + IER = -1; + goto done; + } +/* SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT */ + +/* Diagonal elements are at A(i,i) = 0, 2, 5, 9, 14, ... + * A(i,j) = A( i(i-1)/2 + j - 1 ) + */ +piv = 0.0L; +I = 0; +J = 0; +L = 0; +for( K=1; K<=M; K++ ) + { + L += K; + tb = fabsl( A[L-1] ); + if( tb > piv ) + { + piv = tb; + I = L; + J = K; + } + } +tol = EPS * piv; + +/* +C MAIN DIAGONAL ELEMENT A(I)=A(J,J) IS FIRST PIVOT ELEMENT. +C PIV CONTAINS THE ABSOLUTE VALUE OF A(I). +*/ + +/* START ELIMINATION LOOP */ +LST = 0; +LEND = M - 1; +for( K=1; K<=M; K++ ) + { +/* TEST ON USEFULNESS OF SYMMETRIC ALGORITHM */ + if( piv <= 0.0L ) + { + printf( "gels: piv <= 0 at K = %d\n", K ); + goto fatal; + } + if( IER == 0 ) + { + if( piv <= tol ) + { + IER = K; +/* + goto done; +*/ + } + } + LT = J - K; + LST += K; + +/* PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R */ + pivi = 1.0L / A[I-1]; + L = K; + LL = L + LT; + tb = pivi * R[LL-1]; + R[LL-1] = R[L-1]; + R[L-1] = tb; +/* IS ELIMINATION TERMINATED */ + if( K >= M ) + break; +/* +C ROW AND COLUMN INTERCHANGE AND PIVOT ROW REDUCTION IN MATRIX A. +C ELEMENTS OF PIVOT COLUMN ARE SAVED IN AUXILIARY VECTOR AUX. +*/ + LR = LST + (LT*(K+J-1))/2; + LL = LR; + L=LST; + for( II=K; II<=LEND; II++ ) + { + L += II; + LL += 1; + if( L == LR ) + { + A[LL-1] = A[LST-1]; + tb = A[L-1]; + goto lab13; + } + if( L > LR ) + LL = L + LT; + + tb = A[LL-1]; + A[LL-1] = A[L-1]; +lab13: + AUX[II-1] = tb; + A[L-1] = pivi * tb; + } +/* SAVE COLUMN INTERCHANGE INFORMATION */ + A[LST-1] = LT; +/* ELEMENT REDUCTION AND SEARCH FOR NEXT PIVOT */ + piv = 0.0L; + LLST = LST; + LT = 0; + for( II=K; II<=LEND; II++ ) + { + pivi = -AUX[II-1]; + LL = LLST; + LT += 1; + for( LLD=II; LLD<=LEND; LLD++ ) + { + LL += LLD; + L = LL + LT; + A[L-1] += pivi * A[LL-1]; + } + LLST += II; + LR = LLST + LT; + tb =fabsl( A[LR-1] ); + if( tb > piv ) + { + piv = tb; + I = LR; + J = II + 1; + } + LR = K; + LL = LR + LT; + R[LL-1] += pivi * R[LR-1]; + } + } +/* END OF ELIMINATION LOOP */ + +/* BACK SUBSTITUTION AND BACK INTERCHANGE */ + +if( LEND <= 0 ) + { + printf( "gels: LEND = %d\n", LEND ); + if( LEND < 0 ) + goto fatal; + goto done; + } +II = M; +for( I=2; I<=M; I++ ) + { + LST -= II; + II -= 1; + L = A[LST-1] + 0.5L; + J = II; + tb = R[J-1]; + LL = J; + K = LST; + for( LT=II; LT<=LEND; LT++ ) + { + LL += 1; + K += LT; + tb -= A[K-1] * R[LL-1]; + } + K = J + L; + R[J-1] = R[K-1]; + R[K-1] = tb; + } +done: +if( IER ) + printf( "gels error %d!\n", IER ); +return( IER ); +} diff --git a/libm/ldouble/ieee.c b/libm/ldouble/ieee.c new file mode 100644 index 000000000..584329b0c --- /dev/null +++ b/libm/ldouble/ieee.c @@ -0,0 +1,4182 @@ +/* ieee.c + * + * Extended precision IEEE binary floating point arithmetic routines + * + * Numbers are stored in C language as arrays of 16-bit unsigned + * short integers. The arguments of the routines are pointers to + * the arrays. + * + * + * External e type data structure, simulates Intel 8087 chip + * temporary real format but possibly with a larger significand: + * + * NE-1 significand words (least significant word first, + * most significant bit is normally set) + * exponent (value = EXONE for 1.0, + * top bit is the sign) + * + * + * Internal data structure of a number (a "word" is 16 bits): + * + * ei[0] sign word (0 for positive, 0xffff for negative) + * ei[1] biased exponent (value = EXONE for the number 1.0) + * ei[2] high guard word (always zero after normalization) + * ei[3] + * to ei[NI-2] significand (NI-4 significand words, + * most significant word first, + * most significant bit is set) + * ei[NI-1] low guard word (0x8000 bit is rounding place) + * + * + * + * Routines for external format numbers + * + * asctoe( string, e ) ASCII string to extended double e type + * asctoe64( string, &d ) ASCII string to long double + * asctoe53( string, &d ) ASCII string to double + * asctoe24( string, &f ) ASCII string to single + * asctoeg( string, e, prec ) ASCII string to specified precision + * e24toe( &f, e ) IEEE single precision to e type + * e53toe( &d, e ) IEEE double precision to e type + * e64toe( &d, e ) IEEE long double precision to e type + * eabs(e) absolute value + * eadd( a, b, c ) c = b + a + * eclear(e) e = 0 + * ecmp (a, b) Returns 1 if a > b, 0 if a == b, + * -1 if a < b, -2 if either a or b is a NaN. + * ediv( a, b, c ) c = b / a + * efloor( a, b ) truncate to integer, toward -infinity + * efrexp( a, exp, s ) extract exponent and significand + * eifrac( e, &l, frac ) e to long integer and e type fraction + * euifrac( e, &l, frac ) e to unsigned long integer and e type fraction + * einfin( e ) set e to infinity, leaving its sign alone + * eldexp( a, n, b ) multiply by 2**n + * emov( a, b ) b = a + * emul( a, b, c ) c = b * a + * eneg(e) e = -e + * eround( a, b ) b = nearest integer value to a + * esub( a, b, c ) c = b - a + * e24toasc( &f, str, n ) single to ASCII string, n digits after decimal + * e53toasc( &d, str, n ) double to ASCII string, n digits after decimal + * e64toasc( &d, str, n ) long double to ASCII string + * etoasc( e, str, n ) e to ASCII string, n digits after decimal + * etoe24( e, &f ) convert e type to IEEE single precision + * etoe53( e, &d ) convert e type to IEEE double precision + * etoe64( e, &d ) convert e type to IEEE long double precision + * ltoe( &l, e ) long (32 bit) integer to e type + * ultoe( &l, e ) unsigned long (32 bit) integer to e type + * eisneg( e ) 1 if sign bit of e != 0, else 0 + * eisinf( e ) 1 if e has maximum exponent (non-IEEE) + * or is infinite (IEEE) + * eisnan( e ) 1 if e is a NaN + * esqrt( a, b ) b = square root of a + * + * + * Routines for internal format numbers + * + * eaddm( ai, bi ) add significands, bi = bi + ai + * ecleaz(ei) ei = 0 + * ecleazs(ei) set ei = 0 but leave its sign alone + * ecmpm( ai, bi ) compare significands, return 1, 0, or -1 + * edivm( ai, bi ) divide significands, bi = bi / ai + * emdnorm(ai,l,s,exp) normalize and round off + * emovi( a, ai ) convert external a to internal ai + * emovo( ai, a ) convert internal ai to external a + * emovz( ai, bi ) bi = ai, low guard word of bi = 0 + * emulm( ai, bi ) multiply significands, bi = bi * ai + * enormlz(ei) left-justify the significand + * eshdn1( ai ) shift significand and guards down 1 bit + * eshdn8( ai ) shift down 8 bits + * eshdn6( ai ) shift down 16 bits + * eshift( ai, n ) shift ai n bits up (or down if n < 0) + * eshup1( ai ) shift significand and guards up 1 bit + * eshup8( ai ) shift up 8 bits + * eshup6( ai ) shift up 16 bits + * esubm( ai, bi ) subtract significands, bi = bi - ai + * + * + * The result is always normalized and rounded to NI-4 word precision + * after each arithmetic operation. + * + * Exception flags are NOT fully supported. + * + * Define INFINITY in mconf.h for support of infinity; otherwise a + * saturation arithmetic is implemented. + * + * Define NANS for support of Not-a-Number items; otherwise the + * arithmetic will never produce a NaN output, and might be confused + * by a NaN input. + * If NaN's are supported, the output of ecmp(a,b) is -2 if + * either a or b is a NaN. This means asking if(ecmp(a,b) < 0) + * may not be legitimate. Use if(ecmp(a,b) == -1) for less-than + * if in doubt. + * Signaling NaN's are NOT supported; they are treated the same + * as quiet NaN's. + * + * Denormals are always supported here where appropriate (e.g., not + * for conversion to DEC numbers). + */ + +/* + * Revision history: + * + * 5 Jan 84 PDP-11 assembly language version + * 2 Mar 86 fixed bug in asctoq() + * 6 Dec 86 C language version + * 30 Aug 88 100 digit version, improved rounding + * 15 May 92 80-bit long double support + * + * Author: S. L. Moshier. + */ + +#include <stdio.h> +#include <math.h> +#include "ehead.h" + +/* Change UNK into something else. */ +#ifdef UNK +#undef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +#endif + +/* NaN's require infinity support. */ +#ifdef NANS +#ifndef INFINITY +#define INFINITY +#endif +#endif + +/* This handles 64-bit long ints. */ +#define LONGBITS (8 * sizeof(long)) + +/* Control register for rounding precision. + * This can be set to 80 (if NE=6), 64, 56, 53, or 24 bits. + */ +int rndprc = NBITS; +extern int rndprc; + +#ifdef ANSIPROT +extern void eaddm ( unsigned short *, unsigned short * ); +extern void esubm ( unsigned short *, unsigned short * ); +extern void emdnorm ( unsigned short *, int, int, long, int ); +extern void asctoeg ( char *, unsigned short *, int ); +extern void enan ( unsigned short *, int ); +extern void asctoe24 ( char *, unsigned short * ); +extern void asctoe53 ( char *, unsigned short * ); +extern void asctoe64 ( char *, unsigned short * ); +extern void asctoe113 ( char *, unsigned short * ); +extern void eremain ( unsigned short *, unsigned short *, unsigned short * ); +extern void einit ( void ); +extern void eiremain ( unsigned short *, unsigned short * ); +extern int ecmp ( unsigned short *, unsigned short * ); +extern int edivm ( unsigned short *, unsigned short * ); +extern int emulm ( unsigned short *, unsigned short * ); +extern int eisneg ( unsigned short * ); +extern int eisinf ( unsigned short * ); +extern void emovi ( unsigned short *, unsigned short * ); +extern void emovo ( unsigned short *, unsigned short * ); +extern void emovz ( unsigned short *, unsigned short * ); +extern void ecleaz ( unsigned short * ); +extern void eadd1 ( unsigned short *, unsigned short *, unsigned short * ); +extern int eisnan ( unsigned short * ); +extern int eiisnan ( unsigned short * ); +static void toe24( unsigned short *, unsigned short * ); +static void toe53( unsigned short *, unsigned short * ); +static void toe64( unsigned short *, unsigned short * ); +static void toe113( unsigned short *, unsigned short * ); +void einfin ( unsigned short * ); +void eshdn1 ( unsigned short * ); +void eshup1 ( unsigned short * ); +void eshup6 ( unsigned short * ); +void eshdn6 ( unsigned short * ); +void eshup8 ( unsigned short * ); +void eshdn8 ( unsigned short * ); +void m16m ( unsigned short, unsigned short *, unsigned short * ); +int ecmpm ( unsigned short *, unsigned short * ); +int enormlz ( unsigned short * ); +void ecleazs ( unsigned short * ); +int eshift ( unsigned short *, int ); +void emov ( unsigned short *, unsigned short * ); +void eneg ( unsigned short * ); +void eclear ( unsigned short * ); +void efloor ( unsigned short *, unsigned short * ); +void eadd ( unsigned short *, unsigned short *, unsigned short * ); +void esub ( unsigned short *, unsigned short *, unsigned short * ); +void ediv ( unsigned short *, unsigned short *, unsigned short * ); +void emul ( unsigned short *, unsigned short *, unsigned short * ); +void e24toe ( unsigned short *, unsigned short * ); +void e53toe ( unsigned short *, unsigned short * ); +void e64toe ( unsigned short *, unsigned short * ); +void e113toe ( unsigned short *, unsigned short * ); +void etoasc ( unsigned short *, char *, int ); +static int eiisinf ( unsigned short * ); +#else +void eaddm(), esubm(), emdnorm(), asctoeg(), enan(); +static void toe24(), toe53(), toe64(), toe113(); +void eremain(), einit(), eiremain(); +int ecmpm(), edivm(), emulm(), eisneg(), eisinf(); +void emovi(), emovo(), emovz(), ecleaz(), eadd1(); +/* void etodec(), todec(), dectoe(); */ +int eisnan(), eiisnan(), ecmpm(), enormlz(), eshift(); +void einfin(), eshdn1(), eshup1(), eshup6(), eshdn6(); +void eshup8(), eshdn8(), m16m(); +void eadd(), esub(), ediv(), emul(); +void ecleazs(), emov(), eneg(), eclear(), efloor(); +void e24toe(), e53toe(), e64toe(), e113toe(), etoasc(); +static int eiisinf(); +#endif + + +void einit() +{ +} + +/* +; Clear out entire external format number. +; +; unsigned short x[]; +; eclear( x ); +*/ + +void eclear( x ) +register unsigned short *x; +{ +register int i; + +for( i=0; i<NE; i++ ) + *x++ = 0; +} + + + +/* Move external format number from a to b. + * + * emov( a, b ); + */ + +void emov( a, b ) +register unsigned short *a, *b; +{ +register int i; + +for( i=0; i<NE; i++ ) + *b++ = *a++; +} + + +/* +; Absolute value of external format number +; +; short x[NE]; +; eabs( x ); +*/ + +void eabs(x) +unsigned short x[]; /* x is the memory address of a short */ +{ + +x[NE-1] &= 0x7fff; /* sign is top bit of last word of external format */ +} + + + + +/* +; Negate external format number +; +; unsigned short x[NE]; +; eneg( x ); +*/ + +void eneg(x) +unsigned short x[]; +{ + +#ifdef NANS +if( eisnan(x) ) + return; +#endif +x[NE-1] ^= 0x8000; /* Toggle the sign bit */ +} + + + +/* Return 1 if external format number is negative, + * else return zero. + */ +int eisneg(x) +unsigned short x[]; +{ + +#ifdef NANS +if( eisnan(x) ) + return( 0 ); +#endif +if( x[NE-1] & 0x8000 ) + return( 1 ); +else + return( 0 ); +} + + +/* Return 1 if external format number has maximum possible exponent, + * else return zero. + */ +int eisinf(x) +unsigned short x[]; +{ + +if( (x[NE-1] & 0x7fff) == 0x7fff ) + { +#ifdef NANS + if( eisnan(x) ) + return( 0 ); +#endif + return( 1 ); + } +else + return( 0 ); +} + +/* Check if e-type number is not a number. + */ +int eisnan(x) +unsigned short x[]; +{ + +#ifdef NANS +int i; +/* NaN has maximum exponent */ +if( (x[NE-1] & 0x7fff) != 0x7fff ) + return (0); +/* ... and non-zero significand field. */ +for( i=0; i<NE-1; i++ ) + { + if( *x++ != 0 ) + return (1); + } +#endif +return (0); +} + +/* +; Fill entire number, including exponent and significand, with +; largest possible number. These programs implement a saturation +; value that is an ordinary, legal number. A special value +; "infinity" may also be implemented; this would require tests +; for that value and implementation of special rules for arithmetic +; operations involving inifinity. +*/ + +void einfin(x) +register unsigned short *x; +{ +register int i; + +#ifdef INFINITY +for( i=0; i<NE-1; i++ ) + *x++ = 0; +*x |= 32767; +#else +for( i=0; i<NE-1; i++ ) + *x++ = 0xffff; +*x |= 32766; +if( rndprc < NBITS ) + { + if (rndprc == 113) + { + *(x - 9) = 0; + *(x - 8) = 0; + } + if( rndprc == 64 ) + { + *(x-5) = 0; + } + if( rndprc == 53 ) + { + *(x-4) = 0xf800; + } + else + { + *(x-4) = 0; + *(x-3) = 0; + *(x-2) = 0xff00; + } + } +#endif +} + + + +/* Move in external format number, + * converting it to internal format. + */ +void emovi( a, b ) +unsigned short *a, *b; +{ +register unsigned short *p, *q; +int i; + +q = b; +p = a + (NE-1); /* point to last word of external number */ +/* get the sign bit */ +if( *p & 0x8000 ) + *q++ = 0xffff; +else + *q++ = 0; +/* get the exponent */ +*q = *p--; +*q++ &= 0x7fff; /* delete the sign bit */ +#ifdef INFINITY +if( (*(q-1) & 0x7fff) == 0x7fff ) + { +#ifdef NANS + if( eisnan(a) ) + { + *q++ = 0; + for( i=3; i<NI; i++ ) + *q++ = *p--; + return; + } +#endif + for( i=2; i<NI; i++ ) + *q++ = 0; + return; + } +#endif +/* clear high guard word */ +*q++ = 0; +/* move in the significand */ +for( i=0; i<NE-1; i++ ) + *q++ = *p--; +/* clear low guard word */ +*q = 0; +} + + +/* Move internal format number out, + * converting it to external format. + */ +void emovo( a, b ) +unsigned short *a, *b; +{ +register unsigned short *p, *q; +unsigned short i; + +p = a; +q = b + (NE-1); /* point to output exponent */ +/* combine sign and exponent */ +i = *p++; +if( i ) + *q-- = *p++ | 0x8000; +else + *q-- = *p++; +#ifdef INFINITY +if( *(p-1) == 0x7fff ) + { +#ifdef NANS + if( eiisnan(a) ) + { + enan( b, NBITS ); + return; + } +#endif + einfin(b); + return; + } +#endif +/* skip over guard word */ +++p; +/* move the significand */ +for( i=0; i<NE-1; i++ ) + *q-- = *p++; +} + + + + +/* Clear out internal format number. + */ + +void ecleaz( xi ) +register unsigned short *xi; +{ +register int i; + +for( i=0; i<NI; i++ ) + *xi++ = 0; +} + +/* same, but don't touch the sign. */ + +void ecleazs( xi ) +register unsigned short *xi; +{ +register int i; + +++xi; +for(i=0; i<NI-1; i++) + *xi++ = 0; +} + + + + +/* Move internal format number from a to b. + */ +void emovz( a, b ) +register unsigned short *a, *b; +{ +register int i; + +for( i=0; i<NI-1; i++ ) + *b++ = *a++; +/* clear low guard word */ +*b = 0; +} + +/* Return nonzero if internal format number is a NaN. + */ + +int eiisnan (x) +unsigned short x[]; +{ +int i; + +if( (x[E] & 0x7fff) == 0x7fff ) + { + for( i=M+1; i<NI; i++ ) + { + if( x[i] != 0 ) + return(1); + } + } +return(0); +} + +#ifdef INFINITY +/* Return nonzero if internal format number is infinite. */ + +static int +eiisinf (x) + unsigned short x[]; +{ + +#ifdef NANS + if (eiisnan (x)) + return (0); +#endif + if ((x[E] & 0x7fff) == 0x7fff) + return (1); + return (0); +} +#endif + +/* +; Compare significands of numbers in internal format. +; Guard words are included in the comparison. +; +; unsigned short a[NI], b[NI]; +; cmpm( a, b ); +; +; for the significands: +; returns +1 if a > b +; 0 if a == b +; -1 if a < b +*/ +int ecmpm( a, b ) +register unsigned short *a, *b; +{ +int i; + +a += M; /* skip up to significand area */ +b += M; +for( i=M; i<NI; i++ ) + { + if( *a++ != *b++ ) + goto difrnt; + } +return(0); + +difrnt: +if( *(--a) > *(--b) ) + return(1); +else + return(-1); +} + + +/* +; Shift significand down by 1 bit +*/ + +void eshdn1(x) +register unsigned short *x; +{ +register unsigned short bits; +int i; + +x += M; /* point to significand area */ + +bits = 0; +for( i=M; i<NI; i++ ) + { + if( *x & 1 ) + bits |= 1; + *x >>= 1; + if( bits & 2 ) + *x |= 0x8000; + bits <<= 1; + ++x; + } +} + + + +/* +; Shift significand up by 1 bit +*/ + +void eshup1(x) +register unsigned short *x; +{ +register unsigned short bits; +int i; + +x += NI-1; +bits = 0; + +for( i=M; i<NI; i++ ) + { + if( *x & 0x8000 ) + bits |= 1; + *x <<= 1; + if( bits & 2 ) + *x |= 1; + bits <<= 1; + --x; + } +} + + + +/* +; Shift significand down by 8 bits +*/ + +void eshdn8(x) +register unsigned short *x; +{ +register unsigned short newbyt, oldbyt; +int i; + +x += M; +oldbyt = 0; +for( i=M; i<NI; i++ ) + { + newbyt = *x << 8; + *x >>= 8; + *x |= oldbyt; + oldbyt = newbyt; + ++x; + } +} + +/* +; Shift significand up by 8 bits +*/ + +void eshup8(x) +register unsigned short *x; +{ +int i; +register unsigned short newbyt, oldbyt; + +x += NI-1; +oldbyt = 0; + +for( i=M; i<NI; i++ ) + { + newbyt = *x >> 8; + *x <<= 8; + *x |= oldbyt; + oldbyt = newbyt; + --x; + } +} + +/* +; Shift significand up by 16 bits +*/ + +void eshup6(x) +register unsigned short *x; +{ +int i; +register unsigned short *p; + +p = x + M; +x += M + 1; + +for( i=M; i<NI-1; i++ ) + *p++ = *x++; + +*p = 0; +} + +/* +; Shift significand down by 16 bits +*/ + +void eshdn6(x) +register unsigned short *x; +{ +int i; +register unsigned short *p; + +x += NI-1; +p = x + 1; + +for( i=M; i<NI-1; i++ ) + *(--p) = *(--x); + +*(--p) = 0; +} + +/* +; Add significands +; x + y replaces y +*/ + +void eaddm( x, y ) +unsigned short *x, *y; +{ +register unsigned long a; +int i; +unsigned int carry; + +x += NI-1; +y += NI-1; +carry = 0; +for( i=M; i<NI; i++ ) + { + a = (unsigned long )(*x) + (unsigned long )(*y) + carry; + if( a & 0x10000 ) + carry = 1; + else + carry = 0; + *y = (unsigned short )a; + --x; + --y; + } +} + +/* +; Subtract significands +; y - x replaces y +*/ + +void esubm( x, y ) +unsigned short *x, *y; +{ +unsigned long a; +int i; +unsigned int carry; + +x += NI-1; +y += NI-1; +carry = 0; +for( i=M; i<NI; i++ ) + { + a = (unsigned long )(*y) - (unsigned long )(*x) - carry; + if( a & 0x10000 ) + carry = 1; + else + carry = 0; + *y = (unsigned short )a; + --x; + --y; + } +} + + +/* Divide significands */ + +static unsigned short equot[NI] = {0}; /* was static */ + +#if 0 +int edivm( den, num ) +unsigned short den[], num[]; +{ +int i; +register unsigned short *p, *q; +unsigned short j; + +p = &equot[0]; +*p++ = num[0]; +*p++ = num[1]; + +for( i=M; i<NI; i++ ) + { + *p++ = 0; + } + +/* Use faster compare and subtraction if denominator + * has only 15 bits of significane. + */ +p = &den[M+2]; +if( *p++ == 0 ) + { + for( i=M+3; i<NI; i++ ) + { + if( *p++ != 0 ) + goto fulldiv; + } + if( (den[M+1] & 1) != 0 ) + goto fulldiv; + eshdn1(num); + eshdn1(den); + + p = &den[M+1]; + q = &num[M+1]; + + for( i=0; i<NBITS+2; i++ ) + { + if( *p <= *q ) + { + *q -= *p; + j = 1; + } + else + { + j = 0; + } + eshup1(equot); + equot[NI-2] |= j; + eshup1(num); + } + goto divdon; + } + +/* The number of quotient bits to calculate is + * NBITS + 1 scaling guard bit + 1 roundoff bit. + */ +fulldiv: + +p = &equot[NI-2]; +for( i=0; i<NBITS+2; i++ ) + { + if( ecmpm(den,num) <= 0 ) + { + esubm(den, num); + j = 1; /* quotient bit = 1 */ + } + else + j = 0; + eshup1(equot); + *p |= j; + eshup1(num); + } + +divdon: + +eshdn1( equot ); +eshdn1( equot ); + +/* test for nonzero remainder after roundoff bit */ +p = &num[M]; +j = 0; +for( i=M; i<NI; i++ ) + { + j |= *p++; + } +if( j ) + j = 1; + + +for( i=0; i<NI; i++ ) + num[i] = equot[i]; +return( (int )j ); +} + +/* Multiply significands */ +int emulm( a, b ) +unsigned short a[], b[]; +{ +unsigned short *p, *q; +int i, j, k; + +equot[0] = b[0]; +equot[1] = b[1]; +for( i=M; i<NI; i++ ) + equot[i] = 0; + +p = &a[NI-2]; +k = NBITS; +while( *p == 0 ) /* significand is not supposed to be all zero */ + { + eshdn6(a); + k -= 16; + } +if( (*p & 0xff) == 0 ) + { + eshdn8(a); + k -= 8; + } + +q = &equot[NI-1]; +j = 0; +for( i=0; i<k; i++ ) + { + if( *p & 1 ) + eaddm(b, equot); +/* remember if there were any nonzero bits shifted out */ + if( *q & 1 ) + j |= 1; + eshdn1(a); + eshdn1(equot); + } + +for( i=0; i<NI; i++ ) + b[i] = equot[i]; + +/* return flag for lost nonzero bits */ +return(j); +} + +#else + +/* Multiply significand of e-type number b +by 16-bit quantity a, e-type result to c. */ + +void m16m( a, b, c ) +unsigned short a; +unsigned short b[], c[]; +{ +register unsigned short *pp; +register unsigned long carry; +unsigned short *ps; +unsigned short p[NI]; +unsigned long aa, m; +int i; + +aa = a; +pp = &p[NI-2]; +*pp++ = 0; +*pp = 0; +ps = &b[NI-1]; + +for( i=M+1; i<NI; i++ ) + { + if( *ps == 0 ) + { + --ps; + --pp; + *(pp-1) = 0; + } + else + { + m = (unsigned long) aa * *ps--; + carry = (m & 0xffff) + *pp; + *pp-- = (unsigned short )carry; + carry = (carry >> 16) + (m >> 16) + *pp; + *pp = (unsigned short )carry; + *(pp-1) = carry >> 16; + } + } +for( i=M; i<NI; i++ ) + c[i] = p[i]; +} + + +/* Divide significands. Neither the numerator nor the denominator +is permitted to have its high guard word nonzero. */ + + +int edivm( den, num ) +unsigned short den[], num[]; +{ +int i; +register unsigned short *p; +unsigned long tnum; +unsigned short j, tdenm, tquot; +unsigned short tprod[NI+1]; + +p = &equot[0]; +*p++ = num[0]; +*p++ = num[1]; + +for( i=M; i<NI; i++ ) + { + *p++ = 0; + } +eshdn1( num ); +tdenm = den[M+1]; +for( i=M; i<NI; i++ ) + { + /* Find trial quotient digit (the radix is 65536). */ + tnum = (((unsigned long) num[M]) << 16) + num[M+1]; + + /* Do not execute the divide instruction if it will overflow. */ + if( (tdenm * ((unsigned long)0xffffL)) < tnum ) + tquot = 0xffff; + else + tquot = tnum / tdenm; + + /* Prove that the divide worked. */ +/* + tcheck = (unsigned long )tquot * tdenm; + if( tnum - tcheck > tdenm ) + tquot = 0xffff; +*/ + /* Multiply denominator by trial quotient digit. */ + m16m( tquot, den, tprod ); + /* The quotient digit may have been overestimated. */ + if( ecmpm( tprod, num ) > 0 ) + { + tquot -= 1; + esubm( den, tprod ); + if( ecmpm( tprod, num ) > 0 ) + { + tquot -= 1; + esubm( den, tprod ); + } + } +/* + if( ecmpm( tprod, num ) > 0 ) + { + eshow( "tprod", tprod ); + eshow( "num ", num ); + printf( "tnum = %08lx, tden = %04x, tquot = %04x\n", + tnum, den[M+1], tquot ); + } +*/ + esubm( tprod, num ); +/* + if( ecmpm( num, den ) >= 0 ) + { + eshow( "num ", num ); + eshow( "den ", den ); + printf( "tnum = %08lx, tden = %04x, tquot = %04x\n", + tnum, den[M+1], tquot ); + } +*/ + equot[i] = tquot; + eshup6(num); + } +/* test for nonzero remainder after roundoff bit */ +p = &num[M]; +j = 0; +for( i=M; i<NI; i++ ) + { + j |= *p++; + } +if( j ) + j = 1; + +for( i=0; i<NI; i++ ) + num[i] = equot[i]; + +return( (int )j ); +} + + + +/* Multiply significands */ +int emulm( a, b ) +unsigned short a[], b[]; +{ +unsigned short *p, *q; +unsigned short pprod[NI]; +unsigned short j; +int i; + +equot[0] = b[0]; +equot[1] = b[1]; +for( i=M; i<NI; i++ ) + equot[i] = 0; + +j = 0; +p = &a[NI-1]; +q = &equot[NI-1]; +for( i=M+1; i<NI; i++ ) + { + if( *p == 0 ) + { + --p; + } + else + { + m16m( *p--, b, pprod ); + eaddm(pprod, equot); + } + j |= *q; + eshdn6(equot); + } + +for( i=0; i<NI; i++ ) + b[i] = equot[i]; + +/* return flag for lost nonzero bits */ +return( (int)j ); +} + + +/* +eshow(str, x) +char *str; +unsigned short *x; +{ +int i; + +printf( "%s ", str ); +for( i=0; i<NI; i++ ) + printf( "%04x ", *x++ ); +printf( "\n" ); +} +*/ +#endif + + + +/* + * Normalize and round off. + * + * The internal format number to be rounded is "s". + * Input "lost" indicates whether the number is exact. + * This is the so-called sticky bit. + * + * Input "subflg" indicates whether the number was obtained + * by a subtraction operation. In that case if lost is nonzero + * then the number is slightly smaller than indicated. + * + * Input "exp" is the biased exponent, which may be negative. + * the exponent field of "s" is ignored but is replaced by + * "exp" as adjusted by normalization and rounding. + * + * Input "rcntrl" is the rounding control. + */ + +static int rlast = -1; +static int rw = 0; +static unsigned short rmsk = 0; +static unsigned short rmbit = 0; +static unsigned short rebit = 0; +static int re = 0; +static unsigned short rbit[NI] = {0,0,0,0,0,0,0,0}; + +void emdnorm( s, lost, subflg, exp, rcntrl ) +unsigned short s[]; +int lost; +int subflg; +long exp; +int rcntrl; +{ +int i, j; +unsigned short r; + +/* Normalize */ +j = enormlz( s ); + +/* a blank significand could mean either zero or infinity. */ +#ifndef INFINITY +if( j > NBITS ) + { + ecleazs( s ); + return; + } +#endif +exp -= j; +#ifndef INFINITY +if( exp >= 32767L ) + goto overf; +#else +if( (j > NBITS) && (exp < 32767L) ) + { + ecleazs( s ); + return; + } +#endif +if( exp < 0L ) + { + if( exp > (long )(-NBITS-1) ) + { + j = (int )exp; + i = eshift( s, j ); + if( i ) + lost = 1; + } + else + { + ecleazs( s ); + return; + } + } +/* Round off, unless told not to by rcntrl. */ +if( rcntrl == 0 ) + goto mdfin; +/* Set up rounding parameters if the control register changed. */ +if( rndprc != rlast ) + { + ecleaz( rbit ); + switch( rndprc ) + { + default: + case NBITS: + rw = NI-1; /* low guard word */ + rmsk = 0xffff; + rmbit = 0x8000; + rebit = 1; + re = rw - 1; + break; + case 113: + rw = 10; + rmsk = 0x7fff; + rmbit = 0x4000; + rebit = 0x8000; + re = rw; + break; + case 64: + rw = 7; + rmsk = 0xffff; + rmbit = 0x8000; + rebit = 1; + re = rw-1; + break; +/* For DEC arithmetic */ + case 56: + rw = 6; + rmsk = 0xff; + rmbit = 0x80; + rebit = 0x100; + re = rw; + break; + case 53: + rw = 6; + rmsk = 0x7ff; + rmbit = 0x0400; + rebit = 0x800; + re = rw; + break; + case 24: + rw = 4; + rmsk = 0xff; + rmbit = 0x80; + rebit = 0x100; + re = rw; + break; + } + rbit[re] = rebit; + rlast = rndprc; + } + +/* Shift down 1 temporarily if the data structure has an implied + * most significant bit and the number is denormal. + * For rndprc = 64 or NBITS, there is no implied bit. + * But Intel long double denormals lose one bit of significance even so. + */ +#ifdef IBMPC +if( (exp <= 0) && (rndprc != NBITS) ) +#else +if( (exp <= 0) && (rndprc != 64) && (rndprc != NBITS) ) +#endif + { + lost |= s[NI-1] & 1; + eshdn1(s); + } +/* Clear out all bits below the rounding bit, + * remembering in r if any were nonzero. + */ +r = s[rw] & rmsk; +if( rndprc < NBITS ) + { + i = rw + 1; + while( i < NI ) + { + if( s[i] ) + r |= 1; + s[i] = 0; + ++i; + } + } +s[rw] &= ~rmsk; +if( (r & rmbit) != 0 ) + { + if( r == rmbit ) + { + if( lost == 0 ) + { /* round to even */ + if( (s[re] & rebit) == 0 ) + goto mddone; + } + else + { + if( subflg != 0 ) + goto mddone; + } + } + eaddm( rbit, s ); + } +mddone: +#ifdef IBMPC +if( (exp <= 0) && (rndprc != NBITS) ) +#else +if( (exp <= 0) && (rndprc != 64) && (rndprc != NBITS) ) +#endif + { + eshup1(s); + } +if( s[2] != 0 ) + { /* overflow on roundoff */ + eshdn1(s); + exp += 1; + } +mdfin: +s[NI-1] = 0; +if( exp >= 32767L ) + { +#ifndef INFINITY +overf: +#endif +#ifdef INFINITY + s[1] = 32767; + for( i=2; i<NI-1; i++ ) + s[i] = 0; +#else + s[1] = 32766; + s[2] = 0; + for( i=M+1; i<NI-1; i++ ) + s[i] = 0xffff; + s[NI-1] = 0; + if( (rndprc < 64) || (rndprc == 113) ) + { + s[rw] &= ~rmsk; + if( rndprc == 24 ) + { + s[5] = 0; + s[6] = 0; + } + } +#endif + return; + } +if( exp < 0 ) + s[1] = 0; +else + s[1] = (unsigned short )exp; +} + + + +/* +; Subtract external format numbers. +; +; unsigned short a[NE], b[NE], c[NE]; +; esub( a, b, c ); c = b - a +*/ + +static int subflg = 0; + +void esub( a, b, c ) +unsigned short *a, *b, *c; +{ + +#ifdef NANS +if( eisnan(a) ) + { + emov (a, c); + return; + } +if( eisnan(b) ) + { + emov(b,c); + return; + } +/* Infinity minus infinity is a NaN. + * Test for subtracting infinities of the same sign. + */ +if( eisinf(a) && eisinf(b) && ((eisneg (a) ^ eisneg (b)) == 0)) + { + mtherr( "esub", DOMAIN ); + enan( c, NBITS ); + return; + } +#endif +subflg = 1; +eadd1( a, b, c ); +} + + +/* +; Add. +; +; unsigned short a[NE], b[NE], c[NE]; +; eadd( a, b, c ); c = b + a +*/ +void eadd( a, b, c ) +unsigned short *a, *b, *c; +{ + +#ifdef NANS +/* NaN plus anything is a NaN. */ +if( eisnan(a) ) + { + emov(a,c); + return; + } +if( eisnan(b) ) + { + emov(b,c); + return; + } +/* Infinity minus infinity is a NaN. + * Test for adding infinities of opposite signs. + */ +if( eisinf(a) && eisinf(b) + && ((eisneg(a) ^ eisneg(b)) != 0) ) + { + mtherr( "eadd", DOMAIN ); + enan( c, NBITS ); + return; + } +#endif +subflg = 0; +eadd1( a, b, c ); +} + +void eadd1( a, b, c ) +unsigned short *a, *b, *c; +{ +unsigned short ai[NI], bi[NI], ci[NI]; +int i, lost, j, k; +long lt, lta, ltb; + +#ifdef INFINITY +if( eisinf(a) ) + { + emov(a,c); + if( subflg ) + eneg(c); + return; + } +if( eisinf(b) ) + { + emov(b,c); + return; + } +#endif +emovi( a, ai ); +emovi( b, bi ); +if( subflg ) + ai[0] = ~ai[0]; + +/* compare exponents */ +lta = ai[E]; +ltb = bi[E]; +lt = lta - ltb; +if( lt > 0L ) + { /* put the larger number in bi */ + emovz( bi, ci ); + emovz( ai, bi ); + emovz( ci, ai ); + ltb = bi[E]; + lt = -lt; + } +lost = 0; +if( lt != 0L ) + { + if( lt < (long )(-NBITS-1) ) + goto done; /* answer same as larger addend */ + k = (int )lt; + lost = eshift( ai, k ); /* shift the smaller number down */ + } +else + { +/* exponents were the same, so must compare significands */ + i = ecmpm( ai, bi ); + if( i == 0 ) + { /* the numbers are identical in magnitude */ + /* if different signs, result is zero */ + if( ai[0] != bi[0] ) + { + eclear(c); + return; + } + /* if same sign, result is double */ + /* double denomalized tiny number */ + if( (bi[E] == 0) && ((bi[3] & 0x8000) == 0) ) + { + eshup1( bi ); + goto done; + } + /* add 1 to exponent unless both are zero! */ + for( j=1; j<NI-1; j++ ) + { + if( bi[j] != 0 ) + { +/* This could overflow, but let emovo take care of that. */ + ltb += 1; + break; + } + } + bi[E] = (unsigned short )ltb; + goto done; + } + if( i > 0 ) + { /* put the larger number in bi */ + emovz( bi, ci ); + emovz( ai, bi ); + emovz( ci, ai ); + } + } +if( ai[0] == bi[0] ) + { + eaddm( ai, bi ); + subflg = 0; + } +else + { + esubm( ai, bi ); + subflg = 1; + } +emdnorm( bi, lost, subflg, ltb, 64 ); + +done: +emovo( bi, c ); +} + + + +/* +; Divide. +; +; unsigned short a[NE], b[NE], c[NE]; +; ediv( a, b, c ); c = b / a +*/ +void ediv( a, b, c ) +unsigned short *a, *b, *c; +{ +unsigned short ai[NI], bi[NI]; +int i, sign; +long lt, lta, ltb; + +/* IEEE says if result is not a NaN, the sign is "-" if and only if + operands have opposite signs -- but flush -0 to 0 later if not IEEE. */ +sign = eisneg(a) ^ eisneg(b); + +#ifdef NANS +/* Return any NaN input. */ +if( eisnan(a) ) + { + emov(a,c); + return; + } +if( eisnan(b) ) + { + emov(b,c); + return; + } +/* Zero over zero, or infinity over infinity, is a NaN. */ +if( ((ecmp(a,ezero) == 0) && (ecmp(b,ezero) == 0)) + || (eisinf (a) && eisinf (b)) ) + { + mtherr( "ediv", DOMAIN ); + enan( c, NBITS ); + return; + } +#endif +/* Infinity over anything else is infinity. */ +#ifdef INFINITY +if( eisinf(b) ) + { + einfin(c); + goto divsign; + } +if( eisinf(a) ) + { + eclear(c); + goto divsign; + } +#endif +emovi( a, ai ); +emovi( b, bi ); +lta = ai[E]; +ltb = bi[E]; +if( bi[E] == 0 ) + { /* See if numerator is zero. */ + for( i=1; i<NI-1; i++ ) + { + if( bi[i] != 0 ) + { + ltb -= enormlz( bi ); + goto dnzro1; + } + } + eclear(c); + goto divsign; + } +dnzro1: + +if( ai[E] == 0 ) + { /* possible divide by zero */ + for( i=1; i<NI-1; i++ ) + { + if( ai[i] != 0 ) + { + lta -= enormlz( ai ); + goto dnzro2; + } + } + einfin(c); + mtherr( "ediv", SING ); + goto divsign; + } +dnzro2: + +i = edivm( ai, bi ); +/* calculate exponent */ +lt = ltb - lta + EXONE; +emdnorm( bi, i, 0, lt, 64 ); +emovo( bi, c ); + +divsign: + +if( sign ) + *(c+(NE-1)) |= 0x8000; +else + *(c+(NE-1)) &= ~0x8000; +} + + + +/* +; Multiply. +; +; unsigned short a[NE], b[NE], c[NE]; +; emul( a, b, c ); c = b * a +*/ +void emul( a, b, c ) +unsigned short *a, *b, *c; +{ +unsigned short ai[NI], bi[NI]; +int i, j, sign; +long lt, lta, ltb; + +/* IEEE says if result is not a NaN, the sign is "-" if and only if + operands have opposite signs -- but flush -0 to 0 later if not IEEE. */ +sign = eisneg(a) ^ eisneg(b); + +#ifdef NANS +/* NaN times anything is the same NaN. */ +if( eisnan(a) ) + { + emov(a,c); + return; + } +if( eisnan(b) ) + { + emov(b,c); + return; + } +/* Zero times infinity is a NaN. */ +if( (eisinf(a) && (ecmp(b,ezero) == 0)) + || (eisinf(b) && (ecmp(a,ezero) == 0)) ) + { + mtherr( "emul", DOMAIN ); + enan( c, NBITS ); + return; + } +#endif +/* Infinity times anything else is infinity. */ +#ifdef INFINITY +if( eisinf(a) || eisinf(b) ) + { + einfin(c); + goto mulsign; + } +#endif +emovi( a, ai ); +emovi( b, bi ); +lta = ai[E]; +ltb = bi[E]; +if( ai[E] == 0 ) + { + for( i=1; i<NI-1; i++ ) + { + if( ai[i] != 0 ) + { + lta -= enormlz( ai ); + goto mnzer1; + } + } + eclear(c); + goto mulsign; + } +mnzer1: + +if( bi[E] == 0 ) + { + for( i=1; i<NI-1; i++ ) + { + if( bi[i] != 0 ) + { + ltb -= enormlz( bi ); + goto mnzer2; + } + } + eclear(c); + goto mulsign; + } +mnzer2: + +/* Multiply significands */ +j = emulm( ai, bi ); +/* calculate exponent */ +lt = lta + ltb - (EXONE - 1); +emdnorm( bi, j, 0, lt, 64 ); +emovo( bi, c ); +/* IEEE says sign is "-" if and only if operands have opposite signs. */ +mulsign: +if( sign ) + *(c+(NE-1)) |= 0x8000; +else + *(c+(NE-1)) &= ~0x8000; +} + + + + +/* +; Convert IEEE double precision to e type +; double d; +; unsigned short x[N+2]; +; e53toe( &d, x ); +*/ +void e53toe( pe, y ) +unsigned short *pe, *y; +{ +#ifdef DEC + +dectoe( pe, y ); /* see etodec.c */ + +#else + +register unsigned short r; +register unsigned short *p, *e; +unsigned short yy[NI]; +int denorm, k; + +e = pe; +denorm = 0; /* flag if denormalized number */ +ecleaz(yy); +#ifdef IBMPC +e += 3; +#endif +r = *e; +yy[0] = 0; +if( r & 0x8000 ) + yy[0] = 0xffff; +yy[M] = (r & 0x0f) | 0x10; +r &= ~0x800f; /* strip sign and 4 significand bits */ +#ifdef INFINITY +if( r == 0x7ff0 ) + { +#ifdef NANS +#ifdef IBMPC + if( ((pe[3] & 0xf) != 0) || (pe[2] != 0) + || (pe[1] != 0) || (pe[0] != 0) ) + { + enan( y, NBITS ); + return; + } +#else + if( ((pe[0] & 0xf) != 0) || (pe[1] != 0) + || (pe[2] != 0) || (pe[3] != 0) ) + { + enan( y, NBITS ); + return; + } +#endif +#endif /* NANS */ + eclear( y ); + einfin( y ); + if( yy[0] ) + eneg(y); + return; + } +#endif +r >>= 4; +/* If zero exponent, then the significand is denormalized. + * So, take back the understood high significand bit. */ +if( r == 0 ) + { + denorm = 1; + yy[M] &= ~0x10; + } +r += EXONE - 01777; +yy[E] = r; +p = &yy[M+1]; +#ifdef IBMPC +*p++ = *(--e); +*p++ = *(--e); +*p++ = *(--e); +#endif +#ifdef MIEEE +++e; +*p++ = *e++; +*p++ = *e++; +*p++ = *e++; +#endif +(void )eshift( yy, -5 ); +if( denorm ) + { /* if zero exponent, then normalize the significand */ + if( (k = enormlz(yy)) > NBITS ) + ecleazs(yy); + else + yy[E] -= (unsigned short )(k-1); + } +emovo( yy, y ); +#endif /* not DEC */ +} + +void e64toe( pe, y ) +unsigned short *pe, *y; +{ +unsigned short yy[NI]; +unsigned short *p, *q, *e; +int i; + +e = pe; +p = yy; +for( i=0; i<NE-5; i++ ) + *p++ = 0; +#ifdef IBMPC +for( i=0; i<5; i++ ) + *p++ = *e++; +#endif +#ifdef DEC +for( i=0; i<5; i++ ) + *p++ = *e++; +#endif +#ifdef MIEEE +p = &yy[0] + (NE-1); +*p-- = *e++; +++e; +for( i=0; i<4; i++ ) + *p-- = *e++; +#endif + +#ifdef IBMPC +/* For Intel long double, shift denormal significand up 1 + -- but only if the top significand bit is zero. */ +if((yy[NE-1] & 0x7fff) == 0 && (yy[NE-2] & 0x8000) == 0) + { + unsigned short temp[NI+1]; + emovi(yy, temp); + eshup1(temp); + emovo(temp,y); + return; + } +#endif +#ifdef INFINITY +/* Point to the exponent field. */ +p = &yy[NE-1]; +if( *p == 0x7fff ) + { +#ifdef NANS +#ifdef IBMPC + for( i=0; i<4; i++ ) + { + if((i != 3 && pe[i] != 0) + /* Check for Intel long double infinity pattern. */ + || (i == 3 && pe[i] != 0x8000)) + { + enan( y, NBITS ); + return; + } + } +#else + for( i=1; i<=4; i++ ) + { + if( pe[i] != 0 ) + { + enan( y, NBITS ); + return; + } + } +#endif +#endif /* NANS */ + eclear( y ); + einfin( y ); + if( *p & 0x8000 ) + eneg(y); + return; + } +#endif +p = yy; +q = y; +for( i=0; i<NE; i++ ) + *q++ = *p++; +} + +void e113toe(pe,y) +unsigned short *pe, *y; +{ +register unsigned short r; +unsigned short *e, *p; +unsigned short yy[NI]; +int i; + +e = pe; +ecleaz(yy); +#ifdef IBMPC +e += 7; +#endif +r = *e; +yy[0] = 0; +if( r & 0x8000 ) + yy[0] = 0xffff; +r &= 0x7fff; +#ifdef INFINITY +if( r == 0x7fff ) + { +#ifdef NANS +#ifdef IBMPC + for( i=0; i<7; i++ ) + { + if( pe[i] != 0 ) + { + enan( y, NBITS ); + return; + } + } +#else + for( i=1; i<8; i++ ) + { + if( pe[i] != 0 ) + { + enan( y, NBITS ); + return; + } + } +#endif +#endif /* NANS */ + eclear( y ); + einfin( y ); + if( *e & 0x8000 ) + eneg(y); + return; + } +#endif /* INFINITY */ +yy[E] = r; +p = &yy[M + 1]; +#ifdef IBMPC +for( i=0; i<7; i++ ) + *p++ = *(--e); +#endif +#ifdef MIEEE +++e; +for( i=0; i<7; i++ ) + *p++ = *e++; +#endif +/* If denormal, remove the implied bit; else shift down 1. */ +if( r == 0 ) + { + yy[M] = 0; + } +else + { + yy[M] = 1; + eshift( yy, -1 ); + } +emovo(yy,y); +} + + +/* +; Convert IEEE single precision to e type +; float d; +; unsigned short x[N+2]; +; dtox( &d, x ); +*/ +void e24toe( pe, y ) +unsigned short *pe, *y; +{ +register unsigned short r; +register unsigned short *p, *e; +unsigned short yy[NI]; +int denorm, k; + +e = pe; +denorm = 0; /* flag if denormalized number */ +ecleaz(yy); +#ifdef IBMPC +e += 1; +#endif +#ifdef DEC +e += 1; +#endif +r = *e; +yy[0] = 0; +if( r & 0x8000 ) + yy[0] = 0xffff; +yy[M] = (r & 0x7f) | 0200; +r &= ~0x807f; /* strip sign and 7 significand bits */ +#ifdef INFINITY +if( r == 0x7f80 ) + { +#ifdef NANS +#ifdef MIEEE + if( ((pe[0] & 0x7f) != 0) || (pe[1] != 0) ) + { + enan( y, NBITS ); + return; + } +#else + if( ((pe[1] & 0x7f) != 0) || (pe[0] != 0) ) + { + enan( y, NBITS ); + return; + } +#endif +#endif /* NANS */ + eclear( y ); + einfin( y ); + if( yy[0] ) + eneg(y); + return; + } +#endif +r >>= 7; +/* If zero exponent, then the significand is denormalized. + * So, take back the understood high significand bit. */ +if( r == 0 ) + { + denorm = 1; + yy[M] &= ~0200; + } +r += EXONE - 0177; +yy[E] = r; +p = &yy[M+1]; +#ifdef IBMPC +*p++ = *(--e); +#endif +#ifdef DEC +*p++ = *(--e); +#endif +#ifdef MIEEE +++e; +*p++ = *e++; +#endif +(void )eshift( yy, -8 ); +if( denorm ) + { /* if zero exponent, then normalize the significand */ + if( (k = enormlz(yy)) > NBITS ) + ecleazs(yy); + else + yy[E] -= (unsigned short )(k-1); + } +emovo( yy, y ); +} + +void etoe113(x,e) +unsigned short *x, *e; +{ +unsigned short xi[NI]; +long exp; +int rndsav; + +#ifdef NANS +if( eisnan(x) ) + { + enan( e, 113 ); + return; + } +#endif +emovi( x, xi ); +exp = (long )xi[E]; +#ifdef INFINITY +if( eisinf(x) ) + goto nonorm; +#endif +/* round off to nearest or even */ +rndsav = rndprc; +rndprc = 113; +emdnorm( xi, 0, 0, exp, 64 ); +rndprc = rndsav; +nonorm: +toe113 (xi, e); +} + +/* move out internal format to ieee long double */ +static void toe113(a,b) +unsigned short *a, *b; +{ +register unsigned short *p, *q; +unsigned short i; + +#ifdef NANS +if( eiisnan(a) ) + { + enan( b, 113 ); + return; + } +#endif +p = a; +#ifdef MIEEE +q = b; +#else +q = b + 7; /* point to output exponent */ +#endif + +/* If not denormal, delete the implied bit. */ +if( a[E] != 0 ) + { + eshup1 (a); + } +/* combine sign and exponent */ +i = *p++; +#ifdef MIEEE +if( i ) + *q++ = *p++ | 0x8000; +else + *q++ = *p++; +#else +if( i ) + *q-- = *p++ | 0x8000; +else + *q-- = *p++; +#endif +/* skip over guard word */ +++p; +/* move the significand */ +#ifdef MIEEE +for (i = 0; i < 7; i++) + *q++ = *p++; +#else +for (i = 0; i < 7; i++) + *q-- = *p++; +#endif +} + + +void etoe64( x, e ) +unsigned short *x, *e; +{ +unsigned short xi[NI]; +long exp; +int rndsav; + +#ifdef NANS +if( eisnan(x) ) + { + enan( e, 64 ); + return; + } +#endif +emovi( x, xi ); +exp = (long )xi[E]; /* adjust exponent for offset */ +#ifdef INFINITY +if( eisinf(x) ) + goto nonorm; +#endif +/* round off to nearest or even */ +rndsav = rndprc; +rndprc = 64; +emdnorm( xi, 0, 0, exp, 64 ); +rndprc = rndsav; +nonorm: +toe64( xi, e ); +} + +/* move out internal format to ieee long double */ +static void toe64( a, b ) +unsigned short *a, *b; +{ +register unsigned short *p, *q; +unsigned short i; + +#ifdef NANS +if( eiisnan(a) ) + { + enan( b, 64 ); + return; + } +#endif +#ifdef IBMPC +/* Shift Intel denormal significand down 1. */ +if( a[E] == 0 ) + eshdn1(a); +#endif +p = a; +#ifdef MIEEE +q = b; +#else +q = b + 4; /* point to output exponent */ +#if 1 +/* NOTE: if data type is 96 bits wide, clear the last word here. */ +*(q+1)= 0; +#endif +#endif + +/* combine sign and exponent */ +i = *p++; +#ifdef MIEEE +if( i ) + *q++ = *p++ | 0x8000; +else + *q++ = *p++; +*q++ = 0; +#else +if( i ) + *q-- = *p++ | 0x8000; +else + *q-- = *p++; +#endif +/* skip over guard word */ +++p; +/* move the significand */ +#ifdef MIEEE +for( i=0; i<4; i++ ) + *q++ = *p++; +#else +#ifdef INFINITY +if (eiisinf (a)) + { + /* Intel long double infinity. */ + *q-- = 0x8000; + *q-- = 0; + *q-- = 0; + *q = 0; + return; + } +#endif +for( i=0; i<4; i++ ) + *q-- = *p++; +#endif +} + + +/* +; e type to IEEE double precision +; double d; +; unsigned short x[NE]; +; etoe53( x, &d ); +*/ + +#ifdef DEC + +void etoe53( x, e ) +unsigned short *x, *e; +{ +etodec( x, e ); /* see etodec.c */ +} + +static void toe53( x, y ) +unsigned short *x, *y; +{ +todec( x, y ); +} + +#else + +void etoe53( x, e ) +unsigned short *x, *e; +{ +unsigned short xi[NI]; +long exp; +int rndsav; + +#ifdef NANS +if( eisnan(x) ) + { + enan( e, 53 ); + return; + } +#endif +emovi( x, xi ); +exp = (long )xi[E] - (EXONE - 0x3ff); /* adjust exponent for offsets */ +#ifdef INFINITY +if( eisinf(x) ) + goto nonorm; +#endif +/* round off to nearest or even */ +rndsav = rndprc; +rndprc = 53; +emdnorm( xi, 0, 0, exp, 64 ); +rndprc = rndsav; +nonorm: +toe53( xi, e ); +} + + +static void toe53( x, y ) +unsigned short *x, *y; +{ +unsigned short i; +unsigned short *p; + + +#ifdef NANS +if( eiisnan(x) ) + { + enan( y, 53 ); + return; + } +#endif +p = &x[0]; +#ifdef IBMPC +y += 3; +#endif +*y = 0; /* output high order */ +if( *p++ ) + *y = 0x8000; /* output sign bit */ + +i = *p++; +if( i >= (unsigned int )2047 ) + { /* Saturate at largest number less than infinity. */ +#ifdef INFINITY + *y |= 0x7ff0; +#ifdef IBMPC + *(--y) = 0; + *(--y) = 0; + *(--y) = 0; +#endif +#ifdef MIEEE + ++y; + *y++ = 0; + *y++ = 0; + *y++ = 0; +#endif +#else + *y |= (unsigned short )0x7fef; +#ifdef IBMPC + *(--y) = 0xffff; + *(--y) = 0xffff; + *(--y) = 0xffff; +#endif +#ifdef MIEEE + ++y; + *y++ = 0xffff; + *y++ = 0xffff; + *y++ = 0xffff; +#endif +#endif + return; + } +if( i == 0 ) + { + (void )eshift( x, 4 ); + } +else + { + i <<= 4; + (void )eshift( x, 5 ); + } +i |= *p++ & (unsigned short )0x0f; /* *p = xi[M] */ +*y |= (unsigned short )i; /* high order output already has sign bit set */ +#ifdef IBMPC +*(--y) = *p++; +*(--y) = *p++; +*(--y) = *p; +#endif +#ifdef MIEEE +++y; +*y++ = *p++; +*y++ = *p++; +*y++ = *p++; +#endif +} + +#endif /* not DEC */ + + + +/* +; e type to IEEE single precision +; float d; +; unsigned short x[N+2]; +; xtod( x, &d ); +*/ +void etoe24( x, e ) +unsigned short *x, *e; +{ +long exp; +unsigned short xi[NI]; +int rndsav; + +#ifdef NANS +if( eisnan(x) ) + { + enan( e, 24 ); + return; + } +#endif +emovi( x, xi ); +exp = (long )xi[E] - (EXONE - 0177); /* adjust exponent for offsets */ +#ifdef INFINITY +if( eisinf(x) ) + goto nonorm; +#endif +/* round off to nearest or even */ +rndsav = rndprc; +rndprc = 24; +emdnorm( xi, 0, 0, exp, 64 ); +rndprc = rndsav; +nonorm: +toe24( xi, e ); +} + +static void toe24( x, y ) +unsigned short *x, *y; +{ +unsigned short i; +unsigned short *p; + +#ifdef NANS +if( eiisnan(x) ) + { + enan( y, 24 ); + return; + } +#endif +p = &x[0]; +#ifdef IBMPC +y += 1; +#endif +#ifdef DEC +y += 1; +#endif +*y = 0; /* output high order */ +if( *p++ ) + *y = 0x8000; /* output sign bit */ + +i = *p++; +if( i >= 255 ) + { /* Saturate at largest number less than infinity. */ +#ifdef INFINITY + *y |= (unsigned short )0x7f80; +#ifdef IBMPC + *(--y) = 0; +#endif +#ifdef DEC + *(--y) = 0; +#endif +#ifdef MIEEE + ++y; + *y = 0; +#endif +#else + *y |= (unsigned short )0x7f7f; +#ifdef IBMPC + *(--y) = 0xffff; +#endif +#ifdef DEC + *(--y) = 0xffff; +#endif +#ifdef MIEEE + ++y; + *y = 0xffff; +#endif +#endif + return; + } +if( i == 0 ) + { + (void )eshift( x, 7 ); + } +else + { + i <<= 7; + (void )eshift( x, 8 ); + } +i |= *p++ & (unsigned short )0x7f; /* *p = xi[M] */ +*y |= i; /* high order output already has sign bit set */ +#ifdef IBMPC +*(--y) = *p; +#endif +#ifdef DEC +*(--y) = *p; +#endif +#ifdef MIEEE +++y; +*y = *p; +#endif +} + + +/* Compare two e type numbers. + * + * unsigned short a[NE], b[NE]; + * ecmp( a, b ); + * + * returns +1 if a > b + * 0 if a == b + * -1 if a < b + * -2 if either a or b is a NaN. + */ +int ecmp( a, b ) +unsigned short *a, *b; +{ +unsigned short ai[NI], bi[NI]; +register unsigned short *p, *q; +register int i; +int msign; + +#ifdef NANS +if (eisnan (a) || eisnan (b)) + return( -2 ); +#endif +emovi( a, ai ); +p = ai; +emovi( b, bi ); +q = bi; + +if( *p != *q ) + { /* the signs are different */ +/* -0 equals + 0 */ + for( i=1; i<NI-1; i++ ) + { + if( ai[i] != 0 ) + goto nzro; + if( bi[i] != 0 ) + goto nzro; + } + return(0); +nzro: + if( *p == 0 ) + return( 1 ); + else + return( -1 ); + } +/* both are the same sign */ +if( *p == 0 ) + msign = 1; +else + msign = -1; +i = NI-1; +do + { + if( *p++ != *q++ ) + { + goto diff; + } + } +while( --i > 0 ); + +return(0); /* equality */ + + + +diff: + +if( *(--p) > *(--q) ) + return( msign ); /* p is bigger */ +else + return( -msign ); /* p is littler */ +} + + + + +/* Find nearest integer to x = floor( x + 0.5 ) + * + * unsigned short x[NE], y[NE] + * eround( x, y ); + */ +void eround( x, y ) +unsigned short *x, *y; +{ + +eadd( ehalf, x, y ); +efloor( y, y ); +} + + + + +/* +; convert long (32-bit) integer to e type +; +; long l; +; unsigned short x[NE]; +; ltoe( &l, x ); +; note &l is the memory address of l +*/ +void ltoe( lp, y ) +long *lp; /* lp is the memory address of a long integer */ +unsigned short *y; /* y is the address of a short */ +{ +unsigned short yi[NI]; +unsigned long ll; +int k; + +ecleaz( yi ); +if( *lp < 0 ) + { + ll = (unsigned long )( -(*lp) ); /* make it positive */ + yi[0] = 0xffff; /* put correct sign in the e type number */ + } +else + { + ll = (unsigned long )( *lp ); + } +/* move the long integer to yi significand area */ +if( sizeof(long) == 8 ) + { + yi[M] = (unsigned short) (ll >> (LONGBITS - 16)); + yi[M + 1] = (unsigned short) (ll >> (LONGBITS - 32)); + yi[M + 2] = (unsigned short) (ll >> 16); + yi[M + 3] = (unsigned short) ll; + yi[E] = EXONE + 47; /* exponent if normalize shift count were 0 */ + } +else + { + yi[M] = (unsigned short )(ll >> 16); + yi[M+1] = (unsigned short )ll; + yi[E] = EXONE + 15; /* exponent if normalize shift count were 0 */ + } +if( (k = enormlz( yi )) > NBITS ) /* normalize the significand */ + ecleaz( yi ); /* it was zero */ +else + yi[E] -= (unsigned short )k; /* subtract shift count from exponent */ +emovo( yi, y ); /* output the answer */ +} + +/* +; convert unsigned long (32-bit) integer to e type +; +; unsigned long l; +; unsigned short x[NE]; +; ltox( &l, x ); +; note &l is the memory address of l +*/ +void ultoe( lp, y ) +unsigned long *lp; /* lp is the memory address of a long integer */ +unsigned short *y; /* y is the address of a short */ +{ +unsigned short yi[NI]; +unsigned long ll; +int k; + +ecleaz( yi ); +ll = *lp; + +/* move the long integer to ayi significand area */ +if( sizeof(long) == 8 ) + { + yi[M] = (unsigned short) (ll >> (LONGBITS - 16)); + yi[M + 1] = (unsigned short) (ll >> (LONGBITS - 32)); + yi[M + 2] = (unsigned short) (ll >> 16); + yi[M + 3] = (unsigned short) ll; + yi[E] = EXONE + 47; /* exponent if normalize shift count were 0 */ + } +else + { + yi[M] = (unsigned short )(ll >> 16); + yi[M+1] = (unsigned short )ll; + yi[E] = EXONE + 15; /* exponent if normalize shift count were 0 */ + } +if( (k = enormlz( yi )) > NBITS ) /* normalize the significand */ + ecleaz( yi ); /* it was zero */ +else + yi[E] -= (unsigned short )k; /* subtract shift count from exponent */ +emovo( yi, y ); /* output the answer */ +} + + +/* +; Find long integer and fractional parts + +; long i; +; unsigned short x[NE], frac[NE]; +; xifrac( x, &i, frac ); + + The integer output has the sign of the input. The fraction is + the positive fractional part of abs(x). +*/ +void eifrac( x, i, frac ) +unsigned short *x; +long *i; +unsigned short *frac; +{ +unsigned short xi[NI]; +int j, k; +unsigned long ll; + +emovi( x, xi ); +k = (int )xi[E] - (EXONE - 1); +if( k <= 0 ) + { +/* if exponent <= 0, integer = 0 and real output is fraction */ + *i = 0L; + emovo( xi, frac ); + return; + } +if( k > (8 * sizeof(long) - 1) ) + { +/* +; long integer overflow: output large integer +; and correct fraction +*/ + j = 8 * sizeof(long) - 1; + if( xi[0] ) + *i = (long) ((unsigned long) 1) << j; + else + *i = (long) (((unsigned long) (~(0L))) >> 1); + (void )eshift( xi, k ); + } +if( k > 16 ) + { +/* + Shift more than 16 bits: shift up k-16 mod 16 + then shift by 16's. +*/ + j = k - ((k >> 4) << 4); + eshift (xi, j); + ll = xi[M]; + k -= j; + do + { + eshup6 (xi); + ll = (ll << 16) | xi[M]; + } + while ((k -= 16) > 0); + *i = ll; + if (xi[0]) + *i = -(*i); + } +else + { +/* shift not more than 16 bits */ + eshift( xi, k ); + *i = (long )xi[M] & 0xffff; + if( xi[0] ) + *i = -(*i); + } +xi[0] = 0; +xi[E] = EXONE - 1; +xi[M] = 0; +if( (k = enormlz( xi )) > NBITS ) + ecleaz( xi ); +else + xi[E] -= (unsigned short )k; + +emovo( xi, frac ); +} + + +/* +; Find unsigned long integer and fractional parts + +; unsigned long i; +; unsigned short x[NE], frac[NE]; +; xifrac( x, &i, frac ); + + A negative e type input yields integer output = 0 + but correct fraction. +*/ +void euifrac( x, i, frac ) +unsigned short *x; +unsigned long *i; +unsigned short *frac; +{ +unsigned short xi[NI]; +int j, k; +unsigned long ll; + +emovi( x, xi ); +k = (int )xi[E] - (EXONE - 1); +if( k <= 0 ) + { +/* if exponent <= 0, integer = 0 and argument is fraction */ + *i = 0L; + emovo( xi, frac ); + return; + } +if( k > (8 * sizeof(long)) ) + { +/* +; long integer overflow: output large integer +; and correct fraction +*/ + *i = ~(0L); + (void )eshift( xi, k ); + } +else if( k > 16 ) + { +/* + Shift more than 16 bits: shift up k-16 mod 16 + then shift up by 16's. +*/ + j = k - ((k >> 4) << 4); + eshift (xi, j); + ll = xi[M]; + k -= j; + do + { + eshup6 (xi); + ll = (ll << 16) | xi[M]; + } + while ((k -= 16) > 0); + *i = ll; + } +else + { +/* shift not more than 16 bits */ + eshift( xi, k ); + *i = (long )xi[M] & 0xffff; + } + +if( xi[0] ) /* A negative value yields unsigned integer 0. */ + *i = 0L; + +xi[0] = 0; +xi[E] = EXONE - 1; +xi[M] = 0; +if( (k = enormlz( xi )) > NBITS ) + ecleaz( xi ); +else + xi[E] -= (unsigned short )k; + +emovo( xi, frac ); +} + + + +/* +; Shift significand +; +; Shifts significand area up or down by the number of bits +; given by the variable sc. +*/ +int eshift( x, sc ) +unsigned short *x; +int sc; +{ +unsigned short lost; +unsigned short *p; + +if( sc == 0 ) + return( 0 ); + +lost = 0; +p = x + NI-1; + +if( sc < 0 ) + { + sc = -sc; + while( sc >= 16 ) + { + lost |= *p; /* remember lost bits */ + eshdn6(x); + sc -= 16; + } + + while( sc >= 8 ) + { + lost |= *p & 0xff; + eshdn8(x); + sc -= 8; + } + + while( sc > 0 ) + { + lost |= *p & 1; + eshdn1(x); + sc -= 1; + } + } +else + { + while( sc >= 16 ) + { + eshup6(x); + sc -= 16; + } + + while( sc >= 8 ) + { + eshup8(x); + sc -= 8; + } + + while( sc > 0 ) + { + eshup1(x); + sc -= 1; + } + } +if( lost ) + lost = 1; +return( (int )lost ); +} + + + +/* +; normalize +; +; Shift normalizes the significand area pointed to by argument +; shift count (up = positive) is returned. +*/ +int enormlz(x) +unsigned short x[]; +{ +register unsigned short *p; +int sc; + +sc = 0; +p = &x[M]; +if( *p != 0 ) + goto normdn; +++p; +if( *p & 0x8000 ) + return( 0 ); /* already normalized */ +while( *p == 0 ) + { + eshup6(x); + sc += 16; +/* With guard word, there are NBITS+16 bits available. + * return true if all are zero. + */ + if( sc > NBITS ) + return( sc ); + } +/* see if high byte is zero */ +while( (*p & 0xff00) == 0 ) + { + eshup8(x); + sc += 8; + } +/* now shift 1 bit at a time */ +while( (*p & 0x8000) == 0) + { + eshup1(x); + sc += 1; + if( sc > (NBITS+16) ) + { + mtherr( "enormlz", UNDERFLOW ); + return( sc ); + } + } +return( sc ); + +/* Normalize by shifting down out of the high guard word + of the significand */ +normdn: + +if( *p & 0xff00 ) + { + eshdn8(x); + sc -= 8; + } +while( *p != 0 ) + { + eshdn1(x); + sc -= 1; + + if( sc < -NBITS ) + { + mtherr( "enormlz", OVERFLOW ); + return( sc ); + } + } +return( sc ); +} + + + + +/* Convert e type number to decimal format ASCII string. + * The constants are for 64 bit precision. + */ + +#define NTEN 12 +#define MAXP 4096 + +#if NE == 10 +static unsigned short etens[NTEN + 1][NE] = +{ + {0x6576, 0x4a92, 0x804a, 0x153f, + 0xc94c, 0x979a, 0x8a20, 0x5202, 0xc460, 0x7525,}, /* 10**4096 */ + {0x6a32, 0xce52, 0x329a, 0x28ce, + 0xa74d, 0x5de4, 0xc53d, 0x3b5d, 0x9e8b, 0x5a92,}, /* 10**2048 */ + {0x526c, 0x50ce, 0xf18b, 0x3d28, + 0x650d, 0x0c17, 0x8175, 0x7586, 0xc976, 0x4d48,}, + {0x9c66, 0x58f8, 0xbc50, 0x5c54, + 0xcc65, 0x91c6, 0xa60e, 0xa0ae, 0xe319, 0x46a3,}, + {0x851e, 0xeab7, 0x98fe, 0x901b, + 0xddbb, 0xde8d, 0x9df9, 0xebfb, 0xaa7e, 0x4351,}, + {0x0235, 0x0137, 0x36b1, 0x336c, + 0xc66f, 0x8cdf, 0x80e9, 0x47c9, 0x93ba, 0x41a8,}, + {0x50f8, 0x25fb, 0xc76b, 0x6b71, + 0x3cbf, 0xa6d5, 0xffcf, 0x1f49, 0xc278, 0x40d3,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0xf020, 0xb59d, 0x2b70, 0xada8, 0x9dc5, 0x4069,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0400, 0xc9bf, 0x8e1b, 0x4034,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x2000, 0xbebc, 0x4019,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0x9c40, 0x400c,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0xc800, 0x4005,}, + {0x0000, 0x0000, 0x0000, 0x0000, + 0x0000, 0x0000, 0x0000, 0x0000, 0xa000, 0x4002,}, /* 10**1 */ +}; + +static unsigned short emtens[NTEN + 1][NE] = +{ + {0x2030, 0xcffc, 0xa1c3, 0x8123, + 0x2de3, 0x9fde, 0xd2ce, 0x04c8, 0xa6dd, 0x0ad8,}, /* 10**-4096 */ + {0x8264, 0xd2cb, 0xf2ea, 0x12d4, + 0x4925, 0x2de4, 0x3436, 0x534f, 0xceae, 0x256b,}, /* 10**-2048 */ + {0xf53f, 0xf698, 0x6bd3, 0x0158, + 0x87a6, 0xc0bd, 0xda57, 0x82a5, 0xa2a6, 0x32b5,}, + {0xe731, 0x04d4, 0xe3f2, 0xd332, + 0x7132, 0xd21c, 0xdb23, 0xee32, 0x9049, 0x395a,}, + {0xa23e, 0x5308, 0xfefb, 0x1155, + 0xfa91, 0x1939, 0x637a, 0x4325, 0xc031, 0x3cac,}, + {0xe26d, 0xdbde, 0xd05d, 0xb3f6, + 0xac7c, 0xe4a0, 0x64bc, 0x467c, 0xddd0, 0x3e55,}, + {0x2a20, 0x6224, 0x47b3, 0x98d7, + 0x3f23, 0xe9a5, 0xa539, 0xea27, 0xa87f, 0x3f2a,}, + {0x0b5b, 0x4af2, 0xa581, 0x18ed, + 0x67de, 0x94ba, 0x4539, 0x1ead, 0xcfb1, 0x3f94,}, + {0xbf71, 0xa9b3, 0x7989, 0xbe68, + 0x4c2e, 0xe15b, 0xc44d, 0x94be, 0xe695, 0x3fc9,}, + {0x3d4d, 0x7c3d, 0x36ba, 0x0d2b, + 0xfdc2, 0xcefc, 0x8461, 0x7711, 0xabcc, 0x3fe4,}, + {0xc155, 0xa4a8, 0x404e, 0x6113, + 0xd3c3, 0x652b, 0xe219, 0x1758, 0xd1b7, 0x3ff1,}, + {0xd70a, 0x70a3, 0x0a3d, 0xa3d7, + 0x3d70, 0xd70a, 0x70a3, 0x0a3d, 0xa3d7, 0x3ff8,}, + {0xcccd, 0xcccc, 0xcccc, 0xcccc, + 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0xcccc, 0x3ffb,}, /* 10**-1 */ +}; +#else +static unsigned short etens[NTEN+1][NE] = { +{0xc94c,0x979a,0x8a20,0x5202,0xc460,0x7525,},/* 10**4096 */ +{0xa74d,0x5de4,0xc53d,0x3b5d,0x9e8b,0x5a92,},/* 10**2048 */ +{0x650d,0x0c17,0x8175,0x7586,0xc976,0x4d48,}, +{0xcc65,0x91c6,0xa60e,0xa0ae,0xe319,0x46a3,}, +{0xddbc,0xde8d,0x9df9,0xebfb,0xaa7e,0x4351,}, +{0xc66f,0x8cdf,0x80e9,0x47c9,0x93ba,0x41a8,}, +{0x3cbf,0xa6d5,0xffcf,0x1f49,0xc278,0x40d3,}, +{0xf020,0xb59d,0x2b70,0xada8,0x9dc5,0x4069,}, +{0x0000,0x0000,0x0400,0xc9bf,0x8e1b,0x4034,}, +{0x0000,0x0000,0x0000,0x2000,0xbebc,0x4019,}, +{0x0000,0x0000,0x0000,0x0000,0x9c40,0x400c,}, +{0x0000,0x0000,0x0000,0x0000,0xc800,0x4005,}, +{0x0000,0x0000,0x0000,0x0000,0xa000,0x4002,}, /* 10**1 */ +}; + +static unsigned short emtens[NTEN+1][NE] = { +{0x2de4,0x9fde,0xd2ce,0x04c8,0xa6dd,0x0ad8,}, /* 10**-4096 */ +{0x4925,0x2de4,0x3436,0x534f,0xceae,0x256b,}, /* 10**-2048 */ +{0x87a6,0xc0bd,0xda57,0x82a5,0xa2a6,0x32b5,}, +{0x7133,0xd21c,0xdb23,0xee32,0x9049,0x395a,}, +{0xfa91,0x1939,0x637a,0x4325,0xc031,0x3cac,}, +{0xac7d,0xe4a0,0x64bc,0x467c,0xddd0,0x3e55,}, +{0x3f24,0xe9a5,0xa539,0xea27,0xa87f,0x3f2a,}, +{0x67de,0x94ba,0x4539,0x1ead,0xcfb1,0x3f94,}, +{0x4c2f,0xe15b,0xc44d,0x94be,0xe695,0x3fc9,}, +{0xfdc2,0xcefc,0x8461,0x7711,0xabcc,0x3fe4,}, +{0xd3c3,0x652b,0xe219,0x1758,0xd1b7,0x3ff1,}, +{0x3d71,0xd70a,0x70a3,0x0a3d,0xa3d7,0x3ff8,}, +{0xcccd,0xcccc,0xcccc,0xcccc,0xcccc,0x3ffb,}, /* 10**-1 */ +}; +#endif + +void e24toasc( x, string, ndigs ) +unsigned short x[]; +char *string; +int ndigs; +{ +unsigned short w[NI]; + +e24toe( x, w ); +etoasc( w, string, ndigs ); +} + + +void e53toasc( x, string, ndigs ) +unsigned short x[]; +char *string; +int ndigs; +{ +unsigned short w[NI]; + +e53toe( x, w ); +etoasc( w, string, ndigs ); +} + + +void e64toasc( x, string, ndigs ) +unsigned short x[]; +char *string; +int ndigs; +{ +unsigned short w[NI]; + +e64toe( x, w ); +etoasc( w, string, ndigs ); +} + +void e113toasc (x, string, ndigs) +unsigned short x[]; +char *string; +int ndigs; +{ +unsigned short w[NI]; + +e113toe (x, w); +etoasc (w, string, ndigs); +} + + +void etoasc( x, string, ndigs ) +unsigned short x[]; +char *string; +int ndigs; +{ +long digit; +unsigned short y[NI], t[NI], u[NI], w[NI]; +unsigned short *p, *r, *ten; +unsigned short sign; +int i, j, k, expon, rndsav; +char *s, *ss; +unsigned short m; + +rndsav = rndprc; +#ifdef NANS +if( eisnan(x) ) + { + sprintf( string, " NaN " ); + goto bxit; + } +#endif +rndprc = NBITS; /* set to full precision */ +emov( x, y ); /* retain external format */ +if( y[NE-1] & 0x8000 ) + { + sign = 0xffff; + y[NE-1] &= 0x7fff; + } +else + { + sign = 0; + } +expon = 0; +ten = &etens[NTEN][0]; +emov( eone, t ); +/* Test for zero exponent */ +if( y[NE-1] == 0 ) + { + for( k=0; k<NE-1; k++ ) + { + if( y[k] != 0 ) + goto tnzro; /* denormalized number */ + } + goto isone; /* legal all zeros */ + } +tnzro: + +/* Test for infinity. + */ +if( y[NE-1] == 0x7fff ) + { + if( sign ) + sprintf( string, " -Infinity " ); + else + sprintf( string, " Infinity " ); + goto bxit; + } + +/* Test for exponent nonzero but significand denormalized. + * This is an error condition. + */ +if( (y[NE-1] != 0) && ((y[NE-2] & 0x8000) == 0) ) + { + mtherr( "etoasc", DOMAIN ); + sprintf( string, "NaN" ); + goto bxit; + } + +/* Compare to 1.0 */ +i = ecmp( eone, y ); +if( i == 0 ) + goto isone; + +if( i < 0 ) + { /* Number is greater than 1 */ +/* Convert significand to an integer and strip trailing decimal zeros. */ + emov( y, u ); + u[NE-1] = EXONE + NBITS - 1; + + p = &etens[NTEN-4][0]; + m = 16; +do + { + ediv( p, u, t ); + efloor( t, w ); + for( j=0; j<NE-1; j++ ) + { + if( t[j] != w[j] ) + goto noint; + } + emov( t, u ); + expon += (int )m; +noint: + p += NE; + m >>= 1; + } +while( m != 0 ); + +/* Rescale from integer significand */ + u[NE-1] += y[NE-1] - (unsigned int )(EXONE + NBITS - 1); + emov( u, y ); +/* Find power of 10 */ + emov( eone, t ); + m = MAXP; + p = &etens[0][0]; + while( ecmp( ten, u ) <= 0 ) + { + if( ecmp( p, u ) <= 0 ) + { + ediv( p, u, u ); + emul( p, t, t ); + expon += (int )m; + } + m >>= 1; + if( m == 0 ) + break; + p += NE; + } + } +else + { /* Number is less than 1.0 */ +/* Pad significand with trailing decimal zeros. */ + if( y[NE-1] == 0 ) + { + while( (y[NE-2] & 0x8000) == 0 ) + { + emul( ten, y, y ); + expon -= 1; + } + } + else + { + emovi( y, w ); + for( i=0; i<NDEC+1; i++ ) + { + if( (w[NI-1] & 0x7) != 0 ) + break; +/* multiply by 10 */ + emovz( w, u ); + eshdn1( u ); + eshdn1( u ); + eaddm( w, u ); + u[1] += 3; + while( u[2] != 0 ) + { + eshdn1(u); + u[1] += 1; + } + if( u[NI-1] != 0 ) + break; + if( eone[NE-1] <= u[1] ) + break; + emovz( u, w ); + expon -= 1; + } + emovo( w, y ); + } + k = -MAXP; + p = &emtens[0][0]; + r = &etens[0][0]; + emov( y, w ); + emov( eone, t ); + while( ecmp( eone, w ) > 0 ) + { + if( ecmp( p, w ) >= 0 ) + { + emul( r, w, w ); + emul( r, t, t ); + expon += k; + } + k /= 2; + if( k == 0 ) + break; + p += NE; + r += NE; + } + ediv( t, eone, t ); + } +isone: +/* Find the first (leading) digit. */ +emovi( t, w ); +emovz( w, t ); +emovi( y, w ); +emovz( w, y ); +eiremain( t, y ); +digit = equot[NI-1]; +while( (digit == 0) && (ecmp(y,ezero) != 0) ) + { + eshup1( y ); + emovz( y, u ); + eshup1( u ); + eshup1( u ); + eaddm( u, y ); + eiremain( t, y ); + digit = equot[NI-1]; + expon -= 1; + } +s = string; +if( sign ) + *s++ = '-'; +else + *s++ = ' '; +/* Examine number of digits requested by caller. */ +if( ndigs < 0 ) + ndigs = 0; +if( ndigs > NDEC ) + ndigs = NDEC; +if( digit == 10 ) + { + *s++ = '1'; + *s++ = '.'; + if( ndigs > 0 ) + { + *s++ = '0'; + ndigs -= 1; + } + expon += 1; + } +else + { + *s++ = (char )digit + '0'; + *s++ = '.'; + } +/* Generate digits after the decimal point. */ +for( k=0; k<=ndigs; k++ ) + { +/* multiply current number by 10, without normalizing */ + eshup1( y ); + emovz( y, u ); + eshup1( u ); + eshup1( u ); + eaddm( u, y ); + eiremain( t, y ); + *s++ = (char )equot[NI-1] + '0'; + } +digit = equot[NI-1]; +--s; +ss = s; +/* round off the ASCII string */ +if( digit > 4 ) + { +/* Test for critical rounding case in ASCII output. */ + if( digit == 5 ) + { + emovo( y, t ); + if( ecmp(t,ezero) != 0 ) + goto roun; /* round to nearest */ + if( (*(s-1) & 1) == 0 ) + goto doexp; /* round to even */ + } +/* Round up and propagate carry-outs */ +roun: + --s; + k = *s & 0x7f; +/* Carry out to most significant digit? */ + if( k == '.' ) + { + --s; + k = *s; + k += 1; + *s = (char )k; +/* Most significant digit carries to 10? */ + if( k > '9' ) + { + expon += 1; + *s = '1'; + } + goto doexp; + } +/* Round up and carry out from less significant digits */ + k += 1; + *s = (char )k; + if( k > '9' ) + { + *s = '0'; + goto roun; + } + } +doexp: +/* +if( expon >= 0 ) + sprintf( ss, "e+%d", expon ); +else + sprintf( ss, "e%d", expon ); +*/ + sprintf( ss, "E%d", expon ); +bxit: +rndprc = rndsav; +} + + + + +/* +; ASCTOQ +; ASCTOQ.MAC LATEST REV: 11 JAN 84 +; SLM, 3 JAN 78 +; +; Convert ASCII string to quadruple precision floating point +; +; Numeric input is free field decimal number +; with max of 15 digits with or without +; decimal point entered as ASCII from teletype. +; Entering E after the number followed by a second +; number causes the second number to be interpreted +; as a power of 10 to be multiplied by the first number +; (i.e., "scientific" notation). +; +; Usage: +; asctoq( string, q ); +*/ + +/* ASCII to single */ +void asctoe24( s, y ) +char *s; +unsigned short *y; +{ +asctoeg( s, y, 24 ); +} + + +/* ASCII to double */ +void asctoe53( s, y ) +char *s; +unsigned short *y; +{ +#ifdef DEC +asctoeg( s, y, 56 ); +#else +asctoeg( s, y, 53 ); +#endif +} + + +/* ASCII to long double */ +void asctoe64( s, y ) +char *s; +unsigned short *y; +{ +asctoeg( s, y, 64 ); +} + +/* ASCII to 128-bit long double */ +void asctoe113 (s, y) +char *s; +unsigned short *y; +{ +asctoeg( s, y, 113 ); +} + +/* ASCII to super double */ +void asctoe( s, y ) +char *s; +unsigned short *y; +{ +asctoeg( s, y, NBITS ); +} + +/* Space to make a copy of the input string: */ +static char lstr[82] = {0}; + +void asctoeg( ss, y, oprec ) +char *ss; +unsigned short *y; +int oprec; +{ +unsigned short yy[NI], xt[NI], tt[NI]; +int esign, decflg, sgnflg, nexp, exp, prec, lost; +int k, trail, c, rndsav; +long lexp; +unsigned short nsign, *p; +char *sp, *s; + +/* Copy the input string. */ +s = ss; +while( *s == ' ' ) /* skip leading spaces */ + ++s; +sp = lstr; +for( k=0; k<79; k++ ) + { + if( (*sp++ = *s++) == '\0' ) + break; + } +*sp = '\0'; +s = lstr; + +rndsav = rndprc; +rndprc = NBITS; /* Set to full precision */ +lost = 0; +nsign = 0; +decflg = 0; +sgnflg = 0; +nexp = 0; +exp = 0; +prec = 0; +ecleaz( yy ); +trail = 0; + +nxtcom: +k = *s - '0'; +if( (k >= 0) && (k <= 9) ) + { +/* Ignore leading zeros */ + if( (prec == 0) && (decflg == 0) && (k == 0) ) + goto donchr; +/* Identify and strip trailing zeros after the decimal point. */ + if( (trail == 0) && (decflg != 0) ) + { + sp = s; + while( (*sp >= '0') && (*sp <= '9') ) + ++sp; +/* Check for syntax error */ + c = *sp & 0x7f; + if( (c != 'e') && (c != 'E') && (c != '\0') + && (c != '\n') && (c != '\r') && (c != ' ') + && (c != ',') ) + goto error; + --sp; + while( *sp == '0' ) + *sp-- = 'z'; + trail = 1; + if( *s == 'z' ) + goto donchr; + } +/* If enough digits were given to more than fill up the yy register, + * continuing until overflow into the high guard word yy[2] + * guarantees that there will be a roundoff bit at the top + * of the low guard word after normalization. + */ + if( yy[2] == 0 ) + { + if( decflg ) + nexp += 1; /* count digits after decimal point */ + eshup1( yy ); /* multiply current number by 10 */ + emovz( yy, xt ); + eshup1( xt ); + eshup1( xt ); + eaddm( xt, yy ); + ecleaz( xt ); + xt[NI-2] = (unsigned short )k; + eaddm( xt, yy ); + } + else + { + /* Mark any lost non-zero digit. */ + lost |= k; + /* Count lost digits before the decimal point. */ + if (decflg == 0) + nexp -= 1; + } + prec += 1; + goto donchr; + } + +switch( *s ) + { + case 'z': + break; + case 'E': + case 'e': + goto expnt; + case '.': /* decimal point */ + if( decflg ) + goto error; + ++decflg; + break; + case '-': + nsign = 0xffff; + if( sgnflg ) + goto error; + ++sgnflg; + break; + case '+': + if( sgnflg ) + goto error; + ++sgnflg; + break; + case ',': + case ' ': + case '\0': + case '\n': + case '\r': + goto daldone; + case 'i': + case 'I': + goto infinite; + default: + error: +#ifdef NANS + enan( yy, NI*16 ); +#else + mtherr( "asctoe", DOMAIN ); + ecleaz(yy); +#endif + goto aexit; + } +donchr: +++s; +goto nxtcom; + +/* Exponent interpretation */ +expnt: + +esign = 1; +exp = 0; +++s; +/* check for + or - */ +if( *s == '-' ) + { + esign = -1; + ++s; + } +if( *s == '+' ) + ++s; +while( (*s >= '0') && (*s <= '9') ) + { + exp *= 10; + exp += *s++ - '0'; + if (exp > 4977) + { + if (esign < 0) + goto zero; + else + goto infinite; + } + } +if( esign < 0 ) + exp = -exp; +if( exp > 4932 ) + { +infinite: + ecleaz(yy); + yy[E] = 0x7fff; /* infinity */ + goto aexit; + } +if( exp < -4977 ) + { +zero: + ecleaz(yy); + goto aexit; + } + +daldone: +nexp = exp - nexp; +/* Pad trailing zeros to minimize power of 10, per IEEE spec. */ +while( (nexp > 0) && (yy[2] == 0) ) + { + emovz( yy, xt ); + eshup1( xt ); + eshup1( xt ); + eaddm( yy, xt ); + eshup1( xt ); + if( xt[2] != 0 ) + break; + nexp -= 1; + emovz( xt, yy ); + } +if( (k = enormlz(yy)) > NBITS ) + { + ecleaz(yy); + goto aexit; + } +lexp = (EXONE - 1 + NBITS) - k; +emdnorm( yy, lost, 0, lexp, 64 ); +/* convert to external format */ + + +/* Multiply by 10**nexp. If precision is 64 bits, + * the maximum relative error incurred in forming 10**n + * for 0 <= n <= 324 is 8.2e-20, at 10**180. + * For 0 <= n <= 999, the peak relative error is 1.4e-19 at 10**947. + * For 0 >= n >= -999, it is -1.55e-19 at 10**-435. + */ +lexp = yy[E]; +if( nexp == 0 ) + { + k = 0; + goto expdon; + } +esign = 1; +if( nexp < 0 ) + { + nexp = -nexp; + esign = -1; + if( nexp > 4096 ) + { /* Punt. Can't handle this without 2 divides. */ + emovi( etens[0], tt ); + lexp -= tt[E]; + k = edivm( tt, yy ); + lexp += EXONE; + nexp -= 4096; + } + } +p = &etens[NTEN][0]; +emov( eone, xt ); +exp = 1; +do + { + if( exp & nexp ) + emul( p, xt, xt ); + p -= NE; + exp = exp + exp; + } +while( exp <= MAXP ); + +emovi( xt, tt ); +if( esign < 0 ) + { + lexp -= tt[E]; + k = edivm( tt, yy ); + lexp += EXONE; + } +else + { + lexp += tt[E]; + k = emulm( tt, yy ); + lexp -= EXONE - 1; + } + +expdon: + +/* Round and convert directly to the destination type */ +if( oprec == 53 ) + lexp -= EXONE - 0x3ff; +else if( oprec == 24 ) + lexp -= EXONE - 0177; +#ifdef DEC +else if( oprec == 56 ) + lexp -= EXONE - 0201; +#endif +rndprc = oprec; +emdnorm( yy, k, 0, lexp, 64 ); + +aexit: + +rndprc = rndsav; +yy[0] = nsign; +switch( oprec ) + { +#ifdef DEC + case 56: + todec( yy, y ); /* see etodec.c */ + break; +#endif + case 53: + toe53( yy, y ); + break; + case 24: + toe24( yy, y ); + break; + case 64: + toe64( yy, y ); + break; + case 113: + toe113( yy, y ); + break; + case NBITS: + emovo( yy, y ); + break; + } +} + + + +/* y = largest integer not greater than x + * (truncated toward minus infinity) + * + * unsigned short x[NE], y[NE] + * + * efloor( x, y ); + */ +static unsigned short bmask[] = { +0xffff, +0xfffe, +0xfffc, +0xfff8, +0xfff0, +0xffe0, +0xffc0, +0xff80, +0xff00, +0xfe00, +0xfc00, +0xf800, +0xf000, +0xe000, +0xc000, +0x8000, +0x0000, +}; + +void efloor( x, y ) +unsigned short x[], y[]; +{ +register unsigned short *p; +int e, expon, i; +unsigned short f[NE]; + +emov( x, f ); /* leave in external format */ +expon = (int )f[NE-1]; +e = (expon & 0x7fff) - (EXONE - 1); +if( e <= 0 ) + { + eclear(y); + goto isitneg; + } +/* number of bits to clear out */ +e = NBITS - e; +emov( f, y ); +if( e <= 0 ) + return; + +p = &y[0]; +while( e >= 16 ) + { + *p++ = 0; + e -= 16; + } +/* clear the remaining bits */ +*p &= bmask[e]; +/* truncate negatives toward minus infinity */ +isitneg: + +if( (unsigned short )expon & (unsigned short )0x8000 ) + { + for( i=0; i<NE-1; i++ ) + { + if( f[i] != y[i] ) + { + esub( eone, y, y ); + break; + } + } + } +} + + +/* unsigned short x[], s[]; + * long *exp; + * + * efrexp( x, exp, s ); + * + * Returns s and exp such that s * 2**exp = x and .5 <= s < 1. + * For example, 1.1 = 0.55 * 2**1 + * Handles denormalized numbers properly using long integer exp. + */ +void efrexp( x, exp, s ) +unsigned short x[]; +long *exp; +unsigned short s[]; +{ +unsigned short xi[NI]; +long li; + +emovi( x, xi ); +li = (long )((short )xi[1]); + +if( li == 0 ) + { + li -= enormlz( xi ); + } +xi[1] = 0x3ffe; +emovo( xi, s ); +*exp = li - 0x3ffe; +} + + + +/* unsigned short x[], y[]; + * long pwr2; + * + * eldexp( x, pwr2, y ); + * + * Returns y = x * 2**pwr2. + */ +void eldexp( x, pwr2, y ) +unsigned short x[]; +long pwr2; +unsigned short y[]; +{ +unsigned short xi[NI]; +long li; +int i; + +emovi( x, xi ); +li = xi[1]; +li += pwr2; +i = 0; +emdnorm( xi, i, i, li, 64 ); +emovo( xi, y ); +} + + +/* c = remainder after dividing b by a + * Least significant integer quotient bits left in equot[]. + */ +void eremain( a, b, c ) +unsigned short a[], b[], c[]; +{ +unsigned short den[NI], num[NI]; + +#ifdef NANS +if( eisinf(b) || (ecmp(a,ezero) == 0) || eisnan(a) || eisnan(b)) + { + enan( c, NBITS ); + return; + } +#endif +if( ecmp(a,ezero) == 0 ) + { + mtherr( "eremain", SING ); + eclear( c ); + return; + } +emovi( a, den ); +emovi( b, num ); +eiremain( den, num ); +/* Sign of remainder = sign of quotient */ +if( a[0] == b[0] ) + num[0] = 0; +else + num[0] = 0xffff; +emovo( num, c ); +} + + +void eiremain( den, num ) +unsigned short den[], num[]; +{ +long ld, ln; +unsigned short j; + +ld = den[E]; +ld -= enormlz( den ); +ln = num[E]; +ln -= enormlz( num ); +ecleaz( equot ); +while( ln >= ld ) + { + if( ecmpm(den,num) <= 0 ) + { + esubm(den, num); + j = 1; + } + else + { + j = 0; + } + eshup1(equot); + equot[NI-1] |= j; + eshup1(num); + ln -= 1; + } +emdnorm( num, 0, 0, ln, 0 ); +} + +/* NaN bit patterns + */ +#ifdef MIEEE +unsigned short nan113[8] = { + 0x7fff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}; +unsigned short nan64[6] = {0x7fff, 0xffff, 0xffff, 0xffff, 0xffff, 0xffff}; +unsigned short nan53[4] = {0x7fff, 0xffff, 0xffff, 0xffff}; +unsigned short nan24[2] = {0x7fff, 0xffff}; +#endif + +#ifdef IBMPC +unsigned short nan113[8] = {0, 0, 0, 0, 0, 0, 0xc000, 0xffff}; +unsigned short nan64[6] = {0, 0, 0, 0xc000, 0xffff, 0}; +unsigned short nan53[4] = {0, 0, 0, 0xfff8}; +unsigned short nan24[2] = {0, 0xffc0}; +#endif + + +void enan (nan, size) +unsigned short *nan; +int size; +{ +int i, n; +unsigned short *p; + +switch( size ) + { +#ifndef DEC + case 113: + n = 8; + p = nan113; + break; + + case 64: + n = 6; + p = nan64; + break; + + case 53: + n = 4; + p = nan53; + break; + + case 24: + n = 2; + p = nan24; + break; + + case NBITS: + for( i=0; i<NE-2; i++ ) + *nan++ = 0; + *nan++ = 0xc000; + *nan++ = 0x7fff; + return; + + case NI*16: + *nan++ = 0; + *nan++ = 0x7fff; + *nan++ = 0; + *nan++ = 0xc000; + for( i=4; i<NI; i++ ) + *nan++ = 0; + return; +#endif + default: + mtherr( "enan", DOMAIN ); + return; + } +for (i=0; i < n; i++) + *nan++ = *p++; +} + + + +/* Longhand square root. */ + +static int esqinited = 0; +static unsigned short sqrndbit[NI]; + +void esqrt( x, y ) +unsigned short *x, *y; +{ +unsigned short temp[NI], num[NI], sq[NI], xx[NI]; +int i, j, k, n, nlups; +long m, exp; + +if( esqinited == 0 ) + { + ecleaz( sqrndbit ); + sqrndbit[NI-2] = 1; + esqinited = 1; + } +/* Check for arg <= 0 */ +i = ecmp( x, ezero ); +if( i <= 0 ) + { +#ifdef NANS + if (i == -2) + { + enan (y, NBITS); + return; + } +#endif + eclear(y); + if( i < 0 ) + mtherr( "esqrt", DOMAIN ); + return; + } + +#ifdef INFINITY +if( eisinf(x) ) + { + eclear(y); + einfin(y); + return; + } +#endif +/* Bring in the arg and renormalize if it is denormal. */ +emovi( x, xx ); +m = (long )xx[1]; /* local long word exponent */ +if( m == 0 ) + m -= enormlz( xx ); + +/* Divide exponent by 2 */ +m -= 0x3ffe; +exp = (unsigned short )( (m / 2) + 0x3ffe ); + +/* Adjust if exponent odd */ +if( (m & 1) != 0 ) + { + if( m > 0 ) + exp += 1; + eshdn1( xx ); + } + +ecleaz( sq ); +ecleaz( num ); +n = 8; /* get 8 bits of result per inner loop */ +nlups = rndprc; +j = 0; + +while( nlups > 0 ) + { +/* bring in next word of arg */ + if( j < NE ) + num[NI-1] = xx[j+3]; +/* Do additional bit on last outer loop, for roundoff. */ + if( nlups <= 8 ) + n = nlups + 1; + for( i=0; i<n; i++ ) + { +/* Next 2 bits of arg */ + eshup1( num ); + eshup1( num ); +/* Shift up answer */ + eshup1( sq ); +/* Make trial divisor */ + for( k=0; k<NI; k++ ) + temp[k] = sq[k]; + eshup1( temp ); + eaddm( sqrndbit, temp ); +/* Subtract and insert answer bit if it goes in */ + if( ecmpm( temp, num ) <= 0 ) + { + esubm( temp, num ); + sq[NI-2] |= 1; + } + } + nlups -= n; + j += 1; + } + +/* Adjust for extra, roundoff loop done. */ +exp += (NBITS - 1) - rndprc; + +/* Sticky bit = 1 if the remainder is nonzero. */ +k = 0; +for( i=3; i<NI; i++ ) + k |= (int )num[i]; + +/* Renormalize and round off. */ +emdnorm( sq, k, 0, exp, 64 ); +emovo( sq, y ); +} diff --git a/libm/ldouble/igamil.c b/libm/ldouble/igamil.c new file mode 100644 index 000000000..1abe503e9 --- /dev/null +++ b/libm/ldouble/igamil.c @@ -0,0 +1,193 @@ +/* igamil() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igamil(); + * + * x = igamil( a, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * igamc( a, x ) = y. + * + * Starting with the approximate value + * + * 3 + * x = a t + * + * where + * + * t = 1 - d - ndtri(y) sqrt(d) + * + * and + * + * d = 1/9a, + * + * the routine performs up to 10 Newton iterations to find the + * root of igamc(a,x) - y = 0. + * + * + * ACCURACY: + * + * Tested for a ranging from 0.5 to 30 and x from 0 to 0.5. + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,0.5 3400 8.8e-16 1.3e-16 + * IEEE 0,0.5 10000 1.1e-14 1.0e-15 + * + */ + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +extern long double MACHEPL, MAXNUML, MAXLOGL, MINLOGL; +#ifdef ANSIPROT +extern long double ndtril ( long double ); +extern long double expl ( long double ); +extern long double fabsl ( long double ); +extern long double logl ( long double ); +extern long double sqrtl ( long double ); +extern long double lgaml ( long double ); +extern long double igamcl ( long double, long double ); +#else +long double ndtril(), expl(), fabsl(), logl(), sqrtl(), lgaml(); +long double igamcl(); +#endif + +long double igamil( a, y0 ) +long double a, y0; +{ +long double x0, x1, x, yl, yh, y, d, lgm, dithresh; +int i, dir; + +/* bound the solution */ +x0 = MAXNUML; +yl = 0.0L; +x1 = 0.0L; +yh = 1.0L; +dithresh = 4.0 * MACHEPL; + +/* approximation to inverse function */ +d = 1.0L/(9.0L*a); +y = ( 1.0L - d - ndtril(y0) * sqrtl(d) ); +x = a * y * y * y; + +lgm = lgaml(a); + +for( i=0; i<10; i++ ) + { + if( x > x0 || x < x1 ) + goto ihalve; + y = igamcl(a,x); + if( y < yl || y > yh ) + goto ihalve; + if( y < y0 ) + { + x0 = x; + yl = y; + } + else + { + x1 = x; + yh = y; + } +/* compute the derivative of the function at this point */ + d = (a - 1.0L) * logl(x0) - x0 - lgm; + if( d < -MAXLOGL ) + goto ihalve; + d = -expl(d); +/* compute the step to the next approximation of x */ + d = (y - y0)/d; + x = x - d; + if( i < 3 ) + continue; + if( fabsl(d/x) < dithresh ) + goto done; + } + +/* Resort to interval halving if Newton iteration did not converge. */ +ihalve: + +d = 0.0625L; +if( x0 == MAXNUML ) + { + if( x <= 0.0L ) + x = 1.0L; + while( x0 == MAXNUML ) + { + x = (1.0L + d) * x; + y = igamcl( a, x ); + if( y < y0 ) + { + x0 = x; + yl = y; + break; + } + d = d + d; + } + } +d = 0.5L; +dir = 0; + +for( i=0; i<400; i++ ) + { + x = x1 + d * (x0 - x1); + y = igamcl( a, x ); + lgm = (x0 - x1)/(x1 + x0); + if( fabsl(lgm) < dithresh ) + break; + lgm = (y - y0)/y0; + if( fabsl(lgm) < dithresh ) + break; + if( x <= 0.0L ) + break; + if( y > y0 ) + { + x1 = x; + yh = y; + if( dir < 0 ) + { + dir = 0; + d = 0.5L; + } + else if( dir > 1 ) + d = 0.5L * d + 0.5L; + else + d = (y0 - yl)/(yh - yl); + dir += 1; + } + else + { + x0 = x; + yl = y; + if( dir > 0 ) + { + dir = 0; + d = 0.5L; + } + else if( dir < -1 ) + d = 0.5L * d; + else + d = (y0 - yl)/(yh - yl); + dir -= 1; + } + } +if( x == 0.0L ) + mtherr( "igamil", UNDERFLOW ); + +done: +return( x ); +} diff --git a/libm/ldouble/igaml.c b/libm/ldouble/igaml.c new file mode 100644 index 000000000..0e59c5404 --- /dev/null +++ b/libm/ldouble/igaml.c @@ -0,0 +1,220 @@ +/* igaml.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igaml(); + * + * y = igaml( a, x ); + * + * + * + * DESCRIPTION: + * + * The function is defined by + * + * x + * - + * 1 | | -t a-1 + * igam(a,x) = ----- | e t dt. + * - | | + * | (a) - + * 0 + * + * + * In this implementation both arguments must be positive. + * The integral is evaluated by either a power series or + * continued fraction expansion, depending on the relative + * values of a and x. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 4000 4.4e-15 6.3e-16 + * IEEE 0,30 10000 3.6e-14 5.1e-15 + * + */ + /* igamcl() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * long double a, x, y, igamcl(); + * + * y = igamcl( a, x ); + * + * + * + * DESCRIPTION: + * + * The function is defined by + * + * + * igamc(a,x) = 1 - igam(a,x) + * + * inf. + * - + * 1 | | -t a-1 + * = ----- | e t dt. + * - | | + * | (a) - + * x + * + * + * In this implementation both arguments must be positive. + * The integral is evaluated by either a power series or + * continued fraction expansion, depending on the relative + * values of a and x. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 2.7e-15 4.0e-16 + * IEEE 0,30 60000 1.4e-12 6.3e-15 + * + */ + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1985, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double lgaml ( long double ); +extern long double expl ( long double ); +extern long double logl ( long double ); +extern long double fabsl ( long double ); +extern long double gammal ( long double ); +long double igaml ( long double, long double ); +long double igamcl ( long double, long double ); +#else +long double lgaml(), expl(), logl(), fabsl(), igaml(), gammal(); +long double igamcl(); +#endif + +#define BIG 9.223372036854775808e18L +#define MAXGAML 1755.455L +extern long double MACHEPL, MINLOGL; + +long double igamcl( a, x ) +long double a, x; +{ +long double ans, c, yc, ax, y, z, r, t; +long double pk, pkm1, pkm2, qk, qkm1, qkm2; + +if( (x <= 0.0L) || ( a <= 0.0L) ) + return( 1.0L ); + +if( (x < 1.0L) || (x < a) ) + return( 1.0L - igaml(a,x) ); + +ax = a * logl(x) - x - lgaml(a); +if( ax < MINLOGL ) + { + mtherr( "igamcl", UNDERFLOW ); + return( 0.0L ); + } +ax = expl(ax); + +/* continued fraction */ +y = 1.0L - a; +z = x + y + 1.0L; +c = 0.0L; +pkm2 = 1.0L; +qkm2 = x; +pkm1 = x + 1.0L; +qkm1 = z * x; +ans = pkm1/qkm1; + +do + { + c += 1.0L; + y += 1.0L; + z += 2.0L; + yc = y * c; + pk = pkm1 * z - pkm2 * yc; + qk = qkm1 * z - qkm2 * yc; + if( qk != 0.0L ) + { + r = pk/qk; + t = fabsl( (ans - r)/r ); + ans = r; + } + else + t = 1.0L; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + if( fabsl(pk) > BIG ) + { + pkm2 /= BIG; + pkm1 /= BIG; + qkm2 /= BIG; + qkm1 /= BIG; + } + } +while( t > MACHEPL ); + +return( ans * ax ); +} + + + +/* left tail of incomplete gamma function: + * + * inf. k + * a -x - x + * x e > ---------- + * - - + * k=0 | (a+k+1) + * + */ + +long double igaml( a, x ) +long double a, x; +{ +long double ans, ax, c, r; + +if( (x <= 0.0L) || ( a <= 0.0L) ) + return( 0.0L ); + +if( (x > 1.0L) && (x > a ) ) + return( 1.0L - igamcl(a,x) ); + +ax = a * logl(x) - x - lgaml(a); +if( ax < MINLOGL ) + { + mtherr( "igaml", UNDERFLOW ); + return( 0.0L ); + } +ax = expl(ax); + +/* power series */ +r = a; +c = 1.0L; +ans = 1.0L; + +do + { + r += 1.0L; + c *= x/r; + ans += c; + } +while( c/ans > MACHEPL ); + +return( ans * ax/a ); +} diff --git a/libm/ldouble/incbetl.c b/libm/ldouble/incbetl.c new file mode 100644 index 000000000..fc85ead4c --- /dev/null +++ b/libm/ldouble/incbetl.c @@ -0,0 +1,406 @@ +/* incbetl.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * long double a, b, x, y, incbetl(); + * + * y = incbetl( a, b, x ); + * + * + * DESCRIPTION: + * + * Returns incomplete beta integral of the arguments, evaluated + * from zero to x. The function is defined as + * + * x + * - - + * | (a+b) | | a-1 b-1 + * ----------- | t (1-t) dt. + * - - | | + * | (a) | (b) - + * 0 + * + * The domain of definition is 0 <= x <= 1. In this + * implementation a and b are restricted to positive values. + * The integral from x to 1 may be obtained by the symmetry + * relation + * + * 1 - incbet( a, b, x ) = incbet( b, a, 1-x ). + * + * The integral is evaluated by a continued fraction expansion + * or, when b*x is small, by a power series. + * + * ACCURACY: + * + * Tested at random points (a,b,x) with x between 0 and 1. + * arithmetic domain # trials peak rms + * IEEE 0,5 20000 4.5e-18 2.4e-19 + * IEEE 0,100 100000 3.9e-17 1.0e-17 + * Half-integer a, b: + * IEEE .5,10000 100000 3.9e-14 4.4e-15 + * Outputs smaller than the IEEE gradual underflow threshold + * were excluded from these statistics. + * + * ERROR MESSAGES: + * + * message condition value returned + * incbetl domain x<0, x>1 0.0 + */ + + +/* +Cephes Math Library, Release 2.3: January, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +#define MAXGAML 1755.455L +static long double big = 9.223372036854775808e18L; +static long double biginv = 1.084202172485504434007e-19L; +extern long double MACHEPL, MINLOGL, MAXLOGL; + +#ifdef ANSIPROT +extern long double gammal ( long double ); +extern long double lgaml ( long double ); +extern long double expl ( long double ); +extern long double logl ( long double ); +extern long double fabsl ( long double ); +extern long double powl ( long double, long double ); +static long double incbcfl( long double, long double, long double ); +static long double incbdl( long double, long double, long double ); +static long double pseriesl( long double, long double, long double ); +#else +long double gammal(), lgaml(), expl(), logl(), fabsl(), powl(); +static long double incbcfl(), incbdl(), pseriesl(); +#endif + +long double incbetl( aa, bb, xx ) +long double aa, bb, xx; +{ +long double a, b, t, x, w, xc, y; +int flag; + +if( aa <= 0.0L || bb <= 0.0L ) + goto domerr; + +if( (xx <= 0.0L) || ( xx >= 1.0L) ) + { + if( xx == 0.0L ) + return( 0.0L ); + if( xx == 1.0L ) + return( 1.0L ); +domerr: + mtherr( "incbetl", DOMAIN ); + return( 0.0L ); + } + +flag = 0; +if( (bb * xx) <= 1.0L && xx <= 0.95L) + { + t = pseriesl(aa, bb, xx); + goto done; + } + +w = 1.0L - xx; + +/* Reverse a and b if x is greater than the mean. */ +if( xx > (aa/(aa+bb)) ) + { + flag = 1; + a = bb; + b = aa; + xc = xx; + x = w; + } +else + { + a = aa; + b = bb; + xc = w; + x = xx; + } + +if( flag == 1 && (b * x) <= 1.0L && x <= 0.95L) + { + t = pseriesl(a, b, x); + goto done; + } + +/* Choose expansion for optimal convergence */ +y = x * (a+b-2.0L) - (a-1.0L); +if( y < 0.0L ) + w = incbcfl( a, b, x ); +else + w = incbdl( a, b, x ) / xc; + +/* Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) . */ + +y = a * logl(x); +t = b * logl(xc); +if( (a+b) < MAXGAML && fabsl(y) < MAXLOGL && fabsl(t) < MAXLOGL ) + { + t = powl(xc,b); + t *= powl(x,a); + t /= a; + t *= w; + t *= gammal(a+b) / (gammal(a) * gammal(b)); + goto done; + } +else + { + /* Resort to logarithms. */ + y += t + lgaml(a+b) - lgaml(a) - lgaml(b); + y += logl(w/a); + if( y < MINLOGL ) + t = 0.0L; + else + t = expl(y); + } + +done: + +if( flag == 1 ) + { + if( t <= MACHEPL ) + t = 1.0L - MACHEPL; + else + t = 1.0L - t; + } +return( t ); +} + +/* Continued fraction expansion #1 + * for incomplete beta integral + */ + +static long double incbcfl( a, b, x ) +long double a, b, x; +{ +long double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +long double k1, k2, k3, k4, k5, k6, k7, k8; +long double r, t, ans, thresh; +int n; + +k1 = a; +k2 = a + b; +k3 = a; +k4 = a + 1.0L; +k5 = 1.0L; +k6 = b - 1.0L; +k7 = k4; +k8 = a + 2.0L; + +pkm2 = 0.0L; +qkm2 = 1.0L; +pkm1 = 1.0L; +qkm1 = 1.0L; +ans = 1.0L; +r = 1.0L; +n = 0; +thresh = 3.0L * MACHEPL; +do + { + + xk = -( x * k1 * k2 )/( k3 * k4 ); + pk = pkm1 + pkm2 * xk; + qk = qkm1 + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + + xk = ( x * k5 * k6 )/( k7 * k8 ); + pk = pkm1 + pkm2 * xk; + qk = qkm1 + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + + if( qk != 0.0L ) + r = pk/qk; + if( r != 0.0L ) + { + t = fabsl( (ans - r)/r ); + ans = r; + } + else + t = 1.0L; + + if( t < thresh ) + goto cdone; + + k1 += 1.0L; + k2 += 1.0L; + k3 += 2.0L; + k4 += 2.0L; + k5 += 1.0L; + k6 -= 1.0L; + k7 += 2.0L; + k8 += 2.0L; + + if( (fabsl(qk) + fabsl(pk)) > big ) + { + pkm2 *= biginv; + pkm1 *= biginv; + qkm2 *= biginv; + qkm1 *= biginv; + } + if( (fabsl(qk) < biginv) || (fabsl(pk) < biginv) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 400 ); +mtherr( "incbetl", PLOSS ); + +cdone: +return(ans); +} + + +/* Continued fraction expansion #2 + * for incomplete beta integral + */ + +static long double incbdl( a, b, x ) +long double a, b, x; +{ +long double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +long double k1, k2, k3, k4, k5, k6, k7, k8; +long double r, t, ans, z, thresh; +int n; + +k1 = a; +k2 = b - 1.0L; +k3 = a; +k4 = a + 1.0L; +k5 = 1.0L; +k6 = a + b; +k7 = a + 1.0L; +k8 = a + 2.0L; + +pkm2 = 0.0L; +qkm2 = 1.0L; +pkm1 = 1.0L; +qkm1 = 1.0L; +z = x / (1.0L-x); +ans = 1.0L; +r = 1.0L; +n = 0; +thresh = 3.0L * MACHEPL; +do + { + + xk = -( z * k1 * k2 )/( k3 * k4 ); + pk = pkm1 + pkm2 * xk; + qk = qkm1 + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + + xk = ( z * k5 * k6 )/( k7 * k8 ); + pk = pkm1 + pkm2 * xk; + qk = qkm1 + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + + if( qk != 0.0L ) + r = pk/qk; + if( r != 0.0L ) + { + t = fabsl( (ans - r)/r ); + ans = r; + } + else + t = 1.0L; + + if( t < thresh ) + goto cdone; + + k1 += 1.0L; + k2 -= 1.0L; + k3 += 2.0L; + k4 += 2.0L; + k5 += 1.0L; + k6 += 1.0L; + k7 += 2.0L; + k8 += 2.0L; + + if( (fabsl(qk) + fabsl(pk)) > big ) + { + pkm2 *= biginv; + pkm1 *= biginv; + qkm2 *= biginv; + qkm1 *= biginv; + } + if( (fabsl(qk) < biginv) || (fabsl(pk) < biginv) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 400 ); +mtherr( "incbetl", PLOSS ); + +cdone: +return(ans); +} + +/* Power series for incomplete gamma integral. + Use when b*x is small. */ + +static long double pseriesl( a, b, x ) +long double a, b, x; +{ +long double s, t, u, v, n, t1, z, ai; + +ai = 1.0L / a; +u = (1.0L - b) * x; +v = u / (a + 1.0L); +t1 = v; +t = u; +n = 2.0L; +s = 0.0L; +z = MACHEPL * ai; +while( fabsl(v) > z ) + { + u = (n - b) * x / n; + t *= u; + v = t / (a + n); + s += v; + n += 1.0L; + } +s += t1; +s += ai; + +u = a * logl(x); +if( (a+b) < MAXGAML && fabsl(u) < MAXLOGL ) + { + t = gammal(a+b)/(gammal(a)*gammal(b)); + s = s * t * powl(x,a); + } +else + { + t = lgaml(a+b) - lgaml(a) - lgaml(b) + u + logl(s); + if( t < MINLOGL ) + s = 0.0L; + else + s = expl(t); + } +return(s); +} diff --git a/libm/ldouble/incbil.c b/libm/ldouble/incbil.c new file mode 100644 index 000000000..b7610706b --- /dev/null +++ b/libm/ldouble/incbil.c @@ -0,0 +1,305 @@ +/* incbil() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * long double a, b, x, y, incbil(); + * + * x = incbil( a, b, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * incbet( a, b, x ) = y. + * + * the routine performs up to 10 Newton iterations to find the + * root of incbet(a,b,x) - y = 0. + * + * + * ACCURACY: + * + * Relative error: + * x a,b + * arithmetic domain domain # trials peak rms + * IEEE 0,1 .5,10000 10000 1.1e-14 1.4e-16 + */ + + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +extern long double MACHEPL, MAXNUML, MAXLOGL, MINLOGL; +#ifdef ANSIPROT +extern long double incbetl ( long double, long double, long double ); +extern long double expl ( long double ); +extern long double fabsl ( long double ); +extern long double logl ( long double ); +extern long double sqrtl ( long double ); +extern long double lgaml ( long double ); +extern long double ndtril ( long double ); +#else +long double incbetl(), expl(), fabsl(), logl(), sqrtl(), lgaml(); +long double ndtril(); +#endif + +long double incbil( aa, bb, yy0 ) +long double aa, bb, yy0; +{ +long double a, b, y0, d, y, x, x0, x1, lgm, yp, di, dithresh, yl, yh, xt; +int i, rflg, dir, nflg; + + +if( yy0 <= 0.0L ) + return(0.0L); +if( yy0 >= 1.0L ) + return(1.0L); +x0 = 0.0L; +yl = 0.0L; +x1 = 1.0L; +yh = 1.0L; +if( aa <= 1.0L || bb <= 1.0L ) + { + dithresh = 1.0e-7L; + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + x = a/(a+b); + y = incbetl( a, b, x ); + nflg = 0; + goto ihalve; + } +else + { + nflg = 0; + dithresh = 1.0e-4L; + } + +/* approximation to inverse function */ + +yp = -ndtril( yy0 ); + +if( yy0 > 0.5L ) + { + rflg = 1; + a = bb; + b = aa; + y0 = 1.0L - yy0; + yp = -yp; + } +else + { + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + } + +lgm = (yp * yp - 3.0L)/6.0L; +x = 2.0L/( 1.0L/(2.0L * a-1.0L) + 1.0L/(2.0L * b - 1.0L) ); +d = yp * sqrtl( x + lgm ) / x + - ( 1.0L/(2.0L * b - 1.0L) - 1.0L/(2.0L * a - 1.0L) ) + * (lgm + (5.0L/6.0L) - 2.0L/(3.0L * x)); +d = 2.0L * d; +if( d < MINLOGL ) + { + x = 1.0L; + goto under; + } +x = a/( a + b * expl(d) ); +y = incbetl( a, b, x ); +yp = (y - y0)/y0; +if( fabsl(yp) < 0.2 ) + goto newt; + +/* Resort to interval halving if not close enough. */ +ihalve: + +dir = 0; +di = 0.5L; +for( i=0; i<400; i++ ) + { + if( i != 0 ) + { + x = x0 + di * (x1 - x0); + if( x == 1.0L ) + x = 1.0L - MACHEPL; + if( x == 0.0L ) + { + di = 0.5; + x = x0 + di * (x1 - x0); + if( x == 0.0 ) + goto under; + } + y = incbetl( a, b, x ); + yp = (x1 - x0)/(x1 + x0); + if( fabsl(yp) < dithresh ) + goto newt; + yp = (y-y0)/y0; + if( fabsl(yp) < dithresh ) + goto newt; + } + if( y < y0 ) + { + x0 = x; + yl = y; + if( dir < 0 ) + { + dir = 0; + di = 0.5L; + } + else if( dir > 3 ) + di = 1.0L - (1.0L - di) * (1.0L - di); + else if( dir > 1 ) + di = 0.5L * di + 0.5L; + else + di = (y0 - y)/(yh - yl); + dir += 1; + if( x0 > 0.95L ) + { + if( rflg == 1 ) + { + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + } + else + { + rflg = 1; + a = bb; + b = aa; + y0 = 1.0 - yy0; + } + x = 1.0L - x; + y = incbetl( a, b, x ); + x0 = 0.0; + yl = 0.0; + x1 = 1.0; + yh = 1.0; + goto ihalve; + } + } + else + { + x1 = x; + if( rflg == 1 && x1 < MACHEPL ) + { + x = 0.0L; + goto done; + } + yh = y; + if( dir > 0 ) + { + dir = 0; + di = 0.5L; + } + else if( dir < -3 ) + di = di * di; + else if( dir < -1 ) + di = 0.5L * di; + else + di = (y - y0)/(yh - yl); + dir -= 1; + } + } +mtherr( "incbil", PLOSS ); +if( x0 >= 1.0L ) + { + x = 1.0L - MACHEPL; + goto done; + } +if( x <= 0.0L ) + { +under: + mtherr( "incbil", UNDERFLOW ); + x = 0.0L; + goto done; + } + +newt: + +if( nflg ) + goto done; +nflg = 1; +lgm = lgaml(a+b) - lgaml(a) - lgaml(b); + +for( i=0; i<15; i++ ) + { + /* Compute the function at this point. */ + if( i != 0 ) + y = incbetl(a,b,x); + if( y < yl ) + { + x = x0; + y = yl; + } + else if( y > yh ) + { + x = x1; + y = yh; + } + else if( y < y0 ) + { + x0 = x; + yl = y; + } + else + { + x1 = x; + yh = y; + } + if( x == 1.0L || x == 0.0L ) + break; + /* Compute the derivative of the function at this point. */ + d = (a - 1.0L) * logl(x) + (b - 1.0L) * logl(1.0L - x) + lgm; + if( d < MINLOGL ) + goto done; + if( d > MAXLOGL ) + break; + d = expl(d); + /* Compute the step to the next approximation of x. */ + d = (y - y0)/d; + xt = x - d; + if( xt <= x0 ) + { + y = (x - x0) / (x1 - x0); + xt = x0 + 0.5L * y * (x - x0); + if( xt <= 0.0L ) + break; + } + if( xt >= x1 ) + { + y = (x1 - x) / (x1 - x0); + xt = x1 - 0.5L * y * (x1 - x); + if( xt >= 1.0L ) + break; + } + x = xt; + if( fabsl(d/x) < (128.0L * MACHEPL) ) + goto done; + } +/* Did not converge. */ +dithresh = 256.0L * MACHEPL; +goto ihalve; + +done: +if( rflg ) + { + if( x <= MACHEPL ) + x = 1.0L - MACHEPL; + else + x = 1.0L - x; + } +return( x ); +} diff --git a/libm/ldouble/isnanl.c b/libm/ldouble/isnanl.c new file mode 100644 index 000000000..44158ecc7 --- /dev/null +++ b/libm/ldouble/isnanl.c @@ -0,0 +1,186 @@ +/* isnanl() + * isfinitel() + * signbitl() + * + * Floating point IEEE special number tests + * + * + * + * SYNOPSIS: + * + * int signbitl(), isnanl(), isfinitel(); + * long double x, y; + * + * n = signbitl(x); + * n = isnanl(x); + * n = isfinitel(x); + * + * + * + * DESCRIPTION: + * + * These functions are part of the standard C run time library + * for some but not all C compilers. The ones supplied are + * written in C for IEEE arithmetic. They should + * be used only if your compiler library does not already have + * them. + * + */ + + +/* +Cephes Math Library Release 2.7: June, 1998 +Copyright 1992, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +/* This is defined in mconf.h. */ +/* #define DENORMAL 1 */ + +#ifdef UNK +/* Change UNK into something else. */ +#undef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +#endif + + +/* Return 1 if the sign bit of x is 1, else 0. */ + +int signbitl(x) +long double x; +{ +union + { + long double d; + short s[6]; + int i[3]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + return( u.s[4] < 0 ); +#endif +#ifdef MIEEE + return( u.i[0] < 0 ); +#endif + } +else + { +#ifdef IBMPC + return( u.s[4] < 0 ); +#endif +#ifdef MIEEE + return( u.s[0] < 0 ); +#endif + } +} + + +/* Return 1 if x is a number that is Not a Number, else return 0. */ + +int isnanl(x) +long double x; +{ +#ifdef NANS +union + { + long double d; + unsigned short s[6]; + unsigned int i[3]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( ((u.s[4] & 0x7fff) == 0x7fff) + && (((u.i[1] & 0x7fffffff)!= 0) || (u.i[0] != 0))) + return 1; +#endif +#ifdef MIEEE + if( ((u.i[0] & 0x7fff0000) == 0x7fff0000) + && (((u.i[1] & 0x7fffffff) != 0) || (u.i[2] != 0))) + return 1; +#endif + return(0); + } +else + { /* size int not 4 */ +#ifdef IBMPC + if( (u.s[4] & 0x7fff) == 0x7fff) + { + if((u.s[3] & 0x7fff) | u.s[2] | u.s[1] | u.s[0]) + return(1); + } +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7fff) == 0x7fff) + { + if((u.s[2] & 0x7fff) | u.s[3] | u.s[4] | u.s[5]) + return(1); + } +#endif + return(0); + } /* size int not 4 */ + +#else +/* No NANS. */ +return(0); +#endif +} + + +/* Return 1 if x is not infinite and is not a NaN. */ + +int isfinitel(x) +long double x; +{ +#ifdef INFINITIES +union + { + long double d; + unsigned short s[6]; + unsigned int i[3]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( (u.s[4] & 0x7fff) != 0x7fff) + return 1; +#endif +#ifdef MIEEE + if( (u.i[0] & 0x7fff0000) != 0x7fff0000) + return 1; +#endif + return(0); + } +else + { +#ifdef IBMPC + if( (u.s[4] & 0x7fff) != 0x7fff) + return 1; +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7fff) != 0x7fff) + return 1; +#endif + return(0); + } +#else +/* No INFINITY. */ +return(1); +#endif +} diff --git a/libm/ldouble/j0l.c b/libm/ldouble/j0l.c new file mode 100644 index 000000000..a30a65a4f --- /dev/null +++ b/libm/ldouble/j0l.c @@ -0,0 +1,541 @@ +/* j0l.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * long double x, y, j0l(); + * + * y = j0l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of first kind, order zero of the argument. + * + * The domain is divided into the intervals [0, 9] and + * (9, infinity). In the first interval the rational approximation + * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) P7(x^2) / Q8(x^2), + * where r, s, t are the first three zeros of the function. + * In the second interval the expansion is in terms of the + * modulus M0(x) = sqrt(J0(x)^2 + Y0(x)^2) and phase P0(x) + * = atan(Y0(x)/J0(x)). M0 is approximated by sqrt(1/x)P7(1/x)/Q7(1/x). + * The approximation to J0 is M0 * cos(x - pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 2.8e-19 7.4e-20 + * + * + */ + /* y0l.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y0l(); + * + * y = y0l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 5>, [5,9> and + * [9, infinity). In the first interval a rational approximation + * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). + * + * In the second interval, the approximation is + * (x - p)(x - q)(x - r)(x - s)P7(x)/Q7(x) + * where p, q, r, s are zeros of y0(x). + * + * The third interval uses the same approximations to modulus + * and phase as j0(x), whence y0(x) = modulus * sin(phase). + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 3.4e-19 7.6e-20 + * + */ + +/* Copyright 1994 by Stephen L. Moshier (moshier@world.std.com). */ + +#include <math.h> + +/* +j0(x) = (x^2-JZ1)(x^2-JZ2)(x^2-JZ3)P(x**2)/Q(x**2) +0 <= x <= 9 +Relative error +n=7, d=8 +Peak error = 8.49e-22 +Relative error spread = 2.2e-3 +*/ +#if UNK +static long double j0n[8] = { + 1.296848754518641770562E0L, +-3.239201943301299801018E3L, + 3.490002040733471400107E6L, +-2.076797068740966813173E9L, + 7.283696461857171054941E11L, +-1.487926133645291056388E14L, + 1.620335009643150402368E16L, +-7.173386747526788067407E17L, +}; +static long double j0d[8] = { +/* 1.000000000000000000000E0L,*/ + 2.281959869176887763845E3L, + 2.910386840401647706984E6L, + 2.608400226578100610991E9L, + 1.752689035792859338860E12L, + 8.879132373286001289461E14L, + 3.265560832845194013669E17L, + 7.881340554308432241892E19L, + 9.466475654163919450528E21L, +}; +#endif +#if IBMPC +static short j0n[] = { +0xf759,0x4208,0x23d6,0xa5ff,0x3fff, XPD +0xa9a8,0xe62b,0x3b28,0xca73,0xc00a, XPD +0xfe10,0xb608,0x4829,0xd503,0x4014, XPD +0x008c,0x7b60,0xd119,0xf792,0xc01d, XPD +0x943a,0x69b7,0x36ca,0xa996,0x4026, XPD +0x1b0b,0x6331,0x7add,0x8753,0xc02e, XPD +0x4018,0xad26,0x71ba,0xe643,0x4034, XPD +0xb96c,0xc486,0xfb95,0x9f47,0xc03a, XPD +}; +static short j0d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xbdfe,0xc832,0x5b9f,0x8e9f,0x400a, XPD +0xe1a0,0x923f,0xcb5c,0xb1a2,0x4014, XPD +0x66d2,0x93fe,0x0762,0x9b79,0x401e, XPD +0xfed1,0x086d,0x3425,0xcc0a,0x4027, XPD +0x0841,0x8cb6,0x5a46,0xc9e3,0x4030, XPD +0x3d2c,0xed55,0x20e1,0x9105,0x4039, XPD +0xfdce,0xa4ca,0x2ed8,0x88b8,0x4041, XPD +0x00ac,0xfb2b,0x6f62,0x804b,0x4048, XPD +}; +#endif +#if MIEEE +static long j0n[24] = { +0x3fff0000,0xa5ff23d6,0x4208f759, +0xc00a0000,0xca733b28,0xe62ba9a8, +0x40140000,0xd5034829,0xb608fe10, +0xc01d0000,0xf792d119,0x7b60008c, +0x40260000,0xa99636ca,0x69b7943a, +0xc02e0000,0x87537add,0x63311b0b, +0x40340000,0xe64371ba,0xad264018, +0xc03a0000,0x9f47fb95,0xc486b96c, +}; +static long j0d[24] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x400a0000,0x8e9f5b9f,0xc832bdfe, +0x40140000,0xb1a2cb5c,0x923fe1a0, +0x401e0000,0x9b790762,0x93fe66d2, +0x40270000,0xcc0a3425,0x086dfed1, +0x40300000,0xc9e35a46,0x8cb60841, +0x40390000,0x910520e1,0xed553d2c, +0x40410000,0x88b82ed8,0xa4cafdce, +0x40480000,0x804b6f62,0xfb2b00ac, +}; +#endif +/* +sqrt(j0^2(1/x^2) + y0^2(1/x^2)) = z P(z**2)/Q(z**2) +z(x) = 1/sqrt(x) +Relative error +n=7, d=7 +Peak error = 1.80e-20 +Relative error spread = 5.1e-2 +*/ +#if UNK +static long double modulusn[8] = { + 3.947542376069224461532E-1L, + 6.864682945702134624126E0L, + 1.021369773577974343844E1L, + 7.626141421290849630523E0L, + 2.842537511425216145635E0L, + 7.162842530423205720962E-1L, + 9.036664453160200052296E-2L, + 8.461833426898867839659E-3L, +}; +static long double modulusd[7] = { +/* 1.000000000000000000000E0L,*/ + 9.117176038171821115904E0L, + 1.301235226061478261481E1L, + 9.613002539386213788182E0L, + 3.569671060989910901903E0L, + 8.983920141407590632423E-1L, + 1.132577931332212304986E-1L, + 1.060533546154121770442E-2L, +}; +#endif +#if IBMPC +static short modulusn[] = { +0x8559,0xf552,0x3a38,0xca1d,0x3ffd, XPD +0x38a3,0xa663,0x7b91,0xdbab,0x4001, XPD +0xb343,0x2673,0x4e51,0xa36b,0x4002, XPD +0x5e4b,0xe3af,0x59bb,0xf409,0x4001, XPD +0xb1cd,0x4e5e,0x2274,0xb5ec,0x4000, XPD +0xcfe9,0x74e0,0x67a1,0xb75e,0x3ffe, XPD +0x6b78,0x4cc6,0x25b7,0xb912,0x3ffb, XPD +0xcb2b,0x4b73,0x8075,0x8aa3,0x3ff8, XPD +}; +static short modulusd[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0x4498,0x3d2a,0xf3fb,0x91df,0x4002, XPD +0x5e3d,0xb5f4,0x9848,0xd032,0x4002, XPD +0xb837,0x3075,0xdbc0,0x99ce,0x4002, XPD +0x775a,0x1b79,0x7d9c,0xe475,0x4000, XPD +0x7e3f,0xb8dd,0x04df,0xe5fd,0x3ffe, XPD +0xed5a,0x31cd,0xb3ac,0xe7f3,0x3ffb, XPD +0x8a83,0x1b80,0x003e,0xadc2,0x3ff8, XPD +}; +#endif +#if MIEEE +static long modulusn[24] = { +0x3ffd0000,0xca1d3a38,0xf5528559, +0x40010000,0xdbab7b91,0xa66338a3, +0x40020000,0xa36b4e51,0x2673b343, +0x40010000,0xf40959bb,0xe3af5e4b, +0x40000000,0xb5ec2274,0x4e5eb1cd, +0x3ffe0000,0xb75e67a1,0x74e0cfe9, +0x3ffb0000,0xb91225b7,0x4cc66b78, +0x3ff80000,0x8aa38075,0x4b73cb2b, +}; +static long modulusd[21] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40020000,0x91dff3fb,0x3d2a4498, +0x40020000,0xd0329848,0xb5f45e3d, +0x40020000,0x99cedbc0,0x3075b837, +0x40000000,0xe4757d9c,0x1b79775a, +0x3ffe0000,0xe5fd04df,0xb8dd7e3f, +0x3ffb0000,0xe7f3b3ac,0x31cded5a, +0x3ff80000,0xadc2003e,0x1b808a83, +}; +#endif +/* +atan(y0(x)/j0(x)) = x - pi/4 + x P(x**2)/Q(x**2) +Absolute error +n=5, d=6 +Peak error = 2.80e-21 +Relative error spread = 5.5e-1 +*/ +#if UNK +static long double phasen[6] = { +-7.356766355393571519038E-1L, +-5.001635199922493694706E-1L, +-7.737323518141516881715E-2L, +-3.998893155826990642730E-3L, +-7.496317036829964150970E-5L, +-4.290885090773112963542E-7L, +}; +static long double phased[6] = { +/* 1.000000000000000000000E0L,*/ + 7.377856408614376072745E0L, + 4.285043297797736118069E0L, + 6.348446472935245102890E-1L, + 3.229866782185025048457E-2L, + 6.014932317342190404134E-4L, + 3.432708072618490390095E-6L, +}; +#endif +#if IBMPC +static short phasen[] = { +0x5106,0x12a6,0x4dd2,0xbc55,0xbffe, XPD +0x1e30,0x04da,0xb769,0x800a,0xbffe, XPD +0x8d8a,0x84e7,0xdbd5,0x9e75,0xbffb, XPD +0xe514,0x8866,0x25a9,0x8309,0xbff7, XPD +0xdc17,0x325e,0x8baf,0x9d35,0xbff1, XPD +0x4c2f,0x2dd8,0x79c3,0xe65d,0xbfe9, XPD +}; +static short phased[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xf3e9,0xb2a5,0x6652,0xec17,0x4001, XPD +0x4b69,0x3f87,0x131f,0x891f,0x4001, XPD +0x6f25,0x2a95,0x2dc6,0xa285,0x3ffe, XPD +0x37bf,0xfcc8,0x9b9f,0x844b,0x3ffa, XPD +0xac5c,0x4806,0x8709,0x9dad,0x3ff4, XPD +0x4c8c,0x2dd8,0x79c3,0xe65d,0x3fec, XPD +}; +#endif +#if MIEEE +static long phasen[18] = { +0xbffe0000,0xbc554dd2,0x12a65106, +0xbffe0000,0x800ab769,0x04da1e30, +0xbffb0000,0x9e75dbd5,0x84e78d8a, +0xbff70000,0x830925a9,0x8866e514, +0xbff10000,0x9d358baf,0x325edc17, +0xbfe90000,0xe65d79c3,0x2dd84c2f, +}; +static long phased[18] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40010000,0xec176652,0xb2a5f3e9, +0x40010000,0x891f131f,0x3f874b69, +0x3ffe0000,0xa2852dc6,0x2a956f25, +0x3ffa0000,0x844b9b9f,0xfcc837bf, +0x3ff40000,0x9dad8709,0x4806ac5c, +0x3fec0000,0xe65d79c3,0x2dd84c8c, +}; +#endif +#define JZ1 5.783185962946784521176L +#define JZ2 30.47126234366208639908L +#define JZ3 7.488700679069518344489e1L + +#define PIO4L 0.78539816339744830961566L +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double fabsl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double cosl ( long double ); +extern long double sinl ( long double ); +extern long double logl ( long double ); +long double j0l ( long double ); +#else +long double sqrtl(), fabsl(), polevll(), p1evll(), cosl(), sinl(), logl(); +long double j0l(); +#endif + +long double j0l(x) +long double x; +{ +long double xx, y, z, modulus, phase; + +xx = x * x; +if( xx < 81.0L ) + { + y = (xx - JZ1) * (xx - JZ2) * (xx -JZ3); + y *= polevll( xx, j0n, 7 ) / p1evll( xx, j0d, 8 ); + return y; + } + +y = fabsl(x); +xx = 1.0/xx; +phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); + +z = 1.0/y; +modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 7 ); + +y = modulus * cosl( y - PIO4L + z*phase) / sqrtl(y); +return y; +} + + +/* +y0(x) = 2/pi * log(x) * j0(x) + P(z**2)/Q(z**2) +0 <= x <= 5 +Absolute error +n=7, d=7 +Peak error = 8.55e-22 +Relative error spread = 2.7e-1 +*/ +#if UNK +static long double y0n[8] = { + 1.556909814120445353691E4L, +-1.464324149797947303151E7L, + 5.427926320587133391307E9L, +-9.808510181632626683952E11L, + 8.747842804834934784972E13L, +-3.461898868011666236539E15L, + 4.421767595991969611983E16L, +-1.847183690384811186958E16L, +}; +static long double y0d[7] = { +/* 1.000000000000000000000E0L,*/ + 1.040792201755841697889E3L, + 6.256391154086099882302E5L, + 2.686702051957904669677E8L, + 8.630939306572281881328E10L, + 2.027480766502742538763E13L, + 3.167750475899536301562E15L, + 2.502813268068711844040E17L, +}; +#endif +#if IBMPC +static short y0n[] = { +0x126c,0x20be,0x647f,0xf344,0x400c, XPD +0x2ec0,0x7b95,0x297f,0xdf70,0xc016, XPD +0x2fdd,0x4b27,0xca98,0xa1c3,0x401f, XPD +0x3e3c,0xb343,0x46c9,0xe45f,0xc026, XPD +0xb219,0x37ba,0x5142,0x9f1f,0x402d, XPD +0x23c9,0x6b29,0x4244,0xc4c9,0xc032, XPD +0x501f,0x6264,0xbdf4,0x9d17,0x4036, XPD +0x5fbd,0x0171,0x135a,0x8340,0xc035, XPD +}; +static short y0d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0x9057,0x7f25,0x59b7,0x8219,0x4009, XPD +0xd938,0xb6b2,0x71d8,0x98be,0x4012, XPD +0x97a4,0x90fa,0xa7e9,0x801c,0x401b, XPD +0x553b,0x4dc8,0x8695,0xa0c3,0x4023, XPD +0x6732,0x8c1b,0xc5ab,0x9384,0x402b, XPD +0x04d3,0xa629,0xd61d,0xb410,0x4032, XPD +0x241a,0x8f2b,0x629a,0xde4b,0x4038, XPD +}; +#endif +#if MIEEE +static long y0n[24] = { +0x400c0000,0xf344647f,0x20be126c, +0xc0160000,0xdf70297f,0x7b952ec0, +0x401f0000,0xa1c3ca98,0x4b272fdd, +0xc0260000,0xe45f46c9,0xb3433e3c, +0x402d0000,0x9f1f5142,0x37bab219, +0xc0320000,0xc4c94244,0x6b2923c9, +0x40360000,0x9d17bdf4,0x6264501f, +0xc0350000,0x8340135a,0x01715fbd, +}; +static long y0d[21] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40090000,0x821959b7,0x7f259057, +0x40120000,0x98be71d8,0xb6b2d938, +0x401b0000,0x801ca7e9,0x90fa97a4, +0x40230000,0xa0c38695,0x4dc8553b, +0x402b0000,0x9384c5ab,0x8c1b6732, +0x40320000,0xb410d61d,0xa62904d3, +0x40380000,0xde4b629a,0x8f2b241a, +}; +#endif +/* +y0(x) = (x-Y0Z1)(x-Y0Z2)(x-Y0Z3)(x-Y0Z4)P(x)/Q(x) +4.5 <= x <= 9 +Absolute error +n=9, d=9 +Peak error = 2.35e-20 +Relative error spread = 7.8e-13 +*/ +#if UNK +static long double y059n[10] = { + 2.368715538373384869796E-2L, +-1.472923738545276751402E0L, + 2.525993724177105060507E1L, + 7.727403527387097461580E1L, +-4.578271827238477598563E3L, + 7.051411242092171161986E3L, + 1.951120419910720443331E5L, + 6.515211089266670755622E5L, +-1.164760792144532266855E5L, +-5.566567444353735925323E5L, +}; +static long double y059d[9] = { +/* 1.000000000000000000000E0L,*/ +-6.235501989189125881723E1L, + 2.224790285641017194158E3L, +-5.103881883748705381186E4L, + 8.772616606054526158657E5L, +-1.096162986826467060921E7L, + 1.083335477747278958468E8L, +-7.045635226159434678833E8L, + 3.518324187204647941098E9L, + 1.173085288957116938494E9L, +}; +#endif +#if IBMPC +static short y059n[] = { +0x992f,0xab45,0x90b6,0xc20b,0x3ff9, XPD +0x1207,0x46ea,0xc3db,0xbc88,0xbfff, XPD +0x5504,0x035a,0x59fa,0xca14,0x4003, XPD +0xd5a3,0xf673,0x4e59,0x9a8c,0x4005, XPD +0x62e0,0xc25b,0x2cb3,0x8f12,0xc00b, XPD +0xe8fa,0x4b44,0x4a39,0xdc5b,0x400b, XPD +0x49e2,0xfb52,0x02af,0xbe8a,0x4010, XPD +0x8c07,0x29e3,0x11be,0x9f10,0x4012, XPD +0xfd54,0xb2fe,0x0a23,0xe37e,0xc00f, XPD +0xf90c,0x3510,0x0be9,0x87e7,0xc012, XPD +}; +static short y059d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xdebf,0xa468,0x8a55,0xf96b,0xc004, XPD +0xad09,0x8e6a,0xa502,0x8b0c,0x400a, XPD +0xa28c,0x5563,0xd19f,0xc75e,0xc00e, XPD +0xe8b6,0xd705,0xda91,0xd62c,0x4012, XPD +0xec8a,0x4697,0xddde,0xa742,0xc016, XPD +0x27ff,0xca92,0x3d78,0xcea1,0x4019, XPD +0xe26b,0x76b9,0x250a,0xa7fb,0xc01c, XPD +0xceb6,0x3463,0x5ddb,0xd1b5,0x401e, XPD +0x3b3b,0xea0b,0xb8d1,0x8bd7,0x401d, XPD +}; +#endif +#if MIEEE +static long y059n[30] = { +0x3ff90000,0xc20b90b6,0xab45992f, +0xbfff0000,0xbc88c3db,0x46ea1207, +0x40030000,0xca1459fa,0x035a5504, +0x40050000,0x9a8c4e59,0xf673d5a3, +0xc00b0000,0x8f122cb3,0xc25b62e0, +0x400b0000,0xdc5b4a39,0x4b44e8fa, +0x40100000,0xbe8a02af,0xfb5249e2, +0x40120000,0x9f1011be,0x29e38c07, +0xc00f0000,0xe37e0a23,0xb2fefd54, +0xc0120000,0x87e70be9,0x3510f90c, +}; +static long y059d[27] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0040000,0xf96b8a55,0xa468debf, +0x400a0000,0x8b0ca502,0x8e6aad09, +0xc00e0000,0xc75ed19f,0x5563a28c, +0x40120000,0xd62cda91,0xd705e8b6, +0xc0160000,0xa742ddde,0x4697ec8a, +0x40190000,0xcea13d78,0xca9227ff, +0xc01c0000,0xa7fb250a,0x76b9e26b, +0x401e0000,0xd1b55ddb,0x3463ceb6, +0x401d0000,0x8bd7b8d1,0xea0b3b3b, +}; +#endif +#define TWOOPI 6.36619772367581343075535E-1L +#define Y0Z1 3.957678419314857868376e0L +#define Y0Z2 7.086051060301772697624e0L +#define Y0Z3 1.022234504349641701900e1L +#define Y0Z4 1.336109747387276347827e1L +/* #define MAXNUML 1.189731495357231765021e4932L */ +extern long double MAXNUML; + +long double y0l(x) +long double x; +{ +long double xx, y, z, modulus, phase; + +if( x < 0.0 ) + { + return (-MAXNUML); + } +xx = x * x; +if( xx < 81.0L ) + { + if( xx < 20.25L ) + { + y = TWOOPI * logl(x) * j0l(x); + y += polevll( xx, y0n, 7 ) / p1evll( xx, y0d, 7 ); + } + else + { + y = (x - Y0Z1)*(x - Y0Z2)*(x - Y0Z3)*(x - Y0Z4); + y *= polevll( x, y059n, 9 ) / p1evll( x, y059d, 9 ); + } + return y; + } + +y = fabsl(x); +xx = 1.0/xx; +phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); + +z = 1.0/y; +modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 7 ); + +y = modulus * sinl( y - PIO4L + z*phase) / sqrtl(y); +return y; +} diff --git a/libm/ldouble/j1l.c b/libm/ldouble/j1l.c new file mode 100644 index 000000000..83428473e --- /dev/null +++ b/libm/ldouble/j1l.c @@ -0,0 +1,551 @@ +/* j1l.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * long double x, y, j1l(); + * + * y = j1l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 9] and + * (9, infinity). In the first interval the rational approximation + * is (x^2 - r^2) (x^2 - s^2) (x^2 - t^2) x P8(x^2) / Q8(x^2), + * where r, s, t are the first three zeros of the function. + * In the second interval the expansion is in terms of the + * modulus M1(x) = sqrt(J1(x)^2 + Y1(x)^2) and phase P1(x) + * = atan(Y1(x)/J1(x)). M1 is approximated by sqrt(1/x)P7(1/x)/Q8(1/x). + * The approximation to j1 is M1 * cos(x - 3 pi/4 + 1/x P5(1/x^2)/Q6(1/x^2)). + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 40000 1.8e-19 5.0e-20 + * + * + */ + /* y1l.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y1l(); + * + * y = y1l( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 4.5>, [4.5,9> and + * [9, infinity). In the first interval a rational approximation + * R(x) is employed to compute y0(x) = R(x) + 2/pi * log(x) * j0(x). + * + * In the second interval, the approximation is + * (x - p)(x - q)(x - r)(x - s)P9(x)/Q10(x) + * where p, q, r, s are zeros of y1(x). + * + * The third interval uses the same approximations to modulus + * and phase as j1(x), whence y1(x) = modulus * sin(phase). + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 36000 2.7e-19 5.3e-20 + * + */ + +/* Copyright 1994 by Stephen L. Moshier (moshier@world.std.com). */ + +#include <math.h> + +/* +j1(x) = (x^2-r0^2)(x^2-r1^2)(x^2-r2^2) x P(x**2)/Q(x**2) +0 <= x <= 9 +Relative error +n=8, d=8 +Peak error = 2e-21 +*/ +#if UNK +static long double j1n[9] = { +-2.63469779622127762897E-4L, + 9.31329762279632791262E-1L, +-1.46280142797793933909E3L, + 1.32000129539331214495E6L, +-7.41183271195454042842E8L, + 2.626500686552841932403E11L, +-5.68263073022183470933E13L, + 6.80006297997263446982E15L, +-3.41470097444474566748E17L, +}; +static long double j1d[8] = { +/* 1.00000000000000000000E0L,*/ + 2.95267951972943745733E3L, + 4.78723926343829674773E6L, + 5.37544732957807543920E9L, + 4.46866213886267829490E12L, + 2.76959756375961607085E15L, + 1.23367806884831151194E18L, + 3.57325874689695599524E20L, + 5.10779045516141578461E22L, +}; +#endif +#if IBMPC +static short j1n[] = { +0xf72f,0x18cc,0x50b2,0x8a22,0xbff3, XPD +0x6dc3,0xc850,0xa096,0xee6b,0x3ffe, XPD +0x29f3,0x496b,0xa54c,0xb6d9,0xc009, XPD +0x38f5,0xf72b,0x0a5c,0xa122,0x4013, XPD +0x1ac8,0xc825,0x3c9c,0xb0b6,0xc01c, XPD +0x038e,0xbd23,0xa7fa,0xf49c,0x4024, XPD +0x636c,0x4d29,0x9f71,0xcebb,0xc02c, XPD +0xd3c2,0xf8f0,0xf852,0xc144,0x4033, XPD +0xd8d8,0x7311,0xa7d2,0x97a4,0xc039, XPD +}; +static short j1d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xbaf9,0x146e,0xdf50,0xb88a,0x400a, XPD +0x6a17,0xe162,0x4e86,0x9218,0x4015, XPD +0x6041,0xc9fe,0x6890,0xa033,0x401f, XPD +0xb498,0xfdd5,0x209e,0x820e,0x4029, XPD +0x0122,0x56c0,0xf2ef,0x9d6e,0x4032, XPD +0xe6c0,0xa725,0x3d56,0x88f7,0x403b, XPD +0x665d,0xb178,0x242e,0x9af7,0x4043, XPD +0xdd67,0xf5b3,0x0522,0xad0f,0x404a, XPD +}; +#endif +#if MIEEE +static long j1n[27] = { +0xbff30000,0x8a2250b2,0x18ccf72f, +0x3ffe0000,0xee6ba096,0xc8506dc3, +0xc0090000,0xb6d9a54c,0x496b29f3, +0x40130000,0xa1220a5c,0xf72b38f5, +0xc01c0000,0xb0b63c9c,0xc8251ac8, +0x40240000,0xf49ca7fa,0xbd23038e, +0xc02c0000,0xcebb9f71,0x4d29636c, +0x40330000,0xc144f852,0xf8f0d3c2, +0xc0390000,0x97a4a7d2,0x7311d8d8, +}; +static long j1d[24] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x400a0000,0xb88adf50,0x146ebaf9, +0x40150000,0x92184e86,0xe1626a17, +0x401f0000,0xa0336890,0xc9fe6041, +0x40290000,0x820e209e,0xfdd5b498, +0x40320000,0x9d6ef2ef,0x56c00122, +0x403b0000,0x88f73d56,0xa725e6c0, +0x40430000,0x9af7242e,0xb178665d, +0x404a0000,0xad0f0522,0xf5b3dd67, +}; +#endif +/* +sqrt(j0^2(1/x^2) + y0^2(1/x^2)) = z P(z**2)/Q(z**2) +z(x) = 1/sqrt(x) +Relative error +n=7, d=8 +Peak error = 1.35e=20 +Relative error spread = 9.9e0 +*/ +#if UNK +static long double modulusn[8] = { +-5.041742205078442098874E0L, + 3.918474430130242177355E-1L, + 2.527521168680500659056E0L, + 7.172146812845906480743E0L, + 2.859499532295180940060E0L, + 1.014671139779858141347E0L, + 1.255798064266130869132E-1L, + 1.596507617085714650238E-2L, +}; +static long double modulusd[8] = { +/* 1.000000000000000000000E0L,*/ +-6.233092094568239317498E0L, +-9.214128701852838347002E-1L, + 2.531772200570435289832E0L, + 8.755081357265851765640E0L, + 3.554340386955608261463E0L, + 1.267949948774331531237E0L, + 1.573909467558180942219E-1L, + 2.000925566825407466160E-2L, +}; +#endif +#if IBMPC +static short modulusn[] = { +0x3d53,0xb598,0xf3bf,0xa155,0xc001, XPD +0x3111,0x863a,0x3a61,0xc8a0,0x3ffd, XPD +0x7d55,0xdb8c,0xe825,0xa1c2,0x4000, XPD +0xe5e2,0x6914,0x3a08,0xe582,0x4001, XPD +0x71e6,0x88a5,0x0a53,0xb702,0x4000, XPD +0x2cb0,0xc657,0xbe70,0x81e0,0x3fff, XPD +0x6de4,0x8fae,0xfe26,0x8097,0x3ffc, XPD +0xa905,0x05fb,0x3101,0x82c9,0x3ff9, XPD +}; +static short modulusd[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0x2603,0x640e,0x7d8d,0xc775,0xc001, XPD +0x77b5,0x8f2d,0xb6bf,0xebe1,0xbffe, XPD +0x6420,0x97ce,0x8e44,0xa208,0x4000, XPD +0x0260,0x746b,0xd030,0x8c14,0x4002, XPD +0x77b6,0x34e2,0x501a,0xe37a,0x4000, XPD +0x37ce,0x79ae,0x2f15,0xa24c,0x3fff, XPD +0xfc82,0x02c7,0x17a4,0xa12b,0x3ffc, XPD +0x1237,0xcc6c,0x7356,0xa3ea,0x3ff9, XPD +}; +#endif +#if MIEEE +static long modulusn[24] = { +0xc0010000,0xa155f3bf,0xb5983d53, +0x3ffd0000,0xc8a03a61,0x863a3111, +0x40000000,0xa1c2e825,0xdb8c7d55, +0x40010000,0xe5823a08,0x6914e5e2, +0x40000000,0xb7020a53,0x88a571e6, +0x3fff0000,0x81e0be70,0xc6572cb0, +0x3ffc0000,0x8097fe26,0x8fae6de4, +0x3ff90000,0x82c93101,0x05fba905, +}; +static long modulusd[24] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0010000,0xc7757d8d,0x640e2603, +0xbffe0000,0xebe1b6bf,0x8f2d77b5, +0x40000000,0xa2088e44,0x97ce6420, +0x40020000,0x8c14d030,0x746b0260, +0x40000000,0xe37a501a,0x34e277b6, +0x3fff0000,0xa24c2f15,0x79ae37ce, +0x3ffc0000,0xa12b17a4,0x02c7fc82, +0x3ff90000,0xa3ea7356,0xcc6c1237, +}; +#endif +/* +atan(y1(x)/j1(x)) = x - 3pi/4 + z P(z**2)/Q(z**2) +z(x) = 1/x +Absolute error +n=5, d=6 +Peak error = 4.83e-21 +Relative error spread = 1.9e0 +*/ +#if UNK +static long double phasen[6] = { + 2.010456367705144783933E0L, + 1.587378144541918176658E0L, + 2.682837461073751055565E-1L, + 1.472572645054468815027E-2L, + 2.884976126715926258586E-4L, + 1.708502235134706284899E-6L, +}; +static long double phased[6] = { +/* 1.000000000000000000000E0L,*/ + 6.809332495854873089362E0L, + 4.518597941618813112665E0L, + 7.320149039410806471101E-1L, + 3.960155028960712309814E-2L, + 7.713202197319040439861E-4L, + 4.556005960359216767984E-6L, +}; +#endif +#if IBMPC +static short phasen[] = { +0xebc0,0x5506,0x512f,0x80ab,0x4000, XPD +0x6050,0x98aa,0x3500,0xcb2f,0x3fff, XPD +0xe907,0x28b9,0x7cb7,0x895c,0x3ffd, XPD +0xa830,0xf4a3,0x2c60,0xf144,0x3ff8, XPD +0xf74f,0xbe87,0x7e7d,0x9741,0x3ff3, XPD +0x540c,0xc1d5,0xb096,0xe54f,0x3feb, XPD +}; +static short phased[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xefe3,0x292c,0x0d43,0xd9e6,0x4001, XPD +0xb1f2,0xe0d2,0x5ab5,0x9098,0x4001, XPD +0xc39e,0x9c8c,0x5428,0xbb65,0x3ffe, XPD +0x98f8,0xd610,0x3c35,0xa235,0x3ffa, XPD +0xa853,0x55fb,0x6c79,0xca32,0x3ff4, XPD +0x8d72,0x2be3,0xcb0f,0x98df,0x3fed, XPD +}; +#endif +#if MIEEE +static long phasen[18] = { +0x40000000,0x80ab512f,0x5506ebc0, +0x3fff0000,0xcb2f3500,0x98aa6050, +0x3ffd0000,0x895c7cb7,0x28b9e907, +0x3ff80000,0xf1442c60,0xf4a3a830, +0x3ff30000,0x97417e7d,0xbe87f74f, +0x3feb0000,0xe54fb096,0xc1d5540c, +}; +static long phased[18] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40010000,0xd9e60d43,0x292cefe3, +0x40010000,0x90985ab5,0xe0d2b1f2, +0x3ffe0000,0xbb655428,0x9c8cc39e, +0x3ffa0000,0xa2353c35,0xd61098f8, +0x3ff40000,0xca326c79,0x55fba853, +0x3fed0000,0x98dfcb0f,0x2be38d72, +}; +#endif +#define JZ1 1.46819706421238932572e1L +#define JZ2 4.92184563216946036703e1L +#define JZ3 1.03499453895136580332e2L + +#define THPIO4L 2.35619449019234492885L +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double fabsl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double cosl ( long double ); +extern long double sinl ( long double ); +extern long double logl ( long double ); +long double j1l (long double ); +#else +long double sqrtl(), fabsl(), polevll(), p1evll(), cosl(), sinl(), logl(); +long double j1l(); +#endif + +long double j1l(x) +long double x; +{ +long double xx, y, z, modulus, phase; + +xx = x * x; +if( xx < 81.0L ) + { + y = (xx - JZ1) * (xx - JZ2) * (xx - JZ3); + y *= x * polevll( xx, j1n, 8 ) / p1evll( xx, j1d, 8 ); + return y; + } + +y = fabsl(x); +xx = 1.0/xx; +phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); + +z = 1.0/y; +modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 8 ); + +y = modulus * cosl( y - THPIO4L + z*phase) / sqrtl(y); +if( x < 0 ) + y = -y; +return y; +} + +/* +y1(x) = 2/pi * (log(x) * j1(x) - 1/x) + R(x^2) z P(z**2)/Q(z**2) +0 <= x <= 4.5 +z(x) = x +Absolute error +n=6, d=7 +Peak error = 7.25e-22 +Relative error spread = 4.5e-2 +*/ +#if UNK +static long double y1n[7] = { +-1.288901054372751879531E5L, + 9.914315981558815369372E7L, +-2.906793378120403577274E10L, + 3.954354656937677136266E12L, +-2.445982226888344140154E14L, + 5.685362960165615942886E15L, +-2.158855258453711703120E16L, +}; +static long double y1d[7] = { +/* 1.000000000000000000000E0L,*/ + 8.926354644853231136073E2L, + 4.679841933793707979659E5L, + 1.775133253792677466651E8L, + 5.089532584184822833416E10L, + 1.076474894829072923244E13L, + 1.525917240904692387994E15L, + 1.101136026928555260168E17L, +}; +#endif +#if IBMPC +static short y1n[] = { +0x5b16,0xf7f8,0x0d7e,0xfbbd,0xc00f, XPD +0x53e4,0x194c,0xbefa,0xbd19,0x4019, XPD +0x7607,0xa687,0xaf0a,0xd892,0xc021, XPD +0x5633,0xaa6b,0x79e5,0xe62c,0x4028, XPD +0x69fd,0x1242,0xf62d,0xde75,0xc02e, XPD +0x7f8b,0x4757,0x75bd,0xa196,0x4033, XPD +0x3a10,0x0848,0x5930,0x9965,0xc035, XPD +}; +static short y1d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0xdd1a,0x3b8e,0xab73,0xdf28,0x4008, XPD +0x298c,0x29ef,0x0630,0xe482,0x4011, XPD +0x0e86,0x117b,0x36d6,0xa94a,0x401a, XPD +0x57e0,0x1d92,0x90a9,0xbd99,0x4022, XPD +0xaaf0,0x342b,0xd098,0x9ca5,0x402a, XPD +0x8c6a,0x397e,0x0963,0xad7a,0x4031, XPD +0x7302,0xb91b,0xde7e,0xc399,0x4037, XPD +}; +#endif +#if MIEEE +static long y1n[21] = { +0xc00f0000,0xfbbd0d7e,0xf7f85b16, +0x40190000,0xbd19befa,0x194c53e4, +0xc0210000,0xd892af0a,0xa6877607, +0x40280000,0xe62c79e5,0xaa6b5633, +0xc02e0000,0xde75f62d,0x124269fd, +0x40330000,0xa19675bd,0x47577f8b, +0xc0350000,0x99655930,0x08483a10, +}; +static long y1d[21] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40080000,0xdf28ab73,0x3b8edd1a, +0x40110000,0xe4820630,0x29ef298c, +0x401a0000,0xa94a36d6,0x117b0e86, +0x40220000,0xbd9990a9,0x1d9257e0, +0x402a0000,0x9ca5d098,0x342baaf0, +0x40310000,0xad7a0963,0x397e8c6a, +0x40370000,0xc399de7e,0xb91b7302, +}; +#endif +/* +y1(x) = (x-YZ1)(x-YZ2)(x-YZ3)(x-YZ4)R(x) P(z)/Q(z) +z(x) = x +4.5 <= x <= 9 +Absolute error +n=9, d=10 +Peak error = 3.27e-22 +Relative error spread = 4.5e-2 +*/ +#if UNK +static long double y159n[10] = { +-6.806634906054210550896E-1L, + 4.306669585790359450532E1L, +-9.230477746767243316014E2L, + 6.171186628598134035237E3L, + 2.096869860275353982829E4L, +-1.238961670382216747944E5L, +-1.781314136808997406109E6L, +-1.803400156074242435454E6L, +-1.155761550219364178627E6L, + 3.112221202330688509818E5L, +}; +static long double y159d[10] = { +/* 1.000000000000000000000E0L,*/ +-6.181482377814679766978E1L, + 2.238187927382180589099E3L, +-5.225317824142187494326E4L, + 9.217235006983512475118E5L, +-1.183757638771741974521E7L, + 1.208072488974110742912E8L, +-8.193431077523942651173E8L, + 4.282669747880013349981E9L, +-1.171523459555524458808E9L, + 1.078445545755236785692E8L, +}; +#endif +#if IBMPC +static short y159n[] = { +0xb5e5,0xbb42,0xf667,0xae3f,0xbffe, XPD +0xfdf1,0x41e5,0x4beb,0xac44,0x4004, XPD +0xe917,0x8486,0x0ebd,0xe6c3,0xc008, XPD +0xdf40,0x226b,0x7e37,0xc0d9,0x400b, XPD +0xb2bf,0x4296,0x65af,0xa3d1,0x400d, XPD +0xa33b,0x8229,0x1561,0xf1fc,0xc00f, XPD +0xcd43,0x2f50,0x1118,0xd972,0xc013, XPD +0x3811,0xa3da,0x413f,0xdc24,0xc013, XPD +0xf62f,0xd968,0x8c66,0x8d15,0xc013, XPD +0x539b,0xf305,0xc3d8,0x97f6,0x4011, XPD +}; +static short y159d[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff, XPD*/ +0x1a6c,0x1c93,0x612a,0xf742,0xc004, XPD +0xd0fe,0x2487,0x01c0,0x8be3,0x400a, XPD +0xbed4,0x3ad5,0x2da1,0xcc1d,0xc00e, XPD +0x3c4f,0xdc46,0xb802,0xe107,0x4012, XPD +0xe5e5,0x4172,0x8863,0xb4a0,0xc016, XPD +0x6de5,0xb797,0xea1c,0xe66b,0x4019, XPD +0xa46a,0x0273,0xbc0f,0xc358,0xc01c, XPD +0x8e0e,0xe148,0x5ab3,0xff44,0x401e, XPD +0xb3ad,0x1c6d,0x0f07,0x8ba8,0xc01d, XPD +0xa231,0x6ab0,0x7952,0xcdb2,0x4019, XPD +}; +#endif +#if MIEEE +static long y159n[30] = { +0xbffe0000,0xae3ff667,0xbb42b5e5, +0x40040000,0xac444beb,0x41e5fdf1, +0xc0080000,0xe6c30ebd,0x8486e917, +0x400b0000,0xc0d97e37,0x226bdf40, +0x400d0000,0xa3d165af,0x4296b2bf, +0xc00f0000,0xf1fc1561,0x8229a33b, +0xc0130000,0xd9721118,0x2f50cd43, +0xc0130000,0xdc24413f,0xa3da3811, +0xc0130000,0x8d158c66,0xd968f62f, +0x40110000,0x97f6c3d8,0xf305539b, +}; +static long y159d[30] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0040000,0xf742612a,0x1c931a6c, +0x400a0000,0x8be301c0,0x2487d0fe, +0xc00e0000,0xcc1d2da1,0x3ad5bed4, +0x40120000,0xe107b802,0xdc463c4f, +0xc0160000,0xb4a08863,0x4172e5e5, +0x40190000,0xe66bea1c,0xb7976de5, +0xc01c0000,0xc358bc0f,0x0273a46a, +0x401e0000,0xff445ab3,0xe1488e0e, +0xc01d0000,0x8ba80f07,0x1c6db3ad, +0x40190000,0xcdb27952,0x6ab0a231, +}; +#endif + +extern long double MAXNUML; +/* #define MAXNUML 1.18973149535723176502e4932L */ +#define TWOOPI 6.36619772367581343075535e-1L +#define THPIO4 2.35619449019234492885L +#define Y1Z1 2.19714132603101703515e0L +#define Y1Z2 5.42968104079413513277e0L +#define Y1Z3 8.59600586833116892643e0L +#define Y1Z4 1.17491548308398812434e1L + +long double y1l(x) +long double x; +{ +long double xx, y, z, modulus, phase; + +if( x < 0.0 ) + { + return (-MAXNUML); + } +z = 1.0/x; +xx = x * x; +if( xx < 81.0L ) + { + if( xx < 20.25L ) + { + y = TWOOPI * (logl(x) * j1l(x) - z); + y += x * polevll( xx, y1n, 6 ) / p1evll( xx, y1d, 7 ); + } + else + { + y = (x - Y1Z1)*(x - Y1Z2)*(x - Y1Z3)*(x - Y1Z4); + y *= polevll( x, y159n, 9 ) / p1evll( x, y159d, 10 ); + } + return y; + } + +xx = 1.0/xx; +phase = polevll( xx, phasen, 5 ) / p1evll( xx, phased, 6 ); + +modulus = polevll( z, modulusn, 7 ) / p1evll( z, modulusd, 8 ); + +z = modulus * sinl( x - THPIO4L + z*phase) / sqrtl(x); +return z; +} diff --git a/libm/ldouble/jnl.c b/libm/ldouble/jnl.c new file mode 100644 index 000000000..1b24c50c7 --- /dev/null +++ b/libm/ldouble/jnl.c @@ -0,0 +1,130 @@ +/* jnl.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * long double x, y, jnl(); + * + * y = jnl( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order n, where n is a + * (possibly negative) integer. + * + * The ratio of jn(x) to j0(x) is computed by backward + * recurrence. First the ratio jn/jn-1 is found by a + * continued fraction expansion. Then the recurrence + * relating successive orders is applied until j0 or j1 is + * reached. + * + * If n = 0 or 1 the routine for j0 or j1 is called + * directly. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE -30, 30 5000 3.3e-19 4.7e-20 + * + * + * Not suitable for large n or x. + * + */ + +/* jn.c +Cephes Math Library Release 2.0: April, 1987 +Copyright 1984, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ +#include <math.h> + +extern long double MACHEPL; +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double j0l ( long double ); +extern long double j1l ( long double ); +#else +long double fabsl(), j0l(), j1l(); +#endif + +long double jnl( n, x ) +int n; +long double x; +{ +long double pkm2, pkm1, pk, xk, r, ans; +int k, sign; + +if( n < 0 ) + { + n = -n; + if( (n & 1) == 0 ) /* -1**n */ + sign = 1; + else + sign = -1; + } +else + sign = 1; + +if( x < 0.0L ) + { + if( n & 1 ) + sign = -sign; + x = -x; + } + + +if( n == 0 ) + return( sign * j0l(x) ); +if( n == 1 ) + return( sign * j1l(x) ); +if( n == 2 ) + return( sign * (2.0L * j1l(x) / x - j0l(x)) ); + +if( x < MACHEPL ) + return( 0.0L ); + +/* continued fraction */ +k = 53; +pk = 2 * (n + k); +ans = pk; +xk = x * x; + +do + { + pk -= 2.0L; + ans = pk - (xk/ans); + } +while( --k > 0 ); +ans = x/ans; + +/* backward recurrence */ + +pk = 1.0L; +pkm1 = 1.0L/ans; +k = n-1; +r = 2 * k; + +do + { + pkm2 = (pkm1 * r - pk * x) / x; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0L; + } +while( --k > 0 ); + +if( fabsl(pk) > fabsl(pkm1) ) + ans = j1l(x)/pk; +else + ans = j0l(x)/pkm1; +return( sign * ans ); +} diff --git a/libm/ldouble/lcalc.c b/libm/ldouble/lcalc.c new file mode 100644 index 000000000..87250952f --- /dev/null +++ b/libm/ldouble/lcalc.c @@ -0,0 +1,1484 @@ +/* calc.c */ +/* Keyboard command interpreter */ +/* by Stephen L. Moshier */ + +/* Include functions for IEEE special values */ +#define NANS 1 + +/* length of command line: */ +#define LINLEN 128 + +#define XON 0x11 +#define XOFF 0x13 + +#define SALONE 1 +#define DECPDP 0 +#define INTLOGIN 0 +#define INTHELP 1 +#ifndef TRUE +#define TRUE 1 +#endif + +/* Initialize squirrel printf: */ +#define INIPRINTF 0 + +#if DECPDP +#define TRUE 1 +#endif + +#include <stdio.h> +#include <string.h> +static char idterp[] = { +"\n\nSteve Moshier's command interpreter V1.3\n"}; +#define ISLOWER(c) ((c >= 'a') && (c <= 'z')) +#define ISUPPER(c) ((c >= 'A') && (c <= 'Z')) +#define ISALPHA(c) (ISLOWER(c) || ISUPPER(c)) +#define ISDIGIT(c) ((c >= '0') && (c <= '9')) +#define ISATF(c) (((c >= 'a')&&(c <= 'f')) || ((c >= 'A')&&(c <= 'F'))) +#define ISXDIGIT(c) (ISDIGIT(c) || ISATF(c)) +#define ISOCTAL(c) ((c >= '0') && (c < '8')) +#define ISALNUM(c) (ISALPHA(c) || (ISDIGIT(c)) +FILE *fopen(); + +#include "lcalc.h" +#include "ehead.h" + +/* space for working precision numbers */ +static long double vs[22]; + +/* the symbol table of temporary variables: */ + +#define NTEMP 4 +struct varent temp[NTEMP] = { +{"T", OPR | TEMP, &vs[14]}, +{"T", OPR | TEMP, &vs[15]}, +{"T", OPR | TEMP, &vs[16]}, +{"\0", OPR | TEMP, &vs[17]} +}; + +/* the symbol table of operators */ +/* EOL is interpreted on null, newline, or ; */ +struct symbol oprtbl[] = { +{"BOL", OPR | BOL, 0}, +{"EOL", OPR | EOL, 0}, +{"-", OPR | UMINUS, 8}, +/*"~", OPR | COMP, 8,*/ +{",", OPR | EOE, 1}, +{"=", OPR | EQU, 2}, +/*"|", OPR | LOR, 3,*/ +/*"^", OPR | LXOR, 4,*/ +/*"&", OPR | LAND, 5,*/ +{"+", OPR | PLUS, 6}, +{"-", OPR | MINUS, 6}, +{"*", OPR | MULT, 7}, +{"/", OPR | DIV, 7}, +/*"%", OPR | MOD, 7,*/ +{"(", OPR | LPAREN, 11}, +{")", OPR | RPAREN, 11}, +{"\0", ILLEG, 0} +}; + +#define NOPR 8 + +/* the symbol table of indirect variables: */ +extern long double PIL; +struct varent indtbl[] = { +{"t", VAR | IND, &vs[21]}, +{"u", VAR | IND, &vs[20]}, +{"v", VAR | IND, &vs[19]}, +{"w", VAR | IND, &vs[18]}, +{"x", VAR | IND, &vs[10]}, +{"y", VAR | IND, &vs[11]}, +{"z", VAR | IND, &vs[12]}, +{"pi", VAR | IND, &PIL}, +{"\0", ILLEG, 0} +}; + +/* the symbol table of constants: */ + +#define NCONST 10 +struct varent contbl[NCONST] = { +{"C",CONST,&vs[0]}, +{"C",CONST,&vs[1]}, +{"C",CONST,&vs[2]}, +{"C",CONST,&vs[3]}, +{"C",CONST,&vs[4]}, +{"C",CONST,&vs[5]}, +{"C",CONST,&vs[6]}, +{"C",CONST,&vs[7]}, +{"C",CONST,&vs[8]}, +{"\0",CONST,&vs[9]} +}; + +/* the symbol table of string variables: */ + +static char strngs[160] = {0}; + +#define NSTRNG 5 +struct strent strtbl[NSTRNG] = { +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{"\0",ILLEG,0}, +}; + + +/* Help messages */ +#if INTHELP +static char *intmsg[] = { +"?", +"Unkown symbol", +"Expression ends in illegal operator", +"Precede ( by operator", +")( is illegal", +"Unmatched )", +"Missing )", +"Illegal left hand side", +"Missing symbol", +"Must assign to a variable", +"Divide by zero", +"Missing symbol", +"Missing operator", +"Precede quantity by operator", +"Quantity preceded by )", +"Function syntax", +"Too many function args", +"No more temps", +"Arg list" +}; +#endif + +/* the symbol table of functions: */ +#if SALONE +long double hex(), cmdh(), cmdhlp(); +long double cmddm(), cmdtm(), cmdem(); +long double take(), mxit(), exit(), bits(), csys(); +long double cmddig(), prhlst(), abmac(); +long double ifrac(), xcmpl(); +long double floorl(), logl(), powl(), sqrtl(), tanhl(), expl(); +long double ellpel(), ellpkl(), incbetl(), incbil(); +long double stdtrl(), stdtril(), zstdtrl(), zstdtril(); +long double sinl(), cosl(), tanl(), asinl(), acosl(), atanl(), atan2l(); +long double tanhl(), atanhl(); +#ifdef NANS +int isnanl(), isfinitel(), signbitl(); +long double zisnan(), zisfinite(), zsignbit(); +#endif + +struct funent funtbl[] = { +{"h", OPR | FUNC, cmdh}, +{"help", OPR | FUNC, cmdhlp}, +{"hex", OPR | FUNC, hex}, +/*"view", OPR | FUNC, view,*/ +{"exp", OPR | FUNC, expl}, +{"floor", OPR | FUNC, floorl}, +{"log", OPR | FUNC, logl}, +{"pow", OPR | FUNC, powl}, +{"sqrt", OPR | FUNC, sqrtl}, +{"tanh", OPR | FUNC, tanhl}, +{"sin", OPR | FUNC, sinl}, +{"cos", OPR | FUNC, cosl}, +{"tan", OPR | FUNC, tanl}, +{"asin", OPR | FUNC, asinl}, +{"acos", OPR | FUNC, acosl}, +{"atan", OPR | FUNC, atanl}, +{"atantwo", OPR | FUNC, atan2l}, +{"tanh", OPR | FUNC, tanhl}, +{"atanh", OPR | FUNC, atanhl}, +{"ellpe", OPR | FUNC, ellpel}, +{"ellpk", OPR | FUNC, ellpkl}, +{"incbet", OPR | FUNC, incbetl}, +{"incbi", OPR | FUNC, incbil}, +{"stdtr", OPR | FUNC, zstdtrl}, +{"stdtri", OPR | FUNC, zstdtril}, +{"ifrac", OPR | FUNC, ifrac}, +{"cmp", OPR | FUNC, xcmpl}, +#ifdef NANS +{"isnan", OPR | FUNC, zisnan}, +{"isfinite", OPR | FUNC, zisfinite}, +{"signbit", OPR | FUNC, zsignbit}, +#endif +{"bits", OPR | FUNC, bits}, +{"digits", OPR | FUNC, cmddig}, +{"dm", OPR | FUNC, cmddm}, +{"tm", OPR | FUNC, cmdtm}, +{"em", OPR | FUNC, cmdem}, +{"take", OPR | FUNC | COMMAN, take}, +{"system", OPR | FUNC | COMMAN, csys}, +{"exit", OPR | FUNC, mxit}, +/* +"remain", OPR | FUNC, eremain, +*/ +{"\0", OPR | FUNC, 0} +}; + +/* the symbol table of key words */ +struct funent keytbl[] = { +{"\0", ILLEG, 0} +}; +#endif + +void zgets(), init(); + +/* Number of decimals to display */ +#define DEFDIS 70 +static int ndigits = DEFDIS; + +/* Menu stack */ +struct funent *menstk[5] = {&funtbl[0], NULL, NULL, NULL, NULL}; +int menptr = 0; + +/* Take file stack */ +FILE *takstk[10] = {0}; +int takptr = -1; + +/* size of the expression scan list: */ +#define NSCAN 20 + +/* previous token, saved for syntax checking: */ +struct symbol *lastok = 0; + +/* variables used by parser: */ +static char str[128] = {0}; +int uposs = 0; /* possible unary operator */ +static long double qnc; +char lc[40] = { '\n' }; /* ASCII string of token symbol */ +static char line[LINLEN] = { '\n','\0' }; /* input command line */ +static char maclin[LINLEN] = { '\n','\0' }; /* macro command */ +char *interl = line; /* pointer into line */ +extern char *interl; +static int maccnt = 0; /* number of times to execute macro command */ +static int comptr = 0; /* comma stack pointer */ +static long double comstk[5]; /* comma argument stack */ +static int narptr = 0; /* pointer to number of args */ +static int narstk[5] = {0}; /* stack of number of function args */ + +/* main() */ + +/* Entire program starts here */ + +int main() +{ + +/* the scan table: */ + +/* array of pointers to symbols which have been parsed: */ +struct symbol *ascsym[NSCAN]; + +/* current place in ascsym: */ +register struct symbol **as; + +/* array of attributes of operators parsed: */ +int ascopr[NSCAN]; + +/* current place in ascopr: */ +register int *ao; + +#if LARGEMEM +/* array of precedence levels of operators: */ +long asclev[NSCAN]; +/* current place in asclev: */ +long *al; +long symval; /* value of symbol just parsed */ +#else +int asclev[NSCAN]; +int *al; +int symval; +#endif + +long double acc; /* the accumulator, for arithmetic */ +int accflg; /* flags accumulator in use */ +long double val; /* value to be combined into accumulator */ +register struct symbol *psym; /* pointer to symbol just parsed */ +struct varent *pvar; /* pointer to an indirect variable symbol */ +struct funent *pfun; /* pointer to a function symbol */ +struct strent *pstr; /* pointer to a string symbol */ +int att; /* attributes of symbol just parsed */ +int i; /* counter */ +int offset; /* parenthesis level */ +int lhsflg; /* kluge to detect illegal assignments */ +struct symbol *parser(); /* parser returns pointer to symbol */ +int errcod; /* for syntax error printout */ + + +/* Perform general initialization */ + +init(); + +menstk[0] = &funtbl[0]; +menptr = 0; +cmdhlp(); /* print out list of symbols */ + + +/* Return here to get next command line to execute */ +getcmd: + +/* initialize registers and mutable symbols */ + +accflg = 0; /* Accumulator not in use */ +acc = 0.0L; /* Clear the accumulator */ +offset = 0; /* Parenthesis level zero */ +comptr = 0; /* Start of comma stack */ +narptr = -1; /* Start of function arg counter stack */ + +psym = (struct symbol *)&contbl[0]; +for( i=0; i<NCONST; i++ ) + { + psym->attrib = CONST; /* clearing the busy bit */ + ++psym; + } +psym = (struct symbol *)&temp[0]; +for( i=0; i<NTEMP; i++ ) + { + psym->attrib = VAR | TEMP; /* clearing the busy bit */ + ++psym; + } + +pstr = &strtbl[0]; +for( i=0; i<NSTRNG; i++ ) + { + pstr->spel = &strngs[ 40*i ]; + pstr->attrib = STRING | VAR; + pstr->string = &strngs[ 40*i ]; + ++pstr; + } + +/* List of scanned symbols is empty: */ +as = &ascsym[0]; +*as = 0; +--as; +/* First item in scan list is Beginning of Line operator */ +ao = &ascopr[0]; +*ao = oprtbl[0].attrib & 0xf; /* BOL */ +/* value of first item: */ +al = &asclev[0]; +*al = oprtbl[0].sym; + +lhsflg = 0; /* illegal left hand side flag */ +psym = &oprtbl[0]; /* pointer to current token */ + +/* get next token from input string */ + +gettok: +lastok = psym; /* last token = current token */ +psym = parser(); /* get a new current token */ +/*printf( "%s attrib %7o value %7o\n", psym->spel, psym->attrib & 0xffff, + psym->sym );*/ + +/* Examine attributes of the symbol returned by the parser */ +att = psym->attrib; +if( att == ILLEG ) + { + errcod = 1; + goto synerr; + } + +/* Push functions onto scan list without analyzing further */ +if( att & FUNC ) + { + /* A command is a function whose argument is + * a pointer to the rest of the input line. + * A second argument is also passed: the address + * of the last token parsed. + */ + if( att & COMMAN ) + { + pfun = (struct funent *)psym; + ( *(pfun->fun))( interl, lastok ); + abmac(); /* scrub the input line */ + goto getcmd; /* and ask for more input */ + } + ++narptr; /* offset to number of args */ + narstk[narptr] = 0; + i = lastok->attrib & 0xffff; /* attrib=short, i=int */ + if( ((i & OPR) == 0) + || (i == (OPR | RPAREN)) + || (i == (OPR | FUNC)) ) + { + errcod = 15; + goto synerr; + } + + ++lhsflg; + ++as; + *as = psym; + ++ao; + *ao = FUNC; + ++al; + *al = offset + UMINUS; + goto gettok; + } + +/* deal with operators */ +if( att & OPR ) + { + att &= 0xf; + /* expression cannot end with an operator other than + * (, ), BOL, or a function + */ + if( (att == RPAREN) || (att == EOL) || (att == EOE)) + { + i = lastok->attrib & 0xffff; /* attrib=short, i=int */ + if( (i & OPR) + && (i != (OPR | RPAREN)) + && (i != (OPR | LPAREN)) + && (i != (OPR | FUNC)) + && (i != (OPR | BOL)) ) + { + errcod = 2; + goto synerr; + } + } + ++lhsflg; /* any operator but ( and = is not a legal lhs */ + +/* operator processing, continued */ + + switch( att ) + { + case EOE: + lhsflg = 0; + break; + case LPAREN: + /* ( must be preceded by an operator of some sort. */ + if( ((lastok->attrib & OPR) == 0) ) + { + errcod = 3; + goto synerr; + } + /* also, a preceding ) is illegal */ + if( (unsigned short )lastok->attrib == (OPR|RPAREN)) + { + errcod = 4; + goto synerr; + } + /* Begin looking for illegal left hand sides: */ + lhsflg = 0; + offset += RPAREN; /* new parenthesis level */ + goto gettok; + case RPAREN: + offset -= RPAREN; /* parenthesis level */ + if( offset < 0 ) + { + errcod = 5; /* parenthesis error */ + goto synerr; + } + goto gettok; + case EOL: + if( offset != 0 ) + { + errcod = 6; /* parenthesis error */ + goto synerr; + } + break; + case EQU: + if( --lhsflg ) /* was incremented before switch{} */ + { + errcod = 7; + goto synerr; + } + case UMINUS: + case COMP: + goto pshopr; /* evaluate right to left */ + default: ; + } + + +/* evaluate expression whenever precedence is not increasing */ + +symval = psym->sym + offset; + +while( symval <= *al ) + { + /* if just starting, must fill accumulator with last + * thing on the line + */ + if( (accflg == 0) && (as >= ascsym) && (((*as)->attrib & FUNC) == 0 )) + { + pvar = (struct varent *)*as; +/* + if( pvar->attrib & STRING ) + strcpy( (char *)&acc, (char *)pvar->value ); + else +*/ + acc = *pvar->value; + --as; + accflg = 1; + } + +/* handle beginning of line type cases, where the symbol + * list ascsym[] may be empty. + */ + switch( *ao ) + { + case BOL: +/* printf( "%.16e\n", (double )acc ); */ +#if NE == 6 + e64toasc( &acc, str, 100 ); +#else + e113toasc( &acc, str, 100 ); +#endif + printf( "%s\n", str ); + goto getcmd; /* all finished */ + case UMINUS: + acc = -acc; + goto nochg; +/* + case COMP: + acc = ~acc; + goto nochg; +*/ + default: ; + } +/* Now it is illegal for symbol list to be empty, + * because we are going to need a symbol below. + */ + if( as < &ascsym[0] ) + { + errcod = 8; + goto synerr; + } +/* get attributes and value of current symbol */ + att = (*as)->attrib; + pvar = (struct varent *)*as; + if( att & FUNC ) + val = 0.0L; + else + { +/* + if( att & STRING ) + strcpy( (char *)&val, (char *)pvar->value ); + else +*/ + val = *pvar->value; + } + +/* Expression evaluation, continued. */ + + switch( *ao ) + { + case FUNC: + pfun = (struct funent *)*as; + /* Call the function with appropriate number of args */ + i = narstk[ narptr ]; + --narptr; + switch(i) + { + case 0: + acc = ( *(pfun->fun) )(acc); + break; + case 1: + acc = ( *(pfun->fun) )(acc, comstk[comptr-1]); + break; + case 2: + acc = ( *(pfun->fun) )(acc, comstk[comptr-2], + comstk[comptr-1]); + break; + case 3: + acc = ( *(pfun->fun) )(acc, comstk[comptr-3], + comstk[comptr-2], comstk[comptr-1]); + break; + default: + errcod = 16; + goto synerr; + } + comptr -= i; + accflg = 1; /* in case at end of line */ + break; + case EQU: + if( ( att & TEMP) || ((att & VAR) == 0) || (att & STRING) ) + { + errcod = 9; + goto synerr; /* can only assign to a variable */ + } + pvar = (struct varent *)*as; + *pvar->value = acc; + break; + case PLUS: + acc = acc + val; break; + case MINUS: + acc = val - acc; break; + case MULT: + acc = acc * val; break; + case DIV: + if( acc == 0.0L ) + { +/* +divzer: +*/ + errcod = 10; + goto synerr; + } + acc = val / acc; break; +/* + case MOD: + if( acc == 0 ) + goto divzer; + acc = val % acc; break; + case LOR: + acc |= val; break; + case LXOR: + acc ^= val; break; + case LAND: + acc &= val; break; +*/ + case EOE: + if( narptr < 0 ) + { + errcod = 18; + goto synerr; + } + narstk[narptr] += 1; + comstk[comptr++] = acc; +/* printf( "\ncomptr: %d narptr: %d %d\n", comptr, narptr, acc );*/ + acc = val; + break; + } + + +/* expression evaluation, continued */ + +/* Pop evaluated tokens from scan list: */ + /* make temporary variable not busy */ + if( att & TEMP ) + (*as)->attrib &= ~BUSY; + if( as < &ascsym[0] ) /* can this happen? */ + { + errcod = 11; + goto synerr; + } + --as; +nochg: + --ao; + --al; + if( ao < &ascopr[0] ) /* can this happen? */ + { + errcod = 12; + goto synerr; + } +/* If precedence level will now increase, then */ +/* save accumulator in a temporary location */ + if( symval > *al ) + { + /* find a free temp location */ + pvar = &temp[0]; + for( i=0; i<NTEMP; i++ ) + { + if( (pvar->attrib & BUSY) == 0) + goto temfnd; + ++pvar; + } + errcod = 17; + printf( "no more temps\n" ); + pvar = &temp[0]; + goto synerr; + + temfnd: + pvar->attrib |= BUSY; + *pvar->value = acc; + /*printf( "temp %d\n", acc );*/ + accflg = 0; + ++as; /* push the temp onto the scan list */ + *as = (struct symbol *)pvar; + } + } /* End of evaluation loop */ + + +/* Push operator onto scan list when precedence increases */ + +pshopr: + ++ao; + *ao = psym->attrib & 0xf; + ++al; + *al = psym->sym + offset; + goto gettok; + } /* end of OPR processing */ + + +/* Token was not an operator. Push symbol onto scan list. */ +if( (lastok->attrib & OPR) == 0 ) + { + errcod = 13; + goto synerr; /* quantities must be preceded by an operator */ + } +if( (unsigned short )lastok->attrib == (OPR | RPAREN) ) /* ...but not by ) */ + { + errcod = 14; + goto synerr; + } +++as; +*as = psym; +goto gettok; + +synerr: + +#if INTHELP +printf( "%s ", intmsg[errcod] ); +#endif +printf( " error %d\n", errcod ); +abmac(); /* flush the command line */ +goto getcmd; +} /* end of program */ + +/* parser() */ + +/* Get token from input string and identify it. */ + + +static char number[128]; + +struct symbol *parser( ) +{ +register struct symbol *psym; +register char *pline; +struct varent *pvar; +struct strent *pstr; +char *cp, *plc, *pn; +long lnc; +int i; +long double tem; + +/* reference for old Whitesmiths compiler: */ +/* + *extern FILE *stdout; + */ + +pline = interl; /* get current location in command string */ + + +/* If at beginning of string, must ask for more input */ +if( pline == line ) + { + + if( maccnt > 0 ) + { + --maccnt; + cp = maclin; + plc = pline; + while( (*plc++ = *cp++) != 0 ) + ; + goto mstart; + } + if( takptr < 0 ) + { /* no take file active: prompt keyboard input */ + printf("* "); + } +/* Various ways of typing in a command line. */ + +/* + * Old Whitesmiths call to print "*" immediately + * use RT11 .GTLIN to get command string + * from command file or terminal + */ + +/* + * fflush(stdout); + * gtlin(line); + */ + + + zgets( line, TRUE ); /* keyboard input for other systems: */ + + +mstart: + uposs = 1; /* unary operators possible at start of line */ + } + +ignore: +/* Skip over spaces */ +while( *pline == ' ' ) + ++pline; + +/* unary minus after operator */ +if( uposs && (*pline == '-') ) + { + psym = &oprtbl[2]; /* UMINUS */ + ++pline; + goto pdon3; + } + /* COMP */ +/* +if( uposs && (*pline == '~') ) + { + psym = &oprtbl[3]; + ++pline; + goto pdon3; + } +*/ +if( uposs && (*pline == '+') ) /* ignore leading plus sign */ + { + ++pline; + goto ignore; + } + +/* end of null terminated input */ +if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) + { + pline = line; + goto endlin; + } +if( *pline == ';' ) + { + ++pline; +endlin: + psym = &oprtbl[1]; /* EOL */ + goto pdon2; + } + + +/* parser() */ + + +/* Test for numeric input */ +if( (ISDIGIT(*pline)) || (*pline == '.') ) + { + lnc = 0; /* initialize numeric input to zero */ + qnc = 0.0L; + if( *pline == '0' ) + { /* leading "0" may mean octal or hex radix */ + ++pline; + if( *pline == '.' ) + goto decimal; /* 0.ddd */ + /* leading "0x" means hexadecimal radix */ + if( (*pline == 'x') || (*pline == 'X') ) + { + ++pline; + while( ISXDIGIT(*pline) ) + { + i = *pline++ & 0xff; + if( i >= 'a' ) + i -= 047; + if( i >= 'A' ) + i -= 07; + i -= 060; + lnc = (lnc << 4) + i; + qnc = lnc; + } + goto numdon; + } + else + { + while( ISOCTAL( *pline ) ) + { + i = ((*pline++) & 0xff) - 060; + lnc = (lnc << 3) + i; + qnc = lnc; + } + goto numdon; + } + } + else + { + /* no leading "0" means decimal radix */ +/******/ +decimal: + pn = number; + while( (ISDIGIT(*pline)) || (*pline == '.') ) + *pn++ = *pline++; +/* get possible exponent field */ + if( (*pline == 'e') || (*pline == 'E') ) + *pn++ = *pline++; + else + goto numcvt; + if( (*pline == '-') || (*pline == '+') ) + *pn++ = *pline++; + while( ISDIGIT(*pline) ) + *pn++ = *pline++; +numcvt: + *pn++ = ' '; + *pn++ = 0; +#if NE == 6 + asctoe64( number, &qnc ); +#else + asctoe113( number, &qnc ); +#endif +/* sscanf( number, "%le", &nc ); */ + } +/* output the number */ +numdon: + /* search the symbol table of constants */ + pvar = &contbl[0]; + for( i=0; i<NCONST; i++ ) + { + if( (pvar->attrib & BUSY) == 0 ) + goto confnd; + tem = *pvar->value; + if( tem == qnc ) + { + psym = (struct symbol *)pvar; + goto pdon2; + } + ++pvar; + } + printf( "no room for constant\n" ); + psym = (struct symbol *)&contbl[0]; + goto pdon2; + +confnd: + pvar->spel= contbl[0].spel; + pvar->attrib = CONST | BUSY; + *pvar->value = qnc; + psym = (struct symbol *)pvar; + goto pdon2; + } + +/* check for operators */ +psym = &oprtbl[3]; +for( i=0; i<NOPR; i++ ) + { + if( *pline == *(psym->spel) ) + goto pdon1; + ++psym; + } + +/* if quoted, it is a string variable */ +if( *pline == '"' ) + { + /* find an empty slot for the string */ + pstr = strtbl; /* string table */ + for( i=0; i<NSTRNG-1; i++ ) + { + if( (pstr->attrib & BUSY) == 0 ) + goto fndstr; + ++pstr; + } + printf( "No room for string\n" ); + pstr->attrib |= ILLEG; + psym = (struct symbol *)pstr; + goto pdon0; + +fndstr: + pstr->attrib |= BUSY; + plc = pstr->string; + ++pline; + for( i=0; i<39; i++ ) + { + *plc++ = *pline; + if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) + { +illstr: + pstr = &strtbl[NSTRNG-1]; + pstr->attrib |= ILLEG; + printf( "Missing string terminator\n" ); + psym = (struct symbol *)pstr; + goto pdon0; + } + if( *pline++ == '"' ) + goto finstr; + } + + goto illstr; /* no terminator found */ + +finstr: + --plc; + *plc = '\0'; + psym = (struct symbol *)pstr; + goto pdon2; + } +/* If none of the above, search function and symbol tables: */ + +/* copy character string to array lc[] */ +plc = &lc[0]; +while( ISALPHA(*pline) ) + { + /* convert to lower case characters */ + if( ISUPPER( *pline ) ) + *pline += 040; + *plc++ = *pline++; + } +*plc = 0; /* Null terminate the output string */ + +/* parser() */ + +psym = (struct symbol *)menstk[menptr]; /* function table */ +plc = &lc[0]; +cp = psym->spel; +do + { + if( strcmp( plc, cp ) == 0 ) + goto pdon3; /* following unary minus is possible */ + ++psym; + cp = psym->spel; + } +while( *cp != '\0' ); + +psym = (struct symbol *)&indtbl[0]; /* indirect symbol table */ +plc = &lc[0]; +cp = psym->spel; +do + { + if( strcmp( plc, cp ) == 0 ) + goto pdon2; + ++psym; + cp = psym->spel; + } +while( *cp != '\0' ); + +pdon0: +pline = line; /* scrub line if illegal symbol */ +goto pdon2; + +pdon1: +++pline; +if( (psym->attrib & 0xf) == RPAREN ) +pdon2: uposs = 0; +else +pdon3: uposs = 1; + +interl = pline; +return( psym ); +} /* end of parser */ + +/* exit from current menu */ + +long double cmdex() +{ + +if( menptr == 0 ) + { + printf( "Main menu is active.\n" ); + } +else + --menptr; + +cmdh(); +return(0.0L); +} + + +/* gets() */ + +void zgets( gline, echo ) +char *gline; +int echo; +{ +register char *pline; +register int i; + + +scrub: +pline = gline; +getsl: + if( (pline - gline) >= LINLEN ) + { + printf( "\nLine too long\n *" ); + goto scrub; + } + if( takptr < 0 ) + { /* get character from keyboard */ +/* +if DECPDP + gtlin( gline ); + return(0); +else +*/ + *pline = getchar(); +/*endif*/ + } + else + { /* get a character from take file */ + i = fgetc( takstk[takptr] ); + if( i == -1 ) + { /* end of take file */ + if( takptr >= 0 ) + { /* close file and bump take stack */ + fclose( takstk[takptr] ); + takptr -= 1; + } + if( takptr < 0 ) /* no more take files: */ + printf( "*" ); /* prompt keyboard input */ + goto scrub; /* start a new input line */ + } + *pline = i; + } + + *pline &= 0x7f; + /* xon or xoff characters need filtering out. */ + if ( *pline == XON || *pline == XOFF ) + goto getsl; + + /* control U or control C */ + if( (*pline == 025) || (*pline == 03) ) + { + printf( "\n" ); + goto scrub; + } + + /* Backspace or rubout */ + if( (*pline == 010) || (*pline == 0177) ) + { + pline -= 1; + if( pline >= gline ) + { + if ( echo ) + printf( "\010\040\010" ); + goto getsl; + } + else + goto scrub; + } + if ( echo ) + printf( "%c", *pline ); + if( (*pline != '\n') && (*pline != '\r') ) + { + ++pline; + goto getsl; + } + *pline = 0; + if ( echo ) + printf( "%c", '\n' ); /* \r already echoed */ +} + + +/* help function */ +long double cmdhlp() +{ + +printf( "%s", idterp ); +printf( "\nFunctions:\n" ); +prhlst( &funtbl[0] ); +printf( "\nVariables:\n" ); +prhlst( &indtbl[0] ); +printf( "\nOperators:\n" ); +prhlst( &oprtbl[2] ); +printf("\n"); +return(0.0L); +} + + +long double cmdh() +{ + +prhlst( menstk[menptr] ); +printf( "\n" ); +return(0.0L); +} + +/* print keyword spellings */ + +long double prhlst(ps) +register struct symbol *ps; +{ +register int j, k; +int m; + +j = 0; +while( *(ps->spel) != '\0' ) + { + k = strlen( ps->spel ) - 1; +/* size of a tab field is 2**3 chars */ + m = ((k >> 3) + 1) << 3; + j += m; + if( j > 72 ) + { + printf( "\n" ); + j = m; + } + printf( "%s\t", ps->spel ); + ++ps; + } +return(0.0L); +} + + +#if SALONE +void init(){} +#endif + + +/* macro commands */ + +/* define macro */ +long double cmddm() +{ + +zgets( maclin, TRUE ); +return(0.0L); +} + +/* type (i.e., display) macro */ +long double cmdtm() +{ + +printf( "%s\n", maclin ); +return(0.0L); +} + +/* execute macro # times */ +long double cmdem( arg ) +long double arg; +{ +long double f; +long n; +long double floorl(); + +f = floorl(arg); +n = f; +if( n <= 0 ) + n = 1; +maccnt = n; +return(0.0L); +} + + +/* open a take file */ + +long double take( fname ) +char *fname; +{ +FILE *f; + +while( *fname == ' ' ) + fname += 1; +f = fopen( fname, "r" ); + +if( f == 0 ) + { + printf( "Can't open take file %s\n", fname ); + takptr = -1; /* terminate all take file input */ + return(0.0L); + } +takptr += 1; +takstk[ takptr ] = f; +printf( "Running %s\n", fname ); +return(0.0L); +} + + +/* abort macro execution */ +long double abmac() +{ + +maccnt = 0; +interl = line; +return(0.0L); +} + + +/* display integer part in hex, octal, and decimal + */ +long double hex(qx) +long double qx; +{ +long double f; +long z; +long double floorl(); + +f = floorl(qx); +z = f; +printf( "0%lo 0x%lx %ld.\n", z, z, z ); +return(qx); +} + +#define NASC 16 + +long double bits( x ) +long double x; +{ +int i, j; +unsigned short dd[4], ee[10]; +char strx[40]; +unsigned short *p; + +p = (unsigned short *) &x; +for( i=0; i<NE; i++ ) + ee[i] = *p++; + +j = 0; +for( i=0; i<NE; i++ ) + { + printf( "0x%04x,", ee[i] & 0xffff ); + if( ++j > 7 ) + { + j = 0; + printf( "\n" ); + } + } +printf( "\n" ); + +/* double conversions + */ +*((double *)dd) = x; +printf( "double: " ); +for( i=0; i<4; i++ ) + printf( "0x%04x,", dd[i] & 0xffff ); +printf( "\n" ); + +#if 1 +printf( "double -> long double: " ); +*(long double *)ee = *(double *)dd; +for( i=0; i<6; i++ ) + printf( "0x%04x,", ee[i] & 0xffff ); +printf( "\n" ); +e53toasc( dd, strx, NASC ); +printf( "e53toasc: %s\n", strx ); +printf( "Native printf: %.17e\n", *(double *)dd ); + +/* float conversions + */ +*((float *)dd) = x; +printf( "float: " ); +for( i=0; i<2; i++ ) + printf( "0x%04x,", dd[i] & 0xffff ); +printf( "\n" ); +e24toe( dd, ee ); +printf( "e24toe: " ); +for( i=0; i<NE; i++ ) + printf( "0x%04x,", ee[i] & 0xffff ); +printf( "\n" ); +e24toasc( dd, strx, NASC ); +printf( "e24toasc: %s\n", strx ); +/* printf( "Native printf: %.16e\n", (double) *(float *)dd ); */ + +#ifdef DEC +printf( "etodec: " ); +etodec( x, dd ); +for( i=0; i<4; i++ ) + printf( "0x%04x,", dd[i] & 0xffff ); +printf( "\n" ); +printf( "dectoe: " ); +dectoe( dd, ee ); +for( i=0; i<NE; i++ ) + printf( "0x%04x,", ee[i] & 0xffff ); +printf( "\n" ); +printf( "DEC printf: %.16e\n", *(double *)dd ); +#endif +#endif /* 0 */ +return(x); +} + + +/* Exit to monitor. */ +long double mxit() +{ + +exit(0); +return(0.0L); +} + + +long double cmddig( x ) +long double x; +{ +long double f; +long lx; + +f = floorl(x); +lx = f; +ndigits = lx; +if( ndigits <= 0 ) + ndigits = DEFDIS; +return(f); +} + + +long double csys(x) +char *x; +{ +void system(); + +system( x+1 ); +cmdh(); +return(0.0L); +} + + +long double ifrac(x) +long double x; +{ +unsigned long lx; +long double y, z; + +z = floorl(x); +lx = z; +y = x - z; +printf( " int = %lx\n", lx ); +return(y); +} + +long double xcmpl(x,y) +long double x,y; +{ +long double ans; +char str[40]; + +#if NE == 6 + e64toasc( &x, str, 100 ); + printf( "x = %s\n", str ); + e64toasc( &y, str, 100 ); + printf( "y = %s\n", str ); +#else + e113toasc( &x, str, 100 ); + printf( "x = %s\n", str ); + e113toasc( &y, str, 100 ); + printf( "y = %s\n", str ); +#endif + +ans = -2.0; +if( x == y ) + { + printf( "x == y " ); + ans = 0.0; + } +if( x < y ) + { + printf( "x < y" ); + ans = -1.0; + } +if( x > y ) + { + printf( "x > y" ); + ans = 1.0; + } +return( ans ); +} + +long double zstdtrl(k,t) +long double k, t; +{ +int ki; +long double y; +ki = k; +y = stdtrl(ki,t); +return(y); +} + +long double zstdtril(k,t) +long double k, t; +{ +int ki; +long double y; +ki = k; +y = stdtril(ki,t); +return(y); +} + +#ifdef NANS +long double zisnan(x) +long double x; +{ + long double y; + int k; + k = isnanl(x); + y = k; + return(y); +} +long double zisfinite(x) +long double x; +{ + long double y; + int k; + k = isfinitel(x); + y = k; + return(y); +} +long double zsignbit(x) +long double x; +{ + long double y; + int k; + k = signbitl(x); + y = k; + return(y); +} +#endif diff --git a/libm/ldouble/lcalc.h b/libm/ldouble/lcalc.h new file mode 100644 index 000000000..7be51d79e --- /dev/null +++ b/libm/ldouble/lcalc.h @@ -0,0 +1,79 @@ +/* calc.h + * include file for calc.c + */ + +/* 32 bit memory addresses: */ +#ifndef LARGEMEM +#define LARGEMEM 1 +#endif + +/* data structure of symbol table */ +struct symbol + { + char *spel; + short attrib; +#if LARGEMEM + long sym; +#else + short sym; +#endif + }; + +struct funent + { + char *spel; + short attrib; + long double (*fun )(); + }; + +struct varent + { + char *spel; + short attrib; + long double *value; + }; + +struct strent + { + char *spel; + short attrib; + char *string; + }; + + +/* general symbol attributes: */ +#define OPR 0x8000 +#define VAR 0x4000 +#define CONST 0x2000 +#define FUNC 0x1000 +#define ILLEG 0x800 +#define BUSY 0x400 +#define TEMP 0x200 +#define STRING 0x100 +#define COMMAN 0x80 +#define IND 0x1 + +/* attributes of operators (ordered by precedence): */ +#define BOL 1 +#define EOL 2 +/* end of expression (comma): */ +#define EOE 3 +#define EQU 4 +#define PLUS 5 +#define MINUS 6 +#define MULT 7 +#define DIV 8 +#define UMINUS 9 +#define LPAREN 10 +#define RPAREN 11 +#define COMP 12 +#define MOD 13 +#define LAND 14 +#define LOR 15 +#define LXOR 16 + + +extern struct funent funtbl[]; +/*extern struct symbol symtbl[];*/ +extern struct varent indtbl[]; + diff --git a/libm/ldouble/ldrand.c b/libm/ldouble/ldrand.c new file mode 100644 index 000000000..892b465df --- /dev/null +++ b/libm/ldouble/ldrand.c @@ -0,0 +1,175 @@ +/* ldrand.c + * + * Pseudorandom number generator + * + * + * + * SYNOPSIS: + * + * double y; + * int ldrand(); + * + * ldrand( &y ); + * + * + * + * DESCRIPTION: + * + * Yields a random number 1.0 <= y < 2.0. + * + * The three-generator congruential algorithm by Brian + * Wichmann and David Hill (BYTE magazine, March, 1987, + * pp 127-8) is used. + * + * Versions invoked by the different arithmetic compile + * time options IBMPC, and MIEEE, produce the same sequences. + * + */ + + + +#include <math.h> +#ifdef ANSIPROT +int ranwh ( void ); +#else +int ranwh(); +#endif +#ifdef UNK +#undef UNK +#if BIGENDIAN +#define MIEEE +#else +#define IBMPC +#endif +#endif + +/* Three-generator random number algorithm + * of Brian Wichmann and David Hill + * BYTE magazine, March, 1987 pp 127-8 + * + * The period, given by them, is (p-1)(q-1)(r-1)/4 = 6.95e12. + */ + +static int sx = 1; +static int sy = 10000; +static int sz = 3000; + +static union { + long double d; + unsigned short s[8]; +} unkans; + +/* This function implements the three + * congruential generators. + */ + +int ranwh() +{ +int r, s; + +/* sx = sx * 171 mod 30269 */ +r = sx/177; +s = sx - 177 * r; +sx = 171 * s - 2 * r; +if( sx < 0 ) + sx += 30269; + + +/* sy = sy * 172 mod 30307 */ +r = sy/176; +s = sy - 176 * r; +sy = 172 * s - 35 * r; +if( sy < 0 ) + sy += 30307; + +/* sz = 170 * sz mod 30323 */ +r = sz/178; +s = sz - 178 * r; +sz = 170 * s - 63 * r; +if( sz < 0 ) + sz += 30323; +/* The results are in static sx, sy, sz. */ +return 0; +} + +/* ldrand.c + * + * Random double precision floating point number between 1 and 2. + * + * C callable: + * drand( &x ); + */ + +int ldrand( a ) +long double *a; +{ +unsigned short r; + +/* This algorithm of Wichmann and Hill computes a floating point + * result: + */ +ranwh(); +unkans.d = sx/30269.0L + sy/30307.0L + sz/30323.0L; +r = unkans.d; +unkans.d -= r; +unkans.d += 1.0L; + +if( sizeof(long double) == 16 ) + { +#ifdef MIEEE + ranwh(); + r = sx * sy + sz; + unkans.s[7] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[6] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[5] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[4] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[3] = r; +#endif +#ifdef IBMPC + ranwh(); + r = sx * sy + sz; + unkans.s[0] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[1] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[2] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[3] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[4] = r; +#endif + } +else + { +#ifdef MIEEE + ranwh(); + r = sx * sy + sz; + unkans.s[5] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[4] = r; +#endif +#ifdef IBMPC + ranwh(); + r = sx * sy + sz; + unkans.s[0] = r; + ranwh(); + r = sx * sy + sz; + unkans.s[1] = r; +#endif + } +*a = unkans.d; +return 0; +} diff --git a/libm/ldouble/log10l.c b/libm/ldouble/log10l.c new file mode 100644 index 000000000..fa13ff3a2 --- /dev/null +++ b/libm/ldouble/log10l.c @@ -0,0 +1,319 @@ +/* log10l.c + * + * Common logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, log10l(); + * + * y = log10l( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base 10 logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the logarithm + * of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 9.0e-20 2.6e-20 + * IEEE exp(+-10000) 30000 6.0e-20 2.3e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOG + * log domain: x < 0; returns MINLOG + */ + +/* +Cephes Math Library Release 2.2: January, 1991 +Copyright 1984, 1991 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +static char fname[] = {"log10l"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 6.2e-22 + */ +#ifdef UNK +static long double P[] = { + 4.9962495940332550844739E-1L, + 1.0767376367209449010438E1L, + 7.7671073698359539859595E1L, + 2.5620629828144409632571E2L, + 4.2401812743503691187826E2L, + 3.4258224542413922935104E2L, + 1.0747524399916215149070E2L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0,*/ + 2.3479774160285863271658E1L, + 1.9444210022760132894510E2L, + 7.7952888181207260646090E2L, + 1.6911722418503949084863E3L, + 2.0307734695595183428202E3L, + 1.2695660352705325274404E3L, + 3.2242573199748645407652E2L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0xfe72,0xce22,0xd7b9,0xffce,0x3ffd, XPD +0xb778,0x0e34,0x2c71,0xac47,0x4002, XPD +0xea8b,0xc751,0x96f8,0x9b57,0x4005, XPD +0xfeaf,0x6a02,0x67fb,0x801a,0x4007, XPD +0x6b5a,0xf252,0x51ff,0xd402,0x4007, XPD +0x39ce,0x9f76,0x8704,0xab4a,0x4007, XPD +0x1b39,0x740b,0x532e,0xd6f3,0x4005, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x2f3a,0xbf26,0x93d5,0xbbd6,0x4003, XPD +0x13c8,0x031a,0x2d7b,0xc271,0x4006, XPD +0x449d,0x1993,0xd933,0xc2e1,0x4008, XPD +0x5b65,0x574e,0x8301,0xd365,0x4009, XPD +0xa65d,0x3bd2,0xc043,0xfdd8,0x4009, XPD +0x3b21,0xffea,0x1cf5,0x9eb2,0x4009, XPD +0x545c,0xd708,0x7e62,0xa136,0x4007, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3ffd0000,0xffced7b9,0xce22fe72, +0x40020000,0xac472c71,0x0e34b778, +0x40050000,0x9b5796f8,0xc751ea8b, +0x40070000,0x801a67fb,0x6a02feaf, +0x40070000,0xd40251ff,0xf2526b5a, +0x40070000,0xab4a8704,0x9f7639ce, +0x40050000,0xd6f3532e,0x740b1b39, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40030000,0xbbd693d5,0xbf262f3a, +0x40060000,0xc2712d7b,0x031a13c8, +0x40080000,0xc2e1d933,0x1993449d, +0x40090000,0xd3658301,0x574e5b65, +0x40090000,0xfdd8c043,0x3bd2a65d, +0x40090000,0x9eb21cf5,0xffea3b21, +0x40070000,0xa1367e62,0xd708545c, +}; +#endif + +/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), + * where z = 2(x-1)/(x+1) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 6.16e-22 + */ + +#ifdef UNK +static long double R[4] = { + 1.9757429581415468984296E-3L, +-7.1990767473014147232598E-1L, + 1.0777257190312272158094E1L, +-3.5717684488096787370998E1L, +}; +static long double S[4] = { +/* 1.00000000000000000000E0L,*/ +-2.6201045551331104417768E1L, + 1.9361891836232102174846E2L, +-4.2861221385716144629696E2L, +}; +/* log10(2) */ +#define L102A 0.3125L +#define L102B -1.1470004336018804786261e-2L +/* log10(e) */ +#define L10EA 0.5L +#define L10EB -6.5705518096748172348871e-2L +#endif +#ifdef IBMPC +static short R[] = { +0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD +0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD +0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD +0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD +}; +static short S[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD +0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD +0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD +}; +static short LG102A[] = {0x0000,0x0000,0x0000,0xa000,0x3ffd, XPD}; +#define L102A *(long double *)LG102A +static short LG102B[] = {0x0cee,0x8601,0xaf60,0xbbec,0xbff8, XPD}; +#define L102B *(long double *)LG102B +static short LG10EA[] = {0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD}; +#define L10EA *(long double *)LG10EA +static short LG10EB[] = {0x39ab,0x235e,0x9d5b,0x8690,0xbffb, XPD}; +#define L10EB *(long double *)LG10EB +#endif + +#ifdef MIEEE +static long R[12] = { +0x3ff60000,0x817b7763,0xf9226ef4, +0xbffe0000,0xb84bde8f,0x1af915fd, +0x40020000,0xac6fa53c,0x4f8d8b96, +0xc0040000,0x8edee8ae,0xb4e38932, +}; +static long S[9] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0030000,0xd19bbdc5,0x1fc97ce4, +0x40060000,0xc19e716f,0x0d100af3, +0xc0070000,0xd64e5d06,0x0f554d7d, +}; +static long LG102A[] = {0x3ffd0000,0xa0000000,0x00000000}; +#define L102A *(long double *)LG102A +static long LG102B[] = {0xbff80000,0xbbecaf60,0x86010cee}; +#define L102B *(long double *)LG102B +static long LG10EA[] = {0x3ffe0000,0x80000000,0x00000000}; +#define L10EA *(long double *)LG10EA +static long LG10EB[] = {0xbffb0000,0x86909d5b,0x235e39ab}; +#define L10EB *(long double *)LG10EB +#endif + + +#define SQRTH 0.70710678118654752440L +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +#else +long double frexpl(), ldexpl(), polevll(), p1evll(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double log10l(x) +long double x; +{ +long double y; +VOLATILE long double z; +int e; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0L ) + { + if( x == 0.0L ) + { + mtherr( fname, SING ); +#ifdef INFINITIES + return(-INFINITYL); +#else + return( -4.9314733889673399399914e3L ); +#endif + } + else + { + mtherr( fname, DOMAIN ); +#ifdef NANS + return(NANL); +#else + return( -4.9314733889673399399914e3L ); +#endif + } + } +#ifdef INFINITIES +if( x == INFINITYL ) + return(INFINITYL); +#endif +/* separate mantissa from exponent */ + +/* Note, frexp is used so that denormal numbers + * will be handled properly. + */ +x = frexpl( x, &e ); + + +/* logarithm using log(x) = z + z**3 P(z)/Q(z), + * where z = 2(x-1)/x+1) + */ +if( (e > 2) || (e < -2) ) +{ +if( x < SQRTH ) + { /* 2( 2x-1 )/( 2x+1 ) */ + e -= 1; + z = x - 0.5L; + y = 0.5L * z + 0.5L; + } +else + { /* 2 (x-1)/(x+1) */ + z = x - 0.5L; + z -= 0.5L; + y = 0.5L * x + 0.5L; + } +x = z / y; +z = x*x; +y = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); +goto done; +} + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ + } +else + { + x = x - 1.0L; + } +z = x*x; +y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 7 ) ); +y = y - ldexpl( z, -1 ); /* -0.5x^2 + ... */ + +done: + +/* Multiply log of fraction by log10(e) + * and base 2 exponent by log10(2). + * + * ***CAUTION*** + * + * This sequence of operations is critical and it may + * be horribly defeated by some compiler optimizers. + */ +z = y * (L10EB); +z += x * (L10EB); +z += e * (L102B); +z += y * (L10EA); +z += x * (L10EA); +z += e * (L102A); + +return( z ); +} diff --git a/libm/ldouble/log2l.c b/libm/ldouble/log2l.c new file mode 100644 index 000000000..220b881ae --- /dev/null +++ b/libm/ldouble/log2l.c @@ -0,0 +1,302 @@ +/* log2l.c + * + * Base 2 logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, log2l(); + * + * y = log2l( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base 2 logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the (natural) + * logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 9.8e-20 2.7e-20 + * IEEE exp(+-10000) 70000 5.4e-20 2.3e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns -INFINITYL + * log domain: x < 0; returns NANL + */ + +/* +Cephes Math Library Release 2.8: May, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Coefficients for ln(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 6.2e-22 + */ +#ifdef UNK +static long double P[] = { + 4.9962495940332550844739E-1L, + 1.0767376367209449010438E1L, + 7.7671073698359539859595E1L, + 2.5620629828144409632571E2L, + 4.2401812743503691187826E2L, + 3.4258224542413922935104E2L, + 1.0747524399916215149070E2L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0,*/ + 2.3479774160285863271658E1L, + 1.9444210022760132894510E2L, + 7.7952888181207260646090E2L, + 1.6911722418503949084863E3L, + 2.0307734695595183428202E3L, + 1.2695660352705325274404E3L, + 3.2242573199748645407652E2L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0xfe72,0xce22,0xd7b9,0xffce,0x3ffd, XPD +0xb778,0x0e34,0x2c71,0xac47,0x4002, XPD +0xea8b,0xc751,0x96f8,0x9b57,0x4005, XPD +0xfeaf,0x6a02,0x67fb,0x801a,0x4007, XPD +0x6b5a,0xf252,0x51ff,0xd402,0x4007, XPD +0x39ce,0x9f76,0x8704,0xab4a,0x4007, XPD +0x1b39,0x740b,0x532e,0xd6f3,0x4005, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x2f3a,0xbf26,0x93d5,0xbbd6,0x4003, XPD +0x13c8,0x031a,0x2d7b,0xc271,0x4006, XPD +0x449d,0x1993,0xd933,0xc2e1,0x4008, XPD +0x5b65,0x574e,0x8301,0xd365,0x4009, XPD +0xa65d,0x3bd2,0xc043,0xfdd8,0x4009, XPD +0x3b21,0xffea,0x1cf5,0x9eb2,0x4009, XPD +0x545c,0xd708,0x7e62,0xa136,0x4007, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3ffd0000,0xffced7b9,0xce22fe72, +0x40020000,0xac472c71,0x0e34b778, +0x40050000,0x9b5796f8,0xc751ea8b, +0x40070000,0x801a67fb,0x6a02feaf, +0x40070000,0xd40251ff,0xf2526b5a, +0x40070000,0xab4a8704,0x9f7639ce, +0x40050000,0xd6f3532e,0x740b1b39, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40030000,0xbbd693d5,0xbf262f3a, +0x40060000,0xc2712d7b,0x031a13c8, +0x40080000,0xc2e1d933,0x1993449d, +0x40090000,0xd3658301,0x574e5b65, +0x40090000,0xfdd8c043,0x3bd2a65d, +0x40090000,0x9eb21cf5,0xffea3b21, +0x40070000,0xa1367e62,0xd708545c, +}; +#endif + +/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), + * where z = 2(x-1)/(x+1) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 6.16e-22 + */ +#ifdef UNK +static long double R[4] = { + 1.9757429581415468984296E-3L, +-7.1990767473014147232598E-1L, + 1.0777257190312272158094E1L, +-3.5717684488096787370998E1L, +}; +static long double S[4] = { +/* 1.00000000000000000000E0L,*/ +-2.6201045551331104417768E1L, + 1.9361891836232102174846E2L, +-4.2861221385716144629696E2L, +}; +/* log2(e) - 1 */ +#define LOG2EA 4.4269504088896340735992e-1L +#endif +#ifdef IBMPC +static short R[] = { +0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD +0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD +0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD +0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD +}; +static short S[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD +0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD +0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD +}; +static short LG2EA[] = {0xc2ef,0x705f,0xeca5,0xe2a8,0x3ffd, XPD}; +#define LOG2EA *(long double *)LG2EA +#endif + +#ifdef MIEEE +static long R[12] = { +0x3ff60000,0x817b7763,0xf9226ef4, +0xbffe0000,0xb84bde8f,0x1af915fd, +0x40020000,0xac6fa53c,0x4f8d8b96, +0xc0040000,0x8edee8ae,0xb4e38932, +}; +static long S[9] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0030000,0xd19bbdc5,0x1fc97ce4, +0x40060000,0xc19e716f,0x0d100af3, +0xc0070000,0xd64e5d06,0x0f554d7d, +}; +static long LG2EA[] = {0x3ffd0000,0xe2a8eca5,0x705fc2ef}; +#define LOG2EA *(long double *)LG2EA +#endif + + +#define SQRTH 0.70710678118654752440L +extern long double MINLOGL; +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +#else +long double frexpl(), ldexpl(), polevll(), p1evll(); +extern int isnanl (); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double log2l(x) +long double x; +{ +VOLATILE long double z; +long double y; +int e; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITYL ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0L ) + { + if( x == 0.0L ) + { +#ifdef INFINITIES + return( -INFINITYL ); +#else + mtherr( "log2l", SING ); + return( -16384.0L ); +#endif + } + else + { +#ifdef NANS + return( NANL ); +#else + mtherr( "log2l", DOMAIN ); + return( -16384.0L ); +#endif + } + } + +/* separate mantissa from exponent */ + +/* Note, frexp is used so that denormal numbers + * will be handled properly. + */ +x = frexpl( x, &e ); + + +/* logarithm using log(x) = z + z**3 P(z)/Q(z), + * where z = 2(x-1)/x+1) + */ +if( (e > 2) || (e < -2) ) +{ +if( x < SQRTH ) + { /* 2( 2x-1 )/( 2x+1 ) */ + e -= 1; + z = x - 0.5L; + y = 0.5L * z + 0.5L; + } +else + { /* 2 (x-1)/(x+1) */ + z = x - 0.5L; + z -= 0.5L; + y = 0.5L * x + 0.5L; + } +x = z / y; +z = x*x; +y = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); +goto done; +} + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ + } +else + { + x = x - 1.0L; + } +z = x*x; +y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 7 ) ); +y = y - ldexpl( z, -1 ); /* -0.5x^2 + ... */ + +done: + +/* Multiply log of fraction by log2(e) + * and base 2 exponent by 1 + * + * ***CAUTION*** + * + * This sequence of operations is critical and it may + * be horribly defeated by some compiler optimizers. + */ +z = y * LOG2EA; +z += x * LOG2EA; +z += y; +z += x; +z += e; +return( z ); +} + diff --git a/libm/ldouble/logl.c b/libm/ldouble/logl.c new file mode 100644 index 000000000..d6367eb19 --- /dev/null +++ b/libm/ldouble/logl.c @@ -0,0 +1,292 @@ +/* logl.c + * + * Natural logarithm, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, logl(); + * + * y = logl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the base e (2.718...) logarithm of x. + * + * The argument is separated into its exponent and fractional + * parts. If the exponent is between -1 and +1, the logarithm + * of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * Otherwise, setting z = 2(x-1)/x+1), + * + * log(x) = z + z**3 P(z)/Q(z). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 150000 8.71e-20 2.75e-20 + * IEEE exp(+-10000) 100000 5.39e-20 2.34e-20 + * + * In the tests over the interval exp(+-10000), the logarithms + * of the random arguments were uniformly distributed over + * [-10000, +10000]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns -INFINITYL + * log domain: x < 0; returns NANL + */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1990, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 2.32e-20 + */ +#ifdef UNK +static long double P[] = { + 4.5270000862445199635215E-5L, + 4.9854102823193375972212E-1L, + 6.5787325942061044846969E0L, + 2.9911919328553073277375E1L, + 6.0949667980987787057556E1L, + 5.7112963590585538103336E1L, + 2.0039553499201281259648E1L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0,*/ + 1.5062909083469192043167E1L, + 8.3047565967967209469434E1L, + 2.2176239823732856465394E2L, + 3.0909872225312059774938E2L, + 2.1642788614495947685003E2L, + 6.0118660497603843919306E1L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0x51b9,0x9cae,0x4b15,0xbde0,0x3ff0, XPD +0x19cf,0xf0d4,0xc507,0xff40,0x3ffd, XPD +0x9942,0xa7d2,0xfa37,0xd284,0x4001, XPD +0x4add,0x65ce,0x9c5c,0xef4b,0x4003, XPD +0x8445,0x619a,0x75c3,0xf3cc,0x4004, XPD +0x81ab,0x3cd0,0xacba,0xe473,0x4004, XPD +0x4cbf,0xcc18,0x016c,0xa051,0x4003, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0xb8b7,0x81f1,0xacf4,0xf101,0x4002, XPD +0xbc31,0x09a4,0x5a91,0xa618,0x4005, XPD +0xaeec,0xe7da,0x2c87,0xddc3,0x4006, XPD +0x2bde,0x4845,0xa2ee,0x9a8c,0x4007, XPD +0x3120,0x4703,0x89f2,0xd86d,0x4006, XPD +0x7347,0x3224,0x8223,0xf079,0x4004, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3ff00000,0xbde04b15,0x9cae51b9, +0x3ffd0000,0xff40c507,0xf0d419cf, +0x40010000,0xd284fa37,0xa7d29942, +0x40030000,0xef4b9c5c,0x65ce4add, +0x40040000,0xf3cc75c3,0x619a8445, +0x40040000,0xe473acba,0x3cd081ab, +0x40030000,0xa051016c,0xcc184cbf, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40020000,0xf101acf4,0x81f1b8b7, +0x40050000,0xa6185a91,0x09a4bc31, +0x40060000,0xddc32c87,0xe7daaeec, +0x40070000,0x9a8ca2ee,0x48452bde, +0x40060000,0xd86d89f2,0x47033120, +0x40040000,0xf0798223,0x32247347, +}; +#endif + +/* Coefficients for log(x) = z + z^3 P(z^2)/Q(z^2), + * where z = 2(x-1)/(x+1) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 6.16e-22 + */ + +#ifdef UNK +static long double R[4] = { + 1.9757429581415468984296E-3L, +-7.1990767473014147232598E-1L, + 1.0777257190312272158094E1L, +-3.5717684488096787370998E1L, +}; +static long double S[4] = { +/* 1.00000000000000000000E0L,*/ +-2.6201045551331104417768E1L, + 1.9361891836232102174846E2L, +-4.2861221385716144629696E2L, +}; +static long double C1 = 6.9314575195312500000000E-1L; +static long double C2 = 1.4286068203094172321215E-6L; +#endif +#ifdef IBMPC +static short R[] = { +0x6ef4,0xf922,0x7763,0x817b,0x3ff6, XPD +0x15fd,0x1af9,0xde8f,0xb84b,0xbffe, XPD +0x8b96,0x4f8d,0xa53c,0xac6f,0x4002, XPD +0x8932,0xb4e3,0xe8ae,0x8ede,0xc004, XPD +}; +static short S[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x7ce4,0x1fc9,0xbdc5,0xd19b,0xc003, XPD +0x0af3,0x0d10,0x716f,0xc19e,0x4006, XPD +0x4d7d,0x0f55,0x5d06,0xd64e,0xc007, XPD +}; +static short sc1[] = {0x0000,0x0000,0x0000,0xb172,0x3ffe, XPD}; +#define C1 (*(long double *)sc1) +static short sc2[] = {0x4f1e,0xcd5e,0x8e7b,0xbfbe,0x3feb, XPD}; +#define C2 (*(long double *)sc2) +#endif +#ifdef MIEEE +static long R[12] = { +0x3ff60000,0x817b7763,0xf9226ef4, +0xbffe0000,0xb84bde8f,0x1af915fd, +0x40020000,0xac6fa53c,0x4f8d8b96, +0xc0040000,0x8edee8ae,0xb4e38932, +}; +static long S[9] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0xc0030000,0xd19bbdc5,0x1fc97ce4, +0x40060000,0xc19e716f,0x0d100af3, +0xc0070000,0xd64e5d06,0x0f554d7d, +}; +static long sc1[] = {0x3ffe0000,0xb1720000,0x00000000}; +#define C1 (*(long double *)sc1) +static long sc2[] = {0x3feb0000,0xbfbe8e7b,0xcd5e4f1e}; +#define C2 (*(long double *)sc2) +#endif + + +#define SQRTH 0.70710678118654752440L +extern long double MINLOGL; +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern int isnanl ( long double ); +#else +long double frexpl(), ldexpl(), polevll(), p1evll(), isnanl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double logl(x) +long double x; +{ +long double y, z; +int e; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITYL ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0L ) + { + if( x == 0.0L ) + { +#ifdef INFINITIES + return( -INFINITYL ); +#else + mtherr( "logl", SING ); + return( MINLOGL ); +#endif + } + else + { +#ifdef NANS + return( NANL ); +#else + mtherr( "logl", DOMAIN ); + return( MINLOGL ); +#endif + } + } + +/* separate mantissa from exponent */ + +/* Note, frexp is used so that denormal numbers + * will be handled properly. + */ +x = frexpl( x, &e ); + +/* logarithm using log(x) = z + z**3 P(z)/Q(z), + * where z = 2(x-1)/x+1) + */ +if( (e > 2) || (e < -2) ) +{ +if( x < SQRTH ) + { /* 2( 2x-1 )/( 2x+1 ) */ + e -= 1; + z = x - 0.5L; + y = 0.5L * z + 0.5L; + } +else + { /* 2 (x-1)/(x+1) */ + z = x - 0.5L; + z -= 0.5L; + y = 0.5L * x + 0.5L; + } +x = z / y; +z = x*x; +z = x * ( z * polevll( z, R, 3 ) / p1evll( z, S, 3 ) ); +z = z + e * C2; +z = z + x; +z = z + e * C1; +return( z ); +} + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexpl( x, 1 ) - 1.0L; /* 2x - 1 */ + } +else + { + x = x - 1.0L; + } +z = x*x; +y = x * ( z * polevll( x, P, 6 ) / p1evll( x, Q, 6 ) ); +y = y + e * C2; +z = y - ldexpl( z, -1 ); /* y - 0.5 * z */ +/* Note, the sum of above terms does not exceed x/4, + * so it contributes at most about 1/4 lsb to the error. + */ +z = z + x; +z = z + e * C1; /* This sum has an error of 1/2 lsb. */ +return( z ); +} diff --git a/libm/ldouble/lparanoi.c b/libm/ldouble/lparanoi.c new file mode 100644 index 000000000..eb8fd25c7 --- /dev/null +++ b/libm/ldouble/lparanoi.c @@ -0,0 +1,2348 @@ +/* A C version of Kahan's Floating Point Test "Paranoia" + + Thos Sumner, UCSF, Feb. 1985 + David Gay, BTL, Jan. 1986 + + This is a rewrite from the Pascal version by + + B. A. Wichmann, 18 Jan. 1985 + + (and does NOT exhibit good C programming style). + +(C) Apr 19 1983 in BASIC version by: + Professor W. M. Kahan, + 567 Evans Hall + Electrical Engineering & Computer Science Dept. + University of California + Berkeley, California 94720 + USA + +converted to Pascal by: + B. A. Wichmann + National Physical Laboratory + Teddington Middx + TW11 OLW + UK + +converted to C by: + + David M. Gay and Thos Sumner + AT&T Bell Labs Computer Center, Rm. U-76 + 600 Mountainn Avenue University of California + Murray Hill, NJ 07974 San Francisco, CA 94143 + USA USA + +with simultaneous corrections to the Pascal source (reflected +in the Pascal source available over netlib). + +Reports of results on various systems from all the versions +of Paranoia are being collected by Richard Karpinski at the +same address as Thos Sumner. This includes sample outputs, +bug reports, and criticisms. + +You may copy this program freely if you acknowledge its source. +Comments on the Pascal version to NPL, please. + + +The C version catches signals from floating-point exceptions. +If signal(SIGFPE,...) is unavailable in your environment, you may +#define NOSIGNAL to comment out the invocations of signal. + +This source file is too big for some C compilers, but may be split +into pieces. Comments containing "SPLIT" suggest convenient places +for this splitting. At the end of these comments is an "ed script" +(for the UNIX(tm) editor ed) that will do this splitting. + +By #defining Single when you compile this source, you may obtain +a single-precision C version of Paranoia. + + +The following is from the introductory commentary from Wichmann's work: + +The BASIC program of Kahan is written in Microsoft BASIC using many +facilities which have no exact analogy in Pascal. The Pascal +version below cannot therefore be exactly the same. Rather than be +a minimal transcription of the BASIC program, the Pascal coding +follows the conventional style of block-structured languages. Hence +the Pascal version could be useful in producing versions in other +structured languages. + +Rather than use identifiers of minimal length (which therefore have +little mnemonic significance), the Pascal version uses meaningful +identifiers as follows [Note: A few changes have been made for C]: + + +BASIC C BASIC C BASIC C + + A J S StickyBit + A1 AInverse J0 NoErrors T + B Radix [Failure] T0 Underflow + B1 BInverse J1 NoErrors T2 ThirtyTwo + B2 RadixD2 [SeriousDefect] T5 OneAndHalf + B9 BMinusU2 J2 NoErrors T7 TwentySeven + C [Defect] T8 TwoForty + C1 CInverse J3 NoErrors U OneUlp + D [Flaw] U0 UnderflowThreshold + D4 FourD K PageNo U1 + E0 L Milestone U2 + E1 M V + E2 Exp2 N V0 + E3 N1 V8 + E5 MinSqEr O Zero V9 + E6 SqEr O1 One W + E7 MaxSqEr O2 Two X + E8 O3 Three X1 + E9 O4 Four X8 + F1 MinusOne O5 Five X9 Random1 + F2 Half O8 Eight Y + F3 Third O9 Nine Y1 + F6 P Precision Y2 + F9 Q Y9 Random2 + G1 GMult Q8 Z + G2 GDiv Q9 Z0 PseudoZero + G3 GAddSub R Z1 + H R1 RMult Z2 + H1 HInverse R2 RDiv Z9 + I R3 RAddSub + IO NoTrials R4 RSqrt + I3 IEEE R9 Random9 + + SqRWrng + +All the variables in BASIC are true variables and in consequence, +the program is more difficult to follow since the "constants" must +be determined (the glossary is very helpful). The Pascal version +uses Real constants, but checks are added to ensure that the values +are correctly converted by the compiler. + +The major textual change to the Pascal version apart from the +identifiersis that named procedures are used, inserting parameters +wherehelpful. New procedures are also introduced. The +correspondence is as follows: + + +BASIC Pascal +lines + + 90- 140 Pause + 170- 250 Instructions + 380- 460 Heading + 480- 670 Characteristics + 690- 870 History +2940-2950 Random +3710-3740 NewD +4040-4080 DoesYequalX +4090-4110 PrintIfNPositive +4640-4850 TestPartialUnderflow + +=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*= + +Below is an "ed script" that splits para.c into 10 files +of the form part[1-8].c, subs.c, and msgs.c, plus a header +file, paranoia.h, that these files require. +r paranoia.c +$ +?SPLIT ++,$w msgs.c +.,$d +?SPLIT +.d ++d +-,$w subs.c +-,$d +?part8 ++d +?include +.,$w part8.c +.,$d +-d +?part7 ++d +?include +.,$w part7.c +.,$d +-d +?part6 ++d +?include +.,$w part6.c +.,$d +-d +?part5 ++d +?include +.,$w part5.c +.,$d +-d +?part4 ++d +?include +.,$w part4.c +.,$d +-d +?part3 ++d +?include +.,$w part3.c +.,$d +-d +?part2 ++d +?include +.,$w part2.c +.,$d +?SPLIT +.d +1,/^#include/-1d +1,$w part1.c +/Computed constants/,$d +1,$s/^int/extern &/ +1,$s/^FLOAT/extern &/ +1,$s! = .*!;! +/^Guard/,/^Round/s/^/extern / +/^jmp_buf/s/^/extern / +/^Sig_type/s/^/extern / +a +extern int sigfpe(); +. +w paranoia.h +q + +*/ + +#include <stdio.h> +#ifndef NOSIGNAL +#include <signal.h> +#endif +#include <setjmp.h> + +#define Ldouble +/*#define Single*/ + +#ifdef Single +#define NPRT 2 +extern double fabs(), floor(), log(), pow(), sqrt(); +#define FLOAT float +#define FABS(x) (float)fabs((double)(x)) +#define FLOOR(x) (float)floor((double)(x)) +#define LOG(x) (float)log((double)(x)) +#define POW(x,y) (float)pow((double)(x),(double)(y)) +#define SQRT(x) (float)sqrt((double)(x)) +#define FSETUP sprec +/*sprec() { }*/ +#else +#ifdef Ldouble +#define NPRT 6 +extern long double fabsl(), floorl(), logl(), powl(), sqrtl(); +#define FLOAT long double +#define FABS(x) fabsl(x) +#define FLOOR(x) floorl(x) +#define LOG(x) logl(x) +#define POW(x,y) powl(x,y) +#define SQRT(x) sqrtl(x) +#define FSETUP ldprec +#else +#define NPRT 4 +extern double fabs(), floor(), log(), pow(), sqrt(); +#define FLOAT double +#define FABS(x) fabs(x) +#define FLOOR(x) floor(x) +#define LOG(x) log(x) +#define POW(x,y) pow(x,y) +#define SQRT(x) sqrt(x) +/*double __sqrtdf2(); +#define SQRT(x) __sqrtdf2(x) +*/ +#define FSETUP dprec +/* dprec() { } */ +#endif +#endif + +jmp_buf ovfl_buf; +typedef int (*Sig_type)(); +Sig_type sigsave; + +#define KEYBOARD 0 + +FLOAT Radix, BInvrse, RadixD2, BMinusU2; +FLOAT Sign(), Random(); + +/*Small floating point constants.*/ +FLOAT Zero = 0.0; +FLOAT Half = 0.5; +FLOAT One = 1.0; +FLOAT Two = 2.0; +FLOAT Three = 3.0; +FLOAT Four = 4.0; +FLOAT Five = 5.0; +FLOAT Eight = 8.0; +FLOAT Nine = 9.0; +FLOAT TwentySeven = 27.0; +FLOAT ThirtyTwo = 32.0; +FLOAT TwoForty = 240.0; +FLOAT MinusOne = -1.0; +FLOAT OneAndHalf = 1.5; +/*Integer constants*/ +int NoTrials = 20; /*Number of tests for commutativity. */ +#define False 0 +#define True 1 + +/* Definitions for declared types + Guard == (Yes, No); + Rounding == (Chopped, Rounded, Other); + Message == packed array [1..40] of char; + Class == (Flaw, Defect, Serious, Failure); + */ +#define Yes 1 +#define No 0 +#define Chopped 2 +#define Rounded 1 +#define Other 0 +#define Flaw 3 +#define Defect 2 +#define Serious 1 +#define Failure 0 +typedef int Guard, Rounding, Class; +typedef char Message; + +/* Declarations of Variables */ +int Indx; +char ch[8]; +FLOAT AInvrse, A1; +FLOAT C, CInvrse; +FLOAT D, FourD; +static FLOAT E0, E1, Exp2, E3, MinSqEr; +FLOAT SqEr, MaxSqEr, E9; +FLOAT Third; +FLOAT F6, F9; +FLOAT H, HInvrse; +int I; +FLOAT StickyBit, J; +FLOAT MyZero; +FLOAT Precision; +FLOAT Q, Q9; +FLOAT R, Random9; +FLOAT T, Underflow, S; +FLOAT OneUlp, UfThold, U1, U2; +FLOAT V, V0, V9; +FLOAT W; +FLOAT X, X1, X2, X8, Random1; +static FLOAT Y, Y1, Y2, Random2; +FLOAT Z, PseudoZero, Z1, Z2, Z9; +int ErrCnt[4]; +int fpecount; +int Milestone; +int PageNo; +int M, N, N1; +Guard GMult, GDiv, GAddSub; +Rounding RMult, RDiv, RAddSub, RSqrt; +int Break, Done, NotMonot, Monot, Anomaly, IEEE, + SqRWrng, UfNGrad; +/* Computed constants. */ +/*U1 gap below 1.0, i.e, 1.0-U1 is next number below 1.0 */ +/*U2 gap above 1.0, i.e, 1.0+U2 is next number above 1.0 */ + +/* floating point exception receiver */ +sigfpe() +{ + fpecount++; + printf("\n* * * FLOATING-POINT ERROR * * *\n"); + fflush(stdout); + if (sigsave) { +#ifndef NOSIGNAL + signal(SIGFPE, sigsave); +#endif + sigsave = 0; + longjmp(ovfl_buf, 1); + } + abort(); +} + + +FLOAT Ptemp; + +pnum( x ) +FLOAT *x; +{ +char str[30]; +double d; +unsigned short *p; +int i; + +p = (unsigned short *)x; +for( i=0; i<NPRT; i++ ) + printf( "%04x ", *p++ & 0xffff ); +#ifdef Ldouble +e64toasc( x, str, 20 ); +#else +#ifdef Single +e24toasc( x, str, 20 ); +#else +e53toasc( x, str, 20 ); +#endif +#endif +printf( " = %s\n", str ); +/* +d = *x; +printf( " = %.16e\n", d ); +*/ +} + + + +main() +{ +/* noexcept(); */ + FSETUP(); + /* First two assignments use integer right-hand sides. */ + Zero = 0; + One = 1; + Two = One + One; + Three = Two + One; + Four = Three + One; + Five = Four + One; + Eight = Four + Four; + Nine = Three * Three; + TwentySeven = Nine * Three; + ThirtyTwo = Four * Eight; + TwoForty = Four * Five * Three * Four; + MinusOne = -One; + Half = One / Two; + OneAndHalf = One + Half; + ErrCnt[Failure] = 0; + ErrCnt[Serious] = 0; + ErrCnt[Defect] = 0; + ErrCnt[Flaw] = 0; + PageNo = 1; + /*=============================================*/ + Milestone = 0; + /*=============================================*/ +#ifndef NOSIGNAL + signal(SIGFPE, sigfpe); +#endif + Instructions(); + Pause(); + Heading(); + Pause(); + Characteristics(); + Pause(); + History(); + Pause(); + /*=============================================*/ + Milestone = 7; + /*=============================================*/ + printf("Program is now RUNNING tests on small integers:\n"); + + TstCond (Failure, (Zero + Zero == Zero) && (One - One == Zero) + && (One > Zero) && (One + One == Two), + "0+0 != 0, 1-1 != 0, 1 <= 0, or 1+1 != 2"); + Z = - Zero; + if (Z == 0.0) { + U1 = 0.001; + Radix = 1; + TstPtUf(); + } + else { + ErrCnt[Failure] = ErrCnt[Failure] + 1; + printf("Comparison alleges that -0.0 is Non-zero!\n"); + } + TstCond (Failure, (Three == Two + One) && (Four == Three + One) + && (Four + Two * (- Two) == Zero) + && (Four - Three - One == Zero), + "3 != 2+1, 4 != 3+1, 4+2*(-2) != 0, or 4-3-1 != 0"); + TstCond (Failure, (MinusOne == (0 - One)) + && (MinusOne + One == Zero ) && (One + MinusOne == Zero) + && (MinusOne + FABS(One) == Zero) + && (MinusOne + MinusOne * MinusOne == Zero), + "-1+1 != 0, (-1)+abs(1) != 0, or -1+(-1)*(-1) != 0"); + TstCond (Failure, Half + MinusOne + Half == Zero, + "1/2 + (-1) + 1/2 != 0"); + /*=============================================*/ + /*SPLIT + part2(); + part3(); + part4(); + part5(); + part6(); + part7(); + part8(); + } +#include "paranoia.h" +part2(){ +*/ + Milestone = 10; + /*=============================================*/ + TstCond (Failure, (Nine == Three * Three) + && (TwentySeven == Nine * Three) && (Eight == Four + Four) + && (ThirtyTwo == Eight * Four) + && (ThirtyTwo - TwentySeven - Four - One == Zero), + "9 != 3*3, 27 != 9*3, 32 != 8*4, or 32-27-4-1 != 0"); + TstCond (Failure, (Five == Four + One) && + (TwoForty == Four * Five * Three * Four) + && (TwoForty / Three - Four * Four * Five == Zero) + && ( TwoForty / Four - Five * Three * Four == Zero) + && ( TwoForty / Five - Four * Three * Four == Zero), + "5 != 4+1, 240/3 != 80, 240/4 != 60, or 240/5 != 48"); + if (ErrCnt[Failure] == 0) { + printf("-1, 0, 1/2, 1, 2, 3, 4, 5, 9, 27, 32 & 240 are O.K.\n"); + printf("\n"); + } + printf("Searching for Radix and Precision.\n"); + W = One; + do { + W = W + W; + Y = W + One; + Z = Y - W; + Y = Z - One; + } while (MinusOne + FABS(Y) < Zero); + /*.. now W is just big enough that |((W+1)-W)-1| >= 1 ...*/ + Precision = Zero; + Y = One; + do { + Radix = W + Y; + Y = Y + Y; + Radix = Radix - W; + } while ( Radix == Zero); + if (Radix < Two) Radix = One; + printf("Radix = " ); + pnum( &Radix ); + if (Radix != 1) { + W = One; + do { + Precision = Precision + One; + W = W * Radix; + Y = W + One; + } while ((Y - W) == One); + } + /*... now W == Radix^Precision is barely too big to satisfy (W+1)-W == 1 + ...*/ + U1 = One / W; + U2 = Radix * U1; + printf("Closest relative separation found is U1 = " ); + pnum( &U1 ); + printf("U2 = "); + pnum( &U2 ); + printf("Recalculating radix and precision."); + + /*save old values*/ + E0 = Radix; + E1 = U1; + E9 = U2; + E3 = Precision; + + X = Four / Three; + Third = X - One; + F6 = Half - Third; + X = F6 + F6; + X = FABS(X - Third); + if (X < U2) X = U2; + + /*... now X = (unknown no.) ulps of 1+...*/ + do { + U2 = X; + Y = Half * U2 + ThirtyTwo * U2 * U2; + Y = One + Y; + X = Y - One; + } while ( ! ((U2 <= X) || (X <= Zero))); + + /*... now U2 == 1 ulp of 1 + ... */ + X = Two / Three; + F6 = X - Half; + Third = F6 + F6; + X = Third - Half; + X = FABS(X + F6); + if (X < U1) X = U1; + + /*... now X == (unknown no.) ulps of 1 -... */ + do { + U1 = X; + Y = Half * U1 + ThirtyTwo * U1 * U1; + Y = Half - Y; + X = Half + Y; + Y = Half - X; + X = Half + Y; + } while ( ! ((U1 <= X) || (X <= Zero))); + /*... now U1 == 1 ulp of 1 - ... */ + if (U1 == E1) printf("confirms closest relative separation U1 .\n"); + else + { + printf("gets better closest relative separation U1 = " ); + pnum( &U1 ); + } + W = One / U1; + F9 = (Half - U1) + Half; + Radix = FLOOR(0.01 + U2 / U1); + if (Radix == E0) printf("Radix confirmed.\n"); + else + { + printf("MYSTERY: recalculated Radix = " ); + pnum( &Radix ); + } + TstCond (Defect, Radix <= Eight + Eight, + "Radix is too big: roundoff problems"); + TstCond (Flaw, (Radix == Two) || (Radix == 10) + || (Radix == One), "Radix is not as good as 2 or 10"); + /*=============================================*/ + Milestone = 20; + /*=============================================*/ + TstCond (Failure, F9 - Half < Half, + "(1-U1)-1/2 < 1/2 is FALSE, prog. fails?"); + X = F9; + I = 1; + Y = X - Half; + Z = Y - Half; + TstCond (Failure, (X != One) + || (Z == Zero), "Comparison is fuzzy,X=1 but X-1/2-1/2 != 0"); + X = One + U2; + I = 0; + /*=============================================*/ + Milestone = 25; + /*=============================================*/ + /*... BMinusU2 = nextafter(Radix, 0) */ + BMinusU2 = Radix - One; + BMinusU2 = (BMinusU2 - U2) + One; + /* Purify Integers */ + if (Radix != One) { + X = - TwoForty * LOG(U1) / LOG(Radix); + Y = FLOOR(Half + X); + if (FABS(X - Y) * Four < One) X = Y; + Precision = X / TwoForty; + Y = FLOOR(Half + Precision); + if (FABS(Precision - Y) * TwoForty < Half) Precision = Y; + } + if ((Precision != FLOOR(Precision)) || (Radix == One)) { + printf("Precision cannot be characterized by an Integer number\n"); + printf("of significant digits but, by itself, this is a minor flaw.\n"); + } + if (Radix == One) + printf("logarithmic encoding has precision characterized solely by U1.\n"); + else + { + printf("The number of significant digits of the Radix is " ); + pnum( &Precision ); + } + TstCond (Serious, U2 * Nine * Nine * TwoForty < One, + "Precision worse than 5 decimal figures "); + /*=============================================*/ + Milestone = 30; + /*=============================================*/ + /* Test for extra-precise subepressions */ + X = FABS(((Four / Three - One) - One / Four) * Three - One / Four); + do { + Z2 = X; + X = (One + (Half * Z2 + ThirtyTwo * Z2 * Z2)) - One; + } while ( ! ((Z2 <= X) || (X <= Zero))); + X = Y = Z = FABS((Three / Four - Two / Three) * Three - One / Four); + do { + Z1 = Z; + Z = (One / Two - ((One / Two - (Half * Z1 + ThirtyTwo * Z1 * Z1)) + + One / Two)) + One / Two; + } while ( ! ((Z1 <= Z) || (Z <= Zero))); + do { + do { + Y1 = Y; + Y = (Half - ((Half - (Half * Y1 + ThirtyTwo * Y1 * Y1)) + Half + )) + Half; + } while ( ! ((Y1 <= Y) || (Y <= Zero))); + X1 = X; + X = ((Half * X1 + ThirtyTwo * X1 * X1) - F9) + F9; + } while ( ! ((X1 <= X) || (X <= Zero))); + if ((X1 != Y1) || (X1 != Z1)) { + BadCond(Serious, "Disagreements among the values X1, Y1, Z1,\n"); + printf("respectively " ); + pnum( &X1 ); + pnum( &Y1 ); + pnum( &Z1 ); + printf("are symptoms of inconsistencies introduced\n"); + printf("by extra-precise evaluation of arithmetic subexpressions.\n"); + notify("Possibly some part of this"); + if ((X1 == U1) || (Y1 == U1) || (Z1 == U1)) printf( + "That feature is not tested further by this program.\n") ; + } + else { + if ((Z1 != U1) || (Z2 != U2)) { + if ((Z1 >= U1) || (Z2 >= U2)) { + BadCond(Failure, ""); + notify("Precision"); + printf("\tU1 = " ); + pnum( &U1 ); + printf( "Z1 - U1 = " ); + Ptemp = Z1-U1; + pnum( &Ptemp ); + printf("\tU2 = " ); + pnum( &U2 ); + Ptemp = Z2-U2; + printf( "Z2 - U2 = " ); + pnum( &Ptemp ); + } + else { + if ((Z1 <= Zero) || (Z2 <= Zero)) { + printf("Because of unusual Radix = "); + pnum( &Radix ); + printf(", or exact rational arithmetic a result\n"); + printf("Z1 = " ); + pnum( &Z1 ); + printf( "or Z2 = " ); + pnum( &Z2 ); + notify("of an\nextra-precision"); + } + if (Z1 != Z2 || Z1 > Zero) { + X = Z1 / U1; + Y = Z2 / U2; + if (Y > X) X = Y; + Q = - LOG(X); + printf("Some subexpressions appear to be calculated extra\n"); + printf("precisely with about" ); + Ptemp = Q / LOG(Radix); + pnum( &Ptemp ); + printf( "extra B-digits, i.e.\n" ); + Ptemp = Q / LOG(10.); + printf("roughly " ); + pnum( &Ptemp ); + printf( "extra significant decimals.\n"); + } + printf("That feature is not tested further by this program.\n"); + } + } + } + Pause(); + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part3(){ +*/ + Milestone = 35; + /*=============================================*/ + if (Radix >= Two) { + X = W / (Radix * Radix); + Y = X + One; + Z = Y - X; + T = Z + U2; + X = T - Z; + TstCond (Failure, X == U2, + "Subtraction is not normalized X=Y,X+Z != Y+Z!"); + if (X == U2) printf( + "Subtraction appears to be normalized, as it should be."); + } + printf("\nChecking for guard digit in *, /, and -.\n"); + Y = F9 * One; + Z = One * F9; + X = F9 - Half; + Y = (Y - Half) - X; + Z = (Z - Half) - X; + X = One + U2; + T = X * Radix; + R = Radix * X; + X = T - Radix; + X = X - Radix * U2; + T = R - Radix; + T = T - Radix * U2; + X = X * (Radix - One); + T = T * (Radix - One); + if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero)) GMult = Yes; + else { + GMult = No; + TstCond (Serious, False, + "* lacks a Guard Digit, so 1*X != X"); + } + Z = Radix * U2; + X = One + Z; + Y = FABS((X + Z) - X * X) - U2; + X = One - U2; + Z = FABS((X - U2) - X * X) - U1; + TstCond (Failure, (Y <= Zero) + && (Z <= Zero), "* gets too many final digits wrong.\n"); + Y = One - U2; + X = One + U2; + Z = One / Y; + Y = Z - X; + X = One / Three; + Z = Three / Nine; + X = X - Z; + T = Nine / TwentySeven; + Z = Z - T; + TstCond(Defect, X == Zero && Y == Zero && Z == Zero, + "Division lacks a Guard Digit, so error can exceed 1 ulp\n\ +or 1/3 and 3/9 and 9/27 may disagree"); + Y = F9 / One; + X = F9 - Half; + Y = (Y - Half) - X; + X = One + U2; + T = X / One; + X = T - X; + if ((X == Zero) && (Y == Zero) && (Z == Zero)) GDiv = Yes; + else { + GDiv = No; + TstCond (Serious, False, + "Division lacks a Guard Digit, so X/1 != X"); + } + X = One / (One + U2); + Y = X - Half - Half; + TstCond (Serious, Y < Zero, + "Computed value of 1/1.000..1 >= 1"); + X = One - U2; + Y = One + Radix * U2; + Z = X * Radix; + T = Y * Radix; + R = Z / Radix; + StickyBit = T / Radix; + X = R - X; + Y = StickyBit - Y; + TstCond (Failure, X == Zero && Y == Zero, + "* and/or / gets too many last digits wrong"); + Y = One - U1; + X = One - F9; + Y = One - Y; + T = Radix - U2; + Z = Radix - BMinusU2; + T = Radix - T; + if ((X == U1) && (Y == U1) && (Z == U2) && (T == U2)) GAddSub = Yes; + else { + GAddSub = No; + TstCond (Serious, False, + "- lacks Guard Digit, so cancellation is obscured"); + } + if (F9 != One && F9 - One >= Zero) { + BadCond(Serious, "comparison alleges (1-U1) < 1 although\n"); + printf(" subtration yields (1-U1) - 1 = 0 , thereby vitiating\n"); + printf(" such precautions against division by zero as\n"); + printf(" ... if (X == 1.0) {.....} else {.../(X-1.0)...}\n"); + } + if (GMult == Yes && GDiv == Yes && GAddSub == Yes) printf( + " *, /, and - appear to have guard digits, as they should.\n"); + /*=============================================*/ + Milestone = 40; + /*=============================================*/ + Pause(); + printf("Checking rounding on multiply, divide and add/subtract.\n"); + RMult = Other; + RDiv = Other; + RAddSub = Other; + RadixD2 = Radix / Two; + A1 = Two; + Done = False; + do { + AInvrse = Radix; + do { + X = AInvrse; + AInvrse = AInvrse / A1; + } while ( ! (FLOOR(AInvrse) != AInvrse)); + Done = (X == One) || (A1 > Three); + if (! Done) A1 = Nine + One; + } while ( ! (Done)); + if (X == One) A1 = Radix; + AInvrse = One / A1; + X = A1; + Y = AInvrse; + Done = False; + do { + Z = X * Y - Half; + TstCond (Failure, Z == Half, + "X * (1/X) differs from 1"); + Done = X == Radix; + X = Radix; + Y = One / X; + } while ( ! (Done)); + Y2 = One + U2; + Y1 = One - U2; + X = OneAndHalf - U2; + Y = OneAndHalf + U2; + Z = (X - U2) * Y2; + T = Y * Y1; + Z = Z - X; + T = T - X; + X = X * Y2; + Y = (Y + U2) * Y1; + X = X - OneAndHalf; + Y = Y - OneAndHalf; + if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T <= Zero)) { + printf("Y2 = "); + pnum( &Y2 ); + printf("Y1 = "); + pnum( &Y1 ); + printf("U2 = "); + pnum( &U2 ); + X = (OneAndHalf + U2) * Y2; + Y = OneAndHalf - U2 - U2; + Z = OneAndHalf + U2 + U2; + T = (OneAndHalf - U2) * Y1; + X = X - (Z + U2); + StickyBit = Y * Y1; + S = Z * Y2; + T = T - Y; + Y = (U2 - Y) + StickyBit; + Z = S - (Z + U2 + U2); + StickyBit = (Y2 + U2) * Y1; + Y1 = Y2 * Y1; + StickyBit = StickyBit - Y2; + Y1 = Y1 - Half; + if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero) + && ( StickyBit == Zero) && (Y1 == Half)) { + RMult = Rounded; + printf("Multiplication appears to round correctly.\n"); + } + else if ((X + U2 == Zero) && (Y < Zero) && (Z + U2 == Zero) + && (T < Zero) && (StickyBit + U2 == Zero) + && (Y1 < Half)) { + RMult = Chopped; + printf("Multiplication appears to chop.\n"); + } + else printf("* is neither chopped nor correctly rounded.\n"); + if ((RMult == Rounded) && (GMult == No)) notify("Multiplication"); + } + else printf("* is neither chopped nor correctly rounded.\n"); + /*=============================================*/ + Milestone = 45; + /*=============================================*/ + Y2 = One + U2; + Y1 = One - U2; + Z = OneAndHalf + U2 + U2; + X = Z / Y2; + T = OneAndHalf - U2 - U2; + Y = (T - U2) / Y1; + Z = (Z + U2) / Y2; + X = X - OneAndHalf; + Y = Y - T; + T = T / Y1; + Z = Z - (OneAndHalf + U2); + T = (U2 - OneAndHalf) + T; + if (! ((X > Zero) || (Y > Zero) || (Z > Zero) || (T > Zero))) { + X = OneAndHalf / Y2; + Y = OneAndHalf - U2; + Z = OneAndHalf + U2; + X = X - Y; + T = OneAndHalf / Y1; + Y = Y / Y1; + T = T - (Z + U2); + Y = Y - Z; + Z = Z / Y2; + Y1 = (Y2 + U2) / Y2; + Z = Z - OneAndHalf; + Y2 = Y1 - Y2; + Y1 = (F9 - U1) / F9; + if ((X == Zero) && (Y == Zero) && (Z == Zero) && (T == Zero) + && (Y2 == Zero) && (Y2 == Zero) + && (Y1 - Half == F9 - Half )) { + RDiv = Rounded; + printf("Division appears to round correctly.\n"); + if (GDiv == No) notify("Division"); + } + else if ((X < Zero) && (Y < Zero) && (Z < Zero) && (T < Zero) + && (Y2 < Zero) && (Y1 - Half < F9 - Half)) { + RDiv = Chopped; + printf("Division appears to chop.\n"); + } + } + if (RDiv == Other) printf("/ is neither chopped nor correctly rounded.\n"); + BInvrse = One / Radix; + TstCond (Failure, (BInvrse * Radix - Half == Half), + "Radix * ( 1 / Radix ) differs from 1"); + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part4(){ +*/ + Milestone = 50; + /*=============================================*/ + TstCond (Failure, ((F9 + U1) - Half == Half) + && ((BMinusU2 + U2 ) - One == Radix - One), + "Incomplete carry-propagation in Addition"); + X = One - U1 * U1; + Y = One + U2 * (One - U2); + Z = F9 - Half; + X = (X - Half) - Z; + Y = Y - One; + if ((X == Zero) && (Y == Zero)) { + RAddSub = Chopped; + printf("Add/Subtract appears to be chopped.\n"); + } + if (GAddSub == Yes) { + X = (Half + U2) * U2; + Y = (Half - U2) * U2; + X = One + X; + Y = One + Y; + X = (One + U2) - X; + Y = One - Y; + if ((X == Zero) && (Y == Zero)) { + X = (Half + U2) * U1; + Y = (Half - U2) * U1; + X = One - X; + Y = One - Y; + X = F9 - X; + Y = One - Y; + if ((X == Zero) && (Y == Zero)) { + RAddSub = Rounded; + printf("Addition/Subtraction appears to round correctly.\n"); + if (GAddSub == No) notify("Add/Subtract"); + } + else printf("Addition/Subtraction neither rounds nor chops.\n"); + } + else printf("Addition/Subtraction neither rounds nor chops.\n"); + } + else printf("Addition/Subtraction neither rounds nor chops.\n"); + S = One; + X = One + Half * (One + Half); + Y = (One + U2) * Half; + Z = X - Y; + T = Y - X; + StickyBit = Z + T; + if (StickyBit != Zero) { + S = Zero; + BadCond(Flaw, "(X - Y) + (Y - X) is non zero!\n"); + } + StickyBit = Zero; + if ((GMult == Yes) && (GDiv == Yes) && (GAddSub == Yes) + && (RMult == Rounded) && (RDiv == Rounded) + && (RAddSub == Rounded) && (FLOOR(RadixD2) == RadixD2)) { + printf("Checking for sticky bit.\n"); + X = (Half + U1) * U2; + Y = Half * U2; + Z = One + Y; + T = One + X; + if ((Z - One <= Zero) && (T - One >= U2)) { + Z = T + Y; + Y = Z - X; + if ((Z - T >= U2) && (Y - T == Zero)) { + X = (Half + U1) * U1; + Y = Half * U1; + Z = One - Y; + T = One - X; + if ((Z - One == Zero) && (T - F9 == Zero)) { + Z = (Half - U1) * U1; + T = F9 - Z; + Q = F9 - Y; + if ((T - F9 == Zero) && (F9 - U1 - Q == Zero)) { + Z = (One + U2) * OneAndHalf; + T = (OneAndHalf + U2) - Z + U2; + X = One + Half / Radix; + Y = One + Radix * U2; + Z = X * Y; + if (T == Zero && X + Radix * U2 - Z == Zero) { + if (Radix != Two) { + X = Two + U2; + Y = X / Two; + if ((Y - One == Zero)) StickyBit = S; + } + else StickyBit = S; + } + } + } + } + } + } + if (StickyBit == One) printf("Sticky bit apparently used correctly.\n"); + else printf("Sticky bit used incorrectly or not at all.\n"); + TstCond (Flaw, !(GMult == No || GDiv == No || GAddSub == No || + RMult == Other || RDiv == Other || RAddSub == Other), + "lack(s) of guard digits or failure(s) to correctly round or chop\n\ +(noted above) count as one flaw in the final tally below"); + /*=============================================*/ + Milestone = 60; + /*=============================================*/ + printf("\n"); + printf("Does Multiplication commute? "); + printf("Testing on %d random pairs.\n", NoTrials); + Ptemp = 3.0; + Random9 = SQRT(Ptemp); + Random1 = Third; + I = 1; + do { + X = Random(); + Y = Random(); + Z9 = Y * X; + Z = X * Y; + Z9 = Z - Z9; + I = I + 1; + } while ( ! ((I > NoTrials) || (Z9 != Zero))); + if (I == NoTrials) { + Random1 = One + Half / Three; + Random2 = (U2 + U1) + One; + Z = Random1 * Random2; + Y = Random2 * Random1; + Z9 = (One + Half / Three) * ((U2 + U1) + One) - (One + Half / + Three) * ((U2 + U1) + One); + } + if (! ((I == NoTrials) || (Z9 == Zero))) + BadCond(Defect, "X * Y == Y * X trial fails.\n"); + else printf(" No failures found in %d integer pairs.\n", NoTrials); + /*=============================================*/ + Milestone = 70; + /*=============================================*/ + printf("\nRunning test of square root(x).\n"); + TstCond (Failure, (Zero == SQRT(Zero)) + && (- Zero == SQRT(- Zero)) + && (One == SQRT(One)), "Square root of 0.0, -0.0 or 1.0 wrong"); + MinSqEr = Zero; + MaxSqEr = Zero; + J = Zero; + X = Radix; + OneUlp = U2; + SqXMinX (Serious); + X = BInvrse; + OneUlp = BInvrse * U1; + SqXMinX (Serious); + X = U1; + OneUlp = U1 * U1; + SqXMinX (Serious); + if (J != Zero) Pause(); + printf("Testing if sqrt(X * X) == X for %d Integers X.\n", NoTrials); + J = Zero; + X = Two; + Y = Radix; + if ((Radix != One)) do { + X = Y; + Y = Radix * Y; + } while ( ! ((Y - X >= NoTrials))); + OneUlp = X * U2; + I = 1; + while (I < 10) { + X = X + One; + SqXMinX (Defect); + if (J > Zero) break; + I = I + 1; + } + printf("Test for sqrt monotonicity.\n"); + I = - 1; + X = BMinusU2; + Y = Radix; + Z = Radix + Radix * U2; + NotMonot = False; + Monot = False; + while ( ! (NotMonot || Monot)) { + I = I + 1; + X = SQRT(X); + Q = SQRT(Y); + Z = SQRT(Z); + if ((X > Q) || (Q > Z)) NotMonot = True; + else { + Q = FLOOR(Q + Half); + if ((I > 0) || (Radix == Q * Q)) Monot = True; + else if (I > 0) { + if (I > 1) Monot = True; + else { + Y = Y * BInvrse; + X = Y - U1; + Z = Y + U1; + } + } + else { + Y = Q; + X = Y - U2; + Z = Y + U2; + } + } + } + if (Monot) printf("sqrt has passed a test for Monotonicity.\n"); + else { + BadCond(Defect, ""); + printf("sqrt(X) is non-monotonic for X near " ); + pnum( &Y ); + } + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part5(){ +*/ + Milestone = 80; + /*=============================================*/ + MinSqEr = MinSqEr + Half; + MaxSqEr = MaxSqEr - Half; + Y = (SQRT(One + U2) - One) / U2; + SqEr = (Y - One) + U2 / Eight; + if (SqEr > MaxSqEr) MaxSqEr = SqEr; + SqEr = Y + U2 / Eight; + if (SqEr < MinSqEr) MinSqEr = SqEr; + Y = ((SQRT(F9) - U2) - (One - U2)) / U1; + SqEr = Y + U1 / Eight; + if (SqEr > MaxSqEr) MaxSqEr = SqEr; + SqEr = (Y + One) + U1 / Eight; + if (SqEr < MinSqEr) MinSqEr = SqEr; + OneUlp = U2; + X = OneUlp; + for( Indx = 1; Indx <= 3; ++Indx) { + Y = SQRT((X + U1 + X) + F9); + Y = ((Y - U2) - ((One - U2) + X)) / OneUlp; + Z = ((U1 - X) + F9) * Half * X * X / OneUlp; + SqEr = (Y + Half) + Z; + if (SqEr < MinSqEr) MinSqEr = SqEr; + SqEr = (Y - Half) + Z; + if (SqEr > MaxSqEr) MaxSqEr = SqEr; + if (((Indx == 1) || (Indx == 3))) + X = OneUlp * Sign (X) * FLOOR(Eight / (Nine * SQRT(OneUlp))); + else { + OneUlp = U1; + X = - OneUlp; + } + } + /*=============================================*/ + Milestone = 85; + /*=============================================*/ + SqRWrng = False; + Anomaly = False; + if (Radix != One) { + printf("Testing whether sqrt is rounded or chopped.\n"); + D = FLOOR(Half + POW(Radix, One + Precision - FLOOR(Precision))); + /* ... == Radix^(1 + fract) if (Precision == Integer + fract. */ + X = D / Radix; + Y = D / A1; + if ((X != FLOOR(X)) || (Y != FLOOR(Y))) { + Anomaly = True; + } + else { + X = Zero; + Z2 = X; + Y = One; + Y2 = Y; + Z1 = Radix - One; + FourD = Four * D; + do { + if (Y2 > Z2) { + Q = Radix; + Y1 = Y; + do { + X1 = FABS(Q + FLOOR(Half - Q / Y1) * Y1); + Q = Y1; + Y1 = X1; + } while ( ! (X1 <= Zero)); + if (Q <= One) { + Z2 = Y2; + Z = Y; + } + } + Y = Y + Two; + X = X + Eight; + Y2 = Y2 + X; + if (Y2 >= FourD) Y2 = Y2 - FourD; + } while ( ! (Y >= D)); + X8 = FourD - Z2; + Q = (X8 + Z * Z) / FourD; + X8 = X8 / Eight; + if (Q != FLOOR(Q)) Anomaly = True; + else { + Break = False; + do { + X = Z1 * Z; + X = X - FLOOR(X / Radix) * Radix; + if (X == One) + Break = True; + else + Z1 = Z1 - One; + } while ( ! (Break || (Z1 <= Zero))); + if ((Z1 <= Zero) && (! Break)) Anomaly = True; + else { + if (Z1 > RadixD2) Z1 = Z1 - Radix; + do { + NewD(); + } while ( ! (U2 * D >= F9)); + if (D * Radix - D != W - D) Anomaly = True; + else { + Z2 = D; + I = 0; + Y = D + (One + Z) * Half; + X = D + Z + Q; + SR3750(); + Y = D + (One - Z) * Half + D; + X = D - Z + D; + X = X + Q + X; + SR3750(); + NewD(); + if (D - Z2 != W - Z2) Anomaly = True; + else { + Y = (D - Z2) + (Z2 + (One - Z) * Half); + X = (D - Z2) + (Z2 - Z + Q); + SR3750(); + Y = (One + Z) * Half; + X = Q; + SR3750(); + if (I == 0) Anomaly = True; + } + } + } + } + } + if ((I == 0) || Anomaly) { + BadCond(Failure, "Anomalous arithmetic with Integer < "); + printf("Radix^Precision = " ); + pnum( &W ); + printf(" fails test whether sqrt rounds or chops.\n"); + SqRWrng = True; + } + } + if (! Anomaly) { + if (! ((MinSqEr < Zero) || (MaxSqEr > Zero))) { + RSqrt = Rounded; + printf("Square root appears to be correctly rounded.\n"); + } + else { + if ((MaxSqEr + U2 > U2 - Half) || (MinSqEr > Half) + || (MinSqEr + Radix < Half)) SqRWrng = True; + else { + RSqrt = Chopped; + printf("Square root appears to be chopped.\n"); + } + } + } + if (SqRWrng) { + printf("Square root is neither chopped nor correctly rounded.\n"); + printf("Observed errors run from " ); + Ptemp = MinSqEr - Half; + pnum( &Ptemp ); + printf("to %.7e ulps.\n"); + Ptemp = Half + MaxSqEr; + pnum( &Ptemp ); + TstCond (Serious, MaxSqEr - MinSqEr < Radix * Radix, + "sqrt gets too many last digits wrong"); + } + /*=============================================*/ + Milestone = 90; + /*=============================================*/ + Pause(); + printf("Testing powers Z^i for small Integers Z and i.\n"); + N = 0; + /* ... test powers of zero. */ + I = 0; + Z = -Zero; + M = 3.0; + Break = False; + do { + X = One; + SR3980(); + if (I <= 10) { + I = 1023; + SR3980(); + } + if (Z == MinusOne) Break = True; + else { + Z = MinusOne; + PrintIfNPositive(); + N = 0; + /* .. if(-1)^N is invalid, replace MinusOne by One. */ + I = - 4; + } + } while ( ! Break); + PrintIfNPositive(); + N1 = N; + N = 0; + Z = A1; + M = FLOOR(Two * LOG(W) / LOG(A1)); + Break = False; + do { + X = Z; + I = 1; + SR3980(); + if (Z == AInvrse) Break = True; + else Z = AInvrse; + } while ( ! (Break)); + /*=============================================*/ + Milestone = 100; + /*=============================================*/ + /* Powers of Radix have been tested, */ + /* next try a few primes */ + M = NoTrials; + Z = Three; + do { + X = Z; + I = 1; + SR3980(); + do { + Z = Z + Two; + } while ( Three * FLOOR(Z / Three) == Z ); + } while ( Z < Eight * Three ); + if (N > 0) { + printf("Errors like this may invalidate financial calculations\n"); + printf("\tinvolving interest rates.\n"); + } + PrintIfNPositive(); + N += N1; + if (N == 0) printf("... no discrepancis found.\n"); + if (N > 0) Pause(); + else printf("\n"); + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part6(){ +*/ + Milestone = 110; + /*=============================================*/ + printf("Seeking Underflow thresholds UfThold and E0.\n"); + D = U1; + if (Precision != FLOOR(Precision)) { + D = BInvrse; + X = Precision; + do { + D = D * BInvrse; + X = X - One; + } while ( X > Zero); + } + Y = One; + Z = D; + /* ... D is power of 1/Radix < 1. */ + do { + C = Y; + Y = Z; + Z = Y * Y; + } while ((Y > Z) && (Z + Z > Z)); + Y = C; + Z = Y * D; + do { + C = Y; + Y = Z; + Z = Y * D; + } while ((Y > Z) && (Z + Z > Z)); + if (Radix < Two) HInvrse = Two; + else HInvrse = Radix; + H = One / HInvrse; + /* ... 1/HInvrse == H == Min(1/Radix, 1/2) */ + CInvrse = One / C; + E0 = C; + Z = E0 * H; + /* ...1/Radix^(BIG Integer) << 1 << CInvrse == 1/C */ + do { + Y = E0; + E0 = Z; + Z = E0 * H; + } while ((E0 > Z) && (Z + Z > Z)); + UfThold = E0; + E1 = Zero; + Q = Zero; + E9 = U2; + S = One + E9; + D = C * S; + if (D <= C) { + E9 = Radix * U2; + S = One + E9; + D = C * S; + if (D <= C) { + BadCond(Failure, "multiplication gets too many last digits wrong.\n"); + Underflow = E0; + Y1 = Zero; + PseudoZero = Z; + Pause(); + } + } + else { + Underflow = D; + PseudoZero = Underflow * H; + UfThold = Zero; + do { + Y1 = Underflow; + Underflow = PseudoZero; + if (E1 + E1 <= E1) { + Y2 = Underflow * HInvrse; + E1 = FABS(Y1 - Y2); + Q = Y1; + if ((UfThold == Zero) && (Y1 != Y2)) UfThold = Y1; + } + PseudoZero = PseudoZero * H; + } while ((Underflow > PseudoZero) + && (PseudoZero + PseudoZero > PseudoZero)); + } + /* Comment line 4530 .. 4560 */ + if (PseudoZero != Zero) { + printf("\n"); + Z = PseudoZero; + /* ... Test PseudoZero for "phoney- zero" violates */ + /* ... PseudoZero < Underflow or PseudoZero < PseudoZero + PseudoZero + ... */ + if (PseudoZero <= Zero) { + BadCond(Failure, "Positive expressions can underflow to an\n"); + printf("allegedly negative value\n"); + printf("PseudoZero that prints out as: " ); + pnum( &PseudoZero ); + X = - PseudoZero; + if (X <= Zero) { + printf("But -PseudoZero, which should be\n"); + printf("positive, isn't; it prints out as " ); + pnum( &X ); + } + } + else { + BadCond(Flaw, "Underflow can stick at an allegedly positive\n"); + printf("value PseudoZero that prints out as "); + pnum( &PseudoZero ); + } + TstPtUf(); + } + /*=============================================*/ + Milestone = 120; + /*=============================================*/ + if (CInvrse * Y > CInvrse * Y1) { + S = H * S; + E0 = Underflow; + } + if (! ((E1 == Zero) || (E1 == E0))) { + BadCond(Defect, ""); + if (E1 < E0) { + printf("Products underflow at a higher"); + printf(" threshold than differences.\n"); + if (PseudoZero == Zero) + E0 = E1; + } + else { + printf("Difference underflows at a higher"); + printf(" threshold than products.\n"); + } + } + printf("Smallest strictly positive number found is E0 = "); + Pause(); + pnum( &E0 ); + Z = E0; + TstPtUf(); + Underflow = E0; + if (N == 1) Underflow = Y; + I = 4; + if (E1 == Zero) I = 3; + if (UfThold == Zero) I = I - 2; + UfNGrad = True; + switch (I) { + case 1: + UfThold = Underflow; + if ((CInvrse * Q) != ((CInvrse * Y) * S)) { + UfThold = Y; + BadCond(Failure, "Either accuracy deteriorates as numbers\n"); + printf("approach a threshold = "); + pnum( &UfThold ); + printf(" coming down from " ); + pnum( &C ); + printf(" or else multiplication gets too many last digits wrong.\n"); + } + Pause(); + break; + + case 2: + BadCond(Failure, "Underflow confuses Comparison which alleges that\n"); + printf("Q == Y while denying that |Q - Y| == 0; these values\n"); + printf("print out as Q = " ); + pnum( &Q ); + printf( "Y = " ); + pnum( &Y ); + printf ("|Q - Y| = " ); + Ptemp = FABS(Q - Y2); + pnum( &Ptemp ); + UfThold = Q; + break; + + case 3: + X = X; + break; + + case 4: + if ((Q == UfThold) && (E1 == E0) + && (FABS( UfThold - E1 / E9) <= E1)) { + UfNGrad = False; + printf("Underflow is gradual; it incurs Absolute Error =\n"); + printf("(roundoff in UfThold) < E0.\n"); + Y = E0 * CInvrse; + Y = Y * (OneAndHalf + U2); + X = CInvrse * (One + U2); + Y = Y / X; + IEEE = (Y == E0); + } + } + if (UfNGrad) { + printf("\n"); + R = SQRT(Underflow / UfThold); + if (R <= H) { + Z = R * UfThold; + X = Z * (One + R * H * (One + H)); + } + else { + Z = UfThold; + X = Z * (One + H * H * (One + H)); + } + if (! ((X == Z) || (X - Z != Zero))) { + BadCond(Flaw, ""); + printf("X = " ); + pnum( &X ); + printf( "is not equal to Z = "); + pnum( &Z ); + Z9 = X - Z; + printf("yet X - Z yields " ); + pnum( &Z9 ); + printf(" Should this NOT signal Underflow, "); + printf("this is a SERIOUS DEFECT\nthat causes "); + printf("confusion when innocent statements like\n");; + printf(" if (X == Z) ... else"); + printf(" ... (f(X) - f(Z)) / (X - Z) ...\n"); + printf("encounter Division by Zero although actually\n"); + printf("X / Z = 1 + "); + Ptemp = (X / Z - Half) - Half; + pnum( &Ptemp ); + } + } + printf("The Underflow threshold is "); + pnum( &UfThold ); + printf("below which calculation may suffer larger Relative error than "); + printf("merely roundoff.\n"); + Y2 = U1 * U1; + Y = Y2 * Y2; + Y2 = Y * U1; + if (Y2 <= UfThold) { + if (Y > E0) { + BadCond(Defect, ""); + I = 5; + } + else { + BadCond(Serious, ""); + I = 4; + } + printf("Range is too narrow; U1^%d Underflows.\n", I); + } + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part7(){ +*/ + Milestone = 130; + /*=============================================*/ + Y = - FLOOR(Half - TwoForty * LOG(UfThold) / LOG(HInvrse)) / TwoForty; + Y2 = Y - One; + printf("Since underflow occurs below the threshold\n"); + printf("UfThold = "); + pnum( &HInvrse ); + printf( ") ^ (Y=" ); + pnum( &Y ); + printf( ")\nonly underflow " ); + printf("should afflict the expression HInvrse^(Y+1).\n"); + pnum( &HInvrse ); + pnum( &Y2 ); + V9 = POW(HInvrse, Y2); + printf("actually calculating yields: "); + pnum( &V9 ); + if (! ((V9 >= Zero) && (V9 <= (Radix + Radix + E9) * UfThold))) { + BadCond(Serious, "this is not between 0 and underflow\n"); + printf(" threshold = "); + pnum( &UfThold ); + } + else if (! (V9 > UfThold * (One + E9))) + printf("This computed value is O.K.\n"); + else { + BadCond(Defect, "this is not between 0 and underflow\n"); + printf(" threshold = "); + pnum( &UfThold); + } + /*=============================================*/ + Milestone = 140; + /*=============================================*/ + printf("\n"); + /* ...calculate Exp2 == exp(2) == 7.389056099... */ + X = Zero; + I = 2; + Y = Two * Three; + Q = Zero; + N = 0; + do { + Z = X; + I = I + 1; + Y = Y / (I + I); + R = Y + Q; + X = Z + R; + Q = (Z - X) + R; + } while(X > Z); + Z = (OneAndHalf + One / Eight) + X / (OneAndHalf * ThirtyTwo); + X = Z * Z; + Exp2 = X * X; + X = F9; + Y = X - U1; + printf("Testing X^((X + 1) / (X - 1)) vs. exp(2) = "); + pnum( &Exp2 ); + printf( "as X -> 1.\n"); + for(I = 1;;) { + Z = X - BInvrse; + Z = (X + One) / (Z - (One - BInvrse)); + Q = POW(X, Z) - Exp2; + if (FABS(Q) > TwoForty * U2) { + N = 1; + V9 = (X - BInvrse) - (One - BInvrse); + BadCond(Defect, "Calculated"); + Ptemp = POW(X,Z); + pnum(&Ptemp); + printf("for (1 + (" ); + pnum( &V9 ); + printf( ") ^ (" ); + pnum( &Z ); + printf(") differs from correct value by "); + pnum( &Q ); + printf("\tThis much error may spoil financial\n"); + printf("\tcalculations involving tiny interest rates.\n"); + break; + } + else { + Z = (Y - X) * Two + Y; + X = Y; + Y = Z; + Z = One + (X - F9)*(X - F9); + if (Z > One && I < NoTrials) I++; + else { + if (X > One) { + if (N == 0) + printf("Accuracy seems adequate.\n"); + break; + } + else { + X = One + U2; + Y = U2 + U2; + Y += X; + I = 1; + } + } + } + } + /*=============================================*/ + Milestone = 150; + /*=============================================*/ + printf("Testing powers Z^Q at four nearly extreme values.\n"); + N = 0; + Z = A1; + Q = FLOOR(Half - LOG(C) / LOG(A1)); + Break = False; + do { + X = CInvrse; + Y = POW(Z, Q); + IsYeqX(); + Q = - Q; + X = C; + Y = POW(Z, Q); + IsYeqX(); + if (Z < One) Break = True; + else Z = AInvrse; + } while ( ! (Break)); + PrintIfNPositive(); + if (N == 0) printf(" ... no discrepancies found.\n"); + printf("\n"); + + /*=============================================*/ + Milestone = 160; + /*=============================================*/ + Pause(); + printf("Searching for Overflow threshold:\n"); + printf("This may generate an error.\n"); + sigsave = sigfpe; + I = 0; + Y = - CInvrse; + V9 = HInvrse * Y; + if (setjmp(ovfl_buf)) goto overflow; + do { + V = Y; + Y = V9; + V9 = HInvrse * Y; + } while(V9 < Y); + I = 1; +overflow: + Z = V9; + printf("Can `Z = -Y' overflow?\n"); + printf("Trying it on Y = " ); + pnum( &Y ); + V9 = - Y; + V0 = V9; + if (V - Y == V + V0) printf("Seems O.K.\n"); + else { + printf("finds a "); + BadCond(Flaw, "-(-Y) differs from Y.\n"); + } +#if 0 +/* this doesn't handle infinity. */ + if (Z != Y) { + BadCond(Serious, ""); + printf("overflow past " ); + pnum( &Y ); + printf( "shrinks to " ); + pnum( &Z ); + } +#endif + Y = V * (HInvrse * U2 - HInvrse); + Z = Y + ((One - HInvrse) * U2) * V; + if (Z < V0) Y = Z; + if (Y < V0) V = Y; + if (V0 - V < V0) V = V0; + printf("Overflow threshold is V = " ); + pnum( &V ); + if (I) + { + printf("Overflow saturates at V0 = " ); + pnum( &V0 ); + } + else printf("There is no saturation value because the system traps on overflow.\n"); + V9 = V * One; + printf("No Overflow should be signaled for V * 1 = " ); + pnum( &V9 ); + V9 = V / One; + printf(" nor for V / 1 = " ); + pnum( &V9 ); + printf("Any overflow signal separating this * from the one\n"); + printf("above is a DEFECT.\n"); + /*=============================================*/ + Milestone = 170; + /*=============================================*/ + if (!(-V < V && -V0 < V0 && -UfThold < V && UfThold < V)) { + BadCond(Failure, "Comparisons involving "); + printf("+-" ); + pnum( &V ); + printf( ", +- " ); + pnum( &V0 ); + printf( "and +- " ); + pnum( &UfThold ); + printf( "are confused by Overflow." ); + } + /*=============================================*/ + Milestone = 175; + /*=============================================*/ + printf("\n"); + for(Indx = 1; Indx <= 3; ++Indx) { + switch (Indx) { + case 1: Z = UfThold; break; + case 2: Z = E0; break; + case 3: Z = PseudoZero; break; + } + if (Z != Zero) { + V9 = SQRT(Z); + Y = V9 * V9; + if (Y / (One - Radix * E9) < Z + || Y > (One + Radix + E9) * Z) { + if (V9 > U1) BadCond(Serious, ""); + else BadCond(Defect, ""); + printf("Comparison alleges that what prints as Z =" ); + pnum( &Z ); + printf(" is too far from sqrt(Z) ^ 2 = "); + pnum( &Y ); + } + } + } + /*=============================================*/ + Milestone = 180; + /*=============================================*/ + for(Indx = 1; Indx <= 2; ++Indx) { + if (Indx == 1) Z = V; + else Z = V0; + V9 = SQRT(Z); + X = (One - Radix * E9) * V9; + V9 = V9 * X; + if (((V9 < (One - Two * Radix * E9) * Z) || (V9 > Z))) { + Y = V9; + if (X < W) BadCond(Serious, ""); + else BadCond(Defect, ""); + printf("Comparison alleges that Z = "); + pnum( &Z ); + printf(" is too far from sqrt(Z) ^ 2 " ); + pnum( &Y ); + } + } + /*=============================================*/ + /*SPLIT + } +#include "paranoia.h" +part8(){ +*/ + Milestone = 190; + /*=============================================*/ + Pause(); + X = UfThold * V; + Y = Radix * Radix; + if (X*Y < One || X > Y) { + if (X * Y < U1 || X > Y/U1) BadCond(Defect, "Badly"); + else BadCond(Flaw, ""); + + printf(" unbalanced range; UfThold * V = " ); + pnum( &X ); + printf( "is too far from 1.\n"); + } + /*=============================================*/ + Milestone = 200; + /*=============================================*/ + for (Indx = 1; Indx <= 5; ++Indx) { + X = F9; + switch (Indx) { + case 2: X = One + U2; break; + case 3: X = V; break; + case 4: X = UfThold; break; + case 5: X = Radix; + } + Y = X; + sigsave = sigfpe; + if (setjmp(ovfl_buf)) + { + printf(" X / X traps when X = "); + pnum( &X ); + } + else { + V9 = (Y / X - Half) - Half; + if (V9 == Zero) continue; + if (V9 == - U1 && Indx < 5) BadCond(Flaw, ""); + else BadCond(Serious, ""); + printf(" X / X differs from 1 when X ="); + pnum( &X ); + printf(" instead, X / X - 1/2 - 1/2 = "); + pnum( &V9 ); + } + } + /*=============================================*/ + Milestone = 210; + /*=============================================*/ + MyZero = Zero; + printf("\n"); + printf("What message and/or values does Division by Zero produce?\n") ; +#ifndef NOPAUSE + printf("This can interupt your program. You can "); + printf("skip this part if you wish.\n"); + printf("Do you wish to compute 1 / 0? "); + fflush(stdout); + read (KEYBOARD, ch, 8); + if ((ch[0] == 'Y') || (ch[0] == 'y')) { +#endif + sigsave = sigfpe; + printf(" Trying to compute 1 / 0 produces ..."); + if (!setjmp(ovfl_buf)) + { + Ptemp = One / MyZero; + pnum( &Ptemp ); + } +#ifndef NOPAUSE + } + else printf("O.K.\n"); + printf("\nDo you wish to compute 0 / 0? "); + fflush(stdout); + read (KEYBOARD, ch, 80); + if ((ch[0] == 'Y') || (ch[0] == 'y')) { +#endif + sigsave = sigfpe; + printf("\n Trying to compute 0 / 0 produces ..."); + if (!setjmp(ovfl_buf)) + { + Ptemp = Zero / MyZero; + pnum( &Ptemp ); + } +#ifndef NOPAUSE + } + else printf("O.K.\n"); +#endif + /*=============================================*/ + Milestone = 220; + /*=============================================*/ + Pause(); + printf("\n"); + { + static char *msg[] = { + "FAILUREs encountered =", + "SERIOUS DEFECTs discovered =", + "DEFECTs discovered =", + "FLAWs discovered =" }; + int i; + for(i = 0; i < 4; i++) if (ErrCnt[i]) + printf("The number of %-29s %d.\n", + msg[i], ErrCnt[i]); + } + printf("\n"); + if ((ErrCnt[Failure] + ErrCnt[Serious] + ErrCnt[Defect] + + ErrCnt[Flaw]) > 0) { + if ((ErrCnt[Failure] + ErrCnt[Serious] + ErrCnt[ + Defect] == 0) && (ErrCnt[Flaw] > 0)) { + printf("The arithmetic diagnosed seems "); + printf("satisfactory though flawed.\n"); + } + if ((ErrCnt[Failure] + ErrCnt[Serious] == 0) + && ( ErrCnt[Defect] > 0)) { + printf("The arithmetic diagnosed may be acceptable\n"); + printf("despite inconvenient Defects.\n"); + } + if ((ErrCnt[Failure] + ErrCnt[Serious]) > 0) { + printf("The arithmetic diagnosed has "); + printf("unacceptable serious defects.\n"); + } + if (ErrCnt[Failure] > 0) { + printf("Fatal FAILURE may have spoiled this"); + printf(" program's subsequent diagnoses.\n"); + } + } + else { + printf("No failures, defects nor flaws have been discovered.\n"); + if (! ((RMult == Rounded) && (RDiv == Rounded) + && (RAddSub == Rounded) && (RSqrt == Rounded))) + printf("The arithmetic diagnosed seems satisfactory.\n"); + else { + if (StickyBit >= One && + (Radix - Two) * (Radix - Nine - One) == Zero) { + printf("Rounding appears to conform to "); + printf("the proposed IEEE standard P"); + if ((Radix == Two) && + ((Precision - Four * Three * Two) * + ( Precision - TwentySeven - + TwentySeven + One) == Zero)) + printf("754"); + else printf("854"); + if (IEEE) printf(".\n"); + else { + printf(",\nexcept for possibly Double Rounding"); + printf(" during Gradual Underflow.\n"); + } + } + printf("The arithmetic diagnosed appears to be excellent!\n"); + } + } + if (fpecount) + printf("\nA total of %d floating point exceptions were registered.\n", + fpecount); + printf("END OF TEST.\n"); + } + +/*SPLIT subs.c +#include "paranoia.h" +*/ + +/* Sign */ + +FLOAT Sign (X) +FLOAT X; +{ return X >= 0. ? 1.0 : -1.0; } + +/* Pause */ + +Pause() +{ + char ch[8]; + +#ifndef NOPAUSE + printf("\nTo continue, press RETURN"); + fflush(stdout); + read(KEYBOARD, ch, 8); +#endif + printf("\nDiagnosis resumes after milestone Number %d", Milestone); + printf(" Page: %d\n\n", PageNo); + ++Milestone; + ++PageNo; + } + + /* TstCond */ + +TstCond (K, Valid, T) +int K, Valid; +char *T; +{ if (! Valid) { BadCond(K,T); printf(".\n"); } } + +BadCond(K, T) +int K; +char *T; +{ + static char *msg[] = { "FAILURE", "SERIOUS DEFECT", "DEFECT", "FLAW" }; + + ErrCnt [K] = ErrCnt [K] + 1; + printf("%s: %s", msg[K], T); + } + +/* Random */ +/* Random computes + X = (Random1 + Random9)^5 + Random1 = X - FLOOR(X) + 0.000005 * X; + and returns the new value of Random1 +*/ + +FLOAT Random() +{ + FLOAT X, Y; + + X = Random1 + Random9; + Y = X * X; + Y = Y * Y; + X = X * Y; + Y = X - FLOOR(X); + Random1 = Y + X * 0.000005; + return(Random1); + } + +/* SqXMinX */ + +SqXMinX (ErrKind) +int ErrKind; +{ + FLOAT XA, XB; + + XB = X * BInvrse; + XA = X - XB; + SqEr = ((SQRT(X * X) - XB) - XA) / OneUlp; + if (SqEr != Zero) { + if (SqEr < MinSqEr) MinSqEr = SqEr; + if (SqEr > MaxSqEr) MaxSqEr = SqEr; + J = J + 1.0; + BadCond(ErrKind, "\n"); + printf("sqrt( "); + Ptemp = X * X; + pnum( &Ptemp ); + printf( ") - " ); + pnum( &X ); + printf(" = " ); + Ptemp = OneUlp * SqEr; + pnum( &Ptemp ); + printf("\tinstead of correct value 0 .\n"); + } + } + +/* NewD */ + +NewD() +{ + X = Z1 * Q; + X = FLOOR(Half - X / Radix) * Radix + X; + Q = (Q - X * Z) / Radix + X * X * (D / Radix); + Z = Z - Two * X * D; + if (Z <= Zero) { + Z = - Z; + Z1 = - Z1; + } + D = Radix * D; + } + +/* SR3750 */ + +SR3750() +{ + if (! ((X - Radix < Z2 - Radix) || (X - Z2 > W - Z2))) { + I = I + 1; + X2 = SQRT(X * D); + Y2 = (X2 - Z2) - (Y - Z2); + X2 = X8 / (Y - Half); + X2 = X2 - Half * X2 * X2; + SqEr = (Y2 + Half) + (Half - X2); + if (SqEr < MinSqEr) MinSqEr = SqEr; + SqEr = Y2 - X2; + if (SqEr > MaxSqEr) MaxSqEr = SqEr; + } + } + +/* IsYeqX */ + +IsYeqX() +{ + if (Y != X) { + if (N <= 0) { + if (Z == Zero && Q <= Zero) + printf("WARNING: computing\n"); + else BadCond(Defect, "computing\n"); + printf("\t("); + pnum( &Z ); + printf( ") ^ (" ); + pnum( &Q ); + printf("\tyielded " ); + pnum( &Y ); + printf("\twhich compared unequal to correct " ); + pnum( &X ); + printf("\t\tthey differ by " ); + Ptemp = Y - X; + pnum( &Ptemp ); + } + N = N + 1; /* ... count discrepancies. */ + } + } + +/* SR3980 */ + +SR3980() +{ + do { + Q = (FLOAT) I; + Y = POW(Z, Q); + IsYeqX(); + if (++I > M) break; + X = Z * X; + } while ( X < W ); + } + +/* PrintIfNPositive */ + +PrintIfNPositive() +{ + if (N > 0) printf("Similar discrepancies have occurred %d times.\n", N); + } + +/* TstPtUf */ + +TstPtUf() +{ + N = 0; + if (Z != Zero) { + printf("Since comparison denies Z = 0, evaluating "); + printf("(Z + Z) / Z should be safe.\n"); + sigsave = sigfpe; + if (setjmp(ovfl_buf)) goto very_serious; + Q9 = (Z + Z) / Z; + printf("What the machine gets for (Z + Z) / Z is " ); + pnum( &Q9 ); + if (FABS(Q9 - Two) < Radix * U2) { + printf("This is O.K., provided Over/Underflow"); + printf(" has NOT just been signaled.\n"); + } + else { + if ((Q9 < One) || (Q9 > Two)) { +very_serious: + N = 1; + ErrCnt [Serious] = ErrCnt [Serious] + 1; + printf("This is a VERY SERIOUS DEFECT!\n"); + } + else { + N = 1; + ErrCnt [Defect] = ErrCnt [Defect] + 1; + printf("This is a DEFECT!\n"); + } + } + V9 = Z * One; + Random1 = V9; + V9 = One * Z; + Random2 = V9; + V9 = Z / One; + if ((Z == Random1) && (Z == Random2) && (Z == V9)) { + if (N > 0) Pause(); + } + else { + N = 1; + BadCond(Defect, "What prints as Z = "); + pnum( &Z ); + printf("\tcompares different from "); + if (Z != Random1) + { + printf("Z * 1 = " ); + pnum( &Random1 ); + } + if (! ((Z == Random2) + || (Random2 == Random1))) + { + printf("1 * Z == " ); + pnum( &Random2 ); + } + if (! (Z == V9)) + { + printf("Z / 1 = "); + pnum( &V9 ); + } + if (Random2 != Random1) { + ErrCnt [Defect] = ErrCnt [Defect] + 1; + BadCond(Defect, "Multiplication does not commute!\n"); + printf("\tComparison alleges that 1 * Z = "); + pnum( &Random2 ); + printf("\tdiffers from Z * 1 = "); + pnum( &Random1 ); + } + Pause(); + } + } + } + +notify(s) +char *s; +{ + printf("%s test appears to be inconsistent...\n", s); + printf(" PLEASE NOTIFY KARPINKSI!\n"); + } + +/*SPLIT msgs.c */ + +/* Instructions */ + +msglist(s) +char **s; +{ while(*s) printf("%s\n", *s++); } + +Instructions() +{ + static char *instr[] = { + "Lest this program stop prematurely, i.e. before displaying\n", + " `END OF TEST',\n", + "try to persuade the computer NOT to terminate execution when an", + "error like Over/Underflow or Division by Zero occurs, but rather", + "to persevere with a surrogate value after, perhaps, displaying some", + "warning. If persuasion avails naught, don't despair but run this", + "program anyway to see how many milestones it passes, and then", + "amend it to make further progress.\n", + "Answer questions with Y, y, N or n (unless otherwise indicated).\n", + 0}; + + msglist(instr); + } + +/* Heading */ + +Heading() +{ + static char *head[] = { + "Users are invited to help debug and augment this program so it will", + "cope with unanticipated and newly uncovered arithmetic pathologies.\n", + "Please send suggestions and interesting results to", + "\tRichard Karpinski", + "\tComputer Center U-76", + "\tUniversity of California", + "\tSan Francisco, CA 94143-0704, USA\n", + "In doing so, please include the following information:", +#ifdef Single + "\tPrecision:\tsingle;", +#else + "\tPrecision:\tdouble;", +#endif + "\tVersion:\t27 January 1986;", + "\tComputer:\n", + "\tCompiler:\n", + "\tOptimization level:\n", + "\tOther relevant compiler options:", + 0}; + + msglist(head); + } + +/* Characteristics */ + +Characteristics() +{ + static char *chars[] = { + "Running this program should reveal these characteristics:", + " Radix = 1, 2, 4, 8, 10, 16, 100, 256 ...", + " Precision = number of significant digits carried.", + " U2 = Radix/Radix^Precision = One Ulp", + "\t(OneUlpnit in the Last Place) of 1.000xxx .", + " U1 = 1/Radix^Precision = One Ulp of numbers a little less than 1.0 .", + " Adequacy of guard digits for Mult., Div. and Subt.", + " Whether arithmetic is chopped, correctly rounded, or something else", + "\tfor Mult., Div., Add/Subt. and Sqrt.", + " Whether a Sticky Bit used correctly for rounding.", + " UnderflowThreshold = an underflow threshold.", + " E0 and PseudoZero tell whether underflow is abrupt, gradual, or fuzzy.", + " V = an overflow threshold, roughly.", + " V0 tells, roughly, whether Infinity is represented.", + " Comparisions are checked for consistency with subtraction", + "\tand for contamination with pseudo-zeros.", + " Sqrt is tested. Y^X is not tested.", + " Extra-precise subexpressions are revealed but NOT YET tested.", + " Decimal-Binary conversion is NOT YET tested for accuracy.", + 0}; + + msglist(chars); + } + +History() + +{ /* History */ + /* Converted from Brian Wichmann's Pascal version to C by Thos Sumner, + with further massaging by David M. Gay. */ + + static char *hist[] = { + "The program attempts to discriminate among", + " FLAWs, like lack of a sticky bit,", + " Serious DEFECTs, like lack of a guard digit, and", + " FAILUREs, like 2+2 == 5 .", + "Failures may confound subsequent diagnoses.\n", + "The diagnostic capabilities of this program go beyond an earlier", + "program called `MACHAR', which can be found at the end of the", + "book `Software Manual for the Elementary Functions' (1980) by", + "W. J. Cody and W. Waite. Although both programs try to discover", + "the Radix, Precision and range (over/underflow thresholds)", + "of the arithmetic, this program tries to cope with a wider variety", + "of pathologies, and to say how well the arithmetic is implemented.", + "\nThe program is based upon a conventional radix representation for", + "floating-point numbers, but also allows logarithmic encoding", + "as used by certain early WANG machines.\n", + "BASIC version of this program (C) 1983 by Prof. W. M. Kahan;", + "see source comments for more history.", + 0}; + + msglist(hist); + } diff --git a/libm/ldouble/monotl.c b/libm/ldouble/monotl.c new file mode 100644 index 000000000..86b85eca1 --- /dev/null +++ b/libm/ldouble/monotl.c @@ -0,0 +1,307 @@ + +/* monot.c + Floating point function test vectors. + + Arguments and function values are synthesized for NPTS points in + the vicinity of each given tabulated test point. The points are + chosen to be near and on either side of the likely function algorithm + domain boundaries. Since the function programs change their methods + at these points, major coding errors or monotonicity failures might be + detected. + + August, 1998 + S. L. Moshier */ + + +#include <stdio.h> + +/* Avoid including math.h. */ +long double frexpl (long double, int *); +long double ldexpl (long double, int); + +/* Number of test points to generate on each side of tabulated point. */ +#define NPTS 100 + +/* Functions of one variable. */ +long double expl (long double); +long double logl (long double); +long double sinl (long double); +long double cosl (long double); +long double tanl (long double); +long double atanl (long double); +long double asinl (long double); +long double acosl (long double); +long double sinhl (long double); +long double coshl (long double); +long double tanhl (long double); +long double asinhl (long double); +long double acoshl (long double); +long double atanhl (long double); +long double gammal (long double); +long double fabsl (long double); +long double floorl (long double); + +struct oneargument + { + char *name; /* Name of the function. */ + long double (*func) (long double); + long double arg1; /* Function argument, assumed exact. */ + long double answer1; /* Exact, close to function value. */ + long double answer2; /* answer1 + answer2 has extended precision. */ + long double derivative; /* dy/dx evaluated at x = arg1. */ + int thresh; /* Error report threshold. 2 = 1 ULP approx. */ + }; + +/* Add this to error threshold test[i].thresh. */ +#define OKERROR 2 + +/* Unit of relative error in test[i].thresh. */ +static long double MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; + +/* extern double MACHEP; */ + + +struct oneargument test1[] = +{ + {"exp", expl, 1.0L, 2.7182769775390625L, + 4.85091998273536028747e-6L, 2.71828182845904523536L, 1}, + {"exp", expl, -1.0L, 3.678741455078125e-1L, + 5.29566362982159552377e-6L, 3.678794411714423215955e-1L, 1}, + {"exp", expl, 0.5L, 1.648712158203125L, + 9.1124970031468486507878e-6L, 1.64872127070012814684865L, 1}, + {"exp", expl, -0.5L, 6.065216064453125e-1L, + 9.0532673209236037995e-6L, 6.0653065971263342360e-1L, 1}, + {"exp", expl, 2.0L, 7.3890533447265625L, + 2.75420408772723042746e-6L, 7.38905609893065022723L, 1}, + {"exp", expl, -2.0L, 1.353302001953125e-1L, + 5.08304130019189399949e-6L, 1.3533528323661269189e-1L, 1}, + {"log", logl, 1.41421356237309492343L, 3.465728759765625e-1L, + 7.1430341006605745676897e-7L, 7.0710678118654758708668e-1L, 1}, + {"log", logl, 7.07106781186547461715e-1L, -3.46588134765625e-1L, + 1.45444856522566402246e-5L, 1.41421356237309517417L, 1}, + {"sin", sinl, 7.85398163397448278999e-1L, 7.0709228515625e-1L, + 1.4496030297502751942956e-5L, 7.071067811865475460497e-1L, 1}, + {"sin", sinl, -7.85398163397448501044e-1L, -7.071075439453125e-1L, + 7.62758764840238811175e-7L, 7.07106781186547389040e-1L, 1}, + {"sin", sinl, 1.570796326794896558L, 9.999847412109375e-1L, + 1.52587890625e-5L, 6.12323399573676588613e-17L, 1}, + {"sin", sinl, -1.57079632679489678004L, -1.0L, + 1.29302922820150306903e-32L, -1.60812264967663649223e-16L, 1}, + {"sin", sinl, 4.712388980384689674L, -1.0L, + 1.68722975549458979398e-32L, -1.83697019872102976584e-16L, 1}, + {"sin", sinl, -4.71238898038468989604L, 9.999847412109375e-1L, + 1.52587890625e-5L, 3.83475850529283315008e-17L, 1}, + {"cos", cosl, 3.92699081698724139500E-1L, 9.23873901367187500000E-1L, + 5.63114409926198633370E-6L, -3.82683432365089757586E-1L, 1}, + {"cos", cosl, 7.85398163397448278999E-1L, 7.07092285156250000000E-1L, + 1.44960302975460497458E-5L, -7.07106781186547502752E-1L, 1}, + {"cos", cosl, 1.17809724509617241850E0L, 3.82675170898437500000E-1L, + 8.26146665231415693919E-6L, -9.23879532511286738554E-1L, 1}, + {"cos", cosl, 1.96349540849362069750E0L, -3.82690429687500000000E-1L, + 6.99732241029898567203E-6L, -9.23879532511286785419E-1L, 1}, + {"cos", cosl, 2.35619449019234483700E0L, -7.07107543945312500000E-1L, + 7.62758765040545859856E-7L, -7.07106781186547589348E-1L, 1}, + {"cos", cosl, 2.74889357189106897650E0L, -9.23889160156250000000E-1L, + 9.62764496328487887036E-6L, -3.82683432365089870728E-1L, 1}, + {"cos", cosl, 3.14159265358979311600E0L, -1.00000000000000000000E0L, + 7.49879891330928797323E-33L, -1.22464679914735317723E-16L, 1}, + {"tan", tanl, 7.85398163397448278999E-1L, 9.999847412109375e-1L, + 1.52587890624387676600E-5L, 1.99999999999999987754E0L, 1}, + {"tan", tanl, 1.17809724509617241850E0L, 2.41419982910156250000E0L, + 1.37332715322352112604E-5L, 6.82842712474618858345E0L, 1}, + {"tan", tanl, 1.96349540849362069750E0L, -2.41421508789062500000E0L, + 1.52551752942854759743E-6L, 6.82842712474619262118E0L, 1}, + {"tan", tanl, 2.35619449019234483700E0L, -1.00001525878906250000E0L, + 1.52587890623163029801E-5L, 2.00000000000000036739E0L, 1}, + {"tan", tanl, 2.74889357189106897650E0L, -4.14215087890625000000E-1L, + 1.52551752982565655126E-6L, 1.17157287525381000640E0L, 1}, + {"atan", atanl, 4.14213562373094923430E-1L, 3.92684936523437500000E-1L, + 1.41451752865477964149E-5L, 8.53553390593273837869E-1L, 1}, + {"atan", atanl, 1.0L, 7.85385131835937500000E-1L, + 1.30315615108096156608E-5L, 0.5L, 1}, + {"atan", atanl, 2.41421356237309492343E0L, 1.17808532714843750000E0L, + 1.19179477349460632350E-5L, 1.46446609406726250782E-1L, 1}, + {"atan", atanl, -2.41421356237309514547E0L, -1.17810058593750000000E0L, + 3.34084132752141908545E-6L, 1.46446609406726227789E-1L, 1}, + {"atan", atanl, -1.0L, -7.85400390625000000000E-1L, + 2.22722755169038433915E-6L, 0.5L, 1}, + {"atan", atanl, -4.14213562373095145475E-1L, -3.92700195312500000000E-1L, + 1.11361377576267665972E-6L, 8.53553390593273703853E-1L, 1}, + {"asin", asinl, 3.82683432365089615246E-1L, 3.92684936523437500000E-1L, + 1.41451752864854321970E-5L, 1.08239220029239389286E0L, 1}, + {"asin", asinl, 0.5L, 5.23590087890625000000E-1L, + 8.68770767387307710723E-6L, 1.15470053837925152902E0L, 1}, + {"asin", asinl, 7.07106781186547461715E-1L, 7.85385131835937500000E-1L, + 1.30315615107209645016E-5L, 1.41421356237309492343E0L, 1}, + {"asin", asinl, 9.23879532511286738483E-1L, 1.17808532714843750000E0L, + 1.19179477349183147612E-5L, 2.61312592975275276483E0L, 1}, + {"asin", asinl, -0.5L, -5.23605346679687500000E-1L, + 6.57108138862692289277E-6L, 1.15470053837925152902E0L, 1}, + {"acos", acosl, 1.95090322016128192573E-1L, 1.37443542480468750000E0L, + 1.13611408471185777914E-5L, -1.01959115820831832232E0L, 1}, + {"acos", acosl, 3.82683432365089615246E-1L, 1.17808532714843750000E0L, + 1.19179477351337991247E-5L, -1.08239220029239389286E0L, 1}, + {"acos", acosl, 0.5L, 1.04719543457031250000E0L, + 2.11662628524615421446E-6L, -1.15470053837925152902E0L, 1}, + {"acos", acosl, 7.07106781186547461715E-1L, 7.85385131835937500000E-1L, + 1.30315615108982668201E-5L, -1.41421356237309492343E0L, 1}, + {"acos", acosl, 9.23879532511286738483E-1L, 3.92684936523437500000E-1L, + 1.41451752867009165605E-5L, -2.61312592975275276483E0L, 1}, + {"acos", acosl, 9.80785280403230430579E-1L, 1.96334838867187500000E-1L, + 1.47019821746724723933E-5L, -5.12583089548300990774E0L, 1}, + {"acos", acosl, -0.5L, 2.09439086914062500000E0L, + 4.23325257049230842892E-6L, -1.15470053837925152902E0L, 1}, + {"sinh", sinhl, 1.0L, 1.17518615722656250000E0L, + 1.50364172389568823819E-5L, 1.54308063481524377848E0L, 1}, + {"sinh", sinhl, 7.09089565712818057364E2L, 4.49423283712885057274E307L, + 4.25947714184369757620E208L, 4.49423283712885057274E307L, 1}, + {"sinh", sinhl, 2.22044604925031308085E-16L, 0.00000000000000000000E0L, + 2.22044604925031308085E-16L, 1.00000000000000000000E0L, 1}, + {"cosh", coshl, 7.09089565712818057364E2L, 4.49423283712885057274E307L, + 4.25947714184369757620E208L, 4.49423283712885057274E307L, 1}, + {"cosh", coshl, 1.0L, 1.54307556152343750000E0L, + 5.07329180627847790562E-6L, 1.17520119364380145688E0L, 1}, + {"cosh", coshl, 0.5L, 1.12762451171875000000E0L, + 1.45348763078522622516E-6L, 5.21095305493747361622E-1L, 1}, + {"tanh", tanhl, 0.5L, 4.62112426757812500000E-1L, + 4.73050219725850231848E-6L, 7.86447732965927410150E-1L, 1}, + {"tanh", tanhl, 5.49306144334054780032E-1L, 4.99984741210937500000E-1L, + 1.52587890624507506378E-5L, 7.50000000000000049249E-1L, 1}, + {"tanh", tanhl, 0.625L, 5.54595947265625000000E-1L, + 3.77508375729399903910E-6L, 6.92419147969988069631E-1L, 1}, + {"asinh", asinhl, 0.5L, 4.81201171875000000000E-1L, + 1.06531846034474977589E-5L, 8.94427190999915878564E-1L, 1}, + {"asinh", asinhl, 1.0L, 8.81362915039062500000E-1L, + 1.06719804805252326093E-5L, 7.07106781186547524401E-1L, 1}, + {"asinh", asinhl, 2.0L, 1.44363403320312500000E0L, + 1.44197568534249327674E-6L, 4.47213595499957939282E-1L, 1}, + {"acosh", acoshl, 2.0L, 1.31695556640625000000E0L, + 2.33051856670862504635E-6L, 5.77350269189625764509E-1L, 1}, + {"acosh", acoshl, 1.5L, 9.62417602539062500000E-1L, + 6.04758014439499551783E-6L, 8.94427190999915878564E-1L, 1}, + {"acosh", acoshl, 1.03125L, 2.49343872070312500000E-1L, + 9.62177257298785143908E-6L, 3.96911150685467059809E0L, 1}, + {"atanh", atanhl, 0.5L, 5.49301147460937500000E-1L, + 4.99687311734569762262E-6L, 1.33333333333333333333E0L, 1}, +#if 0 + {"gamma", gammal, 1.0L, 1.0L, + 0.0L, -5.772156649015328606e-1L, 1}, + {"gamma", gammal, 2.0L, 1.0L, + 0.0L, 4.2278433509846713939e-1L, 1}, + {"gamma", gammal, 3.0L, 2.0L, + 0.0L, 1.845568670196934279L, 1}, + {"gamma", gammal, 4.0L, 6.0L, + 0.0L, 7.536706010590802836L, 1}, +#endif + {"null", NULL, 0.0L, 0.0L, 0.0L, 1}, +}; + +/* These take care of extra-precise floating point register problems. */ +volatile long double volat1; +volatile long double volat2; + + +/* Return the next nearest floating point value to X + in the direction of UPDOWN (+1 or -1). + (Fails if X is denormalized.) */ + +long double +nextval (x, updown) + long double x; + int updown; +{ + long double m; + int i; + + volat1 = x; + m = 0.25L * MACHEPL * volat1 * updown; + volat2 = volat1 + m; + if (volat2 != volat1) + printf ("successor failed\n"); + + for (i = 2; i < 10; i++) + { + volat2 = volat1 + i * m; + if (volat1 != volat2) + return volat2; + } + + printf ("nextval failed\n"); + return volat1; +} + + + + +int +main () +{ + long double (*fun1) (long double); + int i, j, errs, tests; + long double x, x0, y, dy, err; + + errs = 0; + tests = 0; + i = 0; + + for (;;) + { + fun1 = test1[i].func; + if (fun1 == NULL) + break; + volat1 = test1[i].arg1; + x0 = volat1; + x = volat1; + for (j = 0; j <= NPTS; j++) + { + volat1 = x - x0; + dy = volat1 * test1[i].derivative; + dy = test1[i].answer2 + dy; + volat1 = test1[i].answer1 + dy; + volat2 = (*(fun1)) (x); + if (volat2 != volat1) + { + /* Report difference between program result + and extended precision function value. */ + err = volat2 - test1[i].answer1; + err = err - dy; + err = err / volat1; + if (fabsl (err) > ((OKERROR + test1[i].thresh) * MACHEPL)) + { + printf ("%d %s(%.19Le) = %.19Le, rel err = %.3Le\n", + j, test1[i].name, x, volat2, err); + errs += 1; + } + } + x = nextval (x, 1); + tests += 1; + } + + x = x0; + x = nextval (x, -1); + for (j = 1; j < NPTS; j++) + { + volat1 = x - x0; + dy = volat1 * test1[i].derivative; + dy = test1[i].answer2 + dy; + volat1 = test1[i].answer1 + dy; + volat2 = (*(fun1)) (x); + if (volat2 != volat1) + { + err = volat2 - test1[i].answer1; + err = err - dy; + err = err / volat1; + if (fabsl (err) > ((OKERROR + test1[i].thresh) * MACHEPL)) + { + printf ("%d %s(%.19Le) = %.19Le, rel err = %.3Le\n", + j, test1[i].name, x, volat2, err); + errs += 1; + } + } + x = nextval (x, -1); + tests += 1; + } + i += 1; + } + printf ("%d errors in %d tests\n", errs, tests); +} diff --git a/libm/ldouble/mtherr.c b/libm/ldouble/mtherr.c new file mode 100644 index 000000000..17d0485d2 --- /dev/null +++ b/libm/ldouble/mtherr.c @@ -0,0 +1,102 @@ +/* mtherr.c + * + * Library common error handling routine + * + * + * + * SYNOPSIS: + * + * char *fctnam; + * int code; + * int mtherr(); + * + * mtherr( fctnam, code ); + * + * + * + * DESCRIPTION: + * + * This routine may be called to report one of the following + * error conditions (in the include file mconf.h). + * + * Mnemonic Value Significance + * + * DOMAIN 1 argument domain error + * SING 2 function singularity + * OVERFLOW 3 overflow range error + * UNDERFLOW 4 underflow range error + * TLOSS 5 total loss of precision + * PLOSS 6 partial loss of precision + * EDOM 33 Unix domain error code + * ERANGE 34 Unix range error code + * + * The default version of the file prints the function name, + * passed to it by the pointer fctnam, followed by the + * error condition. The display is directed to the standard + * output device. The routine then returns to the calling + * program. Users may wish to modify the program to abort by + * calling exit() under severe error conditions such as domain + * errors. + * + * Since all error conditions pass control to this function, + * the display may be easily changed, eliminated, or directed + * to an error logging device. + * + * SEE ALSO: + * + * mconf.h + * + */ + +/* +Cephes Math Library Release 2.0: April, 1987 +Copyright 1984, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <stdio.h> +#include <math.h> + +int merror = 0; + +/* Notice: the order of appearance of the following + * messages is bound to the error codes defined + * in mconf.h. + */ +static char *ermsg[7] = { +"unknown", /* error code 0 */ +"domain", /* error code 1 */ +"singularity", /* et seq. */ +"overflow", +"underflow", +"total loss of precision", +"partial loss of precision" +}; + + +int mtherr( name, code ) +char *name; +int code; +{ + +/* Display string passed by calling program, + * which is supposed to be the name of the + * function in which the error occurred: + */ +printf( "\n%s ", name ); + +/* Set global error message word */ +merror = code; + +/* Display error message defined + * by the code argument. + */ +if( (code <= 0) || (code >= 7) ) + code = 0; +printf( "%s error\n", ermsg[code] ); + +/* Return to calling + * program + */ +return( 0 ); +} diff --git a/libm/ldouble/mtstl.c b/libm/ldouble/mtstl.c new file mode 100644 index 000000000..0cd6eed16 --- /dev/null +++ b/libm/ldouble/mtstl.c @@ -0,0 +1,521 @@ +/* mtst.c + Consistency tests for math functions. + + With NTRIALS=10000, the following are typical results for + an alleged IEEE long double precision arithmetic: + +Consistency test of math functions. +Max and rms errors for 10000 random arguments. +A = absolute error criterion (but relative if >1): +Otherwise, estimate is of relative error +x = cbrt( cube(x) ): max = 7.65E-20 rms = 4.39E-21 +x = atan( tan(x) ): max = 2.01E-19 rms = 3.96E-20 +x = sin( asin(x) ): max = 2.15E-19 rms = 3.00E-20 +x = sqrt( square(x) ): max = 0.00E+00 rms = 0.00E+00 +x = log( exp(x) ): max = 5.42E-20 A rms = 1.87E-21 A +x = log2( exp2(x) ): max = 1.08E-19 A rms = 3.37E-21 A +x = log10( exp10(x) ): max = 2.71E-20 A rms = 6.76E-22 A +x = acosh( cosh(x) ): max = 3.13E-18 A rms = 3.21E-20 A +x = pow( pow(x,a),1/a ): max = 1.25E-17 rms = 1.70E-19 +x = tanh( atanh(x) ): max = 1.08E-19 rms = 1.16E-20 +x = asinh( sinh(x) ): max = 1.03E-19 rms = 2.94E-21 +x = cos( acos(x) ): max = 1.63E-19 A rms = 4.37E-20 A +lgam(x) = log(gamma(x)): max = 2.31E-19 A rms = 5.93E-20 A +x = ndtri( ndtr(x) ): max = 5.07E-17 rms = 7.03E-19 +Legendre ellpk, ellpe: max = 7.59E-19 A rms = 1.72E-19 A +Absolute error and only 2000 trials: +Wronksian of Yn, Jn: max = 6.40E-18 A rms = 1.49E-19 A +Relative error and only 100 trials: +x = stdtri(stdtr(k,x) ): max = 6.73E-19 rms = 2.46E-19 +*/ + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1984, 1987, 1988, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +/* C9X spells lgam lgamma. */ +#define GLIBC2 0 + +#define NTRIALS 10000 +#define WTRIALS (NTRIALS/5) +#define STRTST 0 + +/* Note, fabsl may be an intrinsic function. */ +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double sqrtl ( long double ); +extern long double cbrtl ( long double ); +extern long double expl ( long double ); +extern long double logl ( long double ); +extern long double tanl ( long double ); +extern long double atanl ( long double ); +extern long double sinl ( long double ); +extern long double asinl ( long double ); +extern long double cosl ( long double ); +extern long double acosl ( long double ); +extern long double powl ( long double, long double ); +extern long double tanhl ( long double ); +extern long double atanhl ( long double ); +extern long double sinhl ( long double ); +extern long double asinhl ( long double ); +extern long double coshl ( long double ); +extern long double acoshl ( long double ); +extern long double exp2l ( long double ); +extern long double log2l ( long double ); +extern long double exp10l ( long double ); +extern long double log10l ( long double ); +extern long double gammal ( long double ); +extern long double lgaml ( long double ); +extern long double jnl ( int, long double ); +extern long double ynl ( int, long double ); +extern long double ndtrl ( long double ); +extern long double ndtril ( long double ); +extern long double stdtrl ( int, long double ); +extern long double stdtril ( int, long double ); +extern long double ellpel ( long double ); +extern long double ellpkl ( long double ); +extern void exit (int); +#else +long double fabsl(), sqrtl(); +long double cbrtl(), expl(), logl(), tanl(), atanl(); +long double sinl(), asinl(), cosl(), acosl(), powl(); +long double tanhl(), atanhl(), sinhl(), asinhl(), coshl(), acoshl(); +long double exp2l(), log2l(), exp10l(), log10l(); +long double gammal(), lgaml(), jnl(), ynl(), ndtrl(), ndtril(); +long double stdtrl(), stdtril(), ellpel(), ellpkl(); +void exit (); +#endif +extern int merror; +#if GLIBC2 +long double lgammal(long double); +#endif +/* +NYI: +double iv(), kn(); +*/ + +/* Provide inverses for square root and cube root: */ +long double squarel(x) +long double x; +{ +return( x * x ); +} + +long double cubel(x) +long double x; +{ +return( x * x * x ); +} + +/* lookup table for each function */ +struct fundef + { + char *nam1; /* the function */ + long double (*name )(); + char *nam2; /* its inverse */ + long double (*inv )(); + int nargs; /* number of function arguments */ + int tstyp; /* type code of the function */ + long ctrl; /* relative error flag */ + long double arg1w; /* width of domain for 1st arg */ + long double arg1l; /* lower bound domain 1st arg */ + long arg1f; /* flags, e.g. integer arg */ + long double arg2w; /* same info for args 2, 3, 4 */ + long double arg2l; + long arg2f; +/* + double arg3w; + double arg3l; + long arg3f; + double arg4w; + double arg4l; + long arg4f; +*/ + }; + + +/* fundef.ctrl bits: */ +#define RELERR 1 +#define EXPSCAL 4 + +/* fundef.tstyp test types: */ +#define POWER 1 +#define ELLIP 2 +#define GAMMA 3 +#define WRONK1 4 +#define WRONK2 5 +#define WRONK3 6 +#define STDTR 7 + +/* fundef.argNf argument flag bits: */ +#define INT 2 + +extern long double MINLOGL; +extern long double MAXLOGL; +extern long double PIL; +extern long double PIO2L; +/* +define MINLOG -170.0 +define MAXLOG +170.0 +define PI 3.14159265358979323846 +define PIO2 1.570796326794896619 +*/ + +#define NTESTS 17 +struct fundef defs[NTESTS] = { +{" cube", cubel, " cbrt", cbrtl, 1, 0, 1, 2000.0L, -1000.0L, 0, +0.0, 0.0, 0}, +{" tan", tanl, " atan", atanl, 1, 0, 1, 0.0L, 0.0L, 0, +0.0, 0.0, 0}, +{" asin", asinl, " sin", sinl, 1, 0, 1, 2.0L, -1.0L, 0, +0.0, 0.0, 0}, +{"square", squarel, " sqrt", sqrtl, 1, 0, 1, 170.0L, -85.0L, EXPSCAL, +0.0, 0.0, 0}, +{" exp", expl, " log", logl, 1, 0, 0, 340.0L, -170.0L, 0, +0.0, 0.0, 0}, +{" exp2", exp2l, " log2", log2l, 1, 0, 0, 340.0L, -170.0L, 0, +0.0, 0.0, 0}, +{" exp10", exp10l, " log10", log10l, 1, 0, 0, 340.0L, -170.0L, 0, +0.0, 0.0, 0}, +{" cosh", coshl, " acosh", acoshl, 1, 0, 0, 340.0L, 0.0L, 0, +0.0, 0.0, 0}, +{"pow", powl, "pow", powl, 2, POWER, 1, 25.0L, 0.0L, 0, +50.0, -25.0, 0}, +{" atanh", atanhl, " tanh", tanhl, 1, 0, 1, 2.0L, -1.0L, 0, +0.0, 0.0, 0}, +{" sinh", sinhl, " asinh", asinhl, 1, 0, 1, 340.0L, 0.0L, 0, +0.0, 0.0, 0}, +{" acos", acosl, " cos", cosl, 1, 0, 0, 2.0L, -1.0L, 0, +0.0, 0.0, 0}, +#if GLIBC2 + /* +{ "gamma", gammal, "lgammal", lgammal, 1, GAMMA, 0, 34.0, 0.0, 0, +0.0, 0.0, 0}, +*/ +#else +{ "gamma", gammal, "lgam", lgaml, 1, GAMMA, 0, 34.0, 0.0, 0, +0.0, 0.0, 0}, +{ " ndtr", ndtrl, " ndtri", ndtril, 1, 0, 1, 10.0L, -10.0L, 0, +0.0, 0.0, 0}, +{" ellpe", ellpel, " ellpk", ellpkl, 1, ELLIP, 0, 1.0L, 0.0L, 0, +0.0, 0.0, 0}, +{ "stdtr", stdtrl, "stdtri", stdtril, 2, STDTR, 1, 4.0L, -2.0L, 0, +30.0, 1.0, INT}, +{ " Jn", jnl, " Yn", ynl, 2, WRONK1, 0, 30.0, 0.1, 0, +40.0, -20.0, INT}, +#endif +}; + +static char *headrs[] = { +"x = %s( %s(x) ): ", +"x = %s( %s(x,a),1/a ): ", /* power */ +"Legendre %s, %s: ", /* ellip */ +"%s(x) = log(%s(x)): ", /* gamma */ +"Wronksian of %s, %s: ", /* wronk1 */ +"Wronksian of %s, %s: ", /* wronk2 */ +"Wronksian of %s, %s: ", /* wronk3 */ +"x = %s(%s(k,x) ): ", /* stdtr */ +}; + +static long double y1 = 0.0; +static long double y2 = 0.0; +static long double y3 = 0.0; +static long double y4 = 0.0; +static long double a = 0.0; +static long double x = 0.0; +static long double y = 0.0; +static long double z = 0.0; +static long double e = 0.0; +static long double max = 0.0; +static long double rmsa = 0.0; +static long double rms = 0.0; +static long double ave = 0.0; +static double da, db, dc, dd; + +int ldrand(); +int printf(); + +int +main() +{ +long double (*fun )(); +long double (*ifun )(); +struct fundef *d; +int i, k, itst; +int m, ntr; + +ntr = NTRIALS; +printf( "Consistency test of math functions.\n" ); +printf( "Max and rms errors for %d random arguments.\n", + ntr ); +printf( "A = absolute error criterion (but relative if >1):\n" ); +printf( "Otherwise, estimate is of relative error\n" ); + +/* Initialize machine dependent parameters to test near the + * largest an smallest possible arguments. To compare different + * machines, use the same test intervals for all systems. + */ +defs[1].arg1w = PIL; +defs[1].arg1l = -PIL/2.0; +/* +defs[3].arg1w = MAXLOGL; +defs[3].arg1l = -MAXLOGL/2.0; +defs[4].arg1w = 2.0*MAXLOGL; +defs[4].arg1l = -MAXLOGL; +defs[6].arg1w = 2.0*MAXLOGL; +defs[6].arg1l = -MAXLOGL; +defs[7].arg1w = MAXLOGL; +defs[7].arg1l = 0.0; +*/ + +/* Outer loop, on the test number: */ + +for( itst=STRTST; itst<NTESTS; itst++ ) +{ +d = &defs[itst]; +m = 0; +max = 0.0L; +rmsa = 0.0L; +ave = 0.0L; +fun = d->name; +ifun = d->inv; + +/* Smaller number of trials for Wronksians + * (put them at end of list) + */ +if( d->tstyp == WRONK1 ) + { + ntr = WTRIALS; + printf( "Absolute error and only %d trials:\n", ntr ); + } +else if( d->tstyp == STDTR ) + { + ntr = NTRIALS/100; + printf( "Relative error and only %d trials:\n", ntr ); + } +/* +y1 = d->arg1l; +y2 = d->arg1w; +da = y1; +db = y2; +printf( "arg1l = %.4e, arg1w = %.4e\n", da, db ); +*/ +printf( headrs[d->tstyp], d->nam2, d->nam1 ); + +for( i=0; i<ntr; i++ ) +{ +m++; +k = 0; +/* make random number(s) in desired range(s) */ +switch( d->nargs ) +{ + +default: +goto illegn; + +case 2: +ldrand( &a ); +a = d->arg2w * ( a - 1.0L ) + d->arg2l; +if( d->arg2f & EXPSCAL ) + { + a = expl(a); + ldrand( &y2 ); + a -= 1.0e-13L * a * (y2 - 1.0L); + } +if( d->arg2f & INT ) + { + k = a + 0.25L; + a = k; + } + +case 1: +ldrand( &x ); +y1 = d->arg1l; +y2 = d->arg1w; +x = y2 * ( x - 1.0L ) + y1; +if( x < y1 ) + x = y1; +y1 += y2; +if( x > y1 ) + x = y1; +if( d->arg1f & EXPSCAL ) + { + x = expl(x); + ldrand( &y2 ); + x += 1.0e-13L * x * (y2 - 1.0L); + } +} + +/* compute function under test */ +switch( d->nargs ) + { + case 1: + switch( d->tstyp ) + { + case ELLIP: + y1 = ( *(fun) )(x); + y2 = ( *(fun) )(1.0L-x); + y3 = ( *(ifun) )(x); + y4 = ( *(ifun) )(1.0L-x); + break; +#if 1 + case GAMMA: + y = lgaml(x); + x = logl( gammal(x) ); + break; +#endif + default: + z = ( *(fun) )(x); + y = ( *(ifun) )(z); + } +/* +if( merror ) + { + printf( "error: x = %.15e, z = %.15e, y = %.15e\n", + (double )x, (double )z, (double )y ); + } +*/ + break; + + case 2: + if( d->arg2f & INT ) + { + switch( d->tstyp ) + { + case WRONK1: + y1 = (*fun)( k, x ); /* jn */ + y2 = (*fun)( k+1, x ); + y3 = (*ifun)( k, x ); /* yn */ + y4 = (*ifun)( k+1, x ); + break; + + case WRONK2: + y1 = (*fun)( a, x ); /* iv */ + y2 = (*fun)( a+1.0L, x ); + y3 = (*ifun)( k, x ); /* kn */ + y4 = (*ifun)( k+1, x ); + break; + + default: + z = (*fun)( k, x ); + y = (*ifun)( k, z ); + } + } + else + { + if( d->tstyp == POWER ) + { + z = (*fun)( x, a ); + y = (*ifun)( z, 1.0L/a ); + } + else + { + z = (*fun)( a, x ); + y = (*ifun)( a, z ); + } + } + break; + + + default: +illegn: + printf( "Illegal nargs= %d", d->nargs ); + exit(1); + } + +switch( d->tstyp ) + { + case WRONK1: + /* Jn, Yn */ +/* e = (y2*y3 - y1*y4) - 2.0L/(PIL*x);*/ + e = x*(y2*y3 - y1*y4) - 2.0L/PIL; + break; + + case WRONK2: +/* In, Kn */ +/* e = (y2*y3 + y1*y4) - 1.0L/x; */ + e = x*(y2*y3 + y1*y4) - 1.0L; + break; + + case ELLIP: + e = (y1-y3)*y4 + y3*y2 - PIO2L; + break; + + default: + e = y - x; + break; + } + +if( d->ctrl & RELERR ) + { + if( x != 0.0L ) + e /= x; + else + printf( "warning, x == 0\n" ); + } +else + { + if( fabsl(x) > 1.0L ) + e /= x; + } + +ave += e; +/* absolute value of error */ +if( e < 0 ) + e = -e; + +/* peak detect the error */ +if( e > max ) + { + max = e; + + if( e > 1.0e-10L ) + { +da = x; +db = z; +dc = y; +dd = max; + printf("x %.6E z %.6E y %.6E max %.4E\n", + da, db, dc, dd ); +/* + if( d->tstyp >= WRONK1 ) + { + printf( "y1 %.4E y2 %.4E y3 %.4E y4 %.4E k %d x %.4E\n", + (double )y1, (double )y2, (double )y3, + (double )y4, k, (double )x ); + } +*/ + } + +/* + printf("%.8E %.8E %.4E %6ld \n", x, y, max, n); + printf("%d %.8E %.8E %.4E %6ld \n", k, x, y, max, n); + printf("%.6E %.6E %.6E %.4E %6ld \n", a, x, y, max, n); + printf("%.6E %.6E %.6E %.6E %.4E %6ld \n", a, b, x, y, max, n); + printf("%.4E %.4E %.4E %.4E %.4E %.4E %6ld \n", + a, b, c, x, y, max, n); +*/ + } + +/* accumulate rms error */ +e *= 1.0e16L; /* adjust range */ +rmsa += e * e; /* accumulate the square of the error */ +} + +/* report after NTRIALS trials */ +rms = 1.0e-16L * sqrtl( rmsa/m ); +da = max; +db = rms; +if(d->ctrl & RELERR) + printf(" max = %.2E rms = %.2E\n", da, db ); +else + printf(" max = %.2E A rms = %.2E A\n", da, db ); +} /* loop on itst */ + +exit (0); +return 0; +} + diff --git a/libm/ldouble/nantst.c b/libm/ldouble/nantst.c new file mode 100644 index 000000000..855a43b5a --- /dev/null +++ b/libm/ldouble/nantst.c @@ -0,0 +1,61 @@ +#include <stdio.h> +long double inf = 1.0f/0.0f; +long double nnn = 1.0f/0.0f - 1.0f/0.0f; +long double fin = 1.0f; +long double neg = -1.0f; +long double nn2; + +int isnanl(), isfinitel(), signbitl(); +void abort (void); +void exit (int); + +void pvalue (char *str, long double x) +{ +union + { + long double f; + unsigned int i[3]; + }u; +int k; + +printf("%s ", str); +u.f = x; +for (k = 0; k < 3; k++) + printf("%08x ", u.i[k]); +printf ("\n"); +} + + +int +main() +{ + +if (!isnanl(nnn)) + abort(); +pvalue("nnn", nnn); +pvalue("inf", inf); +nn2 = inf - inf; +pvalue("inf - inf", nn2); +if (isnanl(fin)) + abort(); +if (isnanl(inf)) + abort(); +if (!isfinitel(fin)) + abort(); +if (isfinitel(nnn)) + abort(); +if (isfinitel(inf)) + abort(); +if (!signbitl(neg)) + abort(); +if (signbitl(fin)) + abort(); +if (signbitl(inf)) + abort(); +/* +if (signbitf(nnn)) + abort(); + */ +exit (0); +return 0; +} diff --git a/libm/ldouble/nbdtrl.c b/libm/ldouble/nbdtrl.c new file mode 100644 index 000000000..91593f544 --- /dev/null +++ b/libm/ldouble/nbdtrl.c @@ -0,0 +1,197 @@ +/* nbdtrl.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtrl(); + * + * y = nbdtrl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms 0 through k of the negative + * binomial distribution: + * + * k + * -- ( n+j-1 ) n j + * > ( ) p (1-p) + * -- ( j ) + * j=0 + * + * In a sequence of Bernoulli trials, this is the probability + * that k or fewer failures precede the nth success. + * + * The terms are not computed individually; instead the incomplete + * beta integral is employed, according to the formula + * + * y = nbdtr( k, n, p ) = incbet( n, k+1, p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * Tested at random points (k,n,p) with k and n between 1 and 10,000 + * and p between 0 and 1. + * + * arithmetic domain # trials peak rms + * Absolute error: + * IEEE 0,10000 10000 9.8e-15 2.1e-16 + * + */ + /* nbdtrcl.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtrcl(); + * + * y = nbdtrcl( k, n, p ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 to infinity of the negative + * binomial distribution: + * + * inf + * -- ( n+j-1 ) n j + * > ( ) p (1-p) + * -- ( j ) + * j=k+1 + * + * The terms are not computed individually; instead the incomplete + * beta integral is employed, according to the formula + * + * y = nbdtrc( k, n, p ) = incbet( k+1, n, 1-p ). + * + * The arguments must be positive, with p ranging from 0 to 1. + * + * + * + * ACCURACY: + * + * See incbetl.c. + * + */ + /* nbdtril + * + * Functional inverse of negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * long double p, y, nbdtril(); + * + * p = nbdtril( k, n, y ); + * + * + * + * DESCRIPTION: + * + * Finds the argument p such that nbdtr(k,n,p) is equal to y. + * + * ACCURACY: + * + * Tested at random points (a,b,y), with y between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 + * See also incbil.c. + */ + +/* +Cephes Math Library Release 2.3: January,1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double incbetl ( long double, long double, long double ); +extern long double powl ( long double, long double ); +extern long double incbil ( long double, long double, long double ); +#else +long double incbetl(), powl(), incbil(); +#endif + +long double nbdtrcl( k, n, p ) +int k, n; +long double p; +{ +long double dk, dn; + +if( (p < 0.0L) || (p > 1.0L) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtrl", DOMAIN ); + return( 0.0L ); + } +dn = n; +if( k == 0 ) + return( 1.0L - powl( p, dn ) ); + +dk = k+1; +return( incbetl( dk, dn, 1.0L - p ) ); +} + + + +long double nbdtrl( k, n, p ) +int k, n; +long double p; +{ +long double dk, dn; + +if( (p < 0.0L) || (p > 1.0L) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtrl", DOMAIN ); + return( 0.0L ); + } +dn = n; +if( k == 0 ) + return( powl( p, dn ) ); + +dk = k+1; +return( incbetl( dn, dk, p ) ); +} + + +long double nbdtril( k, n, p ) +int k, n; +long double p; +{ +long double dk, dn, w; + +if( (p < 0.0L) || (p > 1.0L) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtrl", DOMAIN ); + return( 0.0L ); + } +dk = k+1; +dn = n; +w = incbil( dn, dk, p ); +return( w ); +} diff --git a/libm/ldouble/ndtril.c b/libm/ldouble/ndtril.c new file mode 100644 index 000000000..b1a15cedf --- /dev/null +++ b/libm/ldouble/ndtril.c @@ -0,0 +1,416 @@ +/* ndtril.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * long double x, y, ndtril(); + * + * x = ndtril( y ); + * + * + * + * DESCRIPTION: + * + * Returns the argument, x, for which the area under the + * Gaussian probability density function (integrated from + * minus infinity to x) is equal to y. + * + * + * For small arguments 0 < y < exp(-2), the program computes + * z = sqrt( -2 log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z) . + * For larger arguments, x/sqrt(2 pi) = w + w^3 R(w^2)/S(w^2)) , + * where w = y - 0.5 . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * Arguments uniformly distributed: + * IEEE 0, 1 5000 7.8e-19 9.9e-20 + * Arguments exponentially distributed: + * IEEE exp(-11355),-1 30000 1.7e-19 4.3e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtril domain x <= 0 -MAXNUML + * ndtril domain x >= 1 MAXNUML + * + */ + + +/* +Cephes Math Library Release 2.3: January, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +extern long double MAXNUML; + +/* ndtri(y+0.5)/sqrt(2 pi) = y + y^3 R(y^2) + 0 <= y <= 3/8 + Peak relative error 6.8e-21. */ +#if UNK +/* sqrt(2pi) */ +static long double s2pi = 2.506628274631000502416E0L; +static long double P0[8] = { + 8.779679420055069160496E-3L, +-7.649544967784380691785E-1L, + 2.971493676711545292135E0L, +-4.144980036933753828858E0L, + 2.765359913000830285937E0L, +-9.570456817794268907847E-1L, + 1.659219375097958322098E-1L, +-1.140013969885358273307E-2L, +}; +static long double Q0[7] = { +/* 1.000000000000000000000E0L, */ +-5.303846964603721860329E0L, + 9.908875375256718220854E0L, +-9.031318655459381388888E0L, + 4.496118508523213950686E0L, +-1.250016921424819972516E0L, + 1.823840725000038842075E-1L, +-1.088633151006419263153E-2L, +}; +#endif +#if IBMPC +static unsigned short s2p[] = { +0x2cb3,0xb138,0x98ff,0xa06c,0x4000, XPD +}; +#define s2pi *(long double *)s2p +static short P0[] = { +0xb006,0x9fc1,0xa4fe,0x8fd8,0x3ff8, XPD +0x6f8a,0x976e,0x0ed2,0xc3d4,0xbffe, XPD +0xf1f1,0x6fcc,0xf3d0,0xbe2c,0x4000, XPD +0xccfb,0xa681,0xad2c,0x84a3,0xc001, XPD +0x9a0d,0x0082,0xa825,0xb0fb,0x4000, XPD +0x13d1,0x054a,0xf220,0xf500,0xbffe, XPD +0xcee9,0x2c92,0x70bd,0xa9e7,0x3ffc, XPD +0x5fee,0x4a42,0xa6cb,0xbac7,0xbff8, XPD +}; +static short Q0[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0x841e,0xfec7,0x1d44,0xa9b9,0xc001, XPD +0x97e6,0xcde0,0xc0e7,0x9e8a,0x4002, XPD +0x66f9,0x8f3e,0x47fd,0x9080,0xc002, XPD +0x212f,0x2185,0x33ec,0x8fe0,0x4001, XPD +0x8e73,0x7bac,0x8df2,0xa000,0xbfff, XPD +0xc143,0xcb94,0xe3ea,0xbac2,0x3ffc, XPD +0x25d9,0xc8f3,0x9573,0xb25c,0xbff8, XPD +}; +#endif +#if MIEEE +static unsigned long s2p[] = { +0x40000000,0xa06c98ff,0xb1382cb3, +}; +#define s2pi *(long double *)s2p +static long P0[24] = { +0x3ff80000,0x8fd8a4fe,0x9fc1b006, +0xbffe0000,0xc3d40ed2,0x976e6f8a, +0x40000000,0xbe2cf3d0,0x6fccf1f1, +0xc0010000,0x84a3ad2c,0xa681ccfb, +0x40000000,0xb0fba825,0x00829a0d, +0xbffe0000,0xf500f220,0x054a13d1, +0x3ffc0000,0xa9e770bd,0x2c92cee9, +0xbff80000,0xbac7a6cb,0x4a425fee, +}; +static long Q0[21] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0xc0010000,0xa9b91d44,0xfec7841e, +0x40020000,0x9e8ac0e7,0xcde097e6, +0xc0020000,0x908047fd,0x8f3e66f9, +0x40010000,0x8fe033ec,0x2185212f, +0xbfff0000,0xa0008df2,0x7bac8e73, +0x3ffc0000,0xbac2e3ea,0xcb94c143, +0xbff80000,0xb25c9573,0xc8f325d9, +}; +#endif + +/* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 + */ +/* ndtri(p) = z - ln(z)/z - 1/z P1(1/z)/Q1(1/z) + z = sqrt(-2 ln(p)) + 2 <= z <= 8, i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. + Peak relative error 5.3e-21 */ +#if UNK +static long double P1[10] = { + 4.302849750435552180717E0L, + 4.360209451837096682600E1L, + 9.454613328844768318162E1L, + 9.336735653151873871756E1L, + 5.305046472191852391737E1L, + 1.775851836288460008093E1L, + 3.640308340137013109859E0L, + 3.691354900171224122390E-1L, + 1.403530274998072987187E-2L, + 1.377145111380960566197E-4L, +}; +static long double Q1[9] = { +/* 1.000000000000000000000E0L, */ + 2.001425109170530136741E1L, + 7.079893963891488254284E1L, + 8.033277265194672063478E1L, + 5.034715121553662712917E1L, + 1.779820137342627204153E1L, + 3.845554944954699547539E0L, + 3.993627390181238962857E-1L, + 1.526870689522191191380E-2L, + 1.498700676286675466900E-4L, +}; +#endif +#if IBMPC +static short P1[] = { +0x6105,0xb71e,0xf1f5,0x89b0,0x4001, XPD +0x461d,0x2604,0x8b77,0xae68,0x4004, XPD +0x8b33,0x4a47,0x9ec8,0xbd17,0x4005, XPD +0xa0b2,0xc1b0,0x1627,0xbabc,0x4005, XPD +0x9901,0x28f7,0xad06,0xd433,0x4004, XPD +0xddcb,0x5009,0x7213,0x8e11,0x4003, XPD +0x2432,0x0fa6,0xcfd5,0xe8fa,0x4000, XPD +0x3e24,0xd53c,0x53b2,0xbcff,0x3ffd, XPD +0x4058,0x3d75,0x5393,0xe5f4,0x3ff8, XPD +0x1789,0xf50a,0x7524,0x9067,0x3ff2, XPD +}; +static short Q1[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0xd901,0x2673,0x2fad,0xa01d,0x4003, XPD +0x24f5,0xc93c,0x0e9d,0x8d99,0x4005, XPD +0x8cda,0x523a,0x612d,0xa0aa,0x4005, XPD +0x602c,0xb5fc,0x7b9b,0xc963,0x4004, XPD +0xac72,0xd3e7,0xb766,0x8e62,0x4003, XPD +0x048e,0xe34c,0x927c,0xf61d,0x4000, XPD +0x6d88,0xa5cc,0x45de,0xcc79,0x3ffd, XPD +0xe6d1,0x199a,0x9931,0xfa29,0x3ff8, XPD +0x4c7d,0x3675,0x70a0,0x9d26,0x3ff2, XPD +}; +#endif +#if MIEEE +static long P1[30] = { +0x40010000,0x89b0f1f5,0xb71e6105, +0x40040000,0xae688b77,0x2604461d, +0x40050000,0xbd179ec8,0x4a478b33, +0x40050000,0xbabc1627,0xc1b0a0b2, +0x40040000,0xd433ad06,0x28f79901, +0x40030000,0x8e117213,0x5009ddcb, +0x40000000,0xe8facfd5,0x0fa62432, +0x3ffd0000,0xbcff53b2,0xd53c3e24, +0x3ff80000,0xe5f45393,0x3d754058, +0x3ff20000,0x90677524,0xf50a1789, +}; +static long Q1[27] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40030000,0xa01d2fad,0x2673d901, +0x40050000,0x8d990e9d,0xc93c24f5, +0x40050000,0xa0aa612d,0x523a8cda, +0x40040000,0xc9637b9b,0xb5fc602c, +0x40030000,0x8e62b766,0xd3e7ac72, +0x40000000,0xf61d927c,0xe34c048e, +0x3ffd0000,0xcc7945de,0xa5cc6d88, +0x3ff80000,0xfa299931,0x199ae6d1, +0x3ff20000,0x9d2670a0,0x36754c7d, +}; +#endif + +/* ndtri(x) = z - ln(z)/z - 1/z P2(1/z)/Q2(1/z) + z = sqrt(-2 ln(y)) + 8 <= z <= 32 + i.e., y between exp(-32) = 1.27e-14 and exp(-512) = 4.38e-223 + Peak relative error 1.0e-21 */ +#if UNK +static long double P2[8] = { + 3.244525725312906932464E0L, + 6.856256488128415760904E0L, + 3.765479340423144482796E0L, + 1.240893301734538935324E0L, + 1.740282292791367834724E-1L, + 9.082834200993107441750E-3L, + 1.617870121822776093899E-4L, + 7.377405643054504178605E-7L, +}; +static long double Q2[7] = { +/* 1.000000000000000000000E0L, */ + 6.021509481727510630722E0L, + 3.528463857156936773982E0L, + 1.289185315656302878699E0L, + 1.874290142615703609510E-1L, + 9.867655920899636109122E-3L, + 1.760452434084258930442E-4L, + 8.028288500688538331773E-7L, +}; +#endif +#if IBMPC +static short P2[] = { +0xafb1,0x4ff9,0x4f3a,0xcfa6,0x4000, XPD +0xbd81,0xaffa,0x7401,0xdb66,0x4001, XPD +0x3a32,0x3863,0x9d0f,0xf0fd,0x4000, XPD +0x300e,0x633d,0x977a,0x9ed5,0x3fff, XPD +0xea3a,0x56b6,0x74c5,0xb234,0x3ffc, XPD +0x38c6,0x49d2,0x2af6,0x94d0,0x3ff8, XPD +0xc85d,0xe17d,0x5ed1,0xa9a5,0x3ff2, XPD +0x536c,0x808b,0x2542,0xc609,0x3fea, XPD +}; +static short Q2[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0xaabd,0x125a,0x34a7,0xc0b0,0x4001, XPD +0x0ded,0xe6da,0x5a11,0xe1d2,0x4000, XPD +0xc742,0x9d16,0x0640,0xa504,0x3fff, XPD +0xea1e,0x4cc2,0x643a,0xbfed,0x3ffc, XPD +0x7a9b,0xfaff,0xf2dd,0xa1ab,0x3ff8, XPD +0xfd90,0x4688,0xc902,0xb898,0x3ff2, XPD +0xf003,0x032a,0xfa7e,0xd781,0x3fea, XPD +}; +#endif +#if MIEEE +static long P2[24] = { +0x40000000,0xcfa64f3a,0x4ff9afb1, +0x40010000,0xdb667401,0xaffabd81, +0x40000000,0xf0fd9d0f,0x38633a32, +0x3fff0000,0x9ed5977a,0x633d300e, +0x3ffc0000,0xb23474c5,0x56b6ea3a, +0x3ff80000,0x94d02af6,0x49d238c6, +0x3ff20000,0xa9a55ed1,0xe17dc85d, +0x3fea0000,0xc6092542,0x808b536c, +}; +static long Q2[21] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40010000,0xc0b034a7,0x125aaabd, +0x40000000,0xe1d25a11,0xe6da0ded, +0x3fff0000,0xa5040640,0x9d16c742, +0x3ffc0000,0xbfed643a,0x4cc2ea1e, +0x3ff80000,0xa1abf2dd,0xfaff7a9b, +0x3ff20000,0xb898c902,0x4688fd90, +0x3fea0000,0xd781fa7e,0x032af003, +}; +#endif + +/* ndtri(x) = z - ln(z)/z - 1/z P3(1/z)/Q3(1/z) + 32 < z < 2048/13 + Peak relative error 1.4e-20 */ +#if UNK +static long double P3[8] = { + 2.020331091302772535752E0L, + 2.133020661587413053144E0L, + 2.114822217898707063183E-1L, +-6.500909615246067985872E-3L, +-7.279315200737344309241E-4L, +-1.275404675610280787619E-5L, +-6.433966387613344714022E-8L, +-7.772828380948163386917E-11L, +}; +static long double Q3[7] = { +/* 1.000000000000000000000E0L, */ + 2.278210997153449199574E0L, + 2.345321838870438196534E-1L, +-6.916708899719964982855E-3L, +-7.908542088737858288849E-4L, +-1.387652389480217178984E-5L, +-7.001476867559193780666E-8L, +-8.458494263787680376729E-11L, +}; +#endif +#if IBMPC +static short P3[] = { +0x87b2,0x0f31,0x1ac7,0x814d,0x4000, XPD +0x491c,0xcd74,0x6917,0x8883,0x4000, XPD +0x935e,0x1776,0xcba9,0xd88e,0x3ffc, XPD +0xbafd,0x8abb,0x9518,0xd505,0xbff7, XPD +0xc87e,0x2ed3,0xa84a,0xbed2,0xbff4, XPD +0x0094,0xa402,0x36b5,0xd5fa,0xbfee, XPD +0xbc53,0x0fc3,0x1ab2,0x8a2b,0xbfe7, XPD +0x30b4,0x71c0,0x223d,0xaaed,0xbfdd, XPD +}; +static short Q3[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0xdfc1,0x8a57,0x357f,0x91ce,0x4000, XPD +0xcc4f,0x9e03,0x346e,0xf029,0x3ffc, XPD +0x38b1,0x9788,0x8f42,0xe2a5,0xbff7, XPD +0xb281,0x2117,0x53da,0xcf51,0xbff4, XPD +0xf2ab,0x1d42,0x3760,0xe8cf,0xbfee, XPD +0x741b,0xf14f,0x06b0,0x965b,0xbfe7, XPD +0x37c2,0xa91f,0x16ea,0xba01,0xbfdd, XPD +}; +#endif +#if MIEEE +static long P3[24] = { +0x40000000,0x814d1ac7,0x0f3187b2, +0x40000000,0x88836917,0xcd74491c, +0x3ffc0000,0xd88ecba9,0x1776935e, +0xbff70000,0xd5059518,0x8abbbafd, +0xbff40000,0xbed2a84a,0x2ed3c87e, +0xbfee0000,0xd5fa36b5,0xa4020094, +0xbfe70000,0x8a2b1ab2,0x0fc3bc53, +0xbfdd0000,0xaaed223d,0x71c030b4, +}; +static long Q3[21] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40000000,0x91ce357f,0x8a57dfc1, +0x3ffc0000,0xf029346e,0x9e03cc4f, +0xbff70000,0xe2a58f42,0x978838b1, +0xbff40000,0xcf5153da,0x2117b281, +0xbfee0000,0xe8cf3760,0x1d42f2ab, +0xbfe70000,0x965b06b0,0xf14f741b, +0xbfdd0000,0xba0116ea,0xa91f37c2, +}; +#endif +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double logl ( long double ); +extern long double sqrtl ( long double ); +#else +long double polevll(), p1evll(), logl(), sqrtl(); +#endif + +long double ndtril(y0) +long double y0; +{ +long double x, y, z, y2, x0, x1; +int code; + +if( y0 <= 0.0L ) + { + mtherr( "ndtril", DOMAIN ); + return( -MAXNUML ); + } +if( y0 >= 1.0L ) + { + mtherr( "ndtri", DOMAIN ); + return( MAXNUML ); + } +code = 1; +y = y0; +if( y > (1.0L - 0.13533528323661269189L) ) /* 0.135... = exp(-2) */ + { + y = 1.0L - y; + code = 0; + } + +if( y > 0.13533528323661269189L ) + { + y = y - 0.5L; + y2 = y * y; + x = y + y * (y2 * polevll( y2, P0, 7 )/p1evll( y2, Q0, 7 )); + x = x * s2pi; + return(x); + } + +x = sqrtl( -2.0L * logl(y) ); +x0 = x - logl(x)/x; +z = 1.0L/x; +if( x < 8.0L ) + x1 = z * polevll( z, P1, 9 )/p1evll( z, Q1, 9 ); +else if( x < 32.0L ) + x1 = z * polevll( z, P2, 7 )/p1evll( z, Q2, 7 ); +else + x1 = z * polevll( z, P3, 7 )/p1evll( z, Q3, 7 ); +x = x0 - x1; +if( code != 0 ) + x = -x; +return( x ); +} diff --git a/libm/ldouble/ndtrl.c b/libm/ldouble/ndtrl.c new file mode 100644 index 000000000..2c53314a5 --- /dev/null +++ b/libm/ldouble/ndtrl.c @@ -0,0 +1,473 @@ +/* ndtrl.c + * + * Normal distribution function + * + * + * + * SYNOPSIS: + * + * long double x, y, ndtrl(); + * + * y = ndtrl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the area under the Gaussian probability density + * function, integrated from minus infinity to x: + * + * x + * - + * 1 | | 2 + * ndtr(x) = --------- | exp( - t /2 ) dt + * sqrt(2pi) | | + * - + * -inf. + * + * = ( 1 + erf(z) ) / 2 + * = erfc(z) / 2 + * + * where z = x/sqrt(2). Computation is via the functions + * erf and erfc. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -13,0 30000 1.6e-17 2.9e-18 + * IEEE -150.7,0 2000 1.6e-15 3.8e-16 + * Accuracy is limited by error amplification in computing exp(-x^2). + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfcl underflow x^2 / 2 > MAXLOGL 0.0 + * + */ + /* erfl.c + * + * Error function + * + * + * + * SYNOPSIS: + * + * long double x, y, erfl(); + * + * y = erfl( x ); + * + * + * + * DESCRIPTION: + * + * The integral is + * + * x + * - + * 2 | | 2 + * erf(x) = -------- | exp( - t ) dt. + * sqrt(pi) | | + * - + * 0 + * + * The magnitude of x is limited to about 106.56 for IEEE + * arithmetic; 1 or -1 is returned outside this range. + * + * For 0 <= |x| < 1, erf(x) = x * P6(x^2)/Q6(x^2); otherwise + * erf(x) = 1 - erfc(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 50000 2.0e-19 5.7e-20 + * + */ + /* erfcl.c + * + * Complementary error function + * + * + * + * SYNOPSIS: + * + * long double x, y, erfcl(); + * + * y = erfcl( x ); + * + * + * + * DESCRIPTION: + * + * + * 1 - erf(x) = + * + * inf. + * - + * 2 | | 2 + * erfc(x) = -------- | exp( - t ) dt + * sqrt(pi) | | + * - + * x + * + * + * For small x, erfc(x) = 1 - erf(x); otherwise rational + * approximations are computed. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,13 20000 7.0e-18 1.8e-18 + * IEEE 0,106.56 10000 4.4e-16 1.2e-16 + * Accuracy is limited by error amplification in computing exp(-x^2). + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfcl underflow x^2 > MAXLOGL 0.0 + * + * + */ + + +/* +Cephes Math Library Release 2.3: January, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + + +#include <math.h> + +extern long double MAXLOGL; +static long double SQRTHL = 7.071067811865475244008e-1L; + +/* erfc(x) = exp(-x^2) P(1/x)/Q(1/x) + 1/8 <= 1/x <= 1 + Peak relative error 5.8e-21 */ +#if UNK +static long double P[10] = { + 1.130609921802431462353E9L, + 2.290171954844785638925E9L, + 2.295563412811856278515E9L, + 1.448651275892911637208E9L, + 6.234814405521647580919E8L, + 1.870095071120436715930E8L, + 3.833161455208142870198E7L, + 4.964439504376477951135E6L, + 3.198859502299390825278E5L, +-9.085943037416544232472E-6L, +}; +static long double Q[10] = { +/* 1.000000000000000000000E0L, */ + 1.130609910594093747762E9L, + 3.565928696567031388910E9L, + 5.188672873106859049556E9L, + 4.588018188918609726890E9L, + 2.729005809811924550999E9L, + 1.138778654945478547049E9L, + 3.358653716579278063988E8L, + 6.822450775590265689648E7L, + 8.799239977351261077610E6L, + 5.669830829076399819566E5L, +}; +#endif +#if IBMPC +static short P[] = { +0x4bf0,0x9ad8,0x7a03,0x86c7,0x401d, XPD +0xdf23,0xd843,0x4032,0x8881,0x401e, XPD +0xd025,0xcfd5,0x8494,0x88d3,0x401e, XPD +0xb6d0,0xc92b,0x5417,0xacb1,0x401d, XPD +0xada8,0x356a,0x4982,0x94a6,0x401c, XPD +0x4e13,0xcaee,0x9e31,0xb258,0x401a, XPD +0x5840,0x554d,0x37a3,0x9239,0x4018, XPD +0x3b58,0x3da2,0xaf02,0x9780,0x4015, XPD +0x0144,0x489e,0xbe68,0x9c31,0x4011, XPD +0x333b,0xd9e6,0xd404,0x986f,0xbfee, XPD +}; +static short Q[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0x0e43,0x302d,0x79ed,0x86c7,0x401d, XPD +0xf817,0x9128,0xc0f8,0xd48b,0x401e, XPD +0x8eae,0x8dad,0x6eb4,0x9aa2,0x401f, XPD +0x00e7,0x7595,0xcd06,0x88bb,0x401f, XPD +0x4991,0xcfda,0x52f1,0xa2a9,0x401e, XPD +0xc39d,0xe415,0xc43d,0x87c0,0x401d, XPD +0xa75d,0x436f,0x30dd,0xa027,0x401b, XPD +0xc4cb,0x305a,0xbf78,0x8220,0x4019, XPD +0x3708,0x33b1,0x07fa,0x8644,0x4016, XPD +0x24fa,0x96f6,0x7153,0x8a6c,0x4012, XPD +}; +#endif +#if MIEEE +static long P[30] = { +0x401d0000,0x86c77a03,0x9ad84bf0, +0x401e0000,0x88814032,0xd843df23, +0x401e0000,0x88d38494,0xcfd5d025, +0x401d0000,0xacb15417,0xc92bb6d0, +0x401c0000,0x94a64982,0x356aada8, +0x401a0000,0xb2589e31,0xcaee4e13, +0x40180000,0x923937a3,0x554d5840, +0x40150000,0x9780af02,0x3da23b58, +0x40110000,0x9c31be68,0x489e0144, +0xbfee0000,0x986fd404,0xd9e6333b, +}; +static long Q[30] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x401d0000,0x86c779ed,0x302d0e43, +0x401e0000,0xd48bc0f8,0x9128f817, +0x401f0000,0x9aa26eb4,0x8dad8eae, +0x401f0000,0x88bbcd06,0x759500e7, +0x401e0000,0xa2a952f1,0xcfda4991, +0x401d0000,0x87c0c43d,0xe415c39d, +0x401b0000,0xa02730dd,0x436fa75d, +0x40190000,0x8220bf78,0x305ac4cb, +0x40160000,0x864407fa,0x33b13708, +0x40120000,0x8a6c7153,0x96f624fa, +}; +#endif + +/* erfc(x) = exp(-x^2) 1/x R(1/x^2) / S(1/x^2) + 1/128 <= 1/x < 1/8 + Peak relative error 1.9e-21 */ +#if UNK +static long double R[5] = { + 3.621349282255624026891E0L, + 7.173690522797138522298E0L, + 3.445028155383625172464E0L, + 5.537445669807799246891E-1L, + 2.697535671015506686136E-2L, +}; +static long double S[5] = { +/* 1.000000000000000000000E0L, */ + 1.072884067182663823072E1L, + 1.533713447609627196926E1L, + 6.572990478128949439509E0L, + 1.005392977603322982436E0L, + 4.781257488046430019872E-2L, +}; +#endif +#if IBMPC +static short R[] = { +0x260a,0xab95,0x2fc7,0xe7c4,0x4000, XPD +0x4761,0x613e,0xdf6d,0xe58e,0x4001, XPD +0x0615,0x4b00,0x575f,0xdc7b,0x4000, XPD +0x521d,0x8527,0x3435,0x8dc2,0x3ffe, XPD +0x22cf,0xc711,0x6c5b,0xdcfb,0x3ff9, XPD +}; +static short S[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0x5de6,0x17d7,0x54d6,0xaba9,0x4002, XPD +0x55d5,0xd300,0xe71e,0xf564,0x4002, XPD +0xb611,0x8f76,0xf020,0xd255,0x4001, XPD +0x3684,0x3798,0xb793,0x80b0,0x3fff, XPD +0xf5af,0x2fb2,0x1e57,0xc3d7,0x3ffa, XPD +}; +#endif +#if MIEEE +static long R[15] = { +0x40000000,0xe7c42fc7,0xab95260a, +0x40010000,0xe58edf6d,0x613e4761, +0x40000000,0xdc7b575f,0x4b000615, +0x3ffe0000,0x8dc23435,0x8527521d, +0x3ff90000,0xdcfb6c5b,0xc71122cf, +}; +static long S[15] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40020000,0xaba954d6,0x17d75de6, +0x40020000,0xf564e71e,0xd30055d5, +0x40010000,0xd255f020,0x8f76b611, +0x3fff0000,0x80b0b793,0x37983684, +0x3ffa0000,0xc3d71e57,0x2fb2f5af, +}; +#endif + +/* erf(x) = x P(x^2)/Q(x^2) + 0 <= x <= 1 + Peak relative error 7.6e-23 */ +#if UNK +static long double T[7] = { + 1.097496774521124996496E-1L, + 5.402980370004774841217E0L, + 2.871822526820825849235E2L, + 2.677472796799053019985E3L, + 4.825977363071025440855E4L, + 1.549905740900882313773E5L, + 1.104385395713178565288E6L, +}; +static long double U[6] = { +/* 1.000000000000000000000E0L, */ + 4.525777638142203713736E1L, + 9.715333124857259246107E2L, + 1.245905812306219011252E4L, + 9.942956272177178491525E4L, + 4.636021778692893773576E5L, + 9.787360737578177599571E5L, +}; +#endif +#if IBMPC +static short T[] = { +0xfd7a,0x3a1a,0x705b,0xe0c4,0x3ffb, XPD +0x3128,0xc337,0x3716,0xace5,0x4001, XPD +0x9517,0x4e93,0x540e,0x8f97,0x4007, XPD +0x6118,0x6059,0x9093,0xa757,0x400a, XPD +0xb954,0xa987,0xc60c,0xbc83,0x400e, XPD +0x7a56,0xe45a,0xa4bd,0x975b,0x4010, XPD +0xc446,0x6bab,0x0b2a,0x86d0,0x4013, XPD +}; +static short U[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, XPD */ +0x3453,0x1f8e,0xf688,0xb507,0x4004, XPD +0x71ac,0xb12f,0x21ca,0xf2e2,0x4008, XPD +0xffe8,0x9cac,0x3b84,0xc2ac,0x400c, XPD +0x481d,0x445b,0xc807,0xc232,0x400f, XPD +0x9ad5,0x1aef,0x45b1,0xe25e,0x4011, XPD +0x71a7,0x1cad,0x012e,0xeef3,0x4012, XPD +}; +#endif +#if MIEEE +static long T[21] = { +0x3ffb0000,0xe0c4705b,0x3a1afd7a, +0x40010000,0xace53716,0xc3373128, +0x40070000,0x8f97540e,0x4e939517, +0x400a0000,0xa7579093,0x60596118, +0x400e0000,0xbc83c60c,0xa987b954, +0x40100000,0x975ba4bd,0xe45a7a56, +0x40130000,0x86d00b2a,0x6babc446, +}; +static long U[18] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40040000,0xb507f688,0x1f8e3453, +0x40080000,0xf2e221ca,0xb12f71ac, +0x400c0000,0xc2ac3b84,0x9cacffe8, +0x400f0000,0xc232c807,0x445b481d, +0x40110000,0xe25e45b1,0x1aef9ad5, +0x40120000,0xeef3012e,0x1cad71a7, +}; +#endif +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double expl ( long double ); +extern long double logl ( long double ); +extern long double erfl ( long double ); +extern long double erfcl ( long double ); +extern long double fabsl ( long double ); +#else +long double polevll(), p1evll(), expl(), logl(), erfl(), erfcl(), fabsl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif + +long double ndtrl(a) +long double a; +{ +long double x, y, z; + +x = a * SQRTHL; +z = fabsl(x); + +if( z < SQRTHL ) + y = 0.5L + 0.5L * erfl(x); + +else + { + y = 0.5L * erfcl(z); + + if( x > 0.0L ) + y = 1.0L - y; + } + +return(y); +} + + +long double erfcl(a) +long double a; +{ +long double p,q,x,y,z; + +#ifdef INFINITIES +if( a == INFINITYL ) + return(0.0L); +if( a == -INFINITYL ) + return(2.0L); +#endif +if( a < 0.0L ) + x = -a; +else + x = a; + +if( x < 1.0L ) + return( 1.0L - erfl(a) ); + +z = -a * a; + +if( z < -MAXLOGL ) + { +under: + mtherr( "erfcl", UNDERFLOW ); + if( a < 0 ) + return( 2.0L ); + else + return( 0.0L ); + } + +z = expl(z); +y = 1.0L/x; + +if( x < 8.0L ) + { + p = polevll( y, P, 9 ); + q = p1evll( y, Q, 10 ); + } +else + { + q = y * y; + p = y * polevll( q, R, 4 ); + q = p1evll( q, S, 5 ); + } +y = (z * p)/q; + +if( a < 0.0L ) + y = 2.0L - y; + +if( y == 0.0L ) + goto under; + +return(y); +} + + + +long double erfl(x) +long double x; +{ +long double y, z; + +#if MINUSZERO +if( x == 0.0L ) + return(x); +#endif +#ifdef INFINITIES +if( x == -INFINITYL ) + return(-1.0L); +if( x == INFINITYL ) + return(1.0L); +#endif +if( fabsl(x) > 1.0L ) + return( 1.0L - erfcl(x) ); + +z = x * x; +y = x * polevll( z, T, 6 ) / p1evll( z, U, 6 ); +return( y ); +} diff --git a/libm/ldouble/pdtrl.c b/libm/ldouble/pdtrl.c new file mode 100644 index 000000000..861b1d9ae --- /dev/null +++ b/libm/ldouble/pdtrl.c @@ -0,0 +1,184 @@ +/* pdtrl.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrl(); + * + * y = pdtrl( k, m ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the first k terms of the Poisson + * distribution: + * + * k j + * -- -m m + * > e -- + * -- j! + * j=0 + * + * The terms are not summed directly; instead the incomplete + * gamma integral is employed, according to the relation + * + * y = pdtr( k, m ) = igamc( k+1, m ). + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igamc(). + * + */ + /* pdtrcl() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrcl(); + * + * y = pdtrcl( k, m ); + * + * + * + * DESCRIPTION: + * + * Returns the sum of the terms k+1 to infinity of the Poisson + * distribution: + * + * inf. j + * -- -m m + * > e -- + * -- j! + * j=k+1 + * + * The terms are not summed directly; instead the incomplete + * gamma integral is employed, according to the formula + * + * y = pdtrc( k, m ) = igam( k+1, m ). + * + * The arguments must both be positive. + * + * + * + * ACCURACY: + * + * See igam.c. + * + */ + /* pdtril() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * long double m, y, pdtrl(); + * + * m = pdtril( k, y ); + * + * + * + * + * DESCRIPTION: + * + * Finds the Poisson variable x such that the integral + * from 0 to x of the Poisson density is equal to the + * given probability y. + * + * This is accomplished using the inverse gamma integral + * function and the relation + * + * m = igami( k+1, y ). + * + * + * + * + * ACCURACY: + * + * See igami.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * pdtri domain y < 0 or y >= 1 0.0 + * k < 0 + * + */ + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern long double igaml ( long double, long double ); +extern long double igamcl ( long double, long double ); +extern long double igamil ( long double, long double ); +#else +long double igaml(), igamcl(), igamil(); +#endif + +long double pdtrcl( k, m ) +int k; +long double m; +{ +long double v; + +if( (k < 0) || (m <= 0.0L) ) + { + mtherr( "pdtrcl", DOMAIN ); + return( 0.0L ); + } +v = k+1; +return( igaml( v, m ) ); +} + + + +long double pdtrl( k, m ) +int k; +long double m; +{ +long double v; + +if( (k < 0) || (m <= 0.0L) ) + { + mtherr( "pdtrl", DOMAIN ); + return( 0.0L ); + } +v = k+1; +return( igamcl( v, m ) ); +} + + +long double pdtril( k, y ) +int k; +long double y; +{ +long double v; + +if( (k < 0) || (y < 0.0L) || (y >= 1.0L) ) + { + mtherr( "pdtril", DOMAIN ); + return( 0.0L ); + } +v = k+1; +v = igamil( v, y ); +return( v ); +} diff --git a/libm/ldouble/polevll.c b/libm/ldouble/polevll.c new file mode 100644 index 000000000..ce37c6d9d --- /dev/null +++ b/libm/ldouble/polevll.c @@ -0,0 +1,182 @@ +/* polevll.c + * p1evll.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * long double x, y, coef[N+1], polevl[]; + * + * y = polevll( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates polynomial of degree N: + * + * 2 N + * y = C + C x + C x +...+ C x + * 0 1 2 N + * + * Coefficients are stored in reverse order: + * + * coef[0] = C , ..., coef[N] = C . + * N 0 + * + * The function p1evll() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevll(). + * + * This module also contains the following globally declared constants: + * MAXNUML = 1.189731495357231765021263853E4932L; + * MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; + * MAXLOGL = 1.1356523406294143949492E4L; + * MINLOGL = -1.1355137111933024058873E4L; + * LOGE2L = 6.9314718055994530941723E-1L; + * LOG2EL = 1.4426950408889634073599E0L; + * PIL = 3.1415926535897932384626L; + * PIO2L = 1.5707963267948966192313L; + * PIO4L = 7.8539816339744830961566E-1L; + * + * SPEED: + * + * In the interest of speed, there are no checks for out + * of bounds arithmetic. This routine is used by most of + * the functions in the library. Depending on available + * equipment features, the user may wish to rewrite the + * program in microcode or assembly language. + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ +#include <math.h> + +#if UNK +/* almost 2^16384 */ +long double MAXNUML = 1.189731495357231765021263853E4932L; +/* 2^-64 */ +long double MACHEPL = 5.42101086242752217003726400434970855712890625E-20L; +/* log( MAXNUML ) */ +long double MAXLOGL = 1.1356523406294143949492E4L; +#ifdef DENORMAL +/* log(smallest denormal number = 2^-16446) */ +long double MINLOGL = -1.13994985314888605586758E4L; +#else +/* log( underflow threshold = 2^(-16382) ) */ +long double MINLOGL = -1.1355137111933024058873E4L; +#endif +long double LOGE2L = 6.9314718055994530941723E-1L; +long double LOG2EL = 1.4426950408889634073599E0L; +long double PIL = 3.1415926535897932384626L; +long double PIO2L = 1.5707963267948966192313L; +long double PIO4L = 7.8539816339744830961566E-1L; +#ifdef INFINITIES +long double NANL = 0.0L / 0.0L; +long double INFINITYL = 1.0L / 0.0L; +#else +long double INFINITYL = 1.189731495357231765021263853E4932L; +long double NANL = 0.0L; +#endif +#endif +#if IBMPC +short MAXNUML[] = {0xffff,0xffff,0xffff,0xffff,0x7ffe, XPD}; +short MAXLOGL[] = {0x79ab,0xd1cf,0x17f7,0xb172,0x400c, XPD}; +#ifdef INFINITIES +short INFINITYL[] = {0,0,0,0x8000,0x7fff, XPD}; +short NANL[] = {0,0,0,0xc000,0x7fff, XPD}; +#else +short INFINITYL[] = {0xffff,0xffff,0xffff,0xffff,0x7ffe, XPD}; +long double NANL = 0.0L; +#endif +#ifdef DENORMAL +short MINLOGL[] = {0xbaaa,0x09e2,0xfe7f,0xb21d,0xc00c, XPD}; +#else +short MINLOGL[] = {0xeb2f,0x1210,0x8c67,0xb16c,0xc00c, XPD}; +#endif +short MACHEPL[] = {0x0000,0x0000,0x0000,0x8000,0x3fbf, XPD}; +short LOGE2L[] = {0x79ac,0xd1cf,0x17f7,0xb172,0x3ffe, XPD}; +short LOG2EL[] = {0xf0bc,0x5c17,0x3b29,0xb8aa,0x3fff, XPD}; +short PIL[] = {0xc235,0x2168,0xdaa2,0xc90f,0x4000, XPD}; +short PIO2L[] = {0xc235,0x2168,0xdaa2,0xc90f,0x3fff, XPD}; +short PIO4L[] = {0xc235,0x2168,0xdaa2,0xc90f,0x3ffe, XPD}; +#endif +#if MIEEE +long MAXNUML[] = {0x7ffe0000,0xffffffff,0xffffffff}; +long MAXLOGL[] = {0x400c0000,0xb17217f7,0xd1cf79ab}; +#ifdef INFINITIES +long INFINITY[] = {0x7fff0000,0x80000000,0x00000000}; +long NANL[] = {0x7fff0000,0xffffffff,0xffffffff}; +#else +long INFINITYL[] = {0x7ffe0000,0xffffffff,0xffffffff}; +long double NANL = 0.0L; +#endif +#ifdef DENORMAL +long MINLOGL[] = {0xc00c0000,0xb21dfe7f,0x09e2baaa}; +#else +long MINLOGL[] = {0xc00c0000,0xb16c8c67,0x1210eb2f}; +#endif +long MACHEPL[] = {0x3fbf0000,0x80000000,0x00000000}; +long LOGE2L[] = {0x3ffe0000,0xb17217f7,0xd1cf79ac}; +long LOG2EL[] = {0x3fff0000,0xb8aa3b29,0x5c17f0bc}; +long PIL[] = {0x40000000,0xc90fdaa2,0x2168c235}; +long PIO2L[] = {0x3fff0000,0xc90fdaa2,0x2168c235}; +long PIO4L[] = {0x3ffe0000,0xc90fdaa2,0x2168c235}; +#endif + +#ifdef MINUSZERO +long double NEGZEROL = -0.0L; +#else +long double NEGZEROL = 0.0L; +#endif + +/* Polynomial evaluator: + * P[0] x^n + P[1] x^(n-1) + ... + P[n] + */ +long double polevll( x, p, n ) +long double x; +void *p; +int n; +{ +register long double y; +register long double *P = (long double *)p; + +y = *P++; +do + { + y = y * x + *P++; + } +while( --n ); +return(y); +} + + + +/* Polynomial evaluator: + * x^n + P[0] x^(n-1) + P[1] x^(n-2) + ... + P[n] + */ +long double p1evll( x, p, n ) +long double x; +void *p; +int n; +{ +register long double y; +register long double *P = (long double *)p; + +n -= 1; +y = x + *P++; +do + { + y = y * x + *P++; + } +while( --n ); +return( y ); +} diff --git a/libm/ldouble/powil.c b/libm/ldouble/powil.c new file mode 100644 index 000000000..d36c7854e --- /dev/null +++ b/libm/ldouble/powil.c @@ -0,0 +1,164 @@ +/* powil.c + * + * Real raised to integer power, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, powil(); + * int n; + * + * y = powil( x, n ); + * + * + * + * DESCRIPTION: + * + * Returns argument x raised to the nth power. + * The routine efficiently decomposes n as a sum of powers of + * two. The desired power is a product of two-to-the-kth + * powers of x. Thus to compute the 32767 power of x requires + * 28 multiplications instead of 32767 multiplications. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic x domain n domain # trials peak rms + * IEEE .001,1000 -1022,1023 50000 4.3e-17 7.8e-18 + * IEEE 1,2 -1022,1023 20000 3.9e-17 7.6e-18 + * IEEE .99,1.01 0,8700 10000 3.6e-16 7.2e-17 + * + * Returns MAXNUM on overflow, zero on underflow. + * + */ + +/* powil.c */ + +/* +Cephes Math Library Release 2.2: December, 1990 +Copyright 1984, 1990 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern long double MAXNUML, MAXLOGL, MINLOGL; +extern long double LOGE2L; +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +#else +long double frexpl(); +#endif + +long double powil( x, nn ) +long double x; +int nn; +{ +long double w, y; +long double s; +int n, e, sign, asign, lx; + +if( x == 0.0L ) + { + if( nn == 0 ) + return( 1.0L ); + else if( nn < 0 ) + return( MAXNUML ); + else + return( 0.0L ); + } + +if( nn == 0 ) + return( 1.0L ); + + +if( x < 0.0L ) + { + asign = -1; + x = -x; + } +else + asign = 0; + + +if( nn < 0 ) + { + sign = -1; + n = -nn; + } +else + { + sign = 1; + n = nn; + } + +/* Overflow detection */ + +/* Calculate approximate logarithm of answer */ +s = x; +s = frexpl( s, &lx ); +e = (lx - 1)*n; +if( (e == 0) || (e > 64) || (e < -64) ) + { + s = (s - 7.0710678118654752e-1L) / (s + 7.0710678118654752e-1L); + s = (2.9142135623730950L * s - 0.5L + lx) * nn * LOGE2L; + } +else + { + s = LOGE2L * e; + } + +if( s > MAXLOGL ) + { + mtherr( "powil", OVERFLOW ); + y = MAXNUML; + goto done; + } + +if( s < MINLOGL ) + { + mtherr( "powil", UNDERFLOW ); + return(0.0L); + } +/* Handle tiny denormal answer, but with less accuracy + * since roundoff error in 1.0/x will be amplified. + * The precise demarcation should be the gradual underflow threshold. + */ +if( s < (-MAXLOGL+2.0L) ) + { + x = 1.0L/x; + sign = -sign; + } + +/* First bit of the power */ +if( n & 1 ) + y = x; + +else + { + y = 1.0L; + asign = 0; + } + +w = x; +n >>= 1; +while( n ) + { + w = w * w; /* arg to the 2-to-the-kth power */ + if( n & 1 ) /* if that bit is set, then include in product */ + y *= w; + n >>= 1; + } + + +done: + +if( asign ) + y = -y; /* odd power of negative number */ +if( sign < 0 ) + y = 1.0L/y; +return(y); +} diff --git a/libm/ldouble/powl.c b/libm/ldouble/powl.c new file mode 100644 index 000000000..bad380696 --- /dev/null +++ b/libm/ldouble/powl.c @@ -0,0 +1,739 @@ +/* powl.c + * + * Power function, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, z, powl(); + * + * z = powl( x, y ); + * + * + * + * DESCRIPTION: + * + * Computes x raised to the yth power. Analytically, + * + * x**y = exp( y log(x) ). + * + * Following Cody and Waite, this program uses a lookup table + * of 2**-i/32 and pseudo extended precision arithmetic to + * obtain several extra bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * The relative error of pow(x,y) can be estimated + * by y dl ln(2), where dl is the absolute error of + * the internally computed base 2 logarithm. At the ends + * of the approximation interval the logarithm equal 1/32 + * and its relative error is about 1 lsb = 1.1e-19. Hence + * the predicted relative error in the result is 2.3e-21 y . + * + * Relative error: + * arithmetic domain # trials peak rms + * + * IEEE +-1000 40000 2.8e-18 3.7e-19 + * .001 < x < 1000, with log(x) uniformly distributed. + * -1000 < y < 1000, y uniformly distributed. + * + * IEEE 0,8700 60000 6.5e-18 1.0e-18 + * 0.99 < x < 1.01, 0 < y < 8700, uniformly distributed. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * pow overflow x**y > MAXNUM INFINITY + * pow underflow x**y < 1/MAXNUM 0.0 + * pow domain x<0 and y noninteger 0.0 + * + */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +static char fname[] = {"powl"}; + +/* Table size */ +#define NXT 32 +/* log2(Table size) */ +#define LNXT 5 + +#ifdef UNK +/* log(1+x) = x - .5x^2 + x^3 * P(z)/Q(z) + * on the domain 2^(-1/32) - 1 <= x <= 2^(1/32) - 1 + */ +static long double P[] = { + 8.3319510773868690346226E-4L, + 4.9000050881978028599627E-1L, + 1.7500123722550302671919E0L, + 1.4000100839971580279335E0L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ + 5.2500282295834889175431E0L, + 8.4000598057587009834666E0L, + 4.2000302519914740834728E0L, +}; +/* A[i] = 2^(-i/32), rounded to IEEE long double precision. + * If i is even, A[i] + B[i/2] gives additional accuracy. + */ +static long double A[33] = { + 1.0000000000000000000000E0L, + 9.7857206208770013448287E-1L, + 9.5760328069857364691013E-1L, + 9.3708381705514995065011E-1L, + 9.1700404320467123175367E-1L, + 8.9735453750155359320742E-1L, + 8.7812608018664974155474E-1L, + 8.5930964906123895780165E-1L, + 8.4089641525371454301892E-1L, + 8.2287773907698242225554E-1L, + 8.0524516597462715409607E-1L, + 7.8799042255394324325455E-1L, + 7.7110541270397041179298E-1L, + 7.5458221379671136985669E-1L, + 7.3841307296974965571198E-1L, + 7.2259040348852331001267E-1L, + 7.0710678118654752438189E-1L, + 6.9195494098191597746178E-1L, + 6.7712777346844636413344E-1L, + 6.6261832157987064729696E-1L, + 6.4841977732550483296079E-1L, + 6.3452547859586661129850E-1L, + 6.2092890603674202431705E-1L, + 6.0762367999023443907803E-1L, + 5.9460355750136053334378E-1L, + 5.8186242938878875689693E-1L, + 5.6939431737834582684856E-1L, + 5.5719337129794626814472E-1L, + 5.4525386633262882960438E-1L, + 5.3357020033841180906486E-1L, + 5.2213689121370692017331E-1L, + 5.1094857432705833910408E-1L, + 5.0000000000000000000000E-1L, +}; +static long double B[17] = { + 0.0000000000000000000000E0L, + 2.6176170809902549338711E-20L, +-1.0126791927256478897086E-20L, + 1.3438228172316276937655E-21L, + 1.2207982955417546912101E-20L, +-6.3084814358060867200133E-21L, + 1.3164426894366316434230E-20L, +-1.8527916071632873716786E-20L, + 1.8950325588932570796551E-20L, + 1.5564775779538780478155E-20L, + 6.0859793637556860974380E-21L, +-2.0208749253662532228949E-20L, + 1.4966292219224761844552E-20L, + 3.3540909728056476875639E-21L, +-8.6987564101742849540743E-22L, +-1.2327176863327626135542E-20L, + 0.0000000000000000000000E0L, +}; + +/* 2^x = 1 + x P(x), + * on the interval -1/32 <= x <= 0 + */ +static long double R[] = { + 1.5089970579127659901157E-5L, + 1.5402715328927013076125E-4L, + 1.3333556028915671091390E-3L, + 9.6181291046036762031786E-3L, + 5.5504108664798463044015E-2L, + 2.4022650695910062854352E-1L, + 6.9314718055994530931447E-1L, +}; + +#define douba(k) A[k] +#define doubb(k) B[k] +#define MEXP (NXT*16384.0L) +/* The following if denormal numbers are supported, else -MEXP: */ +#ifdef DENORMAL +#define MNEXP (-NXT*(16384.0L+64.0L)) +#else +#define MNEXP (-NXT*16384.0L) +#endif +/* log2(e) - 1 */ +#define LOG2EA 0.44269504088896340735992L +#endif + + +#ifdef IBMPC +static short P[] = { +0xb804,0xa8b7,0xc6f4,0xda6a,0x3ff4, XPD +0x7de9,0xcf02,0x58c0,0xfae1,0x3ffd, XPD +0x405a,0x3722,0x67c9,0xe000,0x3fff, XPD +0xcd99,0x6b43,0x87ca,0xb333,0x3fff, XPD +}; +static short Q[] = { +/* 0x0000,0x0000,0x0000,0x8000,0x3fff, */ +0x6307,0xa469,0x3b33,0xa800,0x4001, XPD +0xfec2,0x62d7,0xa51c,0x8666,0x4002, XPD +0xda32,0xd072,0xa5d7,0x8666,0x4001, XPD +}; +static short A[] = { +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +0x033a,0x722a,0xb2db,0xfa83,0x3ffe, XPD +0xcc2c,0x2486,0x7d15,0xf525,0x3ffe, XPD +0xf5cb,0xdcda,0xb99b,0xefe4,0x3ffe, XPD +0x392f,0xdd24,0xc6e7,0xeac0,0x3ffe, XPD +0x48a8,0x7c83,0x06e7,0xe5b9,0x3ffe, XPD +0xe111,0x2a94,0xdeec,0xe0cc,0x3ffe, XPD +0x3755,0xdaf2,0xb797,0xdbfb,0x3ffe, XPD +0x6af4,0xd69d,0xfcca,0xd744,0x3ffe, XPD +0xe45a,0xf12a,0x1d91,0xd2a8,0x3ffe, XPD +0x80e4,0x1f84,0x8c15,0xce24,0x3ffe, XPD +0x27a3,0x6e2f,0xbd86,0xc9b9,0x3ffe, XPD +0xdadd,0x5506,0x2a11,0xc567,0x3ffe, XPD +0x9456,0x6670,0x4cca,0xc12c,0x3ffe, XPD +0x36bf,0x580c,0xa39f,0xbd08,0x3ffe, XPD +0x9ee9,0x62fb,0xaf47,0xb8fb,0x3ffe, XPD +0x6484,0xf9de,0xf333,0xb504,0x3ffe, XPD +0x2590,0xd2ac,0xf581,0xb123,0x3ffe, XPD +0x4ac6,0x42a1,0x3eea,0xad58,0x3ffe, XPD +0x0ef8,0xea7c,0x5ab4,0xa9a1,0x3ffe, XPD +0x38ea,0xb151,0xd6a9,0xa5fe,0x3ffe, XPD +0x6819,0x0c49,0x4303,0xa270,0x3ffe, XPD +0x11ae,0x91a1,0x3260,0x9ef5,0x3ffe, XPD +0x5539,0xd54e,0x39b9,0x9b8d,0x3ffe, XPD +0xa96f,0x8db8,0xf051,0x9837,0x3ffe, XPD +0x0961,0xfef7,0xefa8,0x94f4,0x3ffe, XPD +0xc336,0xab11,0xd373,0x91c3,0x3ffe, XPD +0x53c0,0x45cd,0x398b,0x8ea4,0x3ffe, XPD +0xd6e7,0xea8b,0xc1e3,0x8b95,0x3ffe, XPD +0x8527,0x92da,0x0e80,0x8898,0x3ffe, XPD +0x7b15,0xcc48,0xc367,0x85aa,0x3ffe, XPD +0xa1d7,0xac2b,0x8698,0x82cd,0x3ffe, XPD +0x0000,0x0000,0x0000,0x8000,0x3ffe, XPD +}; +static short B[] = { +0x0000,0x0000,0x0000,0x0000,0x0000, XPD +0x1f87,0xdb30,0x18f5,0xf73a,0x3fbd, XPD +0xac15,0x3e46,0x2932,0xbf4a,0xbfbc, XPD +0x7944,0xba66,0xa091,0xcb12,0x3fb9, XPD +0xff78,0x40b4,0x2ee6,0xe69a,0x3fbc, XPD +0xc895,0x5069,0xe383,0xee53,0xbfbb, XPD +0x7cde,0x9376,0x4325,0xf8ab,0x3fbc, XPD +0xa10c,0x25e0,0xc093,0xaefd,0xbfbd, XPD +0x7d3e,0xea95,0x1366,0xb2fb,0x3fbd, XPD +0x5d89,0xeb34,0x5191,0x9301,0x3fbd, XPD +0x80d9,0xb883,0xfb10,0xe5eb,0x3fbb, XPD +0x045d,0x288c,0xc1ec,0xbedd,0xbfbd, XPD +0xeded,0x5c85,0x4630,0x8d5a,0x3fbd, XPD +0x9d82,0xe5ac,0x8e0a,0xfd6d,0x3fba, XPD +0x6dfd,0xeb58,0xaf14,0x8373,0xbfb9, XPD +0xf938,0x7aac,0x91cf,0xe8da,0xbfbc, XPD +0x0000,0x0000,0x0000,0x0000,0x0000, XPD +}; +static short R[] = { +0xa69b,0x530e,0xee1d,0xfd2a,0x3fee, XPD +0xc746,0x8e7e,0x5960,0xa182,0x3ff2, XPD +0x63b6,0xadda,0xfd6a,0xaec3,0x3ff5, XPD +0xc104,0xfd99,0x5b7c,0x9d95,0x3ff8, XPD +0xe05e,0x249d,0x46b8,0xe358,0x3ffa, XPD +0x5d1d,0x162c,0xeffc,0xf5fd,0x3ffc, XPD +0x79aa,0xd1cf,0x17f7,0xb172,0x3ffe, XPD +}; + +/* 10 byte sizes versus 12 byte */ +#define douba(k) (*(long double *)(&A[(sizeof( long double )/2)*(k)])) +#define doubb(k) (*(long double *)(&B[(sizeof( long double )/2)*(k)])) +#define MEXP (NXT*16384.0L) +#ifdef DENORMAL +#define MNEXP (-NXT*(16384.0L+64.0L)) +#else +#define MNEXP (-NXT*16384.0L) +#endif +static short L[] = {0xc2ef,0x705f,0xeca5,0xe2a8,0x3ffd, XPD}; +#define LOG2EA (*(long double *)(&L[0])) +#endif + +#ifdef MIEEE +static long P[] = { +0x3ff40000,0xda6ac6f4,0xa8b7b804, +0x3ffd0000,0xfae158c0,0xcf027de9, +0x3fff0000,0xe00067c9,0x3722405a, +0x3fff0000,0xb33387ca,0x6b43cd99, +}; +static long Q[] = { +/* 0x3fff0000,0x80000000,0x00000000, */ +0x40010000,0xa8003b33,0xa4696307, +0x40020000,0x8666a51c,0x62d7fec2, +0x40010000,0x8666a5d7,0xd072da32, +}; +static long A[] = { +0x3fff0000,0x80000000,0x00000000, +0x3ffe0000,0xfa83b2db,0x722a033a, +0x3ffe0000,0xf5257d15,0x2486cc2c, +0x3ffe0000,0xefe4b99b,0xdcdaf5cb, +0x3ffe0000,0xeac0c6e7,0xdd24392f, +0x3ffe0000,0xe5b906e7,0x7c8348a8, +0x3ffe0000,0xe0ccdeec,0x2a94e111, +0x3ffe0000,0xdbfbb797,0xdaf23755, +0x3ffe0000,0xd744fcca,0xd69d6af4, +0x3ffe0000,0xd2a81d91,0xf12ae45a, +0x3ffe0000,0xce248c15,0x1f8480e4, +0x3ffe0000,0xc9b9bd86,0x6e2f27a3, +0x3ffe0000,0xc5672a11,0x5506dadd, +0x3ffe0000,0xc12c4cca,0x66709456, +0x3ffe0000,0xbd08a39f,0x580c36bf, +0x3ffe0000,0xb8fbaf47,0x62fb9ee9, +0x3ffe0000,0xb504f333,0xf9de6484, +0x3ffe0000,0xb123f581,0xd2ac2590, +0x3ffe0000,0xad583eea,0x42a14ac6, +0x3ffe0000,0xa9a15ab4,0xea7c0ef8, +0x3ffe0000,0xa5fed6a9,0xb15138ea, +0x3ffe0000,0xa2704303,0x0c496819, +0x3ffe0000,0x9ef53260,0x91a111ae, +0x3ffe0000,0x9b8d39b9,0xd54e5539, +0x3ffe0000,0x9837f051,0x8db8a96f, +0x3ffe0000,0x94f4efa8,0xfef70961, +0x3ffe0000,0x91c3d373,0xab11c336, +0x3ffe0000,0x8ea4398b,0x45cd53c0, +0x3ffe0000,0x8b95c1e3,0xea8bd6e7, +0x3ffe0000,0x88980e80,0x92da8527, +0x3ffe0000,0x85aac367,0xcc487b15, +0x3ffe0000,0x82cd8698,0xac2ba1d7, +0x3ffe0000,0x80000000,0x00000000, +}; +static long B[51] = { +0x00000000,0x00000000,0x00000000, +0x3fbd0000,0xf73a18f5,0xdb301f87, +0xbfbc0000,0xbf4a2932,0x3e46ac15, +0x3fb90000,0xcb12a091,0xba667944, +0x3fbc0000,0xe69a2ee6,0x40b4ff78, +0xbfbb0000,0xee53e383,0x5069c895, +0x3fbc0000,0xf8ab4325,0x93767cde, +0xbfbd0000,0xaefdc093,0x25e0a10c, +0x3fbd0000,0xb2fb1366,0xea957d3e, +0x3fbd0000,0x93015191,0xeb345d89, +0x3fbb0000,0xe5ebfb10,0xb88380d9, +0xbfbd0000,0xbeddc1ec,0x288c045d, +0x3fbd0000,0x8d5a4630,0x5c85eded, +0x3fba0000,0xfd6d8e0a,0xe5ac9d82, +0xbfb90000,0x8373af14,0xeb586dfd, +0xbfbc0000,0xe8da91cf,0x7aacf938, +0x00000000,0x00000000,0x00000000, +}; +static long R[] = { +0x3fee0000,0xfd2aee1d,0x530ea69b, +0x3ff20000,0xa1825960,0x8e7ec746, +0x3ff50000,0xaec3fd6a,0xadda63b6, +0x3ff80000,0x9d955b7c,0xfd99c104, +0x3ffa0000,0xe35846b8,0x249de05e, +0x3ffc0000,0xf5fdeffc,0x162c5d1d, +0x3ffe0000,0xb17217f7,0xd1cf79aa, +}; + +#define douba(k) (*(long double *)&A[3*(k)]) +#define doubb(k) (*(long double *)&B[3*(k)]) +#define MEXP (NXT*16384.0L) +#ifdef DENORMAL +#define MNEXP (-NXT*(16384.0L+64.0L)) +#else +#define MNEXP (-NXT*16382.0L) +#endif +static long L[3] = {0x3ffd0000,0xe2a8eca5,0x705fc2ef}; +#define LOG2EA (*(long double *)(&L[0])) +#endif + + +#define F W +#define Fa Wa +#define Fb Wb +#define G W +#define Ga Wa +#define Gb u +#define H W +#define Ha Wb +#define Hb Wb + +extern long double MAXNUML; +static VOLATILE long double z; +static long double w, W, Wa, Wb, ya, yb, u; +#ifdef ANSIPROT +extern long double floorl ( long double ); +extern long double fabsl ( long double ); +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double powil ( long double, int ); +extern int isnanl ( long double ); +extern int isfinitel ( long double ); +static long double reducl( long double ); +extern int signbitl ( long double ); +#else +long double floorl(), fabsl(), frexpl(), ldexpl(); +long double polevll(), p1evll(), powil(); +static long double reducl(); +int isnanl(), isfinitel(), signbitl(); +#endif + +#ifdef INFINITIES +extern long double INFINITYL; +#else +#define INFINITYL MAXNUML +#endif + +#ifdef NANS +extern long double NANL; +#endif +#ifdef MINUSZERO +extern long double NEGZEROL; +#endif + +long double powl( x, y ) +long double x, y; +{ +/* double F, Fa, Fb, G, Ga, Gb, H, Ha, Hb */ +int i, nflg, iyflg, yoddint; +long e; + +if( y == 0.0L ) + return( 1.0L ); + +#ifdef NANS +if( isnanl(x) ) + return( x ); +if( isnanl(y) ) + return( y ); +#endif + +if( y == 1.0L ) + return( x ); + +#ifdef INFINITIES +if( !isfinitel(y) && (x == -1.0L || x == 1.0L) ) + { + mtherr( "powl", DOMAIN ); +#ifdef NANS + return( NANL ); +#else + return( INFINITYL ); +#endif + } +#endif + +if( x == 1.0L ) + return( 1.0L ); + +if( y >= MAXNUML ) + { +#ifdef INFINITIES + if( x > 1.0L ) + return( INFINITYL ); +#else + if( x > 1.0L ) + return( MAXNUML ); +#endif + if( x > 0.0L && x < 1.0L ) + return( 0.0L ); +#ifdef INFINITIES + if( x < -1.0L ) + return( INFINITYL ); +#else + if( x < -1.0L ) + return( MAXNUML ); +#endif + if( x > -1.0L && x < 0.0L ) + return( 0.0L ); + } +if( y <= -MAXNUML ) + { + if( x > 1.0L ) + return( 0.0L ); +#ifdef INFINITIES + if( x > 0.0L && x < 1.0L ) + return( INFINITYL ); +#else + if( x > 0.0L && x < 1.0L ) + return( MAXNUML ); +#endif + if( x < -1.0L ) + return( 0.0L ); +#ifdef INFINITIES + if( x > -1.0L && x < 0.0L ) + return( INFINITYL ); +#else + if( x > -1.0L && x < 0.0L ) + return( MAXNUML ); +#endif + } +if( x >= MAXNUML ) + { +#if INFINITIES + if( y > 0.0L ) + return( INFINITYL ); +#else + if( y > 0.0L ) + return( MAXNUML ); +#endif + return( 0.0L ); + } + +w = floorl(y); +/* Set iyflg to 1 if y is an integer. */ +iyflg = 0; +if( w == y ) + iyflg = 1; + +/* Test for odd integer y. */ +yoddint = 0; +if( iyflg ) + { + ya = fabsl(y); + ya = floorl(0.5L * ya); + yb = 0.5L * fabsl(w); + if( ya != yb ) + yoddint = 1; + } + +if( x <= -MAXNUML ) + { + if( y > 0.0L ) + { +#ifdef INFINITIES + if( yoddint ) + return( -INFINITYL ); + return( INFINITYL ); +#else + if( yoddint ) + return( -MAXNUML ); + return( MAXNUML ); +#endif + } + if( y < 0.0L ) + { +#ifdef MINUSZERO + if( yoddint ) + return( NEGZEROL ); +#endif + return( 0.0 ); + } + } + + +nflg = 0; /* flag = 1 if x<0 raised to integer power */ +if( x <= 0.0L ) + { + if( x == 0.0L ) + { + if( y < 0.0 ) + { +#ifdef MINUSZERO + if( signbitl(x) && yoddint ) + return( -INFINITYL ); +#endif +#ifdef INFINITIES + return( INFINITYL ); +#else + return( MAXNUML ); +#endif + } + if( y > 0.0 ) + { +#ifdef MINUSZERO + if( signbitl(x) && yoddint ) + return( NEGZEROL ); +#endif + return( 0.0 ); + } + if( y == 0.0L ) + return( 1.0L ); /* 0**0 */ + else + return( 0.0L ); /* 0**y */ + } + else + { + if( iyflg == 0 ) + { /* noninteger power of negative number */ + mtherr( fname, DOMAIN ); +#ifdef NANS + return(NANL); +#else + return(0.0L); +#endif + } + nflg = 1; + } + } + +/* Integer power of an integer. */ + +if( iyflg ) + { + i = w; + w = floorl(x); + if( (w == x) && (fabsl(y) < 32768.0) ) + { + w = powil( x, (int) y ); + return( w ); + } + } + + +if( nflg ) + x = fabsl(x); + +/* separate significand from exponent */ +x = frexpl( x, &i ); +e = i; + +/* find significand in antilog table A[] */ +i = 1; +if( x <= douba(17) ) + i = 17; +if( x <= douba(i+8) ) + i += 8; +if( x <= douba(i+4) ) + i += 4; +if( x <= douba(i+2) ) + i += 2; +if( x >= douba(1) ) + i = -1; +i += 1; + + +/* Find (x - A[i])/A[i] + * in order to compute log(x/A[i]): + * + * log(x) = log( a x/a ) = log(a) + log(x/a) + * + * log(x/a) = log(1+v), v = x/a - 1 = (x-a)/a + */ +x -= douba(i); +x -= doubb(i/2); +x /= douba(i); + + +/* rational approximation for log(1+v): + * + * log(1+v) = v - v**2/2 + v**3 P(v) / Q(v) + */ +z = x*x; +w = x * ( z * polevll( x, P, 3 ) / p1evll( x, Q, 3 ) ); +w = w - ldexpl( z, -1 ); /* w - 0.5 * z */ + +/* Convert to base 2 logarithm: + * multiply by log2(e) = 1 + LOG2EA + */ +z = LOG2EA * w; +z += w; +z += LOG2EA * x; +z += x; + +/* Compute exponent term of the base 2 logarithm. */ +w = -i; +w = ldexpl( w, -LNXT ); /* divide by NXT */ +w += e; +/* Now base 2 log of x is w + z. */ + +/* Multiply base 2 log by y, in extended precision. */ + +/* separate y into large part ya + * and small part yb less than 1/NXT + */ +ya = reducl(y); +yb = y - ya; + +/* (w+z)(ya+yb) + * = w*ya + w*yb + z*y + */ +F = z * y + w * yb; +Fa = reducl(F); +Fb = F - Fa; + +G = Fa + w * ya; +Ga = reducl(G); +Gb = G - Ga; + +H = Fb + Gb; +Ha = reducl(H); +w = ldexpl( Ga+Ha, LNXT ); + +/* Test the power of 2 for overflow */ +if( w > MEXP ) + { +/* printf( "w = %.4Le ", w ); */ + mtherr( fname, OVERFLOW ); + return( MAXNUML ); + } + +if( w < MNEXP ) + { +/* printf( "w = %.4Le ", w ); */ + mtherr( fname, UNDERFLOW ); + return( 0.0L ); + } + +e = w; +Hb = H - Ha; + +if( Hb > 0.0L ) + { + e += 1; + Hb -= (1.0L/NXT); /*0.0625L;*/ + } + +/* Now the product y * log2(x) = Hb + e/NXT. + * + * Compute base 2 exponential of Hb, + * where -0.0625 <= Hb <= 0. + */ +z = Hb * polevll( Hb, R, 6 ); /* z = 2**Hb - 1 */ + +/* Express e/NXT as an integer plus a negative number of (1/NXT)ths. + * Find lookup table entry for the fractional power of 2. + */ +if( e < 0 ) + i = 0; +else + i = 1; +i = e/NXT + i; +e = NXT*i - e; +w = douba( e ); +z = w * z; /* 2**-e * ( 1 + (2**Hb-1) ) */ +z = z + w; +z = ldexpl( z, i ); /* multiply by integer power of 2 */ + +if( nflg ) + { +/* For negative x, + * find out if the integer exponent + * is odd or even. + */ + w = ldexpl( y, -1 ); + w = floorl(w); + w = ldexpl( w, 1 ); + if( w != y ) + z = -z; /* odd exponent */ + } + +return( z ); +} + + +/* Find a multiple of 1/NXT that is within 1/NXT of x. */ +static long double reducl(x) +long double x; +{ +long double t; + +t = ldexpl( x, LNXT ); +t = floorl( t ); +t = ldexpl( t, -LNXT ); +return(t); +} diff --git a/libm/ldouble/sinhl.c b/libm/ldouble/sinhl.c new file mode 100644 index 000000000..0533a1c7a --- /dev/null +++ b/libm/ldouble/sinhl.c @@ -0,0 +1,150 @@ +/* sinhl.c + * + * Hyperbolic sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sinhl(); + * + * y = sinhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOGL to + * MAXLOGL. + * + * The range is partitioned into two segments. If |x| <= 1, a + * rational function of the form x + x**3 P(x)/Q(x) is employed. + * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 10000 1.5e-19 3.9e-20 + * IEEE +-10000 30000 1.1e-19 2.8e-20 + * + */ + +/* +Cephes Math Library Release 2.7: January, 1998 +Copyright 1984, 1991, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double P[] = { + 1.7550769032975377032681E-6L, + 4.1680702175874268714539E-4L, + 3.0993532520425419002409E-2L, + 9.9999999999999999998002E-1L, +}; +static long double Q[] = { + 1.7453965448620151484660E-8L, +-5.9116673682651952419571E-6L, + 1.0599252315677389339530E-3L, +-1.1403880487744749056675E-1L, + 6.0000000000000000000200E0L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0xec6a,0xd942,0xfbb3,0xeb8f,0x3feb, XPD +0x365e,0xb30a,0xe437,0xda86,0x3ff3, XPD +0x8890,0x01f6,0x2612,0xfde6,0x3ff9, XPD +0x0000,0x0000,0x0000,0x8000,0x3fff, XPD +}; +static short Q[] = { +0x4edd,0x4c21,0xad09,0x95ed,0x3fe5, XPD +0x4376,0x9b70,0xd605,0xc65c,0xbfed, XPD +0xc8ad,0x5d21,0x3069,0x8aed,0x3ff5, XPD +0x9c32,0x6374,0x2d4b,0xe98d,0xbffb, XPD +0x0000,0x0000,0x0000,0xc000,0x4001, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0x3feb0000,0xeb8ffbb3,0xd942ec6a, +0x3ff30000,0xda86e437,0xb30a365e, +0x3ff90000,0xfde62612,0x01f68890, +0x3fff0000,0x80000000,0x00000000, +}; +static long Q[] = { +0x3fe50000,0x95edad09,0x4c214edd, +0xbfed0000,0xc65cd605,0x9b704376, +0x3ff50000,0x8aed3069,0x5d21c8ad, +0xbffb0000,0xe98d2d4b,0x63749c32, +0x40010000,0xc0000000,0x00000000, +}; +#endif + +extern long double MAXNUML, MAXLOGL, MINLOGL, LOGE2L; +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double expl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +#else +long double fabsl(), expl(), polevll(), p1evll(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double sinhl(x) +long double x; +{ +long double a; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +a = fabsl(x); +if( (x > (MAXLOGL + LOGE2L)) || (x > -(MINLOGL-LOGE2L) ) ) + { + mtherr( "sinhl", DOMAIN ); +#ifdef INFINITIES + if( x > 0.0L ) + return( INFINITYL ); + else + return( -INFINITYL ); +#else + if( x > 0.0L ) + return( MAXNUML ); + else + return( -MAXNUML ); +#endif + } +if( a > 1.0L ) + { + if( a >= (MAXLOGL - LOGE2L) ) + { + a = expl(0.5L*a); + a = (0.5L * a) * a; + if( x < 0.0L ) + a = -a; + return(a); + } + a = expl(a); + a = 0.5L*a - (0.5L/a); + if( x < 0.0L ) + a = -a; + return(a); + } + +a *= a; +return( x + x * a * (polevll(a,P,3)/polevll(a,Q,4)) ); +} diff --git a/libm/ldouble/sinl.c b/libm/ldouble/sinl.c new file mode 100644 index 000000000..dc7d739f9 --- /dev/null +++ b/libm/ldouble/sinl.c @@ -0,0 +1,342 @@ +/* sinl.c + * + * Circular sine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sinl(); + * + * y = sinl( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of pi/4. The reduction + * error is nearly eliminated by contriving an extended precision + * modular arithmetic. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by the Cody + * and Waite polynomial form + * x + x**3 P(x**2) . + * Between pi/4 and pi/2 the cosine is represented as + * 1 - .5 x**2 + x**4 Q(x**2) . + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-5.5e11 200,000 1.2e-19 2.9e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2**39 0.0 + * + * Loss of precision occurs for x > 2**39 = 5.49755813888e11. + * The routine as implemented flags a TLOSS error for + * x > 2**39 and returns 0.0. + */ + /* cosl.c + * + * Circular cosine, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cosl(); + * + * y = cosl( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of pi/4. The reduction + * error is nearly eliminated by contriving an extended precision + * modular arithmetic. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - .5 x**2 + x**4 Q(x**2) . + * Between pi/4 and pi/2 the sine is represented by the Cody + * and Waite polynomial form + * x + x**3 P(x**2) . + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-5.5e11 50000 1.2e-19 2.9e-20 + */ + +/* sin.c */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1985, 1990, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double sincof[7] = { +-7.5785404094842805756289E-13L, + 1.6058363167320443249231E-10L, +-2.5052104881870868784055E-8L, + 2.7557319214064922217861E-6L, +-1.9841269841254799668344E-4L, + 8.3333333333333225058715E-3L, +-1.6666666666666666640255E-1L, +}; +static long double coscof[7] = { + 4.7377507964246204691685E-14L, +-1.1470284843425359765671E-11L, + 2.0876754287081521758361E-9L, +-2.7557319214999787979814E-7L, + 2.4801587301570552304991E-5L, +-1.3888888888888872993737E-3L, + 4.1666666666666666609054E-2L, +}; +static long double DP1 = 7.853981554508209228515625E-1L; +static long double DP2 = 7.946627356147928367136046290398E-9L; +static long double DP3 = 3.061616997868382943065164830688E-17L; +#endif + +#ifdef IBMPC +static short sincof[] = { +0x4e27,0xe1d6,0x2389,0xd551,0xbfd6, XPD +0x64d7,0xe706,0x4623,0xb090,0x3fde, XPD +0x01b1,0xbf34,0x2946,0xd732,0xbfe5, XPD +0xc8f7,0x9845,0x1d29,0xb8ef,0x3fec, XPD +0x6514,0x0c53,0x00d0,0xd00d,0xbff2, XPD +0x569a,0x8888,0x8888,0x8888,0x3ff8, XPD +0xaa97,0xaaaa,0xaaaa,0xaaaa,0xbffc, XPD +}; +static short coscof[] = { +0x7436,0x6f99,0x8c3a,0xd55e,0x3fd2, XPD +0x2f37,0x58f4,0x920f,0xc9c9,0xbfda, XPD +0x5350,0x659e,0xc648,0x8f76,0x3fe2, XPD +0x4d2b,0xf5c6,0x7dba,0x93f2,0xbfe9, XPD +0x53ed,0x0c66,0x00d0,0xd00d,0x3fef, XPD +0x7b67,0x0b60,0x60b6,0xb60b,0xbff5, XPD +0xaa9a,0xaaaa,0xaaaa,0xaaaa,0x3ffa, XPD +}; +static short P1[] = {0x0000,0x0000,0xda80,0xc90f,0x3ffe, XPD}; +static short P2[] = {0x0000,0x0000,0xa300,0x8885,0x3fe4, XPD}; +static short P3[] = {0x3707,0xa2e0,0x3198,0x8d31,0x3fc8, XPD}; +#define DP1 *(long double *)P1 +#define DP2 *(long double *)P2 +#define DP3 *(long double *)P3 +#endif + +#ifdef MIEEE +static long sincof[] = { +0xbfd60000,0xd5512389,0xe1d64e27, +0x3fde0000,0xb0904623,0xe70664d7, +0xbfe50000,0xd7322946,0xbf3401b1, +0x3fec0000,0xb8ef1d29,0x9845c8f7, +0xbff20000,0xd00d00d0,0x0c536514, +0x3ff80000,0x88888888,0x8888569a, +0xbffc0000,0xaaaaaaaa,0xaaaaaa97, +}; +static long coscof[] = { +0x3fd20000,0xd55e8c3a,0x6f997436, +0xbfda0000,0xc9c9920f,0x58f42f37, +0x3fe20000,0x8f76c648,0x659e5350, +0xbfe90000,0x93f27dba,0xf5c64d2b, +0x3fef0000,0xd00d00d0,0x0c6653ed, +0xbff50000,0xb60b60b6,0x0b607b67, +0x3ffa0000,0xaaaaaaaa,0xaaaaaa9a, +}; +static long P1[] = {0x3ffe0000,0xc90fda80,0x00000000}; +static long P2[] = {0x3fe40000,0x8885a300,0x00000000}; +static long P3[] = {0x3fc80000,0x8d313198,0xa2e03707}; +#define DP1 *(long double *)P1 +#define DP2 *(long double *)P2 +#define DP3 *(long double *)P3 +#endif + +static long double lossth = 5.49755813888e11L; /* 2^39 */ +extern long double PIO4L; +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double floorl ( long double ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +extern int isfinitel ( long double ); +#else +long double polevll(), floorl(), ldexpl(), isnanl(), isfinitel(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double sinl(x) +long double x; +{ +long double y, z, zz; +int j, sign; + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +#ifdef NANS +if( !isfinitel(x) ) + { + mtherr( "sinl", DOMAIN ); +#ifdef NANS + return(NANL); +#else + return(0.0L); +#endif + } +#endif +/* make argument positive but save the sign */ +sign = 1; +if( x < 0 ) + { + x = -x; + sign = -1; + } + +if( x > lossth ) + { + mtherr( "sinl", TLOSS ); + return(0.0L); + } + +y = floorl( x/PIO4L ); /* integer part of x/PIO4 */ + +/* strip high bits of integer part to prevent integer overflow */ +z = ldexpl( y, -4 ); +z = floorl(z); /* integer part of y/8 */ +z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ + +j = z; /* convert to integer for tests on the phase angle */ +/* map zeros to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0L; + } +j = j & 07; /* octant modulo 360 degrees */ +/* reflect in x axis */ +if( j > 3) + { + sign = -sign; + j -= 4; + } + +/* Extended precision modular arithmetic */ +z = ((x - y * DP1) - y * DP2) - y * DP3; + +zz = z * z; +if( (j==1) || (j==2) ) + { + y = 1.0L - ldexpl(zz,-1) + zz * zz * polevll( zz, coscof, 6 ); + } +else + { + y = z + z * (zz * polevll( zz, sincof, 6 )); + } + +if(sign < 0) + y = -y; + +return(y); +} + + + + + +long double cosl(x) +long double x; +{ +long double y, z, zz; +long i; +int j, sign; + + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef INFINITIES +if( !isfinitel(x) ) + { + mtherr( "cosl", DOMAIN ); +#ifdef NANS + return(NANL); +#else + return(0.0L); +#endif + } +#endif + +/* make argument positive */ +sign = 1; +if( x < 0 ) + x = -x; + +if( x > lossth ) + { + mtherr( "cosl", TLOSS ); + return(0.0L); + } + +y = floorl( x/PIO4L ); +z = ldexpl( y, -4 ); +z = floorl(z); /* integer part of y/8 */ +z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ + +/* integer and fractional part modulo one octant */ +i = z; +if( i & 1 ) /* map zeros to origin */ + { + i += 1; + y += 1.0L; + } +j = i & 07; +if( j > 3) + { + j -=4; + sign = -sign; + } + +if( j > 1 ) + sign = -sign; + +/* Extended precision modular arithmetic */ +z = ((x - y * DP1) - y * DP2) - y * DP3; + +zz = z * z; +if( (j==1) || (j==2) ) + { + y = z + z * (zz * polevll( zz, sincof, 6 )); + } +else + { + y = 1.0L - ldexpl(zz,-1) + zz * zz * polevll( zz, coscof, 6 ); + } + +if(sign < 0) + y = -y; + +return(y); +} diff --git a/libm/ldouble/sqrtl.c b/libm/ldouble/sqrtl.c new file mode 100644 index 000000000..a3b17175f --- /dev/null +++ b/libm/ldouble/sqrtl.c @@ -0,0 +1,172 @@ +/* sqrtl.c + * + * Square root, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, sqrtl(); + * + * y = sqrtl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the square root of x. + * + * Range reduction involves isolating the power of two of the + * argument and using a polynomial approximation to obtain + * a rough value for the square root. Then Heron's iteration + * is used three times to converge to an accurate value. + * + * Note, some arithmetic coprocessors such as the 8087 and + * 68881 produce correctly rounded square roots, which this + * routine will not. + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 30000 8.1e-20 3.1e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrt domain x < 0 0.0 + * + */ + +/* +Cephes Math Library Release 2.2: December, 1990 +Copyright 1984, 1990 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +#define SQRT2 1.4142135623730950488017E0L +#ifdef ANSIPROT +extern long double frexpl ( long double, int * ); +extern long double ldexpl ( long double, int ); +#else +long double frexpl(), ldexpl(); +#endif + +long double sqrtl(x) +long double x; +{ +int e; +long double z, w; +#ifndef UNK +short *q; +#endif + +if( x <= 0.0 ) + { + if( x < 0.0 ) + mtherr( "sqrtl", DOMAIN ); + return( 0.0 ); + } +w = x; +/* separate exponent and significand */ +#ifdef UNK +z = frexpl( x, &e ); +#endif + +/* Note, frexp and ldexp are used in order to + * handle denormal numbers properly. + */ +#ifdef IBMPC +z = frexpl( x, &e ); +q = (short *)&x; /* point to the exponent word */ +q += 4; +/* +e = ((*q >> 4) & 0x0fff) - 0x3fe; +*q &= 0x000f; +*q |= 0x3fe0; +z = x; +*/ +#endif +#ifdef MIEEE +z = frexpl( x, &e ); +q = (short *)&x; +/* +e = ((*q >> 4) & 0x0fff) - 0x3fe; +*q &= 0x000f; +*q |= 0x3fe0; +z = x; +*/ +#endif + +/* approximate square root of number between 0.5 and 1 + * relative error of linear approximation = 7.47e-3 + */ +/* +x = 0.4173075996388649989089L + 0.59016206709064458299663L * z; +*/ + +/* quadratic approximation, relative error 6.45e-4 */ +x = ( -0.20440583154734771959904L * z + + 0.89019407351052789754347L) * z + + 0.31356706742295303132394L; + +/* adjust for odd powers of 2 */ +if( (e & 1) != 0 ) + x *= SQRT2; + +/* re-insert exponent */ +#ifdef UNK +x = ldexpl( x, (e >> 1) ); +#endif +#ifdef IBMPC +x = ldexpl( x, (e >> 1) ); +/* +*q += ((e >>1) & 0x7ff) << 4; +*q &= 077777; +*/ +#endif +#ifdef MIEEE +x = ldexpl( x, (e >> 1) ); +/* +*q += ((e >>1) & 0x7ff) << 4; +*q &= 077777; +*/ +#endif + +/* Newton iterations: */ +#ifdef UNK +x += w/x; +x = ldexpl( x, -1 ); /* divide by 2 */ +x += w/x; +x = ldexpl( x, -1 ); +x += w/x; +x = ldexpl( x, -1 ); +#endif + +/* Note, assume the square root cannot be denormal, + * so it is safe to use integer exponent operations here. + */ +#ifdef IBMPC +x += w/x; +*q -= 1; +x += w/x; +*q -= 1; +x += w/x; +*q -= 1; +#endif +#ifdef MIEEE +x += w/x; +*q -= 1; +x += w/x; +*q -= 1; +x += w/x; +*q -= 1; +#endif + +return(x); +} diff --git a/libm/ldouble/stdtrl.c b/libm/ldouble/stdtrl.c new file mode 100644 index 000000000..4218d4133 --- /dev/null +++ b/libm/ldouble/stdtrl.c @@ -0,0 +1,225 @@ +/* stdtrl.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * long double p, t, stdtrl(); + * int k; + * + * p = stdtrl( k, t ); + * + * + * DESCRIPTION: + * + * Computes the integral from minus infinity to t of the Student + * t distribution with integer k > 0 degrees of freedom: + * + * t + * - + * | | + * - | 2 -(k+1)/2 + * | ( (k+1)/2 ) | ( x ) + * ---------------------- | ( 1 + --- ) dx + * - | ( k ) + * sqrt( k pi ) | ( k/2 ) | + * | | + * - + * -inf. + * + * Relation to incomplete beta integral: + * + * 1 - stdtr(k,t) = 0.5 * incbet( k/2, 1/2, z ) + * where + * z = k/(k + t**2). + * + * For t < -1.6, this is the method of computation. For higher t, + * a direct method is derived from integration by parts. + * Since the function is symmetric about t=0, the area under the + * right tail of the density is found by calling the function + * with -t instead of t. + * + * ACCURACY: + * + * Tested at random 1 <= k <= 100. The "domain" refers to t. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -100,-1.6 10000 5.7e-18 9.8e-19 + * IEEE -1.6,100 10000 3.8e-18 1.0e-19 + */ + +/* stdtril.c + * + * Functional inverse of Student's t distribution + * + * + * + * SYNOPSIS: + * + * long double p, t, stdtril(); + * int k; + * + * t = stdtril( k, p ); + * + * + * DESCRIPTION: + * + * Given probability p, finds the argument t such that stdtrl(k,t) + * is equal to p. + * + * ACCURACY: + * + * Tested at random 1 <= k <= 100. The "domain" refers to p: + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1 3500 4.2e-17 4.1e-18 + */ + + +/* +Cephes Math Library Release 2.3: January, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +extern long double PIL, MACHEPL, MAXNUML; +#ifdef ANSIPROT +extern long double sqrtl ( long double ); +extern long double atanl ( long double ); +extern long double incbetl ( long double, long double, long double ); +extern long double incbil ( long double, long double, long double ); +extern long double fabsl ( long double ); +#else +long double sqrtl(), atanl(), incbetl(), incbil(), fabsl(); +#endif + +long double stdtrl( k, t ) +int k; +long double t; +{ +long double x, rk, z, f, tz, p, xsqk; +int j; + +if( k <= 0 ) + { + mtherr( "stdtrl", DOMAIN ); + return(0.0L); + } + +if( t == 0.0L ) + return( 0.5L ); + +if( t < -1.6L ) + { + rk = k; + z = rk / (rk + t * t); + p = 0.5L * incbetl( 0.5L*rk, 0.5L, z ); + return( p ); + } + +/* compute integral from -t to + t */ + +if( t < 0.0L ) + x = -t; +else + x = t; + +rk = k; /* degrees of freedom */ +z = 1.0L + ( x * x )/rk; + +/* test if k is odd or even */ +if( (k & 1) != 0) + { + + /* computation for odd k */ + + xsqk = x/sqrtl(rk); + p = atanl( xsqk ); + if( k > 1 ) + { + f = 1.0L; + tz = 1.0L; + j = 3; + while( (j<=(k-2)) && ( (tz/f) > MACHEPL ) ) + { + tz *= (j-1)/( z * j ); + f += tz; + j += 2; + } + p += f * xsqk/z; + } + p *= 2.0L/PIL; + } + + +else + { + + /* computation for even k */ + + f = 1.0L; + tz = 1.0L; + j = 2; + + while( ( j <= (k-2) ) && ( (tz/f) > MACHEPL ) ) + { + tz *= (j - 1)/( z * j ); + f += tz; + j += 2; + } + p = f * x/sqrtl(z*rk); + } + +/* common exit */ + + +if( t < 0.0L ) + p = -p; /* note destruction of relative accuracy */ + + p = 0.5L + 0.5L * p; +return(p); +} + + +long double stdtril( k, p ) +int k; +long double p; +{ +long double t, rk, z; +int rflg; + +if( k <= 0 || p <= 0.0L || p >= 1.0L ) + { + mtherr( "stdtril", DOMAIN ); + return(0.0L); + } + +rk = k; + +if( p > 0.25L && p < 0.75L ) + { + if( p == 0.5L ) + return( 0.0L ); + z = 1.0L - 2.0L * p; + z = incbil( 0.5L, 0.5L*rk, fabsl(z) ); + t = sqrtl( rk*z/(1.0L-z) ); + if( p < 0.5L ) + t = -t; + return( t ); + } +rflg = -1; +if( p >= 0.5L) + { + p = 1.0L - p; + rflg = 1; + } +z = incbil( 0.5L*rk, 0.5L, 2.0L*p ); + +if( MAXNUML * z < rk ) + return(rflg* MAXNUML); +t = sqrtl( rk/z - rk ); +return( rflg * t ); +} diff --git a/libm/ldouble/tanhl.c b/libm/ldouble/tanhl.c new file mode 100644 index 000000000..42c7133c3 --- /dev/null +++ b/libm/ldouble/tanhl.c @@ -0,0 +1,129 @@ +/* tanhl.c + * + * Hyperbolic tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, tanhl(); + * + * y = tanhl( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOGL to + * MAXLOGL. + * + * A rational function is used for |x| < 0.625. The form + * x + x**3 P(x)/Q(x) of Cody _& Waite is employed. + * Otherwise, + * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 30000 1.3e-19 2.4e-20 + * + */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1987, 1989, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double P[] = { +-6.8473739392677100872869E-5L, +-9.5658283111794641589011E-1L, +-8.4053568599672284488465E1L, +-1.3080425704712825945553E3L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ + 9.6259501838840336946872E1L, + 1.8218117903645559060232E3L, + 3.9241277114138477845780E3L, +}; +#endif + +#ifdef IBMPC +static short P[] = { +0xd2a4,0x1b0c,0x8f15,0x8f99,0xbff1, XPD +0x5959,0x9111,0x9cc7,0xf4e2,0xbffe, XPD +0xb576,0xef5e,0x6d57,0xa81b,0xc005, XPD +0xe3be,0xbfbd,0x5cbc,0xa381,0xc009, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x687f,0xce24,0xdd6c,0xc084,0x4005, XPD +0x3793,0xc95f,0xfa2f,0xe3b9,0x4009, XPD +0xd5a2,0x1f9c,0x0b1b,0xf542,0x400a, XPD +}; +#endif + +#ifdef MIEEE +static long P[] = { +0xbff10000,0x8f998f15,0x1b0cd2a4, +0xbffe0000,0xf4e29cc7,0x91115959, +0xc0050000,0xa81b6d57,0xef5eb576, +0xc0090000,0xa3815cbc,0xbfbde3be, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x40050000,0xc084dd6c,0xce24687f, +0x40090000,0xe3b9fa2f,0xc95f3793, +0x400a0000,0xf5420b1b,0x1f9cd5a2, +}; +#endif + +extern long double MAXLOGL; +#ifdef ANSIPROT +extern long double fabsl ( long double ); +extern long double expl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +#else +long double fabsl(), expl(), polevll(), p1evll(); +#endif + +long double tanhl(x) +long double x; +{ +long double s, z; + +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +z = fabsl(x); +if( z > 0.5L * MAXLOGL ) + { + if( x > 0 ) + return( 1.0L ); + else + return( -1.0L ); + } +if( z >= 0.625L ) + { + s = expl(2.0*z); + z = 1.0L - 2.0/(s + 1.0L); + if( x < 0 ) + z = -z; + } +else + { + s = x * x; + z = polevll( s, P, 3 )/p1evll(s, Q, 3); + z = x * s * z; + z = x + z; + } +return( z ); +} diff --git a/libm/ldouble/tanl.c b/libm/ldouble/tanl.c new file mode 100644 index 000000000..e546dd664 --- /dev/null +++ b/libm/ldouble/tanl.c @@ -0,0 +1,279 @@ +/* tanl.c + * + * Circular tangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, tanl(); + * + * y = tanl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is modulo pi/4. A rational function + * x + x**3 P(x**2)/Q(x**2) + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-1.07e9 30000 1.9e-19 4.8e-20 + * + * ERROR MESSAGES: + * + * message condition value returned + * tan total loss x > 2^39 0.0 + * + */ + /* cotl.c + * + * Circular cotangent, long double precision + * + * + * + * SYNOPSIS: + * + * long double x, y, cotl(); + * + * y = cotl( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the radian argument x. + * + * Range reduction is modulo pi/4. A rational function + * x + x**3 P(x**2)/Q(x**2) + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-1.07e9 30000 1.9e-19 5.1e-20 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^39 0.0 + * cot singularity x = 0 INFINITYL + * + */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1984, 1990, 1998 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static long double P[] = { +-1.3093693918138377764608E4L, + 1.1535166483858741613983E6L, +-1.7956525197648487798769E7L, +}; +static long double Q[] = { +/* 1.0000000000000000000000E0L,*/ + 1.3681296347069295467845E4L, +-1.3208923444021096744731E6L, + 2.5008380182335791583922E7L, +-5.3869575592945462988123E7L, +}; +static long double DP1 = 7.853981554508209228515625E-1L; +static long double DP2 = 7.946627356147928367136046290398E-9L; +static long double DP3 = 3.061616997868382943065164830688E-17L; +#endif + + +#ifdef IBMPC +static short P[] = { +0xbc1c,0x79f9,0xc692,0xcc96,0xc00c, XPD +0xe5b1,0xe4ee,0x652f,0x8ccf,0x4013, XPD +0xaf9a,0x4c8b,0x5699,0x88ff,0xc017, XPD +}; +static short Q[] = { +/*0x0000,0x0000,0x0000,0x8000,0x3fff,*/ +0x8ed4,0x9b2b,0x2f75,0xd5c5,0x400c, XPD +0xadcd,0x55e4,0xe2c1,0xa13d,0xc013, XPD +0x7adf,0x56c7,0x7e17,0xbecc,0x4017, XPD +0x86f6,0xf2d1,0x01e5,0xcd7f,0xc018, XPD +}; +static short P1[] = {0x0000,0x0000,0xda80,0xc90f,0x3ffe, XPD}; +static short P2[] = {0x0000,0x0000,0xa300,0x8885,0x3fe4, XPD}; +static short P3[] = {0x3707,0xa2e0,0x3198,0x8d31,0x3fc8, XPD}; +#define DP1 *(long double *)P1 +#define DP2 *(long double *)P2 +#define DP3 *(long double *)P3 +#endif + +#ifdef MIEEE +static long P[] = { +0xc00c0000,0xcc96c692,0x79f9bc1c, +0x40130000,0x8ccf652f,0xe4eee5b1, +0xc0170000,0x88ff5699,0x4c8baf9a, +}; +static long Q[] = { +/*0x3fff0000,0x80000000,0x00000000,*/ +0x400c0000,0xd5c52f75,0x9b2b8ed4, +0xc0130000,0xa13de2c1,0x55e4adcd, +0x40170000,0xbecc7e17,0x56c77adf, +0xc0180000,0xcd7f01e5,0xf2d186f6, +}; +static long P1[] = {0x3ffe0000,0xc90fda80,0x00000000}; +static long P2[] = {0x3fe40000,0x8885a300,0x00000000}; +static long P3[] = {0x3fc80000,0x8d313198,0xa2e03707}; +#define DP1 *(long double *)P1 +#define DP2 *(long double *)P2 +#define DP3 *(long double *)P3 +#endif + +static long double lossth = 5.49755813888e11L; /* 2^39 */ +extern long double PIO4L; +extern long double MAXNUML; + +#ifdef ANSIPROT +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +extern long double floorl ( long double ); +extern long double ldexpl ( long double, int ); +extern int isnanl ( long double ); +extern int isfinitel ( long double ); +static long double tancotl( long double, int ); +#else +long double polevll(), p1evll(), floorl(), ldexpl(), isnanl(), isfinitel(); +static long double tancotl(); +#endif +#ifdef INFINITIES +extern long double INFINITYL; +#endif +#ifdef NANS +extern long double NANL; +#endif + +long double tanl(x) +long double x; +{ + +#ifdef NANS +if( isnanl(x) ) + return(x); +#endif +#ifdef MINUSZERO +if( x == 0.0L ) + return(x); +#endif +#ifdef NANS +if( !isfinitel(x) ) + { + mtherr( "tanl", DOMAIN ); + return(NANL); + } +#endif +return( tancotl(x,0) ); +} + + +long double cotl(x) +long double x; +{ + +if( x == 0.0L ) + { + mtherr( "cotl", SING ); +#ifdef INFINITIES + return( INFINITYL ); +#else + return( MAXNUML ); +#endif + } +return( tancotl(x,1) ); +} + + +static long double tancotl( xx, cotflg ) +long double xx; +int cotflg; +{ +long double x, y, z, zz; +int j, sign; + +/* make argument positive but save the sign */ +if( xx < 0.0L ) + { + x = -xx; + sign = -1; + } +else + { + x = xx; + sign = 1; + } + +if( x > lossth ) + { + if( cotflg ) + mtherr( "cotl", TLOSS ); + else + mtherr( "tanl", TLOSS ); + return(0.0L); + } + +/* compute x mod PIO4 */ +y = floorl( x/PIO4L ); + +/* strip high bits of integer part */ +z = ldexpl( y, -4 ); +z = floorl(z); /* integer part of y/16 */ +z = y - ldexpl( z, 4 ); /* y - 16 * (y/16) */ + +/* integer and fractional part modulo one octant */ +j = z; + +/* map zeros and singularities to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0L; + } + +z = ((x - y * DP1) - y * DP2) - y * DP3; + +zz = z * z; + +if( zz > 1.0e-20L ) + y = z + z * (zz * polevll( zz, P, 2 )/p1evll(zz, Q, 4)); +else + y = z; + +if( j & 2 ) + { + if( cotflg ) + y = -y; + else + y = -1.0L/y; + } +else + { + if( cotflg ) + y = 1.0L/y; + } + +if( sign < 0 ) + y = -y; + +return( y ); +} diff --git a/libm/ldouble/testvect.c b/libm/ldouble/testvect.c new file mode 100644 index 000000000..1c3ffcb91 --- /dev/null +++ b/libm/ldouble/testvect.c @@ -0,0 +1,497 @@ + +/* Test vectors for math functions. + See C9X section F.9. + + On some systems it may be necessary to modify the default exception + settings of the floating point arithmetic unit. */ + +/* +Cephes Math Library Release 2.7: May, 1998 +Copyright 1998 by Stephen L. Moshier +*/ + +#include <stdio.h> +int isfinitel (long double); + +/* Some compilers will not accept these expressions. */ + +#define ZINF 1 +#define ZMINF 2 +#define ZNANL 3 +#define ZPIL 4 +#define ZPIO2L 4 + +extern long double INFINITYL, NANL, NEGZEROL; +long double MINFL; +extern long double PIL, PIO2L, PIO4L, MACHEPL; +long double MPIL; +long double MPIO2L; +long double MPIO4L; +long double THPIO4L = 2.35619449019234492884698L; +long double MTHPIO4L = -2.35619449019234492884698L; +long double SQRT2L = 1.414213562373095048802E0L; +long double SQRTHL = 7.071067811865475244008E-1L; +long double ZEROL = 0.0L; +long double HALFL = 0.5L; +long double MHALFL = -0.5L; +long double ONEL = 1.0L; +long double MONEL = -1.0L; +long double TWOL = 2.0L; +long double MTWOL = -2.0L; +long double THREEL = 3.0L; +long double MTHREEL = -3.0L; + +/* Functions of one variable. */ +long double logl (long double); +long double expl (long double); +long double atanl (long double); +long double sinl (long double); +long double cosl (long double); +long double tanl (long double); +long double acosl (long double); +long double asinl (long double); +long double acoshl (long double); +long double asinhl (long double); +long double atanhl (long double); +long double sinhl (long double); +long double coshl (long double); +long double tanhl (long double); +long double exp2l (long double); +long double expm1l (long double); +long double log10l (long double); +long double log1pl (long double); +long double log2l (long double); +long double fabsl (long double); +long double erfl (long double); +long double erfcl (long double); +long double gammal (long double); +long double lgaml (long double); +long double floorl (long double); +long double ceill (long double); +long double cbrtl (long double); + +struct oneargument + { + char *name; /* Name of the function. */ + long double (*func) (long double); + long double *arg1; + long double *answer; + int thresh; /* Error report threshold. */ + }; + +#if 0 + {"sinl", sinl, 32767.L, 1.8750655394138942394239E-1L, 0}, + {"cosl", cosl, 32767.L, 9.8226335176928229845654E-1L, 0}, + {"tanl", tanl, 32767.L, 1.9089234430221485740826E-1L, 0}, + {"sinl", sinl, 8388607.L, 9.9234509376961249835628E-1L, 0}, + {"cosl", cosl, 8388607.L, -1.2349580912475928183718E-1L, 0}, + {"tanl", tanl, 8388607.L, -8.0354556223613614748329E0L, 0}, + {"sinl", sinl, 2147483647.L, -7.2491655514455639054829E-1L, 0}, + {"cosl", cosl, 2147483647.L, -6.8883669187794383467976E-1L, 0}, + {"tanl", tanl, 2147483647.L, 1.0523779637351339136698E0L, 0}, + {"sinl", sinl, PIO4L, 7.0710678118654752440084E-1L, 0}, + {"cosl", cosl, PIO2L, -2.50827880633416613471e-20L, 0}, +#endif + +struct oneargument test1[] = +{ + {"atanl", atanl, &ONEL, &PIO4L, 0}, + {"sinl", sinl, &PIO2L, &ONEL, 0}, + {"cosl", cosl, &PIO4L, &SQRTHL, 0}, + {"acosl", acosl, &NANL, &NANL, 0}, + {"acosl", acosl, &ONEL, &ZEROL, 0}, + {"acosl", acosl, &TWOL, &NANL, 0}, + {"acosl", acosl, &MTWOL, &NANL, 0}, + {"asinl", asinl, &NANL, &NANL, 0}, + {"asinl", asinl, &ZEROL, &ZEROL, 0}, + {"asinl", asinl, &NEGZEROL, &NEGZEROL, 0}, + {"asinl", asinl, &TWOL, &NANL, 0}, + {"asinl", asinl, &MTWOL, &NANL, 0}, + {"atanl", atanl, &NANL, &NANL, 0}, + {"atanl", atanl, &ZEROL, &ZEROL, 0}, + {"atanl", atanl, &NEGZEROL, &NEGZEROL, 0}, + {"atanl", atanl, &INFINITYL, &PIO2L, 0}, + {"atanl", atanl, &MINFL, &MPIO2L, 0}, + {"cosl", cosl, &NANL, &NANL, 0}, + {"cosl", cosl, &ZEROL, &ONEL, 0}, + {"cosl", cosl, &NEGZEROL, &ONEL, 0}, + {"cosl", cosl, &INFINITYL, &NANL, 0}, + {"cosl", cosl, &MINFL, &NANL, 0}, + {"sinl", sinl, &NANL, &NANL, 0}, + {"sinl", sinl, &NEGZEROL, &NEGZEROL, 0}, + {"sinl", sinl, &ZEROL, &ZEROL, 0}, + {"sinl", sinl, &INFINITYL, &NANL, 0}, + {"sinl", sinl, &MINFL, &NANL, 0}, + {"tanl", tanl, &NANL, &NANL, 0}, + {"tanl", tanl, &ZEROL, &ZEROL, 0}, + {"tanl", tanl, &NEGZEROL, &NEGZEROL, 0}, + {"tanl", tanl, &INFINITYL, &NANL, 0}, + {"tanl", tanl, &MINFL, &NANL, 0}, + {"acoshl", acoshl, &NANL, &NANL, 0}, + {"acoshl", acoshl, &ONEL, &ZEROL, 0}, + {"acoshl", acoshl, &INFINITYL, &INFINITYL, 0}, + {"acoshl", acoshl, &HALFL, &NANL, 0}, + {"acoshl", acoshl, &MONEL, &NANL, 0}, + {"asinhl", asinhl, &NANL, &NANL, 0}, + {"asinhl", asinhl, &ZEROL, &ZEROL, 0}, + {"asinhl", asinhl, &NEGZEROL, &NEGZEROL, 0}, + {"asinhl", asinhl, &INFINITYL, &INFINITYL, 0}, + {"asinhl", asinhl, &MINFL, &MINFL, 0}, + {"atanhl", atanhl, &NANL, &NANL, 0}, + {"atanhl", atanhl, &ZEROL, &ZEROL, 0}, + {"atanhl", atanhl, &NEGZEROL, &NEGZEROL, 0}, + {"atanhl", atanhl, &ONEL, &INFINITYL, 0}, + {"atanhl", atanhl, &MONEL, &MINFL, 0}, + {"atanhl", atanhl, &TWOL, &NANL, 0}, + {"atanhl", atanhl, &MTWOL, &NANL, 0}, + {"coshl", coshl, &NANL, &NANL, 0}, + {"coshl", coshl, &ZEROL, &ONEL, 0}, + {"coshl", coshl, &NEGZEROL, &ONEL, 0}, + {"coshl", coshl, &INFINITYL, &INFINITYL, 0}, + {"coshl", coshl, &MINFL, &INFINITYL, 0}, + {"sinhl", sinhl, &NANL, &NANL, 0}, + {"sinhl", sinhl, &ZEROL, &ZEROL, 0}, + {"sinhl", sinhl, &NEGZEROL, &NEGZEROL, 0}, + {"sinhl", sinhl, &INFINITYL, &INFINITYL, 0}, + {"sinhl", sinhl, &MINFL, &MINFL, 0}, + {"tanhl", tanhl, &NANL, &NANL, 0}, + {"tanhl", tanhl, &ZEROL, &ZEROL, 0}, + {"tanhl", tanhl, &NEGZEROL, &NEGZEROL, 0}, + {"tanhl", tanhl, &INFINITYL, &ONEL, 0}, + {"tanhl", tanhl, &MINFL, &MONEL, 0}, + {"expl", expl, &NANL, &NANL, 0}, + {"expl", expl, &ZEROL, &ONEL, 0}, + {"expl", expl, &NEGZEROL, &ONEL, 0}, + {"expl", expl, &INFINITYL, &INFINITYL, 0}, + {"expl", expl, &MINFL, &ZEROL, 0}, + {"exp2l", exp2l, &NANL, &NANL, 0}, + {"exp2l", exp2l, &ZEROL, &ONEL, 0}, + {"exp2l", exp2l, &NEGZEROL, &ONEL, 0}, + {"exp2l", exp2l, &INFINITYL, &INFINITYL, 0}, + {"exp2l", exp2l, &MINFL, &ZEROL, 0}, + {"expm1l", expm1l, &NANL, &NANL, 0}, + {"expm1l", expm1l, &ZEROL, &ZEROL, 0}, + {"expm1l", expm1l, &NEGZEROL, &NEGZEROL, 0}, + {"expm1l", expm1l, &INFINITYL, &INFINITYL, 0}, + {"expm1l", expm1l, &MINFL, &MONEL, 0}, + {"logl", logl, &NANL, &NANL, 0}, + {"logl", logl, &ZEROL, &MINFL, 0}, + {"logl", logl, &NEGZEROL, &MINFL, 0}, + {"logl", logl, &ONEL, &ZEROL, 0}, + {"logl", logl, &MONEL, &NANL, 0}, + {"logl", logl, &INFINITYL, &INFINITYL, 0}, + {"log10l", log10l, &NANL, &NANL, 0}, + {"log10l", log10l, &ZEROL, &MINFL, 0}, + {"log10l", log10l, &NEGZEROL, &MINFL, 0}, + {"log10l", log10l, &ONEL, &ZEROL, 0}, + {"log10l", log10l, &MONEL, &NANL, 0}, + {"log10l", log10l, &INFINITYL, &INFINITYL, 0}, + {"log1pl", log1pl, &NANL, &NANL, 0}, + {"log1pl", log1pl, &ZEROL, &ZEROL, 0}, + {"log1pl", log1pl, &NEGZEROL, &NEGZEROL, 0}, + {"log1pl", log1pl, &MONEL, &MINFL, 0}, + {"log1pl", log1pl, &MTWOL, &NANL, 0}, + {"log1pl", log1pl, &INFINITYL, &INFINITYL, 0}, + {"log2l", log2l, &NANL, &NANL, 0}, + {"log2l", log2l, &ZEROL, &MINFL, 0}, + {"log2l", log2l, &NEGZEROL, &MINFL, 0}, + {"log2l", log2l, &MONEL, &NANL, 0}, + {"log2l", log2l, &INFINITYL, &INFINITYL, 0}, + /* {"fabsl", fabsl, &NANL, &NANL, 0}, */ + {"fabsl", fabsl, &ONEL, &ONEL, 0}, + {"fabsl", fabsl, &MONEL, &ONEL, 0}, + {"fabsl", fabsl, &ZEROL, &ZEROL, 0}, + {"fabsl", fabsl, &NEGZEROL, &ZEROL, 0}, + {"fabsl", fabsl, &INFINITYL, &INFINITYL, 0}, + {"fabsl", fabsl, &MINFL, &INFINITYL, 0}, + {"cbrtl", cbrtl, &NANL, &NANL, 0}, + {"cbrtl", cbrtl, &ZEROL, &ZEROL, 0}, + {"cbrtl", cbrtl, &NEGZEROL, &NEGZEROL, 0}, + {"cbrtl", cbrtl, &INFINITYL, &INFINITYL, 0}, + {"cbrtl", cbrtl, &MINFL, &MINFL, 0}, + {"erfl", erfl, &NANL, &NANL, 0}, + {"erfl", erfl, &ZEROL, &ZEROL, 0}, + {"erfl", erfl, &NEGZEROL, &NEGZEROL, 0}, + {"erfl", erfl, &INFINITYL, &ONEL, 0}, + {"erfl", erfl, &MINFL, &MONEL, 0}, + {"erfcl", erfcl, &NANL, &NANL, 0}, + {"erfcl", erfcl, &INFINITYL, &ZEROL, 0}, + {"erfcl", erfcl, &MINFL, &TWOL, 0}, + {"gammal", gammal, &NANL, &NANL, 0}, + {"gammal", gammal, &INFINITYL, &INFINITYL, 0}, + {"gammal", gammal, &MONEL, &NANL, 0}, + {"gammal", gammal, &ZEROL, &NANL, 0}, + {"gammal", gammal, &MINFL, &NANL, 0}, + {"lgaml", lgaml, &NANL, &NANL, 0}, + {"lgaml", lgaml, &INFINITYL, &INFINITYL, 0}, + {"lgaml", lgaml, &MONEL, &INFINITYL, 0}, + {"lgaml", lgaml, &ZEROL, &INFINITYL, 0}, + {"lgaml", lgaml, &MINFL, &INFINITYL, 0}, + {"ceill", ceill, &NANL, &NANL, 0}, + {"ceill", ceill, &ZEROL, &ZEROL, 0}, + {"ceill", ceill, &NEGZEROL, &NEGZEROL, 0}, + {"ceill", ceill, &INFINITYL, &INFINITYL, 0}, + {"ceill", ceill, &MINFL, &MINFL, 0}, + {"floorl", floorl, &NANL, &NANL, 0}, + {"floorl", floorl, &ZEROL, &ZEROL, 0}, + {"floorl", floorl, &NEGZEROL, &NEGZEROL, 0}, + {"floorl", floorl, &INFINITYL, &INFINITYL, 0}, + {"floorl", floorl, &MINFL, &MINFL, 0}, + {"null", NULL, &ZEROL, &ZEROL, 0}, +}; + +/* Functions of two variables. */ +long double atan2l (long double, long double); +long double powl (long double, long double); + +struct twoarguments + { + char *name; /* Name of the function. */ + long double (*func) (long double, long double); + long double *arg1; + long double *arg2; + long double *answer; + int thresh; + }; + +struct twoarguments test2[] = +{ + {"atan2l", atan2l, &ZEROL, &ONEL, &ZEROL, 0}, + {"atan2l", atan2l, &NEGZEROL, &ONEL,&NEGZEROL, 0}, + {"atan2l", atan2l, &ZEROL, &ZEROL, &ZEROL, 0}, + {"atan2l", atan2l, &NEGZEROL, &ZEROL, &NEGZEROL, 0}, + {"atan2l", atan2l, &ZEROL, &MONEL, &PIL, 0}, + {"atan2l", atan2l, &NEGZEROL, &MONEL, &MPIL, 0}, + {"atan2l", atan2l, &ZEROL, &NEGZEROL, &PIL, 0}, + {"atan2l", atan2l, &NEGZEROL, &NEGZEROL, &MPIL, 0}, + {"atan2l", atan2l, &ONEL, &ZEROL, &PIO2L, 0}, + {"atan2l", atan2l, &ONEL, &NEGZEROL, &PIO2L, 0}, + {"atan2l", atan2l, &MONEL, &ZEROL, &MPIO2L, 0}, + {"atan2l", atan2l, &MONEL, &NEGZEROL, &MPIO2L, 0}, + {"atan2l", atan2l, &ONEL, &INFINITYL, &ZEROL, 0}, + {"atan2l", atan2l, &MONEL, &INFINITYL, &NEGZEROL, 0}, + {"atan2l", atan2l, &INFINITYL, &ONEL, &PIO2L, 0}, + {"atan2l", atan2l, &INFINITYL, &MONEL, &PIO2L, 0}, + {"atan2l", atan2l, &MINFL, &ONEL, &MPIO2L, 0}, + {"atan2l", atan2l, &MINFL, &MONEL, &MPIO2L, 0}, + {"atan2l", atan2l, &ONEL, &MINFL, &PIL, 0}, + {"atan2l", atan2l, &MONEL, &MINFL, &MPIL, 0}, + {"atan2l", atan2l, &INFINITYL, &INFINITYL, &PIO4L, 0}, + {"atan2l", atan2l, &MINFL, &INFINITYL, &MPIO4L, 0}, + {"atan2l", atan2l, &INFINITYL, &MINFL, &THPIO4L, 0}, + {"atan2l", atan2l, &MINFL, &MINFL, &MTHPIO4L, 0}, + {"atan2l", atan2l, &ONEL, &ONEL, &PIO4L, 0}, + {"atan2l", atan2l, &NANL, &ONEL, &NANL, 0}, + {"atan2l", atan2l, &ONEL, &NANL, &NANL, 0}, + {"atan2l", atan2l, &NANL, &NANL, &NANL, 0}, + {"powl", powl, &ONEL, &ZEROL, &ONEL, 0}, + {"powl", powl, &ONEL, &NEGZEROL, &ONEL, 0}, + {"powl", powl, &MONEL, &ZEROL, &ONEL, 0}, + {"powl", powl, &MONEL, &NEGZEROL, &ONEL, 0}, + {"powl", powl, &INFINITYL, &ZEROL, &ONEL, 0}, + {"powl", powl, &INFINITYL, &NEGZEROL, &ONEL, 0}, + {"powl", powl, &NANL, &ZEROL, &ONEL, 0}, + {"powl", powl, &NANL, &NEGZEROL, &ONEL, 0}, + {"powl", powl, &TWOL, &INFINITYL, &INFINITYL, 0}, + {"powl", powl, &MTWOL, &INFINITYL, &INFINITYL, 0}, + {"powl", powl, &HALFL, &INFINITYL, &ZEROL, 0}, + {"powl", powl, &MHALFL, &INFINITYL, &ZEROL, 0}, + {"powl", powl, &TWOL, &MINFL, &ZEROL, 0}, + {"powl", powl, &MTWOL, &MINFL, &ZEROL, 0}, + {"powl", powl, &HALFL, &MINFL, &INFINITYL, 0}, + {"powl", powl, &MHALFL, &MINFL, &INFINITYL, 0}, + {"powl", powl, &INFINITYL, &HALFL, &INFINITYL, 0}, + {"powl", powl, &INFINITYL, &TWOL, &INFINITYL, 0}, + {"powl", powl, &INFINITYL, &MHALFL, &ZEROL, 0}, + {"powl", powl, &INFINITYL, &MTWOL, &ZEROL, 0}, + {"powl", powl, &MINFL, &THREEL, &MINFL, 0}, + {"powl", powl, &MINFL, &TWOL, &INFINITYL, 0}, + {"powl", powl, &MINFL, &MTHREEL, &NEGZEROL, 0}, + {"powl", powl, &MINFL, &MTWOL, &ZEROL, 0}, + {"powl", powl, &NANL, &ONEL, &NANL, 0}, + {"powl", powl, &ONEL, &NANL, &NANL, 0}, + {"powl", powl, &NANL, &NANL, &NANL, 0}, + {"powl", powl, &ONEL, &INFINITYL, &NANL, 0}, + {"powl", powl, &MONEL, &INFINITYL, &NANL, 0}, + {"powl", powl, &ONEL, &MINFL, &NANL, 0}, + {"powl", powl, &MONEL, &MINFL, &NANL, 0}, + {"powl", powl, &MTWOL, &HALFL, &NANL, 0}, + {"powl", powl, &ZEROL, &MTHREEL, &INFINITYL, 0}, + {"powl", powl, &NEGZEROL, &MTHREEL, &MINFL, 0}, + {"powl", powl, &ZEROL, &MHALFL, &INFINITYL, 0}, + {"powl", powl, &NEGZEROL, &MHALFL, &INFINITYL, 0}, + {"powl", powl, &ZEROL, &THREEL, &ZEROL, 0}, + {"powl", powl, &NEGZEROL, &THREEL, &NEGZEROL, 0}, + {"powl", powl, &ZEROL, &HALFL, &ZEROL, 0}, + {"powl", powl, &NEGZEROL, &HALFL, &ZEROL, 0}, + {"null", NULL, &ZEROL, &ZEROL, &ZEROL, 0}, +}; + +/* Integer functions of one variable. */ + +int isnanl (long double); +int signbitl (long double); + +struct intans + { + char *name; /* Name of the function. */ + int (*func) (long double); + long double *arg1; + int ianswer; + }; + +struct intans test3[] = +{ + {"isfinitel", isfinitel, &ZEROL, 1}, + {"isfinitel", isfinitel, &INFINITYL, 0}, + {"isfinitel", isfinitel, &MINFL, 0}, + {"isnanl", isnanl, &NANL, 1}, + {"isnanl", isnanl, &INFINITYL, 0}, + {"isnanl", isnanl, &ZEROL, 0}, + {"isnanl", isnanl, &NEGZEROL, 0}, + {"signbitl", signbitl, &NEGZEROL, 1}, + {"signbitl", signbitl, &MONEL, 1}, + {"signbitl", signbitl, &ZEROL, 0}, + {"signbitl", signbitl, &ONEL, 0}, + {"signbitl", signbitl, &MINFL, 1}, + {"signbitl", signbitl, &INFINITYL, 0}, + {"null", NULL, &ZEROL, 0}, +}; + +static volatile long double x1; +static volatile long double x2; +static volatile long double y; +static volatile long double answer; + +int +main () +{ + int i, nerrors, k, ianswer, ntests; + long double (*fun1) (long double); + long double (*fun2) (long double, long double); + int (*fun3) (long double); + long double e; + union + { + long double d; + char c[12]; + } u, v; + + /* This masks off fpu exceptions on i386. */ + /* setfpu(0x137f); */ + nerrors = 0; + ntests = 0; + MINFL = -INFINITYL; + MPIL = -PIL; + MPIO2L = -PIO2L; + MPIO4L = -PIO4L; + i = 0; + for (;;) + { + fun1 = test1[i].func; + if (fun1 == NULL) + break; + x1 = *(test1[i].arg1); + y = (*(fun1)) (x1); + answer = *(test1[i].answer); + if (test1[i].thresh == 0) + { + v.d = answer; + u.d = y; + if (memcmp(u.c, v.c, 10) != 0) + { + /* O.K. if both are NaNs of some sort. */ + if (isnanl(v.d) && isnanl(u.d)) + goto nxttest1; + goto wrongone; + } + else + goto nxttest1; + } + if (y != answer) + { + e = y - answer; + if (answer != 0.0L) + e = e / answer; + if (e < 0) + e = -e; + if (e > test1[i].thresh * MACHEPL) + { +wrongone: + printf ("%s (%.20Le) = %.20Le\n should be %.20Le\n", + test1[i].name, x1, y, answer); + nerrors += 1; + } + } +nxttest1: + ntests += 1; + i += 1; + } + + i = 0; + for (;;) + { + fun2 = test2[i].func; + if (fun2 == NULL) + break; + x1 = *(test2[i].arg1); + x2 = *(test2[i].arg2); + y = (*(fun2)) (x1, x2); + answer = *(test2[i].answer); + if (test2[i].thresh == 0) + { + v.d = answer; + u.d = y; + if (memcmp(u.c, v.c, 10) != 0) + { + /* O.K. if both are NaNs of some sort. */ + if (isnanl(v.d) && isnanl(u.d)) + goto nxttest2; + goto wrongtwo; + } + else + goto nxttest2; + } + if (y != answer) + { + e = y - answer; + if (answer != 0.0L) + e = e / answer; + if (e < 0) + e = -e; + if (e > test2[i].thresh * MACHEPL) + { +wrongtwo: + printf ("%s (%.20Le, %.20Le) = %.20Le\n should be %.20Le\n", + test2[i].name, x1, x2, y, answer); + nerrors += 1; + } + } +nxttest2: + ntests += 1; + i += 1; + } + + + i = 0; + for (;;) + { + fun3 = test3[i].func; + if (fun3 == NULL) + break; + x1 = *(test3[i].arg1); + k = (*(fun3)) (x1); + ianswer = test3[i].ianswer; + if (k != ianswer) + { + printf ("%s (%.20Le) = %d\n should be. %d\n", + test3[i].name, x1, k, ianswer); + nerrors += 1; + } + ntests += 1; + i += 1; + } + + printf ("testvect: %d errors in %d tests\n", nerrors, ntests); + exit (0); +} diff --git a/libm/ldouble/unityl.c b/libm/ldouble/unityl.c new file mode 100644 index 000000000..10670ce3a --- /dev/null +++ b/libm/ldouble/unityl.c @@ -0,0 +1,128 @@ +/* unityl.c + * + * Relative error approximations for function arguments near + * unity. + * + * log1p(x) = log(1+x) + * expm1(x) = exp(x) - 1 + * cosm1(x) = cos(x) - 1 + * + */ + + +/* log1p(x) = log(1 + x) + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2 30000 1.4e-19 4.1e-20 + * + */ + +#include <math.h> +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + * Theoretical peak relative error = 2.32e-20 + */ +static long double LP[] = { + 4.5270000862445199635215E-5L, + 4.9854102823193375972212E-1L, + 6.5787325942061044846969E0L, + 2.9911919328553073277375E1L, + 6.0949667980987787057556E1L, + 5.7112963590585538103336E1L, + 2.0039553499201281259648E1L, +}; +static long double LQ[] = { +/* 1.0000000000000000000000E0L,*/ + 1.5062909083469192043167E1L, + 8.3047565967967209469434E1L, + 2.2176239823732856465394E2L, + 3.0909872225312059774938E2L, + 2.1642788614495947685003E2L, + 6.0118660497603843919306E1L, +}; + +#define SQRTH 0.70710678118654752440L +#define SQRT2 1.41421356237309504880L +#ifdef ANSIPROT +extern long double logl ( long double ); +extern long double expl ( long double ); +extern long double cosl ( long double ); +extern long double polevll ( long double, void *, int ); +extern long double p1evll ( long double, void *, int ); +#else +long double logl(), expl(), cosl(), polevll(), p1evll(); +#endif + +long double log1pl(x) +long double x; +{ +long double z; + +z = 1.0L + x; +if( (z < SQRTH) || (z > SQRT2) ) + return( logl(z) ); +z = x*x; +z = -0.5L * z + x * ( z * polevll( x, LP, 6 ) / p1evll( x, LQ, 6 ) ); +return (x + z); +} + + + +/* expm1(x) = exp(x) - 1 */ + +/* e^x = 1 + 2x P(x^2)/( Q(x^2) - P(x^2) ) + * -0.5 <= x <= 0.5 + */ + +static long double EP[3] = { + 1.2617719307481059087798E-4L, + 3.0299440770744196129956E-2L, + 9.9999999999999999991025E-1L, +}; +static long double EQ[4] = { + 3.0019850513866445504159E-6L, + 2.5244834034968410419224E-3L, + 2.2726554820815502876593E-1L, + 2.0000000000000000000897E0L, +}; + +long double expm1l(x) +long double x; +{ +long double r, xx; + +if( (x < -0.5L) || (x > 0.5L) ) + return( expl(x) - 1.0L ); +xx = x * x; +r = x * polevll( xx, EP, 2 ); +r = r/( polevll( xx, EQ, 3 ) - r ); +return (r + r); +} + + + +/* cosm1(x) = cos(x) - 1 */ + +static long double coscof[7] = { + 4.7377507964246204691685E-14L, +-1.1470284843425359765671E-11L, + 2.0876754287081521758361E-9L, +-2.7557319214999787979814E-7L, + 2.4801587301570552304991E-5L, +-1.3888888888888872993737E-3L, + 4.1666666666666666609054E-2L, +}; + +extern long double PIO4L; + +long double cosm1l(x) +long double x; +{ +long double xx; + +if( (x < -PIO4L) || (x > PIO4L) ) + return( cosl(x) - 1.0L ); +xx = x * x; +xx = -0.5L*xx + xx * xx * polevll( xx, coscof, 6 ); +return xx; +} diff --git a/libm/ldouble/wronkl.c b/libm/ldouble/wronkl.c new file mode 100644 index 000000000..bec958f01 --- /dev/null +++ b/libm/ldouble/wronkl.c @@ -0,0 +1,67 @@ +/* Wronksian test for Bessel functions. */ + +long double jnl (), ynl (), floorl (); +#define PI 3.14159265358979323846L + +long double y, Jn, Jnp1, Jmn, Jmnp1, Yn, Ynp1; +long double w1, w2, err1, max1, err2, max2; +void wronk (); + +main () +{ + long double x, delta; + int n, i, j; + + max1 = 0.0L; + max2 = 0.0L; + delta = 0.6 / PI; + for (n = -30; n <= 30; n++) + { + x = -30.0; + while (x < 30.0) + { + wronk (n, x); + x += delta; + } + delta += .00123456; + } +} + +void +wronk (n, x) + int n; + long double x; +{ + + Jnp1 = jnl (n + 1, x); + Jmn = jnl (-n, x); + Jn = jnl (n, x); + Jmnp1 = jnl (-(n + 1), x); + /* This should be trivially zero. */ + err1 = Jnp1 * Jmn + Jn * Jmnp1; + if (err1 < 0.0) + err1 = -err1; + if (err1 > max1) + { + max1 = err1; + printf ("1 %3d %.5Le %.3Le\n", n, x, max1); + } + if (x < 0.0) + { + x = -x; + Jn = jnl (n, x); + Jnp1 = jnl (n + 1, x); + } + Yn = ynl (n, x); + Ynp1 = ynl (n + 1, x); + /* The Wronksian. */ + w1 = Jnp1 * Yn - Jn * Ynp1; + /* What the Wronksian should be. */ + w2 = 2.0 / (PI * x); + err2 = w1 - w2; + if (err2 > max2) + { + max2 = err2; + printf ("2 %3d %.5Le %.3Le\n", n, x, max2); + } +} diff --git a/libm/ldouble/ynl.c b/libm/ldouble/ynl.c new file mode 100644 index 000000000..444792850 --- /dev/null +++ b/libm/ldouble/ynl.c @@ -0,0 +1,113 @@ +/* ynl.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * long double x, y, ynl(); + * int n; + * + * y = ynl( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order n, where n is a + * (possibly negative) integer. + * + * The function is evaluated by forward recurrence on + * n, starting with values computed by the routines + * y0l() and y1l(). + * + * If n = 0 or 1 the routine for y0l or y1l is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative error when y > 1. + * x >= 0, -30 <= n <= +30. + * arithmetic domain # trials peak rms + * IEEE -30, 30 10000 1.3e-18 1.8e-19 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ynl singularity x = 0 MAXNUML + * ynl overflow MAXNUML + * + * Spot checked against tables for x, n between 0 and 100. + * + */ + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern long double MAXNUML; +#ifdef ANSIPROT +extern long double y0l ( long double ); +extern long double y1l ( long double ); +#else +long double y0l(), y1l(); +#endif + +long double ynl( n, x ) +int n; +long double x; +{ +long double an, anm1, anm2, r; +int k, sign; + +if( n < 0 ) + { + n = -n; + if( (n & 1) == 0 ) /* -1**n */ + sign = 1; + else + sign = -1; + } +else + sign = 1; + + +if( n == 0 ) + return( sign * y0l(x) ); +if( n == 1 ) + return( sign * y1l(x) ); + +/* test for overflow */ +if( x <= 0.0L ) + { + mtherr( "ynl", SING ); + return( -MAXNUML ); + } + +/* forward recurrence on n */ + +anm2 = y0l(x); +anm1 = y1l(x); +k = 1; +r = 2 * k; +do + { + an = r * anm1 / x - anm2; + anm2 = anm1; + anm1 = an; + r += 2.0L; + ++k; + } +while( k < n ); + + +return( sign * an ); +} |