1 | /* |
---|
2 | The wrapper for gamma function from OpenCL and standard libraries |
---|
3 | The OpenCL gamma function fails miserably on values lower than 1.0 |
---|
4 | while works fine on larger values. |
---|
5 | We use gamma definition Gamma(t + 1) = t * Gamma(t) to compute |
---|
6 | to function for values lower than 1.0. Namely Gamma(t) = 1/t * Gamma(t + 1) |
---|
7 | For t < 0, we use Gamma(t) = pi / ( Gamma(1 - t) * sin(pi * t) ) |
---|
8 | */ |
---|
9 | |
---|
10 | #if defined(NEED_TGAMMA) |
---|
11 | static double cephes_stirf(double x) |
---|
12 | { |
---|
13 | const double MAXSTIR=143.01608; |
---|
14 | const double SQTPI=2.50662827463100050242E0; |
---|
15 | double y, w, v; |
---|
16 | |
---|
17 | w = 1.0 / x; |
---|
18 | |
---|
19 | w = (((( |
---|
20 | 7.87311395793093628397E-4*w |
---|
21 | - 2.29549961613378126380E-4)*w |
---|
22 | - 2.68132617805781232825E-3)*w |
---|
23 | + 3.47222221605458667310E-3)*w |
---|
24 | + 8.33333333333482257126E-2)*w |
---|
25 | + 1.0; |
---|
26 | y = exp(x); |
---|
27 | if (x > MAXSTIR) |
---|
28 | { /* Avoid overflow in pow() */ |
---|
29 | v = pow(x, 0.5 * x - 0.25); |
---|
30 | y = v * (v / y); |
---|
31 | } |
---|
32 | else |
---|
33 | { |
---|
34 | y = pow(x, x - 0.5) / y; |
---|
35 | } |
---|
36 | y = SQTPI * y * w; |
---|
37 | return(y); |
---|
38 | } |
---|
39 | |
---|
40 | static double tgamma(double x) { |
---|
41 | double p, q, z; |
---|
42 | int sgngam; |
---|
43 | int i; |
---|
44 | |
---|
45 | sgngam = 1; |
---|
46 | if (isnan(x)) |
---|
47 | return(x); |
---|
48 | q = fabs(x); |
---|
49 | |
---|
50 | if (q > 33.0) |
---|
51 | { |
---|
52 | if (x < 0.0) |
---|
53 | { |
---|
54 | p = floor(q); |
---|
55 | if (p == q) |
---|
56 | { |
---|
57 | return (NAN); |
---|
58 | } |
---|
59 | i = p; |
---|
60 | if ((i & 1) == 0) |
---|
61 | sgngam = -1; |
---|
62 | z = q - p; |
---|
63 | if (z > 0.5) |
---|
64 | { |
---|
65 | p += 1.0; |
---|
66 | z = q - p; |
---|
67 | } |
---|
68 | z = q * sin(M_PI * z); |
---|
69 | if (z == 0.0) |
---|
70 | { |
---|
71 | return(NAN); |
---|
72 | } |
---|
73 | z = fabs(z); |
---|
74 | z = M_PI / (z * cephes_stirf(q)); |
---|
75 | } |
---|
76 | else |
---|
77 | { |
---|
78 | z = cephes_stirf(x); |
---|
79 | } |
---|
80 | return(sgngam * z); |
---|
81 | } |
---|
82 | |
---|
83 | z = 1.0; |
---|
84 | while (x >= 3.0) |
---|
85 | { |
---|
86 | x -= 1.0; |
---|
87 | z *= x; |
---|
88 | } |
---|
89 | |
---|
90 | while (x < 0.0) |
---|
91 | { |
---|
92 | if (x > -1.E-9) |
---|
93 | goto small; |
---|
94 | z /= x; |
---|
95 | x += 1.0; |
---|
96 | } |
---|
97 | |
---|
98 | while (x < 2.0) |
---|
99 | { |
---|
100 | if (x < 1.e-9) |
---|
101 | goto small; |
---|
102 | z /= x; |
---|
103 | x += 1.0; |
---|
104 | } |
---|
105 | |
---|
106 | if (x == 2.0) |
---|
107 | return(z); |
---|
108 | |
---|
109 | x -= 2.0; |
---|
110 | p = ((((( |
---|
111 | +1.60119522476751861407E-4*x |
---|
112 | + 1.19135147006586384913E-3)*x |
---|
113 | + 1.04213797561761569935E-2)*x |
---|
114 | + 4.76367800457137231464E-2)*x |
---|
115 | + 2.07448227648435975150E-1)*x |
---|
116 | + 4.94214826801497100753E-1)*x |
---|
117 | + 9.99999999999999996796E-1; |
---|
118 | q = (((((( |
---|
119 | -2.31581873324120129819E-5*x |
---|
120 | + 5.39605580493303397842E-4)*x |
---|
121 | - 4.45641913851797240494E-3)*x |
---|
122 | + 1.18139785222060435552E-2)*x |
---|
123 | + 3.58236398605498653373E-2)*x |
---|
124 | - 2.34591795718243348568E-1)*x |
---|
125 | + 7.14304917030273074085E-2)*x |
---|
126 | + 1.00000000000000000320E0; |
---|
127 | return(z * p / q); |
---|
128 | |
---|
129 | small: |
---|
130 | if (x == 0.0) |
---|
131 | { |
---|
132 | return (NAN); |
---|
133 | } |
---|
134 | else |
---|
135 | return(z / ((1.0 + 0.5772156649015329 * x) * x)); |
---|
136 | } |
---|
137 | #endif // NEED_TGAMMA |
---|
138 | |
---|
139 | |
---|
140 | inline double sas_gamma(double x) |
---|
141 | { |
---|
142 | // Note: the builtin tgamma can give slow and unreliable results for x<1. |
---|
143 | // The following transform extends it to zero and to negative values. |
---|
144 | // It should return NaN for zero and negative integers but doesn't. |
---|
145 | // The accuracy is okay but not wonderful for negative numbers, maybe |
---|
146 | // one or two digits lost in the calculation. If higher accuracy is |
---|
147 | // needed, you could test the following loop: |
---|
148 | // double norm = 1.; |
---|
149 | // while (x<1.) { norm*=x; x+=1.; } |
---|
150 | // return tgamma(x)/norm; |
---|
151 | return (x<0. ? M_PI/tgamma(1.-x)/sin(M_PI*x) : tgamma(x+1)/x); |
---|
152 | } |
---|