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 | |
| parent | 22358dd7ce7bb49792204b698f01a6f69b9c8e08 (diff) | |
uClibc now has a math library. muahahahaha!
-Erik
277 files changed, 91551 insertions, 170 deletions
@@ -29,7 +29,7 @@ TOPDIR=./ include Rules.mak -DIRS = extra misc pwd_grp stdio string termios inet signal stdlib sysdeps unistd crypt libutil +DIRS = extra misc pwd_grp stdio string termios inet signal stdlib sysdeps unistd crypt libutil libm ifeq ($(strip $(HAS_MMU)),true) DO_SHARED=shared @@ -60,6 +60,7 @@ shared: $(LIBNAME) ln -sf $(SHARED_MAJORNAME) libc.so @$(MAKE) -C crypt shared @$(MAKE) -C libutil shared + @$(MAKE) -C libm shared @$(MAKE) -C ld.so-1 done: $(LIBNAME) $(DO_SHARED) @@ -116,6 +117,7 @@ install: install_runtime install_dev install_ldso install_runtime: @$(MAKE) -C crypt install @$(MAKE) -C libutil install + @$(MAKE) -C libm install ifneq ($(DO_SHARED),) install -d $(INSTALL_DIR)/lib rm -rf $(INSTALL_DIR)/lib/$(SHARED_FULLNAME) @@ -180,6 +182,16 @@ uClibc_config.h: Config else \ echo "#undef __UCLIBC_HAS_FLOATS__" >> uClibc_config.h ; \ fi + @if [ "$(HAS_DOUBLE)" = "true" ] ; then \ + echo "#define __UCLIBC_HAS_DOUBLE__ 1" >> uClibc_config.h ; \ + else \ + echo "#undef __UCLIBC_HAS_DOUBLE__" >> uClibc_config.h ; \ + fi + @if [ "$(HAS_LONG_DOUBLE)" = "true" ] ; then \ + echo "#define __UCLIBC_HAS_LONG_DOUBLE__ 1" >> uClibc_config.h ; \ + else \ + echo "#undef __UCLIBC_HAS_LONG_DOUBLE__" >> uClibc_config.h ; \ + fi @if [ "$(HAS_LONG_LONG)" = "true" ] ; then \ echo "#define __UCLIBC_HAS_LONG_LONG__ 1" >> uClibc_config.h ; \ else \ diff --git a/include/math.h b/include/math.h index ab74e5ee8..853d71368 100644 --- a/include/math.h +++ b/include/math.h @@ -1,176 +1,634 @@ -#ifndef _MATH_H -#define _MATH_H -/* - * This file was automatically generated by version 1.7 of cextract. - * Manual editing not recommended. +/* mconf.h + * <math.h> + * ISO/IEC 9899:1999 -- Programming Languages C: 7.12 Mathematics + * Derived from the Cephes Math Library Release 2.3 + * Copyright 1984, 1987, 1989, 1995 by Stephen L. Moshier * - * Created: Fri Feb 23 20:31:13 1996 * - * Modified (anyway) for PalmOS Feb 22, 1997, D.Jeff Dionne + * DESCRIPTION: + * + * The file also includes a conditional assembly definition + * for the type of computer arithmetic (IEEE, DEC, Motorola + * IEEE, or UNKnown). + * + * For Digital Equipment PDP-11 and VAX computers, certain + * IBM systems, and others that use numbers with a 56-bit + * significand, the symbol DEC should be defined. In this + * mode, most floating point constants are given as arrays + * of octal integers to eliminate decimal to binary conversion + * errors that might be introduced by the compiler. + * + * For little-endian computers, such as IBM PC, that follow the + * IEEE Standard for Binary Floating Point Arithmetic (ANSI/IEEE + * Std 754-1985), the symbol IBMPC should be defined. These + * numbers have 53-bit significands. In this mode, constants + * are provided as arrays of hexadecimal 16 bit integers. + * + * Big-endian IEEE format is denoted MIEEE. On some RISC + * systems such as Sun SPARC, double precision constants + * must be stored on 8-byte address boundaries. Since integer + * arrays may be aligned differently, the MIEEE configuration + * may fail on such machines. + * + * To accommodate other types of computer arithmetic, all + * constants are also provided in a normal decimal radix + * which one can hope are correctly converted to a suitable + * format by the available C language compiler. To invoke + * this mode, define the symbol UNK. + * + * An important difference among these modes is a predefined + * set of machine arithmetic constants for each. The numbers + * MACHEP (the machine roundoff error), MAXNUM (largest number + * represented), and several other parameters are preset by + * the configuration symbol. Check the file const.c to + * ensure that these values are correct for your computer. + * + * Configurations NANS, INFINITIES, MINUSZERO, and DENORMAL + * may fail on many systems. Verify that they are supposed + * to work on your computer. + */ + + +#ifndef _MATH_H +#define _MATH_H 1 + +#include <features.h> + +#ifndef __UCLIBC_HAS_FLOATS__ + #define float int +#endif +#ifndef __UCLIBC_HAS_DOUBLE__ + #define double int +#endif +#ifndef __UCLIBC_HAS_LONG_DOUBLE__ + #define long + #ifndef double + # define double int + #endif +#endif + +/* Type of computer arithmetic */ + +/* PDP-11, Pro350, VAX: + */ +/* #define DEC 1 */ + +/* Intel IEEE, low order words come first: + */ +/* #define IBMPC 1 */ + +/* Motorola IEEE, high order words come first + * (Sun 680x0 workstation): + */ +/* #define MIEEE 1 */ + +/* UNKnown arithmetic, invokes coefficients given in + * normal decimal format. Beware of range boundary + * problems (MACHEP, MAXLOG, etc. in const.c) and + * roundoff problems in pow.c: + * (Sun SPARCstation) + */ +#define UNK 1 + + +/* Define if the `long double' type works. */ +#define HAVE_LONG_DOUBLE 1 + +/* Define as the return type of signal handlers (int or void). */ +#define RETSIGTYPE void + +/* Define if you have the ANSI C header files. */ +#define STDC_HEADERS 1 + +/* Define if your processor stores words with the most significant + byte first (like Motorola and SPARC, unlike Intel and VAX). */ +/* #undef WORDS_BIGENDIAN */ + +/* Define if floating point words are bigendian. */ +/* #undef FLOAT_WORDS_BIGENDIAN */ + +/* The number of bytes in a int. */ +#define SIZEOF_INT 4 + +/* Define if you have the <string.h> header file. */ +#define HAVE_STRING_H 1 + + +/* Define this `volatile' if your compiler thinks + * that floating point arithmetic obeys the associative + * and distributive laws. It will defeat some optimizations + * (but probably not enough of them). + * + * #define VOLATILE volatile + */ +#define VOLATILE + +/* For 12-byte long doubles on an i386, pad a 16-bit short 0 + * to the end of real constants initialized by integer arrays. + * + * #define XPD 0, + * + * Otherwise, the type is 10 bytes long and XPD should be + * defined blank (e.g., Microsoft C). + * + * #define XPD */ +#define XPD 0, + +/* Define to support tiny denormal numbers, else undefine. */ +#define DENORMAL 1 + +/* Define to ask for infinity support, else undefine. */ +#define INFINITIES 1 + +/* Define to ask for support of numbers that are Not-a-Number, + else undefine. This may automatically define INFINITIES in some files. */ +#define NANS 1 + +/* Define to distinguish between -0.0 and +0.0. */ +#define MINUSZERO 1 + +/* Define 1 for ANSI C atan2() function + and ANSI prototypes for float arguments. + See atan.c and clog.c. */ +#define ANSIC 1 +#define ANSIPROT 1 + + +/* Constant definitions for math error conditions */ + +#define DOMAIN 1 /* argument domain error */ +#define SING 2 /* argument singularity */ +#define OVERFLOW 3 /* overflow range error */ +#define UNDERFLOW 4 /* underflow range error */ +#define TLOSS 5 /* total loss of precision */ +#define PLOSS 6 /* partial loss of precision */ + +#define EDOM 33 +#define ERANGE 34 + +/* Complex numeral. */ +typedef struct + { + double r; + double i; + } cmplx; + +typedef struct + { + float r; + float i; + } cmplxf; + +#ifdef HAVE_LONG_DOUBLE +/* Long double complex numeral. */ +typedef struct + { + long double r; + long double i; + } cmplxl; +#endif + + + +/* Variable for error reporting. See mtherr.c. */ +extern int mtherr(); +extern int merror; + + +/* If you define UNK, then be sure to set BIGENDIAN properly. */ +#include <endian.h> +#if __BYTE_ORDER == __BIG_ENDIAN +# define BIGENDIAN 1 +#else /* __BYTE_ORDER == __LITTLE_ENDIAN */ +# define BIGENDIAN 0 +#endif + + +#define __USE_ISOC9X +/* Get general and ISO C 9X specific information. */ +#include <bits/mathdef.h> +#undef INFINITY +#undef DECIMAL_DIG +#undef FP_ILOGB0 +#undef FP_ILOGBNAN + +/* Get the architecture specific values describing the floating-point + evaluation. The following symbols will get defined: + + float_t floating-point type at least as wide as `float' used + to evaluate `float' expressions + double_t floating-point type at least as wide as `double' used + to evaluate `double' expressions + + FLT_EVAL_METHOD + Defined to + 0 if `float_t' is `float' and `double_t' is `double' + 1 if `float_t' and `double_t' are `double' + 2 if `float_t' and `double_t' are `long double' + else `float_t' and `double_t' are unspecified + + INFINITY representation of the infinity value of type `float' + + FP_FAST_FMA + FP_FAST_FMAF + FP_FAST_FMAL + If defined it indicates that the `fma' function + generally executes about as fast as a multiply and an add. + This macro is defined only iff the `fma' function is + implemented directly with a hardware multiply-add instructions. + + FP_ILOGB0 Expands to a value returned by `ilogb (0.0)'. + FP_ILOGBNAN Expands to a value returned by `ilogb (NAN)'. + + DECIMAL_DIG Number of decimal digits supported by conversion between + decimal and all internal floating-point formats. + +*/ + +/* All floating-point numbers can be put in one of these categories. */ +enum + { + FP_NAN, +# define FP_NAN FP_NAN + FP_INFINITE, +# define FP_INFINITE FP_INFINITE + FP_ZERO, +# define FP_ZERO FP_ZERO + FP_SUBNORMAL, +# define FP_SUBNORMAL FP_SUBNORMAL + FP_NORMAL +# define FP_NORMAL FP_NORMAL + }; + +/* Return number of classification appropriate for X. */ +# ifdef __NO_LONG_DOUBLE_MATH +# define fpclassify(x) \ + (sizeof (x) == sizeof (float) ? __fpclassifyf (x) : __fpclassify (x)) +# else +# define fpclassify(x) \ + (sizeof (x) == sizeof (float) ? \ + __fpclassifyf (x) \ + : sizeof (x) == sizeof (double) ? \ + __fpclassify (x) : __fpclassifyl (x)) +# endif + +/* Return nonzero value if sign of X is negative. */ +int signbit(double x); +int signbitl(long double x); + +/* Return nonzero value if X is not +-Inf or NaN. */ +int isfinite(double x); +int isfinitel(long double x); + +/* Return nonzero value if X is neither zero, subnormal, Inf, nor NaN. */ +# define isnormal(x) (fpclassify (x) == FP_NORMAL) + +/* Return nonzero value if X is a NaN */ +int isnan(double x); +int isnanl(long double x); + +/* Return nonzero value is X is positive or negative infinity. */ +# ifdef __NO_LONG_DOUBLE_MATH +# define isinf(x) \ + (sizeof (x) == sizeof (float) ? __isinff (x) : __isinf (x)) +# else +# define isinf(x) \ + (sizeof (x) == sizeof (float) ? \ + __isinff (x) \ + : sizeof (x) == sizeof (double) ? \ + __isinf (x) : __isinfl (x)) +# endif + -typedef struct { - double r; - double i; -}cmplxf; /* Some useful constants. */ -#define M_E 2.7182818284590452354 /* e */ -#define M_LOG2E 1.4426950408889634074 /* log_2 e */ -#define M_LOG10E 0.43429448190325182765 /* log_10 e */ -#define M_LN2 0.69314718055994530942 /* log_e 2 */ -#define M_LN10 2.30258509299404568402 /* log_e 10 */ -#define M_PI 3.14159265358979323846 /* pi */ -#define M_PI_2 1.57079632679489661923 /* pi/2 */ -#define M_PI_4 0.78539816339744830962 /* pi/4 */ -#define M_1_PI 0.31830988618379067154 /* 1/pi */ -#define M_2_PI 0.63661977236758134308 /* 2/pi */ -#define M_2_SQRTPI 1.12837916709551257390 /* 2/sqrt(pi) */ -#define M_SQRT2 1.41421356237309504880 /* sqrt(2) */ -#define M_SQRT1_2 0.70710678118654752440 /* 1/sqrt(2) */ - - -extern double acos ( double x ); -extern double acosh ( double xx ); -extern int airy ( double xx, double *ai, double *aip, double *bi, double *bip ); -extern double asin ( double xx ); -extern double asinh ( double xx ); -extern double atan2 ( double y, double x ); -extern double atan ( double xx ); -extern double atanh ( double xx ); -extern double bdtrc ( int k, int n, double pp ); -extern double bdtr ( int k, int n, double pp ); -extern double bdtri ( int k, int n, double yy ); -extern double beta ( double aa, double bb ); -extern double cabs ( cmplxf *z ); -extern void cacos ( cmplxf *z, cmplxf *w ); -extern void cadd ( cmplxf *a, cmplxf *b, cmplxf *c ); -extern void casin ( cmplxf *z, cmplxf *w ); -extern void catan ( cmplxf *z, cmplxf *w ); -extern double cbrt ( double xx ); -extern void cchsh ( double xx, double *c, double *s ); -extern void ccos ( cmplxf *z, cmplxf *w ); -extern void ccot ( cmplxf *z, cmplxf *w ); -extern void cdiv ( cmplxf *a, cmplxf *b, cmplxf *c ); -extern double ceil ( double x ); -extern void cexp ( cmplxf *z, cmplxf *w ); -extern double chbevl ( double x, double *array, int n ); -extern double chdtrc ( double dff, double xx ); -extern double chdtr ( double dff, double xx ); -extern double chdtri ( double dff, double yy ); -#if 0 -extern void clog ( cmplxf *z, cmplxf *w ); +#if defined __USE_BSD || defined __USE_XOPEN +# define M_E 2.7182818284590452354 /* e */ +# define M_LOG2E 1.4426950408889634074 /* log_2 e */ +# define M_LOG10E 0.43429448190325182765 /* log_10 e */ +# define M_LN2 0.69314718055994530942 /* log_e 2 */ +# define M_LN10 2.30258509299404568402 /* log_e 10 */ +# define M_PI 3.14159265358979323846 /* pi */ +# define M_PI_2 1.57079632679489661923 /* pi/2 */ +# define M_PI_4 0.78539816339744830962 /* pi/4 */ +# define M_1_PI 0.31830988618379067154 /* 1/pi */ +# define M_2_PI 0.63661977236758134308 /* 2/pi */ +# define M_2_SQRTPI 1.12837916709551257390 /* 2/sqrt(pi) */ +# define M_SQRT2 1.41421356237309504880 /* sqrt(2) */ +# define M_SQRT1_2 0.70710678118654752440 /* 1/sqrt(2) */ +#endif +#ifdef __USE_GNU +# define M_El M_E +# define M_LOG2El M_LOG2E +# define M_LOG10El M_LOG10E +# define M_LN2l M_LN2 +# define M_LN10l M_LN10 +# define M_PIl M_PI +# define M_PI_2l M_PI_2 +# define M_PI_4l M_PI_4 +# define M_1_PIl M_1_PI +# define M_2_PIl M_2_PI +# define M_2_SQRTPIl M_2_SQRTPI +# define M_SQRT2l M_SQRT2 +# define M_SQRT1_2l M_SQRT1_2 +#endif + + + + +/* 7.12.4 Trigonometric functions */ +extern double acos(double x); +extern float acosf(float x); +extern long double acosl(long double x); + +extern double asin(double x); +extern float asinf(float x); +extern long double asinl(long double x); + +extern double atan(double x); +extern float atanf(float x); +extern long double atanl(long double x); + +double atan2(double y, double x); +float atan2f(float y, float x); +long double atan2l(long double y, long double x); + +double cos(double x); +float cosf(float x); +long double cosl(long double x); + +double sin(double x); +float sinf(float x); +long double sinl(long double x); + +double tan(double x); +float tanf(float x); +long double tanl(long double x); + + +/* 7.12.5 Hyperbolic functions */ +double acosh(double x); +float acoshf(float x); +long double acoshl(long double x); + +double asinh(double x); +float asinhf(float x); +long double asinhl(long double x); + +double atanh(double x); +float atanhf(float x); +long double atanhl(long double x); + +double cosh(double x); +float coshf(float x); +long double coshl(long double x); + +double sinh(double x); +float sinhf(float x); +long double sinhl(long double x); + +double tanh(double x); +float tanhf(float x); +long double tanhl(long double x); + + +/* 7.12.6 Exponential and logarithmic functions */ +double exp(double x); +float expf(float x); +long double expl(long double x); + +double exp2(double x); +float exp2f(float x); +long double exp2l(long double x); + +double expm1(double x); +float expm1f(float x); +long double expm1l(long double x); + +double frexp(double value, int *exp); +float frexpf(float value, int *exp); +long double frexpl(long double value, int *exp); + +int ilogb(double x); +int ilogbf(float x); +int ilogbl(long double x); + +double ldexp(double x, int exp); +float ldexpf(float x, int exp); +long double ldexpl(long double x, int exp); + +double log(double x); +float logf(float x); +long double logl(long double x); + +double log10(double x); +float log10f(float x); +long double log10l(long double x); + +double log1p(double x); +float log1pf(float x); +long double log1pl(long double x); + +double log2(double x); +float log2f(float x); +long double log2l(long double x); + +double logb(double x); +float logbf(float x); +long double logbl(long double x); + +double modf(double value, double *iptr); +float modff(float value, float *iptr); +long double modfl(long double value, long double *iptr); + +double scalbn(double x, int n); +float scalbnf(float x, int n); +long double scalbnl(long double x, int n); +double scalbln(double x, long int n); +float scalblnf(float x, long int n); +long double scalblnl(long double x, long int n); + +/* 7.12.7 Power and absolute-value functions */ +double fabs(double x); +float fabsf(float x); +long double fabsl(long double x); + +double hypot(double x, double y); +float hypotf(float x, float y); +long double hypotl(long double x, long double y); + +double pow(double x, double y); +float powf(float x, float y); +long double powl(long double x, long double y); + +double sqrt(double x); +float sqrtf(float x); +long double sqrtl(long double x); + +/* 7.12.8 Error and gamma functions */ +double erf(double x); +float erff(float x); +long double erfl(long double x); + +double erfc(double x); +float erfcf(float x); +long double erfcl(long double x); + +double lgamma(double x); +float lgammaf(float x); +long double lgammal(long double x); + +double tgamma(double x); +float tgammaf(float x); +long double tgammal(long double x); + +/* 7.12.9 Nearest integer functions */ +double ceil(double x); +float ceilf(float x); +long double ceill(long double x); + +double floor(double x); +float floorf(float x); +long double floorl(long double x); + +double nearbyint(double x); +float nearbyintf(float x); +long double nearbyintl(long double x); + +double rint(double x); +float rintf(float x); +long double rintl(long double x); + +long int lrint(double x); +long int lrintf(float x); +long int lrintl(long double x); +long long int llrint(double x); +long long int llrintf(float x); +long long int llrintl(long double x); + +double round(double x); +float roundf(float x); +long double roundl(long double x); + +long int lround(double x); +long int lroundf(float x); +long int lroundl(long double x); +long long int llround(double x); +long long int llroundf(float x); +long long int llroundl(long double x); + +double trunc(double x); +float truncf(float x); +long double truncl(long double x); + +/* 7.12.10 Remainder functions */ +double fmod(double x, double y); +float fmodf(float x, float y); +long double fmodl(long double x, long double y); + +double remainder(double x, double y); +float remainderf(float x, float y); +long double remainderl(long double x, long double y); + +double remquo(double x, double y, int *quo); +float remquof(float x, float y, int *quo); +long double remquol(long double x, long double y, int *quo); + +/* 7.12.11 Manipulation functions */ +double copysign(double x, double y); +float copysignf(float x, float y); +long double copysignl(long double x, long double y); + +double nan(const char *tagp); +float nanf(const char *tagp); +long double nanl(const char *tagp); + +double nextafter(double x, double y); +float nextafterf(float x, float y); +long double nextafterl(long double x, long double y); + +double nexttoward(double x, long double y); +float nexttowardf(float x, long double y); +long double nexttowardl(long double x, long double y); + +/* 7.12.12 Maximum, minimum, and positive difference functions */ +double fdim(double x, double y); +float fdimf(float x, float y); +long double fdiml(long double x, long double y); + +double fmax(double x, double y); +float fmaxf(float x, float y); +long double fmaxl(long double x, long double y); + +double fmin(double x, double y); +float fminf(float x, float y); +long double fminl(long double x, long double y); + +/* 7.12.13 Floating multiply-add */ +double fma(double x, double y, double z); +float fmaf(float x, float y, float z); +long double fmal(long double x, long double y, long double z); + +/* 7.12.14 Comparison macros */ +# ifndef isgreater +# define isgreater(x, y) \ + (__extension__ \ + ({ __typeof__(x) __x = (x); __typeof__(y) __y = (y); \ + !isunordered (__x, __y) && __x > __y; })) +# endif + +/* Return nonzero value if X is greater than or equal to Y. */ +# ifndef isgreaterequal +# define isgreaterequal(x, y) \ + (__extension__ \ + ({ __typeof__(x) __x = (x); __typeof__(y) __y = (y); \ + !isunordered (__x, __y) && __x >= __y; })) +# endif + +/* Return nonzero value if X is less than Y. */ +# ifndef isless +# define isless(x, y) \ + (__extension__ \ + ({ __typeof__(x) __x = (x); __typeof__(y) __y = (y); \ + !isunordered (__x, __y) && __x < __y; })) +# endif + +/* Return nonzero value if X is less than or equal to Y. */ +# ifndef islessequal +# define islessequal(x, y) \ + (__extension__ \ + ({ __typeof__(x) __x = (x); __typeof__(y) __y = (y); \ + !isunordered (__x, __y) && __x <= __y; })) +# endif + +/* Return nonzero value if either X is less than Y or Y is less than X. */ +# ifndef islessgreater +# define islessgreater(x, y) \ + (__extension__ \ + ({ __typeof__(x) __x = (x); __typeof__(y) __y = (y); \ + !isunordered (__x, __y) && (__x < __y || __y < __x); })) +# endif + +/* Return nonzero value if arguments are unordered. */ +# ifndef isunordered +# define isunordered(u, v) \ + (__extension__ \ + ({ __typeof__(u) __u = (u); __typeof__(v) __v = (v); \ + fpclassify (__u) == FP_NAN || fpclassify (__v) == FP_NAN; })) +# endif + + +#ifndef __UCLIBC_HAS_FLOATS__ + #undef float #endif -extern void cmov ( short *a, short *b ); -extern void cmul ( cmplxf *a, cmplxf *b, cmplxf *c ); -extern void cneg ( cmplxf *a ); -extern double cosdg ( double xx ); -extern double cos ( double xx ); -extern double cosh ( double xx ); -extern double cotdg ( double x ); -extern double cot ( double x ); -extern void csin ( cmplxf *z, cmplxf *w ); -extern void csqrt ( cmplxf *z, cmplxf *w ); -extern void csub ( cmplxf *a, cmplxf *b, cmplxf *c ); -extern void ctan ( cmplxf *z, cmplxf *w ); -extern double ctans ( cmplxf *z ); -extern double dawsn ( double xxx ); -extern int dprec ( void ); -extern double ellie ( double phia, double ma ); -extern double ellik ( double phia, double ma ); -extern double ellpe ( double xx ); -extern int ellpj ( double uu, double mm, double *sn, double *cn, double *dn, double *ph ); -extern double ellpk ( double xx ); -extern double erfc ( double aa ); -extern double erf ( double xx ); -extern double exp10 ( double xx ); -extern double exp2 ( double xx ); -extern double exp ( double xx ); -extern double expn ( int n, double xx ); -extern double fac ( int i ); -extern double fdtrc ( int ia, int ib, double xx ); -extern double fdtr ( int ia, int ib, int xx ); -extern double fdtri ( int ia, int ib, double yy ); -extern double floor ( double x ); -extern void fresnl ( double xxa, double *ssa, double *cca ); -extern double frexp ( double x, int *pw2 ); -extern double gamma ( double xx ); -extern double gdtrc ( double aa, double bb, double xx ); -extern double gdtr ( double aa, double bb, double xx ); -extern double hyp2f0 ( double aa, double bb, double xx, int type, double *err ); -extern double hyp2f1 ( double aa, double bb, double cc, double xx ); -extern double hyperg ( double aa, double bb, double xx ); -extern double i0e ( double x ); -extern double i0 ( double x ); -extern double i1e ( double xx ); -extern double i1 ( double xx ); -extern double igamc ( double aa, double xx ); -extern double igam ( double aa, double xx ); -extern double igami ( double aa, double yy0 ); -extern double incbet ( double aaa, double bbb, double xxx ); -extern double incbi ( double aaa, double bbb, double yyy0 ); -extern double incbps ( double aa, double bb, double xx ); -extern double iv ( double v, double x ); -extern double j0 ( double xx ); -extern double j1 ( double xx ); -extern double jn ( int n, double xx ); -extern double jv ( double nn, double xx ); -extern double k0e ( double xx ); -extern double k0 ( double xx ); -extern double k1e ( double xx ); -extern double k1 ( double xx ); -extern double kn ( int nnn, double xx ); -extern double ldexp ( double x, int pw2 ); -extern int ldprec ( void ); -extern double lgam ( double xx ); -extern double log10 ( double xx ); -extern double log2 ( double xx ); -extern double log ( double xx ); -/* extern int mtherr ( char *name, int code ); */ -extern double nbdtrc ( int k, int n, double pp ); -extern double nbdtr ( int k, int n, double pp ); -extern double ndtr ( double aa ); -extern double ndtri ( double yy0 ); -extern double onef2 ( double aa, double bb, double cc, double xx, double *err ); -extern double p1evl ( double xx, double *coef, int N ); -extern double pdtrc ( int k, double mm ); -extern double pdtr ( int k, double mm ); -extern double pdtri ( int k, double yy ); -extern void poladd ( double a[], int na, double b[], int nb, double c[] ); -extern void polclr ( double *a, int n ); -extern int poldiv ( double a[], int na, double b[], int nb, double c[] ); -extern double poleva ( double *a, int na, double xx ); -extern double polevl ( double xx, double *coef, int N ); -extern void polini ( int maxdeg ); -extern void polmov ( double *a, int na, double *b ); -extern void polmul ( double a[], int na, double b[], int nb, double c[] ); -extern void polprt ( double *a, int na, int d ); -extern void polsbt ( double a[], int na, double b[], int nb, double c[] ); -extern void polsub ( double a[], int na, double b[], int nb, double c[] ); -extern double pow ( double x, double y ); -extern double powi ( double x, int nn ); -extern double psi ( double xx ); -extern double redupi ( double xx ); -extern double rgamma ( double xx ); -extern int shichi ( double xx, double *si, double *ci ); -extern int sici ( double xx, double *si, double *ci ); -extern double sindg ( double xx ); -extern double sin ( double xx ); -extern double sinh ( double xx ); -extern double spence ( double xx ); -extern int sprec ( void ); -extern double sqrt ( double xx ); -extern double stdtr ( int k, double tt ); -extern double struve ( double vv, double xx ); -extern double tandg ( double x ); -extern double tan ( double x ); -extern double tanh ( double xx ); -extern double threef0 ( double aa, double bb, double cc, double xx, double *err ); -extern double y0 ( double xx ); -extern double y1 ( double xx ); -extern double yn ( int nn, double xx ); -extern double yv ( double vv, double xx ); -extern double zetac ( double xx ); -extern double zeta ( double xx, double qq ); - -#endif /* _MATH_H */ +#ifndef __UCLIBC_HAS_DOUBLE__ + #undef double +#endif +#ifndef __UCLIBC_HAS_LONG_DOUBLE__ + #undef long + #undef double +#endif + + +#endif /* math.h */ diff --git a/libm/Makefile b/libm/Makefile new file mode 100644 index 000000000..c151d7cbd --- /dev/null +++ b/libm/Makefile @@ -0,0 +1,75 @@ +# 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 +LIBM_SHARED=libm.so +TARGET_CC= $(TOPDIR)extra/gcc-uClibc/$(TARGET_ARCH)-uclibc-gcc + +DIRS= +ifeq ($(strip $(HAS_FLOATS)),true) + DIRS+=float +endif +ifeq ($(strip $(HAS_DOUBLE)),true) + DIRS+=double +endif +ifeq ($(strip $(HAS_LONG_DOUBLE)),true) + DIRS+=ldouble +endif +ALL_SUBDIRS = $(shell find * -type d -prune -name [a-z]\*) + +all: $(LIBM) + +$(LIBM): subdirs + +tags: + ctags -R + +shared: $(LIBM) + $(TARGET_CC) $(LDFLAGS) -shared -o $(LIBM_SHARED).$(MAJOR_VERSION) \ + -Wl,-soname,$(LIBM_SHARED).$(MAJOR_VERSION) -Wl,--whole-archive $(LIBM) $(TOPDIR)$(SHARED_FULLNAME) + +install: all + install -d $(INSTALL_DIR)/lib + install -m 644 $(LIBM) $(INSTALL_DIR)/lib/ + @if [ -f $(LIBM_SHARED).$(MAJOR_VERSION) ] ; then \ + install -m 644 $(LIBM_SHARED).$(MAJOR_VERSION) $(INSTALL_DIR)/lib/; \ + (cd $(INSTALL_DIR)/lib/;ln -sf $(LIBM_SHARED).$(MAJOR_VERSION) $(LIBM_SHARED)); \ + fi; + +subdirs: $(patsubst %, _dir_%, $(DIRS)) +subdirs_clean: $(patsubst %, _dirclean_%, $(ALL_SUBDIRS)) + +$(patsubst %, _dir_%, $(DIRS)) : dummy + $(MAKE) -C $(patsubst _dir_%, %, $@) + +$(patsubst %, _dirclean_%, $(ALL_SUBDIRS)) : dummy + $(MAKE) -C $(patsubst _dirclean_%, %, $@) clean + +clean: subdirs_clean + rm -f *.[oa] *~ core $(LIBM_SHARED)* $(LIBM) + +.PHONY: dummy + + diff --git a/libm/README b/libm/README new file mode 100644 index 000000000..023e46846 --- /dev/null +++ b/libm/README @@ -0,0 +1,42 @@ +The actual routines included in this math library are derived almost +exclusively from the Cephes Mathematical Library, which "is copyrighted by the +author [and] may be used freely but ... comes with no support or guarantee" + +It has been ported to fit into uClibc and generally behave +by Erik Andersen <andersen@lineo.com>, <andersee@debian.org> + 5 May, 2001 + +-------------------------------------------------- + + Some software in this archive may be from the book _Methods and +Programs for Mathematical Functions_ (Prentice-Hall, 1989) or +from the Cephes Mathematical Library, a commercial product. In +either event, it is copyrighted by the author. What you see here +may be used freely but it comes with no support or guarantee. + + The two known misprints in the book are repaired here in the +source listings for the gamma function and the incomplete beta +integral. + + + Stephen L. Moshier + moshier@world.std.com + +-------------------------------------------------- + +19 November 1992 + +ZIP archive constructed and index compiled. + +To reconstruct the original directory structure, use the -d switch: + + C:\CEPHES>pkunzip -d cephes + +This archive includes all the programs in the /netlib/cephes directory +on research.att.com as of 17 Nov 92. The file "index" will tell you in +what directory and file each function can be found. If there is +something else mentioned in cephes.doc that you need, you can check +research.att.com to see whether it has been added. Failing that, you +can contact Stephen Moshier. + + Jim Van Zandt <jrv@mbunix.mitre.org> diff --git a/libm/double/Makefile b/libm/double/Makefile new file mode 100644 index 000000000..be3c5878a --- /dev/null +++ b/libm/double/Makefile @@ -0,0 +1,115 @@ +# 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=acosh.c airy.c asin.c asinh.c atan.c atanh.c bdtr.c beta.c \ + btdtr.c cbrt.c chbevl.c chdtr.c clog.c cmplx.c const.c \ + cosh.c dawsn.c ei.c ellie.c ellik.c ellpe.c ellpj.c ellpk.c \ + exp.c exp10.c exp2.c expn.c fabs.c fac.c fdtr.c \ + fresnl.c gamma.c gdtr.c hyp2f1.c hyperg.c i0.c i1.c igami.c incbet.c \ + incbi.c igam.c isnan.c iv.c j0.c j1.c jn.c jv.c k0.c k1.c kn.c kolmogorov.c \ + log.c log2.c log10.c lrand.c nbdtr.c ndtr.c ndtri.c pdtr.c planck.c \ + polevl.c polmisc.c polylog.c polyn.c pow.c powi.c psi.c rgamma.c round.c \ + shichi.c sici.c sin.c sindg.c sinh.c spence.c stdtr.c struve.c \ + tan.c tandg.c tanh.c unity.c yn.c zeta.c zetac.c \ + sqrt.c floor.c setprec.c mtherr.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: libmd.a mtst dtestvec monot dcalc paranoia + +time-it: time-it.o + $(CC) -o time-it time-it.o + +time-it.o: time-it.c + $(CC) -O2 -c time-it.c + +dcalc: dcalc.o libmd.a + $(CC) -o dcalc dcalc.o libmd.a + +mtst: mtst.o libmd.a + $(CC) -v -o mtst mtst.o libmd.a + +mtst.o: mtst.c + $(CC) -O2 -Wall -c mtst.c + +dtestvec: dtestvec.o libmd.a + $(CC) -o dtestvec dtestvec.o libmd.a + +dtestvec.o: dtestvec.c + $(CC) -g -c dtestvec.c + +monot: monot.o libmd.a + $(CC) -o monot monot.o libmd.a + +monot.o: monot.c + $(CC) -g -c monot.c + +paranoia: paranoia.o setprec.o libmd.a + $(CC) -o paranoia paranoia.o setprec.o libmd.a + +paranoia.o: paranoia.c + $(CC) $(CFLAGS) -Wno-implicit -c paranoia.c + +libmd.a: $(OBJS) $(INCS) + $(AR) rv libmd.a $(OBJS) + +#clean: +# rm -f *.o +# rm -f mtst +# rm -f paranoia +# rm -f dcalc +# rm -f dtestvec +# rm -f monot +# rm -f libmd.a +# rm -f time-it +# rm -f dtestvec + + diff --git a/libm/double/README.txt b/libm/double/README.txt new file mode 100644 index 000000000..f2cb6c3dc --- /dev/null +++ b/libm/double/README.txt @@ -0,0 +1,5845 @@ +/* acosh.c + * + * Inverse hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * double x, y, acosh(); + * + * y = acosh( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a rational approximation + * + * sqrt(z) * 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 + * DEC 1,3 30000 4.2e-17 1.1e-17 + * IEEE 1,3 30000 4.6e-16 8.7e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acosh domain |x| < 1 NAN + * + */ + +/* airy.c + * + * Airy function + * + * + * + * SYNOPSIS: + * + * double x, ai, aip, bi, bip; + * int airy(); + * + * airy( x, _&ai, _&aip, _&bi, _&bip ); + * + * + * + * DESCRIPTION: + * + * Solution of the differential equation + * + * y"(x) = xy. + * + * The function returns the two independent solutions Ai, Bi + * and their first derivatives Ai'(x), Bi'(x). + * + * Evaluation is by power series summation for small x, + * by rational minimax approximations for large x. + * + * + * + * ACCURACY: + * Error criterion is absolute when function <= 1, relative + * when function > 1, except * denotes relative error criterion. + * For large negative x, the absolute error increases as x^1.5. + * For large positive x, the relative error increases as x^1.5. + * + * Arithmetic domain function # trials peak rms + * IEEE -10, 0 Ai 10000 1.6e-15 2.7e-16 + * IEEE 0, 10 Ai 10000 2.3e-14* 1.8e-15* + * IEEE -10, 0 Ai' 10000 4.6e-15 7.6e-16 + * IEEE 0, 10 Ai' 10000 1.8e-14* 1.5e-15* + * IEEE -10, 10 Bi 30000 4.2e-15 5.3e-16 + * IEEE -10, 10 Bi' 30000 4.9e-15 7.3e-16 + * DEC -10, 0 Ai 5000 1.7e-16 2.8e-17 + * DEC 0, 10 Ai 5000 2.1e-15* 1.7e-16* + * DEC -10, 0 Ai' 5000 4.7e-16 7.8e-17 + * DEC 0, 10 Ai' 12000 1.8e-15* 1.5e-16* + * DEC -10, 10 Bi 10000 5.5e-16 6.8e-17 + * DEC -10, 10 Bi' 7000 5.3e-16 8.7e-17 + * + */ + +/* asin.c + * + * Inverse circular sine + * + * + * + * SYNOPSIS: + * + * double x, y, asin(); + * + * y = asin( 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 + * DEC -1, 1 40000 2.6e-17 7.1e-18 + * IEEE -1, 1 10^6 1.9e-16 5.4e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 NAN + * + */ + /* acos() + * + * Inverse circular cosine + * + * + * + * SYNOPSIS: + * + * double x, y, acos(); + * + * y = acos( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between 0 and pi 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 + * DEC -1, 1 50000 3.3e-17 8.2e-18 + * IEEE -1, 1 10^6 2.2e-16 6.5e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 NAN + */ + +/* asinh.c + * + * Inverse hyperbolic sine + * + * + * + * SYNOPSIS: + * + * double x, y, asinh(); + * + * y = asinh( 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 + * DEC -3,3 75000 4.6e-17 1.1e-17 + * IEEE -1,1 30000 3.7e-16 7.8e-17 + * IEEE 1,3 30000 2.5e-16 6.7e-17 + * + */ + +/* atan.c + * + * Inverse circular tangent + * (arctangent) + * + * + * + * SYNOPSIS: + * + * double x, y, atan(); + * + * y = atan( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose tangent + * is x. + * + * Range reduction is from three intervals into the interval + * from zero to 0.66. The approximant uses a rational + * function of degree 4/5 of the form x + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10, 10 50000 2.4e-17 8.3e-18 + * IEEE -10, 10 10^6 1.8e-16 5.0e-17 + * + */ + /* atan2() + * + * Quadrant correct inverse circular tangent + * + * + * + * SYNOPSIS: + * + * double x, y, z, atan2(); + * + * z = atan2( 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 10^6 2.5e-16 6.9e-17 + * See atan.c. + * + */ + +/* atanh.c + * + * Inverse hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * double x, y, atanh(); + * + * y = atanh( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOG to MAXLOG. + * + * 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 + * DEC -1,1 50000 2.4e-17 6.4e-18 + * IEEE -1,1 30000 1.9e-16 5.2e-17 + * + */ + +/* bdtr.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtr(); + * + * y = bdtr( 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 (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 4.3e-15 2.6e-16 + * See also incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtr domain k < 0 0.0 + * n < k + * x < 0, x > 1 + */ + /* bdtrc() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtrc(); + * + * y = bdtrc( 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: + * + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 6.7e-15 8.2e-16 + * For p between 0 and .001: + * IEEE 0,100 100000 1.5e-13 2.7e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrc domain x<0, x>1, n<k 0.0 + */ + /* bdtri() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtri(); + * + * p = bdtr( 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: + * + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 2.3e-14 6.4e-16 + * IEEE 0,10000 100000 6.6e-12 1.2e-13 + * For p between 10^-6 and 0.001: + * IEEE 0,100 100000 2.0e-12 1.3e-14 + * IEEE 0,10000 100000 1.5e-12 3.2e-14 + * See also incbi.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtri domain k < 0, n <= k 0.0 + * x < 0, x > 1 + */ + +/* beta.c + * + * Beta function + * + * + * + * SYNOPSIS: + * + * double a, b, y, beta(); + * + * y = beta( a, b ); + * + * + * + * DESCRIPTION: + * + * - - + * | (a) | (b) + * beta( a, b ) = -----------. + * - + * | (a+b) + * + * For large arguments the logarithm of the function is + * evaluated using lgam(), then exponentiated. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 1700 7.7e-15 1.5e-15 + * IEEE 0,30 30000 8.1e-14 1.1e-14 + * + * ERROR MESSAGES: + * + * message condition value returned + * beta overflow log(beta) > MAXLOG 0.0 + * a or b <0 integer 0.0 + * + */ + +/* btdtr.c + * + * Beta distribution + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, btdtr(); + * + * y = btdtr( 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 + * + * + * This function is identical to the incomplete beta + * integral function incbet(a, b, x). + * + * The complemented function is + * + * 1 - P(1-x) = incbet( b, a, x ); + * + * + * ACCURACY: + * + * See incbet.c. + * + */ + +/* cbrt.c + * + * Cube root + * + * + * + * SYNOPSIS: + * + * double x, y, cbrt(); + * + * y = cbrt( 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 + * DEC -10,10 200000 1.8e-17 6.2e-18 + * IEEE 0,1e308 30000 1.5e-16 5.0e-17 + * + */ + +/* chbevl.c + * + * Evaluate Chebyshev series + * + * + * + * SYNOPSIS: + * + * int N; + * double x, y, coef[N], chebevl(); + * + * y = chbevl( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates the series + * + * N-1 + * - ' + * y = > coef[i] T (x/2) + * - i + * i=0 + * + * of Chebyshev polynomials Ti at argument x/2. + * + * Coefficients are stored in reverse order, i.e. the zero + * order term is last in the array. Note N is the number of + * coefficients, not the order. + * + * If coefficients are for the interval a to b, x must + * have been transformed to x -> 2(2x - b - a)/(b-a) before + * entering the routine. This maps x from (a, b) to (-1, 1), + * over which the Chebyshev polynomials are defined. + * + * If the coefficients are for the inverted interval, in + * which (a, b) is mapped to (1/b, 1/a), the transformation + * required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity, + * this becomes x -> 4a/x - 1. + * + * + * + * SPEED: + * + * Taking advantage of the recurrence properties of the + * Chebyshev polynomials, the routine requires one more + * addition per loop than evaluating a nested polynomial of + * the same degree. + * + */ + +/* chdtr.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double df, x, y, chdtr(); + * + * y = chdtr( 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 + */ + /* chdtrc() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double v, x, y, chdtrc(); + * + * y = chdtrc( 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 + */ + /* chdtri() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double df, x, y, chdtri(); + * + * x = chdtri( 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 + * + */ + +/* clog.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clog(); + * cmplx z, w; + * + * clog( &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. + */ + +/* cexp() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexp(); + * cmplx z, w; + * + * cexp( &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 + * + */ + /* csin() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csin(); + * cmplx z, w; + * + * csin( &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. + * + */ + /* ccos() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccos(); + * cmplx z, w; + * + * ccos( &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 + */ + /* ctan() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctan(); + * cmplx z, w; + * + * ctan( &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. + */ + /* ccot() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccot(); + * cmplx z, w; + * + * ccot( &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. + */ + /* casin() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casin(); + * cmplx z, w; + * + * casin( &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. + */ + + /* cacos() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacos(); + * cmplx z, w; + * + * cacos( &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 + */ + /* catan() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catan(); + * cmplx z, w; + * + * catan( &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(). + */ + +/* cmplx.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * double r; real part + * double i; imaginary part + * }cmplx; + * + * cmplx *a, *b, *c; + * + * cadd( a, b, c ); c = b + a + * csub( a, b, c ); c = b - a + * cmul( a, b, c ); c = b * a + * cdiv( a, b, c ); c = b / a + * cneg( c ); c = -c + * cmov( 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 + */ + +/* cabs() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * double cabs(); + * cmplx z; + * 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 + */ + /* csqrt() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrt(); + * cmplx z, w; + * + * csqrt( &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. + */ + +/* const.c + * + * Globally declared constants + * + * + * + * SYNOPSIS: + * + * extern double nameofconstant; + * + * + * + * + * DESCRIPTION: + * + * This file contains a number of mathematical constants and + * also some needed size parameters of the computer arithmetic. + * The values are supplied as arrays of hexadecimal integers + * for IEEE arithmetic; arrays of octal constants for DEC + * arithmetic; and in a normal decimal scientific notation for + * other machines. The particular notation used is determined + * by a symbol (DEC, IBMPC, or UNK) defined in the include file + * math.h. + * + * The default size parameters are as follows. + * + * For DEC and UNK modes: + * MACHEP = 1.38777878078144567553E-17 2**-56 + * MAXLOG = 8.8029691931113054295988E1 log(2**127) + * MINLOG = -8.872283911167299960540E1 log(2**-128) + * MAXNUM = 1.701411834604692317316873e38 2**127 + * + * For IEEE arithmetic (IBMPC): + * MACHEP = 1.11022302462515654042E-16 2**-53 + * MAXLOG = 7.09782712893383996843E2 log(2**1024) + * MINLOG = -7.08396418532264106224E2 log(2**-1022) + * MAXNUM = 1.7976931348623158E308 2**1024 + * + * The global symbols for mathematical constants are + * PI = 3.14159265358979323846 pi + * PIO2 = 1.57079632679489661923 pi/2 + * PIO4 = 7.85398163397448309616E-1 pi/4 + * SQRT2 = 1.41421356237309504880 sqrt(2) + * SQRTH = 7.07106781186547524401E-1 sqrt(2)/2 + * LOG2E = 1.4426950408889634073599 1/log(2) + * SQ2OPI = 7.9788456080286535587989E-1 sqrt( 2/pi ) + * LOGE2 = 6.93147180559945309417E-1 log(2) + * LOGSQ2 = 3.46573590279972654709E-1 log(2)/2 + * THPIO4 = 2.35619449019234492885 3*pi/4 + * TWOOPI = 6.36619772367581343075535E-1 2/pi + * + * These lists are subject to change. + */ + +/* cosh.c + * + * Hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * double x, y, cosh(); + * + * y = cosh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOG to + * MAXLOG. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +- 88 50000 4.0e-17 7.7e-18 + * IEEE +-MAXLOG 30000 2.6e-16 5.7e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cosh overflow |x| > MAXLOG MAXNUM + * + * + */ + +/* cpmul.c + * + * Multiply two polynomials with complex coefficients + * + * + * + * SYNOPSIS: + * + * typedef struct + * { + * double r; + * double i; + * }cmplx; + * + * cmplx a[], b[], c[]; + * int da, db, dc; + * + * cpmul( a, da, b, db, c, &dc ); + * + * + * + * DESCRIPTION: + * + * The two argument polynomials are multiplied together, and + * their product is placed in c. + * + * Each polynomial is represented by its coefficients stored + * as an array of complex number structures (see the typedef). + * The degree of a is da, which must be passed to the routine + * as an argument; similarly the degree db of b is an argument. + * Array a has da + 1 elements and array b has db + 1 elements. + * Array c must have storage allocated for at least da + db + 1 + * elements. The value da + db is returned in dc; this is + * the degree of the product polynomial. + * + * Polynomial coefficients are stored in ascending order; i.e., + * a(x) = a[0]*x**0 + a[1]*x**1 + ... + a[da]*x**da. + * + * + * If desired, c may be the same as either a or b, in which + * case the input argument array is replaced by the product + * array (but only up to terms of degree da + db). + * + */ + +/* dawsn.c + * + * Dawson's Integral + * + * + * + * SYNOPSIS: + * + * double x, y, dawsn(); + * + * y = dawsn( x ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * x + * - + * 2 | | 2 + * dawsn(x) = exp( -x ) | exp( t ) dt + * | | + * - + * 0 + * + * Three different rational approximations are employed, for + * the intervals 0 to 3.25; 3.25 to 6.25; and 6.25 up. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 10000 6.9e-16 1.0e-16 + * DEC 0,10 6000 7.4e-17 1.4e-17 + * + * + */ + +/* drand.c + * + * Pseudorandom number generator + * + * + * + * SYNOPSIS: + * + * double y, drand(); + * + * drand( &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. The period, given by them, is + * 6953607871644. + * + * Versions invoked by the different arithmetic compile + * time options DEC, IBMPC, and MIEEE, produce + * approximately the same sequences, differing only in the + * least significant bits of the numbers. The UNK option + * implements the algorithm as recommended in the BYTE + * article. It may be used on all computers. However, + * the low order bits of a double precision number may + * not be adequately random, and may vary due to arithmetic + * implementation details on different computers. + * + * The other compile options generate an additional random + * integer that overwrites the low order bits of the double + * precision number. This reduces the period by a factor of + * two but tends to overcome the problems mentioned. + * + */ + +/* eigens.c + * + * Eigenvalues and eigenvectors of a real symmetric matrix + * + * + * + * SYNOPSIS: + * + * int n; + * double A[n*(n+1)/2], EV[n*n], E[n]; + * void eigens( A, EV, E, n ); + * + * + * + * DESCRIPTION: + * + * The algorithm is due to J. vonNeumann. + * + * A[] is a symmetric matrix stored in lower triangular form. + * That is, A[ row, column ] = A[ (row*row+row)/2 + column ] + * or equivalently with row and column interchanged. The + * indices row and column run from 0 through n-1. + * + * EV[] is the output matrix of eigenvectors stored columnwise. + * That is, the elements of each eigenvector appear in sequential + * memory order. The jth element of the ith eigenvector is + * EV[ n*i+j ] = EV[i][j]. + * + * E[] is the output matrix of eigenvalues. The ith element + * of E corresponds to the ith eigenvector (the ith row of EV). + * + * On output, the matrix A will have been diagonalized and its + * orginal contents are destroyed. + * + * ACCURACY: + * + * The error is controlled by an internal parameter called RANGE + * which is set to 1e-10. After diagonalization, the + * off-diagonal elements of A will have been reduced by + * this factor. + * + * ERROR MESSAGES: + * + * None. + * + */ + +/* ellie.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * double phi, m, y, ellie(); + * + * y = ellie( 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 + * DEC 0,2 2000 1.9e-16 3.4e-17 + * IEEE -10,10 150000 3.3e-15 1.4e-16 + * + * + */ + +/* ellik.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * double phi, m, y, ellik(); + * + * y = ellik( 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 200000 7.4e-16 1.0e-16 + * + * + */ + +/* ellpe.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * double m1, y, ellpe(); + * + * y = ellpe( 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 + * DEC 0, 1 13000 3.1e-17 9.4e-18 + * IEEE 0, 1 10000 2.1e-16 7.3e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpe domain x<0, x>1 0.0 + * + */ + +/* ellpj.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * double u, m, sn, cn, dn, phi; + * int ellpj(); + * + * ellpj( 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-9 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 + * DEC sn 1800 4.5e-16 8.7e-17 + * IEEE phi 10000 9.2e-16* 1.4e-16* + * IEEE sn 50000 4.1e-15 4.6e-16 + * IEEE cn 40000 3.6e-15 4.4e-16 + * IEEE dn 10000 1.3e-12 1.8e-14 + * + * Peak error observed in consistency check using addition + * theorem for sn(u+v) was 4e-16 (absolute). Also tested by + * the above relation to the incomplete elliptic integral. + * Accuracy deteriorates when u is large. + * + */ + +/* ellpk.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * double m1, y, ellpk(); + * + * y = ellpk( 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 + * DEC 0,1 16000 3.5e-17 1.1e-17 + * IEEE 0,1 30000 2.5e-16 6.8e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpk domain x<0, x>1 0.0 + * + */ + +/* euclid.c + * + * Rational arithmetic routines + * + * + * + * SYNOPSIS: + * + * + * typedef struct + * { + * double n; numerator + * double d; denominator + * }fract; + * + * radd( a, b, c ) c = b + a + * rsub( a, b, c ) c = b - a + * rmul( a, b, c ) c = b * a + * rdiv( a, b, c ) c = b / a + * euclid( &n, &d ) Reduce n/d to lowest terms, + * return greatest common divisor. + * + * Arguments of the routines are pointers to the structures. + * The double precision numbers are assumed, without checking, + * to be integer valued. Overflow conditions are reported. + */ + +/* exp.c + * + * Exponential function + * + * + * + * SYNOPSIS: + * + * double x, y, exp(); + * + * y = exp( 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 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + * of degree 2/3 is used to approximate exp(f) in the basic + * interval [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +- 88 50000 2.8e-17 7.0e-18 + * IEEE +- 708 40000 2.0e-16 5.6e-17 + * + * + * 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 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 INFINITY + * + */ + +/* exp10.c + * + * Base 10 exponential function + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * double x, y, exp10(); + * + * y = exp10( 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 -307,+307 30000 2.2e-16 5.5e-17 + * Test result from an earlier version (2.1): + * DEC -38,+38 70000 3.1e-17 7.0e-18 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10 underflow x < -MAXL10 0.0 + * exp10 overflow x > MAXL10 MAXNUM + * + * DEC arithmetic: MAXL10 = 38.230809449325611792. + * IEEE arithmetic: MAXL10 = 308.2547155599167. + * + */ + +/* exp2.c + * + * Base 2 exponential function + * + * + * + * SYNOPSIS: + * + * double x, y, exp2(); + * + * y = exp2( 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 -1022,+1024 30000 1.8e-16 5.4e-17 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < -MAXL2 0.0 + * exp overflow x > MAXL2 MAXNUM + * + * For DEC arithmetic, MAXL2 = 127. + * For IEEE arithmetic, MAXL2 = 1024. + */ + +/* expn.c + * + * Exponential integral En + * + * + * + * SYNOPSIS: + * + * int n; + * double x, y, expn(); + * + * y = expn( n, x ); + * + * + * + * DESCRIPTION: + * + * Evaluates the exponential integral + * + * inf. + * - + * | | -xt + * | e + * E (x) = | ---- dt. + * n | n + * | | t + * - + * 1 + * + * + * Both n and x must be nonnegative. + * + * The routine employs either a power series, a continued + * fraction, or an asymptotic formula depending on the + * relative values of n and x. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 5000 2.0e-16 4.6e-17 + * IEEE 0, 30 10000 1.7e-15 3.6e-16 + * + */ + +/* fabs.c + * + * Absolute value + * + * + * + * SYNOPSIS: + * + * double x, y; + * + * y = fabs( x ); + * + * + * + * DESCRIPTION: + * + * Returns the absolute value of the argument. + * + */ + +/* fac.c + * + * Factorial function + * + * + * + * SYNOPSIS: + * + * double y, fac(); + * int i; + * + * y = fac( i ); + * + * + * + * DESCRIPTION: + * + * Returns factorial of i = 1 * 2 * 3 * ... * i. + * fac(0) = 1.0. + * + * Due to machine arithmetic bounds the largest value of + * i accepted is 33 in DEC arithmetic or 170 in IEEE + * arithmetic. Greater values, or negative ones, + * produce an error message and return MAXNUM. + * + * + * + * ACCURACY: + * + * For i < 34 the values are simply tabulated, and have + * full machine accuracy. If i > 55, fac(i) = gamma(i+1); + * see gamma.c. + * + * Relative error: + * arithmetic domain peak + * IEEE 0, 170 1.4e-15 + * DEC 0, 33 1.4e-17 + * + */ + +/* fdtr.c + * + * F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, y, fdtr(); + * + * y = fdtr( 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) = incbet( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x is + * nonnegative. + * + * ACCURACY: + * + * Tested at random points (a,b,x). + * + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 0,100 100000 9.8e-15 1.7e-15 + * IEEE 1,5 0,100 100000 6.5e-15 3.5e-16 + * IEEE 0,1 1,10000 100000 2.2e-11 3.3e-12 + * IEEE 1,5 1,10000 100000 1.1e-11 1.7e-13 + * See also incbet.c. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtr domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrc() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, y, fdtrc(); + * + * y = fdtrc( 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 + * + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). + * + * + * 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 100000 3.7e-14 5.9e-16 + * IEEE 1,5 1,100 100000 8.0e-15 1.6e-15 + * IEEE 0,1 1,10000 100000 1.8e-11 3.5e-13 + * IEEE 1,5 1,10000 100000 2.0e-11 3.0e-12 + * See also incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrc domain a<0, b<0, x<0 0.0 + * + */ + /* fdtri() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, p, fdtri(); + * + * x = fdtri( 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: + * + * 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 100000 8.3e-15 4.7e-16 + * IEEE 1,10000 100000 2.1e-11 1.4e-13 + * For p between 10^-6 and 10^-3: + * IEEE 1,100 50000 1.3e-12 8.4e-15 + * IEEE 1,10000 50000 3.0e-12 4.8e-14 + * See also fdtrc.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtri domain p <= 0 or p > 1 0.0 + * v < 1 + * + */ + +/* fftr.c + * + * FFT of Real Valued Sequence + * + * + * + * SYNOPSIS: + * + * double x[], sine[]; + * int m; + * + * fftr( x, m, sine ); + * + * + * + * DESCRIPTION: + * + * Computes the (complex valued) discrete Fourier transform of + * the real valued sequence x[]. The input sequence x[] contains + * n = 2**m samples. The program fills array sine[k] with + * n/4 + 1 values of sin( 2 PI k / n ). + * + * Data format for complex valued output is real part followed + * by imaginary part. The output is developed in the input + * array x[]. + * + * The algorithm takes advantage of the fact that the FFT of an + * n point real sequence can be obtained from an n/2 point + * complex FFT. + * + * A radix 2 FFT algorithm is used. + * + * Execution time on an LSI-11/23 with floating point chip + * is 1.0 sec for n = 256. + * + * + * + * REFERENCE: + * + * E. Oran Brigham, The Fast Fourier Transform; + * Prentice-Hall, Inc., 1974 + * + */ + +/* ceil() + * floor() + * frexp() + * ldexp() + * signbit() + * isnan() + * isfinite() + * + * Floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * double ceil(), floor(), frexp(), ldexp(); + * int signbit(), isnan(), isfinite(); + * double x, y; + * int expnt, n; + * + * y = floor(x); + * y = ceil(x); + * y = frexp( x, &expnt ); + * y = ldexp( x, n ); + * n = signbit(x); + * n = isnan(x); + * n = isfinite(x); + * + * + * + * DESCRIPTION: + * + * All four routines return a double precision floating point + * result. + * + * floor() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * ceil() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * frexp() 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. + * + * ldexp() multiplies x by 2**n. + * + * signbit(x) returns 1 if the sign bit of x is 1, else 0. + * + * These functions are part of the standard C run time library + * for many but not all C compilers. The ones supplied are + * written in C for either DEC or 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. + */ + +/* fresnl.c + * + * Fresnel integral + * + * + * + * SYNOPSIS: + * + * double x, S, C; + * void fresnl(); + * + * fresnl( x, _&S, _&C ); + * + * + * DESCRIPTION: + * + * Evaluates the Fresnel integrals + * + * x + * - + * | | + * C(x) = | cos(pi/2 t**2) dt, + * | | + * - + * 0 + * + * x + * - + * | | + * S(x) = | sin(pi/2 t**2) dt. + * | | + * - + * 0 + * + * + * The integrals are evaluated by a power series for x < 1. + * For x >= 1 auxiliary functions f(x) and g(x) are employed + * such that + * + * C(x) = 0.5 + f(x) sin( pi/2 x**2 ) - g(x) cos( pi/2 x**2 ) + * S(x) = 0.5 - f(x) cos( pi/2 x**2 ) - g(x) sin( pi/2 x**2 ) + * + * + * + * ACCURACY: + * + * Relative error. + * + * Arithmetic function domain # trials peak rms + * IEEE S(x) 0, 10 10000 2.0e-15 3.2e-16 + * IEEE C(x) 0, 10 10000 1.8e-15 3.3e-16 + * DEC S(x) 0, 10 6000 2.2e-16 3.9e-17 + * DEC C(x) 0, 10 5000 2.3e-16 3.9e-17 + */ + +/* gamma.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, gamma(); + * extern int sgngam; + * + * y = gamma( 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| <= 34 are reduced by recurrence and the function + * approximated by a rational function of degree 6/7 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 + * DEC -34, 34 10000 1.3e-16 2.5e-17 + * IEEE -170,-33 20000 2.3e-15 3.3e-16 + * IEEE -33, 33 20000 9.4e-16 2.2e-16 + * IEEE 33, 171.6 20000 2.3e-15 3.2e-16 + * + * Error for arguments outside the test range will be larger + * owing to error amplification by the exponential function. + * + */ +/* lgam() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, lgam(); + * extern int sgngam; + * + * y = lgam( 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 13, 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 MAXLGM return MAXNUM and an error + * message. MAXLGM = 2.035093e36 for DEC + * arithmetic or 2.556348e305 for IEEE arithmetic. + * + * + * + * ACCURACY: + * + * + * arithmetic domain # trials peak rms + * DEC 0, 3 7000 5.2e-17 1.3e-17 + * DEC 2.718, 2.035e36 5000 3.9e-17 9.9e-18 + * IEEE 0, 3 28000 5.4e-16 1.1e-16 + * IEEE 2.718, 2.556e305 40000 3.5e-16 8.3e-17 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * + * The following test used the relative error criterion, though + * at certain points the relative error could be much higher than + * indicated. + * IEEE -200, -4 10000 4.8e-16 1.3e-16 + * + */ + +/* gdtr.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, gdtr(); + * + * y = gdtr( 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 + * gdtr domain x < 0 0.0 + * + */ + /* gdtrc.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, gdtrc(); + * + * y = gdtrc( 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 + * gdtrc 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 +*/ + +/* hyp2f1.c + * + * Gauss hypergeometric function F + * 2 1 + * + * + * SYNOPSIS: + * + * double a, b, c, x, y, hyp2f1(); + * + * y = hyp2f1( a, b, c, x ); + * + * + * DESCRIPTION: + * + * + * hyp2f1( a, b, c, x ) = F ( a, b; c; x ) + * 2 1 + * + * inf. + * - a(a+1)...(a+k) b(b+1)...(b+k) k+1 + * = 1 + > ----------------------------- x . + * - c(c+1)...(c+k) (k+1)! + * k = 0 + * + * Cases addressed are + * Tests and escapes for negative integer a, b, or c + * Linear transformation if c - a or c - b negative integer + * Special case c = a or c = b + * Linear transformation for x near +1 + * Transformation for x < -0.5 + * Psi function expansion if x > 0.5 and c - a - b integer + * Conditionally, a recurrence on c to make c-a-b > 0 + * + * |x| > 1 is rejected. + * + * The parameters a, b, c are considered to be integer + * valued if they are within 1.0e-14 of the nearest integer + * (1.0e-13 for IEEE arithmetic). + * + * ACCURACY: + * + * + * Relative error (-1 < x < 1): + * arithmetic domain # trials peak rms + * IEEE -1,7 230000 1.2e-11 5.2e-14 + * + * Several special cases also tested with a, b, c in + * the range -7 to 7. + * + * ERROR MESSAGES: + * + * A "partial loss of precision" message is printed if + * the internally estimated relative error exceeds 1^-12. + * A "singularity" message is printed on overflow or + * in cases not addressed (such as x < -1). + */ + +/* hyperg.c + * + * Confluent hypergeometric function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, hyperg(); + * + * y = hyperg( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Computes the confluent hypergeometric function + * + * 1 2 + * a x a(a+1) x + * F ( a,b;x ) = 1 + ---- + --------- + ... + * 1 1 b 1! b(b+1) 2! + * + * Many higher transcendental functions are special cases of + * this power series. + * + * As is evident from the formula, b must not be a negative + * integer or zero unless a is an integer with 0 >= a > b. + * + * The routine attempts both a direct summation of the series + * and an asymptotic expansion. In each case error due to + * roundoff, cancellation, and nonconvergence is estimated. + * The result with smaller estimated error is returned. + * + * + * + * ACCURACY: + * + * Tested at random points (a, b, x), all three variables + * ranging from 0 to 30. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 1.2e-15 1.3e-16 + * IEEE 0,30 30000 1.8e-14 1.1e-15 + * + * Larger errors can be observed when b is near a negative + * integer or zero. Certain combinations of arguments yield + * serious cancellation error in the power series summation + * and also are not in the region of near convergence of the + * asymptotic series. An error message is printed if the + * self-estimated relative error is greater than 1.0e-12. + * + */ + +/* i0.c + * + * Modified Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * double x, y, i0(); + * + * y = i0( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order zero of the + * argument. + * + * The function is defined as i0(x) = j0( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 6000 8.2e-17 1.9e-17 + * IEEE 0,30 30000 5.8e-16 1.4e-16 + * + */ + /* i0e.c + * + * Modified Bessel function of order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, i0e(); + * + * y = i0e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order zero of the argument. + * + * The function is defined as i0e(x) = exp(-|x|) j0( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 30000 5.4e-16 1.2e-16 + * See i0(). + * + */ + +/* i1.c + * + * Modified Bessel function of order one + * + * + * + * SYNOPSIS: + * + * double x, y, i1(); + * + * y = i1( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order one of the + * argument. + * + * The function is defined as i1(x) = -i j1( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3400 1.2e-16 2.3e-17 + * IEEE 0, 30 30000 1.9e-15 2.1e-16 + * + * + */ + /* i1e.c + * + * Modified Bessel function of order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, i1e(); + * + * y = i1e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order one of the argument. + * + * The function is defined as i1(x) = -i exp(-|x|) j1( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 2.0e-15 2.0e-16 + * See i1(). + * + */ + +/* igam.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, y, igam(); + * + * y = igam( 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 + * IEEE 0,30 200000 3.6e-14 2.9e-15 + * IEEE 0,100 300000 9.9e-14 1.5e-14 + */ + /* igamc() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, y, igamc(); + * + * y = igamc( 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: + * + * Tested at random a, x. + * a x Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0.5,100 0,100 200000 1.9e-14 1.7e-15 + * IEEE 0.01,0.5 0,100 200000 1.4e-13 1.6e-15 + */ + +/* igami() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, p, igami(); + * + * x = igami( a, p ); + * + * DESCRIPTION: + * + * Given p, the function finds x such that + * + * igamc( a, x ) = p. + * + * Starting with the approximate value + * + * 3 + * x = a t + * + * where + * + * t = 1 - d - ndtri(p) sqrt(d) + * + * and + * + * d = 1/9a, + * + * the routine performs up to 10 Newton iterations to find the + * root of igamc(a,x) - p = 0. + * + * ACCURACY: + * + * Tested at random a, p in the intervals indicated. + * + * a p Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0.5,100 0,0.5 100000 1.0e-14 1.7e-15 + * IEEE 0.01,0.5 0,0.5 100000 9.0e-14 3.4e-15 + * IEEE 0.5,10000 0,0.5 20000 2.3e-13 3.8e-14 + */ + +/* incbet.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * double a, b, x, y, incbet(); + * + * y = incbet( 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 uniformly distributed random points (a,b,x) with a and b + * in "domain" and x between 0 and 1. + * Relative error + * arithmetic domain # trials peak rms + * IEEE 0,5 10000 6.9e-15 4.5e-16 + * IEEE 0,85 250000 2.2e-13 1.7e-14 + * IEEE 0,1000 30000 5.3e-12 6.3e-13 + * IEEE 0,10000 250000 9.3e-11 7.1e-12 + * IEEE 0,100000 10000 8.7e-10 4.8e-11 + * Outputs smaller than the IEEE gradual underflow threshold + * were excluded from these statistics. + * + * ERROR MESSAGES: + * message condition value returned + * incbet domain x<0, x>1 0.0 + * incbet underflow 0.0 + */ + +/* incbi() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, incbi(); + * + * x = incbi( a, b, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * incbet( a, b, x ) = y . + * + * The routine performs interval halving or 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 50000 5.8e-12 1.3e-13 + * IEEE 0,1 .25,100 100000 1.8e-13 3.9e-15 + * IEEE 0,1 0,5 50000 1.1e-12 5.5e-15 + * VAX 0,1 .5,100 25000 3.5e-14 1.1e-15 + * With a and b constrained to half-integer or integer values: + * IEEE 0,1 .5,10000 50000 5.8e-12 1.1e-13 + * IEEE 0,1 .5,100 100000 1.7e-14 7.9e-16 + * With a = .5, b constrained to half-integer or integer values: + * IEEE 0,1 .5,10000 10000 8.3e-11 1.0e-11 + */ + +/* iv.c + * + * Modified Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * double v, x, y, iv(); + * + * y = iv( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order v of the + * argument. If x is negative, v must be integer valued. + * + * The function is defined as Iv(x) = Jv( ix ). It is + * here computed in terms of the confluent hypergeometric + * function, according to the formula + * + * v -x + * Iv(x) = (x/2) e hyperg( v+0.5, 2v+1, 2x ) / gamma(v+1) + * + * If v is a negative integer, then v is replaced by -v. + * + * + * ACCURACY: + * + * Tested at random points (v, x), with v between 0 and + * 30, x between 0 and 28. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 3.1e-15 5.4e-16 + * IEEE 0,30 10000 1.7e-14 2.7e-15 + * + * Accuracy is diminished if v is near a negative integer. + * + * See also hyperg.c. + * + */ + +/* j0.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * double x, y, j0(); + * + * y = j0( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order zero of the argument. + * + * The domain is divided into the intervals [0, 5] and + * (5, infinity). In the first interval the following rational + * approximation is used: + * + * + * 2 2 + * (w - r ) (w - r ) P (w) / Q (w) + * 1 2 3 8 + * + * 2 + * where w = x and the two r's are zeros of the function. + * + * In the second interval, the Hankel asymptotic expansion + * is employed with two rational functions of degree 6/6 + * and 7/7. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 4.4e-17 6.3e-18 + * IEEE 0, 30 60000 4.2e-16 1.1e-16 + * + */ + /* y0.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y0(); + * + * y = y0( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 5] and + * (5, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * y0(x) = R(x) + 2 * log(x) * j0(x) / PI. + * Thus a call to j0() is required. + * + * In the second interval, the Hankel asymptotic expansion + * is employed with two rational functions of degree 6/6 + * and 7/7. + * + * + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * DEC 0, 30 9400 7.0e-17 7.9e-18 + * IEEE 0, 30 30000 1.3e-15 1.6e-16 + * + */ + +/* j1.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * double x, y, j1(); + * + * y = j1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 8] and + * (8, infinity). In the first interval a 24 term Chebyshev + * expansion is used. In the second, the asymptotic + * trigonometric representation is employed using two + * rational functions of degree 5/5. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 4.0e-17 1.1e-17 + * IEEE 0, 30 30000 2.6e-16 1.1e-16 + * + * + */ + /* y1.c + * + * Bessel function of second kind of order one + * + * + * + * SYNOPSIS: + * + * double x, y, y1(); + * + * y = y1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind of order one + * of the argument. + * + * The domain is divided into the intervals [0, 8] and + * (8, infinity). In the first interval a 25 term Chebyshev + * expansion is used, and a call to j1() is required. + * In the second, the asymptotic trigonometric representation + * is employed using two rational functions of degree 5/5. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 8.6e-17 1.3e-17 + * IEEE 0, 30 30000 1.0e-15 1.3e-16 + * + * (error criterion relative when |y1| > 1). + * + */ + +/* jn.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * double x, y, jn(); + * + * y = jn( 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 range # trials peak rms + * DEC 0, 30 5500 6.9e-17 9.3e-18 + * IEEE 0, 30 5000 4.4e-16 7.9e-17 + * + * + * Not suitable for large n or x. Use jv() instead. + * + */ + +/* jv.c + * + * Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * double v, x, y, jv(); + * + * y = jv( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order v of the argument, + * where v is real. Negative x is allowed if v is an integer. + * + * Several expansions are included: the ascending power + * series, the Hankel expansion, and two transitional + * expansions for large v. If v is not too large, it + * is reduced by recurrence to a region of best accuracy. + * The transitional expansions give 12D accuracy for v > 500. + * + * + * + * ACCURACY: + * Results for integer v are indicated by *, where x and v + * both vary from -125 to +125. Otherwise, + * x ranges from 0 to 125, v ranges as indicated by "domain." + * Error criterion is absolute, except relative when |jv()| > 1. + * + * arithmetic v domain x domain # trials peak rms + * IEEE 0,125 0,125 100000 4.6e-15 2.2e-16 + * IEEE -125,0 0,125 40000 5.4e-11 3.7e-13 + * IEEE 0,500 0,500 20000 4.4e-15 4.0e-16 + * Integer v: + * IEEE -125,125 -125,125 50000 3.5e-15* 1.9e-16* + * + */ + +/* k0.c + * + * Modified Bessel function, third kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, k0(); + * + * y = k0( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order zero of the argument. + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Tested at 2000 random points between 0 and 8. Peak absolute + * error (relative when K0 > 1) was 1.46e-14; rms, 4.26e-15. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3100 1.3e-16 2.1e-17 + * IEEE 0, 30 30000 1.2e-15 1.6e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * K0 domain x <= 0 MAXNUM + * + */ + /* k0e() + * + * Modified Bessel function, third kind, order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, k0e(); + * + * y = k0e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order zero of the argument. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 1.4e-15 1.4e-16 + * See k0(). + * + */ + +/* k1.c + * + * Modified Bessel function, third kind, order one + * + * + * + * SYNOPSIS: + * + * double x, y, k1(); + * + * y = k1( x ); + * + * + * + * DESCRIPTION: + * + * Computes the modified Bessel function of the third kind + * of order one of the argument. + * + * The range is partitioned into the two intervals [0,2] and + * (2, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3300 8.9e-17 2.2e-17 + * IEEE 0, 30 30000 1.2e-15 1.6e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * k1 domain x <= 0 MAXNUM + * + */ + /* k1e.c + * + * Modified Bessel function, third kind, order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, k1e(); + * + * y = k1e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order one of the argument: + * + * k1e(x) = exp(x) * k1(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 7.8e-16 1.2e-16 + * See k1(). + * + */ + +/* kn.c + * + * Modified Bessel function, third kind, integer order + * + * + * + * SYNOPSIS: + * + * double x, y, kn(); + * int n; + * + * y = kn( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order n of the argument. + * + * The range is partitioned into the two intervals [0,9.55] and + * (9.55, infinity). An ascending power series is used in the + * low range, and an asymptotic expansion in the high range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 3000 1.3e-9 5.8e-11 + * IEEE 0,30 90000 1.8e-8 3.0e-10 + * + * Error is high only near the crossover point x = 9.55 + * between the two expansions used. + */ + + +/* Re Kolmogorov statistics, here is Birnbaum and Tingey's formula for the + distribution of D+, the maximum of all positive deviations between a + theoretical distribution function P(x) and an empirical one Sn(x) + from n samples. + + + + D = sup [ P(x) - Sn(x) ] + n -inf < x < inf + + + [n(1-e)] + + - v-1 n-v + Pr{D > e} = > C e (e + v/n) (1 - e - v/n) + n - n v + v=0 + [n(1-e)] is the largest integer not exceeding n(1-e). + nCv is the number of combinations of n things taken v at a time. + + Exact Smirnov statistic, for one-sided test: +double +smirnov (n, e) + int n; + double e; + + Kolmogorov's limiting distribution of two-sided test, returns + probability that sqrt(n) * max deviation > y, + or that max deviation > y/sqrt(n). + The approximation is useful for the tail of the distribution + when n is large. +double +kolmogorov (y) + double y; + + + Functional inverse of Smirnov distribution + finds e such that smirnov(n,e) = p. +double +smirnovi (n, p) + int n; + double p; + + Functional inverse of Kolmogorov statistic for two-sided test. + Finds y such that kolmogorov(y) = p. + If e = smirnovi (n,p), then kolmogi(2 * p) / sqrt(n) should + be close to e. +double +kolmogi (p) + double p; + */ + +/* Levnsn.c */ +/* Levinson-Durbin LPC + * + * | R0 R1 R2 ... RN-1 | | A1 | | -R1 | + * | R1 R0 R1 ... RN-2 | | A2 | | -R2 | + * | R2 R1 R0 ... RN-3 | | A3 | = | -R3 | + * | ... | | ...| | ... | + * | RN-1 RN-2... R0 | | AN | | -RN | + * + * Ref: John Makhoul, "Linear Prediction, A Tutorial Review" + * Proc. IEEE Vol. 63, PP 561-580 April, 1975. + * + * R is the input autocorrelation function. R0 is the zero lag + * term. A is the output array of predictor coefficients. Note + * that a filter impulse response has a coefficient of 1.0 preceding + * A1. E is an array of mean square error for each prediction order + * 1 to N. REFL is an output array of the reflection coefficients. + */ + +/* log.c + * + * Natural logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log(); + * + * y = log( 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 1.44e-16 5.06e-17 + * IEEE +-MAXNUM 30000 1.20e-16 4.78e-17 + * DEC 0, 10 170000 1.8e-17 6.3e-18 + * + * In the tests over the interval [+-MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOG]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns -INFINITY + * log domain: x < 0; returns NAN + */ + +/* log10.c + * + * Common logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log10(); + * + * y = log10( x ); + * + * + * + * DESCRIPTION: + * + * Returns logarithm to the base 10 of x. + * + * The argument is separated into its exponent and fractional + * parts. The logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 1.5e-16 5.0e-17 + * IEEE 0, MAXNUM 30000 1.4e-16 4.8e-17 + * DEC 1, MAXNUM 50000 2.5e-17 6.0e-18 + * + * In the tests over the interval [1, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOG]. + * + * ERROR MESSAGES: + * + * log10 singularity: x = 0; returns -INFINITY + * log10 domain: x < 0; returns NAN + */ + +/* log2.c + * + * Base 2 logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log2(); + * + * y = log2( 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 base e + * 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 2.0e-16 5.5e-17 + * IEEE exp(+-700) 40000 1.3e-16 4.6e-17 + * + * In the tests over the interval [exp(+-700)], the logarithms + * of the random arguments were uniformly distributed. + * + * ERROR MESSAGES: + * + * log2 singularity: x = 0; returns -INFINITY + * log2 domain: x < 0; returns NAN + */ + +/* lrand.c + * + * Pseudorandom number generator + * + * + * + * SYNOPSIS: + * + * long y, drand(); + * + * drand( &y ); + * + * + * + * DESCRIPTION: + * + * Yields a long integer random number. + * + * The three-generator congruential algorithm by Brian + * Wichmann and David Hill (BYTE magazine, March, 1987, + * pp 127-8) is used. The period, given by them, is + * 6953607871644. + * + * + */ + +/* lsqrt.c + * + * Integer square root + * + * + * + * SYNOPSIS: + * + * long x, y; + * long lsqrt(); + * + * y = lsqrt( x ); + * + * + * + * DESCRIPTION: + * + * Returns a long integer square root of the long integer + * argument. The computation is by binary long division. + * + * The largest possible result is lsqrt(2,147,483,647) + * = 46341. + * + * If x < 0, the square root of |x| is returned, and an + * error message is printed. + * + * + * ACCURACY: + * + * An extra, roundoff, bit is computed; hence the result + * is the nearest integer to the actual square root. + * NOTE: only DEC arithmetic is currently supported. + * + */ + +/* minv.c + * + * Matrix inversion + * + * + * + * SYNOPSIS: + * + * int n, errcod; + * double A[n*n], X[n*n]; + * double B[n]; + * int IPS[n]; + * int minv(); + * + * errcod = minv( A, X, n, B, IPS ); + * + * + * + * DESCRIPTION: + * + * Finds the inverse of the n by n matrix A. The result goes + * to X. B and IPS are scratch pad arrays of length n. + * The contents of matrix A are destroyed. + * + * The routine returns nonzero on error; error messages are printed + * by subroutine simq(). + * + */ + +/* mmmpy.c + * + * Matrix multiply + * + * + * + * SYNOPSIS: + * + * int r, c; + * double A[r*c], B[c*r], Y[r*r]; + * + * mmmpy( r, c, A, B, Y ); + * + * + * + * DESCRIPTION: + * + * Y = A B + * c-1 + * -- + * Y[i][j] = > A[i][k] B[k][j] + * -- + * k=0 + * + * Multiplies an r (rows) by c (columns) matrix A on the left + * by a c (rows) by r (columns) matrix B on the right + * to produce an r by r matrix Y. + * + * + */ + +/* 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 math.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: + * + * math.h + * + */ + +/* mtransp.c + * + * Matrix transpose + * + * + * + * SYNOPSIS: + * + * int n; + * double A[n*n], T[n*n]; + * + * mtransp( n, A, T ); + * + * + * + * DESCRIPTION: + * + * + * T[r][c] = A[c][r] + * + * + * Transposes the n by n square matrix A and puts the result in T. + * The output, T, may occupy the same storage as A. + * + * + * + */ + +/* mvmpy.c + * + * Matrix times vector + * + * + * + * SYNOPSIS: + * + * int r, c; + * double A[r*c], V[c], Y[r]; + * + * mvmpy( r, c, A, V, Y ); + * + * + * + * DESCRIPTION: + * + * c-1 + * -- + * Y[j] = > A[j][k] V[k] , j = 1, ..., r + * -- + * k=0 + * + * Multiplies the r (rows) by c (columns) matrix A on the left + * by column vector V of dimension c on the right + * to produce a (column) vector Y output of dimension r. + * + * + * + * + */ + +/* nbdtr.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtr(); + * + * y = nbdtr( 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 (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 100000 1.7e-13 8.8e-15 + * See also incbet.c. + * + */ + /* nbdtrc.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtrc(); + * + * y = nbdtrc( 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: + * + * Tested at random points (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 100000 1.7e-13 8.8e-15 + * See also incbet.c. + */ + +/* nbdtrc + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtrc(); + * + * y = nbdtrc( 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 incbet.c. + */ + /* nbdtri + * + * Functional inverse of negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtri(); + * + * p = nbdtri( 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 100000 1.5e-14 8.5e-16 + * See also incbi.c. + */ + +/* ndtr.c + * + * Normal distribution function + * + * + * + * SYNOPSIS: + * + * double x, y, ndtr(); + * + * y = ndtr( 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 + * DEC -13,0 8000 2.1e-15 4.8e-16 + * IEEE -13,0 30000 3.4e-14 6.7e-15 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfc underflow x > 37.519379347 0.0 + * + */ + /* erf.c + * + * Error function + * + * + * + * SYNOPSIS: + * + * double x, y, erf(); + * + * y = erf( x ); + * + * + * + * DESCRIPTION: + * + * The integral is + * + * x + * - + * 2 | | 2 + * erf(x) = -------- | exp( - t ) dt. + * sqrt(pi) | | + * - + * 0 + * + * The magnitude of x is limited to 9.231948545 for DEC + * arithmetic; 1 or -1 is returned outside this range. + * + * For 0 <= |x| < 1, erf(x) = x * P4(x**2)/Q5(x**2); otherwise + * erf(x) = 1 - erfc(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,1 14000 4.7e-17 1.5e-17 + * IEEE 0,1 30000 3.7e-16 1.0e-16 + * + */ + /* erfc.c + * + * Complementary error function + * + * + * + * SYNOPSIS: + * + * double x, y, erfc(); + * + * y = erfc( 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 + * DEC 0, 9.2319 12000 5.1e-16 1.2e-16 + * IEEE 0,26.6417 30000 5.7e-14 1.5e-14 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfc underflow x > 9.231948545 (DEC) 0.0 + * + * + */ + +/* ndtri.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * double x, y, ndtri(); + * + * x = ndtri( 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.0 * log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). + * There are two rational functions P/Q, one for 0 < y < exp(-32) + * and the other for y up to exp(-2). For larger arguments, + * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0.125, 1 5500 9.5e-17 2.1e-17 + * DEC 6e-39, 0.135 3500 5.7e-17 1.3e-17 + * IEEE 0.125, 1 20000 7.2e-16 1.3e-16 + * IEEE 3e-308, 0.135 50000 4.6e-16 9.8e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtri domain x <= 0 -MAXNUM + * ndtri domain x >= 1 MAXNUM + * + */ + +/* pdtr.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtr(); + * + * y = pdtr( 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(). + * + */ + /* pdtrc() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtrc(); + * + * y = pdtrc( 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. + * + */ + /* pdtri() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtr(); + * + * m = pdtri( 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 + * + */ + +/* polevl.c + * p1evl.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * double x, y, coef[N+1], polevl[]; + * + * y = polevl( 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 p1evl() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevl(). + * + * + * 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. + * + */ + +/* polmisc.c + * Square root, sine, cosine, and arctangent of polynomial. + * See polyn.c for data structures and discussion. + */ + +/* polrt.c + * + * Find roots of a polynomial + * + * + * + * SYNOPSIS: + * + * typedef struct + * { + * double r; + * double i; + * }cmplx; + * + * double xcof[], cof[]; + * int m; + * cmplx root[]; + * + * polrt( xcof, cof, m, root ) + * + * + * + * DESCRIPTION: + * + * Iterative determination of the roots of a polynomial of + * degree m whose coefficient vector is xcof[]. The + * coefficients are arranged in ascending order; i.e., the + * coefficient of x**m is xcof[m]. + * + * The array cof[] is working storage the same size as xcof[]. + * root[] is the output array containing the complex roots. + * + * + * ACCURACY: + * + * Termination depends on evaluation of the polynomial at + * the trial values of the roots. The values of multiple roots + * or of roots that are nearly equal may have poor relative + * accuracy after the first root in the neighborhood has been + * found. + * + */ + +/* polyn.c + * polyr.c + * Arithmetic operations on polynomials + * + * In the following descriptions a, b, c are polynomials of degree + * na, nb, nc respectively. The degree of a polynomial cannot + * exceed a run-time value MAXPOL. An operation that attempts + * to use or generate a polynomial of higher degree may produce a + * result that suffers truncation at degree MAXPOL. The value of + * MAXPOL is set by calling the function + * + * polini( maxpol ); + * + * where maxpol is the desired maximum degree. This must be + * done prior to calling any of the other functions in this module. + * Memory for internal temporary polynomial storage is allocated + * by polini(). + * + * Each polynomial is represented by an array containing its + * coefficients, together with a separately declared integer equal + * to the degree of the polynomial. The coefficients appear in + * ascending order; that is, + * + * 2 na + * a(x) = a[0] + a[1] * x + a[2] * x + ... + a[na] * x . + * + * + * + * sum = poleva( a, na, x ); Evaluate polynomial a(t) at t = x. + * polprt( a, na, D ); Print the coefficients of a to D digits. + * polclr( a, na ); Set a identically equal to zero, up to a[na]. + * polmov( a, na, b ); Set b = a. + * poladd( a, na, b, nb, c ); c = b + a, nc = max(na,nb) + * polsub( a, na, b, nb, c ); c = b - a, nc = max(na,nb) + * polmul( a, na, b, nb, c ); c = b * a, nc = na+nb + * + * + * Division: + * + * i = poldiv( a, na, b, nb, c ); c = b / a, nc = MAXPOL + * + * returns i = the degree of the first nonzero coefficient of a. + * The computed quotient c must be divided by x^i. An error message + * is printed if a is identically zero. + * + * + * Change of variables: + * If a and b are polynomials, and t = a(x), then + * c(t) = b(a(x)) + * is a polynomial found by substituting a(x) for t. The + * subroutine call for this is + * + * polsbt( a, na, b, nb, c ); + * + * + * Notes: + * poldiv() is an integer routine; poleva() is double. + * Any of the arguments a, b, c may refer to the same array. + * + */ + +/* pow.c + * + * Power function + * + * + * + * SYNOPSIS: + * + * double x, y, z, pow(); + * + * z = pow( 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/16 and pseudo extended precision arithmetic to + * obtain an extra three bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -26,26 30000 4.2e-16 7.7e-17 + * DEC -26,26 60000 4.8e-17 9.1e-18 + * 1/26 < x < 26, with log(x) uniformly distributed. + * -26 < y < 26, y uniformly distributed. + * IEEE 0,8700 30000 1.5e-14 2.1e-15 + * 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 + * + */ + +/* powi.c + * + * Real raised to integer power + * + * + * + * SYNOPSIS: + * + * double x, y, powi(); + * int n; + * + * y = powi( 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 + * DEC .04,26 -26,26 100000 2.7e-16 4.3e-17 + * IEEE .04,26 -26,26 50000 2.0e-15 3.8e-16 + * IEEE 1,2 -1022,1023 50000 8.6e-14 1.6e-14 + * + * Returns MAXNUM on overflow, zero on underflow. + * + */ + +/* psi.c + * + * Psi (digamma) function + * + * + * SYNOPSIS: + * + * double x, y, psi(); + * + * y = psi( x ); + * + * + * DESCRIPTION: + * + * d - + * psi(x) = -- ln | (x) + * dx + * + * is the logarithmic derivative of the gamma function. + * For integer x, + * n-1 + * - + * psi(n) = -EUL + > 1/k. + * - + * k=1 + * + * This formula is used for 0 < n <= 10. If x is negative, it + * is transformed to a positive argument by the reflection + * formula psi(1-x) = psi(x) + pi cot(pi x). + * For general positive x, the argument is made greater than 10 + * using the recurrence psi(x+1) = psi(x) + 1/x. + * Then the following asymptotic expansion is applied: + * + * inf. B + * - 2k + * psi(x) = log(x) - 1/2x - > ------- + * - 2k + * k=1 2k x + * + * where the B2k are Bernoulli numbers. + * + * ACCURACY: + * Relative error (except absolute when |psi| < 1): + * arithmetic domain # trials peak rms + * DEC 0,30 2500 1.7e-16 2.0e-17 + * IEEE 0,30 30000 1.3e-15 1.4e-16 + * IEEE -30,0 40000 1.5e-15 2.2e-16 + * + * ERROR MESSAGES: + * message condition value returned + * psi singularity x integer <=0 MAXNUM + */ + +/* revers.c + * + * Reversion of power series + * + * + * + * SYNOPSIS: + * + * extern int MAXPOL; + * int n; + * double x[n+1], y[n+1]; + * + * polini(n); + * revers( y, x, n ); + * + * Note, polini() initializes the polynomial arithmetic subroutines; + * see polyn.c. + * + * + * DESCRIPTION: + * + * If + * + * inf + * - i + * y(x) = > a x + * - i + * i=1 + * + * then + * + * inf + * - j + * x(y) = > A y , + * - j + * j=1 + * + * where + * 1 + * A = --- + * 1 a + * 1 + * + * etc. The coefficients of x(y) are found by expanding + * + * inf inf + * - - i + * x(y) = > A > a x + * - j - i + * j=1 i=1 + * + * and setting each coefficient of x , higher than the first, + * to zero. + * + * + * + * RESTRICTIONS: + * + * y[0] must be zero, and y[1] must be nonzero. + * + */ + +/* rgamma.c + * + * Reciprocal gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, rgamma(); + * + * y = rgamma( x ); + * + * + * + * DESCRIPTION: + * + * Returns one divided by the gamma function of the argument. + * + * The function is approximated by a Chebyshev expansion in + * the interval [0,1]. Range reduction is by recurrence + * for arguments between -34.034 and +34.84425627277176174. + * 1/MAXNUM is returned for positive arguments outside this + * range. For arguments less than -34.034 the cosecant + * reflection formula is applied; lograrithms are employed + * to avoid unnecessary overflow. + * + * The reciprocal gamma function has no singularities, + * but overflow and underflow may occur for large arguments. + * These conditions return either MAXNUM or 1/MAXNUM with + * appropriate sign. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -30,+30 4000 1.2e-16 1.8e-17 + * IEEE -30,+30 30000 1.1e-15 2.0e-16 + * For arguments less than -34.034 the peak error is on the + * order of 5e-15 (DEC), excepting overflow or underflow. + */ + +/* round.c + * + * Round double to nearest or even integer valued double + * + * + * + * SYNOPSIS: + * + * double x, y, round(); + * + * y = round(x); + * + * + * + * DESCRIPTION: + * + * Returns the nearest integer to x as a double precision + * floating point result. If x ends in 0.5 exactly, the + * nearest even integer is chosen. + * + * + * + * ACCURACY: + * + * If x is greater than 1/(2*MACHEP), its closest machine + * representation is already an integer, so rounding does + * not change it. + */ + +/* shichi.c + * + * Hyperbolic sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * double x, Chi, Shi, shichi(); + * + * shichi( x, &Chi, &Shi ); + * + * + * DESCRIPTION: + * + * Approximates the integrals + * + * x + * - + * | | cosh t - 1 + * Chi(x) = eul + ln x + | ----------- dt, + * | | t + * - + * 0 + * + * x + * - + * | | sinh t + * Shi(x) = | ------ dt + * | | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are evaluated by power series for x < 8 + * and by Chebyshev expansions for x between 8 and 88. + * For large x, both functions approach exp(x)/2x. + * Arguments greater than 88 in magnitude return MAXNUM. + * + * + * ACCURACY: + * + * Test interval 0 to 88. + * Relative error: + * arithmetic function # trials peak rms + * DEC Shi 3000 9.1e-17 + * IEEE Shi 30000 6.9e-16 1.6e-16 + * Absolute error, except relative when |Chi| > 1: + * DEC Chi 2500 9.3e-17 + * IEEE Chi 30000 8.4e-16 1.4e-16 + */ + +/* sici.c + * + * Sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * double x, Ci, Si, sici(); + * + * sici( x, &Si, &Ci ); + * + * + * DESCRIPTION: + * + * Evaluates the integrals + * + * x + * - + * | cos t - 1 + * Ci(x) = eul + ln x + | --------- dt, + * | t + * - + * 0 + * x + * - + * | sin t + * Si(x) = | ----- dt + * | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are approximated by rational functions. + * For x > 8 auxiliary functions f(x) and g(x) are employed + * such that + * + * Ci(x) = f(x) sin(x) - g(x) cos(x) + * Si(x) = pi/2 - f(x) cos(x) - g(x) sin(x) + * + * + * ACCURACY: + * Test interval = [0,50]. + * Absolute error, except relative when > 1: + * arithmetic function # trials peak rms + * IEEE Si 30000 4.4e-16 7.3e-17 + * IEEE Ci 30000 6.9e-16 5.1e-17 + * DEC Si 5000 4.4e-17 9.0e-18 + * DEC Ci 5300 7.9e-17 5.2e-18 + */ + +/* simpsn.c */ + * Numerical integration of function tabulated + * at equally spaced arguments + */ + +/* simq.c + * + * Solution of simultaneous linear equations AX = B + * by Gaussian elimination with partial pivoting + * + * + * + * SYNOPSIS: + * + * double A[n*n], B[n], X[n]; + * int n, flag; + * int IPS[]; + * int simq(); + * + * ercode = simq( A, B, X, n, flag, IPS ); + * + * + * + * DESCRIPTION: + * + * B, X, IPS are vectors of length n. + * A is an n x n matrix (i.e., a vector of length n*n), + * stored row-wise: that is, A(i,j) = A[ij], + * where ij = i*n + j, which is the transpose of the normal + * column-wise storage. + * + * The contents of matrix A are destroyed. + * + * Set flag=0 to solve. + * Set flag=-1 to do a new back substitution for different B vector + * using the same A matrix previously reduced when flag=0. + * + * The routine returns nonzero on error; messages are printed. + * + * + * ACCURACY: + * + * Depends on the conditioning (range of eigenvalues) of matrix A. + * + * + * REFERENCE: + * + * Computer Solution of Linear Algebraic Systems, + * by George E. Forsythe and Cleve B. Moler; Prentice-Hall, 1967. + * + */ + +/* sin.c + * + * Circular sine + * + * + * + * SYNOPSIS: + * + * double x, y, sin(); + * + * y = sin( 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 + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 10 150000 3.0e-17 7.8e-18 + * IEEE -1.07e9,+1.07e9 130000 2.1e-16 5.4e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 1.073741824e9 0.0 + * + * Partial loss of accuracy begins to occur at x = 2**30 + * = 1.074e9. The loss is not gradual, but jumps suddenly to + * about 1 part in 10e7. Results may be meaningless for + * x > 2**49 = 5.6e14. The routine as implemented flags a + * TLOSS error for x > 2**30 and returns 0.0. + */ + /* cos.c + * + * Circular cosine + * + * + * + * SYNOPSIS: + * + * double x, y, cos(); + * + * y = cos( 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 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1.07e9,+1.07e9 130000 2.1e-16 5.4e-17 + * DEC 0,+1.07e9 17000 3.0e-17 7.2e-18 + */ + +/* sincos.c + * + * Circular sine and cosine of argument in degrees + * Table lookup and interpolation algorithm + * + * + * + * SYNOPSIS: + * + * double x, sine, cosine, flg, sincos(); + * + * sincos( x, &sine, &cosine, flg ); + * + * + * + * DESCRIPTION: + * + * Returns both the sine and the cosine of the argument x. + * Several different compile time options and minimax + * approximations are supplied to permit tailoring the + * tradeoff between computation speed and accuracy. + * + * Since range reduction is time consuming, the reduction + * of x modulo 360 degrees is also made optional. + * + * sin(i) is internally tabulated for 0 <= i <= 90 degrees. + * Approximation polynomials, ranging from linear interpolation + * to cubics in (x-i)**2, compute the sine and cosine + * of the residual x-i which is between -0.5 and +0.5 degree. + * In the case of the high accuracy options, the residual + * and the tabulated values are combined using the trigonometry + * formulas for sin(A+B) and cos(A+B). + * + * Compile time options are supplied for 5, 11, or 17 decimal + * relative accuracy (ACC5, ACC11, ACC17 respectively). + * A subroutine flag argument "flg" chooses betwen this + * accuracy and table lookup only (peak absolute error + * = 0.0087). + * + * If the argument flg = 1, then the tabulated value is + * returned for the nearest whole number of degrees. The + * approximation polynomials are not computed. At + * x = 0.5 deg, the absolute error is then sin(0.5) = 0.0087. + * + * An intermediate speed and precision can be obtained using + * the compile time option LINTERP and flg = 1. This yields + * a linear interpolation using a slope estimated from the sine + * or cosine at the nearest integer argument. The peak absolute + * error with this option is 3.8e-5. Relative error at small + * angles is about 1e-5. + * + * If flg = 0, then the approximation polynomials are computed + * and applied. + * + * + * + * SPEED: + * + * Relative speed comparisons follow for 6MHz IBM AT clone + * and Microsoft C version 4.0. These figures include + * software overhead of do loop and function calls. + * Since system hardware and software vary widely, the + * numbers should be taken as representative only. + * + * flg=0 flg=0 flg=1 flg=1 + * ACC11 ACC5 LINTERP Lookup only + * In-line 8087 (/FPi) + * sin(), cos() 1.0 1.0 1.0 1.0 + * + * In-line 8087 (/FPi) + * sincos() 1.1 1.4 1.9 3.0 + * + * Software (/FPa) + * sin(), cos() 0.19 0.19 0.19 0.19 + * + * Software (/FPa) + * sincos() 0.39 0.50 0.73 1.7 + * + * + * + * ACCURACY: + * + * The accurate approximations are designed with a relative error + * criterion. The absolute error is greatest at x = 0.5 degree. + * It decreases from a local maximum at i+0.5 degrees to full + * machine precision at each integer i degrees. With the + * ACC5 option, the relative error of 6.3e-6 is equivalent to + * an absolute angular error of 0.01 arc second in the argument + * at x = i+0.5 degrees. For small angles < 0.5 deg, the ACC5 + * accuracy is 6.3e-6 (.00063%) of reading; i.e., the absolute + * error decreases in proportion to the argument. This is true + * for both the sine and cosine approximations, since the latter + * is for the function 1 - cos(x). + * + * If absolute error is of most concern, use the compile time + * option ABSERR to obtain an absolute error of 2.7e-8 for ACC5 + * precision. This is about half the absolute error of the + * relative precision option. In this case the relative error + * for small angles will increase to 9.5e-6 -- a reasonable + * tradeoff. + */ + +/* sindg.c + * + * Circular sine of angle in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, sindg(); + * + * y = sindg( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 P(x**2). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +-1000 3100 3.3e-17 9.0e-18 + * IEEE +-1000 30000 2.3e-16 5.6e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * sindg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * + */ + /* cosdg.c + * + * Circular cosine of angle in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, cosdg(); + * + * y = cosdg( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - x**2 P(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +-1000 3400 3.5e-17 9.1e-18 + * IEEE +-1000 30000 2.1e-16 5.7e-17 + * See also sin(). + * + */ + +/* sinh.c + * + * Hyperbolic sine + * + * + * + * SYNOPSIS: + * + * double x, y, sinh(); + * + * y = sinh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOG to + * MAXLOG. + * + * 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 + * DEC +- 88 50000 4.0e-17 7.7e-18 + * IEEE +-MAXLOG 30000 2.6e-16 5.7e-17 + * + */ + +/* spence.c + * + * Dilogarithm + * + * + * + * SYNOPSIS: + * + * double x, y, spence(); + * + * y = spence( x ); + * + * + * + * DESCRIPTION: + * + * Computes the integral + * + * x + * - + * | | log t + * spence(x) = - | ----- dt + * | | t - 1 + * - + * 1 + * + * for x >= 0. A rational approximation gives the integral in + * the interval (0.5, 1.5). Transformation formulas for 1/x + * and 1-x are employed outside the basic expansion range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,4 30000 3.9e-15 5.4e-16 + * DEC 0,4 3000 2.5e-16 4.5e-17 + * + * + */ + +/* sqrt.c + * + * Square root + * + * + * + * SYNOPSIS: + * + * double x, y, sqrt(); + * + * y = sqrt( 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. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 10 60000 2.1e-17 7.9e-18 + * IEEE 0,1.7e308 30000 1.7e-16 6.3e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrt domain x < 0 0.0 + * + */ + +/* stdtr.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * double t, stdtr(); + * short k; + * + * y = stdtr( 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 < -2, 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 <= 25. The "domain" refers to t. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -100,-2 50000 5.9e-15 1.4e-15 + * IEEE -2,100 500000 2.7e-15 4.9e-17 + */ + +/* stdtri.c + * + * Functional inverse of Student's t distribution + * + * + * + * SYNOPSIS: + * + * double p, t, stdtri(); + * int k; + * + * t = stdtri( k, p ); + * + * + * DESCRIPTION: + * + * Given probability p, finds the argument t such that stdtr(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 .001,.999 25000 5.7e-15 8.0e-16 + * IEEE 10^-6,.001 25000 2.0e-12 2.9e-14 + */ + +/* struve.c + * + * Struve function + * + * + * + * SYNOPSIS: + * + * double v, x, y, struve(); + * + * y = struve( v, x ); + * + * + * + * DESCRIPTION: + * + * Computes the Struve function Hv(x) of order v, argument x. + * Negative x is rejected unless v is an integer. + * + * This module also contains the hypergeometric functions 1F2 + * and 3F0 and a routine for the Bessel function Yv(x) with + * noninteger v. + * + * + * + * ACCURACY: + * + * Not accurately characterized, but spot checked against tables. + * + */ + +/* tan.c + * + * Circular tangent + * + * + * + * SYNOPSIS: + * + * double x, y, tan(); + * + * y = tan( 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 + * DEC +-1.07e9 44000 4.1e-17 1.0e-17 + * IEEE +-1.07e9 30000 2.9e-16 8.1e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * tan total loss x > 1.073741824e9 0.0 + * + */ + /* cot.c + * + * Circular cotangent + * + * + * + * SYNOPSIS: + * + * double x, y, cot(); + * + * y = cot( 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 2.9e-16 8.2e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 1.073741824e9 0.0 + * cot singularity x = 0 INFINITY + * + */ + +/* tandg.c + * + * Circular tangent of argument in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, tandg(); + * + * y = tandg( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the argument x in degrees. + * + * 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 + * DEC 0,10 8000 3.4e-17 1.2e-17 + * IEEE 0,10 30000 3.2e-16 8.4e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * tandg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * tandg singularity x = 180 k + 90 MAXNUM + */ + /* cotdg.c + * + * Circular cotangent of argument in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, cotdg(); + * + * y = cotdg( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the argument x in degrees. + * + * 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]. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cotdg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * cotdg singularity x = 180 k MAXNUM + */ + +/* tanh.c + * + * Hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * double x, y, tanh(); + * + * y = tanh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOG to + * MAXLOG. + * + * 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 + * DEC -2,2 50000 3.3e-17 6.4e-18 + * IEEE -2,2 30000 2.5e-16 5.8e-17 + * + */ + +/* unity.c + * + * Relative error approximations for function arguments near + * unity. + * + * log1p(x) = log(1+x) + * expm1(x) = exp(x) - 1 + * cosm1(x) = cos(x) - 1 + * + */ + +/* yn.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * double x, y, yn(); + * int n; + * + * y = yn( 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 + * y0() and y1(). + * + * If n = 0 or 1 the routine for y0 or y1 is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative + * when y > 1: + * arithmetic domain # trials peak rms + * DEC 0, 30 2200 2.9e-16 5.3e-17 + * IEEE 0, 30 30000 3.4e-15 4.3e-16 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * yn singularity x = 0 MAXNUM + * yn overflow MAXNUM + * + * Spot checked against tables for x, n between 0 and 100. + * + */ + +/* zeta.c + * + * Riemann zeta function of two arguments + * + * + * + * SYNOPSIS: + * + * double x, q, y, zeta(); + * + * y = zeta( x, q ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zeta(x,q) = > (k+q) + * - + * k=0 + * + * where x > 1 and q is not a negative integer or zero. + * The Euler-Maclaurin summation formula is used to obtain + * the expansion + * + * n + * - -x + * zeta(x,q) = > (k+q) + * - + * k=1 + * + * 1-x inf. B x(x+1)...(x+2j) + * (n+q) 1 - 2j + * + --------- - ------- + > -------------------- + * x-1 x - x+2j+1 + * 2(n+q) j=1 (2j)! (n+q) + * + * where the B2j are Bernoulli numbers. Note that (see zetac.c) + * zeta(x,1) = zetac(x) + 1. + * + * + * + * ACCURACY: + * + * + * + * REFERENCE: + * + * Gradshteyn, I. S., and I. M. Ryzhik, Tables of Integrals, + * Series, and Products, p. 1073; Academic Press, 1980. + * + */ + + /* zetac.c + * + * Riemann zeta function + * + * + * + * SYNOPSIS: + * + * double x, y, zetac(); + * + * y = zetac( x ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zetac(x) = > k , x > 1, + * - + * k=2 + * + * is related to the Riemann zeta function by + * + * Riemann zeta(x) = zetac(x) + 1. + * + * Extension of the function definition for x < 1 is implemented. + * Zero is returned for x > log2(MAXNUM). + * + * An overflow error may occur for large negative x, due to the + * gamma function in the reflection formula. + * + * ACCURACY: + * + * Tabulated values have full machine accuracy. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,50 10000 9.8e-16 1.3e-16 + * DEC 1,50 2000 1.1e-16 1.9e-17 + * + * + */ diff --git a/libm/double/acosh.c b/libm/double/acosh.c new file mode 100644 index 000000000..49d9a40e2 --- /dev/null +++ b/libm/double/acosh.c @@ -0,0 +1,167 @@ +/* acosh.c + * + * Inverse hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * double x, y, acosh(); + * + * y = acosh( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a rational approximation + * + * sqrt(z) * 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 + * DEC 1,3 30000 4.2e-17 1.1e-17 + * IEEE 1,3 30000 4.6e-16 8.7e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acosh domain |x| < 1 NAN + * + */ + +/* acosh.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +/* acosh(z) = sqrt(x) * R(x), z = x + 1, interval 0 < x < 0.5 */ + +#include <math.h> + +#ifdef UNK +static double P[] = { + 1.18801130533544501356E2, + 3.94726656571334401102E3, + 3.43989375926195455866E4, + 1.08102874834699867335E5, + 1.10855947270161294369E5 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.86145380837903397292E2, + 4.15352677227719831579E3, + 2.97683430363289370382E4, + 8.29725251988426222434E4, + 7.83869920495893927727E4 +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0041755,0115055,0144002,0146444, +0043166,0132103,0155150,0150302, +0044006,0057360,0003021,0162753, +0044323,0021557,0175225,0056253, +0044330,0101771,0040046,0006636 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0042072,0022467,0126670,0041232, +0043201,0146066,0152142,0034015, +0043750,0110257,0121165,0026100, +0044242,0007103,0034667,0033173, +0044231,0014576,0175573,0017472 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x59a4,0xb900,0xb345,0x405d, +0x1a18,0x7b4d,0xd688,0x40ae, +0x3cbd,0x00c2,0xcbde,0x40e0, +0xab95,0xff52,0x646d,0x40fa, +0xc1b4,0x2804,0x107f,0x40fb +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x0853,0xf5b7,0x44a6,0x4067, +0x4702,0xda8c,0x3986,0x40b0, +0xa588,0xf44e,0x1215,0x40dd, +0xe6cf,0x6736,0x41c8,0x40f4, +0x63e7,0xdf6f,0x232f,0x40f3 +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x405d,0xb345,0xb900,0x59a4, +0x40ae,0xd688,0x7b4d,0x1a18, +0x40e0,0xcbde,0x00c2,0x3cbd, +0x40fa,0x646d,0xff52,0xab95, +0x40fb,0x107f,0x2804,0xc1b4 +}; +static unsigned short Q[] = { +0x4067,0x44a6,0xf5b7,0x0853, +0x40b0,0x3986,0xda8c,0x4702, +0x40dd,0x1215,0xf44e,0xa588, +0x40f4,0x41c8,0x6736,0xe6cf, +0x40f3,0x232f,0xdf6f,0x63e7, +}; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double log ( double ); +extern double sqrt ( double ); +#else +double log(), sqrt(), polevl(), p1evl(); +#endif +extern double LOGE2, INFINITY, NAN; + +double acosh(x) +double x; +{ +double a, z; + +if( x < 1.0 ) + { + mtherr( "acosh", DOMAIN ); + return(NAN); + } + +if( x > 1.0e8 ) + { +#ifdef INFINITIES + if( x == INFINITY ) + return( INFINITY ); +#endif + return( log(x) + LOGE2 ); + } + +z = x - 1.0; + +if( z < 0.5 ) + { + a = sqrt(z) * (polevl(z, P, 4) / p1evl(z, Q, 5) ); + return( a ); + } + +a = sqrt( z*(x+1.0) ); +return( log(x + a) ); +} diff --git a/libm/double/airy.c b/libm/double/airy.c new file mode 100644 index 000000000..91e29088a --- /dev/null +++ b/libm/double/airy.c @@ -0,0 +1,965 @@ +/* airy.c + * + * Airy function + * + * + * + * SYNOPSIS: + * + * double x, ai, aip, bi, bip; + * int airy(); + * + * airy( x, _&ai, _&aip, _&bi, _&bip ); + * + * + * + * DESCRIPTION: + * + * Solution of the differential equation + * + * y"(x) = xy. + * + * The function returns the two independent solutions Ai, Bi + * and their first derivatives Ai'(x), Bi'(x). + * + * Evaluation is by power series summation for small x, + * by rational minimax approximations for large x. + * + * + * + * ACCURACY: + * Error criterion is absolute when function <= 1, relative + * when function > 1, except * denotes relative error criterion. + * For large negative x, the absolute error increases as x^1.5. + * For large positive x, the relative error increases as x^1.5. + * + * Arithmetic domain function # trials peak rms + * IEEE -10, 0 Ai 10000 1.6e-15 2.7e-16 + * IEEE 0, 10 Ai 10000 2.3e-14* 1.8e-15* + * IEEE -10, 0 Ai' 10000 4.6e-15 7.6e-16 + * IEEE 0, 10 Ai' 10000 1.8e-14* 1.5e-15* + * IEEE -10, 10 Bi 30000 4.2e-15 5.3e-16 + * IEEE -10, 10 Bi' 30000 4.9e-15 7.3e-16 + * DEC -10, 0 Ai 5000 1.7e-16 2.8e-17 + * DEC 0, 10 Ai 5000 2.1e-15* 1.7e-16* + * DEC -10, 0 Ai' 5000 4.7e-16 7.8e-17 + * DEC 0, 10 Ai' 12000 1.8e-15* 1.5e-16* + * DEC -10, 10 Bi 10000 5.5e-16 6.8e-17 + * DEC -10, 10 Bi' 7000 5.3e-16 8.7e-17 + * + */ + /* airy.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +static double c1 = 0.35502805388781723926; +static double c2 = 0.258819403792806798405; +static double sqrt3 = 1.732050807568877293527; +static double sqpii = 5.64189583547756286948E-1; +extern double PI; + +extern double MAXNUM, MACHEP; +#ifdef UNK +#define MAXAIRY 25.77 +#endif +#ifdef DEC +#define MAXAIRY 25.77 +#endif +#ifdef IBMPC +#define MAXAIRY 103.892 +#endif +#ifdef MIEEE +#define MAXAIRY 103.892 +#endif + + +#ifdef UNK +static double AN[8] = { + 3.46538101525629032477E-1, + 1.20075952739645805542E1, + 7.62796053615234516538E1, + 1.68089224934630576269E2, + 1.59756391350164413639E2, + 7.05360906840444183113E1, + 1.40264691163389668864E1, + 9.99999999999999995305E-1, +}; +static double AD[8] = { + 5.67594532638770212846E-1, + 1.47562562584847203173E1, + 8.45138970141474626562E1, + 1.77318088145400459522E2, + 1.64234692871529701831E2, + 7.14778400825575695274E1, + 1.40959135607834029598E1, + 1.00000000000000000470E0, +}; +#endif +#ifdef DEC +static unsigned short AN[32] = { +0037661,0066561,0024675,0131301, +0041100,0017434,0034324,0101466, +0041630,0107450,0067427,0007430, +0042050,0013327,0071000,0034737, +0042037,0140642,0156417,0167366, +0041615,0011172,0075147,0051165, +0041140,0066152,0160520,0075146, +0040200,0000000,0000000,0000000, +}; +static unsigned short AD[32] = { +0040021,0046740,0011422,0064606, +0041154,0014640,0024631,0062450, +0041651,0003435,0101152,0106401, +0042061,0050556,0034605,0136602, +0042044,0036024,0152377,0151414, +0041616,0172247,0072216,0115374, +0041141,0104334,0124154,0166007, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short AN[32] = { +0xb658,0x2537,0x2dae,0x3fd6, +0x9067,0x871a,0x03e3,0x4028, +0xe1e3,0x0de2,0x11e5,0x4053, +0x073c,0xee40,0x02da,0x4065, +0xfddf,0x5ba1,0xf834,0x4063, +0xea4f,0x4f4c,0xa24f,0x4051, +0x0f4d,0x5c2a,0x0d8d,0x402c, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short AD[32] = { +0x4d31,0x0262,0x29bc,0x3fe2, +0x2ca5,0x0533,0x8334,0x402d, +0x51a0,0xb04d,0x20e3,0x4055, +0xb7b0,0xc730,0x2a2d,0x4066, +0xfa61,0x9a9f,0x8782,0x4064, +0xd35f,0xee91,0xde94,0x4051, +0x9d81,0x950d,0x311b,0x402c, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short AN[32] = { +0x3fd6,0x2dae,0x2537,0xb658, +0x4028,0x03e3,0x871a,0x9067, +0x4053,0x11e5,0x0de2,0xe1e3, +0x4065,0x02da,0xee40,0x073c, +0x4063,0xf834,0x5ba1,0xfddf, +0x4051,0xa24f,0x4f4c,0xea4f, +0x402c,0x0d8d,0x5c2a,0x0f4d, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short AD[32] = { +0x3fe2,0x29bc,0x0262,0x4d31, +0x402d,0x8334,0x0533,0x2ca5, +0x4055,0x20e3,0xb04d,0x51a0, +0x4066,0x2a2d,0xc730,0xb7b0, +0x4064,0x8782,0x9a9f,0xfa61, +0x4051,0xde94,0xee91,0xd35f, +0x402c,0x311b,0x950d,0x9d81, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +#ifdef UNK +static double APN[8] = { + 6.13759184814035759225E-1, + 1.47454670787755323881E1, + 8.20584123476060982430E1, + 1.71184781360976385540E2, + 1.59317847137141783523E2, + 6.99778599330103016170E1, + 1.39470856980481566958E1, + 1.00000000000000000550E0, +}; +static double APD[8] = { + 3.34203677749736953049E-1, + 1.11810297306158156705E1, + 7.11727352147859965283E1, + 1.58778084372838313640E2, + 1.53206427475809220834E2, + 6.86752304592780337944E1, + 1.38498634758259442477E1, + 9.99999999999999994502E-1, +}; +#endif +#ifdef DEC +static unsigned short APN[32] = { +0040035,0017522,0065145,0054755, +0041153,0166556,0161471,0057174, +0041644,0016750,0034445,0046462, +0042053,0027515,0152316,0046717, +0042037,0050536,0067023,0023264, +0041613,0172252,0007240,0131055, +0041137,0023503,0052472,0002305, +0040200,0000000,0000000,0000000, +}; +static unsigned short APD[32] = { +0037653,0016276,0112106,0126625, +0041062,0162577,0067111,0111761, +0041616,0054160,0140004,0137455, +0042036,0143460,0104626,0157206, +0042031,0032330,0067131,0114260, +0041611,0054667,0147207,0134564, +0041135,0114412,0070653,0146015, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short APN[32] = { +0xab3e,0x4d4c,0xa3ea,0x3fe3, +0x2bcf,0xdc67,0x7dad,0x402d, +0xa9a6,0x0724,0x83bd,0x4054, +0xc9ba,0xba99,0x65e9,0x4065, +0x64d7,0xcdc2,0xea2b,0x4063, +0x1646,0x41d4,0x7e95,0x4051, +0x4099,0x6aa7,0xe4e8,0x402b, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short APD[32] = { +0xd5b3,0xd288,0x6397,0x3fd5, +0x327e,0xedc9,0x5caf,0x4026, +0x97e6,0x1800,0xcb0e,0x4051, +0xdbd1,0x1132,0xd8e6,0x4063, +0x3316,0x0dcb,0x269b,0x4063, +0xf72f,0xf9d0,0x2b36,0x4051, +0x7982,0x4e35,0xb321,0x402b, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short APN[32] = { +0x3fe3,0xa3ea,0x4d4c,0xab3e, +0x402d,0x7dad,0xdc67,0x2bcf, +0x4054,0x83bd,0x0724,0xa9a6, +0x4065,0x65e9,0xba99,0xc9ba, +0x4063,0xea2b,0xcdc2,0x64d7, +0x4051,0x7e95,0x41d4,0x1646, +0x402b,0xe4e8,0x6aa7,0x4099, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short APD[32] = { +0x3fd5,0x6397,0xd288,0xd5b3, +0x4026,0x5caf,0xedc9,0x327e, +0x4051,0xcb0e,0x1800,0x97e6, +0x4063,0xd8e6,0x1132,0xdbd1, +0x4063,0x269b,0x0dcb,0x3316, +0x4051,0x2b36,0xf9d0,0xf72f, +0x402b,0xb321,0x4e35,0x7982, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +#ifdef UNK +static double BN16[5] = { +-2.53240795869364152689E-1, + 5.75285167332467384228E-1, +-3.29907036873225371650E-1, + 6.44404068948199951727E-2, +-3.82519546641336734394E-3, +}; +static double BD16[5] = { +/* 1.00000000000000000000E0,*/ +-7.15685095054035237902E0, + 1.06039580715664694291E1, +-5.23246636471251500874E0, + 9.57395864378383833152E-1, +-5.50828147163549611107E-2, +}; +#endif +#ifdef DEC +static unsigned short BN16[20] = { +0137601,0124307,0010213,0035210, +0040023,0042743,0101621,0016031, +0137650,0164623,0036056,0074511, +0037203,0174525,0000473,0142474, +0136172,0130041,0066726,0064324, +}; +static unsigned short BD16[20] = { +/*0040200,0000000,0000000,0000000,*/ +0140745,0002354,0044335,0055276, +0041051,0124717,0170130,0104013, +0140647,0070135,0046473,0103501, +0040165,0013745,0033324,0127766, +0137141,0117204,0076164,0033107, +}; +#endif +#ifdef IBMPC +static unsigned short BN16[20] = { +0x6751,0xe211,0x3518,0xbfd0, +0x2383,0x7072,0x68bc,0x3fe2, +0xcf29,0x6785,0x1d32,0xbfd5, +0x78a8,0xa027,0x7f2a,0x3fb0, +0xcd1b,0x2dba,0x5604,0xbf6f, +}; +static unsigned short BD16[20] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xab58,0x891b,0xa09d,0xc01c, +0x1101,0xfe0b,0x3539,0x4025, +0x70e8,0xa9a7,0xee0b,0xc014, +0x95ff,0xa6da,0xa2fc,0x3fee, +0x86c9,0x8f8e,0x33d0,0xbfac, +}; +#endif +#ifdef MIEEE +static unsigned short BN16[20] = { +0xbfd0,0x3518,0xe211,0x6751, +0x3fe2,0x68bc,0x7072,0x2383, +0xbfd5,0x1d32,0x6785,0xcf29, +0x3fb0,0x7f2a,0xa027,0x78a8, +0xbf6f,0x5604,0x2dba,0xcd1b, +}; +static unsigned short BD16[20] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc01c,0xa09d,0x891b,0xab58, +0x4025,0x3539,0xfe0b,0x1101, +0xc014,0xee0b,0xa9a7,0x70e8, +0x3fee,0xa2fc,0xa6da,0x95ff, +0xbfac,0x33d0,0x8f8e,0x86c9, +}; +#endif + +#ifdef UNK +static double BPPN[5] = { + 4.65461162774651610328E-1, +-1.08992173800493920734E0, + 6.38800117371827987759E-1, +-1.26844349553102907034E-1, + 7.62487844342109852105E-3, +}; +static double BPPD[5] = { +/* 1.00000000000000000000E0,*/ +-8.70622787633159124240E0, + 1.38993162704553213172E1, +-7.14116144616431159572E0, + 1.34008595960680518666E0, +-7.84273211323341930448E-2, +}; +#endif +#ifdef DEC +static unsigned short BPPN[20] = { +0037756,0050354,0167531,0135731, +0140213,0101216,0032767,0020375, +0040043,0104147,0106312,0177632, +0137401,0161574,0032015,0043714, +0036371,0155035,0143165,0142262, +}; +static unsigned short BPPD[20] = { +/*0040200,0000000,0000000,0000000,*/ +0141013,0046265,0115005,0161053, +0041136,0061631,0072445,0156131, +0140744,0102145,0001127,0065304, +0040253,0103757,0146453,0102513, +0137240,0117200,0155402,0113500, +}; +#endif +#ifdef IBMPC +static unsigned short BPPN[20] = { +0x377b,0x9deb,0xca1d,0x3fdd, +0xe420,0xc6be,0x7051,0xbff1, +0x5ff3,0xf199,0x710c,0x3fe4, +0xa8fa,0x8681,0x3c6f,0xbfc0, +0xb896,0xb8ce,0x3b43,0x3f7f, +}; +static unsigned short BPPD[20] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xbc45,0xb340,0x6996,0xc021, +0xbb8b,0x2ea4,0xcc73,0x402b, +0xed59,0xa04a,0x908c,0xc01c, +0x70a9,0xf9a5,0x70fd,0x3ff5, +0x52e8,0x1b60,0x13d0,0xbfb4, +}; +#endif +#ifdef MIEEE +static unsigned short BPPN[20] = { +0x3fdd,0xca1d,0x9deb,0x377b, +0xbff1,0x7051,0xc6be,0xe420, +0x3fe4,0x710c,0xf199,0x5ff3, +0xbfc0,0x3c6f,0x8681,0xa8fa, +0x3f7f,0x3b43,0xb8ce,0xb896, +}; +static unsigned short BPPD[20] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc021,0x6996,0xb340,0xbc45, +0x402b,0xcc73,0x2ea4,0xbb8b, +0xc01c,0x908c,0xa04a,0xed59, +0x3ff5,0x70fd,0xf9a5,0x70a9, +0xbfb4,0x13d0,0x1b60,0x52e8, +}; +#endif + +#ifdef UNK +static double AFN[9] = { +-1.31696323418331795333E-1, +-6.26456544431912369773E-1, +-6.93158036036933542233E-1, +-2.79779981545119124951E-1, +-4.91900132609500318020E-2, +-4.06265923594885404393E-3, +-1.59276496239262096340E-4, +-2.77649108155232920844E-6, +-1.67787698489114633780E-8, +}; +static double AFD[9] = { +/* 1.00000000000000000000E0,*/ + 1.33560420706553243746E1, + 3.26825032795224613948E1, + 2.67367040941499554804E1, + 9.18707402907259625840E0, + 1.47529146771666414581E0, + 1.15687173795188044134E-1, + 4.40291641615211203805E-3, + 7.54720348287414296618E-5, + 4.51850092970580378464E-7, +}; +#endif +#ifdef DEC +static unsigned short AFN[36] = { +0137406,0155546,0124127,0033732, +0140040,0057564,0141263,0041222, +0140061,0071316,0013674,0175754, +0137617,0037522,0056637,0120130, +0137111,0075567,0121755,0166122, +0136205,0020016,0043317,0002201, +0135047,0001565,0075130,0002334, +0133472,0051700,0165021,0131551, +0131620,0020347,0132165,0013215, +}; +static unsigned short AFD[36] = { +/*0040200,0000000,0000000,0000000,*/ +0041125,0131131,0025627,0067623, +0041402,0135342,0021703,0154315, +0041325,0162305,0016671,0120175, +0041022,0177101,0053114,0141632, +0040274,0153131,0147364,0114306, +0037354,0166545,0120042,0150530, +0036220,0043127,0000727,0130273, +0034636,0043275,0075667,0034733, +0032762,0112715,0146250,0142474, +}; +#endif +#ifdef IBMPC +static unsigned short AFN[36] = { +0xe6fb,0xd50a,0xdb6c,0xbfc0, +0x6852,0x9856,0x0bee,0xbfe4, +0x9f7d,0xc2f7,0x2e59,0xbfe6, +0xf40b,0x4bb3,0xe7ea,0xbfd1, +0xbd8a,0xf47d,0x2f6e,0xbfa9, +0xe090,0xc8d9,0xa401,0xbf70, +0x009c,0xaf4b,0xe06e,0xbf24, +0x366d,0x1d42,0x4a78,0xbec7, +0xa2d2,0xf68e,0x041c,0xbe52, +}; +static unsigned short AFD[36] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xedf2,0x2572,0xb64b,0x402a, +0x7b1a,0x4478,0x575c,0x4040, +0x3410,0xa3b7,0xbc98,0x403a, +0x9873,0x2ac9,0x5fc8,0x4022, +0x9319,0x39de,0x9acb,0x3ff7, +0x5a2b,0xb404,0x9dac,0x3fbd, +0xf617,0xe03a,0x08ca,0x3f72, +0xe73b,0xaf76,0xc8d7,0x3f13, +0x18a7,0xb995,0x52b9,0x3e9e, +}; +#endif +#ifdef MIEEE +static unsigned short AFN[36] = { +0xbfc0,0xdb6c,0xd50a,0xe6fb, +0xbfe4,0x0bee,0x9856,0x6852, +0xbfe6,0x2e59,0xc2f7,0x9f7d, +0xbfd1,0xe7ea,0x4bb3,0xf40b, +0xbfa9,0x2f6e,0xf47d,0xbd8a, +0xbf70,0xa401,0xc8d9,0xe090, +0xbf24,0xe06e,0xaf4b,0x009c, +0xbec7,0x4a78,0x1d42,0x366d, +0xbe52,0x041c,0xf68e,0xa2d2, +}; +static unsigned short AFD[36] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x402a,0xb64b,0x2572,0xedf2, +0x4040,0x575c,0x4478,0x7b1a, +0x403a,0xbc98,0xa3b7,0x3410, +0x4022,0x5fc8,0x2ac9,0x9873, +0x3ff7,0x9acb,0x39de,0x9319, +0x3fbd,0x9dac,0xb404,0x5a2b, +0x3f72,0x08ca,0xe03a,0xf617, +0x3f13,0xc8d7,0xaf76,0xe73b, +0x3e9e,0x52b9,0xb995,0x18a7, +}; +#endif + +#ifdef UNK +static double AGN[11] = { + 1.97339932091685679179E-2, + 3.91103029615688277255E-1, + 1.06579897599595591108E0, + 9.39169229816650230044E-1, + 3.51465656105547619242E-1, + 6.33888919628925490927E-2, + 5.85804113048388458567E-3, + 2.82851600836737019778E-4, + 6.98793669997260967291E-6, + 8.11789239554389293311E-8, + 3.41551784765923618484E-10, +}; +static double AGD[10] = { +/* 1.00000000000000000000E0,*/ + 9.30892908077441974853E0, + 1.98352928718312140417E1, + 1.55646628932864612953E1, + 5.47686069422975497931E0, + 9.54293611618961883998E-1, + 8.64580826352392193095E-2, + 4.12656523824222607191E-3, + 1.01259085116509135510E-4, + 1.17166733214413521882E-6, + 4.91834570062930015649E-9, +}; +#endif +#ifdef DEC +static unsigned short AGN[44] = { +0036641,0124456,0167175,0157354, +0037710,0037250,0001441,0136671, +0040210,0066031,0150401,0123532, +0040160,0066545,0003570,0153133, +0037663,0171516,0072507,0170345, +0037201,0151011,0007510,0045702, +0036277,0172317,0104572,0101030, +0035224,0045663,0000160,0136422, +0033752,0074753,0047702,0135160, +0032256,0052225,0156550,0107103, +0030273,0142443,0166277,0071720, +}; +static unsigned short AGD[40] = { +/*0040200,0000000,0000000,0000000,*/ +0041024,0170537,0117253,0055003, +0041236,0127256,0003570,0143240, +0041171,0004333,0172476,0160645, +0040657,0041161,0055716,0157161, +0040164,0046226,0006257,0063431, +0037261,0010357,0065445,0047563, +0036207,0034043,0057434,0116732, +0034724,0055416,0130035,0026377, +0033235,0041056,0154071,0023502, +0031250,0177071,0167254,0047242, +}; +#endif +#ifdef IBMPC +static unsigned short AGN[44] = { +0xbbde,0xddcf,0x3525,0x3f94, +0x37b7,0x0064,0x07d5,0x3fd9, +0x34eb,0x3a20,0x0d83,0x3ff1, +0x1acb,0xa0ef,0x0dac,0x3fee, +0xfe1d,0xcea8,0x7e69,0x3fd6, +0x0978,0x21e9,0x3a41,0x3fb0, +0x5043,0xf12f,0xfe99,0x3f77, +0x17a2,0x600e,0x8976,0x3f32, +0x574e,0x69f8,0x4f3d,0x3edd, +0x11c8,0xbbad,0xca92,0x3e75, +0xee7a,0x7d97,0x78a4,0x3df7, +}; +static unsigned short AGD[40] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6b40,0xf3d5,0x9e2b,0x4022, +0x18d4,0xc0ef,0xd5d5,0x4033, +0xdc35,0x7ea7,0x211b,0x402f, +0xdbce,0x2b79,0xe84e,0x4015, +0xece3,0xc195,0x8992,0x3fee, +0xa9ee,0xed64,0x221d,0x3fb6, +0x93bb,0x6be3,0xe704,0x3f70, +0xa5a0,0xd603,0x8b61,0x3f1a, +0x24e8,0xdb07,0xa845,0x3eb3, +0x89d4,0x3dd5,0x1fc7,0x3e35, +}; +#endif +#ifdef MIEEE +static unsigned short AGN[44] = { +0x3f94,0x3525,0xddcf,0xbbde, +0x3fd9,0x07d5,0x0064,0x37b7, +0x3ff1,0x0d83,0x3a20,0x34eb, +0x3fee,0x0dac,0xa0ef,0x1acb, +0x3fd6,0x7e69,0xcea8,0xfe1d, +0x3fb0,0x3a41,0x21e9,0x0978, +0x3f77,0xfe99,0xf12f,0x5043, +0x3f32,0x8976,0x600e,0x17a2, +0x3edd,0x4f3d,0x69f8,0x574e, +0x3e75,0xca92,0xbbad,0x11c8, +0x3df7,0x78a4,0x7d97,0xee7a, +}; +static unsigned short AGD[40] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4022,0x9e2b,0xf3d5,0x6b40, +0x4033,0xd5d5,0xc0ef,0x18d4, +0x402f,0x211b,0x7ea7,0xdc35, +0x4015,0xe84e,0x2b79,0xdbce, +0x3fee,0x8992,0xc195,0xece3, +0x3fb6,0x221d,0xed64,0xa9ee, +0x3f70,0xe704,0x6be3,0x93bb, +0x3f1a,0x8b61,0xd603,0xa5a0, +0x3eb3,0xa845,0xdb07,0x24e8, +0x3e35,0x1fc7,0x3dd5,0x89d4, +}; +#endif + +#ifdef UNK +static double APFN[9] = { + 1.85365624022535566142E-1, + 8.86712188052584095637E-1, + 9.87391981747398547272E-1, + 4.01241082318003734092E-1, + 7.10304926289631174579E-2, + 5.90618657995661810071E-3, + 2.33051409401776799569E-4, + 4.08718778289035454598E-6, + 2.48379932900442457853E-8, +}; +static double APFD[9] = { +/* 1.00000000000000000000E0,*/ + 1.47345854687502542552E1, + 3.75423933435489594466E1, + 3.14657751203046424330E1, + 1.09969125207298778536E1, + 1.78885054766999417817E0, + 1.41733275753662636873E-1, + 5.44066067017226003627E-3, + 9.39421290654511171663E-5, + 5.65978713036027009243E-7, +}; +#endif +#ifdef DEC +static unsigned short APFN[36] = { +0037475,0150174,0071752,0166651, +0040142,0177621,0164246,0101757, +0040174,0142670,0106760,0006573, +0037715,0067570,0116274,0022404, +0037221,0074157,0053341,0117207, +0036301,0104257,0015075,0004777, +0035164,0057502,0164034,0001313, +0033611,0022254,0176000,0112565, +0031725,0055523,0025153,0166057, +}; +static unsigned short APFD[36] = { +/*0040200,0000000,0000000,0000000,*/ +0041153,0140334,0130506,0061402, +0041426,0025551,0024440,0070611, +0041373,0134750,0047147,0176702, +0041057,0171532,0105430,0017674, +0040344,0174416,0001726,0047754, +0037421,0021207,0020167,0136264, +0036262,0043621,0151321,0124324, +0034705,0001313,0163733,0016407, +0033027,0166702,0150440,0170561, +}; +#endif +#ifdef IBMPC +static unsigned short APFN[36] = { +0x5db5,0x8e7d,0xba0f,0x3fc7, +0xd07e,0x3d14,0x5ff2,0x3fec, +0x01af,0x11be,0x98b7,0x3fef, +0x84a1,0x1397,0xadef,0x3fd9, +0x33d1,0xeadc,0x2f0d,0x3fb2, +0xa140,0xe347,0x3115,0x3f78, +0x8059,0x5d03,0x8be8,0x3f2e, +0x12af,0x9f80,0x2495,0x3ed1, +0x7d86,0x654d,0xab6a,0x3e5a, +}; +static unsigned short APFD[36] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xcc60,0x9628,0x781b,0x402d, +0x0e31,0x2524,0xc56d,0x4042, +0xffb8,0x09cc,0x773d,0x403f, +0x03f7,0x5163,0xfe6b,0x4025, +0xc9fd,0xc07a,0x9f21,0x3ffc, +0xf796,0xe40e,0x2450,0x3fc2, +0x351a,0x3a5a,0x48f2,0x3f76, +0x63a1,0x7cfb,0xa059,0x3f18, +0x1e2e,0x5a24,0xfdb8,0x3ea2, +}; +#endif +#ifdef MIEEE +static unsigned short APFN[36] = { +0x3fc7,0xba0f,0x8e7d,0x5db5, +0x3fec,0x5ff2,0x3d14,0xd07e, +0x3fef,0x98b7,0x11be,0x01af, +0x3fd9,0xadef,0x1397,0x84a1, +0x3fb2,0x2f0d,0xeadc,0x33d1, +0x3f78,0x3115,0xe347,0xa140, +0x3f2e,0x8be8,0x5d03,0x8059, +0x3ed1,0x2495,0x9f80,0x12af, +0x3e5a,0xab6a,0x654d,0x7d86, +}; +static unsigned short APFD[36] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x402d,0x781b,0x9628,0xcc60, +0x4042,0xc56d,0x2524,0x0e31, +0x403f,0x773d,0x09cc,0xffb8, +0x4025,0xfe6b,0x5163,0x03f7, +0x3ffc,0x9f21,0xc07a,0xc9fd, +0x3fc2,0x2450,0xe40e,0xf796, +0x3f76,0x48f2,0x3a5a,0x351a, +0x3f18,0xa059,0x7cfb,0x63a1, +0x3ea2,0xfdb8,0x5a24,0x1e2e, +}; +#endif + +#ifdef UNK +static double APGN[11] = { +-3.55615429033082288335E-2, +-6.37311518129435504426E-1, +-1.70856738884312371053E0, +-1.50221872117316635393E0, +-5.63606665822102676611E-1, +-1.02101031120216891789E-1, +-9.48396695961445269093E-3, +-4.60325307486780994357E-4, +-1.14300836484517375919E-5, +-1.33415518685547420648E-7, +-5.63803833958893494476E-10, +}; +static double APGD[11] = { +/* 1.00000000000000000000E0,*/ + 9.85865801696130355144E0, + 2.16401867356585941885E1, + 1.73130776389749389525E1, + 6.17872175280828766327E0, + 1.08848694396321495475E0, + 9.95005543440888479402E-2, + 4.78468199683886610842E-3, + 1.18159633322838625562E-4, + 1.37480673554219441465E-6, + 5.79912514929147598821E-9, +}; +#endif +#ifdef DEC +static unsigned short APGN[44] = { +0137021,0124372,0176075,0075331, +0140043,0023330,0177672,0161655, +0140332,0131126,0010413,0171112, +0140300,0044263,0175560,0054070, +0140020,0044206,0142603,0073324, +0137321,0015130,0066144,0144033, +0136433,0061243,0175542,0103373, +0135361,0053721,0020441,0053203, +0134077,0141725,0160277,0130612, +0132417,0040372,0100363,0060200, +0130432,0175052,0171064,0034147, +}; +static unsigned short APGD[40] = { +/*0040200,0000000,0000000,0000000,*/ +0041035,0136420,0030124,0140220, +0041255,0017432,0034447,0162256, +0041212,0100456,0154544,0006321, +0040705,0134026,0127154,0123414, +0040213,0051612,0044470,0172607, +0037313,0143362,0053273,0157051, +0036234,0144322,0054536,0007264, +0034767,0146170,0054265,0170342, +0033270,0102777,0167362,0073631, +0031307,0040644,0167103,0021763, +}; +#endif +#ifdef IBMPC +static unsigned short APGN[44] = { +0xaf5b,0x5f87,0x351f,0xbfa2, +0x5c76,0x1ff7,0x64db,0xbfe4, +0x7e49,0xc221,0x564a,0xbffb, +0x0b07,0x7f6e,0x0916,0xbff8, +0x6edb,0xd8b0,0x0910,0xbfe2, +0x9903,0x0d8c,0x234b,0xbfba, +0x50df,0x7f6c,0x6c54,0xbf83, +0x2ad0,0x2424,0x2afa,0xbf3e, +0xf631,0xbc17,0xf87a,0xbee7, +0x6c10,0x501e,0xe81f,0xbe81, +0x870d,0x5e46,0x5f45,0xbe03, +}; +static unsigned short APGD[40] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x9812,0x060a,0xb7a2,0x4023, +0xfc96,0x4724,0xa3e3,0x4035, +0x819a,0xdb2c,0x5025,0x4031, +0x94e2,0xd5cd,0xb702,0x4018, +0x1eb1,0x4927,0x6a71,0x3ff1, +0x7bc5,0x4ad7,0x78de,0x3fb9, +0xc1d7,0x4b2b,0x991a,0x3f73, +0xbe1c,0x0b16,0xf98f,0x3f1e, +0x4ef3,0xfdde,0x10bf,0x3eb7, +0x647e,0x9dc8,0xe834,0x3e38, +}; +#endif +#ifdef MIEEE +static unsigned short APGN[44] = { +0xbfa2,0x351f,0x5f87,0xaf5b, +0xbfe4,0x64db,0x1ff7,0x5c76, +0xbffb,0x564a,0xc221,0x7e49, +0xbff8,0x0916,0x7f6e,0x0b07, +0xbfe2,0x0910,0xd8b0,0x6edb, +0xbfba,0x234b,0x0d8c,0x9903, +0xbf83,0x6c54,0x7f6c,0x50df, +0xbf3e,0x2afa,0x2424,0x2ad0, +0xbee7,0xf87a,0xbc17,0xf631, +0xbe81,0xe81f,0x501e,0x6c10, +0xbe03,0x5f45,0x5e46,0x870d, +}; +static unsigned short APGD[40] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4023,0xb7a2,0x060a,0x9812, +0x4035,0xa3e3,0x4724,0xfc96, +0x4031,0x5025,0xdb2c,0x819a, +0x4018,0xb702,0xd5cd,0x94e2, +0x3ff1,0x6a71,0x4927,0x1eb1, +0x3fb9,0x78de,0x4ad7,0x7bc5, +0x3f73,0x991a,0x4b2b,0xc1d7, +0x3f1e,0xf98f,0x0b16,0xbe1c, +0x3eb7,0x10bf,0xfdde,0x4ef3, +0x3e38,0xe834,0x9dc8,0x647e, +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double exp ( double ); +extern double sqrt ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double sin ( double ); +extern double cos ( double ); +#else +double fabs(), exp(), sqrt(); +double polevl(), p1evl(), sin(), cos(); +#endif + +int airy( x, ai, aip, bi, bip ) +double x, *ai, *aip, *bi, *bip; +{ +double z, zz, t, f, g, uf, ug, k, zeta, theta; +int domflg; + +domflg = 0; +if( x > MAXAIRY ) + { + *ai = 0; + *aip = 0; + *bi = MAXNUM; + *bip = MAXNUM; + return(-1); + } + +if( x < -2.09 ) + { + domflg = 15; + t = sqrt(-x); + zeta = -2.0 * x * t / 3.0; + t = sqrt(t); + k = sqpii / t; + z = 1.0/zeta; + zz = z * z; + uf = 1.0 + zz * polevl( zz, AFN, 8 ) / p1evl( zz, AFD, 9 ); + ug = z * polevl( zz, AGN, 10 ) / p1evl( zz, AGD, 10 ); + theta = zeta + 0.25 * PI; + f = sin( theta ); + g = cos( theta ); + *ai = k * (f * uf - g * ug); + *bi = k * (g * uf + f * ug); + uf = 1.0 + zz * polevl( zz, APFN, 8 ) / p1evl( zz, APFD, 9 ); + ug = z * polevl( zz, APGN, 10 ) / p1evl( zz, APGD, 10 ); + k = sqpii * t; + *aip = -k * (g * uf + f * ug); + *bip = k * (f * uf - g * ug); + return(0); + } + +if( x >= 2.09 ) /* cbrt(9) */ + { + domflg = 5; + t = sqrt(x); + zeta = 2.0 * x * t / 3.0; + g = exp( zeta ); + t = sqrt(t); + k = 2.0 * t * g; + z = 1.0/zeta; + f = polevl( z, AN, 7 ) / polevl( z, AD, 7 ); + *ai = sqpii * f / k; + k = -0.5 * sqpii * t / g; + f = polevl( z, APN, 7 ) / polevl( z, APD, 7 ); + *aip = f * k; + + if( x > 8.3203353 ) /* zeta > 16 */ + { + f = z * polevl( z, BN16, 4 ) / p1evl( z, BD16, 5 ); + k = sqpii * g; + *bi = k * (1.0 + f) / t; + f = z * polevl( z, BPPN, 4 ) / p1evl( z, BPPD, 5 ); + *bip = k * t * (1.0 + f); + return(0); + } + } + +f = 1.0; +g = x; +t = 1.0; +uf = 1.0; +ug = x; +k = 1.0; +z = x * x * x; +while( t > MACHEP ) + { + uf *= z; + k += 1.0; + uf /=k; + ug *= z; + k += 1.0; + ug /=k; + uf /=k; + f += uf; + k += 1.0; + ug /=k; + g += ug; + t = fabs(uf/f); + } +uf = c1 * f; +ug = c2 * g; +if( (domflg & 1) == 0 ) + *ai = uf - ug; +if( (domflg & 2) == 0 ) + *bi = sqrt3 * (uf + ug); + +/* the deriviative of ai */ +k = 4.0; +uf = x * x/2.0; +ug = z/3.0; +f = uf; +g = 1.0 + ug; +uf /= 3.0; +t = 1.0; + +while( t > MACHEP ) + { + uf *= z; + ug /=k; + k += 1.0; + ug *= z; + uf /=k; + f += uf; + k += 1.0; + ug /=k; + uf /=k; + g += ug; + k += 1.0; + t = fabs(ug/g); + } + +uf = c1 * f; +ug = c2 * g; +if( (domflg & 4) == 0 ) + *aip = uf - ug; +if( (domflg & 8) == 0 ) + *bip = sqrt3 * (uf + ug); +return(0); +} diff --git a/libm/double/arcdot.c b/libm/double/arcdot.c new file mode 100644 index 000000000..44c057229 --- /dev/null +++ b/libm/double/arcdot.c @@ -0,0 +1,110 @@ +/* arcdot.c + * + * Angle between two vectors + * + * + * + * + * SYNOPSIS: + * + * double p[3], q[3], arcdot(); + * + * y = arcdot( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1, 1 10^6 1.7e-16 4.2e-17 + * + */ + +/* +Cephes Math Library Release 2.3: November, 1995 +Copyright 1995 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double acos ( double ); +extern double asin ( double ); +extern double atan ( double ); +#else +double sqrt(), acos(), asin(), atan(); +#endif +extern double PI; + +double arcdot(p,q) +double p[], q[]; +{ +double pp, pr, qq, rr, rt, pt, qt, pq; +int i; + +pq = 0.0; +qq = 0.0; +pp = 0.0; +pr = 0.0; +rr = 0.0; +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.0 || pp == 0.0 || qq == 0.0) + return 0.0; +rt = (rr - (pr * pr) / pp) / qq; +if (rt <= 0.75) + { + rt = sqrt(rt); + qt = asin(rt); + if (pq < 0.0) + qt = PI - qt; + } +else + { + pt = pq / sqrt(pp*qq); + qt = acos(pt); + } +return qt; +} diff --git a/libm/double/asin.c b/libm/double/asin.c new file mode 100644 index 000000000..1f83eccc8 --- /dev/null +++ b/libm/double/asin.c @@ -0,0 +1,324 @@ +/* asin.c + * + * Inverse circular sine + * + * + * + * SYNOPSIS: + * + * double x, y, asin(); + * + * y = asin( 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 + * DEC -1, 1 40000 2.6e-17 7.1e-18 + * IEEE -1, 1 10^6 1.9e-16 5.4e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 NAN + * + */ + /* acos() + * + * Inverse circular cosine + * + * + * + * SYNOPSIS: + * + * double x, y, acos(); + * + * y = acos( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between 0 and pi 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 + * DEC -1, 1 50000 3.3e-17 8.2e-18 + * IEEE -1, 1 10^6 2.2e-16 6.5e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asin domain |x| > 1 NAN + */ + +/* asin.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* arcsin(x) = x + x^3 P(x^2)/Q(x^2) + 0 <= x <= 0.625 + Peak relative error = 1.2e-18 */ +#if UNK +static double P[6] = { + 4.253011369004428248960E-3, +-6.019598008014123785661E-1, + 5.444622390564711410273E0, +-1.626247967210700244449E1, + 1.956261983317594739197E1, +-8.198089802484824371615E0, +}; +static double Q[5] = { +/* 1.000000000000000000000E0, */ +-1.474091372988853791896E1, + 7.049610280856842141659E1, +-1.471791292232726029859E2, + 1.395105614657485689735E2, +-4.918853881490881290097E1, +}; +#endif +#if DEC +static short P[24] = { +0036213,0056330,0057244,0053234, +0140032,0015011,0114762,0160255, +0040656,0035130,0136121,0067313, +0141202,0014616,0170474,0101731, +0041234,0100076,0151674,0111310, +0141003,0025540,0033165,0077246, +}; +static short Q[20] = { +/* 0040200,0000000,0000000,0000000, */ +0141153,0155310,0055360,0072530, +0041614,0177001,0027764,0101237, +0142023,0026733,0064653,0133266, +0042013,0101264,0023775,0176351, +0141504,0140420,0050660,0036543, +}; +#endif +#if IBMPC +static short P[24] = { +0x8ad3,0x0bd4,0x6b9b,0x3f71, +0x5c16,0x333e,0x4341,0xbfe3, +0x2dd9,0x178a,0xc74b,0x4015, +0x907b,0xde27,0x4331,0xc030, +0x9259,0xda77,0x9007,0x4033, +0xafd5,0x06ce,0x656c,0xc020, +}; +static short Q[20] = { +/* 0x0000,0x0000,0x0000,0x3ff0, */ +0x0eab,0x0b5e,0x7b59,0xc02d, +0x9054,0x25fe,0x9fc0,0x4051, +0x76d7,0x6d35,0x65bb,0xc062, +0xbf9d,0x84ff,0x7056,0x4061, +0x07ac,0x0a36,0x9822,0xc048, +}; +#endif +#if MIEEE +static short P[24] = { +0x3f71,0x6b9b,0x0bd4,0x8ad3, +0xbfe3,0x4341,0x333e,0x5c16, +0x4015,0xc74b,0x178a,0x2dd9, +0xc030,0x4331,0xde27,0x907b, +0x4033,0x9007,0xda77,0x9259, +0xc020,0x656c,0x06ce,0xafd5, +}; +static short Q[20] = { +/* 0x3ff0,0x0000,0x0000,0x0000, */ +0xc02d,0x7b59,0x0b5e,0x0eab, +0x4051,0x9fc0,0x25fe,0x9054, +0xc062,0x65bb,0x6d35,0x76d7, +0x4061,0x7056,0x84ff,0xbf9d, +0xc048,0x9822,0x0a36,0x07ac, +}; +#endif + +/* arcsin(1-x) = pi/2 - sqrt(2x)(1+R(x)) + 0 <= x <= 0.5 + Peak relative error = 4.2e-18 */ +#if UNK +static double R[5] = { + 2.967721961301243206100E-3, +-5.634242780008963776856E-1, + 6.968710824104713396794E0, +-2.556901049652824852289E1, + 2.853665548261061424989E1, +}; +static double S[4] = { +/* 1.000000000000000000000E0, */ +-2.194779531642920639778E1, + 1.470656354026814941758E2, +-3.838770957603691357202E2, + 3.424398657913078477438E2, +}; +#endif +#if DEC +static short R[20] = { +0036102,0077034,0142164,0174103, +0140020,0036222,0147711,0044173, +0040736,0177655,0153631,0171523, +0141314,0106525,0060015,0055474, +0041344,0045422,0003630,0040344, +}; +static short S[16] = { +/* 0040200,0000000,0000000,0000000, */ +0141257,0112425,0132772,0166136, +0042023,0010315,0075523,0175020, +0142277,0170104,0126203,0017563, +0042253,0034115,0102662,0022757, +}; +#endif +#if IBMPC +static short R[20] = { +0x9f08,0x988e,0x4fc3,0x3f68, +0x290f,0x59f9,0x0792,0xbfe2, +0x3e6a,0xbaf3,0xdff5,0x401b, +0xab68,0xac01,0x91aa,0xc039, +0x081d,0x40f3,0x8962,0x403c, +}; +static short S[16] = { +/* 0x0000,0x0000,0x0000,0x3ff0, */ +0x5d8c,0xb6bf,0xf2a2,0xc035, +0x7f42,0xaf6a,0x6219,0x4062, +0x63ee,0x9590,0xfe08,0xc077, +0x44be,0xb0b6,0x6709,0x4075, +}; +#endif +#if MIEEE +static short R[20] = { +0x3f68,0x4fc3,0x988e,0x9f08, +0xbfe2,0x0792,0x59f9,0x290f, +0x401b,0xdff5,0xbaf3,0x3e6a, +0xc039,0x91aa,0xac01,0xab68, +0x403c,0x8962,0x40f3,0x081d, +}; +static short S[16] = { +/* 0x3ff0,0x0000,0x0000,0x0000, */ +0xc035,0xf2a2,0xb6bf,0x5d8c, +0x4062,0x6219,0xaf6a,0x7f42, +0xc077,0xfe08,0x9590,0x63ee, +0x4075,0x6709,0xb0b6,0x44be, +}; +#endif + +/* pi/2 = PIO2 + MOREBITS. */ +#ifdef DEC +#define MOREBITS 5.721188726109831840122E-18 +#else +#define MOREBITS 6.123233995736765886130E-17 +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double sqrt ( double ); +double asin ( double ); +#else +double sqrt(), polevl(), p1evl(); +double asin(); +#endif +extern double PIO2, PIO4, NAN; + +double asin(x) +double x; +{ +double a, p, z, zz; +short sign; + +if( x > 0 ) + { + sign = 1; + a = x; + } +else + { + sign = -1; + a = -x; + } + +if( a > 1.0 ) + { + mtherr( "asin", DOMAIN ); + return( NAN ); + } + +if( a > 0.625 ) + { + /* arcsin(1-x) = pi/2 - sqrt(2x)(1+R(x)) */ + zz = 1.0 - a; + p = zz * polevl( zz, R, 4)/p1evl( zz, S, 4); + zz = sqrt(zz+zz); + z = PIO4 - zz; + zz = zz * p - MOREBITS; + z = z - zz; + z = z + PIO4; + } +else + { + if( a < 1.0e-8 ) + { + return(x); + } + zz = a * a; + z = zz * polevl( zz, P, 5)/p1evl( zz, Q, 5); + z = a * z + a; + } +if( sign < 0 ) + z = -z; +return(z); +} + + + +double acos(x) +double x; +{ +double z; + +if( (x < -1.0) || (x > 1.0) ) + { + mtherr( "acos", DOMAIN ); + return( NAN ); + } +if( x > 0.5 ) + { + return( 2.0 * asin( sqrt(0.5 - 0.5*x) ) ); + } +z = PIO4 - asin(x); +z = z + MOREBITS; +z = z + PIO4; +return( z ); +} diff --git a/libm/double/asinh.c b/libm/double/asinh.c new file mode 100644 index 000000000..57966d264 --- /dev/null +++ b/libm/double/asinh.c @@ -0,0 +1,165 @@ +/* asinh.c + * + * Inverse hyperbolic sine + * + * + * + * SYNOPSIS: + * + * double x, y, asinh(); + * + * y = asinh( 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 + * DEC -3,3 75000 4.6e-17 1.1e-17 + * IEEE -1,1 30000 3.7e-16 7.8e-17 + * IEEE 1,3 30000 2.5e-16 6.7e-17 + * + */ + +/* asinh.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +static double P[] = { +-4.33231683752342103572E-3, +-5.91750212056387121207E-1, +-4.37390226194356683570E0, +-9.09030533308377316566E0, +-5.56682227230859640450E0 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.28757002067426453537E1, + 4.86042483805291788324E1, + 6.95722521337257608734E1, + 3.34009336338516356383E1 +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0136215,0173033,0110410,0105475, +0140027,0076361,0020056,0164520, +0140613,0173401,0160136,0053142, +0141021,0070744,0000503,0176261, +0140662,0021550,0073106,0133351 +}; +static unsigned short Q[] = { +/* 0040200,0000000,0000000,0000000,*/ +0041116,0001336,0034120,0173054, +0041502,0065300,0013144,0021231, +0041613,0022376,0035516,0153063, +0041405,0115216,0054265,0004557 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x1168,0x7221,0xbec3,0xbf71, +0xdd2a,0x2405,0xef9e,0xbfe2, +0xcacc,0x3c0b,0x7ee0,0xc011, +0x7f96,0x8028,0x2e3c,0xc022, +0xd6dd,0x0ec8,0x446d,0xc016 +}; +static unsigned short Q[] = { +/* 0x0000,0x0000,0x0000,0x3ff0,*/ +0x1ec5,0xc70a,0xc05b,0x4029, +0x8453,0x02cc,0x4d58,0x4048, +0xdac6,0xc769,0x649f,0x4051, +0xa12e,0xcb16,0xb351,0x4040 +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xbf71,0xbec3,0x7221,0x1168, +0xbfe2,0xef9e,0x2405,0xdd2a, +0xc011,0x7ee0,0x3c0b,0xcacc, +0xc022,0x2e3c,0x8028,0x7f96, +0xc016,0x446d,0x0ec8,0xd6dd +}; +static unsigned short Q[] = { +0x4029,0xc05b,0xc70a,0x1ec5, +0x4048,0x4d58,0x02cc,0x8453, +0x4051,0x649f,0xc769,0xdac6, +0x4040,0xb351,0xcb16,0xa12e +}; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double sqrt ( double ); +extern double log ( double ); +#else +double log(), sqrt(), polevl(), p1evl(); +#endif +extern double LOGE2, INFINITY; + +double asinh(xx) +double xx; +{ +double a, z, x; +int sign; + +#ifdef MINUSZERO +if( xx == 0.0 ) + return(xx); +#endif +if( xx < 0.0 ) + { + sign = -1; + x = -xx; + } +else + { + sign = 1; + x = xx; + } + +if( x > 1.0e8 ) + { +#ifdef INFINITIES + if( x == INFINITY ) + return(xx); +#endif + return( sign * (log(x) + LOGE2) ); + } + +z = x * x; +if( x < 0.5 ) + { + a = ( polevl(z, P, 4)/p1evl(z, Q, 4) ) * z; + a = a * x + x; + if( sign < 0 ) + a = -a; + return(a); + } + +a = sqrt( z + 1.0 ); +return( sign * log(x + a) ); +} diff --git a/libm/double/atan.c b/libm/double/atan.c new file mode 100644 index 000000000..f2d50768d --- /dev/null +++ b/libm/double/atan.c @@ -0,0 +1,393 @@ +/* atan.c + * + * Inverse circular tangent + * (arctangent) + * + * + * + * SYNOPSIS: + * + * double x, y, atan(); + * + * y = atan( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose tangent + * is x. + * + * Range reduction is from three intervals into the interval + * from zero to 0.66. The approximant uses a rational + * function of degree 4/5 of the form x + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -10, 10 50000 2.4e-17 8.3e-18 + * IEEE -10, 10 10^6 1.8e-16 5.0e-17 + * + */ + /* atan2() + * + * Quadrant correct inverse circular tangent + * + * + * + * SYNOPSIS: + * + * double x, y, z, atan2(); + * + * z = atan2( 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 10^6 2.5e-16 6.9e-17 + * See atan.c. + * + */ + +/* atan.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +/* arctan(x) = x + x^3 P(x^2)/Q(x^2) + 0 <= x <= 0.66 + Peak relative error = 2.6e-18 */ +#ifdef UNK +static double P[5] = { +-8.750608600031904122785E-1, +-1.615753718733365076637E1, +-7.500855792314704667340E1, +-1.228866684490136173410E2, +-6.485021904942025371773E1, +}; +static double Q[5] = { +/* 1.000000000000000000000E0, */ + 2.485846490142306297962E1, + 1.650270098316988542046E2, + 4.328810604912902668951E2, + 4.853903996359136964868E2, + 1.945506571482613964425E2, +}; + +/* tan( 3*pi/8 ) */ +static double T3P8 = 2.41421356237309504880; +#endif + +#ifdef DEC +static short P[20] = { +0140140,0001775,0007671,0026242, +0141201,0041242,0155534,0001715, +0141626,0002141,0132100,0011625, +0141765,0142771,0064055,0150453, +0141601,0131517,0164507,0062164, +}; +static short Q[20] = { +/* 0040200,0000000,0000000,0000000, */ +0041306,0157042,0154243,0000742, +0042045,0003352,0016707,0150452, +0042330,0070306,0113425,0170730, +0042362,0130770,0116602,0047520, +0042102,0106367,0156753,0013541, +}; + +/* tan( 3*pi/8 ) = 2.41421356237309504880 */ +static unsigned short T3P8A[] = {040432,0101171,0114774,0167462,}; +#define T3P8 *(double *)T3P8A +#endif + +#ifdef IBMPC +static short P[20] = { +0x2594,0xa1f7,0x007f,0xbfec, +0x807a,0x5b6b,0x2854,0xc030, +0x0273,0x3688,0xc08c,0xc052, +0xba25,0x2d05,0xb8bf,0xc05e, +0xec8e,0xfd28,0x3669,0xc050, +}; +static short Q[20] = { +/* 0x0000,0x0000,0x0000,0x3ff0, */ +0x603c,0x5b14,0xdbc4,0x4038, +0xfa25,0x43b8,0xa0dd,0x4064, +0xbe3b,0xd2e2,0x0e18,0x407b, +0x49ea,0x13b0,0x563f,0x407e, +0x62ec,0xfbbd,0x519e,0x4068, +}; + +/* tan( 3*pi/8 ) = 2.41421356237309504880 */ +static unsigned short T3P8A[] = {0x9de6,0x333f,0x504f,0x4003}; +#define T3P8 *(double *)T3P8A +#endif + +#ifdef MIEEE +static short P[20] = { +0xbfec,0x007f,0xa1f7,0x2594, +0xc030,0x2854,0x5b6b,0x807a, +0xc052,0xc08c,0x3688,0x0273, +0xc05e,0xb8bf,0x2d05,0xba25, +0xc050,0x3669,0xfd28,0xec8e, +}; +static short Q[20] = { +/* 0x3ff0,0x0000,0x0000,0x0000, */ +0x4038,0xdbc4,0x5b14,0x603c, +0x4064,0xa0dd,0x43b8,0xfa25, +0x407b,0x0e18,0xd2e2,0xbe3b, +0x407e,0x563f,0x13b0,0x49ea, +0x4068,0x519e,0xfbbd,0x62ec, +}; + +/* tan( 3*pi/8 ) = 2.41421356237309504880 */ +static unsigned short T3P8A[] = { +0x4003,0x504f,0x333f,0x9de6 +}; +#define T3P8 *(double *)T3P8A +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double atan ( double ); +extern double fabs ( double ); +extern int signbit ( double ); +extern int isnan ( double ); +#else +double polevl(), p1evl(), atan(), fabs(); +//int signbit(), isnan(); +#endif +extern double PI, PIO2, PIO4, INFINITY, NEGZERO, MAXNUM; + +/* pi/2 = PIO2 + MOREBITS. */ +#ifdef DEC +#define MOREBITS 5.721188726109831840122E-18 +#else +#define MOREBITS 6.123233995736765886130E-17 +#endif + + +double atan(x) +double x; +{ +double y, z; +short sign, flag; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +#ifdef INFINITIES +if(x == INFINITY) + return(PIO2); +if(x == -INFINITY) + return(-PIO2); +#endif +/* make argument positive and save the sign */ +sign = 1; +if( x < 0.0 ) + { + sign = -1; + x = -x; + } +/* range reduction */ +flag = 0; +if( x > T3P8 ) + { + y = PIO2; + flag = 1; + x = -( 1.0/x ); + } +else if( x <= 0.66 ) + { + y = 0.0; + } +else + { + y = PIO4; + flag = 2; + x = (x-1.0)/(x+1.0); + } +z = x * x; +z = z * polevl( z, P, 4 ) / p1evl( z, Q, 5 ); +z = x * z + x; +if( flag == 2 ) + z += 0.5 * MOREBITS; +else if( flag == 1 ) + z += MOREBITS; +y = y + z; +if( sign < 0 ) + y = -y; +return(y); +} + +/* atan2 */ + +#ifdef ANSIC +double atan2( y, x ) +#else +double atan2( x, y ) +#endif +double x, y; +{ +double z, w; +short code; + +code = 0; + +#ifdef NANS +if( isnan(x) ) + return(x); +if( isnan(y) ) + return(y); +#endif +#ifdef MINUSZERO +if( y == 0.0 ) + { + if( signbit(y) ) + { + if( x > 0.0 ) + z = y; + else if( x < 0.0 ) + z = -PI; + else + { + if( signbit(x) ) + z = -PI; + else + z = y; + } + } + else /* y is +0 */ + { + if( x == 0.0 ) + { + if( signbit(x) ) + z = PI; + else + z = 0.0; + } + else if( x > 0.0 ) + z = 0.0; + else + z = PI; + } + return z; + } +if( x == 0.0 ) + { + if( y > 0.0 ) + z = PIO2; + else + z = -PIO2; + return z; + } +#endif /* MINUSZERO */ +#ifdef INFINITIES +if( x == INFINITY ) + { + if( y == INFINITY ) + z = 0.25 * PI; + else if( y == -INFINITY ) + z = -0.25 * PI; + else if( y < 0.0 ) + z = NEGZERO; + else + z = 0.0; + return z; + } +if( x == -INFINITY ) + { + if( y == INFINITY ) + z = 0.75 * PI; + else if( y <= -INFINITY ) + z = -0.75 * PI; + else if( y >= 0.0 ) + z = PI; + else + z = -PI; + return z; + } +if( y == INFINITY ) + return( PIO2 ); +if( y == -INFINITY ) + return( -PIO2 ); +#endif + +if( x < 0.0 ) + code = 2; +if( y < 0.0 ) + code |= 1; + +#ifdef INFINITIES +if( x == 0.0 ) +#else +if( fabs(x) <= (fabs(y) / MAXNUM) ) +#endif + { + if( code & 1 ) + { +#if ANSIC + return( -PIO2 ); +#else + return( 3.0*PIO2 ); +#endif + } + if( y == 0.0 ) + return( 0.0 ); + return( PIO2 ); + } + +if( y == 0.0 ) + { + if( code & 2 ) + return( PI ); + return( 0.0 ); + } + + +switch( code ) + { +#if ANSIC + default: + case 0: + case 1: w = 0.0; break; + case 2: w = PI; break; + case 3: w = -PI; break; +#else + default: + case 0: w = 0.0; break; + case 1: w = 2.0 * PI; break; + case 2: + case 3: w = PI; break; +#endif + } + +z = w + atan( y/x ); +#ifdef MINUSZERO +if( z == 0.0 && y < 0 ) + z = NEGZERO; +#endif +return( z ); +} diff --git a/libm/double/atanh.c b/libm/double/atanh.c new file mode 100644 index 000000000..7bb742d3d --- /dev/null +++ b/libm/double/atanh.c @@ -0,0 +1,156 @@ +/* atanh.c + * + * Inverse hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * double x, y, atanh(); + * + * y = atanh( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOG to MAXLOG. + * + * 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 + * DEC -1,1 50000 2.4e-17 6.4e-18 + * IEEE -1,1 30000 1.9e-16 5.2e-17 + * + */ + +/* atanh.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright (C) 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { +-8.54074331929669305196E-1, + 1.20426861384072379242E1, +-4.61252884198732692637E1, + 6.54566728676544377376E1, +-3.09092539379866942570E1 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ +-1.95638849376911654834E1, + 1.08938092147140262656E2, +-2.49839401325893582852E2, + 2.52006675691344555838E2, +-9.27277618139601130017E1 +}; +#endif +#ifdef DEC +static unsigned short P[] = { +0140132,0122235,0105775,0130300, +0041100,0127327,0124407,0034722, +0141470,0100113,0115607,0130535, +0041602,0164721,0003257,0013673, +0141367,0043046,0166673,0045750 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0141234,0101326,0015460,0134564, +0041731,0160115,0116451,0032045, +0142171,0153343,0000532,0167226, +0042174,0000665,0077604,0000310, +0141671,0072235,0031114,0074377 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0xb618,0xb17f,0x5493,0xbfeb, +0xe73a,0xf520,0x15da,0x4028, +0xf62c,0x7370,0x1009,0xc047, +0xe2f7,0x20d5,0x5d3a,0x4050, +0x697d,0xddb7,0xe8c4,0xc03e +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x172f,0xc366,0x905a,0xc033, +0x2685,0xb3a5,0x3c09,0x405b, +0x5dd3,0x602b,0x3adc,0xc06f, +0x8019,0xaff0,0x8036,0x406f, +0x8f20,0xa649,0x2e93,0xc057 +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xbfeb,0x5493,0xb17f,0xb618, +0x4028,0x15da,0xf520,0xe73a, +0xc047,0x1009,0x7370,0xf62c, +0x4050,0x5d3a,0x20d5,0xe2f7, +0xc03e,0xe8c4,0xddb7,0x697d +}; +static unsigned short Q[] = { +0xc033,0x905a,0xc366,0x172f, +0x405b,0x3c09,0xb3a5,0x2685, +0xc06f,0x3adc,0x602b,0x5dd3, +0x406f,0x8036,0xaff0,0x8019, +0xc057,0x2e93,0xa649,0x8f20 +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double log ( double x ); +extern double polevl ( double x, void *P, int N ); +extern double p1evl ( double x, void *P, int N ); +#else +double fabs(), log(), polevl(), p1evl(); +#endif +extern double INFINITY, NAN; + +double atanh(x) +double x; +{ +double s, z; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +z = fabs(x); +if( z >= 1.0 ) + { + if( x == 1.0 ) + return( INFINITY ); + if( x == -1.0 ) + return( -INFINITY ); + mtherr( "atanh", DOMAIN ); + return( NAN ); + } + +if( z < 1.0e-7 ) + return(x); + +if( z < 0.5 ) + { + z = x * x; + s = x + x * z * (polevl(z, P, 4) / p1evl(z, Q, 5)); + return(s); + } + +return( 0.5 * log((1.0+x)/(1.0-x)) ); +} diff --git a/libm/double/bdtr.c b/libm/double/bdtr.c new file mode 100644 index 000000000..a268c7a10 --- /dev/null +++ b/libm/double/bdtr.c @@ -0,0 +1,263 @@ +/* bdtr.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtr(); + * + * y = bdtr( 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 (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 4.3e-15 2.6e-16 + * See also incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtr domain k < 0 0.0 + * n < k + * x < 0, x > 1 + */ + /* bdtrc() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtrc(); + * + * y = bdtrc( 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: + * + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 6.7e-15 8.2e-16 + * For p between 0 and .001: + * IEEE 0,100 100000 1.5e-13 2.7e-15 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrc domain x<0, x>1, n<k 0.0 + */ + /* bdtri() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, bdtri(); + * + * p = bdtr( 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: + * + * Tested at random points (a,b,p). + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * For p between 0.001 and 1: + * IEEE 0,100 100000 2.3e-14 6.4e-16 + * IEEE 0,10000 100000 6.6e-12 1.2e-13 + * For p between 10^-6 and 0.001: + * IEEE 0,100 100000 2.0e-12 1.3e-14 + * IEEE 0,10000 100000 1.5e-12 3.2e-14 + * See also incbi.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtri domain k < 0, n <= k 0.0 + * x < 0, x > 1 + */ + +/* bdtr() */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +extern double pow ( double, double ); +extern double log1p ( double ); +extern double expm1 ( double ); +#else +double incbet(), incbi(), pow(), log1p(), expm1(); +#endif + +double bdtrc( k, n, p ) +int k, n; +double p; +{ +double dk, dn; + +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + return( 1.0 ); + +if( n < k ) + { +domerr: + mtherr( "bdtrc", DOMAIN ); + return( 0.0 ); + } + +if( k == n ) + return( 0.0 ); +dn = n - k; +if( k == 0 ) + { + if( p < .01 ) + dk = -expm1( dn * log1p(-p) ); + else + dk = 1.0 - pow( 1.0-p, dn ); + } +else + { + dk = k + 1; + dk = incbet( dk, dn, p ); + } +return( dk ); +} + + + +double bdtr( k, n, p ) +int k, n; +double p; +{ +double dk, dn; + +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( (k < 0) || (n < k) ) + { +domerr: + mtherr( "bdtr", DOMAIN ); + return( 0.0 ); + } + +if( k == n ) + return( 1.0 ); + +dn = n - k; +if( k == 0 ) + { + dk = pow( 1.0-p, dn ); + } +else + { + dk = k + 1; + dk = incbet( dn, dk, 1.0 - p ); + } +return( dk ); +} + + +double bdtri( k, n, y ) +int k, n; +double y; +{ +double dk, dn, p; + +if( (y < 0.0) || (y > 1.0) ) + goto domerr; +if( (k < 0) || (n <= k) ) + { +domerr: + mtherr( "bdtri", DOMAIN ); + return( 0.0 ); + } + +dn = n - k; +if( k == 0 ) + { + if( y > 0.8 ) + p = -expm1( log1p(y-1.0) / dn ); + else + p = 1.0 - pow( y, 1.0/dn ); + } +else + { + dk = k + 1; + p = incbet( dn, dk, 0.5 ); + if( p > 0.5 ) + p = incbi( dk, dn, 1.0-y ); + else + p = 1.0 - incbi( dn, dk, y ); + } +return( p ); +} diff --git a/libm/double/bernum.c b/libm/double/bernum.c new file mode 100644 index 000000000..e401ff5df --- /dev/null +++ b/libm/double/bernum.c @@ -0,0 +1,74 @@ +/* This program computes the Bernoulli numbers. + * See radd.c for rational arithmetic. + */ + +typedef struct{ + double n; + double d; + }fract; + +#define PD 44 +fract x[PD+1] = {0.0}; +fract p[PD+1] = {0.0}; +#include <math.h> +#ifdef ANSIPROT +extern double fabs ( double ); +extern double log10 ( double ); +#else +double fabs(), log10(); +#endif +extern double MACHEP; + +main() +{ +int nx, np, nu; +int i, j, k, n, sign; +fract r, s, t; + + +for(i=0; i<=PD; i++ ) + { + x[i].n = 0.0; + x[i].d = 1.0; + p[i].n = 0.0; + p[i].d = 1.0; + } +p[0].n = 1.0; +p[0].d = 1.0; +p[1].n = 1.0; +p[1].d = 1.0; +np = 1; +x[0].n = 1.0; +x[0].d = 1.0; + +for( n=1; n<PD-2; n++ ) +{ + +/* Create line of Pascal's triangle */ +/* multiply p = u * p */ +for( k=0; k<=np; k++ ) + { + radd( &p[np-k+1], &p[np-k], &p[np-k+1] ); + } +np += 1; + +/* B0 + nC1 B1 + ... + nCn-1 Bn-1 = 0 */ +s.n = 0.0; +s.d = 1.0; + +for( i=0; i<n; i++ ) + { + rmul( &p[i], &x[i], &t ); + radd( &s, &t, &s ); + } + + +rdiv( &p[n], &s, &x[n] ); /* x[n] = -s/p[n] */ +x[n].n = -x[n].n; +nx += 1; +printf( "%2d %.15e / %.15e\n", n, x[n].n, x[n].d ); +} + + +} + diff --git a/libm/double/beta.c b/libm/double/beta.c new file mode 100644 index 000000000..410760f32 --- /dev/null +++ b/libm/double/beta.c @@ -0,0 +1,201 @@ +/* beta.c + * + * Beta function + * + * + * + * SYNOPSIS: + * + * double a, b, y, beta(); + * + * y = beta( a, b ); + * + * + * + * DESCRIPTION: + * + * - - + * | (a) | (b) + * beta( a, b ) = -----------. + * - + * | (a+b) + * + * For large arguments the logarithm of the function is + * evaluated using lgam(), then exponentiated. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 1700 7.7e-15 1.5e-15 + * IEEE 0,30 30000 8.1e-14 1.1e-14 + * + * ERROR MESSAGES: + * + * message condition value returned + * beta overflow log(beta) > MAXLOG 0.0 + * a or b <0 integer 0.0 + * + */ + +/* beta.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> + +#ifdef UNK +#define MAXGAM 34.84425627277176174 +#endif +#ifdef DEC +#define MAXGAM 34.84425627277176174 +#endif +#ifdef IBMPC +#define MAXGAM 171.624376956302725 +#endif +#ifdef MIEEE +#define MAXGAM 171.624376956302725 +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double gamma ( double ); +extern double lgam ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double floor ( double ); +#else +double fabs(), gamma(), lgam(), exp(), log(), floor(); +#endif +extern double MAXLOG, MAXNUM; +extern int sgngam; + +double beta( a, b ) +double a, b; +{ +double y; +int sign; + +sign = 1; + +if( a <= 0.0 ) + { + if( a == floor(a) ) + goto over; + } +if( b <= 0.0 ) + { + if( b == floor(b) ) + goto over; + } + + +y = a + b; +if( fabs(y) > MAXGAM ) + { + y = lgam(y); + sign *= sgngam; /* keep track of the sign */ + y = lgam(b) - y; + sign *= sgngam; + y = lgam(a) + y; + sign *= sgngam; + if( y > MAXLOG ) + { +over: + mtherr( "beta", OVERFLOW ); + return( sign * MAXNUM ); + } + return( sign * exp(y) ); + } + +y = gamma(y); +if( y == 0.0 ) + goto over; + +if( a > b ) + { + y = gamma(a)/y; + y *= gamma(b); + } +else + { + y = gamma(b)/y; + y *= gamma(a); + } + +return(y); +} + + + +/* Natural log of |beta|. Return the sign of beta in sgngam. */ + +double lbeta( a, b ) +double a, b; +{ +double y; +int sign; + +sign = 1; + +if( a <= 0.0 ) + { + if( a == floor(a) ) + goto over; + } +if( b <= 0.0 ) + { + if( b == floor(b) ) + goto over; + } + + +y = a + b; +if( fabs(y) > MAXGAM ) + { + y = lgam(y); + sign *= sgngam; /* keep track of the sign */ + y = lgam(b) - y; + sign *= sgngam; + y = lgam(a) + y; + sign *= sgngam; + sgngam = sign; + return( y ); + } + +y = gamma(y); +if( y == 0.0 ) + { +over: + mtherr( "lbeta", OVERFLOW ); + return( sign * MAXNUM ); + } + +if( a > b ) + { + y = gamma(a)/y; + y *= gamma(b); + } +else + { + y = gamma(b)/y; + y *= gamma(a); + } + +if( y < 0 ) + { + sgngam = -1; + y = -y; + } +else + sgngam = 1; + +return( log(y) ); +} diff --git a/libm/double/btdtr.c b/libm/double/btdtr.c new file mode 100644 index 000000000..633ba7591 --- /dev/null +++ b/libm/double/btdtr.c @@ -0,0 +1,64 @@ + +/* btdtr.c + * + * Beta distribution + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, btdtr(); + * + * y = btdtr( 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 + * + * + * This function is identical to the incomplete beta + * integral function incbet(a, b, x). + * + * The complemented function is + * + * 1 - P(1-x) = incbet( b, a, x ); + * + * + * ACCURACY: + * + * See incbet.c. + * + */ + +/* btdtr() */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ +#include <math.h> +#ifdef ANSIPROT +extern double incbet ( double, double, double ); +#else +double incbet(); +#endif + +double btdtr( a, b, x ) +double a, b, x; +{ + +return( incbet( a, b, x ) ); +} diff --git a/libm/double/cbrt.c b/libm/double/cbrt.c new file mode 100644 index 000000000..026207275 --- /dev/null +++ b/libm/double/cbrt.c @@ -0,0 +1,142 @@ +/* cbrt.c + * + * Cube root + * + * + * + * SYNOPSIS: + * + * double x, y, cbrt(); + * + * y = cbrt( 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 + * DEC -10,10 200000 1.8e-17 6.2e-18 + * IEEE 0,1e308 30000 1.5e-16 5.0e-17 + * + */ + /* cbrt.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1991, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +static double CBRT2 = 1.2599210498948731647672; +static double CBRT4 = 1.5874010519681994747517; +static double CBRT2I = 0.79370052598409973737585; +static double CBRT4I = 0.62996052494743658238361; + +#ifdef ANSIPROT +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double frexp(), ldexp(); +int isnan(), isfinite(); +#endif + +double cbrt(x) +double x; +{ +int e, rem, sign; +double z; + +#ifdef NANS +if( isnan(x) ) + return x; +#endif +#ifdef INFINITIES +if( !isfinite(x) ) + 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 = frexp( x, &e ); + +/* Approximate cube root of number between .5 and 1, + * peak relative error = 9.2e-6 + */ +x = (((-1.3466110473359520655053e-1 * x + + 5.4664601366395524503440e-1) * x + - 9.5438224771509446525043e-1) * x + + 1.1399983354717293273738e0 ) * x + + 4.0238979564544752126924e-1; + +/* 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; + } + + +/* argument less than 1 */ + +else + { + 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 = ldexp( x, e ); + +/* Newton iteration */ +x -= ( x - (z/(x*x)) )*0.33333333333333333333; +#ifdef DEC +x -= ( x - (z/(x*x)) )/3.0; +#else +x -= ( x - (z/(x*x)) )*0.33333333333333333333; +#endif + +if( sign < 0 ) + x = -x; +return(x); +} diff --git a/libm/double/chbevl.c b/libm/double/chbevl.c new file mode 100644 index 000000000..539388164 --- /dev/null +++ b/libm/double/chbevl.c @@ -0,0 +1,82 @@ +/* chbevl.c + * + * Evaluate Chebyshev series + * + * + * + * SYNOPSIS: + * + * int N; + * double x, y, coef[N], chebevl(); + * + * y = chbevl( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates the series + * + * N-1 + * - ' + * y = > coef[i] T (x/2) + * - i + * i=0 + * + * of Chebyshev polynomials Ti at argument x/2. + * + * Coefficients are stored in reverse order, i.e. the zero + * order term is last in the array. Note N is the number of + * coefficients, not the order. + * + * If coefficients are for the interval a to b, x must + * have been transformed to x -> 2(2x - b - a)/(b-a) before + * entering the routine. This maps x from (a, b) to (-1, 1), + * over which the Chebyshev polynomials are defined. + * + * If the coefficients are for the inverted interval, in + * which (a, b) is mapped to (1/b, 1/a), the transformation + * required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity, + * this becomes x -> 4a/x - 1. + * + * + * + * SPEED: + * + * Taking advantage of the recurrence properties of the + * Chebyshev polynomials, the routine requires one more + * addition per loop than evaluating a nested polynomial of + * the same degree. + * + */ + /* chbevl.c */ + +/* +Cephes Math Library Release 2.0: April, 1987 +Copyright 1985, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +double chbevl( x, array, n ) +double x; +double array[]; +int n; +{ +double b0, b1, b2, *p; +int i; + +p = array; +b0 = *p++; +b1 = 0.0; +i = n - 1; + +do + { + b2 = b1; + b1 = b0; + b0 = x * b1 - b2 + *p++; + } +while( --i ); + +return( 0.5*(b0-b2) ); +} diff --git a/libm/double/chdtr.c b/libm/double/chdtr.c new file mode 100644 index 000000000..a29da7535 --- /dev/null +++ b/libm/double/chdtr.c @@ -0,0 +1,200 @@ +/* chdtr.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double df, x, y, chdtr(); + * + * y = chdtr( 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 + */ + /* chdtrc() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double v, x, y, chdtrc(); + * + * y = chdtrc( 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 + */ + /* chdtri() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * double df, x, y, chdtri(); + * + * x = chdtri( 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.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double igamc ( double, double ); +extern double igam ( double, double ); +extern double igami ( double, double ); +#else +double igamc(), igam(), igami(); +#endif + +double chdtrc(df,x) +double df, x; +{ + +if( (x < 0.0) || (df < 1.0) ) + { + mtherr( "chdtrc", DOMAIN ); + return(0.0); + } +return( igamc( df/2.0, x/2.0 ) ); +} + + + +double chdtr(df,x) +double df, x; +{ + +if( (x < 0.0) || (df < 1.0) ) + { + mtherr( "chdtr", DOMAIN ); + return(0.0); + } +return( igam( df/2.0, x/2.0 ) ); +} + + + +double chdtri( df, y ) +double df, y; +{ +double x; + +if( (y < 0.0) || (y > 1.0) || (df < 1.0) ) + { + mtherr( "chdtri", DOMAIN ); + return(0.0); + } + +x = igami( 0.5 * df, y ); +return( 2.0 * x ); +} diff --git a/libm/double/cheby.c b/libm/double/cheby.c new file mode 100644 index 000000000..8da9b350e --- /dev/null +++ b/libm/double/cheby.c @@ -0,0 +1,149 @@ +/* cheby.c + * + * Program to calculate coefficients of the Chebyshev polynomial + * expansion of a given input function. The algorithm computes + * the discrete Fourier cosine transform of the function evaluated + * at unevenly spaced points. Library routine chbevl.c uses the + * coefficients to calculate an approximate value of the original + * function. + * -- S. L. Moshier + */ + +extern double PI; /* 3.14159... */ +extern double PIO2; +double cosi[33] = {0.0,}; /* cosine array for Fourier transform */ +double func[65] = {0.0,}; /* values of the function */ +double cos(), log(), exp(), sqrt(); + +main() +{ +double c, r, s, t, x, y, z, temp; +double low, high, dtemp; +long n; +int i, ii, j, n2, k, rr, invflg; +short *p; +char st[40]; + +low = 0.0; /* low end of approximation interval */ +high = 1.0; /* high end */ +invflg = 0; /* set to 1 if inverted interval, else zero */ +/* Note: inverted interval goes from 1/high to 1/low */ +z = 0.0; +n = 64; /* will find 64 coefficients */ + /* but use only those greater than roundoff error */ +n2 = n/2; +t = n; +t = PI/t; + +/* calculate array of cosines */ +puts("calculating cosines"); +s = 1.0; +cosi[0] = 1.0; +i = 1; +while( i < 32 ) + { + y = cos( s * t ); + cosi[i] = y; + s += 1.0; + ++i; + } +cosi[32] = 0.0; + +/* cheby.c 2 */ + +/* calculate function at special values of the argument */ +puts("calculating function values"); +x = low; +y = high; +if( invflg && (low != 0.0) ) + { /* inverted interval */ + temp = 1.0/x; + x = 1.0/y; + y = temp; + } +r = (x + y)/2.0; +printf( "center %.15E ", r); +s = (y - x)/2.0; +printf( "width %.15E\n", s); +i = 0; +while( i < 65 ) + { + if( i < n2 ) + c = cosi[i]; + else + c = -cosi[64-i]; + temp = r + s * c; +/* if inverted interval, compute function(1/x) */ + if( invflg && (temp != 0.0) ) + temp = 1.0/temp; + + printf( "%.15E ", temp ); + +/* insert call to function routine here: */ +/**********************************/ + + if( temp == 0.0 ) + y = 1.0; + else + y = exp( temp * log(2.0) ); + +/**********************************/ + func[i] = y; + printf( "%.15E\n", y ); + ++i; + } + +/* cheby.c 3 */ + +puts( "calculating Chebyshev coefficients"); +rr = 0; +while( rr < 65 ) + { + z = func[0]/2.0; + j = 1; + while( j < 65 ) + { + k = (rr * j)/n2; + i = rr * j - n2 * k; + k &= 3; + if( k == 0 ) + c = cosi[i]; + if( k == 1 ) + { + i = 32-i; + c = -cosi[i]; + if( i == 32 ) + c = -c; + } + if( k == 2 ) + { + c = -cosi[i]; + } + if( k == 3 ) + { + i = 32-i; + c = cosi[i]; + } + if( i != 32) + { + temp = func[j]; + temp = c * temp; + z += temp; + } + ++j; + } + + if( i != 32 ) + { + temp /= 2.0; + z = z - temp; + } + z *= 2.0; + temp = n; + z /= temp; + dtemp = z; + ++rr; + sprintf( st, "/* %.16E */", dtemp ); + puts( st ); + } +} diff --git a/libm/double/clog.c b/libm/double/clog.c new file mode 100644 index 000000000..70a318a50 --- /dev/null +++ b/libm/double/clog.c @@ -0,0 +1,1043 @@ +/* clog.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clog(); + * cmplx z, w; + * + * clog( &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. + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ +#include <math.h> +#ifdef ANSIPROT +static void cchsh ( double x, double *c, double *s ); +static double redupi ( double x ); +static double ctans ( cmplx *z ); +/* These are supposed to be in some standard place. */ +double fabs (double); +double sqrt (double); +double pow (double, double); +double log (double); +double exp (double); +double atan2 (double, double); +double cosh (double); +double sinh (double); +double asin (double); +double sin (double); +double cos (double); +double cabs (cmplx *); +void cadd ( cmplx *, cmplx *, cmplx * ); +void cmul ( cmplx *, cmplx *, cmplx * ); +void csqrt ( cmplx *, cmplx * ); +static void cchsh ( double, double *, double * ); +static double redupi ( double ); +static double ctans ( cmplx * ); +void clog ( cmplx *, cmplx * ); +void casin ( cmplx *, cmplx * ); +void cacos ( cmplx *, cmplx * ); +void catan ( cmplx *, cmplx * ); +#else +static void cchsh(); +static double redupi(); +static double ctans(); +double cabs(), fabs(), sqrt(), pow(); +double log(), exp(), atan2(), cosh(), sinh(); +double asin(), sin(), cos(); +void cadd(), cmul(), csqrt(); +void clog(), casin(), cacos(), catan(); +#endif + + +extern double MAXNUM, MACHEP, PI, PIO2; + +void clog( z, w ) +register cmplx *z, *w; +{ +double p, rr; + +/*rr = sqrt( z->r * z->r + z->i * z->i );*/ +rr = cabs(z); +p = log(rr); +#if ANSIC +rr = atan2( z->i, z->r ); +#else +rr = atan2( z->r, z->i ); +if( rr > PI ) + rr -= PI + PI; +#endif +w->i = rr; +w->r = p; +} + /* cexp() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexp(); + * cmplx z, w; + * + * cexp( &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 cexp( z, w ) +register cmplx *z, *w; +{ +double r; + +r = exp( z->r ); +w->r = r * cos( z->i ); +w->i = r * sin( z->i ); +} + /* csin() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csin(); + * cmplx z, w; + * + * csin( &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 csin( z, w ) +register cmplx *z, *w; +{ +double ch, sh; + +cchsh( z->i, &ch, &sh ); +w->r = sin( z->r ) * ch; +w->i = cos( z->r ) * sh; +} + + + +/* calculate cosh and sinh */ + +static void cchsh( x, c, s ) +double x, *c, *s; +{ +double e, ei; + +if( fabs(x) <= 0.5 ) + { + *c = cosh(x); + *s = sinh(x); + } +else + { + e = exp(x); + ei = 0.5/e; + e = 0.5 * e; + *s = e - ei; + *c = e + ei; + } +} + + /* ccos() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccos(); + * cmplx z, w; + * + * ccos( &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 ccos( z, w ) +register cmplx *z, *w; +{ +double ch, sh; + +cchsh( z->i, &ch, &sh ); +w->r = cos( z->r ) * ch; +w->i = -sin( z->r ) * sh; +} + /* ctan() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctan(); + * cmplx z, w; + * + * ctan( &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 ctan( z, w ) +register cmplx *z, *w; +{ +double d; + +d = cos( 2.0 * z->r ) + cosh( 2.0 * z->i ); + +if( fabs(d) < 0.25 ) + d = ctans(z); + +if( d == 0.0 ) + { + mtherr( "ctan", OVERFLOW ); + w->r = MAXNUM; + w->i = MAXNUM; + return; + } + +w->r = sin( 2.0 * z->r ) / d; +w->i = sinh( 2.0 * z->i ) / d; +} + /* ccot() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccot(); + * cmplx z, w; + * + * ccot( &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 ccot( z, w ) +register cmplx *z, *w; +{ +double d; + +d = cosh(2.0 * z->i) - cos(2.0 * z->r); + +if( fabs(d) < 0.25 ) + d = ctans(z); + +if( d == 0.0 ) + { + mtherr( "ccot", OVERFLOW ); + w->r = MAXNUM; + w->i = MAXNUM; + return; + } + +w->r = sin( 2.0 * z->r ) / d; +w->i = -sinh( 2.0 * 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 double redupi(x) +double x; +{ +double t; +long i; + +t = x/PI; +if( t >= 0.0 ) + t += 0.5; +else + t -= 0.5; + +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 double ctans(z) +cmplx *z; +{ +double f, x, x2, y, y2, rn, t; +double d; + +x = fabs( 2.0 * z->r ); +y = fabs( 2.0 * z->i ); + +x = redupi(x); + +x = x * x; +y = y * y; +x2 = 1.0; +y2 = 1.0; +f = 1.0; +rn = 0.0; +d = 0.0; +do + { + rn += 1.0; + f *= rn; + rn += 1.0; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 + x2; + t /= f; + d += t; + + rn += 1.0; + f *= rn; + rn += 1.0; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 - x2; + t /= f; + d += t; + } +while( fabs(t/d) > MACHEP ); +return(d); +} + /* casin() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casin(); + * cmplx z, w; + * + * casin( &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 casin( z, w ) +cmplx *z, *w; +{ +static cmplx ca, ct, zz, z2; +double x, y; + +x = z->r; +y = z->i; + +if( y == 0.0 ) + { + if( fabs(x) > 1.0 ) + { + w->r = PIO2; + w->i = 0.0; + mtherr( "casin", DOMAIN ); + } + else + { + w->r = asin(x); + w->i = 0.0; + } + return; + } + +/* Power series expansion */ +/* +b = cabs(z); +if( b < 0.125 ) +{ +z2.r = (x - y) * (x + y); +z2.i = 2.0 * x * y; + +cn = 1.0; +n = 1.0; +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.0; + cn /= n; + n += 1.0; + b = cn/n; + + ct.r *= b; + ct.i *= b; + sum.r += ct.r; + sum.i += ct.i; + b = fabs(ct.r) + fabs(ct.i); + } +while( b > MACHEP ); +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.0 * ca.r * ca.i; + +zz.r = 1.0 - zz.r; +zz.i = -zz.i; +csqrt( &zz, &z2 ); + +cadd( &z2, &ct, &zz ); +clog( &zz, &zz ); +w->r = zz.i; /* mult by 1/i = -i */ +w->i = -zz.r; +return; +} + /* cacos() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacos(); + * cmplx z, w; + * + * cacos( &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 cacos( z, w ) +cmplx *z, *w; +{ + +casin( z, w ); +w->r = PIO2 - w->r; +w->i = -w->i; +} + /* catan() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catan(); + * cmplx z, w; + * + * catan( &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 catan( z, w ) +cmplx *z, *w; +{ +double a, t, x, x2, y; + +x = z->r; +y = z->i; + +if( (x == 0.0) && (y > 1.0) ) + goto ovrf; + +x2 = x * x; +a = 1.0 - x2 - (y * y); +if( a == 0.0 ) + goto ovrf; + +#if ANSIC +t = atan2( 2.0 * x, a )/2.0; +#else +t = atan2( a, 2.0 * x )/2.0; +#endif +w->r = redupi( t ); + +t = y - 1.0; +a = x2 + (t * t); +if( a == 0.0 ) + goto ovrf; + +t = y + 1.0; +a = (x2 + (t * t))/a; +w->i = log(a)/4.0; +return; + +ovrf: +mtherr( "catan", OVERFLOW ); +w->r = MAXNUM; +w->i = MAXNUM; +} + + +/* csinh + * + * Complex hyperbolic sine + * + * + * + * SYNOPSIS: + * + * void csinh(); + * cmplx z, w; + * + * csinh( &z, &w ); + * + * + * DESCRIPTION: + * + * csinh z = (cexp(z) - cexp(-z))/2 + * = sinh x * cos y + i cosh x * sin y . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 3.1e-16 8.2e-17 + * + */ + +void +csinh (z, w) + cmplx *z, *w; +{ + double x, y; + + x = z->r; + y = z->i; + w->r = sinh (x) * cos (y); + w->i = cosh (x) * sin (y); +} + + +/* casinh + * + * Complex inverse hyperbolic sine + * + * + * + * SYNOPSIS: + * + * void casinh(); + * cmplx z, w; + * + * casinh (&z, &w); + * + * + * + * DESCRIPTION: + * + * casinh z = -i casin iz . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 1.8e-14 2.6e-15 + * + */ + +void +casinh (z, w) + cmplx *z, *w; +{ + cmplx u; + + u.r = 0.0; + u.i = 1.0; + cmul( z, &u, &u ); + casin( &u, w ); + u.r = 0.0; + u.i = -1.0; + cmul( &u, w, w ); +} + +/* ccosh + * + * Complex hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * void ccosh(); + * cmplx z, w; + * + * ccosh (&z, &w); + * + * + * + * DESCRIPTION: + * + * ccosh(z) = cosh x cos y + i sinh x sin y . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 2.9e-16 8.1e-17 + * + */ + +void +ccosh (z, w) + cmplx *z, *w; +{ + double x, y; + + x = z->r; + y = z->i; + w->r = cosh (x) * cos (y); + w->i = sinh (x) * sin (y); +} + + +/* cacosh + * + * Complex inverse hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * void cacosh(); + * cmplx z, w; + * + * cacosh (&z, &w); + * + * + * + * DESCRIPTION: + * + * acosh z = i acos z . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 1.6e-14 2.1e-15 + * + */ + +void +cacosh (z, w) + cmplx *z, *w; +{ + cmplx u; + + cacos( z, w ); + u.r = 0.0; + u.i = 1.0; + cmul( &u, w, w ); +} + + +/* ctanh + * + * Complex hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * void ctanh(); + * cmplx z, w; + * + * ctanh (&z, &w); + * + * + * + * DESCRIPTION: + * + * tanh z = (sinh 2x + i sin 2y) / (cosh 2x + cos 2y) . + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 1.7e-14 2.4e-16 + * + */ + +/* 5.253E-02,1.550E+00 1.643E+01,6.553E+00 1.729E-14 21355 */ + +void +ctanh (z, w) + cmplx *z, *w; +{ + double x, y, d; + + x = z->r; + y = z->i; + d = cosh (2.0 * x) + cos (2.0 * y); + w->r = sinh (2.0 * x) / d; + w->i = sin (2.0 * y) / d; + return; +} + + +/* catanh + * + * Complex inverse hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * void catanh(); + * cmplx z, w; + * + * catanh (&z, &w); + * + * + * + * DESCRIPTION: + * + * Inverse tanh, equal to -i catan (iz); + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 2.3e-16 6.2e-17 + * + */ + +void +catanh (z, w) + cmplx *z, *w; +{ + cmplx u; + + u.r = 0.0; + u.i = 1.0; + cmul (z, &u, &u); /* i z */ + catan (&u, w); + u.r = 0.0; + u.i = -1.0; + cmul (&u, w, w); /* -i catan iz */ + return; +} + + +/* cpow + * + * Complex power function + * + * + * + * SYNOPSIS: + * + * void cpow(); + * cmplx a, z, w; + * + * cpow (&a, &z, &w); + * + * + * + * DESCRIPTION: + * + * Raises complex A to the complex Zth power. + * Definition is per AMS55 # 4.2.8, + * analytically equivalent to cpow(a,z) = cexp(z clog(a)). + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 9.4e-15 1.5e-15 + * + */ + + +void +cpow (a, z, w) + cmplx *a, *z, *w; +{ + double x, y, r, theta, absa, arga; + + x = z->r; + y = z->i; + absa = cabs (a); + if (absa == 0.0) + { + w->r = 0.0; + w->i = 0.0; + return; + } + arga = atan2 (a->i, a->r); + r = pow (absa, x); + theta = x * arga; + if (y != 0.0) + { + r = r * exp (-y * arga); + theta = theta + y * log (absa); + } + w->r = r * cos (theta); + w->i = r * sin (theta); + return; +} diff --git a/libm/double/cmplx.c b/libm/double/cmplx.c new file mode 100644 index 000000000..dcd972bea --- /dev/null +++ b/libm/double/cmplx.c @@ -0,0 +1,461 @@ +/* cmplx.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * double r; real part + * double i; imaginary part + * }cmplx; + * + * cmplx *a, *b, *c; + * + * cadd( a, b, c ); c = b + a + * csub( a, b, c ); c = b - a + * cmul( a, b, c ); c = b * a + * cdiv( a, b, c ); c = b / a + * cneg( c ); c = -c + * cmov( 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.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double cabs ( cmplx * ); +extern double sqrt ( double ); +extern double atan2 ( double, double ); +extern double cos ( double ); +extern double sin ( double ); +extern double sqrt ( double ); +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +int isnan ( double ); +void cdiv ( cmplx *, cmplx *, cmplx * ); +void cadd ( cmplx *, cmplx *, cmplx * ); +#else +double fabs(), cabs(), sqrt(), atan2(), cos(), sin(); +double sqrt(), frexp(), ldexp(); +int isnan(); +void cdiv(), cadd(); +#endif + +extern double MAXNUM, MACHEP, PI, PIO2, INFINITY, NAN; +/* +typedef struct + { + double r; + double i; + }cmplx; +*/ +cmplx czero = {0.0, 0.0}; +extern cmplx czero; +cmplx cone = {1.0, 0.0}; +extern cmplx cone; + +/* c = b + a */ + +void cadd( a, b, c ) +register cmplx *a, *b; +cmplx *c; +{ + +c->r = b->r + a->r; +c->i = b->i + a->i; +} + + +/* c = b - a */ + +void csub( a, b, c ) +register cmplx *a, *b; +cmplx *c; +{ + +c->r = b->r - a->r; +c->i = b->i - a->i; +} + +/* c = b * a */ + +void cmul( a, b, c ) +register cmplx *a, *b; +cmplx *c; +{ +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 cdiv( a, b, c ) +register cmplx *a, *b; +cmplx *c; +{ +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.0 ) + { + w = MAXNUM * y; + if( (fabs(p) > w) || (fabs(q) > w) || (y == 0.0) ) + { + c->r = MAXNUM; + c->i = MAXNUM; + mtherr( "cdiv", OVERFLOW ); + return; + } + } +c->r = p/y; +c->i = q/y; +} + + +/* b = a + Caution, a `short' is assumed to be 16 bits wide. */ + +void cmov( a, b ) +void *a, *b; +{ +register short *pa, *pb; +int i; + +pa = (short *) a; +pb = (short *) b; +i = 8; +do + *pb++ = *pa++; +while( --i ); +} + + +void cneg( a ) +register cmplx *a; +{ + +a->r = -a->r; +a->i = -a->i; +} + +/* cabs() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * double cabs(); + * cmplx z; + * 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 + { + double r; + double i; + }cmplx; +*/ + +#ifdef UNK +#define PREC 27 +#define MAXEXP 1024 +#define MINEXP -1077 +#endif +#ifdef DEC +#define PREC 29 +#define MAXEXP 128 +#define MINEXP -128 +#endif +#ifdef IBMPC +#define PREC 27 +#define MAXEXP 1024 +#define MINEXP -1077 +#endif +#ifdef MIEEE +#define PREC 27 +#define MAXEXP 1024 +#define MINEXP -1077 +#endif + + +double cabs( z ) +register cmplx *z; +{ +double x, y, b, re, im; +int ex, ey, e; + +#ifdef INFINITIES +/* Note, cabs(INFINITY,NAN) = INFINITY. */ +if( z->r == INFINITY || z->i == INFINITY + || z->r == -INFINITY || z->i == -INFINITY ) + return( INFINITY ); +#endif + +#ifdef NANS +if( isnan(z->r) ) + return(z->r); +if( isnan(z->i) ) + return(z->i); +#endif + +re = fabs( z->r ); +im = fabs( z->i ); + +if( re == 0.0 ) + return( im ); +if( im == 0.0 ) + return( re ); + +/* Get the exponents of the numbers */ +x = frexp( re, &ex ); +y = frexp( im, &ey ); + +/* Check if one number is tiny compared to the other */ +e = ex - ey; +if( e > PREC ) + return( re ); +if( e < -PREC ) + return( im ); + +/* Find approximate exponent e of the geometric mean. */ +e = (ex + ey) >> 1; + +/* Rescale so mean is about 1 */ +x = ldexp( re, -e ); +y = ldexp( im, -e ); + +/* Hypotenuse of the right triangle */ +b = sqrt( x * x + y * y ); + +/* Compute the exponent of the answer. */ +y = frexp( b, &ey ); +ey = e + ey; + +/* Check it for overflow and underflow. */ +if( ey > MAXEXP ) + { + mtherr( "cabs", OVERFLOW ); + return( INFINITY ); + } +if( ey < MINEXP ) + return(0.0); + +/* Undo the scaling */ +b = ldexp( b, e ); +return( b ); +} + /* csqrt() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrt(); + * cmplx z, w; + * + * csqrt( &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 csqrt( z, w ) +cmplx *z, *w; +{ +cmplx q, s; +double x, y, r, t; + +x = z->r; +y = z->i; + +if( y == 0.0 ) + { + if( x < 0.0 ) + { + w->r = 0.0; + w->i = sqrt(-x); + return; + } + else + { + w->r = sqrt(x); + w->i = 0.0; + return; + } + } + + +if( x == 0.0 ) + { + r = fabs(y); + r = sqrt(0.5*r); + if( y > 0 ) + 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( (fabs(y) < 2.e-4 * fabs(x)) + && (x > 0) ) + { + t = 0.25*y*(y/x); + } +else + { + r = cabs(z); + t = 0.5*(r - x); + } + +r = sqrt(t); +q.i = r; +q.r = y/(2.0*r); +/* Heron iteration in complex arithmetic */ +cdiv( &q, z, &s ); +cadd( &q, &s, w ); +w->r *= 0.5; +w->i *= 0.5; +} + + +double hypot( x, y ) +double x, y; +{ +cmplx z; + +z.r = x; +z.i = y; +return( cabs(&z) ); +} diff --git a/libm/double/coil.c b/libm/double/coil.c new file mode 100644 index 000000000..f7156497c --- /dev/null +++ b/libm/double/coil.c @@ -0,0 +1,63 @@ +/* Program to calculate the inductance of a coil + * + * Reference: E. Jahnke and F. Emde, _Tables of Functions_, + * 4th edition, Dover, 1945, pp 86-89. + */ + +double sin(), cos(), atan(), ellpe(), ellpk(); + +double d; +double l; +double N; + +/* double PI = 3.14159265358979323846; */ +extern double PI; + +main() +{ +double a, f, tana, sina, K, E, m, L, t; + +printf( "Self inductance of circular solenoidal coil\n" ); + +loop: +getnum( "diameter in centimeters", &d ); +if( d < 0.0 ) + exit(0); /* escape gracefully */ +getnum( "length in centimeters", &l ); +if( d < 0.0 ) + exit(0); +getnum( "total number of turns", &N ); +if( d < 0.0 ) + exit(0); +tana = d/l; /* form factor */ +a = atan( tana ); +sina = sin(a); /* modulus of the elliptic functions (k) */ +m = cos(a); /* subroutine argument = 1 - k^2 */ +m = m * m; +K = ellpk(m); +E = ellpe(m); +tana = tana * tana; /* square of tan(a) */ + +f = ((K + (tana - 1.0) * E)/sina - tana)/3.0; +L = 4.e-9 * PI * N * N * d * f; +printf( "L = %.4e Henries\n", L ); +goto loop; +} + + +/* Get value entered on keyboard + */ +getnum( str, pd ) +char *str; +double *pd; +{ +char s[40]; + +printf( "%s (%.10e) ? ", str, *pd ); +gets(s); +if( s[0] != '\0' ) + { + sscanf( s, "%lf", pd ); + printf( "%.10e\n", *pd ); + } +} diff --git a/libm/double/const.c b/libm/double/const.c new file mode 100644 index 000000000..de4451497 --- /dev/null +++ b/libm/double/const.c @@ -0,0 +1,252 @@ +/* const.c + * + * Globally declared constants + * + * + * + * SYNOPSIS: + * + * extern double nameofconstant; + * + * + * + * + * DESCRIPTION: + * + * This file contains a number of mathematical constants and + * also some needed size parameters of the computer arithmetic. + * The values are supplied as arrays of hexadecimal integers + * for IEEE arithmetic; arrays of octal constants for DEC + * arithmetic; and in a normal decimal scientific notation for + * other machines. The particular notation used is determined + * by a symbol (DEC, IBMPC, or UNK) defined in the include file + * math.h. + * + * The default size parameters are as follows. + * + * For DEC and UNK modes: + * MACHEP = 1.38777878078144567553E-17 2**-56 + * MAXLOG = 8.8029691931113054295988E1 log(2**127) + * MINLOG = -8.872283911167299960540E1 log(2**-128) + * MAXNUM = 1.701411834604692317316873e38 2**127 + * + * For IEEE arithmetic (IBMPC): + * MACHEP = 1.11022302462515654042E-16 2**-53 + * MAXLOG = 7.09782712893383996843E2 log(2**1024) + * MINLOG = -7.08396418532264106224E2 log(2**-1022) + * MAXNUM = 1.7976931348623158E308 2**1024 + * + * The global symbols for mathematical constants are + * PI = 3.14159265358979323846 pi + * PIO2 = 1.57079632679489661923 pi/2 + * PIO4 = 7.85398163397448309616E-1 pi/4 + * SQRT2 = 1.41421356237309504880 sqrt(2) + * SQRTH = 7.07106781186547524401E-1 sqrt(2)/2 + * LOG2E = 1.4426950408889634073599 1/log(2) + * SQ2OPI = 7.9788456080286535587989E-1 sqrt( 2/pi ) + * LOGE2 = 6.93147180559945309417E-1 log(2) + * LOGSQ2 = 3.46573590279972654709E-1 log(2)/2 + * THPIO4 = 2.35619449019234492885 3*pi/4 + * TWOOPI = 6.36619772367581343075535E-1 2/pi + * + * These lists are subject to change. + */ + +/* const.c */ + +/* +Cephes Math Library Release 2.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +#if 1 +double MACHEP = 1.11022302462515654042E-16; /* 2**-53 */ +#else +double MACHEP = 1.38777878078144567553E-17; /* 2**-56 */ +#endif +double UFLOWTHRESH = 2.22507385850720138309E-308; /* 2**-1022 */ +#ifdef DENORMAL +double MAXLOG = 7.09782712893383996732E2; /* log(MAXNUM) */ +/* double MINLOG = -7.44440071921381262314E2; */ /* log(2**-1074) */ +double MINLOG = -7.451332191019412076235E2; /* log(2**-1075) */ +#else +double MAXLOG = 7.08396418532264106224E2; /* log 2**1022 */ +double MINLOG = -7.08396418532264106224E2; /* log 2**-1022 */ +#endif +double MAXNUM = 1.79769313486231570815E308; /* 2**1024*(1-MACHEP) */ +double PI = 3.14159265358979323846; /* pi */ +double PIO2 = 1.57079632679489661923; /* pi/2 */ +double PIO4 = 7.85398163397448309616E-1; /* pi/4 */ +double SQRT2 = 1.41421356237309504880; /* sqrt(2) */ +double SQRTH = 7.07106781186547524401E-1; /* sqrt(2)/2 */ +double LOG2E = 1.4426950408889634073599; /* 1/log(2) */ +double SQ2OPI = 7.9788456080286535587989E-1; /* sqrt( 2/pi ) */ +double LOGE2 = 6.93147180559945309417E-1; /* log(2) */ +double LOGSQ2 = 3.46573590279972654709E-1; /* log(2)/2 */ +double THPIO4 = 2.35619449019234492885; /* 3*pi/4 */ +double TWOOPI = 6.36619772367581343075535E-1; /* 2/pi */ +#ifdef INFINITIES +double INFINITY = 1.0/0.0; /* 99e999; */ +#else +double INFINITY = 1.79769313486231570815E308; /* 2**1024*(1-MACHEP) */ +#endif +#ifdef NANS +double NAN = 1.0/0.0 - 1.0/0.0; +#else +double NAN = 0.0; +#endif +#ifdef MINUSZERO +double NEGZERO = -0.0; +#else +double NEGZERO = 0.0; +#endif +#endif + +#ifdef IBMPC + /* 2**-53 = 1.11022302462515654042E-16 */ +unsigned short MACHEP[4] = {0x0000,0x0000,0x0000,0x3ca0}; +unsigned short UFLOWTHRESH[4] = {0x0000,0x0000,0x0000,0x0010}; +#ifdef DENORMAL + /* log(MAXNUM) = 7.09782712893383996732224E2 */ +unsigned short MAXLOG[4] = {0x39ef,0xfefa,0x2e42,0x4086}; + /* log(2**-1074) = - -7.44440071921381262314E2 */ +/*unsigned short MINLOG[4] = {0x71c3,0x446d,0x4385,0xc087};*/ +unsigned short MINLOG[4] = {0x3052,0xd52d,0x4910,0xc087}; +#else + /* log(2**1022) = 7.08396418532264106224E2 */ +unsigned short MAXLOG[4] = {0xbcd2,0xdd7a,0x232b,0x4086}; + /* log(2**-1022) = - 7.08396418532264106224E2 */ +unsigned short MINLOG[4] = {0xbcd2,0xdd7a,0x232b,0xc086}; +#endif + /* 2**1024*(1-MACHEP) = 1.7976931348623158E308 */ +unsigned short MAXNUM[4] = {0xffff,0xffff,0xffff,0x7fef}; +unsigned short PI[4] = {0x2d18,0x5444,0x21fb,0x4009}; +unsigned short PIO2[4] = {0x2d18,0x5444,0x21fb,0x3ff9}; +unsigned short PIO4[4] = {0x2d18,0x5444,0x21fb,0x3fe9}; +unsigned short SQRT2[4] = {0x3bcd,0x667f,0xa09e,0x3ff6}; +unsigned short SQRTH[4] = {0x3bcd,0x667f,0xa09e,0x3fe6}; +unsigned short LOG2E[4] = {0x82fe,0x652b,0x1547,0x3ff7}; +unsigned short SQ2OPI[4] = {0x3651,0x33d4,0x8845,0x3fe9}; +unsigned short LOGE2[4] = {0x39ef,0xfefa,0x2e42,0x3fe6}; +unsigned short LOGSQ2[4] = {0x39ef,0xfefa,0x2e42,0x3fd6}; +unsigned short THPIO4[4] = {0x21d2,0x7f33,0xd97c,0x4002}; +unsigned short TWOOPI[4] = {0xc883,0x6dc9,0x5f30,0x3fe4}; +#ifdef INFINITIES +unsigned short INFINITY[4] = {0x0000,0x0000,0x0000,0x7ff0}; +#else +unsigned short INFINITY[4] = {0xffff,0xffff,0xffff,0x7fef}; +#endif +#ifdef NANS +unsigned short NAN[4] = {0x0000,0x0000,0x0000,0x7ffc}; +#else +unsigned short NAN[4] = {0x0000,0x0000,0x0000,0x0000}; +#endif +#ifdef MINUSZERO +unsigned short NEGZERO[4] = {0x0000,0x0000,0x0000,0x8000}; +#else +unsigned short NEGZERO[4] = {0x0000,0x0000,0x0000,0x0000}; +#endif +#endif + +#ifdef MIEEE + /* 2**-53 = 1.11022302462515654042E-16 */ +unsigned short MACHEP[4] = {0x3ca0,0x0000,0x0000,0x0000}; +unsigned short UFLOWTHRESH[4] = {0x0010,0x0000,0x0000,0x0000}; +#ifdef DENORMAL + /* log(2**1024) = 7.09782712893383996843E2 */ +unsigned short MAXLOG[4] = {0x4086,0x2e42,0xfefa,0x39ef}; + /* log(2**-1074) = - -7.44440071921381262314E2 */ +/* unsigned short MINLOG[4] = {0xc087,0x4385,0x446d,0x71c3}; */ +unsigned short MINLOG[4] = {0xc087,0x4910,0xd52d,0x3052}; +#else + /* log(2**1022) = 7.08396418532264106224E2 */ +unsigned short MAXLOG[4] = {0x4086,0x232b,0xdd7a,0xbcd2}; + /* log(2**-1022) = - 7.08396418532264106224E2 */ +unsigned short MINLOG[4] = {0xc086,0x232b,0xdd7a,0xbcd2}; +#endif + /* 2**1024*(1-MACHEP) = 1.7976931348623158E308 */ +unsigned short MAXNUM[4] = {0x7fef,0xffff,0xffff,0xffff}; +unsigned short PI[4] = {0x4009,0x21fb,0x5444,0x2d18}; +unsigned short PIO2[4] = {0x3ff9,0x21fb,0x5444,0x2d18}; +unsigned short PIO4[4] = {0x3fe9,0x21fb,0x5444,0x2d18}; +unsigned short SQRT2[4] = {0x3ff6,0xa09e,0x667f,0x3bcd}; +unsigned short SQRTH[4] = {0x3fe6,0xa09e,0x667f,0x3bcd}; +unsigned short LOG2E[4] = {0x3ff7,0x1547,0x652b,0x82fe}; +unsigned short SQ2OPI[4] = {0x3fe9,0x8845,0x33d4,0x3651}; +unsigned short LOGE2[4] = {0x3fe6,0x2e42,0xfefa,0x39ef}; +unsigned short LOGSQ2[4] = {0x3fd6,0x2e42,0xfefa,0x39ef}; +unsigned short THPIO4[4] = {0x4002,0xd97c,0x7f33,0x21d2}; +unsigned short TWOOPI[4] = {0x3fe4,0x5f30,0x6dc9,0xc883}; +#ifdef INFINITIES +unsigned short INFINITY[4] = {0x7ff0,0x0000,0x0000,0x0000}; +#else +unsigned short INFINITY[4] = {0x7fef,0xffff,0xffff,0xffff}; +#endif +#ifdef NANS +unsigned short NAN[4] = {0x7ff8,0x0000,0x0000,0x0000}; +#else +unsigned short NAN[4] = {0x0000,0x0000,0x0000,0x0000}; +#endif +#ifdef MINUSZERO +unsigned short NEGZERO[4] = {0x8000,0x0000,0x0000,0x0000}; +#else +unsigned short NEGZERO[4] = {0x0000,0x0000,0x0000,0x0000}; +#endif +#endif + +#ifdef DEC + /* 2**-56 = 1.38777878078144567553E-17 */ +unsigned short MACHEP[4] = {0022200,0000000,0000000,0000000}; +unsigned short UFLOWTHRESH[4] = {0x0080,0x0000,0x0000,0x0000}; + /* log 2**127 = 88.029691931113054295988 */ +unsigned short MAXLOG[4] = {041660,007463,0143742,025733,}; + /* log 2**-128 = -88.72283911167299960540 */ +unsigned short MINLOG[4] = {0141661,071027,0173721,0147572,}; + /* 2**127 = 1.701411834604692317316873e38 */ +unsigned short MAXNUM[4] = {077777,0177777,0177777,0177777,}; +unsigned short PI[4] = {040511,007732,0121041,064302,}; +unsigned short PIO2[4] = {040311,007732,0121041,064302,}; +unsigned short PIO4[4] = {040111,007732,0121041,064302,}; +unsigned short SQRT2[4] = {040265,002363,031771,0157145,}; +unsigned short SQRTH[4] = {040065,002363,031771,0157144,}; +unsigned short LOG2E[4] = {040270,0125073,024534,013761,}; +unsigned short SQ2OPI[4] = {040114,041051,0117241,0131204,}; +unsigned short LOGE2[4] = {040061,071027,0173721,0147572,}; +unsigned short LOGSQ2[4] = {037661,071027,0173721,0147572,}; +unsigned short THPIO4[4] = {040426,0145743,0174631,007222,}; +unsigned short TWOOPI[4] = {040042,0174603,067116,042025,}; +/* Approximate infinity by MAXNUM. */ +unsigned short INFINITY[4] = {077777,0177777,0177777,0177777,}; +unsigned short NAN[4] = {0000000,0000000,0000000,0000000}; +#ifdef MINUSZERO +unsigned short NEGZERO[4] = {0000000,0000000,0000000,0100000}; +#else +unsigned short NEGZERO[4] = {0000000,0000000,0000000,0000000}; +#endif +#endif + +#ifndef UNK +extern unsigned short MACHEP[]; +extern unsigned short UFLOWTHRESH[]; +extern unsigned short MAXLOG[]; +extern unsigned short UNDLOG[]; +extern unsigned short MINLOG[]; +extern unsigned short MAXNUM[]; +extern unsigned short PI[]; +extern unsigned short PIO2[]; +extern unsigned short PIO4[]; +extern unsigned short SQRT2[]; +extern unsigned short SQRTH[]; +extern unsigned short LOG2E[]; +extern unsigned short SQ2OPI[]; +extern unsigned short LOGE2[]; +extern unsigned short LOGSQ2[]; +extern unsigned short THPIO4[]; +extern unsigned short TWOOPI[]; +extern unsigned short INFINITY[]; +extern unsigned short NAN[]; +extern unsigned short NEGZERO[]; +#endif diff --git a/libm/double/cosh.c b/libm/double/cosh.c new file mode 100644 index 000000000..77a70da3e --- /dev/null +++ b/libm/double/cosh.c @@ -0,0 +1,83 @@ +/* cosh.c + * + * Hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * double x, y, cosh(); + * + * y = cosh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOG to + * MAXLOG. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +- 88 50000 4.0e-17 7.7e-18 + * IEEE +-MAXLOG 30000 2.6e-16 5.7e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cosh overflow |x| > MAXLOG MAXNUM + * + * + */ + +/* cosh.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double exp ( double ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double exp(); +int isnan(), isfinite(); +#endif +extern double MAXLOG, INFINITY, LOGE2; + +double cosh(x) +double x; +{ +double y; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +if( x < 0 ) + x = -x; +if( x > (MAXLOG + LOGE2) ) + { + mtherr( "cosh", OVERFLOW ); + return( INFINITY ); + } +if( x >= (MAXLOG - LOGE2) ) + { + y = exp(0.5 * x); + y = (0.5 * y) * y; + return(y); + } +y = exp(x); +y = 0.5 * (y + 1.0 / y); +return( y ); +} diff --git a/libm/double/cpmul.c b/libm/double/cpmul.c new file mode 100644 index 000000000..3880ac5a1 --- /dev/null +++ b/libm/double/cpmul.c @@ -0,0 +1,104 @@ +/* cpmul.c + * + * Multiply two polynomials with complex coefficients + * + * + * + * SYNOPSIS: + * + * typedef struct + * { + * double r; + * double i; + * }cmplx; + * + * cmplx a[], b[], c[]; + * int da, db, dc; + * + * cpmul( a, da, b, db, c, &dc ); + * + * + * + * DESCRIPTION: + * + * The two argument polynomials are multiplied together, and + * their product is placed in c. + * + * Each polynomial is represented by its coefficients stored + * as an array of complex number structures (see the typedef). + * The degree of a is da, which must be passed to the routine + * as an argument; similarly the degree db of b is an argument. + * Array a has da + 1 elements and array b has db + 1 elements. + * Array c must have storage allocated for at least da + db + 1 + * elements. The value da + db is returned in dc; this is + * the degree of the product polynomial. + * + * Polynomial coefficients are stored in ascending order; i.e., + * a(x) = a[0]*x**0 + a[1]*x**1 + ... + a[da]*x**da. + * + * + * If desired, c may be the same as either a or b, in which + * case the input argument array is replaced by the product + * array (but only up to terms of degree da + db). + * + */ + +/* cpmul */ + +typedef struct + { + double r; + double i; + }cmplx; + +int cpmul( a, da, b, db, c, dc ) +cmplx *a, *b, *c; +int da, db; +int *dc; +{ +int i, j, k; +cmplx y; +register cmplx *pa, *pb, *pc; + +if( da > db ) /* Know which polynomial has higher degree */ + { + i = da; /* Swapping is OK because args are on the stack */ + da = db; + db = i; + pa = a; + a = b; + b = pa; + } + +k = da + db; +*dc = k; /* Output the degree of the product */ +pc = &c[db+1]; +for( i=db+1; i<=k; i++ ) /* Clear high order terms of output */ + { + pc->r = 0; + pc->i = 0; + pc++; + } +/* To permit replacement of input, work backward from highest degree */ +pb = &b[db]; +for( j=0; j<=db; j++ ) + { + pa = &a[da]; + pc = &c[k-j]; + for( i=0; i<da; i++ ) + { + y.r = pa->r * pb->r - pa->i * pb->i; /* cmpx multiply */ + y.i = pa->r * pb->i + pa->i * pb->r; + pc->r += y.r; /* accumulate partial product */ + pc->i += y.i; + pa--; + pc--; + } + y.r = pa->r * pb->r - pa->i * pb->i; /* replace last term, */ + y.i = pa->r * pb->i + pa->i * pb->r; /* ...do not accumulate */ + pc->r = y.r; + pc->i = y.i; + pb--; + } + return 0; +} diff --git a/libm/double/dawsn.c b/libm/double/dawsn.c new file mode 100644 index 000000000..4f8d27a0c --- /dev/null +++ b/libm/double/dawsn.c @@ -0,0 +1,392 @@ +/* dawsn.c + * + * Dawson's Integral + * + * + * + * SYNOPSIS: + * + * double x, y, dawsn(); + * + * y = dawsn( x ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * x + * - + * 2 | | 2 + * dawsn(x) = exp( -x ) | exp( t ) dt + * | | + * - + * 0 + * + * Three different rational approximations are employed, for + * the intervals 0 to 3.25; 3.25 to 6.25; and 6.25 up. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 10000 6.9e-16 1.0e-16 + * DEC 0,10 6000 7.4e-17 1.4e-17 + * + * + */ + +/* dawsn.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +/* Dawson's integral, interval 0 to 3.25 */ +#ifdef UNK +static double AN[10] = { + 1.13681498971755972054E-11, + 8.49262267667473811108E-10, + 1.94434204175553054283E-8, + 9.53151741254484363489E-7, + 3.07828309874913200438E-6, + 3.52513368520288738649E-4, +-8.50149846724410912031E-4, + 4.22618223005546594270E-2, +-9.17480371773452345351E-2, + 9.99999999999999994612E-1, +}; +static double AD[11] = { + 2.40372073066762605484E-11, + 1.48864681368493396752E-9, + 5.21265281010541664570E-8, + 1.27258478273186970203E-6, + 2.32490249820789513991E-5, + 3.25524741826057911661E-4, + 3.48805814657162590916E-3, + 2.79448531198828973716E-2, + 1.58874241960120565368E-1, + 5.74918629489320327824E-1, + 1.00000000000000000539E0, +}; +#endif +#ifdef DEC +static unsigned short AN[40] = { +0027107,0176630,0075752,0107612, +0030551,0070604,0166707,0127727, +0031647,0002210,0117120,0056376, +0033177,0156026,0141275,0140627, +0033516,0112200,0037035,0165515, +0035270,0150613,0016423,0105634, +0135536,0156227,0023515,0044413, +0037055,0015273,0105147,0064025, +0137273,0163145,0014460,0166465, +0040200,0000000,0000000,0000000, +}; +static unsigned short AD[44] = { +0027323,0067372,0115566,0131320, +0030714,0114432,0074206,0006637, +0032137,0160671,0044203,0026344, +0033252,0146656,0020247,0100231, +0034303,0003346,0123260,0022433, +0035252,0125460,0173041,0155415, +0036144,0113747,0125203,0124617, +0036744,0166232,0143671,0133670, +0037442,0127755,0162625,0000100, +0040023,0026736,0003604,0106265, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short AN[40] = { +0x51f1,0x0f7d,0xffb3,0x3da8, +0xf5fb,0x9db8,0x2e30,0x3e0d, +0x0ba0,0x13ca,0xe091,0x3e54, +0xb833,0xd857,0xfb82,0x3eaf, +0xbd6a,0x07c3,0xd290,0x3ec9, +0x7174,0x63a2,0x1a31,0x3f37, +0xa921,0xe4e9,0xdb92,0xbf4b, +0xed03,0x714c,0xa357,0x3fa5, +0x1da7,0xa326,0x7ccc,0xbfb7, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short AD[44] = { +0xd65a,0x536e,0x6ddf,0x3dba, +0xc1b4,0x4f10,0x9323,0x3e19, +0x659c,0x2910,0xfc37,0x3e6b, +0xf013,0xc414,0x59b5,0x3eb5, +0x04a3,0xd4d6,0x60dc,0x3ef8, +0x3b62,0x1ec4,0x5566,0x3f35, +0x7532,0xf550,0x92fc,0x3f6c, +0x36f7,0x58f7,0x9d93,0x3f9c, +0xa008,0xbcb2,0x55fd,0x3fc4, +0x9197,0xc0f0,0x65bb,0x3fe2, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short AN[40] = { +0x3da8,0xffb3,0x0f7d,0x51f1, +0x3e0d,0x2e30,0x9db8,0xf5fb, +0x3e54,0xe091,0x13ca,0x0ba0, +0x3eaf,0xfb82,0xd857,0xb833, +0x3ec9,0xd290,0x07c3,0xbd6a, +0x3f37,0x1a31,0x63a2,0x7174, +0xbf4b,0xdb92,0xe4e9,0xa921, +0x3fa5,0xa357,0x714c,0xed03, +0xbfb7,0x7ccc,0xa326,0x1da7, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short AD[44] = { +0x3dba,0x6ddf,0x536e,0xd65a, +0x3e19,0x9323,0x4f10,0xc1b4, +0x3e6b,0xfc37,0x2910,0x659c, +0x3eb5,0x59b5,0xc414,0xf013, +0x3ef8,0x60dc,0xd4d6,0x04a3, +0x3f35,0x5566,0x1ec4,0x3b62, +0x3f6c,0x92fc,0xf550,0x7532, +0x3f9c,0x9d93,0x58f7,0x36f7, +0x3fc4,0x55fd,0xbcb2,0xa008, +0x3fe2,0x65bb,0xc0f0,0x9197, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +/* interval 3.25 to 6.25 */ +#ifdef UNK +static double BN[11] = { + 5.08955156417900903354E-1, +-2.44754418142697847934E-1, + 9.41512335303534411857E-2, +-2.18711255142039025206E-2, + 3.66207612329569181322E-3, +-4.23209114460388756528E-4, + 3.59641304793896631888E-5, +-2.14640351719968974225E-6, + 9.10010780076391431042E-8, +-2.40274520828250956942E-9, + 3.59233385440928410398E-11, +}; +static double BD[10] = { +/* 1.00000000000000000000E0,*/ +-6.31839869873368190192E-1, + 2.36706788228248691528E-1, +-5.31806367003223277662E-2, + 8.48041718586295374409E-3, +-9.47996768486665330168E-4, + 7.81025592944552338085E-5, +-4.55875153252442634831E-6, + 1.89100358111421846170E-7, +-4.91324691331920606875E-9, + 7.18466403235734541950E-11, +}; +#endif +#ifdef DEC +static unsigned short BN[44] = { +0040002,0045342,0113762,0004360, +0137572,0120346,0172745,0144046, +0037300,0151134,0123440,0117047, +0136663,0025423,0014755,0046026, +0036157,0177561,0027535,0046744, +0135335,0161052,0071243,0146535, +0034426,0154060,0164506,0135625, +0133420,0005356,0100017,0151334, +0032303,0066137,0024013,0046212, +0131045,0016612,0066270,0047574, +0027435,0177025,0060625,0116363, +}; +static unsigned short BD[40] = { +/*0040200,0000000,0000000,0000000,*/ +0140041,0140101,0174552,0037073, +0037562,0061503,0124271,0160756, +0137131,0151760,0073210,0110534, +0036412,0170562,0117017,0155377, +0135570,0101374,0074056,0037276, +0034643,0145376,0001516,0060636, +0133630,0173540,0121344,0155231, +0032513,0005602,0134516,0007144, +0131250,0150540,0075747,0105341, +0027635,0177020,0012465,0125402, +}; +#endif +#ifdef IBMPC +static unsigned short BN[44] = { +0x411e,0x52fe,0x495c,0x3fe0, +0xb905,0xdebc,0x541c,0xbfcf, +0x13c5,0x94e4,0x1a4b,0x3fb8, +0xa983,0x633d,0x6562,0xbf96, +0xa9bd,0x25eb,0xffee,0x3f6d, +0x79ac,0x4e54,0xbc45,0xbf3b, +0xd773,0x1d28,0xdb06,0x3f02, +0xfa5b,0xd001,0x015d,0xbec2, +0x6991,0xe501,0x6d8b,0x3e78, +0x09f0,0x4d97,0xa3b1,0xbe24, +0xb39e,0xac32,0xbfc2,0x3dc3, +}; +static unsigned short BD[40] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x47c7,0x3f2d,0x3808,0xbfe4, +0x3c3e,0x7517,0x4c68,0x3fce, +0x122b,0x0ed1,0x3a7e,0xbfab, +0xfb60,0x53c1,0x5e2e,0x3f81, +0xc7d8,0x8f05,0x105f,0xbf4f, +0xcc34,0xc069,0x795f,0x3f14, +0x9b53,0x145c,0x1eec,0xbed3, +0xc1cd,0x5729,0x6170,0x3e89, +0xf15c,0x0f7c,0x1a2c,0xbe35, +0xb560,0x02a6,0xbfc2,0x3dd3, +}; +#endif +#ifdef MIEEE +static unsigned short BN[44] = { +0x3fe0,0x495c,0x52fe,0x411e, +0xbfcf,0x541c,0xdebc,0xb905, +0x3fb8,0x1a4b,0x94e4,0x13c5, +0xbf96,0x6562,0x633d,0xa983, +0x3f6d,0xffee,0x25eb,0xa9bd, +0xbf3b,0xbc45,0x4e54,0x79ac, +0x3f02,0xdb06,0x1d28,0xd773, +0xbec2,0x015d,0xd001,0xfa5b, +0x3e78,0x6d8b,0xe501,0x6991, +0xbe24,0xa3b1,0x4d97,0x09f0, +0x3dc3,0xbfc2,0xac32,0xb39e, +}; +static unsigned short BD[40] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xbfe4,0x3808,0x3f2d,0x47c7, +0x3fce,0x4c68,0x7517,0x3c3e, +0xbfab,0x3a7e,0x0ed1,0x122b, +0x3f81,0x5e2e,0x53c1,0xfb60, +0xbf4f,0x105f,0x8f05,0xc7d8, +0x3f14,0x795f,0xc069,0xcc34, +0xbed3,0x1eec,0x145c,0x9b53, +0x3e89,0x6170,0x5729,0xc1cd, +0xbe35,0x1a2c,0x0f7c,0xf15c, +0x3dd3,0xbfc2,0x02a6,0xb560, +}; +#endif + +/* 6.25 to infinity */ +#ifdef UNK +static double CN[5] = { +-5.90592860534773254987E-1, + 6.29235242724368800674E-1, +-1.72858975380388136411E-1, + 1.64837047825189632310E-2, +-4.86827613020462700845E-4, +}; +static double CD[5] = { +/* 1.00000000000000000000E0,*/ +-2.69820057197544900361E0, + 1.73270799045947845857E0, +-3.93708582281939493482E-1, + 3.44278924041233391079E-2, +-9.73655226040941223894E-4, +}; +#endif +#ifdef DEC +static unsigned short CN[20] = { +0140027,0030427,0176477,0074402, +0040041,0012617,0112375,0162657, +0137461,0000761,0074120,0135160, +0036607,0004325,0117246,0115525, +0135377,0036345,0064750,0047732, +}; +static unsigned short CD[20] = { +/*0040200,0000000,0000000,0000000,*/ +0140454,0127521,0071653,0133415, +0040335,0144540,0016105,0045241, +0137711,0112053,0155034,0062237, +0037015,0002102,0177442,0074546, +0135577,0036345,0064750,0052152, +}; +#endif +#ifdef IBMPC +static unsigned short CN[20] = { +0xef20,0xffa7,0xe622,0xbfe2, +0xbcb6,0xf29f,0x22b1,0x3fe4, +0x174e,0x2f0a,0x203e,0xbfc6, +0xd36b,0xb3d4,0xe11a,0x3f90, +0x09fb,0xad3d,0xe79c,0xbf3f, +}; +static unsigned short CD[20] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x76e2,0x2e75,0x95ea,0xc005, +0xa954,0x0388,0xb92c,0x3ffb, +0x8c94,0x7b43,0x3285,0xbfd9, +0x4f2d,0x5fe4,0xa088,0x3fa1, +0x0a8d,0xad3d,0xe79c,0xbf4f, +}; +#endif +#ifdef MIEEE +static unsigned short CN[20] = { +0xbfe2,0xe622,0xffa7,0xef20, +0x3fe4,0x22b1,0xf29f,0xbcb6, +0xbfc6,0x203e,0x2f0a,0x174e, +0x3f90,0xe11a,0xb3d4,0xd36b, +0xbf3f,0xe79c,0xad3d,0x09fb, +}; +static unsigned short CD[20] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc005,0x95ea,0x2e75,0x76e2, +0x3ffb,0xb92c,0x0388,0xa954, +0xbfd9,0x3285,0x7b43,0x8c94, +0x3fa1,0xa088,0x5fe4,0x4f2d, +0xbf4f,0xe79c,0xad3d,0x0a8d, +}; +#endif + +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double sqrt ( double ); +extern double fabs ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +double chbevl(), sqrt(), fabs(), polevl(), p1evl(); +#endif +extern double PI, MACHEP; + +double dawsn( xx ) +double xx; +{ +double x, y; +int sign; + + +sign = 1; +if( xx < 0.0 ) + { + sign = -1; + xx = -xx; + } + +if( xx < 3.25 ) +{ +x = xx*xx; +y = xx * polevl( x, AN, 9 )/polevl( x, AD, 10 ); +return( sign * y ); +} + + +x = 1.0/(xx*xx); + +if( xx < 6.25 ) + { + y = 1.0/xx + x * polevl( x, BN, 10) / (p1evl( x, BD, 10) * xx); + return( sign * 0.5 * y ); + } + + +if( xx > 1.0e9 ) + return( (sign * 0.5)/xx ); + +/* 6.25 to infinity */ +y = 1.0/xx + x * polevl( x, CN, 4) / (p1evl( x, CD, 5) * xx); +return( sign * 0.5 * y ); +} diff --git a/libm/double/dcalc.c b/libm/double/dcalc.c new file mode 100644 index 000000000..b740edae2 --- /dev/null +++ b/libm/double/dcalc.c @@ -0,0 +1,1512 @@ +/* calc.c */ +/* Keyboard command interpreter */ +/* by Stephen L. Moshier */ + + +/* 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 "dcalc.h" +/* #include "ehead.h" */ +#include <math.h> +/* int strlen(), strcmp(); */ +int system(); + +/* space for working precision numbers */ +static 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 double PI; +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, &PI}, +{"\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 + +#ifdef ANSIPROT +double floor ( double ); +int dprec ( void ); +#else +double floor(); +int dprec(); +#endif +/* the symbol table of functions: */ +#if SALONE +#ifdef ANSIPROT +extern double floor ( double ); +extern double log ( double ); +extern double pow ( double, double ); +extern double sqrt ( double ); +extern double tanh ( double ); +extern double exp ( double ); +extern double fabs ( double ); +extern double hypot ( double, double ); +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +extern double sin ( double ); +extern double cos ( double ); +extern double atan ( double ); +extern double atan2 ( double, double ); +extern double gamma ( double ); +extern double lgam ( double ); +double zfrexp ( double ); +double zldexp ( double, double ); +double makenan ( double ); +double makeinfinity ( double ); +double hex ( double ); +double hexinput ( double, double ); +double cmdh ( void ); +double cmdhlp ( void ); +double init ( void ); +double cmddm ( void ); +double cmdtm ( void ); +double cmdem ( double ); +double take ( char * ); +double mxit ( void ); +double bits ( double ); +double csys ( char * ); +double cmddig ( double ); +double prhlst ( void * ); +double abmac ( void ); +double ifrac ( double ); +double xcmpl ( double, double ); +void exit ( int ); +#else +void exit(); +double hex(), hexinput(), cmdh(), cmdhlp(), init(); +double cmddm(), cmdtm(), cmdem(); +double take(), mxit(), bits(), csys(); +double cmddig(), prhlst(), abmac(); +double ifrac(), xcmpl(); +double floor(), log(), pow(), sqrt(), tanh(), exp(), fabs(), hypot(); +double frexp(), zfrexp(), ldexp(), zldexp(), makenan(), makeinfinity(); +double incbet(), incbi(), sin(), cos(), atan(), atan2(), gamma(), lgam(); +#define GLIBC2 0 +#if GLIBC2 +double lgamma(); +#endif +#endif /* not ANSIPROT */ +struct funent funtbl[] = { +{"h", OPR | FUNC, cmdh}, +{"help", OPR | FUNC, cmdhlp}, +{"hex", OPR | FUNC, hex}, +{"hexinput", OPR | FUNC, hexinput}, +/*"view", OPR | FUNC, view,*/ +{"exp", OPR | FUNC, exp}, +{"floor", OPR | FUNC, floor}, +{"log", OPR | FUNC, log}, +{"pow", OPR | FUNC, pow}, +{"sqrt", OPR | FUNC, sqrt}, +{"tanh", OPR | FUNC, tanh}, +{"sin", OPR | FUNC, sin}, +{"cos", OPR | FUNC, cos}, +{"atan", OPR | FUNC, atan}, +{"atantwo", OPR | FUNC, atan2}, +{"tanh", OPR | FUNC, tanh}, +{"gamma", OPR | FUNC, gamma}, +#if GLIBC2 +{"lgamma", OPR | FUNC, lgamma}, +#else +{"lgam", OPR | FUNC, lgam}, +#endif +{"incbet", OPR | FUNC, incbet}, +{"incbi", OPR | FUNC, incbi}, +{"fabs", OPR | FUNC, fabs}, +{"hypot", OPR | FUNC, hypot}, +{"ldexp", OPR | FUNC, zldexp}, +{"frexp", OPR | FUNC, zfrexp}, +{"nan", OPR | FUNC, makenan}, +{"infinity", OPR | FUNC, makeinfinity}, +{"ifrac", OPR | FUNC, ifrac}, +{"cmp", OPR | FUNC, xcmpl}, +{"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(); + +/* 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 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 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 + +double acc; /* the accumulator, for arithmetic */ +int accflg; /* flags accumulator in use */ +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.0; /* 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", acc ); +#if 0 +#if NE == 6 + e64toasc( &acc, str, 100 ); +#else + e113toasc( &acc, str, 100 ); +#endif +#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.0; + 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.0 ) + { +/* +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; +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.0; + 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 0 +#if NE == 6 + asctoe64( number, &qnc ); +#else + asctoe113( number, &qnc ); +#endif +#endif + sscanf( number, "%le", &qnc ); + } +/* 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 */ + +double cmdex() +{ + +if( menptr == 0 ) + { + printf( "Main menu is active.\n" ); + } +else + --menptr; + +cmdh(); +return(0.0); +} + + +/* 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 */ +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.0); +} + + +double cmdh() +{ + +prhlst( menstk[menptr] ); +printf( "\n" ); +return(0.0); +} + +/* print keyword spellings */ + +double prhlst(vps) +void *vps; +{ +register int j, k; +int m; +register struct symbol *ps = vps; + +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.0); +} + + +#if SALONE +double init() +{ +/* Set coprocessor to double precision. */ +dprec(); +return 0.0; +} +#endif + + +/* macro commands */ + +/* define macro */ +double cmddm() +{ + +zgets( maclin, TRUE ); +return(0.0); +} + +/* type (i.e., display) macro */ +double cmdtm() +{ + +printf( "%s\n", maclin ); +return 0.0; +} + +/* execute macro # times */ +double cmdem( arg ) +double arg; +{ +double f; +long n; + +f = floor(arg); +n = f; +if( n <= 0 ) + n = 1; +maccnt = n; +return(0.0); +} + + +/* open a take file */ + +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.0; + } +takptr += 1; +takstk[ takptr ] = f; +printf( "Running %s\n", fname ); +return(0.0); +} + + +/* abort macro execution */ +double abmac() +{ + +maccnt = 0; +interl = line; +return(0.0); +} + + +/* display integer part in hex, octal, and decimal + */ +double hex(qx) +double qx; +{ +double f; +long z; + +f = floor(qx); +z = f; +printf( "0%lo 0x%lx %ld.\n", z, z, z ); +return(qx); +} + +#define NASC 16 + +double bits( x ) +double x; +{ +union + { + double d; + short i[4]; + } du; +union + { + float f; + short i[2]; + } df; +int i; + +du.d = x; +printf( "double: " ); +for( i=0; i<4; i++ ) + printf( "0x%04x,", du.i[i] & 0xffff ); +printf( "\n" ); + +df.f = (float) x; +printf( "float: " ); +for( i=0; i<2; i++ ) + printf( "0x%04x,", df.i[i] & 0xffff ); +printf( "\n" ); +return(x); +} + + +/* Exit to monitor. */ +double mxit() +{ + +exit(0); +return(0.0); +} + + +double cmddig( x ) +double x; +{ +double f; +long lx; + +f = floor(x); +lx = f; +ndigits = lx; +if( ndigits <= 0 ) + ndigits = DEFDIS; +return(f); +} + + +double csys(x) +char *x; +{ + +system( x+1 ); +cmdh(); +return(0.0); +} + + +double ifrac(x) +double x; +{ +unsigned long lx; +long double y, z; + +z = floor(x); +lx = z; +y = x - z; +printf( " int = %lx\n", lx ); +return(y); +} + +double xcmpl(x,y) +double x,y; +{ +double ans; + +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 ); +} + +extern double INFINITY, NAN; + +double makenan(x) +double x; +{ +return(NAN); +} + +double makeinfinity(x) +double x; +{ +return(INFINITY); +} + +double zfrexp(x) +double x; +{ +double y; +int e; +y = frexp(x, &e); +printf("exponent = %d, significand = ", e ); +return(y); +} + +double zldexp(x,e) +double x, e; +{ +double y; +int i; + +i = e; +y = ldexp(x,i); +return(y); +} + +double hexinput(a, b) +double a,b; +{ +union + { + double d; + unsigned short i[4]; + } u; +unsigned long l; + +#ifdef IBMPC +l = a; +u.i[3] = l >> 16; +u.i[2] = l; +l = b; +u.i[1] = l >> 16; +u.i[0] = l; +#endif +#ifdef DEC +l = a; +u.i[3] = l >> 16; +u.i[2] = l; +l = b; +u.i[1] = l >> 16; +u.i[0] = l; +#endif +#ifdef MIEEE +l = a; +u.i[0] = l >> 16; +u.i[1] = l; +l = b; +u.i[2] = l >> 16; +u.i[3] = l; +#endif +#ifdef UNK +l = a; +u.i[0] = l >> 16; +u.i[1] = l; +l = b; +u.i[2] = l >> 16; +u.i[3] = l; +#endif +return(u.d); +} diff --git a/libm/double/dcalc.h b/libm/double/dcalc.h new file mode 100644 index 000000000..0ec2a46da --- /dev/null +++ b/libm/double/dcalc.h @@ -0,0 +1,77 @@ +/* calc.h + * include file for calc.c + */ + +/* 32 bit memory addresses: */ +#define LARGEMEM 1 + +/* 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; + double (*fun )(); + }; + +struct varent + { + char *spel; + short attrib; + 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/double/dtestvec.c b/libm/double/dtestvec.c new file mode 100644 index 000000000..ea494029b --- /dev/null +++ b/libm/double/dtestvec.c @@ -0,0 +1,543 @@ + +/* Test vectors for math functions. + See C9X section F.9. */ +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1998, 2000 by Stephen L. Moshier +*/ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +int isfinite (double); + +/* C9X spells lgam lgamma. */ +#define GLIBC2 0 + +extern double PI; +static double MPI, PIO2, MPIO2, PIO4, MPIO4, THPIO4, MTHPIO4; + +#if 0 +#define PI 3.141592653589793238463E0 +#define PIO2 1.570796326794896619231E0 +#define PIO4 7.853981633974483096157E-1 +#define THPIO4 2.35619449019234492884698 +#define SQRT2 1.414213562373095048802E0 +#define SQRTH 7.071067811865475244008E-1 +#define INF (1.0/0.0) +#define MINF (-1.0/0.0) +#endif + +extern double MACHEP, SQRTH, SQRT2; +extern double NAN, INFINITY, NEGZERO; +static double INF, MINF; +static double ZERO, MZERO, HALF, MHALF, ONE, MONE, TWO, MTWO, THREE, MTHREE; +/* #define NAN (1.0/0.0 - 1.0/0.0) */ + +/* Functions of one variable. */ +double log (double); +double exp ( double); +double atan (double); +double sin (double); +double cos (double); +double tan (double); +double acos (double); +double asin (double); +double acosh (double); +double asinh (double); +double atanh (double); +double sinh (double); +double cosh (double); +double tanh (double); +double exp2 (double); +double expm1 (double); +double log10 (double); +double log1p (double); +double log2 (double); +double fabs (double); +double erf (double); +double erfc (double); +double gamma (double); +double floor (double); +double ceil (double); +double cbrt (double); +#if GLIBC2 +double lgamma (double); +#else +double lgam (double); +#endif + +struct oneargument + { + char *name; /* Name of the function. */ + double (*func) (double); + double *arg1; + double *answer; + int thresh; /* Error report threshold. */ + }; + +struct oneargument test1[] = +{ + {"atan", atan, &ONE, &PIO4, 0}, + {"sin", sin, &PIO2, &ONE, 0}, +#if 0 + {"cos", cos, &PIO4, &SQRTH, 0}, + {"sin", sin, 32767., 1.8750655394138942394239E-1, 0}, + {"cos", cos, 32767., 9.8226335176928229845654E-1, 0}, + {"tan", tan, 32767., 1.9089234430221485740826E-1, 0}, + {"sin", sin, 8388607., 9.9234509376961249835628E-1, 0}, + {"cos", cos, 8388607., -1.2349580912475928183718E-1, 0}, + {"tan", tan, 8388607., -8.0354556223613614748329E0, 0}, + /* + {"sin", sin, 2147483647., -7.2491655514455639054829E-1, 0}, + {"cos", cos, 2147483647., -6.8883669187794383467976E-1, 0}, + {"tan", tan, 2147483647., 1.0523779637351339136698E0, 0}, + */ + {"cos", cos, &PIO2, 6.1232339957367574e-17, 1}, + {"sin", sin, &PIO4, &SQRTH, 1}, +#endif + {"acos", acos, &NAN, &NAN, 0}, + {"acos", acos, &ONE, &ZERO, 0}, + {"acos", acos, &TWO, &NAN, 0}, + {"acos", acos, &MTWO, &NAN, 0}, + {"asin", asin, &NAN, &NAN, 0}, + {"asin", asin, &ZERO, &ZERO, 0}, + {"asin", asin, &MZERO, &MZERO, 0}, + {"asin", asin, &TWO, &NAN, 0}, + {"asin", asin, &MTWO, &NAN, 0}, + {"atan", atan, &NAN, &NAN, 0}, + {"atan", atan, &ZERO, &ZERO, 0}, + {"atan", atan, &MZERO, &MZERO, 0}, + {"atan", atan, &INF, &PIO2, 0}, + {"atan", atan, &MINF, &MPIO2, 0}, + {"cos", cos, &NAN, &NAN, 0}, + {"cos", cos, &ZERO, &ONE, 0}, + {"cos", cos, &MZERO, &ONE, 0}, + {"cos", cos, &INF, &NAN, 0}, + {"cos", cos, &MINF, &NAN, 0}, + {"sin", sin, &NAN, &NAN, 0}, + {"sin", sin, &MZERO, &MZERO, 0}, + {"sin", sin, &ZERO, &ZERO, 0}, + {"sin", sin, &INF, &NAN, 0}, + {"sin", sin, &MINF, &NAN, 0}, + {"tan", tan, &NAN, &NAN, 0}, + {"tan", tan, &ZERO, &ZERO, 0}, + {"tan", tan, &MZERO, &MZERO, 0}, + {"tan", tan, &INF, &NAN, 0}, + {"tan", tan, &MINF, &NAN, 0}, + {"acosh", acosh, &NAN, &NAN, 0}, + {"acosh", acosh, &ONE, &ZERO, 0}, + {"acosh", acosh, &INF, &INF, 0}, + {"acosh", acosh, &HALF, &NAN, 0}, + {"acosh", acosh, &MONE, &NAN, 0}, + {"asinh", asinh, &NAN, &NAN, 0}, + {"asinh", asinh, &ZERO, &ZERO, 0}, + {"asinh", asinh, &MZERO, &MZERO, 0}, + {"asinh", asinh, &INF, &INF, 0}, + {"asinh", asinh, &MINF, &MINF, 0}, + {"atanh", atanh, &NAN, &NAN, 0}, + {"atanh", atanh, &ZERO, &ZERO, 0}, + {"atanh", atanh, &MZERO, &MZERO, 0}, + {"atanh", atanh, &ONE, &INF, 0}, + {"atanh", atanh, &MONE, &MINF, 0}, + {"atanh", atanh, &TWO, &NAN, 0}, + {"atanh", atanh, &MTWO, &NAN, 0}, + {"cosh", cosh, &NAN, &NAN, 0}, + {"cosh", cosh, &ZERO, &ONE, 0}, + {"cosh", cosh, &MZERO, &ONE, 0}, + {"cosh", cosh, &INF, &INF, 0}, + {"cosh", cosh, &MINF, &INF, 0}, + {"sinh", sinh, &NAN, &NAN, 0}, + {"sinh", sinh, &ZERO, &ZERO, 0}, + {"sinh", sinh, &MZERO, &MZERO, 0}, + {"sinh", sinh, &INF, &INF, 0}, + {"sinh", sinh, &MINF, &MINF, 0}, + {"tanh", tanh, &NAN, &NAN, 0}, + {"tanh", tanh, &ZERO, &ZERO, 0}, + {"tanh", tanh, &MZERO, &MZERO, 0}, + {"tanh", tanh, &INF, &ONE, 0}, + {"tanh", tanh, &MINF, &MONE, 0}, + {"exp", exp, &NAN, &NAN, 0}, + {"exp", exp, &ZERO, &ONE, 0}, + {"exp", exp, &MZERO, &ONE, 0}, + {"exp", exp, &INF, &INF, 0}, + {"exp", exp, &MINF, &ZERO, 0}, +#if !GLIBC2 + {"exp2", exp2, &NAN, &NAN, 0}, + {"exp2", exp2, &ZERO, &ONE, 0}, + {"exp2", exp2, &MZERO, &ONE, 0}, + {"exp2", exp2, &INF, &INF, 0}, + {"exp2", exp2, &MINF, &ZERO, 0}, +#endif + {"expm1", expm1, &NAN, &NAN, 0}, + {"expm1", expm1, &ZERO, &ZERO, 0}, + {"expm1", expm1, &MZERO, &MZERO, 0}, + {"expm1", expm1, &INF, &INF, 0}, + {"expm1", expm1, &MINF, &MONE, 0}, + {"log", log, &NAN, &NAN, 0}, + {"log", log, &ZERO, &MINF, 0}, + {"log", log, &MZERO, &MINF, 0}, + {"log", log, &ONE, &ZERO, 0}, + {"log", log, &MONE, &NAN, 0}, + {"log", log, &INF, &INF, 0}, + {"log10", log10, &NAN, &NAN, 0}, + {"log10", log10, &ZERO, &MINF, 0}, + {"log10", log10, &MZERO, &MINF, 0}, + {"log10", log10, &ONE, &ZERO, 0}, + {"log10", log10, &MONE, &NAN, 0}, + {"log10", log10, &INF, &INF, 0}, + {"log1p", log1p, &NAN, &NAN, 0}, + {"log1p", log1p, &ZERO, &ZERO, 0}, + {"log1p", log1p, &MZERO, &MZERO, 0}, + {"log1p", log1p, &MONE, &MINF, 0}, + {"log1p", log1p, &MTWO, &NAN, 0}, + {"log1p", log1p, &INF, &INF, 0}, +#if !GLIBC2 + {"log2", log2, &NAN, &NAN, 0}, + {"log2", log2, &ZERO, &MINF, 0}, + {"log2", log2, &MZERO, &MINF, 0}, + {"log2", log2, &MONE, &NAN, 0}, + {"log2", log2, &INF, &INF, 0}, +#endif + /* {"fabs", fabs, NAN, NAN, 0}, */ + {"fabs", fabs, &ONE, &ONE, 0}, + {"fabs", fabs, &MONE, &ONE, 0}, + {"fabs", fabs, &ZERO, &ZERO, 0}, + {"fabs", fabs, &MZERO, &ZERO, 0}, + {"fabs", fabs, &INF, &INF, 0}, + {"fabs", fabs, &MINF, &INF, 0}, + {"cbrt", cbrt, &NAN, &NAN, 0}, + {"cbrt", cbrt, &ZERO, &ZERO, 0}, + {"cbrt", cbrt, &MZERO, &MZERO, 0}, + {"cbrt", cbrt, &INF, &INF, 0}, + {"cbrt", cbrt, &MINF, &MINF, 0}, + {"erf", erf, &NAN, &NAN, 0}, + {"erf", erf, &ZERO, &ZERO, 0}, + {"erf", erf, &MZERO, &MZERO, 0}, + {"erf", erf, &INF, &ONE, 0}, + {"erf", erf, &MINF, &MONE, 0}, + {"erfc", erfc, &NAN, &NAN, 0}, + {"erfc", erfc, &INF, &ZERO, 0}, + {"erfc", erfc, &MINF, &TWO, 0}, + {"gamma", gamma, &NAN, &NAN, 0}, + {"gamma", gamma, &INF, &INF, 0}, + {"gamma", gamma, &MONE, &NAN, 0}, + {"gamma", gamma, &ZERO, &NAN, 0}, + {"gamma", gamma, &MINF, &NAN, 0}, +#if GLIBC2 + {"lgamma", lgamma, &NAN, &NAN, 0}, + {"lgamma", lgamma, &INF, &INF, 0}, + {"lgamma", lgamma, &MONE, &INF, 0}, + {"lgamma", lgamma, &ZERO, &INF, 0}, + {"lgamma", lgamma, &MINF, &INF, 0}, +#else + {"lgam", lgam, &NAN, &NAN, 0}, + {"lgam", lgam, &INF, &INF, 0}, + {"lgam", lgam, &MONE, &INF, 0}, + {"lgam", lgam, &ZERO, &INF, 0}, + {"lgam", lgam, &MINF, &INF, 0}, +#endif + {"ceil", ceil, &NAN, &NAN, 0}, + {"ceil", ceil, &ZERO, &ZERO, 0}, + {"ceil", ceil, &MZERO, &MZERO, 0}, + {"ceil", ceil, &INF, &INF, 0}, + {"ceil", ceil, &MINF, &MINF, 0}, + {"floor", floor, &NAN, &NAN, 0}, + {"floor", floor, &ZERO, &ZERO, 0}, + {"floor", floor, &MZERO, &MZERO, 0}, + {"floor", floor, &INF, &INF, 0}, + {"floor", floor, &MINF, &MINF, 0}, + {"null", NULL, &ZERO, &ZERO, 0}, +}; + +/* Functions of two variables. */ +double atan2 (double, double); +double pow (double, double); + +struct twoarguments + { + char *name; /* Name of the function. */ + double (*func) (double, double); + double *arg1; + double *arg2; + double *answer; + int thresh; + }; + +struct twoarguments test2[] = +{ + {"atan2", atan2, &ZERO, &ONE, &ZERO, 0}, + {"atan2", atan2, &MZERO, &ONE, &MZERO, 0}, + {"atan2", atan2, &ZERO, &ZERO, &ZERO, 0}, + {"atan2", atan2, &MZERO, &ZERO, &MZERO, 0}, + {"atan2", atan2, &ZERO, &MONE, &PI, 0}, + {"atan2", atan2, &MZERO, &MONE, &MPI, 0}, + {"atan2", atan2, &ZERO, &MZERO, &PI, 0}, + {"atan2", atan2, &MZERO, &MZERO, &MPI, 0}, + {"atan2", atan2, &ONE, &ZERO, &PIO2, 0}, + {"atan2", atan2, &ONE, &MZERO, &PIO2, 0}, + {"atan2", atan2, &MONE, &ZERO, &MPIO2, 0}, + {"atan2", atan2, &MONE, &MZERO, &MPIO2, 0}, + {"atan2", atan2, &ONE, &INF, &ZERO, 0}, + {"atan2", atan2, &MONE, &INF, &MZERO, 0}, + {"atan2", atan2, &INF, &ONE, &PIO2, 0}, + {"atan2", atan2, &INF, &MONE, &PIO2, 0}, + {"atan2", atan2, &MINF, &ONE, &MPIO2, 0}, + {"atan2", atan2, &MINF, &MONE, &MPIO2, 0}, + {"atan2", atan2, &ONE, &MINF, &PI, 0}, + {"atan2", atan2, &MONE, &MINF, &MPI, 0}, + {"atan2", atan2, &INF, &INF, &PIO4, 0}, + {"atan2", atan2, &MINF, &INF, &MPIO4, 0}, + {"atan2", atan2, &INF, &MINF, &THPIO4, 0}, + {"atan2", atan2, &MINF, &MINF, &MTHPIO4, 0}, + {"atan2", atan2, &ONE, &ONE, &PIO4, 0}, + {"atan2", atan2, &NAN, &ONE, &NAN, 0}, + {"atan2", atan2, &ONE, &NAN, &NAN, 0}, + {"atan2", atan2, &NAN, &NAN, &NAN, 0}, + {"pow", pow, &ONE, &ZERO, &ONE, 0}, + {"pow", pow, &ONE, &MZERO, &ONE, 0}, + {"pow", pow, &MONE, &ZERO, &ONE, 0}, + {"pow", pow, &MONE, &MZERO, &ONE, 0}, + {"pow", pow, &INF, &ZERO, &ONE, 0}, + {"pow", pow, &INF, &MZERO, &ONE, 0}, + {"pow", pow, &NAN, &ZERO, &ONE, 0}, + {"pow", pow, &NAN, &MZERO, &ONE, 0}, + {"pow", pow, &TWO, &INF, &INF, 0}, + {"pow", pow, &MTWO, &INF, &INF, 0}, + {"pow", pow, &HALF, &INF, &ZERO, 0}, + {"pow", pow, &MHALF, &INF, &ZERO, 0}, + {"pow", pow, &TWO, &MINF, &ZERO, 0}, + {"pow", pow, &MTWO, &MINF, &ZERO, 0}, + {"pow", pow, &HALF, &MINF, &INF, 0}, + {"pow", pow, &MHALF, &MINF, &INF, 0}, + {"pow", pow, &INF, &HALF, &INF, 0}, + {"pow", pow, &INF, &TWO, &INF, 0}, + {"pow", pow, &INF, &MHALF, &ZERO, 0}, + {"pow", pow, &INF, &MTWO, &ZERO, 0}, + {"pow", pow, &MINF, &THREE, &MINF, 0}, + {"pow", pow, &MINF, &TWO, &INF, 0}, + {"pow", pow, &MINF, &MTHREE, &MZERO, 0}, + {"pow", pow, &MINF, &MTWO, &ZERO, 0}, + {"pow", pow, &NAN, &ONE, &NAN, 0}, + {"pow", pow, &ONE, &NAN, &NAN, 0}, + {"pow", pow, &NAN, &NAN, &NAN, 0}, + {"pow", pow, &ONE, &INF, &NAN, 0}, + {"pow", pow, &MONE, &INF, &NAN, 0}, + {"pow", pow, &ONE, &MINF, &NAN, 0}, + {"pow", pow, &MONE, &MINF, &NAN, 0}, + {"pow", pow, &MTWO, &HALF, &NAN, 0}, + {"pow", pow, &ZERO, &MTHREE, &INF, 0}, + {"pow", pow, &MZERO, &MTHREE, &MINF, 0}, + {"pow", pow, &ZERO, &MHALF, &INF, 0}, + {"pow", pow, &MZERO, &MHALF, &INF, 0}, + {"pow", pow, &ZERO, &THREE, &ZERO, 0}, + {"pow", pow, &MZERO, &THREE, &MZERO, 0}, + {"pow", pow, &ZERO, &HALF, &ZERO, 0}, + {"pow", pow, &MZERO, &HALF, &ZERO, 0}, + {"null", NULL, &ZERO, &ZERO, &ZERO, 0}, +}; + +/* Integer functions of one variable. */ + +int isnan (double); +int signbit (double); + +struct intans + { + char *name; /* Name of the function. */ + int (*func) (double); + double *arg1; + int ianswer; + }; + +struct intans test3[] = +{ + {"isfinite", isfinite, &ZERO, 1}, + {"isfinite", isfinite, &INF, 0}, + {"isfinite", isfinite, &MINF, 0}, + {"isnan", isnan, &NAN, 1}, + {"isnan", isnan, &INF, 0}, + {"isnan", isnan, &ZERO, 0}, + {"isnan", isnan, &MZERO, 0}, + {"signbit", signbit, &MZERO, 1}, + {"signbit", signbit, &MONE, 1}, + {"signbit", signbit, &ZERO, 0}, + {"signbit", signbit, &ONE, 0}, + {"signbit", signbit, &MINF, 1}, + {"signbit", signbit, &INF, 0}, + {"null", NULL, &ZERO, 0}, +}; + +static volatile double x1; +static volatile double x2; +static volatile double y; +static volatile double answer; + +void +pvec(x) +double x; +{ + union + { + double d; + unsigned short s[4]; + } u; + int i; + + u.d = x; + for (i = 0; i < 4; i++) + printf ("0x%04x ", u.s[i]); + printf ("\n"); +} + + +int +main () +{ + int i, nerrors, k, ianswer, ntests; + double (*fun1) (double); + double (*fun2) (double, double); + int (*fun3) (double); + double e; + union + { + double d; + char c[8]; + } u, v; + + ZERO = 0.0; + MZERO = NEGZERO; + HALF = 0.5; + MHALF = -HALF; + ONE = 1.0; + MONE = -ONE; + TWO = 2.0; + MTWO = -TWO; + THREE = 3.0; + MTHREE = -THREE; + INF = INFINITY; + MINF = -INFINITY; + MPI = -PI; + PIO2 = 0.5 * PI; + MPIO2 = -PIO2; + PIO4 = 0.5 * PIO2; + MPIO4 = -PIO4; + THPIO4 = 3.0 * PIO4; + MTHPIO4 = -THPIO4; + + nerrors = 0; + ntests = 0; + 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, 8) != 0) + { + if( isnan(v.d) && isnan(u.d) ) + goto nxttest1; + goto wrongone; + } + else + goto nxttest1; + } + if (y != answer) + { + e = y - answer; + if (answer != 0.0) + e = e / answer; + if (e < 0) + e = -e; + if (e > test1[i].thresh * MACHEP) + { +wrongone: + printf ("%s (%.16e) = %.16e\n should be %.16e\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, 8) != 0) + { + if( isnan(v.d) && isnan(u.d) ) + goto nxttest2; +#if 0 + if( isnan(v.d) ) + pvec(v.d); + if( isnan(u.d) ) + pvec(u.d); +#endif + goto wrongtwo; + } + else + goto nxttest2; + } + if (y != answer) + { + e = y - answer; + if (answer != 0.0) + e = e / answer; + if (e < 0) + e = -e; + if (e > test2[i].thresh * MACHEP) + { +wrongtwo: + printf ("%s (%.16e, %.16e) = %.16e\n should be %.16e\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 (%.16e) = %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/double/ei.c b/libm/double/ei.c new file mode 100644 index 000000000..4994fa99c --- /dev/null +++ b/libm/double/ei.c @@ -0,0 +1,1062 @@ +/* ei.c + * + * Exponential integral + * + * + * SYNOPSIS: + * + * double x, y, ei(); + * + * y = ei( x ); + * + * + * + * DESCRIPTION: + * + * x + * - t + * | | e + * Ei(x) = -|- --- dt . + * | | t + * - + * -inf + * + * Not defined for x <= 0. + * See also expn.c. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 50000 8.6e-16 1.3e-16 + * + */ + +/* +Cephes Math Library Release 2.8: May, 1999 +Copyright 1999 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double log ( double ); +extern double exp ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +extern double log(), exp(), polevl(), p1evl(); +#endif + +#define EUL 5.772156649015328606065e-1 + +/* 0 < x <= 2 + Ei(x) - EUL - ln(x) = x A(x)/B(x) + Theoretical peak relative error 9.73e-18 */ +#if UNK +static double A[6] = { +-5.350447357812542947283E0, + 2.185049168816613393830E2, +-4.176572384826693777058E3, + 5.541176756393557601232E4, +-3.313381331178144034309E5, + 1.592627163384945414220E6, +}; +static double B[6] = { + /* 1.000000000000000000000E0, */ +-5.250547959112862969197E1, + 1.259616186786790571525E3, +-1.756549581973534652631E4, + 1.493062117002725991967E5, +-7.294949239640527645655E5, + 1.592627163384945429726E6, +}; +#endif +#if DEC +static short A[24] = { +0140653,0033335,0060230,0144217, +0042132,0100502,0035625,0167413, +0143202,0102224,0037176,0175403, +0044130,0071704,0077421,0170343, +0144641,0144504,0041200,0045154, +0045302,0064631,0047234,0142052, +}; +static short B[24] = { + /* 0040200,0000000,0000000,0000000, */ +0141522,0002634,0070442,0142614, +0042635,0071667,0146532,0027705, +0143611,0035375,0156025,0114015, +0044421,0147215,0106177,0046330, +0145062,0014556,0144216,0103725, +0045302,0064631,0047234,0142052, +}; +#endif +#if IBMPC +static short A[24] = { +0x1912,0xac13,0x66db,0xc015, +0xbde1,0x4772,0x5028,0x406b, +0xdf60,0x87cf,0x5092,0xc0b0, +0x3e1c,0x8fe2,0x0e78,0x40eb, +0x094e,0x8850,0x3928,0xc114, +0x9885,0x29d3,0x4d33,0x4138, +}; +static short B[24] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0x58b1,0x8e24,0x40b3,0xc04a, +0x45f9,0xf9ab,0xae76,0x4093, +0xb302,0xbb82,0x275f,0xc0d1, +0xe99b,0xb18f,0x39d1,0x4102, +0xd0fb,0xd911,0x432d,0xc126, +0x9885,0x29d3,0x4d33,0x4138, +}; +#endif +#if MIEEE +static short A[24] = { +0xc015,0x66db,0xac13,0x1912, +0x406b,0x5028,0x4772,0xbde1, +0xc0b0,0x5092,0x87cf,0xdf60, +0x40eb,0x0e78,0x8fe2,0x3e1c, +0xc114,0x3928,0x8850,0x094e, +0x4138,0x4d33,0x29d3,0x9885, +}; +static short B[24] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xc04a,0x40b3,0x8e24,0x58b1, +0x4093,0xae76,0xf9ab,0x45f9, +0xc0d1,0x275f,0xbb82,0xb302, +0x4102,0x39d1,0xb18f,0xe99b, +0xc126,0x432d,0xd911,0xd0fb, +0x4138,0x4d33,0x29d3,0x9885, +}; +#endif + +#if 0 +/* 0 < x <= 4 + Ei(x) - EUL - ln(x) = x A(x)/B(x) + Theoretical peak relative error 4.75e-17 */ +#if UNK +static double A[7] = { +-6.831869820732773831942E0, + 2.920190530726774500309E2, +-1.195883839286649567993E4, + 1.761045255472548975666E5, +-2.623034438354006526979E6, + 1.472430336917880803157E7, +-8.205359388213261174960E7, +}; +static double B[7] = { + /* 1.000000000000000000000E0, */ +-7.731946237840033971071E1, + 2.751808700543578450827E3, +-5.829268609072186897994E4, + 7.916610857961870631379E5, +-6.873926904825733094076E6, + 3.523770183971164032710E7, +-8.205359388213260785363E7, +}; +#endif +#if DEC +static short A[28] = { +0140732,0117255,0072522,0071743, +0042222,0001160,0052302,0002334, +0143472,0155532,0101650,0155462, +0044453,0175041,0121220,0172022, +0145440,0014351,0140337,0157550, +0046140,0126317,0057202,0100233, +0146634,0100473,0036072,0067054, +}; +static short B[28] = { + /* 0040200,0000000,0000000,0000000, */ +0141632,0121620,0111247,0010115, +0043053,0176360,0067773,0027324, +0144143,0132257,0121644,0036204, +0045101,0043321,0057553,0151231, +0145721,0143215,0147505,0050610, +0046406,0065721,0072675,0152744, +0146634,0100473,0036072,0067052, +}; +#endif +#if IBMPC +static short A[28] = { +0x4e7c,0xaeaa,0x53d5,0xc01b, +0x409b,0x0a98,0x404e,0x4072, +0x1b66,0x5075,0x5b6b,0xc0c7, +0x1e82,0x3452,0x7f44,0x4105, +0xfbed,0x381b,0x031d,0xc144, +0x5013,0xebd0,0x1599,0x416c, +0x4dc5,0x6787,0x9027,0xc193, +}; +static short B[28] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xe20a,0x1254,0x5472,0xc053, +0x65db,0x0dff,0x7f9e,0x40a5, +0x8791,0xf474,0x7695,0xc0ec, +0x7a53,0x2bed,0x28da,0x4128, +0xaa31,0xb9e8,0x38d1,0xc15a, +0xbabd,0x2eb7,0xcd7a,0x4180, +0x4dc5,0x6787,0x9027,0xc193, +}; +#endif +#if MIEEE +static short A[28] = { +0xc01b,0x53d5,0xaeaa,0x4e7c, +0x4072,0x404e,0x0a98,0x409b, +0xc0c7,0x5b6b,0x5075,0x1b66, +0x4105,0x7f44,0x3452,0x1e82, +0xc144,0x031d,0x381b,0xfbed, +0x416c,0x1599,0xebd0,0x5013, +0xc193,0x9027,0x6787,0x4dc5, +}; +static short B[28] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xc053,0x5472,0x1254,0xe20a, +0x40a5,0x7f9e,0x0dff,0x65db, +0xc0ec,0x7695,0xf474,0x8791, +0x4128,0x28da,0x2bed,0x7a53, +0xc15a,0x38d1,0xb9e8,0xaa31, +0x4180,0xcd7a,0x2eb7,0xbabd, +0xc193,0x9027,0x6787,0x4dc5, +}; +#endif +#endif /* 0 */ + +#if 0 +/* 0 < x <= 8 + Ei(x) - EUL - ln(x) = x A(x)/B(x) + Theoretical peak relative error 2.14e-17 */ + +#if UNK +static double A[9] = { +-1.111230942210860450145E1, + 3.688203982071386319616E2, +-4.924786153494029574350E4, + 1.050677503345557903241E6, +-3.626713709916703688968E7, + 4.353499908839918635414E8, +-6.454613717232006895409E9, + 3.408243056457762907071E10, +-1.995466674647028468613E11, +}; +static double B[9] = { + /* 1.000000000000000000000E0, */ +-1.356757648138514017969E2, + 8.562181317107341736606E3, +-3.298257180413775117555E5, + 8.543534058481435917210E6, +-1.542380618535140055068E8, + 1.939251779195993632028E9, +-1.636096210465615015435E10, + 8.396909743075306970605E10, +-1.995466674647028425886E11, +}; +#endif +#if DEC +static short A[36] = { +0141061,0146004,0173357,0151553, +0042270,0064402,0147366,0126701, +0144100,0057734,0106615,0144356, +0045200,0040654,0003332,0004456, +0146412,0054440,0043130,0140263, +0047317,0113517,0033422,0065123, +0150300,0056313,0065235,0131147, +0050775,0167423,0146222,0075760, +0151471,0153642,0003442,0147667, +}; +static short B[36] = { + /* 0040200,0000000,0000000,0000000, */ +0142007,0126376,0166077,0043600, +0043405,0144271,0125461,0014364, +0144641,0006066,0175061,0164463, +0046002,0056456,0007370,0121657, +0147023,0013706,0156647,0177115, +0047747,0026504,0103144,0054507, +0150563,0146036,0007051,0177135, +0051234,0063625,0173266,0003111, +0151471,0153642,0003442,0147666, +}; +#endif +#if IBMPC +static short A[36] = { +0xfa6d,0x9edd,0x3980,0xc026, +0xd5b8,0x59de,0x0d20,0x4077, +0xb91e,0x91b1,0x0bfb,0xc0e8, +0x4126,0x80db,0x0835,0x4130, +0x1816,0x08cb,0x4b24,0xc181, +0x4d4a,0xe6e2,0xf2e9,0x41b9, +0xb64d,0x6d53,0x0b99,0xc1f8, +0x4f7e,0x7992,0xbde2,0x421f, +0x59f7,0x40e4,0x3af4,0xc247, +}; +static short B[36] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xe8f0,0xdd87,0xf59f,0xc060, +0x231e,0x3566,0xb917,0x40c0, +0x3d26,0xdf46,0x2186,0xc114, +0x1476,0xc1df,0x4ba5,0x4160, +0xffca,0xdbb4,0x62f8,0xc1a2, +0x8b29,0x90cc,0xe5a8,0x41dc, +0x3fcc,0xc1c5,0x7983,0xc20e, +0xc0c9,0xbed6,0x8cf2,0x4233, +0x59f7,0x40e4,0x3af4,0xc247, +}; +#endif +#if MIEEE +static short A[36] = { +0xc026,0x3980,0x9edd,0xfa6d, +0x4077,0x0d20,0x59de,0xd5b8, +0xc0e8,0x0bfb,0x91b1,0xb91e, +0x4130,0x0835,0x80db,0x4126, +0xc181,0x4b24,0x08cb,0x1816, +0x41b9,0xf2e9,0xe6e2,0x4d4a, +0xc1f8,0x0b99,0x6d53,0xb64d, +0x421f,0xbde2,0x7992,0x4f7e, +0xc247,0x3af4,0x40e4,0x59f7, +}; +static short B[36] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xc060,0xf59f,0xdd87,0xe8f0, +0x40c0,0xb917,0x3566,0x231e, +0xc114,0x2186,0xdf46,0x3d26, +0x4160,0x4ba5,0xc1df,0x1476, +0xc1a2,0x62f8,0xdbb4,0xffca, +0x41dc,0xe5a8,0x90cc,0x8b29, +0xc20e,0x7983,0xc1c5,0x3fcc, +0x4233,0x8cf2,0xbed6,0xc0c9, +0xc247,0x3af4,0x40e4,0x59f7, +}; +#endif +#endif /* 0 */ + +/* 8 <= x <= 20 + x exp(-x) Ei(x) - 1 = 1/x R(1/x) + Theoretical peak absolute error = 1.07e-17 */ +#if UNK +static double A2[10] = { +-2.106934601691916512584E0, + 1.732733869664688041885E0, +-2.423619178935841904839E-1, + 2.322724180937565842585E-2, + 2.372880440493179832059E-4, +-8.343219561192552752335E-5, + 1.363408795605250394881E-5, +-3.655412321999253963714E-7, + 1.464941733975961318456E-8, + 6.176407863710360207074E-10, +}; +static double B2[9] = { + /* 1.000000000000000000000E0, */ +-2.298062239901678075778E-1, + 1.105077041474037862347E-1, +-1.566542966630792353556E-2, + 2.761106850817352773874E-3, +-2.089148012284048449115E-4, + 1.708528938807675304186E-5, +-4.459311796356686423199E-7, + 1.394634930353847498145E-8, + 6.150865933977338354138E-10, +}; +#endif +#if DEC +static short A2[40] = { +0140406,0154004,0035104,0173336, +0040335,0145071,0031560,0150165, +0137570,0026670,0176230,0055040, +0036676,0043416,0077122,0054476, +0035170,0150206,0034407,0175571, +0134656,0174121,0123231,0021751, +0034144,0136766,0036746,0121115, +0132704,0037632,0135077,0107300, +0031573,0126321,0117076,0004314, +0030451,0143233,0041352,0172464, +}; +static short B2[36] = { + /* 0040200,0000000,0000000,0000000, */ +0137553,0051122,0120721,0170437, +0037342,0050734,0175047,0032132, +0136600,0052311,0101406,0147050, +0036064,0171657,0120001,0071165, +0135133,0010043,0151244,0066340, +0034217,0051141,0026115,0043305, +0132757,0064120,0106341,0051217, +0031557,0114261,0060663,0135017, +0030451,0011337,0001344,0175542, +}; +#endif +#if IBMPC +static short A2[40] = { +0x9edc,0x8748,0xdb00,0xc000, +0x1a0f,0x266e,0xb947,0x3ffb, +0x0b44,0x1f93,0x05b7,0xbfcf, +0x4b28,0xcfca,0xc8e1,0x3f97, +0xff6f,0xc720,0x1a10,0x3f2f, +0x247d,0x34d3,0xdf0a,0xbf15, +0xd44a,0xc7bc,0x97be,0x3eec, +0xf1d8,0x5747,0x87f3,0xbe98, +0xc119,0x33c7,0x759a,0x3e4f, +0x5ea6,0x685d,0x38d3,0x3e05, +}; +static short B2[36] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0x3e24,0x543a,0x6a4a,0xbfcd, +0xe68b,0x9f44,0x4a3b,0x3fbc, +0xd9c5,0x3060,0x0a99,0xbf90, +0x2e4f,0xf400,0x9e75,0x3f66, +0x8d9c,0x7a54,0x6204,0xbf2b, +0xa8d9,0x2589,0xea4c,0x3ef1, +0x2a52,0x119c,0xed0a,0xbe9d, +0x7742,0x2c36,0xf316,0x3e4d, +0x9f6c,0xe05c,0x225b,0x3e05, +}; +#endif +#if MIEEE +static short A2[40] = { +0xc000,0xdb00,0x8748,0x9edc, +0x3ffb,0xb947,0x266e,0x1a0f, +0xbfcf,0x05b7,0x1f93,0x0b44, +0x3f97,0xc8e1,0xcfca,0x4b28, +0x3f2f,0x1a10,0xc720,0xff6f, +0xbf15,0xdf0a,0x34d3,0x247d, +0x3eec,0x97be,0xc7bc,0xd44a, +0xbe98,0x87f3,0x5747,0xf1d8, +0x3e4f,0x759a,0x33c7,0xc119, +0x3e05,0x38d3,0x685d,0x5ea6, +}; +static short B2[36] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xbfcd,0x6a4a,0x543a,0x3e24, +0x3fbc,0x4a3b,0x9f44,0xe68b, +0xbf90,0x0a99,0x3060,0xd9c5, +0x3f66,0x9e75,0xf400,0x2e4f, +0xbf2b,0x6204,0x7a54,0x8d9c, +0x3ef1,0xea4c,0x2589,0xa8d9, +0xbe9d,0xed0a,0x119c,0x2a52, +0x3e4d,0xf316,0x2c36,0x7742, +0x3e05,0x225b,0xe05c,0x9f6c, +}; +#endif + +/* x > 20 + x exp(-x) Ei(x) - 1 = 1/x A3(1/x)/B3(1/x) + Theoretical absolute error = 6.15e-17 */ +#if UNK +static double A3[9] = { +-7.657847078286127362028E-1, + 6.886192415566705051750E-1, +-2.132598113545206124553E-1, + 3.346107552384193813594E-2, +-3.076541477344756050249E-3, + 1.747119316454907477380E-4, +-6.103711682274170530369E-6, + 1.218032765428652199087E-7, +-1.086076102793290233007E-9, +}; +static double B3[9] = { + /* 1.000000000000000000000E0, */ +-1.888802868662308731041E0, + 1.066691687211408896850E0, +-2.751915982306380647738E-1, + 3.930852688233823569726E-2, +-3.414684558602365085394E-3, + 1.866844370703555398195E-4, +-6.345146083130515357861E-6, + 1.239754287483206878024E-7, +-1.086076102793126632978E-9, +}; +#endif +#if DEC +static short A3[36] = { +0140104,0005167,0071746,0115510, +0040060,0044531,0140741,0154556, +0137532,0060307,0126506,0071123, +0037011,0007173,0010405,0127224, +0136111,0117715,0003654,0175577, +0035067,0031340,0102657,0147714, +0133714,0147173,0167473,0136640, +0032402,0144407,0115547,0060114, +0130625,0042347,0156431,0113425, +}; +static short B3[36] = { + /* 0040200,0000000,0000000,0000000, */ +0140361,0142112,0155277,0067714, +0040210,0104532,0065676,0074326, +0137614,0162751,0142421,0131033, +0037041,0000772,0053236,0002632, +0136137,0144346,0100536,0153136, +0035103,0140270,0152211,0166215, +0133724,0164143,0145763,0021153, +0032405,0017033,0035333,0025736, +0130625,0042347,0156431,0077134, +}; +#endif +#if IBMPC +static short A3[36] = { +0xd369,0xee7c,0x814e,0xbfe8, +0x3b2e,0x383c,0x092b,0x3fe6, +0xce4a,0xf5a8,0x4c18,0xbfcb, +0xb5d2,0x6220,0x21cf,0x3fa1, +0x9f70,0xa0f5,0x33f9,0xbf69, +0xf9f9,0x10b5,0xe65c,0x3f26, +0x77b4,0x7de7,0x99cf,0xbed9, +0xec09,0xf36c,0x5920,0x3e80, +0x32e3,0xfba3,0xa89c,0xbe12, +}; +static short B3[36] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xedf9,0x5b57,0x3889,0xbffe, +0xcf1b,0x4d77,0x112b,0x3ff1, +0x3643,0x38a2,0x9cbd,0xbfd1, +0xc0b3,0x4ad3,0x203f,0x3fa4, +0xdacc,0xd02b,0xf91c,0xbf6b, +0x3d92,0x1a91,0x7817,0x3f28, +0x644d,0x797e,0x9d0c,0xbeda, +0x657c,0x675b,0xa3c3,0x3e80, +0x2fcb,0xfba3,0xa89c,0xbe12, +}; +#endif +#if MIEEE +static short A3[36] = { +0xbfe8,0x814e,0xee7c,0xd369, +0x3fe6,0x092b,0x383c,0x3b2e, +0xbfcb,0x4c18,0xf5a8,0xce4a, +0x3fa1,0x21cf,0x6220,0xb5d2, +0xbf69,0x33f9,0xa0f5,0x9f70, +0x3f26,0xe65c,0x10b5,0xf9f9, +0xbed9,0x99cf,0x7de7,0x77b4, +0x3e80,0x5920,0xf36c,0xec09, +0xbe12,0xa89c,0xfba3,0x32e3, +}; +static short B3[36] = { +/* 0x3ff0,0x0000,0x0000,0x0000, */ +0xbffe,0x3889,0x5b57,0xedf9, +0x3ff1,0x112b,0x4d77,0xcf1b, +0xbfd1,0x9cbd,0x38a2,0x3643, +0x3fa4,0x203f,0x4ad3,0xc0b3, +0xbf6b,0xf91c,0xd02b,0xdacc, +0x3f28,0x7817,0x1a91,0x3d92, +0xbeda,0x9d0c,0x797e,0x644d, +0x3e80,0xa3c3,0x675b,0x657c, +0xbe12,0xa89c,0xfba3,0x2fcb, +}; +#endif + +/* 16 <= x <= 32 + x exp(-x) Ei(x) - 1 = 1/x A4(1/x) / B4(1/x) + Theoretical absolute error = 1.22e-17 */ +#if UNK +static double A4[8] = { +-2.458119367674020323359E-1, +-1.483382253322077687183E-1, + 7.248291795735551591813E-2, +-1.348315687380940523823E-2, + 1.342775069788636972294E-3, +-7.942465637159712264564E-5, + 2.644179518984235952241E-6, +-4.239473659313765177195E-8, +}; +static double B4[8] = { + /* 1.000000000000000000000E0, */ +-1.044225908443871106315E-1, +-2.676453128101402655055E-1, + 9.695000254621984627876E-2, +-1.601745692712991078208E-2, + 1.496414899205908021882E-3, +-8.462452563778485013756E-5, + 2.728938403476726394024E-6, +-4.239462431819542051337E-8, +}; +#endif +#if DEC +static short A4[32] = { +0137573,0133037,0152607,0113356, +0137427,0162771,0145061,0126345, +0037224,0070754,0110451,0174104, +0136534,0164165,0072170,0063753, +0035660,0000016,0002560,0147751, +0134646,0110311,0123316,0047432, +0033461,0071250,0101031,0075202, +0132066,0012601,0077305,0170177, +}; +static short B4[32] = { + /* 0040200,0000000,0000000,0000000, */ +0137325,0155602,0162437,0030710, +0137611,0004316,0071344,0176361, +0037306,0106671,0011103,0155053, +0136603,0033412,0132530,0175171, +0035704,0021532,0015516,0166130, +0134661,0074162,0036741,0073466, +0033467,0021316,0003100,0171325, +0132066,0012541,0162202,0150160, +}; +#endif +#if IBMPC +static short A4[] = { +0xf2de,0xfab0,0x76c3,0xbfcf, +0x359d,0x3946,0xfcbf,0xbfc2, +0x3f09,0x9225,0x8e3d,0x3fb2, +0x0cfd,0xae8f,0x9d0e,0xbf8b, +0x19fd,0xc0ae,0x0001,0x3f56, +0xc9e3,0x34d9,0xd219,0xbf14, +0x2f50,0x1043,0x2e55,0x3ec6, +0xbe10,0x2fd8,0xc2b0,0xbe66, +}; +static short B4[] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xe639,0x5ca3,0xbb70,0xbfba, +0x9f9e,0xce5c,0x2119,0xbfd1, +0x7b45,0x2248,0xd1b7,0x3fb8, +0x1f4f,0x56ab,0x66e1,0xbf90, +0xdd8b,0x4369,0x846b,0x3f58, +0x2ee7,0x47bc,0x2f0e,0xbf16, +0x1e5b,0xc0c8,0xe459,0x3ec6, +0x5a0e,0x3c90,0xc2ac,0xbe66, +}; +#endif +#if MIEEE +static short A4[32] = { +0xbfcf,0x76c3,0xfab0,0xf2de, +0xbfc2,0xfcbf,0x3946,0x359d, +0x3fb2,0x8e3d,0x9225,0x3f09, +0xbf8b,0x9d0e,0xae8f,0x0cfd, +0x3f56,0x0001,0xc0ae,0x19fd, +0xbf14,0xd219,0x34d9,0xc9e3, +0x3ec6,0x2e55,0x1043,0x2f50, +0xbe66,0xc2b0,0x2fd8,0xbe10, +}; +static short B4[32] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xbfba,0xbb70,0x5ca3,0xe639, +0xbfd1,0x2119,0xce5c,0x9f9e, +0x3fb8,0xd1b7,0x2248,0x7b45, +0xbf90,0x66e1,0x56ab,0x1f4f, +0x3f58,0x846b,0x4369,0xdd8b, +0xbf16,0x2f0e,0x47bc,0x2ee7, +0x3ec6,0xe459,0xc0c8,0x1e5b, +0xbe66,0xc2ac,0x3c90,0x5a0e, +}; +#endif + + +#if 0 +/* 20 <= x <= 40 + x exp(-x) Ei(x) - 1 = 1/x A4(1/x) / B4(1/x) + Theoretical absolute error = 1.78e-17 */ +#if UNK +static double A4[8] = { + 2.067245813525780707978E-1, +-5.153749551345223645670E-1, + 1.928289589546695033096E-1, +-3.124468842857260044075E-2, + 2.740283734277352539912E-3, +-1.377775664366875175601E-4, + 3.803788980664744242323E-6, +-4.611038277393688031154E-8, +}; +static double B4[8] = { + /* 1.000000000000000000000E0, */ +-8.544436025219516861531E-1, + 2.507436807692907385181E-1, +-3.647688090228423114064E-2, + 3.008576950332041388892E-3, +-1.452926405348421286334E-4, + 3.896007735260115431965E-6, +-4.611037642697098234083E-8, +}; +#endif +#if DEC +static short A4[32] = { +0037523,0127633,0150301,0022031, +0140003,0167634,0170572,0170420, +0037505,0072364,0060672,0063220, +0136777,0172334,0057456,0102640, +0036063,0113125,0002476,0047251, +0135020,0074142,0042600,0043630, +0033577,0042230,0155372,0136105, +0132106,0005346,0165333,0114541, +}; +static short B4[28] = { + /* 0040200,0000000,0000000,0000000, */ +0140132,0136320,0160433,0131535, +0037600,0060571,0144452,0060214, +0137025,0064310,0024220,0176472, +0036105,0025613,0115762,0166605, +0135030,0054662,0035454,0061763, +0033602,0135163,0116430,0000066, +0132106,0005345,0020602,0137133, +}; +#endif +#if IBMPC +static short A4[32] = { +0x2483,0x7a18,0x75f3,0x3fca, +0x5e22,0x9e2f,0x7df3,0xbfe0, +0x4cd2,0x8c37,0xae9e,0x3fc8, +0xd0b4,0x8be5,0xfe9b,0xbf9f, +0xc9d5,0xa0a7,0x72ca,0x3f66, +0x08f3,0x48b0,0x0f0c,0xbf22, +0x5789,0x1b5f,0xe893,0x3ecf, +0x732c,0xdd5b,0xc15c,0xbe68, +}; +static short B4[28] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0x766c,0x1c23,0x579a,0xbfeb, +0x4c11,0x3925,0x0c2f,0x3fd0, +0x1fa7,0x0512,0xad19,0xbfa2, +0x5db1,0x737e,0xa571,0x3f68, +0x8c7e,0x4765,0x0b36,0xbf23, +0x0007,0x73a3,0x574e,0x3ed0, +0x57cb,0xa430,0xc15c,0xbe68, +}; +#endif +#if MIEEE +static short A4[32] = { +0x3fca,0x75f3,0x7a18,0x2483, +0xbfe0,0x7df3,0x9e2f,0x5e22, +0x3fc8,0xae9e,0x8c37,0x4cd2, +0xbf9f,0xfe9b,0x8be5,0xd0b4, +0x3f66,0x72ca,0xa0a7,0xc9d5, +0xbf22,0x0f0c,0x48b0,0x08f3, +0x3ecf,0xe893,0x1b5f,0x5789, +0xbe68,0xc15c,0xdd5b,0x732c, +}; +static short B4[28] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xbfeb,0x579a,0x1c23,0x766c, +0x3fd0,0x0c2f,0x3925,0x4c11, +0xbfa2,0xad19,0x0512,0x1fa7, +0x3f68,0xa571,0x737e,0x5db1, +0xbf23,0x0b36,0x4765,0x8c7e, +0x3ed0,0x574e,0x73a3,0x0007, +0xbe68,0xc15c,0xa430,0x57cb, +}; +#endif +#endif /* 0 */ + +/* 4 <= x <= 8 + x exp(-x) Ei(x) - 1 = 1/x A5(1/x) / B5(1/x) + Theoretical absolute error = 2.20e-17 */ +#if UNK +static double A5[8] = { +-1.373215375871208729803E0, +-7.084559133740838761406E-1, + 1.580806855547941010501E0, +-2.601500427425622944234E-1, + 2.994674694113713763365E-2, +-1.038086040188744005513E-3, + 4.371064420753005429514E-5, + 2.141783679522602903795E-6, +}; +static double B5[8] = { + /* 1.000000000000000000000E0, */ + 8.585231423622028380768E-1, + 4.483285822873995129957E-1, + 7.687932158124475434091E-2, + 2.449868241021887685904E-2, + 8.832165941927796567926E-4, + 4.590952299511353531215E-4, +-4.729848351866523044863E-6, + 2.665195537390710170105E-6, +}; +#endif +#if DEC +static short A5[32] = { +0140257,0142605,0076335,0113632, +0140065,0056535,0161231,0074311, +0040312,0053741,0004357,0076405, +0137605,0031142,0165503,0136705, +0036765,0051341,0053573,0007602, +0135610,0010143,0027643,0110522, +0034467,0052762,0062024,0120161, +0033417,0135620,0036500,0062647, +}; +static short B[32] = { + /* 0040200,0000000,0000000,0000000, */ +0040133,0144054,0031516,0004100, +0037745,0105522,0166622,0123146, +0037235,0071347,0157560,0157464, +0036710,0130565,0173747,0041670, +0035547,0103651,0106243,0101240, +0035360,0131267,0176263,0140257, +0133636,0132426,0102537,0102531, +0033462,0155665,0167503,0176350, +}; +#endif +#if IBMPC +static short A5[32] = { +0xb2f3,0xaf9b,0xf8b0,0xbff5, +0x2f19,0xbc53,0xabab,0xbfe6, +0xefa1,0x211d,0x4afc,0x3ff9, +0x77b9,0x5d68,0xa64c,0xbfd0, +0x61f0,0x2aef,0xaa5c,0x3f9e, +0x722a,0x65f4,0x020c,0xbf51, +0x940e,0x4c82,0xeabe,0x3f06, +0x0cb5,0x07a8,0xf772,0x3ec1, +}; +static short B5[32] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xc108,0x8669,0x7905,0x3feb, +0x54cd,0x5db2,0xb16a,0x3fdc, +0x1be7,0xfbee,0xae5c,0x3fb3, +0xe877,0xbefc,0x162e,0x3f99, +0x7054,0x3194,0xf0f5,0x3f4c, +0x7816,0xff96,0x1656,0x3f3e, +0xf0ab,0xd0ab,0xd6a2,0xbed3, +0x7f9d,0xbde8,0x5b76,0x3ec6, +}; +#endif +#if MIEEE +static short A5[32] = { +0xbff5,0xf8b0,0xaf9b,0xb2f3, +0xbfe6,0xabab,0xbc53,0x2f19, +0x3ff9,0x4afc,0x211d,0xefa1, +0xbfd0,0xa64c,0x5d68,0x77b9, +0x3f9e,0xaa5c,0x2aef,0x61f0, +0xbf51,0x020c,0x65f4,0x722a, +0x3f06,0xeabe,0x4c82,0x940e, +0x3ec1,0xf772,0x07a8,0x0cb5, +}; +static short B5[32] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0x3feb,0x7905,0x8669,0xc108, +0x3fdc,0xb16a,0x5db2,0x54cd, +0x3fb3,0xae5c,0xfbee,0x1be7, +0x3f99,0x162e,0xbefc,0xe877, +0x3f4c,0xf0f5,0x3194,0x7054, +0x3f3e,0x1656,0xff96,0x7816, +0xbed3,0xd6a2,0xd0ab,0xf0ab, +0x3ec6,0x5b76,0xbde8,0x7f9d, +}; +#endif +/* 2 <= x <= 4 + x exp(-x) Ei(x) - 1 = 1/x A6(1/x) / B6(1/x) + Theoretical absolute error = 4.89e-17 */ +#if UNK +static double A6[8] = { + 1.981808503259689673238E-2, +-1.271645625984917501326E0, +-2.088160335681228318920E0, + 2.755544509187936721172E0, +-4.409507048701600257171E-1, + 4.665623805935891391017E-2, +-1.545042679673485262580E-3, + 7.059980605299617478514E-5, +}; +static double B6[7] = { + /* 1.000000000000000000000E0, */ + 1.476498670914921440652E0, + 5.629177174822436244827E-1, + 1.699017897879307263248E-1, + 2.291647179034212017463E-2, + 4.450150439728752875043E-3, + 1.727439612206521482874E-4, + 3.953167195549672482304E-5, +}; +#endif +#if DEC +static short A6[32] = { +0036642,0054611,0061263,0000140, +0140242,0142510,0125732,0072035, +0140405,0122153,0037643,0104527, +0040460,0055327,0055550,0116240, +0137741,0142112,0070441,0103510, +0037077,0015234,0104750,0146765, +0135712,0101407,0107554,0020253, +0034624,0007373,0072621,0063735, +}; +static short B6[28] = { + /* 0040200,0000000,0000000,0000000, */ +0040274,0176750,0110025,0061006, +0040020,0015540,0021354,0155050, +0037455,0175274,0015257,0021112, +0036673,0135523,0016042,0117203, +0036221,0151221,0046352,0144174, +0035065,0021232,0117727,0152432, +0034445,0147317,0037300,0067123, +}; +#endif +#if IBMPC +static short A6[32] = { +0x600c,0x2c56,0x4b31,0x3f94, +0x4e84,0x157b,0x58a9,0xbff4, +0x712b,0x67f4,0xb48d,0xc000, +0x1394,0xeb6d,0x0b5a,0x4006, +0x30e9,0x4e24,0x3889,0xbfdc, +0x19bf,0x913d,0xe353,0x3fa7, +0x8415,0xf1ed,0x5060,0xbf59, +0x2cfc,0x6eb2,0x81df,0x3f12, +}; +static short B6[28] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xac41,0x1202,0x9fbd,0x3ff7, +0x9b45,0x045d,0x036c,0x3fe2, +0xe449,0x8355,0xbf57,0x3fc5, +0x53d0,0x6384,0x776a,0x3f97, +0x590f,0x299d,0x3a52,0x3f72, +0xfaa3,0x53fa,0xa453,0x3f26, +0x0dca,0xe7d8,0xb9d9,0x3f04, +}; +#endif +#if MIEEE +static short A6[32] = { +0x3f94,0x4b31,0x2c56,0x600c, +0xbff4,0x58a9,0x157b,0x4e84, +0xc000,0xb48d,0x67f4,0x712b, +0x4006,0x0b5a,0xeb6d,0x1394, +0xbfdc,0x3889,0x4e24,0x30e9, +0x3fa7,0xe353,0x913d,0x19bf, +0xbf59,0x5060,0xf1ed,0x8415, +0x3f12,0x81df,0x6eb2,0x2cfc, +}; +static short B6[28] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0x3ff7,0x9fbd,0x1202,0xac41, +0x3fe2,0x036c,0x045d,0x9b45, +0x3fc5,0xbf57,0x8355,0xe449, +0x3f97,0x776a,0x6384,0x53d0, +0x3f72,0x3a52,0x299d,0x590f, +0x3f26,0xa453,0x53fa,0xfaa3, +0x3f04,0xb9d9,0xe7d8,0x0dca, +}; +#endif +/* 32 <= x <= 64 + x exp(-x) Ei(x) - 1 = 1/x A7(1/x) / B7(1/x) + Theoretical absolute error = 7.71e-18 */ +#if UNK +static double A7[6] = { + 1.212561118105456670844E-1, +-5.823133179043894485122E-1, + 2.348887314557016779211E-1, +-3.040034318113248237280E-2, + 1.510082146865190661777E-3, +-2.523137095499571377122E-5, +}; +static double B7[5] = { + /* 1.000000000000000000000E0, */ +-1.002252150365854016662E0, + 2.928709694872224144953E-1, +-3.337004338674007801307E-2, + 1.560544881127388842819E-3, +-2.523137093603234562648E-5, +}; +#endif +#if DEC +static short A7[24] = { +0037370,0052437,0152524,0150125, +0140025,0011174,0050154,0131330, +0037560,0103253,0167464,0062245, +0136771,0005043,0174001,0023345, +0035705,0166762,0157300,0016451, +0134323,0123764,0157767,0134477, +}; +static short B7[20] = { + /* 0040200,0000000,0000000,0000000, */ +0140200,0044714,0064025,0060324, +0037625,0171457,0003712,0073131, +0137010,0127406,0150061,0141746, +0035714,0105462,0072356,0103712, +0134323,0123764,0156514,0077414, +}; +#endif +#if IBMPC +static short A7[24] = { +0x9a0b,0xfaaa,0x0aa3,0x3fbf, +0x965b,0x8a0d,0xa24f,0xbfe2, +0x8c95,0x7de6,0x10d5,0x3fce, +0x24dd,0x7f00,0x2144,0xbf9f, +0x03a5,0x5bd8,0xbdbe,0x3f58, +0xf728,0x9bfe,0x74fe,0xbefa, +}; +static short B7[20] = { + /* 0x0000,0x0000,0x0000,0x3ff0, */ +0xac1a,0x8d02,0x0939,0xbff0, +0x4ecb,0xe0f9,0xbe65,0x3fd2, +0x387d,0xda06,0x15e0,0xbfa1, +0xd0f9,0x4e9d,0x9166,0x3f59, +0x8fe2,0x9ba9,0x74fe,0xbefa, +}; +#endif +#if MIEEE +static short A7[24] = { +0x3fbf,0x0aa3,0xfaaa,0x9a0b, +0xbfe2,0xa24f,0x8a0d,0x965b, +0x3fce,0x10d5,0x7de6,0x8c95, +0xbf9f,0x2144,0x7f00,0x24dd, +0x3f58,0xbdbe,0x5bd8,0x03a5, +0xbefa,0x74fe,0x9bfe,0xf728, +}; +static short B7[20] = { + /* 0x3ff0,0x0000,0x0000,0x0000, */ +0xbff0,0x0939,0x8d02,0xac1a, +0x3fd2,0xbe65,0xe0f9,0x4ecb, +0xbfa1,0x15e0,0xda06,0x387d, +0x3f59,0x9166,0x4e9d,0xd0f9, +0xbefa,0x74fe,0x9ba9,0x8fe2, +}; +#endif + +double ei (x) +double x; +{ + double f, w; + + if (x <= 0.0) + { + mtherr("ei", DOMAIN); + return 0.0; + } + else if (x < 2.0) + { + /* Power series. + inf n + - x + Ei(x) = EUL + ln x + > ---- + - n n! + n=1 + */ + f = polevl(x,A,5) / p1evl(x,B,6); + /* f = polevl(x,A,6) / p1evl(x,B,7); */ + /* f = polevl(x,A,8) / p1evl(x,B,9); */ + return (EUL + log(x) + x * f); + } + else if (x < 4.0) + { + /* Asymptotic expansion. + 1 2 6 + x exp(-x) Ei(x) = 1 + --- + --- + ---- + ... + x 2 3 + x x + */ + w = 1.0/x; + f = polevl(w,A6,7) / p1evl(w,B6,7); + return (exp(x) * w * (1.0 + w * f)); + } + else if (x < 8.0) + { + w = 1.0/x; + f = polevl(w,A5,7) / p1evl(w,B5,8); + return (exp(x) * w * (1.0 + w * f)); + } + else if (x < 16.0) + { + w = 1.0/x; + f = polevl(w,A2,9) / p1evl(w,B2,9); + return (exp(x) * w * (1.0 + w * f)); + } + else if (x < 32.0) + { + w = 1.0/x; + f = polevl(w,A4,7) / p1evl(w,B4,8); + return (exp(x) * w * (1.0 + w * f)); + } + else if (x < 64.0) + { + w = 1.0/x; + f = polevl(w,A7,5) / p1evl(w,B7,5); + return (exp(x) * w * (1.0 + w * f)); + } + else + { + w = 1.0/x; + f = polevl(w,A3,8) / p1evl(w,B3,9); + return (exp(x) * w * (1.0 + w * f)); + } +} diff --git a/libm/double/eigens.c b/libm/double/eigens.c new file mode 100644 index 000000000..4035e76a1 --- /dev/null +++ b/libm/double/eigens.c @@ -0,0 +1,181 @@ +/* eigens.c + * + * Eigenvalues and eigenvectors of a real symmetric matrix + * + * + * + * SYNOPSIS: + * + * int n; + * double A[n*(n+1)/2], EV[n*n], E[n]; + * void eigens( A, EV, E, n ); + * + * + * + * DESCRIPTION: + * + * The algorithm is due to J. vonNeumann. + * + * A[] is a symmetric matrix stored in lower triangular form. + * That is, A[ row, column ] = A[ (row*row+row)/2 + column ] + * or equivalently with row and column interchanged. The + * indices row and column run from 0 through n-1. + * + * EV[] is the output matrix of eigenvectors stored columnwise. + * That is, the elements of each eigenvector appear in sequential + * memory order. The jth element of the ith eigenvector is + * EV[ n*i+j ] = EV[i][j]. + * + * E[] is the output matrix of eigenvalues. The ith element + * of E corresponds to the ith eigenvector (the ith row of EV). + * + * On output, the matrix A will have been diagonalized and its + * orginal contents are destroyed. + * + * ACCURACY: + * + * The error is controlled by an internal parameter called RANGE + * which is set to 1e-10. After diagonalization, the + * off-diagonal elements of A will have been reduced by + * this factor. + * + * ERROR MESSAGES: + * + * None. + * + */ + +#include <math.h> +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double fabs ( double ); +#else +double sqrt(), fabs(); +#endif + +void eigens( A, RR, E, N ) +double A[], RR[], E[]; +int N; +{ +int IND, L, LL, LM, M, MM, MQ, I, J, IA, LQ; +int IQ, IM, IL, NLI, NMI; +double ANORM, ANORMX, AIA, THR, ALM, ALL, AMM, X, Y; +double SINX, SINX2, COSX, COSX2, SINCS, AIL, AIM; +double RLI, RMI; +static double RANGE = 1.0e-10; /*3.0517578e-5;*/ + + +/* Initialize identity matrix in RR[] */ +for( J=0; J<N*N; J++ ) + RR[J] = 0.0; +MM = 0; +for( J=0; J<N; J++ ) + { + RR[MM + J] = 1.0; + MM += N; + } + +ANORM=0.0; +for( I=0; I<N; I++ ) + { + for( J=0; J<N; J++ ) + { + if( I != J ) + { + IA = I + (J*J+J)/2; + AIA = A[IA]; + ANORM += AIA * AIA; + } + } + } +if( ANORM <= 0.0 ) + goto done; +ANORM = sqrt( ANORM + ANORM ); +ANORMX = ANORM * RANGE / N; +THR = ANORM; + +while( THR > ANORMX ) +{ +THR=THR/N; + +do +{ /* while IND != 0 */ +IND = 0; + +for( L=0; L<N-1; L++ ) + { + +for( M=L+1; M<N; M++ ) + { + MQ=(M*M+M)/2; + LM=L+MQ; + ALM=A[LM]; + if( fabs(ALM) < THR ) + continue; + + IND=1; + LQ=(L*L+L)/2; + LL=L+LQ; + MM=M+MQ; + ALL=A[LL]; + AMM=A[MM]; + X=(ALL-AMM)/2.0; + Y=-ALM/sqrt(ALM*ALM+X*X); + if(X < 0.0) + Y=-Y; + SINX = Y / sqrt( 2.0 * (1.0 + sqrt( 1.0-Y*Y)) ); + SINX2=SINX*SINX; + COSX=sqrt(1.0-SINX2); + COSX2=COSX*COSX; + SINCS=SINX*COSX; + +/* ROTATE L AND M COLUMNS */ +for( I=0; I<N; I++ ) + { + IQ=(I*I+I)/2; + if( (I != M) && (I != L) ) + { + if(I > M) + IM=M+IQ; + else + IM=I+MQ; + if(I >= L) + IL=L+IQ; + else + IL=I+LQ; + AIL=A[IL]; + AIM=A[IM]; + X=AIL*COSX-AIM*SINX; + A[IM]=AIL*SINX+AIM*COSX; + A[IL]=X; + } + NLI = N*L + I; + NMI = N*M + I; + RLI = RR[ NLI ]; + RMI = RR[ NMI ]; + RR[NLI]=RLI*COSX-RMI*SINX; + RR[NMI]=RLI*SINX+RMI*COSX; + } + + X=2.0*ALM*SINCS; + A[LL]=ALL*COSX2+AMM*SINX2-X; + A[MM]=ALL*SINX2+AMM*COSX2+X; + A[LM]=(ALL-AMM)*SINCS+ALM*(COSX2-SINX2); + } /* for M=L+1 to N-1 */ + } /* for L=0 to N-2 */ + + } +while( IND != 0 ); + +} /* while THR > ANORMX */ + +done: ; + +/* Extract eigenvalues from the reduced matrix */ +L=0; +for( J=1; J<=N; J++ ) + { + L=L+J; + E[J-1]=A[L-1]; + } +} diff --git a/libm/double/ellie.c b/libm/double/ellie.c new file mode 100644 index 000000000..4f3379aa6 --- /dev/null +++ b/libm/double/ellie.c @@ -0,0 +1,148 @@ +/* ellie.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * double phi, m, y, ellie(); + * + * y = ellie( 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 + * DEC 0,2 2000 1.9e-16 3.4e-17 + * IEEE -10,10 150000 3.3e-15 1.4e-16 + * + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1993, 2000 by Stephen L. Moshier +*/ + +/* Incomplete elliptic integral of second kind */ +#include <math.h> +extern double PI, PIO2, MACHEP; +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double fabs ( double ); +extern double log ( double ); +extern double sin ( double x ); +extern double tan ( double x ); +extern double atan ( double ); +extern double floor ( double ); +extern double ellpe ( double ); +extern double ellpk ( double ); +double ellie ( double, double ); +#else +double sqrt(), fabs(), log(), sin(), tan(), atan(), floor(); +double ellpe(), ellpk(), ellie(); +#endif + +double ellie( phi, m ) +double phi, m; +{ +double a, b, c, e, temp; +double lphi, t, E; +int d, mod, npio2, sign; + +if( m == 0.0 ) + return( phi ); +lphi = phi; +npio2 = floor( lphi/PIO2 ); +if( npio2 & 1 ) + npio2 += 1; +lphi = lphi - npio2 * PIO2; +if( lphi < 0.0 ) + { + lphi = -lphi; + sign = -1; + } +else + { + sign = 1; + } +a = 1.0 - m; +E = ellpe( a ); +if( a == 0.0 ) + { + temp = sin( lphi ); + goto done; + } +t = tan( lphi ); +b = sqrt(a); +/* Thanks to Brian Fitzgerald <fitzgb@mml0.meche.rpi.edu> + for pointing out an instability near odd multiples of pi/2. */ +if( fabs(t) > 10.0 ) + { + /* Transform the amplitude */ + e = 1.0/(b*t); + /* ... but avoid multiple recursions. */ + if( fabs(e) < 10.0 ) + { + e = atan(e); + temp = E + m * sin( lphi ) * sin( e ) - ellie( e, m ); + goto done; + } + } +c = sqrt(m); +a = 1.0; +d = 1; +e = 0.0; +mod = 0; + +while( fabs(c/a) > MACHEP ) + { + temp = b/a; + lphi = lphi + atan(t*temp) + mod * PI; + mod = (lphi + PIO2)/PI; + t = t * ( 1.0 + temp )/( 1.0 - temp * t * t ); + c = ( a - b )/2.0; + temp = sqrt( a * b ); + a = ( a + b )/2.0; + b = temp; + d += d; + e += c * sin(lphi); + } + +temp = E / ellpk( 1.0 - m ); +temp *= (atan(t) + mod * PI)/(d * a); +temp += e; + +done: + +if( sign < 0 ) + temp = -temp; +temp += npio2 * E; +return( temp ); +} diff --git a/libm/double/ellik.c b/libm/double/ellik.c new file mode 100644 index 000000000..1c9053676 --- /dev/null +++ b/libm/double/ellik.c @@ -0,0 +1,148 @@ +/* ellik.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * double phi, m, y, ellik(); + * + * y = ellik( 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 200000 7.4e-16 1.0e-16 + * + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +/* Incomplete elliptic integral of first kind */ + +#include <math.h> +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double fabs ( double ); +extern double log ( double ); +extern double tan ( double ); +extern double atan ( double ); +extern double floor ( double ); +extern double ellpk ( double ); +double ellik ( double, double ); +#else +double sqrt(), fabs(), log(), tan(), atan(), floor(), ellpk(); +double ellik(); +#endif +extern double PI, PIO2, MACHEP, MAXNUM; + +double ellik( phi, m ) +double phi, m; +{ +double a, b, c, e, temp, t, K; +int d, mod, sign, npio2; + +if( m == 0.0 ) + return( phi ); +a = 1.0 - m; +if( a == 0.0 ) + { + if( fabs(phi) >= PIO2 ) + { + mtherr( "ellik", SING ); + return( MAXNUM ); + } + return( log( tan( (PIO2 + phi)/2.0 ) ) ); + } +npio2 = floor( phi/PIO2 ); +if( npio2 & 1 ) + npio2 += 1; +if( npio2 ) + { + K = ellpk( a ); + phi = phi - npio2 * PIO2; + } +else + K = 0.0; +if( phi < 0.0 ) + { + phi = -phi; + sign = -1; + } +else + sign = 0; +b = sqrt(a); +t = tan( phi ); +if( fabs(t) > 10.0 ) + { + /* Transform the amplitude */ + e = 1.0/(b*t); + /* ... but avoid multiple recursions. */ + if( fabs(e) < 10.0 ) + { + e = atan(e); + if( npio2 == 0 ) + K = ellpk( a ); + temp = K - ellik( e, m ); + goto done; + } + } +a = 1.0; +c = sqrt(m); +d = 1; +mod = 0; + +while( fabs(c/a) > MACHEP ) + { + temp = b/a; + phi = phi + atan(t*temp) + mod * PI; + mod = (phi + PIO2)/PI; + t = t * ( 1.0 + temp )/( 1.0 - temp * t * t ); + c = ( a - b )/2.0; + temp = sqrt( a * b ); + a = ( a + b )/2.0; + b = temp; + d += d; + } + +temp = (atan(t) + mod * PI)/(d * a); + +done: +if( sign < 0 ) + temp = -temp; +temp += npio2 * K; +return( temp ); +} diff --git a/libm/double/ellpe.c b/libm/double/ellpe.c new file mode 100644 index 000000000..9b2438e0e --- /dev/null +++ b/libm/double/ellpe.c @@ -0,0 +1,195 @@ +/* ellpe.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * double m1, y, ellpe(); + * + * y = ellpe( 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 + * DEC 0, 1 13000 3.1e-17 9.4e-18 + * IEEE 0, 1 10000 2.1e-16 7.3e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpe domain x<0, x>1 0.0 + * + */ + +/* ellpe.c */ + +/* Elliptic integral of second kind */ + +/* +Cephes Math Library, Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { + 1.53552577301013293365E-4, + 2.50888492163602060990E-3, + 8.68786816565889628429E-3, + 1.07350949056076193403E-2, + 7.77395492516787092951E-3, + 7.58395289413514708519E-3, + 1.15688436810574127319E-2, + 2.18317996015557253103E-2, + 5.68051945617860553470E-2, + 4.43147180560990850618E-1, + 1.00000000000000000299E0 +}; +static double Q[] = { + 3.27954898576485872656E-5, + 1.00962792679356715133E-3, + 6.50609489976927491433E-3, + 1.68862163993311317300E-2, + 2.61769742454493659583E-2, + 3.34833904888224918614E-2, + 4.27180926518931511717E-2, + 5.85936634471101055642E-2, + 9.37499997197644278445E-2, + 2.49999999999888314361E-1 +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0035041,0001364,0141572,0117555, +0036044,0066032,0130027,0033404, +0036416,0053617,0064456,0102632, +0036457,0161100,0061177,0122612, +0036376,0136251,0012403,0124162, +0036370,0101316,0151715,0131613, +0036475,0105477,0050317,0133272, +0036662,0154232,0024645,0171552, +0037150,0126220,0047054,0030064, +0037742,0162057,0167645,0165612, +0040200,0000000,0000000,0000000 +}; +static unsigned short Q[] = { +0034411,0106743,0115771,0055462, +0035604,0052575,0155171,0045540, +0036325,0030424,0064332,0167756, +0036612,0052366,0063006,0115175, +0036726,0070430,0004533,0124654, +0037011,0022741,0030675,0030711, +0037056,0174452,0127062,0132122, +0037157,0177750,0142041,0072523, +0037277,0177777,0173137,0002627, +0037577,0177777,0177777,0101101 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x53ee,0x986f,0x205e,0x3f24, +0xe6e0,0x5602,0x8d83,0x3f64, +0xd0b3,0xed25,0xcaf1,0x3f81, +0xf4b1,0x0c4f,0xfc48,0x3f85, +0x750e,0x22a0,0xd795,0x3f7f, +0xb671,0xda79,0x1059,0x3f7f, +0xf6d7,0xea19,0xb167,0x3f87, +0xbe6d,0x4534,0x5b13,0x3f96, +0x8607,0x09c5,0x1592,0x3fad, +0xbd71,0xfdf4,0x5c85,0x3fdc, +0x0000,0x0000,0x0000,0x3ff0 +}; +static unsigned short Q[] = { +0x2b66,0x737f,0x31bc,0x3f01, +0x296c,0xbb4f,0x8aaf,0x3f50, +0x5dfe,0x8d1b,0xa622,0x3f7a, +0xd350,0xccc0,0x4a9e,0x3f91, +0x7535,0x012b,0xce23,0x3f9a, +0xa639,0x2637,0x24bc,0x3fa1, +0x568a,0x55c6,0xdf25,0x3fa5, +0x2eaa,0x1884,0xfffd,0x3fad, +0xe0b3,0xfecb,0xffff,0x3fb7, +0xf048,0xffff,0xffff,0x3fcf +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f24,0x205e,0x986f,0x53ee, +0x3f64,0x8d83,0x5602,0xe6e0, +0x3f81,0xcaf1,0xed25,0xd0b3, +0x3f85,0xfc48,0x0c4f,0xf4b1, +0x3f7f,0xd795,0x22a0,0x750e, +0x3f7f,0x1059,0xda79,0xb671, +0x3f87,0xb167,0xea19,0xf6d7, +0x3f96,0x5b13,0x4534,0xbe6d, +0x3fad,0x1592,0x09c5,0x8607, +0x3fdc,0x5c85,0xfdf4,0xbd71, +0x3ff0,0x0000,0x0000,0x0000 +}; +static unsigned short Q[] = { +0x3f01,0x31bc,0x737f,0x2b66, +0x3f50,0x8aaf,0xbb4f,0x296c, +0x3f7a,0xa622,0x8d1b,0x5dfe, +0x3f91,0x4a9e,0xccc0,0xd350, +0x3f9a,0xce23,0x012b,0x7535, +0x3fa1,0x24bc,0x2637,0xa639, +0x3fa5,0xdf25,0x55c6,0x568a, +0x3fad,0xfffd,0x1884,0x2eaa, +0x3fb7,0xffff,0xfecb,0xe0b3, +0x3fcf,0xffff,0xffff,0xf048 +}; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double log ( double ); +#else +double polevl(), log(); +#endif + +double ellpe(x) +double x; +{ + +if( (x <= 0.0) || (x > 1.0) ) + { + if( x == 0.0 ) + return( 1.0 ); + mtherr( "ellpe", DOMAIN ); + return( 0.0 ); + } +return( polevl(x,P,10) - log(x) * (x * polevl(x,Q,9)) ); +} diff --git a/libm/double/ellpj.c b/libm/double/ellpj.c new file mode 100644 index 000000000..327fc56e8 --- /dev/null +++ b/libm/double/ellpj.c @@ -0,0 +1,171 @@ +/* ellpj.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * double u, m, sn, cn, dn, phi; + * int ellpj(); + * + * ellpj( 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-9 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 + * DEC sn 1800 4.5e-16 8.7e-17 + * IEEE phi 10000 9.2e-16* 1.4e-16* + * IEEE sn 50000 4.1e-15 4.6e-16 + * IEEE cn 40000 3.6e-15 4.4e-16 + * IEEE dn 10000 1.3e-12 1.8e-14 + * + * Peak error observed in consistency check using addition + * theorem for sn(u+v) was 4e-16 (absolute). Also tested by + * the above relation to the incomplete elliptic integral. + * Accuracy deteriorates when u is large. + * + */ + +/* ellpj.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double fabs ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern double asin ( double ); +extern double tanh ( double ); +extern double sinh ( double ); +extern double cosh ( double ); +extern double atan ( double ); +extern double exp ( double ); +#else +double sqrt(), fabs(), sin(), cos(), asin(), tanh(); +double sinh(), cosh(), atan(), exp(); +#endif +extern double PIO2, MACHEP; + +int ellpj( u, m, sn, cn, dn, ph ) +double u, m; +double *sn, *cn, *dn, *ph; +{ +double ai, b, phi, t, twon; +double a[9], c[9]; +int i; + + +/* Check for special cases */ + +if( m < 0.0 || m > 1.0 ) + { + mtherr( "ellpj", DOMAIN ); + *sn = 0.0; + *cn = 0.0; + *ph = 0.0; + *dn = 0.0; + return(-1); + } +if( m < 1.0e-9 ) + { + t = sin(u); + b = cos(u); + ai = 0.25 * m * (u - t*b); + *sn = t - ai*b; + *cn = b + ai*t; + *ph = u - ai; + *dn = 1.0 - 0.5*m*t*t; + return(0); + } + +if( m >= 0.9999999999 ) + { + ai = 0.25 * (1.0-m); + b = cosh(u); + t = tanh(u); + phi = 1.0/b; + twon = b * sinh(u); + *sn = t + ai * (twon - u)/(b*b); + *ph = 2.0*atan(exp(u)) - PIO2 + 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.0; +b = sqrt(1.0 - m); +c[0] = sqrt(m); +twon = 1.0; +i = 0; + +while( fabs(c[i]/a[i]) > MACHEP ) + { + if( i > 7 ) + { + mtherr( "ellpj", OVERFLOW ); + goto done; + } + ai = a[i]; + ++i; + c[i] = ( ai - b )/2.0; + t = sqrt( ai * b ); + a[i] = ( ai + b )/2.0; + b = t; + twon *= 2.0; + } + +done: + +/* backward recurrence */ +phi = twon * a[i] * u; +do + { + t = c[i] * sin(phi) / a[i]; + b = phi; + phi = (asin(t) + phi)/2.0; + } +while( --i ); + +*sn = sin(phi); +t = cos(phi); +*cn = t; +*dn = t/cos(phi-b); +*ph = phi; +return(0); +} diff --git a/libm/double/ellpk.c b/libm/double/ellpk.c new file mode 100644 index 000000000..8b36690e2 --- /dev/null +++ b/libm/double/ellpk.c @@ -0,0 +1,234 @@ +/* ellpk.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * double m1, y, ellpk(); + * + * y = ellpk( 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 + * DEC 0,1 16000 3.5e-17 1.1e-17 + * IEEE 0,1 30000 2.5e-16 6.8e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpk domain x<0, x>1 0.0 + * + */ + +/* ellpk.c */ + + +/* +Cephes Math Library, Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef DEC +static unsigned short P[] = +{ +0035020,0127576,0040430,0051544, +0036025,0070136,0042703,0153716, +0036402,0122614,0062555,0077777, +0036441,0102130,0072334,0025172, +0036341,0043320,0117242,0172076, +0036312,0146456,0077242,0154141, +0036420,0003467,0013727,0035407, +0036564,0137263,0110651,0020237, +0036775,0001330,0144056,0020305, +0037305,0144137,0157521,0141734, +0040261,0071027,0173721,0147572 +}; +static unsigned short Q[] = +{ +0034366,0130371,0103453,0077633, +0035557,0122745,0173515,0113016, +0036302,0124470,0167304,0074473, +0036575,0132403,0117226,0117576, +0036703,0156271,0047124,0147733, +0036766,0137465,0002053,0157312, +0037031,0014423,0154274,0176515, +0037107,0177747,0143216,0016145, +0037217,0177777,0172621,0074000, +0037377,0177777,0177776,0156435, +0040000,0000000,0000000,0000000 +}; +static unsigned short ac1[] = {0040261,0071027,0173721,0147572}; +#define C1 (*(double *)ac1) +#endif + +#ifdef IBMPC +static unsigned short P[] = +{ +0x0a6d,0xc823,0x15ef,0x3f22, +0x7afa,0xc8b8,0xae0b,0x3f62, +0xb000,0x8cad,0x54b1,0x3f80, +0x854f,0x0e9b,0x308b,0x3f84, +0x5e88,0x13d4,0x28da,0x3f7c, +0x5b0c,0xcfd4,0x59a5,0x3f79, +0xe761,0xe2fa,0x00e6,0x3f82, +0x2414,0x7235,0x97d6,0x3f8e, +0xc419,0x1905,0xa05b,0x3f9f, +0x387c,0xfbea,0xb90b,0x3fb8, +0x39ef,0xfefa,0x2e42,0x3ff6 +}; +static unsigned short Q[] = +{ +0x6ff3,0x30e5,0xd61f,0x3efe, +0xb2c2,0xbee9,0xf4bc,0x3f4d, +0x8f27,0x1dd8,0x5527,0x3f78, +0xd3f0,0x73d2,0xb6a0,0x3f8f, +0x99fb,0x29ca,0x7b97,0x3f98, +0x7bd9,0xa085,0xd7e6,0x3f9e, +0x9faa,0x7b17,0x2322,0x3fa3, +0xc38d,0xf8d1,0xfffc,0x3fa8, +0x2f00,0xfeb2,0xffff,0x3fb1, +0xdba4,0xffff,0xffff,0x3fbf, +0x0000,0x0000,0x0000,0x3fe0 +}; +static unsigned short ac1[] = {0x39ef,0xfefa,0x2e42,0x3ff6}; +#define C1 (*(double *)ac1) +#endif + +#ifdef MIEEE +static unsigned short P[] = +{ +0x3f22,0x15ef,0xc823,0x0a6d, +0x3f62,0xae0b,0xc8b8,0x7afa, +0x3f80,0x54b1,0x8cad,0xb000, +0x3f84,0x308b,0x0e9b,0x854f, +0x3f7c,0x28da,0x13d4,0x5e88, +0x3f79,0x59a5,0xcfd4,0x5b0c, +0x3f82,0x00e6,0xe2fa,0xe761, +0x3f8e,0x97d6,0x7235,0x2414, +0x3f9f,0xa05b,0x1905,0xc419, +0x3fb8,0xb90b,0xfbea,0x387c, +0x3ff6,0x2e42,0xfefa,0x39ef +}; +static unsigned short Q[] = +{ +0x3efe,0xd61f,0x30e5,0x6ff3, +0x3f4d,0xf4bc,0xbee9,0xb2c2, +0x3f78,0x5527,0x1dd8,0x8f27, +0x3f8f,0xb6a0,0x73d2,0xd3f0, +0x3f98,0x7b97,0x29ca,0x99fb, +0x3f9e,0xd7e6,0xa085,0x7bd9, +0x3fa3,0x2322,0x7b17,0x9faa, +0x3fa8,0xfffc,0xf8d1,0xc38d, +0x3fb1,0xffff,0xfeb2,0x2f00, +0x3fbf,0xffff,0xffff,0xdba4, +0x3fe0,0x0000,0x0000,0x0000 +}; +static unsigned short ac1[] = { +0x3ff6,0x2e42,0xfefa,0x39ef +}; +#define C1 (*(double *)ac1) +#endif + +#ifdef UNK +static double P[] = +{ + 1.37982864606273237150E-4, + 2.28025724005875567385E-3, + 7.97404013220415179367E-3, + 9.85821379021226008714E-3, + 6.87489687449949877925E-3, + 6.18901033637687613229E-3, + 8.79078273952743772254E-3, + 1.49380448916805252718E-2, + 3.08851465246711995998E-2, + 9.65735902811690126535E-2, + 1.38629436111989062502E0 +}; + +static double Q[] = +{ + 2.94078955048598507511E-5, + 9.14184723865917226571E-4, + 5.94058303753167793257E-3, + 1.54850516649762399335E-2, + 2.39089602715924892727E-2, + 3.01204715227604046988E-2, + 3.73774314173823228969E-2, + 4.88280347570998239232E-2, + 7.03124996963957469739E-2, + 1.24999999999870820058E-1, + 4.99999999999999999821E-1 +}; +static double C1 = 1.3862943611198906188E0; /* log(4) */ +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double log ( double ); +#else +double polevl(), p1evl(), log(); +#endif +extern double MACHEP, MAXNUM; + +double ellpk(x) +double x; +{ + +if( (x < 0.0) || (x > 1.0) ) + { + mtherr( "ellpk", DOMAIN ); + return( 0.0 ); + } + +if( x > MACHEP ) + { + return( polevl(x,P,10) - log(x) * polevl(x,Q,10) ); + } +else + { + if( x == 0.0 ) + { + mtherr( "ellpk", SING ); + return( MAXNUM ); + } + else + { + return( C1 - 0.5 * log(x) ); + } + } +} diff --git a/libm/double/eltst.c b/libm/double/eltst.c new file mode 100644 index 000000000..cef249eaf --- /dev/null +++ b/libm/double/eltst.c @@ -0,0 +1,37 @@ +extern double MACHEP, PIO2, PI; +double ellie(), ellpe(), floor(), fabs(); +double ellie2(); + +main() +{ +double y, m, phi, e, E, phipi, y1; +int i, j, npi; + +/* dprec(); */ +m = 0.9; +E = ellpe(0.1); +for( j=-10; j<=10; j++ ) + { + printf( "%d * PIO2\n", j ); + for( i=-2; i<=2; i++ ) + { + phi = PIO2 * j + 50 * MACHEP * i; + npi = floor(phi/PIO2); + if( npi & 1 ) + npi += 1; + phipi = phi - npi * PIO2; + npi = floor(phi/PIO2); + if( npi & 1 ) + npi += 1; + phipi = phi - npi * PIO2; + printf( "phi %.9e npi %d ", phi, npi ); + y1 = E * npi + ellie(phipi,m); + y = ellie2( phi, m ); + printf( "y %.9e ", y ); + e = fabs(y - y1); + if( y1 != 0.0 ) + e /= y1; + printf( "e %.4e\n", e ); + } + } +} diff --git a/libm/double/euclid.c b/libm/double/euclid.c new file mode 100644 index 000000000..3a899a6d2 --- /dev/null +++ b/libm/double/euclid.c @@ -0,0 +1,251 @@ +/* euclid.c + * + * Rational arithmetic routines + * + * + * + * SYNOPSIS: + * + * + * typedef struct + * { + * double n; numerator + * double d; denominator + * }fract; + * + * radd( a, b, c ) c = b + a + * rsub( a, b, c ) c = b - a + * rmul( a, b, c ) c = b * a + * rdiv( a, b, c ) c = b / a + * euclid( &n, &d ) Reduce n/d to lowest terms, + * return greatest common divisor. + * + * Arguments of the routines are pointers to the structures. + * The double precision numbers are assumed, without checking, + * to be integer valued. Overflow conditions are reported. + */ + + +#include <math.h> +#ifdef ANSIPROT +extern double fabs ( double ); +extern double floor ( double ); +double euclid( double *, double * ); +#else +double fabs(), floor(), euclid(); +#endif + +extern double MACHEP; +#define BIG (1.0/MACHEP) + +typedef struct + { + double n; /* numerator */ + double d; /* denominator */ + }fract; + +/* Add fractions. */ + +void radd( f1, f2, f3 ) +fract *f1, *f2, *f3; +{ +double gcd, d1, d2, gcn, n1, n2; + +n1 = f1->n; +d1 = f1->d; +n2 = f2->n; +d2 = f2->d; +if( n1 == 0.0 ) + { + f3->n = n2; + f3->d = d2; + return; + } +if( n2 == 0.0 ) + { + f3->n = n1; + f3->d = d1; + return; + } + +gcd = euclid( &d1, &d2 ); /* common divisors of denominators */ +gcn = euclid( &n1, &n2 ); /* common divisors of numerators */ +/* Note, factoring the numerators + * makes overflow slightly less likely. + */ +f3->n = ( n1 * d2 + n2 * d1) * gcn; +f3->d = d1 * d2 * gcd; +euclid( &f3->n, &f3->d ); +} + + +/* Subtract fractions. */ + +void rsub( f1, f2, f3 ) +fract *f1, *f2, *f3; +{ +double gcd, d1, d2, gcn, n1, n2; + +n1 = f1->n; +d1 = f1->d; +n2 = f2->n; +d2 = f2->d; +if( n1 == 0.0 ) + { + f3->n = n2; + f3->d = d2; + return; + } +if( n2 == 0.0 ) + { + f3->n = -n1; + f3->d = d1; + return; + } + +gcd = euclid( &d1, &d2 ); +gcn = euclid( &n1, &n2 ); +f3->n = (n2 * d1 - n1 * d2) * gcn; +f3->d = d1 * d2 * gcd; +euclid( &f3->n, &f3->d ); +} + + + + +/* Multiply fractions. */ + +void rmul( ff1, ff2, ff3 ) +fract *ff1, *ff2, *ff3; +{ +double d1, d2, n1, n2; + +n1 = ff1->n; +d1 = ff1->d; +n2 = ff2->n; +d2 = ff2->d; + +if( (n1 == 0.0) || (n2 == 0.0) ) + { + ff3->n = 0.0; + ff3->d = 1.0; + return; + } +euclid( &n1, &d2 ); /* cross cancel common divisors */ +euclid( &n2, &d1 ); +ff3->n = n1 * n2; +ff3->d = d1 * d2; +/* Report overflow. */ +if( (fabs(ff3->n) >= BIG) || (fabs(ff3->d) >= BIG) ) + { + mtherr( "rmul", OVERFLOW ); + return; + } +/* euclid( &ff3->n, &ff3->d );*/ +} + + + +/* Divide fractions. */ + +void rdiv( ff1, ff2, ff3 ) +fract *ff1, *ff2, *ff3; +{ +double d1, d2, n1, n2; + +n1 = ff1->d; /* Invert ff1, then multiply */ +d1 = ff1->n; +if( d1 < 0.0 ) + { /* keep denominator positive */ + n1 = -n1; + d1 = -d1; + } +n2 = ff2->n; +d2 = ff2->d; +if( (n1 == 0.0) || (n2 == 0.0) ) + { + ff3->n = 0.0; + ff3->d = 1.0; + return; + } + +euclid( &n1, &d2 ); /* cross cancel any common divisors */ +euclid( &n2, &d1 ); +ff3->n = n1 * n2; +ff3->d = d1 * d2; +/* Report overflow. */ +if( (fabs(ff3->n) >= BIG) || (fabs(ff3->d) >= BIG) ) + { + mtherr( "rdiv", OVERFLOW ); + return; + } +/* euclid( &ff3->n, &ff3->d );*/ +} + + + + + +/* Euclidean algorithm + * reduces fraction to lowest terms, + * returns greatest common divisor. + */ + + +double euclid( num, den ) +double *num, *den; +{ +double n, d, q, r; + +n = *num; /* Numerator. */ +d = *den; /* Denominator. */ + +/* Make numbers positive, locally. */ +if( n < 0.0 ) + n = -n; +if( d < 0.0 ) + d = -d; + +/* Abort if numbers are too big for integer arithmetic. */ +if( (n >= BIG) || (d >= BIG) ) + { + mtherr( "euclid", OVERFLOW ); + return(1.0); + } + +/* Divide by zero, gcd = 1. */ +if(d == 0.0) + return( 1.0 ); + +/* Zero. Return 0/1, gcd = denominator. */ +if(n == 0.0) + { +/* + if( *den < 0.0 ) + *den = -1.0; + else + *den = 1.0; +*/ + *den = 1.0; + return( d ); + } + +while( d > 0.5 ) + { +/* Find integer part of n divided by d. */ + q = floor( n/d ); +/* Find remainder after dividing n by d. */ + r = n - d * q; +/* The next fraction is d/r. */ + n = d; + d = r; + } + +if( n < 0.0 ) + mtherr( "euclid", UNDERFLOW ); + +*num /= n; +*den /= n; +return( n ); +} + diff --git a/libm/double/exp.c b/libm/double/exp.c new file mode 100644 index 000000000..6d0a8a872 --- /dev/null +++ b/libm/double/exp.c @@ -0,0 +1,203 @@ +/* exp.c + * + * Exponential function + * + * + * + * SYNOPSIS: + * + * double x, y, exp(); + * + * y = exp( 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 1 + 2x P(x**2)/( Q(x**2) - P(x**2) ) + * of degree 2/3 is used to approximate exp(f) in the basic + * interval [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +- 88 50000 2.8e-17 7.0e-18 + * IEEE +- 708 40000 2.0e-16 5.6e-17 + * + * + * 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 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 INFINITY + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +/* Exponential function */ + +#include <math.h> + +#ifdef UNK + +static double P[] = { + 1.26177193074810590878E-4, + 3.02994407707441961300E-2, + 9.99999999999999999910E-1, +}; +static double Q[] = { + 3.00198505138664455042E-6, + 2.52448340349684104192E-3, + 2.27265548208155028766E-1, + 2.00000000000000000009E0, +}; +static double C1 = 6.93145751953125E-1; +static double C2 = 1.42860682030941723212E-6; +#endif + +#ifdef DEC +static unsigned short P[] = { +0035004,0047156,0127442,0057502, +0036770,0033210,0063121,0061764, +0040200,0000000,0000000,0000000, +}; +static unsigned short Q[] = { +0033511,0072665,0160662,0176377, +0036045,0070715,0124105,0132777, +0037550,0134114,0142077,0001637, +0040400,0000000,0000000,0000000, +}; +static unsigned short sc1[] = {0040061,0071000,0000000,0000000}; +#define C1 (*(double *)sc1) +static unsigned short sc2[] = {0033277,0137216,0075715,0057117}; +#define C2 (*(double *)sc2) +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x4be8,0xd5e4,0x89cd,0x3f20, +0x2c7e,0x0cca,0x06d1,0x3f9f, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short Q[] = { +0x5fa0,0xbc36,0x2eb6,0x3ec9, +0xb6c0,0xb508,0xae39,0x3f64, +0xe074,0x9887,0x1709,0x3fcd, +0x0000,0x0000,0x0000,0x4000, +}; +static unsigned short sc1[] = {0x0000,0x0000,0x2e40,0x3fe6}; +#define C1 (*(double *)sc1) +static unsigned short sc2[] = {0xabca,0xcf79,0xf7d1,0x3eb7}; +#define C2 (*(double *)sc2) +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f20,0x89cd,0xd5e4,0x4be8, +0x3f9f,0x06d1,0x0cca,0x2c7e, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short Q[] = { +0x3ec9,0x2eb6,0xbc36,0x5fa0, +0x3f64,0xae39,0xb508,0xb6c0, +0x3fcd,0x1709,0x9887,0xe074, +0x4000,0x0000,0x0000,0x0000, +}; +static unsigned short sc1[] = {0x3fe6,0x2e40,0x0000,0x0000}; +#define C1 (*(double *)sc1) +static unsigned short sc2[] = {0x3eb7,0xf7d1,0xcf79,0xabca}; +#define C2 (*(double *)sc2) +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double polevl(), p1evl(), floor(), ldexp(); +int isnan(), isfinite(); +#endif +extern double LOGE2, LOG2E, MAXLOG, MINLOG, MAXNUM; +#ifdef INFINITIES +extern double INFINITY; +#endif + +double exp(x) +double x; +{ +double px, xx; +int n; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +if( x > MAXLOG) + { +#ifdef INFINITIES + return( INFINITY ); +#else + mtherr( "exp", OVERFLOW ); + return( MAXNUM ); +#endif + } + +if( x < MINLOG ) + { +#ifndef INFINITIES + mtherr( "exp", UNDERFLOW ); +#endif + return(0.0); + } + +/* Express e**x = e**g 2**n + * = e**g e**( n loge(2) ) + * = e**( g + n loge(2) ) + */ +px = floor( LOG2E * x + 0.5 ); /* 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 * polevl( xx, P, 2 ); +x = px/( polevl( xx, Q, 3 ) - px ); +x = 1.0 + 2.0 * x; + +/* multiply by power of 2 */ +x = ldexp( x, n ); +return(x); +} diff --git a/libm/double/exp10.c b/libm/double/exp10.c new file mode 100644 index 000000000..dd0e5a48f --- /dev/null +++ b/libm/double/exp10.c @@ -0,0 +1,223 @@ +/* exp10.c + * + * Base 10 exponential function + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * double x, y, exp10(); + * + * y = exp10( 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 -307,+307 30000 2.2e-16 5.5e-17 + * Test result from an earlier version (2.1): + * DEC -38,+38 70000 3.1e-17 7.0e-18 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10 underflow x < -MAXL10 0.0 + * exp10 overflow x > MAXL10 MAXNUM + * + * DEC arithmetic: MAXL10 = 38.230809449325611792. + * IEEE arithmetic: MAXL10 = 308.2547155599167. + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1991, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +static double P[] = { + 4.09962519798587023075E-2, + 1.17452732554344059015E1, + 4.06717289936872725516E2, + 2.39423741207388267439E3, +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 8.50936160849306532625E1, + 1.27209271178345121210E3, + 2.07960819286001865907E3, +}; +/* static double LOG102 = 3.01029995663981195214e-1; */ +static double LOG210 = 3.32192809488736234787e0; +static double LG102A = 3.01025390625000000000E-1; +static double LG102B = 4.60503898119521373889E-6; +/* static double MAXL10 = 38.230809449325611792; */ +static double MAXL10 = 308.2547155599167; +#endif + +#ifdef DEC +static unsigned short P[] = { +0037047,0165657,0114061,0067234, +0041073,0166243,0123052,0144643, +0042313,0055720,0024032,0047443, +0043025,0121714,0070232,0050007, +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041652,0027756,0071216,0050075, +0042637,0001367,0077263,0136017, +0043001,0174673,0024157,0133416, +}; +/* +static unsigned short L102[] = {0037632,0020232,0102373,0147770}; +#define LOG102 *(double *)L102 +*/ +static unsigned short L210[] = {0040524,0115170,0045715,0015613}; +#define LOG210 *(double *)L210 +static unsigned short L102A[] = {0037632,0020000,0000000,0000000,}; +#define LG102A *(double *)L102A +static unsigned short L102B[] = {0033632,0102373,0147767,0114220,}; +#define LG102B *(double *)L102B +static unsigned short MXL[] = {0041430,0166131,0047761,0154130,}; +#define MAXL10 ( *(double *)MXL ) +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x2dd4,0xf306,0xfd75,0x3fa4, +0x5934,0x74c5,0x7d94,0x4027, +0x49e4,0x0503,0x6b7a,0x4079, +0x4a01,0x8e13,0xb479,0x40a2, +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xca08,0xce51,0x45fd,0x4055, +0x7782,0xefd6,0xe05e,0x4093, +0xf6e2,0x650d,0x3f37,0x40a0, +}; +/* +static unsigned short L102[] = {0x79ff,0x509f,0x4413,0x3fd3}; +#define LOG102 *(double *)L102 +*/ +static unsigned short L210[] = {0xa371,0x0979,0x934f,0x400a}; +#define LOG210 *(double *)L210 +static unsigned short L102A[] = {0x0000,0x0000,0x4400,0x3fd3,}; +#define LG102A *(double *)L102A +static unsigned short L102B[] = {0xf312,0x79fe,0x509f,0x3ed3,}; +#define LG102B *(double *)L102B +static double MAXL10 = 308.2547155599167; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3fa4,0xfd75,0xf306,0x2dd4, +0x4027,0x7d94,0x74c5,0x5934, +0x4079,0x6b7a,0x0503,0x49e4, +0x40a2,0xb479,0x8e13,0x4a01, +}; +static unsigned short Q[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4055,0x45fd,0xce51,0xca08, +0x4093,0xe05e,0xefd6,0x7782, +0x40a0,0x3f37,0x650d,0xf6e2, +}; +/* +static unsigned short L102[] = {0x3fd3,0x4413,0x509f,0x79ff}; +#define LOG102 *(double *)L102 +*/ +static unsigned short L210[] = {0x400a,0x934f,0x0979,0xa371}; +#define LOG210 *(double *)L210 +static unsigned short L102A[] = {0x3fd3,0x4400,0x0000,0x0000,}; +#define LG102A *(double *)L102A +static unsigned short L102B[] = {0x3ed3,0x509f,0x79fe,0xf312,}; +#define LG102B *(double *)L102B +static double MAXL10 = 308.2547155599167; +#endif + +#ifdef ANSIPROT +extern double floor ( double ); +extern double ldexp ( double, int ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double floor(), ldexp(), polevl(), p1evl(); +int isnan(), isfinite(); +#endif +extern double MAXNUM; +#ifdef INFINITIES +extern double INFINITY; +#endif + +double exp10(x) +double x; +{ +double px, xx; +short n; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +if( x > MAXL10 ) + { +#ifdef INFINITIES + return( INFINITY ); +#else + mtherr( "exp10", OVERFLOW ); + return( MAXNUM ); +#endif + } + +if( x < -MAXL10 ) /* Would like to use MINLOG but can't */ + { +#ifndef INFINITIES + mtherr( "exp10", UNDERFLOW ); +#endif + return(0.0); + } + +/* Express 10**x = 10**g 2**n + * = 10**g 10**( n log10(2) ) + * = 10**( g + n log10(2) ) + */ +px = floor( LOG210 * x + 0.5 ); +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 * polevl( xx, P, 3 ); +x = px/( p1evl( xx, Q, 3 ) - px ); +x = 1.0 + ldexp( x, 1 ); + +/* multiply by power of 2 */ +x = ldexp( x, n ); + +return(x); +} diff --git a/libm/double/exp2.c b/libm/double/exp2.c new file mode 100644 index 000000000..be5bdfd0c --- /dev/null +++ b/libm/double/exp2.c @@ -0,0 +1,183 @@ +/* exp2.c + * + * Base 2 exponential function + * + * + * + * SYNOPSIS: + * + * double x, y, exp2(); + * + * y = exp2( 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 -1022,+1024 30000 1.8e-16 5.4e-17 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < -MAXL2 0.0 + * exp overflow x > MAXL2 MAXNUM + * + * For DEC arithmetic, MAXL2 = 127. + * For IEEE arithmetic, MAXL2 = 1024. + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + + +#include <math.h> + +#ifdef UNK +static double P[] = { + 2.30933477057345225087E-2, + 2.02020656693165307700E1, + 1.51390680115615096133E3, +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 2.33184211722314911771E2, + 4.36821166879210612817E3, +}; +#define MAXL2 1024.0 +#define MINL2 -1024.0 +#endif + +#ifdef DEC +static unsigned short P[] = { +0036675,0027102,0122327,0053227, +0041241,0116724,0115412,0157355, +0042675,0036404,0101733,0132226, +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0042151,0027450,0077732,0160744, +0043210,0100661,0077550,0056560, +}; +#define MAXL2 127.0 +#define MINL2 -127.0 +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0xead3,0x549a,0xa5c8,0x3f97, +0x5bde,0x9361,0x33ba,0x4034, +0x7693,0x907b,0xa7a0,0x4097, +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x5c3c,0x0ffb,0x25e5,0x406d, +0x0bae,0x2fed,0x1036,0x40b1, +}; +#define MAXL2 1024.0 +#define MINL2 -1022.0 +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f97,0xa5c8,0x549a,0xead3, +0x4034,0x33ba,0x9361,0x5bde, +0x4097,0xa7a0,0x907b,0x7693, +}; +static unsigned short Q[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x406d,0x25e5,0x0ffb,0x5c3c, +0x40b1,0x1036,0x2fed,0x0bae, +}; +#define MAXL2 1024.0 +#define MINL2 -1022.0 +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double polevl(), p1evl(), floor(), ldexp(); +int isnan(), isfinite(); +#endif +#ifdef INFINITIES +extern double INFINITY; +#endif +extern double MAXNUM; + +double exp2(x) +double x; +{ +double px, xx; +short n; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +if( x > MAXL2) + { +#ifdef INFINITIES + return( INFINITY ); +#else + mtherr( "exp2", OVERFLOW ); + return( MAXNUM ); +#endif + } + +if( x < MINL2 ) + { +#ifndef INFINITIES + mtherr( "exp2", UNDERFLOW ); +#endif + return(0.0); + } + +xx = x; /* save x */ +/* separate into integer and fractional parts */ +px = floor(x+0.5); +n = px; +x = x - px; + +/* rational approximation + * exp2(x) = 1 + 2xP(xx)/(Q(xx) - P(xx)) + * where xx = x**2 + */ +xx = x * x; +px = x * polevl( xx, P, 2 ); +x = px / ( p1evl( xx, Q, 2 ) - px ); +x = 1.0 + ldexp( x, 1 ); + +/* scale by power of 2 */ +x = ldexp( x, n ); +return(x); +} diff --git a/libm/double/expn.c b/libm/double/expn.c new file mode 100644 index 000000000..89b6b139e --- /dev/null +++ b/libm/double/expn.c @@ -0,0 +1,208 @@ +/* expn.c + * + * Exponential integral En + * + * + * + * SYNOPSIS: + * + * int n; + * double x, y, expn(); + * + * y = expn( n, x ); + * + * + * + * DESCRIPTION: + * + * Evaluates the exponential integral + * + * inf. + * - + * | | -xt + * | e + * E (x) = | ---- dt. + * n | n + * | | t + * - + * 1 + * + * + * Both n and x must be nonnegative. + * + * The routine employs either a power series, a continued + * fraction, or an asymptotic formula depending on the + * relative values of n and x. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 5000 2.0e-16 4.6e-17 + * IEEE 0, 30 10000 1.7e-15 3.6e-16 + * + */ + +/* expn.c */ + +/* Cephes Math Library Release 2.8: June, 2000 + Copyright 1985, 2000 by Stephen L. Moshier */ + +#include <math.h> +#ifdef ANSIPROT +extern double pow ( double, double ); +extern double gamma ( double ); +extern double log ( double ); +extern double exp ( double ); +extern double fabs ( double ); +#else +double pow(), gamma(), log(), exp(), fabs(); +#endif +#define EUL 0.57721566490153286060 +#define BIG 1.44115188075855872E+17 +extern double MAXNUM, MACHEP, MAXLOG; + +double expn( n, x ) +int n; +double x; +{ +double ans, r, t, yk, xk; +double pk, pkm1, pkm2, qk, qkm1, qkm2; +double psi, z; +int i, k; +static double big = BIG; + +if( n < 0 ) + goto domerr; + +if( x < 0 ) + { +domerr: mtherr( "expn", DOMAIN ); + return( MAXNUM ); + } + +if( x > MAXLOG ) + return( 0.0 ); + +if( x == 0.0 ) + { + if( n < 2 ) + { + mtherr( "expn", SING ); + return( MAXNUM ); + } + else + return( 1.0/(n-1.0) ); + } + +if( n == 0 ) + return( exp(-x)/x ); + +/* expn.c */ +/* Expansion for large n */ + +if( n > 5000 ) + { + xk = x + n; + yk = 1.0 / (xk * xk); + t = n; + ans = yk * t * (6.0 * x * x - 8.0 * t * x + t * t); + ans = yk * (ans + t * (t - 2.0 * x)); + ans = yk * (ans + t); + ans = (ans + 1.0) * exp( -x ) / xk; + goto done; + } + +if( x > 1.0 ) + goto cfrac; + +/* expn.c */ + +/* Power series expansion */ + +psi = -EUL - log(x); +for( i=1; i<n; i++ ) + psi = psi + 1.0/i; + +z = -x; +xk = 0.0; +yk = 1.0; +pk = 1.0 - n; +if( n == 1 ) + ans = 0.0; +else + ans = 1.0/pk; +do + { + xk += 1.0; + yk *= z/xk; + pk += 1.0; + if( pk != 0.0 ) + { + ans += yk/pk; + } + if( ans != 0.0 ) + t = fabs(yk/ans); + else + t = 1.0; + } +while( t > MACHEP ); +k = xk; +t = n; +r = n - 1; +ans = (pow(z, r) * psi / gamma(t)) - ans; +goto done; + +/* expn.c */ +/* continued fraction */ +cfrac: +k = 1; +pkm2 = 1.0; +qkm2 = x; +pkm1 = 1.0; +qkm1 = x + n; +ans = pkm1/qkm1; + +do + { + k += 1; + if( k & 1 ) + { + yk = 1.0; + xk = n + (k-1)/2; + } + else + { + yk = x; + xk = k/2; + } + pk = pkm1 * yk + pkm2 * xk; + qk = qkm1 * yk + qkm2 * xk; + if( qk != 0 ) + { + r = pk/qk; + t = fabs( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; +if( fabs(pk) > big ) + { + pkm2 /= big; + pkm1 /= big; + qkm2 /= big; + qkm1 /= big; + } + } +while( t > MACHEP ); + +ans *= exp( -x ); + +done: +return( ans ); +} + diff --git a/libm/double/fabs.c b/libm/double/fabs.c new file mode 100644 index 000000000..0c4531a6c --- /dev/null +++ b/libm/double/fabs.c @@ -0,0 +1,56 @@ +/* fabs.c + * + * Absolute value + * + * + * + * SYNOPSIS: + * + * double x, y; + * + * y = fabs( x ); + * + * + * + * DESCRIPTION: + * + * Returns the absolute value of the argument. + * + */ + + +#include <math.h> +/* Avoid using UNK if possible. */ +#ifdef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +#endif + +double fabs(x) +double x; +{ +union + { + double d; + short i[4]; + } u; + +u.d = x; +#ifdef IBMPC + u.i[3] &= 0x7fff; +#endif +#ifdef MIEEE + u.i[0] &= 0x7fff; +#endif +#ifdef DEC + u.i[3] &= 0x7fff; +#endif +#ifdef UNK +if( u.d < 0 ) + u.d = -u.d; +#endif +return( u.d ); +} diff --git a/libm/double/fac.c b/libm/double/fac.c new file mode 100644 index 000000000..a5748ac74 --- /dev/null +++ b/libm/double/fac.c @@ -0,0 +1,263 @@ +/* fac.c + * + * Factorial function + * + * + * + * SYNOPSIS: + * + * double y, fac(); + * int i; + * + * y = fac( i ); + * + * + * + * DESCRIPTION: + * + * Returns factorial of i = 1 * 2 * 3 * ... * i. + * fac(0) = 1.0. + * + * Due to machine arithmetic bounds the largest value of + * i accepted is 33 in DEC arithmetic or 170 in IEEE + * arithmetic. Greater values, or negative ones, + * produce an error message and return MAXNUM. + * + * + * + * ACCURACY: + * + * For i < 34 the values are simply tabulated, and have + * full machine accuracy. If i > 55, fac(i) = gamma(i+1); + * see gamma.c. + * + * Relative error: + * arithmetic domain peak + * IEEE 0, 170 1.4e-15 + * DEC 0, 33 1.4e-17 + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Factorials of integers from 0 through 33 */ +#ifdef UNK +static double factbl[] = { + 1.00000000000000000000E0, + 1.00000000000000000000E0, + 2.00000000000000000000E0, + 6.00000000000000000000E0, + 2.40000000000000000000E1, + 1.20000000000000000000E2, + 7.20000000000000000000E2, + 5.04000000000000000000E3, + 4.03200000000000000000E4, + 3.62880000000000000000E5, + 3.62880000000000000000E6, + 3.99168000000000000000E7, + 4.79001600000000000000E8, + 6.22702080000000000000E9, + 8.71782912000000000000E10, + 1.30767436800000000000E12, + 2.09227898880000000000E13, + 3.55687428096000000000E14, + 6.40237370572800000000E15, + 1.21645100408832000000E17, + 2.43290200817664000000E18, + 5.10909421717094400000E19, + 1.12400072777760768000E21, + 2.58520167388849766400E22, + 6.20448401733239439360E23, + 1.55112100433309859840E25, + 4.03291461126605635584E26, + 1.0888869450418352160768E28, + 3.04888344611713860501504E29, + 8.841761993739701954543616E30, + 2.6525285981219105863630848E32, + 8.22283865417792281772556288E33, + 2.6313083693369353016721801216E35, + 8.68331761881188649551819440128E36 +}; +#define MAXFAC 33 +#endif + +#ifdef DEC +static unsigned short factbl[] = { +0040200,0000000,0000000,0000000, +0040200,0000000,0000000,0000000, +0040400,0000000,0000000,0000000, +0040700,0000000,0000000,0000000, +0041300,0000000,0000000,0000000, +0041760,0000000,0000000,0000000, +0042464,0000000,0000000,0000000, +0043235,0100000,0000000,0000000, +0044035,0100000,0000000,0000000, +0044661,0030000,0000000,0000000, +0045535,0076000,0000000,0000000, +0046430,0042500,0000000,0000000, +0047344,0063740,0000000,0000000, +0050271,0112146,0000000,0000000, +0051242,0060731,0040000,0000000, +0052230,0035673,0126000,0000000, +0053230,0035673,0126000,0000000, +0054241,0137567,0063300,0000000, +0055265,0173546,0051630,0000000, +0056330,0012711,0101504,0100000, +0057407,0006635,0171012,0150000, +0060461,0040737,0046656,0030400, +0061563,0135223,0005317,0101540, +0062657,0027031,0127705,0023155, +0064003,0061223,0041723,0156322, +0065115,0045006,0014773,0004410, +0066246,0146044,0172433,0173526, +0067414,0136077,0027317,0114261, +0070566,0044556,0110753,0045465, +0071737,0031214,0032075,0036050, +0073121,0037543,0070371,0064146, +0074312,0132550,0052561,0116443, +0075512,0132550,0052561,0116443, +0076721,0005423,0114035,0025014 +}; +#define MAXFAC 33 +#endif + +#ifdef IBMPC +static unsigned short factbl[] = { +0x0000,0x0000,0x0000,0x3ff0, +0x0000,0x0000,0x0000,0x3ff0, +0x0000,0x0000,0x0000,0x4000, +0x0000,0x0000,0x0000,0x4018, +0x0000,0x0000,0x0000,0x4038, +0x0000,0x0000,0x0000,0x405e, +0x0000,0x0000,0x8000,0x4086, +0x0000,0x0000,0xb000,0x40b3, +0x0000,0x0000,0xb000,0x40e3, +0x0000,0x0000,0x2600,0x4116, +0x0000,0x0000,0xaf80,0x414b, +0x0000,0x0000,0x08a8,0x4183, +0x0000,0x0000,0x8cfc,0x41bc, +0x0000,0xc000,0x328c,0x41f7, +0x0000,0x2800,0x4c3b,0x4234, +0x0000,0x7580,0x0777,0x4273, +0x0000,0x7580,0x0777,0x42b3, +0x0000,0xecd8,0x37ee,0x42f4, +0x0000,0xca73,0xbeec,0x4336, +0x9000,0x3068,0x02b9,0x437b, +0x5a00,0xbe41,0xe1b3,0x43c0, +0xc620,0xe9b5,0x283b,0x4406, +0xf06c,0x6159,0x7752,0x444e, +0xa4ce,0x35f8,0xe5c3,0x4495, +0x7b9a,0x687a,0x6c52,0x44e0, +0x6121,0xc33f,0xa940,0x4529, +0x7eeb,0x9ea3,0xd984,0x4574, +0xf316,0xe5d9,0x9787,0x45c1, +0x6967,0xd23d,0xc92d,0x460e, +0xa785,0x8687,0xe651,0x465b, +0x2d0d,0x6e1f,0x27ec,0x46aa, +0x33a4,0x0aae,0x56ad,0x46f9, +0x33a4,0x0aae,0x56ad,0x4749, +0xa541,0x7303,0x2162,0x479a +}; +#define MAXFAC 170 +#endif + +#ifdef MIEEE +static unsigned short factbl[] = { +0x3ff0,0x0000,0x0000,0x0000, +0x3ff0,0x0000,0x0000,0x0000, +0x4000,0x0000,0x0000,0x0000, +0x4018,0x0000,0x0000,0x0000, +0x4038,0x0000,0x0000,0x0000, +0x405e,0x0000,0x0000,0x0000, +0x4086,0x8000,0x0000,0x0000, +0x40b3,0xb000,0x0000,0x0000, +0x40e3,0xb000,0x0000,0x0000, +0x4116,0x2600,0x0000,0x0000, +0x414b,0xaf80,0x0000,0x0000, +0x4183,0x08a8,0x0000,0x0000, +0x41bc,0x8cfc,0x0000,0x0000, +0x41f7,0x328c,0xc000,0x0000, +0x4234,0x4c3b,0x2800,0x0000, +0x4273,0x0777,0x7580,0x0000, +0x42b3,0x0777,0x7580,0x0000, +0x42f4,0x37ee,0xecd8,0x0000, +0x4336,0xbeec,0xca73,0x0000, +0x437b,0x02b9,0x3068,0x9000, +0x43c0,0xe1b3,0xbe41,0x5a00, +0x4406,0x283b,0xe9b5,0xc620, +0x444e,0x7752,0x6159,0xf06c, +0x4495,0xe5c3,0x35f8,0xa4ce, +0x44e0,0x6c52,0x687a,0x7b9a, +0x4529,0xa940,0xc33f,0x6121, +0x4574,0xd984,0x9ea3,0x7eeb, +0x45c1,0x9787,0xe5d9,0xf316, +0x460e,0xc92d,0xd23d,0x6967, +0x465b,0xe651,0x8687,0xa785, +0x46aa,0x27ec,0x6e1f,0x2d0d, +0x46f9,0x56ad,0x0aae,0x33a4, +0x4749,0x56ad,0x0aae,0x33a4, +0x479a,0x2162,0x7303,0xa541 +}; +#define MAXFAC 170 +#endif + +#ifdef ANSIPROT +double gamma ( double ); +#else +double gamma(); +#endif +extern double MAXNUM; + +double fac(i) +int i; +{ +double x, f, n; +int j; + +if( i < 0 ) + { + mtherr( "fac", SING ); + return( MAXNUM ); + } + +if( i > MAXFAC ) + { + mtherr( "fac", OVERFLOW ); + return( MAXNUM ); + } + +/* Get answer from table for small i. */ +if( i < 34 ) + { +#ifdef UNK + return( factbl[i] ); +#else + return( *(double *)(&factbl[4*i]) ); +#endif + } +/* Use gamma function for large i. */ +if( i > 55 ) + { + x = i + 1; + return( gamma(x) ); + } +/* Compute directly for intermediate i. */ +n = 34.0; +f = 34.0; +for( j=35; j<=i; j++ ) + { + n += 1.0; + f *= n; + } +#ifdef UNK + f *= factbl[33]; +#else + f *= *(double *)(&factbl[4*33]); +#endif +return( f ); +} diff --git a/libm/double/fdtr.c b/libm/double/fdtr.c new file mode 100644 index 000000000..469b7bedf --- /dev/null +++ b/libm/double/fdtr.c @@ -0,0 +1,237 @@ +/* fdtr.c + * + * F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, y, fdtr(); + * + * y = fdtr( 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) = incbet( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x is + * nonnegative. + * + * ACCURACY: + * + * Tested at random points (a,b,x). + * + * x a,b Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0,1 0,100 100000 9.8e-15 1.7e-15 + * IEEE 1,5 0,100 100000 6.5e-15 3.5e-16 + * IEEE 0,1 1,10000 100000 2.2e-11 3.3e-12 + * IEEE 1,5 1,10000 100000 1.1e-11 1.7e-13 + * See also incbet.c. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtr domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrc() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, y, fdtrc(); + * + * y = fdtrc( 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 + * + * + * The incomplete beta integral is used, according to the + * formula + * + * P(x) = incbet( df2/2, df1/2, (df2/(df2 + df1*x) ). + * + * + * 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 100000 3.7e-14 5.9e-16 + * IEEE 1,5 1,100 100000 8.0e-15 1.6e-15 + * IEEE 0,1 1,10000 100000 1.8e-11 3.5e-13 + * IEEE 1,5 1,10000 100000 2.0e-11 3.0e-12 + * See also incbet.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrc domain a<0, b<0, x<0 0.0 + * + */ + /* fdtri() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * double x, p, fdtri(); + * + * x = fdtri( 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: + * + * 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 100000 8.3e-15 4.7e-16 + * IEEE 1,10000 100000 2.1e-11 1.4e-13 + * For p between 10^-6 and 10^-3: + * IEEE 1,100 50000 1.3e-12 8.4e-15 + * IEEE 1,10000 50000 3.0e-12 4.8e-14 + * See also fdtrc.c. + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtri domain p <= 0 or p > 1 0.0 + * v < 1 + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> +#ifdef ANSIPROT +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +#else +double incbet(), incbi(); +#endif + +double fdtrc( ia, ib, x ) +int ia, ib; +double x; +{ +double a, b, w; + +if( (ia < 1) || (ib < 1) || (x < 0.0) ) + { + mtherr( "fdtrc", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +w = b / (b + a * x); +return( incbet( 0.5*b, 0.5*a, w ) ); +} + + + +double fdtr( ia, ib, x ) +int ia, ib; +double x; +{ +double a, b, w; + +if( (ia < 1) || (ib < 1) || (x < 0.0) ) + { + mtherr( "fdtr", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +w = a * x; +w = w / (b + w); +return( incbet(0.5*a, 0.5*b, w) ); +} + + +double fdtri( ia, ib, y ) +int ia, ib; +double y; +{ +double a, b, w, x; + +if( (ia < 1) || (ib < 1) || (y <= 0.0) || (y > 1.0) ) + { + mtherr( "fdtri", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +/* Compute probability for x = 0.5. */ +w = incbet( 0.5*b, 0.5*a, 0.5 ); +/* 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.001) + { + w = incbi( 0.5*b, 0.5*a, y ); + x = (b - b*w)/(a*w); + } +else + { + w = incbi( 0.5*a, 0.5*b, 1.0-y ); + x = b*w/(a*(1.0-w)); + } +return(x); +} diff --git a/libm/double/fftr.c b/libm/double/fftr.c new file mode 100644 index 000000000..d4ce23463 --- /dev/null +++ b/libm/double/fftr.c @@ -0,0 +1,237 @@ +/* fftr.c + * + * FFT of Real Valued Sequence + * + * + * + * SYNOPSIS: + * + * double x[], sine[]; + * int m; + * + * fftr( x, m, sine ); + * + * + * + * DESCRIPTION: + * + * Computes the (complex valued) discrete Fourier transform of + * the real valued sequence x[]. The input sequence x[] contains + * n = 2**m samples. The program fills array sine[k] with + * n/4 + 1 values of sin( 2 PI k / n ). + * + * Data format for complex valued output is real part followed + * by imaginary part. The output is developed in the input + * array x[]. + * + * The algorithm takes advantage of the fact that the FFT of an + * n point real sequence can be obtained from an n/2 point + * complex FFT. + * + * A radix 2 FFT algorithm is used. + * + * Execution time on an LSI-11/23 with floating point chip + * is 1.0 sec for n = 256. + * + * + * + * REFERENCE: + * + * E. Oran Brigham, The Fast Fourier Transform; + * Prentice-Hall, Inc., 1974 + * + */ + + +#include <math.h> + +static short n0 = 0; +static short n4 = 0; +static short msav = 0; + +extern double PI; + +#ifdef ANSIPROT +extern double sin ( double ); +static int bitrv(int, int); +#else +double sin(); +static int bitrv(); +#endif + +fftr( x, m0, sine ) +double x[]; +int m0; +double sine[]; +{ +int th, nd, pth, nj, dth, m; +int n, n2, j, k, l, r; +double xr, xi, tr, ti, co, si; +double a, b, c, d, bc, cs, bs, cc; +double *p, *q; + +/* Array x assumed filled with real-valued data */ +/* m0 = log2(n0) */ +/* n0 is the number of real data samples */ + +if( m0 != msav ) + { + msav = m0; + + /* Find n0 = 2**m0 */ + n0 = 1; + for( j=0; j<m0; j++ ) + n0 <<= 1; + + n4 = n0 >> 2; + + /* Calculate array of sines */ + xr = 2.0 * PI / n0; + for( j=0; j<=n4; j++ ) + sine[j] = sin( j * xr ); + } + +n = n0 >> 1; /* doing half length transform */ +m = m0 - 1; + + +/* fftr.c */ + +/* Complex Fourier Transform of n Complex Data Points */ + +/* First, bit reverse the input data */ + +for( k=0; k<n; k++ ) + { + j = bitrv( k, m ); + if( j > k ) + { /* executed approx. n/2 times */ + p = &x[2*k]; + tr = *p++; + ti = *p; + q = &x[2*j+1]; + *p = *q; + *(--p) = *(--q); + *q++ = tr; + *q = ti; + } + } + +/* fftr.c */ +/* Radix 2 Complex FFT */ +n2 = n/2; +nj = 1; +pth = 1; +dth = 0; +th = 0; + +for( l=0; l<m; l++ ) + { /* executed log2(n) times, total */ + j = 0; + do + { /* executed n-1 times, total */ + r = th << 1; + si = sine[r]; + co = sine[ n4 - r ]; + if( j >= pth ) + { + th -= dth; + co = -co; + } + else + th += dth; + + nd = j; + + do + { /* executed n/2 log2(n) times, total */ + r = (nd << 1) + (nj << 1); + p = &x[ r ]; + xr = *p++; + xi = *p; + tr = xr * co + xi * si; + ti = xi * co - xr * si; + r = nd << 1; + q = &x[ r ]; + xr = *q++; + xi = *q; + *p = xi - ti; + *(--p) = xr - tr; + *q = xi + ti; + *(--q) = xr + tr; + nd += nj << 1; + } + while( nd < n ); + } + while( ++j < nj ); + + n2 >>= 1; + dth = n2; + pth = nj; + nj <<= 1; + } + +/* fftr.c */ + +/* Special trick algorithm */ +/* converts to spectrum of real series */ + +/* Highest frequency term; add space to input array if wanted */ +/* +x[2*n] = x[0] - x[1]; +x[2*n+1] = 0.0; +*/ + +/* Zero frequency term */ +x[0] = x[0] + x[1]; +x[1] = 0.0; +n2 = n/2; + +for( j=1; j<=n2; j++ ) + { /* executed n/2 times */ + si = sine[j]; + co = sine[ n4 - j ]; + p = &x[ 2*j ]; + xr = *p++; + xi = *p; + q = &x[ 2*(n-j) ]; + tr = *q++; + ti = *q; + a = xr + tr; + b = xi + ti; + c = xr - tr; + d = xi - ti; + bc = b * co; + cs = c * si; + bs = b * si; + cc = c * co; + *p = ( d - bs - cc )/2.0; + *(--p) = ( a + bc - cs )/2.0; + *q = -( d + bs + cc )/2.0; + *(--q) = ( a - bc + cs )/2.0; + } + +return(0); +} + +/* fftr.c */ + +/* Bit reverser */ + +int bitrv( j, m ) +int j, m; +{ +register int j1, ans; +short k; + +ans = 0; +j1 = j; + +for( k=0; k<m; k++ ) + { + ans = (ans << 1) + (j1 & 1); + j1 >>= 1; + } + +return( ans ); +} diff --git a/libm/double/floor.c b/libm/double/floor.c new file mode 100644 index 000000000..dcc1a10f1 --- /dev/null +++ b/libm/double/floor.c @@ -0,0 +1,453 @@ +/* ceil() + * floor() + * frexp() + * ldexp() + * signbit() + * isnan() + * isfinite() + * + * Floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * double ceil(), floor(), frexp(), ldexp(); + * int signbit(), isnan(), isfinite(); + * double x, y; + * int expnt, n; + * + * y = floor(x); + * y = ceil(x); + * y = frexp( x, &expnt ); + * y = ldexp( x, n ); + * n = signbit(x); + * n = isnan(x); + * n = isfinite(x); + * + * + * + * DESCRIPTION: + * + * All four routines return a double precision floating point + * result. + * + * floor() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * ceil() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * frexp() 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. + * + * ldexp() multiplies x by 2**n. + * + * signbit(x) returns 1 if the sign bit of x is 1, else 0. + * + * These functions are part of the standard C run time library + * for many but not all C compilers. The ones supplied are + * written in C for either DEC or 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.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +/* ceil(), floor(), frexp(), ldexp() may need to be rewritten. */ +#undef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +#endif + +#ifdef DEC +#define EXPMSK 0x807f +#define MEXP 255 +#define NBITS 56 +#endif + +#ifdef IBMPC +#define EXPMSK 0x800f +#define MEXP 0x7ff +#define NBITS 53 +#endif + +#ifdef MIEEE +#define EXPMSK 0x800f +#define MEXP 0x7ff +#define NBITS 53 +#endif + +extern double MAXNUM, NEGZERO; +#ifdef ANSIPROT +double floor ( double ); +int isnan ( double ); +int isfinite ( double ); +double ldexp ( double, int ); +#else +double floor(); +int isnan(), isfinite(); +double ldexp(); +#endif + +double ceil(x) +double x; +{ +double y; + +#ifdef UNK +mtherr( "ceil", DOMAIN ); +return(0.0); +#endif +#ifdef NANS +if( isnan(x) ) + return( x ); +#endif +#ifdef INFINITIES +if(!isfinite(x)) + return(x); +#endif + +y = floor(x); +if( y < x ) + y += 1.0; +#ifdef MINUSZERO +if( y == 0.0 && x < 0.0 ) + return( NEGZERO ); +#endif +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, +}; + + + + + +double floor(x) +double x; +{ +union + { + double y; + unsigned short sh[4]; + } u; +unsigned short *p; +int e; + +#ifdef UNK +mtherr( "floor", DOMAIN ); +return(0.0); +#endif +#ifdef NANS +if( isnan(x) ) + return( x ); +#endif +#ifdef INFINITIES +if(!isfinite(x)) + return(x); +#endif +#ifdef MINUSZERO +if(x == 0.0L) + return(x); +#endif +u.y = x; +/* find the exponent (power of 2) */ +#ifdef DEC +p = (unsigned short *)&u.sh[0]; +e = (( *p >> 7) & 0377) - 0201; +p += 3; +#endif + +#ifdef IBMPC +p = (unsigned short *)&u.sh[3]; +e = (( *p >> 4) & 0x7ff) - 0x3ff; +p -= 3; +#endif + +#ifdef MIEEE +p = (unsigned short *)&u.sh[0]; +e = (( *p >> 4) & 0x7ff) - 0x3ff; +p += 3; +#endif + +if( e < 0 ) + { + if( u.y < 0.0 ) + return( -1.0 ); + else + return( 0.0 ); + } + +e = (NBITS -1) - e; +/* clean out 16 bits at a time */ +while( e >= 16 ) + { +#ifdef IBMPC + *p++ = 0; +#endif + +#ifdef DEC + *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.0; + +return(u.y); +} + + + + +double frexp( x, pw2 ) +double x; +int *pw2; +{ +union + { + double y; + unsigned short sh[4]; + } u; +int i; +#ifdef DENORMAL +int k; +#endif +short *q; + +u.y = x; + +#ifdef UNK +mtherr( "frexp", DOMAIN ); +return(0.0); +#endif + +#ifdef IBMPC +q = (short *)&u.sh[3]; +#endif + +#ifdef DEC +q = (short *)&u.sh[0]; +#endif + +#ifdef MIEEE +q = (short *)&u.sh[0]; +#endif + +/* find the exponent (power of 2) */ +#ifdef DEC +i = ( *q >> 7) & 0377; +if( i == 0 ) + { + *pw2 = 0; + return(0.0); + } +i -= 0200; +*pw2 = i; +*q &= 0x807f; /* strip all exponent bits */ +*q |= 040000; /* mantissa between 0.5 and 1 */ +return(u.y); +#endif + +#ifdef IBMPC +i = ( *q >> 4) & 0x7ff; +if( i != 0 ) + goto ieeedon; +#endif + +#ifdef MIEEE +i = *q >> 4; +i &= 0x7ff; +if( i != 0 ) + goto ieeedon; +#ifdef DENORMAL + +#else +*pw2 = 0; +return(0.0); +#endif + +#endif + + +#ifndef DEC +/* Number is denormal or zero */ +#ifdef DENORMAL +if( u.y == 0.0 ) + { + *pw2 = 0; + return( 0.0 ); + } + + +/* Handle denormal number. */ +do + { + u.y *= 2.0; + i -= 1; + k = ( *q >> 4) & 0x7ff; + } +while( k == 0 ); +i = i + k; +#endif /* DENORMAL */ + +ieeedon: + +i -= 0x3fe; +*pw2 = i; +*q &= 0x800f; +*q |= 0x3fe0; +return( u.y ); +#endif +} + + + + + + + +double ldexp( x, pw2 ) +double x; +int pw2; +{ +union + { + double y; + unsigned short sh[4]; + } u; +short *q; +int e; + +#ifdef UNK +mtherr( "ldexp", DOMAIN ); +return(0.0); +#endif + +u.y = x; +#ifdef DEC +q = (short *)&u.sh[0]; +e = ( *q >> 7) & 0377; +if( e == 0 ) + return(0.0); +#else + +#ifdef IBMPC +q = (short *)&u.sh[3]; +#endif +#ifdef MIEEE +q = (short *)&u.sh[0]; +#endif +while( (e = (*q & 0x7ff0) >> 4) == 0 ) + { + if( u.y == 0.0 ) + { + return( 0.0 ); + } +/* Input is denormal. */ + if( pw2 > 0 ) + { + u.y *= 2.0; + pw2 -= 1; + } + if( pw2 < 0 ) + { + if( pw2 < -53 ) + return(0.0); + u.y /= 2.0; + pw2 += 1; + } + if( pw2 == 0 ) + return(u.y); + } +#endif /* not DEC */ + +e += pw2; + +/* Handle overflow */ +#ifdef DEC +if( e > MEXP ) + return( MAXNUM ); +#else +if( e >= MEXP ) + return( 2.0*MAXNUM ); +#endif + +/* Handle denormalized results */ +if( e < 1 ) + { +#ifdef DENORMAL + if( e < -53 ) + return(0.0); + *q &= 0x800f; + *q |= 0x10; + /* For denormals, significant bits may be lost even + when dividing by 2. Construct 2^-(1-e) so the result + is obtained with only one multiplication. */ + u.y *= ldexp(1.0, e-1); + return(u.y); +#else + return(0.0); +#endif + } +else + { +#ifdef DEC + *q &= 0x807f; /* strip all exponent bits */ + *q |= (e & 0xff) << 7; +#else + *q &= 0x800f; + *q |= (e & 0x7ff) << 4; +#endif + return(u.y); + } +} diff --git a/libm/double/fltest.c b/libm/double/fltest.c new file mode 100644 index 000000000..f2e3d8665 --- /dev/null +++ b/libm/double/fltest.c @@ -0,0 +1,272 @@ +/* fltest.c + * Test program for floor(), frexp(), ldexp() + */ + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + + +#include <math.h> +extern double MACHEP; +#define UTH -1023 + +main() +{ +double x, y, y0, z, f, x00, y00; +int i, j, k, e, e0; +int errfr, errld, errfl, underexp, err, errth, e00; +double frexp(), ldexp(), floor(); + + +/* +if( 1 ) + goto flrtst; +*/ + +printf( "Testing frexp() and ldexp().\n" ); +errfr = 0; +errld = 0; +underexp = 0; +f = 1.0; +x00 = 2.0; +y00 = 0.5; +e00 = 2; + +for( j=0; j<20; j++ ) +{ +if( j == 10 ) + { + f = 1.0; + x00 = 2.0; + e00 = 1; +/* Find 2**(2**10) / 2 */ +#ifdef DEC + for( i=0; i<5; i++ ) +#else + for( i=0; i<9; i++ ) +#endif + { + x00 *= x00; + e00 += e00; + } + y00 = x00/2.0; + x00 = x00 * y00; + e00 += e00; + y00 = 0.5; + } +x = x00 * f; +y0 = y00 * f; +e0 = e00; +for( i=0; i<2200; i++ ) + { + x /= 2.0; + e0 -= 1; + if( x == 0.0 ) + { + if( f == 1.0 ) + underexp = e0; + y0 = 0.0; + e0 = 0; + } + y = frexp( x, &e ); + if( (e0 < -1023) && (e != e0) ) + { + if( e == (e0 - 1) ) + { + e += 1; + y /= 2.0; + } + if( e == (e0 + 1) ) + { + e -= 1; + y *= 2.0; + } + } + err = y - y0; + if( y0 != 0.0 ) + err /= y0; + if( err < 0.0 ) + err = -err; + if( e0 > -1023 ) + errth = 0.0; + else + {/* Denormal numbers may have rounding errors */ + if( e0 == -1023 ) + { + errth = 2.0 * MACHEP; + } + else + { + errth *= 2.0; + } + } + + if( (x != 0.0) && ((err > errth) || (e != e0)) ) + { + printf( "Test %d: ", j+1 ); + printf( " frexp( %.15e) =?= %.15e * 2**%d;", x, y, e ); + printf( " should be %.15e * 2**%d\n", y0, e0 ); + errfr += 1; + } + y = ldexp( x, 1-e0 ); + err = y - 1.0; + if( err < 0.0 ) + err = -err; + if( (err > errth) && ((x == 0.0) && (y != 0.0)) ) + { + printf( "Test %d: ", j+1 ); + printf( "ldexp( %.15e, %d ) =?= %.15e;", x, 1-e0, y ); + if( x != 0.0 ) + printf( " should be %.15e\n", f ); + else + printf( " should be %.15e\n", 0.0 ); + errld += 1; + } + if( x == 0.0 ) + { + break; + } + } +f = f * 1.08005973889; +} + + +x = 2.22507385850720138309e-308; +for (i = 0; i < 52; i++) + { + y = ldexp (x, -i); + z = ldexp (y, i); + if (x != z) + { + printf ("x %.16e, i %d, y %.16e, z %.16e\n", x, i, y, z); + errld += 1; + } + } + + +if( (errld == 0) && (errfr == 0) ) + { + printf( "No errors found.\n" ); + } + +flrtst: + +printf( "Testing floor().\n" ); +errfl = 0; + +f = 1.0/MACHEP; +x00 = 1.0; +for( j=0; j<57; j++ ) +{ +x = x00 - 1.0; +for( i=0; i<128; i++ ) + { + y = floor(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.49; + y = floor(z); + if( z == x ) + break; + if( y != (x - 1.0) ) + { + flierr( z, y, j ); + errfl += 1; + } + + z = x + 0.49; + y = floor(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + y = floor(x); + if( z != x ) + { + if( y != x ) + { + flierr( x, y, j ); + errfl += 1; + } + } + z = x + 0.49; + y = floor(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + z = x - 0.49; + y = floor(z); + if( z != x ) + { + if( y != (x - 1.0) ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + x += 1.0; + } +x00 = x00 + x00; +} +y = floor(0.0); +if( y != 0.0 ) + { + flierr( 0.0, y, 57 ); + errfl += 1; + } +y = floor(-0.0); +if( y != 0.0 ) + { + flierr( -0.0, y, 58 ); + errfl += 1; + } +y = floor(-1.0); +if( y != -1.0 ) + { + flierr( -1.0, y, 59 ); + errfl += 1; + } +y = floor(-0.1); +if( y != -1.0 ) + { + flierr( -0.1, y, 60 ); + errfl += 1; + } + +if( errfl == 0 ) + printf( "No errors found in floor().\n" ); + +} + + +flierr( x, y, k ) +double x, y; +int k; +{ +printf( "Test %d: ", k+1 ); +printf( "floor(%.15e) =?= %.15e\n", x, y ); +} diff --git a/libm/double/fltest2.c b/libm/double/fltest2.c new file mode 100644 index 000000000..405b81b6a --- /dev/null +++ b/libm/double/fltest2.c @@ -0,0 +1,18 @@ +int drand(); +double exp(), frexp(), ldexp(); +volatile double x, y, z; + +main() +{ +int i, e; + +for( i=0; i<100000; i++ ) + { + drand(&x); + x = exp( 10.0*(x - 1.5) ); + y = frexp( x, &e ); + z = ldexp( y, e ); + if( z != x ) + abort(); + } +} diff --git a/libm/double/fltest3.c b/libm/double/fltest3.c new file mode 100644 index 000000000..f3025777e --- /dev/null +++ b/libm/double/fltest3.c @@ -0,0 +1,259 @@ +/* fltest.c + * Test program for floor(), frexp(), ldexp() + */ + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + + +#include <math.h> +/*extern double MACHEP;*/ +#define MACHEP 2.3e-16 +#define UTH -1023 + +main() +{ +double x, y, y0, z, f, x00, y00; +int i, j, k, e, e0; +int errfr, errld, errfl, underexp, err, errth, e00; +double frexp(), ldexp(), floor(); + + +/* +if( 1 ) + goto flrtst; +*/ + +printf( "Testing frexp() and ldexp().\n" ); +errfr = 0; +errld = 0; +underexp = 0; +f = 1.0; +x00 = 2.0; +y00 = 0.5; +e00 = 2; + +for( j=0; j<20; j++ ) +{ +if( j == 10 ) + { + f = 1.0; + x00 = 2.0; + e00 = 1; +/* Find 2**(2**10) / 2 */ +#ifdef DEC + for( i=0; i<5; i++ ) +#else + for( i=0; i<9; i++ ) +#endif + { + x00 *= x00; + e00 += e00; + } + y00 = x00/2.0; + x00 = x00 * y00; + e00 += e00; + y00 = 0.5; + } +x = x00 * f; +y0 = y00 * f; +e0 = e00; +for( i=0; i<2200; i++ ) + { + x /= 2.0; + e0 -= 1; + if( x == 0.0 ) + { + if( f == 1.0 ) + underexp = e0; + y0 = 0.0; + e0 = 0; + } + y = frexp( x, &e ); + if( (e0 < -1023) && (e != e0) ) + { + if( e == (e0 - 1) ) + { + e += 1; + y /= 2.0; + } + if( e == (e0 + 1) ) + { + e -= 1; + y *= 2.0; + } + } + err = y - y0; + if( y0 != 0.0 ) + err /= y0; + if( err < 0.0 ) + err = -err; + if( e0 > -1023 ) + errth = 0.0; + else + {/* Denormal numbers may have rounding errors */ + if( e0 == -1023 ) + { + errth = 2.0 * MACHEP; + } + else + { + errth *= 2.0; + } + } + + if( (x != 0.0) && ((err > errth) || (e != e0)) ) + { + printf( "Test %d: ", j+1 ); + printf( " frexp( %.15e) =?= %.15e * 2**%d;", x, y, e ); + printf( " should be %.15e * 2**%d\n", y0, e0 ); + errfr += 1; + } + y = ldexp( x, 1-e0 ); + err = y - 1.0; + if( err < 0.0 ) + err = -err; + if( (err > errth) && ((x == 0.0) && (y != 0.0)) ) + { + printf( "Test %d: ", j+1 ); + printf( "ldexp( %.15e, %d ) =?= %.15e;", x, 1-e0, y ); + if( x != 0.0 ) + printf( " should be %.15e\n", f ); + else + printf( " should be %.15e\n", 0.0 ); + errld += 1; + } + if( x == 0.0 ) + { + break; + } + } +f = f * 1.08005973889; +} + +if( (errld == 0) && (errfr == 0) ) + { + printf( "No errors found.\n" ); + } + +flrtst: + +printf( "Testing floor().\n" ); +errfl = 0; + +f = 1.0/MACHEP; +x00 = 1.0; +for( j=0; j<57; j++ ) +{ +x = x00 - 1.0; +for( i=0; i<128; i++ ) + { + y = floor(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.49; + y = floor(z); + if( z == x ) + break; + if( y != (x - 1.0) ) + { + flierr( z, y, j ); + errfl += 1; + } + + z = x + 0.49; + y = floor(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + y = floor(x); + if( z != x ) + { + if( y != x ) + { + flierr( x, y, j ); + errfl += 1; + } + } + z = x + 0.49; + y = floor(z); + if( z != x ) + { + if( y != x ) + { + flierr( z, y, j ); + errfl += 1; + } + } + z = x - 0.49; + y = floor(z); + if( z != x ) + { + if( y != (x - 1.0) ) + { + flierr( z, y, j ); + errfl += 1; + } + } + x = -x; + x += 1.0; + } +x00 = x00 + x00; +} +y = floor(0.0); +if( y != 0.0 ) + { + flierr( 0.0, y, 57 ); + errfl += 1; + } +y = floor(-0.0); +if( y != 0.0 ) + { + flierr( -0.0, y, 58 ); + errfl += 1; + } +y = floor(-1.0); +if( y != -1.0 ) + { + flierr( -1.0, y, 59 ); + errfl += 1; + } +y = floor(-0.1); +if( y != -1.0 ) + { + flierr( -0.1, y, 60 ); + errfl += 1; + } + +if( errfl == 0 ) + printf( "No errors found in floor().\n" ); + +} + + +flierr( x, y, k ) +double x, y; +int k; +{ +printf( "Test %d: ", k+1 ); +printf( "floor(%.15e) =?= %.15e\n", x, y ); +} diff --git a/libm/double/fresnl.c b/libm/double/fresnl.c new file mode 100644 index 000000000..0872d107a --- /dev/null +++ b/libm/double/fresnl.c @@ -0,0 +1,515 @@ +/* fresnl.c + * + * Fresnel integral + * + * + * + * SYNOPSIS: + * + * double x, S, C; + * void fresnl(); + * + * fresnl( x, _&S, _&C ); + * + * + * DESCRIPTION: + * + * Evaluates the Fresnel integrals + * + * x + * - + * | | + * C(x) = | cos(pi/2 t**2) dt, + * | | + * - + * 0 + * + * x + * - + * | | + * S(x) = | sin(pi/2 t**2) dt. + * | | + * - + * 0 + * + * + * The integrals are evaluated by a power series for x < 1. + * For x >= 1 auxiliary functions f(x) and g(x) are employed + * such that + * + * C(x) = 0.5 + f(x) sin( pi/2 x**2 ) - g(x) cos( pi/2 x**2 ) + * S(x) = 0.5 - f(x) cos( pi/2 x**2 ) - g(x) sin( pi/2 x**2 ) + * + * + * + * ACCURACY: + * + * Relative error. + * + * Arithmetic function domain # trials peak rms + * IEEE S(x) 0, 10 10000 2.0e-15 3.2e-16 + * IEEE C(x) 0, 10 10000 1.8e-15 3.3e-16 + * DEC S(x) 0, 10 6000 2.2e-16 3.9e-17 + * DEC C(x) 0, 10 5000 2.3e-16 3.9e-17 + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* S(x) for small x */ +#ifdef UNK +static double sn[6] = { +-2.99181919401019853726E3, + 7.08840045257738576863E5, +-6.29741486205862506537E7, + 2.54890880573376359104E9, +-4.42979518059697779103E10, + 3.18016297876567817986E11, +}; +static double sd[6] = { +/* 1.00000000000000000000E0,*/ + 2.81376268889994315696E2, + 4.55847810806532581675E4, + 5.17343888770096400730E6, + 4.19320245898111231129E8, + 2.24411795645340920940E10, + 6.07366389490084639049E11, +}; +#endif +#ifdef DEC +static unsigned short sn[24] = { +0143072,0176433,0065455,0127034, +0045055,0007200,0134540,0026661, +0146560,0035061,0023667,0127545, +0050027,0166503,0002673,0153756, +0151045,0002721,0121737,0102066, +0051624,0013177,0033451,0021271, +}; +static unsigned short sd[24] = { +/*0040200,0000000,0000000,0000000,*/ +0042214,0130051,0112070,0101617, +0044062,0010307,0172346,0152510, +0045635,0160575,0143200,0136642, +0047307,0171215,0127457,0052361, +0050647,0031447,0032621,0013510, +0052015,0064733,0117362,0012653, +}; +#endif +#ifdef IBMPC +static unsigned short sn[24] = { +0xb5c3,0x6d65,0x5fa3,0xc0a7, +0x05b6,0x172c,0xa1d0,0x4125, +0xf5ed,0x24f6,0x0746,0xc18e, +0x7afe,0x60b7,0xfda8,0x41e2, +0xf087,0x347b,0xa0ba,0xc224, +0x2457,0xe6e5,0x82cf,0x4252, +}; +static unsigned short sd[24] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x1072,0x3287,0x9605,0x4071, +0xdaa9,0xfe9c,0x4218,0x40e6, +0x17b4,0xb8d0,0xbc2f,0x4153, +0xea9e,0xb5e5,0xfe51,0x41b8, +0x22e9,0xe6b2,0xe664,0x4214, +0x42b5,0x73de,0xad3b,0x4261, +}; +#endif +#ifdef MIEEE +static unsigned short sn[24] = { +0xc0a7,0x5fa3,0x6d65,0xb5c3, +0x4125,0xa1d0,0x172c,0x05b6, +0xc18e,0x0746,0x24f6,0xf5ed, +0x41e2,0xfda8,0x60b7,0x7afe, +0xc224,0xa0ba,0x347b,0xf087, +0x4252,0x82cf,0xe6e5,0x2457, +}; +static unsigned short sd[24] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4071,0x9605,0x3287,0x1072, +0x40e6,0x4218,0xfe9c,0xdaa9, +0x4153,0xbc2f,0xb8d0,0x17b4, +0x41b8,0xfe51,0xb5e5,0xea9e, +0x4214,0xe664,0xe6b2,0x22e9, +0x4261,0xad3b,0x73de,0x42b5, +}; +#endif + +/* C(x) for small x */ +#ifdef UNK +static double cn[6] = { +-4.98843114573573548651E-8, + 9.50428062829859605134E-6, +-6.45191435683965050962E-4, + 1.88843319396703850064E-2, +-2.05525900955013891793E-1, + 9.99999999999999998822E-1, +}; +static double cd[7] = { + 3.99982968972495980367E-12, + 9.15439215774657478799E-10, + 1.25001862479598821474E-7, + 1.22262789024179030997E-5, + 8.68029542941784300606E-4, + 4.12142090722199792936E-2, + 1.00000000000000000118E0, +}; +#endif +#ifdef DEC +static unsigned short cn[24] = { +0132126,0040141,0063733,0013231, +0034037,0072223,0010200,0075637, +0135451,0021020,0073264,0036057, +0036632,0131520,0101316,0060233, +0137522,0072541,0136124,0132202, +0040200,0000000,0000000,0000000, +}; +static unsigned short cd[28] = { +0026614,0135503,0051776,0032631, +0030573,0121116,0154033,0126712, +0032406,0034100,0012442,0106212, +0034115,0017567,0150520,0164623, +0035543,0106171,0177336,0146351, +0037050,0150073,0000607,0171635, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short cn[24] = { +0x62d3,0x2cfb,0xc80c,0xbe6a, +0x0f74,0x6210,0xee92,0x3ee3, +0x8786,0x0ed6,0x2442,0xbf45, +0xcc13,0x1059,0x566a,0x3f93, +0x9690,0x378a,0x4eac,0xbfca, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short cd[28] = { +0xc6b3,0x6a7f,0x9768,0x3d91, +0x75b9,0xdb03,0x7449,0x3e0f, +0x5191,0x02a4,0xc708,0x3e80, +0x1d32,0xfa2a,0xa3ee,0x3ee9, +0xd99d,0x3fdb,0x718f,0x3f4c, +0xfe74,0x6030,0x1a07,0x3fa5, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short cn[24] = { +0xbe6a,0xc80c,0x2cfb,0x62d3, +0x3ee3,0xee92,0x6210,0x0f74, +0xbf45,0x2442,0x0ed6,0x8786, +0x3f93,0x566a,0x1059,0xcc13, +0xbfca,0x4eac,0x378a,0x9690, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short cd[28] = { +0x3d91,0x9768,0x6a7f,0xc6b3, +0x3e0f,0x7449,0xdb03,0x75b9, +0x3e80,0xc708,0x02a4,0x5191, +0x3ee9,0xa3ee,0xfa2a,0x1d32, +0x3f4c,0x718f,0x3fdb,0xd99d, +0x3fa5,0x1a07,0x6030,0xfe74, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +/* Auxiliary function f(x) */ +#ifdef UNK +static double fn[10] = { + 4.21543555043677546506E-1, + 1.43407919780758885261E-1, + 1.15220955073585758835E-2, + 3.45017939782574027900E-4, + 4.63613749287867322088E-6, + 3.05568983790257605827E-8, + 1.02304514164907233465E-10, + 1.72010743268161828879E-13, + 1.34283276233062758925E-16, + 3.76329711269987889006E-20, +}; +static double fd[10] = { +/* 1.00000000000000000000E0,*/ + 7.51586398353378947175E-1, + 1.16888925859191382142E-1, + 6.44051526508858611005E-3, + 1.55934409164153020873E-4, + 1.84627567348930545870E-6, + 1.12699224763999035261E-8, + 3.60140029589371370404E-11, + 5.88754533621578410010E-14, + 4.52001434074129701496E-17, + 1.25443237090011264384E-20, +}; +#endif +#ifdef DEC +static unsigned short fn[40] = { +0037727,0152216,0106601,0016214, +0037422,0154606,0112710,0071355, +0036474,0143453,0154253,0166545, +0035264,0161606,0022250,0073743, +0033633,0110036,0024653,0136246, +0032003,0036652,0041164,0036413, +0027740,0174122,0046305,0036726, +0025501,0125270,0121317,0167667, +0023032,0150555,0076175,0047443, +0020061,0133570,0070130,0027657, +}; +static unsigned short fd[40] = { +/*0040200,0000000,0000000,0000000,*/ +0040100,0063767,0054413,0151452, +0037357,0061566,0007243,0065754, +0036323,0005365,0033552,0133625, +0035043,0101123,0000275,0165402, +0033367,0146614,0110623,0023647, +0031501,0116644,0125222,0144263, +0027436,0062051,0117235,0001411, +0025204,0111543,0056370,0036201, +0022520,0071351,0015227,0122144, +0017554,0172240,0112713,0005006, +}; +#endif +#ifdef IBMPC +static unsigned short fn[40] = { +0x2391,0xd1b0,0xfa91,0x3fda, +0x0e5e,0xd2b9,0x5b30,0x3fc2, +0x7dad,0x7b15,0x98e5,0x3f87, +0x0efc,0xc495,0x9c70,0x3f36, +0x7795,0xc535,0x7203,0x3ed3, +0x87a1,0x484e,0x67b5,0x3e60, +0xa7bb,0x4998,0x1f0a,0x3ddc, +0xfdf7,0x1459,0x3557,0x3d48, +0xa9e4,0xaf8f,0x5a2d,0x3ca3, +0x05f6,0x0e0b,0x36ef,0x3be6, +}; +static unsigned short fd[40] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x7a65,0xeb21,0x0cfe,0x3fe8, +0x6d7d,0xc1d4,0xec6e,0x3fbd, +0x56f3,0xa6ed,0x615e,0x3f7a, +0xbd60,0x6017,0x704a,0x3f24, +0x64f5,0x9232,0xf9b1,0x3ebe, +0x5916,0x9552,0x33b4,0x3e48, +0xa061,0x33d3,0xcc85,0x3dc3, +0x0790,0x6b9f,0x926c,0x3d30, +0xf48d,0x2352,0x0e5d,0x3c8a, +0x6141,0x12b9,0x9e94,0x3bcd, +}; +#endif +#ifdef MIEEE +static unsigned short fn[40] = { +0x3fda,0xfa91,0xd1b0,0x2391, +0x3fc2,0x5b30,0xd2b9,0x0e5e, +0x3f87,0x98e5,0x7b15,0x7dad, +0x3f36,0x9c70,0xc495,0x0efc, +0x3ed3,0x7203,0xc535,0x7795, +0x3e60,0x67b5,0x484e,0x87a1, +0x3ddc,0x1f0a,0x4998,0xa7bb, +0x3d48,0x3557,0x1459,0xfdf7, +0x3ca3,0x5a2d,0xaf8f,0xa9e4, +0x3be6,0x36ef,0x0e0b,0x05f6, +}; +static unsigned short fd[40] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3fe8,0x0cfe,0xeb21,0x7a65, +0x3fbd,0xec6e,0xc1d4,0x6d7d, +0x3f7a,0x615e,0xa6ed,0x56f3, +0x3f24,0x704a,0x6017,0xbd60, +0x3ebe,0xf9b1,0x9232,0x64f5, +0x3e48,0x33b4,0x9552,0x5916, +0x3dc3,0xcc85,0x33d3,0xa061, +0x3d30,0x926c,0x6b9f,0x0790, +0x3c8a,0x0e5d,0x2352,0xf48d, +0x3bcd,0x9e94,0x12b9,0x6141, +}; +#endif + + +/* Auxiliary function g(x) */ +#ifdef UNK +static double gn[11] = { + 5.04442073643383265887E-1, + 1.97102833525523411709E-1, + 1.87648584092575249293E-2, + 6.84079380915393090172E-4, + 1.15138826111884280931E-5, + 9.82852443688422223854E-8, + 4.45344415861750144738E-10, + 1.08268041139020870318E-12, + 1.37555460633261799868E-15, + 8.36354435630677421531E-19, + 1.86958710162783235106E-22, +}; +static double gd[11] = { +/* 1.00000000000000000000E0,*/ + 1.47495759925128324529E0, + 3.37748989120019970451E-1, + 2.53603741420338795122E-2, + 8.14679107184306179049E-4, + 1.27545075667729118702E-5, + 1.04314589657571990585E-7, + 4.60680728146520428211E-10, + 1.10273215066240270757E-12, + 1.38796531259578871258E-15, + 8.39158816283118707363E-19, + 1.86958710162783236342E-22, +}; +#endif +#ifdef DEC +static unsigned short gn[44] = { +0040001,0021435,0120406,0053123, +0037511,0152523,0037703,0122011, +0036631,0134302,0122721,0110235, +0035463,0051712,0043215,0114732, +0034101,0025677,0147725,0057630, +0032323,0010342,0067523,0002206, +0030364,0152247,0110007,0054107, +0026230,0057654,0035464,0047124, +0023706,0036401,0167705,0045440, +0021166,0154447,0105632,0142461, +0016142,0002353,0011175,0170530, +}; +static unsigned short gd[44] = { +/*0040200,0000000,0000000,0000000,*/ +0040274,0145551,0016742,0127005, +0037654,0166557,0076416,0015165, +0036717,0140217,0030675,0050111, +0035525,0110060,0076405,0070502, +0034125,0176061,0060120,0031730, +0032340,0001615,0054343,0120501, +0030375,0041414,0070747,0107060, +0026233,0031034,0160757,0074526, +0023710,0003341,0137100,0144664, +0021167,0126414,0023774,0015435, +0016142,0002353,0011175,0170530, +}; +#endif +#ifdef IBMPC +static unsigned short gn[44] = { +0xcaca,0xb420,0x2463,0x3fe0, +0x7481,0x67f8,0x3aaa,0x3fc9, +0x3214,0x54ba,0x3718,0x3f93, +0xb33b,0x48d1,0x6a79,0x3f46, +0xabf3,0xf9fa,0x2577,0x3ee8, +0x6091,0x4dea,0x621c,0x3e7a, +0xeb09,0xf200,0x9a94,0x3dfe, +0x89cb,0x8766,0x0bf5,0x3d73, +0xa964,0x3df8,0xc7a0,0x3cd8, +0x58a6,0xf173,0xdb24,0x3c2e, +0xbe2b,0x624f,0x409d,0x3b6c, +}; +static unsigned short gd[44] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x55c1,0x23bc,0x996d,0x3ff7, +0xc34f,0xefa1,0x9dad,0x3fd5, +0xaa09,0xe637,0xf811,0x3f99, +0xae28,0x0fa0,0xb206,0x3f4a, +0x067b,0x2c0a,0xbf86,0x3eea, +0x7428,0xab1c,0x0071,0x3e7c, +0xf1c6,0x8e3c,0xa861,0x3dff, +0xef2b,0x9c3d,0x6643,0x3d73, +0x1936,0x37c8,0x00dc,0x3cd9, +0x8364,0x84ff,0xf5a1,0x3c2e, +0xbe2b,0x624f,0x409d,0x3b6c, +}; +#endif +#ifdef MIEEE +static unsigned short gn[44] = { +0x3fe0,0x2463,0xb420,0xcaca, +0x3fc9,0x3aaa,0x67f8,0x7481, +0x3f93,0x3718,0x54ba,0x3214, +0x3f46,0x6a79,0x48d1,0xb33b, +0x3ee8,0x2577,0xf9fa,0xabf3, +0x3e7a,0x621c,0x4dea,0x6091, +0x3dfe,0x9a94,0xf200,0xeb09, +0x3d73,0x0bf5,0x8766,0x89cb, +0x3cd8,0xc7a0,0x3df8,0xa964, +0x3c2e,0xdb24,0xf173,0x58a6, +0x3b6c,0x409d,0x624f,0xbe2b, +}; +static unsigned short gd[44] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3ff7,0x996d,0x23bc,0x55c1, +0x3fd5,0x9dad,0xefa1,0xc34f, +0x3f99,0xf811,0xe637,0xaa09, +0x3f4a,0xb206,0x0fa0,0xae28, +0x3eea,0xbf86,0x2c0a,0x067b, +0x3e7c,0x0071,0xab1c,0x7428, +0x3dff,0xa861,0x8e3c,0xf1c6, +0x3d73,0x6643,0x9c3d,0xef2b, +0x3cd9,0x00dc,0x37c8,0x1936, +0x3c2e,0xf5a1,0x84ff,0x8364, +0x3b6c,0x409d,0x624f,0xbe2b, +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double cos ( double ); +extern double sin ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +double fabs(), cos(), sin(), polevl(), p1evl(); +#endif +extern double PI, PIO2, MACHEP; + +int fresnl( xxa, ssa, cca ) +double xxa, *ssa, *cca; +{ +double f, g, cc, ss, c, s, t, u; +double x, x2; + +x = fabs(xxa); +x2 = x * x; +if( x2 < 2.5625 ) + { + t = x2 * x2; + ss = x * x2 * polevl( t, sn, 5)/p1evl( t, sd, 6 ); + cc = x * polevl( t, cn, 5)/polevl(t, cd, 6 ); + goto done; + } + + + + + + +if( x > 36974.0 ) + { + cc = 0.5; + ss = 0.5; + goto done; + } + + +/* Asymptotic power series auxiliary functions + * for large argument + */ + x2 = x * x; + t = PI * x2; + u = 1.0/(t * t); + t = 1.0/t; + f = 1.0 - u * polevl( u, fn, 9)/p1evl(u, fd, 10); + g = t * polevl( u, gn, 10)/p1evl(u, gd, 11); + + t = PIO2 * x2; + c = cos(t); + s = sin(t); + t = PI * x; + cc = 0.5 + (f * s - g * c)/t; + ss = 0.5 - (f * c + g * s)/t; + +done: +if( xxa < 0.0 ) + { + cc = -cc; + ss = -ss; + } + +*cca = cc; +*ssa = ss; +return(0); +} diff --git a/libm/double/gamma.c b/libm/double/gamma.c new file mode 100644 index 000000000..341b4e915 --- /dev/null +++ b/libm/double/gamma.c @@ -0,0 +1,685 @@ +/* gamma.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, gamma(); + * extern int sgngam; + * + * y = gamma( 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| <= 34 are reduced by recurrence and the function + * approximated by a rational function of degree 6/7 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 + * DEC -34, 34 10000 1.3e-16 2.5e-17 + * IEEE -170,-33 20000 2.3e-15 3.3e-16 + * IEEE -33, 33 20000 9.4e-16 2.2e-16 + * IEEE 33, 171.6 20000 2.3e-15 3.2e-16 + * + * Error for arguments outside the test range will be larger + * owing to error amplification by the exponential function. + * + */ +/* lgam() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, lgam(); + * extern int sgngam; + * + * y = lgam( 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 13, 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 MAXLGM return MAXNUM and an error + * message. MAXLGM = 2.035093e36 for DEC + * arithmetic or 2.556348e305 for IEEE arithmetic. + * + * + * + * ACCURACY: + * + * + * arithmetic domain # trials peak rms + * DEC 0, 3 7000 5.2e-17 1.3e-17 + * DEC 2.718, 2.035e36 5000 3.9e-17 9.9e-18 + * IEEE 0, 3 28000 5.4e-16 1.1e-16 + * IEEE 2.718, 2.556e305 40000 3.5e-16 8.3e-17 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * + * The following test used the relative error criterion, though + * at certain points the relative error could be much higher than + * indicated. + * IEEE -200, -4 10000 4.8e-16 1.3e-16 + * + */ + +/* gamma.c */ +/* gamma function */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 1992, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +static double P[] = { + 1.60119522476751861407E-4, + 1.19135147006586384913E-3, + 1.04213797561761569935E-2, + 4.76367800457137231464E-2, + 2.07448227648435975150E-1, + 4.94214826801497100753E-1, + 9.99999999999999996796E-1 +}; +static double Q[] = { +-2.31581873324120129819E-5, + 5.39605580493303397842E-4, +-4.45641913851797240494E-3, + 1.18139785222060435552E-2, + 3.58236398605498653373E-2, +-2.34591795718243348568E-1, + 7.14304917030273074085E-2, + 1.00000000000000000320E0 +}; +#define MAXGAM 171.624376956302725 +static double LOGPI = 1.14472988584940017414; +#endif + +#ifdef DEC +static unsigned short P[] = { +0035047,0162701,0146301,0005234, +0035634,0023437,0032065,0176530, +0036452,0137157,0047330,0122574, +0037103,0017310,0143041,0017232, +0037524,0066516,0162563,0164605, +0037775,0004671,0146237,0014222, +0040200,0000000,0000000,0000000 +}; +static unsigned short Q[] = { +0134302,0041724,0020006,0116565, +0035415,0072121,0044251,0025634, +0136222,0003447,0035205,0121114, +0036501,0107552,0154335,0104271, +0037022,0135717,0014776,0171471, +0137560,0034324,0165024,0037021, +0037222,0045046,0047151,0161213, +0040200,0000000,0000000,0000000 +}; +#define MAXGAM 34.84425627277176174 +static unsigned short LPI[4] = { +0040222,0103202,0043475,0006750, +}; +#define LOGPI *(double *)LPI +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x2153,0x3998,0xfcb8,0x3f24, +0xbfab,0xe686,0x84e3,0x3f53, +0x14b0,0xe9db,0x57cd,0x3f85, +0x23d3,0x18c4,0x63d9,0x3fa8, +0x7d31,0xdcae,0x8da9,0x3fca, +0xe312,0x3993,0xa137,0x3fdf, +0x0000,0x0000,0x0000,0x3ff0 +}; +static unsigned short Q[] = { +0xd3af,0x8400,0x487a,0xbef8, +0x2573,0x2915,0xae8a,0x3f41, +0xb44a,0xe750,0x40e4,0xbf72, +0xb117,0x5b1b,0x31ed,0x3f88, +0xde67,0xe33f,0x5779,0x3fa2, +0x87c2,0x9d42,0x071a,0xbfce, +0x3c51,0xc9cd,0x4944,0x3fb2, +0x0000,0x0000,0x0000,0x3ff0 +}; +#define MAXGAM 171.624376956302725 +static unsigned short LPI[4] = { +0xa1bd,0x48e7,0x50d0,0x3ff2, +}; +#define LOGPI *(double *)LPI +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f24,0xfcb8,0x3998,0x2153, +0x3f53,0x84e3,0xe686,0xbfab, +0x3f85,0x57cd,0xe9db,0x14b0, +0x3fa8,0x63d9,0x18c4,0x23d3, +0x3fca,0x8da9,0xdcae,0x7d31, +0x3fdf,0xa137,0x3993,0xe312, +0x3ff0,0x0000,0x0000,0x0000 +}; +static unsigned short Q[] = { +0xbef8,0x487a,0x8400,0xd3af, +0x3f41,0xae8a,0x2915,0x2573, +0xbf72,0x40e4,0xe750,0xb44a, +0x3f88,0x31ed,0x5b1b,0xb117, +0x3fa2,0x5779,0xe33f,0xde67, +0xbfce,0x071a,0x9d42,0x87c2, +0x3fb2,0x4944,0xc9cd,0x3c51, +0x3ff0,0x0000,0x0000,0x0000 +}; +#define MAXGAM 171.624376956302725 +static unsigned short LPI[4] = { +0x3ff2,0x50d0,0x48e7,0xa1bd, +}; +#define LOGPI *(double *)LPI +#endif + +/* Stirling's formula for the gamma function */ +#if UNK +static double STIR[5] = { + 7.87311395793093628397E-4, +-2.29549961613378126380E-4, +-2.68132617805781232825E-3, + 3.47222221605458667310E-3, + 8.33333333333482257126E-2, +}; +#define MAXSTIR 143.01608 +static double SQTPI = 2.50662827463100050242E0; +#endif +#if DEC +static unsigned short STIR[20] = { +0035516,0061622,0144553,0112224, +0135160,0131531,0037460,0165740, +0136057,0134460,0037242,0077270, +0036143,0107070,0156306,0027751, +0037252,0125252,0125252,0146064, +}; +#define MAXSTIR 26.77 +static unsigned short SQT[4] = { +0040440,0066230,0177661,0034055, +}; +#define SQTPI *(double *)SQT +#endif +#if IBMPC +static unsigned short STIR[20] = { +0x7293,0x592d,0xcc72,0x3f49, +0x1d7c,0x27e6,0x166b,0xbf2e, +0x4fd7,0x07d4,0xf726,0xbf65, +0xc5fd,0x1b98,0x71c7,0x3f6c, +0x5986,0x5555,0x5555,0x3fb5, +}; +#define MAXSTIR 143.01608 +static unsigned short SQT[4] = { +0x2706,0x1ff6,0x0d93,0x4004, +}; +#define SQTPI *(double *)SQT +#endif +#if MIEEE +static unsigned short STIR[20] = { +0x3f49,0xcc72,0x592d,0x7293, +0xbf2e,0x166b,0x27e6,0x1d7c, +0xbf65,0xf726,0x07d4,0x4fd7, +0x3f6c,0x71c7,0x1b98,0xc5fd, +0x3fb5,0x5555,0x5555,0x5986, +}; +#define MAXSTIR 143.01608 +static unsigned short SQT[4] = { +0x4004,0x0d93,0x1ff6,0x2706, +}; +#define SQTPI *(double *)SQT +#endif + +int sgngam = 0; +extern int sgngam; +extern double MAXLOG, MAXNUM, PI; +#ifdef ANSIPROT +extern double pow ( double, double ); +extern double log ( double ); +extern double exp ( double ); +extern double sin ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double fabs ( double ); +extern int isnan ( double ); +extern int isfinite ( double ); +static double stirf ( double ); +double lgam ( double ); +#else +double pow(), log(), exp(), sin(), polevl(), p1evl(), floor(), fabs(); +int isnan(), isfinite(); +static double stirf(); +double lgam(); +#endif +#ifdef INFINITIES +extern double INFINITY; +#endif +#ifdef NANS +extern double NAN; +#endif + +/* Gamma function computed by Stirling's formula. + * The polynomial STIR is valid for 33 <= x <= 172. + */ +static double stirf(x) +double x; +{ +double y, w, v; + +w = 1.0/x; +w = 1.0 + w * polevl( w, STIR, 4 ); +y = exp(x); +if( x > MAXSTIR ) + { /* Avoid overflow in pow() */ + v = pow( x, 0.5 * x - 0.25 ); + y = v * (v / y); + } +else + { + y = pow( x, x - 0.5 ) / y; + } +y = SQTPI * y * w; +return( y ); +} + + + +double gamma(x) +double x; +{ +double p, q, z; +int i; + +sgngam = 1; +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +#ifdef INFINITIES +#ifdef NANS +if( x == INFINITY ) + return(x); +if( x == -INFINITY ) + return(NAN); +#else +if( !isfinite(x) ) + return(x); +#endif +#endif +q = fabs(x); + +if( q > 33.0 ) + { + if( x < 0.0 ) + { + p = floor(q); + if( p == q ) + { +#ifdef NANS +gamnan: + mtherr( "gamma", DOMAIN ); + return (NAN); +#else + goto goverf; +#endif + } + i = p; + if( (i & 1) == 0 ) + sgngam = -1; + z = q - p; + if( z > 0.5 ) + { + p += 1.0; + z = q - p; + } + z = q * sin( PI * z ); + if( z == 0.0 ) + { +#ifdef INFINITIES + return( sgngam * INFINITY); +#else +goverf: + mtherr( "gamma", OVERFLOW ); + return( sgngam * MAXNUM); +#endif + } + z = fabs(z); + z = PI/(z * stirf(q) ); + } + else + { + z = stirf(x); + } + return( sgngam * z ); + } + +z = 1.0; +while( x >= 3.0 ) + { + x -= 1.0; + z *= x; + } + +while( x < 0.0 ) + { + if( x > -1.E-9 ) + goto small; + z /= x; + x += 1.0; + } + +while( x < 2.0 ) + { + if( x < 1.e-9 ) + goto small; + z /= x; + x += 1.0; + } + +if( x == 2.0 ) + return(z); + +x -= 2.0; +p = polevl( x, P, 6 ); +q = polevl( x, Q, 7 ); +return( z * p / q ); + +small: +if( x == 0.0 ) + { +#ifdef INFINITIES +#ifdef NANS + goto gamnan; +#else + return( INFINITY ); +#endif +#else + mtherr( "gamma", SING ); + return( MAXNUM ); +#endif + } +else + return( z/((1.0 + 0.5772156649015329 * x) * x) ); +} + + + +/* A[]: Stirling's formula expansion of log gamma + * B[], C[]: log gamma function between 2 and 3 + */ +#ifdef UNK +static double A[] = { + 8.11614167470508450300E-4, +-5.95061904284301438324E-4, + 7.93650340457716943945E-4, +-2.77777777730099687205E-3, + 8.33333333333331927722E-2 +}; +static double B[] = { +-1.37825152569120859100E3, +-3.88016315134637840924E4, +-3.31612992738871184744E5, +-1.16237097492762307383E6, +-1.72173700820839662146E6, +-8.53555664245765465627E5 +}; +static double C[] = { +/* 1.00000000000000000000E0, */ +-3.51815701436523470549E2, +-1.70642106651881159223E4, +-2.20528590553854454839E5, +-1.13933444367982507207E6, +-2.53252307177582951285E6, +-2.01889141433532773231E6 +}; +/* log( sqrt( 2*pi ) ) */ +static double LS2PI = 0.91893853320467274178; +#define MAXLGM 2.556348e305 +#endif + +#ifdef DEC +static unsigned short A[] = { +0035524,0141201,0034633,0031405, +0135433,0176755,0126007,0045030, +0035520,0006371,0003342,0172730, +0136066,0005540,0132605,0026407, +0037252,0125252,0125252,0125132 +}; +static unsigned short B[] = { +0142654,0044014,0077633,0035410, +0144027,0110641,0125335,0144760, +0144641,0165637,0142204,0047447, +0145215,0162027,0146246,0155211, +0145322,0026110,0010317,0110130, +0145120,0061472,0120300,0025363 +}; +static unsigned short C[] = { +/*0040200,0000000,0000000,0000000*/ +0142257,0164150,0163630,0112622, +0143605,0050153,0156116,0135272, +0144527,0056045,0145642,0062332, +0145213,0012063,0106250,0001025, +0145432,0111254,0044577,0115142, +0145366,0071133,0050217,0005122 +}; +/* log( sqrt( 2*pi ) ) */ +static unsigned short LS2P[] = {040153,037616,041445,0172645,}; +#define LS2PI *(double *)LS2P +#define MAXLGM 2.035093e36 +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0x6661,0x2733,0x9850,0x3f4a, +0xe943,0xb580,0x7fbd,0xbf43, +0x5ebb,0x20dc,0x019f,0x3f4a, +0xa5a1,0x16b0,0xc16c,0xbf66, +0x554b,0x5555,0x5555,0x3fb5 +}; +static unsigned short B[] = { +0x6761,0x8ff3,0x8901,0xc095, +0xb93e,0x355b,0xf234,0xc0e2, +0x89e5,0xf890,0x3d73,0xc114, +0xdb51,0xf994,0xbc82,0xc131, +0xf20b,0x0219,0x4589,0xc13a, +0x055e,0x5418,0x0c67,0xc12a +}; +static unsigned short C[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x12b2,0x1cf3,0xfd0d,0xc075, +0xd757,0x7b89,0xaa0d,0xc0d0, +0x4c9b,0xb974,0xeb84,0xc10a, +0x0043,0x7195,0x6286,0xc131, +0xf34c,0x892f,0x5255,0xc143, +0xe14a,0x6a11,0xce4b,0xc13e +}; +/* log( sqrt( 2*pi ) ) */ +static unsigned short LS2P[] = { +0xbeb5,0xc864,0x67f1,0x3fed +}; +#define LS2PI *(double *)LS2P +#define MAXLGM 2.556348e305 +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0x3f4a,0x9850,0x2733,0x6661, +0xbf43,0x7fbd,0xb580,0xe943, +0x3f4a,0x019f,0x20dc,0x5ebb, +0xbf66,0xc16c,0x16b0,0xa5a1, +0x3fb5,0x5555,0x5555,0x554b +}; +static unsigned short B[] = { +0xc095,0x8901,0x8ff3,0x6761, +0xc0e2,0xf234,0x355b,0xb93e, +0xc114,0x3d73,0xf890,0x89e5, +0xc131,0xbc82,0xf994,0xdb51, +0xc13a,0x4589,0x0219,0xf20b, +0xc12a,0x0c67,0x5418,0x055e +}; +static unsigned short C[] = { +0xc075,0xfd0d,0x1cf3,0x12b2, +0xc0d0,0xaa0d,0x7b89,0xd757, +0xc10a,0xeb84,0xb974,0x4c9b, +0xc131,0x6286,0x7195,0x0043, +0xc143,0x5255,0x892f,0xf34c, +0xc13e,0xce4b,0x6a11,0xe14a +}; +/* log( sqrt( 2*pi ) ) */ +static unsigned short LS2P[] = { +0x3fed,0x67f1,0xc864,0xbeb5 +}; +#define LS2PI *(double *)LS2P +#define MAXLGM 2.556348e305 +#endif + + +/* Logarithm of gamma function */ + + +double lgam(x) +double x; +{ +double p, q, u, w, z; +int i; + +sgngam = 1; +#ifdef NANS +if( isnan(x) ) + return(x); +#endif + +#ifdef INFINITIES +if( !isfinite(x) ) + return(INFINITY); +#endif + +if( x < -34.0 ) + { + q = -x; + w = lgam(q); /* note this modifies sgngam! */ + p = floor(q); + if( p == q ) + { +lgsing: +#ifdef INFINITIES + mtherr( "lgam", SING ); + return (INFINITY); +#else + goto loverf; +#endif + } + i = p; + if( (i & 1) == 0 ) + sgngam = -1; + else + sgngam = 1; + z = q - p; + if( z > 0.5 ) + { + p += 1.0; + z = p - q; + } + z = q * sin( PI * z ); + if( z == 0.0 ) + goto lgsing; +/* z = log(PI) - log( z ) - w;*/ + z = LOGPI - log( z ) - w; + return( z ); + } + +if( x < 13.0 ) + { + z = 1.0; + p = 0.0; + u = x; + while( u >= 3.0 ) + { + p -= 1.0; + u = x + p; + z *= u; + } + while( u < 2.0 ) + { + if( u == 0.0 ) + goto lgsing; + z /= u; + p += 1.0; + u = x + p; + } + if( z < 0.0 ) + { + sgngam = -1; + z = -z; + } + else + sgngam = 1; + if( u == 2.0 ) + return( log(z) ); + p -= 2.0; + x = x + p; + p = x * polevl( x, B, 5 ) / p1evl( x, C, 6); + return( log(z) + p ); + } + +if( x > MAXLGM ) + { +#ifdef INFINITIES + return( sgngam * INFINITY ); +#else +loverf: + mtherr( "lgam", OVERFLOW ); + return( sgngam * MAXNUM ); +#endif + } + +q = ( x - 0.5 ) * log(x) - x + LS2PI; +if( x > 1.0e8 ) + return( q ); + +p = 1.0/(x*x); +if( x >= 1000.0 ) + q += (( 7.9365079365079365079365e-4 * p + - 2.7777777777777777777778e-3) *p + + 0.0833333333333333333333) / x; +else + q += polevl( p, A, 4 ) / x; +return( q ); +} diff --git a/libm/double/gdtr.c b/libm/double/gdtr.c new file mode 100644 index 000000000..6b27d9abb --- /dev/null +++ b/libm/double/gdtr.c @@ -0,0 +1,130 @@ +/* gdtr.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, gdtr(); + * + * y = gdtr( 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 + * gdtr domain x < 0 0.0 + * + */ + /* gdtrc.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, gdtrc(); + * + * y = gdtrc( 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 + * gdtrc domain x < 0 0.0 + * + */ + +/* gdtr() */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double igam ( double, double ); +extern double igamc ( double, double ); +#else +double igam(), igamc(); +#endif + +double gdtr( a, b, x ) +double a, b, x; +{ + +if( x < 0.0 ) + { + mtherr( "gdtr", DOMAIN ); + return( 0.0 ); + } +return( igam( b, a * x ) ); +} + + + +double gdtrc( a, b, x ) +double a, b, x; +{ + +if( x < 0.0 ) + { + mtherr( "gdtrc", DOMAIN ); + return( 0.0 ); + } +return( igamc( b, a * x ) ); +} diff --git a/libm/double/gels.c b/libm/double/gels.c new file mode 100644 index 000000000..4d548d050 --- /dev/null +++ b/libm/double/gels.c @@ -0,0 +1,232 @@ +/* +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 <math.h> +#ifdef ANSIPROT +extern double fabs ( double ); +#else +double fabs(); +#endif + +gels( A, R, M, EPS, AUX ) +double A[],R[]; +int M; +double EPS; +double AUX[]; +{ +int I, J, K, L, IER; +int II, LL, LLD, LR, LT, LST, LLST, LEND; +double tb, piv, tol, pivi; + +if( M <= 0 ) + { +fatal: + IER = -1; + goto done; + } +/* SEARCH FOR GREATEST MAIN DIAGONAL ELEMENT */ + +/* Diagonal elements are at A(i,i) = 1, 3, 6, 10, ... + * A(i,j) = A( i(i-1)/2 + j ) + */ +IER = 0; +piv = 0.0; +L = 0; +for( K=1; K<=M; K++ ) + { + L += K; + tb = fabs( 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.0 ) + goto fatal; + if( IER == 0 ) + { + if( piv <= tol ) + { + IER = K - 1; + } + } + LT = J - K; + LST += K; + +/* PIVOT ROW REDUCTION AND ROW INTERCHANGE IN RIGHT HAND SIDE R */ + pivi = 1.0 / 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.0; + 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 =fabs( 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 ) + { + if( LEND < 0 ) + goto fatal; + goto done; + } +II = M; +for( I=2; I<=M; I++ ) + { + LST -= II; + II -= 1; + L = A[LST-1] + 0.5; + 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: +return( IER ); +} diff --git a/libm/double/hyp2f1.c b/libm/double/hyp2f1.c new file mode 100644 index 000000000..f2e93106c --- /dev/null +++ b/libm/double/hyp2f1.c @@ -0,0 +1,460 @@ +/* hyp2f1.c + * + * Gauss hypergeometric function F + * 2 1 + * + * + * SYNOPSIS: + * + * double a, b, c, x, y, hyp2f1(); + * + * y = hyp2f1( a, b, c, x ); + * + * + * DESCRIPTION: + * + * + * hyp2f1( a, b, c, x ) = F ( a, b; c; x ) + * 2 1 + * + * inf. + * - a(a+1)...(a+k) b(b+1)...(b+k) k+1 + * = 1 + > ----------------------------- x . + * - c(c+1)...(c+k) (k+1)! + * k = 0 + * + * Cases addressed are + * Tests and escapes for negative integer a, b, or c + * Linear transformation if c - a or c - b negative integer + * Special case c = a or c = b + * Linear transformation for x near +1 + * Transformation for x < -0.5 + * Psi function expansion if x > 0.5 and c - a - b integer + * Conditionally, a recurrence on c to make c-a-b > 0 + * + * |x| > 1 is rejected. + * + * The parameters a, b, c are considered to be integer + * valued if they are within 1.0e-14 of the nearest integer + * (1.0e-13 for IEEE arithmetic). + * + * ACCURACY: + * + * + * Relative error (-1 < x < 1): + * arithmetic domain # trials peak rms + * IEEE -1,7 230000 1.2e-11 5.2e-14 + * + * Several special cases also tested with a, b, c in + * the range -7 to 7. + * + * ERROR MESSAGES: + * + * A "partial loss of precision" message is printed if + * the internally estimated relative error exceeds 1^-12. + * A "singularity" message is printed on overflow or + * in cases not addressed (such as x < -1). + */ + +/* hyp2f1 */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1992, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef DEC +#define EPS 1.0e-14 +#define EPS2 1.0e-11 +#endif + +#ifdef IBMPC +#define EPS 1.0e-13 +#define EPS2 1.0e-10 +#endif + +#ifdef MIEEE +#define EPS 1.0e-13 +#define EPS2 1.0e-10 +#endif + +#ifdef UNK +#define EPS 1.0e-13 +#define EPS2 1.0e-10 +#endif + +#define ETHRESH 1.0e-12 + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double pow ( double, double ); +extern double round ( double ); +extern double gamma ( double ); +extern double log ( double ); +extern double exp ( double ); +extern double psi ( double ); +static double hyt2f1(double, double, double, double, double *); +static double hys2f1(double, double, double, double, double *); +double hyp2f1(double, double, double, double); +#else +double fabs(), pow(), round(), gamma(), log(), exp(), psi(); +static double hyt2f1(); +static double hys2f1(); +double hyp2f1(); +#endif +extern double MAXNUM, MACHEP; + +double hyp2f1( a, b, c, x ) +double a, b, c, x; +{ +double d, d1, d2, e; +double p, q, r, s, y, ax; +double ia, ib, ic, id, err; +int flag, i, aid; + +err = 0.0; +ax = fabs(x); +s = 1.0 - x; +flag = 0; +ia = round(a); /* nearest integer to a */ +ib = round(b); + +if( a <= 0 ) + { + if( fabs(a-ia) < EPS ) /* a is a negative integer */ + flag |= 1; + } + +if( b <= 0 ) + { + if( fabs(b-ib) < EPS ) /* b is a negative integer */ + flag |= 2; + } + +if( ax < 1.0 ) + { + if( fabs(b-c) < EPS ) /* b = c */ + { + y = pow( s, -a ); /* s to the -a power */ + goto hypdon; + } + if( fabs(a-c) < EPS ) /* a = c */ + { + y = pow( s, -b ); /* s to the -b power */ + goto hypdon; + } + } + + + +if( c <= 0.0 ) + { + ic = round(c); /* nearest integer to c */ + if( fabs(c-ic) < EPS ) /* c is a negative integer */ + { + /* check if termination before explosion */ + if( (flag & 1) && (ia > ic) ) + goto hypok; + if( (flag & 2) && (ib > ic) ) + goto hypok; + goto hypdiv; + } + } + +if( flag ) /* function is a polynomial */ + goto hypok; + +if( ax > 1.0 ) /* series diverges */ + goto hypdiv; + +p = c - a; +ia = round(p); /* nearest integer to c-a */ +if( (ia <= 0.0) && (fabs(p-ia) < EPS) ) /* negative int c - a */ + flag |= 4; + +r = c - b; +ib = round(r); /* nearest integer to c-b */ +if( (ib <= 0.0) && (fabs(r-ib) < EPS) ) /* negative int c - b */ + flag |= 8; + +d = c - a - b; +id = round(d); /* nearest integer to d */ +q = fabs(d-id); + +/* Thanks to Christian Burger <BURGER@DMRHRZ11.HRZ.Uni-Marburg.DE> + * for reporting a bug here. */ +if( fabs(ax-1.0) < EPS ) /* |x| == 1.0 */ + { + if( x > 0.0 ) + { + if( flag & 12 ) /* negative int c-a or c-b */ + { + if( d >= 0.0 ) + goto hypf; + else + goto hypdiv; + } + if( d <= 0.0 ) + goto hypdiv; + y = gamma(c)*gamma(d)/(gamma(p)*gamma(r)); + goto hypdon; + } + + if( d <= -1.0 ) + goto hypdiv; + + } + +/* Conditionally make d > 0 by recurrence on c + * AMS55 #15.2.27 + */ +if( d < 0.0 ) + { +/* Try the power series first */ + y = hyt2f1( a, b, c, x, &err ); + if( err < ETHRESH ) + goto hypdon; +/* Apply the recurrence if power series fails */ + err = 0.0; + aid = 2 - id; + e = c + aid; + d2 = hyp2f1(a,b,e,x); + d1 = hyp2f1(a,b,e+1.0,x); + q = a + b + 1.0; + for( i=0; i<aid; i++ ) + { + r = e - 1.0; + y = (e*(r-(2.0*e-q)*x)*d2 + (e-a)*(e-b)*x*d1)/(e*r*s); + e = r; + d1 = d2; + d2 = y; + } + goto hypdon; + } + + +if( flag & 12 ) + goto hypf; /* negative integer c-a or c-b */ + +hypok: +y = hyt2f1( a, b, c, x, &err ); + + +hypdon: +if( err > ETHRESH ) + { + mtherr( "hyp2f1", PLOSS ); +/* printf( "Estimated err = %.2e\n", err ); */ + } +return(y); + +/* The transformation for c-a or c-b negative integer + * AMS55 #15.3.3 + */ +hypf: +y = pow( s, d ) * hys2f1( c-a, c-b, c, x, &err ); +goto hypdon; + +/* The alarm exit */ +hypdiv: +mtherr( "hyp2f1", OVERFLOW ); +return( MAXNUM ); +} + + + + + + +/* Apply transformations for |x| near 1 + * then call the power series + */ +static double hyt2f1( a, b, c, x, loss ) +double a, b, c, x; +double *loss; +{ +double p, q, r, s, t, y, d, err, err1; +double ax, id, d1, d2, e, y1; +int i, aid; + +err = 0.0; +s = 1.0 - x; +if( x < -0.5 ) + { + if( b > a ) + y = pow( s, -a ) * hys2f1( a, c-b, c, -x/s, &err ); + + else + y = pow( s, -b ) * hys2f1( c-a, b, c, -x/s, &err ); + + goto done; + } + +d = c - a - b; +id = round(d); /* nearest integer to d */ + +if( x > 0.9 ) +{ +if( fabs(d-id) > EPS ) /* test for integer c-a-b */ + { +/* Try the power series first */ + y = hys2f1( a, b, c, x, &err ); + if( err < ETHRESH ) + goto done; +/* If power series fails, then apply AMS55 #15.3.6 */ + q = hys2f1( a, b, 1.0-d, s, &err ); + q *= gamma(d) /(gamma(c-a) * gamma(c-b)); + r = pow(s,d) * hys2f1( c-a, c-b, d+1.0, s, &err1 ); + r *= gamma(-d)/(gamma(a) * gamma(b)); + y = q + r; + + q = fabs(q); /* estimate cancellation error */ + r = fabs(r); + if( q > r ) + r = q; + err += err1 + (MACHEP*r)/y; + + y *= gamma(c); + goto done; + } +else + { +/* Psi function expansion, AMS55 #15.3.10, #15.3.11, #15.3.12 */ + if( id >= 0.0 ) + { + e = d; + d1 = d; + d2 = 0.0; + aid = id; + } + else + { + e = -d; + d1 = 0.0; + d2 = d; + aid = -id; + } + + ax = log(s); + + /* sum for t = 0 */ + y = psi(1.0) + psi(1.0+e) - psi(a+d1) - psi(b+d1) - ax; + y /= gamma(e+1.0); + + p = (a+d1) * (b+d1) * s / gamma(e+2.0); /* Poch for t=1 */ + t = 1.0; + do + { + r = psi(1.0+t) + psi(1.0+t+e) - psi(a+t+d1) + - psi(b+t+d1) - ax; + q = p * r; + y += q; + p *= s * (a+t+d1) / (t+1.0); + p *= (b+t+d1) / (t+1.0+e); + t += 1.0; + } + while( fabs(q/y) > EPS ); + + + if( id == 0.0 ) + { + y *= gamma(c)/(gamma(a)*gamma(b)); + goto psidon; + } + + y1 = 1.0; + + if( aid == 1 ) + goto nosum; + + t = 0.0; + p = 1.0; + for( i=1; i<aid; i++ ) + { + r = 1.0-e+t; + p *= s * (a+t+d2) * (b+t+d2) / r; + t += 1.0; + p /= t; + y1 += p; + } +nosum: + p = gamma(c); + y1 *= gamma(e) * p / (gamma(a+d1) * gamma(b+d1)); + + y *= p / (gamma(a+d2) * gamma(b+d2)); + if( (aid & 1) != 0 ) + y = -y; + + q = pow( s, id ); /* s to the id power */ + if( id > 0.0 ) + y *= q; + else + y1 *= q; + + y += y1; +psidon: + goto done; + } + +} + +/* Use defining power series if no special cases */ +y = hys2f1( a, b, c, x, &err ); + +done: +*loss = err; +return(y); +} + + + + + +/* Defining power series expansion of Gauss hypergeometric function */ + +static double hys2f1( a, b, c, x, loss ) +double a, b, c, x; +double *loss; /* estimates loss of significance */ +{ +double f, g, h, k, m, s, u, umax; +int i; + +i = 0; +umax = 0.0; +f = a; +g = b; +h = c; +s = 1.0; +u = 1.0; +k = 0.0; +do + { + if( fabs(h) < EPS ) + { + *loss = 1.0; + return( MAXNUM ); + } + m = k + 1.0; + u = u * ((f+k) * (g+k) * x / ((h+k) * m)); + s += u; + k = fabs(u); /* remember largest term summed */ + if( k > umax ) + umax = k; + k = m; + if( ++i > 10000 ) /* should never happen */ + { + *loss = 1.0; + return(s); + } + } +while( fabs(u/s) > MACHEP ); + +/* return estimated relative error */ +*loss = (MACHEP*umax)/fabs(s) + (MACHEP*i); + +return(s); +} diff --git a/libm/double/hyperg.c b/libm/double/hyperg.c new file mode 100644 index 000000000..36a3f9781 --- /dev/null +++ b/libm/double/hyperg.c @@ -0,0 +1,386 @@ +/* hyperg.c + * + * Confluent hypergeometric function + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, hyperg(); + * + * y = hyperg( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Computes the confluent hypergeometric function + * + * 1 2 + * a x a(a+1) x + * F ( a,b;x ) = 1 + ---- + --------- + ... + * 1 1 b 1! b(b+1) 2! + * + * Many higher transcendental functions are special cases of + * this power series. + * + * As is evident from the formula, b must not be a negative + * integer or zero unless a is an integer with 0 >= a > b. + * + * The routine attempts both a direct summation of the series + * and an asymptotic expansion. In each case error due to + * roundoff, cancellation, and nonconvergence is estimated. + * The result with smaller estimated error is returned. + * + * + * + * ACCURACY: + * + * Tested at random points (a, b, x), all three variables + * ranging from 0 to 30. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 1.2e-15 1.3e-16 + qtst1: + 21800 max = 1.4200E-14 rms = 1.0841E-15 ave = -5.3640E-17 + ltstd: + 25500 max = 1.2759e-14 rms = 3.7155e-16 ave = 1.5384e-18 + * IEEE 0,30 30000 1.8e-14 1.1e-15 + * + * Larger errors can be observed when b is near a negative + * integer or zero. Certain combinations of arguments yield + * serious cancellation error in the power series summation + * and also are not in the region of near convergence of the + * asymptotic series. An error message is printed if the + * self-estimated relative error is greater than 1.0e-12. + * + */ + +/* hyperg.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef ANSIPROT +extern double exp ( double ); +extern double log ( double ); +extern double gamma ( double ); +extern double lgam ( double ); +extern double fabs ( double ); +double hyp2f0 ( double, double, double, int, double * ); +static double hy1f1p(double, double, double, double *); +static double hy1f1a(double, double, double, double *); +double hyperg (double, double, double); +#else +double exp(), log(), gamma(), lgam(), fabs(), hyp2f0(); +static double hy1f1p(); +static double hy1f1a(); +double hyperg(); +#endif +extern double MAXNUM, MACHEP; + +double hyperg( a, b, x) +double a, b, x; +{ +double asum, psum, acanc, pcanc, temp; + +/* See if a Kummer transformation will help */ +temp = b - a; +if( fabs(temp) < 0.001 * fabs(a) ) + return( exp(x) * hyperg( temp, b, -x ) ); + + +psum = hy1f1p( a, b, x, &pcanc ); +if( pcanc < 1.0e-15 ) + goto done; + + +/* try asymptotic series */ + +asum = hy1f1a( a, b, x, &acanc ); + + +/* Pick the result with less estimated error */ + +if( acanc < pcanc ) + { + pcanc = acanc; + psum = asum; + } + +done: +if( pcanc > 1.0e-12 ) + mtherr( "hyperg", PLOSS ); + +return( psum ); +} + + + + +/* Power series summation for confluent hypergeometric function */ + + +static double hy1f1p( a, b, x, err ) +double a, b, x; +double *err; +{ +double n, a0, sum, t, u, temp; +double an, bn, maxt, pcanc; + + +/* set up for power series summation */ +an = a; +bn = b; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +maxt = 0.0; + + +while( t > MACHEP ) + { + if( bn == 0 ) /* check bn first since if both */ + { + mtherr( "hyperg", SING ); + return( MAXNUM ); /* an and bn are zero it is */ + } + if( an == 0 ) /* a singularity */ + return( sum ); + if( n > 200 ) + goto pdone; + u = x * ( an / (bn * n) ); + + /* check for blowup */ + temp = fabs(u); + if( (temp > 1.0 ) && (maxt > (MAXNUM/temp)) ) + { + pcanc = 1.0; /* estimate 100% error */ + goto blowup; + } + + a0 *= u; + sum += a0; + t = fabs(a0); + if( t > maxt ) + maxt = t; +/* + if( (maxt/fabs(sum)) > 1.0e17 ) + { + pcanc = 1.0; + goto blowup; + } +*/ + an += 1.0; + bn += 1.0; + n += 1.0; + } + +pdone: + +/* estimate error due to roundoff and cancellation */ +if( sum != 0.0 ) + maxt /= fabs(sum); +maxt *= MACHEP; /* this way avoids multiply overflow */ +pcanc = fabs( MACHEP * n + maxt ); + +blowup: + +*err = pcanc; + +return( sum ); +} + + +/* hy1f1a() */ +/* asymptotic formula for hypergeometric function: + * + * ( -a + * -- ( |z| + * | (b) ( -------- 2f0( a, 1+a-b, -1/x ) + * ( -- + * ( | (b-a) + * + * + * x a-b ) + * e |x| ) + * + -------- 2f0( b-a, 1-a, 1/x ) ) + * -- ) + * | (a) ) + */ + +static double hy1f1a( a, b, x, err ) +double a, b, x; +double *err; +{ +double h1, h2, t, u, temp, acanc, asum, err1, err2; + +if( x == 0 ) + { + acanc = 1.0; + asum = MAXNUM; + goto adone; + } +temp = log( fabs(x) ); +t = x + temp * (a-b); +u = -temp * a; + +if( b > 0 ) + { + temp = lgam(b); + t += temp; + u += temp; + } + +h1 = hyp2f0( a, a-b+1, -1.0/x, 1, &err1 ); + +temp = exp(u) / gamma(b-a); +h1 *= temp; +err1 *= temp; + +h2 = hyp2f0( b-a, 1.0-a, 1.0/x, 2, &err2 ); + +if( a < 0 ) + temp = exp(t) / gamma(a); +else + temp = exp( t - lgam(a) ); + +h2 *= temp; +err2 *= temp; + +if( x < 0.0 ) + asum = h1; +else + asum = h2; + +acanc = fabs(err1) + fabs(err2); + + +if( b < 0 ) + { + temp = gamma(b); + asum *= temp; + acanc *= fabs(temp); + } + + +if( asum != 0.0 ) + acanc /= fabs(asum); + +acanc *= 30.0; /* fudge factor, since error of asymptotic formula + * often seems this much larger than advertised */ + +adone: + + +*err = acanc; +return( asum ); +} + +/* hyp2f0() */ + +double hyp2f0( a, b, x, type, err ) +double a, b, x; +int type; /* determines what converging factor to use */ +double *err; +{ +double a0, alast, t, tlast, maxt; +double n, an, bn, u, sum, temp; + +an = a; +bn = b; +a0 = 1.0e0; +alast = 1.0e0; +sum = 0.0; +n = 1.0e0; +t = 1.0e0; +tlast = 1.0e9; +maxt = 0.0; + +do + { + if( an == 0 ) + goto pdone; + if( bn == 0 ) + goto pdone; + + u = an * (bn * x / n); + + /* check for blowup */ + temp = fabs(u); + if( (temp > 1.0 ) && (maxt > (MAXNUM/temp)) ) + goto error; + + a0 *= u; + t = fabs(a0); + + /* terminating condition for asymptotic series */ + if( t > tlast ) + goto ndone; + + tlast = t; + sum += alast; /* the sum is one term behind */ + alast = a0; + + if( n > 200 ) + goto ndone; + + an += 1.0e0; + bn += 1.0e0; + n += 1.0e0; + if( t > maxt ) + maxt = t; + } +while( t > MACHEP ); + + +pdone: /* series converged! */ + +/* estimate error due to roundoff and cancellation */ +*err = fabs( MACHEP * (n + maxt) ); + +alast = a0; +goto done; + +ndone: /* series did not converge */ + +/* The following "Converging factors" are supposed to improve accuracy, + * but do not actually seem to accomplish very much. */ + +n -= 1.0; +x = 1.0/x; + +switch( type ) /* "type" given as subroutine argument */ +{ +case 1: + alast *= ( 0.5 + (0.125 + 0.25*b - 0.5*a + 0.25*x - 0.25*n)/x ); + break; + +case 2: + alast *= 2.0/3.0 - b + 2.0*a + x - n; + break; + +default: + ; +} + +/* estimate error due to roundoff, cancellation, and nonconvergence */ +*err = MACHEP * (n + maxt) + fabs ( a0 ); + + +done: +sum += alast; +return( sum ); + +/* series blew up: */ +error: +*err = MAXNUM; +mtherr( "hyperg", TLOSS ); +return( sum ); +} diff --git a/libm/double/i0.c b/libm/double/i0.c new file mode 100644 index 000000000..a4844ab7e --- /dev/null +++ b/libm/double/i0.c @@ -0,0 +1,397 @@ +/* i0.c + * + * Modified Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * double x, y, i0(); + * + * y = i0( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order zero of the + * argument. + * + * The function is defined as i0(x) = j0( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 6000 8.2e-17 1.9e-17 + * IEEE 0,30 30000 5.8e-16 1.4e-16 + * + */ + /* i0e.c + * + * Modified Bessel function of order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, i0e(); + * + * y = i0e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order zero of the argument. + * + * The function is defined as i0e(x) = exp(-|x|) j0( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 30000 5.4e-16 1.2e-16 + * See i0(). + * + */ + +/* i0.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Chebyshev coefficients for exp(-x) I0(x) + * in the interval [0,8]. + * + * lim(x->0){ exp(-x) I0(x) } = 1. + */ + +#ifdef UNK +static double A[] = +{ +-4.41534164647933937950E-18, + 3.33079451882223809783E-17, +-2.43127984654795469359E-16, + 1.71539128555513303061E-15, +-1.16853328779934516808E-14, + 7.67618549860493561688E-14, +-4.85644678311192946090E-13, + 2.95505266312963983461E-12, +-1.72682629144155570723E-11, + 9.67580903537323691224E-11, +-5.18979560163526290666E-10, + 2.65982372468238665035E-9, +-1.30002500998624804212E-8, + 6.04699502254191894932E-8, +-2.67079385394061173391E-7, + 1.11738753912010371815E-6, +-4.41673835845875056359E-6, + 1.64484480707288970893E-5, +-5.75419501008210370398E-5, + 1.88502885095841655729E-4, +-5.76375574538582365885E-4, + 1.63947561694133579842E-3, +-4.32430999505057594430E-3, + 1.05464603945949983183E-2, +-2.37374148058994688156E-2, + 4.93052842396707084878E-2, +-9.49010970480476444210E-2, + 1.71620901522208775349E-1, +-3.04682672343198398683E-1, + 6.76795274409476084995E-1 +}; +#endif + +#ifdef DEC +static unsigned short A[] = { +0121642,0162671,0004646,0103567, +0022431,0115424,0135755,0026104, +0123214,0023533,0110365,0156635, +0023767,0033304,0117662,0172716, +0124522,0100426,0012277,0157531, +0025254,0155062,0054461,0030465, +0126010,0131143,0013560,0153604, +0026517,0170577,0006336,0114437, +0127227,0162253,0152243,0052734, +0027724,0142766,0061641,0160200, +0130416,0123760,0116564,0125262, +0031066,0144035,0021246,0054641, +0131537,0053664,0060131,0102530, +0032201,0155664,0165153,0020652, +0132617,0061434,0074423,0176145, +0033225,0174444,0136147,0122542, +0133624,0031576,0056453,0020470, +0034211,0175305,0172321,0041314, +0134561,0054462,0147040,0165315, +0035105,0124333,0120203,0162532, +0135427,0013750,0174257,0055221, +0035726,0161654,0050220,0100162, +0136215,0131361,0000325,0041110, +0036454,0145417,0117357,0017352, +0136702,0072367,0104415,0133574, +0037111,0172126,0072505,0014544, +0137302,0055601,0120550,0033523, +0037457,0136543,0136544,0043002, +0137633,0177536,0001276,0066150, +0040055,0041164,0100655,0010521 +}; +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0xd0ef,0x2134,0x5cb7,0xbc54, +0xa589,0x977d,0x3362,0x3c83, +0xbbb4,0x721e,0x84eb,0xbcb1, +0x5eba,0x93f6,0xe6d8,0x3cde, +0xfbeb,0xc297,0x5022,0xbd0a, +0x2627,0x4b26,0x9b46,0x3d35, +0x1af0,0x62ee,0x164c,0xbd61, +0xd324,0xe19b,0xfe2f,0x3d89, +0x6abc,0x7a94,0xfc95,0xbdb2, +0x3c10,0xcc74,0x98be,0x3dda, +0x9556,0x13ae,0xd4fe,0xbe01, +0xcb34,0xa454,0xd903,0x3e26, +0x30ab,0x8c0b,0xeaf6,0xbe4b, +0x6435,0x9d4d,0x3b76,0x3e70, +0x7f8d,0x8f22,0xec63,0xbe91, +0xf4ac,0x978c,0xbf24,0x3eb2, +0x6427,0xcba5,0x866f,0xbed2, +0x2859,0xbe9a,0x3f58,0x3ef1, +0x1d5a,0x59c4,0x2b26,0xbf0e, +0x7cab,0x7410,0xb51b,0x3f28, +0xeb52,0x1f15,0xe2fd,0xbf42, +0x100e,0x8a12,0xdc75,0x3f5a, +0xa849,0x201a,0xb65e,0xbf71, +0xe3dd,0xf3dd,0x9961,0x3f85, +0xb6f0,0xf121,0x4e9e,0xbf98, +0xa32d,0xcea8,0x3e8a,0x3fa9, +0x06ea,0x342d,0x4b70,0xbfb8, +0x88c0,0x77ac,0xf7ac,0x3fc5, +0xcd8d,0xc057,0x7feb,0xbfd3, +0xa22a,0x9035,0xa84e,0x3fe5, +}; +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0xbc54,0x5cb7,0x2134,0xd0ef, +0x3c83,0x3362,0x977d,0xa589, +0xbcb1,0x84eb,0x721e,0xbbb4, +0x3cde,0xe6d8,0x93f6,0x5eba, +0xbd0a,0x5022,0xc297,0xfbeb, +0x3d35,0x9b46,0x4b26,0x2627, +0xbd61,0x164c,0x62ee,0x1af0, +0x3d89,0xfe2f,0xe19b,0xd324, +0xbdb2,0xfc95,0x7a94,0x6abc, +0x3dda,0x98be,0xcc74,0x3c10, +0xbe01,0xd4fe,0x13ae,0x9556, +0x3e26,0xd903,0xa454,0xcb34, +0xbe4b,0xeaf6,0x8c0b,0x30ab, +0x3e70,0x3b76,0x9d4d,0x6435, +0xbe91,0xec63,0x8f22,0x7f8d, +0x3eb2,0xbf24,0x978c,0xf4ac, +0xbed2,0x866f,0xcba5,0x6427, +0x3ef1,0x3f58,0xbe9a,0x2859, +0xbf0e,0x2b26,0x59c4,0x1d5a, +0x3f28,0xb51b,0x7410,0x7cab, +0xbf42,0xe2fd,0x1f15,0xeb52, +0x3f5a,0xdc75,0x8a12,0x100e, +0xbf71,0xb65e,0x201a,0xa849, +0x3f85,0x9961,0xf3dd,0xe3dd, +0xbf98,0x4e9e,0xf121,0xb6f0, +0x3fa9,0x3e8a,0xcea8,0xa32d, +0xbfb8,0x4b70,0x342d,0x06ea, +0x3fc5,0xf7ac,0x77ac,0x88c0, +0xbfd3,0x7feb,0xc057,0xcd8d, +0x3fe5,0xa84e,0x9035,0xa22a +}; +#endif + + +/* Chebyshev coefficients for exp(-x) sqrt(x) I0(x) + * in the inverted interval [8,infinity]. + * + * lim(x->inf){ exp(-x) sqrt(x) I0(x) } = 1/sqrt(2pi). + */ + +#ifdef UNK +static double B[] = +{ +-7.23318048787475395456E-18, +-4.83050448594418207126E-18, + 4.46562142029675999901E-17, + 3.46122286769746109310E-17, +-2.82762398051658348494E-16, +-3.42548561967721913462E-16, + 1.77256013305652638360E-15, + 3.81168066935262242075E-15, +-9.55484669882830764870E-15, +-4.15056934728722208663E-14, + 1.54008621752140982691E-14, + 3.85277838274214270114E-13, + 7.18012445138366623367E-13, +-1.79417853150680611778E-12, +-1.32158118404477131188E-11, +-3.14991652796324136454E-11, + 1.18891471078464383424E-11, + 4.94060238822496958910E-10, + 3.39623202570838634515E-9, + 2.26666899049817806459E-8, + 2.04891858946906374183E-7, + 2.89137052083475648297E-6, + 6.88975834691682398426E-5, + 3.36911647825569408990E-3, + 8.04490411014108831608E-1 +}; +#endif + +#ifdef DEC +static unsigned short B[] = { +0122005,0066672,0123124,0054311, +0121662,0033323,0030214,0104602, +0022515,0170300,0113314,0020413, +0022437,0117350,0035402,0007146, +0123243,0000135,0057220,0177435, +0123305,0073476,0144106,0170702, +0023777,0071755,0017527,0154373, +0024211,0052214,0102247,0033270, +0124454,0017763,0171453,0012322, +0125072,0166316,0075505,0154616, +0024612,0133770,0065376,0025045, +0025730,0162143,0056036,0001632, +0026112,0015077,0150464,0063542, +0126374,0101030,0014274,0065457, +0127150,0077271,0125763,0157617, +0127412,0104350,0040713,0120445, +0027121,0023765,0057500,0001165, +0030407,0147146,0003643,0075644, +0031151,0061445,0044422,0156065, +0031702,0132224,0003266,0125551, +0032534,0000076,0147153,0005555, +0033502,0004536,0004016,0026055, +0034620,0076433,0142314,0171215, +0036134,0146145,0013454,0101104, +0040115,0171425,0062500,0047133 +}; +#endif + +#ifdef IBMPC +static unsigned short B[] = { +0x8b19,0x54ca,0xadb7,0xbc60, +0x9130,0x6611,0x46da,0xbc56, +0x8421,0x12d9,0xbe18,0x3c89, +0x41cd,0x0760,0xf3dd,0x3c83, +0x1fe4,0xabd2,0x600b,0xbcb4, +0xde38,0xd908,0xaee7,0xbcb8, +0xfb1f,0xa3ea,0xee7d,0x3cdf, +0xe6d7,0x9094,0x2a91,0x3cf1, +0x629a,0x7e65,0x83fe,0xbd05, +0xbb32,0xcf68,0x5d99,0xbd27, +0xc545,0x0d5f,0x56ff,0x3d11, +0xc073,0x6b83,0x1c8c,0x3d5b, +0x8cec,0xfa26,0x4347,0x3d69, +0x8d66,0x0317,0x9043,0xbd7f, +0x7bf2,0x357e,0x0fd7,0xbdad, +0x7425,0x0839,0x511d,0xbdc1, +0x004f,0xabe8,0x24fe,0x3daa, +0x6f75,0xc0f4,0xf9cc,0x3e00, +0x5b87,0xa922,0x2c64,0x3e2d, +0xd56d,0x80d6,0x5692,0x3e58, +0x616e,0xd9cd,0x8007,0x3e8b, +0xc586,0xc101,0x412b,0x3ec8, +0x9e52,0x7899,0x0fa3,0x3f12, +0x9049,0xa2e5,0x998c,0x3f6b, +0x09cb,0xaca8,0xbe62,0x3fe9 +}; +#endif + +#ifdef MIEEE +static unsigned short B[] = { +0xbc60,0xadb7,0x54ca,0x8b19, +0xbc56,0x46da,0x6611,0x9130, +0x3c89,0xbe18,0x12d9,0x8421, +0x3c83,0xf3dd,0x0760,0x41cd, +0xbcb4,0x600b,0xabd2,0x1fe4, +0xbcb8,0xaee7,0xd908,0xde38, +0x3cdf,0xee7d,0xa3ea,0xfb1f, +0x3cf1,0x2a91,0x9094,0xe6d7, +0xbd05,0x83fe,0x7e65,0x629a, +0xbd27,0x5d99,0xcf68,0xbb32, +0x3d11,0x56ff,0x0d5f,0xc545, +0x3d5b,0x1c8c,0x6b83,0xc073, +0x3d69,0x4347,0xfa26,0x8cec, +0xbd7f,0x9043,0x0317,0x8d66, +0xbdad,0x0fd7,0x357e,0x7bf2, +0xbdc1,0x511d,0x0839,0x7425, +0x3daa,0x24fe,0xabe8,0x004f, +0x3e00,0xf9cc,0xc0f4,0x6f75, +0x3e2d,0x2c64,0xa922,0x5b87, +0x3e58,0x5692,0x80d6,0xd56d, +0x3e8b,0x8007,0xd9cd,0x616e, +0x3ec8,0x412b,0xc101,0xc586, +0x3f12,0x0fa3,0x7899,0x9e52, +0x3f6b,0x998c,0xa2e5,0x9049, +0x3fe9,0xbe62,0xaca8,0x09cb +}; +#endif + +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double exp ( double ); +extern double sqrt ( double ); +#else +double chbevl(), exp(), sqrt(); +#endif + +double i0(x) +double x; +{ +double y; + +if( x < 0 ) + x = -x; +if( x <= 8.0 ) + { + y = (x/2.0) - 2.0; + return( exp(x) * chbevl( y, A, 30 ) ); + } + +return( exp(x) * chbevl( 32.0/x - 2.0, B, 25 ) / sqrt(x) ); + +} + + + + +double i0e( x ) +double x; +{ +double y; + +if( x < 0 ) + x = -x; +if( x <= 8.0 ) + { + y = (x/2.0) - 2.0; + return( chbevl( y, A, 30 ) ); + } + +return( chbevl( 32.0/x - 2.0, B, 25 ) / sqrt(x) ); + +} diff --git a/libm/double/i1.c b/libm/double/i1.c new file mode 100644 index 000000000..dfde216dc --- /dev/null +++ b/libm/double/i1.c @@ -0,0 +1,402 @@ +/* i1.c + * + * Modified Bessel function of order one + * + * + * + * SYNOPSIS: + * + * double x, y, i1(); + * + * y = i1( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order one of the + * argument. + * + * The function is defined as i1(x) = -i j1( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3400 1.2e-16 2.3e-17 + * IEEE 0, 30 30000 1.9e-15 2.1e-16 + * + * + */ + /* i1e.c + * + * Modified Bessel function of order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, i1e(); + * + * y = i1e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order one of the argument. + * + * The function is defined as i1(x) = -i exp(-|x|) j1( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 2.0e-15 2.0e-16 + * See i1(). + * + */ + +/* i1.c 2 */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Chebyshev coefficients for exp(-x) I1(x) / x + * in the interval [0,8]. + * + * lim(x->0){ exp(-x) I1(x) / x } = 1/2. + */ + +#ifdef UNK +static double A[] = +{ + 2.77791411276104639959E-18, +-2.11142121435816608115E-17, + 1.55363195773620046921E-16, +-1.10559694773538630805E-15, + 7.60068429473540693410E-15, +-5.04218550472791168711E-14, + 3.22379336594557470981E-13, +-1.98397439776494371520E-12, + 1.17361862988909016308E-11, +-6.66348972350202774223E-11, + 3.62559028155211703701E-10, +-1.88724975172282928790E-9, + 9.38153738649577178388E-9, +-4.44505912879632808065E-8, + 2.00329475355213526229E-7, +-8.56872026469545474066E-7, + 3.47025130813767847674E-6, +-1.32731636560394358279E-5, + 4.78156510755005422638E-5, +-1.61760815825896745588E-4, + 5.12285956168575772895E-4, +-1.51357245063125314899E-3, + 4.15642294431288815669E-3, +-1.05640848946261981558E-2, + 2.47264490306265168283E-2, +-5.29459812080949914269E-2, + 1.02643658689847095384E-1, +-1.76416518357834055153E-1, + 2.52587186443633654823E-1 +}; +#endif + +#ifdef DEC +static unsigned short A[] = { +0021514,0174520,0060742,0000241, +0122302,0137206,0016120,0025663, +0023063,0017437,0026235,0176536, +0123637,0052523,0170150,0125632, +0024410,0165770,0030251,0044134, +0125143,0012160,0162170,0054727, +0025665,0075702,0035716,0145247, +0126413,0116032,0176670,0015462, +0027116,0073425,0110351,0105242, +0127622,0104034,0137530,0037364, +0030307,0050645,0120776,0175535, +0131001,0130331,0043523,0037455, +0031441,0026160,0010712,0100174, +0132076,0164761,0022706,0017500, +0032527,0015045,0115076,0104076, +0133146,0001714,0015434,0144520, +0033550,0161166,0124215,0077050, +0134136,0127715,0143365,0157170, +0034510,0106652,0013070,0064130, +0135051,0117126,0117264,0123761, +0035406,0045355,0133066,0175751, +0135706,0061420,0054746,0122440, +0036210,0031232,0047235,0006640, +0136455,0012373,0144235,0011523, +0036712,0107437,0036731,0015111, +0137130,0156742,0115744,0172743, +0037322,0033326,0124667,0124740, +0137464,0123210,0021510,0144556, +0037601,0051433,0111123,0177721 +}; +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0x4014,0x0c3c,0x9f2a,0x3c49, +0x0576,0xc38a,0x57d0,0xbc78, +0xbfac,0xe593,0x63e3,0x3ca6, +0x1573,0x7e0d,0xeaaa,0xbcd3, +0x290c,0x0615,0x1d7f,0x3d01, +0x0b3b,0x1c8f,0x628e,0xbd2c, +0xd955,0x4779,0xaf78,0x3d56, +0x0366,0x5fb7,0x7383,0xbd81, +0x3154,0xb21d,0xcee2,0x3da9, +0x07de,0x97eb,0x5103,0xbdd2, +0xdf6c,0xb43f,0xea34,0x3df8, +0x67e6,0x28ea,0x361b,0xbe20, +0x5010,0x0239,0x258e,0x3e44, +0xc3e8,0x24b8,0xdd3e,0xbe67, +0xd108,0xb347,0xe344,0x3e8a, +0x992a,0x8363,0xc079,0xbeac, +0xafc5,0xd511,0x1c4e,0x3ecd, +0xbbcf,0xb8de,0xd5f9,0xbeeb, +0x0d0b,0x42c7,0x11b5,0x3f09, +0x94fe,0xd3d6,0x33ca,0xbf25, +0xdf7d,0xb6c6,0xc95d,0x3f40, +0xd4a4,0x0b3c,0xcc62,0xbf58, +0xa1b4,0x49d3,0x0653,0x3f71, +0xa26a,0x7913,0xa29f,0xbf85, +0x2349,0xe7bb,0x51e3,0x3f99, +0x9ebc,0x537c,0x1bbc,0xbfab, +0xf53c,0xd536,0x46da,0x3fba, +0x192e,0x0469,0x94d1,0xbfc6, +0x7ffa,0x724a,0x2a63,0x3fd0 +}; +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0x3c49,0x9f2a,0x0c3c,0x4014, +0xbc78,0x57d0,0xc38a,0x0576, +0x3ca6,0x63e3,0xe593,0xbfac, +0xbcd3,0xeaaa,0x7e0d,0x1573, +0x3d01,0x1d7f,0x0615,0x290c, +0xbd2c,0x628e,0x1c8f,0x0b3b, +0x3d56,0xaf78,0x4779,0xd955, +0xbd81,0x7383,0x5fb7,0x0366, +0x3da9,0xcee2,0xb21d,0x3154, +0xbdd2,0x5103,0x97eb,0x07de, +0x3df8,0xea34,0xb43f,0xdf6c, +0xbe20,0x361b,0x28ea,0x67e6, +0x3e44,0x258e,0x0239,0x5010, +0xbe67,0xdd3e,0x24b8,0xc3e8, +0x3e8a,0xe344,0xb347,0xd108, +0xbeac,0xc079,0x8363,0x992a, +0x3ecd,0x1c4e,0xd511,0xafc5, +0xbeeb,0xd5f9,0xb8de,0xbbcf, +0x3f09,0x11b5,0x42c7,0x0d0b, +0xbf25,0x33ca,0xd3d6,0x94fe, +0x3f40,0xc95d,0xb6c6,0xdf7d, +0xbf58,0xcc62,0x0b3c,0xd4a4, +0x3f71,0x0653,0x49d3,0xa1b4, +0xbf85,0xa29f,0x7913,0xa26a, +0x3f99,0x51e3,0xe7bb,0x2349, +0xbfab,0x1bbc,0x537c,0x9ebc, +0x3fba,0x46da,0xd536,0xf53c, +0xbfc6,0x94d1,0x0469,0x192e, +0x3fd0,0x2a63,0x724a,0x7ffa +}; +#endif + +/* i1.c */ + +/* Chebyshev coefficients for exp(-x) sqrt(x) I1(x) + * in the inverted interval [8,infinity]. + * + * lim(x->inf){ exp(-x) sqrt(x) I1(x) } = 1/sqrt(2pi). + */ + +#ifdef UNK +static double B[] = +{ + 7.51729631084210481353E-18, + 4.41434832307170791151E-18, +-4.65030536848935832153E-17, +-3.20952592199342395980E-17, + 2.96262899764595013876E-16, + 3.30820231092092828324E-16, +-1.88035477551078244854E-15, +-3.81440307243700780478E-15, + 1.04202769841288027642E-14, + 4.27244001671195135429E-14, +-2.10154184277266431302E-14, +-4.08355111109219731823E-13, +-7.19855177624590851209E-13, + 2.03562854414708950722E-12, + 1.41258074366137813316E-11, + 3.25260358301548823856E-11, +-1.89749581235054123450E-11, +-5.58974346219658380687E-10, +-3.83538038596423702205E-9, +-2.63146884688951950684E-8, +-2.51223623787020892529E-7, +-3.88256480887769039346E-6, +-1.10588938762623716291E-4, +-9.76109749136146840777E-3, + 7.78576235018280120474E-1 +}; +#endif + +#ifdef DEC +static unsigned short B[] = { +0022012,0125555,0115227,0043456, +0021642,0156127,0052075,0145203, +0122526,0072435,0111231,0011664, +0122424,0001544,0161671,0114403, +0023252,0144257,0163532,0142121, +0023276,0132162,0174045,0013204, +0124007,0077154,0057046,0110517, +0124211,0066650,0116127,0157073, +0024473,0133413,0130551,0107504, +0025100,0064741,0032631,0040364, +0124675,0045101,0071551,0012400, +0125745,0161054,0071637,0011247, +0126112,0117410,0035525,0122231, +0026417,0037237,0131034,0176427, +0027170,0100373,0024742,0025725, +0027417,0006417,0105303,0141446, +0127246,0163716,0121202,0060137, +0130431,0123122,0120436,0166000, +0131203,0144134,0153251,0124500, +0131742,0005234,0122732,0033006, +0132606,0157751,0072362,0121031, +0133602,0043372,0047120,0015626, +0134747,0165774,0001125,0046462, +0136437,0166402,0117746,0155137, +0040107,0050305,0125330,0124241 +}; +#endif + +#ifdef IBMPC +static unsigned short B[] = { +0xe8e6,0xb352,0x556d,0x3c61, +0xb950,0xea87,0x5b8a,0x3c54, +0x2277,0xb253,0xcea3,0xbc8a, +0x3320,0x9c77,0x806c,0xbc82, +0x588a,0xfceb,0x5915,0x3cb5, +0xa2d1,0x5f04,0xd68e,0x3cb7, +0xd22a,0x8bc4,0xefcd,0xbce0, +0xfbc7,0x138a,0x2db5,0xbcf1, +0x31e8,0x762d,0x76e1,0x3d07, +0x281e,0x26b3,0x0d3c,0x3d28, +0x22a0,0x2e6d,0xa948,0xbd17, +0xe255,0x8e73,0xbc45,0xbd5c, +0xb493,0x076a,0x53e1,0xbd69, +0x9fa3,0xf643,0xe7d3,0x3d81, +0x457b,0x653c,0x101f,0x3daf, +0x7865,0xf158,0xe1a1,0x3dc1, +0x4c0c,0xd450,0xdcf9,0xbdb4, +0xdd80,0x5423,0x34ca,0xbe03, +0x3528,0x9ad5,0x790b,0xbe30, +0x46c1,0x94bb,0x4153,0xbe5c, +0x5443,0x2e9e,0xdbfd,0xbe90, +0x0373,0x49ca,0x48df,0xbed0, +0xa9a6,0x804a,0xfd7f,0xbf1c, +0xdb4c,0x53fc,0xfda0,0xbf83, +0x1514,0xb55b,0xea18,0x3fe8 +}; +#endif + +#ifdef MIEEE +static unsigned short B[] = { +0x3c61,0x556d,0xb352,0xe8e6, +0x3c54,0x5b8a,0xea87,0xb950, +0xbc8a,0xcea3,0xb253,0x2277, +0xbc82,0x806c,0x9c77,0x3320, +0x3cb5,0x5915,0xfceb,0x588a, +0x3cb7,0xd68e,0x5f04,0xa2d1, +0xbce0,0xefcd,0x8bc4,0xd22a, +0xbcf1,0x2db5,0x138a,0xfbc7, +0x3d07,0x76e1,0x762d,0x31e8, +0x3d28,0x0d3c,0x26b3,0x281e, +0xbd17,0xa948,0x2e6d,0x22a0, +0xbd5c,0xbc45,0x8e73,0xe255, +0xbd69,0x53e1,0x076a,0xb493, +0x3d81,0xe7d3,0xf643,0x9fa3, +0x3daf,0x101f,0x653c,0x457b, +0x3dc1,0xe1a1,0xf158,0x7865, +0xbdb4,0xdcf9,0xd450,0x4c0c, +0xbe03,0x34ca,0x5423,0xdd80, +0xbe30,0x790b,0x9ad5,0x3528, +0xbe5c,0x4153,0x94bb,0x46c1, +0xbe90,0xdbfd,0x2e9e,0x5443, +0xbed0,0x48df,0x49ca,0x0373, +0xbf1c,0xfd7f,0x804a,0xa9a6, +0xbf83,0xfda0,0x53fc,0xdb4c, +0x3fe8,0xea18,0xb55b,0x1514 +}; +#endif + +/* i1.c */ +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double exp ( double ); +extern double sqrt ( double ); +extern double fabs ( double ); +#else +double chbevl(), exp(), sqrt(), fabs(); +#endif + +double i1(x) +double x; +{ +double y, z; + +z = fabs(x); +if( z <= 8.0 ) + { + y = (z/2.0) - 2.0; + z = chbevl( y, A, 29 ) * z * exp(z); + } +else + { + z = exp(z) * chbevl( 32.0/z - 2.0, B, 25 ) / sqrt(z); + } +if( x < 0.0 ) + z = -z; +return( z ); +} + +/* i1e() */ + +double i1e( x ) +double x; +{ +double y, z; + +z = fabs(x); +if( z <= 8.0 ) + { + y = (z/2.0) - 2.0; + z = chbevl( y, A, 29 ) * z; + } +else + { + z = chbevl( 32.0/z - 2.0, B, 25 ) / sqrt(z); + } +if( x < 0.0 ) + z = -z; +return( z ); +} diff --git a/libm/double/igam.c b/libm/double/igam.c new file mode 100644 index 000000000..a1d0bab36 --- /dev/null +++ b/libm/double/igam.c @@ -0,0 +1,210 @@ +/* igam.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, y, igam(); + * + * y = igam( 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 + * IEEE 0,30 200000 3.6e-14 2.9e-15 + * IEEE 0,100 300000 9.9e-14 1.5e-14 + */ + /* igamc() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, y, igamc(); + * + * y = igamc( 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: + * + * Tested at random a, x. + * a x Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0.5,100 0,100 200000 1.9e-14 1.7e-15 + * IEEE 0.01,0.5 0,100 200000 1.4e-13 1.6e-15 + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double lgam ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double fabs ( double ); +extern double igam ( double, double ); +extern double igamc ( double, double ); +#else +double lgam(), exp(), log(), fabs(), igam(), igamc(); +#endif + +extern double MACHEP, MAXLOG; +static double big = 4.503599627370496e15; +static double biginv = 2.22044604925031308085e-16; + +double igamc( a, x ) +double a, x; +{ +double ans, ax, c, yc, r, t, y, z; +double pk, pkm1, pkm2, qk, qkm1, qkm2; + +if( (x <= 0) || ( a <= 0) ) + return( 1.0 ); + +if( (x < 1.0) || (x < a) ) + return( 1.0 - igam(a,x) ); + +ax = a * log(x) - x - lgam(a); +if( ax < -MAXLOG ) + { + mtherr( "igamc", UNDERFLOW ); + return( 0.0 ); + } +ax = exp(ax); + +/* continued fraction */ +y = 1.0 - a; +z = x + y + 1.0; +c = 0.0; +pkm2 = 1.0; +qkm2 = x; +pkm1 = x + 1.0; +qkm1 = z * x; +ans = pkm1/qkm1; + +do + { + c += 1.0; + y += 1.0; + z += 2.0; + yc = y * c; + pk = pkm1 * z - pkm2 * yc; + qk = qkm1 * z - qkm2 * yc; + if( qk != 0 ) + { + r = pk/qk; + t = fabs( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + if( fabs(pk) > big ) + { + pkm2 *= biginv; + pkm1 *= biginv; + qkm2 *= biginv; + qkm1 *= biginv; + } + } +while( t > MACHEP ); + +return( ans * ax ); +} + + + +/* left tail of incomplete gamma function: + * + * inf. k + * a -x - x + * x e > ---------- + * - - + * k=0 | (a+k+1) + * + */ + +double igam( a, x ) +double a, x; +{ +double ans, ax, c, r; + +if( (x <= 0) || ( a <= 0) ) + return( 0.0 ); + +if( (x > 1.0) && (x > a ) ) + return( 1.0 - igamc(a,x) ); + +/* Compute x**a * exp(-x) / gamma(a) */ +ax = a * log(x) - x - lgam(a); +if( ax < -MAXLOG ) + { + mtherr( "igam", UNDERFLOW ); + return( 0.0 ); + } +ax = exp(ax); + +/* power series */ +r = a; +c = 1.0; +ans = 1.0; + +do + { + r += 1.0; + c *= x/r; + ans += c; + } +while( c/ans > MACHEP ); + +return( ans * ax/a ); +} diff --git a/libm/double/igami.c b/libm/double/igami.c new file mode 100644 index 000000000..e93ba2a14 --- /dev/null +++ b/libm/double/igami.c @@ -0,0 +1,187 @@ +/* igami() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * double a, x, p, igami(); + * + * x = igami( a, p ); + * + * DESCRIPTION: + * + * Given p, the function finds x such that + * + * igamc( a, x ) = p. + * + * Starting with the approximate value + * + * 3 + * x = a t + * + * where + * + * t = 1 - d - ndtri(p) sqrt(d) + * + * and + * + * d = 1/9a, + * + * the routine performs up to 10 Newton iterations to find the + * root of igamc(a,x) - p = 0. + * + * ACCURACY: + * + * Tested at random a, p in the intervals indicated. + * + * a p Relative error: + * arithmetic domain domain # trials peak rms + * IEEE 0.5,100 0,0.5 100000 1.0e-14 1.7e-15 + * IEEE 0.01,0.5 0,0.5 100000 9.0e-14 3.4e-15 + * IEEE 0.5,10000 0,0.5 20000 2.3e-13 3.8e-14 + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +extern double MACHEP, MAXNUM, MAXLOG, MINLOG; +#ifdef ANSIPROT +extern double igamc ( double, double ); +extern double ndtri ( double ); +extern double exp ( double ); +extern double fabs ( double ); +extern double log ( double ); +extern double sqrt ( double ); +extern double lgam ( double ); +#else +double igamc(), ndtri(), exp(), fabs(), log(), sqrt(), lgam(); +#endif + +double igami( a, y0 ) +double a, y0; +{ +double x0, x1, x, yl, yh, y, d, lgm, dithresh; +int i, dir; + +/* bound the solution */ +x0 = MAXNUM; +yl = 0; +x1 = 0; +yh = 1.0; +dithresh = 5.0 * MACHEP; + +/* approximation to inverse function */ +d = 1.0/(9.0*a); +y = ( 1.0 - d - ndtri(y0) * sqrt(d) ); +x = a * y * y * y; + +lgm = lgam(a); + +for( i=0; i<10; i++ ) + { + if( x > x0 || x < x1 ) + goto ihalve; + y = igamc(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.0) * log(x) - x - lgm; + if( d < -MAXLOG ) + goto ihalve; + d = -exp(d); +/* compute the step to the next approximation of x */ + d = (y - y0)/d; + if( fabs(d/x) < MACHEP ) + goto done; + x = x - d; + } + +/* Resort to interval halving if Newton iteration did not converge. */ +ihalve: + +d = 0.0625; +if( x0 == MAXNUM ) + { + if( x <= 0.0 ) + x = 1.0; + while( x0 == MAXNUM ) + { + x = (1.0 + d) * x; + y = igamc( a, x ); + if( y < y0 ) + { + x0 = x; + yl = y; + break; + } + d = d + d; + } + } +d = 0.5; +dir = 0; + +for( i=0; i<400; i++ ) + { + x = x1 + d * (x0 - x1); + y = igamc( a, x ); + lgm = (x0 - x1)/(x1 + x0); + if( fabs(lgm) < dithresh ) + break; + lgm = (y - y0)/y0; + if( fabs(lgm) < dithresh ) + break; + if( x <= 0.0 ) + break; + if( y >= y0 ) + { + x1 = x; + yh = y; + if( dir < 0 ) + { + dir = 0; + d = 0.5; + } + else if( dir > 1 ) + d = 0.5 * d + 0.5; + else + d = (y0 - yl)/(yh - yl); + dir += 1; + } + else + { + x0 = x; + yl = y; + if( dir > 0 ) + { + dir = 0; + d = 0.5; + } + else if( dir < -1 ) + d = 0.5 * d; + else + d = (y0 - yl)/(yh - yl); + dir -= 1; + } + } +if( x == 0.0 ) + mtherr( "igami", UNDERFLOW ); + +done: +return( x ); +} diff --git a/libm/double/incbet.c b/libm/double/incbet.c new file mode 100644 index 000000000..ec236747d --- /dev/null +++ b/libm/double/incbet.c @@ -0,0 +1,409 @@ +/* incbet.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * double a, b, x, y, incbet(); + * + * y = incbet( 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 uniformly distributed random points (a,b,x) with a and b + * in "domain" and x between 0 and 1. + * Relative error + * arithmetic domain # trials peak rms + * IEEE 0,5 10000 6.9e-15 4.5e-16 + * IEEE 0,85 250000 2.2e-13 1.7e-14 + * IEEE 0,1000 30000 5.3e-12 6.3e-13 + * IEEE 0,10000 250000 9.3e-11 7.1e-12 + * IEEE 0,100000 10000 8.7e-10 4.8e-11 + * Outputs smaller than the IEEE gradual underflow threshold + * were excluded from these statistics. + * + * ERROR MESSAGES: + * message condition value returned + * incbet domain x<0, x>1 0.0 + * incbet underflow 0.0 + */ + + +/* +Cephes Math Library, Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef DEC +#define MAXGAM 34.84425627277176174 +#else +#define MAXGAM 171.624376956302725 +#endif + +extern double MACHEP, MINLOG, MAXLOG; +#ifdef ANSIPROT +extern double gamma ( double ); +extern double lgam ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double pow ( double, double ); +extern double fabs ( double ); +static double incbcf(double, double, double); +static double incbd(double, double, double); +static double pseries(double, double, double); +#else +double gamma(), lgam(), exp(), log(), pow(), fabs(); +static double incbcf(), incbd(), pseries(); +#endif + +static double big = 4.503599627370496e15; +static double biginv = 2.22044604925031308085e-16; + + +double incbet( aa, bb, xx ) +double aa, bb, xx; +{ +double a, b, t, x, xc, w, y; +int flag; + +if( aa <= 0.0 || bb <= 0.0 ) + goto domerr; + +if( (xx <= 0.0) || ( xx >= 1.0) ) + { + if( xx == 0.0 ) + return(0.0); + if( xx == 1.0 ) + return( 1.0 ); +domerr: + mtherr( "incbet", DOMAIN ); + return( 0.0 ); + } + +flag = 0; +if( (bb * xx) <= 1.0 && xx <= 0.95) + { + t = pseries(aa, bb, xx); + goto done; + } + +w = 1.0 - 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.0 && x <= 0.95) + { + t = pseries(a, b, x); + goto done; + } + +/* Choose expansion for better convergence. */ +y = x * (a+b-2.0) - (a-1.0); +if( y < 0.0 ) + w = incbcf( a, b, x ); +else + w = incbd( a, b, x ) / xc; + +/* Multiply w by the factor + a b _ _ _ + x (1-x) | (a+b) / ( a | (a) | (b) ) . */ + +y = a * log(x); +t = b * log(xc); +if( (a+b) < MAXGAM && fabs(y) < MAXLOG && fabs(t) < MAXLOG ) + { + t = pow(xc,b); + t *= pow(x,a); + t /= a; + t *= w; + t *= gamma(a+b) / (gamma(a) * gamma(b)); + goto done; + } +/* Resort to logarithms. */ +y += t + lgam(a+b) - lgam(a) - lgam(b); +y += log(w/a); +if( y < MINLOG ) + t = 0.0; +else + t = exp(y); + +done: + +if( flag == 1 ) + { + if( t <= MACHEP ) + t = 1.0 - MACHEP; + else + t = 1.0 - t; + } +return( t ); +} + +/* Continued fraction expansion #1 + * for incomplete beta integral + */ + +static double incbcf( a, b, x ) +double a, b, x; +{ +double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +double k1, k2, k3, k4, k5, k6, k7, k8; +double r, t, ans, thresh; +int n; + +k1 = a; +k2 = a + b; +k3 = a; +k4 = a + 1.0; +k5 = 1.0; +k6 = b - 1.0; +k7 = k4; +k8 = a + 2.0; + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = 1.0; +qkm1 = 1.0; +ans = 1.0; +r = 1.0; +n = 0; +thresh = 3.0 * MACHEP; +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 ) + r = pk/qk; + if( r != 0 ) + { + t = fabs( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( t < thresh ) + goto cdone; + + k1 += 1.0; + k2 += 1.0; + k3 += 2.0; + k4 += 2.0; + k5 += 1.0; + k6 -= 1.0; + k7 += 2.0; + k8 += 2.0; + + if( (fabs(qk) + fabs(pk)) > big ) + { + pkm2 *= biginv; + pkm1 *= biginv; + qkm2 *= biginv; + qkm1 *= biginv; + } + if( (fabs(qk) < biginv) || (fabs(pk) < biginv) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 300 ); + +cdone: +return(ans); +} + + +/* Continued fraction expansion #2 + * for incomplete beta integral + */ + +static double incbd( a, b, x ) +double a, b, x; +{ +double xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +double k1, k2, k3, k4, k5, k6, k7, k8; +double r, t, ans, z, thresh; +int n; + +k1 = a; +k2 = b - 1.0; +k3 = a; +k4 = a + 1.0; +k5 = 1.0; +k6 = a + b; +k7 = a + 1.0;; +k8 = a + 2.0; + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = 1.0; +qkm1 = 1.0; +z = x / (1.0-x); +ans = 1.0; +r = 1.0; +n = 0; +thresh = 3.0 * MACHEP; +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 ) + r = pk/qk; + if( r != 0 ) + { + t = fabs( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( t < thresh ) + goto cdone; + + k1 += 1.0; + k2 -= 1.0; + k3 += 2.0; + k4 += 2.0; + k5 += 1.0; + k6 += 1.0; + k7 += 2.0; + k8 += 2.0; + + if( (fabs(qk) + fabs(pk)) > big ) + { + pkm2 *= biginv; + pkm1 *= biginv; + qkm2 *= biginv; + qkm1 *= biginv; + } + if( (fabs(qk) < biginv) || (fabs(pk) < biginv) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 300 ); +cdone: +return(ans); +} + +/* Power series for incomplete beta integral. + Use when b*x is small and x not too close to 1. */ + +static double pseries( a, b, x ) +double a, b, x; +{ +double s, t, u, v, n, t1, z, ai; + +ai = 1.0 / a; +u = (1.0 - b) * x; +v = u / (a + 1.0); +t1 = v; +t = u; +n = 2.0; +s = 0.0; +z = MACHEP * ai; +while( fabs(v) > z ) + { + u = (n - b) * x / n; + t *= u; + v = t / (a + n); + s += v; + n += 1.0; + } +s += t1; +s += ai; + +u = a * log(x); +if( (a+b) < MAXGAM && fabs(u) < MAXLOG ) + { + t = gamma(a+b)/(gamma(a)*gamma(b)); + s = s * t * pow(x,a); + } +else + { + t = lgam(a+b) - lgam(a) - lgam(b) + u + log(s); + if( t < MINLOG ) + s = 0.0; + else + s = exp(t); + } +return(s); +} diff --git a/libm/double/incbi.c b/libm/double/incbi.c new file mode 100644 index 000000000..817219c4a --- /dev/null +++ b/libm/double/incbi.c @@ -0,0 +1,313 @@ +/* incbi() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * double a, b, x, y, incbi(); + * + * x = incbi( a, b, y ); + * + * + * + * DESCRIPTION: + * + * Given y, the function finds x such that + * + * incbet( a, b, x ) = y . + * + * The routine performs interval halving or 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 50000 5.8e-12 1.3e-13 + * IEEE 0,1 .25,100 100000 1.8e-13 3.9e-15 + * IEEE 0,1 0,5 50000 1.1e-12 5.5e-15 + * VAX 0,1 .5,100 25000 3.5e-14 1.1e-15 + * With a and b constrained to half-integer or integer values: + * IEEE 0,1 .5,10000 50000 5.8e-12 1.1e-13 + * IEEE 0,1 .5,100 100000 1.7e-14 7.9e-16 + * With a = .5, b constrained to half-integer or integer values: + * IEEE 0,1 .5,10000 10000 8.3e-11 1.0e-11 + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1996, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +extern double MACHEP, MAXNUM, MAXLOG, MINLOG; +#ifdef ANSIPROT +extern double ndtri ( double ); +extern double exp ( double ); +extern double fabs ( double ); +extern double log ( double ); +extern double sqrt ( double ); +extern double lgam ( double ); +extern double incbet ( double, double, double ); +#else +double ndtri(), exp(), fabs(), log(), sqrt(), lgam(), incbet(); +#endif + +double incbi( aa, bb, yy0 ) +double aa, bb, yy0; +{ +double a, b, y0, d, y, x, x0, x1, lgm, yp, di, dithresh, yl, yh, xt; +int i, rflg, dir, nflg; + + +i = 0; +if( yy0 <= 0 ) + return(0.0); +if( yy0 >= 1.0 ) + return(1.0); +x0 = 0.0; +yl = 0.0; +x1 = 1.0; +yh = 1.0; +nflg = 0; + +if( aa <= 1.0 || bb <= 1.0 ) + { + dithresh = 1.0e-6; + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + x = a/(a+b); + y = incbet( a, b, x ); + goto ihalve; + } +else + { + dithresh = 1.0e-4; + } +/* approximation to inverse function */ + +yp = -ndtri(yy0); + +if( yy0 > 0.5 ) + { + rflg = 1; + a = bb; + b = aa; + y0 = 1.0 - yy0; + yp = -yp; + } +else + { + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + } + +lgm = (yp * yp - 3.0)/6.0; +x = 2.0/( 1.0/(2.0*a-1.0) + 1.0/(2.0*b-1.0) ); +d = yp * sqrt( x + lgm ) / x + - ( 1.0/(2.0*b-1.0) - 1.0/(2.0*a-1.0) ) + * (lgm + 5.0/6.0 - 2.0/(3.0*x)); +d = 2.0 * d; +if( d < MINLOG ) + { + x = 1.0; + goto under; + } +x = a/( a + b * exp(d) ); +y = incbet( a, b, x ); +yp = (y - y0)/y0; +if( fabs(yp) < 0.2 ) + goto newt; + +/* Resort to interval halving if not close enough. */ +ihalve: + +dir = 0; +di = 0.5; +for( i=0; i<100; i++ ) + { + if( i != 0 ) + { + x = x0 + di * (x1 - x0); + if( x == 1.0 ) + x = 1.0 - MACHEP; + if( x == 0.0 ) + { + di = 0.5; + x = x0 + di * (x1 - x0); + if( x == 0.0 ) + goto under; + } + y = incbet( a, b, x ); + yp = (x1 - x0)/(x1 + x0); + if( fabs(yp) < dithresh ) + goto newt; + yp = (y-y0)/y0; + if( fabs(yp) < dithresh ) + goto newt; + } + if( y < y0 ) + { + x0 = x; + yl = y; + if( dir < 0 ) + { + dir = 0; + di = 0.5; + } + else if( dir > 3 ) + di = 1.0 - (1.0 - di) * (1.0 - di); + else if( dir > 1 ) + di = 0.5 * di + 0.5; + else + di = (y0 - y)/(yh - yl); + dir += 1; + if( x0 > 0.75 ) + { + if( rflg == 1 ) + { + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + } + else + { + rflg = 1; + a = bb; + b = aa; + y0 = 1.0 - yy0; + } + x = 1.0 - x; + y = incbet( a, b, x ); + x0 = 0.0; + yl = 0.0; + x1 = 1.0; + yh = 1.0; + goto ihalve; + } + } + else + { + x1 = x; + if( rflg == 1 && x1 < MACHEP ) + { + x = 0.0; + goto done; + } + yh = y; + if( dir > 0 ) + { + dir = 0; + di = 0.5; + } + else if( dir < -3 ) + di = di * di; + else if( dir < -1 ) + di = 0.5 * di; + else + di = (y - y0)/(yh - yl); + dir -= 1; + } + } +mtherr( "incbi", PLOSS ); +if( x0 >= 1.0 ) + { + x = 1.0 - MACHEP; + goto done; + } +if( x <= 0.0 ) + { +under: + mtherr( "incbi", UNDERFLOW ); + x = 0.0; + goto done; + } + +newt: + +if( nflg ) + goto done; +nflg = 1; +lgm = lgam(a+b) - lgam(a) - lgam(b); + +for( i=0; i<8; i++ ) + { + /* Compute the function at this point. */ + if( i != 0 ) + y = incbet(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.0 || x == 0.0 ) + break; + /* Compute the derivative of the function at this point. */ + d = (a - 1.0) * log(x) + (b - 1.0) * log(1.0-x) + lgm; + if( d < MINLOG ) + goto done; + if( d > MAXLOG ) + break; + d = exp(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.5 * y * (x - x0); + if( xt <= 0.0 ) + break; + } + if( xt >= x1 ) + { + y = (x1 - x) / (x1 - x0); + xt = x1 - 0.5 * y * (x1 - x); + if( xt >= 1.0 ) + break; + } + x = xt; + if( fabs(d/x) < 128.0 * MACHEP ) + goto done; + } +/* Did not converge. */ +dithresh = 256.0 * MACHEP; +goto ihalve; + +done: + +if( rflg ) + { + if( x <= MACHEP ) + x = 1.0 - MACHEP; + else + x = 1.0 - x; + } +return( x ); +} diff --git a/libm/double/isnan.c b/libm/double/isnan.c new file mode 100644 index 000000000..8ae83bcba --- /dev/null +++ b/libm/double/isnan.c @@ -0,0 +1,237 @@ +/* isnan() + * signbit() + * isfinite() + * + * Floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * double ceil(), floor(), frexp(), ldexp(); + * int signbit(), isnan(), isfinite(); + * double x, y; + * int expnt, n; + * + * y = floor(x); + * y = ceil(x); + * y = frexp( x, &expnt ); + * y = ldexp( x, n ); + * n = signbit(x); + * n = isnan(x); + * n = isfinite(x); + * + * + * + * DESCRIPTION: + * + * All four routines return a double precision floating point + * result. + * + * floor() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * ceil() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * frexp() 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. + * + * ldexp() multiplies x by 2**n. + * + * signbit(x) returns 1 if the sign bit of x is 1, else 0. + * + * These functions are part of the standard C run time library + * for many but not all C compilers. The ones supplied are + * written in C for either DEC or 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.3: March, 1995 +Copyright 1984, 1995 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +/* ceil(), floor(), frexp(), ldexp() may need to be rewritten. */ +#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 signbit(x) +double x; +{ +union + { + double d; + short s[4]; + int i[2]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + return( u.i[1] < 0 ); +#endif +#ifdef DEC + return( u.s[3] < 0 ); +#endif +#ifdef MIEEE + return( u.i[0] < 0 ); +#endif + } +else + { +#ifdef IBMPC + return( u.s[3] < 0 ); +#endif +#ifdef DEC + return( u.s[3] < 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 isnan(x) +double x; +{ +#ifdef NANS +union + { + double d; + unsigned short s[4]; + unsigned int i[2]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( ((u.i[1] & 0x7ff00000) == 0x7ff00000) + && (((u.i[1] & 0x000fffff) != 0) || (u.i[0] != 0))) + return 1; +#endif +#ifdef DEC + if( (u.s[1] & 0x7fff) == 0) + { + if( (u.s[2] | u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( ((u.i[0] & 0x7ff00000) == 0x7ff00000) + && (((u.i[0] & 0x000fffff) != 0) || (u.i[1] != 0))) + return 1; +#endif + return(0); + } +else + { /* size int not 4 */ +#ifdef IBMPC + if( (u.s[3] & 0x7ff0) == 0x7ff0) + { + if( ((u.s[3] & 0x000f) | u.s[2] | u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef DEC + if( (u.s[3] & 0x7fff) == 0) + { + if( (u.s[2] | u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7ff0) == 0x7ff0) + { + if( ((u.s[0] & 0x000f) | u.s[1] | u.s[2] | u.s[3]) != 0 ) + 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 isfinite(x) +double x; +{ +#ifdef INFINITIES +union + { + double d; + unsigned short s[4]; + unsigned int i[2]; + } u; + +u.d = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( (u.i[1] & 0x7ff00000) != 0x7ff00000) + return 1; +#endif +#ifdef DEC + if( (u.s[3] & 0x7fff) != 0) + return 1; +#endif +#ifdef MIEEE + if( (u.i[0] & 0x7ff00000) != 0x7ff00000) + return 1; +#endif + return(0); + } +else + { +#ifdef IBMPC + if( (u.s[3] & 0x7ff0) != 0x7ff0) + return 1; +#endif +#ifdef DEC + if( (u.s[3] & 0x7fff) != 0) + return 1; +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7ff0) != 0x7ff0) + return 1; +#endif + return(0); + } +#else +/* No INFINITY. */ +return(1); +#endif +} diff --git a/libm/double/iv.c b/libm/double/iv.c new file mode 100644 index 000000000..ec0e96244 --- /dev/null +++ b/libm/double/iv.c @@ -0,0 +1,116 @@ +/* iv.c + * + * Modified Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * double v, x, y, iv(); + * + * y = iv( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order v of the + * argument. If x is negative, v must be integer valued. + * + * The function is defined as Iv(x) = Jv( ix ). It is + * here computed in terms of the confluent hypergeometric + * function, according to the formula + * + * v -x + * Iv(x) = (x/2) e hyperg( v+0.5, 2v+1, 2x ) / gamma(v+1) + * + * If v is a negative integer, then v is replaced by -v. + * + * + * ACCURACY: + * + * Tested at random points (v, x), with v between 0 and + * 30, x between 0 and 28. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 2000 3.1e-15 5.4e-16 + * IEEE 0,30 10000 1.7e-14 2.7e-15 + * + * Accuracy is diminished if v is near a negative integer. + * + * See also hyperg.c. + * + */ + /* iv.c */ +/* Modified Bessel function of noninteger order */ +/* If x < 0, then v must be an integer. */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> +#ifdef ANSIPROT +extern double hyperg ( double, double, double ); +extern double exp ( double ); +extern double gamma ( double ); +extern double log ( double ); +extern double fabs ( double ); +extern double floor ( double ); +#else +double hyperg(), exp(), gamma(), log(), fabs(), floor(); +#endif +extern double MACHEP, MAXNUM; + +double iv( v, x ) +double v, x; +{ +int sign; +double t, ax; + +/* If v is a negative integer, invoke symmetry */ +t = floor(v); +if( v < 0.0 ) + { + if( t == v ) + { + v = -v; /* symmetry */ + t = -t; + } + } +/* If x is negative, require v to be an integer */ +sign = 1; +if( x < 0.0 ) + { + if( t != v ) + { + mtherr( "iv", DOMAIN ); + return( 0.0 ); + } + if( v != 2.0 * floor(v/2.0) ) + sign = -1; + } + +/* Avoid logarithm singularity */ +if( x == 0.0 ) + { + if( v == 0.0 ) + return( 1.0 ); + if( v < 0.0 ) + { + mtherr( "iv", OVERFLOW ); + return( MAXNUM ); + } + else + return( 0.0 ); + } + +ax = fabs(x); +t = v * log( 0.5 * ax ) - x; +t = sign * exp(t) / gamma( v + 1.0 ); +ax = v + 0.5; +return( t * hyperg( ax, 2.0 * ax, 2.0 * x ) ); +} diff --git a/libm/double/j0.c b/libm/double/j0.c new file mode 100644 index 000000000..c0f1bd4b8 --- /dev/null +++ b/libm/double/j0.c @@ -0,0 +1,543 @@ +/* j0.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * double x, y, j0(); + * + * y = j0( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order zero of the argument. + * + * The domain is divided into the intervals [0, 5] and + * (5, infinity). In the first interval the following rational + * approximation is used: + * + * + * 2 2 + * (w - r ) (w - r ) P (w) / Q (w) + * 1 2 3 8 + * + * 2 + * where w = x and the two r's are zeros of the function. + * + * In the second interval, the Hankel asymptotic expansion + * is employed with two rational functions of degree 6/6 + * and 7/7. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 4.4e-17 6.3e-18 + * IEEE 0, 30 60000 4.2e-16 1.1e-16 + * + */ + /* y0.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, y0(); + * + * y = y0( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 5] and + * (5, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * y0(x) = R(x) + 2 * log(x) * j0(x) / PI. + * Thus a call to j0() is required. + * + * In the second interval, the Hankel asymptotic expansion + * is employed with two rational functions of degree 6/6 + * and 7/7. + * + * + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * DEC 0, 30 9400 7.0e-17 7.9e-18 + * IEEE 0, 30 30000 1.3e-15 1.6e-16 + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +/* Note: all coefficients satisfy the relative error criterion + * except YP, YQ which are designed for absolute error. */ + +#include <math.h> + +#ifdef UNK +static double PP[7] = { + 7.96936729297347051624E-4, + 8.28352392107440799803E-2, + 1.23953371646414299388E0, + 5.44725003058768775090E0, + 8.74716500199817011941E0, + 5.30324038235394892183E0, + 9.99999999999999997821E-1, +}; +static double PQ[7] = { + 9.24408810558863637013E-4, + 8.56288474354474431428E-2, + 1.25352743901058953537E0, + 5.47097740330417105182E0, + 8.76190883237069594232E0, + 5.30605288235394617618E0, + 1.00000000000000000218E0, +}; +#endif +#ifdef DEC +static unsigned short PP[28] = { +0035520,0164604,0140733,0054470, +0037251,0122605,0115356,0107170, +0040236,0124412,0071500,0056303, +0040656,0047737,0045720,0045263, +0041013,0172143,0045004,0142103, +0040651,0132045,0026241,0026406, +0040200,0000000,0000000,0000000, +}; +static unsigned short PQ[28] = { +0035562,0052006,0070034,0134666, +0037257,0057055,0055242,0123424, +0040240,0071626,0046630,0032371, +0040657,0011077,0032013,0012731, +0041014,0030307,0050331,0006414, +0040651,0145457,0065021,0150304, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short PP[28] = { +0x6b27,0x983b,0x1d30,0x3f4a, +0xd1cf,0xb35d,0x34b0,0x3fb5, +0x0b98,0x4e68,0xd521,0x3ff3, +0x0956,0xe97a,0xc9fb,0x4015, +0x9888,0x6940,0x7e8c,0x4021, +0x25a1,0xa594,0x3684,0x4015, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short PQ[28] = { +0x9737,0xce03,0x4a80,0x3f4e, +0x54e3,0xab54,0xebc5,0x3fb5, +0x069f,0xc9b3,0x0e72,0x3ff4, +0x62bb,0xe681,0xe247,0x4015, +0x21a1,0xea1b,0x8618,0x4021, +0x3a19,0xed42,0x3965,0x4015, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short PP[28] = { +0x3f4a,0x1d30,0x983b,0x6b27, +0x3fb5,0x34b0,0xb35d,0xd1cf, +0x3ff3,0xd521,0x4e68,0x0b98, +0x4015,0xc9fb,0xe97a,0x0956, +0x4021,0x7e8c,0x6940,0x9888, +0x4015,0x3684,0xa594,0x25a1, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short PQ[28] = { +0x3f4e,0x4a80,0xce03,0x9737, +0x3fb5,0xebc5,0xab54,0x54e3, +0x3ff4,0x0e72,0xc9b3,0x069f, +0x4015,0xe247,0xe681,0x62bb, +0x4021,0x8618,0xea1b,0x21a1, +0x4015,0x3965,0xed42,0x3a19, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +#ifdef UNK +static double QP[8] = { +-1.13663838898469149931E-2, +-1.28252718670509318512E0, +-1.95539544257735972385E1, +-9.32060152123768231369E1, +-1.77681167980488050595E2, +-1.47077505154951170175E2, +-5.14105326766599330220E1, +-6.05014350600728481186E0, +}; +static double QQ[7] = { +/* 1.00000000000000000000E0,*/ + 6.43178256118178023184E1, + 8.56430025976980587198E2, + 3.88240183605401609683E3, + 7.24046774195652478189E3, + 5.93072701187316984827E3, + 2.06209331660327847417E3, + 2.42005740240291393179E2, +}; +#endif +#ifdef DEC +static unsigned short QP[32] = { +0136472,0035021,0142451,0141115, +0140244,0024731,0150620,0105642, +0141234,0067177,0124161,0060141, +0141672,0064572,0151557,0043036, +0142061,0127141,0003127,0043517, +0142023,0011727,0060271,0144544, +0141515,0122142,0126620,0143150, +0140701,0115306,0106715,0007344, +}; +static unsigned short QQ[28] = { +/*0040200,0000000,0000000,0000000,*/ +0041600,0121272,0004741,0026544, +0042526,0015605,0105654,0161771, +0043162,0123155,0165644,0062645, +0043342,0041675,0167576,0130756, +0043271,0052720,0165631,0154214, +0043000,0160576,0034614,0172024, +0042162,0000570,0030500,0051235, +}; +#endif +#ifdef IBMPC +static unsigned short QP[32] = { +0x384a,0x38a5,0x4742,0xbf87, +0x1174,0x3a32,0x853b,0xbff4, +0x2c0c,0xf50e,0x8dcf,0xc033, +0xe8c4,0x5a6d,0x4d2f,0xc057, +0xe8ea,0x20ca,0x35cc,0xc066, +0x392d,0xec17,0x627a,0xc062, +0x18cd,0x55b2,0xb48c,0xc049, +0xa1dd,0xd1b9,0x3358,0xc018, +}; +static unsigned short QQ[28] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x25ac,0x413c,0x1457,0x4050, +0x9c7f,0xb175,0xc370,0x408a, +0x8cb5,0xbd74,0x54cd,0x40ae, +0xd63e,0xbdef,0x4877,0x40bc, +0x3b11,0x1d73,0x2aba,0x40b7, +0x9e82,0xc731,0x1c2f,0x40a0, +0x0a54,0x0628,0x402f,0x406e, +}; +#endif +#ifdef MIEEE +static unsigned short QP[32] = { +0xbf87,0x4742,0x38a5,0x384a, +0xbff4,0x853b,0x3a32,0x1174, +0xc033,0x8dcf,0xf50e,0x2c0c, +0xc057,0x4d2f,0x5a6d,0xe8c4, +0xc066,0x35cc,0x20ca,0xe8ea, +0xc062,0x627a,0xec17,0x392d, +0xc049,0xb48c,0x55b2,0x18cd, +0xc018,0x3358,0xd1b9,0xa1dd, +}; +static unsigned short QQ[28] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4050,0x1457,0x413c,0x25ac, +0x408a,0xc370,0xb175,0x9c7f, +0x40ae,0x54cd,0xbd74,0x8cb5, +0x40bc,0x4877,0xbdef,0xd63e, +0x40b7,0x2aba,0x1d73,0x3b11, +0x40a0,0x1c2f,0xc731,0x9e82, +0x406e,0x402f,0x0628,0x0a54, +}; +#endif + + +#ifdef UNK +static double YP[8] = { + 1.55924367855235737965E4, +-1.46639295903971606143E7, + 5.43526477051876500413E9, +-9.82136065717911466409E11, + 8.75906394395366999549E13, +-3.46628303384729719441E15, + 4.42733268572569800351E16, +-1.84950800436986690637E16, +}; +static double YQ[7] = { +/* 1.00000000000000000000E0,*/ + 1.04128353664259848412E3, + 6.26107330137134956842E5, + 2.68919633393814121987E8, + 8.64002487103935000337E10, + 2.02979612750105546709E13, + 3.17157752842975028269E15, + 2.50596256172653059228E17, +}; +#endif +#ifdef DEC +static unsigned short YP[32] = { +0043563,0120677,0042264,0046166, +0146137,0140371,0113444,0042260, +0050241,0175707,0100502,0063344, +0152144,0125737,0007265,0164526, +0053637,0051621,0163035,0060546, +0155105,0004416,0107306,0060023, +0056035,0045133,0030132,0000024, +0155603,0065132,0144061,0131732, +}; +static unsigned short YQ[28] = { +/*0040200,0000000,0000000,0000000,*/ +0042602,0024422,0135557,0162663, +0045030,0155665,0044075,0160135, +0047200,0035432,0105446,0104005, +0051240,0167331,0056063,0022743, +0053223,0127746,0025764,0012160, +0055064,0044206,0177532,0145545, +0056536,0111375,0163715,0127201, +}; +#endif +#ifdef IBMPC +static unsigned short YP[32] = { +0x898f,0xe896,0x7437,0x40ce, +0x8896,0x32e4,0xf81f,0xc16b, +0x4cdd,0xf028,0x3f78,0x41f4, +0xbd2b,0xe1d6,0x957b,0xc26c, +0xac2d,0x3cc3,0xea72,0x42d3, +0xcc02,0xd1d8,0xa121,0xc328, +0x4003,0x660b,0xa94b,0x4363, +0x367b,0x5906,0x6d4b,0xc350, +}; +static unsigned short YQ[28] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xfcb6,0x576d,0x4522,0x4090, +0xbc0c,0xa907,0x1b76,0x4123, +0xd101,0x5164,0x0763,0x41b0, +0x64bc,0x2b86,0x1ddb,0x4234, +0x828e,0xc57e,0x75fc,0x42b2, +0x596d,0xdfeb,0x8910,0x4326, +0xb5d0,0xbcf9,0xd25f,0x438b, +}; +#endif +#ifdef MIEEE +static unsigned short YP[32] = { +0x40ce,0x7437,0xe896,0x898f, +0xc16b,0xf81f,0x32e4,0x8896, +0x41f4,0x3f78,0xf028,0x4cdd, +0xc26c,0x957b,0xe1d6,0xbd2b, +0x42d3,0xea72,0x3cc3,0xac2d, +0xc328,0xa121,0xd1d8,0xcc02, +0x4363,0xa94b,0x660b,0x4003, +0xc350,0x6d4b,0x5906,0x367b, +}; +static unsigned short YQ[28] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4090,0x4522,0x576d,0xfcb6, +0x4123,0x1b76,0xa907,0xbc0c, +0x41b0,0x0763,0x5164,0xd101, +0x4234,0x1ddb,0x2b86,0x64bc, +0x42b2,0x75fc,0xc57e,0x828e, +0x4326,0x8910,0xdfeb,0x596d, +0x438b,0xd25f,0xbcf9,0xb5d0, +}; +#endif + +#ifdef UNK +/* 5.783185962946784521175995758455807035071 */ +static double DR1 = 5.78318596294678452118E0; +/* 30.47126234366208639907816317502275584842 */ +static double DR2 = 3.04712623436620863991E1; +#endif + +#ifdef DEC +static unsigned short R1[] = {0040671,0007734,0001061,0056734}; +#define DR1 *(double *)R1 +static unsigned short R2[] = {0041363,0142445,0030416,0165567}; +#define DR2 *(double *)R2 +#endif + +#ifdef IBMPC +static unsigned short R1[] = {0x2bbb,0x8046,0x21fb,0x4017}; +#define DR1 *(double *)R1 +static unsigned short R2[] = {0xdd6f,0xa621,0x78a4,0x403e}; +#define DR2 *(double *)R2 +#endif + +#ifdef MIEEE +static unsigned short R1[] = {0x4017,0x21fb,0x8046,0x2bbb}; +#define DR1 *(double *)R1 +static unsigned short R2[] = {0x403e,0x78a4,0xa621,0xdd6f}; +#define DR2 *(double *)R2 +#endif + +#ifdef UNK +static double RP[4] = { +-4.79443220978201773821E9, + 1.95617491946556577543E12, +-2.49248344360967716204E14, + 9.70862251047306323952E15, +}; +static double RQ[8] = { +/* 1.00000000000000000000E0,*/ + 4.99563147152651017219E2, + 1.73785401676374683123E5, + 4.84409658339962045305E7, + 1.11855537045356834862E10, + 2.11277520115489217587E12, + 3.10518229857422583814E14, + 3.18121955943204943306E16, + 1.71086294081043136091E18, +}; +#endif +#ifdef DEC +static unsigned short RP[16] = { +0150216,0161235,0064344,0014450, +0052343,0135216,0035624,0144153, +0154142,0130247,0003310,0003667, +0055411,0173703,0047772,0176635, +}; +static unsigned short RQ[32] = { +/*0040200,0000000,0000000,0000000,*/ +0042371,0144025,0032265,0136137, +0044451,0133131,0132420,0151466, +0046470,0144641,0072540,0030636, +0050446,0126600,0045042,0044243, +0052365,0172633,0110301,0071063, +0054215,0032424,0062272,0043513, +0055742,0005013,0171731,0072335, +0057275,0170646,0036663,0013134, +}; +#endif +#ifdef IBMPC +static unsigned short RP[16] = { +0x8325,0xad1c,0xdc53,0xc1f1, +0x990d,0xc772,0x7751,0x427c, +0x00f7,0xe0d9,0x5614,0xc2ec, +0x5fb4,0x69ff,0x3ef8,0x4341, +}; +static unsigned short RQ[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xb78c,0xa696,0x3902,0x407f, +0x1a67,0x36a2,0x36cb,0x4105, +0x0634,0x2eac,0x1934,0x4187, +0x4914,0x0944,0xd5b0,0x4204, +0x2e46,0x7218,0xbeb3,0x427e, +0x48e9,0x8c97,0xa6a2,0x42f1, +0x2e9c,0x7e7b,0x4141,0x435c, +0x62cc,0xc7b6,0xbe34,0x43b7, +}; +#endif +#ifdef MIEEE +static unsigned short RP[16] = { +0xc1f1,0xdc53,0xad1c,0x8325, +0x427c,0x7751,0xc772,0x990d, +0xc2ec,0x5614,0xe0d9,0x00f7, +0x4341,0x3ef8,0x69ff,0x5fb4, +}; +static unsigned short RQ[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x407f,0x3902,0xa696,0xb78c, +0x4105,0x36cb,0x36a2,0x1a67, +0x4187,0x1934,0x2eac,0x0634, +0x4204,0xd5b0,0x0944,0x4914, +0x427e,0xbeb3,0x7218,0x2e46, +0x42f1,0xa6a2,0x8c97,0x48e9, +0x435c,0x4141,0x7e7b,0x2e9c, +0x43b7,0xbe34,0xc7b6,0x62cc, +}; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double log ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern double sqrt ( double ); +double j0 ( double ); +#else +double polevl(), p1evl(), log(), sin(), cos(), sqrt(); +double j0(); +#endif +extern double TWOOPI, SQ2OPI, PIO4; + +double j0(x) +double x; +{ +double w, z, p, q, xn; + +if( x < 0 ) + x = -x; + +if( x <= 5.0 ) + { + z = x * x; + if( x < 1.0e-5 ) + return( 1.0 - z/4.0 ); + + p = (z - DR1) * (z - DR2); + p = p * polevl( z, RP, 3)/p1evl( z, RQ, 8 ); + return( p ); + } + +w = 5.0/x; +q = 25.0/(x*x); +p = polevl( q, PP, 6)/polevl( q, PQ, 6 ); +q = polevl( q, QP, 7)/p1evl( q, QQ, 7 ); +xn = x - PIO4; +p = p * cos(xn) - w * q * sin(xn); +return( p * SQ2OPI / sqrt(x) ); +} + +/* y0() 2 */ +/* Bessel function of second kind, order zero */ + +/* Rational approximation coefficients YP[], YQ[] are used here. + * The function computed is y0(x) - 2 * log(x) * j0(x) / PI, + * whose value at x = 0 is 2 * ( log(0.5) + EUL ) / PI + * = 0.073804295108687225. + */ + +/* +#define PIO4 .78539816339744830962 +#define SQ2OPI .79788456080286535588 +*/ +extern double MAXNUM; + +double y0(x) +double x; +{ +double w, z, p, q, xn; + +if( x <= 5.0 ) + { + if( x <= 0.0 ) + { + mtherr( "y0", DOMAIN ); + return( -MAXNUM ); + } + z = x * x; + w = polevl( z, YP, 7) / p1evl( z, YQ, 7 ); + w += TWOOPI * log(x) * j0(x); + return( w ); + } + +w = 5.0/x; +z = 25.0 / (x * x); +p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); +q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); +xn = x - PIO4; +p = p * sin(xn) + w * q * cos(xn); +return( p * SQ2OPI / sqrt(x) ); +} diff --git a/libm/double/j1.c b/libm/double/j1.c new file mode 100644 index 000000000..95e46ea79 --- /dev/null +++ b/libm/double/j1.c @@ -0,0 +1,515 @@ +/* j1.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * double x, y, j1(); + * + * y = j1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 8] and + * (8, infinity). In the first interval a 24 term Chebyshev + * expansion is used. In the second, the asymptotic + * trigonometric representation is employed using two + * rational functions of degree 5/5. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 4.0e-17 1.1e-17 + * IEEE 0, 30 30000 2.6e-16 1.1e-16 + * + * + */ + /* y1.c + * + * Bessel function of second kind of order one + * + * + * + * SYNOPSIS: + * + * double x, y, y1(); + * + * y = y1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind of order one + * of the argument. + * + * The domain is divided into the intervals [0, 8] and + * (8, infinity). In the first interval a 25 term Chebyshev + * expansion is used, and a call to j1() is required. + * In the second, the asymptotic trigonometric representation + * is employed using two rational functions of degree 5/5. + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * DEC 0, 30 10000 8.6e-17 1.3e-17 + * IEEE 0, 30 30000 1.0e-15 1.3e-16 + * + * (error criterion relative when |y1| > 1). + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +/* +#define PIO4 .78539816339744830962 +#define THPIO4 2.35619449019234492885 +#define SQ2OPI .79788456080286535588 +*/ + +#include <math.h> + +#ifdef UNK +static double RP[4] = { +-8.99971225705559398224E8, + 4.52228297998194034323E11, +-7.27494245221818276015E13, + 3.68295732863852883286E15, +}; +static double RQ[8] = { +/* 1.00000000000000000000E0,*/ + 6.20836478118054335476E2, + 2.56987256757748830383E5, + 8.35146791431949253037E7, + 2.21511595479792499675E10, + 4.74914122079991414898E12, + 7.84369607876235854894E14, + 8.95222336184627338078E16, + 5.32278620332680085395E18, +}; +#endif +#ifdef DEC +static unsigned short RP[16] = { +0147526,0110742,0063322,0077052, +0051722,0112720,0065034,0061530, +0153604,0052227,0033147,0105650, +0055121,0055025,0032276,0022015, +}; +static unsigned short RQ[32] = { +/*0040200,0000000,0000000,0000000,*/ +0042433,0032610,0155604,0033473, +0044572,0173320,0067270,0006616, +0046637,0045246,0162225,0006606, +0050645,0004773,0157577,0053004, +0052612,0033734,0001667,0176501, +0054462,0054121,0173147,0121367, +0056237,0002777,0121451,0176007, +0057623,0136253,0131601,0044710, +}; +#endif +#ifdef IBMPC +static unsigned short RP[16] = { +0x4fc5,0x4cda,0xd23c,0xc1ca, +0x8c6b,0x0d43,0x52ba,0x425a, +0xf175,0xe6cc,0x8a92,0xc2d0, +0xc482,0xa697,0x2b42,0x432a, +}; +static unsigned short RQ[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x86e7,0x1b70,0x66b1,0x4083, +0x01b2,0x0dd7,0x5eda,0x410f, +0xa1b1,0xdc92,0xe954,0x4193, +0xeac1,0x7bef,0xa13f,0x4214, +0xffa8,0x8076,0x46fb,0x4291, +0xf45f,0x3ecc,0x4b0a,0x4306, +0x3f81,0xf465,0xe0bf,0x4373, +0x2939,0x7670,0x7795,0x43d2, +}; +#endif +#ifdef MIEEE +static unsigned short RP[16] = { +0xc1ca,0xd23c,0x4cda,0x4fc5, +0x425a,0x52ba,0x0d43,0x8c6b, +0xc2d0,0x8a92,0xe6cc,0xf175, +0x432a,0x2b42,0xa697,0xc482, +}; +static unsigned short RQ[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4083,0x66b1,0x1b70,0x86e7, +0x410f,0x5eda,0x0dd7,0x01b2, +0x4193,0xe954,0xdc92,0xa1b1, +0x4214,0xa13f,0x7bef,0xeac1, +0x4291,0x46fb,0x8076,0xffa8, +0x4306,0x4b0a,0x3ecc,0xf45f, +0x4373,0xe0bf,0xf465,0x3f81, +0x43d2,0x7795,0x7670,0x2939, +}; +#endif + +#ifdef UNK +static double PP[7] = { + 7.62125616208173112003E-4, + 7.31397056940917570436E-2, + 1.12719608129684925192E0, + 5.11207951146807644818E0, + 8.42404590141772420927E0, + 5.21451598682361504063E0, + 1.00000000000000000254E0, +}; +static double PQ[7] = { + 5.71323128072548699714E-4, + 6.88455908754495404082E-2, + 1.10514232634061696926E0, + 5.07386386128601488557E0, + 8.39985554327604159757E0, + 5.20982848682361821619E0, + 9.99999999999999997461E-1, +}; +#endif +#ifdef DEC +static unsigned short PP[28] = { +0035507,0144542,0061543,0024326, +0037225,0145105,0017766,0022661, +0040220,0043766,0010254,0133255, +0040643,0113047,0142611,0151521, +0041006,0144344,0055351,0074261, +0040646,0156520,0120574,0006416, +0040200,0000000,0000000,0000000, +}; +static unsigned short PQ[28] = { +0035425,0142330,0115041,0165514, +0037214,0177352,0145105,0052026, +0040215,0072515,0141207,0073255, +0040642,0056427,0137222,0106405, +0041006,0062716,0166427,0165450, +0040646,0133352,0035425,0123304, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short PP[28] = { +0x651b,0x4c6c,0xf92c,0x3f48, +0xc4b6,0xa3fe,0xb948,0x3fb2, +0x96d6,0xc215,0x08fe,0x3ff2, +0x3a6a,0xf8b1,0x72c4,0x4014, +0x2f16,0x8b5d,0xd91c,0x4020, +0x81a2,0x142f,0xdbaa,0x4014, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short PQ[28] = { +0x3d69,0x1344,0xb89b,0x3f42, +0xaa83,0x5948,0x9fdd,0x3fb1, +0xeed6,0xb850,0xaea9,0x3ff1, +0x51a1,0xf7d2,0x4ba2,0x4014, +0xfd65,0xdda2,0xccb9,0x4020, +0xb4d9,0x4762,0xd6dd,0x4014, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short PP[28] = { +0x3f48,0xf92c,0x4c6c,0x651b, +0x3fb2,0xb948,0xa3fe,0xc4b6, +0x3ff2,0x08fe,0xc215,0x96d6, +0x4014,0x72c4,0xf8b1,0x3a6a, +0x4020,0xd91c,0x8b5d,0x2f16, +0x4014,0xdbaa,0x142f,0x81a2, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short PQ[28] = { +0x3f42,0xb89b,0x1344,0x3d69, +0x3fb1,0x9fdd,0x5948,0xaa83, +0x3ff1,0xaea9,0xb850,0xeed6, +0x4014,0x4ba2,0xf7d2,0x51a1, +0x4020,0xccb9,0xdda2,0xfd65, +0x4014,0xd6dd,0x4762,0xb4d9, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +#ifdef UNK +static double QP[8] = { + 5.10862594750176621635E-2, + 4.98213872951233449420E0, + 7.58238284132545283818E1, + 3.66779609360150777800E2, + 7.10856304998926107277E2, + 5.97489612400613639965E2, + 2.11688757100572135698E2, + 2.52070205858023719784E1, +}; +static double QQ[7] = { +/* 1.00000000000000000000E0,*/ + 7.42373277035675149943E1, + 1.05644886038262816351E3, + 4.98641058337653607651E3, + 9.56231892404756170795E3, + 7.99704160447350683650E3, + 2.82619278517639096600E3, + 3.36093607810698293419E2, +}; +#endif +#ifdef DEC +static unsigned short QP[32] = { +0037121,0037723,0055605,0151004, +0040637,0066656,0031554,0077264, +0041627,0122714,0153170,0161466, +0042267,0061712,0036520,0140145, +0042461,0133315,0131573,0071176, +0042425,0057525,0147500,0013201, +0042123,0130122,0061245,0154131, +0041311,0123772,0064254,0172650, +}; +static unsigned short QQ[28] = { +/*0040200,0000000,0000000,0000000,*/ +0041624,0074603,0002112,0101670, +0042604,0007135,0010162,0175565, +0043233,0151510,0157757,0172010, +0043425,0064506,0112006,0104276, +0043371,0164125,0032271,0164242, +0043060,0121425,0122750,0136013, +0042250,0005773,0053472,0146267, +}; +#endif +#ifdef IBMPC +static unsigned short QP[32] = { +0xba40,0x6b70,0x27fa,0x3faa, +0x8fd6,0xc66d,0xedb5,0x4013, +0x1c67,0x9acf,0xf4b9,0x4052, +0x180d,0x47aa,0xec79,0x4076, +0x6e50,0xb66f,0x36d9,0x4086, +0x02d0,0xb9e8,0xabea,0x4082, +0xbb0b,0x4c54,0x760a,0x406a, +0x9eb5,0x4d15,0x34ff,0x4039, +}; +static unsigned short QQ[28] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x5077,0x6089,0x8f30,0x4052, +0x5f6f,0xa20e,0x81cb,0x4090, +0xfe81,0x1bfd,0x7a69,0x40b3, +0xd118,0xd280,0xad28,0x40c2, +0x3d14,0xa697,0x3d0a,0x40bf, +0x1781,0xb4bd,0x1462,0x40a6, +0x5997,0x6ae7,0x017f,0x4075, +}; +#endif +#ifdef MIEEE +static unsigned short QP[32] = { +0x3faa,0x27fa,0x6b70,0xba40, +0x4013,0xedb5,0xc66d,0x8fd6, +0x4052,0xf4b9,0x9acf,0x1c67, +0x4076,0xec79,0x47aa,0x180d, +0x4086,0x36d9,0xb66f,0x6e50, +0x4082,0xabea,0xb9e8,0x02d0, +0x406a,0x760a,0x4c54,0xbb0b, +0x4039,0x34ff,0x4d15,0x9eb5, +}; +static unsigned short QQ[28] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4052,0x8f30,0x6089,0x5077, +0x4090,0x81cb,0xa20e,0x5f6f, +0x40b3,0x7a69,0x1bfd,0xfe81, +0x40c2,0xad28,0xd280,0xd118, +0x40bf,0x3d0a,0xa697,0x3d14, +0x40a6,0x1462,0xb4bd,0x1781, +0x4075,0x017f,0x6ae7,0x5997, +}; +#endif + +#ifdef UNK +static double YP[6] = { + 1.26320474790178026440E9, +-6.47355876379160291031E11, + 1.14509511541823727583E14, +-8.12770255501325109621E15, + 2.02439475713594898196E17, +-7.78877196265950026825E17, +}; +static double YQ[8] = { +/* 1.00000000000000000000E0,*/ + 5.94301592346128195359E2, + 2.35564092943068577943E5, + 7.34811944459721705660E7, + 1.87601316108706159478E10, + 3.88231277496238566008E12, + 6.20557727146953693363E14, + 6.87141087355300489866E16, + 3.97270608116560655612E18, +}; +#endif +#ifdef DEC +static unsigned short YP[24] = { +0047626,0112763,0013715,0133045, +0152026,0134552,0142033,0024411, +0053720,0045245,0102210,0077565, +0155347,0000321,0136415,0102031, +0056463,0146550,0055633,0032605, +0157054,0171012,0167361,0054265, +}; +static unsigned short YQ[32] = { +/*0040200,0000000,0000000,0000000,*/ +0042424,0111515,0044773,0153014, +0044546,0005405,0171307,0075774, +0046614,0023575,0047105,0063556, +0050613,0143034,0101533,0156026, +0052541,0175367,0166514,0114257, +0054415,0014466,0134350,0171154, +0056164,0017436,0025075,0022101, +0057534,0103614,0103663,0121772, +}; +#endif +#ifdef IBMPC +static unsigned short YP[24] = { +0xb6c5,0x62f9,0xd2be,0x41d2, +0x6521,0x5883,0xd72d,0xc262, +0x0fef,0xb091,0x0954,0x42da, +0xb083,0x37a1,0xe01a,0xc33c, +0x66b1,0x0b73,0x79ad,0x4386, +0x2b17,0x5dde,0x9e41,0xc3a5, +}; +static unsigned short YQ[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x7ac2,0xa93f,0x9269,0x4082, +0xef7f,0xbe58,0xc160,0x410c, +0xacee,0xa9c8,0x84ef,0x4191, +0x7b83,0x906b,0x78c3,0x4211, +0x9316,0xfda9,0x3f5e,0x428c, +0x1e4e,0xd71d,0xa326,0x4301, +0xa488,0xc547,0x83e3,0x436e, +0x747f,0x90f6,0x90f1,0x43cb, +}; +#endif +#ifdef MIEEE +static unsigned short YP[24] = { +0x41d2,0xd2be,0x62f9,0xb6c5, +0xc262,0xd72d,0x5883,0x6521, +0x42da,0x0954,0xb091,0x0fef, +0xc33c,0xe01a,0x37a1,0xb083, +0x4386,0x79ad,0x0b73,0x66b1, +0xc3a5,0x9e41,0x5dde,0x2b17, +}; +static unsigned short YQ[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4082,0x9269,0xa93f,0x7ac2, +0x410c,0xc160,0xbe58,0xef7f, +0x4191,0x84ef,0xa9c8,0xacee, +0x4211,0x78c3,0x906b,0x7b83, +0x428c,0x3f5e,0xfda9,0x9316, +0x4301,0xa326,0xd71d,0x1e4e, +0x436e,0x83e3,0xc547,0xa488, +0x43cb,0x90f1,0x90f6,0x747f, +}; +#endif + + +#ifdef UNK +static double Z1 = 1.46819706421238932572E1; +static double Z2 = 4.92184563216946036703E1; +#endif + +#ifdef DEC +static unsigned short DZ1[] = {0041152,0164532,0006114,0010540}; +static unsigned short DZ2[] = {0041504,0157663,0001625,0020621}; +#define Z1 (*(double *)DZ1) +#define Z2 (*(double *)DZ2) +#endif + +#ifdef IBMPC +static unsigned short DZ1[] = {0x822c,0x4189,0x5d2b,0x402d}; +static unsigned short DZ2[] = {0xa432,0x6072,0x9bf6,0x4048}; +#define Z1 (*(double *)DZ1) +#define Z2 (*(double *)DZ2) +#endif + +#ifdef MIEEE +static unsigned short DZ1[] = {0x402d,0x5d2b,0x4189,0x822c}; +static unsigned short DZ2[] = {0x4048,0x9bf6,0x6072,0xa432}; +#define Z1 (*(double *)DZ1) +#define Z2 (*(double *)DZ2) +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double log ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern double sqrt ( double ); +double j1 ( double ); +#else +double polevl(), p1evl(), log(), sin(), cos(), sqrt(); +double j1(); +#endif +extern double TWOOPI, THPIO4, SQ2OPI; + +double j1(x) +double x; +{ +double w, z, p, q, xn; + +w = x; +if( x < 0 ) + w = -x; + +if( w <= 5.0 ) + { + z = x * x; + w = polevl( z, RP, 3 ) / p1evl( z, RQ, 8 ); + w = w * x * (z - Z1) * (z - Z2); + return( w ); + } + +w = 5.0/x; +z = w * w; +p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); +q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); +xn = x - THPIO4; +p = p * cos(xn) - w * q * sin(xn); +return( p * SQ2OPI / sqrt(x) ); +} + + +extern double MAXNUM; + +double y1(x) +double x; +{ +double w, z, p, q, xn; + +if( x <= 5.0 ) + { + if( x <= 0.0 ) + { + mtherr( "y1", DOMAIN ); + return( -MAXNUM ); + } + z = x * x; + w = x * (polevl( z, YP, 5 ) / p1evl( z, YQ, 8 )); + w += TWOOPI * ( j1(x) * log(x) - 1.0/x ); + return( w ); + } + +w = 5.0/x; +z = w * w; +p = polevl( z, PP, 6)/polevl( z, PQ, 6 ); +q = polevl( z, QP, 7)/p1evl( z, QQ, 7 ); +xn = x - THPIO4; +p = p * sin(xn) + w * q * cos(xn); +return( p * SQ2OPI / sqrt(x) ); +} diff --git a/libm/double/jn.c b/libm/double/jn.c new file mode 100644 index 000000000..ee05395aa --- /dev/null +++ b/libm/double/jn.c @@ -0,0 +1,133 @@ +/* jn.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * double x, y, jn(); + * + * y = jn( 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 range # trials peak rms + * DEC 0, 30 5500 6.9e-17 9.3e-18 + * IEEE 0, 30 5000 4.4e-16 7.9e-17 + * + * + * Not suitable for large n or x. Use jv() instead. + * + */ + +/* jn.c +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ +#include <math.h> +#ifdef ANSIPROT +extern double fabs ( double ); +extern double j0 ( double ); +extern double j1 ( double ); +#else +double fabs(), j0(), j1(); +#endif +extern double MACHEP; + +double jn( n, x ) +int n; +double x; +{ +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.0 ) + { + if( n & 1 ) + sign = -sign; + x = -x; + } + +if( n == 0 ) + return( sign * j0(x) ); +if( n == 1 ) + return( sign * j1(x) ); +if( n == 2 ) + return( sign * (2.0 * j1(x) / x - j0(x)) ); + +if( x < MACHEP ) + return( 0.0 ); + +/* continued fraction */ +#ifdef DEC +k = 56; +#else +k = 53; +#endif + +pk = 2 * (n + k); +ans = pk; +xk = x * x; + +do + { + pk -= 2.0; + ans = pk - (xk/ans); + } +while( --k > 0 ); +ans = x/ans; + +/* backward recurrence */ + +pk = 1.0; +pkm1 = 1.0/ans; +k = n-1; +r = 2 * k; + +do + { + pkm2 = (pkm1 * r - pk * x) / x; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; + } +while( --k > 0 ); + +if( fabs(pk) > fabs(pkm1) ) + ans = j1(x)/pk; +else + ans = j0(x)/pkm1; +return( sign * ans ); +} diff --git a/libm/double/jv.c b/libm/double/jv.c new file mode 100644 index 000000000..5b8af3663 --- /dev/null +++ b/libm/double/jv.c @@ -0,0 +1,884 @@ +/* jv.c + * + * Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * double v, x, y, jv(); + * + * y = jv( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order v of the argument, + * where v is real. Negative x is allowed if v is an integer. + * + * Several expansions are included: the ascending power + * series, the Hankel expansion, and two transitional + * expansions for large v. If v is not too large, it + * is reduced by recurrence to a region of best accuracy. + * The transitional expansions give 12D accuracy for v > 500. + * + * + * + * ACCURACY: + * Results for integer v are indicated by *, where x and v + * both vary from -125 to +125. Otherwise, + * x ranges from 0 to 125, v ranges as indicated by "domain." + * Error criterion is absolute, except relative when |jv()| > 1. + * + * arithmetic v domain x domain # trials peak rms + * IEEE 0,125 0,125 100000 4.6e-15 2.2e-16 + * IEEE -125,0 0,125 40000 5.4e-11 3.7e-13 + * IEEE 0,500 0,500 20000 4.4e-15 4.0e-16 + * Integer v: + * IEEE -125,125 -125,125 50000 3.5e-15* 1.9e-16* + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 1992, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> +#define DEBUG 0 + +#ifdef DEC +#define MAXGAM 34.84425627277176174 +#else +#define MAXGAM 171.624376956302725 +#endif + +#ifdef ANSIPROT +extern int airy ( double, double *, double *, double *, double * ); +extern double fabs ( double ); +extern double floor ( double ); +extern double frexp ( double, int * ); +extern double polevl ( double, void *, int ); +extern double j0 ( double ); +extern double j1 ( double ); +extern double sqrt ( double ); +extern double cbrt ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern double acos ( double ); +extern double pow ( double, double ); +extern double gamma ( double ); +extern double lgam ( double ); +static double recur(double *, double, double *, int); +static double jvs(double, double); +static double hankel(double, double); +static double jnx(double, double); +static double jnt(double, double); +#else +int airy(); +double fabs(), floor(), frexp(), polevl(), j0(), j1(), sqrt(), cbrt(); +double exp(), log(), sin(), cos(), acos(), pow(), gamma(), lgam(); +static double recur(), jvs(), hankel(), jnx(), jnt(); +#endif + +extern double MAXNUM, MACHEP, MINLOG, MAXLOG; +#define BIG 1.44115188075855872E+17 + +double jv( n, x ) +double n, x; +{ +double k, q, t, y, an; +int i, sign, nint; + +nint = 0; /* Flag for integer n */ +sign = 1; /* Flag for sign inversion */ +an = fabs( n ); +y = floor( an ); +if( y == an ) + { + nint = 1; + i = an - 16384.0 * floor( an/16384.0 ); + if( n < 0.0 ) + { + if( i & 1 ) + sign = -sign; + n = an; + } + if( x < 0.0 ) + { + if( i & 1 ) + sign = -sign; + x = -x; + } + if( n == 0.0 ) + return( j0(x) ); + if( n == 1.0 ) + return( sign * j1(x) ); + } + +if( (x < 0.0) && (y != an) ) + { + mtherr( "Jv", DOMAIN ); + y = 0.0; + goto done; + } + +y = fabs(x); + +if( y < MACHEP ) + goto underf; + +k = 3.6 * sqrt(y); +t = 3.6 * sqrt(an); +if( (y < t) && (an > 21.0) ) + return( sign * jvs(n,x) ); +if( (an < k) && (y > 21.0) ) + return( sign * hankel(n,x) ); + +if( an < 500.0 ) + { +/* Note: if x is too large, the continued + * fraction will fail; but then the + * Hankel expansion can be used. + */ + if( nint != 0 ) + { + k = 0.0; + q = recur( &n, x, &k, 1 ); + if( k == 0.0 ) + { + y = j0(x)/q; + goto done; + } + if( k == 1.0 ) + { + y = j1(x)/q; + goto done; + } + } + +if( an > 2.0 * y ) + goto rlarger; + + if( (n >= 0.0) && (n < 20.0) + && (y > 6.0) && (y < 20.0) ) + { +/* Recur backwards from a larger value of n + */ +rlarger: + k = n; + + y = y + an + 1.0; + if( y < 30.0 ) + y = 30.0; + y = n + floor(y-n); + q = recur( &y, x, &k, 0 ); + y = jvs(y,x) * q; + goto done; + } + + if( k <= 30.0 ) + { + k = 2.0; + } + else if( k < 90.0 ) + { + k = (3*k)/4; + } + if( an > (k + 3.0) ) + { + if( n < 0.0 ) + k = -k; + q = n - floor(n); + k = floor(k) + q; + if( n > 0.0 ) + q = recur( &n, x, &k, 1 ); + else + { + t = k; + k = n; + q = recur( &t, x, &k, 1 ); + k = t; + } + if( q == 0.0 ) + { +underf: + y = 0.0; + goto done; + } + } + else + { + k = n; + q = 1.0; + } + +/* boundary between convergence of + * power series and Hankel expansion + */ + y = fabs(k); + if( y < 26.0 ) + t = (0.0083*y + 0.09)*y + 12.9; + else + t = 0.9 * y; + + if( x > t ) + y = hankel(k,x); + else + y = jvs(k,x); +#if DEBUG +printf( "y = %.16e, recur q = %.16e\n", y, q ); +#endif + if( n > 0.0 ) + y /= q; + else + y *= q; + } + +else + { +/* For large n, use the uniform expansion + * or the transitional expansion. + * But if x is of the order of n**2, + * these may blow up, whereas the + * Hankel expansion will then work. + */ + if( n < 0.0 ) + { + mtherr( "Jv", TLOSS ); + y = 0.0; + goto done; + } + t = x/n; + t /= n; + if( t > 0.3 ) + y = hankel(n,x); + else + y = jnx(n,x); + } + +done: return( sign * y); +} + +/* Reduce the order by backward recurrence. + * AMS55 #9.1.27 and 9.1.73. + */ + +static double recur( n, x, newn, cancel ) +double *n; +double x; +double *newn; +int cancel; +{ +double pkm2, pkm1, pk, qkm2, qkm1; +/* double pkp1; */ +double k, ans, qk, xk, yk, r, t, kf; +static double big = BIG; +int nflag, ctr; + +/* continued fraction for Jn(x)/Jn-1(x) */ +if( *n < 0.0 ) + nflag = 1; +else + nflag = 0; + +fstart: + +#if DEBUG +printf( "recur: n = %.6e, newn = %.6e, cfrac = ", *n, *newn ); +#endif + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = x; +qkm1 = *n + *n; +xk = -x * x; +yk = qkm1; +ans = 1.0; +ctr = 0; +do + { + yk += 2.0; + pk = pkm1 * yk + pkm2 * xk; + qk = qkm1 * yk + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + if( qk != 0 ) + r = pk/qk; + else + r = 0.0; + if( r != 0 ) + { + t = fabs( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( ++ctr > 1000 ) + { + mtherr( "jv", UNDERFLOW ); + goto done; + } + if( t < MACHEP ) + goto done; + + if( fabs(pk) > big ) + { + pkm2 /= big; + pkm1 /= big; + qkm2 /= big; + qkm1 /= big; + } + } +while( t > MACHEP ); + +done: + +#if DEBUG +printf( "%.6e\n", ans ); +#endif + +/* Change n to n-1 if n < 0 and the continued fraction is small + */ +if( nflag > 0 ) + { + if( fabs(ans) < 0.125 ) + { + nflag = -1; + *n = *n - 1.0; + goto fstart; + } + } + + +kf = *newn; + +/* backward recurrence + * 2k + * J (x) = --- J (x) - J (x) + * k-1 x k k+1 + */ + +pk = 1.0; +pkm1 = 1.0/ans; +k = *n - 1.0; +r = 2 * k; +do + { + pkm2 = (pkm1 * r - pk * x) / x; + /* pkp1 = pk; */ + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; +/* + t = fabs(pkp1) + fabs(pk); + if( (k > (kf + 2.5)) && (fabs(pkm1) < 0.25*t) ) + { + k -= 1.0; + t = x*x; + pkm2 = ( (r*(r+2.0)-t)*pk - r*x*pkp1 )/t; + pkp1 = pk; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; + } +*/ + k -= 1.0; + } +while( k > (kf + 0.5) ); + +/* Take the larger of the last two iterates + * on the theory that it may have less cancellation error. + */ + +if( cancel ) + { + if( (kf >= 0.0) && (fabs(pk) > fabs(pkm1)) ) + { + k += 1.0; + pkm2 = pk; + } + } +*newn = k; +#if DEBUG +printf( "newn %.6e rans %.6e\n", k, pkm2 ); +#endif +return( pkm2 ); +} + + + +/* Ascending power series for Jv(x). + * AMS55 #9.1.10. + */ + +extern double PI; +extern int sgngam; + +static double jvs( n, x ) +double n, x; +{ +double t, u, y, z, k; +int ex; + +z = -x * x / 4.0; +u = 1.0; +y = u; +k = 1.0; +t = 1.0; + +while( t > MACHEP ) + { + u *= z / (k * (n+k)); + y += u; + k += 1.0; + if( y != 0 ) + t = fabs( u/y ); + } +#if DEBUG +printf( "power series=%.5e ", y ); +#endif +t = frexp( 0.5*x, &ex ); +ex = ex * n; +if( (ex > -1023) + && (ex < 1023) + && (n > 0.0) + && (n < (MAXGAM-1.0)) ) + { + t = pow( 0.5*x, n ) / gamma( n + 1.0 ); +#if DEBUG +printf( "pow(.5*x, %.4e)/gamma(n+1)=%.5e\n", n, t ); +#endif + y *= t; + } +else + { +#if DEBUG + z = n * log(0.5*x); + k = lgam( n+1.0 ); + t = z - k; + printf( "log pow=%.5e, lgam(%.4e)=%.5e\n", z, n+1.0, k ); +#else + t = n * log(0.5*x) - lgam(n + 1.0); +#endif + if( y < 0 ) + { + sgngam = -sgngam; + y = -y; + } + t += log(y); +#if DEBUG +printf( "log y=%.5e\n", log(y) ); +#endif + if( t < -MAXLOG ) + { + return( 0.0 ); + } + if( t > MAXLOG ) + { + mtherr( "Jv", OVERFLOW ); + return( MAXNUM ); + } + y = sgngam * exp( t ); + } +return(y); +} + +/* Hankel's asymptotic expansion + * for large x. + * AMS55 #9.2.5. + */ + +static double hankel( n, x ) +double n, x; +{ +double t, u, z, k, sign, conv; +double p, q, j, m, pp, qq; +int flag; + +m = 4.0*n*n; +j = 1.0; +z = 8.0 * x; +k = 1.0; +p = 1.0; +u = (m - 1.0)/z; +q = u; +sign = 1.0; +conv = 1.0; +flag = 0; +t = 1.0; +pp = 1.0e38; +qq = 1.0e38; + +while( t > MACHEP ) + { + k += 2.0; + j += 1.0; + sign = -sign; + u *= (m - k * k)/(j * z); + p += sign * u; + k += 2.0; + j += 1.0; + u *= (m - k * k)/(j * z); + q += sign * u; + t = fabs(u/p); + if( t < conv ) + { + conv = t; + qq = q; + pp = p; + flag = 1; + } +/* stop if the terms start getting larger */ + if( (flag != 0) && (t > conv) ) + { +#if DEBUG + printf( "Hankel: convergence to %.4E\n", conv ); +#endif + goto hank1; + } + } + +hank1: +u = x - (0.5*n + 0.25) * PI; +t = sqrt( 2.0/(PI*x) ) * ( pp * cos(u) - qq * sin(u) ); +#if DEBUG +printf( "hank: %.6e\n", t ); +#endif +return( t ); +} + + +/* Asymptotic expansion for large n. + * AMS55 #9.3.35. + */ + +static double lambda[] = { + 1.0, + 1.041666666666666666666667E-1, + 8.355034722222222222222222E-2, + 1.282265745563271604938272E-1, + 2.918490264641404642489712E-1, + 8.816272674437576524187671E-1, + 3.321408281862767544702647E+0, + 1.499576298686255465867237E+1, + 7.892301301158651813848139E+1, + 4.744515388682643231611949E+2, + 3.207490090890661934704328E+3 +}; +static double mu[] = { + 1.0, + -1.458333333333333333333333E-1, + -9.874131944444444444444444E-2, + -1.433120539158950617283951E-1, + -3.172272026784135480967078E-1, + -9.424291479571202491373028E-1, + -3.511203040826354261542798E+0, + -1.572726362036804512982712E+1, + -8.228143909718594444224656E+1, + -4.923553705236705240352022E+2, + -3.316218568547972508762102E+3 +}; +static double P1[] = { + -2.083333333333333333333333E-1, + 1.250000000000000000000000E-1 +}; +static double P2[] = { + 3.342013888888888888888889E-1, + -4.010416666666666666666667E-1, + 7.031250000000000000000000E-2 +}; +static double P3[] = { + -1.025812596450617283950617E+0, + 1.846462673611111111111111E+0, + -8.912109375000000000000000E-1, + 7.324218750000000000000000E-2 +}; +static double P4[] = { + 4.669584423426247427983539E+0, + -1.120700261622299382716049E+1, + 8.789123535156250000000000E+0, + -2.364086914062500000000000E+0, + 1.121520996093750000000000E-1 +}; +static double P5[] = { + -2.8212072558200244877E1, + 8.4636217674600734632E1, + -9.1818241543240017361E1, + 4.2534998745388454861E1, + -7.3687943594796316964E0, + 2.27108001708984375E-1 +}; +static double P6[] = { + 2.1257013003921712286E2, + -7.6525246814118164230E2, + 1.0599904525279998779E3, + -6.9957962737613254123E2, + 2.1819051174421159048E2, + -2.6491430486951555525E1, + 5.7250142097473144531E-1 +}; +static double P7[] = { + -1.9194576623184069963E3, + 8.0617221817373093845E3, + -1.3586550006434137439E4, + 1.1655393336864533248E4, + -5.3056469786134031084E3, + 1.2009029132163524628E3, + -1.0809091978839465550E2, + 1.7277275025844573975E0 +}; + + +static double jnx( n, x ) +double n, x; +{ +double zeta, sqz, zz, zp, np; +double cbn, n23, t, z, sz; +double pp, qq, z32i, zzi; +double ak, bk, akl, bkl; +int sign, doa, dob, nflg, k, s, tk, tkp1, m; +static double u[8]; +static double ai, aip, bi, bip; + +/* Test for x very close to n. + * Use expansion for transition region if so. + */ +cbn = cbrt(n); +z = (x - n)/cbn; +if( fabs(z) <= 0.7 ) + return( jnt(n,x) ); + +z = x/n; +zz = 1.0 - z*z; +if( zz == 0.0 ) + return(0.0); + +if( zz > 0.0 ) + { + sz = sqrt( zz ); + t = 1.5 * (log( (1.0+sz)/z ) - sz ); /* zeta ** 3/2 */ + zeta = cbrt( t * t ); + nflg = 1; + } +else + { + sz = sqrt(-zz); + t = 1.5 * (sz - acos(1.0/z)); + zeta = -cbrt( t * t ); + nflg = -1; + } +z32i = fabs(1.0/t); +sqz = cbrt(t); + +/* Airy function */ +n23 = cbrt( n * n ); +t = n23 * zeta; + +#if DEBUG +printf("zeta %.5E, Airy(%.5E)\n", zeta, t ); +#endif +airy( t, &ai, &aip, &bi, &bip ); + +/* polynomials in expansion */ +u[0] = 1.0; +zzi = 1.0/zz; +u[1] = polevl( zzi, P1, 1 )/sz; +u[2] = polevl( zzi, P2, 2 )/zz; +u[3] = polevl( zzi, P3, 3 )/(sz*zz); +pp = zz*zz; +u[4] = polevl( zzi, P4, 4 )/pp; +u[5] = polevl( zzi, P5, 5 )/(pp*sz); +pp *= zz; +u[6] = polevl( zzi, P6, 6 )/pp; +u[7] = polevl( zzi, P7, 7 )/(pp*sz); + +#if DEBUG +for( k=0; k<=7; k++ ) + printf( "u[%d] = %.5E\n", k, u[k] ); +#endif + +pp = 0.0; +qq = 0.0; +np = 1.0; +/* flags to stop when terms get larger */ +doa = 1; +dob = 1; +akl = MAXNUM; +bkl = MAXNUM; + +for( k=0; k<=3; k++ ) + { + tk = 2 * k; + tkp1 = tk + 1; + zp = 1.0; + ak = 0.0; + bk = 0.0; + for( s=0; s<=tk; s++ ) + { + if( doa ) + { + if( (s & 3) > 1 ) + sign = nflg; + else + sign = 1; + ak += sign * mu[s] * zp * u[tk-s]; + } + + if( dob ) + { + m = tkp1 - s; + if( ((m+1) & 3) > 1 ) + sign = nflg; + else + sign = 1; + bk += sign * lambda[s] * zp * u[m]; + } + zp *= z32i; + } + + if( doa ) + { + ak *= np; + t = fabs(ak); + if( t < akl ) + { + akl = t; + pp += ak; + } + else + doa = 0; + } + + if( dob ) + { + bk += lambda[tkp1] * zp * u[0]; + bk *= -np/sqz; + t = fabs(bk); + if( t < bkl ) + { + bkl = t; + qq += bk; + } + else + dob = 0; + } +#if DEBUG + printf("a[%d] %.5E, b[%d] %.5E\n", k, ak, k, bk ); +#endif + if( np < MACHEP ) + break; + np /= n*n; + } + +/* normalizing factor ( 4*zeta/(1 - z**2) )**1/4 */ +t = 4.0 * zeta/zz; +t = sqrt( sqrt(t) ); + +t *= ai*pp/cbrt(n) + aip*qq/(n23*n); +return(t); +} + +/* Asymptotic expansion for transition region, + * n large and x close to n. + * AMS55 #9.3.23. + */ + +static double PF2[] = { + -9.0000000000000000000e-2, + 8.5714285714285714286e-2 +}; +static double PF3[] = { + 1.3671428571428571429e-1, + -5.4920634920634920635e-2, + -4.4444444444444444444e-3 +}; +static double PF4[] = { + 1.3500000000000000000e-3, + -1.6036054421768707483e-1, + 4.2590187590187590188e-2, + 2.7330447330447330447e-3 +}; +static double PG1[] = { + -2.4285714285714285714e-1, + 1.4285714285714285714e-2 +}; +static double PG2[] = { + -9.0000000000000000000e-3, + 1.9396825396825396825e-1, + -1.1746031746031746032e-2 +}; +static double PG3[] = { + 1.9607142857142857143e-2, + -1.5983694083694083694e-1, + 6.3838383838383838384e-3 +}; + + +static double jnt( n, x ) +double n, x; +{ +double z, zz, z3; +double cbn, n23, cbtwo; +double ai, aip, bi, bip; /* Airy functions */ +double nk, fk, gk, pp, qq; +double F[5], G[4]; +int k; + +cbn = cbrt(n); +z = (x - n)/cbn; +cbtwo = cbrt( 2.0 ); + +/* Airy function */ +zz = -cbtwo * z; +airy( zz, &ai, &aip, &bi, &bip ); + +/* polynomials in expansion */ +zz = z * z; +z3 = zz * z; +F[0] = 1.0; +F[1] = -z/5.0; +F[2] = polevl( z3, PF2, 1 ) * zz; +F[3] = polevl( z3, PF3, 2 ); +F[4] = polevl( z3, PF4, 3 ) * z; +G[0] = 0.3 * zz; +G[1] = polevl( z3, PG1, 1 ); +G[2] = polevl( z3, PG2, 2 ) * z; +G[3] = polevl( z3, PG3, 2 ) * zz; +#if DEBUG +for( k=0; k<=4; k++ ) + printf( "F[%d] = %.5E\n", k, F[k] ); +for( k=0; k<=3; k++ ) + printf( "G[%d] = %.5E\n", k, G[k] ); +#endif +pp = 0.0; +qq = 0.0; +nk = 1.0; +n23 = cbrt( n * n ); + +for( k=0; k<=4; k++ ) + { + fk = F[k]*nk; + pp += fk; + if( k != 4 ) + { + gk = G[k]*nk; + qq += gk; + } +#if DEBUG + printf("fk[%d] %.5E, gk[%d] %.5E\n", k, fk, k, gk ); +#endif + nk /= n23; + } + +fk = cbtwo * ai * pp/cbn + cbrt(4.0) * aip * qq/n; +return(fk); +} diff --git a/libm/double/k0.c b/libm/double/k0.c new file mode 100644 index 000000000..7d09cb4a1 --- /dev/null +++ b/libm/double/k0.c @@ -0,0 +1,333 @@ +/* k0.c + * + * Modified Bessel function, third kind, order zero + * + * + * + * SYNOPSIS: + * + * double x, y, k0(); + * + * y = k0( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order zero of the argument. + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Tested at 2000 random points between 0 and 8. Peak absolute + * error (relative when K0 > 1) was 1.46e-14; rms, 4.26e-15. + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3100 1.3e-16 2.1e-17 + * IEEE 0, 30 30000 1.2e-15 1.6e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * K0 domain x <= 0 MAXNUM + * + */ + /* k0e() + * + * Modified Bessel function, third kind, order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, k0e(); + * + * y = k0e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order zero of the argument. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 1.4e-15 1.4e-16 + * See k0(). + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Chebyshev coefficients for K0(x) + log(x/2) I0(x) + * in the interval [0,2]. The odd order coefficients are all + * zero; only the even order coefficients are listed. + * + * lim(x->0){ K0(x) + log(x/2) I0(x) } = -EUL. + */ + +#ifdef UNK +static double A[] = +{ + 1.37446543561352307156E-16, + 4.25981614279661018399E-14, + 1.03496952576338420167E-11, + 1.90451637722020886025E-9, + 2.53479107902614945675E-7, + 2.28621210311945178607E-5, + 1.26461541144692592338E-3, + 3.59799365153615016266E-2, + 3.44289899924628486886E-1, +-5.35327393233902768720E-1 +}; +#endif + +#ifdef DEC +static unsigned short A[] = { +0023036,0073417,0032477,0165673, +0025077,0154126,0016046,0012517, +0027066,0011342,0035211,0005041, +0031002,0160233,0037454,0050224, +0032610,0012747,0037712,0173741, +0034277,0144007,0172147,0162375, +0035645,0140563,0125431,0165626, +0037023,0057662,0125124,0102051, +0037660,0043304,0004411,0166707, +0140011,0005467,0047227,0130370 +}; +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0xfd77,0xe6a7,0xcee1,0x3ca3, +0xc2aa,0xc384,0xfb0a,0x3d27, +0x2144,0x4751,0xc25c,0x3da6, +0x8a13,0x67e5,0x5c13,0x3e20, +0x5efc,0xe7f9,0x02bc,0x3e91, +0xfca0,0xfe8c,0xf900,0x3ef7, +0x3d73,0x7563,0xb82e,0x3f54, +0x9085,0x554a,0x6bf6,0x3fa2, +0x3db9,0x8121,0x08d8,0x3fd6, +0xf61f,0xe9d2,0x2166,0xbfe1 +}; +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0x3ca3,0xcee1,0xe6a7,0xfd77, +0x3d27,0xfb0a,0xc384,0xc2aa, +0x3da6,0xc25c,0x4751,0x2144, +0x3e20,0x5c13,0x67e5,0x8a13, +0x3e91,0x02bc,0xe7f9,0x5efc, +0x3ef7,0xf900,0xfe8c,0xfca0, +0x3f54,0xb82e,0x7563,0x3d73, +0x3fa2,0x6bf6,0x554a,0x9085, +0x3fd6,0x08d8,0x8121,0x3db9, +0xbfe1,0x2166,0xe9d2,0xf61f +}; +#endif + + + +/* Chebyshev coefficients for exp(x) sqrt(x) K0(x) + * in the inverted interval [2,infinity]. + * + * lim(x->inf){ exp(x) sqrt(x) K0(x) } = sqrt(pi/2). + */ + +#ifdef UNK +static double B[] = { + 5.30043377268626276149E-18, +-1.64758043015242134646E-17, + 5.21039150503902756861E-17, +-1.67823109680541210385E-16, + 5.51205597852431940784E-16, +-1.84859337734377901440E-15, + 6.34007647740507060557E-15, +-2.22751332699166985548E-14, + 8.03289077536357521100E-14, +-2.98009692317273043925E-13, + 1.14034058820847496303E-12, +-4.51459788337394416547E-12, + 1.85594911495471785253E-11, +-7.95748924447710747776E-11, + 3.57739728140030116597E-10, +-1.69753450938905987466E-9, + 8.57403401741422608519E-9, +-4.66048989768794782956E-8, + 2.76681363944501510342E-7, +-1.83175552271911948767E-6, + 1.39498137188764993662E-5, +-1.28495495816278026384E-4, + 1.56988388573005337491E-3, +-3.14481013119645005427E-2, + 2.44030308206595545468E0 +}; +#endif + +#ifdef DEC +static unsigned short B[] = { +0021703,0106456,0076144,0173406, +0122227,0173144,0116011,0030033, +0022560,0044562,0006506,0067642, +0123101,0076243,0123273,0131013, +0023436,0157713,0056243,0141331, +0124005,0032207,0063726,0164664, +0024344,0066342,0051756,0162300, +0124710,0121365,0154053,0077022, +0025264,0161166,0066246,0077420, +0125647,0141671,0006443,0103212, +0026240,0076431,0077147,0160445, +0126636,0153741,0174002,0105031, +0027243,0040102,0035375,0163073, +0127656,0176256,0113476,0044653, +0030304,0125544,0006377,0130104, +0130751,0047257,0110537,0127324, +0031423,0046400,0014772,0012164, +0132110,0025240,0155247,0112570, +0032624,0105314,0007437,0021574, +0133365,0155243,0174306,0116506, +0034152,0004776,0061643,0102504, +0135006,0136277,0036104,0175023, +0035715,0142217,0162474,0115022, +0137000,0147671,0065177,0134356, +0040434,0026754,0175163,0044070 +}; +#endif + +#ifdef IBMPC +static unsigned short B[] = { +0x9ee1,0xcf8c,0x71a5,0x3c58, +0x2603,0x9381,0xfecc,0xbc72, +0xcdf4,0x41a8,0x092e,0x3c8e, +0x7641,0x74d7,0x2f94,0xbca8, +0x785b,0x6b94,0xdbf9,0x3cc3, +0xdd36,0xecfa,0xa690,0xbce0, +0xdc98,0x4a7d,0x8d9c,0x3cfc, +0x6fc2,0xbb05,0x145e,0xbd19, +0xcfe2,0xcd94,0x9c4e,0x3d36, +0x70d1,0x21a4,0xf877,0xbd54, +0xfc25,0x2fcc,0x0fa3,0x3d74, +0x5143,0x3f00,0xdafc,0xbd93, +0xbcc7,0x475f,0x6808,0x3db4, +0xc935,0xd2e7,0xdf95,0xbdd5, +0xf608,0x819f,0x956c,0x3df8, +0xf5db,0xf22b,0x29d5,0xbe1d, +0x428e,0x033f,0x69a0,0x3e42, +0xf2af,0x1b54,0x0554,0xbe69, +0xe46f,0x81e3,0x9159,0x3e92, +0xd3a9,0x7f18,0xbb54,0xbebe, +0x70a9,0xcc74,0x413f,0x3eed, +0x9f42,0xe788,0xd797,0xbf20, +0x9342,0xfca7,0xb891,0x3f59, +0xf71e,0x2d4f,0x19f7,0xbfa0, +0x6907,0x9f4e,0x85bd,0x4003 +}; +#endif + +#ifdef MIEEE +static unsigned short B[] = { +0x3c58,0x71a5,0xcf8c,0x9ee1, +0xbc72,0xfecc,0x9381,0x2603, +0x3c8e,0x092e,0x41a8,0xcdf4, +0xbca8,0x2f94,0x74d7,0x7641, +0x3cc3,0xdbf9,0x6b94,0x785b, +0xbce0,0xa690,0xecfa,0xdd36, +0x3cfc,0x8d9c,0x4a7d,0xdc98, +0xbd19,0x145e,0xbb05,0x6fc2, +0x3d36,0x9c4e,0xcd94,0xcfe2, +0xbd54,0xf877,0x21a4,0x70d1, +0x3d74,0x0fa3,0x2fcc,0xfc25, +0xbd93,0xdafc,0x3f00,0x5143, +0x3db4,0x6808,0x475f,0xbcc7, +0xbdd5,0xdf95,0xd2e7,0xc935, +0x3df8,0x956c,0x819f,0xf608, +0xbe1d,0x29d5,0xf22b,0xf5db, +0x3e42,0x69a0,0x033f,0x428e, +0xbe69,0x0554,0x1b54,0xf2af, +0x3e92,0x9159,0x81e3,0xe46f, +0xbebe,0xbb54,0x7f18,0xd3a9, +0x3eed,0x413f,0xcc74,0x70a9, +0xbf20,0xd797,0xe788,0x9f42, +0x3f59,0xb891,0xfca7,0x9342, +0xbfa0,0x19f7,0x2d4f,0xf71e, +0x4003,0x85bd,0x9f4e,0x6907 +}; +#endif + +/* k0.c */ +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double exp ( double ); +extern double i0 ( double ); +extern double log ( double ); +extern double sqrt ( double ); +#else +double chbevl(), exp(), i0(), log(), sqrt(); +#endif +extern double PI; +extern double MAXNUM; + +double k0(x) +double x; +{ +double y, z; + +if( x <= 0.0 ) + { + mtherr( "k0", DOMAIN ); + return( MAXNUM ); + } + +if( x <= 2.0 ) + { + y = x * x - 2.0; + y = chbevl( y, A, 10 ) - log( 0.5 * x ) * i0(x); + return( y ); + } +z = 8.0/x - 2.0; +y = exp(-x) * chbevl( z, B, 25 ) / sqrt(x); +return(y); +} + + + + +double k0e( x ) +double x; +{ +double y; + +if( x <= 0.0 ) + { + mtherr( "k0e", DOMAIN ); + return( MAXNUM ); + } + +if( x <= 2.0 ) + { + y = x * x - 2.0; + y = chbevl( y, A, 10 ) - log( 0.5 * x ) * i0(x); + return( y * exp(x) ); + } + +y = chbevl( 8.0/x - 2.0, B, 25 ) / sqrt(x); +return(y); +} diff --git a/libm/double/k1.c b/libm/double/k1.c new file mode 100644 index 000000000..a96305355 --- /dev/null +++ b/libm/double/k1.c @@ -0,0 +1,335 @@ +/* k1.c + * + * Modified Bessel function, third kind, order one + * + * + * + * SYNOPSIS: + * + * double x, y, k1(); + * + * y = k1( x ); + * + * + * + * DESCRIPTION: + * + * Computes the modified Bessel function of the third kind + * of order one of the argument. + * + * The range is partitioned into the two intervals [0,2] and + * (2, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 30 3300 8.9e-17 2.2e-17 + * IEEE 0, 30 30000 1.2e-15 1.6e-16 + * + * ERROR MESSAGES: + * + * message condition value returned + * k1 domain x <= 0 MAXNUM + * + */ + /* k1e.c + * + * Modified Bessel function, third kind, order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * double x, y, k1e(); + * + * y = k1e( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order one of the argument: + * + * k1e(x) = exp(x) * k1(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 7.8e-16 1.2e-16 + * See k1(). + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Chebyshev coefficients for x(K1(x) - log(x/2) I1(x)) + * in the interval [0,2]. + * + * lim(x->0){ x(K1(x) - log(x/2) I1(x)) } = 1. + */ + +#ifdef UNK +static double A[] = +{ +-7.02386347938628759343E-18, +-2.42744985051936593393E-15, +-6.66690169419932900609E-13, +-1.41148839263352776110E-10, +-2.21338763073472585583E-8, +-2.43340614156596823496E-6, +-1.73028895751305206302E-4, +-6.97572385963986435018E-3, +-1.22611180822657148235E-1, +-3.53155960776544875667E-1, + 1.52530022733894777053E0 +}; +#endif + +#ifdef DEC +static unsigned short A[] = { +0122001,0110501,0164746,0151255, +0124056,0165213,0150034,0147377, +0126073,0124026,0167207,0001044, +0130033,0030735,0141061,0033116, +0131676,0020350,0121341,0107175, +0133443,0046631,0062031,0070716, +0135065,0067427,0026435,0164022, +0136344,0112234,0165752,0006222, +0137373,0015622,0017016,0155636, +0137664,0150333,0125730,0067240, +0040303,0036411,0130200,0043120 +}; +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0xda56,0x3d3c,0x3228,0xbc60, +0x99e0,0x7a03,0xdd51,0xbce5, +0xe045,0xddd0,0x7502,0xbd67, +0x26ca,0xb846,0x663b,0xbde3, +0x31d0,0x145c,0xc41d,0xbe57, +0x2e3a,0x2c83,0x69b3,0xbec4, +0xbd02,0xe5a3,0xade2,0xbf26, +0x4192,0x9d7d,0x9293,0xbf7c, +0xdb74,0x43c1,0x6372,0xbfbf, +0x0dd4,0x757b,0x9a1b,0xbfd6, +0x08ca,0x3610,0x67a1,0x3ff8 +}; +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0xbc60,0x3228,0x3d3c,0xda56, +0xbce5,0xdd51,0x7a03,0x99e0, +0xbd67,0x7502,0xddd0,0xe045, +0xbde3,0x663b,0xb846,0x26ca, +0xbe57,0xc41d,0x145c,0x31d0, +0xbec4,0x69b3,0x2c83,0x2e3a, +0xbf26,0xade2,0xe5a3,0xbd02, +0xbf7c,0x9293,0x9d7d,0x4192, +0xbfbf,0x6372,0x43c1,0xdb74, +0xbfd6,0x9a1b,0x757b,0x0dd4, +0x3ff8,0x67a1,0x3610,0x08ca +}; +#endif + + + +/* Chebyshev coefficients for exp(x) sqrt(x) K1(x) + * in the interval [2,infinity]. + * + * lim(x->inf){ exp(x) sqrt(x) K1(x) } = sqrt(pi/2). + */ + +#ifdef UNK +static double B[] = +{ +-5.75674448366501715755E-18, + 1.79405087314755922667E-17, +-5.68946255844285935196E-17, + 1.83809354436663880070E-16, +-6.05704724837331885336E-16, + 2.03870316562433424052E-15, +-7.01983709041831346144E-15, + 2.47715442448130437068E-14, +-8.97670518232499435011E-14, + 3.34841966607842919884E-13, +-1.28917396095102890680E-12, + 5.13963967348173025100E-12, +-2.12996783842756842877E-11, + 9.21831518760500529508E-11, +-4.19035475934189648750E-10, + 2.01504975519703286596E-9, +-1.03457624656780970260E-8, + 5.74108412545004946722E-8, +-3.50196060308781257119E-7, + 2.40648494783721712015E-6, +-1.93619797416608296024E-5, + 1.95215518471351631108E-4, +-2.85781685962277938680E-3, + 1.03923736576817238437E-1, + 2.72062619048444266945E0 +}; +#endif + +#ifdef DEC +static unsigned short B[] = { +0121724,0061352,0013041,0150076, +0022245,0074324,0016172,0173232, +0122603,0030250,0135670,0165221, +0023123,0165362,0023561,0060124, +0123456,0112436,0141654,0073623, +0024022,0163557,0077564,0006753, +0124374,0165221,0131014,0026524, +0024737,0017512,0144250,0175451, +0125312,0021456,0123136,0076633, +0025674,0077720,0020125,0102607, +0126265,0067543,0007744,0043701, +0026664,0152702,0033002,0074202, +0127273,0055234,0120016,0071733, +0027712,0133200,0042441,0075515, +0130346,0057000,0015456,0074470, +0031012,0074441,0051636,0111155, +0131461,0136444,0177417,0002101, +0032166,0111743,0032176,0021410, +0132674,0001224,0076555,0027060, +0033441,0077430,0135226,0106663, +0134242,0065610,0167155,0113447, +0035114,0131304,0043664,0102163, +0136073,0045065,0171465,0122123, +0037324,0152767,0147401,0017732, +0040456,0017275,0050061,0062120, +}; +#endif + +#ifdef IBMPC +static unsigned short B[] = { +0x3a08,0x42c4,0x8c5d,0xbc5a, +0x5ed3,0x838f,0xaf1a,0x3c74, +0x1d52,0x1777,0x6615,0xbc90, +0x2c0b,0x44ee,0x7d5e,0x3caa, +0x8ef2,0xd875,0xd2a3,0xbcc5, +0x81bd,0xefee,0x5ced,0x3ce2, +0x85ab,0x3641,0x9d52,0xbcff, +0x1f65,0x5915,0xe3e9,0x3d1b, +0xcfb3,0xd4cb,0x4465,0xbd39, +0xb0b1,0x040a,0x8ffa,0x3d57, +0x88f8,0x61fc,0xadec,0xbd76, +0x4f10,0x46c0,0x9ab8,0x3d96, +0xce7b,0x9401,0x6b53,0xbdb7, +0x2f6a,0x08a4,0x56d0,0x3dd9, +0xcf27,0x0365,0xcbc0,0xbdfc, +0xd24e,0x2a73,0x4f24,0x3e21, +0xe088,0x9fe1,0x37a4,0xbe46, +0xc461,0x668f,0xd27c,0x3e6e, +0xa5c6,0x8fad,0x8052,0xbe97, +0xd1b6,0x1752,0x2fe3,0x3ec4, +0xb2e5,0x1dcd,0x4d71,0xbef4, +0x908e,0x88f6,0x9658,0x3f29, +0xb48a,0xbe66,0x6946,0xbf67, +0x23fb,0xf9e0,0x9abe,0x3fba, +0x2c8a,0xaa06,0xc3d7,0x4005 +}; +#endif + +#ifdef MIEEE +static unsigned short B[] = { +0xbc5a,0x8c5d,0x42c4,0x3a08, +0x3c74,0xaf1a,0x838f,0x5ed3, +0xbc90,0x6615,0x1777,0x1d52, +0x3caa,0x7d5e,0x44ee,0x2c0b, +0xbcc5,0xd2a3,0xd875,0x8ef2, +0x3ce2,0x5ced,0xefee,0x81bd, +0xbcff,0x9d52,0x3641,0x85ab, +0x3d1b,0xe3e9,0x5915,0x1f65, +0xbd39,0x4465,0xd4cb,0xcfb3, +0x3d57,0x8ffa,0x040a,0xb0b1, +0xbd76,0xadec,0x61fc,0x88f8, +0x3d96,0x9ab8,0x46c0,0x4f10, +0xbdb7,0x6b53,0x9401,0xce7b, +0x3dd9,0x56d0,0x08a4,0x2f6a, +0xbdfc,0xcbc0,0x0365,0xcf27, +0x3e21,0x4f24,0x2a73,0xd24e, +0xbe46,0x37a4,0x9fe1,0xe088, +0x3e6e,0xd27c,0x668f,0xc461, +0xbe97,0x8052,0x8fad,0xa5c6, +0x3ec4,0x2fe3,0x1752,0xd1b6, +0xbef4,0x4d71,0x1dcd,0xb2e5, +0x3f29,0x9658,0x88f6,0x908e, +0xbf67,0x6946,0xbe66,0xb48a, +0x3fba,0x9abe,0xf9e0,0x23fb, +0x4005,0xc3d7,0xaa06,0x2c8a +}; +#endif + +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double exp ( double ); +extern double i1 ( double ); +extern double log ( double ); +extern double sqrt ( double ); +#else +double chbevl(), exp(), i1(), log(), sqrt(); +#endif +extern double PI; +extern double MINLOG, MAXNUM; + +double k1(x) +double x; +{ +double y, z; + +z = 0.5 * x; +if( z <= 0.0 ) + { + mtherr( "k1", DOMAIN ); + return( MAXNUM ); + } + +if( x <= 2.0 ) + { + y = x * x - 2.0; + y = log(z) * i1(x) + chbevl( y, A, 11 ) / x; + return( y ); + } + +return( exp(-x) * chbevl( 8.0/x - 2.0, B, 25 ) / sqrt(x) ); +} + + + + +double k1e( x ) +double x; +{ +double y; + +if( x <= 0.0 ) + { + mtherr( "k1e", DOMAIN ); + return( MAXNUM ); + } + +if( x <= 2.0 ) + { + y = x * x - 2.0; + y = log( 0.5 * x ) * i1(x) + chbevl( y, A, 11 ) / x; + return( y * exp(x) ); + } + +return( chbevl( 8.0/x - 2.0, B, 25 ) / sqrt(x) ); +} diff --git a/libm/double/kn.c b/libm/double/kn.c new file mode 100644 index 000000000..72a1c1a53 --- /dev/null +++ b/libm/double/kn.c @@ -0,0 +1,255 @@ +/* kn.c + * + * Modified Bessel function, third kind, integer order + * + * + * + * SYNOPSIS: + * + * double x, y, kn(); + * int n; + * + * y = kn( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order n of the argument. + * + * The range is partitioned into the two intervals [0,9.55] and + * (9.55, infinity). An ascending power series is used in the + * low range, and an asymptotic expansion in the high range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,30 3000 1.3e-9 5.8e-11 + * IEEE 0,30 90000 1.8e-8 3.0e-10 + * + * Error is high only near the crossover point x = 9.55 + * between the two expansions used. + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 2000 by Stephen L. Moshier +*/ + + +/* +Algorithm for Kn. + n-1 + -n - (n-k-1)! 2 k +K (x) = 0.5 (x/2) > -------- (-x /4) + n - k! + k=0 + + inf. 2 k + n n - (x /4) + + (-1) 0.5(x/2) > {p(k+1) + p(n+k+1) - 2log(x/2)} --------- + - k! (n+k)! + k=0 + +where p(m) is the psi function: p(1) = -EUL and + + m-1 + - + p(m) = -EUL + > 1/k + - + k=1 + +For large x, + 2 2 2 + u-1 (u-1 )(u-3 ) +K (z) = sqrt(pi/2z) exp(-z) { 1 + ------- + ------------ + ...} + v 1 2 + 1! (8z) 2! (8z) +asymptotically, where + + 2 + u = 4 v . + +*/ + +#include <math.h> + +#define EUL 5.772156649015328606065e-1 +#define MAXFAC 31 +#ifdef ANSIPROT +extern double fabs ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double sqrt ( double ); +#else +double fabs(), exp(), log(), sqrt(); +#endif +extern double MACHEP, MAXNUM, MAXLOG, PI; + +double kn( nn, x ) +int nn; +double x; +{ +double k, kf, nk1f, nkf, zn, t, s, z0, z; +double ans, fn, pn, pk, zmn, tlg, tox; +int i, n; + +if( nn < 0 ) + n = -nn; +else + n = nn; + +if( n > MAXFAC ) + { +overf: + mtherr( "kn", OVERFLOW ); + return( MAXNUM ); + } + +if( x <= 0.0 ) + { + if( x < 0.0 ) + mtherr( "kn", DOMAIN ); + else + mtherr( "kn", SING ); + return( MAXNUM ); + } + + +if( x > 9.55 ) + goto asymp; + +ans = 0.0; +z0 = 0.25 * x * x; +fn = 1.0; +pn = 0.0; +zmn = 1.0; +tox = 2.0/x; + +if( n > 0 ) + { + /* compute factorial of n and psi(n) */ + pn = -EUL; + k = 1.0; + for( i=1; i<n; i++ ) + { + pn += 1.0/k; + k += 1.0; + fn *= k; + } + + zmn = tox; + + if( n == 1 ) + { + ans = 1.0/x; + } + else + { + nk1f = fn/n; + kf = 1.0; + s = nk1f; + z = -z0; + zn = 1.0; + for( i=1; i<n; i++ ) + { + nk1f = nk1f/(n-i); + kf = kf * i; + zn *= z; + t = nk1f * zn / kf; + s += t; + if( (MAXNUM - fabs(t)) < fabs(s) ) + goto overf; + if( (tox > 1.0) && ((MAXNUM/tox) < zmn) ) + goto overf; + zmn *= tox; + } + s *= 0.5; + t = fabs(s); + if( (zmn > 1.0) && ((MAXNUM/zmn) < t) ) + goto overf; + if( (t > 1.0) && ((MAXNUM/t) < zmn) ) + goto overf; + ans = s * zmn; + } + } + + +tlg = 2.0 * log( 0.5 * x ); +pk = -EUL; +if( n == 0 ) + { + pn = pk; + t = 1.0; + } +else + { + pn = pn + 1.0/n; + t = 1.0/fn; + } +s = (pk+pn-tlg)*t; +k = 1.0; +do + { + t *= z0 / (k * (k+n)); + pk += 1.0/k; + pn += 1.0/(k+n); + s += (pk+pn-tlg)*t; + k += 1.0; + } +while( fabs(t/s) > MACHEP ); + +s = 0.5 * s / zmn; +if( n & 1 ) + s = -s; +ans += s; + +return(ans); + + + +/* Asymptotic expansion for Kn(x) */ +/* Converges to 1.4e-17 for x > 18.4 */ + +asymp: + +if( x > MAXLOG ) + { + mtherr( "kn", UNDERFLOW ); + return(0.0); + } +k = n; +pn = 4.0 * k * k; +pk = 1.0; +z0 = 8.0 * x; +fn = 1.0; +t = 1.0; +s = t; +nkf = MAXNUM; +i = 0; +do + { + z = pn - pk * pk; + t = t * z /(fn * z0); + nk1f = fabs(t); + if( (i >= n) && (nk1f > nkf) ) + { + goto adone; + } + nkf = nk1f; + s += t; + fn += 1.0; + pk += 2.0; + i += 1; + } +while( fabs(t/s) > MACHEP ); + +adone: +ans = exp(-x) * sqrt( PI/(2.0*x) ) * s; +return(ans); +} diff --git a/libm/double/kolmogorov.c b/libm/double/kolmogorov.c new file mode 100644 index 000000000..0d6fe92bd --- /dev/null +++ b/libm/double/kolmogorov.c @@ -0,0 +1,243 @@ + +/* Re Kolmogorov statistics, here is Birnbaum and Tingey's formula for the + distribution of D+, the maximum of all positive deviations between a + theoretical distribution function P(x) and an empirical one Sn(x) + from n samples. + + + + D = sup [P(x) - S (x)] + n -inf < x < inf n + + + [n(1-e)] + + - v-1 n-v + Pr{D > e} = > C e (e + v/n) (1 - e - v/n) + n - n v + v=0 + + [n(1-e)] is the largest integer not exceeding n(1-e). + nCv is the number of combinations of n things taken v at a time. */ + + +#include <math.h> +#ifdef ANSIPROT +extern double pow ( double, double ); +extern double floor ( double ); +extern double lgam ( double ); +extern double exp ( double ); +extern double sqrt ( double ); +extern double log ( double ); +extern double fabs ( double ); +double smirnov ( int, double ); +double kolmogorov ( double ); +#else +double pow (), floor (), lgam (), exp (), sqrt (), log (), fabs (); +double smirnov (), kolmogorov (); +#endif +extern double MAXLOG; + +/* Exact Smirnov statistic, for one-sided test. */ +double +smirnov (n, e) + int n; + double e; +{ + int v, nn; + double evn, omevn, p, t, c, lgamnp1; + + if (n <= 0 || e < 0.0 || e > 1.0) + return (-1.0); + nn = floor ((double) n * (1.0 - e)); + p = 0.0; + if (n < 1013) + { + c = 1.0; + for (v = 0; v <= nn; v++) + { + evn = e + ((double) v) / n; + p += c * pow (evn, (double) (v - 1)) + * pow (1.0 - evn, (double) (n - v)); + /* Next combinatorial term; worst case error = 4e-15. */ + c *= ((double) (n - v)) / (v + 1); + } + } + else + { + lgamnp1 = lgam ((double) (n + 1)); + for (v = 0; v <= nn; v++) + { + evn = e + ((double) v) / n; + omevn = 1.0 - evn; + if (fabs (omevn) > 0.0) + { + t = lgamnp1 + - lgam ((double) (v + 1)) + - lgam ((double) (n - v + 1)) + + (v - 1) * log (evn) + + (n - v) * log (omevn); + if (t > -MAXLOG) + p += exp (t); + } + } + } + return (p * e); +} + + +/* Kolmogorov's limiting distribution of two-sided test, returns + probability that sqrt(n) * max deviation > y, + or that max deviation > y/sqrt(n). + The approximation is useful for the tail of the distribution + when n is large. */ +double +kolmogorov (y) + double y; +{ + double p, t, r, sign, x; + + x = -2.0 * y * y; + sign = 1.0; + p = 0.0; + r = 1.0; + do + { + t = exp (x * r * r); + p += sign * t; + if (t == 0.0) + break; + r += 1.0; + sign = -sign; + } + while ((t / p) > 1.1e-16); + return (p + p); +} + +/* Functional inverse of Smirnov distribution + finds e such that smirnov(n,e) = p. */ +double +smirnovi (n, p) + int n; + double p; +{ + double e, t, dpde; + + if (p <= 0.0 || p > 1.0) + { + mtherr ("smirnovi", DOMAIN); + return 0.0; + } + /* Start with approximation p = exp(-2 n e^2). */ + e = sqrt (-log (p) / (2.0 * n)); + do + { + /* Use approximate derivative in Newton iteration. */ + t = -2.0 * n * e; + dpde = 2.0 * t * exp (t * e); + if (fabs (dpde) > 0.0) + t = (p - smirnov (n, e)) / dpde; + else + { + mtherr ("smirnovi", UNDERFLOW); + return 0.0; + } + e = e + t; + if (e >= 1.0 || e <= 0.0) + { + mtherr ("smirnovi", OVERFLOW); + return 0.0; + } + } + while (fabs (t / e) > 1e-10); + return (e); +} + + +/* Functional inverse of Kolmogorov statistic for two-sided test. + Finds y such that kolmogorov(y) = p. + If e = smirnovi (n,p), then kolmogi(2 * p) / sqrt(n) should + be close to e. */ +double +kolmogi (p) + double p; +{ + double y, t, dpdy; + + if (p <= 0.0 || p > 1.0) + { + mtherr ("kolmogi", DOMAIN); + return 0.0; + } + /* Start with approximation p = 2 exp(-2 y^2). */ + y = sqrt (-0.5 * log (0.5 * p)); + do + { + /* Use approximate derivative in Newton iteration. */ + t = -2.0 * y; + dpdy = 4.0 * t * exp (t * y); + if (fabs (dpdy) > 0.0) + t = (p - kolmogorov (y)) / dpdy; + else + { + mtherr ("kolmogi", UNDERFLOW); + return 0.0; + } + y = y + t; + } + while (fabs (t / y) > 1e-10); + return (y); +} + + +#ifdef SALONE +/* Type in a number. */ +void +getnum (s, px) + char *s; + double *px; +{ + char str[30]; + + printf (" %s (%.15e) ? ", s, *px); + gets (str); + if (str[0] == '\0' || str[0] == '\n') + return; + sscanf (str, "%lf", px); + printf ("%.15e\n", *px); +} + +/* Type in values, get answers. */ +void +main () +{ + int n; + double e, p, ps, pk, ek, y; + + n = 5; + e = 0.0; + p = 0.1; +loop: + ps = n; + getnum ("n", &ps); + n = ps; + if (n <= 0) + { + printf ("? Operator error.\n"); + goto loop; + } + /* + getnum ("e", &e); + ps = smirnov (n, e); + y = sqrt ((double) n) * e; + printf ("y = %.4e\n", y); + pk = kolmogorov (y); + printf ("Smirnov = %.15e, Kolmogorov/2 = %.15e\n", ps, pk / 2.0); +*/ + getnum ("p", &p); + e = smirnovi (n, p); + printf ("Smirnov e = %.15e\n", e); + y = kolmogi (2.0 * p); + ek = y / sqrt ((double) n); + printf ("Kolmogorov e = %.15e\n", ek); + goto loop; +} +#endif diff --git a/libm/double/levnsn.c b/libm/double/levnsn.c new file mode 100644 index 000000000..3fda5d6bd --- /dev/null +++ b/libm/double/levnsn.c @@ -0,0 +1,82 @@ +/* Levnsn.c */ +/* Levinson-Durbin LPC + * + * | R0 R1 R2 ... RN-1 | | A1 | | -R1 | + * | R1 R0 R1 ... RN-2 | | A2 | | -R2 | + * | R2 R1 R0 ... RN-3 | | A3 | = | -R3 | + * | ... | | ...| | ... | + * | RN-1 RN-2... R0 | | AN | | -RN | + * + * Ref: John Makhoul, "Linear Prediction, A Tutorial Review" + * Proc. IEEE Vol. 63, PP 561-580 April, 1975. + * + * R is the input autocorrelation function. R0 is the zero lag + * term. A is the output array of predictor coefficients. Note + * that a filter impulse response has a coefficient of 1.0 preceding + * A1. E is an array of mean square error for each prediction order + * 1 to N. REFL is an output array of the reflection coefficients. + */ + +#define abs(x) ( (x) < 0 ? -(x) : (x) ) + +int levnsn( n, r, a, e, refl ) +int n; +double r[], a[], e[], refl[]; +{ +int k, km1, i, kmi, j; +double ai, akk, err, err1, r0, t, akmi; +double *pa, *pr; + +for( i=0; i<n; i++ ) + { + a[i] = 0.0; + e[i] = 0.0; + refl[i] = 0.0; + } +r0 = r[0]; +e[0] = r0; +err = r0; + +akk = -r[1]/err; +err = (1.0 - akk*akk) * err; +e[1] = err; +a[1] = akk; +refl[1] = akk; + +if( err < 1.0e-2 ) + return 0; + +for( k=2; k<n; k++ ) + { + t = 0.0; + pa = &a[1]; + pr = &r[k-1]; + for( j=1; j<k; j++ ) + t += *pa++ * *pr--; + akk = -( r[k] + t )/err; + refl[k] = akk; + km1 = k/2; + for( j=1; j<=km1; j++ ) + { + kmi = k-j; + ai = a[j]; + akmi = a[kmi]; + a[j] = ai + akk*akmi; + if( i == kmi ) + goto nxtk; + a[kmi] = akmi + akk*ai; + } +nxtk: + a[k] = akk; + err1 = (1.0 - akk*akk)*err; + e[k] = err1; + if( err1 < 0 ) + err1 = -err1; +/* err1 = abs(err1);*/ +/* if( (err1 < 1.0e-2) || (err1 >= err) )*/ + if( err1 < 1.0e-2 ) + return 0; + err = err1; + } + return 0; +} diff --git a/libm/double/log.c b/libm/double/log.c new file mode 100644 index 000000000..2fdea17a7 --- /dev/null +++ b/libm/double/log.c @@ -0,0 +1,341 @@ +/* log.c + * + * Natural logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log(); + * + * y = log( 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 1.44e-16 5.06e-17 + * IEEE +-MAXNUM 30000 1.20e-16 4.78e-17 + * DEC 0, 10 170000 1.8e-17 6.3e-18 + * + * In the tests over the interval [+-MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOG]. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns -INFINITY + * log domain: x < 0; returns NAN + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +static char fname[] = {"log"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + */ +#ifdef UNK +static double P[] = { + 1.01875663804580931796E-4, + 4.97494994976747001425E-1, + 4.70579119878881725854E0, + 1.44989225341610930846E1, + 1.79368678507819816313E1, + 7.70838733755885391666E0, +}; +static double Q[] = { +/* 1.00000000000000000000E0, */ + 1.12873587189167450590E1, + 4.52279145837532221105E1, + 8.29875266912776603211E1, + 7.11544750618563894466E1, + 2.31251620126765340583E1, +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0037777,0127270,0162547,0057274, +0041001,0054665,0164317,0005341, +0041451,0034104,0031640,0105773, +0041677,0011276,0123617,0160135, +0041701,0126603,0053215,0117250, +0041420,0115777,0135206,0030232, +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041220,0144332,0045272,0174241, +0041742,0164566,0035720,0130431, +0042246,0126327,0166065,0116357, +0042372,0033420,0157525,0124560, +0042271,0167002,0066537,0172303, +0041730,0164777,0113711,0044407, +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x1bb0,0x93c3,0xb4c2,0x3f1a, +0x52f2,0x3f56,0xd6f5,0x3fdf, +0x6911,0xed92,0xd2ba,0x4012, +0xeb2e,0xc63e,0xff72,0x402c, +0xc84d,0x924b,0xefd6,0x4031, +0xdcf8,0x7d7e,0xd563,0x401e, +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xef8e,0xae97,0x9320,0x4026, +0xc033,0x4e19,0x9d2c,0x4046, +0xbdbd,0xa326,0xbf33,0x4054, +0xae21,0xeb5e,0xc9e2,0x4051, +0x25b2,0x9e1f,0x200a,0x4037, +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f1a,0xb4c2,0x93c3,0x1bb0, +0x3fdf,0xd6f5,0x3f56,0x52f2, +0x4012,0xd2ba,0xed92,0x6911, +0x402c,0xff72,0xc63e,0xeb2e, +0x4031,0xefd6,0x924b,0xc84d, +0x401e,0xd563,0x7d7e,0xdcf8, +}; +static unsigned short Q[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4026,0x9320,0xae97,0xef8e, +0x4046,0x9d2c,0x4e19,0xc033, +0x4054,0xbf33,0xa326,0xbdbd, +0x4051,0xc9e2,0xeb5e,0xae21, +0x4037,0x200a,0x9e1f,0x25b2, +}; +#endif + +/* Coefficients for log(x) = z + z**3 P(z)/Q(z), + * where z = 2(x-1)/(x+1) + * 1/sqrt(2) <= x < sqrt(2) + */ + +#ifdef UNK +static double R[3] = { +-7.89580278884799154124E-1, + 1.63866645699558079767E1, +-6.41409952958715622951E1, +}; +static double S[3] = { +/* 1.00000000000000000000E0,*/ +-3.56722798256324312549E1, + 3.12093766372244180303E2, +-7.69691943550460008604E2, +}; +#endif +#ifdef DEC +static unsigned short R[12] = { +0140112,0020756,0161540,0072035, +0041203,0013743,0114023,0155527, +0141600,0044060,0104421,0050400, +}; +static unsigned short S[12] = { +/*0040200,0000000,0000000,0000000,*/ +0141416,0130152,0017543,0064122, +0042234,0006000,0104527,0020155, +0142500,0066110,0146631,0174731, +}; +#endif +#ifdef IBMPC +static unsigned short R[12] = { +0x0e84,0xdc6c,0x443d,0xbfe9, +0x7b6b,0x7302,0x62fc,0x4030, +0x2a20,0x1122,0x0906,0xc050, +}; +static unsigned short S[12] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6d0a,0x43ec,0xd60d,0xc041, +0xe40e,0x112a,0x8180,0x4073, +0x3f3b,0x19b3,0x0d89,0xc088, +}; +#endif +#ifdef MIEEE +static unsigned short R[12] = { +0xbfe9,0x443d,0xdc6c,0x0e84, +0x4030,0x62fc,0x7302,0x7b6b, +0xc050,0x0906,0x1122,0x2a20, +}; +static unsigned short S[12] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc041,0xd60d,0x43ec,0x6d0a, +0x4073,0x8180,0x112a,0xe40e, +0xc088,0x0d89,0x19b3,0x3f3b, +}; +#endif + +#ifdef ANSIPROT +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double frexp(), ldexp(), polevl(), p1evl(); +int isnan(), isfinite(); +#endif +#define SQRTH 0.70710678118654752440 +extern double INFINITY, NAN; + +double log(x) +double x; +{ +int e; +#ifdef DEC +short *q; +#endif +double y, z; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITY ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + { + mtherr( fname, SING ); + return( -INFINITY ); + } + else + { + mtherr( fname, DOMAIN ); + return( NAN ); + } + } + +/* separate mantissa from exponent */ + +#ifdef DEC +q = (short *)&x; +e = *q; /* short containing exponent */ +e = ((e >> 7) & 0377) - 0200; /* the exponent */ +*q &= 0177; /* strip exponent from x */ +*q |= 040000; /* x now between 0.5 and 1 */ +#endif + +/* Note, frexp is used so that denormal numbers + * will be handled properly. + */ +#ifdef IBMPC +x = frexp( x, &e ); +/* +q = (short *)&x; +q += 3; +e = *q; +e = ((e >> 4) & 0x0fff) - 0x3fe; +*q &= 0x0f; +*q |= 0x3fe0; +*/ +#endif + +/* Equivalent C language standard library function: */ +#ifdef UNK +x = frexp( x, &e ); +#endif + +#ifdef MIEEE +x = frexp( x, &e ); +#endif + + + +/* 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.5; + y = 0.5 * z + 0.5; + } +else + { /* 2 (x-1)/(x+1) */ + z = x - 0.5; + z -= 0.5; + y = 0.5 * x + 0.5; + } + +x = z / y; + + +/* rational form */ +z = x*x; +z = x * ( z * polevl( z, R, 2 ) / p1evl( z, S, 3 ) ); +y = e; +z = z - y * 2.121944400546905827679e-4; +z = z + x; +z = z + e * 0.693359375; +goto ldone; +} + + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexp( x, 1 ) - 1.0; /* 2x - 1 */ + } +else + { + x = x - 1.0; + } + + +/* rational form */ +z = x*x; +#if DEC +y = x * ( z * polevl( x, P, 5 ) / p1evl( x, Q, 6 ) ); +#else +y = x * ( z * polevl( x, P, 5 ) / p1evl( x, Q, 5 ) ); +#endif +if( e ) + y = y - e * 2.121944400546905827679e-4; +y = y - ldexp( z, -1 ); /* y - 0.5 * z */ +z = x + y; +if( e ) + z = z + e * 0.693359375; + +ldone: + +return( z ); +} diff --git a/libm/double/log10.c b/libm/double/log10.c new file mode 100644 index 000000000..7dc72e253 --- /dev/null +++ b/libm/double/log10.c @@ -0,0 +1,250 @@ +/* log10.c + * + * Common logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log10(); + * + * y = log10( x ); + * + * + * + * DESCRIPTION: + * + * Returns logarithm to the base 10 of x. + * + * The argument is separated into its exponent and fractional + * parts. The logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 30000 1.5e-16 5.0e-17 + * IEEE 0, MAXNUM 30000 1.4e-16 4.8e-17 + * DEC 1, MAXNUM 50000 2.5e-17 6.0e-18 + * + * In the tests over the interval [1, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOG]. + * + * ERROR MESSAGES: + * + * log10 singularity: x = 0; returns -INFINITY + * log10 domain: x < 0; returns NAN + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +static char fname[] = {"log10"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + */ +#ifdef UNK +static double P[] = { + 4.58482948458143443514E-5, + 4.98531067254050724270E-1, + 6.56312093769992875930E0, + 2.97877425097986925891E1, + 6.06127134467767258030E1, + 5.67349287391754285487E1, + 1.98892446572874072159E1 +}; +static double Q[] = { +/* 1.00000000000000000000E0, */ + 1.50314182634250003249E1, + 8.27410449222435217021E1, + 2.20664384982121929218E2, + 3.07254189979530058263E2, + 2.14955586696422947765E2, + 5.96677339718622216300E1 +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0034500,0046473,0051374,0135174, +0037777,0037566,0145712,0150321, +0040722,0002426,0031543,0123107, +0041356,0046513,0170752,0004346, +0041562,0071553,0023536,0163343, +0041542,0170221,0024316,0114216, +0041237,0016454,0046611,0104602 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041160,0100260,0067736,0102424, +0041645,0075552,0036563,0147072, +0042134,0125025,0021132,0025320, +0042231,0120211,0046030,0103271, +0042126,0172241,0052151,0120426, +0041556,0125702,0072116,0047103 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x974f,0x6a5f,0x09a7,0x3f08, +0x5a1a,0xd979,0xe7ee,0x3fdf, +0x74c9,0xc66c,0x40a2,0x401a, +0x411d,0x7e3d,0xc9a9,0x403d, +0xdcdc,0x64eb,0x4e6d,0x404e, +0xd312,0x2519,0x5e12,0x404c, +0x3130,0x89b1,0xe3a5,0x4033 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xd0a2,0x0dfb,0x1016,0x402e, +0x79c7,0x47ae,0xaf6d,0x4054, +0x455a,0xa44b,0x9542,0x406b, +0x10d7,0x2983,0x3411,0x4073, +0x3423,0x2a8d,0xde94,0x406a, +0xc9c8,0x4e89,0xd578,0x404d +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f08,0x09a7,0x6a5f,0x974f, +0x3fdf,0xe7ee,0xd979,0x5a1a, +0x401a,0x40a2,0xc66c,0x74c9, +0x403d,0xc9a9,0x7e3d,0x411d, +0x404e,0x4e6d,0x64eb,0xdcdc, +0x404c,0x5e12,0x2519,0xd312, +0x4033,0xe3a5,0x89b1,0x3130 +}; +static unsigned short Q[] = { +0x402e,0x1016,0x0dfb,0xd0a2, +0x4054,0xaf6d,0x47ae,0x79c7, +0x406b,0x9542,0xa44b,0x455a, +0x4073,0x3411,0x2983,0x10d7, +0x406a,0xde94,0x2a8d,0x3423, +0x404d,0xd578,0x4e89,0xc9c8 +}; +#endif + +#define SQRTH 0.70710678118654752440 +#define L102A 3.0078125E-1 +#define L102B 2.48745663981195213739E-4 +#define L10EA 4.3359375E-1 +#define L10EB 7.00731903251827651129E-4 + +#ifdef ANSIPROT +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double frexp(), ldexp(), polevl(), p1evl(); +int isnan(), isfinite(); +#endif +extern double LOGE2, SQRT2, INFINITY, NAN; + +double log10(x) +double x; +{ +VOLATILE double z; +double y; +#ifdef DEC +short *q; +#endif +int e; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITY ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + { + mtherr( fname, SING ); + return( -INFINITY ); + } + else + { + mtherr( fname, DOMAIN ); + return( NAN ); + } + } + +/* separate mantissa from exponent */ + +#ifdef DEC +q = (short *)&x; +e = *q; /* short containing exponent */ +e = ((e >> 7) & 0377) - 0200; /* the exponent */ +*q &= 0177; /* strip exponent from x */ +*q |= 040000; /* x now between 0.5 and 1 */ +#endif + +#ifdef IBMPC +x = frexp( x, &e ); +/* +q = (short *)&x; +q += 3; +e = *q; +e = ((e >> 4) & 0x0fff) - 0x3fe; +*q &= 0x0f; +*q |= 0x3fe0; +*/ +#endif + +/* Equivalent C language standard library function: */ +#ifdef UNK +x = frexp( x, &e ); +#endif + +#ifdef MIEEE +x = frexp( x, &e ); +#endif + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexp( x, 1 ) - 1.0; /* 2x - 1 */ + } +else + { + x = x - 1.0; + } + + +/* rational form */ +z = x*x; +y = x * ( z * polevl( x, P, 6 ) / p1evl( x, Q, 6 ) ); +y = y - ldexp( z, -1 ); /* y - 0.5 * x**2 */ + +/* multiply log of fraction by log10(e) + * and base 2 exponent by log10(2) + */ +z = (x + y) * L10EB; /* accumulate terms in order of size */ +z += y * L10EA; +z += x * L10EA; +z += e * L102B; +z += e * L102A; + + +return( z ); +} diff --git a/libm/double/log2.c b/libm/double/log2.c new file mode 100644 index 000000000..e73782712 --- /dev/null +++ b/libm/double/log2.c @@ -0,0 +1,348 @@ +/* log2.c + * + * Base 2 logarithm + * + * + * + * SYNOPSIS: + * + * double x, y, log2(); + * + * y = log2( 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 base e + * 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 2.0e-16 5.5e-17 + * IEEE exp(+-700) 40000 1.3e-16 4.6e-17 + * + * In the tests over the interval [exp(+-700)], the logarithms + * of the random arguments were uniformly distributed. + * + * ERROR MESSAGES: + * + * log2 singularity: x = 0; returns -INFINITY + * log2 domain: x < 0; returns NAN + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +static char fname[] = {"log2"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + */ +#ifdef UNK +static double P[] = { + 1.01875663804580931796E-4, + 4.97494994976747001425E-1, + 4.70579119878881725854E0, + 1.44989225341610930846E1, + 1.79368678507819816313E1, + 7.70838733755885391666E0, +}; +static double Q[] = { +/* 1.00000000000000000000E0, */ + 1.12873587189167450590E1, + 4.52279145837532221105E1, + 8.29875266912776603211E1, + 7.11544750618563894466E1, + 2.31251620126765340583E1, +}; +#define LOG2EA 0.44269504088896340735992 +#endif + +#ifdef DEC +static unsigned short P[] = { +0037777,0127270,0162547,0057274, +0041001,0054665,0164317,0005341, +0041451,0034104,0031640,0105773, +0041677,0011276,0123617,0160135, +0041701,0126603,0053215,0117250, +0041420,0115777,0135206,0030232, +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041220,0144332,0045272,0174241, +0041742,0164566,0035720,0130431, +0042246,0126327,0166065,0116357, +0042372,0033420,0157525,0124560, +0042271,0167002,0066537,0172303, +0041730,0164777,0113711,0044407, +}; +static unsigned short L[5] = {0037742,0124354,0122560,0057703}; +#define LOG2EA (*(double *)(&L[0])) +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x1bb0,0x93c3,0xb4c2,0x3f1a, +0x52f2,0x3f56,0xd6f5,0x3fdf, +0x6911,0xed92,0xd2ba,0x4012, +0xeb2e,0xc63e,0xff72,0x402c, +0xc84d,0x924b,0xefd6,0x4031, +0xdcf8,0x7d7e,0xd563,0x401e, +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xef8e,0xae97,0x9320,0x4026, +0xc033,0x4e19,0x9d2c,0x4046, +0xbdbd,0xa326,0xbf33,0x4054, +0xae21,0xeb5e,0xc9e2,0x4051, +0x25b2,0x9e1f,0x200a,0x4037, +}; +static unsigned short L[5] = {0x0bf8,0x94ae,0x551d,0x3fdc}; +#define LOG2EA (*(double *)(&L[0])) +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3f1a,0xb4c2,0x93c3,0x1bb0, +0x3fdf,0xd6f5,0x3f56,0x52f2, +0x4012,0xd2ba,0xed92,0x6911, +0x402c,0xff72,0xc63e,0xeb2e, +0x4031,0xefd6,0x924b,0xc84d, +0x401e,0xd563,0x7d7e,0xdcf8, +}; +static unsigned short Q[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4026,0x9320,0xae97,0xef8e, +0x4046,0x9d2c,0x4e19,0xc033, +0x4054,0xbf33,0xa326,0xbdbd, +0x4051,0xc9e2,0xeb5e,0xae21, +0x4037,0x200a,0x9e1f,0x25b2, +}; +static unsigned short L[5] = {0x3fdc,0x551d,0x94ae,0x0bf8}; +#define LOG2EA (*(double *)(&L[0])) +#endif + +/* Coefficients for log(x) = z + z**3 P(z)/Q(z), + * where z = 2(x-1)/(x+1) + * 1/sqrt(2) <= x < sqrt(2) + */ + +#ifdef UNK +static double R[3] = { +-7.89580278884799154124E-1, + 1.63866645699558079767E1, +-6.41409952958715622951E1, +}; +static double S[3] = { +/* 1.00000000000000000000E0,*/ +-3.56722798256324312549E1, + 3.12093766372244180303E2, +-7.69691943550460008604E2, +}; +/* log2(e) - 1 */ +#define LOG2EA 0.44269504088896340735992 +#endif +#ifdef DEC +static unsigned short R[12] = { +0140112,0020756,0161540,0072035, +0041203,0013743,0114023,0155527, +0141600,0044060,0104421,0050400, +}; +static unsigned short S[12] = { +/*0040200,0000000,0000000,0000000,*/ +0141416,0130152,0017543,0064122, +0042234,0006000,0104527,0020155, +0142500,0066110,0146631,0174731, +}; +/* log2(e) - 1 */ +#define LOG2EA 0.44269504088896340735992L +#endif +#ifdef IBMPC +static unsigned short R[12] = { +0x0e84,0xdc6c,0x443d,0xbfe9, +0x7b6b,0x7302,0x62fc,0x4030, +0x2a20,0x1122,0x0906,0xc050, +}; +static unsigned short S[12] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6d0a,0x43ec,0xd60d,0xc041, +0xe40e,0x112a,0x8180,0x4073, +0x3f3b,0x19b3,0x0d89,0xc088, +}; +#endif +#ifdef MIEEE +static unsigned short R[12] = { +0xbfe9,0x443d,0xdc6c,0x0e84, +0x4030,0x62fc,0x7302,0x7b6b, +0xc050,0x0906,0x1122,0x2a20, +}; +static unsigned short S[12] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc041,0xd60d,0x43ec,0x6d0a, +0x4073,0x8180,0x112a,0xe40e, +0xc088,0x0d89,0x19b3,0x3f3b, +}; +#endif + +#ifdef ANSIPROT +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double frexp(), ldexp(), polevl(), p1evl(); +int isnan(), isfinite(); +#endif +#define SQRTH 0.70710678118654752440 +extern double LOGE2, INFINITY, NAN; + +double log2(x) +double x; +{ +int e; +double y; +VOLATILE double z; +#ifdef DEC +short *q; +#endif + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITY ) + return(x); +#endif +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + { + mtherr( fname, SING ); + return( -INFINITY ); + } + else + { + mtherr( fname, DOMAIN ); + return( NAN ); + } + } + +/* separate mantissa from exponent */ + +#ifdef DEC +q = (short *)&x; +e = *q; /* short containing exponent */ +e = ((e >> 7) & 0377) - 0200; /* the exponent */ +*q &= 0177; /* strip exponent from x */ +*q |= 040000; /* x now between 0.5 and 1 */ +#endif + +/* Note, frexp is used so that denormal numbers + * will be handled properly. + */ +#ifdef IBMPC +x = frexp( x, &e ); +/* +q = (short *)&x; +q += 3; +e = *q; +e = ((e >> 4) & 0x0fff) - 0x3fe; +*q &= 0x0f; +*q |= 0x3fe0; +*/ +#endif + +/* Equivalent C language standard library function: */ +#ifdef UNK +x = frexp( x, &e ); +#endif + +#ifdef MIEEE +x = frexp( x, &e ); +#endif + + +/* 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.5; + y = 0.5 * z + 0.5; + } +else + { /* 2 (x-1)/(x+1) */ + z = x - 0.5; + z -= 0.5; + y = 0.5 * x + 0.5; + } + +x = z / y; +z = x*x; +y = x * ( z * polevl( z, R, 2 ) / p1evl( z, S, 3 ) ); +goto ldone; +} + + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = ldexp( x, 1 ) - 1.0; /* 2x - 1 */ + } +else + { + x = x - 1.0; + } + +z = x*x; +#if DEC +y = x * ( z * polevl( x, P, 5 ) / p1evl( x, Q, 6 ) ) - ldexp( z, -1 ); +#else +y = x * ( z * polevl( x, P, 5 ) / p1evl( x, Q, 5 ) ) - ldexp( z, -1 ); +#endif + +ldone: + +/* 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/double/lrand.c b/libm/double/lrand.c new file mode 100644 index 000000000..cfdaa9f28 --- /dev/null +++ b/libm/double/lrand.c @@ -0,0 +1,86 @@ +/* lrand.c + * + * Pseudorandom number generator + * + * + * + * SYNOPSIS: + * + * long y, drand(); + * + * drand( &y ); + * + * + * + * DESCRIPTION: + * + * Yields a long integer random number. + * + * The three-generator congruential algorithm by Brian + * Wichmann and David Hill (BYTE magazine, March, 1987, + * pp 127-8) is used. The period, given by them, is + * 6953607871644. + * + * + */ + + + +#include <math.h> + + +/* 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; + +/* This function implements the three + * congruential generators. + */ + +long lrand() +{ +int r, s; +unsigned long ans; + +/* +if( arg ) + { + sx = 1; + sy = 10000; + sz = 3000; + } +*/ + +/* 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; + +ans = sx * sy * sz; +return(ans); +} + diff --git a/libm/double/lsqrt.c b/libm/double/lsqrt.c new file mode 100644 index 000000000..bf85a54f1 --- /dev/null +++ b/libm/double/lsqrt.c @@ -0,0 +1,85 @@ +/* lsqrt.c + * + * Integer square root + * + * + * + * SYNOPSIS: + * + * long x, y; + * long lsqrt(); + * + * y = lsqrt( x ); + * + * + * + * DESCRIPTION: + * + * Returns a long integer square root of the long integer + * argument. The computation is by binary long division. + * + * The largest possible result is lsqrt(2,147,483,647) + * = 46341. + * + * If x < 0, the square root of |x| is returned, and an + * error message is printed. + * + * + * ACCURACY: + * + * An extra, roundoff, bit is computed; hence the result + * is the nearest integer to the actual square root. + * NOTE: only DEC arithmetic is currently supported. + * + */ + +/* +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> + +long lsqrt(x) +long x; +{ +long num, sq; +long temp; +int i, j, k, n; + +if( x < 0 ) + { + mtherr( "lsqrt", DOMAIN ); + x = -x; + } + +num = 0; +sq = 0; +k = 24; +n = 4; + +for( j=0; j<4; j++ ) + { + num |= (x >> k) & 0xff; /* bring in next byte of arg */ + if( j == 3 ) /* do roundoff bit at end */ + n = 5; + for( i=0; i<n; i++ ) + { + num <<= 2; /* next 2 bits of arg */ + sq <<= 1; /* shift up answer */ + temp = (sq << 1) + 256; /* trial divisor */ + temp = num - temp; + if( temp >= 0 ) + { + num = temp; /* it went in */ + sq += 256; /* answer bit = 1 */ + } + } + k -= 8; /* shift count to get next byte of arg */ + } + +sq += 256; /* add roundoff bit */ +sq >>= 9; /* truncate */ +return( sq ); +} diff --git a/libm/double/ltstd.c b/libm/double/ltstd.c new file mode 100644 index 000000000..f47fc3907 --- /dev/null +++ b/libm/double/ltstd.c @@ -0,0 +1,469 @@ +/* ltstd.c */ +/* Function test routine. + * Requires long double type check routine and double precision function + * under test. Indicate function name and range in #define statements + * below. Modifications for two argument functions and absolute + * rather than relative accuracy report are indicated. + */ + +#include <stdio.h> +/* int printf(), gets(), sscanf(); */ + +#include <math.h> +#ifdef ANSIPROT +int drand ( void ); +int dprec ( void ); +int ldprec ( void ); +double exp ( double ); +double sqrt ( double ); +double fabs ( double ); +double floor ( double ); +long double sqrtl ( long double ); +long double fabsl ( long double ); +#else +int drand(); +int dprec(), ldprec(); +double exp(), sqrt(), fabs(), floor(); +long double sqrtl(), fabsl(); +#endif + +#define RELERR 1 +#define ONEARG 0 +#define ONEINT 0 +#define TWOARG 0 +#define TWOINT 0 +#define THREEARG 1 +#define THREEINT 0 +#define FOURARG 0 +#define VECARG 0 +#define FOURANS 0 +#define TWOANS 0 +#define PROB 0 +#define EXPSCALE 0 +#define EXPSC2 0 +/* insert function to be tested here: */ +#define FUNC hyperg +double FUNC(); +#define QFUNC hypergl +long double QFUNC(); +/*extern int aiconf;*/ + +extern double MAXLOG; +extern double MINLOG; +extern double MAXNUM; +#define LTS 3.258096538 +/* insert low end and width of test interval */ +#define LOW 0.0 +#define WIDTH 30.0 +#define LOWA 0.0 +#define WIDTHA 30.0 +/* 1.073741824e9 */ +/* 2.147483648e9 */ +long double qone = 1.0L; +static long double q1, q2, q3, qa, qb, qc, qz, qy1, qy2, qy3, qy4; +static double y2, y3, y4, a, b, c, x, y, z, e; +static long double qe, qmax, qrmsa, qave; +volatile double v; +static long double lp[3], lq[3]; +static double dp[3], dq[3]; + +char strave[20]; +char strrms[20]; +char strmax[20]; +double underthresh = 2.22507385850720138309E-308; /* 2^-1022 */ + +void main() +{ +char s[80]; +int i, j, k; +long m, n; + +merror = 0; +ldprec(); /* set up coprocessor. */ +/*aiconf = -1;*/ /* configure Airy function */ +x = 1.0; +z = x * x; +qmax = 0.0L; +sprintf(strmax, "%.4Le", qmax ); +qrmsa = 0.0L; +qave = 0.0L; + +#if 1 +printf(" Start at random number #:" ); +gets( s ); +sscanf( s, "%ld", &n ); +printf("%ld\n", n ); +#else +n = 0; +#endif + +for( m=0; m<n; m++ ) + drand( &x ); +n = 0; +m = 0; +x = floor( x ); + +loop: + +for( i=0; i<500; i++ ) +{ +n++; +m++; + +#if ONEARG || TWOARG || THREEARG || FOURARG +/*ldprec();*/ /* set up floating point coprocessor */ +/* make random number in desired range */ +drand( &x ); +x = WIDTH * ( x - 1.0 ) + LOW; +#if EXPSCALE +x = exp(x); +drand( &a ); +a = 1.0e-13 * x * a; +if( x > 0.0 ) + x -= a; +else + x += a; +#endif +#if ONEINT +k = x; +x = k; +#endif +v = x; +q1 = v; /* double number to q type */ +#endif + +/* do again if second argument required */ + +#if TWOARG || THREEARG || FOURARG +drand( &a ); +a = WIDTHA * ( a - 1.0 ) + LOWA; +/*a /= 50.0;*/ +#if EXPSC2 +a = exp(a); +drand( &y2 ); +y2 = 1.0e-13 * y2 * a; +if( a > 0.0 ) + a -= y2; +else + a += y2; +#endif +#if TWOINT || THREEINT +k = a + 0.25; +a = k; +#endif +v = a; +qy4 = v; +#endif + +#if THREEARG || FOURARG +drand( &b ); +#if PROB +/* +b = b - 1.0; +b = a * b; +*/ +#if 1 +/* This makes b <= a, for bdtr. */ +b = (a - LOWA) * ( b - 1.0 ) + LOWA; +if( b > 1.0 && a > 1.0 ) + b -= 1.0; +else + { + a += 1.0; + k = a; + a = k; + v = a; + qy4 = v; + } +#else +b = WIDTHA * ( b - 1.0 ) + LOWA; +#endif + +/* Half-integer a and b */ +/* +a = 0.5*floor(2.0*a+1.0); +b = 0.5*floor(2.0*b+1.0); +*/ +v = a; +qy4 = v; +/*x = (a / (a+b));*/ + +#else +b = WIDTHA * ( b - 1.0 ) + LOWA; +#endif +#if THREEINT +j = b + 0.25; +b = j; +#endif +v = b; +qb = v; +#endif + +#if FOURARG +drand( &c ); +c = WIDTHA * ( c - 1.0 ) + LOWA; +/* for hyp2f1 to ensure c-a-b > -1 */ +/* +z = c-a-b; +if( z < -1.0 ) + c -= 1.6 * z; +*/ +v = c; +qc = v; +#endif + +#if VECARG +for( j=0; j<3; j++) + { + drand( &x ); + x = WIDTH * ( x - 1.0 ) + LOW; + v = x; + dp[j] = v; + q1 = v; /* double number to q type */ + lp[j] = q1; + drand( &x ); + x = WIDTH * ( x - 1.0 ) + LOW; + v = x; + dq[j] = v; + q1 = v; /* double number to q type */ + lq[j] = q1; + } +#endif /* VECARG */ + +/*printf("%.16E %.16E\n", a, x);*/ +/* compute function under test */ +/* Set to double precision */ +/*dprec();*/ +#if ONEARG +#if FOURANS +/*FUNC( x, &z, &y2, &y3, &y4 );*/ +FUNC( x, &y4, &y2, &y3, &z ); +#else +#if TWOANS +FUNC( x, &z, &y2 ); +/*FUNC( x, &y2, &z );*/ +#else +#if ONEINT +z = FUNC( k ); +#else +z = FUNC( x ); +#endif +#endif +#endif +#endif + +#if TWOARG +#if TWOINT +z = FUNC( k, x ); +/*z = FUNC( x, k );*/ +/*z = FUNC( a, x );*/ +#else +#if FOURANS +FUNC( a, x, &z, &y2, &y3, &y4 ); +#else +z = FUNC( a, x ); +#endif +#endif +#endif + +#if THREEARG +#if THREEINT +z = FUNC( j, k, x ); +#else +z = FUNC( a, b, x ); +#endif +#endif + +#if FOURARG +z = FUNC( a, b, c, x ); +#endif + +#if VECARG +z = FUNC( dp, dq ); +#endif + +q2 = z; +/* handle detected overflow */ +if( (z == MAXNUM) || (z == -MAXNUM) ) + { + printf("detected overflow "); +#if FOURARG + printf("%.4E %.4E %.4E %.4E %.4E %6ld \n", + a, b, c, x, y, n); +#else + printf("%.16E %.4E %.4E %6ld \n", x, a, z, n); +#endif + e = 0.0; + m -= 1; + goto endlup; + } +/* Skip high precision if underflow. */ +if( merror == UNDERFLOW ) + goto underf; + +/* compute high precision function */ +/*ldprec();*/ +#if ONEARG +#if FOURANS +/*qy4 = QFUNC( q1, qz, qy2, qy3 );*/ +qz = QFUNC( q1, qy4, qy2, qy3 ); +#else +#if TWOANS +qy2 = QFUNC( q1, qz ); +/*qz = QFUNC( q1, qy2 );*/ +#else +/* qy4 = 0.0L;*/ +/* qy4 = 1.0L;*/ +/*qz = QFUNC( qy4, q1 );*/ +/*qz = QFUNC( 1, q1 );*/ +qz = QFUNC( q1 ); /* normal */ +#endif +#endif +#endif + +#if TWOARG +#if TWOINT +qz = QFUNC( k, q1 ); +/*qz = QFUNC( q1, qy4 );*/ +/*qz = QFUNC( qy4, q1 );*/ +#else +#if FOURANS +qc = QFUNC( qy4, q1, qz, qy2, qy3 ); +#else +/*qy4 = 0.0L;;*/ +/*qy4 = 1.0L );*/ +qz = QFUNC( qy4, q1 ); +#endif +#endif +#endif + +#if THREEARG +#if THREEINT +qz = QFUNC( j, k, q1 ); +#else +qz = QFUNC( qy4, qb, q1 ); +#endif +#endif + +#if FOURARG +qz = QFUNC( qy4, qb, qc, q1 ); +#endif + +#if VECARG +qz = QFUNC( lp, lq ); +#endif + +y = qz; /* correct answer, in double precision */ + +/* get absolute error, in extended precision */ +qe = q2 - qz; +e = qe; /* the error in double precision */ + +/* handle function result equal to zero + or underflowed. */ +if( qz == 0.0L || merror == UNDERFLOW || fabs(z) < underthresh ) + { +underf: + merror = 0; +/* Don't bother to print anything. */ +#if 0 + printf("ans 0 "); +#if ONEARG + printf("%.8E %.8E %.4E %6ld \n", x, y, e, n); +#endif + +#if TWOARG +#if TWOINT + printf("%d %.8E %.8E %.4E %6ld \n", k, x, y, e, n); +#else + printf("%.6E %.6E %.6E %.4E %6ld \n", a, x, y, e, n); +#endif +#endif + +#if THREEARG + printf("%.6E %.6E %.6E %.6E %.4E %6ld \n", a, b, x, y, e, n); +#endif + +#if FOURARG + printf("%.4E %.4E %.4E %.4E %.4E %.4E %6ld \n", + a, b, c, x, y, e, n); +#endif +#endif /* 0 */ + qe = 0.0L; + e = 0.0; + m -= 1; + goto endlup; + } + +else + +/* relative error */ + +/* comment out the following two lines if absolute accuracy report */ + +#if RELERR + qe = qe / qz; +#else + { + q2 = qz; + q2 = fabsl(q2); + if( q2 > 1.0L ) + qe = qe / qz; + } +#endif + +qave = qave + qe; +/* absolute value of error */ +qe = fabs(qe); + +/* peak detect the error */ +if( qe > qmax ) + { + qmax = qe; + sprintf(strmax, "%.4Le", qmax ); +#if ONEARG + printf("%.8E %.8E %s %6ld \n", x, y, strmax, n); +#endif +#if TWOARG +#if TWOINT + printf("%d %.8E %.8E %s %6ld \n", k, x, y, strmax, n); +#else + printf("%.6E %.6E %.6E %s %6ld \n", a, x, y, strmax, n); +#endif +#endif +#if THREEARG + printf("%.6E %.6E %.6E %.6E %s %6ld \n", a, b, x, y, strmax, n); +#endif +#if FOURARG + printf("%.4E %.4E %.4E %.4E %.4E %s %6ld \n", + a, b, c, x, y, strmax, n); +#endif +#if VECARG + printf("%.8E %s %6ld \n", y, strmax, n); +#endif + } + +/* accumulate rms error */ +/* rmsa += e * e; accumulate the square of the error */ +q2 = qe * qe; +qrmsa = qrmsa + q2; +endlup: ; +/*ldprec();*/ +} + +/* report every 500 trials */ +/* rms = sqrt( rmsa/m ); */ +q1 = m; +q2 = qrmsa / q1; +q2 = sqrtl(q2); +sprintf(strrms, "%.4Le", q2 ); + +q2 = qave / q1; +sprintf(strave, "%.4Le", q2 ); +/* +printf("%6ld max = %s rms = %s ave = %s \n", m, strmax, strrms, strave ); +*/ +printf("%6ld max = %s rms = %s ave = %s \r", m, strmax, strrms, strave ); +fflush(stdout); +goto loop; +} diff --git a/libm/double/minv.c b/libm/double/minv.c new file mode 100644 index 000000000..df788fecf --- /dev/null +++ b/libm/double/minv.c @@ -0,0 +1,61 @@ +/* minv.c + * + * Matrix inversion + * + * + * + * SYNOPSIS: + * + * int n, errcod; + * double A[n*n], X[n*n]; + * double B[n]; + * int IPS[n]; + * int minv(); + * + * errcod = minv( A, X, n, B, IPS ); + * + * + * + * DESCRIPTION: + * + * Finds the inverse of the n by n matrix A. The result goes + * to X. B and IPS are scratch pad arrays of length n. + * The contents of matrix A are destroyed. + * + * The routine returns nonzero on error; error messages are printed + * by subroutine simq(). + * + */ + +minv( A, X, n, B, IPS ) +double A[], X[]; +int n; +double B[]; +int IPS[]; +{ +double *pX; +int i, j, k; + +for( i=1; i<n; i++ ) + B[i] = 0.0; +B[0] = 1.0; +/* Reduce the matrix and solve for first right hand side vector */ +pX = X; +k = simq( A, B, pX, n, 1, IPS ); +if( k ) + return(-1); +/* Solve for the remaining right hand side vectors */ +for( i=1; i<n; i++ ) + { + B[i-1] = 0.0; + B[i] = 1.0; + pX += n; + k = simq( A, B, pX, n, -1, IPS ); + if( k ) + return(-1); + } +/* Transpose the array of solution vectors */ +mtransp( n, X, X ); +return(0); +} + diff --git a/libm/double/mod2pi.c b/libm/double/mod2pi.c new file mode 100644 index 000000000..057954a9b --- /dev/null +++ b/libm/double/mod2pi.c @@ -0,0 +1,122 @@ +/* Program to test range reduction of trigonometry functions + * + * -- Steve Moshier + */ + +#include <math.h> +#ifdef ANSIPROT +extern double floor ( double ); +extern double ldexp ( double, int ); +extern double sin ( double ); +#else +double floor(), ldexp(), sin(); +#endif + +#define TPI 6.283185307179586476925 + +main() +{ +char s[40]; +double a, n, t, x, y, z; +int lflg; + +x = TPI/4.0; +t = 1.0; + +loop: + +t = 2.0 * t; + +/* Stop testing at a point beyond which the integer part of + * x/2pi cannot be represented exactly by a double precision number. + * The library trigonometry functions will probably give up long before + * this point is reached. + */ +if( t > 1.0e16 ) + exit(0); + +/* Adjust the following to choose a nontrivial x + * where test function(x) has a slope of about 1 or more. + */ +x = TPI * t + 0.5; + +z = x; +lflg = 0; + +inlup: + +/* floor() returns the largest integer less than its argument. + * If you do not have this, or AINT(), then you may convert x/TPI + * to a long integer and then back to double; but in that case + * x will be limited to the largest value that will fit into a + * long integer. + */ +n = floor( z/TPI ); + +/* Carefully subtract 2 pi n from x. + * This is done by subtracting n * 2**k in such a way that there + * is no arithmetic cancellation error at any step. The k are the + * bits in the number 2 pi. + * + * If you do not have ldexp(), then you may multiply or + * divide n by an appropriate power of 2 after each step. + * For example: + * a = z - 4*n; + * a -= 2*n; + * n /= 4; + * a -= n; n/4 + * n /= 8; + * a -= n; n/32 + * etc. + * This will only work if division by a power of 2 is exact. + */ + +a = z - ldexp(n, 2); /* 4n */ +a -= ldexp( n, 1); /* 2n */ +a -= ldexp( n, -2 ); /* n/4 */ +a -= ldexp( n, -5 ); /* n/32 */ +a -= ldexp( n, -9 ); /* n/512 */ +a += ldexp( n, -15 ); /* add n/32768 */ +a -= ldexp( n, -17 ); /* n/131072 */ +a -= ldexp( n, -18 ); +a -= ldexp( n, -20 ); +a -= ldexp( n, -22 ); +a -= ldexp( n, -24 ); +a -= ldexp( n, -28 ); +a -= ldexp( n, -32 ); +a -= ldexp( n, -37 ); +a -= ldexp( n, -39 ); +a -= ldexp( n, -40 ); +a -= ldexp( n, -42 ); +a -= ldexp( n, -46 ); +a -= ldexp( n, -47 ); + +/* Subtract what is left of 2 pi n after all the above reductions. + */ +a -= 2.44929359829470635445e-16 * n; + +/* If the test is extended too far, it is possible + * to have chosen the wrong value of n. The following + * will fix that, but at some reduction in accuracy. + */ +if( (a > TPI) || (a < -1e-11) ) + { + z = a; + lflg += 1; + printf( "Warning! Reduction failed on first try.\n" ); + goto inlup; + } +if( a < 0.0 ) + { + printf( "Warning! Reduced value < 0\n" ); + a += TPI; + } + +/* Compute the test function at x and at a = x mod 2 pi. + */ +y = sin(x); +z = sin(a); +printf( "sin(%.15e) error = %.3e\n", x, y-z ); +goto loop; +} + diff --git a/libm/double/monot.c b/libm/double/monot.c new file mode 100644 index 000000000..bb00c5f28 --- /dev/null +++ b/libm/double/monot.c @@ -0,0 +1,308 @@ + +/* 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. */ +double frexp (double, int *); +double ldexp (double, int); + +/* Number of test points to generate on each side of tabulated point. */ +#define NPTS 100 + +/* Functions of one variable. */ +double exp (double); +double log (double); +double sin (double); +double cos (double); +double tan (double); +double atan (double); +double asin (double); +double acos (double); +double sinh (double); +double cosh (double); +double tanh (double); +double asinh (double); +double acosh (double); +double atanh (double); +double gamma (double); +double fabs (double); +double floor (double); + +struct oneargument + { + char *name; /* Name of the function. */ + double (*func) (double); + double arg1; /* Function argument, assumed exact. */ + double answer1; /* Exact, close to function value. */ + double answer2; /* answer1 + answer2 has extended precision. */ + 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 0 + +/* Unit of relative error in test[i].thresh. */ +static double MACHEP = 1.1102230246251565404e-16; +/* extern double MACHEP; */ + + +struct oneargument test1[] = +{ + {"exp", exp, 1.0, 2.7182769775390625, + 4.85091998273536028747e-6, 2.71828182845904523536, 2}, + {"exp", exp, -1.0, 3.678741455078125e-1, + 5.29566362982159552377e-6, 3.678794411714423215955e-1, 2}, + {"exp", exp, 0.5, 1.648712158203125, + 9.1124970031468486507878e-6, 1.64872127070012814684865, 2}, + {"exp", exp, -0.5, 6.065216064453125e-1, + 9.0532673209236037995e-6, 6.0653065971263342360e-1, 2}, + {"exp", exp, 2.0, 7.3890533447265625, + 2.75420408772723042746e-6, 7.38905609893065022723, 2}, + {"exp", exp, -2.0, 1.353302001953125e-1, + 5.08304130019189399949e-6, 1.3533528323661269189e-1, 2}, + {"log", log, 1.41421356237309492343, 3.465728759765625e-1, + 7.1430341006605745676897e-7, 7.0710678118654758708668e-1, 2}, + {"log", log, 7.07106781186547461715e-1, -3.46588134765625e-1, + 1.45444856522566402246e-5, 1.41421356237309517417, 2}, + {"sin", sin, 7.85398163397448278999e-1, 7.0709228515625e-1, + 1.4496030297502751942956e-5, 7.071067811865475460497e-1, 2}, + {"sin", sin, -7.85398163397448501044e-1, -7.071075439453125e-1, + 7.62758764840238811175e-7, 7.07106781186547389040e-1, 2}, + {"sin", sin, 1.570796326794896558, 9.999847412109375e-1, + 1.52587890625e-5, 6.12323399573676588613e-17, 2}, + {"sin", sin, -1.57079632679489678004, -1.0, + 1.29302922820150306903e-32, -1.60812264967663649223e-16, 2}, + {"sin", sin, 4.712388980384689674, -1.0, + 1.68722975549458979398e-32, -1.83697019872102976584e-16, 2}, + {"sin", sin, -4.71238898038468989604, 9.999847412109375e-1, + 1.52587890625e-5, 3.83475850529283315008e-17, 2}, + {"cos", cos, 3.92699081698724139500E-1, 9.23873901367187500000E-1, + 5.63114409926198633370E-6, -3.82683432365089757586E-1, 2}, + {"cos", cos, 7.85398163397448278999E-1, 7.07092285156250000000E-1, + 1.44960302975460497458E-5, -7.07106781186547502752E-1, 2}, + {"cos", cos, 1.17809724509617241850E0, 3.82675170898437500000E-1, + 8.26146665231415693919E-6, -9.23879532511286738554E-1, 2}, + {"cos", cos, 1.96349540849362069750E0, -3.82690429687500000000E-1, + 6.99732241029898567203E-6, -9.23879532511286785419E-1, 2}, + {"cos", cos, 2.35619449019234483700E0, -7.07107543945312500000E-1, + 7.62758765040545859856E-7, -7.07106781186547589348E-1, 2}, + {"cos", cos, 2.74889357189106897650E0, -9.23889160156250000000E-1, + 9.62764496328487887036E-6, -3.82683432365089870728E-1, 2}, + {"cos", cos, 3.14159265358979311600E0, -1.00000000000000000000E0, + 7.49879891330928797323E-33, -1.22464679914735317723E-16, 2}, + {"tan", tan, 7.85398163397448278999E-1, 9.999847412109375e-1, + 1.52587890624387676600E-5, 1.99999999999999987754E0, 2}, + {"tan", tan, 1.17809724509617241850E0, 2.41419982910156250000E0, + 1.37332715322352112604E-5, 6.82842712474618858345E0, 2}, + {"tan", tan, 1.96349540849362069750E0, -2.41421508789062500000E0, + 1.52551752942854759743E-6, 6.82842712474619262118E0, 2}, + {"tan", tan, 2.35619449019234483700E0, -1.00001525878906250000E0, + 1.52587890623163029801E-5, 2.00000000000000036739E0, 2}, + {"tan", tan, 2.74889357189106897650E0, -4.14215087890625000000E-1, + 1.52551752982565655126E-6, 1.17157287525381000640E0, 2}, + {"atan", atan, 4.14213562373094923430E-1, 3.92684936523437500000E-1, + 1.41451752865477964149E-5, 8.53553390593273837869E-1, 2}, + {"atan", atan, 1.0, 7.85385131835937500000E-1, + 1.30315615108096156608E-5, 0.5, 2}, + {"atan", atan, 2.41421356237309492343E0, 1.17808532714843750000E0, + 1.19179477349460632350E-5, 1.46446609406726250782E-1, 2}, + {"atan", atan, -2.41421356237309514547E0, -1.17810058593750000000E0, + 3.34084132752141908545E-6, 1.46446609406726227789E-1, 2}, + {"atan", atan, -1.0, -7.85400390625000000000E-1, + 2.22722755169038433915E-6, 0.5, 2}, + {"atan", atan, -4.14213562373095145475E-1, -3.92700195312500000000E-1, + 1.11361377576267665972E-6, 8.53553390593273703853E-1, 2}, + {"asin", asin, 3.82683432365089615246E-1, 3.92684936523437500000E-1, + 1.41451752864854321970E-5, 1.08239220029239389286E0, 2}, + {"asin", asin, 0.5, 5.23590087890625000000E-1, + 8.68770767387307710723E-6, 1.15470053837925152902E0, 2}, + {"asin", asin, 7.07106781186547461715E-1, 7.85385131835937500000E-1, + 1.30315615107209645016E-5, 1.41421356237309492343E0, 2}, + {"asin", asin, 9.23879532511286738483E-1, 1.17808532714843750000E0, + 1.19179477349183147612E-5, 2.61312592975275276483E0, 2}, + {"asin", asin, -0.5, -5.23605346679687500000E-1, + 6.57108138862692289277E-6, 1.15470053837925152902E0, 2}, + {"acos", acos, 1.95090322016128192573E-1, 1.37443542480468750000E0, + 1.13611408471185777914E-5, -1.01959115820831832232E0, 2}, + {"acos", acos, 3.82683432365089615246E-1, 1.17808532714843750000E0, + 1.19179477351337991247E-5, -1.08239220029239389286E0, 2}, + {"acos", acos, 0.5, 1.04719543457031250000E0, + 2.11662628524615421446E-6, -1.15470053837925152902E0, 2}, + {"acos", acos, 7.07106781186547461715E-1, 7.85385131835937500000E-1, + 1.30315615108982668201E-5, -1.41421356237309492343E0, 2}, + {"acos", acos, 9.23879532511286738483E-1, 3.92684936523437500000E-1, + 1.41451752867009165605E-5, -2.61312592975275276483E0, 2}, + {"acos", acos, 9.80785280403230430579E-1, 1.96334838867187500000E-1, + 1.47019821746724723933E-5, -5.12583089548300990774E0, 2}, + {"acos", acos, -0.5, 2.09439086914062500000E0, + 4.23325257049230842892E-6, -1.15470053837925152902E0, 2}, + {"sinh", sinh, 1.0, 1.17518615722656250000E0, + 1.50364172389568823819E-5, 1.54308063481524377848E0, 2}, + {"sinh", sinh, 7.09089565712818057364E2, 4.49423283712885057274E307, + 4.25947714184369757620E208, 4.49423283712885057274E307, 2}, + {"sinh", sinh, 2.22044604925031308085E-16, 0.00000000000000000000E0, + 2.22044604925031308085E-16, 1.00000000000000000000E0, 2}, + {"cosh", cosh, 7.09089565712818057364E2, 4.49423283712885057274E307, + 4.25947714184369757620E208, 4.49423283712885057274E307, 2}, + {"cosh", cosh, 1.0, 1.54307556152343750000E0, + 5.07329180627847790562E-6, 1.17520119364380145688E0, 2}, + {"cosh", cosh, 0.5, 1.12762451171875000000E0, + 1.45348763078522622516E-6, 5.21095305493747361622E-1, 2}, + {"tanh", tanh, 0.5, 4.62112426757812500000E-1, + 4.73050219725850231848E-6, 7.86447732965927410150E-1, 2}, + {"tanh", tanh, 5.49306144334054780032E-1, 4.99984741210937500000E-1, + 1.52587890624507506378E-5, 7.50000000000000049249E-1, 2}, + {"tanh", tanh, 0.625, 5.54595947265625000000E-1, + 3.77508375729399903910E-6, 6.92419147969988069631E-1, 2}, + {"asinh", asinh, 0.5, 4.81201171875000000000E-1, + 1.06531846034474977589E-5, 8.94427190999915878564E-1, 2}, + {"asinh", asinh, 1.0, 8.81362915039062500000E-1, + 1.06719804805252326093E-5, 7.07106781186547524401E-1, 2}, + {"asinh", asinh, 2.0, 1.44363403320312500000E0, + 1.44197568534249327674E-6, 4.47213595499957939282E-1, 2}, + {"acosh", acosh, 2.0, 1.31695556640625000000E0, + 2.33051856670862504635E-6, 5.77350269189625764509E-1, 2}, + {"acosh", acosh, 1.5, 9.62417602539062500000E-1, + 6.04758014439499551783E-6, 8.94427190999915878564E-1, 2}, + {"acosh", acosh, 1.03125, 2.49343872070312500000E-1, + 9.62177257298785143908E-6, 3.96911150685467059809E0, 2}, + {"atanh", atanh, 0.5, 5.49301147460937500000E-1, + 4.99687311734569762262E-6, 1.33333333333333333333E0, 2}, +#if 0 + {"gamma", gamma, 1.0, 1.0, + 0.0, -5.772156649015328606e-1, 2}, + {"gamma", gamma, 2.0, 1.0, + 0.0, 4.2278433509846713939e-1, 2}, + {"gamma", gamma, 3.0, 2.0, + 0.0, 1.845568670196934279, 2}, + {"gamma", gamma, 4.0, 6.0, + 0.0, 7.536706010590802836, 2}, +#endif + {"null", NULL, 0.0, 0.0, 0.0, 2}, +}; + +/* These take care of extra-precise floating point register problems. */ +volatile double volat1; +volatile double volat2; + + +/* Return the next nearest floating point value to X + in the direction of UPDOWN (+1 or -1). + (Fails if X is denormalized.) */ + +double +nextval (x, updown) + double x; + int updown; +{ + double m; + int i; + + volat1 = x; + m = 0.25 * MACHEP * 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 () +{ + double (*fun1) (double); + int i, j, errs, tests; + double x, x0, y, dy, err; + + /* Set math coprocessor to double precision. */ + /* dprec (); */ + 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 (fabs (err) > ((OKERROR + test1[i].thresh) * MACHEP)) + { + printf ("%d %s(%.16e) = %.16e, rel err = %.3e\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 (fabs (err) > ((OKERROR + test1[i].thresh) * MACHEP)) + { + printf ("%d %s(%.16e) = %.16e, rel err = %.3e\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/double/mtherr.c b/libm/double/mtherr.c new file mode 100644 index 000000000..ed3d26d51 --- /dev/null +++ b/libm/double/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 math.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: + * + * math.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 math.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/double/mtransp.c b/libm/double/mtransp.c new file mode 100644 index 000000000..b4a54dd0f --- /dev/null +++ b/libm/double/mtransp.c @@ -0,0 +1,61 @@ +/* mtransp.c + * + * Matrix transpose + * + * + * + * SYNOPSIS: + * + * int n; + * double A[n*n], T[n*n]; + * + * mtransp( n, A, T ); + * + * + * + * DESCRIPTION: + * + * + * T[r][c] = A[c][r] + * + * + * Transposes the n by n square matrix A and puts the result in T. + * The output, T, may occupy the same storage as A. + * + * + * + */ + + +mtransp( n, A, T ) +int n; +double *A, *T; +{ +int i, j, np1; +double *pAc, *pAr, *pTc, *pTr, *pA0, *pT0; +double x, y; + +np1 = n+1; +pA0 = A; +pT0 = T; +for( i=0; i<n-1; i++ ) /* row index */ + { + pAc = pA0; /* next diagonal element of input */ + pAr = pAc + n; /* next row down underneath the diagonal element */ + pTc = pT0; /* next diagonal element of the output */ + pTr = pTc + n; /* next row underneath */ + *pTc++ = *pAc++; /* copy the diagonal element */ + for( j=i+1; j<n; j++ ) /* column index */ + { + x = *pAr; + *pTr = *pAc++; + *pTc++ = x; + pAr += n; + pTr += n; + } + pA0 += np1; /* &A[n*i+i] for next i */ + pT0 += np1; /* &T[n*i+i] for next i */ + } +*pT0 = *pA0; /* copy the diagonal element */ +} + diff --git a/libm/double/mtst.c b/libm/double/mtst.c new file mode 100644 index 000000000..2559d2340 --- /dev/null +++ b/libm/double/mtst.c @@ -0,0 +1,464 @@ +/* mtst.c + Consistency tests for math functions. + To get strict rounding rules on a 386 or 68000 computer, + define SETPREC to 1. + + With NTRIALS=10000, the following are typical results for + IEEE double precision arithmetic. + +Consistency test of math functions. +Max and rms relative errors for 10000 random arguments. +x = cbrt( cube(x) ): max = 0.00E+00 rms = 0.00E+00 +x = atan( tan(x) ): max = 2.21E-16 rms = 3.27E-17 +x = sin( asin(x) ): max = 2.13E-16 rms = 2.95E-17 +x = sqrt( square(x) ): max = 0.00E+00 rms = 0.00E+00 +x = log( exp(x) ): max = 1.11E-16 A rms = 4.35E-18 A +x = tanh( atanh(x) ): max = 2.22E-16 rms = 2.43E-17 +x = asinh( sinh(x) ): max = 2.05E-16 rms = 3.49E-18 +x = acosh( cosh(x) ): max = 1.43E-15 A rms = 1.54E-17 A +x = log10( exp10(x) ): max = 5.55E-17 A rms = 1.27E-18 A +x = pow( pow(x,a),1/a ): max = 7.60E-14 rms = 1.05E-15 +x = cos( acos(x) ): max = 2.22E-16 A rms = 6.90E-17 A +*/ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 2000 by Stephen L. Moshier +*/ + + +#include <stdio.h> +#include <stdlib.h> +#include <math.h> + +#ifndef NTRIALS +#define NTRIALS 10000 +#endif + +#define SETPREC 1 +#define STRTST 0 + +#define WTRIALS (NTRIALS/5) + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double sqrt ( double ); +extern double cbrt ( double ); +extern double exp ( double ); +extern double log ( double ); +extern double exp10 ( double ); +extern double log10 ( double ); +extern double tan ( double ); +extern double atan ( double ); +extern double sin ( double ); +extern double asin ( double ); +extern double cos ( double ); +extern double acos ( double ); +extern double pow ( double, double ); +extern double tanh ( double ); +extern double atanh ( double ); +extern double sinh ( double ); +extern double asinh ( double x ); +extern double cosh ( double ); +extern double acosh ( double ); +extern double gamma ( double ); +extern double lgam ( double ); +#else +double fabs(), sqrt(), cbrt(), exp(), log(); +double exp10(), log10(), tan(), atan(); +double sin(), asin(), cos(), acos(), pow(); +double tanh(), atanh(), sinh(), asinh(), cosh(), acosh(); +double gamma(), lgam(); +#endif + +/* C9X spells lgam lgamma. */ +#define GLIBC2 0 +#if GLIBC2 +double lgamma (double); +#endif + +#if SETPREC +int dprec(); +#endif + +int drand(); +/* void exit(); */ +/* int printf(); */ + + +/* Provide inverses for square root and cube root: */ +double square(x) +double x; +{ +return( x * x ); +} + +double cube(x) +double x; +{ +return( x * x * x ); +} + +/* lookup table for each function */ +struct fundef + { + char *nam1; /* the function */ + double (*name )(); + char *nam2; /* its inverse */ + double (*inv )(); + int nargs; /* number of function arguments */ + int tstyp; /* type code of the function */ + long ctrl; /* relative error flag */ + double arg1w; /* width of domain for 1st arg */ + double arg1l; /* lower bound domain 1st arg */ + long arg1f; /* flags, e.g. integer arg */ + double arg2w; /* same info for args 2, 3, 4 */ + double arg2l; + long arg2f; +/* + double arg3w; + double arg3l; + long arg3f; + double arg4w; + double arg4l; + long arg4f; +*/ + }; + + +/* fundef.ctrl bits: */ +#define RELERR 1 + +/* fundef.tstyp test types: */ +#define POWER 1 +#define ELLIP 2 +#define GAMMA 3 +#define WRONK1 4 +#define WRONK2 5 +#define WRONK3 6 + +/* fundef.argNf argument flag bits: */ +#define INT 2 +#define EXPSCAL 4 + +extern double MINLOG; +extern double MAXLOG; +extern double PI; +extern double PIO2; +/* +define MINLOG -170.0 +define MAXLOG +170.0 +define PI 3.14159265358979323846 +define PIO2 1.570796326794896619 +*/ + +#define NTESTS 12 +struct fundef defs[NTESTS] = { +{" cube", cube, " cbrt", cbrt, 1, 0, 1, 2002.0, -1001.0, 0, +0.0, 0.0, 0}, +{" tan", tan, " atan", atan, 1, 0, 1, 0.0, 0.0, 0, +0.0, 0.0, 0}, +{" asin", asin, " sin", sin, 1, 0, 1, 2.0, -1.0, 0, +0.0, 0.0, 0}, +{"square", square, " sqrt", sqrt, 1, 0, 1, 170.0, -85.0, EXPSCAL, +0.0, 0.0, 0}, +{" exp", exp, " log", log, 1, 0, 0, 340.0, -170.0, 0, +0.0, 0.0, 0}, +{" atanh", atanh, " tanh", tanh, 1, 0, 1, 2.0, -1.0, 0, +0.0, 0.0, 0}, +{" sinh", sinh, " asinh", asinh, 1, 0, 1, 340.0, 0.0, 0, +0.0, 0.0, 0}, +{" cosh", cosh, " acosh", acosh, 1, 0, 0, 340.0, 0.0, 0, +0.0, 0.0, 0}, +{" exp10", exp10, " log10", log10, 1, 0, 0, 340.0, -170.0, 0, +0.0, 0.0, 0}, +{"pow", pow, "pow", pow, 2, POWER, 1, 21.0, 0.0, 0, +42.0, -21.0, 0}, +{" acos", acos, " cos", cos, 1, 0, 0, 2.0, -1.0, 0, +0.0, 0.0, 0}, +#if GLIBC2 +{ "gamma", gamma, "lgamma", lgamma, 1, GAMMA, 0, 34.0, 0.0, 0, +0.0, 0.0, 0}, +#else +{ "gamma", gamma, "lgam", lgam, 1, GAMMA, 0, 34.0, 0.0, 0, +0.0, 0.0, 0}, +#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: ", +"Wronksian of %s, %s: ", +"Wronksian of %s, %s: " +}; + +static double yy1 = 0.0; +static double y2 = 0.0; +static double y3 = 0.0; +static double y4 = 0.0; +static double a = 0.0; +static double x = 0.0; +static double y = 0.0; +static double z = 0.0; +static double e = 0.0; +static double max = 0.0; +static double rmsa = 0.0; +static double rms = 0.0; +static double ave = 0.0; + + +int main() +{ +double (*fun )(); +double (*ifun )(); +struct fundef *d; +int i, k, itst; +int m, ntr; + +#if SETPREC +dprec(); /* set coprocessor precision */ +#endif +ntr = NTRIALS; +printf( "Consistency test of math functions.\n" ); +printf( "Max and rms relative errors for %d random arguments.\n", + ntr ); + +/* Initialize machine dependent parameters: */ +defs[1].arg1w = PI; +defs[1].arg1l = -PI/2.0; +/* Microsoft C has trouble with denormal numbers. */ +#if 0 +defs[3].arg1w = MAXLOG; +defs[3].arg1l = -MAXLOG/2.0; +defs[4].arg1w = 2*MAXLOG; +defs[4].arg1l = -MAXLOG; +#endif +defs[6].arg1w = 2.0*MAXLOG; +defs[6].arg1l = -MAXLOG; +defs[7].arg1w = MAXLOG; +defs[7].arg1l = 0.0; + + +/* Outer loop, on the test number: */ + +for( itst=STRTST; itst<NTESTS; itst++ ) +{ +d = &defs[itst]; +k = 0; +m = 0; +max = 0.0; +rmsa = 0.0; +ave = 0.0; +fun = d->name; +ifun = d->inv; + +/* Absolute error criterion starts with gamma function + * (put all such at end of table) + */ +if( d->tstyp == GAMMA ) + printf( "Absolute error criterion (but relative if >1):\n" ); + +/* 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 ); + } + +printf( headrs[d->tstyp], d->nam2, d->nam1 ); + +for( i=0; i<ntr; i++ ) +{ +m++; + +/* make random number(s) in desired range(s) */ +switch( d->nargs ) +{ + +default: +goto illegn; + +case 2: +drand( &a ); +a = d->arg2w * ( a - 1.0 ) + d->arg2l; +if( d->arg2f & EXPSCAL ) + { + a = exp(a); + drand( &y2 ); + a -= 1.0e-13 * a * y2; + } +if( d->arg2f & INT ) + { + k = a + 0.25; + a = k; + } + +case 1: +drand( &x ); +x = d->arg1w * ( x - 1.0 ) + d->arg1l; +if( d->arg1f & EXPSCAL ) + { + x = exp(x); + drand( &a ); + x += 1.0e-13 * x * a; + } +} + + +/* compute function under test */ +switch( d->nargs ) + { + case 1: + switch( d->tstyp ) + { + case ELLIP: + yy1 = ( *(fun) )(x); + y2 = ( *(fun) )(1.0-x); + y3 = ( *(ifun) )(x); + y4 = ( *(ifun) )(1.0-x); + break; + +#if 1 + case GAMMA: +#if GLIBC2 + y = lgamma(x); +#else + y = lgam(x); +#endif + x = log( gamma(x) ); + break; +#endif + default: + z = ( *(fun) )(x); + y = ( *(ifun) )(z); + } + break; + + case 2: + if( d->arg2f & INT ) + { + switch( d->tstyp ) + { + case WRONK1: + yy1 = (*fun)( k, x ); /* jn */ + y2 = (*fun)( k+1, x ); + y3 = (*ifun)( k, x ); /* yn */ + y4 = (*ifun)( k+1, x ); + break; + + case WRONK2: + yy1 = (*fun)( a, x ); /* iv */ + y2 = (*fun)( a+1.0, 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.0/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: + e = (y2*y3 - yy1*y4) - 2.0/(PI*x); /* Jn, Yn */ + break; + + case WRONK2: + e = (y2*y3 + yy1*y4) - 1.0/x; /* In, Kn */ + break; + + case ELLIP: + e = (yy1-y3)*y4 + y3*y2 - PIO2; + break; + + default: + e = y - x; + break; + } + +if( d->ctrl & RELERR ) + e /= x; +else + { + if( fabs(x) > 1.0 ) + 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-10 ) + { + printf("x %.6E z %.6E y %.6E max %.4E\n", + x, z, y, max); + if( d->tstyp == POWER ) + { + printf( "a %.6E\n", a ); + } + if( d->tstyp >= WRONK1 ) + { + printf( "yy1 %.4E y2 %.4E y3 %.4E y4 %.4E k %d x %.4E\n", + yy1, y2, y3, y4, k, 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.0e16; /* adjust range */ +rmsa += e * e; /* accumulate the square of the error */ +} + +/* report after NTRIALS trials */ +rms = 1.0e-16 * sqrt( rmsa/m ); +if(d->ctrl & RELERR) + printf(" max = %.2E rms = %.2E\n", max, rms ); +else + printf(" max = %.2E A rms = %.2E A\n", max, rms ); +} /* loop on itst */ + +exit(0); +} diff --git a/libm/double/nbdtr.c b/libm/double/nbdtr.c new file mode 100644 index 000000000..9930a4087 --- /dev/null +++ b/libm/double/nbdtr.c @@ -0,0 +1,222 @@ +/* nbdtr.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtr(); + * + * y = nbdtr( 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 (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 100000 1.7e-13 8.8e-15 + * See also incbet.c. + * + */ + /* nbdtrc.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtrc(); + * + * y = nbdtrc( 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: + * + * Tested at random points (a,b,p), with p between 0 and 1. + * + * a,b Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 100000 1.7e-13 8.8e-15 + * See also incbet.c. + */ + +/* nbdtrc + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtrc(); + * + * y = nbdtrc( 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 incbet.c. + */ + /* nbdtri + * + * Functional inverse of negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * double p, y, nbdtri(); + * + * p = nbdtri( 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 100000 1.5e-14 8.5e-16 + * See also incbi.c. + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +#else +double incbet(), incbi(); +#endif + +double nbdtrc( k, n, p ) +int k, n; +double p; +{ +double dk, dn; + +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtr", DOMAIN ); + return( 0.0 ); + } + +dk = k+1; +dn = n; +return( incbet( dk, dn, 1.0 - p ) ); +} + + + +double nbdtr( k, n, p ) +int k, n; +double p; +{ +double dk, dn; + +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtr", DOMAIN ); + return( 0.0 ); + } +dk = k+1; +dn = n; +return( incbet( dn, dk, p ) ); +} + + + +double nbdtri( k, n, p ) +int k, n; +double p; +{ +double dk, dn, w; + +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtri", DOMAIN ); + return( 0.0 ); + } +dk = k+1; +dn = n; +w = incbi( dn, dk, p ); +return( w ); +} diff --git a/libm/double/ndtr.c b/libm/double/ndtr.c new file mode 100644 index 000000000..75d59ab54 --- /dev/null +++ b/libm/double/ndtr.c @@ -0,0 +1,481 @@ +/* ndtr.c + * + * Normal distribution function + * + * + * + * SYNOPSIS: + * + * double x, y, ndtr(); + * + * y = ndtr( 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 + * DEC -13,0 8000 2.1e-15 4.8e-16 + * IEEE -13,0 30000 3.4e-14 6.7e-15 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfc underflow x > 37.519379347 0.0 + * + */ + /* erf.c + * + * Error function + * + * + * + * SYNOPSIS: + * + * double x, y, erf(); + * + * y = erf( x ); + * + * + * + * DESCRIPTION: + * + * The integral is + * + * x + * - + * 2 | | 2 + * erf(x) = -------- | exp( - t ) dt. + * sqrt(pi) | | + * - + * 0 + * + * The magnitude of x is limited to 9.231948545 for DEC + * arithmetic; 1 or -1 is returned outside this range. + * + * For 0 <= |x| < 1, erf(x) = x * P4(x**2)/Q5(x**2); otherwise + * erf(x) = 1 - erfc(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0,1 14000 4.7e-17 1.5e-17 + * IEEE 0,1 30000 3.7e-16 1.0e-16 + * + */ + /* erfc.c + * + * Complementary error function + * + * + * + * SYNOPSIS: + * + * double x, y, erfc(); + * + * y = erfc( 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 + * DEC 0, 9.2319 12000 5.1e-16 1.2e-16 + * IEEE 0,26.6417 30000 5.7e-14 1.5e-14 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfc underflow x > 9.231948545 (DEC) 0.0 + * + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 1992, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +extern double SQRTH; +extern double MAXLOG; + + +#ifdef UNK +static double P[] = { + 2.46196981473530512524E-10, + 5.64189564831068821977E-1, + 7.46321056442269912687E0, + 4.86371970985681366614E1, + 1.96520832956077098242E2, + 5.26445194995477358631E2, + 9.34528527171957607540E2, + 1.02755188689515710272E3, + 5.57535335369399327526E2 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.32281951154744992508E1, + 8.67072140885989742329E1, + 3.54937778887819891062E2, + 9.75708501743205489753E2, + 1.82390916687909736289E3, + 2.24633760818710981792E3, + 1.65666309194161350182E3, + 5.57535340817727675546E2 +}; +static double R[] = { + 5.64189583547755073984E-1, + 1.27536670759978104416E0, + 5.01905042251180477414E0, + 6.16021097993053585195E0, + 7.40974269950448939160E0, + 2.97886665372100240670E0 +}; +static double S[] = { +/* 1.00000000000000000000E0,*/ + 2.26052863220117276590E0, + 9.39603524938001434673E0, + 1.20489539808096656605E1, + 1.70814450747565897222E1, + 9.60896809063285878198E0, + 3.36907645100081516050E0 +}; +static double T[] = { + 9.60497373987051638749E0, + 9.00260197203842689217E1, + 2.23200534594684319226E3, + 7.00332514112805075473E3, + 5.55923013010394962768E4 +}; +static double U[] = { +/* 1.00000000000000000000E0,*/ + 3.35617141647503099647E1, + 5.21357949780152679795E2, + 4.59432382970980127987E3, + 2.26290000613890934246E4, + 4.92673942608635921086E4 +}; + +#define UTHRESH 37.519379347 +#endif + +#ifdef DEC +static unsigned short P[] = { +0030207,0054445,0011173,0021706, +0040020,0067272,0030661,0122075, +0040756,0151236,0173053,0067042, +0041502,0106175,0062555,0151457, +0042104,0102525,0047401,0003667, +0042403,0116176,0011446,0075303, +0042551,0120723,0061641,0123275, +0042600,0070651,0007264,0134516, +0042413,0061102,0167507,0176625 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041123,0123257,0165741,0017142, +0041655,0065027,0173413,0115450, +0042261,0074011,0021573,0004150, +0042563,0166530,0013662,0007200, +0042743,0176427,0162443,0105214, +0043014,0062546,0153727,0123772, +0042717,0012470,0006227,0067424, +0042413,0061103,0003042,0013254 +}; +static unsigned short R[] = { +0040020,0067272,0101024,0155421, +0040243,0037467,0056706,0026462, +0040640,0116017,0120665,0034315, +0040705,0020162,0143350,0060137, +0040755,0016234,0134304,0130157, +0040476,0122700,0051070,0015473 +}; +static unsigned short S[] = { +/*0040200,0000000,0000000,0000000,*/ +0040420,0126200,0044276,0070413, +0041026,0053051,0007302,0063746, +0041100,0144203,0174051,0061151, +0041210,0123314,0126343,0177646, +0041031,0137125,0051431,0033011, +0040527,0117362,0152661,0066201 +}; +static unsigned short T[] = { +0041031,0126770,0170672,0166101, +0041664,0006522,0072360,0031770, +0043013,0100025,0162641,0126671, +0043332,0155231,0161627,0076200, +0044131,0024115,0021020,0117343 +}; +static unsigned short U[] = { +/*0040200,0000000,0000000,0000000,*/ +0041406,0037461,0177575,0032714, +0042402,0053350,0123061,0153557, +0043217,0111227,0032007,0164217, +0043660,0145000,0004013,0160114, +0044100,0071544,0167107,0125471 +}; +#define UTHRESH 14.0 +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x6479,0xa24f,0xeb24,0x3df0, +0x3488,0x4636,0x0dd7,0x3fe2, +0x6dc4,0xdec5,0xda53,0x401d, +0xba66,0xacad,0x518f,0x4048, +0x20f7,0xa9e0,0x90aa,0x4068, +0xcf58,0xc264,0x738f,0x4080, +0x34d8,0x6c74,0x343a,0x408d, +0x972a,0x21d6,0x0e35,0x4090, +0xffb3,0x5de8,0x6c48,0x4081 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x23cc,0xfd7c,0x74d5,0x402a, +0x7365,0xfee1,0xad42,0x4055, +0x610d,0x246f,0x2f01,0x4076, +0x41d0,0x02f6,0x7dab,0x408e, +0x7151,0xfca4,0x7fa2,0x409c, +0xf4ff,0xdafa,0x8cac,0x40a1, +0xede2,0x0192,0xe2a7,0x4099, +0x42d6,0x60c4,0x6c48,0x4081 +}; +static unsigned short R[] = { +0x9b62,0x5042,0x0dd7,0x3fe2, +0xc5a6,0xebb8,0x67e6,0x3ff4, +0xa71a,0xf436,0x1381,0x4014, +0x0c0c,0x58dd,0xa40e,0x4018, +0x960e,0x9718,0xa393,0x401d, +0x0367,0x0a47,0xd4b8,0x4007 +}; +static unsigned short S[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xce21,0x0917,0x1590,0x4002, +0x4cfd,0x21d8,0xcac5,0x4022, +0x2c4d,0x7f05,0x1910,0x4028, +0x7ff5,0x959c,0x14d9,0x4031, +0x26c1,0xaa63,0x37ca,0x4023, +0x2d90,0x5ab6,0xf3de,0x400a +}; +static unsigned short T[] = { +0x5d88,0x1e37,0x35bf,0x4023, +0x067f,0x4e9e,0x81aa,0x4056, +0x35b7,0xbcb4,0x7002,0x40a1, +0xef90,0x3c72,0x5b53,0x40bb, +0x13dc,0xa442,0x2509,0x40eb +}; +static unsigned short U[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xa6ba,0x3fef,0xc7e6,0x4040, +0x3aee,0x14c6,0x4add,0x4080, +0xfd12,0xe680,0xf252,0x40b1, +0x7c0a,0x0101,0x1940,0x40d6, +0xf567,0x9dc8,0x0e6c,0x40e8 +}; +#define UTHRESH 37.519379347 +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3df0,0xeb24,0xa24f,0x6479, +0x3fe2,0x0dd7,0x4636,0x3488, +0x401d,0xda53,0xdec5,0x6dc4, +0x4048,0x518f,0xacad,0xba66, +0x4068,0x90aa,0xa9e0,0x20f7, +0x4080,0x738f,0xc264,0xcf58, +0x408d,0x343a,0x6c74,0x34d8, +0x4090,0x0e35,0x21d6,0x972a, +0x4081,0x6c48,0x5de8,0xffb3 +}; +static unsigned short Q[] = { +0x402a,0x74d5,0xfd7c,0x23cc, +0x4055,0xad42,0xfee1,0x7365, +0x4076,0x2f01,0x246f,0x610d, +0x408e,0x7dab,0x02f6,0x41d0, +0x409c,0x7fa2,0xfca4,0x7151, +0x40a1,0x8cac,0xdafa,0xf4ff, +0x4099,0xe2a7,0x0192,0xede2, +0x4081,0x6c48,0x60c4,0x42d6 +}; +static unsigned short R[] = { +0x3fe2,0x0dd7,0x5042,0x9b62, +0x3ff4,0x67e6,0xebb8,0xc5a6, +0x4014,0x1381,0xf436,0xa71a, +0x4018,0xa40e,0x58dd,0x0c0c, +0x401d,0xa393,0x9718,0x960e, +0x4007,0xd4b8,0x0a47,0x0367 +}; +static unsigned short S[] = { +0x4002,0x1590,0x0917,0xce21, +0x4022,0xcac5,0x21d8,0x4cfd, +0x4028,0x1910,0x7f05,0x2c4d, +0x4031,0x14d9,0x959c,0x7ff5, +0x4023,0x37ca,0xaa63,0x26c1, +0x400a,0xf3de,0x5ab6,0x2d90 +}; +static unsigned short T[] = { +0x4023,0x35bf,0x1e37,0x5d88, +0x4056,0x81aa,0x4e9e,0x067f, +0x40a1,0x7002,0xbcb4,0x35b7, +0x40bb,0x5b53,0x3c72,0xef90, +0x40eb,0x2509,0xa442,0x13dc +}; +static unsigned short U[] = { +0x4040,0xc7e6,0x3fef,0xa6ba, +0x4080,0x4add,0x14c6,0x3aee, +0x40b1,0xf252,0xe680,0xfd12, +0x40d6,0x1940,0x0101,0x7c0a, +0x40e8,0x0e6c,0x9dc8,0xf567 +}; +#define UTHRESH 37.519379347 +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double exp ( double ); +extern double log ( double ); +extern double fabs ( double ); +double erf ( double ); +double erfc ( double ); +#else +double polevl(), p1evl(), exp(), log(), fabs(); +double erf(), erfc(); +#endif + +double ndtr(a) +double a; +{ +double x, y, z; + +x = a * SQRTH; +z = fabs(x); + +if( z < SQRTH ) + y = 0.5 + 0.5 * erf(x); + +else + { + y = 0.5 * erfc(z); + + if( x > 0 ) + y = 1.0 - y; + } + +return(y); +} + + +double erfc(a) +double a; +{ +double p,q,x,y,z; + + +if( a < 0.0 ) + x = -a; +else + x = a; + +if( x < 1.0 ) + return( 1.0 - erf(a) ); + +z = -a * a; + +if( z < -MAXLOG ) + { +under: + mtherr( "erfc", UNDERFLOW ); + if( a < 0 ) + return( 2.0 ); + else + return( 0.0 ); + } + +z = exp(z); + +if( x < 8.0 ) + { + p = polevl( x, P, 8 ); + q = p1evl( x, Q, 8 ); + } +else + { + p = polevl( x, R, 5 ); + q = p1evl( x, S, 6 ); + } +y = (z * p)/q; + +if( a < 0 ) + y = 2.0 - y; + +if( y == 0.0 ) + goto under; + +return(y); +} + + + +double erf(x) +double x; +{ +double y, z; + +if( fabs(x) > 1.0 ) + return( 1.0 - erfc(x) ); +z = x * x; +y = x * polevl( z, T, 4 ) / p1evl( z, U, 5 ); +return( y ); + +} diff --git a/libm/double/ndtri.c b/libm/double/ndtri.c new file mode 100644 index 000000000..948e36c50 --- /dev/null +++ b/libm/double/ndtri.c @@ -0,0 +1,417 @@ +/* ndtri.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * double x, y, ndtri(); + * + * x = ndtri( 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.0 * log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). + * There are two rational functions P/Q, one for 0 < y < exp(-32) + * and the other for y up to exp(-2). For larger arguments, + * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0.125, 1 5500 9.5e-17 2.1e-17 + * DEC 6e-39, 0.135 3500 5.7e-17 1.3e-17 + * IEEE 0.125, 1 20000 7.2e-16 1.3e-16 + * IEEE 3e-308, 0.135 50000 4.6e-16 9.8e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtri domain x <= 0 -MAXNUM + * ndtri domain x >= 1 MAXNUM + * + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +extern double MAXNUM; + +#ifdef UNK +/* sqrt(2pi) */ +static double s2pi = 2.50662827463100050242E0; +#endif + +#ifdef DEC +static unsigned short s2p[] = {0040440,0066230,0177661,0034055}; +#define s2pi *(double *)s2p +#endif + +#ifdef IBMPC +static unsigned short s2p[] = {0x2706,0x1ff6,0x0d93,0x4004}; +#define s2pi *(double *)s2p +#endif + +#ifdef MIEEE +static unsigned short s2p[] = { +0x4004,0x0d93,0x1ff6,0x2706 +}; +#define s2pi *(double *)s2p +#endif + +/* approximation for 0 <= |y - 0.5| <= 3/8 */ +#ifdef UNK +static double P0[5] = { +-5.99633501014107895267E1, + 9.80010754185999661536E1, +-5.66762857469070293439E1, + 1.39312609387279679503E1, +-1.23916583867381258016E0, +}; +static double Q0[8] = { +/* 1.00000000000000000000E0,*/ + 1.95448858338141759834E0, + 4.67627912898881538453E0, + 8.63602421390890590575E1, +-2.25462687854119370527E2, + 2.00260212380060660359E2, +-8.20372256168333339912E1, + 1.59056225126211695515E1, +-1.18331621121330003142E0, +}; +#endif +#ifdef DEC +static unsigned short P0[20] = { +0141557,0155170,0071360,0120550, +0041704,0000214,0172417,0067307, +0141542,0132204,0040066,0156723, +0041136,0163161,0157276,0007747, +0140236,0116374,0073666,0051764, +}; +static unsigned short Q0[32] = { +/*0040200,0000000,0000000,0000000,*/ +0040372,0026256,0110403,0123707, +0040625,0122024,0020277,0026661, +0041654,0134161,0124134,0007244, +0142141,0073162,0133021,0131371, +0042110,0041235,0043516,0057767, +0141644,0011417,0036155,0137305, +0041176,0076556,0004043,0125430, +0140227,0073347,0152776,0067251, +}; +#endif +#ifdef IBMPC +static unsigned short P0[20] = { +0x142d,0x0e5e,0xfb4f,0xc04d, +0xedd9,0x9ea1,0x8011,0x4058, +0xdbba,0x8806,0x5690,0xc04c, +0xc1fd,0x3bd7,0xdcce,0x402b, +0xca7e,0x8ef6,0xd39f,0xbff3, +}; +static unsigned short Q0[36] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x74f9,0xd220,0x4595,0x3fff, +0xe5b6,0x8417,0xb482,0x4012, +0x81d4,0x350b,0x970e,0x4055, +0x365f,0x56c2,0x2ece,0xc06c, +0xcbff,0xa8e9,0x0853,0x4069, +0xb7d9,0xe78d,0x8261,0xc054, +0x7563,0xc104,0xcfad,0x402f, +0xcdd5,0xfabf,0xeedc,0xbff2, +}; +#endif +#ifdef MIEEE +static unsigned short P0[20] = { +0xc04d,0xfb4f,0x0e5e,0x142d, +0x4058,0x8011,0x9ea1,0xedd9, +0xc04c,0x5690,0x8806,0xdbba, +0x402b,0xdcce,0x3bd7,0xc1fd, +0xbff3,0xd39f,0x8ef6,0xca7e, +}; +static unsigned short Q0[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3fff,0x4595,0xd220,0x74f9, +0x4012,0xb482,0x8417,0xe5b6, +0x4055,0x970e,0x350b,0x81d4, +0xc06c,0x2ece,0x56c2,0x365f, +0x4069,0x0853,0xa8e9,0xcbff, +0xc054,0x8261,0xe78d,0xb7d9, +0x402f,0xcfad,0xc104,0x7563, +0xbff2,0xeedc,0xfabf,0xcdd5, +}; +#endif + + +/* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 + * i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. + */ +#ifdef UNK +static double P1[9] = { + 4.05544892305962419923E0, + 3.15251094599893866154E1, + 5.71628192246421288162E1, + 4.40805073893200834700E1, + 1.46849561928858024014E1, + 2.18663306850790267539E0, +-1.40256079171354495875E-1, +-3.50424626827848203418E-2, +-8.57456785154685413611E-4, +}; +static double Q1[8] = { +/* 1.00000000000000000000E0,*/ + 1.57799883256466749731E1, + 4.53907635128879210584E1, + 4.13172038254672030440E1, + 1.50425385692907503408E1, + 2.50464946208309415979E0, +-1.42182922854787788574E-1, +-3.80806407691578277194E-2, +-9.33259480895457427372E-4, +}; +#endif +#ifdef DEC +static unsigned short P1[36] = { +0040601,0143074,0150744,0073326, +0041374,0031554,0113253,0146016, +0041544,0123272,0012463,0176771, +0041460,0051160,0103560,0156511, +0041152,0172624,0117772,0030755, +0040413,0170713,0151545,0176413, +0137417,0117512,0022154,0131671, +0137017,0104257,0071432,0007072, +0135540,0143363,0063137,0036166, +}; +static unsigned short Q1[32] = { +/*0040200,0000000,0000000,0000000,*/ +0041174,0075325,0004736,0120326, +0041465,0110044,0047561,0045567, +0041445,0042321,0012142,0030340, +0041160,0127074,0166076,0141051, +0040440,0046055,0040745,0150400, +0137421,0114146,0067330,0010621, +0137033,0175162,0025555,0114351, +0135564,0122773,0145750,0030357, +}; +#endif +#ifdef IBMPC +static unsigned short P1[36] = { +0x8edb,0x9a3c,0x38c7,0x4010, +0x7982,0x92d5,0x866d,0x403f, +0x7fbf,0x42a6,0x94d7,0x404c, +0x1ba9,0x10ee,0x0a4e,0x4046, +0x463e,0x93ff,0x5eb2,0x402d, +0xbfa1,0x7a6c,0x7e39,0x4001, +0x9677,0x448d,0xf3e9,0xbfc1, +0x41c7,0xee63,0xf115,0xbfa1, +0xe78f,0x6ccb,0x18de,0xbf4c, +}; +static unsigned short Q1[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xd41b,0xa13b,0x8f5a,0x402f, +0x296f,0x89ee,0xb204,0x4046, +0x461c,0x228c,0xa89a,0x4044, +0xd845,0x9d87,0x15c7,0x402e, +0xba20,0xa83c,0x0985,0x4004, +0x0232,0xcddb,0x330c,0xbfc2, +0xb31d,0x456d,0x7f4e,0xbfa3, +0x061e,0x797d,0x94bf,0xbf4e, +}; +#endif +#ifdef MIEEE +static unsigned short P1[36] = { +0x4010,0x38c7,0x9a3c,0x8edb, +0x403f,0x866d,0x92d5,0x7982, +0x404c,0x94d7,0x42a6,0x7fbf, +0x4046,0x0a4e,0x10ee,0x1ba9, +0x402d,0x5eb2,0x93ff,0x463e, +0x4001,0x7e39,0x7a6c,0xbfa1, +0xbfc1,0xf3e9,0x448d,0x9677, +0xbfa1,0xf115,0xee63,0x41c7, +0xbf4c,0x18de,0x6ccb,0xe78f, +}; +static unsigned short Q1[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x402f,0x8f5a,0xa13b,0xd41b, +0x4046,0xb204,0x89ee,0x296f, +0x4044,0xa89a,0x228c,0x461c, +0x402e,0x15c7,0x9d87,0xd845, +0x4004,0x0985,0xa83c,0xba20, +0xbfc2,0x330c,0xcddb,0x0232, +0xbfa3,0x7f4e,0x456d,0xb31d, +0xbf4e,0x94bf,0x797d,0x061e, +}; +#endif + +/* Approximation for interval z = sqrt(-2 log y ) between 8 and 64 + * i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890. + */ + +#ifdef UNK +static double P2[9] = { + 3.23774891776946035970E0, + 6.91522889068984211695E0, + 3.93881025292474443415E0, + 1.33303460815807542389E0, + 2.01485389549179081538E-1, + 1.23716634817820021358E-2, + 3.01581553508235416007E-4, + 2.65806974686737550832E-6, + 6.23974539184983293730E-9, +}; +static double Q2[8] = { +/* 1.00000000000000000000E0,*/ + 6.02427039364742014255E0, + 3.67983563856160859403E0, + 1.37702099489081330271E0, + 2.16236993594496635890E-1, + 1.34204006088543189037E-2, + 3.28014464682127739104E-4, + 2.89247864745380683936E-6, + 6.79019408009981274425E-9, +}; +#endif +#ifdef DEC +static unsigned short P2[36] = { +0040517,0033507,0036236,0125641, +0040735,0044616,0014473,0140133, +0040574,0012567,0114535,0102541, +0040252,0120340,0143474,0150135, +0037516,0051057,0115361,0031211, +0036512,0131204,0101511,0125144, +0035236,0016627,0043160,0140216, +0033462,0060512,0060141,0010641, +0031326,0062541,0101304,0077706, +}; +static unsigned short Q2[32] = { +/*0040200,0000000,0000000,0000000,*/ +0040700,0143322,0132137,0040501, +0040553,0101155,0053221,0140257, +0040260,0041071,0052573,0010004, +0037535,0066472,0177261,0162330, +0036533,0160475,0066666,0036132, +0035253,0174533,0027771,0044027, +0033502,0016147,0117666,0063671, +0031351,0047455,0141663,0054751, +}; +#endif +#ifdef IBMPC +static unsigned short P2[36] = { +0xd574,0xe793,0xe6e8,0x4009, +0x780b,0xc327,0xa931,0x401b, +0xb0ac,0xf32b,0x82ae,0x400f, +0x9a0c,0x18e7,0x541c,0x3ff5, +0x2651,0xf35e,0xca45,0x3fc9, +0x354d,0x9069,0x5650,0x3f89, +0x1812,0xe8ce,0xc3b2,0x3f33, +0x2234,0x4c0c,0x4c29,0x3ec6, +0x8ff9,0x3058,0xccac,0x3e3a, +}; +static unsigned short Q2[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xe828,0x568b,0x18da,0x4018, +0x3816,0xaad2,0x704d,0x400d, +0x6200,0x2aaf,0x0847,0x3ff6, +0x3c9b,0x5fd6,0xada7,0x3fcb, +0xc78b,0xadb6,0x7c27,0x3f8b, +0x2903,0x65ff,0x7f2b,0x3f35, +0xccf7,0xf3f6,0x438c,0x3ec8, +0x6b3d,0xb876,0x29e5,0x3e3d, +}; +#endif +#ifdef MIEEE +static unsigned short P2[36] = { +0x4009,0xe6e8,0xe793,0xd574, +0x401b,0xa931,0xc327,0x780b, +0x400f,0x82ae,0xf32b,0xb0ac, +0x3ff5,0x541c,0x18e7,0x9a0c, +0x3fc9,0xca45,0xf35e,0x2651, +0x3f89,0x5650,0x9069,0x354d, +0x3f33,0xc3b2,0xe8ce,0x1812, +0x3ec6,0x4c29,0x4c0c,0x2234, +0x3e3a,0xccac,0x3058,0x8ff9, +}; +static unsigned short Q2[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4018,0x18da,0x568b,0xe828, +0x400d,0x704d,0xaad2,0x3816, +0x3ff6,0x0847,0x2aaf,0x6200, +0x3fcb,0xada7,0x5fd6,0x3c9b, +0x3f8b,0x7c27,0xadb6,0xc78b, +0x3f35,0x7f2b,0x65ff,0x2903, +0x3ec8,0x438c,0xf3f6,0xccf7, +0x3e3d,0x29e5,0xb876,0x6b3d, +}; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double log ( double ); +extern double sqrt ( double ); +#else +double polevl(), p1evl(), log(), sqrt(); +#endif + +double ndtri(y0) +double y0; +{ +double x, y, z, y2, x0, x1; +int code; + +if( y0 <= 0.0 ) + { + mtherr( "ndtri", DOMAIN ); + return( -MAXNUM ); + } +if( y0 >= 1.0 ) + { + mtherr( "ndtri", DOMAIN ); + return( MAXNUM ); + } +code = 1; +y = y0; +if( y > (1.0 - 0.13533528323661269189) ) /* 0.135... = exp(-2) */ + { + y = 1.0 - y; + code = 0; + } + +if( y > 0.13533528323661269189 ) + { + y = y - 0.5; + y2 = y * y; + x = y + y * (y2 * polevl( y2, P0, 4)/p1evl( y2, Q0, 8 )); + x = x * s2pi; + return(x); + } + +x = sqrt( -2.0 * log(y) ); +x0 = x - log(x)/x; + +z = 1.0/x; +if( x < 8.0 ) /* y > exp(-32) = 1.2664165549e-14 */ + x1 = z * polevl( z, P1, 8 )/p1evl( z, Q1, 8 ); +else + x1 = z * polevl( z, P2, 8 )/p1evl( z, Q2, 8 ); +x = x0 - x1; +if( code != 0 ) + x = -x; +return( x ); +} diff --git a/libm/double/paranoia.c b/libm/double/paranoia.c new file mode 100644 index 000000000..49ff72623 --- /dev/null +++ b/libm/double/paranoia.c @@ -0,0 +1,2156 @@ +/* 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> + +extern double fabs(), floor(), log(), pow(), sqrt(); + +#ifdef Single +#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)) +#else +#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) +#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; +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; +FLOAT Y, Y1, Y2, Random2; +FLOAT Z, PseudoZero, Z1, Z2, Z9; +volatile FLOAT VV; +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(); +} + +main() +{ + /* Set coprocessor to double precision, no arith traps. */ + /* __setfpucw(0x127f);*/ + dprec(); + /* 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 = %f .\n", 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 = %.7e .\n\n", U1); + 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 = %.7e .\n", 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 = %.7e .\n", 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 %f .\n", + 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 %.7e, %.7e, %.7e,\n", X1, Y1, 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 = %.7e, Z1 - U1 = %.7e\n",U1,Z1-U1); + printf("\tU2 = %.7e, Z2 - U2 = %.7e\n",U2,Z2-U2); + } + else { + if ((Z1 <= Zero) || (Z2 <= Zero)) { + printf("Because of unusual Radix = %f", Radix); + printf(", or exact rational arithmetic a result\n"); + printf("Z1 = %.7e, or Z2 = %.7e ", Z1, 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 %g extra B-digits, i.e.\n", + (Q / LOG(Radix))); + printf("roughly %g extra significant decimals.\n", + Q / LOG(10.)); + } + 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)) { + 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); + Random9 = SQRT(3.0); + 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 %.7e .\n", 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 = %.7e\n", 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 %.7e ", MinSqEr - Half); + printf("to %.7e ulps.\n", Half + MaxSqEr); + 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; + VV = Z; + } while ((Y > Z) && (VV + VV > VV)); + Y = C; + Z = Y * D; + do { + C = Y; + Y = Z; + Z = Y * D; + VV = Z; + } while ((Y > Z) && (VV + VV > VV)); + 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; + VV = Z; + } while ((E0 > VV) && (VV + VV > VV)); + 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; + VV = PseudoZero; + } while ((Underflow > VV) + && (VV + VV > VV)); + } + /* 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: %g .\n", PseudoZero); + X = - PseudoZero; + if (X <= Zero) { + printf("But -PseudoZero, which should be\n"); + printf("positive, isn't; it prints out as %g .\n", X); + } + } + else { + BadCond(Flaw, "Underflow can stick at an allegedly positive\n"); + printf("value PseudoZero that prints out as %g .\n", 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 = %g .\n", 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 = %.17e\n", UfThold);; + printf(" coming down from %.17e\n", 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 = %.17e, Y = %.17e .\n", Q, Y); + printf ("|Q - Y| = %.17e .\n" , FABS(Q - Y2)); + 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 = %.17e\n\tis not equal to Z = %.17e .\n", X, Z); + Z9 = X - Z; + printf("yet X - Z yields %.17e .\n", 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 + %g .\n", (X / Z - Half) - Half); + } + } + printf("The Underflow threshold is %.17e, %s\n", UfThold, + " below which"); + printf("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 + Y; + printf("Since underflow occurs below the threshold\n"); + printf("UfThold = (%.17e) ^ (%.17e)\nonly underflow ", HInvrse, Y); + printf("should afflict the expression\n\t(%.17e) ^ (%.17e);\n", HInvrse, Y); + V9 = POW(HInvrse, Y2); + printf("actually calculating yields: %.17e .\n", V9); + if (! ((V9 >= Zero) && (V9 <= (Radix + Radix + E9) * UfThold))) { + BadCond(Serious, "this is not between 0 and underflow\n"); + printf(" threshold = %.17e .\n", 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 = %.17e .\n", 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) = %.17e as X -> 1.\n", + Exp2); + 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"); + printf(" %.17e for\n", POW(X,Z)); + printf("\t(1 + (%.17e) ^ (%.17e);\n", V9, Z); + printf("\tdiffers from correct value by %.17e .\n", 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 = %.17e .\n", 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 (Z != Y) { + BadCond(Serious, ""); + printf("overflow past %.17e\n\tshrinks to %.17e .\n", Y, Z); + } + 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 = %.17e .\n", V); + if (I) printf("Overflow saturates at V0 = %.17e .\n", 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 = %.17e\n", V9); + V9 = V / One; + printf(" nor for V / 1 = %.17e .\n", 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("+-%g, +-%g\nand +-%g are confused by Overflow.", + V, V0, UfThold); + } + /*=============================================*/ + 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 = %.17e\n", Z); + printf(" is too far from sqrt(Z) ^ 2 = %.17e .\n", 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 = %17e\n", Z); + printf(" is too far from sqrt(Z) ^ 2 (%.17e) .\n", 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 = %.17e\n\t%s\n", + X, "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 = %g\n", 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 = %.17e\n", X); + printf(" instead, X / X - 1/2 - 1/2 = %.17e .\n", 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)) printf(" %.7e .\n", One / MyZero); +#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)) printf(" %.7e .\n", Zero / MyZero); +#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( %.17e) - %.17e = %.17e\n", X * X, X, OneUlp * SqEr); + 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(%.17e) ^ (%.17e)\n", Z, Q); + printf("\tyielded %.17e;\n", Y); + printf("\twhich compared unequal to correct %.17e ;\n", + X); + printf("\t\tthey differ by %.17e .\n", Y - X); + } + 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 %.17e .\n", + 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 = "); + printf("%.17e\n\tcompares different from ", Z); + if (Z != Random1) printf("Z * 1 = %.17e ", Random1); + if (! ((Z == Random2) + || (Random2 == Random1))) + printf("1 * Z == %g\n", Random2); + if (! (Z == V9)) printf("Z / 1 = %.17e\n", V9); + if (Random2 != Random1) { + ErrCnt [Defect] = ErrCnt [Defect] + 1; + BadCond(Defect, "Multiplication does not commute!\n"); + printf("\tComparison alleges that 1 * Z = %.17e\n", + Random2); + printf("\tdiffers from Z * 1 = %.17e\n", 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/double/pdtr.c b/libm/double/pdtr.c new file mode 100644 index 000000000..5b4ae4054 --- /dev/null +++ b/libm/double/pdtr.c @@ -0,0 +1,184 @@ +/* pdtr.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtr(); + * + * y = pdtr( 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(). + * + */ + /* pdtrc() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtrc(); + * + * y = pdtrc( 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. + * + */ + /* pdtri() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * double m, y, pdtr(); + * + * m = pdtri( 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.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double igam ( double, double ); +extern double igamc ( double, double ); +extern double igami ( double, double ); +#else +double igam(), igamc(), igami(); +#endif + +double pdtrc( k, m ) +int k; +double m; +{ +double v; + +if( (k < 0) || (m <= 0.0) ) + { + mtherr( "pdtrc", DOMAIN ); + return( 0.0 ); + } +v = k+1; +return( igam( v, m ) ); +} + + + +double pdtr( k, m ) +int k; +double m; +{ +double v; + +if( (k < 0) || (m <= 0.0) ) + { + mtherr( "pdtr", DOMAIN ); + return( 0.0 ); + } +v = k+1; +return( igamc( v, m ) ); +} + + +double pdtri( k, y ) +int k; +double y; +{ +double v; + +if( (k < 0) || (y < 0.0) || (y >= 1.0) ) + { + mtherr( "pdtri", DOMAIN ); + return( 0.0 ); + } +v = k+1; +v = igami( v, y ); +return( v ); +} diff --git a/libm/double/planck.c b/libm/double/planck.c new file mode 100644 index 000000000..834c85dff --- /dev/null +++ b/libm/double/planck.c @@ -0,0 +1,223 @@ +/* planck.c + * + * Integral of Planck's black body radiation formula + * + * + * + * SYNOPSIS: + * + * double lambda, T, y, plancki(); + * + * y = plancki( lambda, T ); + * + * + * + * DESCRIPTION: + * + * Evaluates the definite integral, from wavelength 0 to lambda, + * of Planck's radiation formula + * -5 + * c1 lambda + * E = ------------------ + * c2/(lambda T) + * e - 1 + * + * Physical constants c1 = 3.7417749e-16 and c2 = 0.01438769 are built in + * to the function program. They are scaled to provide a result + * in watts per square meter. Argument T represents temperature in degrees + * Kelvin; lambda is wavelength in meters. + * + * The integral is expressed in closed form, in terms of polylogarithms + * (see polylog.c). + * + * The total area under the curve is + * (-1/8) (42 zeta(4) - 12 pi^2 zeta(2) + pi^4 ) c1 (T/c2)^4 + * = (pi^4 / 15) c1 (T/c2)^4 + * = 5.6705032e-8 T^4 + * where sigma = 5.6705032e-8 W m^2 K^-4 is the Stefan-Boltzmann constant. + * + * + * ACCURACY: + * + * The left tail of the function experiences some relative error + * amplification in computing the dominant term exp(-c2/(lambda T)). + * For the right-hand tail see planckc, below. + * + * Relative error. + * The domain refers to lambda T / c2. + * arithmetic domain # trials peak rms + * IEEE 0.1, 10 50000 7.1e-15 5.4e-16 + * + */ + + +/* +Cephes Math Library Release 2.8: July, 1999 +Copyright 1999 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double polylog (int, double); +extern double exp (double); +extern double log1p (double); /* log(1+x) */ +extern double expm1 (double); /* exp(x) - 1 */ +double planckc(double, double); +double plancki(double, double); +#else +double polylog(), exp(), log1p(), expm1(); +double planckc(), plancki(); +#endif + +/* NIST value (1999): 2 pi h c^2 = 3.741 7749(22) × 10-16 W m2 */ +double planck_c1 = 3.7417749e-16; +/* NIST value (1999): h c / k = 0.014 387 69 m K */ +double planck_c2 = 0.01438769; + + +double +plancki(w, T) + double w, T; +{ + double b, h, y, bw; + + b = T / planck_c2; + bw = b * w; + + if (bw > 0.59375) + { + y = b * b; + h = y * y; + /* Right tail. */ + y = planckc (w, T); + /* pi^4 / 15 */ + y = 6.493939402266829149096 * planck_c1 * h - y; + return y; + } + + h = exp(-planck_c2/(w*T)); + y = 6. * polylog (4, h) * bw; + y = (y + 6. * polylog (3, h)) * bw; + y = (y + 3. * polylog (2, h)) * bw; + y = (y - log1p (-h)) * bw; + h = w * w; + h = h * h; + y = y * (planck_c1 / h); + return y; +} + +/* planckc + * + * Complemented Planck radiation integral + * + * + * + * SYNOPSIS: + * + * double lambda, T, y, planckc(); + * + * y = planckc( lambda, T ); + * + * + * + * DESCRIPTION: + * + * Integral from w to infinity (area under right hand tail) + * of Planck's radiation formula. + * + * The program for large lambda uses an asymptotic series in inverse + * powers of the wavelength. + * + * ACCURACY: + * + * Relative error. + * The domain refers to lambda T / c2. + * arithmetic domain # trials peak rms + * IEEE 0.6, 10 50000 1.1e-15 2.2e-16 + * + */ + +double +planckc (w, T) + double w; + double T; +{ + double b, d, p, u, y; + + b = T / planck_c2; + d = b*w; + if (d <= 0.59375) + { + y = 6.493939402266829149096 * planck_c1 * b*b*b*b; + return (y - plancki(w,T)); + } + u = 1.0/d; + p = u * u; +#if 0 + y = 236364091.*p/365866013534056632601804800000.; + y = (y - 15458917./475677107995483570176000000.)*p; + y = (y + 174611./123104841613737984000000.)*p; + y = (y - 43867./643745871363538944000.)*p; + y = ((y + 3617./1081289781411840000.)*p - 1./5928123801600.)*p; + y = ((y + 691./78460462080000.)*p - 1./2075673600.)*p; + y = ((((y + 1./35481600.)*p - 1.0/544320.)*p + 1.0/6720.)*p - 1./40.)*p; + y = y + log(d * expm1(u)); + y = y - 5.*u/8. + 1./3.; +#else + y = -236364091.*p/45733251691757079075225600000.; + y = (y + 77683./352527500984795136000000.)*p; + y = (y - 174611./18465726242060697600000.)*p; + y = (y + 43867./107290978560589824000.)*p; + y = ((y - 3617./202741834014720000.)*p + 1./1270312243200.)*p; + y = ((y - 691./19615115520000.)*p + 1./622702080.)*p; + y = ((((y - 1./13305600.)*p + 1./272160.)*p - 1./5040.)*p + 1./60.)*p; + y = y - 0.125*u + 1./3.; +#endif + y = y * planck_c1 * b / (w*w*w); + return y; +} + + +/* planckd + * + * Planck's black body radiation formula + * + * + * + * SYNOPSIS: + * + * double lambda, T, y, planckd(); + * + * y = planckd( lambda, T ); + * + * + * + * DESCRIPTION: + * + * Evaluates Planck's radiation formula + * -5 + * c1 lambda + * E = ------------------ + * c2/(lambda T) + * e - 1 + * + */ + +double +planckd(w, T) + double w, T; +{ + return (planck_c2 / ((w*w*w*w*w) * (exp(planck_c2/(w*T)) - 1.0))); +} + + +/* Wavelength, w, of maximum radiation at given temperature T. + c2/wT = constant + Wein displacement law. + */ +double +planckw(T) + double T; +{ + return (planck_c2 / (4.96511423174427630 * T)); +} diff --git a/libm/double/polevl.c b/libm/double/polevl.c new file mode 100644 index 000000000..4d050fbfc --- /dev/null +++ b/libm/double/polevl.c @@ -0,0 +1,97 @@ +/* polevl.c + * p1evl.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * double x, y, coef[N+1], polevl[]; + * + * y = polevl( 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 p1evl() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevl(). + * + * + * 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.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +double polevl( x, coef, N ) +double x; +double coef[]; +int N; +{ +double ans; +int i; +double *p; + +p = coef; +ans = *p++; +i = N; + +do + ans = ans * x + *p++; +while( --i ); + +return( ans ); +} + +/* p1evl() */ +/* N + * Evaluate polynomial when coefficient of x is 1.0. + * Otherwise same as polevl. + */ + +double p1evl( x, coef, N ) +double x; +double coef[]; +int N; +{ +double ans; +double *p; +int i; + +p = coef; +ans = x + *p++; +i = N-1; + +do + ans = ans * x + *p++; +while( --i ); + +return( ans ); +} diff --git a/libm/double/polmisc.c b/libm/double/polmisc.c new file mode 100644 index 000000000..7d517ae69 --- /dev/null +++ b/libm/double/polmisc.c @@ -0,0 +1,309 @@ + +/* Square root, sine, cosine, and arctangent of polynomial. + * See polyn.c for data structures and discussion. + */ + +#include <stdio.h> +#include <math.h> +#ifdef ANSIPROT +extern double atan2 ( double, double ); +extern double sqrt ( double ); +extern double fabs ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern void polclr ( double *a, int n ); +extern void polmov ( double *a, int na, double *b ); +extern void polmul ( double a[], int na, double b[], int nb, double c[] ); +extern void poladd ( double a[], int na, double b[], int nb, double c[] ); +extern void polsub ( double a[], int na, double b[], int nb, double c[] ); +extern int poldiv ( double a[], int na, double b[], int nb, double c[] ); +extern void polsbt ( double a[], int na, double b[], int nb, double c[] ); +extern void * malloc ( long ); +extern void free ( void * ); +#else +double atan2(), sqrt(), fabs(), sin(), cos(); +void polclr(), polmov(), polsbt(), poladd(), polsub(), polmul(); +int poldiv(); +void * malloc(); +void free (); +#endif + +/* Highest degree of polynomial to be handled + by the polyn.c subroutine package. */ +#define N 16 +/* Highest degree actually initialized at runtime. */ +extern int MAXPOL; + +/* Taylor series coefficients for various functions + */ +double patan[N+1] = { + 0.0, 1.0, 0.0, -1.0/3.0, 0.0, + 1.0/5.0, 0.0, -1.0/7.0, 0.0, 1.0/9.0, 0.0, -1.0/11.0, + 0.0, 1.0/13.0, 0.0, -1.0/15.0, 0.0 }; + +double psin[N+1] = { + 0.0, 1.0, 0.0, -1.0/6.0, 0.0, 1.0/120.0, 0.0, + -1.0/5040.0, 0.0, 1.0/362880.0, 0.0, -1.0/39916800.0, + 0.0, 1.0/6227020800.0, 0.0, -1.0/1.307674368e12, 0.0}; + +double pcos[N+1] = { + 1.0, 0.0, -1.0/2.0, 0.0, 1.0/24.0, 0.0, + -1.0/720.0, 0.0, 1.0/40320.0, 0.0, -1.0/3628800.0, 0.0, + 1.0/479001600.0, 0.0, -1.0/8.7179291e10, 0.0, 1.0/2.0922789888e13}; + +double pasin[N+1] = { + 0.0, 1.0, 0.0, 1.0/6.0, 0.0, + 3.0/40.0, 0.0, 15.0/336.0, 0.0, 105.0/3456.0, 0.0, 945.0/42240.0, + 0.0, 10395.0/599040.0 , 0.0, 135135.0/9676800.0 , 0.0 +}; + +/* Square root of 1 + x. */ +double psqrt[N+1] = { + 1.0, 1./2., -1./8., 1./16., -5./128., 7./256., -21./1024., 33./2048., + -429./32768., 715./65536., -2431./262144., 4199./524288., -29393./4194304., + 52003./8388608., -185725./33554432., 334305./67108864., + -9694845./2147483648.}; + +/* Arctangent of the ratio num/den of two polynomials. + */ +void +polatn( num, den, ans, nn ) + double num[], den[], ans[]; + int nn; +{ + double a, t; + double *polq, *polu, *polt; + int i; + + if (nn > N) + { + mtherr ("polatn", OVERFLOW); + return; + } + /* arctan( a + b ) = arctan(a) + arctan( b/(1 + ab + a**2) ) */ + t = num[0]; + a = den[0]; + if( (t == 0.0) && (a == 0.0 ) ) + { + t = num[1]; + a = den[1]; + } + t = atan2( t, a ); /* arctan(num/den), the ANSI argument order */ + polq = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polu = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polt = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polclr( polq, MAXPOL ); + i = poldiv( den, nn, num, nn, polq ); + a = polq[0]; /* a */ + polq[0] = 0.0; /* b */ + polmov( polq, nn, polu ); /* b */ + /* Form the polynomial + 1 + ab + a**2 + where a is a scalar. */ + for( i=0; i<=nn; i++ ) + polu[i] *= a; + polu[0] += 1.0 + a * a; + poldiv( polu, nn, polq, nn, polt ); /* divide into b */ + polsbt( polt, nn, patan, nn, polu ); /* arctan(b) */ + polu[0] += t; /* plus arctan(a) */ + polmov( polu, nn, ans ); + free( polt ); + free( polu ); + free( polq ); +} + + + +/* Square root of a polynomial. + * Assumes the lowest degree nonzero term is dominant + * and of even degree. An error message is given + * if the Newton iteration does not converge. + */ +void +polsqt( pol, ans, nn ) + double pol[], ans[]; + int nn; +{ + double t; + double *x, *y; + int i, n; +#if 0 + double z[N+1]; + double u; +#endif + + if (nn > N) + { + mtherr ("polatn", OVERFLOW); + return; + } + x = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + y = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polmov( pol, nn, x ); + polclr( y, MAXPOL ); + + /* Find lowest degree nonzero term. */ + t = 0.0; + for( n=0; n<nn; n++ ) + { + if( x[n] != 0.0 ) + goto nzero; + } + polmov( y, nn, ans ); + return; + +nzero: + + if( n > 0 ) + { + if (n & 1) + { + printf("error, sqrt of odd polynomial\n"); + return; + } + /* Divide by x^n. */ + y[n] = x[n]; + poldiv (y, nn, pol, N, x); + } + + t = x[0]; + for( i=1; i<=nn; i++ ) + x[i] /= t; + x[0] = 0.0; + /* series development sqrt(1+x) = 1 + x / 2 - x**2 / 8 + x**3 / 16 + hopes that first (constant) term is greater than what follows */ + polsbt( x, nn, psqrt, nn, y); + t = sqrt( t ); + for( i=0; i<=nn; i++ ) + y[i] *= t; + + /* If first nonzero coefficient was at degree n > 0, multiply by + x^(n/2). */ + if (n > 0) + { + polclr (x, MAXPOL); + x[n/2] = 1.0; + polmul (x, nn, y, nn, y); + } +#if 0 +/* Newton iterations */ +for( n=0; n<10; n++ ) + { + poldiv( y, nn, pol, nn, z ); + poladd( y, nn, z, nn, y ); + for( i=0; i<=nn; i++ ) + y[i] *= 0.5; + for( i=0; i<=nn; i++ ) + { + u = fabs( y[i] - z[i] ); + if( u > 1.0e-15 ) + goto more; + } + goto done; +more: ; + } +printf( "square root did not converge\n" ); +done: +#endif /* 0 */ + +polmov( y, nn, ans ); +free( y ); +free( x ); +} + + + +/* Sine of a polynomial. + * The computation uses + * sin(a+b) = sin(a) cos(b) + cos(a) sin(b) + * where a is the constant term of the polynomial and + * b is the sum of the rest of the terms. + * Since sin(b) and cos(b) are computed by series expansions, + * the value of b should be small. + */ +void +polsin( x, y, nn ) + double x[], y[]; + int nn; +{ + double a, sc; + double *w, *c; + int i; + + if (nn > N) + { + mtherr ("polatn", OVERFLOW); + return; + } + w = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + c = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polmov( x, nn, w ); + polclr( c, MAXPOL ); + polclr( y, nn ); + /* a, in the description, is x[0]. b is the polynomial x - x[0]. */ + a = w[0]; + /* c = cos (b) */ + w[0] = 0.0; + polsbt( w, nn, pcos, nn, c ); + sc = sin(a); + /* sin(a) cos (b) */ + for( i=0; i<=nn; i++ ) + c[i] *= sc; + /* y = sin (b) */ + polsbt( w, nn, psin, nn, y ); + sc = cos(a); + /* cos(a) sin(b) */ + for( i=0; i<=nn; i++ ) + y[i] *= sc; + poladd( c, nn, y, nn, y ); + free( c ); + free( w ); +} + + +/* Cosine of a polynomial. + * The computation uses + * cos(a+b) = cos(a) cos(b) - sin(a) sin(b) + * where a is the constant term of the polynomial and + * b is the sum of the rest of the terms. + * Since sin(b) and cos(b) are computed by series expansions, + * the value of b should be small. + */ +void +polcos( x, y, nn ) + double x[], y[]; + int nn; +{ + double a, sc; + double *w, *c; + int i; + double sin(), cos(); + + if (nn > N) + { + mtherr ("polatn", OVERFLOW); + return; + } + w = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + c = (double * )malloc( (MAXPOL+1) * sizeof (double) ); + polmov( x, nn, w ); + polclr( c, MAXPOL ); + polclr( y, nn ); + a = w[0]; + w[0] = 0.0; + /* c = cos(b) */ + polsbt( w, nn, pcos, nn, c ); + sc = cos(a); + /* cos(a) cos(b) */ + for( i=0; i<=nn; i++ ) + c[i] *= sc; + /* y = sin(b) */ + polsbt( w, nn, psin, nn, y ); + sc = sin(a); + /* sin(a) sin(b) */ + for( i=0; i<=nn; i++ ) + y[i] *= sc; + polsub( y, nn, c, nn, y ); + free( c ); + free( w ); +} diff --git a/libm/double/polrt.c b/libm/double/polrt.c new file mode 100644 index 000000000..b1cd88087 --- /dev/null +++ b/libm/double/polrt.c @@ -0,0 +1,227 @@ +/* polrt.c + * + * Find roots of a polynomial + * + * + * + * SYNOPSIS: + * + * typedef struct + * { + * double r; + * double i; + * }cmplx; + * + * double xcof[], cof[]; + * int m; + * cmplx root[]; + * + * polrt( xcof, cof, m, root ) + * + * + * + * DESCRIPTION: + * + * Iterative determination of the roots of a polynomial of + * degree m whose coefficient vector is xcof[]. The + * coefficients are arranged in ascending order; i.e., the + * coefficient of x**m is xcof[m]. + * + * The array cof[] is working storage the same size as xcof[]. + * root[] is the output array containing the complex roots. + * + * + * ACCURACY: + * + * Termination depends on evaluation of the polynomial at + * the trial values of the roots. The values of multiple roots + * or of roots that are nearly equal may have poor relative + * accuracy after the first root in the neighborhood has been + * found. + * + */ + +/* polrt */ +/* Complex roots of real polynomial */ +/* number of coefficients is m + 1 ( i.e., m is degree of polynomial) */ + +#include <math.h> +/* +typedef struct + { + double r; + double i; + }cmplx; +*/ +#ifdef ANSIPROT +extern double fabs ( double ); +#else +double fabs(); +#endif + +int polrt( xcof, cof, m, root ) +double xcof[], cof[]; +int m; +cmplx root[]; +{ +register double *p, *q; +int i, j, nsav, n, n1, n2, nroot, iter, retry; +int final; +double mag, cofj; +cmplx x0, x, xsav, dx, t, t1, u, ud; + +final = 0; +n = m; +if( n <= 0 ) + return(1); +if( n > 36 ) + return(2); +if( xcof[m] == 0.0 ) + return(4); + +n1 = n; +n2 = n; +nroot = 0; +nsav = n; +q = &xcof[0]; +p = &cof[n]; +for( j=0; j<=nsav; j++ ) + *p-- = *q++; /* cof[ n-j ] = xcof[j];*/ +xsav.r = 0.0; +xsav.i = 0.0; + +nxtrut: +x0.r = 0.00500101; +x0.i = 0.01000101; +retry = 0; + +tryagn: +retry += 1; +x.r = x0.r; + +x0.r = -10.0 * x0.i; +x0.i = -10.0 * x.r; + +x.r = x0.r; +x.i = x0.i; + +finitr: +iter = 0; + +while( iter < 500 ) +{ +u.r = cof[n]; +if( u.r == 0.0 ) + { /* this root is zero */ + x.r = 0; + n1 -= 1; + n2 -= 1; + goto zerrut; + } +u.i = 0; +ud.r = 0; +ud.i = 0; +t.r = 1.0; +t.i = 0; +p = &cof[n-1]; +for( i=0; i<n; i++ ) + { + t1.r = x.r * t.r - x.i * t.i; + t1.i = x.r * t.i + x.i * t.r; + cofj = *p--; /* evaluate polynomial */ + u.r += cofj * t1.r; + u.i += cofj * t1.i; + cofj = cofj * (i+1); /* derivative */ + ud.r += cofj * t.r; + ud.i -= cofj * t.i; + t.r = t1.r; + t.i = t1.i; + } + +mag = ud.r * ud.r + ud.i * ud.i; +if( mag == 0.0 ) + { + if( !final ) + goto tryagn; + x.r = xsav.r; + x.i = xsav.i; + goto findon; + } +dx.r = (u.i * ud.i - u.r * ud.r)/mag; +x.r += dx.r; +dx.i = -(u.r * ud.i + u.i * ud.r)/mag; +x.i += dx.i; +if( (fabs(dx.i) + fabs(dx.r)) < 1.0e-6 ) + goto lupdon; +iter += 1; +} /* while iter < 500 */ + +if( final ) + goto lupdon; +if( retry < 5 ) + goto tryagn; +return(3); + +lupdon: +/* Swap original and reduced polynomials */ +q = &xcof[nsav]; +p = &cof[0]; +for( j=0; j<=n2; j++ ) + { + cofj = *q; + *q-- = *p; + *p++ = cofj; + } +i = n; +n = n1; +n1 = i; + +if( !final ) + { + final = 1; + if( fabs(x.i/x.r) < 1.0e-4 ) + x.i = 0.0; + xsav.r = x.r; + xsav.i = x.i; + goto finitr; /* do final iteration on original polynomial */ + } + +findon: +final = 0; +if( fabs(x.i/x.r) >= 1.0e-5 ) + { + cofj = x.r + x.r; + mag = x.r * x.r + x.i * x.i; + n -= 2; + } +else + { /* root is real */ +zerrut: + x.i = 0; + cofj = x.r; + mag = 0; + n -= 1; + } +/* divide working polynomial cof(z) by z - x */ +p = &cof[1]; +*p += cofj * *(p-1); +for( j=1; j<n; j++ ) + { + *(p+1) += cofj * *p - mag * *(p-1); + p++; + } + +setrut: +root[nroot].r = x.r; +root[nroot].i = x.i; +nroot += 1; +if( mag != 0.0 ) + { + x.i = -x.i; + mag = 0; + goto setrut; /* fill in the complex conjugate root */ + } +if( n > 0 ) + goto nxtrut; +return(0); +} diff --git a/libm/double/polylog.c b/libm/double/polylog.c new file mode 100644 index 000000000..c21e04449 --- /dev/null +++ b/libm/double/polylog.c @@ -0,0 +1,467 @@ +/* polylog.c + * + * Polylogarithms + * + * + * + * SYNOPSIS: + * + * double x, y, polylog(); + * int n; + * + * y = polylog( n, x ); + * + * + * The polylogarithm of order n is defined by the series + * + * + * inf k + * - x + * Li (x) = > --- . + * n - n + * k=1 k + * + * + * For x = 1, + * + * inf + * - 1 + * Li (1) = > --- = Riemann zeta function (n) . + * n - n + * k=1 k + * + * + * When n = 2, the function is the dilogarithm, related to Spence's integral: + * + * x 1-x + * - - + * | | -ln(1-t) | | ln t + * Li (x) = | -------- dt = | ------ dt = spence(1-x) . + * 2 | | t | | 1 - t + * - - + * 0 1 + * + * + * See also the program cpolylog.c for the complex polylogarithm, + * whose definition is extended to x > 1. + * + * References: + * + * Lewin, L., _Polylogarithms and Associated Functions_, + * North Holland, 1981. + * + * Lewin, L., ed., _Structural Properties of Polylogarithms_, + * American Mathematical Society, 1991. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain n # trials peak rms + * IEEE 0, 1 2 50000 6.2e-16 8.0e-17 + * IEEE 0, 1 3 100000 2.5e-16 6.6e-17 + * IEEE 0, 1 4 30000 1.7e-16 4.9e-17 + * IEEE 0, 1 5 30000 5.1e-16 7.8e-17 + * + */ + +/* +Cephes Math Library Release 2.8: July, 1999 +Copyright 1999 by Stephen L. Moshier +*/ + +#include <math.h> +extern double PI; + +/* polylog(4, 1-x) = zeta(4) - x zeta(3) + x^2 A4(x)/B4(x) + 0 <= x <= 0.125 + Theoretical peak absolute error 4.5e-18 */ +#if UNK +static double A4[13] = { + 3.056144922089490701751E-2, + 3.243086484162581557457E-1, + 2.877847281461875922565E-1, + 7.091267785886180663385E-2, + 6.466460072456621248630E-3, + 2.450233019296542883275E-4, + 4.031655364627704957049E-6, + 2.884169163909467997099E-8, + 8.680067002466594858347E-11, + 1.025983405866370985438E-13, + 4.233468313538272640380E-17, + 4.959422035066206902317E-21, + 1.059365867585275714599E-25, +}; +static double B4[12] = { + /* 1.000000000000000000000E0, */ + 2.821262403600310974875E0, + 1.780221124881327022033E0, + 3.778888211867875721773E-1, + 3.193887040074337940323E-2, + 1.161252418498096498304E-3, + 1.867362374829870620091E-5, + 1.319022779715294371091E-7, + 3.942755256555603046095E-10, + 4.644326968986396928092E-13, + 1.913336021014307074861E-16, + 2.240041814626069927477E-20, + 4.784036597230791011855E-25, +}; +#endif +#if DEC +static short A4[52] = { +0036772,0056001,0016601,0164507, +0037646,0005710,0076603,0176456, +0037623,0054205,0013532,0026476, +0037221,0035252,0101064,0065407, +0036323,0162231,0042033,0107244, +0035200,0073170,0106141,0136543, +0033607,0043647,0163672,0055340, +0031767,0137614,0173376,0072313, +0027676,0160156,0161276,0034203, +0025347,0003752,0123106,0064266, +0022503,0035770,0160173,0177501, +0017273,0056226,0033704,0132530, +0013403,0022244,0175205,0052161, +}; +static short B4[48] = { + /*0040200,0000000,0000000,0000000, */ +0040464,0107620,0027471,0071672, +0040343,0157111,0025601,0137255, +0037701,0075244,0140412,0160220, +0037002,0151125,0036572,0057163, +0035630,0032452,0050727,0161653, +0034234,0122515,0034323,0172615, +0032415,0120405,0123660,0003160, +0030330,0140530,0161045,0150177, +0026002,0134747,0014542,0002510, +0023134,0113666,0035730,0035732, +0017723,0110343,0041217,0007764, +0014024,0007412,0175575,0160230, +}; +#endif +#if IBMPC +static short A4[52] = { +0x3d29,0x23b0,0x4b80,0x3f9f, +0x7fa6,0x0fb0,0xc179,0x3fd4, +0x45a8,0xa2eb,0x6b10,0x3fd2, +0x8d61,0x5046,0x2755,0x3fb2, +0x71d4,0x2883,0x7c93,0x3f7a, +0x37ac,0x118c,0x0ecf,0x3f30, +0x4b5c,0xfcf7,0xe8f4,0x3ed0, +0xce99,0x9edf,0xf7f1,0x3e5e, +0xc710,0xdc57,0xdc0d,0x3dd7, +0xcd17,0x54c8,0xe0fd,0x3d3c, +0x7fe8,0x1c0f,0x677f,0x3c88, +0x96ab,0xc6f8,0x6b92,0x3bb7, +0xaa8e,0x9f50,0x6494,0x3ac0, +}; +static short B4[48] = { + /*0x0000,0x0000,0x0000,0x3ff0,*/ +0x2e77,0x05e7,0x91f2,0x4006, +0x37d6,0x2570,0x7bc9,0x3ffc, +0x5c12,0x9821,0x2f54,0x3fd8, +0x4bce,0xa7af,0x5a4a,0x3fa0, +0xfc75,0x4a3a,0x06a5,0x3f53, +0x7eb2,0xa71a,0x94a9,0x3ef3, +0x00ce,0xb4f6,0xb420,0x3e81, +0xba10,0x1c44,0x182b,0x3dfb, +0x40a9,0xe32c,0x573c,0x3d60, +0x077b,0xc77b,0x92f6,0x3cab, +0xe1fe,0x6851,0x721c,0x3bda, +0xbc13,0x5f6f,0x81e1,0x3ae2, +}; +#endif +#if MIEEE +static short A4[52] = { +0x3f9f,0x4b80,0x23b0,0x3d29, +0x3fd4,0xc179,0x0fb0,0x7fa6, +0x3fd2,0x6b10,0xa2eb,0x45a8, +0x3fb2,0x2755,0x5046,0x8d61, +0x3f7a,0x7c93,0x2883,0x71d4, +0x3f30,0x0ecf,0x118c,0x37ac, +0x3ed0,0xe8f4,0xfcf7,0x4b5c, +0x3e5e,0xf7f1,0x9edf,0xce99, +0x3dd7,0xdc0d,0xdc57,0xc710, +0x3d3c,0xe0fd,0x54c8,0xcd17, +0x3c88,0x677f,0x1c0f,0x7fe8, +0x3bb7,0x6b92,0xc6f8,0x96ab, +0x3ac0,0x6494,0x9f50,0xaa8e, +}; +static short B4[48] = { + /*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4006,0x91f2,0x05e7,0x2e77, +0x3ffc,0x7bc9,0x2570,0x37d6, +0x3fd8,0x2f54,0x9821,0x5c12, +0x3fa0,0x5a4a,0xa7af,0x4bce, +0x3f53,0x06a5,0x4a3a,0xfc75, +0x3ef3,0x94a9,0xa71a,0x7eb2, +0x3e81,0xb420,0xb4f6,0x00ce, +0x3dfb,0x182b,0x1c44,0xba10, +0x3d60,0x573c,0xe32c,0x40a9, +0x3cab,0x92f6,0xc77b,0x077b, +0x3bda,0x721c,0x6851,0xe1fe, +0x3ae2,0x81e1,0x5f6f,0xbc13, +}; +#endif + +#ifdef ANSIPROT +extern double spence ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double zetac ( double ); +extern double pow ( double, double ); +extern double powi ( double, int ); +extern double log ( double ); +extern double fac ( int i ); +extern double fabs (double); +double polylog (int, double); +#else +extern double spence(), polevl(), p1evl(), zetac(); +extern double pow(), powi(), log(); +extern double fac(); /* factorial */ +extern double fabs(); +double polylog(); +#endif +extern double MACHEP; + +double +polylog (n, x) + int n; + double x; +{ + double h, k, p, s, t, u, xc, z; + int i, j; + +/* This recurrence provides formulas for n < 2. + + d 1 + -- Li (x) = --- Li (x) . + dx n x n-1 + +*/ + + if (n == -1) + { + p = 1.0 - x; + u = x / p; + s = u * u + u; + return s; + } + + if (n == 0) + { + s = x / (1.0 - x); + return s; + } + + /* Not implemented for n < -1. + Not defined for x > 1. Use cpolylog if you need that. */ + if (x > 1.0 || n < -1) + { + mtherr("polylog", DOMAIN); + return 0.0; + } + + if (n == 1) + { + s = -log (1.0 - x); + return s; + } + + /* Argument +1 */ + if (x == 1.0 && n > 1) + { + s = zetac ((double) n) + 1.0; + return s; + } + + /* Argument -1. + 1-n + Li (-z) = - (1 - 2 ) Li (z) + n n + */ + if (x == -1.0 && n > 1) + { + /* Li_n(1) = zeta(n) */ + s = zetac ((double) n) + 1.0; + s = s * (powi (2.0, 1 - n) - 1.0); + return s; + } + +/* Inversion formula: + * [n/2] n-2r + * n 1 n - log (z) + * Li (-z) + (-1) Li (-1/z) = - --- log (z) + 2 > ----------- Li (-1) + * n n n! - (n - 2r)! 2r + * r=1 + */ + if (x < -1.0 && n > 1) + { + double q, w; + int r; + + w = log (-x); + s = 0.0; + for (r = 1; r <= n / 2; r++) + { + j = 2 * r; + p = polylog (j, -1.0); + j = n - j; + if (j == 0) + { + s = s + p; + break; + } + q = (double) j; + q = pow (w, q) * p / fac (j); + s = s + q; + } + s = 2.0 * s; + q = polylog (n, 1.0 / x); + if (n & 1) + q = -q; + s = s - q; + s = s - pow (w, (double) n) / fac (n); + return s; + } + + if (n == 2) + { + if (x < 0.0 || x > 1.0) + return (spence (1.0 - x)); + } + + + + /* The power series converges slowly when x is near 1. For n = 3, this + identity helps: + + Li (-x/(1-x)) + Li (1-x) + Li (x) + 3 3 3 + 2 2 3 + = Li (1) + (pi /6) log(1-x) - (1/2) log(x) log (1-x) + (1/6) log (1-x) + 3 + */ + + if (n == 3) + { + p = x * x * x; + if (x > 0.8) + { + u = log(x); + s = p / 6.0; + xc = 1.0 - x; + s = s - 0.5 * u * u * log(xc); + s = s + PI * PI * u / 6.0; + s = s - polylog (3, -xc/x); + s = s - polylog (3, xc); + s = s + zetac(3.0); + s = s + 1.0; + return s; + } + /* Power series */ + t = p / 27.0; + t = t + .125 * x * x; + t = t + x; + + s = 0.0; + k = 4.0; + do + { + p = p * x; + h = p / (k * k * k); + s = s + h; + k += 1.0; + } + while (fabs(h/s) > 1.1e-16); + return (s + t); + } + +if (n == 4) + { + if (x >= 0.875) + { + u = 1.0 - x; + s = polevl(u, A4, 12) / p1evl(u, B4, 12); + s = s * u * u - 1.202056903159594285400 * u; + s += 1.0823232337111381915160; + return s; + } + goto pseries; + } + + + if (x < 0.75) + goto pseries; + + +/* This expansion in powers of log(x) is especially useful when + x is near 1. + + See also the pari gp calculator. + + inf j + - z(n-j) (log(x)) + polylog(n,x) = > ----------------- + - j! + j=0 + + where + + z(j) = Riemann zeta function (j), j != 1 + + n-1 + - + z(1) = -log(-log(x)) + > 1/k + - + k=1 + */ + + z = log(x); + h = -log(-z); + for (i = 1; i < n; i++) + h = h + 1.0/i; + p = 1.0; + s = zetac((double)n) + 1.0; + for (j=1; j<=n+1; j++) + { + p = p * z / j; + if (j == n-1) + s = s + h * p; + else + s = s + (zetac((double)(n-j)) + 1.0) * p; + } + j = n + 3; + z = z * z; + for(;;) + { + p = p * z / ((j-1)*j); + h = (zetac((double)(n-j)) + 1.0); + h = h * p; + s = s + h; + if (fabs(h/s) < MACHEP) + break; + j += 2; + } + return s; + + +pseries: + + p = x * x * x; + k = 3.0; + s = 0.0; + do + { + p = p * x; + k += 1.0; + h = p / powi(k, n); + s = s + h; + } + while (fabs(h/s) > MACHEP); + s += x * x * x / powi(3.0,n); + s += x * x / powi(2.0,n); + s += x; + return s; +} diff --git a/libm/double/polyn.c b/libm/double/polyn.c new file mode 100644 index 000000000..2927e77f0 --- /dev/null +++ b/libm/double/polyn.c @@ -0,0 +1,471 @@ +/* polyn.c + * polyr.c + * Arithmetic operations on polynomials + * + * In the following descriptions a, b, c are polynomials of degree + * na, nb, nc respectively. The degree of a polynomial cannot + * exceed a run-time value MAXPOL. An operation that attempts + * to use or generate a polynomial of higher degree may produce a + * result that suffers truncation at degree MAXPOL. The value of + * MAXPOL is set by calling the function + * + * polini( maxpol ); + * + * where maxpol is the desired maximum degree. This must be + * done prior to calling any of the other functions in this module. + * Memory for internal temporary polynomial storage is allocated + * by polini(). + * + * Each polynomial is represented by an array containing its + * coefficients, together with a separately declared integer equal + * to the degree of the polynomial. The coefficients appear in + * ascending order; that is, + * + * 2 na + * a(x) = a[0] + a[1] * x + a[2] * x + ... + a[na] * x . + * + * + * + * sum = poleva( a, na, x ); Evaluate polynomial a(t) at t = x. + * polprt( a, na, D ); Print the coefficients of a to D digits. + * polclr( a, na ); Set a identically equal to zero, up to a[na]. + * polmov( a, na, b ); Set b = a. + * poladd( a, na, b, nb, c ); c = b + a, nc = max(na,nb) + * polsub( a, na, b, nb, c ); c = b - a, nc = max(na,nb) + * polmul( a, na, b, nb, c ); c = b * a, nc = na+nb + * + * + * Division: + * + * i = poldiv( a, na, b, nb, c ); c = b / a, nc = MAXPOL + * + * returns i = the degree of the first nonzero coefficient of a. + * The computed quotient c must be divided by x^i. An error message + * is printed if a is identically zero. + * + * + * Change of variables: + * If a and b are polynomials, and t = a(x), then + * c(t) = b(a(x)) + * is a polynomial found by substituting a(x) for t. The + * subroutine call for this is + * + * polsbt( a, na, b, nb, c ); + * + * + * Notes: + * poldiv() is an integer routine; poleva() is double. + * Any of the arguments a, b, c may refer to the same array. + * + */ + +#include <stdio.h> +#include <math.h> +#if ANSIPROT +void exit (int); +extern void * malloc ( long ); +extern void free ( void * ); +void polclr ( double *, int ); +void polmov ( double *, int, double * ); +void polmul ( double *, int, double *, int, double * ); +int poldiv ( double *, int, double *, int, double * ); +#else +void exit(); +void * malloc(); +void free (); +void polclr(), polmov(), poldiv(), polmul(); +#endif +#ifndef NULL +#define NULL 0 +#endif + +/* near pointer version of malloc() */ +/* +#define malloc _nmalloc +#define free _nfree +*/ + +/* Pointers to internal arrays. Note poldiv() allocates + * and deallocates some temporary arrays every time it is called. + */ +static double *pt1 = 0; +static double *pt2 = 0; +static double *pt3 = 0; + +/* Maximum degree of polynomial. */ +int MAXPOL = 0; +extern int MAXPOL; + +/* Number of bytes (chars) in maximum size polynomial. */ +static int psize = 0; + + +/* Initialize max degree of polynomials + * and allocate temporary storage. + */ +void polini( maxdeg ) +int maxdeg; +{ + +MAXPOL = maxdeg; +psize = (maxdeg + 1) * sizeof(double); + +/* Release previously allocated memory, if any. */ +if( pt3 ) + free(pt3); +if( pt2 ) + free(pt2); +if( pt1 ) + free(pt1); + +/* Allocate new arrays */ +pt1 = (double * )malloc(psize); /* used by polsbt */ +pt2 = (double * )malloc(psize); /* used by polsbt */ +pt3 = (double * )malloc(psize); /* used by polmul */ + +/* Report if failure */ +if( (pt1 == NULL) || (pt2 == NULL) || (pt3 == NULL) ) + { + mtherr( "polini", ERANGE ); + exit(1); + } +} + + + +/* Print the coefficients of a, with d decimal precision. + */ +static char *form = "abcdefghijk"; + +void polprt( a, na, d ) +double a[]; +int na, d; +{ +int i, j, d1; +char *p; + +/* Create format descriptor string for the printout. + * Do this partly by hand, since sprintf() may be too + * bug-ridden to accomplish this feat by itself. + */ +p = form; +*p++ = '%'; +d1 = d + 8; +sprintf( p, "%d ", d1 ); +p += 1; +if( d1 >= 10 ) + p += 1; +*p++ = '.'; +sprintf( p, "%d ", d ); +p += 1; +if( d >= 10 ) + p += 1; +*p++ = 'e'; +*p++ = ' '; +*p++ = '\0'; + + +/* Now do the printing. + */ +d1 += 1; +j = 0; +for( i=0; i<=na; i++ ) + { +/* Detect end of available line */ + j += d1; + if( j >= 78 ) + { + printf( "\n" ); + j = d1; + } + printf( form, a[i] ); + } +printf( "\n" ); +} + + + +/* Set a = 0. + */ +void polclr( a, n ) +register double *a; +int n; +{ +int i; + +if( n > MAXPOL ) + n = MAXPOL; +for( i=0; i<=n; i++ ) + *a++ = 0.0; +} + + + +/* Set b = a. + */ +void polmov( a, na, b ) +register double *a, *b; +int na; +{ +int i; + +if( na > MAXPOL ) + na = MAXPOL; + +for( i=0; i<= na; i++ ) + { + *b++ = *a++; + } +} + + +/* c = b * a. + */ +void polmul( a, na, b, nb, c ) +double a[], b[], c[]; +int na, nb; +{ +int i, j, k, nc; +double x; + +nc = na + nb; +polclr( pt3, MAXPOL ); + +for( i=0; i<=na; i++ ) + { + x = a[i]; + for( j=0; j<=nb; j++ ) + { + k = i + j; + if( k > MAXPOL ) + break; + pt3[k] += x * b[j]; + } + } + +if( nc > MAXPOL ) + nc = MAXPOL; +for( i=0; i<=nc; i++ ) + c[i] = pt3[i]; +} + + + + +/* c = b + a. + */ +void poladd( a, na, b, nb, c ) +double a[], b[], c[]; +int na, nb; +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOL ) + n = MAXPOL; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + c[i] = b[i]; + else if( i > nb ) + c[i] = a[i]; + else + c[i] = b[i] + a[i]; + } +} + +/* c = b - a. + */ +void polsub( a, na, b, nb, c ) +double a[], b[], c[]; +int na, nb; +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOL ) + n = MAXPOL; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + c[i] = b[i]; + else if( i > nb ) + c[i] = -a[i]; + else + c[i] = b[i] - a[i]; + } +} + + + +/* c = b/a + */ +int poldiv( a, na, b, nb, c ) +double a[], b[], c[]; +int na, nb; +{ +double quot; +double *ta, *tb, *tq; +int i, j, k, sing; + +sing = 0; + +/* Allocate temporary arrays. This would be quicker + * if done automatically on the stack, but stack space + * may be hard to obtain on a small computer. + */ +ta = (double * )malloc( psize ); +polclr( ta, MAXPOL ); +polmov( a, na, ta ); + +tb = (double * )malloc( psize ); +polclr( tb, MAXPOL ); +polmov( b, nb, tb ); + +tq = (double * )malloc( psize ); +polclr( tq, MAXPOL ); + +/* What to do if leading (constant) coefficient + * of denominator is zero. + */ +if( a[0] == 0.0 ) + { + for( i=0; i<=na; i++ ) + { + if( ta[i] != 0.0 ) + goto nzero; + } + mtherr( "poldiv", SING ); + goto done; + +nzero: +/* Reduce the degree of the denominator. */ + for( i=0; i<na; i++ ) + ta[i] = ta[i+1]; + ta[na] = 0.0; + + if( b[0] != 0.0 ) + { +/* Optional message: + printf( "poldiv singularity, divide quotient by x\n" ); +*/ + sing += 1; + } + else + { +/* Reduce degree of numerator. */ + for( i=0; i<nb; i++ ) + tb[i] = tb[i+1]; + tb[nb] = 0.0; + } +/* Call self, using reduced polynomials. */ + sing += poldiv( ta, na, tb, nb, c ); + goto done; + } + +/* Long division algorithm. ta[0] is nonzero. + */ +for( i=0; i<=MAXPOL; i++ ) + { + quot = tb[i]/ta[0]; + for( j=0; j<=MAXPOL; j++ ) + { + k = j + i; + if( k > MAXPOL ) + break; + tb[k] -= quot * ta[j]; + } + tq[i] = quot; + } +/* Send quotient to output array. */ +polmov( tq, MAXPOL, c ); + +done: + +/* Restore allocated memory. */ +free(tq); +free(tb); +free(ta); +return( sing ); +} + + + + +/* Change of variables + * Substitute a(y) for the variable x in b(x). + * x = a(y) + * c(x) = b(x) = b(a(y)). + */ + +void polsbt( a, na, b, nb, c ) +double a[], b[], c[]; +int na, nb; +{ +int i, j, k, n2; +double x; + +/* 0th degree term: + */ +polclr( pt1, MAXPOL ); +pt1[0] = b[0]; + +polclr( pt2, MAXPOL ); +pt2[0] = 1.0; +n2 = 0; + +for( i=1; i<=nb; i++ ) + { +/* Form ith power of a. */ + polmul( a, na, pt2, n2, pt2 ); + n2 += na; + x = b[i]; +/* Add the ith coefficient of b times the ith power of a. */ + for( j=0; j<=n2; j++ ) + { + if( j > MAXPOL ) + break; + pt1[j] += x * pt2[j]; + } + } + +k = n2 + nb; +if( k > MAXPOL ) + k = MAXPOL; +for( i=0; i<=k; i++ ) + c[i] = pt1[i]; +} + + + + +/* Evaluate polynomial a(t) at t = x. + */ +double poleva( a, na, x ) +double a[]; +int na; +double x; +{ +double s; +int i; + +s = a[na]; +for( i=na-1; i>=0; i-- ) + { + s = s * x + a[i]; + } +return(s); +} + diff --git a/libm/double/polyr.c b/libm/double/polyr.c new file mode 100644 index 000000000..81ca817e3 --- /dev/null +++ b/libm/double/polyr.c @@ -0,0 +1,533 @@ + +/* Arithmetic operations on polynomials with rational coefficients + * + * In the following descriptions a, b, c are polynomials of degree + * na, nb, nc respectively. The degree of a polynomial cannot + * exceed a run-time value MAXPOL. An operation that attempts + * to use or generate a polynomial of higher degree may produce a + * result that suffers truncation at degree MAXPOL. The value of + * MAXPOL is set by calling the function + * + * polini( maxpol ); + * + * where maxpol is the desired maximum degree. This must be + * done prior to calling any of the other functions in this module. + * Memory for internal temporary polynomial storage is allocated + * by polini(). + * + * Each polynomial is represented by an array containing its + * coefficients, together with a separately declared integer equal + * to the degree of the polynomial. The coefficients appear in + * ascending order; that is, + * + * 2 na + * a(x) = a[0] + a[1] * x + a[2] * x + ... + a[na] * x . + * + * + * + * `a', `b', `c' are arrays of fracts. + * poleva( a, na, &x, &sum ); Evaluate polynomial a(t) at t = x. + * polprt( a, na, D ); Print the coefficients of a to D digits. + * polclr( a, na ); Set a identically equal to zero, up to a[na]. + * polmov( a, na, b ); Set b = a. + * poladd( a, na, b, nb, c ); c = b + a, nc = max(na,nb) + * polsub( a, na, b, nb, c ); c = b - a, nc = max(na,nb) + * polmul( a, na, b, nb, c ); c = b * a, nc = na+nb + * + * + * Division: + * + * i = poldiv( a, na, b, nb, c ); c = b / a, nc = MAXPOL + * + * returns i = the degree of the first nonzero coefficient of a. + * The computed quotient c must be divided by x^i. An error message + * is printed if a is identically zero. + * + * + * Change of variables: + * If a and b are polynomials, and t = a(x), then + * c(t) = b(a(x)) + * is a polynomial found by substituting a(x) for t. The + * subroutine call for this is + * + * polsbt( a, na, b, nb, c ); + * + * + * Notes: + * poldiv() is an integer routine; poleva() is double. + * Any of the arguments a, b, c may refer to the same array. + * + */ + +#include <stdio.h> +#include <math.h> +#ifndef NULL +#define NULL 0 +#endif +typedef struct{ + double n; + double d; + }fract; + +#ifdef ANSIPROT +extern void radd ( fract *, fract *, fract * ); +extern void rsub ( fract *, fract *, fract * ); +extern void rmul ( fract *, fract *, fract * ); +extern void rdiv ( fract *, fract *, fract * ); +void polmov ( fract *, int, fract * ); +void polmul ( fract *, int, fract *, int, fract * ); +int poldiv ( fract *, int, fract *, int, fract * ); +void * malloc ( long ); +void free ( void * ); +#else +void radd(), rsub(), rmul(), rdiv(); +void polmov(), polmul(); +int poldiv(); +void * malloc(); +void free (); +#endif + +/* near pointer version of malloc() */ +/* +#define malloc _nmalloc +#define free _nfree +*/ +/* Pointers to internal arrays. Note poldiv() allocates + * and deallocates some temporary arrays every time it is called. + */ +static fract *pt1 = 0; +static fract *pt2 = 0; +static fract *pt3 = 0; + +/* Maximum degree of polynomial. */ +int MAXPOL = 0; +extern int MAXPOL; + +/* Number of bytes (chars) in maximum size polynomial. */ +static int psize = 0; + + +/* Initialize max degree of polynomials + * and allocate temporary storage. + */ +void polini( maxdeg ) +int maxdeg; +{ + +MAXPOL = maxdeg; +psize = (maxdeg + 1) * sizeof(fract); + +/* Release previously allocated memory, if any. */ +if( pt3 ) + free(pt3); +if( pt2 ) + free(pt2); +if( pt1 ) + free(pt1); + +/* Allocate new arrays */ +pt1 = (fract * )malloc(psize); /* used by polsbt */ +pt2 = (fract * )malloc(psize); /* used by polsbt */ +pt3 = (fract * )malloc(psize); /* used by polmul */ + +/* Report if failure */ +if( (pt1 == NULL) || (pt2 == NULL) || (pt3 == NULL) ) + { + mtherr( "polini", ERANGE ); + exit(1); + } +} + + + +/* Print the coefficients of a, with d decimal precision. + */ +static char *form = "abcdefghijk"; + +void polprt( a, na, d ) +fract a[]; +int na, d; +{ +int i, j, d1; +char *p; + +/* Create format descriptor string for the printout. + * Do this partly by hand, since sprintf() may be too + * bug-ridden to accomplish this feat by itself. + */ +p = form; +*p++ = '%'; +d1 = d + 8; +sprintf( p, "%d ", d1 ); +p += 1; +if( d1 >= 10 ) + p += 1; +*p++ = '.'; +sprintf( p, "%d ", d ); +p += 1; +if( d >= 10 ) + p += 1; +*p++ = 'e'; +*p++ = ' '; +*p++ = '\0'; + + +/* Now do the printing. + */ +d1 += 1; +j = 0; +for( i=0; i<=na; i++ ) + { +/* Detect end of available line */ + j += d1; + if( j >= 78 ) + { + printf( "\n" ); + j = d1; + } + printf( form, a[i].n ); + j += d1; + if( j >= 78 ) + { + printf( "\n" ); + j = d1; + } + printf( form, a[i].d ); + } +printf( "\n" ); +} + + + +/* Set a = 0. + */ +void polclr( a, n ) +fract a[]; +int n; +{ +int i; + +if( n > MAXPOL ) + n = MAXPOL; +for( i=0; i<=n; i++ ) + { + a[i].n = 0.0; + a[i].d = 1.0; + } +} + + + +/* Set b = a. + */ +void polmov( a, na, b ) +fract a[], b[]; +int na; +{ +int i; + +if( na > MAXPOL ) + na = MAXPOL; + +for( i=0; i<= na; i++ ) + { + b[i].n = a[i].n; + b[i].d = a[i].d; + } +} + + +/* c = b * a. + */ +void polmul( a, na, b, nb, c ) +fract a[], b[], c[]; +int na, nb; +{ +int i, j, k, nc; +fract temp; +fract *p; + +nc = na + nb; +polclr( pt3, MAXPOL ); + +p = &a[0]; +for( i=0; i<=na; i++ ) + { + for( j=0; j<=nb; j++ ) + { + k = i + j; + if( k > MAXPOL ) + break; + rmul( p, &b[j], &temp ); /*pt3[k] += a[i] * b[j];*/ + radd( &temp, &pt3[k], &pt3[k] ); + } + ++p; + } + +if( nc > MAXPOL ) + nc = MAXPOL; +for( i=0; i<=nc; i++ ) + { + c[i].n = pt3[i].n; + c[i].d = pt3[i].d; + } +} + + + + +/* c = b + a. + */ +void poladd( a, na, b, nb, c ) +fract a[], b[], c[]; +int na, nb; +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOL ) + n = MAXPOL; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + { + c[i].n = b[i].n; + c[i].d = b[i].d; + } + else if( i > nb ) + { + c[i].n = a[i].n; + c[i].d = a[i].d; + } + else + { + radd( &a[i], &b[i], &c[i] ); /*c[i] = b[i] + a[i];*/ + } + } +} + +/* c = b - a. + */ +void polsub( a, na, b, nb, c ) +fract a[], b[], c[]; +int na, nb; +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOL ) + n = MAXPOL; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + { + c[i].n = b[i].n; + c[i].d = b[i].d; + } + else if( i > nb ) + { + c[i].n = -a[i].n; + c[i].d = a[i].d; + } + else + { + rsub( &a[i], &b[i], &c[i] ); /*c[i] = b[i] - a[i];*/ + } + } +} + + + +/* c = b/a + */ +int poldiv( a, na, b, nb, c ) +fract a[], b[], c[]; +int na, nb; +{ +fract *ta, *tb, *tq; +fract quot; +fract temp; +int i, j, k, sing; + +sing = 0; + +/* Allocate temporary arrays. This would be quicker + * if done automatically on the stack, but stack space + * may be hard to obtain on a small computer. + */ +ta = (fract * )malloc( psize ); +polclr( ta, MAXPOL ); +polmov( a, na, ta ); + +tb = (fract * )malloc( psize ); +polclr( tb, MAXPOL ); +polmov( b, nb, tb ); + +tq = (fract * )malloc( psize ); +polclr( tq, MAXPOL ); + +/* What to do if leading (constant) coefficient + * of denominator is zero. + */ +if( a[0].n == 0.0 ) + { + for( i=0; i<=na; i++ ) + { + if( ta[i].n != 0.0 ) + goto nzero; + } + mtherr( "poldiv", SING ); + goto done; + +nzero: +/* Reduce the degree of the denominator. */ + for( i=0; i<na; i++ ) + { + ta[i].n = ta[i+1].n; + ta[i].d = ta[i+1].d; + } + ta[na].n = 0.0; + ta[na].d = 1.0; + + if( b[0].n != 0.0 ) + { +/* Optional message: + printf( "poldiv singularity, divide quotient by x\n" ); +*/ + sing += 1; + } + else + { +/* Reduce degree of numerator. */ + for( i=0; i<nb; i++ ) + { + tb[i].n = tb[i+1].n; + tb[i].d = tb[i+1].d; + } + tb[nb].n = 0.0; + tb[nb].d = 1.0; + } +/* Call self, using reduced polynomials. */ + sing += poldiv( ta, na, tb, nb, c ); + goto done; + } + +/* Long division algorithm. ta[0] is nonzero. + */ +for( i=0; i<=MAXPOL; i++ ) + { + rdiv( &ta[0], &tb[i], " ); /*quot = tb[i]/ta[0];*/ + for( j=0; j<=MAXPOL; j++ ) + { + k = j + i; + if( k > MAXPOL ) + break; + + rmul( &ta[j], ", &temp ); /*tb[k] -= quot * ta[j];*/ + rsub( &temp, &tb[k], &tb[k] ); + } + tq[i].n = quot.n; + tq[i].d = quot.d; + } +/* Send quotient to output array. */ +polmov( tq, MAXPOL, c ); + +done: + +/* Restore allocated memory. */ +free(tq); +free(tb); +free(ta); +return( sing ); +} + + + + +/* Change of variables + * Substitute a(y) for the variable x in b(x). + * x = a(y) + * c(x) = b(x) = b(a(y)). + */ + +void polsbt( a, na, b, nb, c ) +fract a[], b[], c[]; +int na, nb; +{ +int i, j, k, n2; +fract temp; +fract *p; + +/* 0th degree term: + */ +polclr( pt1, MAXPOL ); +pt1[0].n = b[0].n; +pt1[0].d = b[0].d; + +polclr( pt2, MAXPOL ); +pt2[0].n = 1.0; +pt2[0].d = 1.0; +n2 = 0; +p = &b[1]; + +for( i=1; i<=nb; i++ ) + { +/* Form ith power of a. */ + polmul( a, na, pt2, n2, pt2 ); + n2 += na; +/* Add the ith coefficient of b times the ith power of a. */ + for( j=0; j<=n2; j++ ) + { + if( j > MAXPOL ) + break; + rmul( &pt2[j], p, &temp ); /*pt1[j] += b[i] * pt2[j];*/ + radd( &temp, &pt1[j], &pt1[j] ); + } + ++p; + } + +k = n2 + nb; +if( k > MAXPOL ) + k = MAXPOL; +for( i=0; i<=k; i++ ) + { + c[i].n = pt1[i].n; + c[i].d = pt1[i].d; + } +} + + + + +/* Evaluate polynomial a(t) at t = x. + */ +void poleva( a, na, x, s ) +fract a[]; +int na; +fract *x; +fract *s; +{ +int i; +fract temp; + +s->n = a[na].n; +s->d = a[na].d; +for( i=na-1; i>=0; i-- ) + { + rmul( s, x, &temp ); /*s = s * x + a[i];*/ + radd( &a[i], &temp, s ); + } +} + diff --git a/libm/double/pow.c b/libm/double/pow.c new file mode 100644 index 000000000..768ad1062 --- /dev/null +++ b/libm/double/pow.c @@ -0,0 +1,756 @@ +/* pow.c + * + * Power function + * + * + * + * SYNOPSIS: + * + * double x, y, z, pow(); + * + * z = pow( 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/16 and pseudo extended precision arithmetic to + * obtain an extra three bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -26,26 30000 4.2e-16 7.7e-17 + * DEC -26,26 60000 4.8e-17 9.1e-18 + * 1/26 < x < 26, with log(x) uniformly distributed. + * -26 < y < 26, y uniformly distributed. + * IEEE 0,8700 30000 1.5e-14 2.1e-15 + * 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.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> +static char fname[] = {"pow"}; + +#define SQRTH 0.70710678118654752440 + +#ifdef UNK +static double P[] = { + 4.97778295871696322025E-1, + 3.73336776063286838734E0, + 7.69994162726912503298E0, + 4.66651806774358464979E0 +}; +static double Q[] = { +/* 1.00000000000000000000E0, */ + 9.33340916416696166113E0, + 2.79999886606328401649E1, + 3.35994905342304405431E1, + 1.39995542032307539578E1 +}; +/* 2^(-i/16), IEEE precision */ +static double A[] = { + 1.00000000000000000000E0, + 9.57603280698573700036E-1, + 9.17004043204671215328E-1, + 8.78126080186649726755E-1, + 8.40896415253714502036E-1, + 8.05245165974627141736E-1, + 7.71105412703970372057E-1, + 7.38413072969749673113E-1, + 7.07106781186547572737E-1, + 6.77127773468446325644E-1, + 6.48419777325504820276E-1, + 6.20928906036742001007E-1, + 5.94603557501360513449E-1, + 5.69394317378345782288E-1, + 5.45253866332628844837E-1, + 5.22136891213706877402E-1, + 5.00000000000000000000E-1 +}; +static double B[] = { + 0.00000000000000000000E0, + 1.64155361212281360176E-17, + 4.09950501029074826006E-17, + 3.97491740484881042808E-17, +-4.83364665672645672553E-17, + 1.26912513974441574796E-17, + 1.99100761573282305549E-17, +-1.52339103990623557348E-17, + 0.00000000000000000000E0 +}; +static double R[] = { + 1.49664108433729301083E-5, + 1.54010762792771901396E-4, + 1.33335476964097721140E-3, + 9.61812908476554225149E-3, + 5.55041086645832347466E-2, + 2.40226506959099779976E-1, + 6.93147180559945308821E-1 +}; + +#define douba(k) A[k] +#define doubb(k) B[k] +#define MEXP 16383.0 +#ifdef DENORMAL +#define MNEXP -17183.0 +#else +#define MNEXP -16383.0 +#endif +#endif + +#ifdef DEC +static unsigned short P[] = { +0037776,0156313,0175332,0163602, +0040556,0167577,0052366,0174245, +0040766,0062753,0175707,0055564, +0040625,0052035,0131344,0155636, +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041025,0052644,0154404,0105155, +0041337,0177772,0007016,0047646, +0041406,0062740,0154273,0020020, +0041137,0177054,0106127,0044555, +}; +static unsigned short A[] = { +0040200,0000000,0000000,0000000, +0040165,0022575,0012444,0103314, +0040152,0140306,0163735,0022071, +0040140,0146336,0166052,0112341, +0040127,0042374,0145326,0116553, +0040116,0022214,0012437,0102201, +0040105,0063452,0010525,0003333, +0040075,0004243,0117530,0006067, +0040065,0002363,0031771,0157145, +0040055,0054076,0165102,0120513, +0040045,0177326,0124661,0050471, +0040036,0172462,0060221,0120422, +0040030,0033760,0050615,0134251, +0040021,0141723,0071653,0010703, +0040013,0112701,0161752,0105727, +0040005,0125303,0063714,0044173, +0040000,0000000,0000000,0000000 +}; +static unsigned short B[] = { +0000000,0000000,0000000,0000000, +0021473,0040265,0153315,0140671, +0121074,0062627,0042146,0176454, +0121413,0003524,0136332,0066212, +0121767,0046404,0166231,0012553, +0121257,0015024,0002357,0043574, +0021736,0106532,0043060,0056206, +0121310,0020334,0165705,0035326, +0000000,0000000,0000000,0000000 +}; + +static unsigned short R[] = { +0034173,0014076,0137624,0115771, +0035041,0076763,0003744,0111311, +0035656,0141766,0041127,0074351, +0036435,0112533,0073611,0116664, +0037143,0054106,0134040,0152223, +0037565,0176757,0176026,0025551, +0040061,0071027,0173721,0147572 +}; + +/* +static double R[] = { +0.14928852680595608186e-4, +0.15400290440989764601e-3, +0.13333541313585784703e-2, +0.96181290595172416964e-2, +0.55504108664085595326e-1, +0.24022650695909537056e0, +0.69314718055994529629e0 +}; +*/ +#define douba(k) (*(double *)&A[(k)<<2]) +#define doubb(k) (*(double *)&B[(k)<<2]) +#define MEXP 2031.0 +#define MNEXP -2031.0 +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x5cf0,0x7f5b,0xdb99,0x3fdf, +0xdf15,0xea9e,0xddef,0x400d, +0xeb6f,0x7f78,0xccbd,0x401e, +0x9b74,0xb65c,0xaa83,0x4012, +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x914e,0x9b20,0xaab4,0x4022, +0xc9f5,0x41c1,0xffff,0x403b, +0x6402,0x1b17,0xccbc,0x4040, +0xe92e,0x918a,0xffc5,0x402b, +}; +static unsigned short A[] = { +0x0000,0x0000,0x0000,0x3ff0, +0x90da,0xa2a4,0xa4af,0x3fee, +0xa487,0xdcfb,0x5818,0x3fed, +0x529c,0xdd85,0x199b,0x3fec, +0xd3ad,0x995a,0xe89f,0x3fea, +0xf090,0x82a3,0xc491,0x3fe9, +0xa0db,0x422a,0xace5,0x3fe8, +0x0187,0x73eb,0xa114,0x3fe7, +0x3bcd,0x667f,0xa09e,0x3fe6, +0x5429,0xdd48,0xab07,0x3fe5, +0x2a27,0xd536,0xbfda,0x3fe4, +0x3422,0x4c12,0xdea6,0x3fe3, +0xb715,0x0a31,0x06fe,0x3fe3, +0x6238,0x6e75,0x387a,0x3fe2, +0x517b,0x3c7d,0x72b8,0x3fe1, +0x890f,0x6cf9,0xb558,0x3fe0, +0x0000,0x0000,0x0000,0x3fe0 +}; +static unsigned short B[] = { +0x0000,0x0000,0x0000,0x0000, +0x3707,0xd75b,0xed02,0x3c72, +0xcc81,0x345d,0xa1cd,0x3c87, +0x4b27,0x5686,0xe9f1,0x3c86, +0x6456,0x13b2,0xdd34,0xbc8b, +0x42e2,0xafec,0x4397,0x3c6d, +0x82e4,0xd231,0xf46a,0x3c76, +0x8a76,0xb9d7,0x9041,0xbc71, +0x0000,0x0000,0x0000,0x0000 +}; +static unsigned short R[] = { +0x937f,0xd7f2,0x6307,0x3eef, +0x9259,0x60fc,0x2fbe,0x3f24, +0xef1d,0xc84a,0xd87e,0x3f55, +0x33b7,0x6ef1,0xb2ab,0x3f83, +0x1a92,0xd704,0x6b08,0x3fac, +0xc56d,0xff82,0xbfbd,0x3fce, +0x39ef,0xfefa,0x2e42,0x3fe6 +}; + +#define douba(k) (*(double *)&A[(k)<<2]) +#define doubb(k) (*(double *)&B[(k)<<2]) +#define MEXP 16383.0 +#ifdef DENORMAL +#define MNEXP -17183.0 +#else +#define MNEXP -16383.0 +#endif +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0x3fdf,0xdb99,0x7f5b,0x5cf0, +0x400d,0xddef,0xea9e,0xdf15, +0x401e,0xccbd,0x7f78,0xeb6f, +0x4012,0xaa83,0xb65c,0x9b74 +}; +static unsigned short Q[] = { +0x4022,0xaab4,0x9b20,0x914e, +0x403b,0xffff,0x41c1,0xc9f5, +0x4040,0xccbc,0x1b17,0x6402, +0x402b,0xffc5,0x918a,0xe92e +}; +static unsigned short A[] = { +0x3ff0,0x0000,0x0000,0x0000, +0x3fee,0xa4af,0xa2a4,0x90da, +0x3fed,0x5818,0xdcfb,0xa487, +0x3fec,0x199b,0xdd85,0x529c, +0x3fea,0xe89f,0x995a,0xd3ad, +0x3fe9,0xc491,0x82a3,0xf090, +0x3fe8,0xace5,0x422a,0xa0db, +0x3fe7,0xa114,0x73eb,0x0187, +0x3fe6,0xa09e,0x667f,0x3bcd, +0x3fe5,0xab07,0xdd48,0x5429, +0x3fe4,0xbfda,0xd536,0x2a27, +0x3fe3,0xdea6,0x4c12,0x3422, +0x3fe3,0x06fe,0x0a31,0xb715, +0x3fe2,0x387a,0x6e75,0x6238, +0x3fe1,0x72b8,0x3c7d,0x517b, +0x3fe0,0xb558,0x6cf9,0x890f, +0x3fe0,0x0000,0x0000,0x0000 +}; +static unsigned short B[] = { +0x0000,0x0000,0x0000,0x0000, +0x3c72,0xed02,0xd75b,0x3707, +0x3c87,0xa1cd,0x345d,0xcc81, +0x3c86,0xe9f1,0x5686,0x4b27, +0xbc8b,0xdd34,0x13b2,0x6456, +0x3c6d,0x4397,0xafec,0x42e2, +0x3c76,0xf46a,0xd231,0x82e4, +0xbc71,0x9041,0xb9d7,0x8a76, +0x0000,0x0000,0x0000,0x0000 +}; +static unsigned short R[] = { +0x3eef,0x6307,0xd7f2,0x937f, +0x3f24,0x2fbe,0x60fc,0x9259, +0x3f55,0xd87e,0xc84a,0xef1d, +0x3f83,0xb2ab,0x6ef1,0x33b7, +0x3fac,0x6b08,0xd704,0x1a92, +0x3fce,0xbfbd,0xff82,0xc56d, +0x3fe6,0x2e42,0xfefa,0x39ef +}; + +#define douba(k) (*(double *)&A[(k)<<2]) +#define doubb(k) (*(double *)&B[(k)<<2]) +#define MEXP 16383.0 +#ifdef DENORMAL +#define MNEXP -17183.0 +#else +#define MNEXP -16383.0 +#endif +#endif + +/* log2(e) - 1 */ +#define LOG2EA 0.44269504088896340736 + +#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 + +#ifdef ANSIPROT +extern double floor ( double ); +extern double fabs ( double ); +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double powi ( double, int ); +extern int signbit ( double ); +extern int isnan ( double ); +extern int isfinite ( double ); +static double reduc ( double ); +#else +double floor(), fabs(), frexp(), ldexp(); +double polevl(), p1evl(), powi(); +int signbit(), isnan(), isfinite(); +static double reduc(); +#endif +extern double MAXNUM; +#ifdef INFINITIES +extern double INFINITY; +#endif +#ifdef NANS +extern double NAN; +#endif +#ifdef MINUSZERO +extern double NEGZERO; +#endif + +double pow( x, y ) +double x, y; +{ +double w, z, W, Wa, Wb, ya, yb, u; +/* double F, Fa, Fb, G, Ga, Gb, H, Ha, Hb */ +double aw, ay, wy; +int e, i, nflg, iyflg, yoddint; + +if( y == 0.0 ) + return( 1.0 ); +#ifdef NANS +if( isnan(x) ) + return( x ); +if( isnan(y) ) + return( y ); +#endif +if( y == 1.0 ) + return( x ); + + +#ifdef INFINITIES +if( !isfinite(y) && (x == 1.0 || x == -1.0) ) + { + mtherr( "pow", DOMAIN ); +#ifdef NANS + return( NAN ); +#else + return( INFINITY ); +#endif + } +#endif + +if( x == 1.0 ) + return( 1.0 ); + +if( y >= MAXNUM ) + { +#ifdef INFINITIES + if( x > 1.0 ) + return( INFINITY ); +#else + if( x > 1.0 ) + return( MAXNUM ); +#endif + if( x > 0.0 && x < 1.0 ) + return( 0.0); + if( x < -1.0 ) + { +#ifdef INFINITIES + return( INFINITY ); +#else + return( MAXNUM ); +#endif + } + if( x > -1.0 && x < 0.0 ) + return( 0.0 ); + } +if( y <= -MAXNUM ) + { + if( x > 1.0 ) + return( 0.0 ); +#ifdef INFINITIES + if( x > 0.0 && x < 1.0 ) + return( INFINITY ); +#else + if( x > 0.0 && x < 1.0 ) + return( MAXNUM ); +#endif + if( x < -1.0 ) + return( 0.0 ); +#ifdef INFINITIES + if( x > -1.0 && x < 0.0 ) + return( INFINITY ); +#else + if( x > -1.0 && x < 0.0 ) + return( MAXNUM ); +#endif + } +if( x >= MAXNUM ) + { +#if INFINITIES + if( y > 0.0 ) + return( INFINITY ); +#else + if( y > 0.0 ) + return( MAXNUM ); +#endif + return(0.0); + } +/* Set iyflg to 1 if y is an integer. */ +iyflg = 0; +w = floor(y); +if( w == y ) + iyflg = 1; + +/* Test for odd integer y. */ +yoddint = 0; +if( iyflg ) + { + ya = fabs(y); + ya = floor(0.5 * ya); + yb = 0.5 * fabs(w); + if( ya != yb ) + yoddint = 1; + } + +if( x <= -MAXNUM ) + { + if( y > 0.0 ) + { +#ifdef INFINITIES + if( yoddint ) + return( -INFINITY ); + return( INFINITY ); +#else + if( yoddint ) + return( -MAXNUM ); + return( MAXNUM ); +#endif + } + if( y < 0.0 ) + { +#ifdef MINUSZERO + if( yoddint ) + return( NEGZERO ); +#endif + return( 0.0 ); + } + } + +nflg = 0; /* flag = 1 if x<0 raised to integer power */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + { + if( y < 0.0 ) + { +#ifdef MINUSZERO + if( signbit(x) && yoddint ) + return( -INFINITY ); +#endif +#ifdef INFINITIES + return( INFINITY ); +#else + return( MAXNUM ); +#endif + } + if( y > 0.0 ) + { +#ifdef MINUSZERO + if( signbit(x) && yoddint ) + return( NEGZERO ); +#endif + return( 0.0 ); + } + return( 1.0 ); + } + else + { + if( iyflg == 0 ) + { /* noninteger power of negative number */ + mtherr( fname, DOMAIN ); +#ifdef NANS + return(NAN); +#else + return(0.0L); +#endif + } + nflg = 1; + } + } + +/* Integer power of an integer. */ + +if( iyflg ) + { + i = w; + w = floor(x); + if( (w == x) && (fabs(y) < 32768.0) ) + { + w = powi( x, (int) y ); + return( w ); + } + } + +if( nflg ) + x = fabs(x); + +/* For results close to 1, use a series expansion. */ +w = x - 1.0; +aw = fabs(w); +ay = fabs(y); +wy = w * y; +ya = fabs(wy); +if((aw <= 1.0e-3 && ay <= 1.0) + || (ya <= 1.0e-3 && ay >= 1.0)) + { + z = (((((w*(y-5.)/720. + 1./120.)*w*(y-4.) + 1./24.)*w*(y-3.) + + 1./6.)*w*(y-2.) + 0.5)*w*(y-1.) )*wy + wy + 1.; + goto done; + } +/* These are probably too much trouble. */ +#if 0 +w = y * log(x); +if (aw > 1.0e-3 && fabs(w) < 1.0e-3) + { + z = (((((( + w/7. + 1.)*w/6. + 1.)*w/5. + 1.)*w/4. + 1.)*w/3. + 1.)*w/2. + 1.)*w + 1.; + goto done; + } + +if(ya <= 1.0e-3 && aw <= 1.0e-4) + { + z = ((((( + wy*1./720. + + (-w*1./48. + 1./120.) )*wy + + ((w*17./144. - 1./12.)*w + 1./24.) )*wy + + (((-w*5./16. + 7./24.)*w - 1./4.)*w + 1./6.) )*wy + + ((((w*137./360. - 5./12.)*w + 11./24.)*w - 1./2.)*w + 1./2.) )*wy + + (((((-w*1./6. + 1./5.)*w - 1./4)*w + 1./3.)*w -1./2.)*w ) )*wy + + wy + 1.0; + goto done; + } +#endif + +/* separate significand from exponent */ +x = frexp( x, &e ); + +#if 0 +/* For debugging, check for gross overflow. */ +if( (e * y) > (MEXP + 1024) ) + goto overflow; +#endif + +/* Find significand of x in antilog table A[]. */ +i = 1; +if( x <= douba(9) ) + i = 9; +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 * polevl( x, P, 3 ) / p1evl( x, Q, 4 ) ); +w = w - ldexp( z, -1 ); /* w - 0.5 * z */ + +/* Convert to base 2 logarithm: + * multiply by log2(e) + */ +w = w + LOG2EA * w; +/* Note x was not yet added in + * to above rational approximation, + * so do it now, while multiplying + * by log2(e). + */ +z = w + LOG2EA * x; +z = z + x; + +/* Compute exponent term of the base 2 logarithm. */ +w = -i; +w = ldexp( w, -4 ); /* divide by 16 */ +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/16 + */ +ya = reduc(y); +yb = y - ya; + + +F = z * y + w * yb; +Fa = reduc(F); +Fb = F - Fa; + +G = Fa + w * ya; +Ga = reduc(G); +Gb = G - Ga; + +H = Fb + Gb; +Ha = reduc(H); +w = ldexp( Ga+Ha, 4 ); + +/* Test the power of 2 for overflow */ +if( w > MEXP ) + { +#ifndef INFINITIES + mtherr( fname, OVERFLOW ); +#endif +#ifdef INFINITIES + if( nflg && yoddint ) + return( -INFINITY ); + return( INFINITY ); +#else + if( nflg && yoddint ) + return( -MAXNUM ); + return( MAXNUM ); +#endif + } + +if( w < (MNEXP - 1) ) + { +#ifndef DENORMAL + mtherr( fname, UNDERFLOW ); +#endif +#ifdef MINUSZERO + if( nflg && yoddint ) + return( NEGZERO ); +#endif + return( 0.0 ); + } + +e = w; +Hb = H - Ha; + +if( Hb > 0.0 ) + { + e += 1; + Hb -= 0.0625; + } + +/* Now the product y * log2(x) = Hb + e/16.0. + * + * Compute base 2 exponential of Hb, + * where -0.0625 <= Hb <= 0. + */ +z = Hb * polevl( Hb, R, 6 ); /* z = 2**Hb - 1 */ + +/* Express e/16 as an integer plus a negative number of 16ths. + * Find lookup table entry for the fractional power of 2. + */ +if( e < 0 ) + i = 0; +else + i = 1; +i = e/16 + i; +e = 16*i - e; +w = douba( e ); +z = w + w * z; /* 2**-e * ( 1 + (2**Hb-1) ) */ +z = ldexp( z, i ); /* multiply by integer power of 2 */ + +done: + +/* Negate if odd integer power of negative number */ +if( nflg && yoddint ) + { +#ifdef MINUSZERO + if( z == 0.0 ) + z = NEGZERO; + else +#endif + z = -z; + } +return( z ); +} + + +/* Find a multiple of 1/16 that is within 1/16 of x. */ +static double reduc(x) +double x; +{ +double t; + +t = ldexp( x, 4 ); +t = floor( t ); +t = ldexp( t, -4 ); +return(t); +} diff --git a/libm/double/powi.c b/libm/double/powi.c new file mode 100644 index 000000000..46d9a1400 --- /dev/null +++ b/libm/double/powi.c @@ -0,0 +1,186 @@ +/* powi.c + * + * Real raised to integer power + * + * + * + * SYNOPSIS: + * + * double x, y, powi(); + * int n; + * + * y = powi( 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 + * DEC .04,26 -26,26 100000 2.7e-16 4.3e-17 + * IEEE .04,26 -26,26 50000 2.0e-15 3.8e-16 + * IEEE 1,2 -1022,1023 50000 8.6e-14 1.6e-14 + * + * Returns MAXNUM on overflow, zero on underflow. + * + */ + +/* powi.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double log ( double ); +extern double frexp ( double, int * ); +extern int signbit ( double ); +#else +double log(), frexp(); +int signbit(); +#endif +extern double NEGZERO, INFINITY, MAXNUM, MAXLOG, MINLOG, LOGE2; + +double powi( x, nn ) +double x; +int nn; +{ +int n, e, sign, asign, lx; +double w, y, s; + +/* See pow.c for these tests. */ +if( x == 0.0 ) + { + if( nn == 0 ) + return( 1.0 ); + else if( nn < 0 ) + return( INFINITY ); + else + { + if( nn & 1 ) + return( x ); + else + return( 0.0 ); + } + } + +if( nn == 0 ) + return( 1.0 ); + +if( nn == -1 ) + return( 1.0/x ); + +if( x < 0.0 ) + { + asign = -1; + x = -x; + } +else + asign = 0; + + +if( nn < 0 ) + { + sign = -1; + n = -nn; + } +else + { + sign = 1; + n = nn; + } + +/* Even power will be positive. */ +if( (n & 1) == 0 ) + asign = 0; + +/* Overflow detection */ + +/* Calculate approximate logarithm of answer */ +s = frexp( x, &lx ); +e = (lx - 1)*n; +if( (e == 0) || (e > 64) || (e < -64) ) + { + s = (s - 7.0710678118654752e-1) / (s + 7.0710678118654752e-1); + s = (2.9142135623730950 * s - 0.5 + lx) * nn * LOGE2; + } +else + { + s = LOGE2 * e; + } + +if( s > MAXLOG ) + { + mtherr( "powi", OVERFLOW ); + y = INFINITY; + goto done; + } + +#if DENORMAL +if( s < MINLOG ) + { + y = 0.0; + goto done; + } + +/* 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 < (-MAXLOG+2.0)) && (sign < 0) ) + { + x = 1.0/x; + sign = -sign; + } +#else +/* do not produce denormal answer */ +if( s < -MAXLOG ) + return(0.0); +#endif + + +/* First bit of the power */ +if( n & 1 ) + y = x; + +else + y = 1.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; + } + +if( sign < 0 ) + y = 1.0/y; + +done: + +if( asign ) + { + /* odd power of negative number */ + if( y == 0.0 ) + y = NEGZERO; + else + y = -y; + } +return(y); +} diff --git a/libm/double/psi.c b/libm/double/psi.c new file mode 100644 index 000000000..6da2aa0c2 --- /dev/null +++ b/libm/double/psi.c @@ -0,0 +1,201 @@ +/* psi.c + * + * Psi (digamma) function + * + * + * SYNOPSIS: + * + * double x, y, psi(); + * + * y = psi( x ); + * + * + * DESCRIPTION: + * + * d - + * psi(x) = -- ln | (x) + * dx + * + * is the logarithmic derivative of the gamma function. + * For integer x, + * n-1 + * - + * psi(n) = -EUL + > 1/k. + * - + * k=1 + * + * This formula is used for 0 < n <= 10. If x is negative, it + * is transformed to a positive argument by the reflection + * formula psi(1-x) = psi(x) + pi cot(pi x). + * For general positive x, the argument is made greater than 10 + * using the recurrence psi(x+1) = psi(x) + 1/x. + * Then the following asymptotic expansion is applied: + * + * inf. B + * - 2k + * psi(x) = log(x) - 1/2x - > ------- + * - 2k + * k=1 2k x + * + * where the B2k are Bernoulli numbers. + * + * ACCURACY: + * Relative error (except absolute when |psi| < 1): + * arithmetic domain # trials peak rms + * DEC 0,30 2500 1.7e-16 2.0e-17 + * IEEE 0,30 30000 1.3e-15 1.4e-16 + * IEEE -30,0 40000 1.5e-15 2.2e-16 + * + * ERROR MESSAGES: + * message condition value returned + * psi singularity x integer <=0 MAXNUM + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1992, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double A[] = { + 8.33333333333333333333E-2, +-2.10927960927960927961E-2, + 7.57575757575757575758E-3, +-4.16666666666666666667E-3, + 3.96825396825396825397E-3, +-8.33333333333333333333E-3, + 8.33333333333333333333E-2 +}; +#endif + +#ifdef DEC +static unsigned short A[] = { +0037252,0125252,0125252,0125253, +0136654,0145314,0126312,0146255, +0036370,0037017,0101740,0174076, +0136210,0104210,0104210,0104211, +0036202,0004040,0101010,0020202, +0136410,0104210,0104210,0104211, +0037252,0125252,0125252,0125253 +}; +#endif + +#ifdef IBMPC +static unsigned short A[] = { +0x5555,0x5555,0x5555,0x3fb5, +0x5996,0x9599,0x9959,0xbf95, +0x1f08,0xf07c,0x07c1,0x3f7f, +0x1111,0x1111,0x1111,0xbf71, +0x0410,0x1041,0x4104,0x3f70, +0x1111,0x1111,0x1111,0xbf81, +0x5555,0x5555,0x5555,0x3fb5 +}; +#endif + +#ifdef MIEEE +static unsigned short A[] = { +0x3fb5,0x5555,0x5555,0x5555, +0xbf95,0x9959,0x9599,0x5996, +0x3f7f,0x07c1,0xf07c,0x1f08, +0xbf71,0x1111,0x1111,0x1111, +0x3f70,0x4104,0x1041,0x0410, +0xbf81,0x1111,0x1111,0x1111, +0x3fb5,0x5555,0x5555,0x5555 +}; +#endif + +#define EUL 0.57721566490153286061 + +#ifdef ANSIPROT +extern double floor ( double ); +extern double log ( double ); +extern double tan ( double ); +extern double polevl ( double, void *, int ); +#else +double floor(), log(), tan(), polevl(); +#endif +extern double PI, MAXNUM; + + +double psi(x) +double x; +{ +double p, q, nz, s, w, y, z; +int i, n, negative; + +negative = 0; +nz = 0.0; + +if( x <= 0.0 ) + { + negative = 1; + q = x; + p = floor(q); + if( p == q ) + { + mtherr( "psi", SING ); + return( MAXNUM ); + } +/* Remove the zeros of tan(PI x) + * by subtracting the nearest integer from x + */ + nz = q - p; + if( nz != 0.5 ) + { + if( nz > 0.5 ) + { + p += 1.0; + nz = q - p; + } + nz = PI/tan(PI*nz); + } + else + { + nz = 0.0; + } + x = 1.0 - x; + } + +/* check for positive integer up to 10 */ +if( (x <= 10.0) && (x == floor(x)) ) + { + y = 0.0; + n = x; + for( i=1; i<n; i++ ) + { + w = i; + y += 1.0/w; + } + y -= EUL; + goto done; + } + +s = x; +w = 0.0; +while( s < 10.0 ) + { + w += 1.0/s; + s += 1.0; + } + +if( s < 1.0e17 ) + { + z = 1.0/(s * s); + y = z * polevl( z, A, 6 ); + } +else + y = 0.0; + +y = log(s) - (0.5/s) - y - w; + +done: + +if( negative ) + { + y -= nz; + } + +return(y); +} diff --git a/libm/double/revers.c b/libm/double/revers.c new file mode 100644 index 000000000..370bdb5d6 --- /dev/null +++ b/libm/double/revers.c @@ -0,0 +1,156 @@ +/* revers.c + * + * Reversion of power series + * + * + * + * SYNOPSIS: + * + * extern int MAXPOL; + * int n; + * double x[n+1], y[n+1]; + * + * polini(n); + * revers( y, x, n ); + * + * Note, polini() initializes the polynomial arithmetic subroutines; + * see polyn.c. + * + * + * DESCRIPTION: + * + * If + * + * inf + * - i + * y(x) = > a x + * - i + * i=1 + * + * then + * + * inf + * - j + * x(y) = > A y , + * - j + * j=1 + * + * where + * 1 + * A = --- + * 1 a + * 1 + * + * etc. The coefficients of x(y) are found by expanding + * + * inf inf + * - - i + * x(y) = > A > a x + * - j - i + * j=1 i=1 + * + * and setting each coefficient of x , higher than the first, + * to zero. + * + * + * + * RESTRICTIONS: + * + * y[0] must be zero, and y[1] must be nonzero. + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 1992, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +extern int MAXPOL; /* initialized by polini() */ + +#ifdef ANSIPROT +/* See polyn.c. */ +void polmov ( double *, int, double * ); +void polclr ( double *, int ); +void poladd ( double *, int, double *, int, double * ); +void polmul ( double *, int, double *, int, double * ); +void * malloc ( long ); +void free ( void * ); +#else +void polmov(), polclr(), poladd(), polmul(); +void * malloc(); +void free (); +#endif + +void revers( y, x, n) +double y[], x[]; +int n; +{ +double *yn, *yp, *ysum; +int j; + +if( y[1] == 0.0 ) + mtherr( "revers", DOMAIN ); +/* printf( "revers: y[1] = 0\n" );*/ +j = (MAXPOL + 1) * sizeof(double); +yn = (double *)malloc(j); +yp = (double *)malloc(j); +ysum = (double *)malloc(j); + +polmov( y, n, yn ); +polclr( ysum, n ); +x[0] = 0.0; +x[1] = 1.0/y[1]; +for( j=2; j<=n; j++ ) + { +/* A_(j-1) times the expansion of y^(j-1) */ + polmul( &x[j-1], 0, yn, n, yp ); +/* The expansion of the sum of A_k y^k up to k=j-1 */ + poladd( yp, n, ysum, n, ysum ); +/* The expansion of y^j */ + polmul( yn, n, y, n, yn ); +/* The coefficient A_j to make the sum up to k=j equal to zero */ + x[j] = -ysum[j]/yn[j]; + } +free(yn); +free(yp); +free(ysum); +} + + +#if 0 +/* Demonstration program + */ +#define N 10 +double y[N], x[N]; +double fac(); + +main() +{ +double a, odd; +int i; + +polini( N-1 ); +a = 1.0; +y[0] = 0.0; +odd = 1.0; +for( i=1; i<N; i++ ) + { +/* sin(x) */ +/* + if( i & 1 ) + { + y[i] = odd/fac(i); + odd = -odd; + } + else + y[i] = 0.0; +*/ + y[i] = 1.0/fac(i); + } +revers( y, x, N-1 ); +for( i=0; i<N; i++ ) + printf( "%2d %.10e %.10e\n", i, x[i], y[i] ); +} +#endif diff --git a/libm/double/rgamma.c b/libm/double/rgamma.c new file mode 100644 index 000000000..1d6ff3840 --- /dev/null +++ b/libm/double/rgamma.c @@ -0,0 +1,209 @@ +/* rgamma.c + * + * Reciprocal gamma function + * + * + * + * SYNOPSIS: + * + * double x, y, rgamma(); + * + * y = rgamma( x ); + * + * + * + * DESCRIPTION: + * + * Returns one divided by the gamma function of the argument. + * + * The function is approximated by a Chebyshev expansion in + * the interval [0,1]. Range reduction is by recurrence + * for arguments between -34.034 and +34.84425627277176174. + * 1/MAXNUM is returned for positive arguments outside this + * range. For arguments less than -34.034 the cosecant + * reflection formula is applied; lograrithms are employed + * to avoid unnecessary overflow. + * + * The reciprocal gamma function has no singularities, + * but overflow and underflow may occur for large arguments. + * These conditions return either MAXNUM or 1/MAXNUM with + * appropriate sign. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC -30,+30 4000 1.2e-16 1.8e-17 + * IEEE -30,+30 30000 1.1e-15 2.0e-16 + * For arguments less than -34.034 the peak error is on the + * order of 5e-15 (DEC), excepting overflow or underflow. + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +/* Chebyshev coefficients for reciprocal gamma function + * in interval 0 to 1. Function is 1/(x gamma(x)) - 1 + */ + +#ifdef UNK +static double R[] = { + 3.13173458231230000000E-17, +-6.70718606477908000000E-16, + 2.20039078172259550000E-15, + 2.47691630348254132600E-13, +-6.60074100411295197440E-12, + 5.13850186324226978840E-11, + 1.08965386454418662084E-9, +-3.33964630686836942556E-8, + 2.68975996440595483619E-7, + 2.96001177518801696639E-6, +-8.04814124978471142852E-5, + 4.16609138709688864714E-4, + 5.06579864028608725080E-3, +-6.41925436109158228810E-2, +-4.98558728684003594785E-3, + 1.27546015610523951063E-1 +}; +#endif + +#ifdef DEC +static unsigned short R[] = { +0022420,0066376,0176751,0071636, +0123501,0051114,0042104,0131153, +0024036,0107013,0126504,0033361, +0025613,0070040,0035174,0162316, +0126750,0037060,0077775,0122202, +0027541,0177143,0037675,0105150, +0030625,0141311,0075005,0115436, +0132017,0067714,0125033,0014721, +0032620,0063707,0105256,0152643, +0033506,0122235,0072757,0170053, +0134650,0144041,0015617,0016143, +0035332,0066125,0000776,0006215, +0036245,0177377,0137173,0131432, +0137203,0073541,0055645,0141150, +0136243,0057043,0026226,0017362, +0037402,0115554,0033441,0012310 +}; +#endif + +#ifdef IBMPC +static unsigned short R[] = { +0x2e74,0xdfbd,0x0d9f,0x3c82, +0x964d,0x8888,0x2a49,0xbcc8, +0x86de,0x75a8,0xd1c1,0x3ce3, +0x9c9a,0x074f,0x6e04,0x3d51, +0xb490,0x0fff,0x07c6,0xbd9d, +0xb14d,0x67f7,0x3fcc,0x3dcc, +0xb364,0x2f40,0xb859,0x3e12, +0x633a,0x9543,0xedf9,0xbe61, +0xdab4,0xf155,0x0cf8,0x3e92, +0xfe05,0xaebd,0xd493,0x3ec8, +0xe38c,0x2371,0x1904,0xbf15, +0xc192,0xa03f,0x4d8a,0x3f3b, +0x7663,0xf7cf,0xbfdf,0x3f74, +0xb84d,0x2b74,0x6eec,0xbfb0, +0xc3de,0x6592,0x6bc4,0xbf74, +0x2299,0x86e4,0x536d,0x3fc0 +}; +#endif + +#ifdef MIEEE +static unsigned short R[] = { +0x3c82,0x0d9f,0xdfbd,0x2e74, +0xbcc8,0x2a49,0x8888,0x964d, +0x3ce3,0xd1c1,0x75a8,0x86de, +0x3d51,0x6e04,0x074f,0x9c9a, +0xbd9d,0x07c6,0x0fff,0xb490, +0x3dcc,0x3fcc,0x67f7,0xb14d, +0x3e12,0xb859,0x2f40,0xb364, +0xbe61,0xedf9,0x9543,0x633a, +0x3e92,0x0cf8,0xf155,0xdab4, +0x3ec8,0xd493,0xaebd,0xfe05, +0xbf15,0x1904,0x2371,0xe38c, +0x3f3b,0x4d8a,0xa03f,0xc192, +0x3f74,0xbfdf,0xf7cf,0x7663, +0xbfb0,0x6eec,0x2b74,0xb84d, +0xbf74,0x6bc4,0x6592,0xc3de, +0x3fc0,0x536d,0x86e4,0x2299 +}; +#endif + +static char name[] = "rgamma"; + +#ifdef ANSIPROT +extern double chbevl ( double, void *, int ); +extern double exp ( double ); +extern double log ( double ); +extern double sin ( double ); +extern double lgam ( double ); +#else +double chbevl(), exp(), log(), sin(), lgam(); +#endif +extern double PI, MAXLOG, MAXNUM; + + +double rgamma(x) +double x; +{ +double w, y, z; +int sign; + +if( x > 34.84425627277176174) + { + mtherr( name, UNDERFLOW ); + return(1.0/MAXNUM); + } +if( x < -34.034 ) + { + w = -x; + z = sin( PI*w ); + if( z == 0.0 ) + return(0.0); + if( z < 0.0 ) + { + sign = 1; + z = -z; + } + else + sign = -1; + + y = log( w * z ) - log(PI) + lgam(w); + if( y < -MAXLOG ) + { + mtherr( name, UNDERFLOW ); + return( sign * 1.0 / MAXNUM ); + } + if( y > MAXLOG ) + { + mtherr( name, OVERFLOW ); + return( sign * MAXNUM ); + } + return( sign * exp(y)); + } +z = 1.0; +w = x; + +while( w > 1.0 ) /* Downward recurrence */ + { + w -= 1.0; + z *= w; + } +while( w < 0.0 ) /* Upward recurrence */ + { + z /= w; + w += 1.0; + } +if( w == 0.0 ) /* Nonpositive integer */ + return(0.0); +if( w == 1.0 ) /* Other integer */ + return( 1.0/z ); + +y = w * ( 1.0 + chbevl( 4.0*w-2.0, R, 16 ) ) / z; +return(y); +} diff --git a/libm/double/round.c b/libm/double/round.c new file mode 100644 index 000000000..df4564a0f --- /dev/null +++ b/libm/double/round.c @@ -0,0 +1,70 @@ +/* round.c + * + * Round double to nearest or even integer valued double + * + * + * + * SYNOPSIS: + * + * double x, y, round(); + * + * y = round(x); + * + * + * + * DESCRIPTION: + * + * Returns the nearest integer to x as a double precision + * floating point result. If x ends in 0.5 exactly, the + * nearest even integer is chosen. + * + * + * + * ACCURACY: + * + * If x is greater than 1/(2*MACHEP), its closest machine + * representation is already an integer, so rounding does + * not change it. + */ + +/* +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 +*/ +#include <math.h> +#ifdef ANSIPROT +double floor ( double ); +#else +double floor(); +#endif + +double round(x) +double x; +{ +double y, r; + +/* Largest integer <= x */ +y = floor(x); + +/* Fractional part */ +r = x - y; + +/* Round up to nearest. */ +if( r > 0.5 ) + goto rndup; + +/* Round to even */ +if( r == 0.5 ) + { + r = y - 2.0 * floor( 0.5 * y ); + if( r == 1.0 ) + { +rndup: + y += 1.0; + } + } + +/* Else round down. */ +return(y); +} diff --git a/libm/double/setprec.c b/libm/double/setprec.c new file mode 100644 index 000000000..a5222ae73 --- /dev/null +++ b/libm/double/setprec.c @@ -0,0 +1,10 @@ +/* Null stubs for coprocessor precision settings */ + +int +sprec() {return 0; } + +int +dprec() {return 0; } + +int +ldprec() {return 0; } diff --git a/libm/double/shichi.c b/libm/double/shichi.c new file mode 100644 index 000000000..a1497fc34 --- /dev/null +++ b/libm/double/shichi.c @@ -0,0 +1,599 @@ +/* shichi.c + * + * Hyperbolic sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * double x, Chi, Shi, shichi(); + * + * shichi( x, &Chi, &Shi ); + * + * + * DESCRIPTION: + * + * Approximates the integrals + * + * x + * - + * | | cosh t - 1 + * Chi(x) = eul + ln x + | ----------- dt, + * | | t + * - + * 0 + * + * x + * - + * | | sinh t + * Shi(x) = | ------ dt + * | | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are evaluated by power series for x < 8 + * and by Chebyshev expansions for x between 8 and 88. + * For large x, both functions approach exp(x)/2x. + * Arguments greater than 88 in magnitude return MAXNUM. + * + * + * ACCURACY: + * + * Test interval 0 to 88. + * Relative error: + * arithmetic function # trials peak rms + * DEC Shi 3000 9.1e-17 + * IEEE Shi 30000 6.9e-16 1.6e-16 + * Absolute error, except relative when |Chi| > 1: + * DEC Chi 2500 9.3e-17 + * IEEE Chi 30000 8.4e-16 1.4e-16 + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> + +#ifdef UNK +/* x exp(-x) shi(x), inverted interval 8 to 18 */ +static double S1[] = { + 1.83889230173399459482E-17, +-9.55485532279655569575E-17, + 2.04326105980879882648E-16, + 1.09896949074905343022E-15, +-1.31313534344092599234E-14, + 5.93976226264314278932E-14, +-3.47197010497749154755E-14, +-1.40059764613117131000E-12, + 9.49044626224223543299E-12, +-1.61596181145435454033E-11, +-1.77899784436430310321E-10, + 1.35455469767246947469E-9, +-1.03257121792819495123E-9, +-3.56699611114982536845E-8, + 1.44818877384267342057E-7, + 7.82018215184051295296E-7, +-5.39919118403805073710E-6, +-3.12458202168959833422E-5, + 8.90136741950727517826E-5, + 2.02558474743846862168E-3, + 2.96064440855633256972E-2, + 1.11847751047257036625E0 +}; + +/* x exp(-x) shi(x), inverted interval 18 to 88 */ +static double S2[] = { +-1.05311574154850938805E-17, + 2.62446095596355225821E-17, + 8.82090135625368160657E-17, +-3.38459811878103047136E-16, +-8.30608026366935789136E-16, + 3.93397875437050071776E-15, + 1.01765565969729044505E-14, +-4.21128170307640802703E-14, +-1.60818204519802480035E-13, + 3.34714954175994481761E-13, + 2.72600352129153073807E-12, + 1.66894954752839083608E-12, +-3.49278141024730899554E-11, +-1.58580661666482709598E-10, +-1.79289437183355633342E-10, + 1.76281629144264523277E-9, + 1.69050228879421288846E-8, + 1.25391771228487041649E-7, + 1.16229947068677338732E-6, + 1.61038260117376323993E-5, + 3.49810375601053973070E-4, + 1.28478065259647610779E-2, + 1.03665722588798326712E0 +}; +#endif + +#ifdef DEC +static unsigned short S1[] = { +0022251,0115635,0165120,0006574, +0122734,0050751,0020305,0101356, +0023153,0111154,0011103,0177462, +0023636,0060321,0060253,0124246, +0124554,0106655,0152525,0166400, +0025205,0140145,0171006,0106556, +0125034,0056427,0004205,0176022, +0126305,0016731,0025011,0134453, +0027046,0172453,0112604,0116235, +0127216,0022071,0116600,0137667, +0130103,0115126,0071104,0052535, +0030672,0025450,0010071,0141414, +0130615,0165136,0132137,0177737, +0132031,0031611,0074436,0175407, +0032433,0077602,0104345,0060076, +0033121,0165741,0167177,0172433, +0133665,0025262,0174621,0022612, +0134403,0006761,0124566,0145405, +0034672,0126332,0034737,0116744, +0036004,0137654,0037332,0131766, +0036762,0104466,0121445,0124326, +0040217,0025105,0062145,0042640 +}; + +static unsigned short S2[] = { +0122102,0041774,0016051,0055137, +0022362,0010125,0007651,0015773, +0022713,0062551,0040227,0071645, +0123303,0015732,0025731,0146570, +0123557,0064016,0002067,0067711, +0024215,0136214,0132374,0124234, +0024467,0051425,0071066,0064210, +0125075,0124305,0135123,0024170, +0125465,0010261,0005560,0034232, +0025674,0066602,0030724,0174557, +0026477,0151520,0051510,0067250, +0026352,0161076,0113154,0116271, +0127431,0116470,0177465,0127274, +0130056,0056174,0170315,0013321, +0130105,0020575,0075327,0036710, +0030762,0043625,0113046,0125035, +0031621,0033211,0154354,0022077, +0032406,0121555,0074270,0041141, +0033234,0000116,0041611,0173743, +0034207,0013263,0174715,0115563, +0035267,0063300,0175753,0117266, +0036522,0077633,0033255,0136200, +0040204,0130457,0014454,0166254 +}; +#endif + +#ifdef IBMPC +static unsigned short S1[] = { +0x01b0,0xbd4a,0x3373,0x3c75, +0xb05e,0x2418,0x8a3d,0xbc9b, +0x7fe6,0x8248,0x724d,0x3cad, +0x7515,0x2c15,0xcc1a,0x3cd3, +0xbda0,0xbaaa,0x91b5,0xbd0d, +0xd1ae,0xbe40,0xb80c,0x3d30, +0xbf82,0xe110,0x8ba2,0xbd23, +0x3725,0x2541,0xa3bb,0xbd78, +0x9394,0x72b0,0xdea5,0x3da4, +0x17f7,0x33b0,0xc487,0xbdb1, +0x8aac,0xce48,0x734a,0xbde8, +0x3862,0x0207,0x4565,0x3e17, +0xfffc,0xd68b,0xbd4b,0xbe11, +0xdf61,0x2f23,0x2671,0xbe63, +0xac08,0x511c,0x6ff0,0x3e83, +0xfea3,0x3dcf,0x3d7c,0x3eaa, +0x24b1,0x5f32,0xa556,0xbed6, +0xd961,0x352e,0x61be,0xbf00, +0xf3bd,0x473b,0x559b,0x3f17, +0x567f,0x87db,0x97f5,0x3f60, +0xb51b,0xd464,0x5126,0x3f9e, +0xa8b4,0xac8c,0xe548,0x3ff1 +}; + +static unsigned short S2[] = { +0x2b4c,0x8385,0x487f,0xbc68, +0x237f,0xa1f5,0x420a,0x3c7e, +0xee75,0x2812,0x6cad,0x3c99, +0x39af,0x457b,0x637b,0xbcb8, +0xedf9,0xc086,0xed01,0xbccd, +0x9513,0x969f,0xb791,0x3cf1, +0xcd11,0xae46,0xea62,0x3d06, +0x650f,0xb74a,0xb518,0xbd27, +0x0713,0x216e,0xa216,0xbd46, +0x9f2e,0x463a,0x8db0,0x3d57, +0x0dd5,0x0a69,0xfa6a,0x3d87, +0x9397,0xd2cd,0x5c47,0x3d7d, +0xb5d8,0x1fe6,0x33a7,0xbdc3, +0xa2da,0x9e19,0xcb8f,0xbde5, +0xe7b9,0xaf5a,0xa42f,0xbde8, +0xd544,0xb2c4,0x48f2,0x3e1e, +0x8488,0x3b1d,0x26d1,0x3e52, +0x084c,0xaf17,0xd46d,0x3e80, +0x3efc,0xc871,0x8009,0x3eb3, +0xb36e,0x7f39,0xe2d6,0x3ef0, +0x73d7,0x1f7d,0xecd8,0x3f36, +0xb790,0x66d5,0x4ff3,0x3f8a, +0x9d96,0xe325,0x9625,0x3ff0 +}; +#endif + +#ifdef MIEEE +static unsigned short S1[] = { +0x3c75,0x3373,0xbd4a,0x01b0, +0xbc9b,0x8a3d,0x2418,0xb05e, +0x3cad,0x724d,0x8248,0x7fe6, +0x3cd3,0xcc1a,0x2c15,0x7515, +0xbd0d,0x91b5,0xbaaa,0xbda0, +0x3d30,0xb80c,0xbe40,0xd1ae, +0xbd23,0x8ba2,0xe110,0xbf82, +0xbd78,0xa3bb,0x2541,0x3725, +0x3da4,0xdea5,0x72b0,0x9394, +0xbdb1,0xc487,0x33b0,0x17f7, +0xbde8,0x734a,0xce48,0x8aac, +0x3e17,0x4565,0x0207,0x3862, +0xbe11,0xbd4b,0xd68b,0xfffc, +0xbe63,0x2671,0x2f23,0xdf61, +0x3e83,0x6ff0,0x511c,0xac08, +0x3eaa,0x3d7c,0x3dcf,0xfea3, +0xbed6,0xa556,0x5f32,0x24b1, +0xbf00,0x61be,0x352e,0xd961, +0x3f17,0x559b,0x473b,0xf3bd, +0x3f60,0x97f5,0x87db,0x567f, +0x3f9e,0x5126,0xd464,0xb51b, +0x3ff1,0xe548,0xac8c,0xa8b4 +}; + +static unsigned short S2[] = { +0xbc68,0x487f,0x8385,0x2b4c, +0x3c7e,0x420a,0xa1f5,0x237f, +0x3c99,0x6cad,0x2812,0xee75, +0xbcb8,0x637b,0x457b,0x39af, +0xbccd,0xed01,0xc086,0xedf9, +0x3cf1,0xb791,0x969f,0x9513, +0x3d06,0xea62,0xae46,0xcd11, +0xbd27,0xb518,0xb74a,0x650f, +0xbd46,0xa216,0x216e,0x0713, +0x3d57,0x8db0,0x463a,0x9f2e, +0x3d87,0xfa6a,0x0a69,0x0dd5, +0x3d7d,0x5c47,0xd2cd,0x9397, +0xbdc3,0x33a7,0x1fe6,0xb5d8, +0xbde5,0xcb8f,0x9e19,0xa2da, +0xbde8,0xa42f,0xaf5a,0xe7b9, +0x3e1e,0x48f2,0xb2c4,0xd544, +0x3e52,0x26d1,0x3b1d,0x8488, +0x3e80,0xd46d,0xaf17,0x084c, +0x3eb3,0x8009,0xc871,0x3efc, +0x3ef0,0xe2d6,0x7f39,0xb36e, +0x3f36,0xecd8,0x1f7d,0x73d7, +0x3f8a,0x4ff3,0x66d5,0xb790, +0x3ff0,0x9625,0xe325,0x9d96 +}; +#endif + + +#ifdef UNK +/* x exp(-x) chin(x), inverted interval 8 to 18 */ +static double C1[] = { +-8.12435385225864036372E-18, + 2.17586413290339214377E-17, + 5.22624394924072204667E-17, +-9.48812110591690559363E-16, + 5.35546311647465209166E-15, +-1.21009970113732918701E-14, +-6.00865178553447437951E-14, + 7.16339649156028587775E-13, +-2.93496072607599856104E-12, +-1.40359438136491256904E-12, + 8.76302288609054966081E-11, +-4.40092476213282340617E-10, +-1.87992075640569295479E-10, + 1.31458150989474594064E-8, +-4.75513930924765465590E-8, +-2.21775018801848880741E-7, + 1.94635531373272490962E-6, + 4.33505889257316408893E-6, +-6.13387001076494349496E-5, +-3.13085477492997465138E-4, + 4.97164789823116062801E-4, + 2.64347496031374526641E-2, + 1.11446150876699213025E0 +}; + +/* x exp(-x) chin(x), inverted interval 18 to 88 */ +static double C2[] = { + 8.06913408255155572081E-18, +-2.08074168180148170312E-17, +-5.98111329658272336816E-17, + 2.68533951085945765591E-16, + 4.52313941698904694774E-16, +-3.10734917335299464535E-15, +-4.42823207332531972288E-15, + 3.49639695410806959872E-14, + 6.63406731718911586609E-14, +-3.71902448093119218395E-13, +-1.27135418132338309016E-12, + 2.74851141935315395333E-12, + 2.33781843985453438400E-11, + 2.71436006377612442764E-11, +-2.56600180000355990529E-10, +-1.61021375163803438552E-9, +-4.72543064876271773512E-9, +-3.00095178028681682282E-9, + 7.79387474390914922337E-8, + 1.06942765566401507066E-6, + 1.59503164802313196374E-5, + 3.49592575153777996871E-4, + 1.28475387530065247392E-2, + 1.03665693917934275131E0 +}; +#endif + +#ifdef DEC +static unsigned short C1[] = { +0122025,0157055,0021702,0021427, +0022310,0130043,0123265,0022340, +0022561,0002231,0017746,0013043, +0123610,0136375,0002352,0024467, +0024300,0171555,0141300,0000446, +0124531,0176777,0126210,0035616, +0125207,0046604,0167760,0077132, +0026111,0120666,0026606,0064143, +0126516,0103615,0054127,0005436, +0126305,0104721,0025415,0004134, +0027700,0131556,0164725,0157553, +0130361,0170602,0077274,0055406, +0130116,0131420,0125472,0017231, +0031541,0153747,0177312,0056304, +0132114,0035517,0041545,0043151, +0132556,0020415,0110044,0172442, +0033402,0117041,0031152,0010364, +0033621,0072737,0050647,0013720, +0134600,0121366,0140010,0063265, +0135244,0022637,0013756,0044742, +0035402,0052052,0006523,0043564, +0036730,0106660,0020277,0162146, +0040216,0123254,0135147,0005724 +}; + +static unsigned short C2[] = { +0022024,0154550,0104311,0144257, +0122277,0165037,0133443,0155601, +0122611,0165102,0157053,0055252, +0023232,0146235,0153511,0113222, +0023402,0057340,0145304,0010471, +0124137,0164171,0113071,0100002, +0124237,0105473,0056130,0022022, +0025035,0073266,0056746,0164433, +0025225,0061313,0055600,0165407, +0125721,0056312,0107613,0051215, +0126262,0166534,0115336,0066653, +0026501,0064307,0127442,0065573, +0027315,0121375,0142020,0045356, +0027356,0140764,0070641,0046570, +0130215,0010503,0146335,0177737, +0130735,0047134,0015215,0163665, +0131242,0056523,0155276,0050053, +0131116,0034515,0050707,0163512, +0032247,0057507,0107545,0032007, +0033217,0104501,0021706,0025047, +0034205,0146413,0033746,0076562, +0035267,0044605,0065355,0002772, +0036522,0077173,0130716,0170304, +0040204,0130454,0130571,0027270 +}; +#endif + +#ifdef IBMPC +static unsigned short C1[] = { +0x4463,0xa478,0xbbc5,0xbc62, +0xa49c,0x74d6,0x1604,0x3c79, +0xc2c4,0x23fc,0x2093,0x3c8e, +0x4527,0xa09d,0x179f,0xbcd1, +0x0025,0xb858,0x1e6d,0x3cf8, +0x0772,0xf591,0x3fbf,0xbd0b, +0x0fcb,0x9dfe,0xe9b0,0xbd30, +0xcd0c,0xc5b0,0x3436,0x3d69, +0xe164,0xab0a,0xd0f1,0xbd89, +0xa10c,0x2561,0xb13a,0xbd78, +0xbbed,0xdd3a,0x166d,0x3dd8, +0x8b61,0x4fd7,0x3e30,0xbdfe, +0x43d3,0x1567,0xd662,0xbde9, +0x4b98,0xffd9,0x3afc,0x3e4c, +0xa8cd,0xe86c,0x8769,0xbe69, +0x9ea4,0xb204,0xc421,0xbe8d, +0x421f,0x264d,0x53c4,0x3ec0, +0xe2fa,0xea34,0x2ebb,0x3ed2, +0x0cd7,0xd801,0x145e,0xbf10, +0xc93c,0xe2fd,0x84b3,0xbf34, +0x68ef,0x41aa,0x4a85,0x3f40, +0xfc8d,0x0417,0x11b6,0x3f9b, +0xe17b,0x974c,0xd4d5,0x3ff1 +}; + +static unsigned short C2[] = { +0x3916,0x1119,0x9b2d,0x3c62, +0x7b70,0xf6e4,0xfd43,0xbc77, +0x6b55,0x5bc5,0x3d48,0xbc91, +0x32d2,0xbae9,0x5993,0x3cb3, +0x8227,0x1958,0x4bdc,0x3cc0, +0x3000,0x32c7,0xfd0f,0xbceb, +0x0482,0x6b8b,0xf167,0xbcf3, +0xdd23,0xcbbc,0xaed6,0x3d23, +0x1d61,0x6b70,0xac59,0x3d32, +0x6a52,0x51f1,0x2b99,0xbd5a, +0xcdb5,0x935b,0x5dab,0xbd76, +0x4d6f,0xf5e4,0x2d18,0x3d88, +0x095e,0xb882,0xb45f,0x3db9, +0x29af,0x8e34,0xd83e,0x3dbd, +0xbffc,0x799b,0xa228,0xbdf1, +0xbcf7,0x8351,0xa9cb,0xbe1b, +0xca05,0x7b57,0x4baa,0xbe34, +0xfce9,0xaa38,0xc729,0xbe29, +0xa681,0xf1ec,0xebe8,0x3e74, +0xc545,0x2478,0xf128,0x3eb1, +0xcfae,0x66fc,0xb9a1,0x3ef0, +0xa0bf,0xad5d,0xe930,0x3f36, +0xde19,0x7639,0x4fcf,0x3f8a, +0x25d7,0x962f,0x9625,0x3ff0 +}; +#endif + +#ifdef MIEEE +static unsigned short C1[] = { +0xbc62,0xbbc5,0xa478,0x4463, +0x3c79,0x1604,0x74d6,0xa49c, +0x3c8e,0x2093,0x23fc,0xc2c4, +0xbcd1,0x179f,0xa09d,0x4527, +0x3cf8,0x1e6d,0xb858,0x0025, +0xbd0b,0x3fbf,0xf591,0x0772, +0xbd30,0xe9b0,0x9dfe,0x0fcb, +0x3d69,0x3436,0xc5b0,0xcd0c, +0xbd89,0xd0f1,0xab0a,0xe164, +0xbd78,0xb13a,0x2561,0xa10c, +0x3dd8,0x166d,0xdd3a,0xbbed, +0xbdfe,0x3e30,0x4fd7,0x8b61, +0xbde9,0xd662,0x1567,0x43d3, +0x3e4c,0x3afc,0xffd9,0x4b98, +0xbe69,0x8769,0xe86c,0xa8cd, +0xbe8d,0xc421,0xb204,0x9ea4, +0x3ec0,0x53c4,0x264d,0x421f, +0x3ed2,0x2ebb,0xea34,0xe2fa, +0xbf10,0x145e,0xd801,0x0cd7, +0xbf34,0x84b3,0xe2fd,0xc93c, +0x3f40,0x4a85,0x41aa,0x68ef, +0x3f9b,0x11b6,0x0417,0xfc8d, +0x3ff1,0xd4d5,0x974c,0xe17b +}; + +static unsigned short C2[] = { +0x3c62,0x9b2d,0x1119,0x3916, +0xbc77,0xfd43,0xf6e4,0x7b70, +0xbc91,0x3d48,0x5bc5,0x6b55, +0x3cb3,0x5993,0xbae9,0x32d2, +0x3cc0,0x4bdc,0x1958,0x8227, +0xbceb,0xfd0f,0x32c7,0x3000, +0xbcf3,0xf167,0x6b8b,0x0482, +0x3d23,0xaed6,0xcbbc,0xdd23, +0x3d32,0xac59,0x6b70,0x1d61, +0xbd5a,0x2b99,0x51f1,0x6a52, +0xbd76,0x5dab,0x935b,0xcdb5, +0x3d88,0x2d18,0xf5e4,0x4d6f, +0x3db9,0xb45f,0xb882,0x095e, +0x3dbd,0xd83e,0x8e34,0x29af, +0xbdf1,0xa228,0x799b,0xbffc, +0xbe1b,0xa9cb,0x8351,0xbcf7, +0xbe34,0x4baa,0x7b57,0xca05, +0xbe29,0xc729,0xaa38,0xfce9, +0x3e74,0xebe8,0xf1ec,0xa681, +0x3eb1,0xf128,0x2478,0xc545, +0x3ef0,0xb9a1,0x66fc,0xcfae, +0x3f36,0xe930,0xad5d,0xa0bf, +0x3f8a,0x4fcf,0x7639,0xde19, +0x3ff0,0x9625,0x962f,0x25d7 +}; +#endif + + + +/* Sine and cosine integrals */ + +#ifdef ANSIPROT +extern double log ( double ); +extern double exp ( double ); +extern double fabs ( double ); +extern double chbevl ( double, void *, int ); +#else +double log(), exp(), fabs(), chbevl(); +#endif +#define EUL 0.57721566490153286061 +extern double MACHEP, MAXNUM, PIO2; + +int shichi( x, si, ci ) +double x; +double *si, *ci; +{ +double k, z, c, s, a; +short sign; + +if( x < 0.0 ) + { + sign = -1; + x = -x; + } +else + sign = 0; + + +if( x == 0.0 ) + { + *si = 0.0; + *ci = -MAXNUM; + return( 0 ); + } + +if( x >= 8.0 ) + goto chb; + +z = x * x; + +/* Direct power series expansion */ + +a = 1.0; +s = 1.0; +c = 0.0; +k = 2.0; + +do + { + a *= z/k; + c += a/k; + k += 1.0; + a /= k; + s += a/k; + k += 1.0; + } +while( fabs(a/s) > MACHEP ); + +s *= x; +goto done; + + +chb: + +if( x < 18.0 ) + { + a = (576.0/x - 52.0)/10.0; + k = exp(x) / x; + s = k * chbevl( a, S1, 22 ); + c = k * chbevl( a, C1, 23 ); + goto done; + } + +if( x <= 88.0 ) + { + a = (6336.0/x - 212.0)/70.0; + k = exp(x) / x; + s = k * chbevl( a, S2, 23 ); + c = k * chbevl( a, C2, 24 ); + goto done; + } +else + { + if( sign ) + *si = -MAXNUM; + else + *si = MAXNUM; + *ci = MAXNUM; + return(0); + } +done: +if( sign ) + s = -s; + +*si = s; + +*ci = EUL + log(x) + c; +return(0); +} diff --git a/libm/double/sici.c b/libm/double/sici.c new file mode 100644 index 000000000..b00b9c449 --- /dev/null +++ b/libm/double/sici.c @@ -0,0 +1,675 @@ +/* sici.c + * + * Sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * double x, Ci, Si, sici(); + * + * sici( x, &Si, &Ci ); + * + * + * DESCRIPTION: + * + * Evaluates the integrals + * + * x + * - + * | cos t - 1 + * Ci(x) = eul + ln x + | --------- dt, + * | t + * - + * 0 + * x + * - + * | sin t + * Si(x) = | ----- dt + * | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are approximated by rational functions. + * For x > 8 auxiliary functions f(x) and g(x) are employed + * such that + * + * Ci(x) = f(x) sin(x) - g(x) cos(x) + * Si(x) = pi/2 - f(x) cos(x) - g(x) sin(x) + * + * + * ACCURACY: + * Test interval = [0,50]. + * Absolute error, except relative when > 1: + * arithmetic function # trials peak rms + * IEEE Si 30000 4.4e-16 7.3e-17 + * IEEE Ci 30000 6.9e-16 5.1e-17 + * DEC Si 5000 4.4e-17 9.0e-18 + * DEC Ci 5300 7.9e-17 5.2e-18 + */ + +/* +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 +*/ + +#include <math.h> + +#ifdef UNK +static double SN[] = { +-8.39167827910303881427E-11, + 4.62591714427012837309E-8, +-9.75759303843632795789E-6, + 9.76945438170435310816E-4, +-4.13470316229406538752E-2, + 1.00000000000000000302E0, +}; +static double SD[] = { + 2.03269266195951942049E-12, + 1.27997891179943299903E-9, + 4.41827842801218905784E-7, + 9.96412122043875552487E-5, + 1.42085239326149893930E-2, + 9.99999999999999996984E-1, +}; +#endif +#ifdef DEC +static unsigned short SN[] = { +0127670,0104362,0167505,0035161, +0032106,0127177,0032131,0056461, +0134043,0132213,0000476,0172351, +0035600,0006331,0064761,0032665, +0137051,0055601,0044667,0017645, +0040200,0000000,0000000,0000000, +}; +static unsigned short SD[] = { +0026417,0004674,0052064,0001573, +0030657,0165501,0014666,0131526, +0032755,0032133,0034147,0024124, +0034720,0173167,0166624,0154477, +0036550,0145336,0063534,0063220, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short SN[] = { +0xa74e,0x5de8,0x111e,0xbdd7, +0x2ba6,0xe68b,0xd5cf,0x3e68, +0xde9d,0x6027,0x7691,0xbee4, +0x26b7,0x2d3e,0x019b,0x3f50, +0xe3f5,0x2936,0x2b70,0xbfa5, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short SD[] = { +0x806f,0x8a86,0xe137,0x3d81, +0xd66b,0x2336,0xfd68,0x3e15, +0xe50a,0x670c,0xa68b,0x3e9d, +0x9b28,0xfdb2,0x1ece,0x3f1a, +0x8cd2,0xcceb,0x195b,0x3f8d, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short SN[] = { +0xbdd7,0x111e,0x5de8,0xa74e, +0x3e68,0xd5cf,0xe68b,0x2ba6, +0xbee4,0x7691,0x6027,0xde9d, +0x3f50,0x019b,0x2d3e,0x26b7, +0xbfa5,0x2b70,0x2936,0xe3f5, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short SD[] = { +0x3d81,0xe137,0x8a86,0x806f, +0x3e15,0xfd68,0x2336,0xd66b, +0x3e9d,0xa68b,0x670c,0xe50a, +0x3f1a,0x1ece,0xfdb2,0x9b28, +0x3f8d,0x195b,0xcceb,0x8cd2, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif +#ifdef UNK +static double CN[] = { + 2.02524002389102268789E-11, +-1.35249504915790756375E-8, + 3.59325051419993077021E-6, +-4.74007206873407909465E-4, + 2.89159652607555242092E-2, +-1.00000000000000000080E0, +}; +static double CD[] = { + 4.07746040061880559506E-12, + 3.06780997581887812692E-9, + 1.23210355685883423679E-6, + 3.17442024775032769882E-4, + 5.10028056236446052392E-2, + 4.00000000000000000080E0, +}; +#endif +#ifdef DEC +static unsigned short CN[] = { +0027262,0022131,0160257,0020166, +0131550,0055534,0077637,0000557, +0033561,0021622,0161463,0026575, +0135370,0102053,0116333,0000466, +0036754,0160454,0122022,0024622, +0140200,0000000,0000000,0000000, +}; +static unsigned short CD[] = { +0026617,0073177,0107543,0104425, +0031122,0150573,0156453,0041517, +0033245,0057301,0077706,0110510, +0035246,0067130,0165424,0044543, +0037120,0164121,0061206,0053657, +0040600,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short CN[] = { +0xe40f,0x3c15,0x448b,0x3db6, +0xe02e,0x8ff3,0x0b6b,0xbe4d, +0x65b0,0x5c66,0x2472,0x3ece, +0x6027,0x739b,0x1085,0xbf3f, +0x4532,0x9482,0x9c25,0x3f9d, +0x0000,0x0000,0x0000,0xbff0, +}; +static unsigned short CD[] = { +0x7123,0xf1ec,0xeecf,0x3d91, +0x686a,0x7ba5,0x5a2f,0x3e2a, +0xd229,0x2ff8,0xabd8,0x3eb4, +0x892c,0x1d62,0xcdcb,0x3f34, +0xcaf6,0x2c50,0x1d0a,0x3faa, +0x0000,0x0000,0x0000,0x4010, +}; +#endif +#ifdef MIEEE +static unsigned short CN[] = { +0x3db6,0x448b,0x3c15,0xe40f, +0xbe4d,0x0b6b,0x8ff3,0xe02e, +0x3ece,0x2472,0x5c66,0x65b0, +0xbf3f,0x1085,0x739b,0x6027, +0x3f9d,0x9c25,0x9482,0x4532, +0xbff0,0x0000,0x0000,0x0000, +}; +static unsigned short CD[] = { +0x3d91,0xeecf,0xf1ec,0x7123, +0x3e2a,0x5a2f,0x7ba5,0x686a, +0x3eb4,0xabd8,0x2ff8,0xd229, +0x3f34,0xcdcb,0x1d62,0x892c, +0x3faa,0x1d0a,0x2c50,0xcaf6, +0x4010,0x0000,0x0000,0x0000, +}; +#endif + + +#ifdef UNK +static double FN4[] = { + 4.23612862892216586994E0, + 5.45937717161812843388E0, + 1.62083287701538329132E0, + 1.67006611831323023771E-1, + 6.81020132472518137426E-3, + 1.08936580650328664411E-4, + 5.48900223421373614008E-7, +}; +static double FD4[] = { +/* 1.00000000000000000000E0,*/ + 8.16496634205391016773E0, + 7.30828822505564552187E0, + 1.86792257950184183883E0, + 1.78792052963149907262E-1, + 7.01710668322789753610E-3, + 1.10034357153915731354E-4, + 5.48900252756255700982E-7, +}; +#endif +#ifdef DEC +static unsigned short FN4[] = { +0040607,0107135,0120133,0153471, +0040656,0131467,0140424,0017567, +0040317,0073563,0121610,0002511, +0037453,0001710,0000040,0006334, +0036337,0024033,0176003,0171425, +0034744,0072341,0121657,0126035, +0033023,0054042,0154652,0000451, +}; +static unsigned short FD4[] = { +/*0040200,0000000,0000000,0000000,*/ +0041002,0121663,0137500,0177450, +0040751,0156577,0042213,0061552, +0040357,0014026,0045465,0147265, +0037467,0012503,0110413,0131772, +0036345,0167701,0155706,0160551, +0034746,0141076,0162250,0123547, +0033023,0054043,0056706,0151050, +}; +#endif +#ifdef IBMPC +static unsigned short FN4[] = { +0x7ae7,0xb40b,0xf1cb,0x4010, +0x83ef,0xf822,0xd666,0x4015, +0x00a9,0x7471,0xeeee,0x3ff9, +0x019c,0x0004,0x6079,0x3fc5, +0x7e63,0x7f80,0xe503,0x3f7b, +0xf584,0x3475,0x8e9c,0x3f1c, +0x4025,0x5b35,0x6b04,0x3ea2, +}; +static unsigned short FD4[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x1fe5,0x77e8,0x5476,0x4020, +0x6c6d,0xe891,0x3baf,0x401d, +0xb9d7,0xc966,0xe302,0x3ffd, +0x767f,0x7221,0xe2a8,0x3fc6, +0xdc2d,0x3b78,0xbdf8,0x3f7c, +0x14ed,0xdc95,0xd847,0x3f1c, +0xda45,0x6bb8,0x6b04,0x3ea2, +}; +#endif +#ifdef MIEEE +static unsigned short FN4[] = { +0x4010,0xf1cb,0xb40b,0x7ae7, +0x4015,0xd666,0xf822,0x83ef, +0x3ff9,0xeeee,0x7471,0x00a9, +0x3fc5,0x6079,0x0004,0x019c, +0x3f7b,0xe503,0x7f80,0x7e63, +0x3f1c,0x8e9c,0x3475,0xf584, +0x3ea2,0x6b04,0x5b35,0x4025, +}; +static unsigned short FD4[] = { +/* 0x3ff0,0x0000,0x0000,0x0000,*/ +0x4020,0x5476,0x77e8,0x1fe5, +0x401d,0x3baf,0xe891,0x6c6d, +0x3ffd,0xe302,0xc966,0xb9d7, +0x3fc6,0xe2a8,0x7221,0x767f, +0x3f7c,0xbdf8,0x3b78,0xdc2d, +0x3f1c,0xd847,0xdc95,0x14ed, +0x3ea2,0x6b04,0x6bb8,0xda45, +}; +#endif + +#ifdef UNK +static double FN8[] = { + 4.55880873470465315206E-1, + 7.13715274100146711374E-1, + 1.60300158222319456320E-1, + 1.16064229408124407915E-2, + 3.49556442447859055605E-4, + 4.86215430826454749482E-6, + 3.20092790091004902806E-8, + 9.41779576128512936592E-11, + 9.70507110881952024631E-14, +}; +static double FD8[] = { +/* 1.00000000000000000000E0,*/ + 9.17463611873684053703E-1, + 1.78685545332074536321E-1, + 1.22253594771971293032E-2, + 3.58696481881851580297E-4, + 4.92435064317881464393E-6, + 3.21956939101046018377E-8, + 9.43720590350276732376E-11, + 9.70507110881952025725E-14, +}; +#endif +#ifdef DEC +static unsigned short FN8[] = { +0037751,0064467,0142332,0164573, +0040066,0133013,0050352,0071102, +0037444,0022671,0102157,0013535, +0036476,0024335,0136423,0146444, +0035267,0042253,0164110,0110460, +0033643,0022626,0062535,0060320, +0032011,0075223,0010110,0153413, +0027717,0014572,0011360,0014034, +0025332,0104755,0004563,0152354, +}; +static unsigned short FD8[] = { +/*0040200,0000000,0000000,0000000,*/ +0040152,0157345,0030104,0075616, +0037466,0174527,0172740,0071060, +0036510,0046337,0144272,0156552, +0035274,0007555,0042537,0015572, +0033645,0035731,0112465,0026474, +0032012,0043612,0030613,0030123, +0027717,0103277,0004564,0151000, +0025332,0104755,0004563,0152354, +}; +#endif +#ifdef IBMPC +static unsigned short FN8[] = { +0x5d2f,0xf89b,0x2d26,0x3fdd, +0x4e48,0x6a1d,0xd6c1,0x3fe6, +0xe2ec,0x308d,0x84b7,0x3fc4, +0x79a4,0xb7a2,0xc51b,0x3f87, +0x1226,0x7d09,0xe895,0x3f36, +0xac1a,0xccab,0x64b2,0x3ed4, +0x1ae1,0x6209,0x2f52,0x3e61, +0x0304,0x425e,0xe32f,0x3dd9, +0x7a9d,0xa12e,0x513d,0x3d3b, +}; +static unsigned short FD8[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x8f72,0xa608,0x5bdc,0x3fed, +0x0e46,0xfebc,0xdf2a,0x3fc6, +0x5bad,0xf917,0x099b,0x3f89, +0xe36f,0xa8ab,0x81ed,0x3f37, +0xa5a8,0x32a6,0xa77b,0x3ed4, +0x660a,0x4631,0x48f1,0x3e61, +0x9a40,0xe12e,0xf0d7,0x3dd9, +0x7a9d,0xa12e,0x513d,0x3d3b, +}; +#endif +#ifdef MIEEE +static unsigned short FN8[] = { +0x3fdd,0x2d26,0xf89b,0x5d2f, +0x3fe6,0xd6c1,0x6a1d,0x4e48, +0x3fc4,0x84b7,0x308d,0xe2ec, +0x3f87,0xc51b,0xb7a2,0x79a4, +0x3f36,0xe895,0x7d09,0x1226, +0x3ed4,0x64b2,0xccab,0xac1a, +0x3e61,0x2f52,0x6209,0x1ae1, +0x3dd9,0xe32f,0x425e,0x0304, +0x3d3b,0x513d,0xa12e,0x7a9d, +}; +static unsigned short FD8[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3fed,0x5bdc,0xa608,0x8f72, +0x3fc6,0xdf2a,0xfebc,0x0e46, +0x3f89,0x099b,0xf917,0x5bad, +0x3f37,0x81ed,0xa8ab,0xe36f, +0x3ed4,0xa77b,0x32a6,0xa5a8, +0x3e61,0x48f1,0x4631,0x660a, +0x3dd9,0xf0d7,0xe12e,0x9a40, +0x3d3b,0x513d,0xa12e,0x7a9d, +}; +#endif + +#ifdef UNK +static double GN4[] = { + 8.71001698973114191777E-2, + 6.11379109952219284151E-1, + 3.97180296392337498885E-1, + 7.48527737628469092119E-2, + 5.38868681462177273157E-3, + 1.61999794598934024525E-4, + 1.97963874140963632189E-6, + 7.82579040744090311069E-9, +}; +static double GD4[] = { +/* 1.00000000000000000000E0,*/ + 1.64402202413355338886E0, + 6.66296701268987968381E-1, + 9.88771761277688796203E-2, + 6.22396345441768420760E-3, + 1.73221081474177119497E-4, + 2.02659182086343991969E-6, + 7.82579218933534490868E-9, +}; +#endif +#ifdef DEC +static unsigned short GN4[] = { +0037262,0060622,0164572,0157515, +0040034,0101527,0061263,0147204, +0037713,0055467,0037475,0144512, +0037231,0046151,0035234,0045261, +0036260,0111624,0150617,0053536, +0035051,0157175,0016675,0155456, +0033404,0154757,0041211,0000055, +0031406,0071060,0130322,0033322, +}; +static unsigned short GD4[] = { +/* 0040200,0000000,0000000,0000000,*/ +0040322,0067520,0046707,0053275, +0040052,0111153,0126542,0005516, +0037312,0100035,0167121,0014552, +0036313,0171143,0137176,0014213, +0035065,0121256,0012033,0150603, +0033410,0000225,0013121,0071643, +0031406,0071062,0131152,0150454, +}; +#endif +#ifdef IBMPC +static unsigned short GN4[] = { +0x5bea,0x5d2f,0x4c32,0x3fb6, +0x79d1,0xec56,0x906a,0x3fe3, +0xb929,0xe7e7,0x6b66,0x3fd9, +0x8956,0x2753,0x298d,0x3fb3, +0xeaec,0x9a31,0x1272,0x3f76, +0xbb66,0xa3b7,0x3bcf,0x3f25, +0x2006,0xe851,0x9b3d,0x3ec0, +0x46da,0x161a,0xce46,0x3e40, +}; +static unsigned short GD4[] = { +/* 0x0000,0x0000,0x0000,0x3ff0,*/ +0xead8,0x09b8,0x4dea,0x3ffa, +0x416a,0x75ac,0x524d,0x3fe5, +0x232d,0xbdca,0x5003,0x3fb9, +0xc311,0x77cf,0x7e4c,0x3f79, +0x7a30,0xc283,0xb455,0x3f26, +0x2e74,0xa2ca,0x0012,0x3ec1, +0x5a26,0x564d,0xce46,0x3e40, +}; +#endif +#ifdef MIEEE +static unsigned short GN4[] = { +0x3fb6,0x4c32,0x5d2f,0x5bea, +0x3fe3,0x906a,0xec56,0x79d1, +0x3fd9,0x6b66,0xe7e7,0xb929, +0x3fb3,0x298d,0x2753,0x8956, +0x3f76,0x1272,0x9a31,0xeaec, +0x3f25,0x3bcf,0xa3b7,0xbb66, +0x3ec0,0x9b3d,0xe851,0x2006, +0x3e40,0xce46,0x161a,0x46da, +}; +static unsigned short GD4[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3ffa,0x4dea,0x09b8,0xead8, +0x3fe5,0x524d,0x75ac,0x416a, +0x3fb9,0x5003,0xbdca,0x232d, +0x3f79,0x7e4c,0x77cf,0xc311, +0x3f26,0xb455,0xc283,0x7a30, +0x3ec1,0x0012,0xa2ca,0x2e74, +0x3e40,0xce46,0x564d,0x5a26, +}; +#endif + +#ifdef UNK +static double GN8[] = { + 6.97359953443276214934E-1, + 3.30410979305632063225E-1, + 3.84878767649974295920E-2, + 1.71718239052347903558E-3, + 3.48941165502279436777E-5, + 3.47131167084116673800E-7, + 1.70404452782044526189E-9, + 3.85945925430276600453E-12, + 3.14040098946363334640E-15, +}; +static double GD8[] = { +/* 1.00000000000000000000E0,*/ + 1.68548898811011640017E0, + 4.87852258695304967486E-1, + 4.67913194259625806320E-2, + 1.90284426674399523638E-3, + 3.68475504442561108162E-5, + 3.57043223443740838771E-7, + 1.72693748966316146736E-9, + 3.87830166023954706752E-12, + 3.14040098946363335242E-15, +}; +#endif +#ifdef DEC +static unsigned short GN8[] = { +0040062,0103056,0110624,0033123, +0037651,0025640,0136266,0145647, +0037035,0122566,0137770,0061777, +0035741,0011424,0065311,0013370, +0034422,0055505,0134324,0016755, +0032672,0056530,0022565,0014747, +0030752,0031674,0114735,0013162, +0026607,0145353,0022020,0123625, +0024142,0045054,0060033,0016505, +}; +static unsigned short GD8[] = { +/*0040200,0000000,0000000,0000000,*/ +0040327,0137032,0064331,0136425, +0037771,0143705,0070300,0105711, +0037077,0124101,0025275,0035356, +0035771,0064333,0145103,0105357, +0034432,0106301,0105311,0010713, +0032677,0127645,0120034,0157551, +0030755,0054466,0010743,0105566, +0026610,0072242,0142530,0135744, +0024142,0045054,0060033,0016505, +}; +#endif +#ifdef IBMPC +static unsigned short GN8[] = { +0x86ca,0xd232,0x50c5,0x3fe6, +0xd975,0x1796,0x2574,0x3fd5, +0x0c80,0xd7ff,0xb4ae,0x3fa3, +0x22df,0x8d59,0x2262,0x3f5c, +0x83be,0xb71a,0x4b68,0x3f02, +0xa33d,0x04ae,0x4bab,0x3e97, +0xa2ce,0x933b,0x4677,0x3e1d, +0x14f3,0x6482,0xf95d,0x3d90, +0x63a9,0x8c03,0x4945,0x3cec, +}; +static unsigned short GD8[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x37a3,0x4d1b,0xf7c3,0x3ffa, +0x1179,0xae18,0x38f8,0x3fdf, +0xa75e,0x2557,0xf508,0x3fa7, +0x715e,0x7948,0x2d1b,0x3f5f, +0x2239,0x3159,0x5198,0x3f03, +0x9bed,0xb403,0xf5f4,0x3e97, +0x716f,0xc23c,0xab26,0x3e1d, +0x177c,0x58ab,0x0e94,0x3d91, +0x63a9,0x8c03,0x4945,0x3cec, +}; +#endif +#ifdef MIEEE +static unsigned short GN8[] = { +0x3fe6,0x50c5,0xd232,0x86ca, +0x3fd5,0x2574,0x1796,0xd975, +0x3fa3,0xb4ae,0xd7ff,0x0c80, +0x3f5c,0x2262,0x8d59,0x22df, +0x3f02,0x4b68,0xb71a,0x83be, +0x3e97,0x4bab,0x04ae,0xa33d, +0x3e1d,0x4677,0x933b,0xa2ce, +0x3d90,0xf95d,0x6482,0x14f3, +0x3cec,0x4945,0x8c03,0x63a9, +}; +static unsigned short GD8[] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x3ffa,0xf7c3,0x4d1b,0x37a3, +0x3fdf,0x38f8,0xae18,0x1179, +0x3fa7,0xf508,0x2557,0xa75e, +0x3f5f,0x2d1b,0x7948,0x715e, +0x3f03,0x5198,0x3159,0x2239, +0x3e97,0xf5f4,0xb403,0x9bed, +0x3e1d,0xab26,0xc23c,0x716f, +0x3d91,0x0e94,0x58ab,0x177c, +0x3cec,0x4945,0x8c03,0x63a9, +}; +#endif + +#ifdef ANSIPROT +extern double log ( double ); +extern double sin ( double ); +extern double cos ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +double log(), sin(), cos(), polevl(), p1evl(); +#endif +#define EUL 0.57721566490153286061 +extern double MAXNUM, PIO2, MACHEP; + + +int sici( x, si, ci ) +double x; +double *si, *ci; +{ +double z, c, s, f, g; +short sign; + +if( x < 0.0 ) + { + sign = -1; + x = -x; + } +else + sign = 0; + + +if( x == 0.0 ) + { + *si = 0.0; + *ci = -MAXNUM; + return( 0 ); + } + + +if( x > 1.0e9 ) + { + *si = PIO2 - cos(x)/x; + *ci = sin(x)/x; + return( 0 ); + } + + + +if( x > 4.0 ) + goto asympt; + +z = x * x; +s = x * polevl( z, SN, 5 ) / polevl( z, SD, 5 ); +c = z * polevl( z, CN, 5 ) / polevl( z, CD, 5 ); + +if( sign ) + s = -s; +*si = s; +*ci = EUL + log(x) + c; /* real part if x < 0 */ +return(0); + + + +/* The auxiliary functions are: + * + * + * *si = *si - PIO2; + * c = cos(x); + * s = sin(x); + * + * t = *ci * s - *si * c; + * a = *ci * c + *si * s; + * + * *si = t; + * *ci = -a; + */ + + +asympt: + +s = sin(x); +c = cos(x); +z = 1.0/(x*x); +if( x < 8.0 ) + { + f = polevl( z, FN4, 6 ) / (x * p1evl( z, FD4, 7 )); + g = z * polevl( z, GN4, 7 ) / p1evl( z, GD4, 7 ); + } +else + { + f = polevl( z, FN8, 8 ) / (x * p1evl( z, FD8, 8 )); + g = z * polevl( z, GN8, 8 ) / p1evl( z, GD8, 9 ); + } +*si = PIO2 - f * c - g * s; +if( sign ) + *si = -( *si ); +*ci = f * s - g * c; + +return(0); +} diff --git a/libm/double/simpsn.c b/libm/double/simpsn.c new file mode 100644 index 000000000..4eb19460b --- /dev/null +++ b/libm/double/simpsn.c @@ -0,0 +1,81 @@ +/* simpsn.c */ +/* simpsn.c + * Numerical integration of function tabulated + * at equally spaced arguments + */ + +/* Coefficients for Cote integration formulas */ + +/* Note: these numbers were computed using 40-decimal precision. */ + +#define NCOTE 8 + +/* 6th order formula */ +/* +static double simcon[] = +{ + 4.88095238095238095E-2, + 2.57142857142857142857E-1, + 3.2142857142857142857E-2, + 3.2380952380952380952E-1, +}; +*/ + +/* 8th order formula */ +static double simcon[] = +{ + 3.488536155202821869E-2, + 2.076895943562610229E-1, + -3.27336860670194003527E-2, + 3.7022927689594356261E-1, + -1.6014109347442680776E-1, +}; + +/* 10th order formula */ +/* +static double simcon[] = +{ + 2.68341483619261397039E-2, + 1.77535941424830313719E-1, + -8.1043570626903960237E-2, + 4.5494628827962161295E-1, + -4.3515512265512265512E-1, + 7.1376463043129709796E-1, +}; +*/ + +/* simpsn.c 2 */ +/* 20th order formula */ +/* +static double simcon[] = +{ + 1.182527324903160319E-2, + 1.14137717644606974987E-1, + -2.36478370511426964E-1, + 1.20618689348187566E+0, + -3.7710317267153304677E+0, + 1.03367982199398011435E+1, + -2.270881584397951229796E+1, + 4.1828057422193554603E+1, + -6.4075279490154004651555E+1, + 8.279728347247285172085E+1, + -9.0005367135242894657916E+1, +}; +*/ + +/* simpsn.c 3 */ +double simpsn( f, delta ) +double f[]; /* tabulated function */ +double delta; /* spacing of arguments */ +{ +extern double simcon[]; +double ans; +int i; + + +ans = simcon[NCOTE/2] * f[NCOTE/2]; +for( i=0; i < NCOTE/2; i++ ) + ans += simcon[i] * ( f[i] + f[NCOTE-i] ); + +return( ans * delta * NCOTE ); +} diff --git a/libm/double/simq.c b/libm/double/simq.c new file mode 100644 index 000000000..96d63e521 --- /dev/null +++ b/libm/double/simq.c @@ -0,0 +1,180 @@ +/* simq.c + * + * Solution of simultaneous linear equations AX = B + * by Gaussian elimination with partial pivoting + * + * + * + * SYNOPSIS: + * + * double A[n*n], B[n], X[n]; + * int n, flag; + * int IPS[]; + * int simq(); + * + * ercode = simq( A, B, X, n, flag, IPS ); + * + * + * + * DESCRIPTION: + * + * B, X, IPS are vectors of length n. + * A is an n x n matrix (i.e., a vector of length n*n), + * stored row-wise: that is, A(i,j) = A[ij], + * where ij = i*n + j, which is the transpose of the normal + * column-wise storage. + * + * The contents of matrix A are destroyed. + * + * Set flag=0 to solve. + * Set flag=-1 to do a new back substitution for different B vector + * using the same A matrix previously reduced when flag=0. + * + * The routine returns nonzero on error; messages are printed. + * + * + * ACCURACY: + * + * Depends on the conditioning (range of eigenvalues) of matrix A. + * + * + * REFERENCE: + * + * Computer Solution of Linear Algebraic Systems, + * by George E. Forsythe and Cleve B. Moler; Prentice-Hall, 1967. + * + */ + +/* simq 2 */ + +#include <stdio.h> +#define fabs(x) ((x) < 0 ? -(x) : (x)) + +int simq( A, B, X, n, flag, IPS ) +double A[], B[], X[]; +int n, flag; +int IPS[]; +{ +int i, j, ij, ip, ipj, ipk, ipn; +int idxpiv, iback; +int k, kp, kp1, kpk, kpn; +int nip, nkp, nm1; +double em, q, rownrm, big, size, pivot, sum; + +nm1 = n-1; +if( flag < 0 ) + goto solve; + +/* Initialize IPS and X */ + +ij=0; +for( i=0; i<n; i++ ) + { + IPS[i] = i; + rownrm = 0.0; + for( j=0; j<n; j++ ) + { + q = fabs( A[ij] ); + if( rownrm < q ) + rownrm = q; + ++ij; + } + if( rownrm == 0.0 ) + { + printf("SIMQ ROWNRM=0"); + return(1); + } + X[i] = 1.0/rownrm; + } + +/* simq 3 */ +/* Gaussian elimination with partial pivoting */ + +for( k=0; k<nm1; k++ ) + { + big= 0.0; + idxpiv = 0; + for( i=k; i<n; i++ ) + { + ip = IPS[i]; + ipk = n*ip + k; + size = fabs( A[ipk] ) * X[ip]; + if( size > big ) + { + big = size; + idxpiv = i; + } + } + + if( big == 0.0 ) + { + printf( "SIMQ BIG=0" ); + return(2); + } + if( idxpiv != k ) + { + j = IPS[k]; + IPS[k] = IPS[idxpiv]; + IPS[idxpiv] = j; + } + kp = IPS[k]; + kpk = n*kp + k; + pivot = A[kpk]; + kp1 = k+1; + for( i=kp1; i<n; i++ ) + { + ip = IPS[i]; + ipk = n*ip + k; + em = -A[ipk]/pivot; + A[ipk] = -em; + nip = n*ip; + nkp = n*kp; + for( j=kp1; j<n; j++ ) + { + ipj = nip + j; + A[ipj] = A[ipj] + em * A[nkp + j]; + } + } + } +kpn = n * IPS[n-1] + n - 1; /* last element of IPS[n] th row */ +if( A[kpn] == 0.0 ) + { + printf( "SIMQ A[kpn]=0"); + return(3); + } + +/* simq 4 */ +/* back substitution */ + +solve: +ip = IPS[0]; +X[0] = B[ip]; +for( i=1; i<n; i++ ) + { + ip = IPS[i]; + ipj = n * ip; + sum = 0.0; + for( j=0; j<i; j++ ) + { + sum += A[ipj] * X[j]; + ++ipj; + } + X[i] = B[ip] - sum; + } + +ipn = n * IPS[n-1] + n - 1; +X[n-1] = X[n-1]/A[ipn]; + +for( iback=1; iback<n; iback++ ) + { +/* i goes (n-1),...,1 */ + i = nm1 - iback; + ip = IPS[i]; + nip = n*ip; + sum = 0.0; + for( j=i+1; j<n; j++ ) + sum += A[nip+j] * X[j]; + X[i] = (X[i] - sum)/A[nip+i]; + } +return(0); +} diff --git a/libm/double/sin.c b/libm/double/sin.c new file mode 100644 index 000000000..24746d79d --- /dev/null +++ b/libm/double/sin.c @@ -0,0 +1,387 @@ +/* sin.c + * + * Circular sine + * + * + * + * SYNOPSIS: + * + * double x, y, sin(); + * + * y = sin( 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 + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 10 150000 3.0e-17 7.8e-18 + * IEEE -1.07e9,+1.07e9 130000 2.1e-16 5.4e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 1.073741824e9 0.0 + * + * Partial loss of accuracy begins to occur at x = 2**30 + * = 1.074e9. The loss is not gradual, but jumps suddenly to + * about 1 part in 10e7. Results may be meaningless for + * x > 2**49 = 5.6e14. The routine as implemented flags a + * TLOSS error for x > 2**30 and returns 0.0. + */ + /* cos.c + * + * Circular cosine + * + * + * + * SYNOPSIS: + * + * double x, y, cos(); + * + * y = cos( 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 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1.07e9,+1.07e9 130000 2.1e-16 5.4e-17 + * DEC 0,+1.07e9 17000 3.0e-17 7.2e-18 + */ + +/* sin.c */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double sincof[] = { + 1.58962301576546568060E-10, +-2.50507477628578072866E-8, + 2.75573136213857245213E-6, +-1.98412698295895385996E-4, + 8.33333333332211858878E-3, +-1.66666666666666307295E-1, +}; +static double coscof[6] = { +-1.13585365213876817300E-11, + 2.08757008419747316778E-9, +-2.75573141792967388112E-7, + 2.48015872888517045348E-5, +-1.38888888888730564116E-3, + 4.16666666666665929218E-2, +}; +static double DP1 = 7.85398125648498535156E-1; +static double DP2 = 3.77489470793079817668E-8; +static double DP3 = 2.69515142907905952645E-15; +/* static double lossth = 1.073741824e9; */ +#endif + +#ifdef DEC +static unsigned short sincof[] = { +0030056,0143750,0177214,0163153, +0131727,0027455,0044510,0175352, +0033470,0167432,0131752,0042414, +0135120,0006400,0146776,0174027, +0036410,0104210,0104207,0137202, +0137452,0125252,0125252,0125103, +}; +static unsigned short coscof[24] = { +0127107,0151115,0002060,0152325, +0031017,0072353,0155161,0174053, +0132623,0171173,0172542,0057056, +0034320,0006400,0147102,0023652, +0135666,0005540,0133012,0076213, +0037052,0125252,0125252,0125126, +}; +/* 7.853981629014015197753906250000E-1 */ +static unsigned short P1[] = {0040111,0007732,0120000,0000000,}; +/* 4.960467869796758577649598009884E-10 */ +static unsigned short P2[] = {0030410,0055060,0100000,0000000,}; +/* 2.860594363054915898381331279295E-18 */ +static unsigned short P3[] = {0021523,0011431,0105056,0001560,}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +#ifdef IBMPC +static unsigned short sincof[] = { +0x9ccd,0x1fd1,0xd8fd,0x3de5, +0x1f5d,0xa929,0xe5e5,0xbe5a, +0x48a1,0x567d,0x1de3,0x3ec7, +0xdf03,0x19bf,0x01a0,0xbf2a, +0xf7d0,0x1110,0x1111,0x3f81, +0x5548,0x5555,0x5555,0xbfc5, +}; +static unsigned short coscof[24] = { +0x1a9b,0xa086,0xfa49,0xbda8, +0x3f05,0x7b4e,0xee9d,0x3e21, +0x4bc6,0x7eac,0x7e4f,0xbe92, +0x44f5,0x19c8,0x01a0,0x3efa, +0x4f91,0x16c1,0xc16c,0xbf56, +0x554b,0x5555,0x5555,0x3fa5, +}; +/* + 7.85398125648498535156E-1, + 3.77489470793079817668E-8, + 2.69515142907905952645E-15, +*/ +static unsigned short P1[] = {0x0000,0x4000,0x21fb,0x3fe9}; +static unsigned short P2[] = {0x0000,0x0000,0x442d,0x3e64}; +static unsigned short P3[] = {0x5170,0x98cc,0x4698,0x3ce8}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +#ifdef MIEEE +static unsigned short sincof[] = { +0x3de5,0xd8fd,0x1fd1,0x9ccd, +0xbe5a,0xe5e5,0xa929,0x1f5d, +0x3ec7,0x1de3,0x567d,0x48a1, +0xbf2a,0x01a0,0x19bf,0xdf03, +0x3f81,0x1111,0x1110,0xf7d0, +0xbfc5,0x5555,0x5555,0x5548, +}; +static unsigned short coscof[24] = { +0xbda8,0xfa49,0xa086,0x1a9b, +0x3e21,0xee9d,0x7b4e,0x3f05, +0xbe92,0x7e4f,0x7eac,0x4bc6, +0x3efa,0x01a0,0x19c8,0x44f5, +0xbf56,0xc16c,0x16c1,0x4f91, +0x3fa5,0x5555,0x5555,0x554b, +}; +static unsigned short P1[] = {0x3fe9,0x21fb,0x4000,0x0000}; +static unsigned short P2[] = {0x3e64,0x442d,0x0000,0x0000}; +static unsigned short P3[] = {0x3ce8,0x4698,0x98cc,0x5170}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +#else +double polevl(), floor(), ldexp(); +int isnan(), isfinite(); +#endif +extern double PIO4; +static double lossth = 1.073741824e9; +#ifdef NANS +extern double NAN; +#endif +#ifdef INFINITIES +extern double INFINITY; +#endif + + +double sin(x) +double x; +{ +double y, z, zz; +int j, sign; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +#ifdef NANS +if( isnan(x) ) + return(x); +if( !isfinite(x) ) + { + mtherr( "sin", DOMAIN ); + return(NAN); + } +#endif +/* make argument positive but save the sign */ +sign = 1; +if( x < 0 ) + { + x = -x; + sign = -1; + } + +if( x > lossth ) + { + mtherr( "sin", TLOSS ); + return(0.0); + } + +y = floor( x/PIO4 ); /* integer part of x/PIO4 */ + +/* strip high bits of integer part to prevent integer overflow */ +z = ldexp( y, -4 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( 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.0; + } +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.0 - ldexp(zz,-1) + zz * zz * polevl( zz, coscof, 5 ); + } +else + { +/* y = z + z * (zz * polevl( zz, sincof, 5 ));*/ + y = z + z * z * z * polevl( zz, sincof, 5 ); + } + +if(sign < 0) + y = -y; + +return(y); +} + + + + + +double cos(x) +double x; +{ +double y, z, zz; +long i; +int j, sign; + +#ifdef NANS +if( isnan(x) ) + return(x); +if( !isfinite(x) ) + { + mtherr( "cos", DOMAIN ); + return(NAN); + } +#endif + +/* make argument positive */ +sign = 1; +if( x < 0 ) + x = -x; + +if( x > lossth ) + { + mtherr( "cos", TLOSS ); + return(0.0); + } + +y = floor( x/PIO4 ); +z = ldexp( y, -4 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( 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.0; + } +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 * polevl( zz, sincof, 5 ));*/ + y = z + z * z * z * polevl( zz, sincof, 5 ); + } +else + { + y = 1.0 - ldexp(zz,-1) + zz * zz * polevl( zz, coscof, 5 ); + } + +if(sign < 0) + y = -y; + +return(y); +} + + + + + +/* Degrees, minutes, seconds to radians: */ + +/* 1 arc second, in radians = 4.8481368110953599358991410e-5 */ +#ifdef DEC +static unsigned short P648[] = {034513,054170,0176773,0116043,}; +#define P64800 *(double *)P648 +#else +static double P64800 = 4.8481368110953599358991410e-5; +#endif + +double radian(d,m,s) +double d,m,s; +{ + +return( ((d*60.0 + m)*60.0 + s)*P64800 ); +} diff --git a/libm/double/sincos.c b/libm/double/sincos.c new file mode 100644 index 000000000..8a4a3784c --- /dev/null +++ b/libm/double/sincos.c @@ -0,0 +1,364 @@ +/* sincos.c + * + * Circular sine and cosine of argument in degrees + * Table lookup and interpolation algorithm + * + * + * + * SYNOPSIS: + * + * double x, sine, cosine, flg, sincos(); + * + * sincos( x, &sine, &cosine, flg ); + * + * + * + * DESCRIPTION: + * + * Returns both the sine and the cosine of the argument x. + * Several different compile time options and minimax + * approximations are supplied to permit tailoring the + * tradeoff between computation speed and accuracy. + * + * Since range reduction is time consuming, the reduction + * of x modulo 360 degrees is also made optional. + * + * sin(i) is internally tabulated for 0 <= i <= 90 degrees. + * Approximation polynomials, ranging from linear interpolation + * to cubics in (x-i)**2, compute the sine and cosine + * of the residual x-i which is between -0.5 and +0.5 degree. + * In the case of the high accuracy options, the residual + * and the tabulated values are combined using the trigonometry + * formulas for sin(A+B) and cos(A+B). + * + * Compile time options are supplied for 5, 11, or 17 decimal + * relative accuracy (ACC5, ACC11, ACC17 respectively). + * A subroutine flag argument "flg" chooses betwen this + * accuracy and table lookup only (peak absolute error + * = 0.0087). + * + * If the argument flg = 1, then the tabulated value is + * returned for the nearest whole number of degrees. The + * approximation polynomials are not computed. At + * x = 0.5 deg, the absolute error is then sin(0.5) = 0.0087. + * + * An intermediate speed and precision can be obtained using + * the compile time option LINTERP and flg = 1. This yields + * a linear interpolation using a slope estimated from the sine + * or cosine at the nearest integer argument. The peak absolute + * error with this option is 3.8e-5. Relative error at small + * angles is about 1e-5. + * + * If flg = 0, then the approximation polynomials are computed + * and applied. + * + * + * + * SPEED: + * + * Relative speed comparisons follow for 6MHz IBM AT clone + * and Microsoft C version 4.0. These figures include + * software overhead of do loop and function calls. + * Since system hardware and software vary widely, the + * numbers should be taken as representative only. + * + * flg=0 flg=0 flg=1 flg=1 + * ACC11 ACC5 LINTERP Lookup only + * In-line 8087 (/FPi) + * sin(), cos() 1.0 1.0 1.0 1.0 + * + * In-line 8087 (/FPi) + * sincos() 1.1 1.4 1.9 3.0 + * + * Software (/FPa) + * sin(), cos() 0.19 0.19 0.19 0.19 + * + * Software (/FPa) + * sincos() 0.39 0.50 0.73 1.7 + * + * + * + * ACCURACY: + * + * The accurate approximations are designed with a relative error + * criterion. The absolute error is greatest at x = 0.5 degree. + * It decreases from a local maximum at i+0.5 degrees to full + * machine precision at each integer i degrees. With the + * ACC5 option, the relative error of 6.3e-6 is equivalent to + * an absolute angular error of 0.01 arc second in the argument + * at x = i+0.5 degrees. For small angles < 0.5 deg, the ACC5 + * accuracy is 6.3e-6 (.00063%) of reading; i.e., the absolute + * error decreases in proportion to the argument. This is true + * for both the sine and cosine approximations, since the latter + * is for the function 1 - cos(x). + * + * If absolute error is of most concern, use the compile time + * option ABSERR to obtain an absolute error of 2.7e-8 for ACC5 + * precision. This is about half the absolute error of the + * relative precision option. In this case the relative error + * for small angles will increase to 9.5e-6 -- a reasonable + * tradeoff. + */ + + +#include <math.h> + +/* Define one of the following to be 1: + */ +#define ACC5 1 +#define ACC11 0 +#define ACC17 0 + +/* Option for linear interpolation when flg = 1 + */ +#define LINTERP 1 + +/* Option for absolute error criterion + */ +#define ABSERR 1 + +/* Option to include modulo 360 function: + */ +#define MOD360 0 + +/* +Cephes Math Library Release 2.1 +Copyright 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +/* Table of sin(i degrees) + * for 0 <= i <= 90 + */ +static double sintbl[92] = { + 0.00000000000000000000E0, + 1.74524064372835128194E-2, + 3.48994967025009716460E-2, + 5.23359562429438327221E-2, + 6.97564737441253007760E-2, + 8.71557427476581735581E-2, + 1.04528463267653471400E-1, + 1.21869343405147481113E-1, + 1.39173100960065444112E-1, + 1.56434465040230869010E-1, + 1.73648177666930348852E-1, + 1.90808995376544812405E-1, + 2.07911690817759337102E-1, + 2.24951054343864998051E-1, + 2.41921895599667722560E-1, + 2.58819045102520762349E-1, + 2.75637355816999185650E-1, + 2.92371704722736728097E-1, + 3.09016994374947424102E-1, + 3.25568154457156668714E-1, + 3.42020143325668733044E-1, + 3.58367949545300273484E-1, + 3.74606593415912035415E-1, + 3.90731128489273755062E-1, + 4.06736643075800207754E-1, + 4.22618261740699436187E-1, + 4.38371146789077417453E-1, + 4.53990499739546791560E-1, + 4.69471562785890775959E-1, + 4.84809620246337029075E-1, + 5.00000000000000000000E-1, + 5.15038074910054210082E-1, + 5.29919264233204954047E-1, + 5.44639035015027082224E-1, + 5.59192903470746830160E-1, + 5.73576436351046096108E-1, + 5.87785252292473129169E-1, + 6.01815023152048279918E-1, + 6.15661475325658279669E-1, + 6.29320391049837452706E-1, + 6.42787609686539326323E-1, + 6.56059028990507284782E-1, + 6.69130606358858213826E-1, + 6.81998360062498500442E-1, + 6.94658370458997286656E-1, + 7.07106781186547524401E-1, + 7.19339800338651139356E-1, + 7.31353701619170483288E-1, + 7.43144825477394235015E-1, + 7.54709580222771997943E-1, + 7.66044443118978035202E-1, + 7.77145961456970879980E-1, + 7.88010753606721956694E-1, + 7.98635510047292846284E-1, + 8.09016994374947424102E-1, + 8.19152044288991789684E-1, + 8.29037572555041692006E-1, + 8.38670567945424029638E-1, + 8.48048096156425970386E-1, + 8.57167300702112287465E-1, + 8.66025403784438646764E-1, + 8.74619707139395800285E-1, + 8.82947592858926942032E-1, + 8.91006524188367862360E-1, + 8.98794046299166992782E-1, + 9.06307787036649963243E-1, + 9.13545457642600895502E-1, + 9.20504853452440327397E-1, + 9.27183854566787400806E-1, + 9.33580426497201748990E-1, + 9.39692620785908384054E-1, + 9.45518575599316810348E-1, + 9.51056516295153572116E-1, + 9.56304755963035481339E-1, + 9.61261695938318861916E-1, + 9.65925826289068286750E-1, + 9.70295726275996472306E-1, + 9.74370064785235228540E-1, + 9.78147600733805637929E-1, + 9.81627183447663953497E-1, + 9.84807753012208059367E-1, + 9.87688340595137726190E-1, + 9.90268068741570315084E-1, + 9.92546151641322034980E-1, + 9.94521895368273336923E-1, + 9.96194698091745532295E-1, + 9.97564050259824247613E-1, + 9.98629534754573873784E-1, + 9.99390827019095730006E-1, + 9.99847695156391239157E-1, + 1.00000000000000000000E0, + 9.99847695156391239157E-1, +}; + +#ifdef ANSIPROT +double floor ( double ); +#else +double floor(); +#endif + +int sincos(x, s, c, flg) +double x; +double *s, *c; +int flg; +{ +int ix, ssign, csign, xsign; +double y, z, sx, sz, cx, cz; + +/* Make argument nonnegative. + */ +xsign = 1; +if( x < 0.0 ) + { + xsign = -1; + x = -x; + } + + +#if MOD360 +x = x - 360.0 * floor( x/360.0 ); +#endif + +/* Find nearest integer to x. + * Note there should be a domain error test here, + * but this is omitted to gain speed. + */ +ix = x + 0.5; +z = x - ix; /* the residual */ + +/* Look up the sine and cosine of the integer. + */ +if( ix <= 180 ) + { + ssign = 1; + csign = 1; + } +else + { + ssign = -1; + csign = -1; + ix -= 180; + } + +if( ix > 90 ) + { + csign = -csign; + ix = 180 - ix; + } + +sx = sintbl[ix]; +if( ssign < 0 ) + sx = -sx; +cx = sintbl[ 90-ix ]; +if( csign < 0 ) + cx = -cx; + +/* If the flag argument is set, then just return + * the tabulated values for arg to the nearest whole degree. + */ +if( flg ) + { +#if LINTERP + y = sx + 1.74531263774940077459e-2 * z * cx; + cx -= 1.74531263774940077459e-2 * z * sx; + sx = y; +#endif + if( xsign < 0 ) + sx = -sx; + *s = sx; /* sine */ + *c = cx; /* cosine */ + return 0; + } + + +if( ssign < 0 ) + sx = -sx; +if( csign < 0 ) + cx = -cx; + +/* Find sine and cosine + * of the residual angle between -0.5 and +0.5 degree. + */ +#if ACC5 +#if ABSERR +/* absolute error = 2.769e-8: */ +sz = 1.74531263774940077459e-2 * z; +/* absolute error = 4.146e-11: */ +cz = 1.0 - 1.52307909153324666207e-4 * z * z; +#else +/* relative error = 6.346e-6: */ +sz = 1.74531817576426662296e-2 * z; +/* relative error = 3.173e-6: */ +cz = 1.0 - 1.52308226602566149927e-4 * z * z; +#endif +#else +y = z * z; +#endif + + +#if ACC11 +sz = ( -8.86092781698004819918e-7 * y + + 1.74532925198378577601e-2 ) * z; + +cz = 1.0 - ( -3.86631403698859047896e-9 * y + + 1.52308709893047593702e-4 ) * y; +#endif + + +#if ACC17 +sz = (( 1.34959795251974073996e-11 * y + - 8.86096155697856783296e-7 ) * y + + 1.74532925199432957214e-2 ) * z; + +cz = 1.0 - (( 3.92582397764340914444e-14 * y + - 3.86632385155548605680e-9 ) * y + + 1.52308709893354299569e-4 ) * y; +#endif + + +/* Combine the tabulated part and the calculated part + * by trigonometry. + */ +y = sx * cz + cx * sz; +if( xsign < 0 ) + y = - y; +*s = y; /* sine */ + +*c = cx * cz - sx * sz; /* cosine */ +return 0; +} diff --git a/libm/double/sindg.c b/libm/double/sindg.c new file mode 100644 index 000000000..8057ab68d --- /dev/null +++ b/libm/double/sindg.c @@ -0,0 +1,308 @@ +/* sindg.c + * + * Circular sine of angle in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, sindg(); + * + * y = sindg( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 P(x**2). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +-1000 3100 3.3e-17 9.0e-18 + * IEEE +-1000 30000 2.3e-16 5.6e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * sindg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * + */ + /* cosdg.c + * + * Circular cosine of angle in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, cosdg(); + * + * y = cosdg( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - x**2 P(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC +-1000 3400 3.5e-17 9.1e-18 + * IEEE +-1000 30000 2.1e-16 5.7e-17 + * See also sin(). + * + */ + +/* Cephes Math Library Release 2.0: April, 1987 + * Copyright 1985, 1987 by Stephen L. Moshier + * Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ + +#include <math.h> + +#ifdef UNK +static double sincof[] = { + 1.58962301572218447952E-10, +-2.50507477628503540135E-8, + 2.75573136213856773549E-6, +-1.98412698295895384658E-4, + 8.33333333332211858862E-3, +-1.66666666666666307295E-1 +}; +static double coscof[] = { + 1.13678171382044553091E-11, +-2.08758833757683644217E-9, + 2.75573155429816611547E-7, +-2.48015872936186303776E-5, + 1.38888888888806666760E-3, +-4.16666666666666348141E-2, + 4.99999999999999999798E-1 +}; +static double PI180 = 1.74532925199432957692E-2; /* pi/180 */ +static double lossth = 1.0e14; +#endif + +#ifdef DEC +static unsigned short sincof[] = { +0030056,0143750,0177170,0073013, +0131727,0027455,0044510,0132205, +0033470,0167432,0131752,0042263, +0135120,0006400,0146776,0174027, +0036410,0104210,0104207,0137202, +0137452,0125252,0125252,0125103 +}; +static unsigned short coscof[] = { +0027107,0176030,0153315,0110312, +0131017,0072476,0007450,0123243, +0032623,0171174,0070066,0146445, +0134320,0006400,0147355,0163313, +0035666,0005540,0133012,0165067, +0137052,0125252,0125252,0125206, +0040000,0000000,0000000,0000000 +}; +static unsigned short P1[] = {0036616,0175065,0011224,0164711}; +#define PI180 *(double *)P1 +static double lossth = 8.0e14; +#endif + +#ifdef IBMPC +static unsigned short sincof[] = { +0x0ec1,0x1fcf,0xd8fd,0x3de5, +0x1691,0xa929,0xe5e5,0xbe5a, +0x4896,0x567d,0x1de3,0x3ec7, +0xdf03,0x19bf,0x01a0,0xbf2a, +0xf7d0,0x1110,0x1111,0x3f81, +0x5548,0x5555,0x5555,0xbfc5 +}; +static unsigned short coscof[] = { +0xb219,0x1ad9,0xff83,0x3da8, +0x14d4,0xc1e5,0xeea7,0xbe21, +0xd9a5,0x8e06,0x7e4f,0x3e92, +0xbcd9,0x19dd,0x01a0,0xbefa, +0x5d47,0x16c1,0xc16c,0x3f56, +0x5551,0x5555,0x5555,0xbfa5, +0x0000,0x0000,0x0000,0x3fe0 +}; + +static unsigned short P1[] = {0x9d39,0xa252,0xdf46,0x3f91}; +#define PI180 *(double *)P1 +static double lossth = 1.0e14; +#endif + +#ifdef MIEEE +static unsigned short sincof[] = { +0x3de5,0xd8fd,0x1fcf,0x0ec1, +0xbe5a,0xe5e5,0xa929,0x1691, +0x3ec7,0x1de3,0x567d,0x4896, +0xbf2a,0x01a0,0x19bf,0xdf03, +0x3f81,0x1111,0x1110,0xf7d0, +0xbfc5,0x5555,0x5555,0x5548 +}; +static unsigned short coscof[] = { +0x3da8,0xff83,0x1ad9,0xb219, +0xbe21,0xeea7,0xc1e5,0x14d4, +0x3e92,0x7e4f,0x8e06,0xd9a5, +0xbefa,0x01a0,0x19dd,0xbcd9, +0x3f56,0xc16c,0x16c1,0x5d47, +0xbfa5,0x5555,0x5555,0x5551, +0x3fe0,0x0000,0x0000,0x0000 +}; + +static unsigned short P1[] = { +0x3f91,0xdf46,0xa252,0x9d39 +}; +#define PI180 *(double *)P1 +static double lossth = 1.0e14; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +#else +double polevl(), floor(), ldexp(); +#endif +extern double PIO4; + +double sindg(x) +double x; +{ +double y, z, zz; +int j, sign; + +/* make argument positive but save the sign */ +sign = 1; +if( x < 0 ) + { + x = -x; + sign = -1; + } + +if( x > lossth ) + { + mtherr( "sindg", TLOSS ); + return(0.0); + } + +y = floor( x/45.0 ); /* integer part of x/PIO4 */ + +/* strip high bits of integer part to prevent integer overflow */ +z = ldexp( y, -4 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( 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.0; + } +j = j & 07; /* octant modulo 360 degrees */ +/* reflect in x axis */ +if( j > 3) + { + sign = -sign; + j -= 4; + } + +z = x - y * 45.0; /* x mod 45 degrees */ +z *= PI180; /* multiply by pi/180 to convert to radians */ +zz = z * z; + +if( (j==1) || (j==2) ) + { + y = 1.0 - zz * polevl( zz, coscof, 6 ); + } +else + { + y = z + z * (zz * polevl( zz, sincof, 5 )); + } + +if(sign < 0) + y = -y; + +return(y); +} + + + + + +double cosdg(x) +double x; +{ +double y, z, zz; +int j, sign; + +/* make argument positive */ +sign = 1; +if( x < 0 ) + x = -x; + +if( x > lossth ) + { + mtherr( "cosdg", TLOSS ); + return(0.0); + } + +y = floor( x/45.0 ); +z = ldexp( y, -4 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( z, 4 ); /* y - 16 * (y/16) */ + +/* integer and fractional part modulo one octant */ +j = z; +if( j & 1 ) /* map zeros to origin */ + { + j += 1; + y += 1.0; + } +j = j & 07; +if( j > 3) + { + j -=4; + sign = -sign; + } + +if( j > 1 ) + sign = -sign; + +z = x - y * 45.0; /* x mod 45 degrees */ +z *= PI180; /* multiply by pi/180 to convert to radians */ + +zz = z * z; + +if( (j==1) || (j==2) ) + { + y = z + z * (zz * polevl( zz, sincof, 5 )); + } +else + { + y = 1.0 - zz * polevl( zz, coscof, 6 ); + } + +if(sign < 0) + y = -y; + +return(y); +} diff --git a/libm/double/sinh.c b/libm/double/sinh.c new file mode 100644 index 000000000..545bd6826 --- /dev/null +++ b/libm/double/sinh.c @@ -0,0 +1,148 @@ +/* sinh.c + * + * Hyperbolic sine + * + * + * + * SYNOPSIS: + * + * double x, y, sinh(); + * + * y = sinh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOG to + * MAXLOG. + * + * 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 + * DEC +- 88 50000 4.0e-17 7.7e-18 + * IEEE +-MAXLOG 30000 2.6e-16 5.7e-17 + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { +-7.89474443963537015605E-1, +-1.63725857525983828727E2, +-1.15614435765005216044E4, +-3.51754964808151394800E5 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ +-2.77711081420602794433E2, + 3.61578279834431989373E4, +-2.11052978884890840399E6 +}; +#endif + +#ifdef DEC +static unsigned short P[] = { +0140112,0015377,0042731,0163255, +0142043,0134721,0146177,0123761, +0143464,0122706,0034353,0006017, +0144653,0140536,0157665,0054045 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0142212,0155404,0133513,0022040, +0044015,0036723,0173271,0011053, +0145400,0150407,0023710,0001034 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x3cd6,0xe8bb,0x435f,0xbfe9, +0xf4fe,0x398f,0x773a,0xc064, +0x6182,0xc71d,0x94b8,0xc0c6, +0xab05,0xdbf6,0x782b,0xc115 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6484,0x96e9,0x5b60,0xc071, +0x2245,0x7ed7,0xa7ba,0x40e1, +0x0044,0xe4f9,0x1a20,0xc140 +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xbfe9,0x435f,0xe8bb,0x3cd6, +0xc064,0x773a,0x398f,0xf4fe, +0xc0c6,0x94b8,0xc71d,0x6182, +0xc115,0x782b,0xdbf6,0xab05 +}; +static unsigned short Q[] = { +0xc071,0x5b60,0x96e9,0x6484, +0x40e1,0xa7ba,0x7ed7,0x2245, +0xc140,0x1a20,0xe4f9,0x0044 +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double exp ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +double fabs(), exp(), polevl(), p1evl(); +#endif +extern double INFINITY, MINLOG, MAXLOG, LOGE2; + +double sinh(x) +double x; +{ +double a; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +a = fabs(x); +if( (x > (MAXLOG + LOGE2)) || (x > -(MINLOG-LOGE2) ) ) + { + mtherr( "sinh", DOMAIN ); + if( x > 0 ) + return( INFINITY ); + else + return( -INFINITY ); + } +if( a > 1.0 ) + { + if( a >= (MAXLOG - LOGE2) ) + { + a = exp(0.5*a); + a = (0.5 * a) * a; + if( x < 0 ) + a = -a; + return(a); + } + a = exp(a); + a = 0.5*a - (0.5/a); + if( x < 0 ) + a = -a; + return(a); + } + +a *= a; +return( x + x * a * (polevl(a,P,3)/p1evl(a,Q,3)) ); +} diff --git a/libm/double/spence.c b/libm/double/spence.c new file mode 100644 index 000000000..e2a56176b --- /dev/null +++ b/libm/double/spence.c @@ -0,0 +1,205 @@ +/* spence.c + * + * Dilogarithm + * + * + * + * SYNOPSIS: + * + * double x, y, spence(); + * + * y = spence( x ); + * + * + * + * DESCRIPTION: + * + * Computes the integral + * + * x + * - + * | | log t + * spence(x) = - | ----- dt + * | | t - 1 + * - + * 1 + * + * for x >= 0. A rational approximation gives the integral in + * the interval (0.5, 1.5). Transformation formulas for 1/x + * and 1-x are employed outside the basic expansion range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,4 30000 3.9e-15 5.4e-16 + * DEC 0,4 3000 2.5e-16 4.5e-17 + * + * + */ + +/* spence.c */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1985, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double A[8] = { + 4.65128586073990045278E-5, + 7.31589045238094711071E-3, + 1.33847639578309018650E-1, + 8.79691311754530315341E-1, + 2.71149851196553469920E0, + 4.25697156008121755724E0, + 3.29771340985225106936E0, + 1.00000000000000000126E0, +}; +static double B[8] = { + 6.90990488912553276999E-4, + 2.54043763932544379113E-2, + 2.82974860602568089943E-1, + 1.41172597751831069617E0, + 3.63800533345137075418E0, + 5.03278880143316990390E0, + 3.54771340985225096217E0, + 9.99999999999999998740E-1, +}; +#endif +#ifdef DEC +static unsigned short A[32] = { +0034503,0013315,0034120,0157771, +0036357,0135043,0016766,0150637, +0037411,0007533,0005212,0161475, +0040141,0031563,0023217,0120331, +0040455,0104461,0007002,0155522, +0040610,0034434,0065721,0120465, +0040523,0006674,0105671,0054427, +0040200,0000000,0000000,0000000, +}; +static unsigned short B[32] = { +0035465,0021626,0032367,0144157, +0036720,0016326,0134431,0000406, +0037620,0161024,0133701,0120766, +0040264,0131557,0152055,0064512, +0040550,0152424,0051166,0034272, +0040641,0006233,0014672,0111572, +0040543,0006674,0105671,0054425, +0040200,0000000,0000000,0000000, +}; +#endif +#ifdef IBMPC +static unsigned short A[32] = { +0x1bff,0xa70a,0x62d9,0x3f08, +0xda34,0x63be,0xf744,0x3f7d, +0x5c68,0x6151,0x21eb,0x3fc1, +0xf41b,0x64d1,0x266e,0x3fec, +0x5b6a,0x21c0,0xb126,0x4005, +0x3427,0x8d7a,0x0723,0x4011, +0x2b23,0x9177,0x61b7,0x400a, +0x0000,0x0000,0x0000,0x3ff0, +}; +static unsigned short B[32] = { +0xf90e,0xc69e,0xa472,0x3f46, +0x2021,0xd723,0x039a,0x3f9a, +0x343f,0x96f8,0x1c42,0x3fd2, +0xad29,0xfa85,0x966d,0x3ff6, +0xc717,0x8a4e,0x1aa2,0x400d, +0x526f,0x6337,0x2193,0x4014, +0x2b23,0x9177,0x61b7,0x400c, +0x0000,0x0000,0x0000,0x3ff0, +}; +#endif +#ifdef MIEEE +static unsigned short A[32] = { +0x3f08,0x62d9,0xa70a,0x1bff, +0x3f7d,0xf744,0x63be,0xda34, +0x3fc1,0x21eb,0x6151,0x5c68, +0x3fec,0x266e,0x64d1,0xf41b, +0x4005,0xb126,0x21c0,0x5b6a, +0x4011,0x0723,0x8d7a,0x3427, +0x400a,0x61b7,0x9177,0x2b23, +0x3ff0,0x0000,0x0000,0x0000, +}; +static unsigned short B[32] = { +0x3f46,0xa472,0xc69e,0xf90e, +0x3f9a,0x039a,0xd723,0x2021, +0x3fd2,0x1c42,0x96f8,0x343f, +0x3ff6,0x966d,0xfa85,0xad29, +0x400d,0x1aa2,0x8a4e,0xc717, +0x4014,0x2193,0x6337,0x526f, +0x400c,0x61b7,0x9177,0x2b23, +0x3ff0,0x0000,0x0000,0x0000, +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double log ( double ); +extern double polevl ( double, void *, int ); +#else +double fabs(), log(), polevl(); +#endif +extern double PI, MACHEP; + +double spence(x) +double x; +{ +double w, y, z; +int flag; + +if( x < 0.0 ) + { + mtherr( "spence", DOMAIN ); + return(0.0); + } + +if( x == 1.0 ) + return( 0.0 ); + +if( x == 0.0 ) + return( PI*PI/6.0 ); + +flag = 0; + +if( x > 2.0 ) + { + x = 1.0/x; + flag |= 2; + } + +if( x > 1.5 ) + { + w = (1.0/x) - 1.0; + flag |= 2; + } + +else if( x < 0.5 ) + { + w = -x; + flag |= 1; + } + +else + w = x - 1.0; + + +y = -w * polevl( w, A, 7) / polevl( w, B, 7 ); + +if( flag & 1 ) + y = (PI * PI)/6.0 - log(x) * log(1.0-x) - y; + +if( flag & 2 ) + { + z = log(x); + y = -0.5 * z * z - y; + } + +return( y ); +} diff --git a/libm/double/sqrt.c b/libm/double/sqrt.c new file mode 100644 index 000000000..92bbce53b --- /dev/null +++ b/libm/double/sqrt.c @@ -0,0 +1,178 @@ +/* sqrt.c + * + * Square root + * + * + * + * SYNOPSIS: + * + * double x, y, sqrt(); + * + * y = sqrt( 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. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * DEC 0, 10 60000 2.1e-17 7.9e-18 + * IEEE 0,1.7e308 30000 1.7e-16 6.3e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrt domain x < 0 0.0 + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1988, 2000 by Stephen L. Moshier +*/ + + +#include <math.h> +#ifdef ANSIPROT +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +#else +double frexp(), ldexp(); +#endif +extern double SQRT2; /* SQRT2 = 1.41421356237309504880 */ + +double sqrt(x) +double x; +{ +int e; +#ifndef UNK +short *q; +#endif +double z, w; + +if( x <= 0.0 ) + { + if( x < 0.0 ) + mtherr( "sqrt", DOMAIN ); + return( 0.0 ); + } +w = x; +/* separate exponent and significand */ +#ifdef UNK +z = frexp( x, &e ); +#endif +#ifdef DEC +q = (short *)&x; +e = ((*q >> 7) & 0377) - 0200; +*q &= 0177; +*q |= 040000; +z = x; +#endif + +/* Note, frexp and ldexp are used in order to + * handle denormal numbers properly. + */ +#ifdef IBMPC +z = frexp( x, &e ); +q = (short *)&x; +q += 3; +/* +e = ((*q >> 4) & 0x0fff) - 0x3fe; +*q &= 0x000f; +*q |= 0x3fe0; +z = x; +*/ +#endif +#ifdef MIEEE +z = frexp( 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 approximation = 7.47e-3 + */ +x = 4.173075996388649989089E-1 + 5.9016206709064458299663E-1 * z; + +/* adjust for odd powers of 2 */ +if( (e & 1) != 0 ) + x *= SQRT2; + +/* re-insert exponent */ +#ifdef UNK +x = ldexp( x, (e >> 1) ); +#endif +#ifdef DEC +*q += ((e >> 1) & 0377) << 7; +*q &= 077777; +#endif +#ifdef IBMPC +x = ldexp( x, (e >> 1) ); +/* +*q += ((e >>1) & 0x7ff) << 4; +*q &= 077777; +*/ +#endif +#ifdef MIEEE +x = ldexp( x, (e >> 1) ); +/* +*q += ((e >>1) & 0x7ff) << 4; +*q &= 077777; +*/ +#endif + +/* Newton iterations: */ +#ifdef UNK +x = 0.5*(x + w/x); +x = 0.5*(x + w/x); +x = 0.5*(x + w/x); +#endif + +/* Note, assume the square root cannot be denormal, + * so it is safe to use integer exponent operations here. + */ +#ifdef DEC +x += w/x; +*q -= 0200; +x += w/x; +*q -= 0200; +x += w/x; +*q -= 0200; +#endif +#ifdef IBMPC +x += w/x; +*q -= 0x10; +x += w/x; +*q -= 0x10; +x += w/x; +*q -= 0x10; +#endif +#ifdef MIEEE +x += w/x; +*q -= 0x10; +x += w/x; +*q -= 0x10; +x += w/x; +*q -= 0x10; +#endif + +return(x); +} diff --git a/libm/double/stdtr.c b/libm/double/stdtr.c new file mode 100644 index 000000000..743e01704 --- /dev/null +++ b/libm/double/stdtr.c @@ -0,0 +1,225 @@ +/* stdtr.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * double t, stdtr(); + * short k; + * + * y = stdtr( 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 < -2, 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 <= 25. The "domain" refers to t. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -100,-2 50000 5.9e-15 1.4e-15 + * IEEE -2,100 500000 2.7e-15 4.9e-17 + */ + +/* stdtri.c + * + * Functional inverse of Student's t distribution + * + * + * + * SYNOPSIS: + * + * double p, t, stdtri(); + * int k; + * + * t = stdtri( k, p ); + * + * + * DESCRIPTION: + * + * Given probability p, finds the argument t such that stdtr(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 .001,.999 25000 5.7e-15 8.0e-16 + * IEEE 10^-6,.001 25000 2.0e-12 2.9e-14 + */ + + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +extern double PI, MACHEP, MAXNUM; +#ifdef ANSIPROT +extern double sqrt ( double ); +extern double atan ( double ); +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +extern double fabs ( double ); +#else +double sqrt(), atan(), incbet(), incbi(), fabs(); +#endif + +double stdtr( k, t ) +int k; +double t; +{ +double x, rk, z, f, tz, p, xsqk; +int j; + +if( k <= 0 ) + { + mtherr( "stdtr", DOMAIN ); + return(0.0); + } + +if( t == 0 ) + return( 0.5 ); + +if( t < -2.0 ) + { + rk = k; + z = rk / (rk + t * t); + p = 0.5 * incbet( 0.5*rk, 0.5, z ); + return( p ); + } + +/* compute integral from -t to + t */ + +if( t < 0 ) + x = -t; +else + x = t; + +rk = k; /* degrees of freedom */ +z = 1.0 + ( x * x )/rk; + +/* test if k is odd or even */ +if( (k & 1) != 0) + { + + /* computation for odd k */ + + xsqk = x/sqrt(rk); + p = atan( xsqk ); + if( k > 1 ) + { + f = 1.0; + tz = 1.0; + j = 3; + while( (j<=(k-2)) && ( (tz/f) > MACHEP ) ) + { + tz *= (j-1)/( z * j ); + f += tz; + j += 2; + } + p += f * xsqk/z; + } + p *= 2.0/PI; + } + + +else + { + + /* computation for even k */ + + f = 1.0; + tz = 1.0; + j = 2; + + while( ( j <= (k-2) ) && ( (tz/f) > MACHEP ) ) + { + tz *= (j - 1)/( z * j ); + f += tz; + j += 2; + } + p = f * x/sqrt(z*rk); + } + +/* common exit */ + + +if( t < 0 ) + p = -p; /* note destruction of relative accuracy */ + + p = 0.5 + 0.5 * p; +return(p); +} + +double stdtri( k, p ) +int k; +double p; +{ +double t, rk, z; +int rflg; + +if( k <= 0 || p <= 0.0 || p >= 1.0 ) + { + mtherr( "stdtri", DOMAIN ); + return(0.0); + } + +rk = k; + +if( p > 0.25 && p < 0.75 ) + { + if( p == 0.5 ) + return( 0.0 ); + z = 1.0 - 2.0 * p; + z = incbi( 0.5, 0.5*rk, fabs(z) ); + t = sqrt( rk*z/(1.0-z) ); + if( p < 0.5 ) + t = -t; + return( t ); + } +rflg = -1; +if( p >= 0.5) + { + p = 1.0 - p; + rflg = 1; + } +z = incbi( 0.5*rk, 0.5, 2.0*p ); + +if( MAXNUM * z < rk ) + return(rflg* MAXNUM); +t = sqrt( rk/z - rk ); +return( rflg * t ); +} diff --git a/libm/double/struve.c b/libm/double/struve.c new file mode 100644 index 000000000..fabf0735e --- /dev/null +++ b/libm/double/struve.c @@ -0,0 +1,312 @@ +/* struve.c + * + * Struve function + * + * + * + * SYNOPSIS: + * + * double v, x, y, struve(); + * + * y = struve( v, x ); + * + * + * + * DESCRIPTION: + * + * Computes the Struve function Hv(x) of order v, argument x. + * Negative x is rejected unless v is an integer. + * + * This module also contains the hypergeometric functions 1F2 + * and 3F0 and a routine for the Bessel function Yv(x) with + * noninteger v. + * + * + * + * ACCURACY: + * + * Not accurately characterized, but spot checked against tables. + * + */ + + +/* +Cephes Math Library Release 2.81: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ +#include <math.h> +#define DEBUG 0 +#ifdef ANSIPROT +extern double gamma ( double ); +extern double pow ( double, double ); +extern double sqrt ( double ); +extern double yn ( int, double ); +extern double jv ( double, double ); +extern double fabs ( double ); +extern double floor ( double ); +extern double sin ( double ); +extern double cos ( double ); +double yv ( double, double ); +double onef2 (double, double, double, double, double * ); +double threef0 (double, double, double, double, double * ); +#else +double gamma(), pow(), sqrt(), yn(), yv(), jv(), fabs(), floor(); +double sin(), cos(); +double onef2(), threef0(); +#endif +static double stop = 1.37e-17; +extern double MACHEP; + +double onef2( a, b, c, x, err ) +double a, b, c, x; +double *err; +{ +double n, a0, sum, t; +double an, bn, cn, max, z; + +an = a; +bn = b; +cn = c; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +max = 0.0; + +do + { + if( an == 0 ) + goto done; + if( bn == 0 ) + goto error; + if( cn == 0 ) + goto error; + if( (a0 > 1.0e34) || (n > 200) ) + goto error; + a0 *= (an * x) / (bn * cn * n); + sum += a0; + an += 1.0; + bn += 1.0; + cn += 1.0; + n += 1.0; + z = fabs( a0 ); + if( z > max ) + max = z; + if( sum != 0 ) + t = fabs( a0 / sum ); + else + t = z; + } +while( t > stop ); + +done: + +*err = fabs( MACHEP*max /sum ); + +#if DEBUG + printf(" onef2 cancellation error %.5E\n", *err ); +#endif + +goto xit; + +error: +#if DEBUG +printf("onef2 does not converge\n"); +#endif +*err = 1.0e38; + +xit: + +#if DEBUG +printf("onef2( %.2E %.2E %.2E %.5E ) = %.3E %.6E\n", a, b, c, x, n, sum); +#endif +return(sum); +} + + + + +double threef0( a, b, c, x, err ) +double a, b, c, x; +double *err; +{ +double n, a0, sum, t, conv, conv1; +double an, bn, cn, max, z; + +an = a; +bn = b; +cn = c; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +max = 0.0; +conv = 1.0e38; +conv1 = conv; + +do + { + if( an == 0.0 ) + goto done; + if( bn == 0.0 ) + goto done; + if( cn == 0.0 ) + goto done; + if( (a0 > 1.0e34) || (n > 200) ) + goto error; + a0 *= (an * bn * cn * x) / n; + an += 1.0; + bn += 1.0; + cn += 1.0; + n += 1.0; + z = fabs( a0 ); + if( z > max ) + max = z; + if( z >= conv ) + { + if( (z < max) && (z > conv1) ) + goto done; + } + conv1 = conv; + conv = z; + sum += a0; + if( sum != 0 ) + t = fabs( a0 / sum ); + else + t = z; + } +while( t > stop ); + +done: + +t = fabs( MACHEP*max/sum ); +#if DEBUG + printf(" threef0 cancellation error %.5E\n", t ); +#endif + +max = fabs( conv/sum ); +if( max > t ) + t = max; +#if DEBUG + printf(" threef0 convergence %.5E\n", max ); +#endif + +goto xit; + +error: +#if DEBUG +printf("threef0 does not converge\n"); +#endif +t = 1.0e38; + +xit: + +#if DEBUG +printf("threef0( %.2E %.2E %.2E %.5E ) = %.3E %.6E\n", a, b, c, x, n, sum); +#endif + +*err = t; +return(sum); +} + + + + +extern double PI; + +double struve( v, x ) +double v, x; +{ +double y, ya, f, g, h, t; +double onef2err, threef0err; + +f = floor(v); +if( (v < 0) && ( v-f == 0.5 ) ) + { + y = jv( -v, x ); + f = 1.0 - f; + g = 2.0 * floor(f/2.0); + if( g != f ) + y = -y; + return(y); + } +t = 0.25*x*x; +f = fabs(x); +g = 1.5 * fabs(v); +if( (f > 30.0) && (f > g) ) + { + onef2err = 1.0e38; + y = 0.0; + } +else + { + y = onef2( 1.0, 1.5, 1.5+v, -t, &onef2err ); + } + +if( (f < 18.0) || (x < 0.0) ) + { + threef0err = 1.0e38; + ya = 0.0; + } +else + { + ya = threef0( 1.0, 0.5, 0.5-v, -1.0/t, &threef0err ); + } + +f = sqrt( PI ); +h = pow( 0.5*x, v-1.0 ); + +if( onef2err <= threef0err ) + { + g = gamma( v + 1.5 ); + y = y * h * t / ( 0.5 * f * g ); + return(y); + } +else + { + g = gamma( v + 0.5 ); + ya = ya * h / ( f * g ); + ya = ya + yv( v, x ); + return(ya); + } +} + + + + +/* Bessel function of noninteger order + */ + +double yv( v, x ) +double v, x; +{ +double y, t; +int n; + +y = floor( v ); +if( y == v ) + { + n = v; + y = yn( n, x ); + return( y ); + } +t = PI * v; +y = (cos(t) * jv( v, x ) - jv( -v, x ))/sin(t); +return( y ); +} + +/* Crossover points between ascending series and asymptotic series + * for Struve function + * + * v x + * + * 0 19.2 + * 1 18.95 + * 2 19.15 + * 3 19.3 + * 5 19.7 + * 10 21.35 + * 20 26.35 + * 30 32.31 + * 40 40.0 + */ diff --git a/libm/double/tan.c b/libm/double/tan.c new file mode 100644 index 000000000..603f4b6a9 --- /dev/null +++ b/libm/double/tan.c @@ -0,0 +1,304 @@ +/* tan.c + * + * Circular tangent + * + * + * + * SYNOPSIS: + * + * double x, y, tan(); + * + * y = tan( 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 + * DEC +-1.07e9 44000 4.1e-17 1.0e-17 + * IEEE +-1.07e9 30000 2.9e-16 8.1e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * tan total loss x > 1.073741824e9 0.0 + * + */ + /* cot.c + * + * Circular cotangent + * + * + * + * SYNOPSIS: + * + * double x, y, cot(); + * + * y = cot( 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 2.9e-16 8.2e-17 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 1.073741824e9 0.0 + * cot singularity x = 0 INFINITY + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +yright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { +-1.30936939181383777646E4, + 1.15351664838587416140E6, +-1.79565251976484877988E7 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.36812963470692954678E4, +-1.32089234440210967447E6, + 2.50083801823357915839E7, +-5.38695755929454629881E7 +}; +static double DP1 = 7.853981554508209228515625E-1; +static double DP2 = 7.94662735614792836714E-9; +static double DP3 = 3.06161699786838294307E-17; +static double lossth = 1.073741824e9; +#endif + +#ifdef DEC +static unsigned short P[] = { +0143514,0113306,0111171,0174674, +0045214,0147545,0027744,0167346, +0146210,0177526,0114514,0105660 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0043525,0142457,0072633,0025617, +0145241,0036742,0140525,0162256, +0046276,0146176,0013526,0143573, +0146515,0077401,0162762,0150607 +}; +/* 7.853981629014015197753906250000E-1 */ +static unsigned short P1[] = {0040111,0007732,0120000,0000000,}; +/* 4.960467869796758577649598009884E-10 */ +static unsigned short P2[] = {0030410,0055060,0100000,0000000,}; +/* 2.860594363054915898381331279295E-18 */ +static unsigned short P3[] = {0021523,0011431,0105056,0001560,}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +static double lossth = 1.073741824e9; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x3f38,0xd24f,0x92d8,0xc0c9, +0x9ddd,0xa5fc,0x99ec,0x4131, +0x9176,0xd329,0x1fea,0xc171 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6572,0xeeb3,0xb8a5,0x40ca, +0xbc96,0x582a,0x27bc,0xc134, +0xd8ef,0xc2ea,0xd98f,0x4177, +0x5a31,0x3cbe,0xafe0,0xc189 +}; +/* + 7.85398125648498535156E-1, + 3.77489470793079817668E-8, + 2.69515142907905952645E-15, +*/ +static unsigned short P1[] = {0x0000,0x4000,0x21fb,0x3fe9}; +static unsigned short P2[] = {0x0000,0x0000,0x442d,0x3e64}; +static unsigned short P3[] = {0x5170,0x98cc,0x4698,0x3ce8}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +static double lossth = 1.073741824e9; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xc0c9,0x92d8,0xd24f,0x3f38, +0x4131,0x99ec,0xa5fc,0x9ddd, +0xc171,0x1fea,0xd329,0x9176 +}; +static unsigned short Q[] = { +0x40ca,0xb8a5,0xeeb3,0x6572, +0xc134,0x27bc,0x582a,0xbc96, +0x4177,0xd98f,0xc2ea,0xd8ef, +0xc189,0xafe0,0x3cbe,0x5a31 +}; +static unsigned short P1[] = { +0x3fe9,0x21fb,0x4000,0x0000 +}; +static unsigned short P2[] = { +0x3e64,0x442d,0x0000,0x0000 +}; +static unsigned short P3[] = { +0x3ce8,0x4698,0x98cc,0x5170, +}; +#define DP1 *(double *)P1 +#define DP2 *(double *)P2 +#define DP3 *(double *)P3 +static double lossth = 1.073741824e9; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +extern int isnan ( double ); +extern int isfinite ( double ); +static double tancot(double, int); +#else +double polevl(), p1evl(), floor(), ldexp(); +static double tancot(); +int isnan(), isfinite(); +#endif +extern double PIO4; +extern double INFINITY; +extern double NAN; + +double tan(x) +double x; +{ +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +#ifdef NANS +if( isnan(x) ) + return(x); +if( !isfinite(x) ) + { + mtherr( "tan", DOMAIN ); + return(NAN); + } +#endif +return( tancot(x,0) ); +} + + +double cot(x) +double x; +{ + +if( x == 0.0 ) + { + mtherr( "cot", SING ); + return( INFINITY ); + } +return( tancot(x,1) ); +} + + +static double tancot( xx, cotflg ) +double xx; +int cotflg; +{ +double x, y, z, zz; +int j, sign; + +/* make argument positive but save the sign */ +if( xx < 0 ) + { + x = -xx; + sign = -1; + } +else + { + x = xx; + sign = 1; + } + +if( x > lossth ) + { + if( cotflg ) + mtherr( "cot", TLOSS ); + else + mtherr( "tan", TLOSS ); + return(0.0); + } + +/* compute x mod PIO4 */ +y = floor( x/PIO4 ); + +/* strip high bits of integer part */ +z = ldexp( y, -3 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( z, 3 ); /* 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.0; + } + +z = ((x - y * DP1) - y * DP2) - y * DP3; + +zz = z * z; + +if( zz > 1.0e-14 ) + y = z + z * (zz * polevl( zz, P, 2 )/p1evl(zz, Q, 4)); +else + y = z; + +if( j & 2 ) + { + if( cotflg ) + y = -y; + else + y = -1.0/y; + } +else + { + if( cotflg ) + y = 1.0/y; + } + +if( sign < 0 ) + y = -y; + +return( y ); +} diff --git a/libm/double/tandg.c b/libm/double/tandg.c new file mode 100644 index 000000000..92fd1e56b --- /dev/null +++ b/libm/double/tandg.c @@ -0,0 +1,267 @@ +/* tandg.c + * + * Circular tangent of argument in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, tandg(); + * + * y = tandg( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the argument x in degrees. + * + * 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 + * DEC 0,10 8000 3.4e-17 1.2e-17 + * IEEE 0,10 30000 3.2e-16 8.4e-17 + * + * ERROR MESSAGES: + * + * message condition value returned + * tandg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * tandg singularity x = 180 k + 90 MAXNUM + */ + /* cotdg.c + * + * Circular cotangent of argument in degrees + * + * + * + * SYNOPSIS: + * + * double x, y, cotdg(); + * + * y = cotdg( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the argument x in degrees. + * + * 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]. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cotdg total loss x > 8.0e14 (DEC) 0.0 + * x > 1.0e14 (IEEE) + * cotdg singularity x = 180 k MAXNUM + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { +-1.30936939181383777646E4, + 1.15351664838587416140E6, +-1.79565251976484877988E7 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.36812963470692954678E4, +-1.32089234440210967447E6, + 2.50083801823357915839E7, +-5.38695755929454629881E7 +}; +static double PI180 = 1.74532925199432957692E-2; +static double lossth = 1.0e14; +#endif + +#ifdef DEC +static unsigned short P[] = { +0143514,0113306,0111171,0174674, +0045214,0147545,0027744,0167346, +0146210,0177526,0114514,0105660 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0043525,0142457,0072633,0025617, +0145241,0036742,0140525,0162256, +0046276,0146176,0013526,0143573, +0146515,0077401,0162762,0150607 +}; +static unsigned short P1[] = {0036616,0175065,0011224,0164711}; +#define PI180 *(double *)P1 +static double lossth = 8.0e14; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x3f38,0xd24f,0x92d8,0xc0c9, +0x9ddd,0xa5fc,0x99ec,0x4131, +0x9176,0xd329,0x1fea,0xc171 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x6572,0xeeb3,0xb8a5,0x40ca, +0xbc96,0x582a,0x27bc,0xc134, +0xd8ef,0xc2ea,0xd98f,0x4177, +0x5a31,0x3cbe,0xafe0,0xc189 +}; +static unsigned short P1[] = {0x9d39,0xa252,0xdf46,0x3f91}; +#define PI180 *(double *)P1 +static double lossth = 1.0e14; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xc0c9,0x92d8,0xd24f,0x3f38, +0x4131,0x99ec,0xa5fc,0x9ddd, +0xc171,0x1fea,0xd329,0x9176 +}; +static unsigned short Q[] = { +0x40ca,0xb8a5,0xeeb3,0x6572, +0xc134,0x27bc,0x582a,0xbc96, +0x4177,0xd98f,0xc2ea,0xd8ef, +0xc189,0xafe0,0x3cbe,0x5a31 +}; +static unsigned short P1[] = { +0x3f91,0xdf46,0xa252,0x9d39 +}; +#define PI180 *(double *)P1 +static double lossth = 1.0e14; +#endif + +#ifdef ANSIPROT +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double floor ( double ); +extern double ldexp ( double, int ); +static double tancot( double, int ); +#else +double polevl(), p1evl(), floor(), ldexp(); +static double tancot(); +#endif +extern double MAXNUM; +extern double PIO4; + + +double tandg(x) +double x; +{ + +return( tancot(x,0) ); +} + + +double cotdg(x) +double x; +{ + +return( tancot(x,1) ); +} + + +static double tancot( xx, cotflg ) +double xx; +int cotflg; +{ +double x, y, z, zz; +int j, sign; + +/* make argument positive but save the sign */ +if( xx < 0 ) + { + x = -xx; + sign = -1; + } +else + { + x = xx; + sign = 1; + } + +if( x > lossth ) + { + mtherr( "tandg", TLOSS ); + return(0.0); + } + +/* compute x mod PIO4 */ +y = floor( x/45.0 ); + +/* strip high bits of integer part */ +z = ldexp( y, -3 ); +z = floor(z); /* integer part of y/8 */ +z = y - ldexp( z, 3 ); /* 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.0; + } + +z = x - y * 45.0; +z *= PI180; + +zz = z * z; + +if( zz > 1.0e-14 ) + y = z + z * (zz * polevl( zz, P, 2 )/p1evl(zz, Q, 4)); +else + y = z; + +if( j & 2 ) + { + if( cotflg ) + y = -y; + else + { + if( y != 0.0 ) + { + y = -1.0/y; + } + else + { + mtherr( "tandg", SING ); + y = MAXNUM; + } + } + } +else + { + if( cotflg ) + { + if( y != 0.0 ) + y = 1.0/y; + else + { + mtherr( "cotdg", SING ); + y = MAXNUM; + } + } + } + +if( sign < 0 ) + y = -y; + +return( y ); +} diff --git a/libm/double/tanh.c b/libm/double/tanh.c new file mode 100644 index 000000000..910a4188e --- /dev/null +++ b/libm/double/tanh.c @@ -0,0 +1,141 @@ +/* tanh.c + * + * Hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * double x, y, tanh(); + * + * y = tanh( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOG to + * MAXLOG. + * + * 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 + * DEC -2,2 50000 3.3e-17 6.4e-18 + * IEEE -2,2 30000 2.5e-16 5.8e-17 + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1995, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +#ifdef UNK +static double P[] = { +-9.64399179425052238628E-1, +-9.92877231001918586564E1, +-1.61468768441708447952E3 +}; +static double Q[] = { +/* 1.00000000000000000000E0,*/ + 1.12811678491632931402E2, + 2.23548839060100448583E3, + 4.84406305325125486048E3 +}; +#endif +#ifdef DEC +static unsigned short P[] = { +0140166,0161335,0053753,0075126, +0141706,0111520,0070463,0040552, +0142711,0153001,0101300,0025430 +}; +static unsigned short Q[] = { +/*0040200,0000000,0000000,0000000,*/ +0041741,0117624,0051300,0156060, +0043013,0133720,0071251,0127717, +0043227,0060201,0021020,0020136 +}; +#endif + +#ifdef IBMPC +static unsigned short P[] = { +0x6f4b,0xaafd,0xdc5b,0xbfee, +0x682d,0x0e26,0xd26a,0xc058, +0x0563,0x3058,0x3ac0,0xc099 +}; +static unsigned short Q[] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x1b86,0x8a58,0x33f2,0x405c, +0x35fa,0x0e55,0x76fa,0x40a1, +0x040c,0x2442,0xec10,0x40b2 +}; +#endif + +#ifdef MIEEE +static unsigned short P[] = { +0xbfee,0xdc5b,0xaafd,0x6f4b, +0xc058,0xd26a,0x0e26,0x682d, +0xc099,0x3ac0,0x3058,0x0563 +}; +static unsigned short Q[] = { +0x405c,0x33f2,0x8a58,0x1b86, +0x40a1,0x76fa,0x0e55,0x35fa, +0x40b2,0xec10,0x2442,0x040c +}; +#endif + +#ifdef ANSIPROT +extern double fabs ( double ); +extern double exp ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +#else +double fabs(), exp(), polevl(), p1evl(); +#endif +extern double MAXLOG; + +double tanh(x) +double x; +{ +double s, z; + +#ifdef MINUSZERO +if( x == 0.0 ) + return(x); +#endif +z = fabs(x); +if( z > 0.5 * MAXLOG ) + { + if( x > 0 ) + return( 1.0 ); + else + return( -1.0 ); + } +if( z >= 0.625 ) + { + s = exp(2.0*z); + z = 1.0 - 2.0/(s + 1.0); + if( x < 0 ) + z = -z; + } +else + { + if( x == 0.0 ) + return(x); + s = x * x; + z = polevl( s, P, 2 )/p1evl(s, Q, 3); + z = x * s * z; + z = x + z; + } +return( z ); +} diff --git a/libm/double/time-it.c b/libm/double/time-it.c new file mode 100644 index 000000000..32d07db4e --- /dev/null +++ b/libm/double/time-it.c @@ -0,0 +1,38 @@ +/* Reports run time, in seconds, for a command. + The command argument can have multiple words, but then + it has to be quoted, as for example + + time-it "command < file1 > file2" + + The time interval resolution is one whole second. */ + + +#include <time.h> +int system (); +int printf (); + +int +main (argv, argc) + int argv; + char **argc; +{ + time_t t0, t1; + + if (argv < 2) + { + printf ("Usage: time-it name_of_program_to_be_timed\n"); + exit (1); + } + time (&t0); + /* Wait til the clock changes before starting. */ + do + { + time (&t1); + } + while (t1 == t0); + system (argc[1]); + t0 = t1; + time (&t1); + printf ("%ld seconds.\n", t1 - t0); + exit (0); +} diff --git a/libm/double/unity.c b/libm/double/unity.c new file mode 100644 index 000000000..9223e0edf --- /dev/null +++ b/libm/double/unity.c @@ -0,0 +1,138 @@ +/* unity.c + * + * Relative error approximations for function arguments near + * unity. + * + * log1p(x) = log(1+x) + * expm1(x) = exp(x) - 1 + * cosm1(x) = cos(x) - 1 + * + */ + +#include <math.h> + +#ifdef ANSIPROT +extern int isnan (double); +extern int isfinite (double); +extern double log ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +extern double exp ( double ); +extern double cos ( double ); +#else +double log(), polevl(), p1evl(), exp(), cos(); +int isnan(), isfinite(); +#endif +extern double INFINITY; + +/* log1p(x) = log(1 + x) */ + +/* 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 double LP[] = { + 4.5270000862445199635215E-5, + 4.9854102823193375972212E-1, + 6.5787325942061044846969E0, + 2.9911919328553073277375E1, + 6.0949667980987787057556E1, + 5.7112963590585538103336E1, + 2.0039553499201281259648E1, +}; +static double LQ[] = { +/* 1.0000000000000000000000E0,*/ + 1.5062909083469192043167E1, + 8.3047565967967209469434E1, + 2.2176239823732856465394E2, + 3.0909872225312059774938E2, + 2.1642788614495947685003E2, + 6.0118660497603843919306E1, +}; + +#define SQRTH 0.70710678118654752440 +#define SQRT2 1.41421356237309504880 + +double log1p(x) +double x; +{ +double z; + +z = 1.0 + x; +if( (z < SQRTH) || (z > SQRT2) ) + return( log(z) ); +z = x*x; +z = -0.5 * z + x * ( z * polevl( x, LP, 6 ) / p1evl( 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 double EP[3] = { + 1.2617719307481059087798E-4, + 3.0299440770744196129956E-2, + 9.9999999999999999991025E-1, +}; +static double EQ[4] = { + 3.0019850513866445504159E-6, + 2.5244834034968410419224E-3, + 2.2726554820815502876593E-1, + 2.0000000000000000000897E0, +}; + +double expm1(x) +double x; +{ +double r, xx; + +#ifdef NANS +if( isnan(x) ) + return(x); +#endif +#ifdef INFINITIES +if( x == INFINITY ) + return(INFINITY); +if( x == -INFINITY ) + return(-1.0); +#endif +if( (x < -0.5) || (x > 0.5) ) + return( exp(x) - 1.0 ); +xx = x * x; +r = x * polevl( xx, EP, 2 ); +r = r/( polevl( xx, EQ, 3 ) - r ); +return (r + r); +} + + + +/* cosm1(x) = cos(x) - 1 */ + +static double coscof[7] = { + 4.7377507964246204691685E-14, +-1.1470284843425359765671E-11, + 2.0876754287081521758361E-9, +-2.7557319214999787979814E-7, + 2.4801587301570552304991E-5, +-1.3888888888888872993737E-3, + 4.1666666666666666609054E-2, +}; + +extern double PIO4; + +double cosm1(x) +double x; +{ +double xx; + +if( (x < -PIO4) || (x > PIO4) ) + return( cos(x) - 1.0 ); +xx = x * x; +xx = -0.5*xx + xx * xx * polevl( xx, coscof, 6 ); +return xx; +} diff --git a/libm/double/yn.c b/libm/double/yn.c new file mode 100644 index 000000000..0c569a925 --- /dev/null +++ b/libm/double/yn.c @@ -0,0 +1,114 @@ +/* yn.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * double x, y, yn(); + * int n; + * + * y = yn( 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 + * y0() and y1(). + * + * If n = 0 or 1 the routine for y0 or y1 is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative + * when y > 1: + * arithmetic domain # trials peak rms + * DEC 0, 30 2200 2.9e-16 5.3e-17 + * IEEE 0, 30 30000 3.4e-15 4.3e-16 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * yn singularity x = 0 MAXNUM + * yn overflow MAXNUM + * + * Spot checked against tables for x, n between 0 and 100. + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double y0 ( double ); +extern double y1 ( double ); +extern double log ( double ); +#else +double y0(), y1(), log(); +#endif +extern double MAXNUM, MAXLOG; + +double yn( n, x ) +int n; +double x; +{ +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 * y0(x) ); +if( n == 1 ) + return( sign * y1(x) ); + +/* test for overflow */ +if( x <= 0.0 ) + { + mtherr( "yn", SING ); + return( -MAXNUM ); + } + +/* forward recurrence on n */ + +anm2 = y0(x); +anm1 = y1(x); +k = 1; +r = 2 * k; +do + { + an = r * anm1 / x - anm2; + anm2 = anm1; + anm1 = an; + r += 2.0; + ++k; + } +while( k < n ); + + +return( sign * an ); +} diff --git a/libm/double/zeta.c b/libm/double/zeta.c new file mode 100644 index 000000000..a49c619d5 --- /dev/null +++ b/libm/double/zeta.c @@ -0,0 +1,189 @@ +/* zeta.c + * + * Riemann zeta function of two arguments + * + * + * + * SYNOPSIS: + * + * double x, q, y, zeta(); + * + * y = zeta( x, q ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zeta(x,q) = > (k+q) + * - + * k=0 + * + * where x > 1 and q is not a negative integer or zero. + * The Euler-Maclaurin summation formula is used to obtain + * the expansion + * + * n + * - -x + * zeta(x,q) = > (k+q) + * - + * k=1 + * + * 1-x inf. B x(x+1)...(x+2j) + * (n+q) 1 - 2j + * + --------- - ------- + > -------------------- + * x-1 x - x+2j+1 + * 2(n+q) j=1 (2j)! (n+q) + * + * where the B2j are Bernoulli numbers. Note that (see zetac.c) + * zeta(x,1) = zetac(x) + 1. + * + * + * + * ACCURACY: + * + * + * + * REFERENCE: + * + * Gradshteyn, I. S., and I. M. Ryzhik, Tables of Integrals, + * Series, and Products, p. 1073; Academic Press, 1980. + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 2000 by Stephen L. Moshier +*/ + +#include <math.h> +#ifdef ANSIPROT +extern double fabs ( double ); +extern double pow ( double, double ); +extern double floor ( double ); +#else +double fabs(), pow(), floor(); +#endif +extern double MAXNUM, MACHEP; + +/* Expansion coefficients + * for Euler-Maclaurin summation formula + * (2k)! / B2k + * where B2k are Bernoulli numbers + */ +static double A[] = { +12.0, +-720.0, +30240.0, +-1209600.0, +47900160.0, +-1.8924375803183791606e9, /*1.307674368e12/691*/ +7.47242496e10, +-2.950130727918164224e12, /*1.067062284288e16/3617*/ +1.1646782814350067249e14, /*5.109094217170944e18/43867*/ +-4.5979787224074726105e15, /*8.028576626982912e20/174611*/ +1.8152105401943546773e17, /*1.5511210043330985984e23/854513*/ +-7.1661652561756670113e18 /*1.6938241367317436694528e27/236364091*/ +}; +/* 30 Nov 86 -- error in third coefficient fixed */ + + +double zeta(x,q) +double x,q; +{ +int i; +double a, b, k, s, t, w; + +if( x == 1.0 ) + goto retinf; + +if( x < 1.0 ) + { +domerr: + mtherr( "zeta", DOMAIN ); + return(0.0); + } + +if( q <= 0.0 ) + { + if(q == floor(q)) + { + mtherr( "zeta", SING ); +retinf: + return( MAXNUM ); + } + if( x != floor(x) ) + goto domerr; /* because q^-x not defined */ + } + +/* Euler-Maclaurin summation formula */ +/* +if( x < 25.0 ) +*/ +{ +/* Permit negative q but continue sum until n+q > +9 . + * This case should be handled by a reflection formula. + * If q<0 and x is an integer, there is a relation to + * the polygamma function. + */ +s = pow( q, -x ); +a = q; +i = 0; +b = 0.0; +while( (i < 9) || (a <= 9.0) ) + { + i += 1; + a += 1.0; + b = pow( a, -x ); + s += b; + if( fabs(b/s) < MACHEP ) + goto done; + } + +w = a; +s += b*w/(x-1.0); +s -= 0.5 * b; +a = 1.0; +k = 0.0; +for( i=0; i<12; i++ ) + { + a *= x + k; + b /= w; + t = a*b/A[i]; + s = s + t; + t = fabs(t/s); + if( t < MACHEP ) + goto done; + k += 1.0; + a *= x + k; + b /= w; + k += 1.0; + } +done: +return(s); +} + + + +/* Basic sum of inverse powers */ +/* +pseres: + +s = pow( q, -x ); +a = q; +do + { + a += 2.0; + b = pow( a, -x ); + s += b; + } +while( b/s > MACHEP ); + +b = pow( 2.0, -x ); +s = (s + b)/(1.0-b); +return(s); +*/ +} diff --git a/libm/double/zetac.c b/libm/double/zetac.c new file mode 100644 index 000000000..cc28590b3 --- /dev/null +++ b/libm/double/zetac.c @@ -0,0 +1,599 @@ + /* zetac.c + * + * Riemann zeta function + * + * + * + * SYNOPSIS: + * + * double x, y, zetac(); + * + * y = zetac( x ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zetac(x) = > k , x > 1, + * - + * k=2 + * + * is related to the Riemann zeta function by + * + * Riemann zeta(x) = zetac(x) + 1. + * + * Extension of the function definition for x < 1 is implemented. + * Zero is returned for x > log2(MAXNUM). + * + * An overflow error may occur for large negative x, due to the + * gamma function in the reflection formula. + * + * ACCURACY: + * + * Tabulated values have full machine accuracy. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,50 10000 9.8e-16 1.3e-16 + * DEC 1,50 2000 1.1e-16 1.9e-17 + * + * + */ + +/* +Cephes Math Library Release 2.8: June, 2000 +Copyright 1984, 1987, 1989, 2000 by Stephen L. Moshier +*/ + +#include <math.h> + +extern double MAXNUM, PI; + +/* Riemann zeta(x) - 1 + * for integer arguments between 0 and 30. + */ +#ifdef UNK +static double azetac[] = { +-1.50000000000000000000E0, + 1.70141183460469231730E38, /* infinity. */ + 6.44934066848226436472E-1, + 2.02056903159594285400E-1, + 8.23232337111381915160E-2, + 3.69277551433699263314E-2, + 1.73430619844491397145E-2, + 8.34927738192282683980E-3, + 4.07735619794433937869E-3, + 2.00839282608221441785E-3, + 9.94575127818085337146E-4, + 4.94188604119464558702E-4, + 2.46086553308048298638E-4, + 1.22713347578489146752E-4, + 6.12481350587048292585E-5, + 3.05882363070204935517E-5, + 1.52822594086518717326E-5, + 7.63719763789976227360E-6, + 3.81729326499983985646E-6, + 1.90821271655393892566E-6, + 9.53962033872796113152E-7, + 4.76932986787806463117E-7, + 2.38450502727732990004E-7, + 1.19219925965311073068E-7, + 5.96081890512594796124E-8, + 2.98035035146522801861E-8, + 1.49015548283650412347E-8, + 7.45071178983542949198E-9, + 3.72533402478845705482E-9, + 1.86265972351304900640E-9, + 9.31327432419668182872E-10 +}; +#endif + +#ifdef DEC +static unsigned short azetac[] = { +0140300,0000000,0000000,0000000, +0077777,0177777,0177777,0177777, +0040045,0015146,0022460,0076462, +0037516,0164001,0036001,0104116, +0037250,0114425,0061754,0022033, +0037027,0040616,0145174,0146670, +0036616,0011411,0100444,0104437, +0036410,0145550,0051474,0161067, +0036205,0115527,0141434,0133506, +0036003,0117475,0100553,0053403, +0035602,0056147,0045567,0027703, +0035401,0106157,0111054,0145242, +0035201,0002455,0113151,0101015, +0035000,0126235,0004273,0157260, +0034600,0071127,0112647,0005261, +0034400,0045736,0057610,0157550, +0034200,0031146,0172621,0074172, +0034000,0020603,0115503,0032007, +0033600,0013114,0124672,0023135, +0033400,0007330,0043715,0151117, +0033200,0004742,0145043,0033514, +0033000,0003225,0152624,0004411, +0032600,0002143,0033166,0035746, +0032400,0001354,0074234,0026143, +0032200,0000762,0147776,0170220, +0032000,0000514,0072452,0130631, +0031600,0000335,0114266,0063315, +0031400,0000223,0132710,0041045, +0031200,0000142,0073202,0153426, +0031000,0000101,0121400,0152065, +0030600,0000053,0140525,0072761 +}; +#endif + +#ifdef IBMPC +static unsigned short azetac[] = { +0x0000,0x0000,0x0000,0xbff8, +0xffff,0xffff,0xffff,0x7fef, +0x0fa6,0xc4a6,0xa34c,0x3fe4, +0x310a,0x2780,0xdd00,0x3fc9, +0x8483,0xac7d,0x1322,0x3fb5, +0x99b7,0xd94f,0xe831,0x3fa2, +0x9124,0x3024,0xc261,0x3f91, +0x9c47,0x0a67,0x196d,0x3f81, +0x96e9,0xf863,0xb36a,0x3f70, +0x6ae0,0xb02d,0x73e7,0x3f60, +0xe5f8,0xe96e,0x4b8c,0x3f50, +0x9954,0xf245,0x318d,0x3f40, +0x3042,0xb2cd,0x20a5,0x3f30, +0x7bd6,0xa117,0x1593,0x3f20, +0xe156,0xf2b4,0x0e4a,0x3f10, +0x1bed,0xcbf1,0x097b,0x3f00, +0x2f0f,0xdeb2,0x064c,0x3ef0, +0x6681,0x7368,0x0430,0x3ee0, +0x44cc,0x9537,0x02c9,0x3ed0, +0xba4a,0x08f9,0x01db,0x3ec0, +0x66ea,0x5944,0x013c,0x3eb0, +0x8121,0xbab2,0x00d2,0x3ea0, +0xc77d,0x66ce,0x008c,0x3e90, +0x858c,0x8f13,0x005d,0x3e80, +0xde12,0x59ff,0x003e,0x3e70, +0x5633,0x8ea5,0x0029,0x3e60, +0xccda,0xb316,0x001b,0x3e50, +0x0845,0x76b9,0x0012,0x3e40, +0x5ae3,0x4ed0,0x000c,0x3e30, +0x1a87,0x3460,0x0008,0x3e20, +0xaebe,0x782a,0x0005,0x3e10 +}; +#endif + +#ifdef MIEEE +static unsigned short azetac[] = { +0xbff8,0x0000,0x0000,0x0000, +0x7fef,0xffff,0xffff,0xffff, +0x3fe4,0xa34c,0xc4a6,0x0fa6, +0x3fc9,0xdd00,0x2780,0x310a, +0x3fb5,0x1322,0xac7d,0x8483, +0x3fa2,0xe831,0xd94f,0x99b7, +0x3f91,0xc261,0x3024,0x9124, +0x3f81,0x196d,0x0a67,0x9c47, +0x3f70,0xb36a,0xf863,0x96e9, +0x3f60,0x73e7,0xb02d,0x6ae0, +0x3f50,0x4b8c,0xe96e,0xe5f8, +0x3f40,0x318d,0xf245,0x9954, +0x3f30,0x20a5,0xb2cd,0x3042, +0x3f20,0x1593,0xa117,0x7bd6, +0x3f10,0x0e4a,0xf2b4,0xe156, +0x3f00,0x097b,0xcbf1,0x1bed, +0x3ef0,0x064c,0xdeb2,0x2f0f, +0x3ee0,0x0430,0x7368,0x6681, +0x3ed0,0x02c9,0x9537,0x44cc, +0x3ec0,0x01db,0x08f9,0xba4a, +0x3eb0,0x013c,0x5944,0x66ea, +0x3ea0,0x00d2,0xbab2,0x8121, +0x3e90,0x008c,0x66ce,0xc77d, +0x3e80,0x005d,0x8f13,0x858c, +0x3e70,0x003e,0x59ff,0xde12, +0x3e60,0x0029,0x8ea5,0x5633, +0x3e50,0x001b,0xb316,0xccda, +0x3e40,0x0012,0x76b9,0x0845, +0x3e30,0x000c,0x4ed0,0x5ae3, +0x3e20,0x0008,0x3460,0x1a87, +0x3e10,0x0005,0x782a,0xaebe +}; +#endif + + +/* 2**x (1 - 1/x) (zeta(x) - 1) = P(1/x)/Q(1/x), 1 <= x <= 10 */ +#ifdef UNK +static double P[9] = { + 5.85746514569725319540E11, + 2.57534127756102572888E11, + 4.87781159567948256438E10, + 5.15399538023885770696E9, + 3.41646073514754094281E8, + 1.60837006880656492731E7, + 5.92785467342109522998E5, + 1.51129169964938823117E4, + 2.01822444485997955865E2, +}; +static double Q[8] = { +/* 1.00000000000000000000E0,*/ + 3.90497676373371157516E11, + 5.22858235368272161797E10, + 5.64451517271280543351E9, + 3.39006746015350418834E8, + 1.79410371500126453702E7, + 5.66666825131384797029E5, + 1.60382976810944131506E4, + 1.96436237223387314144E2, +}; +#endif +#ifdef DEC +static unsigned short P[36] = { +0052010,0060466,0101211,0134657, +0051557,0154353,0135060,0064411, +0051065,0133157,0133514,0133633, +0050231,0114735,0035036,0111344, +0047242,0164327,0146036,0033545, +0046165,0065364,0130045,0011005, +0045020,0134427,0075073,0134107, +0043554,0021653,0000440,0177426, +0042111,0151213,0134312,0021402, +}; +static unsigned short Q[32] = { +/*0040200,0000000,0000000,0000000,*/ +0051665,0153363,0054252,0137010, +0051102,0143645,0121415,0036107, +0050250,0034073,0131133,0036465, +0047241,0123250,0150037,0070012, +0046210,0160426,0111463,0116507, +0045012,0054255,0031674,0173612, +0043572,0114460,0151520,0012221, +0042104,0067655,0037037,0137421, +}; +#endif +#ifdef IBMPC +static unsigned short P[36] = { +0x3736,0xd051,0x0c26,0x4261, +0x0d21,0x7746,0xfb1d,0x424d, +0x96f3,0xf6e9,0xb6cd,0x4226, +0xd25c,0xa743,0x333b,0x41f3, +0xc6ed,0xf983,0x5d1a,0x41b4, +0xa241,0x9604,0xad5e,0x416e, +0x7709,0xef47,0x1722,0x4122, +0x1fe3,0x6024,0x8475,0x40cd, +0x4460,0x7719,0x3a51,0x4069, +}; +static unsigned short Q[32] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x57c1,0x6b15,0xbade,0x4256, +0xa789,0xb461,0x58f4,0x4228, +0x67a7,0x764b,0x0707,0x41f5, +0xee01,0x1a03,0x34d5,0x41b4, +0x73a9,0xd266,0x1c22,0x4171, +0x9ef1,0xa677,0x4b15,0x4121, +0x0292,0x1a6a,0x5326,0x40cf, +0xf7e2,0xa7c3,0x8df5,0x4068, +}; +#endif +#ifdef MIEEE +static unsigned short P[36] = { +0x4261,0x0c26,0xd051,0x3736, +0x424d,0xfb1d,0x7746,0x0d21, +0x4226,0xb6cd,0xf6e9,0x96f3, +0x41f3,0x333b,0xa743,0xd25c, +0x41b4,0x5d1a,0xf983,0xc6ed, +0x416e,0xad5e,0x9604,0xa241, +0x4122,0x1722,0xef47,0x7709, +0x40cd,0x8475,0x6024,0x1fe3, +0x4069,0x3a51,0x7719,0x4460, +}; +static unsigned short Q[32] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4256,0xbade,0x6b15,0x57c1, +0x4228,0x58f4,0xb461,0xa789, +0x41f5,0x0707,0x764b,0x67a7, +0x41b4,0x34d5,0x1a03,0xee01, +0x4171,0x1c22,0xd266,0x73a9, +0x4121,0x4b15,0xa677,0x9ef1, +0x40cf,0x5326,0x1a6a,0x0292, +0x4068,0x8df5,0xa7c3,0xf7e2, +}; +#endif + +/* log(zeta(x) - 1 - 2**-x), 10 <= x <= 50 */ +#ifdef UNK +static double A[11] = { + 8.70728567484590192539E6, + 1.76506865670346462757E8, + 2.60889506707483264896E10, + 5.29806374009894791647E11, + 2.26888156119238241487E13, + 3.31884402932705083599E14, + 5.13778997975868230192E15, +-1.98123688133907171455E15, +-9.92763810039983572356E16, + 7.82905376180870586444E16, + 9.26786275768927717187E16, +}; +static double B[10] = { +/* 1.00000000000000000000E0,*/ +-7.92625410563741062861E6, +-1.60529969932920229676E8, +-2.37669260975543221788E10, +-4.80319584350455169857E11, +-2.07820961754173320170E13, +-2.96075404507272223680E14, +-4.86299103694609136686E15, + 5.34589509675789930199E15, + 5.71464111092297631292E16, +-1.79915597658676556828E16, +}; +#endif +#ifdef DEC +static unsigned short A[44] = { +0046004,0156325,0126302,0131567, +0047050,0052177,0015271,0136466, +0050702,0060271,0070727,0171112, +0051766,0132727,0064363,0145042, +0053245,0012466,0056000,0117230, +0054226,0166155,0174275,0170213, +0055222,0003127,0112544,0101322, +0154741,0036625,0010346,0053767, +0156260,0054653,0154052,0031113, +0056213,0011152,0021000,0007111, +0056244,0120534,0040576,0163262, +}; +static unsigned short B[40] = { +/*0040200,0000000,0000000,0000000,*/ +0145761,0161734,0033026,0015520, +0147031,0013743,0017355,0036703, +0150661,0011720,0061061,0136402, +0151737,0125216,0070274,0164414, +0153227,0032653,0127211,0145250, +0154206,0121666,0123774,0042035, +0155212,0033352,0125154,0132533, +0055227,0170201,0110775,0072132, +0056113,0003133,0127132,0122303, +0155577,0126351,0141462,0171037, +}; +#endif +#ifdef IBMPC +static unsigned short A[44] = { +0x566f,0xb598,0x9b9a,0x4160, +0x37a7,0xe357,0x0a8f,0x41a5, +0xfe49,0x2e3a,0x4c17,0x4218, +0x7944,0xed1e,0xd6ba,0x425e, +0x13d3,0xcb80,0xa2a6,0x42b4, +0xbe11,0xbf17,0xdd8d,0x42f2, +0x905a,0xf2ac,0x40ca,0x4332, +0xcaff,0xa21c,0x27b2,0xc31c, +0x4649,0x7b05,0x0b35,0xc376, +0x01c9,0x4440,0x624d,0x4371, +0xdcd6,0x882f,0x942b,0x4374, +}; +static unsigned short B[40] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0xc36a,0x86c2,0x3c7b,0xc15e, +0xa7b8,0x63dd,0x22fc,0xc1a3, +0x37a0,0x0c46,0x227a,0xc216, +0x9d22,0xce17,0xf551,0xc25b, +0x3955,0x75d1,0xe6b5,0xc2b2, +0x8884,0xd4ff,0xd476,0xc2f0, +0x96ab,0x554d,0x46dd,0xc331, +0xae8b,0x323f,0xfe10,0x4332, +0x5498,0x75cb,0x60cb,0x4369, +0x5e44,0x3866,0xf59d,0xc34f, +}; +#endif +#ifdef MIEEE +static unsigned short A[44] = { +0x4160,0x9b9a,0xb598,0x566f, +0x41a5,0x0a8f,0xe357,0x37a7, +0x4218,0x4c17,0x2e3a,0xfe49, +0x425e,0xd6ba,0xed1e,0x7944, +0x42b4,0xa2a6,0xcb80,0x13d3, +0x42f2,0xdd8d,0xbf17,0xbe11, +0x4332,0x40ca,0xf2ac,0x905a, +0xc31c,0x27b2,0xa21c,0xcaff, +0xc376,0x0b35,0x7b05,0x4649, +0x4371,0x624d,0x4440,0x01c9, +0x4374,0x942b,0x882f,0xdcd6, +}; +static unsigned short B[40] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0xc15e,0x3c7b,0x86c2,0xc36a, +0xc1a3,0x22fc,0x63dd,0xa7b8, +0xc216,0x227a,0x0c46,0x37a0, +0xc25b,0xf551,0xce17,0x9d22, +0xc2b2,0xe6b5,0x75d1,0x3955, +0xc2f0,0xd476,0xd4ff,0x8884, +0xc331,0x46dd,0x554d,0x96ab, +0x4332,0xfe10,0x323f,0xae8b, +0x4369,0x60cb,0x75cb,0x5498, +0xc34f,0xf59d,0x3866,0x5e44, +}; +#endif + +/* (1-x) (zeta(x) - 1), 0 <= x <= 1 */ + +#ifdef UNK +static double R[6] = { +-3.28717474506562731748E-1, + 1.55162528742623950834E1, +-2.48762831680821954401E2, + 1.01050368053237678329E3, + 1.26726061410235149405E4, +-1.11578094770515181334E5, +}; +static double S[5] = { +/* 1.00000000000000000000E0,*/ + 1.95107674914060531512E1, + 3.17710311750646984099E2, + 3.03835500874445748734E3, + 2.03665876435770579345E4, + 7.43853965136767874343E4, +}; +#endif +#ifdef DEC +static unsigned short R[24] = { +0137650,0046650,0022502,0040316, +0041170,0041222,0057666,0142216, +0142170,0141510,0167741,0075646, +0042574,0120074,0046505,0106053, +0043506,0001154,0130073,0101413, +0144331,0166414,0020560,0131652, +}; +static unsigned short S[20] = { +/*0040200,0000000,0000000,0000000,*/ +0041234,0013015,0042073,0113570, +0042236,0155353,0077325,0077445, +0043075,0162656,0016646,0031723, +0043637,0016454,0157636,0071126, +0044221,0044262,0140365,0146434, +}; +#endif +#ifdef IBMPC +static unsigned short R[24] = { +0x481a,0x04a8,0x09b5,0xbfd5, +0xd892,0x4bf6,0x0852,0x402f, +0x2f75,0x1dfc,0x1869,0xc06f, +0xb185,0x89a8,0x9407,0x408f, +0x7061,0x9607,0xc04d,0x40c8, +0x1675,0x842e,0x3da1,0xc0fb, +}; +static unsigned short S[20] = { +/*0x0000,0x0000,0x0000,0x3ff0,*/ +0x72ef,0xa887,0x82c1,0x4033, +0xafe5,0x6fda,0xdb5d,0x4073, +0xc67a,0xc3b4,0xbcb5,0x40a7, +0xce4b,0x9bf3,0xe3a5,0x40d3, +0xb9a3,0x581e,0x2916,0x40f2, +}; +#endif +#ifdef MIEEE +static unsigned short R[24] = { +0xbfd5,0x09b5,0x04a8,0x481a, +0x402f,0x0852,0x4bf6,0xd892, +0xc06f,0x1869,0x1dfc,0x2f75, +0x408f,0x9407,0x89a8,0xb185, +0x40c8,0xc04d,0x9607,0x7061, +0xc0fb,0x3da1,0x842e,0x1675, +}; +static unsigned short S[20] = { +/*0x3ff0,0x0000,0x0000,0x0000,*/ +0x4033,0x82c1,0xa887,0x72ef, +0x4073,0xdb5d,0x6fda,0xafe5, +0x40a7,0xbcb5,0xc3b4,0xc67a, +0x40d3,0xe3a5,0x9bf3,0xce4b, +0x40f2,0x2916,0x581e,0xb9a3, +}; +#endif + +#define MAXL2 127 + +/* + * Riemann zeta function, minus one + */ +#ifdef ANSIPROT +extern double sin ( double ); +extern double floor ( double ); +extern double gamma ( double ); +extern double pow ( double, double ); +extern double exp ( double ); +extern double polevl ( double, void *, int ); +extern double p1evl ( double, void *, int ); +double zetac ( double ); +#else +double sin(), floor(), gamma(), pow(), exp(); +double polevl(), p1evl(), zetac(); +#endif +extern double MACHEP; + +double zetac(x) +double x; +{ +int i; +double a, b, s, w; + +if( x < 0.0 ) + { +#ifdef DEC + if( x < -30.8148 ) +#else + if( x < -170.6243 ) +#endif + { + mtherr( "zetac", OVERFLOW ); + return(0.0); + } + s = 1.0 - x; + w = zetac( s ); + b = sin(0.5*PI*x) * pow(2.0*PI, x) * gamma(s) * (1.0 + w) / PI; + return(b - 1.0); + } + +if( x >= MAXL2 ) + return(0.0); /* because first term is 2**-x */ + +/* Tabulated values for integer argument */ +w = floor(x); +if( w == x ) + { + i = x; + if( i < 31 ) + { +#ifdef UNK + return( azetac[i] ); +#else + return( *(double *)&azetac[4*i] ); +#endif + } + } + + +if( x < 1.0 ) + { + w = 1.0 - x; + a = polevl( x, R, 5 ) / ( w * p1evl( x, S, 5 )); + return( a ); + } + +if( x == 1.0 ) + { + mtherr( "zetac", SING ); + return( MAXNUM ); + } + +if( x <= 10.0 ) + { + b = pow( 2.0, x ) * (x - 1.0); + w = 1.0/x; + s = (x * polevl( w, P, 8 )) / (b * p1evl( w, Q, 8 )); + return( s ); + } + +if( x <= 50.0 ) + { + b = pow( 2.0, -x ); + w = polevl( x, A, 10 ) / p1evl( x, B, 10 ); + w = exp(w) + b; + return(w); + } + + +/* Basic sum of inverse powers */ + + +s = 0.0; +a = 1.0; +do + { + a += 2.0; + b = pow( a, -x ); + s += b; + } +while( b/s > MACHEP ); + +b = pow( 2.0, -x ); +s = (s + b)/(1.0-b); +return(s); +} diff --git a/libm/float/Makefile b/libm/float/Makefile new file mode 100644 index 000000000..389ac1a5d --- /dev/null +++ b/libm/float/Makefile @@ -0,0 +1,62 @@ +# 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= acoshf.c airyf.c asinf.c asinhf.c atanf.c \ + atanhf.c bdtrf.c betaf.c cbrtf.c chbevlf.c chdtrf.c \ + clogf.c cmplxf.c constf.c coshf.c dawsnf.c ellief.c \ + ellikf.c ellpef.c ellpkf.c ellpjf.c expf.c exp2f.c \ + exp10f.c expnf.c facf.c fdtrf.c floorf.c fresnlf.c \ + gammaf.c gdtrf.c hypergf.c hyp2f1f.c igamf.c igamif.c \ + incbetf.c incbif.c i0f.c i1f.c ivf.c j0f.c j1f.c \ + jnf.c jvf.c k0f.c k1f.c knf.c logf.c log2f.c \ + log10f.c nbdtrf.c ndtrf.c ndtrif.c pdtrf.c polynf.c \ + powif.c powf.c psif.c rgammaf.c shichif.c sicif.c \ + sindgf.c sinf.c sinhf.c spencef.c sqrtf.c stdtrf.c \ + struvef.c tandgf.c tanf.c tanhf.c ynf.c zetaf.c \ + zetacf.c polevlf.c setprec.c mtherr.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 + diff --git a/libm/float/README.txt b/libm/float/README.txt new file mode 100644 index 000000000..30a10b083 --- /dev/null +++ b/libm/float/README.txt @@ -0,0 +1,4721 @@ +/* acoshf.c + * + * Inverse hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * float x, y, acoshf(); + * + * y = acoshf( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a polynomial approximation + * + * sqrt(z) * P(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 100000 1.8e-7 3.9e-8 + * IEEE 1,2000 100000 3.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acoshf domain |x| < 1 0.0 + * + */ + +/* airy.c + * + * Airy function + * + * + * + * SYNOPSIS: + * + * float x, ai, aip, bi, bip; + * int airyf(); + * + * airyf( x, _&ai, _&aip, _&bi, _&bip ); + * + * + * + * DESCRIPTION: + * + * Solution of the differential equation + * + * y"(x) = xy. + * + * The function returns the two independent solutions Ai, Bi + * and their first derivatives Ai'(x), Bi'(x). + * + * Evaluation is by power series summation for small x, + * by rational minimax approximations for large x. + * + * + * + * ACCURACY: + * Error criterion is absolute when function <= 1, relative + * when function > 1, except * denotes relative error criterion. + * For large negative x, the absolute error increases as x^1.5. + * For large positive x, the relative error increases as x^1.5. + * + * Arithmetic domain function # trials peak rms + * IEEE -10, 0 Ai 50000 7.0e-7 1.2e-7 + * IEEE 0, 10 Ai 50000 9.9e-6* 6.8e-7* + * IEEE -10, 0 Ai' 50000 2.4e-6 3.5e-7 + * IEEE 0, 10 Ai' 50000 8.7e-6* 6.2e-7* + * IEEE -10, 10 Bi 100000 2.2e-6 2.6e-7 + * IEEE -10, 10 Bi' 50000 2.2e-6 3.5e-7 + * + */ + +/* asinf.c + * + * Inverse circular sine + * + * + * + * SYNOPSIS: + * + * float x, y, asinf(); + * + * y = asinf( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose sine is x. + * + * A polynomial of the form x + x**3 P(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 100000 2.5e-7 5.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asinf domain |x| > 1 0.0 + * + */ + /* acosf() + * + * Inverse circular cosine + * + * + * + * SYNOPSIS: + * + * float x, y, acosf(); + * + * y = acosf( 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 100000 1.4e-7 4.2e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acosf domain |x| > 1 0.0 + */ + +/* asinhf.c + * + * Inverse hyperbolic sine + * + * + * + * SYNOPSIS: + * + * float x, y, asinhf(); + * + * y = asinhf( 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 100000 2.4e-7 4.1e-8 + * + */ + +/* atanf.c + * + * Inverse circular tangent + * (arctangent) + * + * + * + * SYNOPSIS: + * + * float x, y, atanf(); + * + * y = atanf( 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 ). A polynomial approximates + * the function in this basic interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 100000 1.9e-7 4.1e-8 + * + */ + /* atan2f() + * + * Quadrant correct inverse circular tangent + * + * + * + * SYNOPSIS: + * + * float x, y, z, atan2f(); + * + * z = atan2f( 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 100000 1.9e-7 4.1e-8 + * See atan.c. + * + */ + +/* atanhf.c + * + * Inverse hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * float x, y, atanhf(); + * + * y = atanhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOGF to MAXLOGF. + * + * If |x| < 0.5, a polynomial approximation is used. + * Otherwise, + * atanh(x) = 0.5 * log( (1+x)/(1-x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1,1 100000 1.4e-7 3.1e-8 + * + */ + +/* bdtrf.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrf(); + * + * y = bdtrf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 6.9e-5 1.1e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrf domain k < 0 0.0 + * n < k + * x < 0, x > 1 + * + */ + /* bdtrcf() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrcf(); + * + * y = bdtrcf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 6.0e-5 1.2e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrcf domain x<0, x>1, n<k 0.0 + */ + /* bdtrif() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrif(); + * + * p = bdtrf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 3.5e-5 3.3e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrif domain k < 0, n <= k 0.0 + * x < 0, x > 1 + * + */ + +/* betaf.c + * + * Beta function + * + * + * + * SYNOPSIS: + * + * float a, b, y, betaf(); + * + * y = betaf( a, b ); + * + * + * + * DESCRIPTION: + * + * - - + * | (a) | (b) + * beta( a, b ) = -----------. + * - + * | (a+b) + * + * For large arguments the logarithm of the function is + * evaluated using lgam(), then exponentiated. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 10000 4.0e-5 6.0e-6 + * IEEE -20,0 10000 4.9e-3 5.4e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * betaf overflow log(beta) > MAXLOG 0.0 + * a or b <0 integer 0.0 + * + */ + +/* cbrtf.c + * + * Cube root + * + * + * + * SYNOPSIS: + * + * float x, y, cbrtf(); + * + * y = cbrtf( 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 to converge to an accurate result. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1e38 100000 7.6e-8 2.7e-8 + * + */ + +/* chbevlf.c + * + * Evaluate Chebyshev series + * + * + * + * SYNOPSIS: + * + * int N; + * float x, y, coef[N], chebevlf(); + * + * y = chbevlf( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates the series + * + * N-1 + * - ' + * y = > coef[i] T (x/2) + * - i + * i=0 + * + * of Chebyshev polynomials Ti at argument x/2. + * + * Coefficients are stored in reverse order, i.e. the zero + * order term is last in the array. Note N is the number of + * coefficients, not the order. + * + * If coefficients are for the interval a to b, x must + * have been transformed to x -> 2(2x - b - a)/(b-a) before + * entering the routine. This maps x from (a, b) to (-1, 1), + * over which the Chebyshev polynomials are defined. + * + * If the coefficients are for the inverted interval, in + * which (a, b) is mapped to (1/b, 1/a), the transformation + * required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity, + * this becomes x -> 4a/x - 1. + * + * + * + * SPEED: + * + * Taking advantage of the recurrence properties of the + * Chebyshev polynomials, the routine requires one more + * addition per loop than evaluating a nested polynomial of + * the same degree. + * + */ + +/* chdtrf.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float df, x, y, chdtrf(); + * + * y = chdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 3.2e-5 5.0e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrf domain x < 0 or v < 1 0.0 + */ + /* chdtrcf() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float v, x, y, chdtrcf(); + * + * y = chdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 2.7e-5 3.2e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrc domain x < 0 or v < 1 0.0 + */ + /* chdtrif() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float df, x, y, chdtrif(); + * + * x = chdtrif( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 10000 2.2e-5 8.5e-7 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtri domain y < 0 or y > 1 0.0 + * v < 1 + * + */ + +/* clogf.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clogf(); + * cmplxf z, w; + * + * clogf( &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 + * IEEE -10,+10 30000 1.9e-6 6.2e-8 + * + * Larger relative error can be observed for z near 1 +i0. + * In IEEE arithmetic the peak absolute error is 3.1e-7. + * + */ + /* cexpf() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexpf(); + * cmplxf z, w; + * + * cexpf( &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 + * IEEE -10,+10 30000 1.4e-7 4.5e-8 + * + */ + /* csinf() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csinf(); + * cmplxf z, w; + * + * csinf( &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 + * IEEE -10,+10 30000 1.9e-7 5.5e-8 + * + */ + /* ccosf() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccosf(); + * cmplxf z, w; + * + * ccosf( &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 + * IEEE -10,+10 30000 1.8e-7 5.5e-8 + */ + /* ctanf() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctanf(); + * cmplxf z, w; + * + * ctanf( &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 + * IEEE -10,+10 30000 3.3e-7 5.1e-8 + */ + /* ccotf() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccotf(); + * cmplxf z, w; + * + * ccotf( &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 + * IEEE -10,+10 30000 3.6e-7 5.7e-8 + * Also tested by ctan * ccot = 1 + i0. + */ + /* casinf() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casinf(); + * cmplxf z, w; + * + * casinf( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Inverse complex sine: + * + * 2 + * w = -i clog( iz + csqrt( 1 - z ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 1.1e-5 1.5e-6 + * Larger relative error can be observed for z near zero. + * + */ + /* cacosf() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacosf(); + * cmplxf z, w; + * + * cacosf( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * w = arccos z = PI/2 - arcsin z. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 9.2e-6 1.2e-6 + * + */ + /* catan() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catan(); + * cmplxf z, w; + * + * catan( &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 + * IEEE -10,+10 30000 2.3e-6 5.2e-8 + * + */ + +/* cmplxf.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * float r; real part + * float i; imaginary part + * }cmplxf; + * + * cmplxf *a, *b, *c; + * + * caddf( a, b, c ); c = b + a + * csubf( a, b, c ); c = b - a + * cmulf( a, b, c ); c = b * a + * cdivf( a, b, c ); c = b / a + * cnegf( c ); c = -c + * cmovf( 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 + * IEEE cadd 30000 5.9e-8 2.6e-8 + * IEEE csub 30000 6.0e-8 2.6e-8 + * IEEE cmul 30000 1.1e-7 3.7e-8 + * IEEE cdiv 30000 2.1e-7 5.7e-8 + */ + +/* cabsf() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * float cabsf(); + * cmplxf z; + * float a; + * + * a = cabsf( &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 + * IEEE -10,+10 30000 1.2e-7 3.4e-8 + */ + /* csqrtf() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrtf(); + * cmplxf z, w; + * + * csqrtf( &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 solution + * reported 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 + * IEEE -10,+10 100000 1.8e-7 4.2e-8 + * + */ + +/* coshf.c + * + * Hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * float x, y, coshf(); + * + * y = coshf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOGF to + * MAXLOGF. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-MAXLOGF 100000 1.2e-7 2.8e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * coshf overflow |x| > MAXLOGF MAXNUMF + * + * + */ + +/* dawsnf.c + * + * Dawson's Integral + * + * + * + * SYNOPSIS: + * + * float x, y, dawsnf(); + * + * y = dawsnf( x ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * x + * - + * 2 | | 2 + * dawsn(x) = exp( -x ) | exp( t ) dt + * | | + * - + * 0 + * + * Three different rational approximations are employed, for + * the intervals 0 to 3.25; 3.25 to 6.25; and 6.25 up. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 50000 4.4e-7 6.3e-8 + * + * + */ + +/* ellief.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * float phi, m, y, ellief(); + * + * y = ellief( 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 [0, 2] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,2 10000 4.5e-7 7.4e-8 + * + * + */ + +/* ellikf.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * float phi, m, y, ellikf(); + * + * y = ellikf( 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 phi in [0, 2] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,2 10000 2.9e-7 5.8e-8 + * + * + */ + +/* ellpef.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * float m1, y, ellpef(); + * + * y = ellpef( 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 30000 1.1e-7 3.9e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpef domain x<0, x>1 0.0 + * + */ + +/* ellpjf.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * float u, m, sn, cn, dn, phi; + * int ellpj(); + * + * ellpj( 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-9 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-6 2.2e-7 + * IEEE cn 10000 1.6e-6 2.2e-7 + * IEEE dn 10000 1.4e-3 1.9e-5 + * IEEE phi 10000 3.9e-7* 6.7e-8* + * + * Peak error observed in consistency check using addition + * theorem for sn(u+v) was 4e-16 (absolute). Also tested by + * the above relation to the incomplete elliptic integral. + * Accuracy deteriorates when u is large. + * + */ + +/* ellpkf.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * float m1, y, ellpkf(); + * + * y = ellpkf( 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 30000 1.3e-7 3.4e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpkf domain x<0, x>1 0.0 + * + */ + +/* exp10f.c + * + * Base 10 exponential function + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * float x, y, exp10f(); + * + * y = exp10f( 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). + * A polynomial approximates 10**f. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -38,+38 100000 9.8e-8 2.8e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10 underflow x < -MAXL10 0.0 + * exp10 overflow x > MAXL10 MAXNUM + * + * IEEE single arithmetic: MAXL10 = 38.230809449325611792. + * + */ + +/* exp2f.c + * + * Base 2 exponential function + * + * + * + * SYNOPSIS: + * + * float x, y, exp2f(); + * + * y = exp2f( 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 polynomial approximates 2**x in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -127,+127 100000 1.7e-7 2.8e-8 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < -MAXL2 0.0 + * exp overflow x > MAXL2 MAXNUMF + * + * For IEEE arithmetic, MAXL2 = 127. + */ + +/* expf.c + * + * Exponential function + * + * + * + * SYNOPSIS: + * + * float x, y, expf(); + * + * y = expf( 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 polynomial is used to approximate exp(f) + * in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +- MAXLOG 100000 1.7e-7 2.8e-8 + * + * + * 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 double precision + * computer number, the result contains amplified roundoff + * error for large arguments not exactly represented. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * expf underflow x < MINLOGF 0.0 + * expf overflow x > MAXLOGF MAXNUMF + * + */ + +/* expnf.c + * + * Exponential integral En + * + * + * + * SYNOPSIS: + * + * int n; + * float x, y, expnf(); + * + * y = expnf( n, x ); + * + * + * + * DESCRIPTION: + * + * Evaluates the exponential integral + * + * inf. + * - + * | | -xt + * | e + * E (x) = | ---- dt. + * n | n + * | | t + * - + * 1 + * + * + * Both n and x must be nonnegative. + * + * The routine employs either a power series, a continued + * fraction, or an asymptotic formula depending on the + * relative values of n and x. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 10000 5.6e-7 1.2e-7 + * + */ + +/* facf.c + * + * Factorial function + * + * + * + * SYNOPSIS: + * + * float y, facf(); + * int i; + * + * y = facf( i ); + * + * + * + * DESCRIPTION: + * + * Returns factorial of i = 1 * 2 * 3 * ... * i. + * fac(0) = 1.0. + * + * Due to machine arithmetic bounds the largest value of + * i accepted is 33 in single precision arithmetic. + * Greater values, or negative ones, + * produce an error message and return MAXNUM. + * + * + * + * ACCURACY: + * + * For i < 34 the values are simply tabulated, and have + * full machine accuracy. + * + */ + +/* fdtrf.c + * + * F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * float x, y, fdtrf(); + * + * y = fdtrf( 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) = incbet( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x + * x is nonnegative. + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 2.2e-5 1.1e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrf domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrcf() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * float x, y, fdtrcf(); + * + * y = fdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 7.3e-5 1.2e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrcf domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrif() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * float df1, df2, x, y, fdtrif(); + * + * x = fdtrif( df1, df2, y ); + * + * + * + * + * 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 y. + * + * This is accomplished using the inverse beta integral + * function and the relations + * + * z = incbi( df2/2, df1/2, y ) + * 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, y ) + * x = df2 z / (df1 (1-z)). + * + * + * + * ACCURACY: + * + * arithmetic domain # trials peak rms + * Absolute error: + * IEEE 0,100 5000 4.0e-5 3.2e-6 + * Relative error: + * IEEE 0,100 5000 1.2e-3 1.8e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrif domain y <= 0 or y > 1 0.0 + * v < 1 + * + */ + +/* ceilf() + * floorf() + * frexpf() + * ldexpf() + * + * Single precision floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * float x, y; + * float ceilf(), floorf(), frexpf(), ldexpf(); + * int expnt, n; + * + * y = floorf(x); + * y = ceilf(x); + * y = frexpf( x, &expnt ); + * y = ldexpf( x, n ); + * + * + * + * DESCRIPTION: + * + * All four routines return a single precision floating point + * result. + * + * sfloor() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * sceil() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * sfrexp() 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. + * + * sldexp() multiplies x by 2**n. + * + * These functions are part of the standard C run time library + * for many but not all C compilers. The ones supplied are + * written in C for either DEC or 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. + */ + +/* fresnlf.c + * + * Fresnel integral + * + * + * + * SYNOPSIS: + * + * float x, S, C; + * void fresnlf(); + * + * fresnlf( x, _&S, _&C ); + * + * + * DESCRIPTION: + * + * Evaluates the Fresnel integrals + * + * x + * - + * | | + * C(x) = | cos(pi/2 t**2) dt, + * | | + * - + * 0 + * + * x + * - + * | | + * S(x) = | sin(pi/2 t**2) dt. + * | | + * - + * 0 + * + * + * The integrals are evaluated by power series for small x. + * For x >= 1 auxiliary functions f(x) and g(x) are employed + * such that + * + * C(x) = 0.5 + f(x) sin( pi/2 x**2 ) - g(x) cos( pi/2 x**2 ) + * S(x) = 0.5 - f(x) cos( pi/2 x**2 ) - g(x) sin( pi/2 x**2 ) + * + * + * + * ACCURACY: + * + * Relative error. + * + * Arithmetic function domain # trials peak rms + * IEEE S(x) 0, 10 30000 1.1e-6 1.9e-7 + * IEEE C(x) 0, 10 30000 1.1e-6 2.0e-7 + */ + +/* gammaf.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, gammaf(); + * extern int sgngamf; + * + * y = gammaf( 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 sgngamf. + * This same variable is also filled in by the logarithmic + * gamma function lgam(). + * + * Arguments between 0 and 10 are reduced by recurrence and the + * function is approximated by a polynomial function covering + * the interval (2,3). Large arguments are handled by Stirling's + * formula. Negative arguments are made positive using + * a reflection formula. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,-33 100,000 5.7e-7 1.0e-7 + * IEEE -33,0 100,000 6.1e-7 1.2e-7 + * + * + */ +/* lgamf() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, lgamf(); + * extern int sgngamf; + * + * y = lgamf( 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 sgngamf. + * + * For arguments greater than 6.5, the logarithm of the gamma + * function is approximated by the logarithmic version of + * Stirling's formula. Arguments between 0 and +6.5 are reduced by + * by recurrence to the interval [.75,1.25] or [1.5,2.5] of a rational + * approximation. The cosecant reflection formula is employed for + * arguments less than zero. + * + * Arguments greater than MAXLGM = 2.035093e36 return MAXNUM and an + * error message. + * + * + * + * ACCURACY: + * + * + * + * arithmetic domain # trials peak rms + * IEEE -100,+100 500,000 7.4e-7 6.8e-8 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * The routine has low relative error for positive arguments. + * + * The following test used the relative error criterion. + * IEEE -2, +3 100000 4.0e-7 5.6e-8 + * + */ + +/* gdtrf.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, gdtrf(); + * + * y = gdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 5.8e-5 3.0e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrf domain x < 0 0.0 + * + */ + /* gdtrcf.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, gdtrcf(); + * + * y = gdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 9.1e-5 1.5e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrcf domain x < 0 0.0 + * + */ + +/* hyp2f1f.c + * + * Gauss hypergeometric function F + * 2 1 + * + * + * SYNOPSIS: + * + * float a, b, c, x, y, hyp2f1f(); + * + * y = hyp2f1f( a, b, c, x ); + * + * + * DESCRIPTION: + * + * + * hyp2f1( a, b, c, x ) = F ( a, b; c; x ) + * 2 1 + * + * inf. + * - a(a+1)...(a+k) b(b+1)...(b+k) k+1 + * = 1 + > ----------------------------- x . + * - c(c+1)...(c+k) (k+1)! + * k = 0 + * + * Cases addressed are + * Tests and escapes for negative integer a, b, or c + * Linear transformation if c - a or c - b negative integer + * Special case c = a or c = b + * Linear transformation for x near +1 + * Transformation for x < -0.5 + * Psi function expansion if x > 0.5 and c - a - b integer + * Conditionally, a recurrence on c to make c-a-b > 0 + * + * |x| > 1 is rejected. + * + * The parameters a, b, c are considered to be integer + * valued if they are within 1.0e-6 of the nearest integer. + * + * ACCURACY: + * + * Relative error (-1 < x < 1): + * arithmetic domain # trials peak rms + * IEEE 0,3 30000 5.8e-4 4.3e-6 + */ + +/* hypergf.c + * + * Confluent hypergeometric function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, hypergf(); + * + * y = hypergf( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Computes the confluent hypergeometric function + * + * 1 2 + * a x a(a+1) x + * F ( a,b;x ) = 1 + ---- + --------- + ... + * 1 1 b 1! b(b+1) 2! + * + * Many higher transcendental functions are special cases of + * this power series. + * + * As is evident from the formula, b must not be a negative + * integer or zero unless a is an integer with 0 >= a > b. + * + * The routine attempts both a direct summation of the series + * and an asymptotic expansion. In each case error due to + * roundoff, cancellation, and nonconvergence is estimated. + * The result with smaller estimated error is returned. + * + * + * + * ACCURACY: + * + * Tested at random points (a, b, x), all three variables + * ranging from 0 to 30. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,5 10000 6.6e-7 1.3e-7 + * IEEE 0,30 30000 1.1e-5 6.5e-7 + * + * Larger errors can be observed when b is near a negative + * integer or zero. Certain combinations of arguments yield + * serious cancellation error in the power series summation + * and also are not in the region of near convergence of the + * asymptotic series. An error message is printed if the + * self-estimated relative error is greater than 1.0e-3. + * + */ + +/* i0f.c + * + * Modified Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * float x, y, i0(); + * + * y = i0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order zero of the + * argument. + * + * The function is defined as i0(x) = j0( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 100000 4.0e-7 7.9e-8 + * + */ + /* i0ef.c + * + * Modified Bessel function of order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, i0ef(); + * + * y = i0ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order zero of the argument. + * + * The function is defined as i0e(x) = exp(-|x|) j0( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 100000 3.7e-7 7.0e-8 + * See i0f(). + * + */ + +/* i1f.c + * + * Modified Bessel function of order one + * + * + * + * SYNOPSIS: + * + * float x, y, i1f(); + * + * y = i1f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order one of the + * argument. + * + * The function is defined as i1(x) = -i j1( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 1.5e-6 1.6e-7 + * + * + */ + /* i1ef.c + * + * Modified Bessel function of order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, i1ef(); + * + * y = i1ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order one of the argument. + * + * The function is defined as i1(x) = -i exp(-|x|) j1( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 1.5e-6 1.5e-7 + * See i1(). + * + */ + +/* igamf.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamf(); + * + * y = igamf( 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 + * IEEE 0,30 20000 7.8e-6 5.9e-7 + * + */ + /* igamcf() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamcf(); + * + * y = igamcf( 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 + * IEEE 0,30 30000 7.8e-6 5.9e-7 + * + */ + +/* igamif() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamif(); + * + * x = igamif( 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 to 100 and x from 0 to 1. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.0e-5 1.5e-6 + * + */ + +/* incbetf.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * float a, b, x, y, incbetf(); + * + * y = incbetf( 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. + * If a < 1, the function calls itself recursively after a + * transformation to increase a to a+1. + * + * ACCURACY: + * + * Tested at random points (a,b,x) with a and b in the indicated + * interval and x between 0 and 1. + * + * arithmetic domain # trials peak rms + * Relative error: + * IEEE 0,30 10000 3.7e-5 5.1e-6 + * IEEE 0,100 10000 1.7e-4 2.5e-5 + * The useful domain for relative error is limited by underflow + * of the single precision exponential function. + * Absolute error: + * IEEE 0,30 100000 2.2e-5 9.6e-7 + * IEEE 0,100 10000 6.5e-5 3.7e-6 + * + * Larger errors may occur for extreme ratios of a and b. + * + * ERROR MESSAGES: + * message condition value returned + * incbetf domain x<0, x>1 0.0 + */ + +/* incbif() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, incbif(); + * + * x = incbif( 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 0,100 5000 2.8e-4 8.3e-6 + * + * Overflow and larger errors may occur for one of a or b near zero + * and the other large. + */ + +/* ivf.c + * + * Modified Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * float v, x, y, ivf(); + * + * y = ivf( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order v of the + * argument. If x is negative, v must be integer valued. + * + * The function is defined as Iv(x) = Jv( ix ). It is + * here computed in terms of the confluent hypergeometric + * function, according to the formula + * + * v -x + * Iv(x) = (x/2) e hyperg( v+0.5, 2v+1, 2x ) / gamma(v+1) + * + * If v is a negative integer, then v is replaced by -v. + * + * + * ACCURACY: + * + * Tested at random points (v, x), with v between 0 and + * 30, x between 0 and 28. + * arithmetic domain # trials peak rms + * Relative error: + * IEEE 0,15 3000 4.7e-6 5.4e-7 + * Absolute error (relative when function > 1) + * IEEE 0,30 5000 8.5e-6 1.3e-6 + * + * Accuracy is diminished if v is near a negative integer. + * The useful domain for relative error is limited by overflow + * of the single precision exponential function. + * + * See also hyperg.c. + * + */ + +/* j0f.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * float x, y, j0f(); + * + * y = j0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order zero of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval the following polynomial + * approximation is used: + * + * + * 2 2 2 + * (w - r ) (w - r ) (w - r ) P(w) + * 1 2 3 + * + * 2 + * where w = x and the three r's are zeros of the function. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x R(1/x^2) - pi/4. The function is + * + * j0(x) = Modulus(x) cos( Phase(x) ). + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 1.3e-7 3.6e-8 + * IEEE 2, 32 100000 1.9e-7 5.4e-8 + * + */ + /* y0f.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * float x, y, y0f(); + * + * y = y0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * + * 2 2 2 + * y0(x) = (w - r ) (w - r ) (w - r ) R(x) + 2/pi ln(x) j0(x). + * 1 2 3 + * + * Thus a call to j0() is required. The three zeros are removed + * from R(x) to improve its numerical stability. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x S(1/x^2) - pi/4. Then the function is + * + * y0(x) = Modulus(x) sin( Phase(x) ). + * + * + * + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 2.4e-7 3.4e-8 + * IEEE 2, 32 100000 1.8e-7 5.3e-8 + * + */ + +/* j1f.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * float x, y, j1f(); + * + * y = j1f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a polynomial approximation + * 2 + * (w - r ) x P(w) + * 1 + * 2 + * is used, where w = x and r is the first zero of the function. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x R(1/x^2) - 3pi/4. The function is + * + * j0(x) = Modulus(x) cos( Phase(x) ). + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 1.2e-7 2.5e-8 + * IEEE 2, 32 100000 2.0e-7 5.3e-8 + * + * + */ + /* y1.c + * + * Bessel function of second kind of order one + * + * + * + * SYNOPSIS: + * + * double x, y, y1(); + * + * y = y1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind of order one + * of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * + * 2 + * y0(x) = (w - r ) x R(x^2) + 2/pi (ln(x) j1(x) - 1/x) . + * 1 + * + * Thus a call to j1() is required. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x S(1/x^2) - 3pi/4. Then the function is + * + * y0(x) = Modulus(x) sin( Phase(x) ). + * + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 2.2e-7 4.6e-8 + * IEEE 2, 32 100000 1.9e-7 5.3e-8 + * + * (error criterion relative when |y1| > 1). + * + */ + +/* jnf.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * float x, y, jnf(); + * + * y = jnf( 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 range # trials peak rms + * IEEE 0, 15 30000 3.6e-7 3.6e-8 + * + * + * Not suitable for large n or x. Use jvf() instead. + * + */ + +/* jvf.c + * + * Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * float v, x, y, jvf(); + * + * y = jvf( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order v of the argument, + * where v is real. Negative x is allowed if v is an integer. + * + * Several expansions are included: the ascending power + * series, the Hankel expansion, and two transitional + * expansions for large v. If v is not too large, it + * is reduced by recurrence to a region of best accuracy. + * + * The single precision routine accepts negative v, but with + * reduced accuracy. + * + * + * + * ACCURACY: + * Results for integer v are indicated by *. + * Error criterion is absolute, except relative when |jv()| > 1. + * + * arithmetic domain # trials peak rms + * v x + * IEEE 0,125 0,125 30000 2.0e-6 2.0e-7 + * IEEE -17,0 0,125 30000 1.1e-5 4.0e-7 + * IEEE -100,0 0,125 3000 1.5e-4 7.8e-6 + */ + +/* k0f.c + * + * Modified Bessel function, third kind, order zero + * + * + * + * SYNOPSIS: + * + * float x, y, k0f(); + * + * y = k0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order zero of the argument. + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Tested at 2000 random points between 0 and 8. Peak absolute + * error (relative when K0 > 1) was 1.46e-14; rms, 4.26e-15. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 7.8e-7 8.5e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * K0 domain x <= 0 MAXNUM + * + */ + /* k0ef() + * + * Modified Bessel function, third kind, order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, k0ef(); + * + * y = k0ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order zero of the argument. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 8.1e-7 7.8e-8 + * See k0(). + * + */ + +/* k1f.c + * + * Modified Bessel function, third kind, order one + * + * + * + * SYNOPSIS: + * + * float x, y, k1f(); + * + * y = k1f( x ); + * + * + * + * DESCRIPTION: + * + * Computes the modified Bessel function of the third kind + * of order one of the argument. + * + * The range is partitioned into the two intervals [0,2] and + * (2, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 4.6e-7 7.6e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * k1 domain x <= 0 MAXNUM + * + */ + /* k1ef.c + * + * Modified Bessel function, third kind, order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, k1ef(); + * + * y = k1ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order one of the argument: + * + * k1e(x) = exp(x) * k1(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 4.9e-7 6.7e-8 + * See k1(). + * + */ + +/* knf.c + * + * Modified Bessel function, third kind, integer order + * + * + * + * SYNOPSIS: + * + * float x, y, knf(); + * int n; + * + * y = knf( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order n of the argument. + * + * The range is partitioned into the two intervals [0,9.55] and + * (9.55, infinity). An ascending power series is used in the + * low range, and an asymptotic expansion in the high range. + * + * + * + * ACCURACY: + * + * Absolute error, relative when function > 1: + * arithmetic domain # trials peak rms + * IEEE 0,30 10000 2.0e-4 3.8e-6 + * + * Error is high only near the crossover point x = 9.55 + * between the two expansions used. + */ + +/* log10f.c + * + * Common logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, log10f(); + * + * y = log10f( x ); + * + * + * + * DESCRIPTION: + * + * Returns logarithm to the base 10 of x. + * + * The argument is separated into its exponent and fractional + * parts. The logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 100000 1.3e-7 3.4e-8 + * IEEE 0, MAXNUMF 100000 1.3e-7 2.6e-8 + * + * In the tests over the interval [0, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [-MAXL10, MAXL10]. + * + * ERROR MESSAGES: + * + * log10f singularity: x = 0; returns -MAXL10 + * log10f domain: x < 0; returns -MAXL10 + * MAXL10 = 38.230809449325611792 + */ + +/* log2f.c + * + * Base 2 logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, log2f(); + * + * y = log2f( 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 base e + * 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 exp(+-88) 100000 1.1e-7 2.4e-8 + * IEEE 0.5, 2.0 100000 1.1e-7 3.0e-8 + * + * In the tests over the interval [exp(+-88)], the logarithms + * of the random arguments were uniformly distributed. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOGF/log(2) + * log domain: x < 0; returns MINLOGF/log(2) + */ + +/* logf.c + * + * Natural logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, logf(); + * + * y = logf( 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) + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 100000 7.6e-8 2.7e-8 + * IEEE 1, MAXNUMF 100000 2.6e-8 + * + * In the tests over the interval [1, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOGF]. + * + * ERROR MESSAGES: + * + * logf singularity: x = 0; returns MINLOG + * logf domain: x < 0; returns MINLOG + */ + +/* mtherr.c + * + * Library common error handling routine + * + * + * + * SYNOPSIS: + * + * char *fctnam; + * int code; + * void mtherr(); + * + * mtherr( fctnam, code ); + * + * + * + * DESCRIPTION: + * + * This routine may be called to report one of the following + * error conditions (in the include file math.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: + * + * math.h + * + */ + +/* nbdtrf.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, nbdtrf(); + * + * y = nbdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.5e-4 1.9e-5 + * + */ + /* nbdtrcf.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, nbdtrcf(); + * + * y = nbdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.4e-4 2.0e-5 + * + */ + +/* ndtrf.c + * + * Normal distribution function + * + * + * + * SYNOPSIS: + * + * float x, y, ndtrf(); + * + * y = ndtrf( 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 50000 1.5e-5 2.6e-6 + * + * + * ERROR MESSAGES: + * + * See erfcf(). + * + */ + /* erff.c + * + * Error function + * + * + * + * SYNOPSIS: + * + * float x, y, erff(); + * + * y = erff( x ); + * + * + * + * DESCRIPTION: + * + * The integral is + * + * x + * - + * 2 | | 2 + * erf(x) = -------- | exp( - t ) dt. + * sqrt(pi) | | + * - + * 0 + * + * The magnitude of x is limited to 9.231948545 for DEC + * arithmetic; 1 or -1 is returned outside this range. + * + * For 0 <= |x| < 1, erf(x) = x * P(x**2); otherwise + * erf(x) = 1 - erfc(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -9.3,9.3 50000 1.7e-7 2.8e-8 + * + */ + /* erfcf.c + * + * Complementary error function + * + * + * + * SYNOPSIS: + * + * float x, y, erfcf(); + * + * y = erfcf( 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 polynomial + * approximations 1/x P(1/x**2) are computed. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -9.3,9.3 50000 3.9e-6 7.2e-7 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfcf underflow x**2 > MAXLOGF 0.0 + * + * + */ + +/* ndtrif.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * float x, y, ndtrif(); + * + * x = ndtrif( 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.0 * log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). + * There are two rational functions P/Q, one for 0 < y < exp(-32) + * and the other for y up to exp(-2). For larger arguments, + * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1e-38, 1 30000 3.6e-7 5.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtrif domain x <= 0 -MAXNUM + * ndtrif domain x >= 1 MAXNUM + * + */ + +/* pdtrf.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrf(); + * + * y = pdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 6.9e-5 8.0e-6 + * + */ + /* pdtrcf() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrcf(); + * + * y = pdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 8.4e-5 1.2e-5 + * + */ + /* pdtrif() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrf(); + * + * m = pdtrif( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 8.7e-6 1.4e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * pdtri domain y < 0 or y >= 1 0.0 + * k < 0 + * + */ + +/* polevlf.c + * p1evlf.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * float x, y, coef[N+1], polevlf[]; + * + * y = polevlf( 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 p1evl() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevl(). + * + * + * 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. + * + */ + +/* polynf.c + * polyrf.c + * Arithmetic operations on polynomials + * + * In the following descriptions a, b, c are polynomials of degree + * na, nb, nc respectively. The degree of a polynomial cannot + * exceed a run-time value MAXPOLF. An operation that attempts + * to use or generate a polynomial of higher degree may produce a + * result that suffers truncation at degree MAXPOL. The value of + * MAXPOL is set by calling the function + * + * polinif( maxpol ); + * + * where maxpol is the desired maximum degree. This must be + * done prior to calling any of the other functions in this module. + * Memory for internal temporary polynomial storage is allocated + * by polinif(). + * + * Each polynomial is represented by an array containing its + * coefficients, together with a separately declared integer equal + * to the degree of the polynomial. The coefficients appear in + * ascending order; that is, + * + * 2 na + * a(x) = a[0] + a[1] * x + a[2] * x + ... + a[na] * x . + * + * + * + * sum = poleva( a, na, x ); Evaluate polynomial a(t) at t = x. + * polprtf( a, na, D ); Print the coefficients of a to D digits. + * polclrf( a, na ); Set a identically equal to zero, up to a[na]. + * polmovf( a, na, b ); Set b = a. + * poladdf( a, na, b, nb, c ); c = b + a, nc = max(na,nb) + * polsubf( a, na, b, nb, c ); c = b - a, nc = max(na,nb) + * polmulf( a, na, b, nb, c ); c = b * a, nc = na+nb + * + * + * Division: + * + * i = poldivf( a, na, b, nb, c ); c = b / a, nc = MAXPOL + * + * returns i = the degree of the first nonzero coefficient of a. + * The computed quotient c must be divided by x^i. An error message + * is printed if a is identically zero. + * + * + * Change of variables: + * If a and b are polynomials, and t = a(x), then + * c(t) = b(a(x)) + * is a polynomial found by substituting a(x) for t. The + * subroutine call for this is + * + * polsbtf( a, na, b, nb, c ); + * + * + * Notes: + * poldivf() is an integer routine; polevaf() is float. + * Any of the arguments a, b, c may refer to the same array. + * + */ + +/* powf.c + * + * Power function + * + * + * + * SYNOPSIS: + * + * float x, y, z, powf(); + * + * z = powf( 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/16 and pseudo extended precision arithmetic to + * obtain an extra three bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 100,000 1.4e-7 3.6e-8 + * 1/10 < x < 10, x uniformly distributed. + * -10 < y < 10, y uniformly distributed. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * powf overflow x**y > MAXNUMF MAXNUMF + * powf underflow x**y < 1/MAXNUMF 0.0 + * powf domain x<0 and y noninteger 0.0 + * + */ + +/* powif.c + * + * Real raised to integer power + * + * + * + * SYNOPSIS: + * + * float x, y, powif(); + * int n; + * + * y = powif( 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 .04,26 -26,26 100000 1.1e-6 2.0e-7 + * IEEE 1,2 -128,128 100000 1.1e-5 1.0e-6 + * + * Returns MAXNUMF on overflow, zero on underflow. + * + */ + +/* psif.c + * + * Psi (digamma) function + * + * + * SYNOPSIS: + * + * float x, y, psif(); + * + * y = psif( x ); + * + * + * DESCRIPTION: + * + * d - + * psi(x) = -- ln | (x) + * dx + * + * is the logarithmic derivative of the gamma function. + * For integer x, + * n-1 + * - + * psi(n) = -EUL + > 1/k. + * - + * k=1 + * + * This formula is used for 0 < n <= 10. If x is negative, it + * is transformed to a positive argument by the reflection + * formula psi(1-x) = psi(x) + pi cot(pi x). + * For general positive x, the argument is made greater than 10 + * using the recurrence psi(x+1) = psi(x) + 1/x. + * Then the following asymptotic expansion is applied: + * + * inf. B + * - 2k + * psi(x) = log(x) - 1/2x - > ------- + * - 2k + * k=1 2k x + * + * where the B2k are Bernoulli numbers. + * + * ACCURACY: + * Absolute error, relative when |psi| > 1 : + * arithmetic domain # trials peak rms + * IEEE -33,0 30000 8.2e-7 1.2e-7 + * IEEE 0,33 100000 7.3e-7 7.7e-8 + * + * ERROR MESSAGES: + * message condition value returned + * psi singularity x integer <=0 MAXNUMF + */ + +/* rgammaf.c + * + * Reciprocal gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, rgammaf(); + * + * y = rgammaf( x ); + * + * + * + * DESCRIPTION: + * + * Returns one divided by the gamma function of the argument. + * + * The function is approximated by a Chebyshev expansion in + * the interval [0,1]. Range reduction is by recurrence + * for arguments between -34.034 and +34.84425627277176174. + * 1/MAXNUMF is returned for positive arguments outside this + * range. + * + * The reciprocal gamma function has no singularities, + * but overflow and underflow may occur for large arguments. + * These conditions return either MAXNUMF or 1/MAXNUMF with + * appropriate sign. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -34,+34 100000 8.9e-7 1.1e-7 + */ + +/* shichif.c + * + * Hyperbolic sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * float x, Chi, Shi; + * + * shichi( x, &Chi, &Shi ); + * + * + * DESCRIPTION: + * + * Approximates the integrals + * + * x + * - + * | | cosh t - 1 + * Chi(x) = eul + ln x + | ----------- dt, + * | | t + * - + * 0 + * + * x + * - + * | | sinh t + * Shi(x) = | ------ dt + * | | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are evaluated by power series for x < 8 + * and by Chebyshev expansions for x between 8 and 88. + * For large x, both functions approach exp(x)/2x. + * Arguments greater than 88 in magnitude return MAXNUM. + * + * + * ACCURACY: + * + * Test interval 0 to 88. + * Relative error: + * arithmetic function # trials peak rms + * IEEE Shi 20000 3.5e-7 7.0e-8 + * Absolute error, except relative when |Chi| > 1: + * IEEE Chi 20000 3.8e-7 7.6e-8 + */ + +/* sicif.c + * + * Sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * float x, Ci, Si; + * + * sicif( x, &Si, &Ci ); + * + * + * DESCRIPTION: + * + * Evaluates the integrals + * + * x + * - + * | cos t - 1 + * Ci(x) = eul + ln x + | --------- dt, + * | t + * - + * 0 + * x + * - + * | sin t + * Si(x) = | ----- dt + * | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are approximated by rational functions. + * For x > 8 auxiliary functions f(x) and g(x) are employed + * such that + * + * Ci(x) = f(x) sin(x) - g(x) cos(x) + * Si(x) = pi/2 - f(x) cos(x) - g(x) sin(x) + * + * + * ACCURACY: + * Test interval = [0,50]. + * Absolute error, except relative when > 1: + * arithmetic function # trials peak rms + * IEEE Si 30000 2.1e-7 4.3e-8 + * IEEE Ci 30000 3.9e-7 2.2e-8 + */ + +/* sindgf.c + * + * Circular sine of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, sindgf(); + * + * y = sindgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-3600 100,000 1.2e-7 3.0e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2^24 0.0 + * + */ + +/* cosdgf.c + * + * Circular cosine of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, cosdgf(); + * + * y = cosdgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + */ + +/* sinf.c + * + * Circular sine + * + * + * + * SYNOPSIS: + * + * float x, y, sinf(); + * + * y = sinf( 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 + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -4096,+4096 100,000 1.2e-7 3.0e-8 + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2^24 0.0 + * + * Partial loss of accuracy begins to occur at x = 2^13 + * = 8192. Results may be meaningless for x >= 2^24 + * The routine as implemented flags a TLOSS error + * for x >= 2^24 and returns 0.0. + */ + +/* cosf.c + * + * Circular cosine + * + * + * + * SYNOPSIS: + * + * float x, y, cosf(); + * + * y = cosf( 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 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + */ + +/* sinhf.c + * + * Hyperbolic sine + * + * + * + * SYNOPSIS: + * + * float x, y, sinhf(); + * + * y = sinhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOGF to + * MAXLOGF. + * + * The range is partitioned into two segments. If |x| <= 1, a + * polynomial approximation is used. + * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-MAXLOG 100000 1.1e-7 2.9e-8 + * + */ + +/* spencef.c + * + * Dilogarithm + * + * + * + * SYNOPSIS: + * + * float x, y, spencef(); + * + * y = spencef( x ); + * + * + * + * DESCRIPTION: + * + * Computes the integral + * + * x + * - + * | | log t + * spence(x) = - | ----- dt + * | | t - 1 + * - + * 1 + * + * for x >= 0. A rational approximation gives the integral in + * the interval (0.5, 1.5). Transformation formulas for 1/x + * and 1-x are employed outside the basic expansion range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,4 30000 4.4e-7 6.3e-8 + * + * + */ + +/* sqrtf.c + * + * Square root + * + * + * + * SYNOPSIS: + * + * float x, y, sqrtf(); + * + * y = sqrtf( 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. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1.e38 100000 8.7e-8 2.9e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrtf domain x < 0 0.0 + * + */ + +/* stdtrf.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * float t, stdtrf(); + * short k; + * + * y = stdtrf( 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, 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +/- 100 5000 2.3e-5 2.9e-6 + */ + +/* struvef.c + * + * Struve function + * + * + * + * SYNOPSIS: + * + * float v, x, y, struvef(); + * + * y = struvef( v, x ); + * + * + * + * DESCRIPTION: + * + * Computes the Struve function Hv(x) of order v, argument x. + * Negative x is rejected unless v is an integer. + * + * This module also contains the hypergeometric functions 1F2 + * and 3F0 and a routine for the Bessel function Yv(x) with + * noninteger v. + * + * + * + * ACCURACY: + * + * v varies from 0 to 10. + * Absolute error (relative error when |Hv(x)| > 1): + * arithmetic domain # trials peak rms + * IEEE -10,10 100000 9.0e-5 4.0e-6 + * + */ + +/* tandgf.c + * + * Circular tangent of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, tandgf(); + * + * y = tandgf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is into intervals of 45 degrees. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-2^24 50000 2.4e-7 4.8e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * tanf total loss x > 2^24 0.0 + * + */ + /* cotdgf.c + * + * Circular cotangent of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, cotdgf(); + * + * y = cotdgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * A common routine computes either the tangent or cotangent. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-2^24 50000 2.4e-7 4.8e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^24 0.0 + * cot singularity x = 0 MAXNUMF + * + */ + +/* tanf.c + * + * Circular tangent + * + * + * + * SYNOPSIS: + * + * float x, y, tanf(); + * + * y = tanf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is modulo pi/4. A polynomial approximation + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4096 100000 3.3e-7 4.5e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * tanf total loss x > 2^24 0.0 + * + */ + /* cotf.c + * + * Circular cotangent + * + * + * + * SYNOPSIS: + * + * float x, y, cotf(); + * + * y = cotf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the radian argument x. + * A common routine computes either the tangent or cotangent. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4096 100000 3.0e-7 4.5e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^24 0.0 + * cot singularity x = 0 MAXNUMF + * + */ + +/* tanhf.c + * + * Hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * float x, y, tanhf(); + * + * y = tanhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOG to + * MAXLOG. + * + * A polynomial approximation is used for |x| < 0.625. + * Otherwise, + * + * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 100000 1.3e-7 2.6e-8 + * + */ + +/* ynf.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * float x, y, ynf(); + * int n; + * + * y = ynf( 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 + * y0() and y1(). + * + * If n = 0 or 1 the routine for y0 or y1 is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative when y > 1: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 10000 2.3e-6 3.4e-7 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * yn singularity x = 0 MAXNUMF + * yn overflow MAXNUMF + * + * Spot checked against tables for x, n between 0 and 100. + * + */ + + /* zetacf.c + * + * Riemann zeta function + * + * + * + * SYNOPSIS: + * + * float x, y, zetacf(); + * + * y = zetacf( x ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zetac(x) = > k , x > 1, + * - + * k=2 + * + * is related to the Riemann zeta function by + * + * Riemann zeta(x) = zetac(x) + 1. + * + * Extension of the function definition for x < 1 is implemented. + * Zero is returned for x > log2(MAXNUM). + * + * An overflow error may occur for large negative x, due to the + * gamma function in the reflection formula. + * + * ACCURACY: + * + * Tabulated values have full machine accuracy. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,50 30000 5.5e-7 7.5e-8 + * + * + */ + +/* zetaf.c + * + * Riemann zeta function of two arguments + * + * + * + * SYNOPSIS: + * + * float x, q, y, zetaf(); + * + * y = zetaf( x, q ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zeta(x,q) = > (k+q) + * - + * k=0 + * + * where x > 1 and q is not a negative integer or zero. + * The Euler-Maclaurin summation formula is used to obtain + * the expansion + * + * n + * - -x + * zeta(x,q) = > (k+q) + * - + * k=1 + * + * 1-x inf. B x(x+1)...(x+2j) + * (n+q) 1 - 2j + * + --------- - ------- + > -------------------- + * x-1 x - x+2j+1 + * 2(n+q) j=1 (2j)! (n+q) + * + * where the B2j are Bernoulli numbers. Note that (see zetac.c) + * zeta(x,1) = zetac(x) + 1. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,25 10000 6.9e-7 1.0e-7 + * + * Large arguments may produce underflow in powf(), in which + * case the results are inaccurate. + * + * REFERENCE: + * + * Gradshteyn, I. S., and I. M. Ryzhik, Tables of Integrals, + * Series, and Products, p. 1073; Academic Press, 1980. + * + */ diff --git a/libm/float/acoshf.c b/libm/float/acoshf.c new file mode 100644 index 000000000..c45206125 --- /dev/null +++ b/libm/float/acoshf.c @@ -0,0 +1,97 @@ +/* acoshf.c + * + * Inverse hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * float x, y, acoshf(); + * + * y = acoshf( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic cosine of argument. + * + * If 1 <= x < 1.5, a polynomial approximation + * + * sqrt(z) * P(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 100000 1.8e-7 3.9e-8 + * IEEE 1,2000 100000 3.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acoshf domain |x| < 1 0.0 + * + */ + +/* acosh.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision inverse hyperbolic cosine + * test interval: [1.0, 1.5] + * trials: 10000 + * peak relative error: 1.7e-7 + * rms relative error: 5.0e-8 + * + * Copyright (C) 1989 by Stephen L. Moshier. All rights reserved. + */ +#include <math.h> +extern float LOGE2F; + +float sqrtf( float ); +float logf( float ); + +float acoshf( float xx ) +{ +float x, z; + +x = xx; +if( x < 1.0 ) + { + mtherr( "acoshf", DOMAIN ); + return(0.0); + } + +if( x > 1500.0 ) + return( logf(x) + LOGE2F ); + +z = x - 1.0; + +if( z < 0.5 ) + { + z = + (((( 1.7596881071E-3 * z + - 7.5272886713E-3) * z + + 2.6454905019E-2) * z + - 1.1784741703E-1) * z + + 1.4142135263E0) * sqrtf( z ); + } +else + { + z = sqrtf( z*(x+1.0) ); + z = logf(x + z); + } +return( z ); +} diff --git a/libm/float/airyf.c b/libm/float/airyf.c new file mode 100644 index 000000000..a84a5c861 --- /dev/null +++ b/libm/float/airyf.c @@ -0,0 +1,377 @@ +/* airy.c + * + * Airy function + * + * + * + * SYNOPSIS: + * + * float x, ai, aip, bi, bip; + * int airyf(); + * + * airyf( x, _&ai, _&aip, _&bi, _&bip ); + * + * + * + * DESCRIPTION: + * + * Solution of the differential equation + * + * y"(x) = xy. + * + * The function returns the two independent solutions Ai, Bi + * and their first derivatives Ai'(x), Bi'(x). + * + * Evaluation is by power series summation for small x, + * by rational minimax approximations for large x. + * + * + * + * ACCURACY: + * Error criterion is absolute when function <= 1, relative + * when function > 1, except * denotes relative error criterion. + * For large negative x, the absolute error increases as x^1.5. + * For large positive x, the relative error increases as x^1.5. + * + * Arithmetic domain function # trials peak rms + * IEEE -10, 0 Ai 50000 7.0e-7 1.2e-7 + * IEEE 0, 10 Ai 50000 9.9e-6* 6.8e-7* + * IEEE -10, 0 Ai' 50000 2.4e-6 3.5e-7 + * IEEE 0, 10 Ai' 50000 8.7e-6* 6.2e-7* + * IEEE -10, 10 Bi 100000 2.2e-6 2.6e-7 + * IEEE -10, 10 Bi' 50000 2.2e-6 3.5e-7 + * + */ + /* airy.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +static float c1 = 0.35502805388781723926; +static float c2 = 0.258819403792806798405; +static float sqrt3 = 1.732050807568877293527; +static float sqpii = 5.64189583547756286948E-1; +extern float PIF; + +extern float MAXNUMF, MACHEPF; +#define MAXAIRY 25.77 + +/* Note, these expansions are for double precision accuracy; + * they have not yet been redesigned for single precision. + */ +static float AN[8] = { + 3.46538101525629032477e-1, + 1.20075952739645805542e1, + 7.62796053615234516538e1, + 1.68089224934630576269e2, + 1.59756391350164413639e2, + 7.05360906840444183113e1, + 1.40264691163389668864e1, + 9.99999999999999995305e-1, +}; +static float AD[8] = { + 5.67594532638770212846e-1, + 1.47562562584847203173e1, + 8.45138970141474626562e1, + 1.77318088145400459522e2, + 1.64234692871529701831e2, + 7.14778400825575695274e1, + 1.40959135607834029598e1, + 1.00000000000000000470e0, +}; + + +static float APN[8] = { + 6.13759184814035759225e-1, + 1.47454670787755323881e1, + 8.20584123476060982430e1, + 1.71184781360976385540e2, + 1.59317847137141783523e2, + 6.99778599330103016170e1, + 1.39470856980481566958e1, + 1.00000000000000000550e0, +}; +static float APD[8] = { + 3.34203677749736953049e-1, + 1.11810297306158156705e1, + 7.11727352147859965283e1, + 1.58778084372838313640e2, + 1.53206427475809220834e2, + 6.86752304592780337944e1, + 1.38498634758259442477e1, + 9.99999999999999994502e-1, +}; + +static float BN16[5] = { +-2.53240795869364152689e-1, + 5.75285167332467384228e-1, +-3.29907036873225371650e-1, + 6.44404068948199951727e-2, +-3.82519546641336734394e-3, +}; +static float BD16[5] = { +/* 1.00000000000000000000e0,*/ +-7.15685095054035237902e0, + 1.06039580715664694291e1, +-5.23246636471251500874e0, + 9.57395864378383833152e-1, +-5.50828147163549611107e-2, +}; + +static float BPPN[5] = { + 4.65461162774651610328e-1, +-1.08992173800493920734e0, + 6.38800117371827987759e-1, +-1.26844349553102907034e-1, + 7.62487844342109852105e-3, +}; +static float BPPD[5] = { +/* 1.00000000000000000000e0,*/ +-8.70622787633159124240e0, + 1.38993162704553213172e1, +-7.14116144616431159572e0, + 1.34008595960680518666e0, +-7.84273211323341930448e-2, +}; + +static float AFN[9] = { +-1.31696323418331795333e-1, +-6.26456544431912369773e-1, +-6.93158036036933542233e-1, +-2.79779981545119124951e-1, +-4.91900132609500318020e-2, +-4.06265923594885404393e-3, +-1.59276496239262096340e-4, +-2.77649108155232920844e-6, +-1.67787698489114633780e-8, +}; +static float AFD[9] = { +/* 1.00000000000000000000e0,*/ + 1.33560420706553243746e1, + 3.26825032795224613948e1, + 2.67367040941499554804e1, + 9.18707402907259625840e0, + 1.47529146771666414581e0, + 1.15687173795188044134e-1, + 4.40291641615211203805e-3, + 7.54720348287414296618e-5, + 4.51850092970580378464e-7, +}; + +static float AGN[11] = { + 1.97339932091685679179e-2, + 3.91103029615688277255e-1, + 1.06579897599595591108e0, + 9.39169229816650230044e-1, + 3.51465656105547619242e-1, + 6.33888919628925490927e-2, + 5.85804113048388458567e-3, + 2.82851600836737019778e-4, + 6.98793669997260967291e-6, + 8.11789239554389293311e-8, + 3.41551784765923618484e-10, +}; +static float AGD[10] = { +/* 1.00000000000000000000e0,*/ + 9.30892908077441974853e0, + 1.98352928718312140417e1, + 1.55646628932864612953e1, + 5.47686069422975497931e0, + 9.54293611618961883998e-1, + 8.64580826352392193095e-2, + 4.12656523824222607191e-3, + 1.01259085116509135510e-4, + 1.17166733214413521882e-6, + 4.91834570062930015649e-9, +}; + +static float APFN[9] = { + 1.85365624022535566142e-1, + 8.86712188052584095637e-1, + 9.87391981747398547272e-1, + 4.01241082318003734092e-1, + 7.10304926289631174579e-2, + 5.90618657995661810071e-3, + 2.33051409401776799569e-4, + 4.08718778289035454598e-6, + 2.48379932900442457853e-8, +}; +static float APFD[9] = { +/* 1.00000000000000000000e0,*/ + 1.47345854687502542552e1, + 3.75423933435489594466e1, + 3.14657751203046424330e1, + 1.09969125207298778536e1, + 1.78885054766999417817e0, + 1.41733275753662636873e-1, + 5.44066067017226003627e-3, + 9.39421290654511171663e-5, + 5.65978713036027009243e-7, +}; + +static float APGN[11] = { +-3.55615429033082288335e-2, +-6.37311518129435504426e-1, +-1.70856738884312371053e0, +-1.50221872117316635393e0, +-5.63606665822102676611e-1, +-1.02101031120216891789e-1, +-9.48396695961445269093e-3, +-4.60325307486780994357e-4, +-1.14300836484517375919e-5, +-1.33415518685547420648e-7, +-5.63803833958893494476e-10, +}; +static float APGD[11] = { +/* 1.00000000000000000000e0,*/ + 9.85865801696130355144e0, + 2.16401867356585941885e1, + 1.73130776389749389525e1, + 6.17872175280828766327e0, + 1.08848694396321495475e0, + 9.95005543440888479402e-2, + 4.78468199683886610842e-3, + 1.18159633322838625562e-4, + 1.37480673554219441465e-6, + 5.79912514929147598821e-9, +}; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +float polevlf(float, float *, int); +float p1evlf(float, float *, int); +float sinf(float), cosf(float), expf(float), sqrtf(float); + +int airyf( float xx, float *ai, float *aip, float *bi, float *bip ) +{ +float x, z, zz, t, f, g, uf, ug, k, zeta, theta; +int domflg; + +x = xx; +domflg = 0; +if( x > MAXAIRY ) + { + *ai = 0; + *aip = 0; + *bi = MAXNUMF; + *bip = MAXNUMF; + return(-1); + } + +if( x < -2.09 ) + { + domflg = 15; + t = sqrtf(-x); + zeta = -2.0 * x * t / 3.0; + t = sqrtf(t); + k = sqpii / t; + z = 1.0/zeta; + zz = z * z; + uf = 1.0 + zz * polevlf( zz, AFN, 8 ) / p1evlf( zz, AFD, 9 ); + ug = z * polevlf( zz, AGN, 10 ) / p1evlf( zz, AGD, 10 ); + theta = zeta + 0.25 * PIF; + f = sinf( theta ); + g = cosf( theta ); + *ai = k * (f * uf - g * ug); + *bi = k * (g * uf + f * ug); + uf = 1.0 + zz * polevlf( zz, APFN, 8 ) / p1evlf( zz, APFD, 9 ); + ug = z * polevlf( zz, APGN, 10 ) / p1evlf( zz, APGD, 10 ); + k = sqpii * t; + *aip = -k * (g * uf + f * ug); + *bip = k * (f * uf - g * ug); + return(0); + } + +if( x >= 2.09 ) /* cbrt(9) */ + { + domflg = 5; + t = sqrtf(x); + zeta = 2.0 * x * t / 3.0; + g = expf( zeta ); + t = sqrtf(t); + k = 2.0 * t * g; + z = 1.0/zeta; + f = polevlf( z, AN, 7 ) / polevlf( z, AD, 7 ); + *ai = sqpii * f / k; + k = -0.5 * sqpii * t / g; + f = polevlf( z, APN, 7 ) / polevlf( z, APD, 7 ); + *aip = f * k; + + if( x > 8.3203353 ) /* zeta > 16 */ + { + f = z * polevlf( z, BN16, 4 ) / p1evlf( z, BD16, 5 ); + k = sqpii * g; + *bi = k * (1.0 + f) / t; + f = z * polevlf( z, BPPN, 4 ) / p1evlf( z, BPPD, 5 ); + *bip = k * t * (1.0 + f); + return(0); + } + } + +f = 1.0; +g = x; +t = 1.0; +uf = 1.0; +ug = x; +k = 1.0; +z = x * x * x; +while( t > MACHEPF ) + { + uf *= z; + k += 1.0; + uf /=k; + ug *= z; + k += 1.0; + ug /=k; + uf /=k; + f += uf; + k += 1.0; + ug /=k; + g += ug; + t = fabsf(uf/f); + } +uf = c1 * f; +ug = c2 * g; +if( (domflg & 1) == 0 ) + *ai = uf - ug; +if( (domflg & 2) == 0 ) + *bi = sqrt3 * (uf + ug); + +/* the deriviative of ai */ +k = 4.0; +uf = x * x/2.0; +ug = z/3.0; +f = uf; +g = 1.0 + ug; +uf /= 3.0; +t = 1.0; + +while( t > MACHEPF ) + { + uf *= z; + ug /=k; + k += 1.0; + ug *= z; + uf /=k; + f += uf; + k += 1.0; + ug /=k; + uf /=k; + g += ug; + k += 1.0; + t = fabsf(ug/g); + } + +uf = c1 * f; +ug = c2 * g; +if( (domflg & 4) == 0 ) + *aip = uf - ug; +if( (domflg & 8) == 0 ) + *bip = sqrt3 * (uf + ug); +return(0); +} diff --git a/libm/float/asinf.c b/libm/float/asinf.c new file mode 100644 index 000000000..c96d75acb --- /dev/null +++ b/libm/float/asinf.c @@ -0,0 +1,186 @@ +/* asinf.c + * + * Inverse circular sine + * + * + * + * SYNOPSIS: + * + * float x, y, asinf(); + * + * y = asinf( x ); + * + * + * + * DESCRIPTION: + * + * Returns radian angle between -pi/2 and +pi/2 whose sine is x. + * + * A polynomial of the form x + x**3 P(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 100000 2.5e-7 5.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * asinf domain |x| > 1 0.0 + * + */ + /* acosf() + * + * Inverse circular cosine + * + * + * + * SYNOPSIS: + * + * float x, y, acosf(); + * + * y = acosf( 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 100000 1.4e-7 4.2e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * acosf domain |x| > 1 0.0 + */ + +/* asin.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision circular arcsine + * test interval: [-0.5, +0.5] + * trials: 10000 + * peak relative error: 6.7e-8 + * rms relative error: 2.5e-8 + */ +#include <math.h> +extern float PIF, PIO2F; + +float sqrtf( float ); + +float asinf( float xx ) +{ +float a, x, z; +int sign, flag; + +x = xx; + +if( x > 0 ) + { + sign = 1; + a = x; + } +else + { + sign = -1; + a = -x; + } + +if( a > 1.0 ) + { + mtherr( "asinf", DOMAIN ); + return( 0.0 ); + } + +if( a < 1.0e-4 ) + { + z = a; + goto done; + } + +if( a > 0.5 ) + { + z = 0.5 * (1.0 - a); + x = sqrtf( z ); + flag = 1; + } +else + { + x = a; + z = x * x; + flag = 0; + } + +z = +(((( 4.2163199048E-2 * z + + 2.4181311049E-2) * z + + 4.5470025998E-2) * z + + 7.4953002686E-2) * z + + 1.6666752422E-1) * z * x + + x; + +if( flag != 0 ) + { + z = z + z; + z = PIO2F - z; + } +done: +if( sign < 0 ) + z = -z; +return( z ); +} + + + + +float acosf( float x ) +{ + +if( x < -1.0 ) + goto domerr; + +if( x < -0.5) + return( PIF - 2.0 * asinf( sqrtf(0.5*(1.0+x)) ) ); + +if( x > 1.0 ) + { +domerr: mtherr( "acosf", DOMAIN ); + return( 0.0 ); + } + +if( x > 0.5 ) + return( 2.0 * asinf( sqrtf(0.5*(1.0-x) ) ) ); + +return( PIO2F - asinf(x) ); +} + diff --git a/libm/float/asinhf.c b/libm/float/asinhf.c new file mode 100644 index 000000000..d3fbe10a7 --- /dev/null +++ b/libm/float/asinhf.c @@ -0,0 +1,88 @@ +/* asinhf.c + * + * Inverse hyperbolic sine + * + * + * + * SYNOPSIS: + * + * float x, y, asinhf(); + * + * y = asinhf( 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 100000 2.4e-7 4.1e-8 + * + */ + +/* asinh.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision inverse hyperbolic sine + * test interval: [-0.5, +0.5] + * trials: 10000 + * peak relative error: 8.8e-8 + * rms relative error: 3.2e-8 + */ +#include <math.h> +extern float LOGE2F; + +float logf( float ); +float sqrtf( float ); + +float asinhf( float xx ) +{ +float x, z; + +if( xx < 0 ) + x = -xx; +else + x = xx; + +if( x > 1500.0 ) + { + z = logf(x) + LOGE2F; + goto done; + } +z = x * x; +if( x < 0.5 ) + { + z = + ((( 2.0122003309E-2 * z + - 4.2699340972E-2) * z + + 7.4847586088E-2) * z + - 1.6666288134E-1) * z * x + + x; + } +else + { + z = sqrtf( z + 1.0 ); + z = logf( x + z ); + } +done: +if( xx < 0 ) + z = -z; +return( z ); +} + diff --git a/libm/float/atanf.c b/libm/float/atanf.c new file mode 100644 index 000000000..321e3be39 --- /dev/null +++ b/libm/float/atanf.c @@ -0,0 +1,190 @@ +/* atanf.c + * + * Inverse circular tangent + * (arctangent) + * + * + * + * SYNOPSIS: + * + * float x, y, atanf(); + * + * y = atanf( 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 ). A polynomial approximates + * the function in this basic interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10, 10 100000 1.9e-7 4.1e-8 + * + */ + /* atan2f() + * + * Quadrant correct inverse circular tangent + * + * + * + * SYNOPSIS: + * + * float x, y, z, atan2f(); + * + * z = atan2f( 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 100000 1.9e-7 4.1e-8 + * See atan.c. + * + */ + +/* atan.c */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision circular arcsine + * test interval: [-tan(pi/8), +tan(pi/8)] + * trials: 10000 + * peak relative error: 7.7e-8 + * rms relative error: 2.9e-8 + */ +#include <math.h> +extern float PIF, PIO2F, PIO4F; + +float atanf( float xx ) +{ +float x, y, z; +int sign; + +x = xx; + +/* make argument positive and save the sign */ +if( xx < 0.0 ) + { + sign = -1; + x = -xx; + } +else + { + sign = 1; + x = xx; + } +/* range reduction */ +if( x > 2.414213562373095 ) /* tan 3pi/8 */ + { + y = PIO2F; + x = -( 1.0/x ); + } + +else if( x > 0.4142135623730950 ) /* tan pi/8 */ + { + y = PIO4F; + x = (x-1.0)/(x+1.0); + } +else + y = 0.0; + +z = x * x; +y += +((( 8.05374449538e-2 * z + - 1.38776856032E-1) * z + + 1.99777106478E-1) * z + - 3.33329491539E-1) * z * x + + x; + +if( sign < 0 ) + y = -y; + +return( y ); +} + + + + +float atan2f( float y, float x ) +{ +float z, w; +int code; + + +code = 0; + +if( x < 0.0 ) + code = 2; +if( y < 0.0 ) + code |= 1; + +if( x == 0.0 ) + { + if( code & 1 ) + { +#if ANSIC + return( -PIO2F ); +#else + return( 3.0*PIO2F ); +#endif + } + if( y == 0.0 ) + return( 0.0 ); + return( PIO2F ); + } + +if( y == 0.0 ) + { + if( code & 2 ) + return( PIF ); + return( 0.0 ); + } + + +switch( code ) + { + default: +#if ANSIC + case 0: + case 1: w = 0.0; break; + case 2: w = PIF; break; + case 3: w = -PIF; break; +#else + case 0: w = 0.0; break; + case 1: w = 2.0 * PIF; break; + case 2: + case 3: w = PIF; break; +#endif + } + +z = atanf( y/x ); + +return( w + z ); +} + diff --git a/libm/float/atanhf.c b/libm/float/atanhf.c new file mode 100644 index 000000000..dfadad09e --- /dev/null +++ b/libm/float/atanhf.c @@ -0,0 +1,92 @@ +/* atanhf.c + * + * Inverse hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * float x, y, atanhf(); + * + * y = atanhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns inverse hyperbolic tangent of argument in the range + * MINLOGF to MAXLOGF. + * + * If |x| < 0.5, a polynomial approximation is used. + * Otherwise, + * atanh(x) = 0.5 * log( (1+x)/(1-x) ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -1,1 100000 1.4e-7 3.1e-8 + * + */ + +/* atanh.c */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright (C) 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision inverse hyperbolic tangent + * test interval: [-0.5, +0.5] + * trials: 10000 + * peak relative error: 8.2e-8 + * rms relative error: 3.0e-8 + */ +#include <math.h> +extern float MAXNUMF; + +float logf( float ); + +float atanhf( float xx ) +{ +float x, z; + +x = xx; +if( x < 0 ) + z = -x; +else + z = x; +if( z >= 1.0 ) + { + if( x == 1.0 ) + return( MAXNUMF ); + if( x == -1.0 ) + return( -MAXNUMF ); + mtherr( "atanhl", DOMAIN ); + return( MAXNUMF ); + } + +if( z < 1.0e-4 ) + return(x); + +if( z < 0.5 ) + { + z = x * x; + z = + (((( 1.81740078349E-1 * z + + 8.24370301058E-2) * z + + 1.46691431730E-1) * z + + 1.99782164500E-1) * z + + 3.33337300303E-1) * z * x + + x; + } +else + { + z = 0.5 * logf( (1.0+x)/(1.0-x) ); + } +return( z ); +} diff --git a/libm/float/bdtrf.c b/libm/float/bdtrf.c new file mode 100644 index 000000000..e063f1c77 --- /dev/null +++ b/libm/float/bdtrf.c @@ -0,0 +1,247 @@ +/* bdtrf.c + * + * Binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrf(); + * + * y = bdtrf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 6.9e-5 1.1e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrf domain k < 0 0.0 + * n < k + * x < 0, x > 1 + * + */ + /* bdtrcf() + * + * Complemented binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrcf(); + * + * y = bdtrcf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 6.0e-5 1.2e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrcf domain x<0, x>1, n<k 0.0 + */ + /* bdtrif() + * + * Inverse binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, bdtrif(); + * + * p = bdtrf( 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: + * + * Relative error (p varies from 0 to 1): + * arithmetic domain # trials peak rms + * IEEE 0,100 2000 3.5e-5 3.3e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * bdtrif domain k < 0, n <= k 0.0 + * x < 0, x > 1 + * + */ + +/* bdtr() */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#ifdef ANSIC +float incbetf(float, float, float), powf(float, float); +float incbif( float, float, float ); +#else +float incbetf(), powf(), incbif(); +#endif + +float bdtrcf( int k, int n, float pp ) +{ +float p, dk, dn; + +p = pp; +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + return( 1.0 ); + +if( n < k ) + { +domerr: + mtherr( "bdtrcf", DOMAIN ); + return( 0.0 ); + } + +if( k == n ) + return( 0.0 ); +dn = n - k; +if( k == 0 ) + { + dk = 1.0 - powf( 1.0-p, dn ); + } +else + { + dk = k + 1; + dk = incbetf( dk, dn, p ); + } +return( dk ); +} + + + +float bdtrf( int k, int n, float pp ) +{ +float p, dk, dn; + +p = pp; +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( (k < 0) || (n < k) ) + { +domerr: + mtherr( "bdtrf", DOMAIN ); + return( 0.0 ); + } + +if( k == n ) + return( 1.0 ); + +dn = n - k; +if( k == 0 ) + { + dk = powf( 1.0-p, dn ); + } +else + { + dk = k + 1; + dk = incbetf( dn, dk, 1.0 - p ); + } +return( dk ); +} + + +float bdtrif( int k, int n, float yy ) +{ +float y, dk, dn, p; + +y = yy; +if( (y < 0.0) || (y > 1.0) ) + goto domerr; +if( (k < 0) || (n <= k) ) + { +domerr: + mtherr( "bdtrif", DOMAIN ); + return( 0.0 ); + } + +dn = n - k; +if( k == 0 ) + { + p = 1.0 - powf( y, 1.0/dn ); + } +else + { + dk = k + 1; + p = 1.0 - incbif( dn, dk, y ); + } +return( p ); +} diff --git a/libm/float/betaf.c b/libm/float/betaf.c new file mode 100644 index 000000000..7a1963191 --- /dev/null +++ b/libm/float/betaf.c @@ -0,0 +1,122 @@ +/* betaf.c + * + * Beta function + * + * + * + * SYNOPSIS: + * + * float a, b, y, betaf(); + * + * y = betaf( a, b ); + * + * + * + * DESCRIPTION: + * + * - - + * | (a) | (b) + * beta( a, b ) = -----------. + * - + * | (a+b) + * + * For large arguments the logarithm of the function is + * evaluated using lgam(), then exponentiated. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 10000 4.0e-5 6.0e-6 + * IEEE -20,0 10000 4.9e-3 5.4e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * betaf overflow log(beta) > MAXLOG 0.0 + * a or b <0 integer 0.0 + * + */ + +/* beta.c */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#define MAXGAM 34.84425627277176174 + + +extern float MAXLOGF, MAXNUMF; +extern int sgngamf; + +#ifdef ANSIC +float gammaf(float), lgamf(float), expf(float), floorf(float); +#else +float gammaf(), lgamf(), expf(), floorf(); +#endif + +float betaf( float aa, float bb ) +{ +float a, b, y; +int sign; + +sign = 1; +a = aa; +b = bb; +if( a <= 0.0 ) + { + if( a == floorf(a) ) + goto over; + } +if( b <= 0.0 ) + { + if( b == floorf(b) ) + goto over; + } + + +y = a + b; +if( fabsf(y) > MAXGAM ) + { + y = lgamf(y); + sign *= sgngamf; /* keep track of the sign */ + y = lgamf(b) - y; + sign *= sgngamf; + y = lgamf(a) + y; + sign *= sgngamf; + if( y > MAXLOGF ) + { +over: + mtherr( "betaf", OVERFLOW ); + return( sign * MAXNUMF ); + } + return( sign * expf(y) ); + } + +y = gammaf(y); +if( y == 0.0 ) + goto over; + +if( a > b ) + { + y = gammaf(a)/y; + y *= gammaf(b); + } +else + { + y = gammaf(b)/y; + y *= gammaf(a); + } + +return(y); +} diff --git a/libm/float/cbrtf.c b/libm/float/cbrtf.c new file mode 100644 index 000000000..ca9b433d9 --- /dev/null +++ b/libm/float/cbrtf.c @@ -0,0 +1,119 @@ +/* cbrtf.c + * + * Cube root + * + * + * + * SYNOPSIS: + * + * float x, y, cbrtf(); + * + * y = cbrtf( 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 to converge to an accurate result. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1e38 100000 7.6e-8 2.7e-8 + * + */ + /* cbrt.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +static float CBRT2 = 1.25992104989487316477; +static float CBRT4 = 1.58740105196819947475; + + +float frexpf(float, int *), ldexpf(float, int); + +float cbrtf( float xx ) +{ +int e, rem, sign; +float x, z; + +x = xx; +if( x == 0 ) + return( 0.0 ); +if( x > 0 ) + sign = 1; +else + { + sign = -1; + x = -x; + } + +z = x; +/* extract power of 2, leaving + * mantissa between 0.5 and 1 + */ +x = frexpf( x, &e ); + +/* Approximate cube root of number between .5 and 1, + * peak relative error = 9.2e-6 + */ +x = (((-0.13466110473359520655053 * x + + 0.54664601366395524503440 ) * x + - 0.95438224771509446525043 ) * x + + 1.1399983354717293273738 ) * x + + 0.40238979564544752126924; + +/* 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; + } + + +/* argument less than 1 */ + +else + { + e = -e; + rem = e; + e /= 3; + rem -= 3*e; + if( rem == 1 ) + x /= CBRT2; + else if( rem == 2 ) + x /= CBRT4; + e = -e; + } + +/* multiply by power of 2 */ +x = ldexpf( x, e ); + +/* Newton iteration */ +x -= ( x - (z/(x*x)) ) * 0.333333333333; + +if( sign < 0 ) + x = -x; +return(x); +} diff --git a/libm/float/chbevlf.c b/libm/float/chbevlf.c new file mode 100644 index 000000000..343d00a22 --- /dev/null +++ b/libm/float/chbevlf.c @@ -0,0 +1,86 @@ +/* chbevlf.c + * + * Evaluate Chebyshev series + * + * + * + * SYNOPSIS: + * + * int N; + * float x, y, coef[N], chebevlf(); + * + * y = chbevlf( x, coef, N ); + * + * + * + * DESCRIPTION: + * + * Evaluates the series + * + * N-1 + * - ' + * y = > coef[i] T (x/2) + * - i + * i=0 + * + * of Chebyshev polynomials Ti at argument x/2. + * + * Coefficients are stored in reverse order, i.e. the zero + * order term is last in the array. Note N is the number of + * coefficients, not the order. + * + * If coefficients are for the interval a to b, x must + * have been transformed to x -> 2(2x - b - a)/(b-a) before + * entering the routine. This maps x from (a, b) to (-1, 1), + * over which the Chebyshev polynomials are defined. + * + * If the coefficients are for the inverted interval, in + * which (a, b) is mapped to (1/b, 1/a), the transformation + * required is x -> 2(2ab/x - b - a)/(b-a). If b is infinity, + * this becomes x -> 4a/x - 1. + * + * + * + * SPEED: + * + * Taking advantage of the recurrence properties of the + * Chebyshev polynomials, the routine requires one more + * addition per loop than evaluating a nested polynomial of + * the same degree. + * + */ + /* chbevl.c */ + +/* +Cephes Math Library Release 2.0: April, 1987 +Copyright 1985, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#ifdef ANSIC +float chbevlf( float x, float *array, int n ) +#else +float chbevlf( x, array, n ) +float x; +float *array; +int n; +#endif +{ +float b0, b1, b2, *p; +int i; + +p = array; +b0 = *p++; +b1 = 0.0; +i = n - 1; + +do + { + b2 = b1; + b1 = b0; + b0 = x * b1 - b2 + *p++; + } +while( --i ); + +return( 0.5*(b0-b2) ); +} diff --git a/libm/float/chdtrf.c b/libm/float/chdtrf.c new file mode 100644 index 000000000..53bd3d961 --- /dev/null +++ b/libm/float/chdtrf.c @@ -0,0 +1,210 @@ +/* chdtrf.c + * + * Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float df, x, y, chdtrf(); + * + * y = chdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 3.2e-5 5.0e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrf domain x < 0 or v < 1 0.0 + */ + /* chdtrcf() + * + * Complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float v, x, y, chdtrcf(); + * + * y = chdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 2.7e-5 3.2e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtrc domain x < 0 or v < 1 0.0 + */ + /* chdtrif() + * + * Inverse of complemented Chi-square distribution + * + * + * + * SYNOPSIS: + * + * float df, x, y, chdtrif(); + * + * x = chdtrif( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 10000 2.2e-5 8.5e-7 + * + * ERROR MESSAGES: + * + * message condition value returned + * chdtri domain y < 0 or y > 1 0.0 + * v < 1 + * + */ + +/* chdtr() */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#ifdef ANSIC +float igamcf(float, float), igamf(float, float), igamif(float, float); +#else +float igamcf(), igamf(), igamif(); +#endif + +float chdtrcf(float dff, float xx) +{ +float df, x; + +df = dff; +x = xx; + +if( (x < 0.0) || (df < 1.0) ) + { + mtherr( "chdtrcf", DOMAIN ); + return(0.0); + } +return( igamcf( 0.5*df, 0.5*x ) ); +} + + +float chdtrf(float dff, float xx) +{ +float df, x; + +df = dff; +x = xx; +if( (x < 0.0) || (df < 1.0) ) + { + mtherr( "chdtrf", DOMAIN ); + return(0.0); + } +return( igamf( 0.5*df, 0.5*x ) ); +} + + +float chdtrif( float dff, float yy ) +{ +float y, df, x; + +y = yy; +df = dff; +if( (y < 0.0) || (y > 1.0) || (df < 1.0) ) + { + mtherr( "chdtrif", DOMAIN ); + return(0.0); + } + +x = igamif( 0.5 * df, y ); +return( 2.0 * x ); +} diff --git a/libm/float/clogf.c b/libm/float/clogf.c new file mode 100644 index 000000000..5f4944eba --- /dev/null +++ b/libm/float/clogf.c @@ -0,0 +1,669 @@ +/* clogf.c + * + * Complex natural logarithm + * + * + * + * SYNOPSIS: + * + * void clogf(); + * cmplxf z, w; + * + * clogf( &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 + * IEEE -10,+10 30000 1.9e-6 6.2e-8 + * + * Larger relative error can be observed for z near 1 +i0. + * In IEEE arithmetic the peak absolute error is 3.1e-7. + * + */ + +#include <math.h> +extern float MAXNUMF, MACHEPF, PIF, PIO2F; +#ifdef ANSIC +float cabsf(cmplxf *), sqrtf(float), logf(float), atan2f(float, float); +float expf(float), sinf(float), cosf(float); +float coshf(float), sinhf(float), asinf(float); +float ctansf(cmplxf *), redupif(float); +void cchshf( float, float *, float * ); +void caddf( cmplxf *, cmplxf *, cmplxf * ); +void csqrtf( cmplxf *, cmplxf * ); +#else +float cabsf(), sqrtf(), logf(), atan2f(); +float expf(), sinf(), cosf(); +float coshf(), sinhf(), asinf(); +float ctansf(), redupif(); +void cchshf(), csqrtf(), caddf(); +#endif + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +void clogf( z, w ) +register cmplxf *z, *w; +{ +float p, rr; + +/*rr = sqrtf( z->r * z->r + z->i * z->i );*/ +rr = cabsf(z); +p = logf(rr); +#if ANSIC +rr = atan2f( z->i, z->r ); +#else +rr = atan2f( z->r, z->i ); +if( rr > PIF ) + rr -= PIF + PIF; +#endif +w->i = rr; +w->r = p; +} + /* cexpf() + * + * Complex exponential function + * + * + * + * SYNOPSIS: + * + * void cexpf(); + * cmplxf z, w; + * + * cexpf( &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 + * IEEE -10,+10 30000 1.4e-7 4.5e-8 + * + */ + +void cexpf( z, w ) +register cmplxf *z, *w; +{ +float r; + +r = expf( z->r ); +w->r = r * cosf( z->i ); +w->i = r * sinf( z->i ); +} + /* csinf() + * + * Complex circular sine + * + * + * + * SYNOPSIS: + * + * void csinf(); + * cmplxf z, w; + * + * csinf( &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 + * IEEE -10,+10 30000 1.9e-7 5.5e-8 + * + */ + +void csinf( z, w ) +register cmplxf *z, *w; +{ +float ch, sh; + +cchshf( z->i, &ch, &sh ); +w->r = sinf( z->r ) * ch; +w->i = cosf( z->r ) * sh; +} + + + +/* calculate cosh and sinh */ + +void cchshf( float xx, float *c, float *s ) +{ +float x, e, ei; + +x = xx; +if( fabsf(x) <= 0.5f ) + { + *c = coshf(x); + *s = sinhf(x); + } +else + { + e = expf(x); + ei = 0.5f/e; + e = 0.5f * e; + *s = e - ei; + *c = e + ei; + } +} + + /* ccosf() + * + * Complex circular cosine + * + * + * + * SYNOPSIS: + * + * void ccosf(); + * cmplxf z, w; + * + * ccosf( &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 + * IEEE -10,+10 30000 1.8e-7 5.5e-8 + */ + +void ccosf( z, w ) +register cmplxf *z, *w; +{ +float ch, sh; + +cchshf( z->i, &ch, &sh ); +w->r = cosf( z->r ) * ch; +w->i = -sinf( z->r ) * sh; +} + /* ctanf() + * + * Complex circular tangent + * + * + * + * SYNOPSIS: + * + * void ctanf(); + * cmplxf z, w; + * + * ctanf( &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 + * IEEE -10,+10 30000 3.3e-7 5.1e-8 + */ + +void ctanf( z, w ) +register cmplxf *z, *w; +{ +float d; + +d = cosf( 2.0f * z->r ) + coshf( 2.0f * z->i ); + +if( fabsf(d) < 0.25f ) + d = ctansf(z); + +if( d == 0.0f ) + { + mtherr( "ctanf", OVERFLOW ); + w->r = MAXNUMF; + w->i = MAXNUMF; + return; + } + +w->r = sinf( 2.0f * z->r ) / d; +w->i = sinhf( 2.0f * z->i ) / d; +} + /* ccotf() + * + * Complex circular cotangent + * + * + * + * SYNOPSIS: + * + * void ccotf(); + * cmplxf z, w; + * + * ccotf( &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 + * IEEE -10,+10 30000 3.6e-7 5.7e-8 + * Also tested by ctan * ccot = 1 + i0. + */ + +void ccotf( z, w ) +register cmplxf *z, *w; +{ +float d; + + +d = coshf(2.0f * z->i) - cosf(2.0f * z->r); + +if( fabsf(d) < 0.25f ) + d = ctansf(z); + +if( d == 0.0f ) + { + mtherr( "ccotf", OVERFLOW ); + w->r = MAXNUMF; + w->i = MAXNUMF; + return; + } + +d = 1.0f/d; +w->r = sinf( 2.0f * z->r ) * d; +w->i = -sinhf( 2.0f * z->i ) * d; +} + +/* Program to subtract nearest integer multiple of PI */ +/* extended precision value of PI: */ + +static float DP1 = 3.140625; +static float DP2 = 9.67502593994140625E-4; +static float DP3 = 1.509957990978376432E-7; + + +float redupif(float xx) +{ +float x, t; +long i; + +x = xx; +t = x/PIF; +if( t >= 0.0f ) + t += 0.5f; +else + t -= 0.5f; + +i = t; /* the multiple */ +t = i; +t = ((x - t * DP1) - t * DP2) - t * DP3; +return(t); +} + +/* Taylor series expansion for cosh(2y) - cos(2x) */ + +float ctansf(z) +cmplxf *z; +{ +float f, x, x2, y, y2, rn, t, d; + +x = fabsf( 2.0f * z->r ); +y = fabsf( 2.0f * z->i ); + +x = redupif(x); + +x = x * x; +y = y * y; +x2 = 1.0f; +y2 = 1.0f; +f = 1.0f; +rn = 0.0f; +d = 0.0f; +do + { + rn += 1.0f; + f *= rn; + rn += 1.0f; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 + x2; + t /= f; + d += t; + + rn += 1.0f; + f *= rn; + rn += 1.0f; + f *= rn; + x2 *= x; + y2 *= y; + t = y2 - x2; + t /= f; + d += t; + } +while( fabsf(t/d) > MACHEPF ); +return(d); +} + /* casinf() + * + * Complex circular arc sine + * + * + * + * SYNOPSIS: + * + * void casinf(); + * cmplxf z, w; + * + * casinf( &z, &w ); + * + * + * + * DESCRIPTION: + * + * Inverse complex sine: + * + * 2 + * w = -i clog( iz + csqrt( 1 - z ) ). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 1.1e-5 1.5e-6 + * Larger relative error can be observed for z near zero. + * + */ + +void casinf( z, w ) +cmplxf *z, *w; +{ +float x, y; +static cmplxf ca, ct, zz, z2; +/* +float cn, n; +static float a, b, s, t, u, v, y2; +static cmplxf sum; +*/ + +x = z->r; +y = z->i; + +if( y == 0.0f ) + { + if( fabsf(x) > 1.0f ) + { + w->r = PIO2F; + w->i = 0.0f; + mtherr( "casinf", DOMAIN ); + } + else + { + w->r = asinf(x); + w->i = 0.0f; + } + return; + } + +/* Power series expansion */ +/* +b = cabsf(z); +if( b < 0.125 ) +{ +z2.r = (x - y) * (x + y); +z2.i = 2.0 * x * y; + +cn = 1.0; +n = 1.0; +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.0; + cn /= n; + n += 1.0; + b = cn/n; + + ct.r *= b; + ct.i *= b; + sum.r += ct.r; + sum.i += ct.i; + b = fabsf(ct.r) + fabsf(ct.i); + } +while( b > MACHEPF ); +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.0f * ca.r * ca.i; + +zz.r = 1.0f - zz.r; +zz.i = -zz.i; +csqrtf( &zz, &z2 ); + +caddf( &z2, &ct, &zz ); +clogf( &zz, &zz ); +w->r = zz.i; /* mult by 1/i = -i */ +w->i = -zz.r; +return; +} + /* cacosf() + * + * Complex circular arc cosine + * + * + * + * SYNOPSIS: + * + * void cacosf(); + * cmplxf z, w; + * + * cacosf( &z, &w ); + * + * + * + * DESCRIPTION: + * + * + * w = arccos z = PI/2 - arcsin z. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,+10 30000 9.2e-6 1.2e-6 + * + */ + +void cacosf( z, w ) +cmplxf *z, *w; +{ + +casinf( z, w ); +w->r = PIO2F - w->r; +w->i = -w->i; +} + /* catan() + * + * Complex circular arc tangent + * + * + * + * SYNOPSIS: + * + * void catan(); + * cmplxf z, w; + * + * catan( &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 + * IEEE -10,+10 30000 2.3e-6 5.2e-8 + * + */ + +void catanf( z, w ) +cmplxf *z, *w; +{ +float a, t, x, x2, y; + +x = z->r; +y = z->i; + +if( (x == 0.0f) && (y > 1.0f) ) + goto ovrf; + +x2 = x * x; +a = 1.0f - x2 - (y * y); +if( a == 0.0f ) + goto ovrf; + +#if ANSIC +t = 0.5f * atan2f( 2.0f * x, a ); +#else +t = 0.5f * atan2f( a, 2.0f * x ); +#endif +w->r = redupif( t ); + +t = y - 1.0f; +a = x2 + (t * t); +if( a == 0.0f ) + goto ovrf; + +t = y + 1.0f; +a = (x2 + (t * t))/a; +w->i = 0.25f*logf(a); +return; + +ovrf: +mtherr( "catanf", OVERFLOW ); +w->r = MAXNUMF; +w->i = MAXNUMF; +} diff --git a/libm/float/cmplxf.c b/libm/float/cmplxf.c new file mode 100644 index 000000000..949b94e3d --- /dev/null +++ b/libm/float/cmplxf.c @@ -0,0 +1,407 @@ +/* cmplxf.c + * + * Complex number arithmetic + * + * + * + * SYNOPSIS: + * + * typedef struct { + * float r; real part + * float i; imaginary part + * }cmplxf; + * + * cmplxf *a, *b, *c; + * + * caddf( a, b, c ); c = b + a + * csubf( a, b, c ); c = b - a + * cmulf( a, b, c ); c = b * a + * cdivf( a, b, c ); c = b / a + * cnegf( c ); c = -c + * cmovf( 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 + * IEEE cadd 30000 5.9e-8 2.6e-8 + * IEEE csub 30000 6.0e-8 2.6e-8 + * IEEE cmul 30000 1.1e-7 3.7e-8 + * IEEE cdiv 30000 2.1e-7 5.7e-8 + */ + /* cmplx.c + * complex number arithmetic + */ + + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> +extern float MAXNUMF, MACHEPF, PIF, PIO2F; +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) +#ifdef ANSIC +float sqrtf(float), frexpf(float, int *); +float ldexpf(float, int); +float cabsf(cmplxf *), atan2f(float, float), cosf(float), sinf(float); +#else +float sqrtf(), frexpf(), ldexpf(); +float cabsf(), atan2f(), cosf(), sinf(); +#endif +/* +typedef struct + { + float r; + float i; + }cmplxf; +*/ +cmplxf czerof = {0.0, 0.0}; +extern cmplxf czerof; +cmplxf conef = {1.0, 0.0}; +extern cmplxf conef; + +/* c = b + a */ + +void caddf( a, b, c ) +register cmplxf *a, *b; +cmplxf *c; +{ + +c->r = b->r + a->r; +c->i = b->i + a->i; +} + + +/* c = b - a */ + +void csubf( a, b, c ) +register cmplxf *a, *b; +cmplxf *c; +{ + +c->r = b->r - a->r; +c->i = b->i - a->i; +} + +/* c = b * a */ + +void cmulf( a, b, c ) +register cmplxf *a, *b; +cmplxf *c; +{ +register float 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 cdivf( a, b, c ) +register cmplxf *a, *b; +cmplxf *c; +{ +float 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.0f ) + { + w = MAXNUMF * y; + if( (fabsf(p) > w) || (fabsf(q) > w) || (y == 0.0f) ) + { + c->r = MAXNUMF; + c->i = MAXNUMF; + mtherr( "cdivf", OVERFLOW ); + return; + } + } +c->r = p/y; +c->i = q/y; +} + + +/* b = a */ + +void cmovf( a, b ) +register short *a, *b; +{ +int i; + + +i = 8; +do + *b++ = *a++; +while( --i ); +} + + +void cnegf( a ) +register cmplxf *a; +{ + +a->r = -a->r; +a->i = -a->i; +} + +/* cabsf() + * + * Complex absolute value + * + * + * + * SYNOPSIS: + * + * float cabsf(); + * cmplxf z; + * float a; + * + * a = cabsf( &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 + * IEEE -10,+10 30000 1.2e-7 3.4e-8 + */ + + +/* +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 + { + float r; + float i; + }cmplxf; +*/ +/* square root of max and min numbers */ +#define SMAX 1.3043817825332782216E+19 +#define SMIN 7.6664670834168704053E-20 +#define PREC 12 +#define MAXEXPF 128 + + +#define SMAXT (2.0f * SMAX) +#define SMINT (0.5f * SMIN) + +float cabsf( z ) +register cmplxf *z; +{ +float x, y, b, re, im; +int ex, ey, e; + +re = fabsf( z->r ); +im = fabsf( z->i ); + +if( re == 0.0f ) + { + return( im ); + } +if( im == 0.0f ) + { + return( re ); + } + +/* Get the exponents of the numbers */ +x = frexpf( re, &ex ); +y = frexpf( im, &ey ); + +/* Check if one number is tiny compared to the other */ +e = ex - ey; +if( e > PREC ) + return( re ); +if( e < -PREC ) + return( im ); + +/* Find approximate exponent e of the geometric mean. */ +e = (ex + ey) >> 1; + +/* Rescale so mean is about 1 */ +x = ldexpf( re, -e ); +y = ldexpf( im, -e ); + +/* Hypotenuse of the right triangle */ +b = sqrtf( x * x + y * y ); + +/* Compute the exponent of the answer. */ +y = frexpf( b, &ey ); +ey = e + ey; + +/* Check it for overflow and underflow. */ +if( ey > MAXEXPF ) + { + mtherr( "cabsf", OVERFLOW ); + return( MAXNUMF ); + } +if( ey < -MAXEXPF ) + return(0.0f); + +/* Undo the scaling */ +b = ldexpf( b, e ); +return( b ); +} + /* csqrtf() + * + * Complex square root + * + * + * + * SYNOPSIS: + * + * void csqrtf(); + * cmplxf z, w; + * + * csqrtf( &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 solution + * reported 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 + * IEEE -10,+10 100000 1.8e-7 4.2e-8 + * + */ + + +void csqrtf( z, w ) +cmplxf *z, *w; +{ +cmplxf q, s; +float x, y, r, t; + +x = z->r; +y = z->i; + +if( y == 0.0f ) + { + if( x < 0.0f ) + { + w->r = 0.0f; + w->i = sqrtf(-x); + return; + } + else + { + w->r = sqrtf(x); + w->i = 0.0f; + return; + } + } + +if( x == 0.0f ) + { + r = fabsf(y); + r = sqrtf(0.5f*r); + if( y > 0 ) + 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( (fabsf(y) < fabsf(0.015f*x)) + && (x > 0) ) + { + t = 0.25f*y*(y/x); + } +else + { + r = cabsf(z); + t = 0.5f*(r - x); + } + +r = sqrtf(t); +q.i = r; +q.r = 0.5f*y/r; + +/* Heron iteration in complex arithmetic: + * q = (q + z/q)/2 + */ +cdivf( &q, z, &s ); +caddf( &q, &s, w ); +w->r *= 0.5f; +w->i *= 0.5f; +} + diff --git a/libm/float/constf.c b/libm/float/constf.c new file mode 100644 index 000000000..bf6b6f657 --- /dev/null +++ b/libm/float/constf.c @@ -0,0 +1,20 @@ + +#ifdef DEC +/* MAXNUMF = 2^127 * (1 - 2^-24) */ +float MAXNUMF = 1.7014117331926442990585209174225846272e38; +float MAXLOGF = 88.02969187150841; +float MINLOGF = -88.7228391116729996; /* log(2^-128) */ +#else +/* MAXNUMF = 2^128 * (1 - 2^-24) */ +float MAXNUMF = 3.4028234663852885981170418348451692544e38; +float MAXLOGF = 88.72283905206835; +float MINLOGF = -103.278929903431851103; /* log(2^-149) */ +#endif + +float LOG2EF = 1.44269504088896341; +float LOGE2F = 0.693147180559945309; +float SQRTHF = 0.707106781186547524; +float PIF = 3.141592653589793238; +float PIO2F = 1.5707963267948966192; +float PIO4F = 0.7853981633974483096; +float MACHEPF = 5.9604644775390625E-8; diff --git a/libm/float/coshf.c b/libm/float/coshf.c new file mode 100644 index 000000000..2b44fdeb3 --- /dev/null +++ b/libm/float/coshf.c @@ -0,0 +1,67 @@ +/* coshf.c + * + * Hyperbolic cosine + * + * + * + * SYNOPSIS: + * + * float x, y, coshf(); + * + * y = coshf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic cosine of argument in the range MINLOGF to + * MAXLOGF. + * + * cosh(x) = ( exp(x) + exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-MAXLOGF 100000 1.2e-7 2.8e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * coshf overflow |x| > MAXLOGF MAXNUMF + * + * + */ + +/* cosh.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1985, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float MAXLOGF, MAXNUMF; + +float expf(float); + +float coshf(float xx) +{ +float x, y; + +x = xx; +if( x < 0 ) + x = -x; +if( x > MAXLOGF ) + { + mtherr( "coshf", OVERFLOW ); + return( MAXNUMF ); + } +y = expf(x); +y = y + 1.0/y; +return( 0.5*y ); +} diff --git a/libm/float/dawsnf.c b/libm/float/dawsnf.c new file mode 100644 index 000000000..d00607719 --- /dev/null +++ b/libm/float/dawsnf.c @@ -0,0 +1,168 @@ +/* dawsnf.c + * + * Dawson's Integral + * + * + * + * SYNOPSIS: + * + * float x, y, dawsnf(); + * + * y = dawsnf( x ); + * + * + * + * DESCRIPTION: + * + * Approximates the integral + * + * x + * - + * 2 | | 2 + * dawsn(x) = exp( -x ) | exp( t ) dt + * | | + * - + * 0 + * + * Three different rational approximations are employed, for + * the intervals 0 to 3.25; 3.25 to 6.25; and 6.25 up. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,10 50000 4.4e-7 6.3e-8 + * + * + */ + +/* dawsn.c */ + + +/* +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 +*/ + +#include <math.h> +/* Dawson's integral, interval 0 to 3.25 */ +static float AN[10] = { + 1.13681498971755972054E-11, + 8.49262267667473811108E-10, + 1.94434204175553054283E-8, + 9.53151741254484363489E-7, + 3.07828309874913200438E-6, + 3.52513368520288738649E-4, +-8.50149846724410912031E-4, + 4.22618223005546594270E-2, +-9.17480371773452345351E-2, + 9.99999999999999994612E-1, +}; +static float AD[11] = { + 2.40372073066762605484E-11, + 1.48864681368493396752E-9, + 5.21265281010541664570E-8, + 1.27258478273186970203E-6, + 2.32490249820789513991E-5, + 3.25524741826057911661E-4, + 3.48805814657162590916E-3, + 2.79448531198828973716E-2, + 1.58874241960120565368E-1, + 5.74918629489320327824E-1, + 1.00000000000000000539E0, +}; + +/* interval 3.25 to 6.25 */ +static float BN[11] = { + 5.08955156417900903354E-1, +-2.44754418142697847934E-1, + 9.41512335303534411857E-2, +-2.18711255142039025206E-2, + 3.66207612329569181322E-3, +-4.23209114460388756528E-4, + 3.59641304793896631888E-5, +-2.14640351719968974225E-6, + 9.10010780076391431042E-8, +-2.40274520828250956942E-9, + 3.59233385440928410398E-11, +}; +static float BD[10] = { +/* 1.00000000000000000000E0,*/ +-6.31839869873368190192E-1, + 2.36706788228248691528E-1, +-5.31806367003223277662E-2, + 8.48041718586295374409E-3, +-9.47996768486665330168E-4, + 7.81025592944552338085E-5, +-4.55875153252442634831E-6, + 1.89100358111421846170E-7, +-4.91324691331920606875E-9, + 7.18466403235734541950E-11, +}; + +/* 6.25 to infinity */ +static float CN[5] = { +-5.90592860534773254987E-1, + 6.29235242724368800674E-1, +-1.72858975380388136411E-1, + 1.64837047825189632310E-2, +-4.86827613020462700845E-4, +}; +static float CD[5] = { +/* 1.00000000000000000000E0,*/ +-2.69820057197544900361E0, + 1.73270799045947845857E0, +-3.93708582281939493482E-1, + 3.44278924041233391079E-2, +-9.73655226040941223894E-4, +}; + + +extern float PIF, MACHEPF; +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) +#ifdef ANSIC +float polevlf(float, float *, int); +float p1evlf(float, float *, int); +#else +float polevlf(), p1evlf(); +#endif + +float dawsnf( float xxx ) +{ +float xx, x, y; +int sign; + +xx = xxx; +sign = 1; +if( xx < 0.0 ) + { + sign = -1; + xx = -xx; + } + +if( xx < 3.25 ) + { + x = xx*xx; + y = xx * polevlf( x, AN, 9 )/polevlf( x, AD, 10 ); + return( sign * y ); + } + + +x = 1.0/(xx*xx); + +if( xx < 6.25 ) + { + y = 1.0/xx + x * polevlf( x, BN, 10) / (p1evlf( x, BD, 10) * xx); + return( sign * 0.5 * y ); + } + + +if( xx > 1.0e9 ) + return( (sign * 0.5)/xx ); + +/* 6.25 to infinity */ +y = 1.0/xx + x * polevlf( x, CN, 4) / (p1evlf( x, CD, 5) * xx); +return( sign * 0.5 * y ); +} diff --git a/libm/float/ellief.c b/libm/float/ellief.c new file mode 100644 index 000000000..5c3f822df --- /dev/null +++ b/libm/float/ellief.c @@ -0,0 +1,115 @@ +/* ellief.c + * + * Incomplete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * float phi, m, y, ellief(); + * + * y = ellief( 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 [0, 2] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,2 10000 4.5e-7 7.4e-8 + * + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Incomplete elliptic integral of second kind */ + +#include <math.h> + +extern float PIF, PIO2F, MACHEPF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float sqrtf(float), logf(float), sinf(float), tanf(float), atanf(float); +float ellpef(float), ellpkf(float); +#else +float sqrtf(), logf(), sinf(), tanf(), atanf(); +float ellpef(), ellpkf(); +#endif + + +float ellief( float phia, float ma ) +{ +float phi, m, a, b, c, e, temp; +float lphi, t; +int d, mod; + +phi = phia; +m = ma; +if( m == 0.0 ) + return( phi ); +if( m == 1.0 ) + return( sinf(phi) ); +lphi = phi; +if( lphi < 0.0 ) + lphi = -lphi; +a = 1.0; +b = 1.0 - m; +b = sqrtf(b); +c = sqrtf(m); +d = 1; +e = 0.0; +t = tanf( lphi ); +mod = (lphi + PIO2F)/PIF; + +while( fabsf(c/a) > MACHEPF ) + { + temp = b/a; + lphi = lphi + atanf(t*temp) + mod * PIF; + mod = (lphi + PIO2F)/PIF; + t = t * ( 1.0 + temp )/( 1.0 - temp * t * t ); + c = 0.5 * ( a - b ); + temp = sqrtf( a * b ); + a = 0.5 * ( a + b ); + b = temp; + d += d; + e += c * sinf(lphi); + } + +b = 1.0 - m; +temp = ellpef(b)/ellpkf(b); +temp *= (atanf(t) + mod * PIF)/(d * a); +temp += e; +if( phi < 0.0 ) + temp = -temp; +return( temp ); +} diff --git a/libm/float/ellikf.c b/libm/float/ellikf.c new file mode 100644 index 000000000..8ec890926 --- /dev/null +++ b/libm/float/ellikf.c @@ -0,0 +1,113 @@ +/* ellikf.c + * + * Incomplete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * float phi, m, y, ellikf(); + * + * y = ellikf( 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 phi in [0, 2] and m in + * [0, 1]. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,2 10000 2.9e-7 5.8e-8 + * + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Incomplete elliptic integral of first kind */ + +#include <math.h> +extern float PIF, PIO2F, MACHEPF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float sqrtf(float), logf(float), sinf(float), tanf(float), atanf(float); +#else +float sqrtf(), logf(), sinf(), tanf(), atanf(); +#endif + + +float ellikf( float phia, float ma ) +{ +float phi, m, a, b, c, temp; +float t; +int d, mod, sign; + +phi = phia; +m = ma; +if( m == 0.0 ) + return( phi ); +if( phi < 0.0 ) + { + phi = -phi; + sign = -1; + } +else + sign = 0; +a = 1.0; +b = 1.0 - m; +if( b == 0.0 ) + return( logf( tanf( 0.5*(PIO2F + phi) ) ) ); +b = sqrtf(b); +c = sqrtf(m); +d = 1; +t = tanf( phi ); +mod = (phi + PIO2F)/PIF; + +while( fabsf(c/a) > MACHEPF ) + { + temp = b/a; + phi = phi + atanf(t*temp) + mod * PIF; + mod = (phi + PIO2F)/PIF; + t = t * ( 1.0 + temp )/( 1.0 - temp * t * t ); + c = ( a - b )/2.0; + temp = sqrtf( a * b ); + a = ( a + b )/2.0; + b = temp; + d += d; + } + +temp = (atanf(t) + mod * PIF)/(d * a); +if( sign < 0 ) + temp = -temp; +return( temp ); +} diff --git a/libm/float/ellpef.c b/libm/float/ellpef.c new file mode 100644 index 000000000..645bc55ba --- /dev/null +++ b/libm/float/ellpef.c @@ -0,0 +1,105 @@ +/* ellpef.c + * + * Complete elliptic integral of the second kind + * + * + * + * SYNOPSIS: + * + * float m1, y, ellpef(); + * + * y = ellpef( 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 30000 1.1e-7 3.9e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpef domain x<0, x>1 0.0 + * + */ + +/* ellpe.c */ + +/* Elliptic integral of second kind */ + +/* +Cephes Math Library, Release 2.1: February, 1989 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + + +static float P[] = { + 1.53552577301013293365E-4, + 2.50888492163602060990E-3, + 8.68786816565889628429E-3, + 1.07350949056076193403E-2, + 7.77395492516787092951E-3, + 7.58395289413514708519E-3, + 1.15688436810574127319E-2, + 2.18317996015557253103E-2, + 5.68051945617860553470E-2, + 4.43147180560990850618E-1, + 1.00000000000000000299E0 +}; +static float Q[] = { + 3.27954898576485872656E-5, + 1.00962792679356715133E-3, + 6.50609489976927491433E-3, + 1.68862163993311317300E-2, + 2.61769742454493659583E-2, + 3.34833904888224918614E-2, + 4.27180926518931511717E-2, + 5.85936634471101055642E-2, + 9.37499997197644278445E-2, + 2.49999999999888314361E-1 +}; + +float polevlf(float, float *, int), logf(float); +float ellpef( float xx) +{ +float x; + +x = xx; +if( (x <= 0.0) || (x > 1.0) ) + { + if( x == 0.0 ) + return( 1.0 ); + mtherr( "ellpef", DOMAIN ); + return( 0.0 ); + } +return( polevlf(x,P,10) - logf(x) * (x * polevlf(x,Q,9)) ); +} diff --git a/libm/float/ellpjf.c b/libm/float/ellpjf.c new file mode 100644 index 000000000..552f5ffe4 --- /dev/null +++ b/libm/float/ellpjf.c @@ -0,0 +1,161 @@ +/* ellpjf.c + * + * Jacobian Elliptic Functions + * + * + * + * SYNOPSIS: + * + * float u, m, sn, cn, dn, phi; + * int ellpj(); + * + * ellpj( 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-9 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-6 2.2e-7 + * IEEE cn 10000 1.6e-6 2.2e-7 + * IEEE dn 10000 1.4e-3 1.9e-5 + * IEEE phi 10000 3.9e-7* 6.7e-8* + * + * Peak error observed in consistency check using addition + * theorem for sn(u+v) was 4e-16 (absolute). Also tested by + * the above relation to the incomplete elliptic integral. + * Accuracy deteriorates when u is large. + * + */ + +/* ellpj.c */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float PIO2F, MACHEPF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float sqrtf(float), sinf(float), cosf(float), asinf(float), tanhf(float); +float sinhf(float), coshf(float), atanf(float), expf(float); +#else +float sqrtf(), sinf(), cosf(), asinf(), tanhf(); +float sinhf(), coshf(), atanf(), expf(); +#endif + +int ellpjf( float uu, float mm, + float *sn, float *cn, float *dn, float *ph ) +{ +float u, m, ai, b, phi, t, twon; +float a[10], c[10]; +int i; + +u = uu; +m = mm; +/* Check for special cases */ + +if( m < 0.0 || m > 1.0 ) + { + mtherr( "ellpjf", DOMAIN ); + return(-1); + } +if( m < 1.0e-5 ) + { + t = sinf(u); + b = cosf(u); + ai = 0.25 * m * (u - t*b); + *sn = t - ai*b; + *cn = b + ai*t; + *ph = u - ai; + *dn = 1.0 - 0.5*m*t*t; + return(0); + } + +if( m >= 0.99999 ) + { + ai = 0.25 * (1.0-m); + b = coshf(u); + t = tanhf(u); + phi = 1.0/b; + twon = b * sinhf(u); + *sn = t + ai * (twon - u)/(b*b); + *ph = 2.0*atanf(expf(u)) - PIO2F + 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.0; +b = sqrtf(1.0 - m); +c[0] = sqrtf(m); +twon = 1.0; +i = 0; + +while( fabsf( (c[i]/a[i]) ) > MACHEPF ) + { + if( i > 8 ) + { +/* mtherr( "ellpjf", OVERFLOW );*/ + break; + } + ai = a[i]; + ++i; + c[i] = 0.5 * ( ai - b ); + t = sqrtf( ai * b ); + a[i] = 0.5 * ( ai + b ); + b = t; + twon += twon; + } + + +/* backward recurrence */ +phi = twon * a[i] * u; +do + { + t = c[i] * sinf(phi) / a[i]; + b = phi; + phi = 0.5 * (asinf(t) + phi); + } +while( --i ); + +*sn = sinf(phi); +t = cosf(phi); +*cn = t; +*dn = t/cosf(phi-b); +*ph = phi; +return(0); +} diff --git a/libm/float/ellpkf.c b/libm/float/ellpkf.c new file mode 100644 index 000000000..2cc13d90a --- /dev/null +++ b/libm/float/ellpkf.c @@ -0,0 +1,128 @@ +/* ellpkf.c + * + * Complete elliptic integral of the first kind + * + * + * + * SYNOPSIS: + * + * float m1, y, ellpkf(); + * + * y = ellpkf( 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 30000 1.3e-7 3.4e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * ellpkf domain x<0, x>1 0.0 + * + */ + +/* ellpk.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> + +static float P[] = +{ + 1.37982864606273237150E-4, + 2.28025724005875567385E-3, + 7.97404013220415179367E-3, + 9.85821379021226008714E-3, + 6.87489687449949877925E-3, + 6.18901033637687613229E-3, + 8.79078273952743772254E-3, + 1.49380448916805252718E-2, + 3.08851465246711995998E-2, + 9.65735902811690126535E-2, + 1.38629436111989062502E0 +}; + +static float Q[] = +{ + 2.94078955048598507511E-5, + 9.14184723865917226571E-4, + 5.94058303753167793257E-3, + 1.54850516649762399335E-2, + 2.39089602715924892727E-2, + 3.01204715227604046988E-2, + 3.73774314173823228969E-2, + 4.88280347570998239232E-2, + 7.03124996963957469739E-2, + 1.24999999999870820058E-1, + 4.99999999999999999821E-1 +}; +static float C1 = 1.3862943611198906188E0; /* log(4) */ + +extern float MACHEPF, MAXNUMF; + +float polevlf(float, float *, int); +float p1evlf(float, float *, int); +float logf(float); +float ellpkf(float xx) +{ +float x; + +x = xx; +if( (x < 0.0) || (x > 1.0) ) + { + mtherr( "ellpkf", DOMAIN ); + return( 0.0 ); + } + +if( x > MACHEPF ) + { + return( polevlf(x,P,10) - logf(x) * polevlf(x,Q,10) ); + } +else + { + if( x == 0.0 ) + { + mtherr( "ellpkf", SING ); + return( MAXNUMF ); + } + else + { + return( C1 - 0.5 * logf(x) ); + } + } +} diff --git a/libm/float/exp10f.c b/libm/float/exp10f.c new file mode 100644 index 000000000..c7c62c567 --- /dev/null +++ b/libm/float/exp10f.c @@ -0,0 +1,115 @@ +/* exp10f.c + * + * Base 10 exponential function + * (Common antilogarithm) + * + * + * + * SYNOPSIS: + * + * float x, y, exp10f(); + * + * y = exp10f( 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). + * A polynomial approximates 10**f. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -38,+38 100000 9.8e-8 2.8e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * exp10 underflow x < -MAXL10 0.0 + * exp10 overflow x > MAXL10 MAXNUM + * + * IEEE single arithmetic: MAXL10 = 38.230809449325611792. + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +static float P[] = { + 2.063216740311022E-001, + 5.420251702225484E-001, + 1.171292686296281E+000, + 2.034649854009453E+000, + 2.650948748208892E+000, + 2.302585167056758E+000 +}; + +/*static float LOG102 = 3.01029995663981195214e-1;*/ +static float LOG210 = 3.32192809488736234787e0; +static float LG102A = 3.00781250000000000000E-1; +static float LG102B = 2.48745663981195213739E-4; +static float MAXL10 = 38.230809449325611792; + + + + +extern float MAXNUMF; + +float floorf(float), ldexpf(float, int), polevlf(float, float *, int); + +float exp10f(float xx) +{ +float x, px, qx; +short n; + +x = xx; +if( x > MAXL10 ) + { + mtherr( "exp10f", OVERFLOW ); + return( MAXNUMF ); + } + +if( x < -MAXL10 ) /* Would like to use MINLOG but can't */ + { + mtherr( "exp10f", UNDERFLOW ); + return(0.0); + } + +/* The following is necessary because range reduction blows up: */ +if( x == 0 ) + return(1.0); + +/* Express 10**x = 10**g 2**n + * = 10**g 10**( n log10(2) ) + * = 10**( g + n log10(2) ) + */ +px = x * LOG210; +qx = floorf( px + 0.5 ); +n = qx; +x -= qx * LG102A; +x -= qx * LG102B; + +/* rational approximation for exponential + * of the fractional part: + * 10**x - 1 = 2x P(x**2)/( Q(x**2) - P(x**2) ) + */ +px = 1.0 + x * polevlf( x, P, 5 ); + +/* multiply by power of 2 */ +x = ldexpf( px, n ); + +return(x); +} diff --git a/libm/float/exp2f.c b/libm/float/exp2f.c new file mode 100644 index 000000000..0de21decd --- /dev/null +++ b/libm/float/exp2f.c @@ -0,0 +1,116 @@ +/* exp2f.c + * + * Base 2 exponential function + * + * + * + * SYNOPSIS: + * + * float x, y, exp2f(); + * + * y = exp2f( 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 polynomial approximates 2**x in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -127,+127 100000 1.7e-7 2.8e-8 + * + * + * See exp.c for comments on error amplification. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * exp underflow x < -MAXL2 0.0 + * exp overflow x > MAXL2 MAXNUMF + * + * For IEEE arithmetic, MAXL2 = 127. + */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + + +#include <math.h> +static char fname[] = {"exp2f"}; + +static float P[] = { + 1.535336188319500E-004, + 1.339887440266574E-003, + 9.618437357674640E-003, + 5.550332471162809E-002, + 2.402264791363012E-001, + 6.931472028550421E-001 +}; +#define MAXL2 127.0 +#define MINL2 -127.0 + + + +extern float MAXNUMF; + +float polevlf(float, float *, int), floorf(float), ldexpf(float, int); + +float exp2f( float xx ) +{ +float x, px; +int i0; + +x = xx; +if( x > MAXL2) + { + mtherr( fname, OVERFLOW ); + return( MAXNUMF ); + } + +if( x < MINL2 ) + { + mtherr( fname, UNDERFLOW ); + return(0.0); + } + +/* The following is necessary because range reduction blows up: */ +if( x == 0 ) + return(1.0); + +/* separate into integer and fractional parts */ +px = floorf(x); +i0 = px; +x = x - px; + +if( x > 0.5 ) + { + i0 += 1; + x -= 1.0; + } + +/* rational approximation + * exp2(x) = 1.0 + xP(x) + */ +px = 1.0 + x * polevlf( x, P, 5 ); + +/* scale by power of 2 */ +px = ldexpf( px, i0 ); +return(px); +} diff --git a/libm/float/expf.c b/libm/float/expf.c new file mode 100644 index 000000000..073678b99 --- /dev/null +++ b/libm/float/expf.c @@ -0,0 +1,122 @@ +/* expf.c + * + * Exponential function + * + * + * + * SYNOPSIS: + * + * float x, y, expf(); + * + * y = expf( 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 polynomial is used to approximate exp(f) + * in the basic range [-0.5, 0.5]. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +- MAXLOG 100000 1.7e-7 2.8e-8 + * + * + * 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 double precision + * computer number, the result contains amplified roundoff + * error for large arguments not exactly represented. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * expf underflow x < MINLOGF 0.0 + * expf overflow x > MAXLOGF MAXNUMF + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision exponential function. + * test interval: [-0.5, +0.5] + * trials: 80000 + * peak relative error: 7.6e-8 + * rms relative error: 2.8e-8 + */ +#include <math.h> +extern float LOG2EF, MAXLOGF, MINLOGF, MAXNUMF; + +static float C1 = 0.693359375; +static float C2 = -2.12194440e-4; + + + +float floorf( float ), ldexpf( float, int ); + +float expf( float xx ) +{ +float x, z; +int n; + +x = xx; + + +if( x > MAXLOGF) + { + mtherr( "expf", OVERFLOW ); + return( MAXNUMF ); + } + +if( x < MINLOGF ) + { + mtherr( "expf", UNDERFLOW ); + return(0.0); + } + +/* Express e**x = e**g 2**n + * = e**g e**( n loge(2) ) + * = e**( g + n loge(2) ) + */ +z = floorf( LOG2EF * x + 0.5 ); /* floor() truncates toward -infinity. */ +x -= z * C1; +x -= z * C2; +n = z; + +z = x * x; +/* Theoretical peak relative error in [-0.5, +0.5] is 4.2e-9. */ +z = +((((( 1.9875691500E-4 * x + + 1.3981999507E-3) * x + + 8.3334519073E-3) * x + + 4.1665795894E-2) * x + + 1.6666665459E-1) * x + + 5.0000001201E-1) * z + + x + + 1.0; + +/* multiply by power of 2 */ +x = ldexpf( z, n ); + +return( x ); +} diff --git a/libm/float/expnf.c b/libm/float/expnf.c new file mode 100644 index 000000000..ebf0ccb3e --- /dev/null +++ b/libm/float/expnf.c @@ -0,0 +1,207 @@ +/* expnf.c + * + * Exponential integral En + * + * + * + * SYNOPSIS: + * + * int n; + * float x, y, expnf(); + * + * y = expnf( n, x ); + * + * + * + * DESCRIPTION: + * + * Evaluates the exponential integral + * + * inf. + * - + * | | -xt + * | e + * E (x) = | ---- dt. + * n | n + * | | t + * - + * 1 + * + * + * Both n and x must be nonnegative. + * + * The routine employs either a power series, a continued + * fraction, or an asymptotic formula depending on the + * relative values of n and x. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 10000 5.6e-7 1.2e-7 + * + */ + +/* expn.c */ + +/* Cephes Math Library Release 2.2: July, 1992 + * Copyright 1985, 1992 by Stephen L. Moshier + * Direct inquiries to 30 Frost Street, Cambridge, MA 02140 */ + +#include <math.h> + +#define EUL 0.57721566490153286060 +#define BIG 16777216. +extern float MAXNUMF, MACHEPF, MAXLOGF; +#ifdef ANSIC +float powf(float, float), gammaf(float), logf(float), expf(float); +#else +float powf(), gammaf(), logf(), expf(); +#endif +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + + +float expnf( int n, float xx ) +{ +float x, ans, r, t, yk, xk; +float pk, pkm1, pkm2, qk, qkm1, qkm2; +float psi, z; +int i, k; +static float big = BIG; + + +x = xx; +if( n < 0 ) + goto domerr; + +if( x < 0 ) + { +domerr: mtherr( "expnf", DOMAIN ); + return( MAXNUMF ); + } + +if( x > MAXLOGF ) + return( 0.0 ); + +if( x == 0.0 ) + { + if( n < 2 ) + { + mtherr( "expnf", SING ); + return( MAXNUMF ); + } + else + return( 1.0/(n-1.0) ); + } + +if( n == 0 ) + return( expf(-x)/x ); + +/* expn.c */ +/* Expansion for large n */ + +if( n > 5000 ) + { + xk = x + n; + yk = 1.0 / (xk * xk); + t = n; + ans = yk * t * (6.0 * x * x - 8.0 * t * x + t * t); + ans = yk * (ans + t * (t - 2.0 * x)); + ans = yk * (ans + t); + ans = (ans + 1.0) * expf( -x ) / xk; + goto done; + } + +if( x > 1.0 ) + goto cfrac; + +/* expn.c */ + +/* Power series expansion */ + +psi = -EUL - logf(x); +for( i=1; i<n; i++ ) + psi = psi + 1.0/i; + +z = -x; +xk = 0.0; +yk = 1.0; +pk = 1.0 - n; +if( n == 1 ) + ans = 0.0; +else + ans = 1.0/pk; +do + { + xk += 1.0; + yk *= z/xk; + pk += 1.0; + if( pk != 0.0 ) + { + ans += yk/pk; + } + if( ans != 0.0 ) + t = fabsf(yk/ans); + else + t = 1.0; + } +while( t > MACHEPF ); +k = xk; +t = n; +r = n - 1; +ans = (powf(z, r) * psi / gammaf(t)) - ans; +goto done; + +/* expn.c */ +/* continued fraction */ +cfrac: +k = 1; +pkm2 = 1.0; +qkm2 = x; +pkm1 = 1.0; +qkm1 = x + n; +ans = pkm1/qkm1; + +do + { + k += 1; + if( k & 1 ) + { + yk = 1.0; + xk = n + (k-1)/2; + } + else + { + yk = x; + xk = k/2; + } + pk = pkm1 * yk + pkm2 * xk; + qk = qkm1 * yk + qkm2 * xk; + if( qk != 0 ) + { + r = pk/qk; + t = fabsf( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; +if( fabsf(pk) > big ) + { + pkm2 *= MACHEPF; + pkm1 *= MACHEPF; + qkm2 *= MACHEPF; + qkm1 *= MACHEPF; + } + } +while( t > MACHEPF ); + +ans *= expf( -x ); + +done: +return( ans ); +} + diff --git a/libm/float/facf.c b/libm/float/facf.c new file mode 100644 index 000000000..c69738897 --- /dev/null +++ b/libm/float/facf.c @@ -0,0 +1,106 @@ +/* facf.c + * + * Factorial function + * + * + * + * SYNOPSIS: + * + * float y, facf(); + * int i; + * + * y = facf( i ); + * + * + * + * DESCRIPTION: + * + * Returns factorial of i = 1 * 2 * 3 * ... * i. + * fac(0) = 1.0. + * + * Due to machine arithmetic bounds the largest value of + * i accepted is 33 in single precision arithmetic. + * Greater values, or negative ones, + * produce an error message and return MAXNUM. + * + * + * + * ACCURACY: + * + * For i < 34 the values are simply tabulated, and have + * full machine accuracy. + * + */ + +/* +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> + +/* Factorials of integers from 0 through 33 */ +static float factbl[] = { + 1.00000000000000000000E0, + 1.00000000000000000000E0, + 2.00000000000000000000E0, + 6.00000000000000000000E0, + 2.40000000000000000000E1, + 1.20000000000000000000E2, + 7.20000000000000000000E2, + 5.04000000000000000000E3, + 4.03200000000000000000E4, + 3.62880000000000000000E5, + 3.62880000000000000000E6, + 3.99168000000000000000E7, + 4.79001600000000000000E8, + 6.22702080000000000000E9, + 8.71782912000000000000E10, + 1.30767436800000000000E12, + 2.09227898880000000000E13, + 3.55687428096000000000E14, + 6.40237370572800000000E15, + 1.21645100408832000000E17, + 2.43290200817664000000E18, + 5.10909421717094400000E19, + 1.12400072777760768000E21, + 2.58520167388849766400E22, + 6.20448401733239439360E23, + 1.55112100433309859840E25, + 4.03291461126605635584E26, + 1.0888869450418352160768E28, + 3.04888344611713860501504E29, + 8.841761993739701954543616E30, + 2.6525285981219105863630848E32, + 8.22283865417792281772556288E33, + 2.6313083693369353016721801216E35, + 8.68331761881188649551819440128E36 +}; +#define MAXFACF 33 + +extern float MAXNUMF; + +#ifdef ANSIC +float facf( int i ) +#else +float facf(i) +int i; +#endif +{ + +if( i < 0 ) + { + mtherr( "facf", SING ); + return( MAXNUMF ); + } + +if( i > MAXFACF ) + { + mtherr( "facf", OVERFLOW ); + return( MAXNUMF ); + } + +/* Get answer from table for small i. */ +return( factbl[i] ); +} diff --git a/libm/float/fdtrf.c b/libm/float/fdtrf.c new file mode 100644 index 000000000..5fdc6d81d --- /dev/null +++ b/libm/float/fdtrf.c @@ -0,0 +1,214 @@ +/* fdtrf.c + * + * F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * float x, y, fdtrf(); + * + * y = fdtrf( 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) = incbet( df1/2, df2/2, (df1*x/(df2 + df1*x) ). + * + * + * The arguments a and b are greater than zero, and x + * x is nonnegative. + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 2.2e-5 1.1e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrf domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrcf() + * + * Complemented F distribution + * + * + * + * SYNOPSIS: + * + * int df1, df2; + * float x, y, fdtrcf(); + * + * y = fdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 7.3e-5 1.2e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrcf domain a<0, b<0, x<0 0.0 + * + */ + /* fdtrif() + * + * Inverse of complemented F distribution + * + * + * + * SYNOPSIS: + * + * float df1, df2, x, y, fdtrif(); + * + * x = fdtrif( df1, df2, y ); + * + * + * + * + * 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 y. + * + * This is accomplished using the inverse beta integral + * function and the relations + * + * z = incbi( df2/2, df1/2, y ) + * 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, y ) + * x = df2 z / (df1 (1-z)). + * + * + * + * ACCURACY: + * + * arithmetic domain # trials peak rms + * Absolute error: + * IEEE 0,100 5000 4.0e-5 3.2e-6 + * Relative error: + * IEEE 0,100 5000 1.2e-3 1.8e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * fdtrif domain y <= 0 or y > 1 0.0 + * v < 1 + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +#ifdef ANSIC +float incbetf(float, float, float); +float incbif(float, float, float); +#else +float incbetf(), incbif(); +#endif + +float fdtrcf( int ia, int ib, float xx ) +{ +float x, a, b, w; + +x = xx; +if( (ia < 1) || (ib < 1) || (x < 0.0) ) + { + mtherr( "fdtrcf", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +w = b / (b + a * x); +return( incbetf( 0.5*b, 0.5*a, w ) ); +} + + + +float fdtrf( int ia, int ib, int xx ) +{ +float x, a, b, w; + +x = xx; +if( (ia < 1) || (ib < 1) || (x < 0.0) ) + { + mtherr( "fdtrf", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +w = a * x; +w = w / (b + w); +return( incbetf( 0.5*a, 0.5*b, w) ); +} + + +float fdtrif( int ia, int ib, float yy ) +{ +float y, a, b, w, x; + +y = yy; +if( (ia < 1) || (ib < 1) || (y <= 0.0) || (y > 1.0) ) + { + mtherr( "fdtrif", DOMAIN ); + return( 0.0 ); + } +a = ia; +b = ib; +w = incbif( 0.5*b, 0.5*a, y ); +x = (b - b*w)/(a*w); +return(x); +} diff --git a/libm/float/floorf.c b/libm/float/floorf.c new file mode 100644 index 000000000..7a2f3530d --- /dev/null +++ b/libm/float/floorf.c @@ -0,0 +1,526 @@ +/* ceilf() + * floorf() + * frexpf() + * ldexpf() + * signbitf() + * isnanf() + * isfinitef() + * + * Single precision floating point numeric utilities + * + * + * + * SYNOPSIS: + * + * float x, y; + * float ceilf(), floorf(), frexpf(), ldexpf(); + * int signbit(), isnan(), isfinite(); + * int expnt, n; + * + * y = floorf(x); + * y = ceilf(x); + * y = frexpf( x, &expnt ); + * y = ldexpf( x, n ); + * n = signbit(x); + * n = isnan(x); + * n = isfinite(x); + * + * + * + * DESCRIPTION: + * + * All four routines return a single precision floating point + * result. + * + * sfloor() returns the largest integer less than or equal to x. + * It truncates toward minus infinity. + * + * sceil() returns the smallest integer greater than or equal + * to x. It truncates toward plus infinity. + * + * sfrexp() 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. + * + * ldexpf() multiplies x by 2**n. + * + * signbit(x) returns 1 if the sign bit of x is 1, else 0. + * + * These functions are part of the standard C run time library + * for many but not all C compilers. The ones supplied are + * written in C for either DEC or 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.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> +#ifdef DEC +#undef DENORMAL +#define DENORMAL 0 +#endif + +#ifdef UNK +#undef UNK +#if BIGENDIAN +#define MIEEE 1 +#else +#define IBMPC 1 +#endif +/* +char *unkmsg = "ceil(), floor(), frexp(), ldexp() must be rewritten!\n"; +*/ +#endif + +#define EXPMSK 0x807f +#define MEXP 255 +#define NBITS 24 + + +extern float MAXNUMF; /* (2^24 - 1) * 2^103 */ +#ifdef ANSIC +float floorf(float); +#else +float floorf(); +#endif + +float ceilf( float x ) +{ +float y; + +#ifdef UNK +printf( "%s\n", unkmsg ); +return(0.0); +#endif + +y = floorf( (float )x ); +if( y < x ) + y += 1.0; +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, +}; + + + +float floorf( float x ) +{ +unsigned short *p; +union + { + float y; + unsigned short i[2]; + } u; +int e; + +#ifdef UNK +printf( "%s\n", unkmsg ); +return(0.0); +#endif + +u.y = x; +/* find the exponent (power of 2) */ +#ifdef DEC +p = &u.i[0]; +e = (( *p >> 7) & 0377) - 0201; +p += 3; +#endif + +#ifdef IBMPC +p = &u.i[1]; +e = (( *p >> 7) & 0xff) - 0x7f; +p -= 1; +#endif + +#ifdef MIEEE +p = &u.i[0]; +e = (( *p >> 7) & 0xff) - 0x7f; +p += 1; +#endif + +if( e < 0 ) + { + if( u.y < 0 ) + return( -1.0 ); + else + return( 0.0 ); + } + +e = (NBITS -1) - e; +/* clean out 16 bits at a time */ +while( e >= 16 ) + { +#ifdef IBMPC + *p++ = 0; +#endif + +#ifdef DEC + *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.0; + +return(u.y); +} + + + +float frexpf( float x, int *pw2 ) +{ +union + { + float y; + unsigned short i[2]; + } u; +int i, k; +short *q; + +u.y = x; + +#ifdef UNK +printf( "%s\n", unkmsg ); +return(0.0); +#endif + +#ifdef IBMPC +q = &u.i[1]; +#endif + +#ifdef DEC +q = &u.i[0]; +#endif + +#ifdef MIEEE +q = &u.i[0]; +#endif + +/* find the exponent (power of 2) */ + +i = ( *q >> 7) & 0xff; +if( i == 0 ) + { + if( u.y == 0.0 ) + { + *pw2 = 0; + return(0.0); + } +/* Number is denormal or zero */ +#if DENORMAL +/* Handle denormal number. */ + do + { + u.y *= 2.0; + i -= 1; + k = ( *q >> 7) & 0xff; + } + while( k == 0 ); + i = i + k; +#else + *pw2 = 0; + return( 0.0 ); +#endif /* DENORMAL */ + } +i -= 0x7e; +*pw2 = i; +*q &= 0x807f; /* strip all exponent bits */ +*q |= 0x3f00; /* mantissa between 0.5 and 1 */ +return( u.y ); +} + + + + + +float ldexpf( float x, int pw2 ) +{ +union + { + float y; + unsigned short i[2]; + } u; +short *q; +int e; + +#ifdef UNK +printf( "%s\n", unkmsg ); +return(0.0); +#endif + +u.y = x; +#ifdef DEC +q = &u.i[0]; +#endif + +#ifdef IBMPC +q = &u.i[1]; +#endif +#ifdef MIEEE +q = &u.i[0]; +#endif +while( (e = ( *q >> 7) & 0xff) == 0 ) + { + if( u.y == (float )0.0 ) + { + return( 0.0 ); + } +/* Input is denormal. */ + if( pw2 > 0 ) + { + u.y *= 2.0; + pw2 -= 1; + } + if( pw2 < 0 ) + { + if( pw2 < -24 ) + return( 0.0 ); + u.y *= 0.5; + pw2 += 1; + } + if( pw2 == 0 ) + return(u.y); + } + +e += pw2; + +/* Handle overflow */ +if( e > MEXP ) + { + return( MAXNUMF ); + } + +*q &= 0x807f; + +/* Handle denormalized results */ +if( e < 1 ) + { +#if DENORMAL + if( e < -24 ) + return( 0.0 ); + *q |= 0x80; /* Set LSB of exponent. */ + /* For denormals, significant bits may be lost even + when dividing by 2. Construct 2^-(1-e) so the result + is obtained with only one multiplication. */ + u.y *= ldexpf(1.0f, e - 1); + return(u.y); +#else + return( 0.0 ); +#endif + } +*q |= (e & 0xff) << 7; +return(u.y); +} + + +/* Return 1 if the sign bit of x is 1, else 0. */ + +int signbitf(x) +float x; +{ +union + { + float f; + short s[4]; + int i; + } u; + +u.f = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + return( u.i < 0 ); +#endif +#ifdef DEC + return( u.s[1] < 0 ); +#endif +#ifdef MIEEE + return( u.i < 0 ); +#endif + } +else + { +#ifdef IBMPC + return( u.s[1] < 0 ); +#endif +#ifdef DEC + return( u.s[1] < 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 isnanf(x) +float x; +{ +#ifdef NANS +union + { + float f; + unsigned short s[2]; + unsigned int i; + } u; + +u.f = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( ((u.i & 0x7f800000) == 0x7f800000) + && ((u.i & 0x007fffff) != 0) ) + return 1; +#endif +#ifdef DEC + if( (u.s[1] & 0x7f80) == 0) + { + if( (u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( ((u.i & 0x7f800000) == 0x7f800000) + && ((u.i & 0x007fffff) != 0) ) + return 1; +#endif + return(0); + } +else + { /* size int not 4 */ +#ifdef IBMPC + if( (u.s[1] & 0x7f80) == 0x7f80) + { + if( ((u.s[1] & 0x007f) | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef DEC + if( (u.s[1] & 0x7f80) == 0) + { + if( (u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7f80) == 0x7f80) + { + if( ((u.s[0] & 0x000f) | u.s[1]) != 0 ) + 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 isfinitef(x) +float x; +{ +#ifdef INFINITIES +union + { + float f; + unsigned short s[2]; + unsigned int i; + } u; + +u.f = x; + +if( sizeof(int) == 4 ) + { +#ifdef IBMPC + if( (u.i & 0x7f800000) != 0x7f800000) + return 1; +#endif +#ifdef DEC + if( (u.s[1] & 0x7f80) == 0) + { + if( (u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( (u.i & 0x7f800000) != 0x7f800000) + return 1; +#endif + return(0); + } +else + { +#ifdef IBMPC + if( (u.s[1] & 0x7f80) != 0x7f80) + return 1; +#endif +#ifdef DEC + if( (u.s[1] & 0x7f80) == 0) + { + if( (u.s[1] | u.s[0]) != 0 ) + return(1); + } +#endif +#ifdef MIEEE + if( (u.s[0] & 0x7f80) != 0x7f80) + return 1; +#endif + return(0); + } +#else +/* No INFINITY. */ +return(1); +#endif +} diff --git a/libm/float/fresnlf.c b/libm/float/fresnlf.c new file mode 100644 index 000000000..d6ae773b1 --- /dev/null +++ b/libm/float/fresnlf.c @@ -0,0 +1,173 @@ +/* fresnlf.c + * + * Fresnel integral + * + * + * + * SYNOPSIS: + * + * float x, S, C; + * void fresnlf(); + * + * fresnlf( x, _&S, _&C ); + * + * + * DESCRIPTION: + * + * Evaluates the Fresnel integrals + * + * x + * - + * | | + * C(x) = | cos(pi/2 t**2) dt, + * | | + * - + * 0 + * + * x + * - + * | | + * S(x) = | sin(pi/2 t**2) dt. + * | | + * - + * 0 + * + * + * The integrals are evaluated by power series for small x. + * For x >= 1 auxiliary functions f(x) and g(x) are employed + * such that + * + * C(x) = 0.5 + f(x) sin( pi/2 x**2 ) - g(x) cos( pi/2 x**2 ) + * S(x) = 0.5 - f(x) cos( pi/2 x**2 ) - g(x) sin( pi/2 x**2 ) + * + * + * + * ACCURACY: + * + * Relative error. + * + * Arithmetic function domain # trials peak rms + * IEEE S(x) 0, 10 30000 1.1e-6 1.9e-7 + * IEEE C(x) 0, 10 30000 1.1e-6 2.0e-7 + */ + +/* +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 +*/ + +#include <math.h> + +/* S(x) for small x */ +static float sn[7] = { + 1.647629463788700E-009, +-1.522754752581096E-007, + 8.424748808502400E-006, +-3.120693124703272E-004, + 7.244727626597022E-003, +-9.228055941124598E-002, + 5.235987735681432E-001 +}; + +/* C(x) for small x */ +static float cn[7] = { + 1.416802502367354E-008, +-1.157231412229871E-006, + 5.387223446683264E-005, +-1.604381798862293E-003, + 2.818489036795073E-002, +-2.467398198317899E-001, + 9.999999760004487E-001 +}; + + +/* Auxiliary function f(x) */ +static float fn[8] = { +-1.903009855649792E+012, + 1.355942388050252E+011, +-4.158143148511033E+009, + 7.343848463587323E+007, +-8.732356681548485E+005, + 8.560515466275470E+003, +-1.032877601091159E+002, + 2.999401847870011E+000 +}; + +/* Auxiliary function g(x) */ +static float gn[8] = { +-1.860843997624650E+011, + 1.278350673393208E+010, +-3.779387713202229E+008, + 6.492611570598858E+006, +-7.787789623358162E+004, + 8.602931494734327E+002, +-1.493439396592284E+001, + 9.999841934744914E-001 +}; + + +extern float PIF, PIO2F; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float polevlf( float, float *, int ); +float cosf(float), sinf(float); +#else +float polevlf(), cosf(), sinf(); +#endif + +void fresnlf( float xxa, float *ssa, float *cca ) +{ +float f, g, cc, ss, c, s, t, u, x, x2; + +x = xxa; +x = fabsf(x); +x2 = x * x; +if( x2 < 2.5625 ) + { + t = x2 * x2; + ss = x * x2 * polevlf( t, sn, 6); + cc = x * polevlf( t, cn, 6); + goto done; + } + +if( x > 36974.0 ) + { + cc = 0.5; + ss = 0.5; + goto done; + } + + +/* Asymptotic power series auxiliary functions + * for large argument + */ + x2 = x * x; + t = PIF * x2; + u = 1.0/(t * t); + t = 1.0/t; + f = 1.0 - u * polevlf( u, fn, 7); + g = t * polevlf( u, gn, 7); + + t = PIO2F * x2; + c = cosf(t); + s = sinf(t); + t = PIF * x; + cc = 0.5 + (f * s - g * c)/t; + ss = 0.5 - (f * c + g * s)/t; + +done: +if( xxa < 0.0 ) + { + cc = -cc; + ss = -ss; + } + +*cca = cc; +*ssa = ss; +#if !ANSIC +return 0; +#endif +} diff --git a/libm/float/gammaf.c b/libm/float/gammaf.c new file mode 100644 index 000000000..e8c4694c4 --- /dev/null +++ b/libm/float/gammaf.c @@ -0,0 +1,423 @@ +/* gammaf.c + * + * Gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, gammaf(); + * extern int sgngamf; + * + * y = gammaf( 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 sgngamf. + * This same variable is also filled in by the logarithmic + * gamma function lgam(). + * + * Arguments between 0 and 10 are reduced by recurrence and the + * function is approximated by a polynomial function covering + * the interval (2,3). Large arguments are handled by Stirling's + * formula. Negative arguments are made positive using + * a reflection formula. + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,-33 100,000 5.7e-7 1.0e-7 + * IEEE -33,0 100,000 6.1e-7 1.2e-7 + * + * + */ +/* lgamf() + * + * Natural logarithm of gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, lgamf(); + * extern int sgngamf; + * + * y = lgamf( 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 sgngamf. + * + * For arguments greater than 6.5, the logarithm of the gamma + * function is approximated by the logarithmic version of + * Stirling's formula. Arguments between 0 and +6.5 are reduced by + * by recurrence to the interval [.75,1.25] or [1.5,2.5] of a rational + * approximation. The cosecant reflection formula is employed for + * arguments less than zero. + * + * Arguments greater than MAXLGM = 2.035093e36 return MAXNUM and an + * error message. + * + * + * + * ACCURACY: + * + * + * + * arithmetic domain # trials peak rms + * IEEE -100,+100 500,000 7.4e-7 6.8e-8 + * The error criterion was relative when the function magnitude + * was greater than one but absolute when it was less than one. + * The routine has low relative error for positive arguments. + * + * The following test used the relative error criterion. + * IEEE -2, +3 100000 4.0e-7 5.6e-8 + * + */ + +/* gamma.c */ +/* gamma function */ + +/* +Cephes Math Library Release 2.7: July, 1998 +Copyright 1984, 1987, 1989, 1992, 1998 by Stephen L. Moshier +*/ + + +#include <math.h> + +/* define MAXGAM 34.84425627277176174 */ + +/* Stirling's formula for the gamma function + * gamma(x) = sqrt(2 pi) x^(x-.5) exp(-x) ( 1 + 1/x P(1/x) ) + * .028 < 1/x < .1 + * relative error < 1.9e-11 + */ +static float STIR[] = { +-2.705194986674176E-003, + 3.473255786154910E-003, + 8.333331788340907E-002, +}; +static float MAXSTIR = 26.77; +static float SQTPIF = 2.50662827463100050242; /* sqrt( 2 pi ) */ + +int sgngamf = 0; +extern int sgngamf; +extern float MAXLOGF, MAXNUMF, PIF; + +#ifdef ANSIC +float expf(float); +float logf(float); +float powf( float, float ); +float sinf(float); +float gammaf(float); +float floorf(float); +static float stirf(float); +float polevlf( float, float *, int ); +float p1evlf( float, float *, int ); +#else +float expf(), logf(), powf(), sinf(), floorf(); +float polevlf(), p1evlf(); +static float stirf(); +#endif + +/* Gamma function computed by Stirling's formula, + * sqrt(2 pi) x^(x-.5) exp(-x) (1 + 1/x P(1/x)) + * The polynomial STIR is valid for 33 <= x <= 172. + */ +static float stirf( float xx ) +{ +float x, y, w, v; + +x = xx; +w = 1.0/x; +w = 1.0 + w * polevlf( w, STIR, 2 ); +y = expf( -x ); +if( x > MAXSTIR ) + { /* Avoid overflow in pow() */ + v = powf( x, 0.5 * x - 0.25 ); + y *= v; + y *= v; + } +else + { + y = powf( x, x - 0.5 ) * y; + } +y = SQTPIF * y * w; +return( y ); +} + + +/* gamma(x+2), 0 < x < 1 */ +static float P[] = { + 1.536830450601906E-003, + 5.397581592950993E-003, + 4.130370201859976E-003, + 7.232307985516519E-002, + 8.203960091619193E-002, + 4.117857447645796E-001, + 4.227867745131584E-001, + 9.999999822945073E-001, +}; + +float gammaf( float xx ) +{ +float p, q, x, z, nz; +int i, direction, negative; + +x = xx; +sgngamf = 1; +negative = 0; +nz = 0.0; +if( x < 0.0 ) + { + negative = 1; + q = -x; + p = floorf(q); + if( p == q ) + goto goverf; + i = p; + if( (i & 1) == 0 ) + sgngamf = -1; + nz = q - p; + if( nz > 0.5 ) + { + p += 1.0; + nz = q - p; + } + nz = q * sinf( PIF * nz ); + if( nz == 0.0 ) + { +goverf: + mtherr( "gamma", OVERFLOW ); + return( sgngamf * MAXNUMF); + } + if( nz < 0 ) + nz = -nz; + x = q; + } +if( x >= 10.0 ) + { + z = stirf(x); + } +if( x < 2.0 ) + direction = 1; +else + direction = 0; +z = 1.0; +while( x >= 3.0 ) + { + x -= 1.0; + z *= x; + } +/* +while( x < 0.0 ) + { + if( x > -1.E-4 ) + goto small; + z *=x; + x += 1.0; + } +*/ +while( x < 2.0 ) + { + if( x < 1.e-4 ) + goto small; + z *=x; + x += 1.0; + } + +if( direction ) + z = 1.0/z; + +if( x == 2.0 ) + return(z); + +x -= 2.0; +p = z * polevlf( x, P, 7 ); + +gdone: + +if( negative ) + { + p = sgngamf * PIF/(nz * p ); + } +return(p); + +small: +if( x == 0.0 ) + { + mtherr( "gamma", SING ); + return( MAXNUMF ); + } +else + { + p = z / ((1.0 + 0.5772156649015329 * x) * x); + goto gdone; + } +} + + + + +/* log gamma(x+2), -.5 < x < .5 */ +static float B[] = { + 6.055172732649237E-004, +-1.311620815545743E-003, + 2.863437556468661E-003, +-7.366775108654962E-003, + 2.058355474821512E-002, +-6.735323259371034E-002, + 3.224669577325661E-001, + 4.227843421859038E-001 +}; + +/* log gamma(x+1), -.25 < x < .25 */ +static float C[] = { + 1.369488127325832E-001, +-1.590086327657347E-001, + 1.692415923504637E-001, +-2.067882815621965E-001, + 2.705806208275915E-001, +-4.006931650563372E-001, + 8.224670749082976E-001, +-5.772156501719101E-001 +}; + +/* log( sqrt( 2*pi ) ) */ +static float LS2PI = 0.91893853320467274178; +#define MAXLGM 2.035093e36 +static float PIINV = 0.318309886183790671538; + +/* Logarithm of gamma function */ + + +float lgamf( float xx ) +{ +float p, q, w, z, x; +float nx, tx; +int i, direction; + +sgngamf = 1; + +x = xx; +if( x < 0.0 ) + { + q = -x; + w = lgamf(q); /* note this modifies sgngam! */ + p = floorf(q); + if( p == q ) + goto loverf; + i = p; + if( (i & 1) == 0 ) + sgngamf = -1; + else + sgngamf = 1; + z = q - p; + if( z > 0.5 ) + { + p += 1.0; + z = p - q; + } + z = q * sinf( PIF * z ); + if( z == 0.0 ) + goto loverf; + z = -logf( PIINV*z ) - w; + return( z ); + } + +if( x < 6.5 ) + { + direction = 0; + z = 1.0; + tx = x; + nx = 0.0; + if( x >= 1.5 ) + { + while( tx > 2.5 ) + { + nx -= 1.0; + tx = x + nx; + z *=tx; + } + x += nx - 2.0; +iv1r5: + p = x * polevlf( x, B, 7 ); + goto cont; + } + if( x >= 1.25 ) + { + z *= x; + x -= 1.0; /* x + 1 - 2 */ + direction = 1; + goto iv1r5; + } + if( x >= 0.75 ) + { + x -= 1.0; + p = x * polevlf( x, C, 7 ); + q = 0.0; + goto contz; + } + while( tx < 1.5 ) + { + if( tx == 0.0 ) + goto loverf; + z *=tx; + nx += 1.0; + tx = x + nx; + } + direction = 1; + x += nx - 2.0; + p = x * polevlf( x, B, 7 ); + +cont: + if( z < 0.0 ) + { + sgngamf = -1; + z = -z; + } + else + { + sgngamf = 1; + } + q = logf(z); + if( direction ) + q = -q; +contz: + return( p + q ); + } + +if( x > MAXLGM ) + { +loverf: + mtherr( "lgamf", OVERFLOW ); + return( sgngamf * MAXNUMF ); + } + +/* Note, though an asymptotic formula could be used for x >= 3, + * there is cancellation error in the following if x < 6.5. */ +q = LS2PI - x; +q += ( x - 0.5 ) * logf(x); + +if( x <= 1.0e4 ) + { + z = 1.0/x; + p = z * z; + q += (( 6.789774945028216E-004 * p + - 2.769887652139868E-003 ) * p + + 8.333316229807355E-002 ) * z; + } +return( q ); +} diff --git a/libm/float/gdtrf.c b/libm/float/gdtrf.c new file mode 100644 index 000000000..e7e02026b --- /dev/null +++ b/libm/float/gdtrf.c @@ -0,0 +1,144 @@ +/* gdtrf.c + * + * Gamma distribution function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, gdtrf(); + * + * y = gdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 5.8e-5 3.0e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrf domain x < 0 0.0 + * + */ + /* gdtrcf.c + * + * Complemented gamma distribution function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, gdtrcf(); + * + * y = gdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 9.1e-5 1.5e-5 + * + * ERROR MESSAGES: + * + * message condition value returned + * gdtrcf domain x < 0 0.0 + * + */ + +/* gdtr() */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +#ifdef ANSIC +float igamf(float, float), igamcf(float, float); +#else +float igamf(), igamcf(); +#endif + + + +float gdtrf( float aa, float bb, float xx ) +{ +float a, b, x; + +a = aa; +b = bb; +x = xx; + + +if( x < 0.0 ) + { + mtherr( "gdtrf", DOMAIN ); + return( 0.0 ); + } +return( igamf( b, a * x ) ); +} + + + +float gdtrcf( float aa, float bb, float xx ) +{ +float a, b, x; + +a = aa; +b = bb; +x = xx; +if( x < 0.0 ) + { + mtherr( "gdtrcf", DOMAIN ); + return( 0.0 ); + } +return( igamcf( b, a * x ) ); +} diff --git a/libm/float/hyp2f1f.c b/libm/float/hyp2f1f.c new file mode 100644 index 000000000..01fe54928 --- /dev/null +++ b/libm/float/hyp2f1f.c @@ -0,0 +1,442 @@ +/* hyp2f1f.c + * + * Gauss hypergeometric function F + * 2 1 + * + * + * SYNOPSIS: + * + * float a, b, c, x, y, hyp2f1f(); + * + * y = hyp2f1f( a, b, c, x ); + * + * + * DESCRIPTION: + * + * + * hyp2f1( a, b, c, x ) = F ( a, b; c; x ) + * 2 1 + * + * inf. + * - a(a+1)...(a+k) b(b+1)...(b+k) k+1 + * = 1 + > ----------------------------- x . + * - c(c+1)...(c+k) (k+1)! + * k = 0 + * + * Cases addressed are + * Tests and escapes for negative integer a, b, or c + * Linear transformation if c - a or c - b negative integer + * Special case c = a or c = b + * Linear transformation for x near +1 + * Transformation for x < -0.5 + * Psi function expansion if x > 0.5 and c - a - b integer + * Conditionally, a recurrence on c to make c-a-b > 0 + * + * |x| > 1 is rejected. + * + * The parameters a, b, c are considered to be integer + * valued if they are within 1.0e-6 of the nearest integer. + * + * ACCURACY: + * + * Relative error (-1 < x < 1): + * arithmetic domain # trials peak rms + * IEEE 0,3 30000 5.8e-4 4.3e-6 + */ + +/* hyp2f1 */ + + +/* +Cephes Math Library Release 2.2: November, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +#define EPS 1.0e-5 +#define EPS2 1.0e-5 +#define ETHRESH 1.0e-5 + +extern float MAXNUMF, MACHEPF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float powf(float, float); +static float hys2f1f(float, float, float, float, float *); +static float hyt2f1f(float, float, float, float, float *); +float gammaf(float), logf(float), expf(float), psif(float); +float floorf(float); +#else +float powf(), gammaf(), logf(), expf(), psif(); +float floorf(); +static float hyt2f1f(), hys2f1f(); +#endif + +#define roundf(x) (floorf((x)+(float )0.5)) + + + + +float hyp2f1f( float aa, float bb, float cc, float xx ) +{ +float a, b, c, x; +float d, d1, d2, e; +float p, q, r, s, y, ax; +float ia, ib, ic, id, err; +int flag, i, aid; + +a = aa; +b = bb; +c = cc; +x = xx; +err = 0.0; +ax = fabsf(x); +s = 1.0 - x; +flag = 0; +ia = roundf(a); /* nearest integer to a */ +ib = roundf(b); + +if( a <= 0 ) + { + if( fabsf(a-ia) < EPS ) /* a is a negative integer */ + flag |= 1; + } + +if( b <= 0 ) + { + if( fabsf(b-ib) < EPS ) /* b is a negative integer */ + flag |= 2; + } + +if( ax < 1.0 ) + { + if( fabsf(b-c) < EPS ) /* b = c */ + { + y = powf( s, -a ); /* s to the -a power */ + goto hypdon; + } + if( fabsf(a-c) < EPS ) /* a = c */ + { + y = powf( s, -b ); /* s to the -b power */ + goto hypdon; + } + } + + + +if( c <= 0.0 ) + { + ic = roundf(c); /* nearest integer to c */ + if( fabsf(c-ic) < EPS ) /* c is a negative integer */ + { + /* check if termination before explosion */ + if( (flag & 1) && (ia > ic) ) + goto hypok; + if( (flag & 2) && (ib > ic) ) + goto hypok; + goto hypdiv; + } + } + +if( flag ) /* function is a polynomial */ + goto hypok; + +if( ax > 1.0 ) /* series diverges */ + goto hypdiv; + +p = c - a; +ia = roundf(p); +if( (ia <= 0.0) && (fabsf(p-ia) < EPS) ) /* negative int c - a */ + flag |= 4; + +r = c - b; +ib = roundf(r); /* nearest integer to r */ +if( (ib <= 0.0) && (fabsf(r-ib) < EPS) ) /* negative int c - b */ + flag |= 8; + +d = c - a - b; +id = roundf(d); /* nearest integer to d */ +q = fabsf(d-id); + +if( fabsf(ax-1.0) < EPS ) /* |x| == 1.0 */ + { + if( x > 0.0 ) + { + if( flag & 12 ) /* negative int c-a or c-b */ + { + if( d >= 0.0 ) + goto hypf; + else + goto hypdiv; + } + if( d <= 0.0 ) + goto hypdiv; + y = gammaf(c)*gammaf(d)/(gammaf(p)*gammaf(r)); + goto hypdon; + } + + if( d <= -1.0 ) + goto hypdiv; + } + +/* Conditionally make d > 0 by recurrence on c + * AMS55 #15.2.27 + */ +if( d < 0.0 ) + { +/* Try the power series first */ + y = hyt2f1f( a, b, c, x, &err ); + if( err < ETHRESH ) + goto hypdon; +/* Apply the recurrence if power series fails */ + err = 0.0; + aid = 2 - id; + e = c + aid; + d2 = hyp2f1f(a,b,e,x); + d1 = hyp2f1f(a,b,e+1.0,x); + q = a + b + 1.0; + for( i=0; i<aid; i++ ) + { + r = e - 1.0; + y = (e*(r-(2.0*e-q)*x)*d2 + (e-a)*(e-b)*x*d1)/(e*r*s); + e = r; + d1 = d2; + d2 = y; + } + goto hypdon; + } + + +if( flag & 12 ) + goto hypf; /* negative integer c-a or c-b */ + +hypok: +y = hyt2f1f( a, b, c, x, &err ); + +hypdon: +if( err > ETHRESH ) + { + mtherr( "hyp2f1", PLOSS ); +/* printf( "Estimated err = %.2e\n", err );*/ + } +return(y); + +/* The transformation for c-a or c-b negative integer + * AMS55 #15.3.3 + */ +hypf: +y = powf( s, d ) * hys2f1f( c-a, c-b, c, x, &err ); +goto hypdon; + +/* The alarm exit */ +hypdiv: +mtherr( "hyp2f1f", OVERFLOW ); +return( MAXNUMF ); +} + + + + +/* Apply transformations for |x| near 1 + * then call the power series + */ +static float hyt2f1f( float aa, float bb, float cc, float xx, float *loss ) +{ +float a, b, c, x; +float p, q, r, s, t, y, d, err, err1; +float ax, id, d1, d2, e, y1; +int i, aid; + +a = aa; +b = bb; +c = cc; +x = xx; +err = 0.0; +s = 1.0 - x; +if( x < -0.5 ) + { + if( b > a ) + y = powf( s, -a ) * hys2f1f( a, c-b, c, -x/s, &err ); + + else + y = powf( s, -b ) * hys2f1f( c-a, b, c, -x/s, &err ); + + goto done; + } + + + +d = c - a - b; +id = roundf(d); /* nearest integer to d */ + +if( x > 0.8 ) +{ + +if( fabsf(d-id) > EPS2 ) /* test for integer c-a-b */ + { +/* Try the power series first */ + y = hys2f1f( a, b, c, x, &err ); + if( err < ETHRESH ) + goto done; +/* If power series fails, then apply AMS55 #15.3.6 */ + q = hys2f1f( a, b, 1.0-d, s, &err ); + q *= gammaf(d) /(gammaf(c-a) * gammaf(c-b)); + r = powf(s,d) * hys2f1f( c-a, c-b, d+1.0, s, &err1 ); + r *= gammaf(-d)/(gammaf(a) * gammaf(b)); + y = q + r; + + q = fabsf(q); /* estimate cancellation error */ + r = fabsf(r); + if( q > r ) + r = q; + err += err1 + (MACHEPF*r)/y; + + y *= gammaf(c); + goto done; + } +else + { +/* Psi function expansion, AMS55 #15.3.10, #15.3.11, #15.3.12 */ + if( id >= 0.0 ) + { + e = d; + d1 = d; + d2 = 0.0; + aid = id; + } + else + { + e = -d; + d1 = 0.0; + d2 = d; + aid = -id; + } + + ax = logf(s); + + /* sum for t = 0 */ + y = psif(1.0) + psif(1.0+e) - psif(a+d1) - psif(b+d1) - ax; + y /= gammaf(e+1.0); + + p = (a+d1) * (b+d1) * s / gammaf(e+2.0); /* Poch for t=1 */ + t = 1.0; + do + { + r = psif(1.0+t) + psif(1.0+t+e) - psif(a+t+d1) + - psif(b+t+d1) - ax; + q = p * r; + y += q; + p *= s * (a+t+d1) / (t+1.0); + p *= (b+t+d1) / (t+1.0+e); + t += 1.0; + } + while( fabsf(q/y) > EPS ); + + + if( id == 0.0 ) + { + y *= gammaf(c)/(gammaf(a)*gammaf(b)); + goto psidon; + } + + y1 = 1.0; + + if( aid == 1 ) + goto nosum; + + t = 0.0; + p = 1.0; + for( i=1; i<aid; i++ ) + { + r = 1.0-e+t; + p *= s * (a+t+d2) * (b+t+d2) / r; + t += 1.0; + p /= t; + y1 += p; + } + + +nosum: + p = gammaf(c); + y1 *= gammaf(e) * p / (gammaf(a+d1) * gammaf(b+d1)); + y *= p / (gammaf(a+d2) * gammaf(b+d2)); + if( (aid & 1) != 0 ) + y = -y; + + q = powf( s, id ); /* s to the id power */ + if( id > 0.0 ) + y *= q; + else + y1 *= q; + + y += y1; +psidon: + goto done; + } +} + + +/* Use defining power series if no special cases */ +y = hys2f1f( a, b, c, x, &err ); + +done: +*loss = err; +return(y); +} + + + + + +/* Defining power series expansion of Gauss hypergeometric function */ + +static float hys2f1f( float aa, float bb, float cc, float xx, float *loss ) +{ +int i; +float a, b, c, x; +float f, g, h, k, m, s, u, umax; + + +a = aa; +b = bb; +c = cc; +x = xx; +i = 0; +umax = 0.0; +f = a; +g = b; +h = c; +k = 0.0; +s = 1.0; +u = 1.0; + +do + { + if( fabsf(h) < EPS ) + return( MAXNUMF ); + m = k + 1.0; + u = u * ((f+k) * (g+k) * x / ((h+k) * m)); + s += u; + k = fabsf(u); /* remember largest term summed */ + if( k > umax ) + umax = k; + k = m; + if( ++i > 10000 ) /* should never happen */ + { + *loss = 1.0; + return(s); + } + } +while( fabsf(u/s) > MACHEPF ); + +/* return estimated relative error */ +*loss = (MACHEPF*umax)/fabsf(s) + (MACHEPF*i); + +return(s); +} + + diff --git a/libm/float/hypergf.c b/libm/float/hypergf.c new file mode 100644 index 000000000..60d0eb4c5 --- /dev/null +++ b/libm/float/hypergf.c @@ -0,0 +1,384 @@ +/* hypergf.c + * + * Confluent hypergeometric function + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, hypergf(); + * + * y = hypergf( a, b, x ); + * + * + * + * DESCRIPTION: + * + * Computes the confluent hypergeometric function + * + * 1 2 + * a x a(a+1) x + * F ( a,b;x ) = 1 + ---- + --------- + ... + * 1 1 b 1! b(b+1) 2! + * + * Many higher transcendental functions are special cases of + * this power series. + * + * As is evident from the formula, b must not be a negative + * integer or zero unless a is an integer with 0 >= a > b. + * + * The routine attempts both a direct summation of the series + * and an asymptotic expansion. In each case error due to + * roundoff, cancellation, and nonconvergence is estimated. + * The result with smaller estimated error is returned. + * + * + * + * ACCURACY: + * + * Tested at random points (a, b, x), all three variables + * ranging from 0 to 30. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,5 10000 6.6e-7 1.3e-7 + * IEEE 0,30 30000 1.1e-5 6.5e-7 + * + * Larger errors can be observed when b is near a negative + * integer or zero. Certain combinations of arguments yield + * serious cancellation error in the power series summation + * and also are not in the region of near convergence of the + * asymptotic series. An error message is printed if the + * self-estimated relative error is greater than 1.0e-3. + * + */ + +/* hyperg.c */ + + +/* +Cephes Math Library Release 2.1: November, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +extern float MAXNUMF, MACHEPF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float expf(float); +float hyp2f0f(float, float, float, int, float *); +static float hy1f1af(float, float, float, float *); +static float hy1f1pf(float, float, float, float *); +float logf(float), gammaf(float), lgamf(float); +#else +float expf(), hyp2f0f(); +float logf(), gammaf(), lgamf(); +static float hy1f1pf(), hy1f1af(); +#endif + +float hypergf( float aa, float bb, float xx ) +{ +float a, b, x, asum, psum, acanc, pcanc, temp; + + +a = aa; +b = bb; +x = xx; +/* See if a Kummer transformation will help */ +temp = b - a; +if( fabsf(temp) < 0.001 * fabsf(a) ) + return( expf(x) * hypergf( temp, b, -x ) ); + +psum = hy1f1pf( a, b, x, &pcanc ); +if( pcanc < 1.0e-6 ) + goto done; + + +/* try asymptotic series */ + +asum = hy1f1af( a, b, x, &acanc ); + + +/* Pick the result with less estimated error */ + +if( acanc < pcanc ) + { + pcanc = acanc; + psum = asum; + } + +done: +if( pcanc > 1.0e-3 ) + mtherr( "hyperg", PLOSS ); + +return( psum ); +} + + + + +/* Power series summation for confluent hypergeometric function */ + + +static float hy1f1pf( float aa, float bb, float xx, float *err ) +{ +float a, b, x, n, a0, sum, t, u, temp; +float an, bn, maxt, pcanc; + +a = aa; +b = bb; +x = xx; +/* set up for power series summation */ +an = a; +bn = b; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +maxt = 0.0; + + +while( t > MACHEPF ) + { + if( bn == 0 ) /* check bn first since if both */ + { + mtherr( "hypergf", SING ); + return( MAXNUMF ); /* an and bn are zero it is */ + } + if( an == 0 ) /* a singularity */ + return( sum ); + if( n > 200 ) + goto pdone; + u = x * ( an / (bn * n) ); + + /* check for blowup */ + temp = fabsf(u); + if( (temp > 1.0 ) && (maxt > (MAXNUMF/temp)) ) + { + pcanc = 1.0; /* estimate 100% error */ + goto blowup; + } + + a0 *= u; + sum += a0; + t = fabsf(a0); + if( t > maxt ) + maxt = t; +/* + if( (maxt/fabsf(sum)) > 1.0e17 ) + { + pcanc = 1.0; + goto blowup; + } +*/ + an += 1.0; + bn += 1.0; + n += 1.0; + } + +pdone: + +/* estimate error due to roundoff and cancellation */ +if( sum != 0.0 ) + maxt /= fabsf(sum); +maxt *= MACHEPF; /* this way avoids multiply overflow */ +pcanc = fabsf( MACHEPF * n + maxt ); + +blowup: + +*err = pcanc; + +return( sum ); +} + + +/* hy1f1a() */ +/* asymptotic formula for hypergeometric function: + * + * ( -a + * -- ( |z| + * | (b) ( -------- 2f0( a, 1+a-b, -1/x ) + * ( -- + * ( | (b-a) + * + * + * x a-b ) + * e |x| ) + * + -------- 2f0( b-a, 1-a, 1/x ) ) + * -- ) + * | (a) ) + */ + +static float hy1f1af( float aa, float bb, float xx, float *err ) +{ +float a, b, x, h1, h2, t, u, temp, acanc, asum, err1, err2; + +a = aa; +b = bb; +x = xx; +if( x == 0 ) + { + acanc = 1.0; + asum = MAXNUMF; + goto adone; + } +temp = logf( fabsf(x) ); +t = x + temp * (a-b); +u = -temp * a; + +if( b > 0 ) + { + temp = lgamf(b); + t += temp; + u += temp; + } + +h1 = hyp2f0f( a, a-b+1, -1.0/x, 1, &err1 ); + +temp = expf(u) / gammaf(b-a); +h1 *= temp; +err1 *= temp; + +h2 = hyp2f0f( b-a, 1.0-a, 1.0/x, 2, &err2 ); + +if( a < 0 ) + temp = expf(t) / gammaf(a); +else + temp = expf( t - lgamf(a) ); + +h2 *= temp; +err2 *= temp; + +if( x < 0.0 ) + asum = h1; +else + asum = h2; + +acanc = fabsf(err1) + fabsf(err2); + + +if( b < 0 ) + { + temp = gammaf(b); + asum *= temp; + acanc *= fabsf(temp); + } + + +if( asum != 0.0 ) + acanc /= fabsf(asum); + +acanc *= 30.0; /* fudge factor, since error of asymptotic formula + * often seems this much larger than advertised */ + +adone: + + +*err = acanc; +return( asum ); +} + +/* hyp2f0() */ + +float hyp2f0f(float aa, float bb, float xx, int type, float *err) +{ +float a, b, x, a0, alast, t, tlast, maxt; +float n, an, bn, u, sum, temp; + +a = aa; +b = bb; +x = xx; +an = a; +bn = b; +a0 = 1.0; +alast = 1.0; +sum = 0.0; +n = 1.0; +t = 1.0; +tlast = 1.0e9; +maxt = 0.0; + +do + { + if( an == 0 ) + goto pdone; + if( bn == 0 ) + goto pdone; + + u = an * (bn * x / n); + + /* check for blowup */ + temp = fabsf(u); + if( (temp > 1.0 ) && (maxt > (MAXNUMF/temp)) ) + goto error; + + a0 *= u; + t = fabsf(a0); + + /* terminating condition for asymptotic series */ + if( t > tlast ) + goto ndone; + + tlast = t; + sum += alast; /* the sum is one term behind */ + alast = a0; + + if( n > 200 ) + goto ndone; + + an += 1.0; + bn += 1.0; + n += 1.0; + if( t > maxt ) + maxt = t; + } +while( t > MACHEPF ); + + +pdone: /* series converged! */ + +/* estimate error due to roundoff and cancellation */ +*err = fabsf( MACHEPF * (n + maxt) ); + +alast = a0; +goto done; + +ndone: /* series did not converge */ + +/* The following "Converging factors" are supposed to improve accuracy, + * but do not actually seem to accomplish very much. */ + +n -= 1.0; +x = 1.0/x; + +switch( type ) /* "type" given as subroutine argument */ +{ +case 1: + alast *= ( 0.5 + (0.125 + 0.25*b - 0.5*a + 0.25*x - 0.25*n)/x ); + break; + +case 2: + alast *= 2.0/3.0 - b + 2.0*a + x - n; + break; + +default: + ; +} + +/* estimate error due to roundoff, cancellation, and nonconvergence */ +*err = MACHEPF * (n + maxt) + fabsf( a0 ); + + +done: +sum += alast; +return( sum ); + +/* series blew up: */ +error: +*err = MAXNUMF; +mtherr( "hypergf", TLOSS ); +return( sum ); +} diff --git a/libm/float/i0f.c b/libm/float/i0f.c new file mode 100644 index 000000000..bb62cf60a --- /dev/null +++ b/libm/float/i0f.c @@ -0,0 +1,160 @@ +/* i0f.c + * + * Modified Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * float x, y, i0(); + * + * y = i0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order zero of the + * argument. + * + * The function is defined as i0(x) = j0( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 100000 4.0e-7 7.9e-8 + * + */ + /* i0ef.c + * + * Modified Bessel function of order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, i0ef(); + * + * y = i0ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order zero of the argument. + * + * The function is defined as i0e(x) = exp(-|x|) j0( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,30 100000 3.7e-7 7.0e-8 + * See i0f(). + * + */ + +/* i0.c */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +/* Chebyshev coefficients for exp(-x) I0(x) + * in the interval [0,8]. + * + * lim(x->0){ exp(-x) I0(x) } = 1. + */ + +static float A[] = +{ +-1.30002500998624804212E-8f, + 6.04699502254191894932E-8f, +-2.67079385394061173391E-7f, + 1.11738753912010371815E-6f, +-4.41673835845875056359E-6f, + 1.64484480707288970893E-5f, +-5.75419501008210370398E-5f, + 1.88502885095841655729E-4f, +-5.76375574538582365885E-4f, + 1.63947561694133579842E-3f, +-4.32430999505057594430E-3f, + 1.05464603945949983183E-2f, +-2.37374148058994688156E-2f, + 4.93052842396707084878E-2f, +-9.49010970480476444210E-2f, + 1.71620901522208775349E-1f, +-3.04682672343198398683E-1f, + 6.76795274409476084995E-1f +}; + + +/* Chebyshev coefficients for exp(-x) sqrt(x) I0(x) + * in the inverted interval [8,infinity]. + * + * lim(x->inf){ exp(-x) sqrt(x) I0(x) } = 1/sqrt(2pi). + */ + +static float B[] = +{ + 3.39623202570838634515E-9f, + 2.26666899049817806459E-8f, + 2.04891858946906374183E-7f, + 2.89137052083475648297E-6f, + 6.88975834691682398426E-5f, + 3.36911647825569408990E-3f, + 8.04490411014108831608E-1f +}; + + +float chbevlf(float, float *, int), expf(float), sqrtf(float); + +float i0f( float x ) +{ +float y; + +if( x < 0 ) + x = -x; +if( x <= 8.0f ) + { + y = 0.5f*x - 2.0f; + return( expf(x) * chbevlf( y, A, 18 ) ); + } + +return( expf(x) * chbevlf( 32.0f/x - 2.0f, B, 7 ) / sqrtf(x) ); +} + + + +float chbevlf(float, float *, int), expf(float), sqrtf(float); + +float i0ef( float x ) +{ +float y; + +if( x < 0 ) + x = -x; +if( x <= 8.0f ) + { + y = 0.5f*x - 2.0f; + return( chbevlf( y, A, 18 ) ); + } + +return( chbevlf( 32.0f/x - 2.0f, B, 7 ) / sqrtf(x) ); +} diff --git a/libm/float/i1f.c b/libm/float/i1f.c new file mode 100644 index 000000000..e9741e1da --- /dev/null +++ b/libm/float/i1f.c @@ -0,0 +1,177 @@ +/* i1f.c + * + * Modified Bessel function of order one + * + * + * + * SYNOPSIS: + * + * float x, y, i1f(); + * + * y = i1f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order one of the + * argument. + * + * The function is defined as i1(x) = -i j1( ix ). + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 100000 1.5e-6 1.6e-7 + * + * + */ + /* i1ef.c + * + * Modified Bessel function of order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, i1ef(); + * + * y = i1ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of order one of the argument. + * + * The function is defined as i1(x) = -i exp(-|x|) j1( ix ). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 1.5e-6 1.5e-7 + * See i1(). + * + */ + +/* i1.c 2 */ + + +/* +Cephes Math Library Release 2.0: March, 1987 +Copyright 1985, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +/* Chebyshev coefficients for exp(-x) I1(x) / x + * in the interval [0,8]. + * + * lim(x->0){ exp(-x) I1(x) / x } = 1/2. + */ + +static float A[] = +{ + 9.38153738649577178388E-9f, +-4.44505912879632808065E-8f, + 2.00329475355213526229E-7f, +-8.56872026469545474066E-7f, + 3.47025130813767847674E-6f, +-1.32731636560394358279E-5f, + 4.78156510755005422638E-5f, +-1.61760815825896745588E-4f, + 5.12285956168575772895E-4f, +-1.51357245063125314899E-3f, + 4.15642294431288815669E-3f, +-1.05640848946261981558E-2f, + 2.47264490306265168283E-2f, +-5.29459812080949914269E-2f, + 1.02643658689847095384E-1f, +-1.76416518357834055153E-1f, + 2.52587186443633654823E-1f +}; + + +/* Chebyshev coefficients for exp(-x) sqrt(x) I1(x) + * in the inverted interval [8,infinity]. + * + * lim(x->inf){ exp(-x) sqrt(x) I1(x) } = 1/sqrt(2pi). + */ + +static float B[] = +{ +-3.83538038596423702205E-9f, +-2.63146884688951950684E-8f, +-2.51223623787020892529E-7f, +-3.88256480887769039346E-6f, +-1.10588938762623716291E-4f, +-9.76109749136146840777E-3f, + 7.78576235018280120474E-1f +}; + +/* i1.c */ + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float chbevlf(float, float *, int); +float expf(float), sqrtf(float); +#else +float chbevlf(), expf(), sqrtf(); +#endif + + +float i1f(float xx) +{ +float x, y, z; + +x = xx; +z = fabsf(x); +if( z <= 8.0f ) + { + y = 0.5f*z - 2.0f; + z = chbevlf( y, A, 17 ) * z * expf(z); + } +else + { + z = expf(z) * chbevlf( 32.0f/z - 2.0f, B, 7 ) / sqrtf(z); + } +if( x < 0.0f ) + z = -z; +return( z ); +} + +/* i1e() */ + +float i1ef( float xx ) +{ +float x, y, z; + +x = xx; +z = fabsf(x); +if( z <= 8.0f ) + { + y = 0.5f*z - 2.0f; + z = chbevlf( y, A, 17 ) * z; + } +else + { + z = chbevlf( 32.0f/z - 2.0f, B, 7 ) / sqrtf(z); + } +if( x < 0.0f ) + z = -z; +return( z ); +} diff --git a/libm/float/igamf.c b/libm/float/igamf.c new file mode 100644 index 000000000..c54225df4 --- /dev/null +++ b/libm/float/igamf.c @@ -0,0 +1,223 @@ +/* igamf.c + * + * Incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamf(); + * + * y = igamf( 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 + * IEEE 0,30 20000 7.8e-6 5.9e-7 + * + */ + /* igamcf() + * + * Complemented incomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamcf(); + * + * y = igamcf( 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 + * IEEE 0,30 30000 7.8e-6 5.9e-7 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1985, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +/* BIG = 1/MACHEPF */ +#define BIG 16777216. + +extern float MACHEPF, MAXLOGF; + +#ifdef ANSIC +float lgamf(float), expf(float), logf(float), igamf(float, float); +#else +float lgamf(), expf(), logf(), igamf(); +#endif + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + + + +float igamcf( float aa, float xx ) +{ +float a, x, ans, c, yc, ax, y, z; +float pk, pkm1, pkm2, qk, qkm1, qkm2; +float r, t; +static float big = BIG; + +a = aa; +x = xx; +if( (x <= 0) || ( a <= 0) ) + return( 1.0 ); + +if( (x < 1.0) || (x < a) ) + return( 1.0 - igamf(a,x) ); + +ax = a * logf(x) - x - lgamf(a); +if( ax < -MAXLOGF ) + { + mtherr( "igamcf", UNDERFLOW ); + return( 0.0 ); + } +ax = expf(ax); + +/* continued fraction */ +y = 1.0 - a; +z = x + y + 1.0; +c = 0.0; +pkm2 = 1.0; +qkm2 = x; +pkm1 = x + 1.0; +qkm1 = z * x; +ans = pkm1/qkm1; + +do + { + c += 1.0; + y += 1.0; + z += 2.0; + yc = y * c; + pk = pkm1 * z - pkm2 * yc; + qk = qkm1 * z - qkm2 * yc; + if( qk != 0 ) + { + r = pk/qk; + t = fabsf( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + if( fabsf(pk) > big ) + { + pkm2 *= MACHEPF; + pkm1 *= MACHEPF; + qkm2 *= MACHEPF; + qkm1 *= MACHEPF; + } + } +while( t > MACHEPF ); + +return( ans * ax ); +} + + + +/* left tail of incomplete gamma function: + * + * inf. k + * a -x - x + * x e > ---------- + * - - + * k=0 | (a+k+1) + * + */ + +float igamf( float aa, float xx ) +{ +float a, x, ans, ax, c, r; + +a = aa; +x = xx; +if( (x <= 0) || ( a <= 0) ) + return( 0.0 ); + +if( (x > 1.0) && (x > a ) ) + return( 1.0 - igamcf(a,x) ); + +/* Compute x**a * exp(-x) / gamma(a) */ +ax = a * logf(x) - x - lgamf(a); +if( ax < -MAXLOGF ) + { + mtherr( "igamf", UNDERFLOW ); + return( 0.0 ); + } +ax = expf(ax); + +/* power series */ +r = a; +c = 1.0; +ans = 1.0; + +do + { + r += 1.0; + c *= x/r; + ans += c; + } +while( c/ans > MACHEPF ); + +return( ans * ax/a ); +} diff --git a/libm/float/igamif.c b/libm/float/igamif.c new file mode 100644 index 000000000..5a33b4982 --- /dev/null +++ b/libm/float/igamif.c @@ -0,0 +1,112 @@ +/* igamif() + * + * Inverse of complemented imcomplete gamma integral + * + * + * + * SYNOPSIS: + * + * float a, x, y, igamif(); + * + * x = igamif( 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 to 100 and x from 0 to 1. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.0e-5 1.5e-6 + * + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +extern float MACHEPF, MAXLOGF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float igamcf(float, float); +float ndtrif(float), expf(float), logf(float), sqrtf(float), lgamf(float); +#else +float igamcf(); +float ndtrif(), expf(), logf(), sqrtf(), lgamf(); +#endif + + +float igamif( float aa, float yy0 ) +{ +float a, y0, d, y, x0, lgm; +int i; + +a = aa; +y0 = yy0; +/* approximation to inverse function */ +d = 1.0/(9.0*a); +y = ( 1.0 - d - ndtrif(y0) * sqrtf(d) ); +x0 = a * y * y * y; + +lgm = lgamf(a); + +for( i=0; i<10; i++ ) + { + if( x0 <= 0.0 ) + { + mtherr( "igamif", UNDERFLOW ); + return(0.0); + } + y = igamcf(a,x0); +/* compute the derivative of the function at this point */ + d = (a - 1.0) * logf(x0) - x0 - lgm; + if( d < -MAXLOGF ) + { + mtherr( "igamif", UNDERFLOW ); + goto done; + } + d = -expf(d); +/* compute the step to the next approximation of x */ + if( d == 0.0 ) + goto done; + d = (y - y0)/d; + x0 = x0 - d; + if( i < 3 ) + continue; + if( fabsf(d/x0) < (2.0 * MACHEPF) ) + goto done; + } + +done: +return( x0 ); +} diff --git a/libm/float/incbetf.c b/libm/float/incbetf.c new file mode 100644 index 000000000..fed9aae4b --- /dev/null +++ b/libm/float/incbetf.c @@ -0,0 +1,424 @@ +/* incbetf.c + * + * Incomplete beta integral + * + * + * SYNOPSIS: + * + * float a, b, x, y, incbetf(); + * + * y = incbetf( 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. + * If a < 1, the function calls itself recursively after a + * transformation to increase a to a+1. + * + * ACCURACY: + * + * Tested at random points (a,b,x) with a and b in the indicated + * interval and x between 0 and 1. + * + * arithmetic domain # trials peak rms + * Relative error: + * IEEE 0,30 10000 3.7e-5 5.1e-6 + * IEEE 0,100 10000 1.7e-4 2.5e-5 + * The useful domain for relative error is limited by underflow + * of the single precision exponential function. + * Absolute error: + * IEEE 0,30 100000 2.2e-5 9.6e-7 + * IEEE 0,100 10000 6.5e-5 3.7e-6 + * + * Larger errors may occur for extreme ratios of a and b. + * + * ERROR MESSAGES: + * message condition value returned + * incbetf domain x<0, x>1 0.0 + */ + + +/* +Cephes Math Library, Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#ifdef ANSIC +float lgamf(float), expf(float), logf(float); +static float incbdf(float, float, float); +static float incbcff(float, float, float); +float incbpsf(float, float, float); +#else +float lgamf(), expf(), logf(); +float incbpsf(); +static float incbcff(), incbdf(); +#endif + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +/* BIG = 1/MACHEPF */ +#define BIG 16777216. +extern float MACHEPF, MAXLOGF; +#define MINLOGF (-MAXLOGF) + +float incbetf( float aaa, float bbb, float xxx ) +{ +float aa, bb, xx, ans, a, b, t, x, onemx; +int flag; + +aa = aaa; +bb = bbb; +xx = xxx; +if( (xx <= 0.0) || ( xx >= 1.0) ) + { + if( xx == 0.0 ) + return(0.0); + if( xx == 1.0 ) + return( 1.0 ); + mtherr( "incbetf", DOMAIN ); + return( 0.0 ); + } + +onemx = 1.0 - xx; + + +/* transformation for small aa */ + +if( aa <= 1.0 ) + { + ans = incbetf( aa+1.0, bb, xx ); + t = aa*logf(xx) + bb*logf( 1.0-xx ) + + lgamf(aa+bb) - lgamf(aa+1.0) - lgamf(bb); + if( t > MINLOGF ) + ans += expf(t); + return( ans ); + } + + +/* see if x is greater than the mean */ + +if( xx > (aa/(aa+bb)) ) + { + flag = 1; + a = bb; + b = aa; + t = xx; + x = onemx; + } +else + { + flag = 0; + a = aa; + b = bb; + t = onemx; + x = xx; + } + +/* transformation for small aa */ +/* +if( a <= 1.0 ) + { + ans = a*logf(x) + b*logf( onemx ) + + lgamf(a+b) - lgamf(a+1.0) - lgamf(b); + t = incbetf( a+1.0, b, x ); + if( ans > MINLOGF ) + t += expf(ans); + goto bdone; + } +*/ +/* Choose expansion for optimal convergence */ + + +if( b > 10.0 ) + { +if( fabsf(b*x/a) < 0.3 ) + { + t = incbpsf( a, b, x ); + goto bdone; + } + } + +ans = x * (a+b-2.0)/(a-1.0); +if( ans < 1.0 ) + { + ans = incbcff( a, b, x ); + t = b * logf( t ); + } +else + { + ans = incbdf( a, b, x ); + t = (b-1.0) * logf(t); + } + +t += a*logf(x) + lgamf(a+b) - lgamf(a) - lgamf(b); +t += logf( ans/a ); + +if( t < MINLOGF ) + { + t = 0.0; + if( flag == 0 ) + { + mtherr( "incbetf", UNDERFLOW ); + } + } +else + { + t = expf(t); + } +bdone: + +if( flag ) + t = 1.0 - t; + +return( t ); +} + +/* Continued fraction expansion #1 + * for incomplete beta integral + */ + +static float incbcff( float aa, float bb, float xx ) +{ +float a, b, x, xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +float k1, k2, k3, k4, k5, k6, k7, k8; +float r, t, ans; +static float big = BIG; +int n; + +a = aa; +b = bb; +x = xx; +k1 = a; +k2 = a + b; +k3 = a; +k4 = a + 1.0; +k5 = 1.0; +k6 = b - 1.0; +k7 = k4; +k8 = a + 2.0; + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = 1.0; +qkm1 = 1.0; +ans = 1.0; +r = 0.0; +n = 0; +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 ) + r = pk/qk; + if( r != 0 ) + { + t = fabsf( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( t < MACHEPF ) + goto cdone; + + k1 += 1.0; + k2 += 1.0; + k3 += 2.0; + k4 += 2.0; + k5 += 1.0; + k6 -= 1.0; + k7 += 2.0; + k8 += 2.0; + + if( (fabsf(qk) + fabsf(pk)) > big ) + { + pkm2 *= MACHEPF; + pkm1 *= MACHEPF; + qkm2 *= MACHEPF; + qkm1 *= MACHEPF; + } + if( (fabsf(qk) < MACHEPF) || (fabsf(pk) < MACHEPF) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 100 ); + +cdone: +return(ans); +} + + +/* Continued fraction expansion #2 + * for incomplete beta integral + */ + +static float incbdf( float aa, float bb, float xx ) +{ +float a, b, x, xk, pk, pkm1, pkm2, qk, qkm1, qkm2; +float k1, k2, k3, k4, k5, k6, k7, k8; +float r, t, ans, z; +static float big = BIG; +int n; + +a = aa; +b = bb; +x = xx; +k1 = a; +k2 = b - 1.0; +k3 = a; +k4 = a + 1.0; +k5 = 1.0; +k6 = a + b; +k7 = a + 1.0;; +k8 = a + 2.0; + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = 1.0; +qkm1 = 1.0; +z = x / (1.0-x); +ans = 1.0; +r = 0.0; +n = 0; +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 ) + r = pk/qk; + if( r != 0 ) + { + t = fabsf( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( t < MACHEPF ) + goto cdone; + + k1 += 1.0; + k2 -= 1.0; + k3 += 2.0; + k4 += 2.0; + k5 += 1.0; + k6 += 1.0; + k7 += 2.0; + k8 += 2.0; + + if( (fabsf(qk) + fabsf(pk)) > big ) + { + pkm2 *= MACHEPF; + pkm1 *= MACHEPF; + qkm2 *= MACHEPF; + qkm1 *= MACHEPF; + } + if( (fabsf(qk) < MACHEPF) || (fabsf(pk) < MACHEPF) ) + { + pkm2 *= big; + pkm1 *= big; + qkm2 *= big; + qkm1 *= big; + } + } +while( ++n < 100 ); + +cdone: +return(ans); +} + + +/* power series */ +float incbpsf( float aa, float bb, float xx ) +{ +float a, b, x, t, u, y, s; + +a = aa; +b = bb; +x = xx; + +y = a * logf(x) + (b-1.0)*logf(1.0-x) - logf(a); +y -= lgamf(a) + lgamf(b); +y += lgamf(a+b); + + +t = x / (1.0 - x); +s = 0.0; +u = 1.0; +do + { + b -= 1.0; + if( b == 0.0 ) + break; + a += 1.0; + u *= t*b/a; + s += u; + } +while( fabsf(u) > MACHEPF ); + +if( y < MINLOGF ) + { + mtherr( "incbetf", UNDERFLOW ); + s = 0.0; + } +else + s = expf(y) * (1.0 + s); +/*printf( "incbpsf: %.4e\n", s );*/ +return(s); +} diff --git a/libm/float/incbif.c b/libm/float/incbif.c new file mode 100644 index 000000000..4d8c0652e --- /dev/null +++ b/libm/float/incbif.c @@ -0,0 +1,197 @@ +/* incbif() + * + * Inverse of imcomplete beta integral + * + * + * + * SYNOPSIS: + * + * float a, b, x, y, incbif(); + * + * x = incbif( 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 0,100 5000 2.8e-4 8.3e-6 + * + * Overflow and larger errors may occur for one of a or b near zero + * and the other large. + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +extern float MACHEPF, MINLOGF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float incbetf(float, float, float); +float ndtrif(float), expf(float), logf(float), sqrtf(float), lgamf(float); +#else +float incbetf(); +float ndtrif(), expf(), logf(), sqrtf(), lgamf(); +#endif + +float incbif( float aaa, float bbb, float yyy0 ) +{ +float aa, bb, yy0, a, b, y0; +float d, y, x, x0, x1, lgm, yp, di; +int i, rflg; + + +aa = aaa; +bb = bbb; +yy0 = yyy0; +if( yy0 <= 0 ) + return(0.0); +if( yy0 >= 1.0 ) + return(1.0); + +/* approximation to inverse function */ + +yp = -ndtrif(yy0); + +if( yy0 > 0.5 ) + { + rflg = 1; + a = bb; + b = aa; + y0 = 1.0 - yy0; + yp = -yp; + } +else + { + rflg = 0; + a = aa; + b = bb; + y0 = yy0; + } + + +if( (aa <= 1.0) || (bb <= 1.0) ) + { + y = 0.5 * yp * yp; + } +else + { + lgm = (yp * yp - 3.0)* 0.16666666666666667; + x0 = 2.0/( 1.0/(2.0*a-1.0) + 1.0/(2.0*b-1.0) ); + y = yp * sqrtf( x0 + lgm ) / x0 + - ( 1.0/(2.0*b-1.0) - 1.0/(2.0*a-1.0) ) + * (lgm + 0.833333333333333333 - 2.0/(3.0*x0)); + y = 2.0 * y; + if( y < MINLOGF ) + { + x0 = 1.0; + goto under; + } + } + +x = a/( a + b * expf(y) ); +y = incbetf( a, b, x ); +yp = (y - y0)/y0; +if( fabsf(yp) < 0.1 ) + goto newt; + +/* Resort to interval halving if not close enough */ +x0 = 0.0; +x1 = 1.0; +di = 0.5; + +for( i=0; i<20; i++ ) + { + if( i != 0 ) + { + x = di * x1 + (1.0-di) * x0; + y = incbetf( a, b, x ); + yp = (y - y0)/y0; + if( fabsf(yp) < 1.0e-3 ) + goto newt; + } + + if( y < y0 ) + { + x0 = x; + di = 0.5; + } + else + { + x1 = x; + di *= di; + if( di == 0.0 ) + di = 0.5; + } + } + +if( x0 == 0.0 ) + { +under: + mtherr( "incbif", UNDERFLOW ); + goto done; + } + +newt: + +x0 = x; +lgm = lgamf(a+b) - lgamf(a) - lgamf(b); + +for( i=0; i<10; i++ ) + { +/* compute the function at this point */ + if( i != 0 ) + y = incbetf(a,b,x0); +/* compute the derivative of the function at this point */ + d = (a - 1.0) * logf(x0) + (b - 1.0) * logf(1.0-x0) + lgm; + if( d < MINLOGF ) + { + x0 = 0.0; + goto under; + } + d = expf(d); +/* compute the step to the next approximation of x */ + d = (y - y0)/d; + x = x0; + x0 = x0 - d; + if( x0 <= 0.0 ) + { + x0 = 0.0; + goto under; + } + if( x0 >= 1.0 ) + { + x0 = 1.0; + goto under; + } + if( i < 2 ) + continue; + if( fabsf(d/x0) < 256.0 * MACHEPF ) + goto done; + } + +done: +if( rflg ) + x0 = 1.0 - x0; +return( x0 ); +} diff --git a/libm/float/ivf.c b/libm/float/ivf.c new file mode 100644 index 000000000..b7ab2b619 --- /dev/null +++ b/libm/float/ivf.c @@ -0,0 +1,114 @@ +/* ivf.c + * + * Modified Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * float v, x, y, ivf(); + * + * y = ivf( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of order v of the + * argument. If x is negative, v must be integer valued. + * + * The function is defined as Iv(x) = Jv( ix ). It is + * here computed in terms of the confluent hypergeometric + * function, according to the formula + * + * v -x + * Iv(x) = (x/2) e hyperg( v+0.5, 2v+1, 2x ) / gamma(v+1) + * + * If v is a negative integer, then v is replaced by -v. + * + * + * ACCURACY: + * + * Tested at random points (v, x), with v between 0 and + * 30, x between 0 and 28. + * arithmetic domain # trials peak rms + * Relative error: + * IEEE 0,15 3000 4.7e-6 5.4e-7 + * Absolute error (relative when function > 1) + * IEEE 0,30 5000 8.5e-6 1.3e-6 + * + * Accuracy is diminished if v is near a negative integer. + * The useful domain for relative error is limited by overflow + * of the single precision exponential function. + * + * See also hyperg.c. + * + */ + /* iv.c */ +/* Modified Bessel function of noninteger order */ +/* If x < 0, then v must be an integer. */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +extern float MAXNUMF; +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +float hypergf(float, float, float); +float expf(float), gammaf(float), logf(float), floorf(float); + +float ivf( float v, float x ) +{ +int sign; +float t, ax; + +/* If v is a negative integer, invoke symmetry */ +t = floorf(v); +if( v < 0.0 ) + { + if( t == v ) + { + v = -v; /* symmetry */ + t = -t; + } + } +/* If x is negative, require v to be an integer */ +sign = 1; +if( x < 0.0 ) + { + if( t != v ) + { + mtherr( "ivf", DOMAIN ); + return( 0.0 ); + } + if( v != 2.0 * floorf(v/2.0) ) + sign = -1; + } + +/* Avoid logarithm singularity */ +if( x == 0.0 ) + { + if( v == 0.0 ) + return( 1.0 ); + if( v < 0.0 ) + { + mtherr( "ivf", OVERFLOW ); + return( MAXNUMF ); + } + else + return( 0.0 ); + } + +ax = fabsf(x); +t = v * logf( 0.5 * ax ) - x; +t = sign * expf(t) / gammaf( v + 1.0 ); +ax = v + 0.5; +return( t * hypergf( ax, 2.0 * ax, 2.0 * x ) ); +} diff --git a/libm/float/j0f.c b/libm/float/j0f.c new file mode 100644 index 000000000..2b0d4a5a4 --- /dev/null +++ b/libm/float/j0f.c @@ -0,0 +1,228 @@ +/* j0f.c + * + * Bessel function of order zero + * + * + * + * SYNOPSIS: + * + * float x, y, j0f(); + * + * y = j0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order zero of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval the following polynomial + * approximation is used: + * + * + * 2 2 2 + * (w - r ) (w - r ) (w - r ) P(w) + * 1 2 3 + * + * 2 + * where w = x and the three r's are zeros of the function. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x R(1/x^2) - pi/4. The function is + * + * j0(x) = Modulus(x) cos( Phase(x) ). + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 1.3e-7 3.6e-8 + * IEEE 2, 32 100000 1.9e-7 5.4e-8 + * + */ + /* y0f.c + * + * Bessel function of the second kind, order zero + * + * + * + * SYNOPSIS: + * + * float x, y, y0f(); + * + * y = y0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind, of order + * zero, of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * + * 2 2 2 + * y0(x) = (w - r ) (w - r ) (w - r ) R(x) + 2/pi ln(x) j0(x). + * 1 2 3 + * + * Thus a call to j0() is required. The three zeros are removed + * from R(x) to improve its numerical stability. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x S(1/x^2) - pi/4. Then the function is + * + * y0(x) = Modulus(x) sin( Phase(x) ). + * + * + * + * + * ACCURACY: + * + * Absolute error, when y0(x) < 1; else relative error: + * + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 2.4e-7 3.4e-8 + * IEEE 2, 32 100000 1.8e-7 5.3e-8 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +static float MO[8] = { +-6.838999669318810E-002f, + 1.864949361379502E-001f, +-2.145007480346739E-001f, + 1.197549369473540E-001f, +-3.560281861530129E-003f, +-4.969382655296620E-002f, +-3.355424622293709E-006f, + 7.978845717621440E-001f +}; + +static float PH[8] = { + 3.242077816988247E+001f, +-3.630592630518434E+001f, + 1.756221482109099E+001f, +-4.974978466280903E+000f, + 1.001973420681837E+000f, +-1.939906941791308E-001f, + 6.490598792654666E-002f, +-1.249992184872738E-001f +}; + +static float YP[5] = { + 9.454583683980369E-008f, +-9.413212653797057E-006f, + 5.344486707214273E-004f, +-1.584289289821316E-002f, + 1.707584643733568E-001f +}; + +float YZ1 = 0.43221455686510834878f; +float YZ2 = 22.401876406482861405f; +float YZ3 = 64.130620282338755553f; + +static float DR1 = 5.78318596294678452118f; +/* +static float DR2 = 30.4712623436620863991; +static float DR3 = 74.887006790695183444889; +*/ + +static float JP[5] = { +-6.068350350393235E-008f, + 6.388945720783375E-006f, +-3.969646342510940E-004f, + 1.332913422519003E-002f, +-1.729150680240724E-001f +}; +extern float PIO4F; + + +float polevlf(float, float *, int); +float logf(float), sinf(float), cosf(float), sqrtf(float); + +float j0f( float xx ) +{ +float x, w, z, p, q, xn; + + +if( xx < 0 ) + x = -xx; +else + x = xx; + +if( x <= 2.0f ) + { + z = x * x; + if( x < 1.0e-3f ) + return( 1.0f - 0.25f*z ); + + p = (z-DR1) * polevlf( z, JP, 4); + return( p ); + } + +q = 1.0f/x; +w = sqrtf(q); + +p = w * polevlf( q, MO, 7); +w = q*q; +xn = q * polevlf( w, PH, 7) - PIO4F; +p = p * cosf(xn + x); +return(p); +} + +/* y0() 2 */ +/* Bessel function of second kind, order zero */ + +/* Rational approximation coefficients YP[] are used for x < 6.5. + * The function computed is y0(x) - 2 ln(x) j0(x) / pi, + * whose value at x = 0 is 2 * ( log(0.5) + EUL ) / pi + * = 0.073804295108687225 , EUL is Euler's constant. + */ + +static float TWOOPI = 0.636619772367581343075535f; /* 2/pi */ +extern float MAXNUMF; + +float y0f( float xx ) +{ +float x, w, z, p, q, xn; + + +x = xx; +if( x <= 2.0f ) + { + if( x <= 0.0f ) + { + mtherr( "y0f", DOMAIN ); + return( -MAXNUMF ); + } + z = x * x; +/* w = (z-YZ1)*(z-YZ2)*(z-YZ3) * polevlf( z, YP, 4);*/ + w = (z-YZ1) * polevlf( z, YP, 4); + w += TWOOPI * logf(x) * j0f(x); + return( w ); + } + +q = 1.0f/x; +w = sqrtf(q); + +p = w * polevlf( q, MO, 7); +w = q*q; +xn = q * polevlf( w, PH, 7) - PIO4F; +p = p * sinf(xn + x); +return( p ); +} diff --git a/libm/float/j0tst.c b/libm/float/j0tst.c new file mode 100644 index 000000000..e5a5607d7 --- /dev/null +++ b/libm/float/j0tst.c @@ -0,0 +1,43 @@ +float z[20] = { +2.4048254489898681641, +5.5200781822204589844, +8.6537275314331054687, +11.791533470153808594, +14.930917739868164062, +18.071063995361328125, +21.211637496948242188, +24.352472305297851563, +27.493478775024414062, +30.634607315063476562, +33.775821685791015625, +36.9170989990234375, +40.0584259033203125, +43.19979095458984375, +46.3411865234375, +49.482608795166015625, +52.624050140380859375, +55.76551055908203125, +58.906982421875, +62.04846954345703125, +}; + +/* #if ANSIC */ +#if __STDC__ +float j0f(float); +#else +float j0f(); +#endif + +int main() +{ +float y; +int i; + +for (i = 0; i< 20; i++) + { + y = j0f(z[i]); + printf("%.9e\n", y); + } +exit(0); +} + diff --git a/libm/float/j1f.c b/libm/float/j1f.c new file mode 100644 index 000000000..4306e9747 --- /dev/null +++ b/libm/float/j1f.c @@ -0,0 +1,211 @@ +/* j1f.c + * + * Bessel function of order one + * + * + * + * SYNOPSIS: + * + * float x, y, j1f(); + * + * y = j1f( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order one of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a polynomial approximation + * 2 + * (w - r ) x P(w) + * 1 + * 2 + * is used, where w = x and r is the first zero of the function. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x R(1/x^2) - 3pi/4. The function is + * + * j0(x) = Modulus(x) cos( Phase(x) ). + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 1.2e-7 2.5e-8 + * IEEE 2, 32 100000 2.0e-7 5.3e-8 + * + * + */ + /* y1.c + * + * Bessel function of second kind of order one + * + * + * + * SYNOPSIS: + * + * double x, y, y1(); + * + * y = y1( x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of the second kind of order one + * of the argument. + * + * The domain is divided into the intervals [0, 2] and + * (2, infinity). In the first interval a rational approximation + * R(x) is employed to compute + * + * 2 + * y0(x) = (w - r ) x R(x^2) + 2/pi (ln(x) j1(x) - 1/x) . + * 1 + * + * Thus a call to j1() is required. + * + * In the second interval, the modulus and phase are approximated + * by polynomials of the form Modulus(x) = sqrt(1/x) Q(1/x) + * and Phase(x) = x + 1/x S(1/x^2) - 3pi/4. Then the function is + * + * y0(x) = Modulus(x) sin( Phase(x) ). + * + * + * + * + * ACCURACY: + * + * Absolute error: + * arithmetic domain # trials peak rms + * IEEE 0, 2 100000 2.2e-7 4.6e-8 + * IEEE 2, 32 100000 1.9e-7 5.3e-8 + * + * (error criterion relative when |y1| > 1). + * + */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + + +static float JP[5] = { +-4.878788132172128E-009f, + 6.009061827883699E-007f, +-4.541343896997497E-005f, + 1.937383947804541E-003f, +-3.405537384615824E-002f +}; + +static float YP[5] = { + 8.061978323326852E-009f, +-9.496460629917016E-007f, + 6.719543806674249E-005f, +-2.641785726447862E-003f, + 4.202369946500099E-002f +}; + +static float MO1[8] = { + 6.913942741265801E-002f, +-2.284801500053359E-001f, + 3.138238455499697E-001f, +-2.102302420403875E-001f, + 5.435364690523026E-003f, + 1.493389585089498E-001f, + 4.976029650847191E-006f, + 7.978845453073848E-001f +}; + +static float PH1[8] = { +-4.497014141919556E+001f, + 5.073465654089319E+001f, +-2.485774108720340E+001f, + 7.222973196770240E+000f, +-1.544842782180211E+000f, + 3.503787691653334E-001f, +-1.637986776941202E-001f, + 3.749989509080821E-001f +}; + +static float YO1 = 4.66539330185668857532f; +static float Z1 = 1.46819706421238932572E1f; + +static float THPIO4F = 2.35619449019234492885f; /* 3*pi/4 */ +static float TWOOPI = 0.636619772367581343075535f; /* 2/pi */ +extern float PIO4; + + +float polevlf(float, float *, int); +float logf(float), sinf(float), cosf(float), sqrtf(float); + +float j1f( float xx ) +{ +float x, w, z, p, q, xn; + + +x = xx; +if( x < 0 ) + x = -xx; + +if( x <= 2.0f ) + { + z = x * x; + p = (z-Z1) * x * polevlf( z, JP, 4 ); + return( p ); + } + +q = 1.0f/x; +w = sqrtf(q); + +p = w * polevlf( q, MO1, 7); +w = q*q; +xn = q * polevlf( w, PH1, 7) - THPIO4F; +p = p * cosf(xn + x); +return(p); +} + + + + +extern float MAXNUMF; + +float y1f( float xx ) +{ +float x, w, z, p, q, xn; + + +x = xx; +if( x <= 2.0f ) + { + if( x <= 0.0f ) + { + mtherr( "y1f", DOMAIN ); + return( -MAXNUMF ); + } + z = x * x; + w = (z - YO1) * x * polevlf( z, YP, 4 ); + w += TWOOPI * ( j1f(x) * logf(x) - 1.0f/x ); + return( w ); + } + +q = 1.0f/x; +w = sqrtf(q); + +p = w * polevlf( q, MO1, 7); +w = q*q; +xn = q * polevlf( w, PH1, 7) - THPIO4F; +p = p * sinf(xn + x); +return(p); +} diff --git a/libm/float/jnf.c b/libm/float/jnf.c new file mode 100644 index 000000000..de358e0ef --- /dev/null +++ b/libm/float/jnf.c @@ -0,0 +1,124 @@ +/* jnf.c + * + * Bessel function of integer order + * + * + * + * SYNOPSIS: + * + * int n; + * float x, y, jnf(); + * + * y = jnf( 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 range # trials peak rms + * IEEE 0, 15 30000 3.6e-7 3.6e-8 + * + * + * Not suitable for large n or x. Use jvf() instead. + * + */ + +/* jn.c +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ +#include <math.h> + +extern float MACHEPF; + +float j0f(float), j1f(float); + +float jnf( int n, float xx ) +{ +float x, pkm2, pkm1, pk, xk, r, ans, xinv, sign; +int k; + +x = xx; +sign = 1.0; +if( n < 0 ) + { + n = -n; + if( (n & 1) != 0 ) /* -1**n */ + sign = -1.0; + } + +if( n == 0 ) + return( sign * j0f(x) ); +if( n == 1 ) + return( sign * j1f(x) ); +if( n == 2 ) + return( sign * (2.0 * j1f(x) / x - j0f(x)) ); + +/* +if( x < MACHEPF ) + return( 0.0 ); +*/ + +/* continued fraction */ +k = 24; +pk = 2 * (n + k); +ans = pk; +xk = x * x; + +do + { + pk -= 2.0; + ans = pk - (xk/ans); + } +while( --k > 0 ); +/*ans = x/ans;*/ + +/* backward recurrence */ + +pk = 1.0; +/*pkm1 = 1.0/ans;*/ +xinv = 1.0/x; +pkm1 = ans * xinv; +k = n-1; +r = (float )(2 * k); + +do + { + pkm2 = (pkm1 * r - pk * x) * xinv; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; + } +while( --k > 0 ); + +r = pk; +if( r < 0 ) + r = -r; +ans = pkm1; +if( ans < 0 ) + ans = -ans; + +if( r > ans ) /* if( fabs(pk) > fabs(pkm1) ) */ + ans = sign * j1f(x)/pk; +else + ans = sign * j0f(x)/pkm1; +return( ans ); +} diff --git a/libm/float/jvf.c b/libm/float/jvf.c new file mode 100644 index 000000000..268a8e4eb --- /dev/null +++ b/libm/float/jvf.c @@ -0,0 +1,848 @@ +/* jvf.c + * + * Bessel function of noninteger order + * + * + * + * SYNOPSIS: + * + * float v, x, y, jvf(); + * + * y = jvf( v, x ); + * + * + * + * DESCRIPTION: + * + * Returns Bessel function of order v of the argument, + * where v is real. Negative x is allowed if v is an integer. + * + * Several expansions are included: the ascending power + * series, the Hankel expansion, and two transitional + * expansions for large v. If v is not too large, it + * is reduced by recurrence to a region of best accuracy. + * + * The single precision routine accepts negative v, but with + * reduced accuracy. + * + * + * + * ACCURACY: + * Results for integer v are indicated by *. + * Error criterion is absolute, except relative when |jv()| > 1. + * + * arithmetic domain # trials peak rms + * v x + * IEEE 0,125 0,125 30000 2.0e-6 2.0e-7 + * IEEE -17,0 0,125 30000 1.1e-5 4.0e-7 + * IEEE -100,0 0,125 3000 1.5e-4 7.8e-6 + */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> +#define DEBUG 0 + +extern float MAXNUMF, MACHEPF, MINLOGF, MAXLOGF, PIF; +extern int sgngamf; + +/* BIG = 1/MACHEPF */ +#define BIG 16777216. + +#ifdef ANSIC +float floorf(float), j0f(float), j1f(float); +static float jnxf(float, float); +static float jvsf(float, float); +static float hankelf(float, float); +static float jntf(float, float); +static float recurf( float *, float, float * ); +float sqrtf(float), sinf(float), cosf(float); +float lgamf(float), expf(float), logf(float), powf(float, float); +float gammaf(float), cbrtf(float), acosf(float); +int airyf(float, float *, float *, float *, float *); +float polevlf(float, float *, int); +#else +float floorf(), j0f(), j1f(); +float sqrtf(), sinf(), cosf(); +float lgamf(), expf(), logf(), powf(), gammaf(); +float cbrtf(), polevlf(), acosf(); +void airyf(); +static float recurf(), jvsf(), hankelf(), jnxf(), jntf(), jvsf(); +#endif + + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +float jvf( float nn, float xx ) +{ +float n, x, k, q, t, y, an, sign; +int i, nint; + +n = nn; +x = xx; +nint = 0; /* Flag for integer n */ +sign = 1.0; /* Flag for sign inversion */ +an = fabsf( n ); +y = floorf( an ); +if( y == an ) + { + nint = 1; + i = an - 16384.0 * floorf( an/16384.0 ); + if( n < 0.0 ) + { + if( i & 1 ) + sign = -sign; + n = an; + } + if( x < 0.0 ) + { + if( i & 1 ) + sign = -sign; + x = -x; + } + if( n == 0.0 ) + return( j0f(x) ); + if( n == 1.0 ) + return( sign * j1f(x) ); + } + +if( (x < 0.0) && (y != an) ) + { + mtherr( "jvf", DOMAIN ); + y = 0.0; + goto done; + } + +y = fabsf(x); + +if( y < MACHEPF ) + goto underf; + +/* Easy cases - x small compared to n */ +t = 3.6 * sqrtf(an); +if( y < t ) + return( sign * jvsf(n,x) ); + +/* x large compared to n */ +k = 3.6 * sqrtf(y); +if( (an < k) && (y > 6.0) ) + return( sign * hankelf(n,x) ); + +if( (n > -100) && (n < 14.0) ) + { +/* Note: if x is too large, the continued + * fraction will fail; but then the + * Hankel expansion can be used. + */ + if( nint != 0 ) + { + k = 0.0; + q = recurf( &n, x, &k ); + if( k == 0.0 ) + { + y = j0f(x)/q; + goto done; + } + if( k == 1.0 ) + { + y = j1f(x)/q; + goto done; + } + } + + if( n >= 0.0 ) + { +/* Recur backwards from a larger value of n + */ + if( y > 1.3 * an ) + goto recurdwn; + if( an > 1.3 * y ) + goto recurdwn; + k = n; + y = 2.0*(y+an+1.0); + if( (y - n) > 33.0 ) + y = n + 33.0; + y = n + floorf(y-n); + q = recurf( &y, x, &k ); + y = jvsf(y,x) * q; + goto done; + } +recurdwn: + if( an > (k + 3.0) ) + { +/* Recur backwards from n to k + */ + if( n < 0.0 ) + k = -k; + q = n - floorf(n); + k = floorf(k) + q; + if( n > 0.0 ) + q = recurf( &n, x, &k ); + else + { + t = k; + k = n; + q = recurf( &t, x, &k ); + k = t; + } + if( q == 0.0 ) + { +underf: + y = 0.0; + goto done; + } + } + else + { + k = n; + q = 1.0; + } + +/* boundary between convergence of + * power series and Hankel expansion + */ + t = fabsf(k); + if( t < 26.0 ) + t = (0.0083*t + 0.09)*t + 12.9; + else + t = 0.9 * t; + + if( y > t ) /* y = |x| */ + y = hankelf(k,x); + else + y = jvsf(k,x); +#if DEBUG +printf( "y = %.16e, q = %.16e\n", y, q ); +#endif + if( n > 0.0 ) + y /= q; + else + y *= q; + } + +else + { +/* For large positive n, use the uniform expansion + * or the transitional expansion. + * But if x is of the order of n**2, + * these may blow up, whereas the + * Hankel expansion will then work. + */ + if( n < 0.0 ) + { + mtherr( "jvf", TLOSS ); + y = 0.0; + goto done; + } + t = y/an; + t /= an; + if( t > 0.3 ) + y = hankelf(n,x); + else + y = jnxf(n,x); + } + +done: return( sign * y); +} + +/* Reduce the order by backward recurrence. + * AMS55 #9.1.27 and 9.1.73. + */ + +static float recurf( float *n, float xx, float *newn ) +{ +float x, pkm2, pkm1, pk, pkp1, qkm2, qkm1; +float k, ans, qk, xk, yk, r, t, kf, xinv; +static float big = BIG; +int nflag, ctr; + +x = xx; +/* continued fraction for Jn(x)/Jn-1(x) */ +if( *n < 0.0 ) + nflag = 1; +else + nflag = 0; + +fstart: + +#if DEBUG +printf( "n = %.6e, newn = %.6e, cfrac = ", *n, *newn ); +#endif + +pkm2 = 0.0; +qkm2 = 1.0; +pkm1 = x; +qkm1 = *n + *n; +xk = -x * x; +yk = qkm1; +ans = 1.0; +ctr = 0; +do + { + yk += 2.0; + pk = pkm1 * yk + pkm2 * xk; + qk = qkm1 * yk + qkm2 * xk; + pkm2 = pkm1; + pkm1 = pk; + qkm2 = qkm1; + qkm1 = qk; + if( qk != 0 ) + r = pk/qk; + else + r = 0.0; + if( r != 0 ) + { + t = fabsf( (ans - r)/r ); + ans = r; + } + else + t = 1.0; + + if( t < MACHEPF ) + goto done; + + if( fabsf(pk) > big ) + { + pkm2 *= MACHEPF; + pkm1 *= MACHEPF; + qkm2 *= MACHEPF; + qkm1 *= MACHEPF; + } + } +while( t > MACHEPF ); + +done: + +#if DEBUG +printf( "%.6e\n", ans ); +#endif + +/* Change n to n-1 if n < 0 and the continued fraction is small + */ +if( nflag > 0 ) + { + if( fabsf(ans) < 0.125 ) + { + nflag = -1; + *n = *n - 1.0; + goto fstart; + } + } + + +kf = *newn; + +/* backward recurrence + * 2k + * J (x) = --- J (x) - J (x) + * k-1 x k k+1 + */ + +pk = 1.0; +pkm1 = 1.0/ans; +k = *n - 1.0; +r = 2 * k; +xinv = 1.0/x; +do + { + pkm2 = (pkm1 * r - pk * x) * xinv; + pkp1 = pk; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; +#if 0 + t = fabsf(pkp1) + fabsf(pk); + if( (k > (kf + 2.5)) && (fabsf(pkm1) < 0.25*t) ) + { + k -= 1.0; + t = x*x; + pkm2 = ( (r*(r+2.0)-t)*pk - r*x*pkp1 )/t; + pkp1 = pk; + pk = pkm1; + pkm1 = pkm2; + r -= 2.0; + } +#endif + k -= 1.0; + } +while( k > (kf + 0.5) ); + +#if 0 +/* Take the larger of the last two iterates + * on the theory that it may have less cancellation error. + */ +if( (kf >= 0.0) && (fabsf(pk) > fabsf(pkm1)) ) + { + k += 1.0; + pkm2 = pk; + } +#endif + +*newn = k; +#if DEBUG +printf( "newn %.6e\n", k ); +#endif +return( pkm2 ); +} + + + +/* Ascending power series for Jv(x). + * AMS55 #9.1.10. + */ + +static float jvsf( float nn, float xx ) +{ +float n, x, t, u, y, z, k, ay; + +#if DEBUG +printf( "jvsf: " ); +#endif +n = nn; +x = xx; +z = -0.25 * x * x; +u = 1.0; +y = u; +k = 1.0; +t = 1.0; + +while( t > MACHEPF ) + { + u *= z / (k * (n+k)); + y += u; + k += 1.0; + t = fabsf(u); + if( (ay = fabsf(y)) > 1.0 ) + t /= ay; + } + +if( x < 0.0 ) + { + y = y * powf( 0.5 * x, n ) / gammaf( n + 1.0 ); + } +else + { + t = n * logf(0.5*x) - lgamf(n + 1.0); + if( t < -MAXLOGF ) + { + return( 0.0 ); + } + if( t > MAXLOGF ) + { + t = logf(y) + t; + if( t > MAXLOGF ) + { + mtherr( "jvf", OVERFLOW ); + return( MAXNUMF ); + } + else + { + y = sgngamf * expf(t); + return(y); + } + } + y = sgngamf * y * expf( t ); + } +#if DEBUG +printf( "y = %.8e\n", y ); +#endif +return(y); +} + +/* Hankel's asymptotic expansion + * for large x. + * AMS55 #9.2.5. + */ +static float hankelf( float nn, float xx ) +{ +float n, x, t, u, z, k, sign, conv; +float p, q, j, m, pp, qq; +int flag; + +#if DEBUG +printf( "hankelf: " ); +#endif +n = nn; +x = xx; +m = 4.0*n*n; +j = 1.0; +z = 8.0 * x; +k = 1.0; +p = 1.0; +u = (m - 1.0)/z; +q = u; +sign = 1.0; +conv = 1.0; +flag = 0; +t = 1.0; +pp = 1.0e38; +qq = 1.0e38; + +while( t > MACHEPF ) + { + k += 2.0; + j += 1.0; + sign = -sign; + u *= (m - k * k)/(j * z); + p += sign * u; + k += 2.0; + j += 1.0; + u *= (m - k * k)/(j * z); + q += sign * u; + t = fabsf(u/p); + if( t < conv ) + { + conv = t; + qq = q; + pp = p; + flag = 1; + } +/* stop if the terms start getting larger */ + if( (flag != 0) && (t > conv) ) + { +#if DEBUG + printf( "Hankel: convergence to %.4E\n", conv ); +#endif + goto hank1; + } + } + +hank1: +u = x - (0.5*n + 0.25) * PIF; +t = sqrtf( 2.0/(PIF*x) ) * ( pp * cosf(u) - qq * sinf(u) ); +return( t ); +} + + +/* Asymptotic expansion for large n. + * AMS55 #9.3.35. + */ + +static float lambda[] = { + 1.0, + 1.041666666666666666666667E-1, + 8.355034722222222222222222E-2, + 1.282265745563271604938272E-1, + 2.918490264641404642489712E-1, + 8.816272674437576524187671E-1, + 3.321408281862767544702647E+0, + 1.499576298686255465867237E+1, + 7.892301301158651813848139E+1, + 4.744515388682643231611949E+2, + 3.207490090890661934704328E+3 +}; +static float mu[] = { + 1.0, + -1.458333333333333333333333E-1, + -9.874131944444444444444444E-2, + -1.433120539158950617283951E-1, + -3.172272026784135480967078E-1, + -9.424291479571202491373028E-1, + -3.511203040826354261542798E+0, + -1.572726362036804512982712E+1, + -8.228143909718594444224656E+1, + -4.923553705236705240352022E+2, + -3.316218568547972508762102E+3 +}; +static float P1[] = { + -2.083333333333333333333333E-1, + 1.250000000000000000000000E-1 +}; +static float P2[] = { + 3.342013888888888888888889E-1, + -4.010416666666666666666667E-1, + 7.031250000000000000000000E-2 +}; +static float P3[] = { + -1.025812596450617283950617E+0, + 1.846462673611111111111111E+0, + -8.912109375000000000000000E-1, + 7.324218750000000000000000E-2 +}; +static float P4[] = { + 4.669584423426247427983539E+0, + -1.120700261622299382716049E+1, + 8.789123535156250000000000E+0, + -2.364086914062500000000000E+0, + 1.121520996093750000000000E-1 +}; +static float P5[] = { + -2.8212072558200244877E1, + 8.4636217674600734632E1, + -9.1818241543240017361E1, + 4.2534998745388454861E1, + -7.3687943594796316964E0, + 2.27108001708984375E-1 +}; +static float P6[] = { + 2.1257013003921712286E2, + -7.6525246814118164230E2, + 1.0599904525279998779E3, + -6.9957962737613254123E2, + 2.1819051174421159048E2, + -2.6491430486951555525E1, + 5.7250142097473144531E-1 +}; +static float P7[] = { + -1.9194576623184069963E3, + 8.0617221817373093845E3, + -1.3586550006434137439E4, + 1.1655393336864533248E4, + -5.3056469786134031084E3, + 1.2009029132163524628E3, + -1.0809091978839465550E2, + 1.7277275025844573975E0 +}; + + +static float jnxf( float nn, float xx ) +{ +float n, x, zeta, sqz, zz, zp, np; +float cbn, n23, t, z, sz; +float pp, qq, z32i, zzi; +float ak, bk, akl, bkl; +int sign, doa, dob, nflg, k, s, tk, tkp1, m; +static float u[8]; +static float ai, aip, bi, bip; + +n = nn; +x = xx; +/* Test for x very close to n. + * Use expansion for transition region if so. + */ +cbn = cbrtf(n); +z = (x - n)/cbn; +if( (fabsf(z) <= 0.7) || (n < 0.0) ) + return( jntf(n,x) ); +z = x/n; +zz = 1.0 - z*z; +if( zz == 0.0 ) + return(0.0); + +if( zz > 0.0 ) + { + sz = sqrtf( zz ); + t = 1.5 * (logf( (1.0+sz)/z ) - sz ); /* zeta ** 3/2 */ + zeta = cbrtf( t * t ); + nflg = 1; + } +else + { + sz = sqrtf(-zz); + t = 1.5 * (sz - acosf(1.0/z)); + zeta = -cbrtf( t * t ); + nflg = -1; + } +z32i = fabsf(1.0/t); +sqz = cbrtf(t); + +/* Airy function */ +n23 = cbrtf( n * n ); +t = n23 * zeta; + +#if DEBUG +printf("zeta %.5E, Airyf(%.5E)\n", zeta, t ); +#endif +airyf( t, &ai, &aip, &bi, &bip ); + +/* polynomials in expansion */ +u[0] = 1.0; +zzi = 1.0/zz; +u[1] = polevlf( zzi, P1, 1 )/sz; +u[2] = polevlf( zzi, P2, 2 )/zz; +u[3] = polevlf( zzi, P3, 3 )/(sz*zz); +pp = zz*zz; +u[4] = polevlf( zzi, P4, 4 )/pp; +u[5] = polevlf( zzi, P5, 5 )/(pp*sz); +pp *= zz; +u[6] = polevlf( zzi, P6, 6 )/pp; +u[7] = polevlf( zzi, P7, 7 )/(pp*sz); + +#if DEBUG +for( k=0; k<=7; k++ ) + printf( "u[%d] = %.5E\n", k, u[k] ); +#endif + +pp = 0.0; +qq = 0.0; +np = 1.0; +/* flags to stop when terms get larger */ +doa = 1; +dob = 1; +akl = MAXNUMF; +bkl = MAXNUMF; + +for( k=0; k<=3; k++ ) + { + tk = 2 * k; + tkp1 = tk + 1; + zp = 1.0; + ak = 0.0; + bk = 0.0; + for( s=0; s<=tk; s++ ) + { + if( doa ) + { + if( (s & 3) > 1 ) + sign = nflg; + else + sign = 1; + ak += sign * mu[s] * zp * u[tk-s]; + } + + if( dob ) + { + m = tkp1 - s; + if( ((m+1) & 3) > 1 ) + sign = nflg; + else + sign = 1; + bk += sign * lambda[s] * zp * u[m]; + } + zp *= z32i; + } + + if( doa ) + { + ak *= np; + t = fabsf(ak); + if( t < akl ) + { + akl = t; + pp += ak; + } + else + doa = 0; + } + + if( dob ) + { + bk += lambda[tkp1] * zp * u[0]; + bk *= -np/sqz; + t = fabsf(bk); + if( t < bkl ) + { + bkl = t; + qq += bk; + } + else + dob = 0; + } +#if DEBUG + printf("a[%d] %.5E, b[%d] %.5E\n", k, ak, k, bk ); +#endif + if( np < MACHEPF ) + break; + np /= n*n; + } + +/* normalizing factor ( 4*zeta/(1 - z**2) )**1/4 */ +t = 4.0 * zeta/zz; +t = sqrtf( sqrtf(t) ); + +t *= ai*pp/cbrtf(n) + aip*qq/(n23*n); +return(t); +} + +/* Asymptotic expansion for transition region, + * n large and x close to n. + * AMS55 #9.3.23. + */ + +static float PF2[] = { + -9.0000000000000000000e-2, + 8.5714285714285714286e-2 +}; +static float PF3[] = { + 1.3671428571428571429e-1, + -5.4920634920634920635e-2, + -4.4444444444444444444e-3 +}; +static float PF4[] = { + 1.3500000000000000000e-3, + -1.6036054421768707483e-1, + 4.2590187590187590188e-2, + 2.7330447330447330447e-3 +}; +static float PG1[] = { + -2.4285714285714285714e-1, + 1.4285714285714285714e-2 +}; +static float PG2[] = { + -9.0000000000000000000e-3, + 1.9396825396825396825e-1, + -1.1746031746031746032e-2 +}; +static float PG3[] = { + 1.9607142857142857143e-2, + -1.5983694083694083694e-1, + 6.3838383838383838384e-3 +}; + + +static float jntf( float nn, float xx ) +{ +float n, x, z, zz, z3; +float cbn, n23, cbtwo; +float ai, aip, bi, bip; /* Airy functions */ +float nk, fk, gk, pp, qq; +float F[5], G[4]; +int k; + +n = nn; +x = xx; +cbn = cbrtf(n); +z = (x - n)/cbn; +cbtwo = cbrtf( 2.0 ); + +/* Airy function */ +zz = -cbtwo * z; +airyf( zz, &ai, &aip, &bi, &bip ); + +/* polynomials in expansion */ +zz = z * z; +z3 = zz * z; +F[0] = 1.0; +F[1] = -z/5.0; +F[2] = polevlf( z3, PF2, 1 ) * zz; +F[3] = polevlf( z3, PF3, 2 ); +F[4] = polevlf( z3, PF4, 3 ) * z; +G[0] = 0.3 * zz; +G[1] = polevlf( z3, PG1, 1 ); +G[2] = polevlf( z3, PG2, 2 ) * z; +G[3] = polevlf( z3, PG3, 2 ) * zz; +#if DEBUG +for( k=0; k<=4; k++ ) + printf( "F[%d] = %.5E\n", k, F[k] ); +for( k=0; k<=3; k++ ) + printf( "G[%d] = %.5E\n", k, G[k] ); +#endif +pp = 0.0; +qq = 0.0; +nk = 1.0; +n23 = cbrtf( n * n ); + +for( k=0; k<=4; k++ ) + { + fk = F[k]*nk; + pp += fk; + if( k != 4 ) + { + gk = G[k]*nk; + qq += gk; + } +#if DEBUG + printf("fk[%d] %.5E, gk[%d] %.5E\n", k, fk, k, gk ); +#endif + nk /= n23; + } + +fk = cbtwo * ai * pp/cbn + cbrtf(4.0) * aip * qq/n; +return(fk); +} diff --git a/libm/float/k0f.c b/libm/float/k0f.c new file mode 100644 index 000000000..e0e0698ac --- /dev/null +++ b/libm/float/k0f.c @@ -0,0 +1,175 @@ +/* k0f.c + * + * Modified Bessel function, third kind, order zero + * + * + * + * SYNOPSIS: + * + * float x, y, k0f(); + * + * y = k0f( x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order zero of the argument. + * + * The range is partitioned into the two intervals [0,8] and + * (8, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Tested at 2000 random points between 0 and 8. Peak absolute + * error (relative when K0 > 1) was 1.46e-14; rms, 4.26e-15. + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 7.8e-7 8.5e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * K0 domain x <= 0 MAXNUM + * + */ + /* k0ef() + * + * Modified Bessel function, third kind, order zero, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, k0ef(); + * + * y = k0ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order zero of the argument. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 8.1e-7 7.8e-8 + * See k0(). + * + */ + +/* +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> + +/* Chebyshev coefficients for K0(x) + log(x/2) I0(x) + * in the interval [0,2]. The odd order coefficients are all + * zero; only the even order coefficients are listed. + * + * lim(x->0){ K0(x) + log(x/2) I0(x) } = -EUL. + */ + +static float A[] = +{ + 1.90451637722020886025E-9f, + 2.53479107902614945675E-7f, + 2.28621210311945178607E-5f, + 1.26461541144692592338E-3f, + 3.59799365153615016266E-2f, + 3.44289899924628486886E-1f, +-5.35327393233902768720E-1f +}; + + + +/* Chebyshev coefficients for exp(x) sqrt(x) K0(x) + * in the inverted interval [2,infinity]. + * + * lim(x->inf){ exp(x) sqrt(x) K0(x) } = sqrt(pi/2). + */ + +static float B[] = { +-1.69753450938905987466E-9f, + 8.57403401741422608519E-9f, +-4.66048989768794782956E-8f, + 2.76681363944501510342E-7f, +-1.83175552271911948767E-6f, + 1.39498137188764993662E-5f, +-1.28495495816278026384E-4f, + 1.56988388573005337491E-3f, +-3.14481013119645005427E-2f, + 2.44030308206595545468E0f +}; + +/* k0.c */ + +extern float MAXNUMF; + +#ifdef ANSIC +float chbevlf(float, float *, int); +float expf(float), i0f(float), logf(float), sqrtf(float); +#else +float chbevlf(), expf(), i0f(), logf(), sqrtf(); +#endif + + +float k0f( float xx ) +{ +float x, y, z; + +x = xx; +if( x <= 0.0f ) + { + mtherr( "k0f", DOMAIN ); + return( MAXNUMF ); + } + +if( x <= 2.0f ) + { + y = x * x - 2.0f; + y = chbevlf( y, A, 7 ) - logf( 0.5f * x ) * i0f(x); + return( y ); + } +z = 8.0f/x - 2.0f; +y = expf(-x) * chbevlf( z, B, 10 ) / sqrtf(x); +return(y); +} + + + +float k0ef( float xx ) +{ +float x, y; + + +x = xx; +if( x <= 0.0f ) + { + mtherr( "k0ef", DOMAIN ); + return( MAXNUMF ); + } + +if( x <= 2.0f ) + { + y = x * x - 2.0f; + y = chbevlf( y, A, 7 ) - logf( 0.5f * x ) * i0f(x); + return( y * expf(x) ); + } + +y = chbevlf( 8.0f/x - 2.0f, B, 10 ) / sqrtf(x); +return(y); +} diff --git a/libm/float/k1f.c b/libm/float/k1f.c new file mode 100644 index 000000000..d5b9bdfce --- /dev/null +++ b/libm/float/k1f.c @@ -0,0 +1,174 @@ +/* k1f.c + * + * Modified Bessel function, third kind, order one + * + * + * + * SYNOPSIS: + * + * float x, y, k1f(); + * + * y = k1f( x ); + * + * + * + * DESCRIPTION: + * + * Computes the modified Bessel function of the third kind + * of order one of the argument. + * + * The range is partitioned into the two intervals [0,2] and + * (2, infinity). Chebyshev polynomial expansions are employed + * in each interval. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 4.6e-7 7.6e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * k1 domain x <= 0 MAXNUM + * + */ + /* k1ef.c + * + * Modified Bessel function, third kind, order one, + * exponentially scaled + * + * + * + * SYNOPSIS: + * + * float x, y, k1ef(); + * + * y = k1ef( x ); + * + * + * + * DESCRIPTION: + * + * Returns exponentially scaled modified Bessel function + * of the third kind of order one of the argument: + * + * k1e(x) = exp(x) * k1(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0, 30 30000 4.9e-7 6.7e-8 + * See k1(). + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +/* Chebyshev coefficients for x(K1(x) - log(x/2) I1(x)) + * in the interval [0,2]. + * + * lim(x->0){ x(K1(x) - log(x/2) I1(x)) } = 1. + */ + +#define MINNUMF 6.0e-39 +static float A[] = +{ +-2.21338763073472585583E-8f, +-2.43340614156596823496E-6f, +-1.73028895751305206302E-4f, +-6.97572385963986435018E-3f, +-1.22611180822657148235E-1f, +-3.53155960776544875667E-1f, + 1.52530022733894777053E0f +}; + + + + +/* Chebyshev coefficients for exp(x) sqrt(x) K1(x) + * in the interval [2,infinity]. + * + * lim(x->inf){ exp(x) sqrt(x) K1(x) } = sqrt(pi/2). + */ + +static float B[] = +{ + 2.01504975519703286596E-9f, +-1.03457624656780970260E-8f, + 5.74108412545004946722E-8f, +-3.50196060308781257119E-7f, + 2.40648494783721712015E-6f, +-1.93619797416608296024E-5f, + 1.95215518471351631108E-4f, +-2.85781685962277938680E-3f, + 1.03923736576817238437E-1f, + 2.72062619048444266945E0f +}; + + + +extern float MAXNUMF; +#ifdef ANSIC +float chbevlf(float, float *, int); +float expf(float), i1f(float), logf(float), sqrtf(float); +#else +float chbevlf(), expf(), i1f(), logf(), sqrtf(); +#endif + +float k1f(float xx) +{ +float x, y; + +x = xx; +if( x <= MINNUMF ) + { + mtherr( "k1f", DOMAIN ); + return( MAXNUMF ); + } + +if( x <= 2.0f ) + { + y = x * x - 2.0f; + y = logf( 0.5f * x ) * i1f(x) + chbevlf( y, A, 7 ) / x; + return( y ); + } + +return( expf(-x) * chbevlf( 8.0f/x - 2.0f, B, 10 ) / sqrtf(x) ); + +} + + + +float k1ef( float xx ) +{ +float x, y; + +x = xx; +if( x <= 0.0f ) + { + mtherr( "k1ef", DOMAIN ); + return( MAXNUMF ); + } + +if( x <= 2.0f ) + { + y = x * x - 2.0f; + y = logf( 0.5f * x ) * i1f(x) + chbevlf( y, A, 7 ) / x; + return( y * expf(x) ); + } + +return( chbevlf( 8.0f/x - 2.0f, B, 10 ) / sqrtf(x) ); + +} diff --git a/libm/float/knf.c b/libm/float/knf.c new file mode 100644 index 000000000..85e297390 --- /dev/null +++ b/libm/float/knf.c @@ -0,0 +1,252 @@ +/* knf.c + * + * Modified Bessel function, third kind, integer order + * + * + * + * SYNOPSIS: + * + * float x, y, knf(); + * int n; + * + * y = knf( n, x ); + * + * + * + * DESCRIPTION: + * + * Returns modified Bessel function of the third kind + * of order n of the argument. + * + * The range is partitioned into the two intervals [0,9.55] and + * (9.55, infinity). An ascending power series is used in the + * low range, and an asymptotic expansion in the high range. + * + * + * + * ACCURACY: + * + * Absolute error, relative when function > 1: + * arithmetic domain # trials peak rms + * IEEE 0,30 10000 2.0e-4 3.8e-6 + * + * Error is high only near the crossover point x = 9.55 + * between the two expansions used. + */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 + +*/ + + +/* +Algorithm for Kn. + n-1 + -n - (n-k-1)! 2 k +K (x) = 0.5 (x/2) > -------- (-x /4) + n - k! + k=0 + + inf. 2 k + n n - (x /4) + + (-1) 0.5(x/2) > {p(k+1) + p(n+k+1) - 2log(x/2)} --------- + - k! (n+k)! + k=0 + +where p(m) is the psi function: p(1) = -EUL and + + m-1 + - + p(m) = -EUL + > 1/k + - + k=1 + +For large x, + 2 2 2 + u-1 (u-1 )(u-3 ) +K (z) = sqrt(pi/2z) exp(-z) { 1 + ------- + ------------ + ...} + v 1 2 + 1! (8z) 2! (8z) +asymptotically, where + + 2 + u = 4 v . + +*/ + +#include <math.h> + +#define EUL 5.772156649015328606065e-1 +#define MAXFAC 31 +extern float MACHEPF, MAXNUMF, MAXLOGF, PIF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +float expf(float), logf(float), sqrtf(float); + +float knf( int nnn, float xx ) +{ +float x, k, kf, nk1f, nkf, zn, t, s, z0, z; +float ans, fn, pn, pk, zmn, tlg, tox; +int i, n, nn; + +nn = nnn; +x = xx; +if( nn < 0 ) + n = -nn; +else + n = nn; + +if( n > MAXFAC ) + { +overf: + mtherr( "knf", OVERFLOW ); + return( MAXNUMF ); + } + +if( x <= 0.0 ) + { + if( x < 0.0 ) + mtherr( "knf", DOMAIN ); + else + mtherr( "knf", SING ); + return( MAXNUMF ); + } + + +if( x > 9.55 ) + goto asymp; + +ans = 0.0; +z0 = 0.25 * x * x; +fn = 1.0; +pn = 0.0; +zmn = 1.0; +tox = 2.0/x; + +if( n > 0 ) + { + /* compute factorial of n and psi(n) */ + pn = -EUL; + k = 1.0; + for( i=1; i<n; i++ ) + { + pn += 1.0/k; + k += 1.0; + fn *= k; + } + + zmn = tox; + + if( n == 1 ) + { + ans = 1.0/x; + } + else + { + nk1f = fn/n; + kf = 1.0; + s = nk1f; + z = -z0; + zn = 1.0; + for( i=1; i<n; i++ ) + { + nk1f = nk1f/(n-i); + kf = kf * i; + zn *= z; + t = nk1f * zn / kf; + s += t; + if( (MAXNUMF - fabsf(t)) < fabsf(s) ) + goto overf; + if( (tox > 1.0) && ((MAXNUMF/tox) < zmn) ) + goto overf; + zmn *= tox; + } + s *= 0.5; + t = fabsf(s); + if( (zmn > 1.0) && ((MAXNUMF/zmn) < t) ) + goto overf; + if( (t > 1.0) && ((MAXNUMF/t) < zmn) ) + goto overf; + ans = s * zmn; + } + } + + +tlg = 2.0 * logf( 0.5 * x ); +pk = -EUL; +if( n == 0 ) + { + pn = pk; + t = 1.0; + } +else + { + pn = pn + 1.0/n; + t = 1.0/fn; + } +s = (pk+pn-tlg)*t; +k = 1.0; +do + { + t *= z0 / (k * (k+n)); + pk += 1.0/k; + pn += 1.0/(k+n); + s += (pk+pn-tlg)*t; + k += 1.0; + } +while( fabsf(t/s) > MACHEPF ); + +s = 0.5 * s / zmn; +if( n & 1 ) + s = -s; +ans += s; + +return(ans); + + + +/* Asymptotic expansion for Kn(x) */ +/* Converges to 1.4e-17 for x > 18.4 */ + +asymp: + +if( x > MAXLOGF ) + { + mtherr( "knf", UNDERFLOW ); + return(0.0); + } +k = n; +pn = 4.0 * k * k; +pk = 1.0; +z0 = 8.0 * x; +fn = 1.0; +t = 1.0; +s = t; +nkf = MAXNUMF; +i = 0; +do + { + z = pn - pk * pk; + t = t * z /(fn * z0); + nk1f = fabsf(t); + if( (i >= n) && (nk1f > nkf) ) + { + goto adone; + } + nkf = nk1f; + s += t; + fn += 1.0; + pk += 2.0; + i += 1; + } +while( fabsf(t/s) > MACHEPF ); + +adone: +ans = expf(-x) * sqrtf( PIF/(2.0*x) ) * s; +return(ans); +} diff --git a/libm/float/log10f.c b/libm/float/log10f.c new file mode 100644 index 000000000..6cb2e4d87 --- /dev/null +++ b/libm/float/log10f.c @@ -0,0 +1,129 @@ +/* log10f.c + * + * Common logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, log10f(); + * + * y = log10f( x ); + * + * + * + * DESCRIPTION: + * + * Returns logarithm to the base 10 of x. + * + * The argument is separated into its exponent and fractional + * parts. The logarithm of the fraction is approximated by + * + * log(1+x) = x - 0.5 x**2 + x**3 P(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 100000 1.3e-7 3.4e-8 + * IEEE 0, MAXNUMF 100000 1.3e-7 2.6e-8 + * + * In the tests over the interval [0, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [-MAXL10, MAXL10]. + * + * ERROR MESSAGES: + * + * log10f singularity: x = 0; returns -MAXL10 + * log10f domain: x < 0; returns -MAXL10 + * MAXL10 = 38.230809449325611792 + */ + +/* +Cephes Math Library Release 2.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +static char fname[] = {"log10"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x)/Q(x) + * 1/sqrt(2) <= x < sqrt(2) + */ +static float P[] = { + 7.0376836292E-2, +-1.1514610310E-1, + 1.1676998740E-1, +-1.2420140846E-1, + 1.4249322787E-1, +-1.6668057665E-1, + 2.0000714765E-1, +-2.4999993993E-1, + 3.3333331174E-1 +}; + + +#define SQRTH 0.70710678118654752440 +#define L102A 3.0078125E-1 +#define L102B 2.48745663981195213739E-4 +#define L10EA 4.3359375E-1 +#define L10EB 7.00731903251827651129E-4 + +static float MAXL10 = 38.230809449325611792; + +float frexpf(float, int *), polevlf(float, float *, int); + +float log10f(float xx) +{ +float x, y, z; +int e; + +x = xx; +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + mtherr( fname, SING ); + else + mtherr( fname, DOMAIN ); + return( -MAXL10 ); + } + +/* separate mantissa from exponent */ + +x = frexpf( x, &e ); + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = 2.0*x - 1.0; + } +else + { + x = x - 1.0; + } + + +/* rational form */ +z = x*x; +y = x * ( z * polevlf( x, P, 8 ) ); +y = y - 0.5 * z; /* y - 0.5 * x**2 */ + +/* multiply log of fraction by log10(e) + * and base 2 exponent by log10(2) + */ +z = (x + y) * L10EB; /* accumulate terms in order of size */ +z += y * L10EA; +z += x * L10EA; +x = e; +z += x * L102B; +z += x * L102A; + + +return( z ); +} diff --git a/libm/float/log2f.c b/libm/float/log2f.c new file mode 100644 index 000000000..5cd5f4838 --- /dev/null +++ b/libm/float/log2f.c @@ -0,0 +1,129 @@ +/* log2f.c + * + * Base 2 logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, log2f(); + * + * y = log2f( 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 base e + * 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 exp(+-88) 100000 1.1e-7 2.4e-8 + * IEEE 0.5, 2.0 100000 1.1e-7 3.0e-8 + * + * In the tests over the interval [exp(+-88)], the logarithms + * of the random arguments were uniformly distributed. + * + * ERROR MESSAGES: + * + * log singularity: x = 0; returns MINLOGF/log(2) + * log domain: x < 0; returns MINLOGF/log(2) + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +static char fname[] = {"log2"}; + +/* Coefficients for log(1+x) = x - x**2/2 + x**3 P(x) + * 1/sqrt(2) <= x < sqrt(2) + */ + +static float P[] = { + 7.0376836292E-2, +-1.1514610310E-1, + 1.1676998740E-1, +-1.2420140846E-1, + 1.4249322787E-1, +-1.6668057665E-1, + 2.0000714765E-1, +-2.4999993993E-1, + 3.3333331174E-1 +}; + +#define LOG2EA 0.44269504088896340735992 +#define SQRTH 0.70710678118654752440 +extern float MINLOGF, LOGE2F; + +float frexpf(float, int *), polevlf(float, float *, int); + +float log2f(float xx) +{ +float x, y, z; +int e; + +x = xx; +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + mtherr( fname, SING ); + else + mtherr( fname, DOMAIN ); + return( MINLOGF/LOGE2F ); + } + +/* separate mantissa from exponent */ +x = frexpf( x, &e ); + + +/* logarithm using log(1+x) = x - .5x**2 + x**3 P(x)/Q(x) */ + +if( x < SQRTH ) + { + e -= 1; + x = 2.0*x - 1.0; + } +else + { + x = x - 1.0; + } + +z = x*x; +y = x * ( z * polevlf( x, P, 8 ) ); +y = y - 0.5 * z; /* y - 0.5 * x**2 */ + + +/* 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 += (float )e; +return( z ); +} diff --git a/libm/float/logf.c b/libm/float/logf.c new file mode 100644 index 000000000..750138564 --- /dev/null +++ b/libm/float/logf.c @@ -0,0 +1,128 @@ +/* logf.c + * + * Natural logarithm + * + * + * + * SYNOPSIS: + * + * float x, y, logf(); + * + * y = logf( 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) + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0.5, 2.0 100000 7.6e-8 2.7e-8 + * IEEE 1, MAXNUMF 100000 2.6e-8 + * + * In the tests over the interval [1, MAXNUM], the logarithms + * of the random arguments were uniformly distributed over + * [0, MAXLOGF]. + * + * ERROR MESSAGES: + * + * logf singularity: x = 0; returns MINLOG + * logf domain: x < 0; returns MINLOG + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision natural logarithm + * test interval: [sqrt(2)/2, sqrt(2)] + * trials: 10000 + * peak relative error: 7.1e-8 + * rms relative error: 2.7e-8 + */ + +#include <math.h> +extern float MINLOGF, SQRTHF; + + +float frexpf( float, int * ); + +float logf( float xx ) +{ +register float y; +float x, z, fe; +int e; + +x = xx; +fe = 0.0; +/* Test for domain */ +if( x <= 0.0 ) + { + if( x == 0.0 ) + mtherr( "logf", SING ); + else + mtherr( "logf", DOMAIN ); + return( MINLOGF ); + } + +x = frexpf( x, &e ); +if( x < SQRTHF ) + { + e -= 1; + x = x + x - 1.0; /* 2x - 1 */ + } +else + { + x = x - 1.0; + } +z = x * x; +/* 3.4e-9 */ +/* +p = logfcof; +y = *p++ * x; +for( i=0; i<8; i++ ) + { + y += *p++; + y *= x; + } +y *= z; +*/ + +y = +(((((((( 7.0376836292E-2 * x +- 1.1514610310E-1) * x ++ 1.1676998740E-1) * x +- 1.2420140846E-1) * x ++ 1.4249322787E-1) * x +- 1.6668057665E-1) * x ++ 2.0000714765E-1) * x +- 2.4999993993E-1) * x ++ 3.3333331174E-1) * x * z; + +if( e ) + { + fe = e; + y += -2.12194440e-4 * fe; + } + +y += -0.5 * z; /* y - 0.5 x^2 */ +z = x + y; /* ... + x */ + +if( e ) + z += 0.693359375 * fe; + +return( z ); +} diff --git a/libm/float/mtherr.c b/libm/float/mtherr.c new file mode 100644 index 000000000..d67dc042e --- /dev/null +++ b/libm/float/mtherr.c @@ -0,0 +1,99 @@ +/* mtherr.c + * + * Library common error handling routine + * + * + * + * SYNOPSIS: + * + * char *fctnam; + * int code; + * void mtherr(); + * + * mtherr( fctnam, code ); + * + * + * + * DESCRIPTION: + * + * This routine may be called to report one of the following + * error conditions (in the include file math.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: + * + * math.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 <math.h> + +/* Notice: the order of appearance of the following + * messages is bound to the error codes defined + * in math.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" +}; + + +void printf(); + +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 ); + /* exit(2); */ + +/* Display error message defined + * by the code argument. + */ +if( (code <= 0) || (code >= 6) ) + code = 0; +printf( "%s error\n", ermsg[code] ); + +/* Return to calling + * program + */ +return 0; +} diff --git a/libm/float/nantst.c b/libm/float/nantst.c new file mode 100644 index 000000000..7edd992ae --- /dev/null +++ b/libm/float/nantst.c @@ -0,0 +1,54 @@ +float inf = 1.0f/0.0f; +float nnn = 1.0f/0.0f - 1.0f/0.0f; +float fin = 1.0f; +float neg = -1.0f; +float nn2; + +int isnanf(), isfinitef(), signbitf(); + +void pvalue (char *str, float x) +{ +union + { + float f; + unsigned int i; + }u; + +printf("%s ", str); +u.f = x; +printf("%08x\n", u.i); +} + + +int +main() +{ + +if (!isnanf(nnn)) + abort(); +pvalue("nnn", nnn); +pvalue("inf", inf); +nn2 = inf - inf; +pvalue("inf - inf", nn2); +if (isnanf(fin)) + abort(); +if (isnanf(inf)) + abort(); +if (!isfinitef(fin)) + abort(); +if (isfinitef(nnn)) + abort(); +if (isfinitef(inf)) + abort(); +if (!signbitf(neg)) + abort(); +if (signbitf(fin)) + abort(); +if (signbitf(inf)) + abort(); +/* +if (signbitf(nnn)) + abort(); + */ +exit (0); +} diff --git a/libm/float/nbdtrf.c b/libm/float/nbdtrf.c new file mode 100644 index 000000000..e9b02753b --- /dev/null +++ b/libm/float/nbdtrf.c @@ -0,0 +1,141 @@ +/* nbdtrf.c + * + * Negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, nbdtrf(); + * + * y = nbdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.5e-4 1.9e-5 + * + */ + /* nbdtrcf.c + * + * Complemented negative binomial distribution + * + * + * + * SYNOPSIS: + * + * int k, n; + * float p, y, nbdtrcf(); + * + * y = nbdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 1.4e-4 2.0e-5 + * + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#ifdef ANSIC +float incbetf(float, float, float); +#else +float incbetf(); +#endif + + +float nbdtrcf( int k, int n, float pp ) +{ +float dk, dn, p; + +p = pp; +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtrf", DOMAIN ); + return( 0.0 ); + } + +dk = k+1; +dn = n; +return( incbetf( dk, dn, 1.0 - p ) ); +} + + + +float nbdtrf( int k, int n, float pp ) +{ +float dk, dn, p; + +p = pp; +if( (p < 0.0) || (p > 1.0) ) + goto domerr; +if( k < 0 ) + { +domerr: + mtherr( "nbdtrf", DOMAIN ); + return( 0.0 ); + } +dk = k+1; +dn = n; +return( incbetf( dn, dk, p ) ); +} diff --git a/libm/float/ndtrf.c b/libm/float/ndtrf.c new file mode 100644 index 000000000..c08d69eca --- /dev/null +++ b/libm/float/ndtrf.c @@ -0,0 +1,281 @@ +/* ndtrf.c + * + * Normal distribution function + * + * + * + * SYNOPSIS: + * + * float x, y, ndtrf(); + * + * y = ndtrf( 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 50000 1.5e-5 2.6e-6 + * + * + * ERROR MESSAGES: + * + * See erfcf(). + * + */ + /* erff.c + * + * Error function + * + * + * + * SYNOPSIS: + * + * float x, y, erff(); + * + * y = erff( x ); + * + * + * + * DESCRIPTION: + * + * The integral is + * + * x + * - + * 2 | | 2 + * erf(x) = -------- | exp( - t ) dt. + * sqrt(pi) | | + * - + * 0 + * + * The magnitude of x is limited to 9.231948545 for DEC + * arithmetic; 1 or -1 is returned outside this range. + * + * For 0 <= |x| < 1, erf(x) = x * P(x**2); otherwise + * erf(x) = 1 - erfc(x). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -9.3,9.3 50000 1.7e-7 2.8e-8 + * + */ + /* erfcf.c + * + * Complementary error function + * + * + * + * SYNOPSIS: + * + * float x, y, erfcf(); + * + * y = erfcf( 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 polynomial + * approximations 1/x P(1/x**2) are computed. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -9.3,9.3 50000 3.9e-6 7.2e-7 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * erfcf underflow x**2 > MAXLOGF 0.0 + * + * + */ + + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +extern float MAXLOGF, SQRTHF; + + +/* erfc(x) = exp(-x^2) P(1/x), 1 < x < 2 */ +static float P[] = { + 2.326819970068386E-002, +-1.387039388740657E-001, + 3.687424674597105E-001, +-5.824733027278666E-001, + 6.210004621745983E-001, +-4.944515323274145E-001, + 3.404879937665872E-001, +-2.741127028184656E-001, + 5.638259427386472E-001 +}; + +/* erfc(x) = exp(-x^2) 1/x P(1/x^2), 2 < x < 14 */ +static float R[] = { +-1.047766399936249E+001, + 1.297719955372516E+001, +-7.495518717768503E+000, + 2.921019019210786E+000, +-1.015265279202700E+000, + 4.218463358204948E-001, +-2.820767439740514E-001, + 5.641895067754075E-001 +}; + +/* erf(x) = x P(x^2), 0 < x < 1 */ +static float T[] = { + 7.853861353153693E-005, +-8.010193625184903E-004, + 5.188327685732524E-003, +-2.685381193529856E-002, + 1.128358514861418E-001, +-3.761262582423300E-001, + 1.128379165726710E+000 +}; + +/*#define UTHRESH 37.519379347*/ + +#define UTHRESH 14.0 + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float polevlf(float, float *, int); +float expf(float), logf(float), erff(float), erfcf(float); +#else +float polevlf(), expf(), logf(), erff(), erfcf(); +#endif + + + +float ndtrf(float aa) +{ +float x, y, z; + +x = aa; +x *= SQRTHF; +z = fabsf(x); + +if( z < SQRTHF ) + y = 0.5 + 0.5 * erff(x); +else + { + y = 0.5 * erfcf(z); + + if( x > 0 ) + y = 1.0 - y; + } + +return(y); +} + + +float erfcf(float aa) +{ +float a, p,q,x,y,z; + + +a = aa; +x = fabsf(a); + +if( x < 1.0 ) + return( 1.0 - erff(a) ); + +z = -a * a; + +if( z < -MAXLOGF ) + { +under: + mtherr( "erfcf", UNDERFLOW ); + if( a < 0 ) + return( 2.0 ); + else + return( 0.0 ); + } + +z = expf(z); +q = 1.0/x; +y = q * q; +if( x < 2.0 ) + { + p = polevlf( y, P, 8 ); + } +else + { + p = polevlf( y, R, 7 ); + } + +y = z * q * p; + +if( a < 0 ) + y = 2.0 - y; + +if( y == 0.0 ) + goto under; + +return(y); +} + + +float erff(float xx) +{ +float x, y, z; + +x = xx; +if( fabsf(x) > 1.0 ) + return( 1.0 - erfcf(x) ); + +z = x * x; +y = x * polevlf( z, T, 6 ); +return( y ); + +} diff --git a/libm/float/ndtrif.c b/libm/float/ndtrif.c new file mode 100644 index 000000000..3e33bc2c5 --- /dev/null +++ b/libm/float/ndtrif.c @@ -0,0 +1,186 @@ +/* ndtrif.c + * + * Inverse of Normal distribution function + * + * + * + * SYNOPSIS: + * + * float x, y, ndtrif(); + * + * x = ndtrif( 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.0 * log(y) ); then the approximation is + * x = z - log(z)/z - (1/z) P(1/z) / Q(1/z). + * There are two rational functions P/Q, one for 0 < y < exp(-32) + * and the other for y up to exp(-2). For larger arguments, + * w = y - 0.5, and x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1e-38, 1 30000 3.6e-7 5.0e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * ndtrif domain x <= 0 -MAXNUM + * ndtrif domain x >= 1 MAXNUM + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float MAXNUMF; + +/* sqrt(2pi) */ +static float s2pi = 2.50662827463100050242; + +/* approximation for 0 <= |y - 0.5| <= 3/8 */ +static float P0[5] = { +-5.99633501014107895267E1, + 9.80010754185999661536E1, +-5.66762857469070293439E1, + 1.39312609387279679503E1, +-1.23916583867381258016E0, +}; +static float Q0[8] = { +/* 1.00000000000000000000E0,*/ + 1.95448858338141759834E0, + 4.67627912898881538453E0, + 8.63602421390890590575E1, +-2.25462687854119370527E2, + 2.00260212380060660359E2, +-8.20372256168333339912E1, + 1.59056225126211695515E1, +-1.18331621121330003142E0, +}; + +/* Approximation for interval z = sqrt(-2 log y ) between 2 and 8 + * i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14. + */ +static float P1[9] = { + 4.05544892305962419923E0, + 3.15251094599893866154E1, + 5.71628192246421288162E1, + 4.40805073893200834700E1, + 1.46849561928858024014E1, + 2.18663306850790267539E0, +-1.40256079171354495875E-1, +-3.50424626827848203418E-2, +-8.57456785154685413611E-4, +}; +static float Q1[8] = { +/* 1.00000000000000000000E0,*/ + 1.57799883256466749731E1, + 4.53907635128879210584E1, + 4.13172038254672030440E1, + 1.50425385692907503408E1, + 2.50464946208309415979E0, +-1.42182922854787788574E-1, +-3.80806407691578277194E-2, +-9.33259480895457427372E-4, +}; + + +/* Approximation for interval z = sqrt(-2 log y ) between 8 and 64 + * i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890. + */ + +static float P2[9] = { + 3.23774891776946035970E0, + 6.91522889068984211695E0, + 3.93881025292474443415E0, + 1.33303460815807542389E0, + 2.01485389549179081538E-1, + 1.23716634817820021358E-2, + 3.01581553508235416007E-4, + 2.65806974686737550832E-6, + 6.23974539184983293730E-9, +}; +static float Q2[8] = { +/* 1.00000000000000000000E0,*/ + 6.02427039364742014255E0, + 3.67983563856160859403E0, + 1.37702099489081330271E0, + 2.16236993594496635890E-1, + 1.34204006088543189037E-2, + 3.28014464682127739104E-4, + 2.89247864745380683936E-6, + 6.79019408009981274425E-9, +}; + +#ifdef ANSIC +float polevlf(float, float *, int); +float p1evlf(float, float *, int); +float logf(float), sqrtf(float); +#else +float polevlf(), p1evlf(), logf(), sqrtf(); +#endif + + +float ndtrif(float yy0) +{ +float y0, x, y, z, y2, x0, x1; +int code; + +y0 = yy0; +if( y0 <= 0.0 ) + { + mtherr( "ndtrif", DOMAIN ); + return( -MAXNUMF ); + } +if( y0 >= 1.0 ) + { + mtherr( "ndtrif", DOMAIN ); + return( MAXNUMF ); + } +code = 1; +y = y0; +if( y > (1.0 - 0.13533528323661269189) ) /* 0.135... = exp(-2) */ + { + y = 1.0 - y; + code = 0; + } + +if( y > 0.13533528323661269189 ) + { + y = y - 0.5; + y2 = y * y; + x = y + y * (y2 * polevlf( y2, P0, 4)/p1evlf( y2, Q0, 8 )); + x = x * s2pi; + return(x); + } + +x = sqrtf( -2.0 * logf(y) ); +x0 = x - logf(x)/x; + +z = 1.0/x; +if( x < 8.0 ) /* y > exp(-32) = 1.2664165549e-14 */ + x1 = z * polevlf( z, P1, 8 )/p1evlf( z, Q1, 8 ); +else + x1 = z * polevlf( z, P2, 8 )/p1evlf( z, Q2, 8 ); +x = x0 - x1; +if( code != 0 ) + x = -x; +return( x ); +} diff --git a/libm/float/pdtrf.c b/libm/float/pdtrf.c new file mode 100644 index 000000000..17a05ee13 --- /dev/null +++ b/libm/float/pdtrf.c @@ -0,0 +1,188 @@ +/* pdtrf.c + * + * Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrf(); + * + * y = pdtrf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 6.9e-5 8.0e-6 + * + */ + /* pdtrcf() + * + * Complemented poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrcf(); + * + * y = pdtrcf( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 8.4e-5 1.2e-5 + * + */ + /* pdtrif() + * + * Inverse Poisson distribution + * + * + * + * SYNOPSIS: + * + * int k; + * float m, y, pdtrf(); + * + * m = pdtrif( 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,100 5000 8.7e-6 1.4e-6 + * + * ERROR MESSAGES: + * + * message condition value returned + * pdtri domain y < 0 or y >= 1 0.0 + * k < 0 + * + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +#ifdef ANSIC +float igamf(float, float), igamcf(float, float), igamif(float, float); +#else +float igamf(), igamcf(), igamif(); +#endif + + +float pdtrcf( int k, float mm ) +{ +float v, m; + +m = mm; +if( (k < 0) || (m <= 0.0) ) + { + mtherr( "pdtrcf", DOMAIN ); + return( 0.0 ); + } +v = k+1; +return( igamf( v, m ) ); +} + + + +float pdtrf( int k, float mm ) +{ +float v, m; + +m = mm; +if( (k < 0) || (m <= 0.0) ) + { + mtherr( "pdtr", DOMAIN ); + return( 0.0 ); + } +v = k+1; +return( igamcf( v, m ) ); +} + + +float pdtrif( int k, float yy ) +{ +float v, y; + +y = yy; +if( (k < 0) || (y < 0.0) || (y >= 1.0) ) + { + mtherr( "pdtrif", DOMAIN ); + return( 0.0 ); + } +v = k+1; +v = igamif( v, y ); +return( v ); +} diff --git a/libm/float/polevlf.c b/libm/float/polevlf.c new file mode 100644 index 000000000..7d7b4d0b7 --- /dev/null +++ b/libm/float/polevlf.c @@ -0,0 +1,99 @@ +/* polevlf.c + * p1evlf.c + * + * Evaluate polynomial + * + * + * + * SYNOPSIS: + * + * int N; + * float x, y, coef[N+1], polevlf[]; + * + * y = polevlf( 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 p1evl() assumes that coef[N] = 1.0 and is + * omitted from the array. Its calling arguments are + * otherwise the same as polevl(). + * + * + * 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.1: December, 1988 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +float polevlf( float xx, float *coef, int N ) +{ +float ans, x; +float *p; +int i; + +x = xx; +p = coef; +ans = *p++; + +/* +for( i=0; i<N; i++ ) + ans = ans * x + *p++; +*/ + +i = N; +do + ans = ans * x + *p++; +while( --i ); + +return( ans ); +} + +/* p1evl() */ +/* N + * Evaluate polynomial when coefficient of x is 1.0. + * Otherwise same as polevl. + */ + +float p1evlf( float xx, float *coef, int N ) +{ +float ans, x; +float *p; +int i; + +x = xx; +p = coef; +ans = x + *p++; +i = N-1; + +do + ans = ans * x + *p++; +while( --i ); + +return( ans ); +} diff --git a/libm/float/polynf.c b/libm/float/polynf.c new file mode 100644 index 000000000..48c6675d4 --- /dev/null +++ b/libm/float/polynf.c @@ -0,0 +1,520 @@ +/* polynf.c + * polyrf.c + * Arithmetic operations on polynomials + * + * In the following descriptions a, b, c are polynomials of degree + * na, nb, nc respectively. The degree of a polynomial cannot + * exceed a run-time value MAXPOLF. An operation that attempts + * to use or generate a polynomial of higher degree may produce a + * result that suffers truncation at degree MAXPOL. The value of + * MAXPOL is set by calling the function + * + * polinif( maxpol ); + * + * where maxpol is the desired maximum degree. This must be + * done prior to calling any of the other functions in this module. + * Memory for internal temporary polynomial storage is allocated + * by polinif(). + * + * Each polynomial is represented by an array containing its + * coefficients, together with a separately declared integer equal + * to the degree of the polynomial. The coefficients appear in + * ascending order; that is, + * + * 2 na + * a(x) = a[0] + a[1] * x + a[2] * x + ... + a[na] * x . + * + * + * + * sum = poleva( a, na, x ); Evaluate polynomial a(t) at t = x. + * polprtf( a, na, D ); Print the coefficients of a to D digits. + * polclrf( a, na ); Set a identically equal to zero, up to a[na]. + * polmovf( a, na, b ); Set b = a. + * poladdf( a, na, b, nb, c ); c = b + a, nc = max(na,nb) + * polsubf( a, na, b, nb, c ); c = b - a, nc = max(na,nb) + * polmulf( a, na, b, nb, c ); c = b * a, nc = na+nb + * + * + * Division: + * + * i = poldivf( a, na, b, nb, c ); c = b / a, nc = MAXPOL + * + * returns i = the degree of the first nonzero coefficient of a. + * The computed quotient c must be divided by x^i. An error message + * is printed if a is identically zero. + * + * + * Change of variables: + * If a and b are polynomials, and t = a(x), then + * c(t) = b(a(x)) + * is a polynomial found by substituting a(x) for t. The + * subroutine call for this is + * + * polsbtf( a, na, b, nb, c ); + * + * + * Notes: + * poldivf() is an integer routine; polevaf() is float. + * Any of the arguments a, b, c may refer to the same array. + * + */ + +#ifndef NULL +#define NULL 0 +#endif +#include <math.h> + +#ifdef ANSIC +void printf(), sprintf(), exit(); +void free(void *); +void *malloc(int); +#else +void printf(), sprintf(), free(), exit(); +void *malloc(); +#endif +/* near pointer version of malloc() */ +/*#define malloc _nmalloc*/ +/*#define free _nfree*/ + +/* Pointers to internal arrays. Note poldiv() allocates + * and deallocates some temporary arrays every time it is called. + */ +static float *pt1 = 0; +static float *pt2 = 0; +static float *pt3 = 0; + +/* Maximum degree of polynomial. */ +int MAXPOLF = 0; +extern int MAXPOLF; + +/* Number of bytes (chars) in maximum size polynomial. */ +static int psize = 0; + + +/* Initialize max degree of polynomials + * and allocate temporary storage. + */ +#ifdef ANSIC +void polinif( int maxdeg ) +#else +int polinif( maxdeg ) +int maxdeg; +#endif +{ + +MAXPOLF = maxdeg; +psize = (maxdeg + 1) * sizeof(float); + +/* Release previously allocated memory, if any. */ +if( pt3 ) + free(pt3); +if( pt2 ) + free(pt2); +if( pt1 ) + free(pt1); + +/* Allocate new arrays */ +pt1 = (float * )malloc(psize); /* used by polsbtf */ +pt2 = (float * )malloc(psize); /* used by polsbtf */ +pt3 = (float * )malloc(psize); /* used by polmul */ + +/* Report if failure */ +if( (pt1 == NULL) || (pt2 == NULL) || (pt3 == NULL) ) + { + mtherr( "polinif", ERANGE ); + exit(1); + } +#if !ANSIC +return 0; +#endif +} + + + +/* Print the coefficients of a, with d decimal precision. + */ +static char *form = "abcdefghijk"; + +#ifdef ANSIC +void polprtf( float *a, int na, int d ) +#else +int polprtf( a, na, d ) +float a[]; +int na, d; +#endif +{ +int i, j, d1; +char *p; + +/* Create format descriptor string for the printout. + * Do this partly by hand, since sprintf() may be too + * bug-ridden to accomplish this feat by itself. + */ +p = form; +*p++ = '%'; +d1 = d + 8; +(void )sprintf( p, "%d ", d1 ); +p += 1; +if( d1 >= 10 ) + p += 1; +*p++ = '.'; +(void )sprintf( p, "%d ", d ); +p += 1; +if( d >= 10 ) + p += 1; +*p++ = 'e'; +*p++ = ' '; +*p++ = '\0'; + + +/* Now do the printing. + */ +d1 += 1; +j = 0; +for( i=0; i<=na; i++ ) + { +/* Detect end of available line */ + j += d1; + if( j >= 78 ) + { + printf( "\n" ); + j = d1; + } + printf( form, a[i] ); + } +printf( "\n" ); +#if !ANSIC +return 0; +#endif +} + + + +/* Set a = 0. + */ +#ifdef ANSIC +void polclrf( register float *a, int n ) +#else +int polclrf( a, n ) +register float *a; +int n; +#endif +{ +int i; + +if( n > MAXPOLF ) + n = MAXPOLF; +for( i=0; i<=n; i++ ) + *a++ = 0.0; +#if !ANSIC +return 0; +#endif +} + + + +/* Set b = a. + */ +#ifdef ANSIC +void polmovf( register float *a, int na, register float *b ) +#else +int polmovf( a, na, b ) +register float *a, *b; +int na; +#endif +{ +int i; + +if( na > MAXPOLF ) + na = MAXPOLF; + +for( i=0; i<= na; i++ ) + { + *b++ = *a++; + } +#if !ANSIC +return 0; +#endif +} + + +/* c = b * a. + */ +#ifdef ANSIC +void polmulf( float a[], int na, float b[], int nb, float c[] ) +#else +int polmulf( a, na, b, nb, c ) +float a[], b[], c[]; +int na, nb; +#endif +{ +int i, j, k, nc; +float x; + +nc = na + nb; +polclrf( pt3, MAXPOLF ); + +for( i=0; i<=na; i++ ) + { + x = a[i]; + for( j=0; j<=nb; j++ ) + { + k = i + j; + if( k > MAXPOLF ) + break; + pt3[k] += x * b[j]; + } + } + +if( nc > MAXPOLF ) + nc = MAXPOLF; +for( i=0; i<=nc; i++ ) + c[i] = pt3[i]; +#if !ANSIC +return 0; +#endif +} + + + + +/* c = b + a. + */ +#ifdef ANSIC +void poladdf( float a[], int na, float b[], int nb, float c[] ) +#else +int poladdf( a, na, b, nb, c ) +float a[], b[], c[]; +int na, nb; +#endif +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOLF ) + n = MAXPOLF; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + c[i] = b[i]; + else if( i > nb ) + c[i] = a[i]; + else + c[i] = b[i] + a[i]; + } +#if !ANSIC +return 0; +#endif +} + +/* c = b - a. + */ +#ifdef ANSIC +void polsubf( float a[], int na, float b[], int nb, float c[] ) +#else +int polsubf( a, na, b, nb, c ) +float a[], b[], c[]; +int na, nb; +#endif +{ +int i, n; + + +if( na > nb ) + n = na; +else + n = nb; + +if( n > MAXPOLF ) + n = MAXPOLF; + +for( i=0; i<=n; i++ ) + { + if( i > na ) + c[i] = b[i]; + else if( i > nb ) + c[i] = -a[i]; + else + c[i] = b[i] - a[i]; + } +#if !ANSIC +return 0; +#endif +} + + + +/* c = b/a + */ +#ifdef ANSIC +int poldivf( float a[], int na, float b[], int nb, float c[] ) +#else +int poldivf( a, na, b, nb, c ) +float a[], b[], c[]; +int na, nb; +#endif +{ +float quot; +float *ta, *tb, *tq; +int i, j, k, sing; + +sing = 0; + +/* Allocate temporary arrays. This would be quicker + * if done automatically on the stack, but stack space + * may be hard to obtain on a small computer. + */ +ta = (float * )malloc( psize ); +polclrf( ta, MAXPOLF ); +polmovf( a, na, ta ); + +tb = (float * )malloc( psize ); +polclrf( tb, MAXPOLF ); +polmovf( b, nb, tb ); + +tq = (float * )malloc( psize ); +polclrf( tq, MAXPOLF ); + +/* What to do if leading (constant) coefficient + * of denominator is zero. + */ +if( a[0] == 0.0 ) + { + for( i=0; i<=na; i++ ) + { + if( ta[i] != 0.0 ) + goto nzero; + } + mtherr( "poldivf", SING ); + goto done; + +nzero: +/* Reduce the degree of the denominator. */ + for( i=0; i<na; i++ ) + ta[i] = ta[i+1]; + ta[na] = 0.0; + + if( b[0] != 0.0 ) + { +/* Optional message: + printf( "poldivf singularity, divide quotient by x\n" ); +*/ + sing += 1; + } + else + { +/* Reduce degree of numerator. */ + for( i=0; i<nb; i++ ) + tb[i] = tb[i+1]; + tb[nb] = 0.0; + } +/* Call self, using reduced polynomials. */ + sing += poldivf( ta, na, tb, nb, c ); + goto done; + } + +/* Long division algorithm. ta[0] is nonzero. + */ +for( i=0; i<=MAXPOLF; i++ ) + { + quot = tb[i]/ta[0]; + for( j=0; j<=MAXPOLF; j++ ) + { + k = j + i; + if( k > MAXPOLF ) + break; + tb[k] -= quot * ta[j]; + } + tq[i] = quot; + } +/* Send quotient to output array. */ +polmovf( tq, MAXPOLF, c ); + +done: + +/* Restore allocated memory. */ +free(tq); +free(tb); +free(ta); +return( sing ); +} + + + + +/* Change of variables + * Substitute a(y) for the variable x in b(x). + * x = a(y) + * c(x) = b(x) = b(a(y)). + */ + +#ifdef ANSIC +void polsbtf( float a[], int na, float b[], int nb, float c[] ) +#else +int polsbtf( a, na, b, nb, c ) +float a[], b[], c[]; +int na, nb; +#endif +{ +int i, j, k, n2; +float x; + +/* 0th degree term: + */ +polclrf( pt1, MAXPOLF ); +pt1[0] = b[0]; + +polclrf( pt2, MAXPOLF ); +pt2[0] = 1.0; +n2 = 0; + +for( i=1; i<=nb; i++ ) + { +/* Form ith power of a. */ + polmulf( a, na, pt2, n2, pt2 ); + n2 += na; + x = b[i]; +/* Add the ith coefficient of b times the ith power of a. */ + for( j=0; j<=n2; j++ ) + { + if( j > MAXPOLF ) + break; + pt1[j] += x * pt2[j]; + } + } + +k = n2 + nb; +if( k > MAXPOLF ) + k = MAXPOLF; +for( i=0; i<=k; i++ ) + c[i] = pt1[i]; +#if !ANSIC +return 0; +#endif +} + + + + +/* Evaluate polynomial a(t) at t = x. + */ +float polevaf( float *a, int na, float xx ) +{ +float x, s; +int i; + +x = xx; +s = a[na]; +for( i=na-1; i>=0; i-- ) + { + s = s * x + a[i]; + } +return(s); +} + diff --git a/libm/float/powf.c b/libm/float/powf.c new file mode 100644 index 000000000..367a39ad4 --- /dev/null +++ b/libm/float/powf.c @@ -0,0 +1,338 @@ +/* powf.c + * + * Power function + * + * + * + * SYNOPSIS: + * + * float x, y, z, powf(); + * + * z = powf( 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/16 and pseudo extended precision arithmetic to + * obtain an extra three bits of accuracy in both the logarithm + * and the exponential. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -10,10 100,000 1.4e-7 3.6e-8 + * 1/10 < x < 10, x uniformly distributed. + * -10 < y < 10, y uniformly distributed. + * + * + * ERROR MESSAGES: + * + * message condition value returned + * powf overflow x**y > MAXNUMF MAXNUMF + * powf underflow x**y < 1/MAXNUMF 0.0 + * powf domain x<0 and y noninteger 0.0 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> +static char fname[] = {"powf"}; + + +/* 2^(-i/16) + * The decimal values are rounded to 24-bit precision + */ +static float A[] = { + 1.00000000000000000000E0, + 9.57603275775909423828125E-1, + 9.17004048824310302734375E-1, + 8.78126084804534912109375E-1, + 8.40896427631378173828125E-1, + 8.05245161056518554687500E-1, + 7.71105408668518066406250E-1, + 7.38413095474243164062500E-1, + 7.07106769084930419921875E-1, + 6.77127778530120849609375E-1, + 6.48419797420501708984375E-1, + 6.20928883552551269531250E-1, + 5.94603538513183593750000E-1, + 5.69394290447235107421875E-1, + 5.45253872871398925781250E-1, + 5.22136867046356201171875E-1, + 5.00000000000000000000E-1 +}; +/* continuation, for even i only + * 2^(i/16) = A[i] + B[i/2] + */ +static float B[] = { + 0.00000000000000000000E0, +-5.61963907099083340520586E-9, +-1.23776636307969995237668E-8, + 4.03545234539989593104537E-9, + 1.21016171044789693621048E-8, +-2.00949968760174979411038E-8, + 1.89881769396087499852802E-8, +-6.53877009617774467211965E-9, + 0.00000000000000000000E0 +}; + +/* 1 / A[i] + * The decimal values are full precision + */ +static float Ainv[] = { + 1.00000000000000000000000E0, + 1.04427378242741384032197E0, + 1.09050773266525765920701E0, + 1.13878863475669165370383E0, + 1.18920711500272106671750E0, + 1.24185781207348404859368E0, + 1.29683955465100966593375E0, + 1.35425554693689272829801E0, + 1.41421356237309504880169E0, + 1.47682614593949931138691E0, + 1.54221082540794082361229E0, + 1.61049033194925430817952E0, + 1.68179283050742908606225E0, + 1.75625216037329948311216E0, + 1.83400808640934246348708E0, + 1.91520656139714729387261E0, + 2.00000000000000000000000E0 +}; + +#ifdef DEC +#define MEXP 2032.0 +#define MNEXP -2032.0 +#else +#define MEXP 2048.0 +#define MNEXP -2400.0 +#endif + +/* log2(e) - 1 */ +#define LOG2EA 0.44269504088896340736F +extern float MAXNUMF; + +#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 + + +#ifdef ANSIC +float floorf( float ); +float frexpf( float, int *); +float ldexpf( float, int ); +float powif( float, int ); +#else +float floorf(), frexpf(), ldexpf(), powif(); +#endif + +/* Find a multiple of 1/16 that is within 1/16 of x. */ +#define reduc(x) 0.0625 * floorf( 16 * (x) ) + +#ifdef ANSIC +float powf( float x, float y ) +#else +float powf( x, y ) +float x, y; +#endif +{ +float u, w, z, W, Wa, Wb, ya, yb; +/* float F, Fa, Fb, G, Ga, Gb, H, Ha, Hb */ +int e, i, nflg; + + +nflg = 0; /* flag = 1 if x<0 raised to integer power */ +w = floorf(y); +if( w < 0 ) + z = -w; +else + z = w; +if( (w == y) && (z < 32768.0) ) + { + i = w; + w = powif( x, i ); + return( w ); + } + + +if( x <= 0.0F ) + { + if( x == 0.0 ) + { + if( y == 0.0 ) + return( 1.0 ); /* 0**0 */ + else + return( 0.0 ); /* 0**y */ + } + else + { + if( w != y ) + { /* noninteger power of negative number */ + mtherr( fname, DOMAIN ); + return(0.0); + } + nflg = 1; + if( x < 0 ) + x = -x; + } + } + +/* separate significand from exponent */ +x = frexpf( x, &e ); + +/* find significand in antilog table A[] */ +i = 1; +if( x <= A[9] ) + i = 9; +if( x <= A[i+4] ) + i += 4; +if( x <= A[i+2] ) + i += 2; +if( x >= A[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 -= A[i]; +x -= B[ i >> 1 ]; +x *= Ainv[i]; + + +/* rational approximation for log(1+v): + * + * log(1+v) = v - 0.5 v^2 + v^3 P(v) + * Theoretical relative error of the approximation is 3.5e-11 + * on the interval 2^(1/16) - 1 > v > 2^(-1/16) - 1 + */ +z = x*x; +w = (((-0.1663883081054895 * x + + 0.2003770364206271) * x + - 0.2500006373383951) * x + + 0.3333331095506474) * x * z; +w -= 0.5 * z; + +/* Convert to base 2 logarithm: + * multiply by log2(e) + */ +w = w + LOG2EA * w; +/* Note x was not yet added in + * to above rational approximation, + * so do it now, while multiplying + * by log2(e). + */ +z = w + LOG2EA * x; +z = z + x; + +/* Compute exponent term of the base 2 logarithm. */ +w = -i; +w *= 0.0625; /* divide by 16 */ +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/16 + */ +ya = reduc(y); +yb = y - ya; + + +F = z * y + w * yb; +Fa = reduc(F); +Fb = F - Fa; + +G = Fa + w * ya; +Ga = reduc(G); +Gb = G - Ga; + +H = Fb + Gb; +Ha = reduc(H); +w = 16 * (Ga + Ha); + +/* Test the power of 2 for overflow */ +if( w > MEXP ) + { + mtherr( fname, OVERFLOW ); + return( MAXNUMF ); + } + +if( w < MNEXP ) + { + mtherr( fname, UNDERFLOW ); + return( 0.0 ); + } + +e = w; +Hb = H - Ha; + +if( Hb > 0.0 ) + { + e += 1; + Hb -= 0.0625; + } + +/* Now the product y * log2(x) = Hb + e/16.0. + * + * Compute base 2 exponential of Hb, + * where -0.0625 <= Hb <= 0. + * Theoretical relative error of the approximation is 2.8e-12. + */ +/* z = 2**Hb - 1 */ +z = ((( 9.416993633606397E-003 * Hb + + 5.549356188719141E-002) * Hb + + 2.402262883964191E-001) * Hb + + 6.931471791490764E-001) * Hb; + +/* Express e/16 as an integer plus a negative number of 16ths. + * Find lookup table entry for the fractional power of 2. + */ +if( e < 0 ) + i = -( -e >> 4 ); +else + i = (e >> 4) + 1; +e = (i << 4) - e; +w = A[e]; +z = w + w * z; /* 2**-e * ( 1 + (2**Hb-1) ) */ +z = ldexpf( z, i ); /* multiply by integer power of 2 */ + +if( nflg ) + { +/* For negative x, + * find out if the integer exponent + * is odd or even. + */ + w = 2 * floorf( (float) 0.5 * w ); + if( w != y ) + z = -z; /* odd exponent */ + } + +return( z ); +} diff --git a/libm/float/powif.c b/libm/float/powif.c new file mode 100644 index 000000000..d226896ba --- /dev/null +++ b/libm/float/powif.c @@ -0,0 +1,156 @@ +/* powif.c + * + * Real raised to integer power + * + * + * + * SYNOPSIS: + * + * float x, y, powif(); + * int n; + * + * y = powif( 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 .04,26 -26,26 100000 1.1e-6 2.0e-7 + * IEEE 1,2 -128,128 100000 1.1e-5 1.0e-6 + * + * Returns MAXNUMF on overflow, zero on underflow. + * + */ + +/* powi.c */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float MAXNUMF, MAXLOGF, MINLOGF, LOGE2F; + +float frexpf( float, int * ); + +float powif( float x, int nn ) +{ +int n, e, sign, asign, lx; +float w, y, s; + +if( x == 0.0 ) + { + if( nn == 0 ) + return( 1.0 ); + else if( nn < 0 ) + return( MAXNUMF ); + else + return( 0.0 ); + } + +if( nn == 0 ) + return( 1.0 ); + + +if( x < 0.0 ) + { + asign = -1; + x = -x; + } +else + asign = 0; + + +if( nn < 0 ) + { + sign = -1; + n = -nn; +/* + x = 1.0/x; +*/ + } +else + { + sign = 0; + n = nn; + } + +/* Overflow detection */ + +/* Calculate approximate logarithm of answer */ +s = frexpf( x, &lx ); +e = (lx - 1)*n; +if( (e == 0) || (e > 64) || (e < -64) ) + { + s = (s - 7.0710678118654752e-1) / (s + 7.0710678118654752e-1); + s = (2.9142135623730950 * s - 0.5 + lx) * nn * LOGE2F; + } +else + { + s = LOGE2F * e; + } + +if( s > MAXLOGF ) + { + mtherr( "powi", OVERFLOW ); + y = MAXNUMF; + goto done; + } + +if( s < MINLOGF ) + return(0.0); + +/* 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 < (-MAXLOGF+2.0) ) + { + x = 1.0/x; + sign = 0; + } + +/* First bit of the power */ +if( n & 1 ) + y = x; + +else + { + y = 1.0; + 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 ) + y = 1.0/y; +return(y); +} diff --git a/libm/float/powtst.c b/libm/float/powtst.c new file mode 100644 index 000000000..ff4845de2 --- /dev/null +++ b/libm/float/powtst.c @@ -0,0 +1,41 @@ +#include <stdio.h> +#include <math.h> +extern float MAXNUMF, MAXLOGF, MINLOGF; + +int +main() +{ +float exp1, minnum, x, y, z, e; +exp1 = expf(1.0F); + +minnum = powif(2.0F,-149); + +x = exp1; +y = MINLOGF + logf(0.501); +/*y = MINLOGF - 0.405;*/ +z = powf(x,y); +e = (z - minnum) / minnum; +printf("%.16e %.16e\n", z, e); + +x = exp1; +y = MAXLOGF; +z = powf(x,y); +e = (z - MAXNUMF) / MAXNUMF; +printf("%.16e %.16e\n", z, e); + +x = MAXNUMF; +y = 1.0F/MAXLOGF; +z = powf(x,y); +e = (z - exp1) / exp1; +printf("%.16e %.16e\n", z, e); + + +x = exp1; +y = MINLOGF; +z = powf(x,y); +e = (z - minnum) / minnum; +printf("%.16e %.16e\n", z, e); + + +exit(0); +} diff --git a/libm/float/psif.c b/libm/float/psif.c new file mode 100644 index 000000000..2d9187c67 --- /dev/null +++ b/libm/float/psif.c @@ -0,0 +1,153 @@ +/* psif.c + * + * Psi (digamma) function + * + * + * SYNOPSIS: + * + * float x, y, psif(); + * + * y = psif( x ); + * + * + * DESCRIPTION: + * + * d - + * psi(x) = -- ln | (x) + * dx + * + * is the logarithmic derivative of the gamma function. + * For integer x, + * n-1 + * - + * psi(n) = -EUL + > 1/k. + * - + * k=1 + * + * This formula is used for 0 < n <= 10. If x is negative, it + * is transformed to a positive argument by the reflection + * formula psi(1-x) = psi(x) + pi cot(pi x). + * For general positive x, the argument is made greater than 10 + * using the recurrence psi(x+1) = psi(x) + 1/x. + * Then the following asymptotic expansion is applied: + * + * inf. B + * - 2k + * psi(x) = log(x) - 1/2x - > ------- + * - 2k + * k=1 2k x + * + * where the B2k are Bernoulli numbers. + * + * ACCURACY: + * Absolute error, relative when |psi| > 1 : + * arithmetic domain # trials peak rms + * IEEE -33,0 30000 8.2e-7 1.2e-7 + * IEEE 0,33 100000 7.3e-7 7.7e-8 + * + * ERROR MESSAGES: + * message condition value returned + * psi singularity x integer <=0 MAXNUMF + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + + +static float A[] = { +-4.16666666666666666667E-3, + 3.96825396825396825397E-3, +-8.33333333333333333333E-3, + 8.33333333333333333333E-2 +}; + + +#define EUL 0.57721566490153286061 + +extern float PIF, MAXNUMF; + + + +float floorf(float), logf(float), tanf(float); +float polevlf(float, float *, int); + +float psif(float xx) +{ +float p, q, nz, x, s, w, y, z; +int i, n, negative; + + +x = xx; +nz = 0.0; +negative = 0; +if( x <= 0.0 ) + { + negative = 1; + q = x; + p = floorf(q); + if( p == q ) + { + mtherr( "psif", SING ); + return( MAXNUMF ); + } + nz = q - p; + if( nz != 0.5 ) + { + if( nz > 0.5 ) + { + p += 1.0; + nz = q - p; + } + nz = PIF/tanf(PIF*nz); + } + else + { + nz = 0.0; + } + x = 1.0 - x; + } + +/* check for positive integer up to 10 */ +if( (x <= 10.0) && (x == floorf(x)) ) + { + y = 0.0; + n = x; + for( i=1; i<n; i++ ) + { + w = i; + y += 1.0/w; + } + y -= EUL; + goto done; + } + +s = x; +w = 0.0; +while( s < 10.0 ) + { + w += 1.0/s; + s += 1.0; + } + +if( s < 1.0e8 ) + { + z = 1.0/(s * s); + y = z * polevlf( z, A, 3 ); + } +else + y = 0.0; + +y = logf(s) - (0.5/s) - y - w; + +done: +if( negative ) + { + y -= nz; + } +return(y); +} diff --git a/libm/float/rgammaf.c b/libm/float/rgammaf.c new file mode 100644 index 000000000..5afa25e91 --- /dev/null +++ b/libm/float/rgammaf.c @@ -0,0 +1,130 @@ +/* rgammaf.c + * + * Reciprocal gamma function + * + * + * + * SYNOPSIS: + * + * float x, y, rgammaf(); + * + * y = rgammaf( x ); + * + * + * + * DESCRIPTION: + * + * Returns one divided by the gamma function of the argument. + * + * The function is approximated by a Chebyshev expansion in + * the interval [0,1]. Range reduction is by recurrence + * for arguments between -34.034 and +34.84425627277176174. + * 1/MAXNUMF is returned for positive arguments outside this + * range. + * + * The reciprocal gamma function has no singularities, + * but overflow and underflow may occur for large arguments. + * These conditions return either MAXNUMF or 1/MAXNUMF with + * appropriate sign. + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -34,+34 100000 8.9e-7 1.1e-7 + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1985, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +/* Chebyshev coefficients for reciprocal gamma function + * in interval 0 to 1. Function is 1/(x gamma(x)) - 1 + */ + +static float R[] = { + 1.08965386454418662084E-9, +-3.33964630686836942556E-8, + 2.68975996440595483619E-7, + 2.96001177518801696639E-6, +-8.04814124978471142852E-5, + 4.16609138709688864714E-4, + 5.06579864028608725080E-3, +-6.41925436109158228810E-2, +-4.98558728684003594785E-3, + 1.27546015610523951063E-1 +}; + + +static char name[] = "rgammaf"; + +extern float PIF, MAXLOGF, MAXNUMF; + + + +float chbevlf(float, float *, int); +float expf(float), logf(float), sinf(float), lgamf(float); + +float rgammaf(float xx) +{ +float x, w, y, z; +int sign; + +x = xx; +if( x > 34.84425627277176174) + { + mtherr( name, UNDERFLOW ); + return(1.0/MAXNUMF); + } +if( x < -34.034 ) + { + w = -x; + z = sinf( PIF*w ); + if( z == 0.0 ) + return(0.0); + if( z < 0.0 ) + { + sign = 1; + z = -z; + } + else + sign = -1; + + y = logf( w * z / PIF ) + lgamf(w); + if( y < -MAXLOGF ) + { + mtherr( name, UNDERFLOW ); + return( sign * 1.0 / MAXNUMF ); + } + if( y > MAXLOGF ) + { + mtherr( name, OVERFLOW ); + return( sign * MAXNUMF ); + } + return( sign * expf(y)); + } +z = 1.0; +w = x; + +while( w > 1.0 ) /* Downward recurrence */ + { + w -= 1.0; + z *= w; + } +while( w < 0.0 ) /* Upward recurrence */ + { + z /= w; + w += 1.0; + } +if( w == 0.0 ) /* Nonpositive integer */ + return(0.0); +if( w == 1.0 ) /* Other integer */ + return( 1.0/z ); + +y = w * ( 1.0 + chbevlf( 4.0*w-2.0, R, 10 ) ) / z; +return(y); +} diff --git a/libm/float/setprec.c b/libm/float/setprec.c new file mode 100644 index 000000000..a5222ae73 --- /dev/null +++ b/libm/float/setprec.c @@ -0,0 +1,10 @@ +/* Null stubs for coprocessor precision settings */ + +int +sprec() {return 0; } + +int +dprec() {return 0; } + +int +ldprec() {return 0; } diff --git a/libm/float/shichif.c b/libm/float/shichif.c new file mode 100644 index 000000000..ae98021a9 --- /dev/null +++ b/libm/float/shichif.c @@ -0,0 +1,212 @@ +/* shichif.c + * + * Hyperbolic sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * float x, Chi, Shi; + * + * shichi( x, &Chi, &Shi ); + * + * + * DESCRIPTION: + * + * Approximates the integrals + * + * x + * - + * | | cosh t - 1 + * Chi(x) = eul + ln x + | ----------- dt, + * | | t + * - + * 0 + * + * x + * - + * | | sinh t + * Shi(x) = | ------ dt + * | | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are evaluated by power series for x < 8 + * and by Chebyshev expansions for x between 8 and 88. + * For large x, both functions approach exp(x)/2x. + * Arguments greater than 88 in magnitude return MAXNUM. + * + * + * ACCURACY: + * + * Test interval 0 to 88. + * Relative error: + * arithmetic function # trials peak rms + * IEEE Shi 20000 3.5e-7 7.0e-8 + * Absolute error, except relative when |Chi| > 1: + * IEEE Chi 20000 3.8e-7 7.6e-8 + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +#include <math.h> + +/* x exp(-x) shi(x), inverted interval 8 to 18 */ +static float S1[] = { +-3.56699611114982536845E-8, + 1.44818877384267342057E-7, + 7.82018215184051295296E-7, +-5.39919118403805073710E-6, +-3.12458202168959833422E-5, + 8.90136741950727517826E-5, + 2.02558474743846862168E-3, + 2.96064440855633256972E-2, + 1.11847751047257036625E0 +}; + +/* x exp(-x) shi(x), inverted interval 18 to 88 */ +static float S2[] = { + 1.69050228879421288846E-8, + 1.25391771228487041649E-7, + 1.16229947068677338732E-6, + 1.61038260117376323993E-5, + 3.49810375601053973070E-4, + 1.28478065259647610779E-2, + 1.03665722588798326712E0 +}; + + +/* x exp(-x) chin(x), inverted interval 8 to 18 */ +static float C1[] = { + 1.31458150989474594064E-8, +-4.75513930924765465590E-8, +-2.21775018801848880741E-7, + 1.94635531373272490962E-6, + 4.33505889257316408893E-6, +-6.13387001076494349496E-5, +-3.13085477492997465138E-4, + 4.97164789823116062801E-4, + 2.64347496031374526641E-2, + 1.11446150876699213025E0 +}; + +/* x exp(-x) chin(x), inverted interval 18 to 88 */ +static float C2[] = { +-3.00095178028681682282E-9, + 7.79387474390914922337E-8, + 1.06942765566401507066E-6, + 1.59503164802313196374E-5, + 3.49592575153777996871E-4, + 1.28475387530065247392E-2, + 1.03665693917934275131E0 +}; + + + +/* Sine and cosine integrals */ + +#define EUL 0.57721566490153286061 +extern float MACHEPF, MAXNUMF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float logf(float ), expf(float), chbevlf(float, float *, int); +#else +float logf(), expf(), chbevlf(); +#endif + + + +int shichif( float xx, float *si, float *ci ) +{ +float x, k, z, c, s, a; +short sign; + +x = xx; +if( x < 0.0 ) + { + sign = -1; + x = -x; + } +else + sign = 0; + + +if( x == 0.0 ) + { + *si = 0.0; + *ci = -MAXNUMF; + return( 0 ); + } + +if( x >= 8.0 ) + goto chb; + +z = x * x; + +/* Direct power series expansion */ + +a = 1.0; +s = 1.0; +c = 0.0; +k = 2.0; + +do + { + a *= z/k; + c += a/k; + k += 1.0; + a /= k; + s += a/k; + k += 1.0; + } +while( fabsf(a/s) > MACHEPF ); + +s *= x; +goto done; + + +chb: + +if( x < 18.0 ) + { + a = (576.0/x - 52.0)/10.0; + k = expf(x) / x; + s = k * chbevlf( a, S1, 9 ); + c = k * chbevlf( a, C1, 10 ); + goto done; + } + +if( x <= 88.0 ) + { + a = (6336.0/x - 212.0)/70.0; + k = expf(x) / x; + s = k * chbevlf( a, S2, 7 ); + c = k * chbevlf( a, C2, 7 ); + goto done; + } +else + { + if( sign ) + *si = -MAXNUMF; + else + *si = MAXNUMF; + *ci = MAXNUMF; + return(0); + } +done: +if( sign ) + s = -s; + +*si = s; + +*ci = EUL + logf(x) + c; +return(0); +} diff --git a/libm/float/sicif.c b/libm/float/sicif.c new file mode 100644 index 000000000..04633ee68 --- /dev/null +++ b/libm/float/sicif.c @@ -0,0 +1,279 @@ +/* sicif.c + * + * Sine and cosine integrals + * + * + * + * SYNOPSIS: + * + * float x, Ci, Si; + * + * sicif( x, &Si, &Ci ); + * + * + * DESCRIPTION: + * + * Evaluates the integrals + * + * x + * - + * | cos t - 1 + * Ci(x) = eul + ln x + | --------- dt, + * | t + * - + * 0 + * x + * - + * | sin t + * Si(x) = | ----- dt + * | t + * - + * 0 + * + * where eul = 0.57721566490153286061 is Euler's constant. + * The integrals are approximated by rational functions. + * For x > 8 auxiliary functions f(x) and g(x) are employed + * such that + * + * Ci(x) = f(x) sin(x) - g(x) cos(x) + * Si(x) = pi/2 - f(x) cos(x) - g(x) sin(x) + * + * + * ACCURACY: + * Test interval = [0,50]. + * Absolute error, except relative when > 1: + * arithmetic function # trials peak rms + * IEEE Si 30000 2.1e-7 4.3e-8 + * IEEE Ci 30000 3.9e-7 2.2e-8 + */ + +/* +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 +*/ + +#include <math.h> + +static float SN[] = { +-8.39167827910303881427E-11, + 4.62591714427012837309E-8, +-9.75759303843632795789E-6, + 9.76945438170435310816E-4, +-4.13470316229406538752E-2, + 1.00000000000000000302E0, +}; +static float SD[] = { + 2.03269266195951942049E-12, + 1.27997891179943299903E-9, + 4.41827842801218905784E-7, + 9.96412122043875552487E-5, + 1.42085239326149893930E-2, + 9.99999999999999996984E-1, +}; + +static float CN[] = { + 2.02524002389102268789E-11, +-1.35249504915790756375E-8, + 3.59325051419993077021E-6, +-4.74007206873407909465E-4, + 2.89159652607555242092E-2, +-1.00000000000000000080E0, +}; +static float CD[] = { + 4.07746040061880559506E-12, + 3.06780997581887812692E-9, + 1.23210355685883423679E-6, + 3.17442024775032769882E-4, + 5.10028056236446052392E-2, + 4.00000000000000000080E0, +}; + + +static float FN4[] = { + 4.23612862892216586994E0, + 5.45937717161812843388E0, + 1.62083287701538329132E0, + 1.67006611831323023771E-1, + 6.81020132472518137426E-3, + 1.08936580650328664411E-4, + 5.48900223421373614008E-7, +}; +static float FD4[] = { +/* 1.00000000000000000000E0,*/ + 8.16496634205391016773E0, + 7.30828822505564552187E0, + 1.86792257950184183883E0, + 1.78792052963149907262E-1, + 7.01710668322789753610E-3, + 1.10034357153915731354E-4, + 5.48900252756255700982E-7, +}; + + +static float FN8[] = { + 4.55880873470465315206E-1, + 7.13715274100146711374E-1, + 1.60300158222319456320E-1, + 1.16064229408124407915E-2, + 3.49556442447859055605E-4, + 4.86215430826454749482E-6, + 3.20092790091004902806E-8, + 9.41779576128512936592E-11, + 9.70507110881952024631E-14, +}; +static float FD8[] = { +/* 1.00000000000000000000E0,*/ + 9.17463611873684053703E-1, + 1.78685545332074536321E-1, + 1.22253594771971293032E-2, + 3.58696481881851580297E-4, + 4.92435064317881464393E-6, + 3.21956939101046018377E-8, + 9.43720590350276732376E-11, + 9.70507110881952025725E-14, +}; + +static float GN4[] = { + 8.71001698973114191777E-2, + 6.11379109952219284151E-1, + 3.97180296392337498885E-1, + 7.48527737628469092119E-2, + 5.38868681462177273157E-3, + 1.61999794598934024525E-4, + 1.97963874140963632189E-6, + 7.82579040744090311069E-9, +}; +static float GD4[] = { +/* 1.00000000000000000000E0,*/ + 1.64402202413355338886E0, + 6.66296701268987968381E-1, + 9.88771761277688796203E-2, + 6.22396345441768420760E-3, + 1.73221081474177119497E-4, + 2.02659182086343991969E-6, + 7.82579218933534490868E-9, +}; + +static float GN8[] = { + 6.97359953443276214934E-1, + 3.30410979305632063225E-1, + 3.84878767649974295920E-2, + 1.71718239052347903558E-3, + 3.48941165502279436777E-5, + 3.47131167084116673800E-7, + 1.70404452782044526189E-9, + 3.85945925430276600453E-12, + 3.14040098946363334640E-15, +}; +static float GD8[] = { +/* 1.00000000000000000000E0,*/ + 1.68548898811011640017E0, + 4.87852258695304967486E-1, + 4.67913194259625806320E-2, + 1.90284426674399523638E-3, + 3.68475504442561108162E-5, + 3.57043223443740838771E-7, + 1.72693748966316146736E-9, + 3.87830166023954706752E-12, + 3.14040098946363335242E-15, +}; + +#define EUL 0.57721566490153286061 +extern float MAXNUMF, PIO2F, MACHEPF; + + + +#ifdef ANSIC +float logf(float), sinf(float), cosf(float); +float polevlf(float, float *, int); +float p1evlf(float, float *, int); +#else +float logf(), sinf(), cosf(), polevlf(), p1evlf(); +#endif + + +int sicif( float xx, float *si, float *ci ) +{ +float x, z, c, s, f, g; +int sign; + +x = xx; +if( x < 0.0 ) + { + sign = -1; + x = -x; + } +else + sign = 0; + + +if( x == 0.0 ) + { + *si = 0.0; + *ci = -MAXNUMF; + return( 0 ); + } + + +if( x > 1.0e9 ) + { + *si = PIO2F - cosf(x)/x; + *ci = sinf(x)/x; + return( 0 ); + } + + + +if( x > 4.0 ) + goto asympt; + +z = x * x; +s = x * polevlf( z, SN, 5 ) / polevlf( z, SD, 5 ); +c = z * polevlf( z, CN, 5 ) / polevlf( z, CD, 5 ); + +if( sign ) + s = -s; +*si = s; +*ci = EUL + logf(x) + c; /* real part if x < 0 */ +return(0); + + + +/* The auxiliary functions are: + * + * + * *si = *si - PIO2; + * c = cos(x); + * s = sin(x); + * + * t = *ci * s - *si * c; + * a = *ci * c + *si * s; + * + * *si = t; + * *ci = -a; + */ + + +asympt: + +s = sinf(x); +c = cosf(x); +z = 1.0/(x*x); +if( x < 8.0 ) + { + f = polevlf( z, FN4, 6 ) / (x * p1evlf( z, FD4, 7 )); + g = z * polevlf( z, GN4, 7 ) / p1evlf( z, GD4, 7 ); + } +else + { + f = polevlf( z, FN8, 8 ) / (x * p1evlf( z, FD8, 8 )); + g = z * polevlf( z, GN8, 8 ) / p1evlf( z, GD8, 9 ); + } +*si = PIO2F - f * c - g * s; +if( sign ) + *si = -( *si ); +*ci = f * s - g * c; + +return(0); +} diff --git a/libm/float/sindgf.c b/libm/float/sindgf.c new file mode 100644 index 000000000..a3f5851c8 --- /dev/null +++ b/libm/float/sindgf.c @@ -0,0 +1,232 @@ +/* sindgf.c + * + * Circular sine of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, sindgf(); + * + * y = sindgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the sine is approximated by + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-3600 100,000 1.2e-7 3.0e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2^24 0.0 + * + */ + +/* cosdgf.c + * + * Circular cosine of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, cosdgf(); + * + * y = cosdgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * + * Two polynomial approximating functions are employed. + * Between 0 and pi/4 the cosine is approximated by + * 1 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1985, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +/* Single precision circular sine + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 6.8e-8 + * rms relative error: 2.6e-8 + */ +#include <math.h> + + +/*static float FOPI = 1.27323954473516;*/ + +extern float PIO4F; + +/* These are for a 24-bit significand: */ +static float T24M1 = 16777215.; + +static float PI180 = 0.0174532925199432957692; /* pi/180 */ + +float sindgf( float xx ) +{ +float x, y, z; +long j; +int sign; + +sign = 1; +x = xx; +if( xx < 0 ) + { + sign = -1; + x = -xx; + } +if( x > T24M1 ) + { + mtherr( "sindgf", TLOSS ); + return(0.0); + } +j = 0.022222222222222222222 * x; /* integer part of x/45 */ +y = j; +/* map zeros to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0; + } +j &= 7; /* octant modulo 360 degrees */ +/* reflect in x axis */ +if( j > 3) + { + sign = -sign; + j -= 4; + } + +x = x - y * 45.0; +x *= PI180; /* multiply by pi/180 to convert to radians */ + +z = x * x; +if( (j==1) || (j==2) ) + { +/* + y = ((( 2.4462803166E-5 * z + - 1.3887580023E-3) * z + + 4.1666650433E-2) * z + - 4.9999999968E-1) * z + + 1.0; +*/ + +/* measured relative error in +/- pi/4 is 7.8e-8 */ + y = (( 2.443315711809948E-005 * z + - 1.388731625493765E-003) * z + + 4.166664568298827E-002) * z * z; + y -= 0.5 * z; + y += 1.0; + } +else + { +/* Theoretical relative error = 3.8e-9 in [-pi/4, +pi/4] */ + y = ((-1.9515295891E-4 * z + + 8.3321608736E-3) * z + - 1.6666654611E-1) * z * x; + y += x; + } + +if(sign < 0) + y = -y; +return( y); +} + + +/* Single precision circular cosine + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 8.3e-8 + * rms relative error: 2.2e-8 + */ + +float cosdgf( float xx ) +{ +register float x, y, z; +int j, sign; + +/* make argument positive */ +sign = 1; +x = xx; +if( x < 0 ) + x = -x; + +if( x > T24M1 ) + { + mtherr( "cosdgf", TLOSS ); + return(0.0); + } + +j = 0.02222222222222222222222 * x; /* integer part of x/PIO4 */ +y = j; +/* integer and fractional part modulo one octant */ +if( j & 1 ) /* map zeros to origin */ + { + j += 1; + y += 1.0; + } +j &= 7; +if( j > 3) + { + j -=4; + sign = -sign; + } + +if( j > 1 ) + sign = -sign; + +x = x - y * 45.0; /* x mod 45 degrees */ +x *= PI180; /* multiply by pi/180 to convert to radians */ + +z = x * x; + +if( (j==1) || (j==2) ) + { + y = (((-1.9515295891E-4 * z + + 8.3321608736E-3) * z + - 1.6666654611E-1) * z * x) + + x; + } +else + { + y = (( 2.443315711809948E-005 * z + - 1.388731625493765E-003) * z + + 4.166664568298827E-002) * z * z; + y -= 0.5 * z; + y += 1.0; + } +if(sign < 0) + y = -y; +return( y ); +} + diff --git a/libm/float/sinf.c b/libm/float/sinf.c new file mode 100644 index 000000000..2f1bb45b8 --- /dev/null +++ b/libm/float/sinf.c @@ -0,0 +1,283 @@ +/* sinf.c + * + * Circular sine + * + * + * + * SYNOPSIS: + * + * float x, y, sinf(); + * + * y = sinf( 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 + * x + x**3 P(x**2). + * Between pi/4 and pi/2 the cosine is represented as + * 1 - x**2 Q(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -4096,+4096 100,000 1.2e-7 3.0e-8 + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * sin total loss x > 2^24 0.0 + * + * Partial loss of accuracy begins to occur at x = 2^13 + * = 8192. Results may be meaningless for x >= 2^24 + * The routine as implemented flags a TLOSS error + * for x >= 2^24 and returns 0.0. + */ + +/* cosf.c + * + * Circular cosine + * + * + * + * SYNOPSIS: + * + * float x, y, cosf(); + * + * y = cosf( 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 - x**2 Q(x**2). + * Between pi/4 and pi/2 the sine is represented as + * x + x**3 P(x**2). + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -8192,+8192 100,000 3.0e-7 3.0e-8 + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1985, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + + +/* Single precision circular sine + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 6.8e-8 + * rms relative error: 2.6e-8 + */ +#include <math.h> + + +static float FOPI = 1.27323954473516; + +extern float PIO4F; +/* Note, these constants are for a 32-bit significand: */ +/* +static float DP1 = 0.7853851318359375; +static float DP2 = 1.30315311253070831298828125e-5; +static float DP3 = 3.03855025325309630e-11; +static float lossth = 65536.; +*/ + +/* These are for a 24-bit significand: */ +static float DP1 = 0.78515625; +static float DP2 = 2.4187564849853515625e-4; +static float DP3 = 3.77489497744594108e-8; +static float lossth = 8192.; +static float T24M1 = 16777215.; + +static float sincof[] = { +-1.9515295891E-4, + 8.3321608736E-3, +-1.6666654611E-1 +}; +static float coscof[] = { + 2.443315711809948E-005, +-1.388731625493765E-003, + 4.166664568298827E-002 +}; + +float sinf( float xx ) +{ +float *p; +float x, y, z; +register unsigned long j; +register int sign; + +sign = 1; +x = xx; +if( xx < 0 ) + { + sign = -1; + x = -xx; + } +if( x > T24M1 ) + { + mtherr( "sinf", TLOSS ); + return(0.0); + } +j = FOPI * x; /* integer part of x/(PI/4) */ +y = j; +/* map zeros to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0; + } +j &= 7; /* octant modulo 360 degrees */ +/* reflect in x axis */ +if( j > 3) + { + sign = -sign; + j -= 4; + } + +if( x > lossth ) + { + mtherr( "sinf", PLOSS ); + x = x - y * PIO4F; + } +else + { +/* Extended precision modular arithmetic */ + x = ((x - y * DP1) - y * DP2) - y * DP3; + } +/*einits();*/ +z = x * x; +if( (j==1) || (j==2) ) + { +/* measured relative error in +/- pi/4 is 7.8e-8 */ +/* + y = (( 2.443315711809948E-005 * z + - 1.388731625493765E-003) * z + + 4.166664568298827E-002) * z * z; +*/ + p = coscof; + y = *p++; + y = y * z + *p++; + y = y * z + *p++; + y *= z * z; + y -= 0.5 * z; + y += 1.0; + } +else + { +/* Theoretical relative error = 3.8e-9 in [-pi/4, +pi/4] */ +/* + y = ((-1.9515295891E-4 * z + + 8.3321608736E-3) * z + - 1.6666654611E-1) * z * x; + y += x; +*/ + p = sincof; + y = *p++; + y = y * z + *p++; + y = y * z + *p++; + y *= z * x; + y += x; + } +/*einitd();*/ +if(sign < 0) + y = -y; +return( y); +} + + +/* Single precision circular cosine + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 8.3e-8 + * rms relative error: 2.2e-8 + */ + +float cosf( float xx ) +{ +float x, y, z; +int j, sign; + +/* make argument positive */ +sign = 1; +x = xx; +if( x < 0 ) + x = -x; + +if( x > T24M1 ) + { + mtherr( "cosf", TLOSS ); + return(0.0); + } + +j = FOPI * x; /* integer part of x/PIO4 */ +y = j; +/* integer and fractional part modulo one octant */ +if( j & 1 ) /* map zeros to origin */ + { + j += 1; + y += 1.0; + } +j &= 7; +if( j > 3) + { + j -=4; + sign = -sign; + } + +if( j > 1 ) + sign = -sign; + +if( x > lossth ) + { + mtherr( "cosf", PLOSS ); + x = x - y * PIO4F; + } +else +/* Extended precision modular arithmetic */ + x = ((x - y * DP1) - y * DP2) - y * DP3; + +z = x * x; + +if( (j==1) || (j==2) ) + { + y = (((-1.9515295891E-4 * z + + 8.3321608736E-3) * z + - 1.6666654611E-1) * z * x) + + x; + } +else + { + y = (( 2.443315711809948E-005 * z + - 1.388731625493765E-003) * z + + 4.166664568298827E-002) * z * z; + y -= 0.5 * z; + y += 1.0; + } +if(sign < 0) + y = -y; +return( y ); +} + diff --git a/libm/float/sinhf.c b/libm/float/sinhf.c new file mode 100644 index 000000000..e8baaf4fa --- /dev/null +++ b/libm/float/sinhf.c @@ -0,0 +1,87 @@ +/* sinhf.c + * + * Hyperbolic sine + * + * + * + * SYNOPSIS: + * + * float x, y, sinhf(); + * + * y = sinhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic sine of argument in the range MINLOGF to + * MAXLOGF. + * + * The range is partitioned into two segments. If |x| <= 1, a + * polynomial approximation is used. + * Otherwise the calculation is sinh(x) = ( exp(x) - exp(-x) )/2. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-MAXLOG 100000 1.1e-7 2.9e-8 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision hyperbolic sine + * test interval: [-1, +1] + * trials: 10000 + * peak relative error: 9.0e-8 + * rms relative error: 3.0e-8 + */ +#include <math.h> +extern float MAXLOGF, MAXNUMF; + +float expf( float ); + +float sinhf( float xx ) +{ +register float z; +float x; + +x = xx; +if( xx < 0 ) + z = -x; +else + z = x; + +if( z > MAXLOGF ) + { + mtherr( "sinhf", DOMAIN ); + if( x > 0 ) + return( MAXNUMF ); + else + return( -MAXNUMF ); + } +if( z > 1.0 ) + { + z = expf(z); + z = 0.5*z - (0.5/z); + if( x < 0 ) + z = -z; + } +else + { + z = x * x; + z = + (( 2.03721912945E-4 * z + + 8.33028376239E-3) * z + + 1.66667160211E-1) * z * x + + x; + } +return( z ); +} diff --git a/libm/float/spencef.c b/libm/float/spencef.c new file mode 100644 index 000000000..52799babe --- /dev/null +++ b/libm/float/spencef.c @@ -0,0 +1,135 @@ +/* spencef.c + * + * Dilogarithm + * + * + * + * SYNOPSIS: + * + * float x, y, spencef(); + * + * y = spencef( x ); + * + * + * + * DESCRIPTION: + * + * Computes the integral + * + * x + * - + * | | log t + * spence(x) = - | ----- dt + * | | t - 1 + * - + * 1 + * + * for x >= 0. A rational approximation gives the integral in + * the interval (0.5, 1.5). Transformation formulas for 1/x + * and 1-x are employed outside the basic expansion range. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,4 30000 4.4e-7 6.3e-8 + * + * + */ + +/* spence.c */ + + +/* +Cephes Math Library Release 2.1: January, 1989 +Copyright 1985, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +static float A[8] = { + 4.65128586073990045278E-5, + 7.31589045238094711071E-3, + 1.33847639578309018650E-1, + 8.79691311754530315341E-1, + 2.71149851196553469920E0, + 4.25697156008121755724E0, + 3.29771340985225106936E0, + 1.00000000000000000126E0, +}; +static float B[8] = { + 6.90990488912553276999E-4, + 2.54043763932544379113E-2, + 2.82974860602568089943E-1, + 1.41172597751831069617E0, + 3.63800533345137075418E0, + 5.03278880143316990390E0, + 3.54771340985225096217E0, + 9.99999999999999998740E-1, +}; + +extern float PIF, MACHEPF; + +/* pi * pi / 6 */ +#define PIFS 1.64493406684822643647 + + +float logf(float), polevlf(float, float *, int); +float spencef(float xx) +{ +float x, w, y, z; +int flag; + +x = xx; +if( x < 0.0 ) + { + mtherr( "spencef", DOMAIN ); + return(0.0); + } + +if( x == 1.0 ) + return( 0.0 ); + +if( x == 0.0 ) + return( PIFS ); + +flag = 0; + +if( x > 2.0 ) + { + x = 1.0/x; + flag |= 2; + } + +if( x > 1.5 ) + { + w = (1.0/x) - 1.0; + flag |= 2; + } + +else if( x < 0.5 ) + { + w = -x; + flag |= 1; + } + +else + w = x - 1.0; + + +y = -w * polevlf( w, A, 7) / polevlf( w, B, 7 ); + +if( flag & 1 ) + y = PIFS - logf(x) * logf(1.0-x) - y; + +if( flag & 2 ) + { + z = logf(x); + y = -0.5 * z * z - y; + } + +return( y ); +} diff --git a/libm/float/sqrtf.c b/libm/float/sqrtf.c new file mode 100644 index 000000000..bc75a907b --- /dev/null +++ b/libm/float/sqrtf.c @@ -0,0 +1,140 @@ +/* sqrtf.c + * + * Square root + * + * + * + * SYNOPSIS: + * + * float x, y, sqrtf(); + * + * y = sqrtf( 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. + * + * + * + * ACCURACY: + * + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,1.e38 100000 8.7e-8 2.9e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * sqrtf domain x < 0 0.0 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1988, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision square root + * test interval: [sqrt(2)/2, sqrt(2)] + * trials: 30000 + * peak relative error: 8.8e-8 + * rms relative error: 3.3e-8 + * + * test interval: [0.01, 100.0] + * trials: 50000 + * peak relative error: 8.7e-8 + * rms relative error: 3.3e-8 + * + * Copyright (C) 1989 by Stephen L. Moshier. All rights reserved. + */ +#include <math.h> + +#ifdef ANSIC +float frexpf( float, int * ); +float ldexpf( float, int ); + +float sqrtf( float xx ) +#else +float frexpf(), ldexpf(); + +float sqrtf(xx) +float xx; +#endif +{ +float f, x, y; +int e; + +f = xx; +if( f <= 0.0 ) + { + if( f < 0.0 ) + mtherr( "sqrtf", DOMAIN ); + return( 0.0 ); + } + +x = frexpf( f, &e ); /* f = x * 2**e, 0.5 <= x < 1.0 */ +/* If power of 2 is odd, double x and decrement the power of 2. */ +if( e & 1 ) + { + x = x + x; + e -= 1; + } + +e >>= 1; /* The power of 2 of the square root. */ + +if( x > 1.41421356237 ) + { +/* x is between sqrt(2) and 2. */ + x = x - 2.0; + y = + ((((( -9.8843065718E-4 * x + + 7.9479950957E-4) * x + - 3.5890535377E-3) * x + + 1.1028809744E-2) * x + - 4.4195203560E-2) * x + + 3.5355338194E-1) * x + + 1.41421356237E0; + goto sqdon; + } + +if( x > 0.707106781187 ) + { +/* x is between sqrt(2)/2 and sqrt(2). */ + x = x - 1.0; + y = + ((((( 1.35199291026E-2 * x + - 2.26657767832E-2) * x + + 2.78720776889E-2) * x + - 3.89582788321E-2) * x + + 6.24811144548E-2) * x + - 1.25001503933E-1) * x * x + + 0.5 * x + + 1.0; + goto sqdon; + } + +/* x is between 0.5 and sqrt(2)/2. */ +x = x - 0.5; +y = +((((( -3.9495006054E-1 * x + + 5.1743034569E-1) * x + - 4.3214437330E-1) * x + + 3.5310730460E-1) * x + - 3.5354581892E-1) * x + + 7.0710676017E-1) * x + + 7.07106781187E-1; + +sqdon: +y = ldexpf( y, e ); /* y = y * 2**e */ +return( y); +} diff --git a/libm/float/stdtrf.c b/libm/float/stdtrf.c new file mode 100644 index 000000000..76b14c1f6 --- /dev/null +++ b/libm/float/stdtrf.c @@ -0,0 +1,154 @@ +/* stdtrf.c + * + * Student's t distribution + * + * + * + * SYNOPSIS: + * + * float t, stdtrf(); + * short k; + * + * y = stdtrf( 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, 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: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +/- 100 5000 2.3e-5 2.9e-6 + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + +extern float PIF, MACHEPF; + +#ifdef ANSIC +float sqrtf(float), atanf(float), incbetf(float, float, float); +#else +float sqrtf(), atanf(), incbetf(); +#endif + + + +float stdtrf( int k, float tt ) +{ +float t, x, rk, z, f, tz, p, xsqk; +int j; + +t = tt; +if( k <= 0 ) + { + mtherr( "stdtrf", DOMAIN ); + return(0.0); + } + +if( t == 0 ) + return( 0.5 ); + +if( t < -1.0 ) + { + rk = k; + z = rk / (rk + t * t); + p = 0.5 * incbetf( 0.5*rk, 0.5, z ); + return( p ); + } + +/* compute integral from -t to + t */ + +if( t < 0 ) + x = -t; +else + x = t; + +rk = k; /* degrees of freedom */ +z = 1.0 + ( x * x )/rk; + +/* test if k is odd or even */ +if( (k & 1) != 0) + { + + /* computation for odd k */ + + xsqk = x/sqrtf(rk); + p = atanf( xsqk ); + if( k > 1 ) + { + f = 1.0; + tz = 1.0; + j = 3; + while( (j<=(k-2)) && ( (tz/f) > MACHEPF ) ) + { + tz *= (j-1)/( z * j ); + f += tz; + j += 2; + } + p += f * xsqk/z; + } + p *= 2.0/PIF; + } + + +else + { + + /* computation for even k */ + + f = 1.0; + tz = 1.0; + j = 2; + + while( ( j <= (k-2) ) && ( (tz/f) > MACHEPF ) ) + { + tz *= (j - 1)/( z * j ); + f += tz; + j += 2; + } + p = f * x/sqrtf(z*rk); + } + +/* common exit */ + + +if( t < 0 ) + p = -p; /* note destruction of relative accuracy */ + + p = 0.5 + 0.5 * p; +return(p); +} diff --git a/libm/float/struvef.c b/libm/float/struvef.c new file mode 100644 index 000000000..4cf8854ed --- /dev/null +++ b/libm/float/struvef.c @@ -0,0 +1,315 @@ +/* struvef.c + * + * Struve function + * + * + * + * SYNOPSIS: + * + * float v, x, y, struvef(); + * + * y = struvef( v, x ); + * + * + * + * DESCRIPTION: + * + * Computes the Struve function Hv(x) of order v, argument x. + * Negative x is rejected unless v is an integer. + * + * This module also contains the hypergeometric functions 1F2 + * and 3F0 and a routine for the Bessel function Yv(x) with + * noninteger v. + * + * + * + * ACCURACY: + * + * v varies from 0 to 10. + * Absolute error (relative error when |Hv(x)| > 1): + * arithmetic domain # trials peak rms + * IEEE -10,10 100000 9.0e-5 4.0e-6 + * + */ + + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +#define DEBUG 0 + +extern float MACHEPF, MAXNUMF, PIF; + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + +#ifdef ANSIC +float gammaf(float), powf(float, float), sqrtf(float); +float yvf(float, float); +float floorf(float), ynf(int, float); +float jvf(float, float); +float sinf(float), cosf(float); +#else +float gammaf(), powf(), sqrtf(), yvf(); +float floorf(), ynf(), jvf(), sinf(), cosf(); +#endif + +float onef2f( float aa, float bb, float cc, float xx, float *err ) +{ +float a, b, c, x, n, a0, sum, t; +float an, bn, cn, max, z; + +a = aa; +b = bb; +c = cc; +x = xx; +an = a; +bn = b; +cn = c; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +max = 0.0; + +do + { + if( an == 0 ) + goto done; + if( bn == 0 ) + goto error; + if( cn == 0 ) + goto error; + if( (a0 > 1.0e34) || (n > 200) ) + goto error; + a0 *= (an * x) / (bn * cn * n); + sum += a0; + an += 1.0; + bn += 1.0; + cn += 1.0; + n += 1.0; + z = fabsf( a0 ); + if( z > max ) + max = z; + if( sum != 0 ) + t = fabsf( a0 / sum ); + else + t = z; + } +while( t > MACHEPF ); + +done: + +*err = fabsf( MACHEPF*max /sum ); + +#if DEBUG + printf(" onef2f cancellation error %.5E\n", *err ); +#endif + +goto xit; + +error: +#if DEBUG +printf("onef2f does not converge\n"); +#endif +*err = MAXNUMF; + +xit: + +#if DEBUG +printf("onef2( %.2E %.2E %.2E %.5E ) = %.3E %.6E\n", a, b, c, x, n, sum); +#endif +return(sum); +} + + + +float threef0f( float aa, float bb, float cc, float xx, float *err ) +{ +float a, b, c, x, n, a0, sum, t, conv, conv1; +float an, bn, cn, max, z; + +a = aa; +b = bb; +c = cc; +x = xx; +an = a; +bn = b; +cn = c; +a0 = 1.0; +sum = 1.0; +n = 1.0; +t = 1.0; +max = 0.0; +conv = 1.0e38; +conv1 = conv; + +do + { + if( an == 0.0 ) + goto done; + if( bn == 0.0 ) + goto done; + if( cn == 0.0 ) + goto done; + if( (a0 > 1.0e34) || (n > 200) ) + goto error; + a0 *= (an * bn * cn * x) / n; + an += 1.0; + bn += 1.0; + cn += 1.0; + n += 1.0; + z = fabsf( a0 ); + if( z > max ) + max = z; + if( z >= conv ) + { + if( (z < max) && (z > conv1) ) + goto done; + } + conv1 = conv; + conv = z; + sum += a0; + if( sum != 0 ) + t = fabsf( a0 / sum ); + else + t = z; + } +while( t > MACHEPF ); + +done: + +t = fabsf( MACHEPF*max/sum ); +#if DEBUG + printf(" threef0f cancellation error %.5E\n", t ); +#endif + +max = fabsf( conv/sum ); +if( max > t ) + t = max; +#if DEBUG + printf(" threef0f convergence %.5E\n", max ); +#endif + +goto xit; + +error: +#if DEBUG +printf("threef0f does not converge\n"); +#endif +t = MAXNUMF; + +xit: + +#if DEBUG +printf("threef0f( %.2E %.2E %.2E %.5E ) = %.3E %.6E\n", a, b, c, x, n, sum); +#endif + +*err = t; +return(sum); +} + + + + +float struvef( float vv, float xx ) +{ +float v, x, y, ya, f, g, h, t; +float onef2err, threef0err; + +v = vv; +x = xx; +f = floorf(v); +if( (v < 0) && ( v-f == 0.5 ) ) + { + y = jvf( -v, x ); + f = 1.0 - f; + g = 2.0 * floorf(0.5*f); + if( g != f ) + y = -y; + return(y); + } +t = 0.25*x*x; +f = fabsf(x); +g = 1.5 * fabsf(v); +if( (f > 30.0) && (f > g) ) + { + onef2err = MAXNUMF; + y = 0.0; + } +else + { + y = onef2f( 1.0, 1.5, 1.5+v, -t, &onef2err ); + } + +if( (f < 18.0) || (x < 0.0) ) + { + threef0err = MAXNUMF; + ya = 0.0; + } +else + { + ya = threef0f( 1.0, 0.5, 0.5-v, -1.0/t, &threef0err ); + } + +f = sqrtf( PIF ); +h = powf( 0.5*x, v-1.0 ); + +if( onef2err <= threef0err ) + { + g = gammaf( v + 1.5 ); + y = y * h * t / ( 0.5 * f * g ); + return(y); + } +else + { + g = gammaf( v + 0.5 ); + ya = ya * h / ( f * g ); + ya = ya + yvf( v, x ); + return(ya); + } +} + + + + +/* Bessel function of noninteger order + */ + +float yvf( float vv, float xx ) +{ +float v, x, y, t; +int n; + +v = vv; +x = xx; +y = floorf( v ); +if( y == v ) + { + n = v; + y = ynf( n, x ); + return( y ); + } +t = PIF * v; +y = (cosf(t) * jvf( v, x ) - jvf( -v, x ))/sinf(t); +return( y ); +} + +/* Crossover points between ascending series and asymptotic series + * for Struve function + * + * v x + * + * 0 19.2 + * 1 18.95 + * 2 19.15 + * 3 19.3 + * 5 19.7 + * 10 21.35 + * 20 26.35 + * 30 32.31 + * 40 40.0 + */ diff --git a/libm/float/tandgf.c b/libm/float/tandgf.c new file mode 100644 index 000000000..dc55ad5e4 --- /dev/null +++ b/libm/float/tandgf.c @@ -0,0 +1,206 @@ +/* tandgf.c + * + * Circular tangent of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, tandgf(); + * + * y = tandgf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is into intervals of 45 degrees. + * + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-2^24 50000 2.4e-7 4.8e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * tanf total loss x > 2^24 0.0 + * + */ + /* cotdgf.c + * + * Circular cotangent of angle in degrees + * + * + * + * SYNOPSIS: + * + * float x, y, cotdgf(); + * + * y = cotdgf( x ); + * + * + * + * DESCRIPTION: + * + * Range reduction is into intervals of 45 degrees. + * A common routine computes either the tangent or cotangent. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-2^24 50000 2.4e-7 4.8e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^24 0.0 + * cot singularity x = 0 MAXNUMF + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision circular tangent + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 8.7e-8 + * rms relative error: 2.8e-8 + */ +#include <math.h> + +extern float MAXNUMF; + +static float T24M1 = 16777215.; +static float PI180 = 0.0174532925199432957692; /* pi/180 */ + +static float tancotf( float xx, int cotflg ) +{ +float x, y, z, zz; +long j; +int sign; + + +/* make argument positive but save the sign */ +if( xx < 0.0 ) + { + x = -xx; + sign = -1; + } +else + { + x = xx; + sign = 1; + } + +if( x > T24M1 ) + { + if( cotflg ) + mtherr( "cotdgf", TLOSS ); + else + mtherr( "tandgf", TLOSS ); + return(0.0); + } + +/* compute x mod PIO4 */ +j = 0.022222222222222222222 * x; /* integer part of x/45 */ +y = j; + +/* map zeros and singularities to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0; + } + +z = x - y * 45.0; +z *= PI180; /* multiply by pi/180 to convert to radians */ + +zz = z * z; + +if( x > 1.0e-4 ) + { +/* 1.7e-8 relative error in [-pi/4, +pi/4] */ + y = + ((((( 9.38540185543E-3 * zz + + 3.11992232697E-3) * zz + + 2.44301354525E-2) * zz + + 5.34112807005E-2) * zz + + 1.33387994085E-1) * zz + + 3.33331568548E-1) * zz * z + + z; + } +else + { + y = z; + } + +if( j & 2 ) + { + if( cotflg ) + y = -y; + else + { + if( y != 0.0 ) + { + y = -1.0/y; + } + else + { + mtherr( "tandgf", SING ); + y = MAXNUMF; + } + } + } +else + { + if( cotflg ) + { + if( y != 0.0 ) + y = 1.0/y; + else + { + mtherr( "cotdgf", SING ); + y = MAXNUMF; + } + } + } + +if( sign < 0 ) + y = -y; + +return( y ); +} + + +float tandgf( float x ) +{ + +return( tancotf(x,0) ); +} + +float cotdgf( float x ) +{ + +if( x == 0.0 ) + { + mtherr( "cotdgf", SING ); + return( MAXNUMF ); + } +return( tancotf(x,1) ); +} + diff --git a/libm/float/tanf.c b/libm/float/tanf.c new file mode 100644 index 000000000..5bbf43075 --- /dev/null +++ b/libm/float/tanf.c @@ -0,0 +1,192 @@ +/* tanf.c + * + * Circular tangent + * + * + * + * SYNOPSIS: + * + * float x, y, tanf(); + * + * y = tanf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular tangent of the radian argument x. + * + * Range reduction is modulo pi/4. A polynomial approximation + * is employed in the basic interval [0, pi/4]. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4096 100000 3.3e-7 4.5e-8 + * + * ERROR MESSAGES: + * + * message condition value returned + * tanf total loss x > 2^24 0.0 + * + */ + /* cotf.c + * + * Circular cotangent + * + * + * + * SYNOPSIS: + * + * float x, y, cotf(); + * + * y = cotf( x ); + * + * + * + * DESCRIPTION: + * + * Returns the circular cotangent of the radian argument x. + * A common routine computes either the tangent or cotangent. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE +-4096 100000 3.0e-7 4.5e-8 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * cot total loss x > 2^24 0.0 + * cot singularity x = 0 MAXNUMF + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision circular tangent + * test interval: [-pi/4, +pi/4] + * trials: 10000 + * peak relative error: 8.7e-8 + * rms relative error: 2.8e-8 + */ +#include <math.h> + +extern float MAXNUMF; + +static float DP1 = 0.78515625; +static float DP2 = 2.4187564849853515625e-4; +static float DP3 = 3.77489497744594108e-8; +float FOPI = 1.27323954473516; /* 4/pi */ +static float lossth = 8192.; +/*static float T24M1 = 16777215.;*/ + + +static float tancotf( float xx, int cotflg ) +{ +float x, y, z, zz; +long j; +int sign; + + +/* make argument positive but save the sign */ +if( xx < 0.0 ) + { + x = -xx; + sign = -1; + } +else + { + x = xx; + sign = 1; + } + +if( x > lossth ) + { + if( cotflg ) + mtherr( "cotf", TLOSS ); + else + mtherr( "tanf", TLOSS ); + return(0.0); + } + +/* compute x mod PIO4 */ +j = FOPI * x; /* integer part of x/(PI/4) */ +y = j; + +/* map zeros and singularities to origin */ +if( j & 1 ) + { + j += 1; + y += 1.0; + } + +z = ((x - y * DP1) - y * DP2) - y * DP3; + +zz = z * z; + +if( x > 1.0e-4 ) + { +/* 1.7e-8 relative error in [-pi/4, +pi/4] */ + y = + ((((( 9.38540185543E-3 * zz + + 3.11992232697E-3) * zz + + 2.44301354525E-2) * zz + + 5.34112807005E-2) * zz + + 1.33387994085E-1) * zz + + 3.33331568548E-1) * zz * z + + z; + } +else + { + y = z; + } + +if( j & 2 ) + { + if( cotflg ) + y = -y; + else + y = -1.0/y; + } +else + { + if( cotflg ) + y = 1.0/y; + } + +if( sign < 0 ) + y = -y; + +return( y ); +} + + +float tanf( float x ) +{ + +return( tancotf(x,0) ); +} + +float cotf( float x ) +{ + +if( x == 0.0 ) + { + mtherr( "cotf", SING ); + return( MAXNUMF ); + } +return( tancotf(x,1) ); +} + diff --git a/libm/float/tanhf.c b/libm/float/tanhf.c new file mode 100644 index 000000000..4636192c2 --- /dev/null +++ b/libm/float/tanhf.c @@ -0,0 +1,88 @@ +/* tanhf.c + * + * Hyperbolic tangent + * + * + * + * SYNOPSIS: + * + * float x, y, tanhf(); + * + * y = tanhf( x ); + * + * + * + * DESCRIPTION: + * + * Returns hyperbolic tangent of argument in the range MINLOG to + * MAXLOG. + * + * A polynomial approximation is used for |x| < 0.625. + * Otherwise, + * + * tanh(x) = sinh(x)/cosh(x) = 1 - 2/(exp(2x) + 1). + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE -2,2 100000 1.3e-7 2.6e-8 + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +/* Single precision hyperbolic tangent + * test interval: [-0.625, +0.625] + * trials: 10000 + * peak relative error: 7.2e-8 + * rms relative error: 2.6e-8 + */ +#include <math.h> + +extern float MAXLOGF; + +float expf( float ); + +float tanhf( float xx ) +{ +float x, z; + +if( xx < 0 ) + x = -xx; +else + x = xx; + +if( x > 0.5 * MAXLOGF ) + { + if( xx > 0 ) + return( 1.0 ); + else + return( -1.0 ); + } +if( x >= 0.625 ) + { + x = expf(x+x); + z = 1.0 - 2.0/(x + 1.0); + if( xx < 0 ) + z = -z; + } +else + { + z = x * x; + z = + (((( -5.70498872745E-3 * z + + 2.06390887954E-2) * z + - 5.37397155531E-2) * z + + 1.33314422036E-1) * z + - 3.33332819422E-1) * z * xx + + xx; + } +return( z ); +} diff --git a/libm/float/ynf.c b/libm/float/ynf.c new file mode 100644 index 000000000..55d984b26 --- /dev/null +++ b/libm/float/ynf.c @@ -0,0 +1,120 @@ +/* ynf.c + * + * Bessel function of second kind of integer order + * + * + * + * SYNOPSIS: + * + * float x, y, ynf(); + * int n; + * + * y = ynf( 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 + * y0() and y1(). + * + * If n = 0 or 1 the routine for y0 or y1 is called + * directly. + * + * + * + * ACCURACY: + * + * + * Absolute error, except relative when y > 1: + * + * arithmetic domain # trials peak rms + * IEEE 0, 30 10000 2.3e-6 3.4e-7 + * + * + * ERROR MESSAGES: + * + * message condition value returned + * yn singularity x = 0 MAXNUMF + * yn overflow MAXNUMF + * + * Spot checked against tables for x, n between 0 and 100. + * + */ + +/* +Cephes Math Library Release 2.2: June, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float MAXNUMF, MAXLOGF; + +float y0f(float), y1f(float), logf(float); + +float ynf( int nn, float xx ) +{ +float x, an, anm1, anm2, r, xinv; +int k, n, sign; + +x = xx; +n = nn; +if( n < 0 ) + { + n = -n; + if( (n & 1) == 0 ) /* -1**n */ + sign = 1; + else + sign = -1; + } +else + sign = 1; + + +if( n == 0 ) + return( sign * y0f(x) ); +if( n == 1 ) + return( sign * y1f(x) ); + +/* test for overflow */ +if( x <= 0.0 ) + { + mtherr( "ynf", SING ); + return( -MAXNUMF ); + } +if( (x < 1.0) || (n > 29) ) + { + an = (float )n; + r = an * logf( an/x ); + if( r > MAXLOGF ) + { + mtherr( "ynf", OVERFLOW ); + return( -MAXNUMF ); + } + } + +/* forward recurrence on n */ + +anm2 = y0f(x); +anm1 = y1f(x); +k = 1; +r = 2 * k; +xinv = 1.0/x; +do + { + an = r * anm1 * xinv - anm2; + anm2 = anm1; + anm1 = an; + r += 2.0; + ++k; + } +while( k < n ); + + +return( sign * an ); +} diff --git a/libm/float/zetacf.c b/libm/float/zetacf.c new file mode 100644 index 000000000..da2ace6a4 --- /dev/null +++ b/libm/float/zetacf.c @@ -0,0 +1,266 @@ + /* zetacf.c + * + * Riemann zeta function + * + * + * + * SYNOPSIS: + * + * float x, y, zetacf(); + * + * y = zetacf( x ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zetac(x) = > k , x > 1, + * - + * k=2 + * + * is related to the Riemann zeta function by + * + * Riemann zeta(x) = zetac(x) + 1. + * + * Extension of the function definition for x < 1 is implemented. + * Zero is returned for x > log2(MAXNUM). + * + * An overflow error may occur for large negative x, due to the + * gamma function in the reflection formula. + * + * ACCURACY: + * + * Tabulated values have full machine accuracy. + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 1,50 30000 5.5e-7 7.5e-8 + * + * + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1989, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> + + +/* Riemann zeta(x) - 1 + * for integer arguments between 0 and 30. + */ +static float azetacf[] = { +-1.50000000000000000000E0, + 1.70141183460469231730E38, /* infinity. */ + 6.44934066848226436472E-1, + 2.02056903159594285400E-1, + 8.23232337111381915160E-2, + 3.69277551433699263314E-2, + 1.73430619844491397145E-2, + 8.34927738192282683980E-3, + 4.07735619794433937869E-3, + 2.00839282608221441785E-3, + 9.94575127818085337146E-4, + 4.94188604119464558702E-4, + 2.46086553308048298638E-4, + 1.22713347578489146752E-4, + 6.12481350587048292585E-5, + 3.05882363070204935517E-5, + 1.52822594086518717326E-5, + 7.63719763789976227360E-6, + 3.81729326499983985646E-6, + 1.90821271655393892566E-6, + 9.53962033872796113152E-7, + 4.76932986787806463117E-7, + 2.38450502727732990004E-7, + 1.19219925965311073068E-7, + 5.96081890512594796124E-8, + 2.98035035146522801861E-8, + 1.49015548283650412347E-8, + 7.45071178983542949198E-9, + 3.72533402478845705482E-9, + 1.86265972351304900640E-9, + 9.31327432419668182872E-10 +}; + + +/* 2**x (1 - 1/x) (zeta(x) - 1) = P(1/x)/Q(1/x), 1 <= x <= 10 */ +static float P[9] = { + 5.85746514569725319540E11, + 2.57534127756102572888E11, + 4.87781159567948256438E10, + 5.15399538023885770696E9, + 3.41646073514754094281E8, + 1.60837006880656492731E7, + 5.92785467342109522998E5, + 1.51129169964938823117E4, + 2.01822444485997955865E2, +}; +static float Q[8] = { +/* 1.00000000000000000000E0,*/ + 3.90497676373371157516E11, + 5.22858235368272161797E10, + 5.64451517271280543351E9, + 3.39006746015350418834E8, + 1.79410371500126453702E7, + 5.66666825131384797029E5, + 1.60382976810944131506E4, + 1.96436237223387314144E2, +}; + +/* log(zeta(x) - 1 - 2**-x), 10 <= x <= 50 */ +static float A[11] = { + 8.70728567484590192539E6, + 1.76506865670346462757E8, + 2.60889506707483264896E10, + 5.29806374009894791647E11, + 2.26888156119238241487E13, + 3.31884402932705083599E14, + 5.13778997975868230192E15, +-1.98123688133907171455E15, +-9.92763810039983572356E16, + 7.82905376180870586444E16, + 9.26786275768927717187E16, +}; +static float B[10] = { +/* 1.00000000000000000000E0,*/ +-7.92625410563741062861E6, +-1.60529969932920229676E8, +-2.37669260975543221788E10, +-4.80319584350455169857E11, +-2.07820961754173320170E13, +-2.96075404507272223680E14, +-4.86299103694609136686E15, + 5.34589509675789930199E15, + 5.71464111092297631292E16, +-1.79915597658676556828E16, +}; + +/* (1-x) (zeta(x) - 1), 0 <= x <= 1 */ + +static float R[6] = { +-3.28717474506562731748E-1, + 1.55162528742623950834E1, +-2.48762831680821954401E2, + 1.01050368053237678329E3, + 1.26726061410235149405E4, +-1.11578094770515181334E5, +}; +static float S[5] = { +/* 1.00000000000000000000E0,*/ + 1.95107674914060531512E1, + 3.17710311750646984099E2, + 3.03835500874445748734E3, + 2.03665876435770579345E4, + 7.43853965136767874343E4, +}; + + +#define MAXL2 127 + +/* + * Riemann zeta function, minus one + */ + +extern float MACHEPF, PIO2F, MAXNUMF, PIF; + +#ifdef ANSIC +extern float sinf ( float xx ); +extern float floorf ( float x ); +extern float gammaf ( float xx ); +extern float powf ( float x, float y ); +extern float expf ( float xx ); +extern float polevlf ( float xx, float *coef, int N ); +extern float p1evlf ( float xx, float *coef, int N ); +#else +float sinf(), floorf(), gammaf(), powf(), expf(); +float polevlf(), p1evlf(); +#endif + +float zetacf(float xx) +{ +int i; +float x, a, b, s, w; + +x = xx; +if( x < 0.0 ) + { + if( x < -30.8148 ) + { + mtherr( "zetacf", OVERFLOW ); + return(0.0); + } + s = 1.0 - x; + w = zetacf( s ); + b = sinf(PIO2F*x) * powf(2.0*PIF, x) * gammaf(s) * (1.0 + w) / PIF; + return(b - 1.0); + } + +if( x >= MAXL2 ) + return(0.0); /* because first term is 2**-x */ + +/* Tabulated values for integer argument */ +w = floorf(x); +if( w == x ) + { + i = x; + if( i < 31 ) + { + return( azetacf[i] ); + } + } + + +if( x < 1.0 ) + { + w = 1.0 - x; + a = polevlf( x, R, 5 ) / ( w * p1evlf( x, S, 5 )); + return( a ); + } + +if( x == 1.0 ) + { + mtherr( "zetacf", SING ); + return( MAXNUMF ); + } + +if( x <= 10.0 ) + { + b = powf( 2.0, x ) * (x - 1.0); + w = 1.0/x; + s = (x * polevlf( w, P, 8 )) / (b * p1evlf( w, Q, 8 )); + return( s ); + } + +if( x <= 50.0 ) + { + b = powf( 2.0, -x ); + w = polevlf( x, A, 10 ) / p1evlf( x, B, 10 ); + w = expf(w) + b; + return(w); + } + + +/* Basic sum of inverse powers */ + + +s = 0.0; +a = 1.0; +do + { + a += 2.0; + b = powf( a, -x ); + s += b; + } +while( b/s > MACHEPF ); + +b = powf( 2.0, -x ); +s = (s + b)/(1.0-b); +return(s); +} diff --git a/libm/float/zetaf.c b/libm/float/zetaf.c new file mode 100644 index 000000000..d01f1d2b2 --- /dev/null +++ b/libm/float/zetaf.c @@ -0,0 +1,175 @@ +/* zetaf.c + * + * Riemann zeta function of two arguments + * + * + * + * SYNOPSIS: + * + * float x, q, y, zetaf(); + * + * y = zetaf( x, q ); + * + * + * + * DESCRIPTION: + * + * + * + * inf. + * - -x + * zeta(x,q) = > (k+q) + * - + * k=0 + * + * where x > 1 and q is not a negative integer or zero. + * The Euler-Maclaurin summation formula is used to obtain + * the expansion + * + * n + * - -x + * zeta(x,q) = > (k+q) + * - + * k=1 + * + * 1-x inf. B x(x+1)...(x+2j) + * (n+q) 1 - 2j + * + --------- - ------- + > -------------------- + * x-1 x - x+2j+1 + * 2(n+q) j=1 (2j)! (n+q) + * + * where the B2j are Bernoulli numbers. Note that (see zetac.c) + * zeta(x,1) = zetac(x) + 1. + * + * + * + * ACCURACY: + * + * Relative error: + * arithmetic domain # trials peak rms + * IEEE 0,25 10000 6.9e-7 1.0e-7 + * + * Large arguments may produce underflow in powf(), in which + * case the results are inaccurate. + * + * REFERENCE: + * + * Gradshteyn, I. S., and I. M. Ryzhik, Tables of Integrals, + * Series, and Products, p. 1073; Academic Press, 1980. + * + */ + +/* +Cephes Math Library Release 2.2: July, 1992 +Copyright 1984, 1987, 1992 by Stephen L. Moshier +Direct inquiries to 30 Frost Street, Cambridge, MA 02140 +*/ + +#include <math.h> +extern float MAXNUMF, MACHEPF; + +/* Expansion coefficients + * for Euler-Maclaurin summation formula + * (2k)! / B2k + * where B2k are Bernoulli numbers + */ +static float A[] = { +12.0, +-720.0, +30240.0, +-1209600.0, +47900160.0, +-1.8924375803183791606e9, /*1.307674368e12/691*/ +7.47242496e10, +-2.950130727918164224e12, /*1.067062284288e16/3617*/ +1.1646782814350067249e14, /*5.109094217170944e18/43867*/ +-4.5979787224074726105e15, /*8.028576626982912e20/174611*/ +1.8152105401943546773e17, /*1.5511210043330985984e23/854513*/ +-7.1661652561756670113e18 /*1.6938241367317436694528e27/236364091*/ +}; +/* 30 Nov 86 -- error in third coefficient fixed */ + + +#define fabsf(x) ( (x) < 0 ? -(x) : (x) ) + + +float powf( float, float ); +float zetaf(float xx, float qq) +{ +int i; +float x, q, a, b, k, s, w, t; + +x = xx; +q = qq; +if( x == 1.0 ) + return( MAXNUMF ); + +if( x < 1.0 ) + { + mtherr( "zetaf", DOMAIN ); + return(0.0); + } + + +/* Euler-Maclaurin summation formula */ +/* +if( x < 25.0 ) +{ +*/ +w = 9.0; +s = powf( q, -x ); +a = q; +for( i=0; i<9; i++ ) + { + a += 1.0; + b = powf( a, -x ); + s += b; + if( b/s < MACHEPF ) + goto done; + } + +w = a; +s += b*w/(x-1.0); +s -= 0.5 * b; +a = 1.0; +k = 0.0; +for( i=0; i<12; i++ ) + { + a *= x + k; + b /= w; + t = a*b/A[i]; + s = s + t; + t = fabsf(t/s); + if( t < MACHEPF ) + goto done; + k += 1.0; + a *= x + k; + b /= w; + k += 1.0; + } +done: +return(s); +/* +} +*/ + + +/* Basic sum of inverse powers */ +/* +pseres: + +s = powf( q, -x ); +a = q; +do + { + a += 2.0; + b = powf( a, -x ); + s += b; + } +while( b/s > MACHEPF ); + +b = powf( 2.0, -x ); +s = (s + b)/(1.0-b); +return(s); +*/ +} 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 ); +} |