1 | /* lgamma.c |
---|
2 | * |
---|
3 | * Log Gamma function |
---|
4 | * |
---|
5 | */ |
---|
6 | /* lgamma() |
---|
7 | * |
---|
8 | * Natural logarithm of gamma function |
---|
9 | * |
---|
10 | * |
---|
11 | * |
---|
12 | * SYNOPSIS: |
---|
13 | * |
---|
14 | * double x, y, lgamma(); |
---|
15 | * extern int sgngam; |
---|
16 | * |
---|
17 | * y = lgamma( x ); |
---|
18 | * |
---|
19 | * |
---|
20 | * |
---|
21 | * DESCRIPTION: |
---|
22 | * |
---|
23 | * Returns the base e (2.718...) logarithm of the absolute |
---|
24 | * value of the gamma function of the argument. |
---|
25 | * The sign (+1 or -1) of the gamma function is returned in a |
---|
26 | * global (extern) variable named sgngam. |
---|
27 | * |
---|
28 | * For arguments greater than 13, the logarithm of the gamma |
---|
29 | * function is approximated by the logarithmic version of |
---|
30 | * Stirling's formula using a polynomial approximation of |
---|
31 | * degree 4. Arguments between -33 and +33 are reduced by |
---|
32 | * recurrence to the interval [2,3] of a rational approximation. |
---|
33 | * The cosecant reflection formula is employed for arguments |
---|
34 | * less than -33. |
---|
35 | * |
---|
36 | * Arguments greater than MAXLGM return MAXNUM and an error |
---|
37 | * message. MAXLGM = 2.035093e36 for DEC |
---|
38 | * arithmetic or 2.556348e305 for IEEE arithmetic. |
---|
39 | * |
---|
40 | * |
---|
41 | * |
---|
42 | * ACCURACY: |
---|
43 | * |
---|
44 | * |
---|
45 | * arithmetic domain # trials peak rms |
---|
46 | * DEC 0, 3 7000 5.2e-17 1.3e-17 |
---|
47 | * DEC 2.718, 2.035e36 5000 3.9e-17 9.9e-18 |
---|
48 | * IEEE 0, 3 28000 5.4e-16 1.1e-16 |
---|
49 | * IEEE 2.718, 2.556e305 40000 3.5e-16 8.3e-17 |
---|
50 | * The error criterion was relative when the function magnitude |
---|
51 | * was greater than one but absolute when it was less than one. |
---|
52 | * |
---|
53 | * The following test used the relative error criterion, though |
---|
54 | * at certain points the relative error could be much higher than |
---|
55 | * indicated. |
---|
56 | * IEEE -200, -4 10000 4.8e-16 1.3e-16 |
---|
57 | * |
---|
58 | */ |
---|
59 | |
---|
60 | /* |
---|
61 | Cephes Math Library Release 2.8: June, 2000 |
---|
62 | Copyright 1984, 1987, 1989, 1992, 2000 by Stephen L. Moshier |
---|
63 | */ |
---|
64 | |
---|
65 | |
---|
66 | double lgamma( double ); |
---|
67 | |
---|
68 | double lgamma( double x) { |
---|
69 | |
---|
70 | #if FLOAT_SIZE > 4 |
---|
71 | double p, q, u, w, z; |
---|
72 | int i; |
---|
73 | int sgngam = 1; |
---|
74 | |
---|
75 | const double LS2PI = 0.91893853320467274178; |
---|
76 | const double MAXLGM = 2.556348e305; |
---|
77 | const double MAXNUM = 1.79769313486231570815E308; |
---|
78 | const double LOGPI = 1.14472988584940017414; |
---|
79 | const double PI = M_PI; |
---|
80 | |
---|
81 | double A[8] = { |
---|
82 | 8.11614167470508450300E-4, |
---|
83 | -5.95061904284301438324E-4, |
---|
84 | 7.93650340457716943945E-4, |
---|
85 | -2.77777777730099687205E-3, |
---|
86 | 8.33333333333331927722E-2, |
---|
87 | 0.0, |
---|
88 | 0.0, |
---|
89 | 0.0 |
---|
90 | }; |
---|
91 | double B[8] = { |
---|
92 | -1.37825152569120859100E3, |
---|
93 | -3.88016315134637840924E4, |
---|
94 | -3.31612992738871184744E5, |
---|
95 | -1.16237097492762307383E6, |
---|
96 | -1.72173700820839662146E6, |
---|
97 | -8.53555664245765465627E5, |
---|
98 | 0.0, |
---|
99 | 0.0 |
---|
100 | }; |
---|
101 | |
---|
102 | double C[8] = { |
---|
103 | /* 1.00000000000000000000E0, */ |
---|
104 | -3.51815701436523470549E2, |
---|
105 | -1.70642106651881159223E4, |
---|
106 | -2.20528590553854454839E5, |
---|
107 | -1.13933444367982507207E6, |
---|
108 | -2.53252307177582951285E6, |
---|
109 | -2.01889141433532773231E6, |
---|
110 | 0.0, |
---|
111 | 0.0 |
---|
112 | }; |
---|
113 | |
---|
114 | sgngam = 1; |
---|
115 | |
---|
116 | if( x < -34.0 ) { |
---|
117 | q = -x; |
---|
118 | w = lanczos_gamma(q); /* note this modifies sgngam! */ |
---|
119 | p = floor(q); |
---|
120 | if( p == q ) { |
---|
121 | lgsing: |
---|
122 | goto loverf; |
---|
123 | } |
---|
124 | i = p; |
---|
125 | if( (i & 1) == 0 ) |
---|
126 | sgngam = -1; |
---|
127 | else |
---|
128 | sgngam = 1; |
---|
129 | z = q - p; |
---|
130 | if( z > 0.5 ) { |
---|
131 | p += 1.0; |
---|
132 | z = p - q; |
---|
133 | } |
---|
134 | z = q * sin( PI * z ); |
---|
135 | if( z == 0.0 ) |
---|
136 | goto lgsing; |
---|
137 | z = LOGPI - log( z ) - w; |
---|
138 | return( z ); |
---|
139 | } |
---|
140 | |
---|
141 | if( x < 13.0 ) { |
---|
142 | z = 1.0; |
---|
143 | p = 0.0; |
---|
144 | u = x; |
---|
145 | while( u >= 3.0 ) { |
---|
146 | p -= 1.0; |
---|
147 | u = x + p; |
---|
148 | z *= u; |
---|
149 | } |
---|
150 | while( u < 2.0 ) { |
---|
151 | if( u == 0.0 ) |
---|
152 | goto lgsing; |
---|
153 | z /= u; |
---|
154 | p += 1.0; |
---|
155 | u = x + p; |
---|
156 | } |
---|
157 | if( z < 0.0 ) { |
---|
158 | sgngam = -1; |
---|
159 | z = -z; |
---|
160 | } |
---|
161 | else |
---|
162 | sgngam = 1; |
---|
163 | if( u == 2.0 ) |
---|
164 | return( log(z) ); |
---|
165 | p -= 2.0; |
---|
166 | x = x + p; |
---|
167 | p = x * polevl( x, B, 5 ) / p1evl( x, C, 6); |
---|
168 | return( log(z) + p ); |
---|
169 | } |
---|
170 | |
---|
171 | if( x > MAXLGM ) { |
---|
172 | loverf: |
---|
173 | return( sgngam * MAXNUM ); |
---|
174 | } |
---|
175 | |
---|
176 | q = ( x - 0.5 ) * log(x) - x + LS2PI; |
---|
177 | if( x > 1.0e8 ) |
---|
178 | return( q ); |
---|
179 | |
---|
180 | p = 1.0/(x*x); |
---|
181 | if( x >= 1000.0 ) |
---|
182 | q += (( 7.9365079365079365079365e-4 * p |
---|
183 | - 2.7777777777777777777778e-3) *p |
---|
184 | + 0.0833333333333333333333) / x; |
---|
185 | else |
---|
186 | q += polevl( p, A, 4 ) / x; |
---|
187 | return( q ); |
---|
188 | #else |
---|
189 | |
---|
190 | double p, q, w, z, xx; |
---|
191 | double nx, tx; |
---|
192 | int i, direction; |
---|
193 | int sgngamf = 1; |
---|
194 | |
---|
195 | double B[8] = { |
---|
196 | 6.055172732649237E-004, |
---|
197 | -1.311620815545743E-003, |
---|
198 | 2.863437556468661E-003, |
---|
199 | -7.366775108654962E-003, |
---|
200 | 2.058355474821512E-002, |
---|
201 | -6.735323259371034E-002, |
---|
202 | 3.224669577325661E-001, |
---|
203 | 4.227843421859038E-001 |
---|
204 | }; |
---|
205 | |
---|
206 | /* log gamma(x+1), -.25 < x < .25 */ |
---|
207 | double C[8] = { |
---|
208 | 1.369488127325832E-001, |
---|
209 | -1.590086327657347E-001, |
---|
210 | 1.692415923504637E-001, |
---|
211 | -2.067882815621965E-001, |
---|
212 | 2.705806208275915E-001, |
---|
213 | -4.006931650563372E-001, |
---|
214 | 8.224670749082976E-001, |
---|
215 | -5.772156501719101E-001 |
---|
216 | }; |
---|
217 | |
---|
218 | /* log( sqrt( 2*pi ) ) */ |
---|
219 | const double LS2PI = 0.91893853320467274178; |
---|
220 | const double MAXLGM = 2.035093e36; |
---|
221 | const double PIINV = 0.318309886183790671538; |
---|
222 | const double MAXNUMF = 3.4028234663852885981170418348451692544e38; |
---|
223 | const double PIF = 3.141592653589793238; |
---|
224 | /* Logarithm of gamma function */ |
---|
225 | |
---|
226 | sgngamf = 1; |
---|
227 | |
---|
228 | xx = x; |
---|
229 | if( xx < 0.0 ) { |
---|
230 | q = -xx; |
---|
231 | w = lgamma(q); /* note this modifies sgngam! */ |
---|
232 | p = floor(q); |
---|
233 | if( p == q ) |
---|
234 | goto loverf; |
---|
235 | i = p; |
---|
236 | |
---|
237 | if( (i & 1) == 0 ) |
---|
238 | sgngamf = -1; |
---|
239 | else |
---|
240 | sgngamf = 1; |
---|
241 | |
---|
242 | z = q - p; |
---|
243 | |
---|
244 | if( z > 0.5 ) { |
---|
245 | p += 1.0; |
---|
246 | z = p - q; |
---|
247 | } |
---|
248 | z = q * sin( PIF * z ); |
---|
249 | if( z == 0.0 ) |
---|
250 | goto loverf; |
---|
251 | z = -log( PIINV*z ) - w; |
---|
252 | return( z ); |
---|
253 | } |
---|
254 | |
---|
255 | if( x < 6.5 ) { |
---|
256 | direction = 0; |
---|
257 | z = 1.0; |
---|
258 | tx = x; |
---|
259 | nx = 0.0; |
---|
260 | if( x >= 1.5 ) { |
---|
261 | while( tx > 2.5 ) { |
---|
262 | nx -= 1.0; |
---|
263 | tx = x + nx; |
---|
264 | z *=tx; |
---|
265 | } |
---|
266 | x += nx - 2.0; |
---|
267 | iv1r5: |
---|
268 | p = x * polevl( x, B, 7 ); |
---|
269 | goto cont; |
---|
270 | } |
---|
271 | if( x >= 1.25 ) { |
---|
272 | z *= x; |
---|
273 | x -= 1.0; /* x + 1 - 2 */ |
---|
274 | direction = 1; |
---|
275 | goto iv1r5; |
---|
276 | } |
---|
277 | if( x >= 0.75 ) { |
---|
278 | x -= 1.0; |
---|
279 | p = x * polevl( x, C, 7 ); |
---|
280 | q = 0.0; |
---|
281 | goto contz; |
---|
282 | } |
---|
283 | while( tx < 1.5 ) { |
---|
284 | if( tx == 0.0 ) |
---|
285 | goto loverf; |
---|
286 | z *=tx; |
---|
287 | nx += 1.0; |
---|
288 | tx = x + nx; |
---|
289 | } |
---|
290 | direction = 1; |
---|
291 | x += nx - 2.0; |
---|
292 | p = x * polevl( x, B, 7 ); |
---|
293 | |
---|
294 | cont: |
---|
295 | if( z < 0.0 ) { |
---|
296 | sgngamf = -1; |
---|
297 | z = -z; |
---|
298 | } |
---|
299 | else { |
---|
300 | sgngamf = 1; |
---|
301 | } |
---|
302 | q = log(z); |
---|
303 | if( direction ) |
---|
304 | q = -q; |
---|
305 | contz: |
---|
306 | return( p + q ); |
---|
307 | } |
---|
308 | |
---|
309 | if( x > MAXLGM ) { |
---|
310 | loverf: |
---|
311 | return( sgngamf * MAXNUMF ); |
---|
312 | } |
---|
313 | |
---|
314 | /* Note, though an asymptotic formula could be used for x >= 3, |
---|
315 | * there is cancellation error in the following if x < 6.5. */ |
---|
316 | q = LS2PI - x; |
---|
317 | q += ( x - 0.5 ) * log(x); |
---|
318 | |
---|
319 | if( x <= 1.0e4 ) { |
---|
320 | z = 1.0/x; |
---|
321 | p = z * z; |
---|
322 | q += (( 6.789774945028216E-004 * p |
---|
323 | - 2.769887652139868E-003 ) * p |
---|
324 | + 8.333316229807355E-002 ) * z; |
---|
325 | } |
---|
326 | return( q ); |
---|
327 | #endif |
---|
328 | } |
---|