1 /* specfunc/hyperg_2F1.c 2 * 3 * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2004 Gerard Jungman 4 * 5 * This program is free software; you can redistribute it and/or modify 6 * it under the terms of the GNU General Public License as published by 7 * the Free Software Foundation; either version 3 of the License, or (at 8 * your option) any later version. 9 * 10 * This program is distributed in the hope that it will be useful, but 11 * WITHOUT ANY WARRANTY; without even the implied warranty of 12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 * General Public License for more details. 14 * 15 * You should have received a copy of the GNU General Public License 16 * along with this program; if not, write to the Free Software 17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. 18 */ 19 20 /* Author: G. Jungman */ 21 22 #include "gsl__config.h" 23 #include "gsl_math.h" 24 #include "gsl_errno.h" 25 #include "gsl_sf_exp.h" 26 #include "gsl_sf_pow_int.h" 27 #include "gsl_sf_gamma.h" 28 #include "gsl_sf_psi.h" 29 #include "gsl_sf_hyperg.h" 30 31 #include "gsl_specfunc__error.h" 32 33 #define locEPS (1000.0*GSL_DBL_EPSILON) 34 35 36 /* Assumes c != negative integer. 37 */ 38 static int 39 hyperg_2F1_series(const double a, const double b, const double c, 40 const double x, 41 gsl_sf_result * result 42 ) 43 { 44 double sum_pos = 1.0; 45 double sum_neg = 0.0; 46 double del_pos = 1.0; 47 double del_neg = 0.0; 48 double del = 1.0; 49 double k = 0.0; 50 int i = 0; 51 52 if(fabs(c) < GSL_DBL_EPSILON) { 53 result->val = 0.0; /* FIXME: ?? */ 54 result->err = 1.0; 55 GSL_ERROR ("error", GSL_EDOM); 56 } 57 58 do { 59 if(++i > 30000) { 60 result->val = sum_pos - sum_neg; 61 result->err = del_pos + del_neg; 62 result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg); 63 result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k)+1.0) * fabs(result->val); 64 GSL_ERROR ("error", GSL_EMAXITER); 65 } 66 del *= (a+k)*(b+k) * x / ((c+k) * (k+1.0)); /* Gauss series */ 67 68 if(del > 0.0) { 69 del_pos = del; 70 sum_pos += del; 71 } 72 else if(del == 0.0) { 73 /* Exact termination (a or b was a negative integer). 74 */ 75 del_pos = 0.0; 76 del_neg = 0.0; 77 break; 78 } 79 else { 80 del_neg = -del; 81 sum_neg -= del; 82 } 83 84 k += 1.0; 85 } while(fabs((del_pos + del_neg)/(sum_pos-sum_neg)) > GSL_DBL_EPSILON); 86 87 result->val = sum_pos - sum_neg; 88 result->err = del_pos + del_neg; 89 result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg); 90 result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k) + 1.0) * fabs(result->val); 91 92 return GSL_SUCCESS; 93 } 94 95 96 /* a = aR + i aI, b = aR - i aI */ 97 static 98 int 99 hyperg_2F1_conj_series(const double aR, const double aI, const double c, 100 double x, 101 gsl_sf_result * result) 102 { 103 if(c == 0.0) { 104 result->val = 0.0; /* FIXME: should be Inf */ 105 result->err = 0.0; 106 GSL_ERROR ("error", GSL_EDOM); 107 } 108 else { 109 double sum_pos = 1.0; 110 double sum_neg = 0.0; 111 double del_pos = 1.0; 112 double del_neg = 0.0; 113 double del = 1.0; 114 double k = 0.0; 115 do { 116 del *= ((aR+k)*(aR+k) + aI*aI)/((k+1.0)*(c+k)) * x; 117 118 if(del >= 0.0) { 119 del_pos = del; 120 sum_pos += del; 121 } 122 else { 123 del_neg = -del; 124 sum_neg -= del; 125 } 126 127 if(k > 30000) { 128 result->val = sum_pos - sum_neg; 129 result->err = del_pos + del_neg; 130 result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg); 131 result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k)+1.0) * fabs(result->val); 132 GSL_ERROR ("error", GSL_EMAXITER); 133 } 134 135 k += 1.0; 136 } while(fabs((del_pos + del_neg)/(sum_pos - sum_neg)) > GSL_DBL_EPSILON); 137 138 result->val = sum_pos - sum_neg; 139 result->err = del_pos + del_neg; 140 result->err += 2.0 * GSL_DBL_EPSILON * (sum_pos + sum_neg); 141 result->err += 2.0 * GSL_DBL_EPSILON * (2.0*sqrt(k) + 1.0) * fabs(result->val); 142 143 return GSL_SUCCESS; 144 } 145 } 146 147 148 /* Luke's rational approximation. The most accesible 149 * discussion is in [Kolbig, CPC 23, 51 (1981)]. 150 * The convergence is supposedly guaranteed for x < 0. 151 * You have to read Luke's books to see this and other 152 * results. Unfortunately, the stability is not so 153 * clear to me, although it seems very efficient when 154 * it works. 155 */ 156 static 157 int 158 hyperg_2F1_luke(const double a, const double b, const double c, 159 const double xin, 160 gsl_sf_result * result) 161 { 162 int stat_iter; 163 const double RECUR_BIG = 1.0e+50; 164 const int nmax = 20000; 165 int n = 3; 166 const double x = -xin; 167 const double x3 = x*x*x; 168 const double t0 = a*b/c; 169 const double t1 = (a+1.0)*(b+1.0)/(2.0*c); 170 const double t2 = (a+2.0)*(b+2.0)/(2.0*(c+1.0)); 171 double F = 1.0; 172 double prec; 173 174 double Bnm3 = 1.0; /* B0 */ 175 double Bnm2 = 1.0 + t1 * x; /* B1 */ 176 double Bnm1 = 1.0 + t2 * x * (1.0 + t1/3.0 * x); /* B2 */ 177 178 double Anm3 = 1.0; /* A0 */ 179 double Anm2 = Bnm2 - t0 * x; /* A1 */ 180 double Anm1 = Bnm1 - t0*(1.0 + t2*x)*x + t0 * t1 * (c/(c+1.0)) * x*x; /* A2 */ 181 182 while(1) { 183 double npam1 = n + a - 1; 184 double npbm1 = n + b - 1; 185 double npcm1 = n + c - 1; 186 double npam2 = n + a - 2; 187 double npbm2 = n + b - 2; 188 double npcm2 = n + c - 2; 189 double tnm1 = 2*n - 1; 190 double tnm3 = 2*n - 3; 191 double tnm5 = 2*n - 5; 192 double n2 = n*n; 193 double F1 = (3.0*n2 + (a+b-6)*n + 2 - a*b - 2*(a+b)) / (2*tnm3*npcm1); 194 double F2 = -(3.0*n2 - (a+b+6)*n + 2 - a*b)*npam1*npbm1/(4*tnm1*tnm3*npcm2*npcm1); 195 double F3 = (npam2*npam1*npbm2*npbm1*(n-a-2)*(n-b-2)) / (8*tnm3*tnm3*tnm5*(n+c-3)*npcm2*npcm1); 196 double E = -npam1*npbm1*(n-c-1) / (2*tnm3*npcm2*npcm1); 197 198 double An = (1.0+F1*x)*Anm1 + (E + F2*x)*x*Anm2 + F3*x3*Anm3; 199 double Bn = (1.0+F1*x)*Bnm1 + (E + F2*x)*x*Bnm2 + F3*x3*Bnm3; 200 double r = An/Bn; 201 202 prec = fabs((F - r)/F); 203 F = r; 204 205 if(prec < GSL_DBL_EPSILON || n > nmax) break; 206 207 if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) { 208 An /= RECUR_BIG; 209 Bn /= RECUR_BIG; 210 Anm1 /= RECUR_BIG; 211 Bnm1 /= RECUR_BIG; 212 Anm2 /= RECUR_BIG; 213 Bnm2 /= RECUR_BIG; 214 Anm3 /= RECUR_BIG; 215 Bnm3 /= RECUR_BIG; 216 } 217 else if(fabs(An) < 1.0/RECUR_BIG || fabs(Bn) < 1.0/RECUR_BIG) { 218 An *= RECUR_BIG; 219 Bn *= RECUR_BIG; 220 Anm1 *= RECUR_BIG; 221 Bnm1 *= RECUR_BIG; 222 Anm2 *= RECUR_BIG; 223 Bnm2 *= RECUR_BIG; 224 Anm3 *= RECUR_BIG; 225 Bnm3 *= RECUR_BIG; 226 } 227 228 n++; 229 Bnm3 = Bnm2; 230 Bnm2 = Bnm1; 231 Bnm1 = Bn; 232 Anm3 = Anm2; 233 Anm2 = Anm1; 234 Anm1 = An; 235 } 236 237 result->val = F; 238 result->err = 2.0 * fabs(prec * F); 239 result->err += 2.0 * GSL_DBL_EPSILON * (n+1.0) * fabs(F); 240 241 /* FIXME: just a hack: there's a lot of shit going on here */ 242 result->err *= 8.0 * (fabs(a) + fabs(b) + 1.0); 243 244 stat_iter = (n >= nmax ? GSL_EMAXITER : GSL_SUCCESS ); 245 246 return stat_iter; 247 } 248 249 250 /* Luke's rational approximation for the 251 * case a = aR + i aI, b = aR - i aI. 252 */ 253 static 254 int 255 hyperg_2F1_conj_luke(const double aR, const double aI, const double c, 256 const double xin, 257 gsl_sf_result * result) 258 { 259 int stat_iter; 260 const double RECUR_BIG = 1.0e+50; 261 const int nmax = 10000; 262 int n = 3; 263 const double x = -xin; 264 const double x3 = x*x*x; 265 const double atimesb = aR*aR + aI*aI; 266 const double apb = 2.0*aR; 267 const double t0 = atimesb/c; 268 const double t1 = (atimesb + apb + 1.0)/(2.0*c); 269 const double t2 = (atimesb + 2.0*apb + 4.0)/(2.0*(c+1.0)); 270 double F = 1.0; 271 double prec; 272 273 double Bnm3 = 1.0; /* B0 */ 274 double Bnm2 = 1.0 + t1 * x; /* B1 */ 275 double Bnm1 = 1.0 + t2 * x * (1.0 + t1/3.0 * x); /* B2 */ 276 277 double Anm3 = 1.0; /* A0 */ 278 double Anm2 = Bnm2 - t0 * x; /* A1 */ 279 double Anm1 = Bnm1 - t0*(1.0 + t2*x)*x + t0 * t1 * (c/(c+1.0)) * x*x; /* A2 */ 280 281 while(1) { 282 double nm1 = n - 1; 283 double nm2 = n - 2; 284 double npam1_npbm1 = atimesb + nm1*apb + nm1*nm1; 285 double npam2_npbm2 = atimesb + nm2*apb + nm2*nm2; 286 double npcm1 = nm1 + c; 287 double npcm2 = nm2 + c; 288 double tnm1 = 2*n - 1; 289 double tnm3 = 2*n - 3; 290 double tnm5 = 2*n - 5; 291 double n2 = n*n; 292 double F1 = (3.0*n2 + (apb-6)*n + 2 - atimesb - 2*apb) / (2*tnm3*npcm1); 293 double F2 = -(3.0*n2 - (apb+6)*n + 2 - atimesb)*npam1_npbm1/(4*tnm1*tnm3*npcm2*npcm1); 294 double F3 = (npam2_npbm2*npam1_npbm1*(nm2*nm2 - nm2*apb + atimesb)) / (8*tnm3*tnm3*tnm5*(n+c-3)*npcm2*npcm1); 295 double E = -npam1_npbm1*(n-c-1) / (2*tnm3*npcm2*npcm1); 296 297 double An = (1.0+F1*x)*Anm1 + (E + F2*x)*x*Anm2 + F3*x3*Anm3; 298 double Bn = (1.0+F1*x)*Bnm1 + (E + F2*x)*x*Bnm2 + F3*x3*Bnm3; 299 double r = An/Bn; 300 301 prec = fabs(F - r)/fabs(F); 302 F = r; 303 304 if(prec < GSL_DBL_EPSILON || n > nmax) break; 305 306 if(fabs(An) > RECUR_BIG || fabs(Bn) > RECUR_BIG) { 307 An /= RECUR_BIG; 308 Bn /= RECUR_BIG; 309 Anm1 /= RECUR_BIG; 310 Bnm1 /= RECUR_BIG; 311 Anm2 /= RECUR_BIG; 312 Bnm2 /= RECUR_BIG; 313 Anm3 /= RECUR_BIG; 314 Bnm3 /= RECUR_BIG; 315 } 316 else if(fabs(An) < 1.0/RECUR_BIG || fabs(Bn) < 1.0/RECUR_BIG) { 317 An *= RECUR_BIG; 318 Bn *= RECUR_BIG; 319 Anm1 *= RECUR_BIG; 320 Bnm1 *= RECUR_BIG; 321 Anm2 *= RECUR_BIG; 322 Bnm2 *= RECUR_BIG; 323 Anm3 *= RECUR_BIG; 324 Bnm3 *= RECUR_BIG; 325 } 326 327 n++; 328 Bnm3 = Bnm2; 329 Bnm2 = Bnm1; 330 Bnm1 = Bn; 331 Anm3 = Anm2; 332 Anm2 = Anm1; 333 Anm1 = An; 334 } 335 336 result->val = F; 337 result->err = 2.0 * fabs(prec * F); 338 result->err += 2.0 * GSL_DBL_EPSILON * (n+1.0) * fabs(F); 339 340 /* FIXME: see above */ 341 result->err *= 8.0 * (fabs(aR) + fabs(aI) + 1.0); 342 343 stat_iter = (n >= nmax ? GSL_EMAXITER : GSL_SUCCESS ); 344 345 return stat_iter; 346 } 347 348 349 /* Do the reflection described in [Moshier, p. 334]. 350 * Assumes a,b,c != neg integer. 351 */ 352 static 353 int 354 hyperg_2F1_reflect(const double a, const double b, const double c, 355 const double x, gsl_sf_result * result) 356 { 357 const double d = c - a - b; 358 const int intd = floor(d+0.5); 359 const int d_integer = ( fabs(d - intd) < locEPS ); 360 361 if(d_integer) { 362 const double ln_omx = log(1.0 - x); 363 const double ad = fabs(d); 364 int stat_F2 = GSL_SUCCESS; 365 double sgn_2; 366 gsl_sf_result F1; 367 gsl_sf_result F2; 368 double d1, d2; 369 gsl_sf_result lng_c; 370 gsl_sf_result lng_ad2; 371 gsl_sf_result lng_bd2; 372 int stat_ad2; 373 int stat_bd2; 374 375 if(d >= 0.0) { 376 d1 = d; 377 d2 = 0.0; 378 } 379 else { 380 d1 = 0.0; 381 d2 = d; 382 } 383 384 stat_ad2 = gsl_sf_lngamma_e(a+d2, &lng_ad2); 385 stat_bd2 = gsl_sf_lngamma_e(b+d2, &lng_bd2); 386 (void) gsl_sf_lngamma_e(c, &lng_c); 387 388 /* Evaluate F1. 389 */ 390 if(ad < GSL_DBL_EPSILON) { 391 /* d = 0 */ 392 F1.val = 0.0; 393 F1.err = 0.0; 394 } 395 else { 396 gsl_sf_result lng_ad; 397 gsl_sf_result lng_ad1; 398 gsl_sf_result lng_bd1; 399 int stat_ad = gsl_sf_lngamma_e(ad, &lng_ad); 400 int stat_ad1 = gsl_sf_lngamma_e(a+d1, &lng_ad1); 401 int stat_bd1 = gsl_sf_lngamma_e(b+d1, &lng_bd1); 402 403 if(stat_ad1 == GSL_SUCCESS && stat_bd1 == GSL_SUCCESS && stat_ad == GSL_SUCCESS) { 404 /* Gamma functions in the denominator are ok. 405 * Proceed with evaluation. 406 */ 407 int i; 408 double sum1 = 1.0; 409 double term = 1.0; 410 double ln_pre1_val = lng_ad.val + lng_c.val + d2*ln_omx - lng_ad1.val - lng_bd1.val; 411 double ln_pre1_err = lng_ad.err + lng_c.err + lng_ad1.err + lng_bd1.err + GSL_DBL_EPSILON * fabs(ln_pre1_val); 412 int stat_e; 413 414 /* Do F1 sum. 415 */ 416 for(i=1; i<ad; i++) { 417 int j = i-1; 418 term *= (a + d2 + j) * (b + d2 + j) / (1.0 + d2 + j) / i * (1.0-x); 419 sum1 += term; 420 } 421 422 stat_e = gsl_sf_exp_mult_err_e(ln_pre1_val, ln_pre1_err, 423 sum1, GSL_DBL_EPSILON*fabs(sum1), 424 &F1); 425 if(stat_e == GSL_EOVRFLW) { 426 OVERFLOW_ERROR(result); 427 } 428 } 429 else { 430 /* Gamma functions in the denominator were not ok. 431 * So the F1 term is zero. 432 */ 433 F1.val = 0.0; 434 F1.err = 0.0; 435 } 436 } /* end F1 evaluation */ 437 438 439 /* Evaluate F2. 440 */ 441 if(stat_ad2 == GSL_SUCCESS && stat_bd2 == GSL_SUCCESS) { 442 /* Gamma functions in the denominator are ok. 443 * Proceed with evaluation. 444 */ 445 const int maxiter = 2000; 446 double psi_1 = -M_EULER; 447 gsl_sf_result psi_1pd; 448 gsl_sf_result psi_apd1; 449 gsl_sf_result psi_bpd1; 450 int stat_1pd = gsl_sf_psi_e(1.0 + ad, &psi_1pd); 451 int stat_apd1 = gsl_sf_psi_e(a + d1, &psi_apd1); 452 int stat_bpd1 = gsl_sf_psi_e(b + d1, &psi_bpd1); 453 int stat_dall = GSL_ERROR_SELECT_3(stat_1pd, stat_apd1, stat_bpd1); 454 455 double psi_val = psi_1 + psi_1pd.val - psi_apd1.val - psi_bpd1.val - ln_omx; 456 double psi_err = psi_1pd.err + psi_apd1.err + psi_bpd1.err + GSL_DBL_EPSILON*fabs(psi_val); 457 double fact = 1.0; 458 double sum2_val = psi_val; 459 double sum2_err = psi_err; 460 double ln_pre2_val = lng_c.val + d1*ln_omx - lng_ad2.val - lng_bd2.val; 461 double ln_pre2_err = lng_c.err + lng_ad2.err + lng_bd2.err + GSL_DBL_EPSILON * fabs(ln_pre2_val); 462 int stat_e; 463 464 int j; 465 466 /* Do F2 sum. 467 */ 468 for(j=1; j<maxiter; j++) { 469 /* values for psi functions use recurrence; Abramowitz+Stegun 6.3.5 */ 470 double term1 = 1.0/(double)j + 1.0/(ad+j); 471 double term2 = 1.0/(a+d1+j-1.0) + 1.0/(b+d1+j-1.0); 472 double delta = 0.0; 473 psi_val += term1 - term2; 474 psi_err += GSL_DBL_EPSILON * (fabs(term1) + fabs(term2)); 475 fact *= (a+d1+j-1.0)*(b+d1+j-1.0)/((ad+j)*j) * (1.0-x); 476 delta = fact * psi_val; 477 sum2_val += delta; 478 sum2_err += fabs(fact * psi_err) + GSL_DBL_EPSILON*fabs(delta); 479 if(fabs(delta) < GSL_DBL_EPSILON * fabs(sum2_val)) break; 480 } 481 482 if(j == maxiter) stat_F2 = GSL_EMAXITER; 483 484 if(sum2_val == 0.0) { 485 F2.val = 0.0; 486 F2.err = 0.0; 487 } 488 else { 489 stat_e = gsl_sf_exp_mult_err_e(ln_pre2_val, ln_pre2_err, 490 sum2_val, sum2_err, 491 &F2); 492 if(stat_e == GSL_EOVRFLW) { 493 result->val = 0.0; 494 result->err = 0.0; 495 GSL_ERROR ("error", GSL_EOVRFLW); 496 } 497 } 498 stat_F2 = GSL_ERROR_SELECT_2(stat_F2, stat_dall); 499 } 500 else { 501 /* Gamma functions in the denominator not ok. 502 * So the F2 term is zero. 503 */ 504 F2.val = 0.0; 505 F2.err = 0.0; 506 } /* end F2 evaluation */ 507 508 sgn_2 = ( GSL_IS_ODD(intd) ? -1.0 : 1.0 ); 509 result->val = F1.val + sgn_2 * F2.val; 510 result->err = F1.err + F2. err; 511 result->err += 2.0 * GSL_DBL_EPSILON * (fabs(F1.val) + fabs(F2.val)); 512 result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val); 513 return stat_F2; 514 } 515 else { 516 /* d not an integer */ 517 518 gsl_sf_result pre1, pre2; 519 double sgn1, sgn2; 520 gsl_sf_result F1, F2; 521 522 /* These gamma functions appear in the denominator, so we 523 * catch their harmless domain errors and set the terms to zero. 524 */ 525 gsl_sf_result ln_g1ca, ln_g1cb, ln_g2a, ln_g2b; 526 double sgn_g1ca, sgn_g1cb, sgn_g2a, sgn_g2b; 527 int stat_1ca = gsl_sf_lngamma_sgn_e(c-a, &ln_g1ca, &sgn_g1ca); 528 int stat_1cb = gsl_sf_lngamma_sgn_e(c-b, &ln_g1cb, &sgn_g1cb); 529 int stat_2a = gsl_sf_lngamma_sgn_e(a, &ln_g2a, &sgn_g2a); 530 int stat_2b = gsl_sf_lngamma_sgn_e(b, &ln_g2b, &sgn_g2b); 531 int ok1 = (stat_1ca == GSL_SUCCESS && stat_1cb == GSL_SUCCESS); 532 int ok2 = (stat_2a == GSL_SUCCESS && stat_2b == GSL_SUCCESS); 533 534 gsl_sf_result ln_gc, ln_gd, ln_gmd; 535 double sgn_gc, sgn_gd, sgn_gmd; 536 gsl_sf_lngamma_sgn_e( c, &ln_gc, &sgn_gc); 537 gsl_sf_lngamma_sgn_e( d, &ln_gd, &sgn_gd); 538 gsl_sf_lngamma_sgn_e(-d, &ln_gmd, &sgn_gmd); 539 540 sgn1 = sgn_gc * sgn_gd * sgn_g1ca * sgn_g1cb; 541 sgn2 = sgn_gc * sgn_gmd * sgn_g2a * sgn_g2b; 542 543 if(ok1 && ok2) { 544 double ln_pre1_val = ln_gc.val + ln_gd.val - ln_g1ca.val - ln_g1cb.val; 545 double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val - ln_g2b.val + d*log(1.0-x); 546 double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err; 547 double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err + ln_g2b.err; 548 if(ln_pre1_val < GSL_LOG_DBL_MAX && ln_pre2_val < GSL_LOG_DBL_MAX) { 549 gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1); 550 gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2); 551 pre1.val *= sgn1; 552 pre2.val *= sgn2; 553 } 554 else { 555 OVERFLOW_ERROR(result); 556 } 557 } 558 else if(ok1 && !ok2) { 559 double ln_pre1_val = ln_gc.val + ln_gd.val - ln_g1ca.val - ln_g1cb.val; 560 double ln_pre1_err = ln_gc.err + ln_gd.err + ln_g1ca.err + ln_g1cb.err; 561 if(ln_pre1_val < GSL_LOG_DBL_MAX) { 562 gsl_sf_exp_err_e(ln_pre1_val, ln_pre1_err, &pre1); 563 pre1.val *= sgn1; 564 pre2.val = 0.0; 565 pre2.err = 0.0; 566 } 567 else { 568 OVERFLOW_ERROR(result); 569 } 570 } 571 else if(!ok1 && ok2) { 572 double ln_pre2_val = ln_gc.val + ln_gmd.val - ln_g2a.val - ln_g2b.val + d*log(1.0-x); 573 double ln_pre2_err = ln_gc.err + ln_gmd.err + ln_g2a.err + ln_g2b.err; 574 if(ln_pre2_val < GSL_LOG_DBL_MAX) { 575 pre1.val = 0.0; 576 pre1.err = 0.0; 577 gsl_sf_exp_err_e(ln_pre2_val, ln_pre2_err, &pre2); 578 pre2.val *= sgn2; 579 } 580 else { 581 OVERFLOW_ERROR(result); 582 } 583 } 584 else { 585 pre1.val = 0.0; 586 pre2.val = 0.0; 587 UNDERFLOW_ERROR(result); 588 } 589 590 (void) hyperg_2F1_series( a, b, 1.0-d, 1.0-x, &F1); 591 (void) hyperg_2F1_series(c-a, c-b, 1.0+d, 1.0-x, &F2); 592 593 result->val = pre1.val*F1.val + pre2.val*F2.val; 594 result->err = fabs(pre1.val*F1.err) + fabs(pre2.val*F2.err); 595 result->err += fabs(pre1.err*F1.val) + fabs(pre2.err*F2.val); 596 result->err += 2.0 * GSL_DBL_EPSILON * (fabs(pre1.val*F1.val) + fabs(pre2.val*F2.val)); 597 result->err += 2.0 * GSL_DBL_EPSILON * fabs(result->val); 598 599 return GSL_SUCCESS; 600 } 601 } 602 603 604 static int pow_omx(const double x, const double p, gsl_sf_result * result) 605 { 606 double ln_omx; 607 double ln_result; 608 if(fabs(x) < GSL_ROOT5_DBL_EPSILON) { 609 ln_omx = -x*(1.0 + x*(1.0/2.0 + x*(1.0/3.0 + x/4.0 + x*x/5.0))); 610 } 611 else { 612 ln_omx = log(1.0-x); 613 } 614 ln_result = p * ln_omx; 615 return gsl_sf_exp_err_e(ln_result, GSL_DBL_EPSILON * fabs(ln_result), result); 616 } 617 618 619 /*-*-*-*-*-*-*-*-*-*-*-* Functions with Error Codes *-*-*-*-*-*-*-*-*-*-*-*/ 620 621 int 622 gsl_sf_hyperg_2F1_e(double a, double b, const double c, 623 const double x, 624 gsl_sf_result * result) 625 { 626 const double d = c - a - b; 627 const double rinta = floor(a + 0.5); 628 const double rintb = floor(b + 0.5); 629 const double rintc = floor(c + 0.5); 630 const int a_neg_integer = ( a < 0.0 && fabs(a - rinta) < locEPS ); 631 const int b_neg_integer = ( b < 0.0 && fabs(b - rintb) < locEPS ); 632 const int c_neg_integer = ( c < 0.0 && fabs(c - rintc) < locEPS ); 633 634 result->val = 0.0; 635 result->err = 0.0; 636 637 if(x < -1.0 || 1.0 <= x) { 638 DOMAIN_ERROR(result); 639 } 640 641 if(c_neg_integer) { 642 if(! (a_neg_integer && a > c + 0.1)) DOMAIN_ERROR(result); 643 if(! (b_neg_integer && b > c + 0.1)) DOMAIN_ERROR(result); 644 } 645 646 if(fabs(c-b) < locEPS || fabs(c-a) < locEPS) { 647 return pow_omx(x, d, result); /* (1-x)^(c-a-b) */ 648 } 649 650 if(a >= 0.0 && b >= 0.0 && c >=0.0 && x >= 0.0 && x < 0.995) { 651 /* Series has all positive definite 652 * terms and x is not close to 1. 653 */ 654 return hyperg_2F1_series(a, b, c, x, result); 655 } 656 657 if(fabs(a) < 10.0 && fabs(b) < 10.0) { 658 /* a and b are not too large, so we attempt 659 * variations on the series summation. 660 */ 661 if(a_neg_integer) { 662 return hyperg_2F1_series(rinta, b, c, x, result); 663 } 664 if(b_neg_integer) { 665 return hyperg_2F1_series(a, rintb, c, x, result); 666 } 667 668 if(x < -0.25) { 669 return hyperg_2F1_luke(a, b, c, x, result); 670 } 671 else if(x < 0.5) { 672 return hyperg_2F1_series(a, b, c, x, result); 673 } 674 else { 675 if(fabs(c) > 10.0) { 676 return hyperg_2F1_series(a, b, c, x, result); 677 } 678 else { 679 return hyperg_2F1_reflect(a, b, c, x, result); 680 } 681 } 682 } 683 else { 684 /* Either a or b or both large. 685 * Introduce some new variables ap,bp so that bp is 686 * the larger in magnitude. 687 */ 688 double bp; 689 if(fabs(a) > fabs(b)) { 690 bp = a; 691 } 692 else { 693 bp = b; 694 } 695 696 if(x < 0.0) { 697 /* What the hell, maybe Luke will converge. 698 */ 699 return hyperg_2F1_luke(a, b, c, x, result); 700 } 701 702 if(GSL_MAX_DBL(fabs(a),1.0)*fabs(bp)*fabs(x) < 2.0*fabs(c)) { 703 /* If c is large enough or x is small enough, 704 * we can attempt the series anyway. 705 */ 706 return hyperg_2F1_series(a, b, c, x, result); 707 } 708 709 if(fabs(bp*bp*x*x) < 0.001*fabs(bp) && fabs(a) < 10.0) { 710 /* The famous but nearly worthless "large b" asymptotic. 711 */ 712 int stat = gsl_sf_hyperg_1F1_e(a, c, bp*x, result); 713 result->err = 0.001 * fabs(result->val); 714 return stat; 715 } 716 717 /* We give up. */ 718 result->val = 0.0; 719 result->err = 0.0; 720 GSL_ERROR ("error", GSL_EUNIMPL); 721 } 722 } 723 724 725 int 726 gsl_sf_hyperg_2F1_conj_e(const double aR, const double aI, const double c, 727 const double x, 728 gsl_sf_result * result) 729 { 730 const double ax = fabs(x); 731 const double rintc = floor(c + 0.5); 732 const int c_neg_integer = ( c < 0.0 && fabs(c - rintc) < locEPS ); 733 734 result->val = 0.0; 735 result->err = 0.0; 736 737 if(ax >= 1.0 || c_neg_integer || c == 0.0) { 738 DOMAIN_ERROR(result); 739 } 740 741 if( (ax < 0.25 && fabs(aR) < 20.0 && fabs(aI) < 20.0) 742 || (c > 0.0 && x > 0.0) 743 ) { 744 return hyperg_2F1_conj_series(aR, aI, c, x, result); 745 } 746 else if(fabs(aR) < 10.0 && fabs(aI) < 10.0) { 747 if(x < -0.25) { 748 return hyperg_2F1_conj_luke(aR, aI, c, x, result); 749 } 750 else { 751 return hyperg_2F1_conj_series(aR, aI, c, x, result); 752 } 753 } 754 else { 755 if(x < 0.0) { 756 /* What the hell, maybe Luke will converge. 757 */ 758 return hyperg_2F1_conj_luke(aR, aI, c, x, result); 759 } 760 761 /* Give up. */ 762 result->val = 0.0; 763 result->err = 0.0; 764 GSL_ERROR ("error", GSL_EUNIMPL); 765 } 766 } 767 768 769 int 770 gsl_sf_hyperg_2F1_renorm_e(const double a, const double b, const double c, 771 const double x, 772 gsl_sf_result * result 773 ) 774 { 775 const double rinta = floor(a + 0.5); 776 const double rintb = floor(b + 0.5); 777 const double rintc = floor(c + 0.5); 778 const int a_neg_integer = ( a < 0.0 && fabs(a - rinta) < locEPS ); 779 const int b_neg_integer = ( b < 0.0 && fabs(b - rintb) < locEPS ); 780 const int c_neg_integer = ( c < 0.0 && fabs(c - rintc) < locEPS ); 781 782 if(c_neg_integer) { 783 if((a_neg_integer && a > c+0.1) || (b_neg_integer && b > c+0.1)) { 784 /* 2F1 terminates early */ 785 result->val = 0.0; 786 result->err = 0.0; 787 return GSL_SUCCESS; 788 } 789 else { 790 /* 2F1 does not terminate early enough, so something survives */ 791 /* [Abramowitz+Stegun, 15.1.2] */ 792 gsl_sf_result g1, g2, g3, g4, g5; 793 double s1, s2, s3, s4, s5; 794 int stat = 0; 795 stat += gsl_sf_lngamma_sgn_e(a-c+1, &g1, &s1); 796 stat += gsl_sf_lngamma_sgn_e(b-c+1, &g2, &s2); 797 stat += gsl_sf_lngamma_sgn_e(a, &g3, &s3); 798 stat += gsl_sf_lngamma_sgn_e(b, &g4, &s4); 799 stat += gsl_sf_lngamma_sgn_e(-c+2, &g5, &s5); 800 if(stat != 0) { 801 DOMAIN_ERROR(result); 802 } 803 else { 804 gsl_sf_result F; 805 int stat_F = gsl_sf_hyperg_2F1_e(a-c+1, b-c+1, -c+2, x, &F); 806 double ln_pre_val = g1.val + g2.val - g3.val - g4.val - g5.val; 807 double ln_pre_err = g1.err + g2.err + g3.err + g4.err + g5.err; 808 double sg = s1 * s2 * s3 * s4 * s5; 809 int stat_e = gsl_sf_exp_mult_err_e(ln_pre_val, ln_pre_err, 810 sg * F.val, F.err, 811 result); 812 return GSL_ERROR_SELECT_2(stat_e, stat_F); 813 } 814 } 815 } 816 else { 817 /* generic c */ 818 gsl_sf_result F; 819 gsl_sf_result lng; 820 double sgn; 821 int stat_g = gsl_sf_lngamma_sgn_e(c, &lng, &sgn); 822 int stat_F = gsl_sf_hyperg_2F1_e(a, b, c, x, &F); 823 int stat_e = gsl_sf_exp_mult_err_e(-lng.val, lng.err, 824 sgn*F.val, F.err, 825 result); 826 return GSL_ERROR_SELECT_3(stat_e, stat_F, stat_g); 827 } 828 } 829 830 831 int 832 gsl_sf_hyperg_2F1_conj_renorm_e(const double aR, const double aI, const double c, 833 const double x, 834 gsl_sf_result * result 835 ) 836 { 837 const double rintc = floor(c + 0.5); 838 const double rinta = floor(aR + 0.5); 839 const int a_neg_integer = ( aR < 0.0 && fabs(aR-rinta) < locEPS && aI == 0.0); 840 const int c_neg_integer = ( c < 0.0 && fabs(c - rintc) < locEPS ); 841 842 if(c_neg_integer) { 843 if(a_neg_integer && aR > c+0.1) { 844 /* 2F1 terminates early */ 845 result->val = 0.0; 846 result->err = 0.0; 847 return GSL_SUCCESS; 848 } 849 else { 850 /* 2F1 does not terminate early enough, so something survives */ 851 /* [Abramowitz+Stegun, 15.1.2] */ 852 gsl_sf_result g1, g2; 853 gsl_sf_result g3; 854 gsl_sf_result a1, a2; 855 int stat = 0; 856 stat += gsl_sf_lngamma_complex_e(aR-c+1, aI, &g1, &a1); 857 stat += gsl_sf_lngamma_complex_e(aR, aI, &g2, &a2); 858 stat += gsl_sf_lngamma_e(-c+2.0, &g3); 859 if(stat != 0) { 860 DOMAIN_ERROR(result); 861 } 862 else { 863 gsl_sf_result F; 864 int stat_F = gsl_sf_hyperg_2F1_conj_e(aR-c+1, aI, -c+2, x, &F); 865 double ln_pre_val = 2.0*(g1.val - g2.val) - g3.val; 866 double ln_pre_err = 2.0 * (g1.err + g2.err) + g3.err; 867 int stat_e = gsl_sf_exp_mult_err_e(ln_pre_val, ln_pre_err, 868 F.val, F.err, 869 result); 870 return GSL_ERROR_SELECT_2(stat_e, stat_F); 871 } 872 } 873 } 874 else { 875 /* generic c */ 876 gsl_sf_result F; 877 gsl_sf_result lng; 878 double sgn; 879 int stat_g = gsl_sf_lngamma_sgn_e(c, &lng, &sgn); 880 int stat_F = gsl_sf_hyperg_2F1_conj_e(aR, aI, c, x, &F); 881 int stat_e = gsl_sf_exp_mult_err_e(-lng.val, lng.err, 882 sgn*F.val, F.err, 883 result); 884 return GSL_ERROR_SELECT_3(stat_e, stat_F, stat_g); 885 } 886 } 887 888 889 /*-*-*-*-*-*-*-*-*-* Functions w/ Natural Prototypes *-*-*-*-*-*-*-*-*-*-*/ 890 891 #include "gsl_specfunc__eval.h" 892 893 double gsl_sf_hyperg_2F1(double a, double b, double c, double x) 894 { 895 EVAL_RESULT(gsl_sf_hyperg_2F1_e(a, b, c, x, &result)); 896 } 897 898 double gsl_sf_hyperg_2F1_conj(double aR, double aI, double c, double x) 899 { 900 EVAL_RESULT(gsl_sf_hyperg_2F1_conj_e(aR, aI, c, x, &result)); 901 } 902 903 double gsl_sf_hyperg_2F1_renorm(double a, double b, double c, double x) 904 { 905 EVAL_RESULT(gsl_sf_hyperg_2F1_renorm_e(a, b, c, x, &result)); 906 } 907 908 double gsl_sf_hyperg_2F1_conj_renorm(double aR, double aI, double c, double x) 909 { 910 EVAL_RESULT(gsl_sf_hyperg_2F1_conj_renorm_e(aR, aI, c, x, &result)); 911 } 912