[cae6ce6] | 1 | /* lgamma.c |
---|
[38daeec] | 2 | * |
---|
[cae6ce6] | 3 | * Log Gamma function |
---|
[38daeec] | 4 | * |
---|
| 5 | */ |
---|
[cae6ce6] | 6 | /* lgamma() |
---|
[38daeec] | 7 | * |
---|
| 8 | * Natural logarithm of gamma function |
---|
| 9 | * |
---|
| 10 | * |
---|
| 11 | * |
---|
| 12 | * SYNOPSIS: |
---|
| 13 | * |
---|
[cae6ce6] | 14 | * double x, y, lgamma(); |
---|
[38daeec] | 15 | * extern int sgngam; |
---|
| 16 | * |
---|
[cae6ce6] | 17 | * y = lgamma( x ); |
---|
[38daeec] | 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 | |
---|
[cae6ce6] | 66 | double lgamma( double ); |
---|
[38daeec] | 67 | |
---|
[cae6ce6] | 68 | double lgamma( double x) { |
---|
[38daeec] | 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 | } |
---|