1 /*
2 vcflib C++ library for parsing and manipulating VCF files
3
4 Copyright © 2010-2020 Erik Garrison
5 Copyright © 2020 Pjotr Prins
6
7 This software is published under the MIT License. See the LICENSE file.
8 */
9
10 # include <cstdlib>
11 # include <iostream>
12 # include <iomanip>
13 # include <cmath>
14 # include <ctime>
15 # include <cstring>
16
17 using namespace std;
18
19 # include "cdflib.hpp"
20
21 //****************************************************************************80
22
algdiv(double * a,double * b)23 double algdiv ( double *a, double *b )
24
25 //****************************************************************************80
26 //
27 // Purpose:
28 //
29 // ALGDIV computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B.
30 //
31 // Discussion:
32 //
33 // In this algorithm, DEL(X) is the function defined by
34 //
35 // ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI )
36 // + DEL(X).
37 //
38 // Parameters:
39 //
40 // Input, double *A, *B, define the arguments.
41 //
42 // Output, double ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)).
43 //
44 {
45 static double algdiv;
46 static double c;
47 static double c0 = 0.833333333333333e-01;
48 static double c1 = -0.277777777760991e-02;
49 static double c2 = 0.793650666825390e-03;
50 static double c3 = -0.595202931351870e-03;
51 static double c4 = 0.837308034031215e-03;
52 static double c5 = -0.165322962780713e-02;
53 static double d;
54 static double h;
55 static double s11;
56 static double s3;
57 static double s5;
58 static double s7;
59 static double s9;
60 static double t;
61 static double T1;
62 static double u;
63 static double v;
64 static double w;
65 static double x;
66 static double x2;
67
68 if ( *b <= *a )
69 {
70 h = *b / *a;
71 c = 1.0e0 / ( 1.0e0 + h );
72 x = h / ( 1.0e0 + h );
73 d = *a + ( *b - 0.5e0 );
74 }
75 else
76 {
77 h = *a / *b;
78 c = h / ( 1.0e0 + h );
79 x = 1.0e0 / ( 1.0e0 + h );
80 d = *b + ( *a - 0.5e0 );
81 }
82 //
83 // SET SN = (1 - X**N)/(1 - X)
84 //
85 x2 = x * x;
86 s3 = 1.0e0 + ( x + x2 );
87 s5 = 1.0e0 + ( x + x2 * s3 );
88 s7 = 1.0e0 + ( x + x2 * s5 );
89 s9 = 1.0e0 + ( x + x2 * s7 );
90 s11 = 1.0e0 + ( x + x2 * s9 );
91 //
92 // SET W = DEL(B) - DEL(A + B)
93 //
94 t = pow ( 1.0e0 / *b, 2.0 );
95
96 w = (((( c5 * s11 * t
97 + c4 * s9 ) * t
98 + c3 * s7 ) * t
99 + c2 * s5 ) * t
100 + c1 * s3 ) * t
101 + c0;
102
103 w *= ( c / *b );
104 //
105 // Combine the results.
106 //
107 T1 = *a / *b;
108 u = d * alnrel ( &T1 );
109 v = *a * ( log ( *b ) - 1.0e0 );
110
111 if ( v < u )
112 {
113 algdiv = w - v - u;
114 }
115 else
116 {
117 algdiv = w - u - v;
118 }
119 return algdiv;
120 }
121 //****************************************************************************80
122
alnrel(double * a)123 double alnrel ( double *a )
124
125 //****************************************************************************80
126 //
127 // Purpose:
128 //
129 // ALNREL evaluates the function ln ( 1 + A ).
130 //
131 // Modified:
132 //
133 // 17 November 2006
134 //
135 // Reference:
136 //
137 // Armido DiDinato, Alfred Morris,
138 // Algorithm 708:
139 // Significant Digit Computation of the Incomplete Beta Function Ratios,
140 // ACM Transactions on Mathematical Software,
141 // Volume 18, 1993, pages 360-373.
142 //
143 // Parameters:
144 //
145 // Input, double *A, the argument.
146 //
147 // Output, double ALNREL, the value of ln ( 1 + A ).
148 //
149 {
150 double alnrel;
151 static double p1 = -0.129418923021993e+01;
152 static double p2 = 0.405303492862024e+00;
153 static double p3 = -0.178874546012214e-01;
154 static double q1 = -0.162752256355323e+01;
155 static double q2 = 0.747811014037616e+00;
156 static double q3 = -0.845104217945565e-01;
157 double t;
158 double t2;
159 double w;
160 double x;
161
162 if ( fabs ( *a ) <= 0.375e0 )
163 {
164 t = *a / ( *a + 2.0e0 );
165 t2 = t * t;
166 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)
167 / (((q3*t2+q2)*t2+q1)*t2+1.0e0);
168 alnrel = 2.0e0 * t * w;
169 }
170 else
171 {
172 x = 1.0e0 + *a;
173 alnrel = log ( x );
174 }
175 return alnrel;
176 }
177 //****************************************************************************80
178
apser(double * a,double * b,double * x,double * eps)179 double apser ( double *a, double *b, double *x, double *eps )
180
181 //****************************************************************************80
182 //
183 // Purpose:
184 //
185 // APSER computes the incomplete beta ratio I(SUB(1-X))(B,A).
186 //
187 // Discussion:
188 //
189 // APSER is used only for cases where
190 //
191 // A <= min ( EPS, EPS * B ),
192 // B * X <= 1, and
193 // X <= 0.5.
194 //
195 // Parameters:
196 //
197 // Input, double *A, *B, *X, the parameters of teh
198 // incomplete beta ratio.
199 //
200 // Input, double *EPS, a tolerance.
201 //
202 // Output, double APSER, the computed value of the
203 // incomplete beta ratio.
204 //
205 {
206 static double g = 0.577215664901533e0;
207 static double apser,aj,bx,c,j,s,t,tol;
208
209 bx = *b**x;
210 t = *x-bx;
211 if(*b**eps > 2.e-2) goto S10;
212 c = log(*x)+psi(b)+g+t;
213 goto S20;
214 S10:
215 c = log(bx)+g+t;
216 S20:
217 tol = 5.0e0**eps*fabs(c);
218 j = 1.0e0;
219 s = 0.0e0;
220 S30:
221 j = j + 1.0e0;
222 t = t * (*x-bx/j);
223 aj = t/j;
224 s = s + aj;
225 if(fabs(aj) > tol) goto S30;
226 apser = -(*a*(c+s));
227 return apser;
228 }
229 //****************************************************************************80
230
bcorr(double * a0,double * b0)231 double bcorr ( double *a0, double *b0 )
232
233 //****************************************************************************80
234 //
235 // Purpose:
236 //
237 // BCORR evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0).
238 //
239 // Discussion:
240 //
241 // The function DEL(A) is a remainder term that is used in the expression:
242 //
243 // ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A )
244 // - A + 0.5 * ln ( 2 * PI ) + DEL ( A ),
245 //
246 // or, in other words, DEL ( A ) is defined as:
247 //
248 // DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A )
249 // + A + 0.5 * ln ( 2 * PI ).
250 //
251 // Parameters:
252 //
253 // Input, double *A0, *B0, the arguments.
254 // It is assumed that 8 <= A0 and 8 <= B0.
255 //
256 // Output, double *BCORR, the value of the function.
257 //
258 {
259 static double c0 = 0.833333333333333e-01;
260 static double c1 = -0.277777777760991e-02;
261 static double c2 = 0.793650666825390e-03;
262 static double c3 = -0.595202931351870e-03;
263 static double c4 = 0.837308034031215e-03;
264 static double c5 = -0.165322962780713e-02;
265 static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2;
266
267 a = fifdmin1 ( *a0, *b0 );
268 b = fifdmax1 ( *a0, *b0 );
269 h = a / b;
270 c = h / ( 1.0e0 + h );
271 x = 1.0e0 / ( 1.0e0 + h );
272 x2 = x * x;
273 //
274 // SET SN = (1 - X**N)/(1 - X)
275 //
276 s3 = 1.0e0 + ( x + x2 );
277 s5 = 1.0e0 + ( x + x2 * s3 );
278 s7 = 1.0e0 + ( x + x2 * s5 );
279 s9 = 1.0e0 + ( x + x2 * s7 );
280 s11 = 1.0e0 + ( x + x2 * s9 );
281 //
282 // SET W = DEL(B) - DEL(A + B)
283 //
284 t = pow ( 1.0e0 / b, 2.0 );
285
286 w = (((( c5 * s11 * t + c4
287 * s9 ) * t + c3
288 * s7 ) * t + c2
289 * s5 ) * t + c1
290 * s3 ) * t + c0;
291 w *= ( c / b );
292 //
293 // COMPUTE DEL(A) + W
294 //
295 t = pow ( 1.0e0 / a, 2.0 );
296
297 bcorr = ((((( c5 * t + c4 )
298 * t + c3 )
299 * t + c2 )
300 * t + c1 )
301 * t + c0 ) / a + w;
302 return bcorr;
303 }
304 //****************************************************************************80
305
beta(double a,double b)306 double beta ( double a, double b )
307
308 //****************************************************************************80
309 //
310 // Purpose:
311 //
312 // BETA evaluates the beta function.
313 //
314 // Modified:
315 //
316 // 03 December 1999
317 //
318 // Author:
319 //
320 // John Burkardt
321 //
322 // Parameters:
323 //
324 // Input, double A, B, the arguments of the beta function.
325 //
326 // Output, double BETA, the value of the beta function.
327 //
328 {
329 return ( exp ( beta_log ( &a, &b ) ) );
330 }
331 //****************************************************************************80
332
beta_asym(double * a,double * b,double * lambda,double * eps)333 double beta_asym ( double *a, double *b, double *lambda, double *eps )
334
335 //****************************************************************************80
336 //
337 // Purpose:
338 //
339 // BETA_ASYM computes an asymptotic expansion for IX(A,B), for large A and B.
340 //
341 // Parameters:
342 //
343 // Input, double *A, *B, the parameters of the function.
344 // A and B should be nonnegative. It is assumed that both A and B
345 // are greater than or equal to 15.
346 //
347 // Input, double *LAMBDA, the value of ( A + B ) * Y - B.
348 // It is assumed that 0 <= LAMBDA.
349 //
350 // Input, double *EPS, the tolerance.
351 //
352 {
353 static double e0 = 1.12837916709551e0;
354 static double e1 = .353553390593274e0;
355 static int num = 20;
356 //
357 // NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
358 // ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
359 // THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
360 // E0 = 2/SQRT(PI)
361 // E1 = 2**(-3/2)
362 //
363 static int K3 = 1;
364 static double value;
365 static double bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0,
366 z2,zn,znm1;
367 static int i,im1,imj,j,m,mm1,mmj,n,np1;
368 static double a0[21],b0[21],c[21],d[21],T1,T2;
369
370 value = 0.0e0;
371 if(*a >= *b) goto S10;
372 h = *a/ *b;
373 r0 = 1.0e0/(1.0e0+h);
374 r1 = (*b-*a)/ *b;
375 w0 = 1.0e0/sqrt(*a*(1.0e0+h));
376 goto S20;
377 S10:
378 h = *b/ *a;
379 r0 = 1.0e0/(1.0e0+h);
380 r1 = (*b-*a)/ *a;
381 w0 = 1.0e0/sqrt(*b*(1.0e0+h));
382 S20:
383 T1 = -(*lambda/ *a);
384 T2 = *lambda/ *b;
385 f = *a*rlog1(&T1)+*b*rlog1(&T2);
386 t = exp(-f);
387 if(t == 0.0e0) return value;
388 z0 = sqrt(f);
389 z = 0.5e0*(z0/e1);
390 z2 = f+f;
391 a0[0] = 2.0e0/3.0e0*r1;
392 c[0] = -(0.5e0*a0[0]);
393 d[0] = -c[0];
394 j0 = 0.5e0/e0 * error_fc ( &K3, &z0 );
395 j1 = e1;
396 sum = j0+d[0]*w0*j1;
397 s = 1.0e0;
398 h2 = h*h;
399 hn = 1.0e0;
400 w = w0;
401 znm1 = z;
402 zn = z2;
403 for ( n = 2; n <= num; n += 2 )
404 {
405 hn = h2*hn;
406 a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0);
407 np1 = n+1;
408 s += hn;
409 a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0);
410 for ( i = n; i <= np1; i++ )
411 {
412 r = -(0.5e0*((double)i+1.0e0));
413 b0[0] = r*a0[0];
414 for ( m = 2; m <= i; m++ )
415 {
416 bsum = 0.0e0;
417 mm1 = m-1;
418 for ( j = 1; j <= mm1; j++ )
419 {
420 mmj = m-j;
421 bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]);
422 }
423 b0[m-1] = r*a0[m-1]+bsum/(double)m;
424 }
425 c[i-1] = b0[i-1]/((double)i+1.0e0);
426 dsum = 0.0e0;
427 im1 = i-1;
428 for ( j = 1; j <= im1; j++ )
429 {
430 imj = i-j;
431 dsum += (d[imj-1]*c[j-1]);
432 }
433 d[i-1] = -(dsum+c[i-1]);
434 }
435 j0 = e1*znm1+((double)n-1.0e0)*j0;
436 j1 = e1*zn+(double)n*j1;
437 znm1 = z2*znm1;
438 zn = z2*zn;
439 w = w0*w;
440 t0 = d[n-1]*w*j0;
441 w = w0*w;
442 t1 = d[np1-1]*w*j1;
443 sum += (t0+t1);
444 if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80;
445 }
446 S80:
447 u = exp(-bcorr(a,b));
448 value = e0*t*u*sum;
449 return value;
450 }
451 //****************************************************************************80
452
beta_frac(double * a,double * b,double * x,double * y,double * lambda,double * eps)453 double beta_frac ( double *a, double *b, double *x, double *y, double *lambda,
454 double *eps )
455
456 //****************************************************************************80
457 //
458 // Purpose:
459 //
460 // BETA_FRAC evaluates a continued fraction expansion for IX(A,B).
461 //
462 // Parameters:
463 //
464 // Input, double *A, *B, the parameters of the function.
465 // A and B should be nonnegative. It is assumed that both A and
466 // B are greater than 1.
467 //
468 // Input, double *X, *Y. X is the argument of the
469 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
470 //
471 // Input, double *LAMBDA, the value of ( A + B ) * Y - B.
472 //
473 // Input, double *EPS, a tolerance.
474 //
475 // Output, double BETA_FRAC, the value of the continued
476 // fraction approximation for IX(A,B).
477 //
478 {
479 static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1;
480
481 bfrac = beta_rcomp ( a, b, x, y );
482
483 if ( bfrac == 0.0e0 )
484 {
485 return bfrac;
486 }
487
488 c = 1.0e0+*lambda;
489 c0 = *b/ *a;
490 c1 = 1.0e0+1.0e0/ *a;
491 yp1 = *y+1.0e0;
492 n = 0.0e0;
493 p = 1.0e0;
494 s = *a+1.0e0;
495 an = 0.0e0;
496 bn = anp1 = 1.0e0;
497 bnp1 = c/c1;
498 r = c1/c;
499 //
500 // CONTINUED FRACTION CALCULATION
501 //
502 S10:
503 n = n + 1.0e0;
504 t = n/ *a;
505 w = n*(*b-n)**x;
506 e = *a/s;
507 alpha = p*(p+c0)*e*e*(w**x);
508 e = (1.0e0+t)/(c1+t+t);
509 beta = n+w/s+e*(c+n*yp1);
510 p = 1.0e0+t;
511 s += 2.0e0;
512 //
513 // UPDATE AN, BN, ANP1, AND BNP1
514 //
515 t = alpha*an+beta*anp1;
516 an = anp1;
517 anp1 = t;
518 t = alpha*bn+beta*bnp1;
519 bn = bnp1;
520 bnp1 = t;
521 r0 = r;
522 r = anp1/bnp1;
523
524 if ( fabs(r-r0) <= (*eps) * r )
525 {
526 goto S20;
527 }
528 //
529 // RESCALE AN, BN, ANP1, AND BNP1
530 //
531 an /= bnp1;
532 bn /= bnp1;
533 anp1 = r;
534 bnp1 = 1.0e0;
535 goto S10;
536 //
537 // TERMINATION
538 //
539 S20:
540 bfrac = bfrac * r;
541 return bfrac;
542 }
543 //****************************************************************************80
544
beta_grat(double * a,double * b,double * x,double * y,double * w,double * eps,int * ierr)545 void beta_grat ( double *a, double *b, double *x, double *y, double *w,
546 double *eps,int *ierr )
547
548 //****************************************************************************80
549 //
550 // Purpose:
551 //
552 // BETA_GRAT evaluates an asymptotic expansion for IX(A,B).
553 //
554 // Parameters:
555 //
556 // Input, double *A, *B, the parameters of the function.
557 // A and B should be nonnegative. It is assumed that 15 <= A
558 // and B <= 1, and that B is less than A.
559 //
560 // Input, double *X, *Y. X is the argument of the
561 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
562 //
563 // Input/output, double *W, a quantity to which the
564 // result of the computation is to be added on output.
565 //
566 // Input, double *EPS, a tolerance.
567 //
568 // Output, int *IERR, an error flag, which is 0 if no error
569 // was detected.
570 //
571 {
572 static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z;
573 static int i,n,nm1;
574 static double c[30],d[30],T1;
575
576 bm1 = *b-0.5e0-0.5e0;
577 nu = *a+0.5e0*bm1;
578 if(*y > 0.375e0) goto S10;
579 T1 = -*y;
580 lnx = alnrel(&T1);
581 goto S20;
582 S10:
583 lnx = log(*x);
584 S20:
585 z = -(nu*lnx);
586 if(*b*z == 0.0e0) goto S70;
587 //
588 // COMPUTATION OF THE EXPANSION
589 // SET R = EXP(-Z)*Z**B/GAMMA(B)
590 //
591 r = *b*(1.0e0+gam1(b))*exp(*b*log(z));
592 r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx));
593 u = algdiv(b,a)+*b*log(nu);
594 u = r*exp(-u);
595 if(u == 0.0e0) goto S70;
596 gamma_rat1 ( b, &z, &r, &p, &q, eps );
597 v = 0.25e0*pow(1.0e0/nu,2.0);
598 t2 = 0.25e0*lnx*lnx;
599 l = *w/u;
600 j = q/r;
601 sum = j;
602 t = cn = 1.0e0;
603 n2 = 0.0e0;
604 for ( n = 1; n <= 30; n++ )
605 {
606 bp2n = *b+n2;
607 j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v;
608 n2 = n2 + 2.0e0;
609 t *= t2;
610 cn /= (n2*(n2+1.0e0));
611 c[n-1] = cn;
612 s = 0.0e0;
613 if(n == 1) goto S40;
614 nm1 = n-1;
615 coef = *b-(double)n;
616 for ( i = 1; i <= nm1; i++ )
617 {
618 s = s + (coef*c[i-1]*d[n-i-1]);
619 coef = coef + *b;
620 }
621 S40:
622 d[n-1] = bm1*cn+s/(double)n;
623 dj = d[n-1]*j;
624 sum = sum + dj;
625 if(sum <= 0.0e0) goto S70;
626 if(fabs(dj) <= *eps*(sum+l)) goto S60;
627 }
628 S60:
629 //
630 // ADD THE RESULTS TO W
631 //
632 *ierr = 0;
633 *w = *w + (u*sum);
634 return;
635 S70:
636 //
637 // THE EXPANSION CANNOT BE COMPUTED
638 //
639 *ierr = 1;
640 return;
641 }
642 //****************************************************************************80
643
beta_inc(double * a,double * b,double * x,double * y,double * w,double * w1,int * ierr)644 void beta_inc ( double *a, double *b, double *x, double *y, double *w,
645 double *w1, int *ierr )
646
647 //****************************************************************************80
648 //
649 // Purpose:
650 //
651 // BETA_INC evaluates the incomplete beta function IX(A,B).
652 //
653 // Author:
654 //
655 // Alfred H Morris, Jr,
656 // Naval Surface Weapons Center,
657 // Dahlgren, Virginia.
658 //
659 // Parameters:
660 //
661 // Input, double *A, *B, the parameters of the function.
662 // A and B should be nonnegative.
663 //
664 // Input, double *X, *Y. X is the argument of the
665 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
666 //
667 // Output, double *W, *W1, the values of IX(A,B) and
668 // 1-IX(A,B).
669 //
670 // Output, int *IERR, the error flag.
671 // 0, no error was detected.
672 // 1, A or B is negative;
673 // 2, A = B = 0;
674 // 3, X < 0 or 1 < X;
675 // 4, Y < 0 or 1 < Y;
676 // 5, X + Y /= 1;
677 // 6, X = A = 0;
678 // 7, Y = B = 0.
679 //
680 {
681 static int K1 = 1;
682 static double a0,b0,eps,lambda,t,x0,y0,z;
683 static int ierr1,ind,n;
684 static double T2,T3,T4,T5;
685 //
686 // EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
687 // NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
688 //
689 eps = dpmpar ( &K1 );
690 *w = *w1 = 0.0e0;
691 if(*a < 0.0e0 || *b < 0.0e0) goto S270;
692 if(*a == 0.0e0 && *b == 0.0e0) goto S280;
693 if(*x < 0.0e0 || *x > 1.0e0) goto S290;
694 if(*y < 0.0e0 || *y > 1.0e0) goto S300;
695 z = *x+*y-0.5e0-0.5e0;
696 if(fabs(z) > 3.0e0*eps) goto S310;
697 *ierr = 0;
698 if(*x == 0.0e0) goto S210;
699 if(*y == 0.0e0) goto S230;
700 if(*a == 0.0e0) goto S240;
701 if(*b == 0.0e0) goto S220;
702 eps = fifdmax1(eps,1.e-15);
703 if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260;
704 ind = 0;
705 a0 = *a;
706 b0 = *b;
707 x0 = *x;
708 y0 = *y;
709 if(fifdmin1(a0,b0) > 1.0e0) goto S40;
710 //
711 // PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
712 //
713 if(*x <= 0.5e0) goto S10;
714 ind = 1;
715 a0 = *b;
716 b0 = *a;
717 x0 = *y;
718 y0 = *x;
719 S10:
720 if(b0 < fifdmin1(eps,eps*a0)) goto S90;
721 if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100;
722 if(fifdmax1(a0,b0) > 1.0e0) goto S20;
723 if(a0 >= fifdmin1(0.2e0,b0)) goto S110;
724 if(pow(x0,a0) <= 0.9e0) goto S110;
725 if(x0 >= 0.3e0) goto S120;
726 n = 20;
727 goto S140;
728 S20:
729 if(b0 <= 1.0e0) goto S110;
730 if(x0 >= 0.3e0) goto S120;
731 if(x0 >= 0.1e0) goto S30;
732 if(pow(x0*b0,a0) <= 0.7e0) goto S110;
733 S30:
734 if(b0 > 15.0e0) goto S150;
735 n = 20;
736 goto S140;
737 S40:
738 //
739 // PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
740 //
741 if(*a > *b) goto S50;
742 lambda = *a-(*a+*b)**x;
743 goto S60;
744 S50:
745 lambda = (*a+*b)**y-*b;
746 S60:
747 if(lambda >= 0.0e0) goto S70;
748 ind = 1;
749 a0 = *b;
750 b0 = *a;
751 x0 = *y;
752 y0 = *x;
753 lambda = fabs(lambda);
754 S70:
755 if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110;
756 if(b0 < 40.0e0) goto S160;
757 if(a0 > b0) goto S80;
758 if(a0 <= 100.0e0) goto S130;
759 if(lambda > 0.03e0*a0) goto S130;
760 goto S200;
761 S80:
762 if(b0 <= 100.0e0) goto S130;
763 if(lambda > 0.03e0*b0) goto S130;
764 goto S200;
765 S90:
766 //
767 // EVALUATION OF THE APPROPRIATE ALGORITHM
768 //
769 *w = fpser(&a0,&b0,&x0,&eps);
770 *w1 = 0.5e0+(0.5e0-*w);
771 goto S250;
772 S100:
773 *w1 = apser(&a0,&b0,&x0,&eps);
774 *w = 0.5e0+(0.5e0-*w1);
775 goto S250;
776 S110:
777 *w = beta_pser(&a0,&b0,&x0,&eps);
778 *w1 = 0.5e0+(0.5e0-*w);
779 goto S250;
780 S120:
781 *w1 = beta_pser(&b0,&a0,&y0,&eps);
782 *w = 0.5e0+(0.5e0-*w1);
783 goto S250;
784 S130:
785 T2 = 15.0e0*eps;
786 *w = beta_frac ( &a0,&b0,&x0,&y0,&lambda,&T2 );
787 *w1 = 0.5e0+(0.5e0-*w);
788 goto S250;
789 S140:
790 *w1 = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );
791 b0 = b0 + (double)n;
792 S150:
793 T3 = 15.0e0*eps;
794 beta_grat (&b0,&a0,&y0,&x0,w1,&T3,&ierr1);
795 *w = 0.5e0+(0.5e0-*w1);
796 goto S250;
797 S160:
798 n = ( int ) b0;
799 b0 -= (double)n;
800 if(b0 != 0.0e0) goto S170;
801 n -= 1;
802 b0 = 1.0e0;
803 S170:
804 *w = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );
805 if(x0 > 0.7e0) goto S180;
806 *w = *w + beta_pser(&a0,&b0,&x0,&eps);
807 *w1 = 0.5e0+(0.5e0-*w);
808 goto S250;
809 S180:
810 if(a0 > 15.0e0) goto S190;
811 n = 20;
812 *w = *w + beta_up ( &a0, &b0, &x0, &y0, &n, &eps );
813 a0 = a0 + (double)n;
814 S190:
815 T4 = 15.0e0*eps;
816 beta_grat ( &a0, &b0, &x0, &y0, w, &T4, &ierr1 );
817 *w1 = 0.5e0+(0.5e0-*w);
818 goto S250;
819 S200:
820 T5 = 100.0e0*eps;
821 *w = beta_asym ( &a0, &b0, &lambda, &T5 );
822 *w1 = 0.5e0+(0.5e0-*w);
823 goto S250;
824 S210:
825 //
826 // TERMINATION OF THE PROCEDURE
827 //
828 if(*a == 0.0e0) goto S320;
829 S220:
830 *w = 0.0e0;
831 *w1 = 1.0e0;
832 return;
833 S230:
834 if(*b == 0.0e0) goto S330;
835 S240:
836 *w = 1.0e0;
837 *w1 = 0.0e0;
838 return;
839 S250:
840 if(ind == 0) return;
841 t = *w;
842 *w = *w1;
843 *w1 = t;
844 return;
845 S260:
846 //
847 // PROCEDURE FOR A AND B .LT. 1.E-3*EPS
848 //
849 *w = *b/(*a+*b);
850 *w1 = *a/(*a+*b);
851 return;
852 S270:
853 //
854 // ERROR RETURN
855 //
856 *ierr = 1;
857 return;
858 S280:
859 *ierr = 2;
860 return;
861 S290:
862 *ierr = 3;
863 return;
864 S300:
865 *ierr = 4;
866 return;
867 S310:
868 *ierr = 5;
869 return;
870 S320:
871 *ierr = 6;
872 return;
873 S330:
874 *ierr = 7;
875 return;
876 }
877 //****************************************************************************80
878
beta_inc_values(int * n_data,double * a,double * b,double * x,double * fx)879 void beta_inc_values ( int *n_data, double *a, double *b, double *x,
880 double *fx )
881
882 //****************************************************************************80
883 //
884 // Purpose:
885 //
886 // BETA_INC_VALUES returns some values of the incomplete Beta function.
887 //
888 // Discussion:
889 //
890 // The incomplete Beta function may be written
891 //
892 // BETA_INC(A,B,X) = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT
893 // / Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT
894 //
895 // Thus,
896 //
897 // BETA_INC(A,B,0.0) = 0.0
898 // BETA_INC(A,B,1.0) = 1.0
899 //
900 // Note that in Mathematica, the expressions:
901 //
902 // BETA[A,B] = Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT
903 // BETA[X,A,B] = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT
904 //
905 // and thus, to evaluate the incomplete Beta function requires:
906 //
907 // BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B]
908 //
909 // Modified:
910 //
911 // 09 June 2004
912 //
913 // Author:
914 //
915 // John Burkardt
916 //
917 // Reference:
918 //
919 // Milton Abramowitz and Irene Stegun,
920 // Handbook of Mathematical Functions,
921 // US Department of Commerce, 1964.
922 //
923 // Karl Pearson,
924 // Tables of the Incomplete Beta Function,
925 // Cambridge University Press, 1968.
926 //
927 // Parameters:
928 //
929 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
930 // first call. On each call, the routine increments N_DATA by 1, and
931 // returns the corresponding data; when there is no more data, the
932 // output value of N_DATA will be 0 again.
933 //
934 // Output, double *A, *B, the parameters of the function.
935 //
936 // Output, double *X, the argument of the function.
937 //
938 // Output, double *FX, the value of the function.
939 //
940 {
941 # define N_MAX 30
942
943 double a_vec[N_MAX] = {
944 0.5E+00, 0.5E+00, 0.5E+00, 1.0E+00,
945 1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00,
946 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
947 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
948 2.0E+00, 5.5E+00, 10.0E+00, 10.0E+00,
949 10.0E+00, 10.0E+00, 20.0E+00, 20.0E+00,
950 20.0E+00, 20.0E+00, 20.0E+00, 30.0E+00,
951 30.0E+00, 40.0E+00 };
952 double b_vec[N_MAX] = {
953 0.5E+00, 0.5E+00, 0.5E+00, 0.5E+00,
954 0.5E+00, 0.5E+00, 0.5E+00, 1.0E+00,
955 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
956 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
957 2.0E+00, 5.0E+00, 0.5E+00, 5.0E+00,
958 5.0E+00, 10.0E+00, 5.0E+00, 10.0E+00,
959 10.0E+00, 20.0E+00, 20.0E+00, 10.0E+00,
960 10.0E+00, 20.0E+00 };
961 double fx_vec[N_MAX] = {
962 0.0637686E+00, 0.2048328E+00, 1.0000000E+00, 0.0E+00,
963 0.0050126E+00, 0.0513167E+00, 0.2928932E+00, 0.5000000E+00,
964 0.028E+00, 0.104E+00, 0.216E+00, 0.352E+00,
965 0.500E+00, 0.648E+00, 0.784E+00, 0.896E+00,
966 0.972E+00, 0.4361909E+00, 0.1516409E+00, 0.0897827E+00,
967 1.0000000E+00, 0.5000000E+00, 0.4598773E+00, 0.2146816E+00,
968 0.9507365E+00, 0.5000000E+00, 0.8979414E+00, 0.2241297E+00,
969 0.7586405E+00, 0.7001783E+00 };
970 double x_vec[N_MAX] = {
971 0.01E+00, 0.10E+00, 1.00E+00, 0.0E+00,
972 0.01E+00, 0.10E+00, 0.50E+00, 0.50E+00,
973 0.1E+00, 0.2E+00, 0.3E+00, 0.4E+00,
974 0.5E+00, 0.6E+00, 0.7E+00, 0.8E+00,
975 0.9E+00, 0.50E+00, 0.90E+00, 0.50E+00,
976 1.00E+00, 0.50E+00, 0.80E+00, 0.60E+00,
977 0.80E+00, 0.50E+00, 0.60E+00, 0.70E+00,
978 0.80E+00, 0.70E+00 };
979
980 if ( *n_data < 0 )
981 {
982 *n_data = 0;
983 }
984
985 *n_data = *n_data + 1;
986
987 if ( N_MAX < *n_data )
988 {
989 *n_data = 0;
990 *a = 0.0E+00;
991 *b = 0.0E+00;
992 *x = 0.0E+00;
993 *fx = 0.0E+00;
994 }
995 else
996 {
997 *a = a_vec[*n_data-1];
998 *b = b_vec[*n_data-1];
999 *x = x_vec[*n_data-1];
1000 *fx = fx_vec[*n_data-1];
1001 }
1002 return;
1003 # undef N_MAX
1004 }
1005 //****************************************************************************80
1006
beta_log(double * a0,double * b0)1007 double beta_log ( double *a0, double *b0 )
1008
1009 //****************************************************************************80
1010 //
1011 // Purpose:
1012 //
1013 // BETA_LOG evaluates the logarithm of the beta function.
1014 //
1015 // Reference:
1016 //
1017 // Armido DiDinato and Alfred Morris,
1018 // Algorithm 708:
1019 // Significant Digit Computation of the Incomplete Beta Function Ratios,
1020 // ACM Transactions on Mathematical Software,
1021 // Volume 18, 1993, pages 360-373.
1022 //
1023 // Parameters:
1024 //
1025 // Input, double *A0, *B0, the parameters of the function.
1026 // A0 and B0 should be nonnegative.
1027 //
1028 // Output, double *BETA_LOG, the value of the logarithm
1029 // of the Beta function.
1030 //
1031 {
1032 static double e = .918938533204673e0;
1033 static double value,a,b,c,h,u,v,w,z;
1034 static int i,n;
1035 static double T1;
1036
1037 a = fifdmin1(*a0,*b0);
1038 b = fifdmax1(*a0,*b0);
1039 if(a >= 8.0e0) goto S100;
1040 if(a >= 1.0e0) goto S20;
1041 //
1042 // PROCEDURE WHEN A .LT. 1
1043 //
1044 if(b >= 8.0e0) goto S10;
1045 T1 = a+b;
1046 value = gamma_log ( &a )+( gamma_log ( &b )- gamma_log ( &T1 ));
1047 return value;
1048 S10:
1049 value = gamma_log ( &a )+algdiv(&a,&b);
1050 return value;
1051 S20:
1052 //
1053 // PROCEDURE WHEN 1 .LE. A .LT. 8
1054 //
1055 if(a > 2.0e0) goto S40;
1056 if(b > 2.0e0) goto S30;
1057 value = gamma_log ( &a )+ gamma_log ( &b )-gsumln(&a,&b);
1058 return value;
1059 S30:
1060 w = 0.0e0;
1061 if(b < 8.0e0) goto S60;
1062 value = gamma_log ( &a )+algdiv(&a,&b);
1063 return value;
1064 S40:
1065 //
1066 // REDUCTION OF A WHEN B .LE. 1000
1067 //
1068 if(b > 1000.0e0) goto S80;
1069 n = ( int ) ( a - 1.0e0 );
1070 w = 1.0e0;
1071 for ( i = 1; i <= n; i++ )
1072 {
1073 a -= 1.0e0;
1074 h = a/b;
1075 w *= (h/(1.0e0+h));
1076 }
1077 w = log(w);
1078 if(b < 8.0e0) goto S60;
1079 value = w+ gamma_log ( &a )+algdiv(&a,&b);
1080 return value;
1081 S60:
1082 //
1083 // REDUCTION OF B WHEN B .LT. 8
1084 //
1085 n = ( int ) ( b - 1.0e0 );
1086 z = 1.0e0;
1087 for ( i = 1; i <= n; i++ )
1088 {
1089 b -= 1.0e0;
1090 z *= (b/(a+b));
1091 }
1092 value = w+log(z)+( gamma_log ( &a )+( gamma_log ( &b )-gsumln(&a,&b)));
1093 return value;
1094 S80:
1095 //
1096 // REDUCTION OF A WHEN B .GT. 1000
1097 //
1098 n = ( int ) ( a - 1.0e0 );
1099 w = 1.0e0;
1100 for ( i = 1; i <= n; i++ )
1101 {
1102 a -= 1.0e0;
1103 w *= (a/(1.0e0+a/b));
1104 }
1105 value = log(w)-(double)n*log(b)+( gamma_log ( &a )+algdiv(&a,&b));
1106 return value;
1107 S100:
1108 //
1109 // PROCEDURE WHEN A .GE. 8
1110 //
1111 w = bcorr(&a,&b);
1112 h = a/b;
1113 c = h/(1.0e0+h);
1114 u = -((a-0.5e0)*log(c));
1115 v = b*alnrel(&h);
1116 if(u <= v) goto S110;
1117 value = -(0.5e0*log(b))+e+w-v-u;
1118 return value;
1119 S110:
1120 value = -(0.5e0*log(b))+e+w-u-v;
1121 return value;
1122 }
1123 //****************************************************************************80
1124
beta_pser(double * a,double * b,double * x,double * eps)1125 double beta_pser ( double *a, double *b, double *x, double *eps )
1126
1127 //****************************************************************************80
1128 //
1129 // Purpose:
1130 //
1131 // BETA_PSER uses a power series expansion to evaluate IX(A,B)(X).
1132 //
1133 // Discussion:
1134 //
1135 // BETA_PSER is used when B <= 1 or B*X <= 0.7.
1136 //
1137 // Parameters:
1138 //
1139 // Input, double *A, *B, the parameters.
1140 //
1141 // Input, double *X, the point where the function
1142 // is to be evaluated.
1143 //
1144 // Input, double *EPS, the tolerance.
1145 //
1146 // Output, double BETA_PSER, the approximate value of IX(A,B)(X).
1147 //
1148 {
1149 static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z;
1150 static int i,m;
1151
1152 bpser = 0.0e0;
1153 if(*x == 0.0e0) return bpser;
1154 //
1155 // COMPUTE THE FACTOR X**A/(A*BETA(A,B))
1156 //
1157 a0 = fifdmin1(*a,*b);
1158 if(a0 < 1.0e0) goto S10;
1159 z = *a*log(*x)-beta_log(a,b);
1160 bpser = exp(z)/ *a;
1161 goto S100;
1162 S10:
1163 b0 = fifdmax1(*a,*b);
1164 if(b0 >= 8.0e0) goto S90;
1165 if(b0 > 1.0e0) goto S40;
1166 //
1167 // PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
1168 //
1169 bpser = pow(*x,*a);
1170 if(bpser == 0.0e0) return bpser;
1171 apb = *a+*b;
1172 if(apb > 1.0e0) goto S20;
1173 z = 1.0e0+gam1(&apb);
1174 goto S30;
1175 S20:
1176 u = *a+*b-1.e0;
1177 z = (1.0e0+gam1(&u))/apb;
1178 S30:
1179 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1180 bpser *= (c*(*b/apb));
1181 goto S100;
1182 S40:
1183 //
1184 // PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
1185 //
1186 u = gamma_ln1 ( &a0 );
1187 m = ( int ) ( b0 - 1.0e0 );
1188 if(m < 1) goto S60;
1189 c = 1.0e0;
1190 for ( i = 1; i <= m; i++ )
1191 {
1192 b0 -= 1.0e0;
1193 c *= (b0/(a0+b0));
1194 }
1195 u = log(c)+u;
1196 S60:
1197 z = *a*log(*x)-u;
1198 b0 -= 1.0e0;
1199 apb = a0+b0;
1200 if(apb > 1.0e0) goto S70;
1201 t = 1.0e0+gam1(&apb);
1202 goto S80;
1203 S70:
1204 u = a0+b0-1.e0;
1205 t = (1.0e0+gam1(&u))/apb;
1206 S80:
1207 bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t;
1208 goto S100;
1209 S90:
1210 //
1211 // PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
1212 //
1213 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1214 z = *a*log(*x)-u;
1215 bpser = a0/ *a*exp(z);
1216 S100:
1217 if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser;
1218 //
1219 // COMPUTE THE SERIES
1220 //
1221 sum = n = 0.0e0;
1222 c = 1.0e0;
1223 tol = *eps/ *a;
1224 S110:
1225 n = n + 1.0e0;
1226 c *= ((0.5e0+(0.5e0-*b/n))**x);
1227 w = c/(*a+n);
1228 sum = sum + w;
1229 if(fabs(w) > tol) goto S110;
1230 bpser *= (1.0e0+*a*sum);
1231 return bpser;
1232 }
1233 //****************************************************************************80
1234
beta_rcomp(double * a,double * b,double * x,double * y)1235 double beta_rcomp ( double *a, double *b, double *x, double *y )
1236
1237 //****************************************************************************80
1238 //
1239 // Purpose:
1240 //
1241 // BETA_RCOMP evaluates X**A * Y**B / Beta(A,B).
1242 //
1243 // Parameters:
1244 //
1245 // Input, double *A, *B, the parameters of the Beta function.
1246 // A and B should be nonnegative.
1247 //
1248 // Input, double *X, *Y, define the numerator of the fraction.
1249 //
1250 // Output, double BETA_RCOMP, the value of X**A * Y**B / Beta(A,B).
1251 //
1252 {
1253 static double Const = .398942280401433e0;
1254 static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1255 static int i,n;
1256 //
1257 // CONST = 1/SQRT(2*PI)
1258 //
1259 static double T1,T2;
1260
1261 brcomp = 0.0e0;
1262 if(*x == 0.0e0 || *y == 0.0e0) return brcomp;
1263 a0 = fifdmin1(*a,*b);
1264 if(a0 >= 8.0e0) goto S130;
1265 if(*x > 0.375e0) goto S10;
1266 lnx = log(*x);
1267 T1 = -*x;
1268 lny = alnrel(&T1);
1269 goto S30;
1270 S10:
1271 if(*y > 0.375e0) goto S20;
1272 T2 = -*y;
1273 lnx = alnrel(&T2);
1274 lny = log(*y);
1275 goto S30;
1276 S20:
1277 lnx = log(*x);
1278 lny = log(*y);
1279 S30:
1280 z = *a*lnx+*b*lny;
1281 if(a0 < 1.0e0) goto S40;
1282 z -= beta_log(a,b);
1283 brcomp = exp(z);
1284 return brcomp;
1285 S40:
1286 //
1287 // PROCEDURE FOR A .LT. 1 OR B .LT. 1
1288 //
1289 b0 = fifdmax1(*a,*b);
1290 if(b0 >= 8.0e0) goto S120;
1291 if(b0 > 1.0e0) goto S70;
1292 //
1293 // ALGORITHM FOR B0 .LE. 1
1294 //
1295 brcomp = exp(z);
1296 if(brcomp == 0.0e0) return brcomp;
1297 apb = *a+*b;
1298 if(apb > 1.0e0) goto S50;
1299 z = 1.0e0+gam1(&apb);
1300 goto S60;
1301 S50:
1302 u = *a+*b-1.e0;
1303 z = (1.0e0+gam1(&u))/apb;
1304 S60:
1305 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1306 brcomp = brcomp*(a0*c)/(1.0e0+a0/b0);
1307 return brcomp;
1308 S70:
1309 //
1310 // ALGORITHM FOR 1 .LT. B0 .LT. 8
1311 //
1312 u = gamma_ln1 ( &a0 );
1313 n = ( int ) ( b0 - 1.0e0 );
1314 if(n < 1) goto S90;
1315 c = 1.0e0;
1316 for ( i = 1; i <= n; i++ )
1317 {
1318 b0 -= 1.0e0;
1319 c *= (b0/(a0+b0));
1320 }
1321 u = log(c)+u;
1322 S90:
1323 z -= u;
1324 b0 -= 1.0e0;
1325 apb = a0+b0;
1326 if(apb > 1.0e0) goto S100;
1327 t = 1.0e0+gam1(&apb);
1328 goto S110;
1329 S100:
1330 u = a0+b0-1.e0;
1331 t = (1.0e0+gam1(&u))/apb;
1332 S110:
1333 brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t;
1334 return brcomp;
1335 S120:
1336 //
1337 // ALGORITHM FOR B0 .GE. 8
1338 //
1339 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1340 brcomp = a0*exp(z-u);
1341 return brcomp;
1342 S130:
1343 //
1344 // PROCEDURE FOR A .GE. 8 AND B .GE. 8
1345 //
1346 if(*a > *b) goto S140;
1347 h = *a/ *b;
1348 x0 = h/(1.0e0+h);
1349 y0 = 1.0e0/(1.0e0+h);
1350 lambda = *a-(*a+*b)**x;
1351 goto S150;
1352 S140:
1353 h = *b/ *a;
1354 x0 = 1.0e0/(1.0e0+h);
1355 y0 = h/(1.0e0+h);
1356 lambda = (*a+*b)**y-*b;
1357 S150:
1358 e = -(lambda/ *a);
1359 if(fabs(e) > 0.6e0) goto S160;
1360 u = rlog1(&e);
1361 goto S170;
1362 S160:
1363 u = e-log(*x/x0);
1364 S170:
1365 e = lambda/ *b;
1366 if(fabs(e) > 0.6e0) goto S180;
1367 v = rlog1(&e);
1368 goto S190;
1369 S180:
1370 v = e-log(*y/y0);
1371 S190:
1372 z = exp(-(*a*u+*b*v));
1373 brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1374 return brcomp;
1375 }
1376 //****************************************************************************80
1377
beta_rcomp1(int * mu,double * a,double * b,double * x,double * y)1378 double beta_rcomp1 ( int *mu, double *a, double *b, double *x, double *y )
1379
1380 //****************************************************************************80
1381 //
1382 // Purpose:
1383 //
1384 // BETA_RCOMP1 evaluates exp(MU) * X**A * Y**B / Beta(A,B).
1385 //
1386 // Parameters:
1387 //
1388 // Input, int MU, ?
1389 //
1390 // Input, double A, B, the parameters of the Beta function.
1391 // A and B should be nonnegative.
1392 //
1393 // Input, double X, Y, ?
1394 //
1395 // Output, double BETA_RCOMP1, the value of
1396 // exp(MU) * X**A * Y**B / Beta(A,B).
1397 //
1398 {
1399 static double Const = .398942280401433e0;
1400 static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1401 static int i,n;
1402 //
1403 // CONST = 1/SQRT(2*PI)
1404 //
1405 static double T1,T2,T3,T4;
1406
1407 a0 = fifdmin1(*a,*b);
1408 if(a0 >= 8.0e0) goto S130;
1409 if(*x > 0.375e0) goto S10;
1410 lnx = log(*x);
1411 T1 = -*x;
1412 lny = alnrel(&T1);
1413 goto S30;
1414 S10:
1415 if(*y > 0.375e0) goto S20;
1416 T2 = -*y;
1417 lnx = alnrel(&T2);
1418 lny = log(*y);
1419 goto S30;
1420 S20:
1421 lnx = log(*x);
1422 lny = log(*y);
1423 S30:
1424 z = *a*lnx+*b*lny;
1425 if(a0 < 1.0e0) goto S40;
1426 z -= beta_log(a,b);
1427 brcmp1 = esum(mu,&z);
1428 return brcmp1;
1429 S40:
1430 //
1431 // PROCEDURE FOR A .LT. 1 OR B .LT. 1
1432 //
1433 b0 = fifdmax1(*a,*b);
1434 if(b0 >= 8.0e0) goto S120;
1435 if(b0 > 1.0e0) goto S70;
1436 //
1437 // ALGORITHM FOR B0 .LE. 1
1438 //
1439 brcmp1 = esum(mu,&z);
1440 if(brcmp1 == 0.0e0) return brcmp1;
1441 apb = *a+*b;
1442 if(apb > 1.0e0) goto S50;
1443 z = 1.0e0+gam1(&apb);
1444 goto S60;
1445 S50:
1446 u = *a+*b-1.e0;
1447 z = (1.0e0+gam1(&u))/apb;
1448 S60:
1449 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1450 brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0);
1451 return brcmp1;
1452 S70:
1453 //
1454 // ALGORITHM FOR 1 .LT. B0 .LT. 8
1455 //
1456 u = gamma_ln1 ( &a0 );
1457 n = ( int ) ( b0 - 1.0e0 );
1458 if(n < 1) goto S90;
1459 c = 1.0e0;
1460 for ( i = 1; i <= n; i++ )
1461 {
1462 b0 -= 1.0e0;
1463 c *= (b0/(a0+b0));
1464 }
1465 u = log(c)+u;
1466 S90:
1467 z -= u;
1468 b0 -= 1.0e0;
1469 apb = a0+b0;
1470 if(apb > 1.0e0) goto S100;
1471 t = 1.0e0+gam1(&apb);
1472 goto S110;
1473 S100:
1474 u = a0+b0-1.e0;
1475 t = (1.0e0+gam1(&u))/apb;
1476 S110:
1477 brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t;
1478 return brcmp1;
1479 S120:
1480 //
1481 // ALGORITHM FOR B0 .GE. 8
1482 //
1483 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1484 T3 = z-u;
1485 brcmp1 = a0*esum(mu,&T3);
1486 return brcmp1;
1487 S130:
1488 //
1489 // PROCEDURE FOR A .GE. 8 AND B .GE. 8
1490 //
1491 if(*a > *b) goto S140;
1492 h = *a/ *b;
1493 x0 = h/(1.0e0+h);
1494 y0 = 1.0e0/(1.0e0+h);
1495 lambda = *a-(*a+*b)**x;
1496 goto S150;
1497 S140:
1498 h = *b/ *a;
1499 x0 = 1.0e0/(1.0e0+h);
1500 y0 = h/(1.0e0+h);
1501 lambda = (*a+*b)**y-*b;
1502 S150:
1503 e = -(lambda/ *a);
1504 if(fabs(e) > 0.6e0) goto S160;
1505 u = rlog1(&e);
1506 goto S170;
1507 S160:
1508 u = e-log(*x/x0);
1509 S170:
1510 e = lambda/ *b;
1511 if(fabs(e) > 0.6e0) goto S180;
1512 v = rlog1(&e);
1513 goto S190;
1514 S180:
1515 v = e-log(*y/y0);
1516 S190:
1517 T4 = -(*a*u+*b*v);
1518 z = esum(mu,&T4);
1519 brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1520 return brcmp1;
1521 }
1522 //****************************************************************************80
1523
beta_up(double * a,double * b,double * x,double * y,int * n,double * eps)1524 double beta_up ( double *a, double *b, double *x, double *y, int *n,
1525 double *eps )
1526
1527 //****************************************************************************80
1528 //
1529 // Purpose:
1530 //
1531 // BETA_UP evaluates IX(A,B) - IX(A+N,B) where N is a positive integer.
1532 //
1533 // Parameters:
1534 //
1535 // Input, double *A, *B, the parameters of the function.
1536 // A and B should be nonnegative.
1537 //
1538 // Input, double *X, *Y, ?
1539 //
1540 // Input, int *N, ?
1541 //
1542 // Input, double *EPS, the tolerance.
1543 //
1544 // Output, double BETA_UP, the value of IX(A,B) - IX(A+N,B).
1545 //
1546 {
1547 static int K1 = 1;
1548 static int K2 = 0;
1549 static double bup,ap1,apb,d,l,r,t,w;
1550 static int i,k,kp1,mu,nm1;
1551 //
1552 // OBTAIN THE SCALING FACTOR EXP(-MU) AND
1553 // EXP(MU)*(X**A*Y**B/BETA(A,B))/A
1554 //
1555 apb = *a+*b;
1556 ap1 = *a+1.0e0;
1557 mu = 0;
1558 d = 1.0e0;
1559 if(*n == 1 || *a < 1.0e0) goto S10;
1560 if(apb < 1.1e0*ap1) goto S10;
1561 mu = ( int ) fabs ( exparg(&K1) );
1562 k = ( int ) exparg ( &K2 );
1563 if(k < mu) mu = k;
1564 t = mu;
1565 d = exp(-t);
1566 S10:
1567 bup = beta_rcomp1 ( &mu, a, b, x, y ) / *a;
1568 if(*n == 1 || bup == 0.0e0) return bup;
1569 nm1 = *n-1;
1570 w = d;
1571 //
1572 // LET K BE THE INDEX OF THE MAXIMUM TERM
1573 //
1574 k = 0;
1575 if(*b <= 1.0e0) goto S50;
1576 if(*y > 1.e-4) goto S20;
1577 k = nm1;
1578 goto S30;
1579 S20:
1580 r = (*b-1.0e0)**x/ *y-*a;
1581 if(r < 1.0e0) goto S50;
1582 t = ( double ) nm1;
1583 k = nm1;
1584 if ( r < t ) k = ( int ) r;
1585 S30:
1586 //
1587 // ADD THE INCREASING TERMS OF THE SERIES
1588 //
1589 for ( i = 1; i <= k; i++ )
1590 {
1591 l = i-1;
1592 d = (apb+l)/(ap1+l)**x*d;
1593 w = w + d;
1594 }
1595 if(k == nm1) goto S70;
1596 S50:
1597 //
1598 // ADD THE REMAINING TERMS OF THE SERIES
1599 //
1600 kp1 = k+1;
1601 for ( i = kp1; i <= nm1; i++ )
1602 {
1603 l = i-1;
1604 d = (apb+l)/(ap1+l)**x*d;
1605 w = w + d;
1606 if(d <= *eps*w) goto S70;
1607 }
1608 S70:
1609 //
1610 // TERMINATE THE PROCEDURE
1611 //
1612 bup *= w;
1613 return bup;
1614 }
1615 //****************************************************************************80
1616
binomial_cdf_values(int * n_data,int * a,double * b,int * x,double * fx)1617 void binomial_cdf_values ( int *n_data, int *a, double *b, int *x, double *fx )
1618
1619 //****************************************************************************80
1620 //
1621 // Purpose:
1622 //
1623 // BINOMIAL_CDF_VALUES returns some values of the binomial CDF.
1624 //
1625 // Discussion:
1626 //
1627 // CDF(X)(A,B) is the probability of at most X successes in A trials,
1628 // given that the probability of success on a single trial is B.
1629 //
1630 // Modified:
1631 //
1632 // 31 May 2004
1633 //
1634 // Author:
1635 //
1636 // John Burkardt
1637 //
1638 // Reference:
1639 //
1640 // Milton Abramowitz and Irene Stegun,
1641 // Handbook of Mathematical Functions,
1642 // US Department of Commerce, 1964.
1643 //
1644 // Daniel Zwillinger,
1645 // CRC Standard Mathematical Tables and Formulae,
1646 // 30th Edition, CRC Press, 1996, pages 651-652.
1647 //
1648 // Parameters:
1649 //
1650 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
1651 // first call. On each call, the routine increments N_DATA by 1, and
1652 // returns the corresponding data; when there is no more data, the
1653 // output value of N_DATA will be 0 again.
1654 //
1655 // Output, int *A, double *B, the parameters of the function.
1656 //
1657 // Output, int *X, the argument of the function.
1658 //
1659 // Output, double *FX, the value of the function.
1660 //
1661 {
1662 # define N_MAX 17
1663
1664 int a_vec[N_MAX] = {
1665 2, 2, 2, 2,
1666 2, 4, 4, 4,
1667 4, 10, 10, 10,
1668 10, 10, 10, 10,
1669 10 };
1670 double b_vec[N_MAX] = {
1671 0.05E+00, 0.05E+00, 0.05E+00, 0.50E+00,
1672 0.50E+00, 0.25E+00, 0.25E+00, 0.25E+00,
1673 0.25E+00, 0.05E+00, 0.10E+00, 0.15E+00,
1674 0.20E+00, 0.25E+00, 0.30E+00, 0.40E+00,
1675 0.50E+00 };
1676 double fx_vec[N_MAX] = {
1677 0.9025E+00, 0.9975E+00, 1.0000E+00, 0.2500E+00,
1678 0.7500E+00, 0.3164E+00, 0.7383E+00, 0.9492E+00,
1679 0.9961E+00, 0.9999E+00, 0.9984E+00, 0.9901E+00,
1680 0.9672E+00, 0.9219E+00, 0.8497E+00, 0.6331E+00,
1681 0.3770E+00 };
1682 int x_vec[N_MAX] = {
1683 0, 1, 2, 0,
1684 1, 0, 1, 2,
1685 3, 4, 4, 4,
1686 4, 4, 4, 4,
1687 4 };
1688
1689 if ( *n_data < 0 )
1690 {
1691 *n_data = 0;
1692 }
1693
1694 *n_data = *n_data + 1;
1695
1696 if ( N_MAX < *n_data )
1697 {
1698 *n_data = 0;
1699 *a = 0;
1700 *b = 0.0E+00;
1701 *x = 0;
1702 *fx = 0.0E+00;
1703 }
1704 else
1705 {
1706 *a = a_vec[*n_data-1];
1707 *b = b_vec[*n_data-1];
1708 *x = x_vec[*n_data-1];
1709 *fx = fx_vec[*n_data-1];
1710 }
1711 return;
1712 # undef N_MAX
1713 }
1714 //****************************************************************************80
1715
cdfbet(int * which,double * p,double * q,double * x,double * y,double * a,double * b,int * status,double * bound)1716 void cdfbet ( int *which, double *p, double *q, double *x, double *y,
1717 double *a, double *b, int *status, double *bound )
1718
1719 //****************************************************************************80
1720 //
1721 // Purpose:
1722 //
1723 // CDFBET evaluates the CDF of the Beta Distribution.
1724 //
1725 // Discussion:
1726 //
1727 // This routine calculates any one parameter of the beta distribution
1728 // given the others.
1729 //
1730 // The value P of the cumulative distribution function is calculated
1731 // directly by code associated with the reference.
1732 //
1733 // Computation of the other parameters involves a seach for a value that
1734 // produces the desired value of P. The search relies on the
1735 // monotonicity of P with respect to the other parameters.
1736 //
1737 // The beta density is proportional to t^(A-1) * (1-t)^(B-1).
1738 //
1739 // Modified:
1740 //
1741 // 09 June 2004
1742 //
1743 // Reference:
1744 //
1745 // Armido DiDinato and Alfred Morris,
1746 // Algorithm 708:
1747 // Significant Digit Computation of the Incomplete Beta Function Ratios,
1748 // ACM Transactions on Mathematical Software,
1749 // Volume 18, 1993, pages 360-373.
1750 //
1751 // Parameters:
1752 //
1753 // Input, int *WHICH, indicates which of the next four argument
1754 // values is to be calculated from the others.
1755 // 1: Calculate P and Q from X, Y, A and B;
1756 // 2: Calculate X and Y from P, Q, A and B;
1757 // 3: Calculate A from P, Q, X, Y and B;
1758 // 4: Calculate B from P, Q, X, Y and A.
1759 //
1760 // Input/output, double *P, the integral from 0 to X of the
1761 // chi-square distribution. Input range: [0, 1].
1762 //
1763 // Input/output, double *Q, equals 1-P. Input range: [0, 1].
1764 //
1765 // Input/output, double *X, the upper limit of integration
1766 // of the beta density. If it is an input value, it should lie in
1767 // the range [0,1]. If it is an output value, it will be searched for
1768 // in the range [0,1].
1769 //
1770 // Input/output, double *Y, equal to 1-X. If it is an input
1771 // value, it should lie in the range [0,1]. If it is an output value,
1772 // it will be searched for in the range [0,1].
1773 //
1774 // Input/output, double *A, the first parameter of the beta
1775 // density. If it is an input value, it should lie in the range
1776 // (0, +infinity). If it is an output value, it will be searched
1777 // for in the range [1D-300,1D300].
1778 //
1779 // Input/output, double *B, the second parameter of the beta
1780 // density. If it is an input value, it should lie in the range
1781 // (0, +infinity). If it is an output value, it will be searched
1782 // for in the range [1D-300,1D300].
1783 //
1784 // Output, int *STATUS, reports the status of the computation.
1785 // 0, if the calculation completed correctly;
1786 // -I, if the input parameter number I is out of range;
1787 // +1, if the answer appears to be lower than lowest search bound;
1788 // +2, if the answer appears to be higher than greatest search bound;
1789 // +3, if P + Q /= 1;
1790 // +4, if X + Y /= 1.
1791 //
1792 // Output, double *BOUND, is only defined if STATUS is nonzero.
1793 // If STATUS is negative, then this is the value exceeded by parameter I.
1794 // if STATUS is 1 or 2, this is the search bound that was exceeded.
1795 //
1796 {
1797 # define tol (1.0e-8)
1798 # define atol (1.0e-50)
1799 # define zero (1.0e-300)
1800 # define inf 1.0e300
1801 # define one 1.0e0
1802
1803 static int K1 = 1;
1804 static double K2 = 0.0e0;
1805 static double K3 = 1.0e0;
1806 static double K8 = 0.5e0;
1807 static double K9 = 5.0e0;
1808 static double fx,xhi,xlo,cum,ccum,xy,pq;
1809 static unsigned long qhi,qleft,qporq;
1810 static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15;
1811
1812 *status = 0;
1813 *bound = 0.0;
1814 //
1815 // Check arguments
1816 //
1817 if(!(*which < 1 || *which > 4)) goto S30;
1818 if(!(*which < 1)) goto S10;
1819 *bound = 1.0e0;
1820 goto S20;
1821 S10:
1822 *bound = 4.0e0;
1823 S20:
1824 *status = -1;
1825 return;
1826 S30:
1827 if(*which == 1) goto S70;
1828 //
1829 // P
1830 //
1831 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
1832 if(!(*p < 0.0e0)) goto S40;
1833 *bound = 0.0e0;
1834 goto S50;
1835 S40:
1836 *bound = 1.0e0;
1837 S50:
1838 *status = -2;
1839 return;
1840 S70:
1841 S60:
1842 if(*which == 1) goto S110;
1843 //
1844 // Q
1845 //
1846 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
1847 if(!(*q < 0.0e0)) goto S80;
1848 *bound = 0.0e0;
1849 goto S90;
1850 S80:
1851 *bound = 1.0e0;
1852 S90:
1853 *status = -3;
1854 return;
1855 S110:
1856 S100:
1857 if(*which == 2) goto S150;
1858 //
1859 // X
1860 //
1861 if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140;
1862 if(!(*x < 0.0e0)) goto S120;
1863 *bound = 0.0e0;
1864 goto S130;
1865 S120:
1866 *bound = 1.0e0;
1867 S130:
1868 *status = -4;
1869 return;
1870 S150:
1871 S140:
1872 if(*which == 2) goto S190;
1873 //
1874 // Y
1875 //
1876 if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180;
1877 if(!(*y < 0.0e0)) goto S160;
1878 *bound = 0.0e0;
1879 goto S170;
1880 S160:
1881 *bound = 1.0e0;
1882 S170:
1883 *status = -5;
1884 return;
1885 S190:
1886 S180:
1887 if(*which == 3) goto S210;
1888 //
1889 // A
1890 //
1891 if(!(*a <= 0.0e0)) goto S200;
1892 *bound = 0.0e0;
1893 *status = -6;
1894 return;
1895 S210:
1896 S200:
1897 if(*which == 4) goto S230;
1898 //
1899 // B
1900 //
1901 if(!(*b <= 0.0e0)) goto S220;
1902 *bound = 0.0e0;
1903 *status = -7;
1904 return;
1905 S230:
1906 S220:
1907 if(*which == 1) goto S270;
1908 //
1909 // P + Q
1910 //
1911 pq = *p+*q;
1912 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S260;
1913 if(!(pq < 0.0e0)) goto S240;
1914 *bound = 0.0e0;
1915 goto S250;
1916 S240:
1917 *bound = 1.0e0;
1918 S250:
1919 *status = 3;
1920 return;
1921 S270:
1922 S260:
1923 if(*which == 2) goto S310;
1924 //
1925 // X + Y
1926 //
1927 xy = *x+*y;
1928 if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S300;
1929 if(!(xy < 0.0e0)) goto S280;
1930 *bound = 0.0e0;
1931 goto S290;
1932 S280:
1933 *bound = 1.0e0;
1934 S290:
1935 *status = 4;
1936 return;
1937 S310:
1938 S300:
1939 if(!(*which == 1)) qporq = *p <= *q;
1940 //
1941 // Select the minimum of P or Q
1942 // Calculate ANSWERS
1943 //
1944 if(1 == *which) {
1945 //
1946 // Calculating P and Q
1947 //
1948 cumbet(x,y,a,b,p,q);
1949 *status = 0;
1950 }
1951 else if(2 == *which) {
1952 //
1953 // Calculating X and Y
1954 //
1955 T4 = atol;
1956 T5 = tol;
1957 dstzr(&K2,&K3,&T4,&T5);
1958 if(!qporq) goto S340;
1959 *status = 0;
1960 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1961 *y = one-*x;
1962 S320:
1963 if(!(*status == 1)) goto S330;
1964 cumbet(x,y,a,b,&cum,&ccum);
1965 fx = cum-*p;
1966 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1967 *y = one-*x;
1968 goto S320;
1969 S330:
1970 goto S370;
1971 S340:
1972 *status = 0;
1973 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1974 *x = one-*y;
1975 S350:
1976 if(!(*status == 1)) goto S360;
1977 cumbet(x,y,a,b,&cum,&ccum);
1978 fx = ccum-*q;
1979 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1980 *x = one-*y;
1981 goto S350;
1982 S370:
1983 S360:
1984 if(!(*status == -1)) goto S400;
1985 if(!qleft) goto S380;
1986 *status = 1;
1987 *bound = 0.0e0;
1988 goto S390;
1989 S380:
1990 *status = 2;
1991 *bound = 1.0e0;
1992 S400:
1993 S390:
1994 ;
1995 }
1996 else if(3 == *which) {
1997 //
1998 // Computing A
1999 //
2000 *a = 5.0e0;
2001 T6 = zero;
2002 T7 = inf;
2003 T10 = atol;
2004 T11 = tol;
2005 dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11);
2006 *status = 0;
2007 dinvr(status,a,&fx,&qleft,&qhi);
2008 S410:
2009 if(!(*status == 1)) goto S440;
2010 cumbet(x,y,a,b,&cum,&ccum);
2011 if(!qporq) goto S420;
2012 fx = cum-*p;
2013 goto S430;
2014 S420:
2015 fx = ccum-*q;
2016 S430:
2017 dinvr(status,a,&fx,&qleft,&qhi);
2018 goto S410;
2019 S440:
2020 if(!(*status == -1)) goto S470;
2021 if(!qleft) goto S450;
2022 *status = 1;
2023 *bound = zero;
2024 goto S460;
2025 S450:
2026 *status = 2;
2027 *bound = inf;
2028 S470:
2029 S460:
2030 ;
2031 }
2032 else if(4 == *which) {
2033 //
2034 // Computing B
2035 //
2036 *b = 5.0e0;
2037 T12 = zero;
2038 T13 = inf;
2039 T14 = atol;
2040 T15 = tol;
2041 dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15);
2042 *status = 0;
2043 dinvr(status,b,&fx,&qleft,&qhi);
2044 S480:
2045 if(!(*status == 1)) goto S510;
2046 cumbet(x,y,a,b,&cum,&ccum);
2047 if(!qporq) goto S490;
2048 fx = cum-*p;
2049 goto S500;
2050 S490:
2051 fx = ccum-*q;
2052 S500:
2053 dinvr(status,b,&fx,&qleft,&qhi);
2054 goto S480;
2055 S510:
2056 if(!(*status == -1)) goto S540;
2057 if(!qleft) goto S520;
2058 *status = 1;
2059 *bound = zero;
2060 goto S530;
2061 S520:
2062 *status = 2;
2063 *bound = inf;
2064 S530:
2065 ;
2066 }
2067 S540:
2068 return;
2069 # undef tol
2070 # undef atol
2071 # undef zero
2072 # undef inf
2073 # undef one
2074 }
2075 //****************************************************************************80
2076
cdfbin(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)2077 void cdfbin ( int *which, double *p, double *q, double *s, double *xn,
2078 double *pr, double *ompr, int *status, double *bound )
2079
2080 //****************************************************************************80
2081 //
2082 // Purpose:
2083 //
2084 // CDFBIN evaluates the CDF of the Binomial distribution.
2085 //
2086 // Discussion:
2087 //
2088 // This routine calculates any one parameter of the binomial distribution
2089 // given the others.
2090 //
2091 // The value P of the cumulative distribution function is calculated
2092 // directly.
2093 //
2094 // Computation of the other parameters involves a seach for a value that
2095 // produces the desired value of P. The search relies on the
2096 // monotonicity of P with respect to the other parameters.
2097 //
2098 // P is the probablility of S or fewer successes in XN binomial trials,
2099 // each trial having an individual probability of success of PR.
2100 //
2101 // Modified:
2102 //
2103 // 09 June 2004
2104 //
2105 // Reference:
2106 //
2107 // Milton Abramowitz and Irene Stegun,
2108 // Handbook of Mathematical Functions
2109 // 1966, Formula 26.5.24.
2110 //
2111 // Parameters:
2112 //
2113 // Input, int *WHICH, indicates which of argument values is to
2114 // be calculated from the others.
2115 // 1: Calculate P and Q from S, XN, PR and OMPR;
2116 // 2: Calculate S from P, Q, XN, PR and OMPR;
2117 // 3: Calculate XN from P, Q, S, PR and OMPR;
2118 // 4: Calculate PR and OMPR from P, Q, S and XN.
2119 //
2120 // Input/output, double *P, the cumulation, from 0 to S,
2121 // of the binomial distribution. If P is an input value, it should
2122 // lie in the range [0,1].
2123 //
2124 // Input/output, double *Q, equal to 1-P. If Q is an input
2125 // value, it should lie in the range [0,1]. If Q is an output value,
2126 // it will lie in the range [0,1].
2127 //
2128 // Input/output, double *S, the number of successes observed.
2129 // Whether this is an input or output value, it should lie in the
2130 // range [0,XN].
2131 //
2132 // Input/output, double *XN, the number of binomial trials.
2133 // If this is an input value it should lie in the range: (0, +infinity).
2134 // If it is an output value it will be searched for in the
2135 // range [1.0D-300, 1.0D+300].
2136 //
2137 // Input/output, double *PR, the probability of success in each
2138 // binomial trial. Whether this is an input or output value, it should
2139 // lie in the range: [0,1].
2140 //
2141 // Input/output, double *OMPR, equal to 1-PR. Whether this is an
2142 // input or output value, it should lie in the range [0,1]. Also, it should
2143 // be the case that PR + OMPR = 1.
2144 //
2145 // Output, int *STATUS, reports the status of the computation.
2146 // 0, if the calculation completed correctly;
2147 // -I, if the input parameter number I is out of range;
2148 // +1, if the answer appears to be lower than lowest search bound;
2149 // +2, if the answer appears to be higher than greatest search bound;
2150 // +3, if P + Q /= 1;
2151 // +4, if PR + OMPR /= 1.
2152 //
2153 // Output, double *BOUND, is only defined if STATUS is nonzero.
2154 // If STATUS is negative, then this is the value exceeded by parameter I.
2155 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2156 //
2157 {
2158 # define atol (1.0e-50)
2159 # define tol (1.0e-8)
2160 # define zero (1.0e-300)
2161 # define inf 1.0e300
2162 # define one 1.0e0
2163
2164 static int K1 = 1;
2165 static double K2 = 0.0e0;
2166 static double K3 = 0.5e0;
2167 static double K4 = 5.0e0;
2168 static double K11 = 1.0e0;
2169 static double fx,xhi,xlo,cum,ccum,pq,prompr;
2170 static unsigned long qhi,qleft,qporq;
2171 static double T5,T6,T7,T8,T9,T10,T12,T13;
2172
2173 *status = 0;
2174 *bound = 0.0;
2175 //
2176 // Check arguments
2177 //
2178 if(!(*which < 1 && *which > 4)) goto S30;
2179 if(!(*which < 1)) goto S10;
2180 *bound = 1.0e0;
2181 goto S20;
2182 S10:
2183 *bound = 4.0e0;
2184 S20:
2185 *status = -1;
2186 return;
2187 S30:
2188 if(*which == 1) goto S70;
2189 //
2190 // P
2191 //
2192 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2193 if(!(*p < 0.0e0)) goto S40;
2194 *bound = 0.0e0;
2195 goto S50;
2196 S40:
2197 *bound = 1.0e0;
2198 S50:
2199 *status = -2;
2200 return;
2201 S70:
2202 S60:
2203 if(*which == 1) goto S110;
2204 //
2205 // Q
2206 //
2207 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
2208 if(!(*q < 0.0e0)) goto S80;
2209 *bound = 0.0e0;
2210 goto S90;
2211 S80:
2212 *bound = 1.0e0;
2213 S90:
2214 *status = -3;
2215 return;
2216 S110:
2217 S100:
2218 if(*which == 3) goto S130;
2219 //
2220 // XN
2221 //
2222 if(!(*xn <= 0.0e0)) goto S120;
2223 *bound = 0.0e0;
2224 *status = -5;
2225 return;
2226 S130:
2227 S120:
2228 if(*which == 2) goto S170;
2229 //
2230 // S
2231 //
2232 if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160;
2233 if(!(*s < 0.0e0)) goto S140;
2234 *bound = 0.0e0;
2235 goto S150;
2236 S140:
2237 *bound = *xn;
2238 S150:
2239 *status = -4;
2240 return;
2241 S170:
2242 S160:
2243 if(*which == 4) goto S210;
2244 //
2245 // PR
2246 //
2247 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200;
2248 if(!(*pr < 0.0e0)) goto S180;
2249 *bound = 0.0e0;
2250 goto S190;
2251 S180:
2252 *bound = 1.0e0;
2253 S190:
2254 *status = -6;
2255 return;
2256 S210:
2257 S200:
2258 if(*which == 4) goto S250;
2259 //
2260 // OMPR
2261 //
2262 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240;
2263 if(!(*ompr < 0.0e0)) goto S220;
2264 *bound = 0.0e0;
2265 goto S230;
2266 S220:
2267 *bound = 1.0e0;
2268 S230:
2269 *status = -7;
2270 return;
2271 S250:
2272 S240:
2273 if(*which == 1) goto S290;
2274 //
2275 // P + Q
2276 //
2277 pq = *p+*q;
2278 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S280;
2279 if(!(pq < 0.0e0)) goto S260;
2280 *bound = 0.0e0;
2281 goto S270;
2282 S260:
2283 *bound = 1.0e0;
2284 S270:
2285 *status = 3;
2286 return;
2287 S290:
2288 S280:
2289 if(*which == 4) goto S330;
2290 //
2291 // PR + OMPR
2292 //
2293 prompr = *pr+*ompr;
2294 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S320;
2295 if(!(prompr < 0.0e0)) goto S300;
2296 *bound = 0.0e0;
2297 goto S310;
2298 S300:
2299 *bound = 1.0e0;
2300 S310:
2301 *status = 4;
2302 return;
2303 S330:
2304 S320:
2305 if(!(*which == 1)) qporq = *p <= *q;
2306 //
2307 // Select the minimum of P or Q
2308 // Calculate ANSWERS
2309 //
2310 if(1 == *which) {
2311 //
2312 // Calculating P
2313 //
2314 cumbin(s,xn,pr,ompr,p,q);
2315 *status = 0;
2316 }
2317 else if(2 == *which) {
2318 //
2319 // Calculating S
2320 //
2321 *s = 5.0e0;
2322 T5 = atol;
2323 T6 = tol;
2324 dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6);
2325 *status = 0;
2326 dinvr(status,s,&fx,&qleft,&qhi);
2327 S340:
2328 if(!(*status == 1)) goto S370;
2329 cumbin(s,xn,pr,ompr,&cum,&ccum);
2330 if(!qporq) goto S350;
2331 fx = cum-*p;
2332 goto S360;
2333 S350:
2334 fx = ccum-*q;
2335 S360:
2336 dinvr(status,s,&fx,&qleft,&qhi);
2337 goto S340;
2338 S370:
2339 if(!(*status == -1)) goto S400;
2340 if(!qleft) goto S380;
2341 *status = 1;
2342 *bound = 0.0e0;
2343 goto S390;
2344 S380:
2345 *status = 2;
2346 *bound = *xn;
2347 S400:
2348 S390:
2349 ;
2350 }
2351 else if(3 == *which) {
2352 //
2353 // Calculating XN
2354 //
2355 *xn = 5.0e0;
2356 T7 = zero;
2357 T8 = inf;
2358 T9 = atol;
2359 T10 = tol;
2360 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2361 *status = 0;
2362 dinvr(status,xn,&fx,&qleft,&qhi);
2363 S410:
2364 if(!(*status == 1)) goto S440;
2365 cumbin(s,xn,pr,ompr,&cum,&ccum);
2366 if(!qporq) goto S420;
2367 fx = cum-*p;
2368 goto S430;
2369 S420:
2370 fx = ccum-*q;
2371 S430:
2372 dinvr(status,xn,&fx,&qleft,&qhi);
2373 goto S410;
2374 S440:
2375 if(!(*status == -1)) goto S470;
2376 if(!qleft) goto S450;
2377 *status = 1;
2378 *bound = zero;
2379 goto S460;
2380 S450:
2381 *status = 2;
2382 *bound = inf;
2383 S470:
2384 S460:
2385 ;
2386 }
2387 else if(4 == *which) {
2388 //
2389 // Calculating PR and OMPR
2390 //
2391 T12 = atol;
2392 T13 = tol;
2393 dstzr(&K2,&K11,&T12,&T13);
2394 if(!qporq) goto S500;
2395 *status = 0;
2396 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2397 *ompr = one-*pr;
2398 S480:
2399 if(!(*status == 1)) goto S490;
2400 cumbin(s,xn,pr,ompr,&cum,&ccum);
2401 fx = cum-*p;
2402 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2403 *ompr = one-*pr;
2404 goto S480;
2405 S490:
2406 goto S530;
2407 S500:
2408 *status = 0;
2409 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2410 *pr = one-*ompr;
2411 S510:
2412 if(!(*status == 1)) goto S520;
2413 cumbin(s,xn,pr,ompr,&cum,&ccum);
2414 fx = ccum-*q;
2415 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2416 *pr = one-*ompr;
2417 goto S510;
2418 S530:
2419 S520:
2420 if(!(*status == -1)) goto S560;
2421 if(!qleft) goto S540;
2422 *status = 1;
2423 *bound = 0.0e0;
2424 goto S550;
2425 S540:
2426 *status = 2;
2427 *bound = 1.0e0;
2428 S550:
2429 ;
2430 }
2431 S560:
2432 return;
2433 # undef atol
2434 # undef tol
2435 # undef zero
2436 # undef inf
2437 # undef one
2438 }
2439 //****************************************************************************80
2440
cdfchi(int * which,double * p,double * q,double * x,double * df,int * status,double * bound)2441 void cdfchi ( int *which, double *p, double *q, double *x, double *df,
2442 int *status, double *bound )
2443
2444 //****************************************************************************80
2445 //
2446 // Purpose:
2447 //
2448 // CDFCHI evaluates the CDF of the chi square distribution.
2449 //
2450 // Discussion:
2451 //
2452 // This routine calculates any one parameter of the chi square distribution
2453 // given the others.
2454 //
2455 // The value P of the cumulative distribution function is calculated
2456 // directly.
2457 //
2458 // Computation of the other parameters involves a seach for a value that
2459 // produces the desired value of P. The search relies on the
2460 // monotonicity of P with respect to the other parameters.
2461 //
2462 // The CDF of the chi square distribution can be evaluated
2463 // within Mathematica by commands such as:
2464 //
2465 // Needs["Statistics`ContinuousDistributions`"]
2466 // CDF [ ChiSquareDistribution [ DF ], X ]
2467 //
2468 // Reference:
2469 //
2470 // Milton Abramowitz and Irene Stegun,
2471 // Handbook of Mathematical Functions
2472 // 1966, Formula 26.4.19.
2473 //
2474 // Stephen Wolfram,
2475 // The Mathematica Book,
2476 // Fourth Edition,
2477 // Wolfram Media / Cambridge University Press, 1999.
2478 //
2479 // Parameters:
2480 //
2481 // Input, int *WHICH, indicates which argument is to be calculated
2482 // from the others.
2483 // 1: Calculate P and Q from X and DF;
2484 // 2: Calculate X from P, Q and DF;
2485 // 3: Calculate DF from P, Q and X.
2486 //
2487 // Input/output, double *P, the integral from 0 to X of
2488 // the chi-square distribution. If this is an input value, it should
2489 // lie in the range [0,1].
2490 //
2491 // Input/output, double *Q, equal to 1-P. If Q is an input
2492 // value, it should lie in the range [0,1]. If Q is an output value,
2493 // it will lie in the range [0,1].
2494 //
2495 // Input/output, double *X, the upper limit of integration
2496 // of the chi-square distribution. If this is an input
2497 // value, it should lie in the range: [0, +infinity). If it is an output
2498 // value, it will be searched for in the range: [0,1.0D+300].
2499 //
2500 // Input/output, double *DF, the degrees of freedom of the
2501 // chi-square distribution. If this is an input value, it should lie
2502 // in the range: (0, +infinity). If it is an output value, it will be
2503 // searched for in the range: [ 1.0D-300, 1.0D+300].
2504 //
2505 // Output, int *STATUS, reports the status of the computation.
2506 // 0, if the calculation completed correctly;
2507 // -I, if the input parameter number I is out of range;
2508 // +1, if the answer appears to be lower than lowest search bound;
2509 // +2, if the answer appears to be higher than greatest search bound;
2510 // +3, if P + Q /= 1;
2511 // +10, an error was returned from CUMGAM.
2512 //
2513 // Output, double *BOUND, is only defined if STATUS is nonzero.
2514 // If STATUS is negative, then this is the value exceeded by parameter I.
2515 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2516 //
2517 {
2518 # define tol (1.0e-8)
2519 # define atol (1.0e-50)
2520 # define zero (1.0e-300)
2521 # define inf 1.0e300
2522
2523 static int K1 = 1;
2524 static double K2 = 0.0e0;
2525 static double K4 = 0.5e0;
2526 static double K5 = 5.0e0;
2527 static double fx,cum,ccum,pq,porq;
2528 static unsigned long qhi,qleft,qporq;
2529 static double T3,T6,T7,T8,T9,T10,T11;
2530
2531 *status = 0;
2532 *bound = 0.0;
2533 //
2534 // Check arguments
2535 //
2536 if(!(*which < 1 || *which > 3)) goto S30;
2537 if(!(*which < 1)) goto S10;
2538 *bound = 1.0e0;
2539 goto S20;
2540 S10:
2541 *bound = 3.0e0;
2542 S20:
2543 *status = -1;
2544 return;
2545 S30:
2546 if(*which == 1) goto S70;
2547 //
2548 // P
2549 //
2550 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2551 if(!(*p < 0.0e0)) goto S40;
2552 *bound = 0.0e0;
2553 goto S50;
2554 S40:
2555 *bound = 1.0e0;
2556 S50:
2557 *status = -2;
2558 return;
2559 S70:
2560 S60:
2561 if(*which == 1) goto S110;
2562 //
2563 // Q
2564 //
2565 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2566 if(!(*q <= 0.0e0)) goto S80;
2567 *bound = 0.0e0;
2568 goto S90;
2569 S80:
2570 *bound = 1.0e0;
2571 S90:
2572 *status = -3;
2573 return;
2574 S110:
2575 S100:
2576 if(*which == 2) goto S130;
2577 //
2578 // X
2579 //
2580 if(!(*x < 0.0e0)) goto S120;
2581 *bound = 0.0e0;
2582 *status = -4;
2583 return;
2584 S130:
2585 S120:
2586 if(*which == 3) goto S150;
2587 //
2588 // DF
2589 //
2590 if(!(*df <= 0.0e0)) goto S140;
2591 *bound = 0.0e0;
2592 *status = -5;
2593 return;
2594 S150:
2595 S140:
2596 if(*which == 1) goto S190;
2597 //
2598 // P + Q
2599 //
2600 pq = *p+*q;
2601 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S180;
2602 if(!(pq < 0.0e0)) goto S160;
2603 *bound = 0.0e0;
2604 goto S170;
2605 S160:
2606 *bound = 1.0e0;
2607 S170:
2608 *status = 3;
2609 return;
2610 S190:
2611 S180:
2612 if(*which == 1) goto S220;
2613 //
2614 // Select the minimum of P or Q
2615 //
2616 qporq = *p <= *q;
2617 if(!qporq) goto S200;
2618 porq = *p;
2619 goto S210;
2620 S200:
2621 porq = *q;
2622 S220:
2623 S210:
2624 //
2625 // Calculate ANSWERS
2626 //
2627 if(1 == *which) {
2628 //
2629 // Calculating P and Q
2630 //
2631 *status = 0;
2632 cumchi(x,df,p,q);
2633 if(porq > 1.5e0) {
2634 *status = 10;
2635 return;
2636 }
2637 }
2638 else if(2 == *which) {
2639 //
2640 // Calculating X
2641 //
2642 *x = 5.0e0;
2643 T3 = inf;
2644 T6 = atol;
2645 T7 = tol;
2646 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
2647 *status = 0;
2648 dinvr(status,x,&fx,&qleft,&qhi);
2649 S230:
2650 if(!(*status == 1)) goto S270;
2651 cumchi(x,df,&cum,&ccum);
2652 if(!qporq) goto S240;
2653 fx = cum-*p;
2654 goto S250;
2655 S240:
2656 fx = ccum-*q;
2657 S250:
2658 if(!(fx+porq > 1.5e0)) goto S260;
2659 *status = 10;
2660 return;
2661 S260:
2662 dinvr(status,x,&fx,&qleft,&qhi);
2663 goto S230;
2664 S270:
2665 if(!(*status == -1)) goto S300;
2666 if(!qleft) goto S280;
2667 *status = 1;
2668 *bound = 0.0e0;
2669 goto S290;
2670 S280:
2671 *status = 2;
2672 *bound = inf;
2673 S300:
2674 S290:
2675 ;
2676 }
2677 else if(3 == *which) {
2678 //
2679 // Calculating DF
2680 //
2681 *df = 5.0e0;
2682 T8 = zero;
2683 T9 = inf;
2684 T10 = atol;
2685 T11 = tol;
2686 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
2687 *status = 0;
2688 dinvr(status,df,&fx,&qleft,&qhi);
2689 S310:
2690 if(!(*status == 1)) goto S350;
2691 cumchi(x,df,&cum,&ccum);
2692 if(!qporq) goto S320;
2693 fx = cum-*p;
2694 goto S330;
2695 S320:
2696 fx = ccum-*q;
2697 S330:
2698 if(!(fx+porq > 1.5e0)) goto S340;
2699 *status = 10;
2700 return;
2701 S340:
2702 dinvr(status,df,&fx,&qleft,&qhi);
2703 goto S310;
2704 S350:
2705 if(!(*status == -1)) goto S380;
2706 if(!qleft) goto S360;
2707 *status = 1;
2708 *bound = zero;
2709 goto S370;
2710 S360:
2711 *status = 2;
2712 *bound = inf;
2713 S370:
2714 ;
2715 }
2716 S380:
2717 return;
2718 # undef tol
2719 # undef atol
2720 # undef zero
2721 # undef inf
2722 }
2723 //****************************************************************************80
2724
cdfchn(int * which,double * p,double * q,double * x,double * df,double * pnonc,int * status,double * bound)2725 void cdfchn ( int *which, double *p, double *q, double *x, double *df,
2726 double *pnonc, int *status, double *bound )
2727
2728 //****************************************************************************80
2729 //
2730 // Purpose:
2731 //
2732 // CDFCHN evaluates the CDF of the Noncentral Chi-Square.
2733 //
2734 // Discussion:
2735 //
2736 // This routine calculates any one parameter of the noncentral chi-square
2737 // distribution given values for the others.
2738 //
2739 // The value P of the cumulative distribution function is calculated
2740 // directly.
2741 //
2742 // Computation of the other parameters involves a seach for a value that
2743 // produces the desired value of P. The search relies on the
2744 // monotonicity of P with respect to the other parameters.
2745 //
2746 // The computation time required for this routine is proportional
2747 // to the noncentrality parameter (PNONC). Very large values of
2748 // this parameter can consume immense computer resources. This is
2749 // why the search range is bounded by 10,000.
2750 //
2751 // The CDF of the noncentral chi square distribution can be evaluated
2752 // within Mathematica by commands such as:
2753 //
2754 // Needs["Statistics`ContinuousDistributions`"]
2755 // CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
2756 //
2757 // Reference:
2758 //
2759 // Milton Abramowitz and Irene Stegun,
2760 // Handbook of Mathematical Functions
2761 // 1966, Formula 26.5.25.
2762 //
2763 // Stephen Wolfram,
2764 // The Mathematica Book,
2765 // Fourth Edition,
2766 // Wolfram Media / Cambridge University Press, 1999.
2767 //
2768 // Parameters:
2769 //
2770 // Input, int *WHICH, indicates which argument is to be calculated
2771 // from the others.
2772 // 1: Calculate P and Q from X, DF and PNONC;
2773 // 2: Calculate X from P, DF and PNONC;
2774 // 3: Calculate DF from P, X and PNONC;
2775 // 4: Calculate PNONC from P, X and DF.
2776 //
2777 // Input/output, double *P, the integral from 0 to X of
2778 // the noncentral chi-square distribution. If this is an input
2779 // value, it should lie in the range: [0, 1.0-1.0D-16).
2780 //
2781 // Input/output, double *Q, is generally not used by this
2782 // subroutine and is only included for similarity with other routines.
2783 // However, if P is to be computed, then a value will also be computed
2784 // for Q.
2785 //
2786 // Input, double *X, the upper limit of integration of the
2787 // noncentral chi-square distribution. If this is an input value, it
2788 // should lie in the range: [0, +infinity). If it is an output value,
2789 // it will be sought in the range: [0,1.0D+300].
2790 //
2791 // Input/output, double *DF, the number of degrees of freedom
2792 // of the noncentral chi-square distribution. If this is an input value,
2793 // it should lie in the range: (0, +infinity). If it is an output value,
2794 // it will be searched for in the range: [ 1.0D-300, 1.0D+300].
2795 //
2796 // Input/output, double *PNONC, the noncentrality parameter of
2797 // the noncentral chi-square distribution. If this is an input value, it
2798 // should lie in the range: [0, +infinity). If it is an output value,
2799 // it will be searched for in the range: [0,1.0D+4]
2800 //
2801 // Output, int *STATUS, reports on the calculation.
2802 // 0, if calculation completed correctly;
2803 // -I, if input parameter number I is out of range;
2804 // 1, if the answer appears to be lower than the lowest search bound;
2805 // 2, if the answer appears to be higher than the greatest search bound.
2806 //
2807 // Output, double *BOUND, is only defined if STATUS is nonzero.
2808 // If STATUS is negative, then this is the value exceeded by parameter I.
2809 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2810 //
2811 {
2812 # define tent4 1.0e4
2813 # define tol (1.0e-8)
2814 # define atol (1.0e-50)
2815 # define zero (1.0e-300)
2816 # define one (1.0e0-1.0e-16)
2817 # define inf 1.0e300
2818
2819 static double K1 = 0.0e0;
2820 static double K3 = 0.5e0;
2821 static double K4 = 5.0e0;
2822 static double fx,cum,ccum;
2823 static unsigned long qhi,qleft;
2824 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13;
2825
2826 *status = 0;
2827 *bound = 0.0;
2828 //
2829 // Check arguments
2830 //
2831 if(!(*which < 1 || *which > 4)) goto S30;
2832 if(!(*which < 1)) goto S10;
2833 *bound = 1.0e0;
2834 goto S20;
2835 S10:
2836 *bound = 4.0e0;
2837 S20:
2838 *status = -1;
2839 return;
2840 S30:
2841 if(*which == 1) goto S70;
2842 //
2843 // P
2844 //
2845 if(!(*p < 0.0e0 || *p > one)) goto S60;
2846 if(!(*p < 0.0e0)) goto S40;
2847 *bound = 0.0e0;
2848 goto S50;
2849 S40:
2850 *bound = one;
2851 S50:
2852 *status = -2;
2853 return;
2854 S70:
2855 S60:
2856 if(*which == 2) goto S90;
2857 //
2858 // X
2859 //
2860 if(!(*x < 0.0e0)) goto S80;
2861 *bound = 0.0e0;
2862 *status = -4;
2863 return;
2864 S90:
2865 S80:
2866 if(*which == 3) goto S110;
2867 //
2868 // DF
2869 //
2870 if(!(*df <= 0.0e0)) goto S100;
2871 *bound = 0.0e0;
2872 *status = -5;
2873 return;
2874 S110:
2875 S100:
2876 if(*which == 4) goto S130;
2877 //
2878 // PNONC
2879 //
2880 if(!(*pnonc < 0.0e0)) goto S120;
2881 *bound = 0.0e0;
2882 *status = -6;
2883 return;
2884 S130:
2885 S120:
2886 //
2887 // Calculate ANSWERS
2888 //
2889 if(1 == *which) {
2890 //
2891 // Calculating P and Q
2892 //
2893 cumchn(x,df,pnonc,p,q);
2894 *status = 0;
2895 }
2896 else if(2 == *which) {
2897 //
2898 // Calculating X
2899 //
2900 *x = 5.0e0;
2901 T2 = inf;
2902 T5 = atol;
2903 T6 = tol;
2904 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
2905 *status = 0;
2906 dinvr(status,x,&fx,&qleft,&qhi);
2907 S140:
2908 if(!(*status == 1)) goto S150;
2909 cumchn(x,df,pnonc,&cum,&ccum);
2910 fx = cum-*p;
2911 dinvr(status,x,&fx,&qleft,&qhi);
2912 goto S140;
2913 S150:
2914 if(!(*status == -1)) goto S180;
2915 if(!qleft) goto S160;
2916 *status = 1;
2917 *bound = 0.0e0;
2918 goto S170;
2919 S160:
2920 *status = 2;
2921 *bound = inf;
2922 S180:
2923 S170:
2924 ;
2925 }
2926 else if(3 == *which) {
2927 //
2928 // Calculating DF
2929 //
2930 *df = 5.0e0;
2931 T7 = zero;
2932 T8 = inf;
2933 T9 = atol;
2934 T10 = tol;
2935 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2936 *status = 0;
2937 dinvr(status,df,&fx,&qleft,&qhi);
2938 S190:
2939 if(!(*status == 1)) goto S200;
2940 cumchn(x,df,pnonc,&cum,&ccum);
2941 fx = cum-*p;
2942 dinvr(status,df,&fx,&qleft,&qhi);
2943 goto S190;
2944 S200:
2945 if(!(*status == -1)) goto S230;
2946 if(!qleft) goto S210;
2947 *status = 1;
2948 *bound = zero;
2949 goto S220;
2950 S210:
2951 *status = 2;
2952 *bound = inf;
2953 S230:
2954 S220:
2955 ;
2956 }
2957 else if(4 == *which) {
2958 //
2959 // Calculating PNONC
2960 //
2961 *pnonc = 5.0e0;
2962 T11 = tent4;
2963 T12 = atol;
2964 T13 = tol;
2965 dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13);
2966 *status = 0;
2967 dinvr(status,pnonc,&fx,&qleft,&qhi);
2968 S240:
2969 if(!(*status == 1)) goto S250;
2970 cumchn(x,df,pnonc,&cum,&ccum);
2971 fx = cum-*p;
2972 dinvr(status,pnonc,&fx,&qleft,&qhi);
2973 goto S240;
2974 S250:
2975 if(!(*status == -1)) goto S280;
2976 if(!qleft) goto S260;
2977 *status = 1;
2978 *bound = zero;
2979 goto S270;
2980 S260:
2981 *status = 2;
2982 *bound = tent4;
2983 S270:
2984 ;
2985 }
2986 S280:
2987 return;
2988 # undef tent4
2989 # undef tol
2990 # undef atol
2991 # undef zero
2992 # undef one
2993 # undef inf
2994 }
2995 //****************************************************************************80
2996
cdff(int * which,double * p,double * q,double * f,double * dfn,double * dfd,int * status,double * bound)2997 void cdff ( int *which, double *p, double *q, double *f, double *dfn,
2998 double *dfd, int *status, double *bound )
2999
3000 //****************************************************************************80
3001 //
3002 // Purpose:
3003 //
3004 // CDFF evaluates the CDF of the F distribution.
3005 //
3006 // Discussion:
3007 //
3008 // This routine calculates any one parameter of the F distribution
3009 // given the others.
3010 //
3011 // The value P of the cumulative distribution function is calculated
3012 // directly.
3013 //
3014 // Computation of the other parameters involves a seach for a value that
3015 // produces the desired value of P. The search relies on the
3016 // monotonicity of P with respect to the other parameters.
3017 //
3018 // The value of the cumulative F distribution is not necessarily
3019 // monotone in either degree of freedom. There thus may be two
3020 // values that provide a given CDF value. This routine assumes
3021 // monotonicity and will find an arbitrary one of the two values.
3022 //
3023 // Modified:
3024 //
3025 // 14 April 2007
3026 //
3027 // Reference:
3028 //
3029 // Milton Abramowitz, Irene Stegun,
3030 // Handbook of Mathematical Functions
3031 // 1966, Formula 26.6.2.
3032 //
3033 // Parameters:
3034 //
3035 // Input, int *WHICH, indicates which argument is to be calculated
3036 // from the others.
3037 // 1: Calculate P and Q from F, DFN and DFD;
3038 // 2: Calculate F from P, Q, DFN and DFD;
3039 // 3: Calculate DFN from P, Q, F and DFD;
3040 // 4: Calculate DFD from P, Q, F and DFN.
3041 //
3042 // Input/output, double *P, the integral from 0 to F of
3043 // the F-density. If it is an input value, it should lie in the
3044 // range [0,1].
3045 //
3046 // Input/output, double *Q, equal to 1-P. If Q is an input
3047 // value, it should lie in the range [0,1]. If Q is an output value,
3048 // it will lie in the range [0,1].
3049 //
3050 // Input/output, double *F, the upper limit of integration
3051 // of the F-density. If this is an input value, it should lie in the
3052 // range [0, +infinity). If it is an output value, it will be searched
3053 // for in the range [0,1.0D+300].
3054 //
3055 // Input/output, double *DFN, the number of degrees of
3056 // freedom of the numerator sum of squares. If this is an input value,
3057 // it should lie in the range: (0, +infinity). If it is an output value,
3058 // it will be searched for in the range: [ 1.0D-300, 1.0D+300].
3059 //
3060 // Input/output, double *DFD, the number of degrees of freedom
3061 // of the denominator sum of squares. If this is an input value, it should
3062 // lie in the range: (0, +infinity). If it is an output value, it will
3063 // be searched for in the range: [ 1.0D-300, 1.0D+300].
3064 //
3065 // Output, int *STATUS, reports the status of the computation.
3066 // 0, if the calculation completed correctly;
3067 // -I, if the input parameter number I is out of range;
3068 // +1, if the answer appears to be lower than lowest search bound;
3069 // +2, if the answer appears to be higher than greatest search bound;
3070 // +3, if P + Q /= 1.
3071 //
3072 // Output, double *BOUND, is only defined if STATUS is nonzero.
3073 // If STATUS is negative, then this is the value exceeded by parameter I.
3074 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3075 //
3076 {
3077 # define tol (1.0e-8)
3078 # define atol (1.0e-50)
3079 # define zero (1.0e-300)
3080 # define inf 1.0e300
3081
3082 static int K1 = 1;
3083 static double K2 = 0.0e0;
3084 static double K4 = 0.5e0;
3085 static double K5 = 5.0e0;
3086 static double pq,fx,cum,ccum;
3087 static unsigned long qhi,qleft,qporq;
3088 static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15;
3089
3090 *status = 0;
3091 *bound = 0.0;
3092 //
3093 // Check arguments
3094 //
3095 if(!(*which < 1 || *which > 4)) goto S30;
3096 if(!(*which < 1)) goto S10;
3097 *bound = 1.0e0;
3098 goto S20;
3099 S10:
3100 *bound = 4.0e0;
3101 S20:
3102 *status = -1;
3103 return;
3104 S30:
3105 if(*which == 1) goto S70;
3106 //
3107 // P
3108 //
3109 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3110 if(!(*p < 0.0e0)) goto S40;
3111 *bound = 0.0e0;
3112 goto S50;
3113 S40:
3114 *bound = 1.0e0;
3115 S50:
3116 *status = -2;
3117 return;
3118 S70:
3119 S60:
3120 if(*which == 1) goto S110;
3121 //
3122 // Q
3123 //
3124 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3125 if(!(*q <= 0.0e0)) goto S80;
3126 *bound = 0.0e0;
3127 goto S90;
3128 S80:
3129 *bound = 1.0e0;
3130 S90:
3131 *status = -3;
3132 return;
3133 S110:
3134 S100:
3135 if(*which == 2) goto S130;
3136 //
3137 // F
3138 //
3139 if(!(*f < 0.0e0)) goto S120;
3140 *bound = 0.0e0;
3141 *status = -4;
3142 return;
3143 S130:
3144 S120:
3145 if(*which == 3) goto S150;
3146 //
3147 // DFN
3148 //
3149 if(!(*dfn <= 0.0e0)) goto S140;
3150 *bound = 0.0e0;
3151 *status = -5;
3152 return;
3153 S150:
3154 S140:
3155 if(*which == 4) goto S170;
3156 //
3157 // DFD
3158 //
3159 if(!(*dfd <= 0.0e0)) goto S160;
3160 *bound = 0.0e0;
3161 *status = -6;
3162 return;
3163 S170:
3164 S160:
3165 if(*which == 1) goto S210;
3166 //
3167 // P + Q
3168 //
3169 pq = *p+*q;
3170 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S200;
3171 if(!(pq < 0.0e0)) goto S180;
3172 *bound = 0.0e0;
3173 goto S190;
3174 S180:
3175 *bound = 1.0e0;
3176 S190:
3177 *status = 3;
3178 return;
3179 S210:
3180 S200:
3181 if(!(*which == 1)) qporq = *p <= *q;
3182 //
3183 // Select the minimum of P or Q
3184 // Calculate ANSWERS
3185 //
3186 if(1 == *which) {
3187 //
3188 // Calculating P
3189 //
3190 cumf(f,dfn,dfd,p,q);
3191 *status = 0;
3192 }
3193 else if(2 == *which) {
3194 //
3195 // Calculating F
3196 //
3197 *f = 5.0e0;
3198 T3 = inf;
3199 T6 = atol;
3200 T7 = tol;
3201 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
3202 *status = 0;
3203 dinvr(status,f,&fx,&qleft,&qhi);
3204 S220:
3205 if(!(*status == 1)) goto S250;
3206 cumf(f,dfn,dfd,&cum,&ccum);
3207 if(!qporq) goto S230;
3208 fx = cum-*p;
3209 goto S240;
3210 S230:
3211 fx = ccum-*q;
3212 S240:
3213 dinvr(status,f,&fx,&qleft,&qhi);
3214 goto S220;
3215 S250:
3216 if(!(*status == -1)) goto S280;
3217 if(!qleft) goto S260;
3218 *status = 1;
3219 *bound = 0.0e0;
3220 goto S270;
3221 S260:
3222 *status = 2;
3223 *bound = inf;
3224 S280:
3225 S270:
3226 ;
3227 }
3228 //
3229 // Calculate DFN.
3230 //
3231 // Note that, in the original calculation, the lower bound for DFN was 0.
3232 // Using DFN = 0 causes an error in CUMF when it calls BETA_INC.
3233 // The lower bound was set to the more reasonable value of 1.
3234 // JVB, 14 April 2007.
3235 //
3236 else if ( 3 == *which )
3237 {
3238
3239 T8 = 1.0;
3240 T9 = inf;
3241 T10 = atol;
3242 T11 = tol;
3243 dstinv ( &T8, &T9, &K4, &K4, &K5, &T10, &T11 );
3244
3245 *status = 0;
3246 *dfn = 5.0;
3247 fx = 0.0;
3248
3249 dinvr ( status, dfn, &fx, &qleft, &qhi );
3250
3251 while ( *status == 1 )
3252 {
3253 cumf ( f, dfn, dfd, &cum, &ccum );
3254
3255 if ( *p <= *q )
3256 {
3257 fx = cum - *p;
3258 }
3259 else
3260 {
3261 fx = ccum - *q;
3262 }
3263 dinvr ( status, dfn, &fx, &qleft, &qhi );
3264 }
3265
3266 if ( *status == -1 )
3267 {
3268 if ( qleft )
3269 {
3270 *status = 1;
3271 *bound = 1.0;
3272 }
3273 else
3274 {
3275 *status = 2;
3276 *bound = inf;
3277 }
3278 }
3279 }
3280 //
3281 // Calculate DFD.
3282 //
3283 // Note that, in the original calculation, the lower bound for DFD was 0.
3284 // Using DFD = 0 causes an error in CUMF when it calls BETA_INC.
3285 // The lower bound was set to the more reasonable value of 1.
3286 // JVB, 14 April 2007.
3287 //
3288 //
3289 else if ( 4 == *which )
3290 {
3291
3292 T12 = 1.0;
3293 T13 = inf;
3294 T14 = atol;
3295 T15 = tol;
3296 dstinv ( &T12, &T13, &K4, &K4, &K5, &T14, &T15 );
3297
3298 *status = 0;
3299 *dfd = 5.0;
3300 fx = 0.0;
3301 dinvr ( status, dfd, &fx, &qleft, &qhi );
3302
3303 while ( *status == 1 )
3304 {
3305 cumf ( f, dfn, dfd, &cum, &ccum );
3306
3307 if ( *p <= *q )
3308 {
3309 fx = cum - *p;
3310 }
3311 else
3312 {
3313 fx = ccum - *q;
3314 }
3315 dinvr ( status, dfd, &fx, &qleft, &qhi );
3316 }
3317
3318 if ( *status == -1 )
3319 {
3320 if ( qleft )
3321 {
3322 *status = 1;
3323 *bound = 1.0;
3324 }
3325 else
3326 {
3327 *status = 2;
3328 *bound = inf;
3329 }
3330 }
3331 }
3332
3333 return;
3334 # undef tol
3335 # undef atol
3336 # undef zero
3337 # undef inf
3338 }
3339 //****************************************************************************80
3340
cdffnc(int * which,double * p,double * q,double * f,double * dfn,double * dfd,double * phonc,int * status,double * bound)3341 void cdffnc ( int *which, double *p, double *q, double *f, double *dfn,
3342 double *dfd, double *phonc, int *status, double *bound )
3343
3344 //****************************************************************************80
3345 //
3346 // Purpose:
3347 //
3348 // CDFFNC evaluates the CDF of the Noncentral F distribution.
3349 //
3350 // Discussion:
3351 //
3352 // This routine originally used 1.0E+300 as the upper bound for the
3353 // interval in which many of the missing parameters are to be sought.
3354 // Since the underlying rootfinder routine needs to evaluate the
3355 // function at this point, it is no surprise that the program was
3356 // experiencing overflows. A less extravagant upper bound
3357 // is being tried for now!
3358 //
3359 //
3360 // This routine calculates any one parameter of the Noncentral F distribution
3361 // given the others.
3362 //
3363 // The value P of the cumulative distribution function is calculated
3364 // directly.
3365 //
3366 // Computation of the other parameters involves a seach for a value that
3367 // produces the desired value of P. The search relies on the
3368 // monotonicity of P with respect to the other parameters.
3369 //
3370 // The computation time required for this routine is proportional
3371 // to the noncentrality parameter PNONC. Very large values of
3372 // this parameter can consume immense computer resources. This is
3373 // why the search range is bounded by 10,000.
3374 //
3375 // The value of the cumulative noncentral F distribution is not
3376 // necessarily monotone in either degree of freedom. There thus
3377 // may be two values that provide a given CDF value. This routine
3378 // assumes monotonicity and will find an arbitrary one of the two
3379 // values.
3380 //
3381 // The CDF of the noncentral F distribution can be evaluated
3382 // within Mathematica by commands such as:
3383 //
3384 // Needs["Statistics`ContinuousDistributions`"]
3385 // CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ]
3386 //
3387 // Modified:
3388 //
3389 // 15 June 2004
3390 //
3391 // Reference:
3392 //
3393 // Milton Abramowitz and Irene Stegun,
3394 // Handbook of Mathematical Functions
3395 // 1966, Formula 26.6.20.
3396 //
3397 // Stephen Wolfram,
3398 // The Mathematica Book,
3399 // Fourth Edition,
3400 // Wolfram Media / Cambridge University Press, 1999.
3401 //
3402 // Parameters:
3403 //
3404 // Input, int *WHICH, indicates which argument is to be calculated
3405 // from the others.
3406 // 1: Calculate P and Q from F, DFN, DFD and PNONC;
3407 // 2: Calculate F from P, Q, DFN, DFD and PNONC;
3408 // 3: Calculate DFN from P, Q, F, DFD and PNONC;
3409 // 4: Calculate DFD from P, Q, F, DFN and PNONC;
3410 // 5: Calculate PNONC from P, Q, F, DFN and DFD.
3411 //
3412 // Input/output, double *P, the integral from 0 to F of
3413 // the noncentral F-density. If P is an input value it should
3414 // lie in the range [0,1) (Not including 1!).
3415 //
3416 // Dummy, double *Q, is not used by this subroutine,
3417 // and is only included for similarity with the other routines.
3418 // Its input value is not checked. If P is to be computed, the
3419 // Q is set to 1 - P.
3420 //
3421 // Input/output, double *F, the upper limit of integration
3422 // of the noncentral F-density. If this is an input value, it should
3423 // lie in the range: [0, +infinity). If it is an output value, it
3424 // will be searched for in the range: [0,1.0D+30].
3425 //
3426 // Input/output, double *DFN, the number of degrees of freedom
3427 // of the numerator sum of squares. If this is an input value, it should
3428 // lie in the range: (0, +infinity). If it is an output value, it will
3429 // be searched for in the range: [ 1.0, 1.0D+30].
3430 //
3431 // Input/output, double *DFD, the number of degrees of freedom
3432 // of the denominator sum of squares. If this is an input value, it should
3433 // be in range: (0, +infinity). If it is an output value, it will be
3434 // searched for in the range [1.0, 1.0D+30].
3435 //
3436 // Input/output, double *PNONC, the noncentrality parameter
3437 // If this is an input value, it should be nonnegative.
3438 // If it is an output value, it will be searched for in the range: [0,1.0D+4].
3439 //
3440 // Output, int *STATUS, reports the status of the computation.
3441 // 0, if the calculation completed correctly;
3442 // -I, if the input parameter number I is out of range;
3443 // +1, if the answer appears to be lower than lowest search bound;
3444 // +2, if the answer appears to be higher than greatest search bound;
3445 // +3, if P + Q /= 1.
3446 //
3447 // Output, double *BOUND, is only defined if STATUS is nonzero.
3448 // If STATUS is negative, then this is the value exceeded by parameter I.
3449 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3450 //
3451 {
3452 # define tent4 1.0e4
3453 # define tol (1.0e-8)
3454 # define atol (1.0e-50)
3455 # define zero (1.0e-300)
3456 # define one (1.0e0-1.0e-16)
3457 # define inf 1.0e300
3458
3459 static double K1 = 0.0e0;
3460 static double K3 = 0.5e0;
3461 static double K4 = 5.0e0;
3462 static double fx,cum,ccum;
3463 static unsigned long qhi,qleft;
3464 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17;
3465
3466 *status = 0;
3467 *bound = 0.0;
3468 //
3469 // Check arguments
3470 //
3471 if(!(*which < 1 || *which > 5)) goto S30;
3472 if(!(*which < 1)) goto S10;
3473 *bound = 1.0e0;
3474 goto S20;
3475 S10:
3476 *bound = 5.0e0;
3477 S20:
3478 *status = -1;
3479 return;
3480 S30:
3481 if(*which == 1) goto S70;
3482 //
3483 // P
3484 //
3485 if(!(*p < 0.0e0 || *p > one)) goto S60;
3486 if(!(*p < 0.0e0)) goto S40;
3487 *bound = 0.0e0;
3488 goto S50;
3489 S40:
3490 *bound = one;
3491 S50:
3492 *status = -2;
3493 return;
3494 S70:
3495 S60:
3496 if(*which == 2) goto S90;
3497 //
3498 // F
3499 //
3500 if(!(*f < 0.0e0)) goto S80;
3501 *bound = 0.0e0;
3502 *status = -4;
3503 return;
3504 S90:
3505 S80:
3506 if(*which == 3) goto S110;
3507 //
3508 // DFN
3509 //
3510 if(!(*dfn <= 0.0e0)) goto S100;
3511 *bound = 0.0e0;
3512 *status = -5;
3513 return;
3514 S110:
3515 S100:
3516 if(*which == 4) goto S130;
3517 //
3518 // DFD
3519 //
3520 if(!(*dfd <= 0.0e0)) goto S120;
3521 *bound = 0.0e0;
3522 *status = -6;
3523 return;
3524 S130:
3525 S120:
3526 if(*which == 5) goto S150;
3527 //
3528 // PHONC
3529 //
3530 if(!(*phonc < 0.0e0)) goto S140;
3531 *bound = 0.0e0;
3532 *status = -7;
3533 return;
3534 S150:
3535 S140:
3536 //
3537 // Calculate ANSWERS
3538 //
3539 if(1 == *which) {
3540 //
3541 // Calculating P
3542 //
3543 cumfnc(f,dfn,dfd,phonc,p,q);
3544 *status = 0;
3545 }
3546 else if(2 == *which) {
3547 //
3548 // Calculating F
3549 //
3550 *f = 5.0e0;
3551 T2 = inf;
3552 T5 = atol;
3553 T6 = tol;
3554 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
3555 *status = 0;
3556 dinvr(status,f,&fx,&qleft,&qhi);
3557 S160:
3558 if(!(*status == 1)) goto S170;
3559 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3560 fx = cum-*p;
3561 dinvr(status,f,&fx,&qleft,&qhi);
3562 goto S160;
3563 S170:
3564 if(!(*status == -1)) goto S200;
3565 if(!qleft) goto S180;
3566 *status = 1;
3567 *bound = 0.0e0;
3568 goto S190;
3569 S180:
3570 *status = 2;
3571 *bound = inf;
3572 S200:
3573 S190:
3574 ;
3575 }
3576 else if(3 == *which) {
3577 //
3578 // Calculating DFN
3579 //
3580 *dfn = 5.0e0;
3581 T7 = zero;
3582 T8 = inf;
3583 T9 = atol;
3584 T10 = tol;
3585 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
3586 *status = 0;
3587 dinvr(status,dfn,&fx,&qleft,&qhi);
3588 S210:
3589 if(!(*status == 1)) goto S220;
3590 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3591 fx = cum-*p;
3592 dinvr(status,dfn,&fx,&qleft,&qhi);
3593 goto S210;
3594 S220:
3595 if(!(*status == -1)) goto S250;
3596 if(!qleft) goto S230;
3597 *status = 1;
3598 *bound = zero;
3599 goto S240;
3600 S230:
3601 *status = 2;
3602 *bound = inf;
3603 S250:
3604 S240:
3605 ;
3606 }
3607 else if(4 == *which) {
3608 //
3609 // Calculating DFD
3610 //
3611 *dfd = 5.0e0;
3612 T11 = zero;
3613 T12 = inf;
3614 T13 = atol;
3615 T14 = tol;
3616 dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14);
3617 *status = 0;
3618 dinvr(status,dfd,&fx,&qleft,&qhi);
3619 S260:
3620 if(!(*status == 1)) goto S270;
3621 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3622 fx = cum-*p;
3623 dinvr(status,dfd,&fx,&qleft,&qhi);
3624 goto S260;
3625 S270:
3626 if(!(*status == -1)) goto S300;
3627 if(!qleft) goto S280;
3628 *status = 1;
3629 *bound = zero;
3630 goto S290;
3631 S280:
3632 *status = 2;
3633 *bound = inf;
3634 S300:
3635 S290:
3636 ;
3637 }
3638 else if(5 == *which) {
3639 //
3640 // Calculating PHONC
3641 //
3642 *phonc = 5.0e0;
3643 T15 = tent4;
3644 T16 = atol;
3645 T17 = tol;
3646 dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17);
3647 *status = 0;
3648 dinvr(status,phonc,&fx,&qleft,&qhi);
3649 S310:
3650 if(!(*status == 1)) goto S320;
3651 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3652 fx = cum-*p;
3653 dinvr(status,phonc,&fx,&qleft,&qhi);
3654 goto S310;
3655 S320:
3656 if(!(*status == -1)) goto S350;
3657 if(!qleft) goto S330;
3658 *status = 1;
3659 *bound = 0.0e0;
3660 goto S340;
3661 S330:
3662 *status = 2;
3663 *bound = tent4;
3664 S340:
3665 ;
3666 }
3667 S350:
3668 return;
3669 # undef tent4
3670 # undef tol
3671 # undef atol
3672 # undef zero
3673 # undef one
3674 # undef inf
3675 }
3676 //****************************************************************************80
3677
cdfgam(int * which,double * p,double * q,double * x,double * shape,double * scale,int * status,double * bound)3678 void cdfgam ( int *which, double *p, double *q, double *x, double *shape,
3679 double *scale, int *status, double *bound )
3680
3681 //****************************************************************************80
3682 //
3683 // Purpose:
3684 //
3685 // CDFGAM evaluates the CDF of the Gamma Distribution.
3686 //
3687 // Discussion:
3688 //
3689 // This routine calculates any one parameter of the Gamma distribution
3690 // given the others.
3691 //
3692 // The cumulative distribution function P is calculated directly.
3693 //
3694 // Computation of the other parameters involves a seach for a value that
3695 // produces the desired value of P. The search relies on the
3696 // monotonicity of P with respect to the other parameters.
3697 //
3698 // The gamma density is proportional to T**(SHAPE - 1) * EXP(- SCALE * T)
3699 //
3700 // Reference:
3701 //
3702 // Armido DiDinato and Alfred Morris,
3703 // Computation of the incomplete gamma function ratios and their inverse,
3704 // ACM Transactions on Mathematical Software,
3705 // Volume 12, 1986, pages 377-393.
3706 //
3707 // Parameters:
3708 //
3709 // Input, int *WHICH, indicates which argument is to be calculated
3710 // from the others.
3711 // 1: Calculate P and Q from X, SHAPE and SCALE;
3712 // 2: Calculate X from P, Q, SHAPE and SCALE;
3713 // 3: Calculate SHAPE from P, Q, X and SCALE;
3714 // 4: Calculate SCALE from P, Q, X and SHAPE.
3715 //
3716 // Input/output, double *P, the integral from 0 to X of the
3717 // Gamma density. If this is an input value, it should lie in the
3718 // range: [0,1].
3719 //
3720 // Input/output, double *Q, equal to 1-P. If Q is an input
3721 // value, it should lie in the range [0,1]. If Q is an output value,
3722 // it will lie in the range [0,1].
3723 //
3724 // Input/output, double *X, the upper limit of integration of
3725 // the Gamma density. If this is an input value, it should lie in the
3726 // range: [0, +infinity). If it is an output value, it will lie in
3727 // the range: [0,1E300].
3728 //
3729 // Input/output, double *SHAPE, the shape parameter of the
3730 // Gamma density. If this is an input value, it should lie in the range:
3731 // (0, +infinity). If it is an output value, it will be searched for
3732 // in the range: [1.0D-300,1.0D+300].
3733 //
3734 // Input/output, double *SCALE, the scale parameter of the
3735 // Gamma density. If this is an input value, it should lie in the range
3736 // (0, +infinity). If it is an output value, it will be searched for
3737 // in the range: (1.0D-300,1.0D+300].
3738 //
3739 // Output, int *STATUS, reports the status of the computation.
3740 // 0, if the calculation completed correctly;
3741 // -I, if the input parameter number I is out of range;
3742 // +1, if the answer appears to be lower than lowest search bound;
3743 // +2, if the answer appears to be higher than greatest search bound;
3744 // +3, if P + Q /= 1;
3745 // +10, if the Gamma or inverse Gamma routine cannot compute the answer.
3746 // This usually happens only for X and SHAPE very large (more than 1.0D+10.
3747 //
3748 // Output, double *BOUND, is only defined if STATUS is nonzero.
3749 // If STATUS is negative, then this is the value exceeded by parameter I.
3750 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3751 //
3752 {
3753 # define tol (1.0e-8)
3754 # define atol (1.0e-50)
3755 # define zero (1.0e-300)
3756 # define inf 1.0e300
3757
3758 static int K1 = 1;
3759 static double K5 = 0.5e0;
3760 static double K6 = 5.0e0;
3761 static double xx,fx,xscale,cum,ccum,pq,porq;
3762 static int ierr;
3763 static unsigned long qhi,qleft,qporq;
3764 static double T2,T3,T4,T7,T8,T9;
3765
3766 *status = 0;
3767 *bound = 0.0;
3768 //
3769 // Check arguments
3770 //
3771 if(!(*which < 1 || *which > 4)) goto S30;
3772 if(!(*which < 1)) goto S10;
3773 *bound = 1.0e0;
3774 goto S20;
3775 S10:
3776 *bound = 4.0e0;
3777 S20:
3778 *status = -1;
3779 return;
3780 S30:
3781 if(*which == 1) goto S70;
3782 //
3783 // P
3784 //
3785 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3786 if(!(*p < 0.0e0)) goto S40;
3787 *bound = 0.0e0;
3788 goto S50;
3789 S40:
3790 *bound = 1.0e0;
3791 S50:
3792 *status = -2;
3793 return;
3794 S70:
3795 S60:
3796 if(*which == 1) goto S110;
3797 //
3798 // Q
3799 //
3800 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3801 if(!(*q <= 0.0e0)) goto S80;
3802 *bound = 0.0e0;
3803 goto S90;
3804 S80:
3805 *bound = 1.0e0;
3806 S90:
3807 *status = -3;
3808 return;
3809 S110:
3810 S100:
3811 if(*which == 2) goto S130;
3812 //
3813 // X
3814 //
3815 if(!(*x < 0.0e0)) goto S120;
3816 *bound = 0.0e0;
3817 *status = -4;
3818 return;
3819 S130:
3820 S120:
3821 if(*which == 3) goto S150;
3822 //
3823 // SHAPE
3824 //
3825 if(!(*shape <= 0.0e0)) goto S140;
3826 *bound = 0.0e0;
3827 *status = -5;
3828 return;
3829 S150:
3830 S140:
3831 if(*which == 4) goto S170;
3832 //
3833 // SCALE
3834 //
3835 if(!(*scale <= 0.0e0)) goto S160;
3836 *bound = 0.0e0;
3837 *status = -6;
3838 return;
3839 S170:
3840 S160:
3841 if(*which == 1) goto S210;
3842 //
3843 // P + Q
3844 //
3845 pq = *p+*q;
3846 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S200;
3847 if(!(pq < 0.0e0)) goto S180;
3848 *bound = 0.0e0;
3849 goto S190;
3850 S180:
3851 *bound = 1.0e0;
3852 S190:
3853 *status = 3;
3854 return;
3855 S210:
3856 S200:
3857 if(*which == 1) goto S240;
3858 //
3859 // Select the minimum of P or Q
3860 //
3861 qporq = *p <= *q;
3862 if(!qporq) goto S220;
3863 porq = *p;
3864 goto S230;
3865 S220:
3866 porq = *q;
3867 S240:
3868 S230:
3869 //
3870 // Calculate ANSWERS
3871 //
3872 if(1 == *which) {
3873 //
3874 // Calculating P
3875 //
3876 *status = 0;
3877 xscale = *x**scale;
3878 cumgam(&xscale,shape,p,q);
3879 if(porq > 1.5e0) *status = 10;
3880 }
3881 else if(2 == *which) {
3882 //
3883 // Computing X
3884 //
3885 T2 = -1.0e0;
3886 gamma_inc_inv ( shape, &xx, &T2, p, q, &ierr );
3887 if(ierr < 0.0e0) {
3888 *status = 10;
3889 return;
3890 }
3891 else {
3892 *x = xx/ *scale;
3893 *status = 0;
3894 }
3895 }
3896 else if(3 == *which) {
3897 //
3898 // Computing SHAPE
3899 //
3900 *shape = 5.0e0;
3901 xscale = *x**scale;
3902 T3 = zero;
3903 T4 = inf;
3904 T7 = atol;
3905 T8 = tol;
3906 dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8);
3907 *status = 0;
3908 dinvr(status,shape,&fx,&qleft,&qhi);
3909 S250:
3910 if(!(*status == 1)) goto S290;
3911 cumgam(&xscale,shape,&cum,&ccum);
3912 if(!qporq) goto S260;
3913 fx = cum-*p;
3914 goto S270;
3915 S260:
3916 fx = ccum-*q;
3917 S270:
3918 if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280;
3919 *status = 10;
3920 return;
3921 S280:
3922 dinvr(status,shape,&fx,&qleft,&qhi);
3923 goto S250;
3924 S290:
3925 if(!(*status == -1)) goto S320;
3926 if(!qleft) goto S300;
3927 *status = 1;
3928 *bound = zero;
3929 goto S310;
3930 S300:
3931 *status = 2;
3932 *bound = inf;
3933 S320:
3934 S310:
3935 ;
3936 }
3937 else if(4 == *which) {
3938 //
3939 // Computing SCALE
3940 //
3941 T9 = -1.0e0;
3942 gamma_inc_inv ( shape, &xx, &T9, p, q, &ierr );
3943 if(ierr < 0.0e0) {
3944 *status = 10;
3945 return;
3946 }
3947 else {
3948 *scale = xx/ *x;
3949 *status = 0;
3950 }
3951 }
3952 return;
3953 # undef tol
3954 # undef atol
3955 # undef zero
3956 # undef inf
3957 }
3958 //****************************************************************************80
3959
cdfnbn(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)3960 void cdfnbn ( int *which, double *p, double *q, double *s, double *xn,
3961 double *pr, double *ompr, int *status, double *bound )
3962
3963 //****************************************************************************80
3964 //
3965 // Purpose:
3966 //
3967 // CDFNBN evaluates the CDF of the Negative Binomial distribution
3968 //
3969 // Discussion:
3970 //
3971 // This routine calculates any one parameter of the negative binomial
3972 // distribution given values for the others.
3973 //
3974 // The cumulative negative binomial distribution returns the
3975 // probability that there will be F or fewer failures before the
3976 // S-th success in binomial trials each of which has probability of
3977 // success PR.
3978 //
3979 // The individual term of the negative binomial is the probability of
3980 // F failures before S successes and is
3981 // Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F
3982 //
3983 // Computation of other parameters involve a seach for a value that
3984 // produces the desired value of P. The search relies on the
3985 // monotonicity of P with respect to the other parameters.
3986 //
3987 // Reference:
3988 //
3989 // Milton Abramowitz and Irene Stegun,
3990 // Handbook of Mathematical Functions
3991 // 1966, Formula 26.5.26.
3992 //
3993 // Parameters:
3994 //
3995 // Input, int WHICH, indicates which argument is to be calculated
3996 // from the others.
3997 // 1: Calculate P and Q from F, S, PR and OMPR;
3998 // 2: Calculate F from P, Q, S, PR and OMPR;
3999 // 3: Calculate S from P, Q, F, PR and OMPR;
4000 // 4: Calculate PR and OMPR from P, Q, F and S.
4001 //
4002 // Input/output, double P, the cumulation from 0 to F of
4003 // the negative binomial distribution. If P is an input value, it
4004 // should lie in the range [0,1].
4005 //
4006 // Input/output, double Q, equal to 1-P. If Q is an input
4007 // value, it should lie in the range [0,1]. If Q is an output value,
4008 // it will lie in the range [0,1].
4009 //
4010 // Input/output, double F, the upper limit of cumulation of
4011 // the binomial distribution. There are F or fewer failures before
4012 // the S-th success. If this is an input value, it may lie in the
4013 // range [0,+infinity), and if it is an output value, it will be searched
4014 // for in the range [0,1.0D+300].
4015 //
4016 // Input/output, double S, the number of successes.
4017 // If this is an input value, it should lie in the range: [0, +infinity).
4018 // If it is an output value, it will be searched for in the range:
4019 // [0, 1.0D+300].
4020 //
4021 // Input/output, double PR, the probability of success in each
4022 // binomial trial. Whether an input or output value, it should lie in the
4023 // range [0,1].
4024 //
4025 // Input/output, double OMPR, the value of (1-PR). Whether an
4026 // input or output value, it should lie in the range [0,1].
4027 //
4028 // Output, int STATUS, reports the status of the computation.
4029 // 0, if the calculation completed correctly;
4030 // -I, if the input parameter number I is out of range;
4031 // +1, if the answer appears to be lower than lowest search bound;
4032 // +2, if the answer appears to be higher than greatest search bound;
4033 // +3, if P + Q /= 1;
4034 // +4, if PR + OMPR /= 1.
4035 //
4036 // Output, double BOUND, is only defined if STATUS is nonzero.
4037 // If STATUS is negative, then this is the value exceeded by parameter I.
4038 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4039 //
4040 {
4041 # define tol (1.0e-8)
4042 # define atol (1.0e-50)
4043 # define inf 1.0e300
4044 # define one 1.0e0
4045
4046 static int K1 = 1;
4047 static double K2 = 0.0e0;
4048 static double K4 = 0.5e0;
4049 static double K5 = 5.0e0;
4050 static double K11 = 1.0e0;
4051 static double fx,xhi,xlo,pq,prompr,cum,ccum;
4052 static unsigned long qhi,qleft,qporq;
4053 static double T3,T6,T7,T8,T9,T10,T12,T13;
4054
4055 *status = 0;
4056 *bound = 0.0;
4057 //
4058 // Check arguments
4059 //
4060 if(!(*which < 1 || *which > 4)) goto S30;
4061 if(!(*which < 1)) goto S10;
4062 *bound = 1.0e0;
4063 goto S20;
4064 S10:
4065 *bound = 4.0e0;
4066 S20:
4067 *status = -1;
4068 return;
4069 S30:
4070 if(*which == 1) goto S70;
4071 //
4072 // P
4073 //
4074 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4075 if(!(*p < 0.0e0)) goto S40;
4076 *bound = 0.0e0;
4077 goto S50;
4078 S40:
4079 *bound = 1.0e0;
4080 S50:
4081 *status = -2;
4082 return;
4083 S70:
4084 S60:
4085 if(*which == 1) goto S110;
4086 //
4087 // Q
4088 //
4089 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4090 if(!(*q <= 0.0e0)) goto S80;
4091 *bound = 0.0e0;
4092 goto S90;
4093 S80:
4094 *bound = 1.0e0;
4095 S90:
4096 *status = -3;
4097 return;
4098 S110:
4099 S100:
4100 if(*which == 2) goto S130;
4101 //
4102 // S
4103 //
4104 if(!(*s < 0.0e0)) goto S120;
4105 *bound = 0.0e0;
4106 *status = -4;
4107 return;
4108 S130:
4109 S120:
4110 if(*which == 3) goto S150;
4111 //
4112 // XN
4113 //
4114 if(!(*xn < 0.0e0)) goto S140;
4115 *bound = 0.0e0;
4116 *status = -5;
4117 return;
4118 S150:
4119 S140:
4120 if(*which == 4) goto S190;
4121 //
4122 // PR
4123 //
4124 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180;
4125 if(!(*pr < 0.0e0)) goto S160;
4126 *bound = 0.0e0;
4127 goto S170;
4128 S160:
4129 *bound = 1.0e0;
4130 S170:
4131 *status = -6;
4132 return;
4133 S190:
4134 S180:
4135 if(*which == 4) goto S230;
4136 //
4137 // OMPR
4138 //
4139 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220;
4140 if(!(*ompr < 0.0e0)) goto S200;
4141 *bound = 0.0e0;
4142 goto S210;
4143 S200:
4144 *bound = 1.0e0;
4145 S210:
4146 *status = -7;
4147 return;
4148 S230:
4149 S220:
4150 if(*which == 1) goto S270;
4151 //
4152 // P + Q
4153 //
4154 pq = *p+*q;
4155 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S260;
4156 if(!(pq < 0.0e0)) goto S240;
4157 *bound = 0.0e0;
4158 goto S250;
4159 S240:
4160 *bound = 1.0e0;
4161 S250:
4162 *status = 3;
4163 return;
4164 S270:
4165 S260:
4166 if(*which == 4) goto S310;
4167 //
4168 // PR + OMPR
4169 //
4170 prompr = *pr+*ompr;
4171 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S300;
4172 if(!(prompr < 0.0e0)) goto S280;
4173 *bound = 0.0e0;
4174 goto S290;
4175 S280:
4176 *bound = 1.0e0;
4177 S290:
4178 *status = 4;
4179 return;
4180 S310:
4181 S300:
4182 if(!(*which == 1)) qporq = *p <= *q;
4183 //
4184 // Select the minimum of P or Q
4185 // Calculate ANSWERS
4186 //
4187 if(1 == *which) {
4188 //
4189 // Calculating P
4190 //
4191 cumnbn(s,xn,pr,ompr,p,q);
4192 *status = 0;
4193 }
4194 else if(2 == *which) {
4195 //
4196 // Calculating S
4197 //
4198 *s = 5.0e0;
4199 T3 = inf;
4200 T6 = atol;
4201 T7 = tol;
4202 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4203 *status = 0;
4204 dinvr(status,s,&fx,&qleft,&qhi);
4205 S320:
4206 if(!(*status == 1)) goto S350;
4207 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4208 if(!qporq) goto S330;
4209 fx = cum-*p;
4210 goto S340;
4211 S330:
4212 fx = ccum-*q;
4213 S340:
4214 dinvr(status,s,&fx,&qleft,&qhi);
4215 goto S320;
4216 S350:
4217 if(!(*status == -1)) goto S380;
4218 if(!qleft) goto S360;
4219 *status = 1;
4220 *bound = 0.0e0;
4221 goto S370;
4222 S360:
4223 *status = 2;
4224 *bound = inf;
4225 S380:
4226 S370:
4227 ;
4228 }
4229 else if(3 == *which) {
4230 //
4231 // Calculating XN
4232 //
4233 *xn = 5.0e0;
4234 T8 = inf;
4235 T9 = atol;
4236 T10 = tol;
4237 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4238 *status = 0;
4239 dinvr(status,xn,&fx,&qleft,&qhi);
4240 S390:
4241 if(!(*status == 1)) goto S420;
4242 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4243 if(!qporq) goto S400;
4244 fx = cum-*p;
4245 goto S410;
4246 S400:
4247 fx = ccum-*q;
4248 S410:
4249 dinvr(status,xn,&fx,&qleft,&qhi);
4250 goto S390;
4251 S420:
4252 if(!(*status == -1)) goto S450;
4253 if(!qleft) goto S430;
4254 *status = 1;
4255 *bound = 0.0e0;
4256 goto S440;
4257 S430:
4258 *status = 2;
4259 *bound = inf;
4260 S450:
4261 S440:
4262 ;
4263 }
4264 else if(4 == *which) {
4265 //
4266 // Calculating PR and OMPR
4267 //
4268 T12 = atol;
4269 T13 = tol;
4270 dstzr(&K2,&K11,&T12,&T13);
4271 if(!qporq) goto S480;
4272 *status = 0;
4273 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4274 *ompr = one-*pr;
4275 S460:
4276 if(!(*status == 1)) goto S470;
4277 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4278 fx = cum-*p;
4279 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4280 *ompr = one-*pr;
4281 goto S460;
4282 S470:
4283 goto S510;
4284 S480:
4285 *status = 0;
4286 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4287 *pr = one-*ompr;
4288 S490:
4289 if(!(*status == 1)) goto S500;
4290 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4291 fx = ccum-*q;
4292 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4293 *pr = one-*ompr;
4294 goto S490;
4295 S510:
4296 S500:
4297 if(!(*status == -1)) goto S540;
4298 if(!qleft) goto S520;
4299 *status = 1;
4300 *bound = 0.0e0;
4301 goto S530;
4302 S520:
4303 *status = 2;
4304 *bound = 1.0e0;
4305 S530:
4306 ;
4307 }
4308 S540:
4309 return;
4310 # undef tol
4311 # undef atol
4312 # undef inf
4313 # undef one
4314 }
4315 //****************************************************************************80
4316
cdfnor(int * which,double * p,double * q,double * x,double * mean,double * sd,int * status,double * bound)4317 void cdfnor ( int *which, double *p, double *q, double *x, double *mean,
4318 double *sd, int *status, double *bound )
4319
4320 //****************************************************************************80
4321 //
4322 // Purpose:
4323 //
4324 // CDFNOR evaluates the CDF of the Normal distribution.
4325 //
4326 // Discussion:
4327 //
4328 // A slightly modified version of ANORM from SPECFUN
4329 // is used to calculate the cumulative standard normal distribution.
4330 //
4331 // The rational functions from pages 90-95 of Kennedy and Gentle
4332 // are used as starting values to Newton's Iterations which
4333 // compute the inverse standard normal. Therefore no searches are
4334 // necessary for any parameter.
4335 //
4336 // For X < -15, the asymptotic expansion for the normal is used as
4337 // the starting value in finding the inverse standard normal.
4338 //
4339 // The normal density is proportional to
4340 // exp( - 0.5D+00 * (( X - MEAN)/SD)**2)
4341 //
4342 // Reference:
4343 //
4344 // Milton Abramowitz and Irene Stegun,
4345 // Handbook of Mathematical Functions
4346 // 1966, Formula 26.2.12.
4347 //
4348 // William Cody,
4349 // Algorithm 715: SPECFUN - A Portable FORTRAN Package of
4350 // Special Function Routines and Test Drivers,
4351 // ACM Transactions on Mathematical Software,
4352 // Volume 19, pages 22-32, 1993.
4353 //
4354 // Kennedy and Gentle,
4355 // Statistical Computing,
4356 // Marcel Dekker, NY, 1980,
4357 // QA276.4 K46
4358 //
4359 // Parameters:
4360 //
4361 // Input, int *WHICH, indicates which argument is to be calculated
4362 // from the others.
4363 // 1: Calculate P and Q from X, MEAN and SD;
4364 // 2: Calculate X from P, Q, MEAN and SD;
4365 // 3: Calculate MEAN from P, Q, X and SD;
4366 // 4: Calculate SD from P, Q, X and MEAN.
4367 //
4368 // Input/output, double *P, the integral from -infinity to X
4369 // of the Normal density. If this is an input or output value, it will
4370 // lie in the range [0,1].
4371 //
4372 // Input/output, double *Q, equal to 1-P. If Q is an input
4373 // value, it should lie in the range [0,1]. If Q is an output value,
4374 // it will lie in the range [0,1].
4375 //
4376 // Input/output, double *X, the upper limit of integration of
4377 // the Normal density.
4378 //
4379 // Input/output, double *MEAN, the mean of the Normal density.
4380 //
4381 // Input/output, double *SD, the standard deviation of the
4382 // Normal density. If this is an input value, it should lie in the
4383 // range (0,+infinity).
4384 //
4385 // Output, int *STATUS, the status of the calculation.
4386 // 0, if calculation completed correctly;
4387 // -I, if input parameter number I is out of range;
4388 // 1, if answer appears to be lower than lowest search bound;
4389 // 2, if answer appears to be higher than greatest search bound;
4390 // 3, if P + Q /= 1.
4391 //
4392 // Output, double *BOUND, is only defined if STATUS is nonzero.
4393 // If STATUS is negative, then this is the value exceeded by parameter I.
4394 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4395 //
4396 {
4397 static int K1 = 1;
4398 static double z,pq;
4399
4400 *status = 0;
4401 *bound = 0.0;
4402 //
4403 // Check arguments
4404 //
4405 *status = 0;
4406 if(!(*which < 1 || *which > 4)) goto S30;
4407 if(!(*which < 1)) goto S10;
4408 *bound = 1.0e0;
4409 goto S20;
4410 S10:
4411 *bound = 4.0e0;
4412 S20:
4413 *status = -1;
4414 return;
4415 S30:
4416 if(*which == 1) goto S70;
4417 //
4418 // P
4419 //
4420 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4421 if(!(*p <= 0.0e0)) goto S40;
4422 *bound = 0.0e0;
4423 goto S50;
4424 S40:
4425 *bound = 1.0e0;
4426 S50:
4427 *status = -2;
4428 return;
4429 S70:
4430 S60:
4431 if(*which == 1) goto S110;
4432 //
4433 // Q
4434 //
4435 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4436 if(!(*q <= 0.0e0)) goto S80;
4437 *bound = 0.0e0;
4438 goto S90;
4439 S80:
4440 *bound = 1.0e0;
4441 S90:
4442 *status = -3;
4443 return;
4444 S110:
4445 S100:
4446 if(*which == 1) goto S150;
4447 //
4448 // P + Q
4449 //
4450 pq = *p+*q;
4451 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S140;
4452 if(!(pq < 0.0e0)) goto S120;
4453 *bound = 0.0e0;
4454 goto S130;
4455 S120:
4456 *bound = 1.0e0;
4457 S130:
4458 *status = 3;
4459 return;
4460 S150:
4461 S140:
4462 if(*which == 4) goto S170;
4463 //
4464 // SD
4465 //
4466 if(!(*sd <= 0.0e0)) goto S160;
4467 *bound = 0.0e0;
4468 *status = -6;
4469 return;
4470 S170:
4471 S160:
4472 //
4473 // Calculate ANSWERS
4474 //
4475 if(1 == *which) {
4476 //
4477 // Computing P
4478 //
4479 z = (*x-*mean)/ *sd;
4480 cumnor(&z,p,q);
4481 }
4482 else if(2 == *which) {
4483 //
4484 // Computing X
4485 //
4486 z = dinvnr(p,q);
4487 *x = *sd*z+*mean;
4488 }
4489 else if(3 == *which) {
4490 //
4491 // Computing the MEAN
4492 //
4493 z = dinvnr(p,q);
4494 *mean = *x-*sd*z;
4495 }
4496 else if(4 == *which) {
4497 //
4498 // Computing SD
4499 //
4500 z = dinvnr(p,q);
4501 *sd = (*x-*mean)/z;
4502 }
4503 return;
4504 }
4505 //****************************************************************************80
4506
cdfpoi(int * which,double * p,double * q,double * s,double * xlam,int * status,double * bound)4507 void cdfpoi ( int *which, double *p, double *q, double *s, double *xlam,
4508 int *status, double *bound )
4509
4510 //****************************************************************************80
4511 //
4512 // Purpose:
4513 //
4514 // CDFPOI evaluates the CDF of the Poisson distribution.
4515 //
4516 // Discussion:
4517 //
4518 // This routine calculates any one parameter of the Poisson distribution
4519 // given the others.
4520 //
4521 // The value P of the cumulative distribution function is calculated
4522 // directly.
4523 //
4524 // Computation of other parameters involve a seach for a value that
4525 // produces the desired value of P. The search relies on the
4526 // monotonicity of P with respect to the other parameters.
4527 //
4528 // Reference:
4529 //
4530 // Milton Abramowitz and Irene Stegun,
4531 // Handbook of Mathematical Functions
4532 // 1966, Formula 26.4.21.
4533 //
4534 // Parameters:
4535 //
4536 // Input, int *WHICH, indicates which argument is to be calculated
4537 // from the others.
4538 // 1: Calculate P and Q from S and XLAM;
4539 // 2: Calculate A from P, Q and XLAM;
4540 // 3: Calculate XLAM from P, Q and S.
4541 //
4542 // Input/output, double *P, the cumulation from 0 to S of the
4543 // Poisson density. Whether this is an input or output value, it will
4544 // lie in the range [0,1].
4545 //
4546 // Input/output, double *Q, equal to 1-P. If Q is an input
4547 // value, it should lie in the range [0,1]. If Q is an output value,
4548 // it will lie in the range [0,1].
4549 //
4550 // Input/output, double *S, the upper limit of cumulation of
4551 // the Poisson CDF. If this is an input value, it should lie in
4552 // the range: [0, +infinity). If it is an output value, it will be
4553 // searched for in the range: [0,1.0D+300].
4554 //
4555 // Input/output, double *XLAM, the mean of the Poisson
4556 // distribution. If this is an input value, it should lie in the range
4557 // [0, +infinity). If it is an output value, it will be searched for
4558 // in the range: [0,1E300].
4559 //
4560 // Output, int *STATUS, reports the status of the computation.
4561 // 0, if the calculation completed correctly;
4562 // -I, if the input parameter number I is out of range;
4563 // +1, if the answer appears to be lower than lowest search bound;
4564 // +2, if the answer appears to be higher than greatest search bound;
4565 // +3, if P + Q /= 1.
4566 //
4567 // Output, double *BOUND, is only defined if STATUS is nonzero.
4568 // If STATUS is negative, then this is the value exceeded by parameter I.
4569 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4570 //
4571 {
4572 # define tol (1.0e-8)
4573 # define atol (1.0e-50)
4574 # define inf 1.0e300
4575
4576 static int K1 = 1;
4577 static double K2 = 0.0e0;
4578 static double K4 = 0.5e0;
4579 static double K5 = 5.0e0;
4580 static double fx,cum,ccum,pq;
4581 static unsigned long qhi,qleft,qporq;
4582 static double T3,T6,T7,T8,T9,T10;
4583
4584 *status = 0;
4585 *bound = 0.0;
4586 //
4587 // Check arguments
4588 //
4589 if(!(*which < 1 || *which > 3)) goto S30;
4590 if(!(*which < 1)) goto S10;
4591 *bound = 1.0e0;
4592 goto S20;
4593 S10:
4594 *bound = 3.0e0;
4595 S20:
4596 *status = -1;
4597 return;
4598 S30:
4599 if(*which == 1) goto S70;
4600 //
4601 // P
4602 //
4603 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4604 if(!(*p < 0.0e0)) goto S40;
4605 *bound = 0.0e0;
4606 goto S50;
4607 S40:
4608 *bound = 1.0e0;
4609 S50:
4610 *status = -2;
4611 return;
4612 S70:
4613 S60:
4614 if(*which == 1) goto S110;
4615 //
4616 // Q
4617 //
4618 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4619 if(!(*q <= 0.0e0)) goto S80;
4620 *bound = 0.0e0;
4621 goto S90;
4622 S80:
4623 *bound = 1.0e0;
4624 S90:
4625 *status = -3;
4626 return;
4627 S110:
4628 S100:
4629 if(*which == 2) goto S130;
4630 //
4631 // S
4632 //
4633 if(!(*s < 0.0e0)) goto S120;
4634 *bound = 0.0e0;
4635 *status = -4;
4636 return;
4637 S130:
4638 S120:
4639 if(*which == 3) goto S150;
4640 //
4641 // XLAM
4642 //
4643 if(!(*xlam < 0.0e0)) goto S140;
4644 *bound = 0.0e0;
4645 *status = -5;
4646 return;
4647 S150:
4648 S140:
4649 if(*which == 1) goto S190;
4650 //
4651 // P + Q
4652 //
4653 pq = *p+*q;
4654 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S180;
4655 if(!(pq < 0.0e0)) goto S160;
4656 *bound = 0.0e0;
4657 goto S170;
4658 S160:
4659 *bound = 1.0e0;
4660 S170:
4661 *status = 3;
4662 return;
4663 S190:
4664 S180:
4665 if(!(*which == 1)) qporq = *p <= *q;
4666 //
4667 // Select the minimum of P or Q
4668 // Calculate ANSWERS
4669 //
4670 if(1 == *which) {
4671 //
4672 // Calculating P
4673 //
4674 cumpoi(s,xlam,p,q);
4675 *status = 0;
4676 }
4677 else if(2 == *which) {
4678 //
4679 // Calculating S
4680 //
4681 *s = 5.0e0;
4682 T3 = inf;
4683 T6 = atol;
4684 T7 = tol;
4685 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4686 *status = 0;
4687 dinvr(status,s,&fx,&qleft,&qhi);
4688 S200:
4689 if(!(*status == 1)) goto S230;
4690 cumpoi(s,xlam,&cum,&ccum);
4691 if(!qporq) goto S210;
4692 fx = cum-*p;
4693 goto S220;
4694 S210:
4695 fx = ccum-*q;
4696 S220:
4697 dinvr(status,s,&fx,&qleft,&qhi);
4698 goto S200;
4699 S230:
4700 if(!(*status == -1)) goto S260;
4701 if(!qleft) goto S240;
4702 *status = 1;
4703 *bound = 0.0e0;
4704 goto S250;
4705 S240:
4706 *status = 2;
4707 *bound = inf;
4708 S260:
4709 S250:
4710 ;
4711 }
4712 else if(3 == *which) {
4713 //
4714 // Calculating XLAM
4715 //
4716 *xlam = 5.0e0;
4717 T8 = inf;
4718 T9 = atol;
4719 T10 = tol;
4720 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4721 *status = 0;
4722 dinvr(status,xlam,&fx,&qleft,&qhi);
4723 S270:
4724 if(!(*status == 1)) goto S300;
4725 cumpoi(s,xlam,&cum,&ccum);
4726 if(!qporq) goto S280;
4727 fx = cum-*p;
4728 goto S290;
4729 S280:
4730 fx = ccum-*q;
4731 S290:
4732 dinvr(status,xlam,&fx,&qleft,&qhi);
4733 goto S270;
4734 S300:
4735 if(!(*status == -1)) goto S330;
4736 if(!qleft) goto S310;
4737 *status = 1;
4738 *bound = 0.0e0;
4739 goto S320;
4740 S310:
4741 *status = 2;
4742 *bound = inf;
4743 S320:
4744 ;
4745 }
4746 S330:
4747 return;
4748 # undef tol
4749 # undef atol
4750 # undef inf
4751 }
4752 //****************************************************************************80
4753
cdft(int * which,double * p,double * q,double * t,double * df,int * status,double * bound)4754 void cdft ( int *which, double *p, double *q, double *t, double *df,
4755 int *status, double *bound )
4756
4757 //****************************************************************************80
4758 //
4759 // Purpose:
4760 //
4761 // CDFT evaluates the CDF of the T distribution.
4762 //
4763 // Discussion:
4764 //
4765 // This routine calculates any one parameter of the T distribution
4766 // given the others.
4767 //
4768 // The value P of the cumulative distribution function is calculated
4769 // directly.
4770 //
4771 // Computation of other parameters involve a seach for a value that
4772 // produces the desired value of P. The search relies on the
4773 // monotonicity of P with respect to the other parameters.
4774 //
4775 // The original version of this routine allowed the search interval
4776 // to extend from -1.0E+300 to +1.0E+300, which is fine until you
4777 // try to evaluate a function at such a point!
4778 //
4779 // Reference:
4780 //
4781 // Milton Abramowitz and Irene Stegun,
4782 // Handbook of Mathematical Functions
4783 // 1966, Formula 26.5.27.
4784 //
4785 // Parameters:
4786 //
4787 // Input, int *WHICH, indicates which argument is to be calculated
4788 // from the others.
4789 // 1 : Calculate P and Q from T and DF;
4790 // 2 : Calculate T from P, Q and DF;
4791 // 3 : Calculate DF from P, Q and T.
4792 //
4793 // Input/output, double *P, the integral from -infinity to T of
4794 // the T-density. Whether an input or output value, this will lie in the
4795 // range [0,1].
4796 //
4797 // Input/output, double *Q, equal to 1-P. If Q is an input
4798 // value, it should lie in the range [0,1]. If Q is an output value,
4799 // it will lie in the range [0,1].
4800 //
4801 // Input/output, double *T, the upper limit of integration of
4802 // the T-density. If this is an input value, it may have any value.
4803 // It it is an output value, it will be searched for in the range
4804 // [ -1.0D+30, 1.0D+30 ].
4805 //
4806 // Input/output, double *DF, the number of degrees of freedom
4807 // of the T distribution. If this is an input value, it should lie
4808 // in the range: (0 , +infinity). If it is an output value, it will be
4809 // searched for in the range: [1, 1.0D+10].
4810 //
4811 // Output, int *STATUS, reports the status of the computation.
4812 // 0, if the calculation completed correctly;
4813 // -I, if the input parameter number I is out of range;
4814 // +1, if the answer appears to be lower than lowest search bound;
4815 // +2, if the answer appears to be higher than greatest search bound;
4816 // +3, if P + Q /= 1.
4817 //
4818 // Output, double *BOUND, is only defined if STATUS is nonzero.
4819 // If STATUS is negative, then this is the value exceeded by parameter I.
4820 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4821 //
4822 {
4823 # define tol (1.0e-8)
4824 # define atol (1.0e-50)
4825 # define zero (1.0e-300)
4826 # define inf 1.0e30
4827 # define maxdf 1.0e10
4828
4829 static int K1 = 1;
4830 static double K4 = 0.5e0;
4831 static double K5 = 5.0e0;
4832 static double fx,cum,ccum,pq;
4833 static unsigned long qhi,qleft,qporq;
4834 static double T2,T3,T6,T7,T8,T9,T10,T11;
4835
4836 *status = 0;
4837 *bound = 0.0;
4838 //
4839 // Check arguments
4840 //
4841 if(!(*which < 1 || *which > 3)) goto S30;
4842 if(!(*which < 1)) goto S10;
4843 *bound = 1.0e0;
4844 goto S20;
4845 S10:
4846 *bound = 3.0e0;
4847 S20:
4848 *status = -1;
4849 return;
4850 S30:
4851 if(*which == 1) goto S70;
4852 //
4853 // P
4854 //
4855 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4856 if(!(*p <= 0.0e0)) goto S40;
4857 *bound = 0.0e0;
4858 goto S50;
4859 S40:
4860 *bound = 1.0e0;
4861 S50:
4862 *status = -2;
4863 return;
4864 S70:
4865 S60:
4866 if(*which == 1) goto S110;
4867 //
4868 // Q
4869 //
4870 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4871 if(!(*q <= 0.0e0)) goto S80;
4872 *bound = 0.0e0;
4873 goto S90;
4874 S80:
4875 *bound = 1.0e0;
4876 S90:
4877 *status = -3;
4878 return;
4879 S110:
4880 S100:
4881 if(*which == 3) goto S130;
4882 //
4883 // DF
4884 //
4885 if(!(*df <= 0.0e0)) goto S120;
4886 *bound = 0.0e0;
4887 *status = -5;
4888 return;
4889 S130:
4890 S120:
4891 if(*which == 1) goto S170;
4892 //
4893 // P + Q
4894 //
4895 pq = *p+*q;
4896 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S160;
4897 if(!(pq < 0.0e0)) goto S140;
4898 *bound = 0.0e0;
4899 goto S150;
4900 S140:
4901 *bound = 1.0e0;
4902 S150:
4903 *status = 3;
4904 return;
4905 S170:
4906 S160:
4907 if(!(*which == 1)) qporq = *p <= *q;
4908 //
4909 // Select the minimum of P or Q
4910 // Calculate ANSWERS
4911 //
4912 if(1 == *which) {
4913 //
4914 // Computing P and Q
4915 //
4916 cumt(t,df,p,q);
4917 *status = 0;
4918 }
4919 else if(2 == *which) {
4920 //
4921 // Computing T
4922 // .. Get initial approximation for T
4923 //
4924 *t = dt1(p,q,df);
4925 T2 = -inf;
4926 T3 = inf;
4927 T6 = atol;
4928 T7 = tol;
4929 dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7);
4930 *status = 0;
4931 dinvr(status,t,&fx,&qleft,&qhi);
4932 S180:
4933 if(!(*status == 1)) goto S210;
4934 cumt(t,df,&cum,&ccum);
4935 if(!qporq) goto S190;
4936 fx = cum-*p;
4937 goto S200;
4938 S190:
4939 fx = ccum-*q;
4940 S200:
4941 dinvr(status,t,&fx,&qleft,&qhi);
4942 goto S180;
4943 S210:
4944 if(!(*status == -1)) goto S240;
4945 if(!qleft) goto S220;
4946 *status = 1;
4947 *bound = -inf;
4948 goto S230;
4949 S220:
4950 *status = 2;
4951 *bound = inf;
4952 S240:
4953 S230:
4954 ;
4955 }
4956 else if(3 == *which) {
4957 //
4958 // Computing DF
4959 //
4960 *df = 5.0e0;
4961 T8 = zero;
4962 T9 = maxdf;
4963 T10 = atol;
4964 T11 = tol;
4965 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
4966 *status = 0;
4967 dinvr(status,df,&fx,&qleft,&qhi);
4968 S250:
4969 if(!(*status == 1)) goto S280;
4970 cumt(t,df,&cum,&ccum);
4971 if(!qporq) goto S260;
4972 fx = cum-*p;
4973 goto S270;
4974 S260:
4975 fx = ccum-*q;
4976 S270:
4977 dinvr(status,df,&fx,&qleft,&qhi);
4978 goto S250;
4979 S280:
4980 if(!(*status == -1)) goto S310;
4981 if(!qleft) goto S290;
4982 *status = 1;
4983 *bound = zero;
4984 goto S300;
4985 S290:
4986 *status = 2;
4987 *bound = maxdf;
4988 S300:
4989 ;
4990 }
4991 S310:
4992 return;
4993 # undef tol
4994 # undef atol
4995 # undef zero
4996 # undef inf
4997 # undef maxdf
4998 }
4999 //****************************************************************************80
5000
chi_noncentral_cdf_values(int * n_data,double * x,double * lambda,int * df,double * cdf)5001 void chi_noncentral_cdf_values ( int *n_data, double *x, double *lambda,
5002 int *df, double *cdf )
5003
5004 //****************************************************************************80
5005 //
5006 // Purpose:
5007 //
5008 // CHI_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF.
5009 //
5010 // Discussion:
5011 //
5012 // The CDF of the noncentral chi square distribution can be evaluated
5013 // within Mathematica by commands such as:
5014 //
5015 // Needs["Statistics`ContinuousDistributions`"]
5016 // CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
5017 //
5018 // Modified:
5019 //
5020 // 12 June 2004
5021 //
5022 // Author:
5023 //
5024 // John Burkardt
5025 //
5026 // Reference:
5027 //
5028 // Stephen Wolfram,
5029 // The Mathematica Book,
5030 // Fourth Edition,
5031 // Wolfram Media / Cambridge University Press, 1999.
5032 //
5033 // Parameters:
5034 //
5035 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
5036 // first call. On each call, the routine increments N_DATA by 1, and
5037 // returns the corresponding data; when there is no more data, the
5038 // output value of N_DATA will be 0 again.
5039 //
5040 // Output, double *X, the argument of the function.
5041 //
5042 // Output, double *LAMBDA, the noncentrality parameter.
5043 //
5044 // Output, int *DF, the number of degrees of freedom.
5045 //
5046 // Output, double *CDF, the noncentral chi CDF.
5047 //
5048 {
5049 # define N_MAX 27
5050
5051 double cdf_vec[N_MAX] = {
5052 0.839944E+00, 0.695906E+00, 0.535088E+00,
5053 0.764784E+00, 0.620644E+00, 0.469167E+00,
5054 0.307088E+00, 0.220382E+00, 0.150025E+00,
5055 0.307116E-02, 0.176398E-02, 0.981679E-03,
5056 0.165175E-01, 0.202342E-03, 0.498448E-06,
5057 0.151325E-01, 0.209041E-02, 0.246502E-03,
5058 0.263684E-01, 0.185798E-01, 0.130574E-01,
5059 0.583804E-01, 0.424978E-01, 0.308214E-01,
5060 0.105788E+00, 0.794084E-01, 0.593201E-01 };
5061 int df_vec[N_MAX] = {
5062 1, 2, 3,
5063 1, 2, 3,
5064 1, 2, 3,
5065 1, 2, 3,
5066 60, 80, 100,
5067 1, 2, 3,
5068 10, 10, 10,
5069 10, 10, 10,
5070 10, 10, 10 };
5071 double lambda_vec[N_MAX] = {
5072 0.5E+00, 0.5E+00, 0.5E+00,
5073 1.0E+00, 1.0E+00, 1.0E+00,
5074 5.0E+00, 5.0E+00, 5.0E+00,
5075 20.0E+00, 20.0E+00, 20.0E+00,
5076 30.0E+00, 30.0E+00, 30.0E+00,
5077 5.0E+00, 5.0E+00, 5.0E+00,
5078 2.0E+00, 3.0E+00, 4.0E+00,
5079 2.0E+00, 3.0E+00, 4.0E+00,
5080 2.0E+00, 3.0E+00, 4.0E+00 };
5081 double x_vec[N_MAX] = {
5082 3.000E+00, 3.000E+00, 3.000E+00,
5083 3.000E+00, 3.000E+00, 3.000E+00,
5084 3.000E+00, 3.000E+00, 3.000E+00,
5085 3.000E+00, 3.000E+00, 3.000E+00,
5086 60.000E+00, 60.000E+00, 60.000E+00,
5087 0.050E+00, 0.050E+00, 0.050E+00,
5088 4.000E+00, 4.000E+00, 4.000E+00,
5089 5.000E+00, 5.000E+00, 5.000E+00,
5090 6.000E+00, 6.000E+00, 6.000E+00 };
5091
5092 if ( *n_data < 0 )
5093 {
5094 *n_data = 0;
5095 }
5096
5097 *n_data = *n_data + 1;
5098
5099 if ( N_MAX < *n_data )
5100 {
5101 *n_data = 0;
5102 *x = 0.0E+00;
5103 *lambda = 0.0E+00;
5104 *df = 0;
5105 *cdf = 0.0E+00;
5106 }
5107 else
5108 {
5109 *x = x_vec[*n_data-1];
5110 *lambda = lambda_vec[*n_data-1];
5111 *df = df_vec[*n_data-1];
5112 *cdf = cdf_vec[*n_data-1];
5113 }
5114
5115 return;
5116 # undef N_MAX
5117 }
5118 //****************************************************************************80
5119
chi_square_cdf_values(int * n_data,int * a,double * x,double * fx)5120 void chi_square_cdf_values ( int *n_data, int *a, double *x, double *fx )
5121
5122 //****************************************************************************80
5123 //
5124 // Purpose:
5125 //
5126 // CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF.
5127 //
5128 // Discussion:
5129 //
5130 // The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by
5131 // commands like:
5132 //
5133 // Needs["Statistics`ContinuousDistributions`"]
5134 // CDF[ChiSquareDistribution[DF], X ]
5135 //
5136 // Modified:
5137 //
5138 // 11 June 2004
5139 //
5140 // Author:
5141 //
5142 // John Burkardt
5143 //
5144 // Reference:
5145 //
5146 // Milton Abramowitz and Irene Stegun,
5147 // Handbook of Mathematical Functions,
5148 // US Department of Commerce, 1964.
5149 //
5150 // Stephen Wolfram,
5151 // The Mathematica Book,
5152 // Fourth Edition,
5153 // Wolfram Media / Cambridge University Press, 1999.
5154 //
5155 // Parameters:
5156 //
5157 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
5158 // first call. On each call, the routine increments N_DATA by 1, and
5159 // returns the corresponding data; when there is no more data, the
5160 // output value of N_DATA will be 0 again.
5161 //
5162 // Output, int *A, the parameter of the function.
5163 //
5164 // Output, double *X, the argument of the function.
5165 //
5166 // Output, double *FX, the value of the function.
5167 //
5168 {
5169 # define N_MAX 21
5170
5171 int a_vec[N_MAX] = {
5172 1, 2, 1, 2,
5173 1, 2, 3, 4,
5174 1, 2, 3, 4,
5175 5, 3, 3, 3,
5176 3, 3, 10, 10,
5177 10 };
5178 double fx_vec[N_MAX] = {
5179 0.0796557E+00, 0.00498752E+00, 0.112463E+00, 0.00995017E+00,
5180 0.472911E+00, 0.181269E+00, 0.0597575E+00, 0.0175231E+00,
5181 0.682689E+00, 0.393469E+00, 0.198748E+00, 0.090204E+00,
5182 0.0374342E+00, 0.427593E+00, 0.608375E+00, 0.738536E+00,
5183 0.828203E+00, 0.88839E+00, 0.000172116E+00, 0.00365985E+00,
5184 0.0185759E+00 };
5185 double x_vec[N_MAX] = {
5186 0.01E+00, 0.01E+00, 0.02E+00, 0.02E+00,
5187 0.40E+00, 0.40E+00, 0.40E+00, 0.40E+00,
5188 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
5189 1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,
5190 5.00E+00, 6.00E+00, 1.00E+00, 2.00E+00,
5191 3.00E+00 };
5192
5193 if ( *n_data < 0 )
5194 {
5195 *n_data = 0;
5196 }
5197
5198 *n_data = *n_data + 1;
5199
5200 if ( N_MAX < *n_data )
5201 {
5202 *n_data = 0;
5203 *a = 0;
5204 *x = 0.0E+00;
5205 *fx = 0.0E+00;
5206 }
5207 else
5208 {
5209 *a = a_vec[*n_data-1];
5210 *x = x_vec[*n_data-1];
5211 *fx = fx_vec[*n_data-1];
5212 }
5213 return;
5214 # undef N_MAX
5215 }
5216 //****************************************************************************80
5217
cumbet(double * x,double * y,double * a,double * b,double * cum,double * ccum)5218 void cumbet ( double *x, double *y, double *a, double *b, double *cum,
5219 double *ccum )
5220
5221 //****************************************************************************80
5222 //
5223 // Purpose:
5224 //
5225 // CUMBET evaluates the cumulative incomplete beta distribution.
5226 //
5227 // Discussion:
5228 //
5229 // This routine calculates the CDF to X of the incomplete beta distribution
5230 // with parameters A and B. This is the integral from 0 to x
5231 // of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
5232 //
5233 // Modified:
5234 //
5235 // 14 March 2006
5236 //
5237 // Reference:
5238 //
5239 // A R Didonato and Alfred Morris,
5240 // Algorithm 708:
5241 // Significant Digit Computation of the Incomplete Beta Function Ratios.
5242 // ACM Transactions on Mathematical Software,
5243 // Volume 18, Number 3, September 1992, pages 360-373.
5244 //
5245 // Parameters:
5246 //
5247 // Input, double *X, the upper limit of integration.
5248 //
5249 // Input, double *Y, the value of 1-X.
5250 //
5251 // Input, double *A, *B, the parameters of the distribution.
5252 //
5253 // Output, double *CUM, *CCUM, the values of the cumulative
5254 // density function and complementary cumulative density function.
5255 //
5256 {
5257 static int ierr;
5258
5259 if ( *x <= 0.0 )
5260 {
5261 *cum = 0.0;
5262 *ccum = 1.0;
5263 }
5264 else if ( *y <= 0.0 )
5265 {
5266 *cum = 1.0;
5267 *ccum = 0.0;
5268 }
5269 else
5270 {
5271 beta_inc ( a, b, x, y, cum, ccum, &ierr );
5272 }
5273 return;
5274 }
5275 //****************************************************************************80
5276
cumbin(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5277 void cumbin ( double *s, double *xn, double *pr, double *ompr,
5278 double *cum, double *ccum )
5279
5280 //****************************************************************************80
5281 //
5282 // Purpose:
5283 //
5284 // CUMBIN evaluates the cumulative binomial distribution.
5285 //
5286 // Discussion:
5287 //
5288 // This routine returns the probability of 0 to S successes in XN binomial
5289 // trials, each of which has a probability of success, PR.
5290 //
5291 // Modified:
5292 //
5293 // 14 March 2006
5294 //
5295 // Reference:
5296 //
5297 // Milton Abramowitz and Irene Stegun,
5298 // Handbook of Mathematical Functions
5299 // 1966, Formula 26.5.24.
5300 //
5301 // Parameters:
5302 //
5303 // Input, double *S, the upper limit of summation.
5304 //
5305 // Input, double *XN, the number of trials.
5306 //
5307 // Input, double *PR, the probability of success in one trial.
5308 //
5309 // Input, double *OMPR, equals ( 1 - PR ).
5310 //
5311 // Output, double *CUM, the cumulative binomial distribution.
5312 //
5313 // Output, double *CCUM, the complement of the cumulative
5314 // binomial distribution.
5315 //
5316 {
5317 static double T1,T2;
5318
5319 if ( *s < *xn )
5320 {
5321 T1 = *s + 1.0;
5322 T2 = *xn - *s;
5323 cumbet ( pr, ompr, &T1, &T2, ccum, cum );
5324 }
5325 else
5326 {
5327 *cum = 1.0;
5328 *ccum = 0.0;
5329 }
5330 return;
5331 }
5332 //****************************************************************************80
5333
cumchi(double * x,double * df,double * cum,double * ccum)5334 void cumchi ( double *x, double *df, double *cum, double *ccum )
5335
5336 //****************************************************************************80
5337 //
5338 // Purpose:
5339 //
5340 // CUMCHI evaluates the cumulative chi-square distribution.
5341 //
5342 // Parameters:
5343 //
5344 // Input, double *X, the upper limit of integration.
5345 //
5346 // Input, double *DF, the degrees of freedom of the
5347 // chi-square distribution.
5348 //
5349 // Output, double *CUM, the cumulative chi-square distribution.
5350 //
5351 // Output, double *CCUM, the complement of the cumulative
5352 // chi-square distribution.
5353 //
5354 {
5355 static double a;
5356 static double xx;
5357
5358 a = *df * 0.5;
5359 xx = *x * 0.5;
5360 cumgam ( &xx, &a, cum, ccum );
5361 return;
5362 }
5363 //****************************************************************************80
5364
cumchn(double * x,double * df,double * pnonc,double * cum,double * ccum)5365 void cumchn ( double *x, double *df, double *pnonc, double *cum,
5366 double *ccum )
5367
5368 //****************************************************************************80
5369 //
5370 // Purpose:
5371 //
5372 // CUMCHN evaluates the cumulative noncentral chi-square distribution.
5373 //
5374 // Discussion:
5375 //
5376 // Calculates the cumulative noncentral chi-square
5377 // distribution, i.e., the probability that a random variable
5378 // which follows the noncentral chi-square distribution, with
5379 // noncentrality parameter PNONC and continuous degrees of
5380 // freedom DF, is less than or equal to X.
5381 //
5382 // Reference:
5383 //
5384 // Milton Abramowitz and Irene Stegun,
5385 // Handbook of Mathematical Functions
5386 // 1966, Formula 26.4.25.
5387 //
5388 // Parameters:
5389 //
5390 // Input, double *X, the upper limit of integration.
5391 //
5392 // Input, double *DF, the number of degrees of freedom.
5393 //
5394 // Input, double *PNONC, the noncentrality parameter of
5395 // the noncentral chi-square distribution.
5396 //
5397 // Output, double *CUM, *CCUM, the CDF and complementary
5398 // CDF of the noncentral chi-square distribution.
5399 //
5400 // Local Parameters:
5401 //
5402 // Local, double EPS, the convergence criterion. The sum
5403 // stops when a term is less than EPS*SUM.
5404 //
5405 // Local, int NTIRED, the maximum number of terms to be evaluated
5406 // in each sum.
5407 //
5408 // Local, bool QCONV, is TRUE if convergence was achieved, that is,
5409 // the program did not stop on NTIRED criterion.
5410 //
5411 {
5412 # define dg(i) (*df+2.0e0*(double)(i))
5413 # define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum)
5414 # define qtired(i) (int)((i) > ntired)
5415
5416 static double eps = 1.0e-5;
5417 static int ntired = 1000;
5418 static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum,
5419 sumadj,term,wt,xnonc;
5420 static int i,icent,iterb,iterf;
5421 static double T1,T2,T3;
5422
5423 if(!(*x <= 0.0e0)) goto S10;
5424 *cum = 0.0e0;
5425 *ccum = 1.0e0;
5426 return;
5427 S10:
5428 if(!(*pnonc <= 1.0e-10)) goto S20;
5429 //
5430 // When non-centrality parameter is (essentially) zero,
5431 // use cumulative chi-square distribution
5432 //
5433 cumchi(x,df,cum,ccum);
5434 return;
5435 S20:
5436 xnonc = *pnonc/2.0e0;
5437 //
5438 // The following code calculates the weight, chi-square, and
5439 // adjustment term for the central term in the infinite series.
5440 // The central term is the one in which the poisson weight is
5441 // greatest. The adjustment term is the amount that must
5442 // be subtracted from the chi-square to move up two degrees
5443 // of freedom.
5444 //
5445 icent = fifidint(xnonc);
5446 if(icent == 0) icent = 1;
5447 chid2 = *x/2.0e0;
5448 //
5449 // Calculate central weight term
5450 //
5451 T1 = (double)(icent+1);
5452 lfact = gamma_log ( &T1 );
5453 lcntwt = -xnonc+(double)icent*log(xnonc)-lfact;
5454 centwt = exp(lcntwt);
5455 //
5456 // Calculate central chi-square
5457 //
5458 T2 = dg(icent);
5459 cumchi(x,&T2,&pcent,ccum);
5460 //
5461 // Calculate central adjustment term
5462 //
5463 dfd2 = dg(icent)/2.0e0;
5464 T3 = 1.0e0+dfd2;
5465 lfact = gamma_log ( &T3 );
5466 lcntaj = dfd2*log(chid2)-chid2-lfact;
5467 centaj = exp(lcntaj);
5468 sum = centwt*pcent;
5469 //
5470 // Sum backwards from the central term towards zero.
5471 // Quit whenever either
5472 // (1) the zero term is reached, or
5473 // (2) the term gets small relative to the sum, or
5474 // (3) More than NTIRED terms are totaled.
5475 //
5476 iterb = 0;
5477 sumadj = 0.0e0;
5478 adj = centaj;
5479 wt = centwt;
5480 i = icent;
5481 goto S40;
5482 S30:
5483 if(qtired(iterb) || qsmall(term) || i == 0) goto S50;
5484 S40:
5485 dfd2 = dg(i)/2.0e0;
5486 //
5487 // Adjust chi-square for two fewer degrees of freedom.
5488 // The adjusted value ends up in PTERM.
5489 //
5490 adj = adj*dfd2/chid2;
5491 sumadj = sumadj + adj;
5492 pterm = pcent+sumadj;
5493 //
5494 // Adjust poisson weight for J decreased by one
5495 //
5496 wt *= ((double)i/xnonc);
5497 term = wt*pterm;
5498 sum = sum + term;
5499 i -= 1;
5500 iterb = iterb + 1;
5501 goto S30;
5502 S50:
5503 iterf = 0;
5504 //
5505 // Now sum forward from the central term towards infinity.
5506 // Quit when either
5507 // (1) the term gets small relative to the sum, or
5508 // (2) More than NTIRED terms are totaled.
5509 //
5510 sumadj = adj = centaj;
5511 wt = centwt;
5512 i = icent;
5513 goto S70;
5514 S60:
5515 if(qtired(iterf) || qsmall(term)) goto S80;
5516 S70:
5517 //
5518 // Update weights for next higher J
5519 //
5520 wt *= (xnonc/(double)(i+1));
5521 //
5522 // Calculate PTERM and add term to sum
5523 //
5524 pterm = pcent-sumadj;
5525 term = wt*pterm;
5526 sum = sum + term;
5527 //
5528 // Update adjustment term for DF for next iteration
5529 //
5530 i = i + 1;
5531 dfd2 = dg(i)/2.0e0;
5532 adj = adj*chid2/dfd2;
5533 sumadj = sum + adj;
5534 iterf = iterf + 1;
5535 goto S60;
5536 S80:
5537 *cum = sum;
5538 *ccum = 0.5e0+(0.5e0-*cum);
5539 return;
5540 # undef dg
5541 # undef qsmall
5542 # undef qtired
5543 }
5544 //****************************************************************************80
5545
cumf(double * f,double * dfn,double * dfd,double * cum,double * ccum)5546 void cumf ( double *f, double *dfn, double *dfd, double *cum, double *ccum )
5547
5548 //****************************************************************************80
5549 //
5550 // Purpose:
5551 //
5552 // CUMF evaluates the cumulative F distribution.
5553 //
5554 // Discussion:
5555 //
5556 // CUMF computes the integral from 0 to F of the F density with DFN
5557 // numerator and DFD denominator degrees of freedom.
5558 //
5559 // Reference:
5560 //
5561 // Milton Abramowitz and Irene Stegun,
5562 // Handbook of Mathematical Functions
5563 // 1966, Formula 26.5.28.
5564 //
5565 // Parameters:
5566 //
5567 // Input, double *F, the upper limit of integration.
5568 //
5569 // Input, double *DFN, *DFD, the number of degrees of
5570 // freedom for the numerator and denominator.
5571 //
5572 // Output, double *CUM, *CCUM, the value of the F CDF and
5573 // the complementary F CDF.
5574 //
5575 {
5576 # define half 0.5e0
5577 # define done 1.0e0
5578
5579 static double dsum,prod,xx,yy;
5580 static int ierr;
5581 static double T1,T2;
5582
5583 if(!(*f <= 0.0e0)) goto S10;
5584 *cum = 0.0e0;
5585 *ccum = 1.0e0;
5586 return;
5587 S10:
5588 prod = *dfn**f;
5589 //
5590 // XX is such that the incomplete beta with parameters
5591 // DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
5592 // YY is 1 - XX
5593 // Calculate the smaller of XX and YY accurately
5594 //
5595 dsum = *dfd+prod;
5596 xx = *dfd/dsum;
5597
5598 if ( xx > half )
5599 {
5600 yy = prod/dsum;
5601 xx = done-yy;
5602 }
5603 else
5604 {
5605 yy = done-xx;
5606 }
5607
5608 T1 = *dfd*half;
5609 T2 = *dfn*half;
5610 beta_inc ( &T1, &T2, &xx, &yy, ccum, cum, &ierr );
5611 return;
5612 # undef half
5613 # undef done
5614 }
5615 //****************************************************************************80
5616
cumfnc(double * f,double * dfn,double * dfd,double * pnonc,double * cum,double * ccum)5617 void cumfnc ( double *f, double *dfn, double *dfd, double *pnonc,
5618 double *cum, double *ccum )
5619
5620 //****************************************************************************80
5621 //
5622 // Purpose:
5623 //
5624 // CUMFNC evaluates the cumulative noncentral F distribution.
5625 //
5626 // Discussion:
5627 //
5628 // This routine computes the noncentral F distribution with DFN and DFD
5629 // degrees of freedom and noncentrality parameter PNONC.
5630 //
5631 // The series is calculated backward and forward from J = LAMBDA/2
5632 // (this is the term with the largest Poisson weight) until
5633 // the convergence criterion is met.
5634 //
5635 // The sum continues until a succeeding term is less than EPS
5636 // times the sum (or the sum is less than 1.0e-20). EPS is
5637 // set to 1.0e-4 in a data statement which can be changed.
5638 //
5639 //
5640 // The original version of this routine allowed the input values
5641 // of DFN and DFD to be negative (nonsensical) or zero (which
5642 // caused numerical overflow.) I have forced both these values
5643 // to be at least 1.
5644 //
5645 // Modified:
5646 //
5647 // 15 June 2004
5648 //
5649 // Reference:
5650 //
5651 // Milton Abramowitz and Irene Stegun,
5652 // Handbook of Mathematical Functions
5653 // 1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20.
5654 //
5655 // Parameters:
5656 //
5657 // Input, double *F, the upper limit of integration.
5658 //
5659 // Input, double *DFN, *DFD, the number of degrees of freedom
5660 // in the numerator and denominator. Both DFN and DFD must be positive,
5661 // and normally would be integers. This routine requires that they
5662 // be no less than 1.
5663 //
5664 // Input, double *PNONC, the noncentrality parameter.
5665 //
5666 // Output, double *CUM, *CCUM, the noncentral F CDF and
5667 // complementary CDF.
5668 //
5669 {
5670 # define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)
5671 # define half 0.5e0
5672 # define done 1.0e0
5673
5674 static double eps = 1.0e-4;
5675 static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,
5676 upterm,xmult,xnonc;
5677 static int i,icent,ierr;
5678 static double T1,T2,T3,T4,T5,T6;
5679
5680 if(!(*f <= 0.0e0)) goto S10;
5681 *cum = 0.0e0;
5682 *ccum = 1.0e0;
5683 return;
5684 S10:
5685 if(!(*pnonc < 1.0e-10)) goto S20;
5686 //
5687 // Handle case in which the non-centrality parameter is
5688 // (essentially) zero.
5689 //
5690 cumf(f,dfn,dfd,cum,ccum);
5691 return;
5692 S20:
5693 xnonc = *pnonc/2.0e0;
5694 //
5695 // Calculate the central term of the poisson weighting factor.
5696 //
5697 icent = ( int ) xnonc;
5698 if(icent == 0) icent = 1;
5699 //
5700 // Compute central weight term
5701 //
5702 T1 = (double)(icent+1);
5703 centwt = exp(-xnonc+(double)icent*log(xnonc)- gamma_log ( &T1 ) );
5704 //
5705 // Compute central incomplete beta term
5706 // Assure that minimum of arg to beta and 1 - arg is computed
5707 // accurately.
5708 //
5709 prod = *dfn**f;
5710 dsum = *dfd+prod;
5711 yy = *dfd/dsum;
5712 if(yy > half) {
5713 xx = prod/dsum;
5714 yy = done-xx;
5715 }
5716 else xx = done-yy;
5717 T2 = *dfn*half+(double)icent;
5718 T3 = *dfd*half;
5719 beta_inc ( &T2, &T3, &xx, &yy, &betdn, &dummy, &ierr );
5720 adn = *dfn/2.0e0+(double)icent;
5721 aup = adn;
5722 b = *dfd/2.0e0;
5723 betup = betdn;
5724 sum = centwt*betdn;
5725 //
5726 // Now sum terms backward from icent until convergence or all done
5727 //
5728 xmult = centwt;
5729 i = icent;
5730 T4 = adn+b;
5731 T5 = adn+1.0e0;
5732 dnterm = exp( gamma_log ( &T4 ) - gamma_log ( &T5 )
5733 - gamma_log ( &b ) + adn * log ( xx ) + b * log(yy));
5734 S30:
5735 if(qsmall(xmult*betdn) || i <= 0) goto S40;
5736 xmult *= ((double)i/xnonc);
5737 i -= 1;
5738 adn -= 1.0;
5739 dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;
5740 betdn += dnterm;
5741 sum += (xmult*betdn);
5742 goto S30;
5743 S40:
5744 i = icent+1;
5745 //
5746 // Now sum forwards until convergence
5747 //
5748 xmult = centwt;
5749 if(aup-1.0+b == 0) upterm = exp(-gamma_log ( &aup )
5750 - gamma_log ( &b ) + (aup-1.0)*log(xx)+
5751 b*log(yy));
5752 else {
5753 T6 = aup-1.0+b;
5754 upterm = exp( gamma_log ( &T6 ) - gamma_log ( &aup )
5755 - gamma_log ( &b ) + (aup-1.0)*log(xx)+b*
5756 log(yy));
5757 }
5758 goto S60;
5759 S50:
5760 if(qsmall(xmult*betup)) goto S70;
5761 S60:
5762 xmult *= (xnonc/(double)i);
5763 i += 1;
5764 aup += 1.0;
5765 upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;
5766 betup -= upterm;
5767 sum += (xmult*betup);
5768 goto S50;
5769 S70:
5770 *cum = sum;
5771 *ccum = 0.5e0+(0.5e0-*cum);
5772 return;
5773 # undef qsmall
5774 # undef half
5775 # undef done
5776 }
5777 //****************************************************************************80
5778
cumgam(double * x,double * a,double * cum,double * ccum)5779 void cumgam ( double *x, double *a, double *cum, double *ccum )
5780
5781 //****************************************************************************80
5782 //
5783 // Purpose:
5784 //
5785 // CUMGAM evaluates the cumulative incomplete gamma distribution.
5786 //
5787 // Discussion:
5788 //
5789 // This routine computes the cumulative distribution function of the
5790 // incomplete gamma distribution, i.e., the integral from 0 to X of
5791 //
5792 // (1/GAM(A))*EXP(-T)*T**(A-1) DT
5793 //
5794 // where GAM(A) is the complete gamma function of A, i.e.,
5795 //
5796 // GAM(A) = integral from 0 to infinity of EXP(-T)*T**(A-1) DT
5797 //
5798 // Parameters:
5799 //
5800 // Input, double *X, the upper limit of integration.
5801 //
5802 // Input, double *A, the shape parameter of the incomplete
5803 // Gamma distribution.
5804 //
5805 // Output, double *CUM, *CCUM, the incomplete Gamma CDF and
5806 // complementary CDF.
5807 //
5808 {
5809 static int K1 = 0;
5810
5811 if(!(*x <= 0.0e0)) goto S10;
5812 *cum = 0.0e0;
5813 *ccum = 1.0e0;
5814 return;
5815 S10:
5816 gamma_inc ( a, x, cum, ccum, &K1 );
5817 //
5818 // Call gratio routine
5819 //
5820 return;
5821 }
5822 //****************************************************************************80
5823
cumnbn(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5824 void cumnbn ( double *s, double *xn, double *pr, double *ompr,
5825 double *cum, double *ccum )
5826
5827 //****************************************************************************80
5828 //
5829 // Purpose:
5830 //
5831 // CUMNBN evaluates the cumulative negative binomial distribution.
5832 //
5833 // Discussion:
5834 //
5835 // This routine returns the probability that there will be F or
5836 // fewer failures before there are S successes, with each binomial
5837 // trial having a probability of success PR.
5838 //
5839 // Prob(# failures = F | S successes, PR) =
5840 // ( S + F - 1 )
5841 // ( ) * PR^S * (1-PR)^F
5842 // ( F )
5843 //
5844 // Reference:
5845 //
5846 // Milton Abramowitz and Irene Stegun,
5847 // Handbook of Mathematical Functions
5848 // 1966, Formula 26.5.26.
5849 //
5850 // Parameters:
5851 //
5852 // Input, double *F, the number of failures.
5853 //
5854 // Input, double *S, the number of successes.
5855 //
5856 // Input, double *PR, *OMPR, the probability of success on
5857 // each binomial trial, and the value of (1-PR).
5858 //
5859 // Output, double *CUM, *CCUM, the negative binomial CDF,
5860 // and the complementary CDF.
5861 //
5862 {
5863 static double T1;
5864
5865 T1 = *s+1.e0;
5866 cumbet(pr,ompr,xn,&T1,cum,ccum);
5867 return;
5868 }
5869 //****************************************************************************80
5870
cumnor(double * arg,double * result,double * ccum)5871 void cumnor ( double *arg, double *result, double *ccum )
5872
5873 //****************************************************************************80
5874 //
5875 // Purpose:
5876 //
5877 // CUMNOR computes the cumulative normal distribution.
5878 //
5879 // Discussion:
5880 //
5881 // This function evaluates the normal distribution function:
5882 //
5883 // / x
5884 // 1 | -t*t/2
5885 // P(x) = ----------- | e dt
5886 // sqrt(2 pi) |
5887 // /-oo
5888 //
5889 // This transportable program uses rational functions that
5890 // theoretically approximate the normal distribution function to
5891 // at least 18 significant decimal digits. The accuracy achieved
5892 // depends on the arithmetic system, the compiler, the intrinsic
5893 // functions, and proper selection of the machine-dependent
5894 // constants.
5895 //
5896 // Author:
5897 //
5898 // William Cody
5899 // Mathematics and Computer Science Division
5900 // Argonne National Laboratory
5901 // Argonne, IL 60439
5902 //
5903 // Reference:
5904 //
5905 // William Cody,
5906 // Rational Chebyshev approximations for the error function,
5907 // Mathematics of Computation,
5908 // 1969, pages 631-637.
5909 //
5910 // William Cody,
5911 // Algorithm 715:
5912 // SPECFUN - A Portable FORTRAN Package of Special Function Routines
5913 // and Test Drivers,
5914 // ACM Transactions on Mathematical Software,
5915 // Volume 19, 1993, pages 22-32.
5916 //
5917 // Parameters:
5918 //
5919 // Input, double *ARG, the upper limit of integration.
5920 //
5921 // Output, double *CUM, *CCUM, the Normal density CDF and
5922 // complementary CDF.
5923 //
5924 // Local Parameters:
5925 //
5926 // Local, double EPS, the argument below which anorm(x)
5927 // may be represented by 0.5D+00 and above which x*x will not underflow.
5928 // A conservative value is the largest machine number X
5929 // such that 1.0D+00 + X = 1.0D+00 to machine precision.
5930 //
5931 {
5932 static double a[5] = {
5933 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03,
5934 1.8154981253343561249e04,6.5682337918207449113e-2
5935 };
5936 static double b[4] = {
5937 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04,
5938 4.5507789335026729956e04
5939 };
5940 static double c[9] = {
5941 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01,
5942 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03,
5943 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8
5944 };
5945 static double d[8] = {
5946 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03,
5947 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04,
5948 3.8912003286093271411e04,1.9685429676859990727e04
5949 };
5950 static double half = 0.5e0;
5951 static double p[6] = {
5952 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2,
5953 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2
5954 };
5955 static double one = 1.0e0;
5956 static double q[5] = {
5957 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2,
5958 3.78239633202758244e-3,7.29751555083966205e-5
5959 };
5960 static double sixten = 1.60e0;
5961 static double sqrpi = 3.9894228040143267794e-1;
5962 static double thrsh = 0.66291e0;
5963 static double root32 = 5.656854248e0;
5964 static double zero = 0.0e0;
5965 static int K1 = 1;
5966 static int K2 = 2;
5967 static int i;
5968 static double del,eps,temp,x,xden,xnum,y,xsq,min;
5969 //
5970 // Machine dependent constants
5971 //
5972 eps = dpmpar(&K1)*0.5e0;
5973 min = dpmpar(&K2);
5974 x = *arg;
5975 y = fabs(x);
5976 if(y <= thrsh) {
5977 //
5978 // Evaluate anorm for |X| <= 0.66291
5979 //
5980 xsq = zero;
5981 if(y > eps) xsq = x*x;
5982 xnum = a[4]*xsq;
5983 xden = xsq;
5984 for ( i = 0; i < 3; i++ )
5985 {
5986 xnum = (xnum+a[i])*xsq;
5987 xden = (xden+b[i])*xsq;
5988 }
5989 *result = x*(xnum+a[3])/(xden+b[3]);
5990 temp = *result;
5991 *result = half+temp;
5992 *ccum = half-temp;
5993 }
5994 //
5995 // Evaluate anorm for 0.66291 <= |X| <= sqrt(32)
5996 //
5997 else if(y <= root32) {
5998 xnum = c[8]*y;
5999 xden = y;
6000 for ( i = 0; i < 7; i++ )
6001 {
6002 xnum = (xnum+c[i])*y;
6003 xden = (xden+d[i])*y;
6004 }
6005 *result = (xnum+c[7])/(xden+d[7]);
6006 xsq = fifdint(y*sixten)/sixten;
6007 del = (y-xsq)*(y+xsq);
6008 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
6009 *ccum = one-*result;
6010 if(x > zero) {
6011 temp = *result;
6012 *result = *ccum;
6013 *ccum = temp;
6014 }
6015 }
6016 //
6017 // Evaluate anorm for |X| > sqrt(32)
6018 //
6019 else {
6020 *result = zero;
6021 xsq = one/(x*x);
6022 xnum = p[5]*xsq;
6023 xden = xsq;
6024 for ( i = 0; i < 4; i++ )
6025 {
6026 xnum = (xnum+p[i])*xsq;
6027 xden = (xden+q[i])*xsq;
6028 }
6029 *result = xsq*(xnum+p[4])/(xden+q[4]);
6030 *result = (sqrpi-*result)/y;
6031 xsq = fifdint(x*sixten)/sixten;
6032 del = (x-xsq)*(x+xsq);
6033 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
6034 *ccum = one-*result;
6035 if(x > zero) {
6036 temp = *result;
6037 *result = *ccum;
6038 *ccum = temp;
6039 }
6040 }
6041 if(*result < min) *result = 0.0e0;
6042 //
6043 // Fix up for negative argument, erf, etc.
6044 //
6045 if(*ccum < min) *ccum = 0.0e0;
6046 }
6047 //****************************************************************************80
6048
cumpoi(double * s,double * xlam,double * cum,double * ccum)6049 void cumpoi ( double *s, double *xlam, double *cum, double *ccum )
6050
6051 //****************************************************************************80
6052 //
6053 // Purpose:
6054 //
6055 // CUMPOI evaluates the cumulative Poisson distribution.
6056 //
6057 // Discussion:
6058 //
6059 // CUMPOI returns the probability of S or fewer events in a Poisson
6060 // distribution with mean XLAM.
6061 //
6062 // Reference:
6063 //
6064 // Milton Abramowitz and Irene Stegun,
6065 // Handbook of Mathematical Functions,
6066 // Formula 26.4.21.
6067 //
6068 // Parameters:
6069 //
6070 // Input, double *S, the upper limit of cumulation of the
6071 // Poisson density function.
6072 //
6073 // Input, double *XLAM, the mean of the Poisson distribution.
6074 //
6075 // Output, double *CUM, *CCUM, the Poisson density CDF and
6076 // complementary CDF.
6077 //
6078 {
6079 static double chi,df;
6080
6081 df = 2.0e0*(*s+1.0e0);
6082 chi = 2.0e0**xlam;
6083 cumchi(&chi,&df,ccum,cum);
6084 return;
6085 }
6086 //****************************************************************************80
6087
cumt(double * t,double * df,double * cum,double * ccum)6088 void cumt ( double *t, double *df, double *cum, double *ccum )
6089
6090 //****************************************************************************80
6091 //
6092 // Purpose:
6093 //
6094 // CUMT evaluates the cumulative T distribution.
6095 //
6096 // Reference:
6097 //
6098 // Milton Abramowitz and Irene Stegun,
6099 // Handbook of Mathematical Functions,
6100 // Formula 26.5.27.
6101 //
6102 // Parameters:
6103 //
6104 // Input, double *T, the upper limit of integration.
6105 //
6106 // Input, double *DF, the number of degrees of freedom of
6107 // the T distribution.
6108 //
6109 // Output, double *CUM, *CCUM, the T distribution CDF and
6110 // complementary CDF.
6111 //
6112 {
6113 static double a;
6114 static double dfptt;
6115 static double K2 = 0.5e0;
6116 static double oma;
6117 static double T1;
6118 static double tt;
6119 static double xx;
6120 static double yy;
6121
6122 tt = (*t) * (*t);
6123 dfptt = ( *df ) + tt;
6124 xx = *df / dfptt;
6125 yy = tt / dfptt;
6126 T1 = 0.5e0 * ( *df );
6127 cumbet ( &xx, &yy, &T1, &K2, &a, &oma );
6128
6129 if ( *t <= 0.0e0 )
6130 {
6131 *cum = 0.5e0 * a;
6132 *ccum = oma + ( *cum );
6133 }
6134 else
6135 {
6136 *ccum = 0.5e0 * a;
6137 *cum = oma + ( *ccum );
6138 }
6139 return;
6140 }
6141 //****************************************************************************80
6142
dbetrm(double * a,double * b)6143 double dbetrm ( double *a, double *b )
6144
6145 //****************************************************************************80
6146 //
6147 // Purpose:
6148 //
6149 // DBETRM computes the Sterling remainder for the complete beta function.
6150 //
6151 // Discussion:
6152 //
6153 // Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
6154 // where Lgamma is the log of the (complete) gamma function
6155 //
6156 // Let ZZ be approximation obtained if each log gamma is approximated
6157 // by Sterling's formula, i.e.,
6158 // Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5D+00 ) * LOG( Z ) - Z
6159 //
6160 // The Sterling remainder is Log(Beta(A,B)) - ZZ.
6161 //
6162 // Parameters:
6163 //
6164 // Input, double *A, *B, the parameters of the Beta function.
6165 //
6166 // Output, double DBETRM, the Sterling remainder.
6167 //
6168 {
6169 static double dbetrm,T1,T2,T3;
6170 //
6171 // Try to sum from smallest to largest
6172 //
6173 T1 = *a+*b;
6174 dbetrm = -dstrem(&T1);
6175 T2 = fifdmax1(*a,*b);
6176 dbetrm += dstrem(&T2);
6177 T3 = fifdmin1(*a,*b);
6178 dbetrm += dstrem(&T3);
6179 return dbetrm;
6180 }
6181 //****************************************************************************80
6182
dexpm1(double * x)6183 double dexpm1 ( double *x )
6184
6185 //****************************************************************************80
6186 //
6187 // Purpose:
6188 //
6189 // DEXPM1 evaluates the function EXP(X) - 1.
6190 //
6191 // Reference:
6192 //
6193 // Armido DiDinato and Alfred Morris,
6194 // Algorithm 708:
6195 // Significant Digit Computation of the Incomplete Beta Function Ratios,
6196 // ACM Transactions on Mathematical Software,
6197 // Volume 18, 1993, pages 360-373.
6198 //
6199 // Parameters:
6200 //
6201 // Input, double *X, the value at which exp(X)-1 is desired.
6202 //
6203 // Output, double DEXPM1, the value of exp(X)-1.
6204 //
6205 {
6206 static double p1 = .914041914819518e-09;
6207 static double p2 = .238082361044469e-01;
6208 static double q1 = -.499999999085958e+00;
6209 static double q2 = .107141568980644e+00;
6210 static double q3 = -.119041179760821e-01;
6211 static double q4 = .595130811860248e-03;
6212 static double dexpm1;
6213 double w;
6214
6215 if ( fabs(*x) <= 0.15e0 )
6216 {
6217 dexpm1 = *x * ( ( (
6218 p2 * *x
6219 + p1 ) * *x
6220 + 1.0e0 )
6221 /((((
6222 q4 * *x
6223 + q3 ) * *x
6224 + q2 ) * *x
6225 + q1 ) * *x
6226 + 1.0e0 ) );
6227 }
6228 else if ( *x <= 0.0e0 )
6229 {
6230 w = exp(*x);
6231 dexpm1 = w-0.5e0-0.5e0;
6232 }
6233 else
6234 {
6235 w = exp(*x);
6236 dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w));
6237 }
6238
6239 return dexpm1;
6240 }
6241 //****************************************************************************80
6242
dinvnr(double * p,double * q)6243 double dinvnr ( double *p, double *q )
6244
6245 //****************************************************************************80
6246 //
6247 // Purpose:
6248 //
6249 // DINVNR computes the inverse of the normal distribution.
6250 //
6251 // Discussion:
6252 //
6253 // Returns X such that CUMNOR(X) = P, i.e., the integral from -
6254 // infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
6255 //
6256 // The rational function on page 95 of Kennedy and Gentle is used as a start
6257 // value for the Newton method of finding roots.
6258 //
6259 // Reference:
6260 //
6261 // Kennedy and Gentle,
6262 // Statistical Computing,
6263 // Marcel Dekker, NY, 1980,
6264 // QA276.4 K46
6265 //
6266 // Parameters:
6267 //
6268 // Input, double *P, *Q, the probability, and the complementary
6269 // probability.
6270 //
6271 // Output, double DINVNR, the argument X for which the
6272 // Normal CDF has the value P.
6273 //
6274 {
6275 # define maxit 100
6276 # define eps (1.0e-13)
6277 # define r2pi 0.3989422804014326e0
6278 # define nhalf (-0.5e0)
6279 # define dennor(x) (r2pi*exp(nhalf*(x)*(x)))
6280
6281 static double dinvnr,strtx,xcur,cum,ccum,pp,dx;
6282 static int i;
6283 static unsigned long qporq;
6284
6285 //
6286 // FIND MINIMUM OF P AND Q
6287 //
6288 qporq = *p <= *q;
6289 if(!qporq) goto S10;
6290 pp = *p;
6291 goto S20;
6292 S10:
6293 pp = *q;
6294 S20:
6295 //
6296 // INITIALIZATION STEP
6297 //
6298 strtx = stvaln(&pp);
6299 xcur = strtx;
6300 //
6301 // NEWTON INTERATIONS
6302 //
6303 for ( i = 1; i <= maxit; i++ )
6304 {
6305 cumnor(&xcur,&cum,&ccum);
6306 dx = (cum-pp)/dennor(xcur);
6307 xcur -= dx;
6308 if(fabs(dx/xcur) < eps) goto S40;
6309 }
6310 dinvnr = strtx;
6311 //
6312 // IF WE GET HERE, NEWTON HAS FAILED
6313 //
6314 if(!qporq) dinvnr = -dinvnr;
6315 return dinvnr;
6316 S40:
6317 //
6318 // IF WE GET HERE, NEWTON HAS SUCCEDED
6319 //
6320 dinvnr = xcur;
6321 if(!qporq) dinvnr = -dinvnr;
6322 return dinvnr;
6323 # undef maxit
6324 # undef eps
6325 # undef r2pi
6326 # undef nhalf
6327 # undef dennor
6328 }
6329 //****************************************************************************80
6330
dinvr(int * status,double * x,double * fx,unsigned long * qleft,unsigned long * qhi)6331 void dinvr ( int *status, double *x, double *fx,
6332 unsigned long *qleft, unsigned long *qhi )
6333
6334 //****************************************************************************80
6335 //
6336 // Purpose:
6337 //
6338 // DINVR bounds the zero of the function and invokes DZROR.
6339 //
6340 // Discussion:
6341 //
6342 // This routine seeks to find bounds on a root of the function and
6343 // invokes ZROR to perform the zero finding. STINVR must have been
6344 // called before this routine in order to set its parameters.
6345 //
6346 // Reference:
6347 //
6348 // J C P Bus and T J Dekker,
6349 // Two Efficient Algorithms with Guaranteed Convergence for
6350 // Finding a Zero of a Function,
6351 // ACM Transactions on Mathematical Software,
6352 // Volume 1, Number 4, pages 330-345, 1975.
6353 //
6354 // Parameters:
6355 //
6356 // Input/output, integer STATUS. At the beginning of a zero finding
6357 // problem, STATUS should be set to 0 and INVR invoked. The value
6358 // of parameters other than X will be ignored on this call.
6359 // If INVR needs the function to be evaluated, it will set STATUS to 1
6360 // and return. The value of the function should be set in FX and INVR
6361 // again called without changing any of its other parameters.
6362 // If INVR finishes without error, it returns with STATUS 0, and X an
6363 // approximate root of F(X).
6364 // If INVR cannot bound the function, it returns a negative STATUS and
6365 // sets QLEFT and QHI.
6366 //
6367 // Output, double precision X, the value at which F(X) is to be evaluated.
6368 //
6369 // Input, double precision FX, the value of F(X) calculated by the user
6370 // on the previous call, when INVR returned with STATUS = 1.
6371 //
6372 // Output, logical QLEFT, is defined only if QMFINV returns FALSE. In that
6373 // case, QLEFT is TRUE if the stepping search terminated unsucessfully
6374 // at SMALL, and FALSE if the search terminated unsucessfully at BIG.
6375 //
6376 // Output, logical QHI, is defined only if QMFINV returns FALSE. In that
6377 // case, it is TRUE if Y < F(X) at the termination of the search and FALSE
6378 // if F(X) < Y.
6379 //
6380 {
6381 E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL);
6382 }
6383 //****************************************************************************80
6384
dlanor(double * x)6385 double dlanor ( double *x )
6386
6387 //****************************************************************************80
6388 //
6389 // Purpose:
6390 //
6391 // DLANOR evaluates the logarithm of the asymptotic Normal CDF.
6392 //
6393 // Discussion:
6394 //
6395 // This routine computes the logarithm of the cumulative normal distribution
6396 // from abs ( x ) to infinity for 5 <= abs ( X ).
6397 //
6398 // The relative error at X = 5 is about 0.5D-5.
6399 //
6400 // Reference:
6401 //
6402 // Milton Abramowitz and Irene Stegun,
6403 // Handbook of Mathematical Functions
6404 // 1966, Formula 26.2.12.
6405 //
6406 // Parameters:
6407 //
6408 // Input, double *X, the value at which the Normal CDF is to be
6409 // evaluated. It is assumed that 5 <= abs ( X ).
6410 //
6411 // Output, double DLANOR, the logarithm of the asymptotic
6412 // Normal CDF.
6413 //
6414 {
6415 # define dlsqpi 0.91893853320467274177e0
6416
6417 static double coef[12] = {
6418 -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0,
6419 -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0
6420 };
6421 static int K1 = 12;
6422 static double dlanor,approx,correc,xx,xx2,T2;
6423
6424 xx = fabs(*x);
6425 if ( xx < 5.0e0 )
6426 {
6427 ftnstop(" Argument too small in DLANOR");
6428 }
6429 approx = -dlsqpi-0.5e0*xx*xx-log(xx);
6430 xx2 = xx*xx;
6431 T2 = 1.0e0/xx2;
6432 correc = eval_pol ( coef, &K1, &T2 ) / xx2;
6433 correc = alnrel ( &correc );
6434 dlanor = approx+correc;
6435 return dlanor;
6436 # undef dlsqpi
6437 }
6438 //****************************************************************************80
6439
dpmpar(int * i)6440 double dpmpar ( int *i )
6441
6442 //****************************************************************************80
6443 //
6444 // Purpose:
6445 //
6446 // DPMPAR provides machine constants for double precision arithmetic.
6447 //
6448 // Discussion:
6449 //
6450 // DPMPAR PROVIDES THE double PRECISION MACHINE CONSTANTS FOR
6451 // THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
6452 // I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
6453 // double PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
6454 // ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
6455 //
6456 // DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
6457 //
6458 // DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
6459 //
6460 // DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
6461 //
6462 // WRITTEN BY
6463 // ALFRED H. MORRIS, JR.
6464 // NAVAL SURFACE WARFARE CENTER
6465 // DAHLGREN VIRGINIA
6466 //
6467 // MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE
6468 // CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS
6469 // MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION
6470 //
6471 {
6472 static int K1 = 4;
6473 static int K2 = 8;
6474 static int K3 = 9;
6475 static int K4 = 10;
6476 static double value,b,binv,bm1,one,w,z;
6477 static int emax,emin,ibeta,m;
6478
6479 if(*i > 1) goto S10;
6480 b = ipmpar(&K1);
6481 m = ipmpar(&K2);
6482 value = pow(b,(double)(1-m));
6483 return value;
6484 S10:
6485 if(*i > 2) goto S20;
6486 b = ipmpar(&K1);
6487 emin = ipmpar(&K3);
6488 one = 1.0;
6489 binv = one/b;
6490 w = pow(b,(double)(emin+2));
6491 value = w*binv*binv*binv;
6492 return value;
6493 S20:
6494 ibeta = ipmpar(&K1);
6495 m = ipmpar(&K2);
6496 emax = ipmpar(&K4);
6497 b = ibeta;
6498 bm1 = ibeta-1;
6499 one = 1.0;
6500 z = pow(b,(double)(m-1));
6501 w = ((z-one)*b+bm1)/(b*z);
6502 z = pow(b,(double)(emax-2));
6503 value = w*z*b*b;
6504 return value;
6505 }
6506 //****************************************************************************80
6507
dstinv(double * zsmall,double * zbig,double * zabsst,double * zrelst,double * zstpmu,double * zabsto,double * zrelto)6508 void dstinv ( double *zsmall, double *zbig, double *zabsst,
6509 double *zrelst, double *zstpmu, double *zabsto, double *zrelto )
6510
6511 //****************************************************************************80
6512 //
6513 // Purpose:
6514 //
6515 // DSTINV seeks a value X such that F(X) = Y.
6516 //
6517 // Discussion:
6518 //
6519 // Double Precision - SeT INverse finder - Reverse Communication
6520 // Function
6521 // Concise Description - Given a monotone function F finds X
6522 // such that F(X) = Y. Uses Reverse communication -- see invr.
6523 // This routine sets quantities needed by INVR.
6524 // More Precise Description of INVR -
6525 // F must be a monotone function, the results of QMFINV are
6526 // otherwise undefined. QINCR must be .TRUE. if F is non-
6527 // decreasing and .FALSE. if F is non-increasing.
6528 // QMFINV will return .TRUE. if and only if F(SMALL) and
6529 // F(BIG) bracket Y, i. e.,
6530 // QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or
6531 // QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL)
6532 // if QMFINV returns .TRUE., then the X returned satisfies
6533 // the following condition. let
6534 // TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6535 // then if QINCR is .TRUE.,
6536 // F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X))
6537 // and if QINCR is .FALSE.
6538 // F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
6539 // Arguments
6540 // SMALL --> The left endpoint of the interval to be
6541 // searched for a solution.
6542 // SMALL is DOUBLE PRECISION
6543 // BIG --> The right endpoint of the interval to be
6544 // searched for a solution.
6545 // BIG is DOUBLE PRECISION
6546 // ABSSTP, RELSTP --> The initial step size in the search
6547 // is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm.
6548 // ABSSTP is DOUBLE PRECISION
6549 // RELSTP is DOUBLE PRECISION
6550 // STPMUL --> When a step doesn't bound the zero, the step
6551 // size is multiplied by STPMUL and another step
6552 // taken. A popular value is 2.0
6553 // DOUBLE PRECISION STPMUL
6554 // ABSTOL, RELTOL --> Two numbers that determine the accuracy
6555 // of the solution. See function for a precise definition.
6556 // ABSTOL is DOUBLE PRECISION
6557 // RELTOL is DOUBLE PRECISION
6558 // Method
6559 // Compares F(X) with Y for the input value of X then uses QINCR
6560 // to determine whether to step left or right to bound the
6561 // desired x. the initial step size is
6562 // MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X.
6563 // Iteratively steps right or left until it bounds X.
6564 // At each step which doesn't bound X, the step size is doubled.
6565 // The routine is careful never to step beyond SMALL or BIG. If
6566 // it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE.
6567 // after setting QLEFT and QHI.
6568 // If X is successfully bounded then Algorithm R of the paper
6569 // 'Two Efficient Algorithms with Guaranteed Convergence for
6570 // Finding a Zero of a Function' by J. C. P. Bus and
6571 // T. J. Dekker in ACM Transactions on Mathematical
6572 // Software, Volume 1, No. 4 page 330 (DEC. '75) is employed
6573 // to find the zero of the function F(X)-Y. This is routine
6574 // QRZERO.
6575 //
6576 {
6577 E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall,
6578 zstpmu);
6579 }
6580 //****************************************************************************80
6581
dstrem(double * z)6582 double dstrem ( double *z )
6583
6584 //****************************************************************************80
6585 //
6586 // Purpose:
6587 //
6588 // DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ).
6589 //
6590 // Discussion:
6591 //
6592 // This routine returns
6593 //
6594 // ln ( Gamma ( Z ) ) - Sterling ( Z )
6595 //
6596 // where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ).
6597 //
6598 // Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z
6599 //
6600 // If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers,
6601 // with values calculated using Maple.
6602 //
6603 // Otherwise, the difference is computed explicitly.
6604 //
6605 // Modified:
6606 //
6607 // 14 June 2004
6608 //
6609 // Parameters:
6610 //
6611 // Input, double *Z, the value at which the Sterling
6612 // remainder is to be calculated. Z must be positive.
6613 //
6614 // Output, double DSTREM, the Sterling remainder.
6615 //
6616 {
6617 # define hln2pi 0.91893853320467274178e0
6618 # define ncoef 10
6619
6620 static double coef[ncoef] = {
6621 0.0e0,0.0833333333333333333333333333333e0,
6622 -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0,
6623 -0.000595238095238095238095238095238e0,
6624 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0,
6625 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0,
6626 0.179644372368830573164938490016e0
6627 };
6628 static int K1 = 10;
6629 static double dstrem,sterl,T2;
6630 //
6631 // For information, here are the next 11 coefficients of the
6632 // remainder term in Sterling's formula
6633 // -1.39243221690590111642743221691
6634 // 13.4028640441683919944789510007
6635 // -156.848284626002017306365132452
6636 // 2193.10333333333333333333333333
6637 // -36108.7712537249893571732652192
6638 // 691472.268851313067108395250776
6639 // -0.152382215394074161922833649589D8
6640 // 0.382900751391414141414141414141D9
6641 // -0.108822660357843910890151491655D11
6642 // 0.347320283765002252252252252252D12
6643 // -0.123696021422692744542517103493D14
6644 //
6645 if(*z <= 0.0e0)
6646 {
6647 ftnstop ( "Zero or negative argument in DSTREM" );
6648 }
6649 if(!(*z > 6.0e0)) goto S10;
6650 T2 = 1.0e0/pow(*z,2.0);
6651 dstrem = eval_pol ( coef, &K1, &T2 )**z;
6652 goto S20;
6653 S10:
6654 sterl = hln2pi+(*z-0.5e0)*log(*z)-*z;
6655 dstrem = gamma_log ( z ) - sterl;
6656 S20:
6657 return dstrem;
6658 # undef hln2pi
6659 # undef ncoef
6660 }
6661 //****************************************************************************80
6662
dstzr(double * zxlo,double * zxhi,double * zabstl,double * zreltl)6663 void dstzr ( double *zxlo, double *zxhi, double *zabstl, double *zreltl )
6664
6665 //****************************************************************************80
6666 //
6667 // Purpose:
6668 //
6669 // DSTXR sets quantities needed by the zero finder.
6670 //
6671 // Discussion:
6672 //
6673 // Double precision SeT ZeRo finder - Reverse communication version
6674 // Function
6675 // Sets quantities needed by ZROR. The function of ZROR
6676 // and the quantities set is given here.
6677 // Concise Description - Given a function F
6678 // find XLO such that F(XLO) = 0.
6679 // More Precise Description -
6680 // Input condition. F is a double function of a single
6681 // double argument and XLO and XHI are such that
6682 // F(XLO)*F(XHI) .LE. 0.0
6683 // If the input condition is met, QRZERO returns .TRUE.
6684 // and output values of XLO and XHI satisfy the following
6685 // F(XLO)*F(XHI) .LE. 0.
6686 // ABS(F(XLO) .LE. ABS(F(XHI)
6687 // ABS(XLO-XHI) .LE. TOL(X)
6688 // where
6689 // TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6690 // If this algorithm does not find XLO and XHI satisfying
6691 // these conditions then QRZERO returns .FALSE. This
6692 // implies that the input condition was not met.
6693 // Arguments
6694 // XLO --> The left endpoint of the interval to be
6695 // searched for a solution.
6696 // XLO is DOUBLE PRECISION
6697 // XHI --> The right endpoint of the interval to be
6698 // for a solution.
6699 // XHI is DOUBLE PRECISION
6700 // ABSTOL, RELTOL --> Two numbers that determine the accuracy
6701 // of the solution. See function for a
6702 // precise definition.
6703 // ABSTOL is DOUBLE PRECISION
6704 // RELTOL is DOUBLE PRECISION
6705 // Method
6706 // Algorithm R of the paper 'Two Efficient Algorithms with
6707 // Guaranteed Convergence for Finding a Zero of a Function'
6708 // by J. C. P. Bus and T. J. Dekker in ACM Transactions on
6709 // Mathematical Software, Volume 1, no. 4 page 330
6710 // (Dec. '75) is employed to find the zero of F(X)-Y.
6711 //
6712 {
6713 E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo);
6714 }
6715 //****************************************************************************80
6716
dt1(double * p,double * q,double * df)6717 double dt1 ( double *p, double *q, double *df )
6718
6719 //****************************************************************************80
6720 //
6721 // Purpose:
6722 //
6723 // DT1 computes an approximate inverse of the cumulative T distribution.
6724 //
6725 // Discussion:
6726 //
6727 // Returns the inverse of the T distribution function, i.e.,
6728 // the integral from 0 to INVT of the T density is P. This is an
6729 // initial approximation.
6730 //
6731 // Parameters:
6732 //
6733 // Input, double *P, *Q, the value whose inverse from the
6734 // T distribution CDF is desired, and the value (1-P).
6735 //
6736 // Input, double *DF, the number of degrees of freedom of the
6737 // T distribution.
6738 //
6739 // Output, double DT1, the approximate value of X for which
6740 // the T density CDF with DF degrees of freedom has value P.
6741 //
6742 {
6743 static double coef[4][5] = {
6744 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0,
6745 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0
6746 };
6747 static double denom[4] = {
6748 4.0e0,96.0e0,384.0e0,92160.0e0
6749 };
6750 static int ideg[4] = {
6751 2,3,4,5
6752 };
6753 static double dt1,denpow,sum,term,x,xp,xx;
6754 static int i;
6755
6756 x = fabs(dinvnr(p,q));
6757 xx = x*x;
6758 sum = x;
6759 denpow = 1.0e0;
6760 for ( i = 0; i < 4; i++ )
6761 {
6762 term = eval_pol ( &coef[i][0], &ideg[i], &xx ) * x;
6763 denpow *= *df;
6764 sum += (term/(denpow*denom[i]));
6765 }
6766 if(!(*p >= 0.5e0)) goto S20;
6767 xp = sum;
6768 goto S30;
6769 S20:
6770 xp = -sum;
6771 S30:
6772 dt1 = xp;
6773 return dt1;
6774 }
6775 //****************************************************************************80
6776
dzror(int * status,double * x,double * fx,double * xlo,double * xhi,unsigned long * qleft,unsigned long * qhi)6777 void dzror ( int *status, double *x, double *fx, double *xlo,
6778 double *xhi, unsigned long *qleft, unsigned long *qhi )
6779
6780 //****************************************************************************80
6781 //
6782 // Purpose:
6783 //
6784 // DZROR seeks the zero of a function using reverse communication.
6785 //
6786 // Discussion:
6787 //
6788 // Performs the zero finding. STZROR must have been called before
6789 // this routine in order to set its parameters.
6790 //
6791 //
6792 // Arguments
6793 //
6794 //
6795 // STATUS <--> At the beginning of a zero finding problem, STATUS
6796 // should be set to 0 and ZROR invoked. (The value
6797 // of other parameters will be ignored on this call.)
6798 //
6799 // When ZROR needs the function evaluated, it will set
6800 // STATUS to 1 and return. The value of the function
6801 // should be set in FX and ZROR again called without
6802 // changing any of its other parameters.
6803 //
6804 // When ZROR has finished without error, it will return
6805 // with STATUS 0. In that case (XLO,XHI) bound the answe
6806 //
6807 // If ZROR finds an error (which implies that F(XLO)-Y an
6808 // F(XHI)-Y have the same sign, it returns STATUS -1. In
6809 // this case, XLO and XHI are undefined.
6810 // INTEGER STATUS
6811 //
6812 // X <-- The value of X at which F(X) is to be evaluated.
6813 // DOUBLE PRECISION X
6814 //
6815 // FX --> The value of F(X) calculated when ZROR returns with
6816 // STATUS = 1.
6817 // DOUBLE PRECISION FX
6818 //
6819 // XLO <-- When ZROR returns with STATUS = 0, XLO bounds the
6820 // inverval in X containing the solution below.
6821 // DOUBLE PRECISION XLO
6822 //
6823 // XHI <-- When ZROR returns with STATUS = 0, XHI bounds the
6824 // inverval in X containing the solution above.
6825 // DOUBLE PRECISION XHI
6826 //
6827 // QLEFT <-- .TRUE. if the stepping search terminated unsucessfully
6828 // at XLO. If it is .FALSE. the search terminated
6829 // unsucessfully at XHI.
6830 // QLEFT is LOGICAL
6831 //
6832 // QHI <-- .TRUE. if F(X) .GT. Y at the termination of the
6833 // search and .FALSE. if F(X) .LT. Y at the
6834 // termination of the search.
6835 // QHI is LOGICAL
6836 //
6837 //
6838 {
6839 E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL);
6840 }
6841 //****************************************************************************80
6842
E0000(int IENTRY,int * status,double * x,double * fx,unsigned long * qleft,unsigned long * qhi,double * zabsst,double * zabsto,double * zbig,double * zrelst,double * zrelto,double * zsmall,double * zstpmu)6843 static void E0000 ( int IENTRY, int *status, double *x, double *fx,
6844 unsigned long *qleft, unsigned long *qhi, double *zabsst,
6845 double *zabsto, double *zbig, double *zrelst,
6846 double *zrelto, double *zsmall, double *zstpmu )
6847
6848 //****************************************************************************80
6849 //
6850 // Purpose:
6851 //
6852 // E0000 is a reverse-communication zero bounder.
6853 //
6854 {
6855 # define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))
6856
6857 static double absstp;
6858 static double abstol;
6859 static double big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,
6860 xlb,xlo,xsave,xub,yy;
6861 static int i99999;
6862 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;
6863 switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}
6864 DINVR:
6865 if(*status > 0) goto S310;
6866 qcond = !qxmon(small,*x,big);
6867 if(qcond)
6868 {
6869 ftnstop(" SMALL, X, BIG not monotone in INVR");
6870 }
6871 xsave = *x;
6872 //
6873 // See that SMALL and BIG bound the zero and set QINCR
6874 //
6875 *x = small;
6876 //
6877 // GET-FUNCTION-VALUE
6878 //
6879 i99999 = 1;
6880 goto S300;
6881 S10:
6882 fsmall = *fx;
6883 *x = big;
6884 //
6885 // GET-FUNCTION-VALUE
6886 //
6887 i99999 = 2;
6888 goto S300;
6889 S20:
6890 fbig = *fx;
6891 qincr = fbig > fsmall;
6892 if(!qincr) goto S50;
6893 if(fsmall <= 0.0e0) goto S30;
6894 *status = -1;
6895 *qleft = *qhi = 1;
6896 return;
6897 S30:
6898 if(fbig >= 0.0e0) goto S40;
6899 *status = -1;
6900 *qleft = *qhi = 0;
6901 return;
6902 S40:
6903 goto S80;
6904 S50:
6905 if(fsmall >= 0.0e0) goto S60;
6906 *status = -1;
6907 *qleft = 1;
6908 *qhi = 0;
6909 return;
6910 S60:
6911 if(fbig <= 0.0e0) goto S70;
6912 *status = -1;
6913 *qleft = 0;
6914 *qhi = 1;
6915 return;
6916 S80:
6917 S70:
6918 *x = xsave;
6919 step = fifdmax1(absstp,relstp*fabs(*x));
6920 //
6921 // YY = F(X) - Y
6922 // GET-FUNCTION-VALUE
6923 //
6924 i99999 = 3;
6925 goto S300;
6926 S90:
6927 yy = *fx;
6928 if(!(yy == 0.0e0)) goto S100;
6929 *status = 0;
6930 qok = 1;
6931 return;
6932 S100:
6933 qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;
6934 //
6935 // HANDLE CASE IN WHICH WE MUST STEP HIGHER
6936 //
6937 if(!qup) goto S170;
6938 xlb = xsave;
6939 xub = fifdmin1(xlb+step,big);
6940 goto S120;
6941 S110:
6942 if(qcond) goto S150;
6943 S120:
6944 //
6945 // YY = F(XUB) - Y
6946 //
6947 *x = xub;
6948 //
6949 // GET-FUNCTION-VALUE
6950 //
6951 i99999 = 4;
6952 goto S300;
6953 S130:
6954 yy = *fx;
6955 qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;
6956 qlim = xub >= big;
6957 qcond = qbdd || qlim;
6958 if(qcond) goto S140;
6959 step = stpmul*step;
6960 xlb = xub;
6961 xub = fifdmin1(xlb+step,big);
6962 S140:
6963 goto S110;
6964 S150:
6965 if(!(qlim && !qbdd)) goto S160;
6966 *status = -1;
6967 *qleft = 0;
6968 *qhi = !qincr;
6969 *x = big;
6970 return;
6971 S160:
6972 goto S240;
6973 S170:
6974 //
6975 // HANDLE CASE IN WHICH WE MUST STEP LOWER
6976 //
6977 xub = xsave;
6978 xlb = fifdmax1(xub-step,small);
6979 goto S190;
6980 S180:
6981 if(qcond) goto S220;
6982 S190:
6983 //
6984 // YY = F(XLB) - Y
6985 //
6986 *x = xlb;
6987 //
6988 // GET-FUNCTION-VALUE
6989 //
6990 i99999 = 5;
6991 goto S300;
6992 S200:
6993 yy = *fx;
6994 qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;
6995 qlim = xlb <= small;
6996 qcond = qbdd || qlim;
6997 if(qcond) goto S210;
6998 step = stpmul*step;
6999 xub = xlb;
7000 xlb = fifdmax1(xub-step,small);
7001 S210:
7002 goto S180;
7003 S220:
7004 if(!(qlim && !qbdd)) goto S230;
7005 *status = -1;
7006 *qleft = 1;
7007 *qhi = qincr;
7008 *x = small;
7009 return;
7010 S240:
7011 S230:
7012 dstzr(&xlb,&xub,&abstol,&reltol);
7013 //
7014 // IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.
7015 //
7016 *status = 0;
7017 goto S260;
7018 S250:
7019 if(!(*status == 1)) goto S290;
7020 S260:
7021 dzror ( status, x, fx, &xlo, &xhi, &qdum1, &qdum2 );
7022 if(!(*status == 1)) goto S280;
7023 //
7024 // GET-FUNCTION-VALUE
7025 //
7026 i99999 = 6;
7027 goto S300;
7028 S280:
7029 S270:
7030 goto S250;
7031 S290:
7032 *x = xlo;
7033 *status = 0;
7034 return;
7035 DSTINV:
7036 small = *zsmall;
7037 big = *zbig;
7038 absstp = *zabsst;
7039 relstp = *zrelst;
7040 stpmul = *zstpmu;
7041 abstol = *zabsto;
7042 reltol = *zrelto;
7043 return;
7044 S300:
7045 //
7046 // TO GET-FUNCTION-VALUE
7047 //
7048 *status = 1;
7049 return;
7050 S310:
7051 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case
7052 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}
7053 # undef qxmon
7054 }
7055 //****************************************************************************80
7056
E0001(int IENTRY,int * status,double * x,double * fx,double * xlo,double * xhi,unsigned long * qleft,unsigned long * qhi,double * zabstl,double * zreltl,double * zxhi,double * zxlo)7057 static void E0001 ( int IENTRY, int *status, double *x, double *fx,
7058 double *xlo, double *xhi, unsigned long *qleft,
7059 unsigned long *qhi, double *zabstl, double *zreltl,
7060 double *zxhi, double *zxlo )
7061
7062 //****************************************************************************80
7063 //
7064 // Purpose:
7065 //
7066 // E00001 is a reverse-communication zero finder.
7067 //
7068 {
7069 # define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx))))
7070
7071 static double a,abstol,b,c,d,fa,fb,fc,fd,fda;
7072 static double fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo;
7073 static int ext,i99999;
7074 static unsigned long first,qrzero;
7075 switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;}
7076 DZROR:
7077 if(*status > 0) goto S280;
7078 *xlo = xxlo;
7079 *xhi = xxhi;
7080 b = *x = *xlo;
7081 //
7082 // GET-FUNCTION-VALUE
7083 //
7084 i99999 = 1;
7085 goto S270;
7086 S10:
7087 fb = *fx;
7088 *xlo = *xhi;
7089 a = *x = *xlo;
7090 //
7091 // GET-FUNCTION-VALUE
7092 //
7093 i99999 = 2;
7094 goto S270;
7095 S20:
7096 //
7097 // Check that F(ZXLO) < 0 < F(ZXHI) or
7098 // F(ZXLO) > 0 > F(ZXHI)
7099 //
7100 if(!(fb < 0.0e0)) goto S40;
7101 if(!(*fx < 0.0e0)) goto S30;
7102 *status = -1;
7103 *qleft = *fx < fb;
7104 *qhi = 0;
7105 return;
7106 S40:
7107 S30:
7108 if(!(fb > 0.0e0)) goto S60;
7109 if(!(*fx > 0.0e0)) goto S50;
7110 *status = -1;
7111 *qleft = *fx > fb;
7112 *qhi = 1;
7113 return;
7114 S60:
7115 S50:
7116 fa = *fx;
7117 first = 1;
7118 S70:
7119 c = a;
7120 fc = fa;
7121 ext = 0;
7122 S80:
7123 if(!(fabs(fc) < fabs(fb))) goto S100;
7124 if(!(c != a)) goto S90;
7125 d = a;
7126 fd = fa;
7127 S90:
7128 a = b;
7129 fa = fb;
7130 *xlo = c;
7131 b = *xlo;
7132 fb = fc;
7133 c = a;
7134 fc = fa;
7135 S100:
7136 tol = ftol(*xlo);
7137 m = (c+b)*.5e0;
7138 mb = m-b;
7139 if(!(fabs(mb) > tol)) goto S240;
7140 if(!(ext > 3)) goto S110;
7141 w = mb;
7142 goto S190;
7143 S110:
7144 tol = fifdsign(tol,mb);
7145 p = (b-a)*fb;
7146 if(!first) goto S120;
7147 q = fa-fb;
7148 first = 0;
7149 goto S130;
7150 S120:
7151 fdb = (fd-fb)/(d-b);
7152 fda = (fd-fa)/(d-a);
7153 p = fda*p;
7154 q = fdb*fa-fda*fb;
7155 S130:
7156 if(!(p < 0.0e0)) goto S140;
7157 p = -p;
7158 q = -q;
7159 S140:
7160 if(ext == 3) p *= 2.0e0;
7161 if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150;
7162 w = tol;
7163 goto S180;
7164 S150:
7165 if(!(p < mb*q)) goto S160;
7166 w = p/q;
7167 goto S170;
7168 S160:
7169 w = mb;
7170 S190:
7171 S180:
7172 S170:
7173 d = a;
7174 fd = fa;
7175 a = b;
7176 fa = fb;
7177 b += w;
7178 *xlo = b;
7179 *x = *xlo;
7180 //
7181 // GET-FUNCTION-VALUE
7182 //
7183 i99999 = 3;
7184 goto S270;
7185 S200:
7186 fb = *fx;
7187 if(!(fc*fb >= 0.0e0)) goto S210;
7188 goto S70;
7189 S210:
7190 if(!(w == mb)) goto S220;
7191 ext = 0;
7192 goto S230;
7193 S220:
7194 ext += 1;
7195 S230:
7196 goto S80;
7197 S240:
7198 *xhi = c;
7199 qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0;
7200 if(!qrzero) goto S250;
7201 *status = 0;
7202 goto S260;
7203 S250:
7204 *status = -1;
7205 S260:
7206 return;
7207 DSTZR:
7208 xxlo = *zxlo;
7209 xxhi = *zxhi;
7210 abstol = *zabstl;
7211 reltol = *zreltl;
7212 return;
7213 S270:
7214 //
7215 // TO GET-FUNCTION-VALUE
7216 //
7217 *status = 1;
7218 return;
7219 S280:
7220 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200;
7221 default: break;}
7222 # undef ftol
7223 }
7224 //****************************************************************************80
7225
erf_values(int * n_data,double * x,double * fx)7226 void erf_values ( int *n_data, double *x, double *fx )
7227
7228 //****************************************************************************80
7229 //
7230 // Purpose:
7231 //
7232 // ERF_VALUES returns some values of the ERF or "error" function.
7233 //
7234 // Definition:
7235 //
7236 // ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT
7237 //
7238 // Modified:
7239 //
7240 // 31 May 2004
7241 //
7242 // Author:
7243 //
7244 // John Burkardt
7245 //
7246 // Reference:
7247 //
7248 // Milton Abramowitz and Irene Stegun,
7249 // Handbook of Mathematical Functions,
7250 // US Department of Commerce, 1964.
7251 //
7252 // Parameters:
7253 //
7254 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7255 // first call. On each call, the routine increments N_DATA by 1, and
7256 // returns the corresponding data; when there is no more data, the
7257 // output value of N_DATA will be 0 again.
7258 //
7259 // Output, double *X, the argument of the function.
7260 //
7261 // Output, double *FX, the value of the function.
7262 //
7263 {
7264 # define N_MAX 21
7265
7266 double fx_vec[N_MAX] = {
7267 0.0000000000E+00, 0.1124629160E+00, 0.2227025892E+00, 0.3286267595E+00,
7268 0.4283923550E+00, 0.5204998778E+00, 0.6038560908E+00, 0.6778011938E+00,
7269 0.7421009647E+00, 0.7969082124E+00, 0.8427007929E+00, 0.8802050696E+00,
7270 0.9103139782E+00, 0.9340079449E+00, 0.9522851198E+00, 0.9661051465E+00,
7271 0.9763483833E+00, 0.9837904586E+00, 0.9890905016E+00, 0.9927904292E+00,
7272 0.9953222650E+00 };
7273 double x_vec[N_MAX] = {
7274 0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00,
7275 0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00,
7276 0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00,
7277 1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00,
7278 1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00,
7279 2.0E+00 };
7280
7281 if ( *n_data < 0 )
7282 {
7283 *n_data = 0;
7284 }
7285
7286 *n_data = *n_data + 1;
7287
7288 if ( N_MAX < *n_data )
7289 {
7290 *n_data = 0;
7291 *x = 0.0E+00;
7292 *fx = 0.0E+00;
7293 }
7294 else
7295 {
7296 *x = x_vec[*n_data-1];
7297 *fx = fx_vec[*n_data-1];
7298 }
7299 return;
7300 # undef N_MAX
7301 }
7302 //****************************************************************************80
7303
error_f(double * x)7304 double error_f ( double *x )
7305
7306 //****************************************************************************80
7307 //
7308 // Purpose:
7309 //
7310 // ERROR_F evaluates the error function ERF.
7311 //
7312 // Parameters:
7313 //
7314 // Input, double *X, the argument.
7315 //
7316 // Output, double ERROR_F, the value of the error function at X.
7317 //
7318 {
7319 static double c = .564189583547756e0;
7320 static double a[5] = {
7321 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7322 .479137145607681e-01,.128379167095513e+00
7323 };
7324 static double b[3] = {
7325 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7326 };
7327 static double p[8] = {
7328 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7329 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7330 4.51918953711873e+02,3.00459261020162e+02
7331 };
7332 static double q[8] = {
7333 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7334 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7335 7.90950925327898e+02,3.00459260956983e+02
7336 };
7337 static double r[5] = {
7338 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7339 4.65807828718470e+00,2.82094791773523e-01
7340 };
7341 static double s[4] = {
7342 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7343 1.80124575948747e+01
7344 };
7345 static double erf1,ax,bot,t,top,x2;
7346
7347 ax = fabs(*x);
7348 if(ax > 0.5e0) goto S10;
7349 t = *x**x;
7350 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7351 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7352 erf1 = *x*(top/bot);
7353 return erf1;
7354 S10:
7355 if(ax > 4.0e0) goto S20;
7356 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7357 7];
7358 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7359 7];
7360 erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot);
7361 if(*x < 0.0e0) erf1 = -erf1;
7362 return erf1;
7363 S20:
7364 if(ax >= 5.8e0) goto S30;
7365 x2 = *x**x;
7366 t = 1.0e0/x2;
7367 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7368 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7369 erf1 = (c-top/(x2*bot))/ax;
7370 erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1);
7371 if(*x < 0.0e0) erf1 = -erf1;
7372 return erf1;
7373 S30:
7374 erf1 = fifdsign(1.0e0,*x);
7375 return erf1;
7376 }
7377 //****************************************************************************80
7378
error_fc(int * ind,double * x)7379 double error_fc ( int *ind, double *x )
7380
7381 //****************************************************************************80
7382 //
7383 // Purpose:
7384 //
7385 // ERROR_FC evaluates the complementary error function ERFC.
7386 //
7387 // Modified:
7388 //
7389 // 09 December 1999
7390 //
7391 // Parameters:
7392 //
7393 // Input, int *IND, chooses the scaling.
7394 // If IND is nonzero, then the value returned has been multiplied by
7395 // EXP(X*X).
7396 //
7397 // Input, double *X, the argument of the function.
7398 //
7399 // Output, double ERROR_FC, the value of the complementary
7400 // error function.
7401 //
7402 {
7403 static double c = .564189583547756e0;
7404 static double a[5] = {
7405 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7406 .479137145607681e-01,.128379167095513e+00
7407 };
7408 static double b[3] = {
7409 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7410 };
7411 static double p[8] = {
7412 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7413 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7414 4.51918953711873e+02,3.00459261020162e+02
7415 };
7416 static double q[8] = {
7417 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7418 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7419 7.90950925327898e+02,3.00459260956983e+02
7420 };
7421 static double r[5] = {
7422 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7423 4.65807828718470e+00,2.82094791773523e-01
7424 };
7425 static double s[4] = {
7426 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7427 1.80124575948747e+01
7428 };
7429 static int K1 = 1;
7430 static double erfc1,ax,bot,e,t,top,w;
7431
7432 //
7433 // ABS(X) .LE. 0.5
7434 //
7435 ax = fabs(*x);
7436 if(ax > 0.5e0) goto S10;
7437 t = *x**x;
7438 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7439 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7440 erfc1 = 0.5e0+(0.5e0-*x*(top/bot));
7441 if(*ind != 0) erfc1 = exp(t)*erfc1;
7442 return erfc1;
7443 S10:
7444 //
7445 // 0.5 .LT. ABS(X) .LE. 4
7446 //
7447 if(ax > 4.0e0) goto S20;
7448 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7449 7];
7450 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7451 7];
7452 erfc1 = top/bot;
7453 goto S40;
7454 S20:
7455 //
7456 // ABS(X) .GT. 4
7457 //
7458 if(*x <= -5.6e0) goto S60;
7459 if(*ind != 0) goto S30;
7460 if(*x > 100.0e0) goto S70;
7461 if(*x**x > -exparg(&K1)) goto S70;
7462 S30:
7463 t = pow(1.0e0/ *x,2.0);
7464 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7465 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7466 erfc1 = (c-t*top/bot)/ax;
7467 S40:
7468 //
7469 // FINAL ASSEMBLY
7470 //
7471 if(*ind == 0) goto S50;
7472 if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1;
7473 return erfc1;
7474 S50:
7475 w = *x**x;
7476 t = w;
7477 e = w-t;
7478 erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1;
7479 if(*x < 0.0e0) erfc1 = 2.0e0-erfc1;
7480 return erfc1;
7481 S60:
7482 //
7483 // LIMIT VALUE FOR LARGE NEGATIVE X
7484 //
7485 erfc1 = 2.0e0;
7486 if(*ind != 0) erfc1 = 2.0e0*exp(*x**x);
7487 return erfc1;
7488 S70:
7489 //
7490 // LIMIT VALUE FOR LARGE POSITIVE X
7491 // WHEN IND = 0
7492 //
7493 erfc1 = 0.0e0;
7494 return erfc1;
7495 }
7496 //****************************************************************************80
7497
esum(int * mu,double * x)7498 double esum ( int *mu, double *x )
7499
7500 //****************************************************************************80
7501 //
7502 // Purpose:
7503 //
7504 // ESUM evaluates exp ( MU + X ).
7505 //
7506 // Parameters:
7507 //
7508 // Input, int *MU, part of the argument.
7509 //
7510 // Input, double *X, part of the argument.
7511 //
7512 // Output, double ESUM, the value of exp ( MU + X ).
7513 //
7514 {
7515 static double esum,w;
7516
7517 if(*x > 0.0e0) goto S10;
7518 if(*mu < 0) goto S20;
7519 w = (double)*mu+*x;
7520 if(w > 0.0e0) goto S20;
7521 esum = exp(w);
7522 return esum;
7523 S10:
7524 if(*mu > 0) goto S20;
7525 w = (double)*mu+*x;
7526 if(w < 0.0e0) goto S20;
7527 esum = exp(w);
7528 return esum;
7529 S20:
7530 w = *mu;
7531 esum = exp(w)*exp(*x);
7532 return esum;
7533 }
7534 //****************************************************************************80
7535
eval_pol(double a[],int * n,double * x)7536 double eval_pol ( double a[], int *n, double *x )
7537
7538 //****************************************************************************80
7539 //
7540 // Purpose:
7541 //
7542 // EVAL_POL evaluates a polynomial at X.
7543 //
7544 // Discussion:
7545 //
7546 // EVAL_POL = A(0) + A(1)*X + ... + A(N)*X**N
7547 //
7548 // Modified:
7549 //
7550 // 15 December 1999
7551 //
7552 // Parameters:
7553 //
7554 // Input, double precision A(0:N), coefficients of the polynomial.
7555 //
7556 // Input, int *N, length of A.
7557 //
7558 // Input, double *X, the point at which the polynomial
7559 // is to be evaluated.
7560 //
7561 // Output, double EVAL_POL, the value of the polynomial at X.
7562 //
7563 {
7564 static double devlpl,term;
7565 static int i;
7566
7567 term = a[*n-1];
7568 for ( i = *n-1-1; i >= 0; i-- )
7569 {
7570 term = a[i]+term**x;
7571 }
7572
7573 devlpl = term;
7574 return devlpl;
7575 }
7576 //****************************************************************************80
7577
exparg(int * l)7578 double exparg ( int *l )
7579
7580 //****************************************************************************80
7581 //
7582 // Purpose:
7583 //
7584 // EXPARG returns the largest or smallest legal argument for EXP.
7585 //
7586 // Discussion:
7587 //
7588 // Only an approximate limit for the argument of EXP is desired.
7589 //
7590 // Modified:
7591 //
7592 // 09 December 1999
7593 //
7594 // Parameters:
7595 //
7596 // Input, int *L, indicates which limit is desired.
7597 // If L = 0, then the largest positive argument for EXP is desired.
7598 // Otherwise, the largest negative argument for EXP for which the
7599 // result is nonzero is desired.
7600 //
7601 // Output, double EXPARG, the desired value.
7602 //
7603 {
7604 static int K1 = 4;
7605 static int K2 = 9;
7606 static int K3 = 10;
7607 static double exparg,lnb;
7608 static int b,m;
7609
7610 b = ipmpar(&K1);
7611 if(b != 2) goto S10;
7612 lnb = .69314718055995e0;
7613 goto S40;
7614 S10:
7615 if(b != 8) goto S20;
7616 lnb = 2.0794415416798e0;
7617 goto S40;
7618 S20:
7619 if(b != 16) goto S30;
7620 lnb = 2.7725887222398e0;
7621 goto S40;
7622 S30:
7623 lnb = log((double)b);
7624 S40:
7625 if(*l == 0) goto S50;
7626 m = ipmpar(&K2)-1;
7627 exparg = 0.99999e0*((double)m*lnb);
7628 return exparg;
7629 S50:
7630 m = ipmpar(&K3);
7631 exparg = 0.99999e0*((double)m*lnb);
7632 return exparg;
7633 }
7634 //****************************************************************************80
7635
f_cdf_values(int * n_data,int * a,int * b,double * x,double * fx)7636 void f_cdf_values ( int *n_data, int *a, int *b, double *x, double *fx )
7637
7638 //****************************************************************************80
7639 //
7640 // Purpose:
7641 //
7642 // F_CDF_VALUES returns some values of the F CDF test function.
7643 //
7644 // Discussion:
7645 //
7646 // The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by
7647 // commands like:
7648 //
7649 // Needs["Statistics`ContinuousDistributions`"]
7650 // CDF[FRatioDistribution[ DFN, DFD ], X ]
7651 //
7652 // Modified:
7653 //
7654 // 11 June 2004
7655 //
7656 // Author:
7657 //
7658 // John Burkardt
7659 //
7660 // Reference:
7661 //
7662 // Milton Abramowitz and Irene Stegun,
7663 // Handbook of Mathematical Functions,
7664 // US Department of Commerce, 1964.
7665 //
7666 // Stephen Wolfram,
7667 // The Mathematica Book,
7668 // Fourth Edition,
7669 // Wolfram Media / Cambridge University Press, 1999.
7670 //
7671 // Parameters:
7672 //
7673 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7674 // first call. On each call, the routine increments N_DATA by 1, and
7675 // returns the corresponding data; when there is no more data, the
7676 // output value of N_DATA will be 0 again.
7677 //
7678 // Output, int *A, int *B, the parameters of the function.
7679 //
7680 // Output, double *X, the argument of the function.
7681 //
7682 // Output, double *FX, the value of the function.
7683 //
7684 {
7685 # define N_MAX 20
7686
7687 int a_vec[N_MAX] = {
7688 1, 1, 5, 1,
7689 2, 4, 1, 6,
7690 8, 1, 3, 6,
7691 1, 1, 1, 1,
7692 2, 3, 4, 5 };
7693 int b_vec[N_MAX] = {
7694 1, 5, 1, 5,
7695 10, 20, 5, 6,
7696 16, 5, 10, 12,
7697 5, 5, 5, 5,
7698 5, 5, 5, 5 };
7699 double fx_vec[N_MAX] = {
7700 0.500000E+00, 0.499971E+00, 0.499603E+00, 0.749699E+00,
7701 0.750466E+00, 0.751416E+00, 0.899987E+00, 0.899713E+00,
7702 0.900285E+00, 0.950025E+00, 0.950057E+00, 0.950193E+00,
7703 0.975013E+00, 0.990002E+00, 0.994998E+00, 0.999000E+00,
7704 0.568799E+00, 0.535145E+00, 0.514343E+00, 0.500000E+00 };
7705 double x_vec[N_MAX] = {
7706 1.00E+00, 0.528E+00, 1.89E+00, 1.69E+00,
7707 1.60E+00, 1.47E+00, 4.06E+00, 3.05E+00,
7708 2.09E+00, 6.61E+00, 3.71E+00, 3.00E+00,
7709 10.01E+00, 16.26E+00, 22.78E+00, 47.18E+00,
7710 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00 };
7711
7712 if ( *n_data < 0 )
7713 {
7714 *n_data = 0;
7715 }
7716
7717 *n_data = *n_data + 1;
7718
7719 if ( N_MAX < *n_data )
7720 {
7721 *n_data = 0;
7722 *a = 0;
7723 *b = 0;
7724 *x = 0.0E+00;
7725 *fx = 0.0E+00;
7726 }
7727 else
7728 {
7729 *a = a_vec[*n_data-1];
7730 *b = b_vec[*n_data-1];
7731 *x = x_vec[*n_data-1];
7732 *fx = fx_vec[*n_data-1];
7733 }
7734 return;
7735 # undef N_MAX
7736 }
7737 //****************************************************************************80
7738
f_noncentral_cdf_values(int * n_data,int * a,int * b,double * lambda,double * x,double * fx)7739 void f_noncentral_cdf_values ( int *n_data, int *a, int *b, double *lambda,
7740 double *x, double *fx )
7741
7742 //****************************************************************************80
7743 //
7744 // Purpose:
7745 //
7746 // F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function.
7747 //
7748 // Discussion:
7749 //
7750 // The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated
7751 // in Mathematica by commands like:
7752 //
7753 // Needs["Statistics`ContinuousDistributions`"]
7754 // CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ]
7755 //
7756 // Modified:
7757 //
7758 // 12 June 2004
7759 //
7760 // Author:
7761 //
7762 // John Burkardt
7763 //
7764 // Reference:
7765 //
7766 // Milton Abramowitz and Irene Stegun,
7767 // Handbook of Mathematical Functions,
7768 // US Department of Commerce, 1964.
7769 //
7770 // Stephen Wolfram,
7771 // The Mathematica Book,
7772 // Fourth Edition,
7773 // Wolfram Media / Cambridge University Press, 1999.
7774 //
7775 // Parameters:
7776 //
7777 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7778 // first call. On each call, the routine increments N_DATA by 1, and
7779 // returns the corresponding data; when there is no more data, the
7780 // output value of N_DATA will be 0 again.
7781 //
7782 // Output, int *A, int *B, double *LAMBDA, the
7783 // parameters of the function.
7784 //
7785 // Output, double *X, the argument of the function.
7786 //
7787 // Output, double *FX, the value of the function.
7788 //
7789 {
7790 # define N_MAX 22
7791
7792 int a_vec[N_MAX] = {
7793 1, 1, 1, 1,
7794 1, 1, 1, 1,
7795 1, 1, 2, 2,
7796 3, 3, 4, 4,
7797 5, 5, 6, 6,
7798 8, 16 };
7799 int b_vec[N_MAX] = {
7800 1, 5, 5, 5,
7801 5, 5, 5, 5,
7802 5, 5, 5, 10,
7803 5, 5, 5, 5,
7804 1, 5, 6, 12,
7805 16, 8 };
7806 double fx_vec[N_MAX] = {
7807 0.500000E+00, 0.636783E+00, 0.584092E+00, 0.323443E+00,
7808 0.450119E+00, 0.607888E+00, 0.705928E+00, 0.772178E+00,
7809 0.819105E+00, 0.317035E+00, 0.432722E+00, 0.450270E+00,
7810 0.426188E+00, 0.337744E+00, 0.422911E+00, 0.692767E+00,
7811 0.363217E+00, 0.421005E+00, 0.426667E+00, 0.446402E+00,
7812 0.844589E+00, 0.816368E+00 };
7813 double lambda_vec[N_MAX] = {
7814 0.00E+00, 0.000E+00, 0.25E+00, 1.00E+00,
7815 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7816 1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,
7817 1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,
7818 0.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7819 1.00E+00, 1.00E+00 };
7820 double x_vec[N_MAX] = {
7821 1.00E+00, 1.00E+00, 1.00E+00, 0.50E+00,
7822 1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,
7823 5.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7824 1.00E+00, 1.00E+00, 1.00E+00, 2.00E+00,
7825 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7826 2.00E+00, 2.00E+00 };
7827
7828 if ( *n_data < 0 )
7829 {
7830 *n_data = 0;
7831 }
7832
7833 *n_data = *n_data + 1;
7834
7835 if ( N_MAX < *n_data )
7836 {
7837 *n_data = 0;
7838 *a = 0;
7839 *b = 0;
7840 *lambda = 0.0E+00;
7841 *x = 0.0E+00;
7842 *fx = 0.0E+00;
7843 }
7844 else
7845 {
7846 *a = a_vec[*n_data-1];
7847 *b = b_vec[*n_data-1];
7848 *lambda = lambda_vec[*n_data-1];
7849 *x = x_vec[*n_data-1];
7850 *fx = fx_vec[*n_data-1];
7851 }
7852
7853 return;
7854 # undef N_MAX
7855 }
7856 //****************************************************************************80
7857
fifdint(double a)7858 double fifdint ( double a )
7859
7860 //****************************************************************************80
7861 //
7862 // Purpose:
7863 //
7864 // FIFDINT truncates a double number to an integer.
7865 //
7866 // Parameters:
7867 //
7868 // a - number to be truncated
7869 {
7870 return (double) ((int) a);
7871 }
7872 //****************************************************************************80
7873
fifdmax1(double a,double b)7874 double fifdmax1 ( double a, double b )
7875
7876 //****************************************************************************80
7877 //
7878 // Purpose:
7879 //
7880 // FIFDMAX1 returns the maximum of two numbers a and b
7881 //
7882 // Parameters:
7883 //
7884 // a - first number
7885 // b - second number
7886 //
7887 {
7888 if ( a < b )
7889 {
7890 return b;
7891 }
7892 else
7893 {
7894 return a;
7895 }
7896 }
7897 //****************************************************************************80
7898
fifdmin1(double a,double b)7899 double fifdmin1 ( double a, double b )
7900
7901 //****************************************************************************80
7902 //
7903 // Purpose:
7904 //
7905 // FIFDMIN1 returns the minimum of two numbers.
7906 //
7907 // Parameters:
7908 //
7909 // a - first number
7910 // b - second number
7911 //
7912 {
7913 if (a < b) return a;
7914 else return b;
7915 }
7916 //****************************************************************************80
7917
fifdsign(double mag,double sign)7918 double fifdsign ( double mag, double sign )
7919
7920 //****************************************************************************80
7921 //
7922 // Purpose:
7923 //
7924 // FIFDSIGN transfers the sign of the variable "sign" to the variable "mag"
7925 //
7926 // Parameters:
7927 //
7928 // mag - magnitude
7929 // sign - sign to be transfered
7930 //
7931 {
7932 if (mag < 0) mag = -mag;
7933 if (sign < 0) mag = -mag;
7934 return mag;
7935
7936 }
7937 //****************************************************************************80
7938
fifidint(double a)7939 long fifidint ( double a )
7940
7941 //****************************************************************************80
7942 //
7943 // Purpose:
7944 //
7945 // FIFIDINT truncates a double number to a long integer
7946 //
7947 // Parameters:
7948 //
7949 // a - number to be truncated
7950 //
7951 {
7952 if ( a < 1.0 )
7953 {
7954 return (long) 0;
7955 }
7956 else
7957 {
7958 return ( long ) a;
7959 }
7960 }
7961 //****************************************************************************80
7962
fifmod(long a,long b)7963 long fifmod ( long a, long b )
7964
7965 //****************************************************************************80
7966 //
7967 // Purpose:
7968 //
7969 // FIFMOD returns the modulo of a and b
7970 //
7971 // Parameters:
7972 //
7973 // a - numerator
7974 // b - denominator
7975 //
7976 {
7977 return ( a % b );
7978 }
7979 //****************************************************************************80
7980
fpser(double * a,double * b,double * x,double * eps)7981 double fpser ( double *a, double *b, double *x, double *eps )
7982
7983 //****************************************************************************80
7984 //
7985 // Purpose:
7986 //
7987 // FPSER evaluates IX(A,B)(X) for very small B.
7988 //
7989 // Discussion:
7990 //
7991 // This routine is appropriate for use when
7992 //
7993 // B < min ( EPS, EPS * A )
7994 //
7995 // and
7996 //
7997 // X <= 0.5.
7998 //
7999 // Parameters:
8000 //
8001 // Input, double *A, *B, parameters of the function.
8002 //
8003 // Input, double *X, the point at which the function is to
8004 // be evaluated.
8005 //
8006 // Input, double *EPS, a tolerance.
8007 //
8008 // Output, double FPSER, the value of IX(A,B)(X).
8009 //
8010 {
8011 static int K1 = 1;
8012 static double fpser,an,c,s,t,tol;
8013
8014 fpser = 1.0e0;
8015 if(*a <= 1.e-3**eps) goto S10;
8016 fpser = 0.0e0;
8017 t = *a*log(*x);
8018 if(t < exparg(&K1)) return fpser;
8019 fpser = exp(t);
8020 S10:
8021 //
8022 // NOTE THAT 1/B(A,B) = B
8023 //
8024 fpser = *b/ *a*fpser;
8025 tol = *eps/ *a;
8026 an = *a+1.0e0;
8027 t = *x;
8028 s = t/an;
8029 S20:
8030 an += 1.0e0;
8031 t = *x*t;
8032 c = t/an;
8033 s += c;
8034 if(fabs(c) > tol) goto S20;
8035 fpser *= (1.0e0+*a*s);
8036 return fpser;
8037 }
8038 //****************************************************************************80
8039
ftnstop(string msg)8040 void ftnstop ( string msg )
8041
8042 //****************************************************************************80
8043 //
8044 // Purpose:
8045 //
8046 // FTNSTOP prints a message to standard error and then exits.
8047 //
8048 // Parameters:
8049 //
8050 // Input, string MSG, the message to be printed.
8051 //
8052 {
8053 cerr << msg << "\n";
8054
8055 exit ( 0 );
8056 }
8057 //****************************************************************************80
8058
gam1(double * a)8059 double gam1 ( double *a )
8060
8061 //****************************************************************************80
8062 //
8063 // Purpose:
8064 //
8065 // GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5D+00 <= A <= 1.5
8066 //
8067 // Parameters:
8068 //
8069 // Input, double *A, forms the argument of the Gamma function.
8070 //
8071 // Output, double GAM1, the value of 1 / GAMMA ( A + 1 ) - 1.
8072 //
8073 {
8074 static double s1 = .273076135303957e+00;
8075 static double s2 = .559398236957378e-01;
8076 static double p[7] = {
8077 .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00,
8078 .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02,
8079 .589597428611429e-03
8080 };
8081 static double q[5] = {
8082 .100000000000000e+01,.427569613095214e+00,.158451672430138e+00,
8083 .261132021441447e-01,.423244297896961e-02
8084 };
8085 static double r[9] = {
8086 -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00,
8087 .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01,
8088 .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03
8089 };
8090 static double gam1,bot,d,t,top,w,T1;
8091
8092 t = *a;
8093 d = *a-0.5e0;
8094 if(d > 0.0e0) t = d-0.5e0;
8095 T1 = t;
8096 if(T1 < 0) goto S40;
8097 else if(T1 == 0) goto S10;
8098 else goto S20;
8099 S10:
8100 gam1 = 0.0e0;
8101 return gam1;
8102 S20:
8103 top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0];
8104 bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0;
8105 w = top/bot;
8106 if(d > 0.0e0) goto S30;
8107 gam1 = *a*w;
8108 return gam1;
8109 S30:
8110 gam1 = t/ *a*(w-0.5e0-0.5e0);
8111 return gam1;
8112 S40:
8113 top = (((((((r[8]*t+r[7])*t+r[6])*t+r[5])*t+r[4])*t+r[3])*t+r[2])*t+r[1])*t+
8114 r[0];
8115 bot = (s2*t+s1)*t+1.0e0;
8116 w = top/bot;
8117 if(d > 0.0e0) goto S50;
8118 gam1 = *a*(w+0.5e0+0.5e0);
8119 return gam1;
8120 S50:
8121 gam1 = t*w/ *a;
8122 return gam1;
8123 }
8124 //****************************************************************************80
8125
gamma_inc(double * a,double * x,double * ans,double * qans,int * ind)8126 void gamma_inc ( double *a, double *x, double *ans, double *qans, int *ind )
8127
8128 //****************************************************************************80
8129 //
8130 // Purpose:
8131 //
8132 // GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
8133 //
8134 // Discussion:
8135 //
8136 // This is certified spaghetti code.
8137 //
8138 // Author:
8139 //
8140 // Alfred H Morris, Jr,
8141 // Naval Surface Weapons Center,
8142 // Dahlgren, Virginia.
8143 //
8144 // Parameters:
8145 //
8146 // Input, double *A, *X, the arguments of the incomplete
8147 // gamma ratio. A and X must be nonnegative. A and X cannot
8148 // both be zero.
8149 //
8150 // Output, double *ANS, *QANS. On normal output,
8151 // ANS = P(A,X) and QANS = Q(A,X). However, ANS is set to 2 if
8152 // A or X is negative, or both are 0, or when the answer is
8153 // computationally indeterminate because A is extremely large
8154 // and X is very close to A.
8155 //
8156 // Input, int *IND, indicates the accuracy request:
8157 // 0, as much accuracy as possible.
8158 // 1, to within 1 unit of the 6-th significant digit,
8159 // otherwise, to within 1 unit of the 3rd significant digit.
8160 //
8161 {
8162 static double alog10 = 2.30258509299405e0;
8163 static double d10 = -.185185185185185e-02;
8164 static double d20 = .413359788359788e-02;
8165 static double d30 = .649434156378601e-03;
8166 static double d40 = -.861888290916712e-03;
8167 static double d50 = -.336798553366358e-03;
8168 static double d60 = .531307936463992e-03;
8169 static double d70 = .344367606892378e-03;
8170 static double rt2pin = .398942280401433e0;
8171 static double rtpi = 1.77245385090552e0;
8172 static double third = .333333333333333e0;
8173 static double acc0[3] = {
8174 5.e-15,5.e-7,5.e-4
8175 };
8176 static double big[3] = {
8177 20.0e0,14.0e0,10.0e0
8178 };
8179 static double d0[13] = {
8180 .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02,
8181 .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04,
8182 -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06,
8183 -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07,
8184 -.438203601845335e-08
8185 };
8186 static double d1[12] = {
8187 -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03,
8188 .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04,
8189 .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08,
8190 .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07
8191 };
8192 static double d2[10] = {
8193 -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05,
8194 -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04,
8195 .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06,
8196 .142806142060642e-06
8197 };
8198 static double d3[8] = {
8199 .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03,
8200 -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04,
8201 -.567495282699160e-05,.142309007324359e-05
8202 };
8203 static double d4[6] = {
8204 .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05,
8205 .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04
8206 };
8207 static double d5[4] = {
8208 -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03,
8209 .679778047793721e-04
8210 };
8211 static double d6[2] = {
8212 -.592166437353694e-03,.270878209671804e-03
8213 };
8214 static double e00[3] = {
8215 .25e-3,.25e-1,.14e0
8216 };
8217 static double x00[3] = {
8218 31.0e0,17.0e0,9.7e0
8219 };
8220 static int K1 = 1;
8221 static int K2 = 0;
8222 static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6,
8223 cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z;
8224 static int i,iop,m,max,n;
8225 static double wk[20],T3;
8226 static int T4,T5;
8227 static double T6,T7;
8228
8229 //
8230 // E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
8231 // NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
8232 //
8233 e = dpmpar(&K1);
8234 if(*a < 0.0e0 || *x < 0.0e0) goto S430;
8235 if(*a == 0.0e0 && *x == 0.0e0) goto S430;
8236 if(*a**x == 0.0e0) goto S420;
8237 iop = *ind+1;
8238 if(iop != 1 && iop != 2) iop = 3;
8239 acc = fifdmax1(acc0[iop-1],e);
8240 e0 = e00[iop-1];
8241 x0 = x00[iop-1];
8242 //
8243 // SELECT THE APPROPRIATE ALGORITHM
8244 //
8245 if(*a >= 1.0e0) goto S10;
8246 if(*a == 0.5e0) goto S390;
8247 if(*x < 1.1e0) goto S160;
8248 t1 = *a*log(*x)-*x;
8249 u = *a*exp(t1);
8250 if(u == 0.0e0) goto S380;
8251 r = u*(1.0e0+gam1(a));
8252 goto S250;
8253 S10:
8254 if(*a >= big[iop-1]) goto S30;
8255 if(*a > *x || *x >= x0) goto S20;
8256 twoa = *a+*a;
8257 m = fifidint(twoa);
8258 if(twoa != (double)m) goto S20;
8259 i = m/2;
8260 if(*a == (double)i) goto S210;
8261 goto S220;
8262 S20:
8263 t1 = *a*log(*x)-*x;
8264 r = exp(t1)/ gamma_x(a);
8265 goto S40;
8266 S30:
8267 l = *x/ *a;
8268 if(l == 0.0e0) goto S370;
8269 s = 0.5e0+(0.5e0-l);
8270 z = rlog(&l);
8271 if(z >= 700.0e0/ *a) goto S410;
8272 y = *a*z;
8273 rta = sqrt(*a);
8274 if(fabs(s) <= e0/rta) goto S330;
8275 if(fabs(s) <= 0.4e0) goto S270;
8276 t = pow(1.0e0/ *a,2.0);
8277 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
8278 t1 -= y;
8279 r = rt2pin*rta*exp(t1);
8280 S40:
8281 if(r == 0.0e0) goto S420;
8282 if(*x <= fifdmax1(*a,alog10)) goto S50;
8283 if(*x < x0) goto S250;
8284 goto S100;
8285 S50:
8286 //
8287 // TAYLOR SERIES FOR P/R
8288 //
8289 apn = *a+1.0e0;
8290 t = *x/apn;
8291 wk[0] = t;
8292 for ( n = 2; n <= 20; n++ )
8293 {
8294 apn += 1.0e0;
8295 t *= (*x/apn);
8296 if(t <= 1.e-3) goto S70;
8297 wk[n-1] = t;
8298 }
8299 n = 20;
8300 S70:
8301 sum = t;
8302 tol = 0.5e0*acc;
8303 S80:
8304 apn += 1.0e0;
8305 t *= (*x/apn);
8306 sum += t;
8307 if(t > tol) goto S80;
8308 max = n-1;
8309 for ( m = 1; m <= max; m++ )
8310 {
8311 n -= 1;
8312 sum += wk[n-1];
8313 }
8314 *ans = r/ *a*(1.0e0+sum);
8315 *qans = 0.5e0+(0.5e0-*ans);
8316 return;
8317 S100:
8318 //
8319 // ASYMPTOTIC EXPANSION
8320 //
8321 amn = *a-1.0e0;
8322 t = amn/ *x;
8323 wk[0] = t;
8324 for ( n = 2; n <= 20; n++ )
8325 {
8326 amn -= 1.0e0;
8327 t *= (amn/ *x);
8328 if(fabs(t) <= 1.e-3) goto S120;
8329 wk[n-1] = t;
8330 }
8331 n = 20;
8332 S120:
8333 sum = t;
8334 S130:
8335 if(fabs(t) <= acc) goto S140;
8336 amn -= 1.0e0;
8337 t *= (amn/ *x);
8338 sum += t;
8339 goto S130;
8340 S140:
8341 max = n-1;
8342 for ( m = 1; m <= max; m++ )
8343 {
8344 n -= 1;
8345 sum += wk[n-1];
8346 }
8347 *qans = r/ *x*(1.0e0+sum);
8348 *ans = 0.5e0+(0.5e0-*qans);
8349 return;
8350 S160:
8351 //
8352 // TAYLOR SERIES FOR P(A,X)/X**A
8353 //
8354 an = 3.0e0;
8355 c = *x;
8356 sum = *x/(*a+3.0e0);
8357 tol = 3.0e0*acc/(*a+1.0e0);
8358 S170:
8359 an += 1.0e0;
8360 c = -(c*(*x/an));
8361 t = c/(*a+an);
8362 sum += t;
8363 if(fabs(t) > tol) goto S170;
8364 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8365 z = *a*log(*x);
8366 h = gam1(a);
8367 g = 1.0e0+h;
8368 if(*x < 0.25e0) goto S180;
8369 if(*a < *x/2.59e0) goto S200;
8370 goto S190;
8371 S180:
8372 if(z > -.13394e0) goto S200;
8373 S190:
8374 w = exp(z);
8375 *ans = w*g*(0.5e0+(0.5e0-j));
8376 *qans = 0.5e0+(0.5e0-*ans);
8377 return;
8378 S200:
8379 l = rexp(&z);
8380 w = 0.5e0+(0.5e0+l);
8381 *qans = (w*j-l)*g-h;
8382 if(*qans < 0.0e0) goto S380;
8383 *ans = 0.5e0+(0.5e0-*qans);
8384 return;
8385 S210:
8386 //
8387 // FINITE SUMS FOR Q WHEN A .GE. 1 AND 2*A IS AN INTEGER
8388 //
8389 sum = exp(-*x);
8390 t = sum;
8391 n = 1;
8392 c = 0.0e0;
8393 goto S230;
8394 S220:
8395 rtx = sqrt(*x);
8396 sum = error_fc ( &K2, &rtx );
8397 t = exp(-*x)/(rtpi*rtx);
8398 n = 0;
8399 c = -0.5e0;
8400 S230:
8401 if(n == i) goto S240;
8402 n += 1;
8403 c += 1.0e0;
8404 t = *x*t/c;
8405 sum += t;
8406 goto S230;
8407 S240:
8408 *qans = sum;
8409 *ans = 0.5e0+(0.5e0-*qans);
8410 return;
8411 S250:
8412 //
8413 // CONTINUED FRACTION EXPANSION
8414 //
8415 tol = fifdmax1(5.0e0*e,acc);
8416 a2nm1 = a2n = 1.0e0;
8417 b2nm1 = *x;
8418 b2n = *x+(1.0e0-*a);
8419 c = 1.0e0;
8420 S260:
8421 a2nm1 = *x*a2n+c*a2nm1;
8422 b2nm1 = *x*b2n+c*b2nm1;
8423 am0 = a2nm1/b2nm1;
8424 c += 1.0e0;
8425 cma = c-*a;
8426 a2n = a2nm1+cma*a2n;
8427 b2n = b2nm1+cma*b2n;
8428 an0 = a2n/b2n;
8429 if(fabs(an0-am0) >= tol*an0) goto S260;
8430 *qans = r*an0;
8431 *ans = 0.5e0+(0.5e0-*qans);
8432 return;
8433 S270:
8434 //
8435 // GENERAL TEMME EXPANSION
8436 //
8437 if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430;
8438 c = exp(-y);
8439 T3 = sqrt(y);
8440 w = 0.5e0 * error_fc ( &K1, &T3 );
8441 u = 1.0e0/ *a;
8442 z = sqrt(z+z);
8443 if(l < 1.0e0) z = -z;
8444 T4 = iop-2;
8445 if(T4 < 0) goto S280;
8446 else if(T4 == 0) goto S290;
8447 else goto S300;
8448 S280:
8449 if(fabs(s) <= 1.e-3) goto S340;
8450 c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[
8451 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8452 c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5]
8453 )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8454 c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+
8455 d2[2])*z+d2[1])*z+d2[0])*z+d20;
8456 c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+
8457 d3[0])*z+d30;
8458 c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40;
8459 c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50;
8460 c6 = (d6[1]*z+d6[0])*z+d60;
8461 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8462 goto S310;
8463 S290:
8464 c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8465 c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8466 c2 = d2[0]*z+d20;
8467 t = (c2*u+c1)*u+c0;
8468 goto S310;
8469 S300:
8470 t = ((d0[2]*z+d0[1])*z+d0[0])*z-third;
8471 S310:
8472 if(l < 1.0e0) goto S320;
8473 *qans = c*(w+rt2pin*t/rta);
8474 *ans = 0.5e0+(0.5e0-*qans);
8475 return;
8476 S320:
8477 *ans = c*(w-rt2pin*t/rta);
8478 *qans = 0.5e0+(0.5e0-*ans);
8479 return;
8480 S330:
8481 //
8482 // TEMME EXPANSION FOR L = 1
8483 //
8484 if(*a*e*e > 3.28e-3) goto S430;
8485 c = 0.5e0+(0.5e0-y);
8486 w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c;
8487 u = 1.0e0/ *a;
8488 z = sqrt(z+z);
8489 if(l < 1.0e0) z = -z;
8490 T5 = iop-2;
8491 if(T5 < 0) goto S340;
8492 else if(T5 == 0) goto S350;
8493 else goto S360;
8494 S340:
8495 c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-
8496 third;
8497 c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8498 c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20;
8499 c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30;
8500 c4 = (d4[1]*z+d4[0])*z+d40;
8501 c5 = (d5[1]*z+d5[0])*z+d50;
8502 c6 = d6[0]*z+d60;
8503 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8504 goto S310;
8505 S350:
8506 c0 = (d0[1]*z+d0[0])*z-third;
8507 c1 = d1[0]*z+d10;
8508 t = (d20*u+c1)*u+c0;
8509 goto S310;
8510 S360:
8511 t = d0[0]*z-third;
8512 goto S310;
8513 S370:
8514 //
8515 // SPECIAL CASES
8516 //
8517 *ans = 0.0e0;
8518 *qans = 1.0e0;
8519 return;
8520 S380:
8521 *ans = 1.0e0;
8522 *qans = 0.0e0;
8523 return;
8524 S390:
8525 if(*x >= 0.25e0) goto S400;
8526 T6 = sqrt(*x);
8527 *ans = error_f ( &T6 );
8528 *qans = 0.5e0+(0.5e0-*ans);
8529 return;
8530 S400:
8531 T7 = sqrt(*x);
8532 *qans = error_fc ( &K2, &T7 );
8533 *ans = 0.5e0+(0.5e0-*qans);
8534 return;
8535 S410:
8536 if(fabs(s) <= 2.0e0*e) goto S430;
8537 S420:
8538 if(*x <= *a) goto S370;
8539 goto S380;
8540 S430:
8541 //
8542 // ERROR RETURN
8543 //
8544 *ans = 2.0e0;
8545 return;
8546 }
8547 //****************************************************************************80
8548
gamma_inc_inv(double * a,double * x,double * x0,double * p,double * q,int * ierr)8549 void gamma_inc_inv ( double *a, double *x, double *x0, double *p, double *q,
8550 int *ierr )
8551
8552 //****************************************************************************80
8553 //
8554 // Purpose:
8555 //
8556 // GAMMA_INC_INV computes the inverse incomplete gamma ratio function.
8557 //
8558 // Discussion:
8559 //
8560 // The routine is given positive A, and nonnegative P and Q where P + Q = 1.
8561 // The value X is computed with the property that P(A,X) = P and Q(A,X) = Q.
8562 // Schroder iteration is employed. The routine attempts to compute X
8563 // to 10 significant digits if this is possible for the particular computer
8564 // arithmetic being used.
8565 //
8566 // Author:
8567 //
8568 // Alfred H Morris, Jr,
8569 // Naval Surface Weapons Center,
8570 // Dahlgren, Virginia.
8571 //
8572 // Parameters:
8573 //
8574 // Input, double *A, the parameter in the incomplete gamma
8575 // ratio. A must be positive.
8576 //
8577 // Output, double *X, the computed point for which the
8578 // incomplete gamma functions have the values P and Q.
8579 //
8580 // Input, double *X0, an optional initial approximation
8581 // for the solution X. If the user does not want to supply an
8582 // initial approximation, then X0 should be set to 0, or a negative
8583 // value.
8584 //
8585 // Input, double *P, *Q, the values of the incomplete gamma
8586 // functions, for which the corresponding argument is desired.
8587 //
8588 // Output, int *IERR, error flag.
8589 // 0, the solution was obtained. Iteration was not used.
8590 // 0 < K, The solution was obtained. IERR iterations were performed.
8591 // -2, A <= 0
8592 // -3, No solution was obtained. The ratio Q/A is too large.
8593 // -4, P + Q /= 1
8594 // -6, 20 iterations were performed. The most recent value obtained
8595 // for X is given. This cannot occur if X0 <= 0.
8596 // -7, Iteration failed. No value is given for X.
8597 // This may occur when X is approximately 0.
8598 // -8, A value for X has been obtained, but the routine is not certain
8599 // of its accuracy. Iteration cannot be performed in this
8600 // case. If X0 <= 0, this can occur only when P or Q is
8601 // approximately 0. If X0 is positive then this can occur when A is
8602 // exceedingly close to X and A is extremely large (say A .GE. 1.E20).
8603 //
8604 {
8605 static double a0 = 3.31125922108741e0;
8606 static double a1 = 11.6616720288968e0;
8607 static double a2 = 4.28342155967104e0;
8608 static double a3 = .213623493715853e0;
8609 static double b1 = 6.61053765625462e0;
8610 static double b2 = 6.40691597760039e0;
8611 static double b3 = 1.27364489782223e0;
8612 static double b4 = .036117081018842e0;
8613 static double c = .577215664901533e0;
8614 static double ln10 = 2.302585e0;
8615 static double tol = 1.e-5;
8616 static double amin[2] = {
8617 500.0e0,100.0e0
8618 };
8619 static double bmin[2] = {
8620 1.e-28,1.e-13
8621 };
8622 static double dmin[2] = {
8623 1.e-06,1.e-04
8624 };
8625 static double emin[2] = {
8626 2.e-03,6.e-03
8627 };
8628 static double eps0[2] = {
8629 1.e-10,1.e-08
8630 };
8631 static int K1 = 1;
8632 static int K2 = 2;
8633 static int K3 = 3;
8634 static int K8 = 0;
8635 static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn,
8636 r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z;
8637 static int iop;
8638 static double T4,T5,T6,T7,T9;
8639
8640 //
8641 // E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.
8642 // E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.
8643 // XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE
8644 // LARGEST POSITIVE NUMBER.
8645 //
8646 e = dpmpar(&K1);
8647 xmin = dpmpar(&K2);
8648 xmax = dpmpar(&K3);
8649 *x = 0.0e0;
8650 if(*a <= 0.0e0) goto S300;
8651 t = *p+*q-1.e0;
8652 if(fabs(t) > e) goto S320;
8653 *ierr = 0;
8654 if(*p == 0.0e0) return;
8655 if(*q == 0.0e0) goto S270;
8656 if(*a == 1.0e0) goto S280;
8657 e2 = 2.0e0*e;
8658 amax = 0.4e-10/(e*e);
8659 iop = 1;
8660 if(e > 1.e-10) iop = 2;
8661 eps = eps0[iop-1];
8662 xn = *x0;
8663 if(*x0 > 0.0e0) goto S160;
8664 //
8665 // SELECTION OF THE INITIAL APPROXIMATION XN OF X
8666 // WHEN A .LT. 1
8667 //
8668 if(*a > 1.0e0) goto S80;
8669 T4 = *a+1.0e0;
8670 g = gamma_x(&T4);
8671 qg = *q*g;
8672 if(qg == 0.0e0) goto S360;
8673 b = qg/ *a;
8674 if(qg > 0.6e0**a) goto S40;
8675 if(*a >= 0.30e0 || b < 0.35e0) goto S10;
8676 t = exp(-(b+c));
8677 u = t*exp(t);
8678 xn = t*exp(u);
8679 goto S160;
8680 S10:
8681 if(b >= 0.45e0) goto S40;
8682 if(b == 0.0e0) goto S360;
8683 y = -log(b);
8684 s = 0.5e0+(0.5e0-*a);
8685 z = log(y);
8686 t = y-s*z;
8687 if(b < 0.15e0) goto S20;
8688 xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0));
8689 goto S220;
8690 S20:
8691 if(b <= 0.01e0) goto S30;
8692 u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0);
8693 xn = y-s*log(t)-log(u);
8694 goto S220;
8695 S30:
8696 c1 = -(s*z);
8697 c2 = -(s*(1.0e0+c1));
8698 c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a));
8699 c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+(
8700 (11.0e0**a-46.0)**a+47.0e0)/6.0e0));
8701 c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)*
8702 *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+((
8703 (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0));
8704 xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y;
8705 if(*a > 1.0e0) goto S220;
8706 if(b > bmin[iop-1]) goto S220;
8707 *x = xn;
8708 return;
8709 S40:
8710 if(b**q > 1.e-8) goto S50;
8711 xn = exp(-(*q/ *a+c));
8712 goto S70;
8713 S50:
8714 if(*p <= 0.9e0) goto S60;
8715 T5 = -*q;
8716 xn = exp((alnrel(&T5)+ gamma_ln1 ( a ) ) / *a );
8717 goto S70;
8718 S60:
8719 xn = exp(log(*p*g)/ *a);
8720 S70:
8721 if(xn == 0.0e0) goto S310;
8722 t = 0.5e0+(0.5e0-xn/(*a+1.0e0));
8723 xn /= t;
8724 goto S160;
8725 S80:
8726 //
8727 // SELECTION OF THE INITIAL APPROXIMATION XN OF X
8728 // WHEN A .GT. 1
8729 //
8730 if(*q <= 0.5e0) goto S90;
8731 w = log(*p);
8732 goto S100;
8733 S90:
8734 w = log(*q);
8735 S100:
8736 t = sqrt(-(2.0e0*w));
8737 s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0);
8738 if(*q > 0.5e0) s = -s;
8739 rta = sqrt(*a);
8740 s2 = s*s;
8741 xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)*
8742 s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a*
8743 rta);
8744 xn = fifdmax1(xn,0.0e0);
8745 if(*a < amin[iop-1]) goto S110;
8746 *x = xn;
8747 d = 0.5e0+(0.5e0-*x/ *a);
8748 if(fabs(d) <= dmin[iop-1]) return;
8749 S110:
8750 if(*p <= 0.5e0) goto S130;
8751 if(xn < 3.0e0**a) goto S220;
8752 y = -(w+ gamma_log ( a ) );
8753 d = fifdmax1(2.0e0,*a*(*a-1.0e0));
8754 if(y < ln10*d) goto S120;
8755 s = 1.0e0-*a;
8756 z = log(y);
8757 goto S30;
8758 S120:
8759 t = *a-1.0e0;
8760 T6 = -(t/(xn+1.0e0));
8761 xn = y+t*log(xn)-alnrel(&T6);
8762 T7 = -(t/(xn+1.0e0));
8763 xn = y+t*log(xn)-alnrel(&T7);
8764 goto S220;
8765 S130:
8766 ap1 = *a+1.0e0;
8767 if(xn > 0.70e0*ap1) goto S170;
8768 w += gamma_log ( &ap1 );
8769 if(xn > 0.15e0*ap1) goto S140;
8770 ap2 = *a+2.0e0;
8771 ap3 = *a+3.0e0;
8772 *x = exp((w+*x)/ *a);
8773 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
8774 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
8775 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a);
8776 xn = *x;
8777 if(xn > 1.e-2*ap1) goto S140;
8778 if(xn <= emin[iop-1]*ap1) return;
8779 goto S170;
8780 S140:
8781 apn = ap1;
8782 t = xn/apn;
8783 sum = 1.0e0+t;
8784 S150:
8785 apn += 1.0e0;
8786 t *= (xn/apn);
8787 sum += t;
8788 if(t > 1.e-4) goto S150;
8789 t = w-log(sum);
8790 xn = exp((xn+t)/ *a);
8791 xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn));
8792 goto S170;
8793 S160:
8794 //
8795 // SCHRODER ITERATION USING P
8796 //
8797 if(*p > 0.5e0) goto S220;
8798 S170:
8799 if(*p <= 1.e10*xmin) goto S350;
8800 am1 = *a-0.5e0-0.5e0;
8801 S180:
8802 if(*a <= amax) goto S190;
8803 d = 0.5e0+(0.5e0-xn/ *a);
8804 if(fabs(d) <= e2) goto S350;
8805 S190:
8806 if(*ierr >= 20) goto S330;
8807 *ierr += 1;
8808 gamma_inc ( a, &xn, &pn, &qn, &K8 );
8809 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8810 r = rcomp(a,&xn);
8811 if(r == 0.0e0) goto S350;
8812 t = (pn-*p)/r;
8813 w = 0.5e0*(am1-xn);
8814 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200;
8815 *x = xn*(1.0e0-t);
8816 if(*x <= 0.0e0) goto S340;
8817 d = fabs(t);
8818 goto S210;
8819 S200:
8820 h = t*(1.0e0+w*t);
8821 *x = xn*(1.0e0-h);
8822 if(*x <= 0.0e0) goto S340;
8823 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8824 d = fabs(h);
8825 S210:
8826 xn = *x;
8827 if(d > tol) goto S180;
8828 if(d <= eps) return;
8829 if(fabs(*p-pn) <= tol**p) return;
8830 goto S180;
8831 S220:
8832 //
8833 // SCHRODER ITERATION USING Q
8834 //
8835 if(*q <= 1.e10*xmin) goto S350;
8836 am1 = *a-0.5e0-0.5e0;
8837 S230:
8838 if(*a <= amax) goto S240;
8839 d = 0.5e0+(0.5e0-xn/ *a);
8840 if(fabs(d) <= e2) goto S350;
8841 S240:
8842 if(*ierr >= 20) goto S330;
8843 *ierr += 1;
8844 gamma_inc ( a, &xn, &pn, &qn, &K8 );
8845 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8846 r = rcomp(a,&xn);
8847 if(r == 0.0e0) goto S350;
8848 t = (*q-qn)/r;
8849 w = 0.5e0*(am1-xn);
8850 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250;
8851 *x = xn*(1.0e0-t);
8852 if(*x <= 0.0e0) goto S340;
8853 d = fabs(t);
8854 goto S260;
8855 S250:
8856 h = t*(1.0e0+w*t);
8857 *x = xn*(1.0e0-h);
8858 if(*x <= 0.0e0) goto S340;
8859 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8860 d = fabs(h);
8861 S260:
8862 xn = *x;
8863 if(d > tol) goto S230;
8864 if(d <= eps) return;
8865 if(fabs(*q-qn) <= tol**q) return;
8866 goto S230;
8867 S270:
8868 //
8869 // SPECIAL CASES
8870 //
8871 *x = xmax;
8872 return;
8873 S280:
8874 if(*q < 0.9e0) goto S290;
8875 T9 = -*p;
8876 *x = -alnrel(&T9);
8877 return;
8878 S290:
8879 *x = -log(*q);
8880 return;
8881 S300:
8882 //
8883 // ERROR RETURN
8884 //
8885 *ierr = -2;
8886 return;
8887 S310:
8888 *ierr = -3;
8889 return;
8890 S320:
8891 *ierr = -4;
8892 return;
8893 S330:
8894 *ierr = -6;
8895 return;
8896 S340:
8897 *ierr = -7;
8898 return;
8899 S350:
8900 *x = xn;
8901 *ierr = -8;
8902 return;
8903 S360:
8904 *x = xmax;
8905 *ierr = -8;
8906 return;
8907 }
8908 //****************************************************************************80
8909
gamma_inc_values(int * n_data,double * a,double * x,double * fx)8910 void gamma_inc_values ( int *n_data, double *a, double *x, double *fx )
8911
8912 //****************************************************************************80
8913 //
8914 // Purpose:
8915 //
8916 // GAMMA_INC_VALUES returns some values of the incomplete Gamma function.
8917 //
8918 // Discussion:
8919 //
8920 // The (normalized) incomplete Gamma function P(A,X) is defined as:
8921 //
8922 // PN(A,X) = 1/GAMMA(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT.
8923 //
8924 // With this definition, for all A and X,
8925 //
8926 // 0 <= PN(A,X) <= 1
8927 //
8928 // and
8929 //
8930 // PN(A,INFINITY) = 1.0
8931 //
8932 // Mathematica can compute this value as
8933 //
8934 // 1 - GammaRegularized[A,X]
8935 //
8936 // Modified:
8937 //
8938 // 31 May 2004
8939 //
8940 // Author:
8941 //
8942 // John Burkardt
8943 //
8944 // Reference:
8945 //
8946 // Milton Abramowitz and Irene Stegun,
8947 // Handbook of Mathematical Functions,
8948 // US Department of Commerce, 1964.
8949 //
8950 // Parameters:
8951 //
8952 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
8953 // first call. On each call, the routine increments N_DATA by 1, and
8954 // returns the corresponding data; when there is no more data, the
8955 // output value of N_DATA will be 0 again.
8956 //
8957 // Output, double *A, the parameter of the function.
8958 //
8959 // Output, double *X, the argument of the function.
8960 //
8961 // Output, double *FX, the value of the function.
8962 //
8963 {
8964 # define N_MAX 20
8965
8966 double a_vec[N_MAX] = {
8967 0.1E+00, 0.1E+00, 0.1E+00, 0.5E+00,
8968 0.5E+00, 0.5E+00, 1.0E+00, 1.0E+00,
8969 1.0E+00, 1.1E+00, 1.1E+00, 1.1E+00,
8970 2.0E+00, 2.0E+00, 2.0E+00, 6.0E+00,
8971 6.0E+00, 11.0E+00, 26.0E+00, 41.0E+00 };
8972 double fx_vec[N_MAX] = {
8973 0.7420263E+00, 0.9119753E+00, 0.9898955E+00, 0.2931279E+00,
8974 0.7656418E+00, 0.9921661E+00, 0.0951626E+00, 0.6321206E+00,
8975 0.9932621E+00, 0.0757471E+00, 0.6076457E+00, 0.9933425E+00,
8976 0.0091054E+00, 0.4130643E+00, 0.9931450E+00, 0.0387318E+00,
8977 0.9825937E+00, 0.9404267E+00, 0.4863866E+00, 0.7359709E+00 };
8978 double x_vec[N_MAX] = {
8979 3.1622777E-02, 3.1622777E-01, 1.5811388E+00, 7.0710678E-02,
8980 7.0710678E-01, 3.5355339E+00, 0.1000000E+00, 1.0000000E+00,
8981 5.0000000E+00, 1.0488088E-01, 1.0488088E+00, 5.2440442E+00,
8982 1.4142136E-01, 1.4142136E+00, 7.0710678E+00, 2.4494897E+00,
8983 1.2247449E+01, 1.6583124E+01, 2.5495098E+01, 4.4821870E+01 };
8984
8985 if ( *n_data < 0 )
8986 {
8987 *n_data = 0;
8988 }
8989
8990 *n_data = *n_data + 1;
8991
8992 if ( N_MAX < *n_data )
8993 {
8994 *n_data = 0;
8995 *a = 0.0E+00;
8996 *x = 0.0E+00;
8997 *fx = 0.0E+00;
8998 }
8999 else
9000 {
9001 *a = a_vec[*n_data-1];
9002 *x = x_vec[*n_data-1];
9003 *fx = fx_vec[*n_data-1];
9004 }
9005 return;
9006 # undef N_MAX
9007 }
9008 //****************************************************************************80
9009
gamma_ln1(double * a)9010 double gamma_ln1 ( double *a )
9011
9012 //****************************************************************************80
9013 //
9014 // Purpose:
9015 //
9016 // GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25.
9017 //
9018 // Parameters:
9019 //
9020 // Input, double *A, defines the argument of the function.
9021 //
9022 // Output, double GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ).
9023 //
9024 {
9025 static double p0 = .577215664901533e+00;
9026 static double p1 = .844203922187225e+00;
9027 static double p2 = -.168860593646662e+00;
9028 static double p3 = -.780427615533591e+00;
9029 static double p4 = -.402055799310489e+00;
9030 static double p5 = -.673562214325671e-01;
9031 static double p6 = -.271935708322958e-02;
9032 static double q1 = .288743195473681e+01;
9033 static double q2 = .312755088914843e+01;
9034 static double q3 = .156875193295039e+01;
9035 static double q4 = .361951990101499e+00;
9036 static double q5 = .325038868253937e-01;
9037 static double q6 = .667465618796164e-03;
9038 static double r0 = .422784335098467e+00;
9039 static double r1 = .848044614534529e+00;
9040 static double r2 = .565221050691933e+00;
9041 static double r3 = .156513060486551e+00;
9042 static double r4 = .170502484022650e-01;
9043 static double r5 = .497958207639485e-03;
9044 static double s1 = .124313399877507e+01;
9045 static double s2 = .548042109832463e+00;
9046 static double s3 = .101552187439830e+00;
9047 static double s4 = .713309612391000e-02;
9048 static double s5 = .116165475989616e-03;
9049 static double gamln1,w,x;
9050
9051 if(*a >= 0.6e0) goto S10;
9052 w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+
9053 q4)**a+q3)**a+q2)**a+q1)**a+1.0e0);
9054 gamln1 = -(*a*w);
9055 return gamln1;
9056 S10:
9057 x = *a-0.5e0-0.5e0;
9058 w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x
9059 +1.0e0);
9060 gamln1 = x*w;
9061 return gamln1;
9062 }
9063 //****************************************************************************80
9064
gamma_log(double * a)9065 double gamma_log ( double *a )
9066
9067 //****************************************************************************80
9068 //
9069 // Purpose:
9070 //
9071 // GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A.
9072 //
9073 // Author:
9074 //
9075 // Alfred H Morris, Jr,
9076 // Naval Surface Weapons Center,
9077 // Dahlgren, Virginia.
9078 //
9079 // Reference:
9080 //
9081 // Armido DiDinato and Alfred Morris,
9082 // Algorithm 708:
9083 // Significant Digit Computation of the Incomplete Beta Function Ratios,
9084 // ACM Transactions on Mathematical Software,
9085 // Volume 18, 1993, pages 360-373.
9086 //
9087 // Parameters:
9088 //
9089 // Input, double *A, the argument of the function.
9090 // A should be positive.
9091 //
9092 // Output, double GAMMA_LOG, the value of ln ( Gamma ( A ) ).
9093 //
9094 {
9095 static double c0 = .833333333333333e-01;
9096 static double c1 = -.277777777760991e-02;
9097 static double c2 = .793650666825390e-03;
9098 static double c3 = -.595202931351870e-03;
9099 static double c4 = .837308034031215e-03;
9100 static double c5 = -.165322962780713e-02;
9101 static double d = .418938533204673e0;
9102 static double gamln,t,w;
9103 static int i,n;
9104 static double T1;
9105
9106 if(*a > 0.8e0) goto S10;
9107 gamln = gamma_ln1 ( a ) - log ( *a );
9108 return gamln;
9109 S10:
9110 if(*a > 2.25e0) goto S20;
9111 t = *a-0.5e0-0.5e0;
9112 gamln = gamma_ln1 ( &t );
9113 return gamln;
9114 S20:
9115 if(*a >= 10.0e0) goto S40;
9116 n = ( int ) ( *a - 1.25e0 );
9117 t = *a;
9118 w = 1.0e0;
9119 for ( i = 1; i <= n; i++ )
9120 {
9121 t -= 1.0e0;
9122 w = t*w;
9123 }
9124 T1 = t-1.0e0;
9125 gamln = gamma_ln1 ( &T1 ) + log ( w );
9126 return gamln;
9127 S40:
9128 t = pow(1.0e0/ *a,2.0);
9129 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
9130 gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
9131 return gamln;
9132 }
9133 //****************************************************************************80
9134
gamma_rat1(double * a,double * x,double * r,double * p,double * q,double * eps)9135 void gamma_rat1 ( double *a, double *x, double *r, double *p, double *q,
9136 double *eps )
9137
9138 //****************************************************************************80
9139 //
9140 // Purpose:
9141 //
9142 // GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
9143 //
9144 // Parameters:
9145 //
9146 // Input, double *A, *X, the parameters of the functions.
9147 // It is assumed that A <= 1.
9148 //
9149 // Input, double *R, the value exp(-X) * X**A / Gamma(A).
9150 //
9151 // Output, double *P, *Q, the values of P(A,X) and Q(A,X).
9152 //
9153 // Input, double *EPS, the tolerance.
9154 //
9155 {
9156 static int K2 = 0;
9157 static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3;
9158
9159 if(*a**x == 0.0e0) goto S120;
9160 if(*a == 0.5e0) goto S100;
9161 if(*x < 1.1e0) goto S10;
9162 goto S60;
9163 S10:
9164 //
9165 // TAYLOR SERIES FOR P(A,X)/X**A
9166 //
9167 an = 3.0e0;
9168 c = *x;
9169 sum = *x/(*a+3.0e0);
9170 tol = 0.1e0**eps/(*a+1.0e0);
9171 S20:
9172 an += 1.0e0;
9173 c = -(c*(*x/an));
9174 t = c/(*a+an);
9175 sum += t;
9176 if(fabs(t) > tol) goto S20;
9177 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
9178 z = *a*log(*x);
9179 h = gam1(a);
9180 g = 1.0e0+h;
9181 if(*x < 0.25e0) goto S30;
9182 if(*a < *x/2.59e0) goto S50;
9183 goto S40;
9184 S30:
9185 if(z > -.13394e0) goto S50;
9186 S40:
9187 w = exp(z);
9188 *p = w*g*(0.5e0+(0.5e0-j));
9189 *q = 0.5e0+(0.5e0-*p);
9190 return;
9191 S50:
9192 l = rexp(&z);
9193 w = 0.5e0+(0.5e0+l);
9194 *q = (w*j-l)*g-h;
9195 if(*q < 0.0e0) goto S90;
9196 *p = 0.5e0+(0.5e0-*q);
9197 return;
9198 S60:
9199 //
9200 // CONTINUED FRACTION EXPANSION
9201 //
9202 a2nm1 = a2n = 1.0e0;
9203 b2nm1 = *x;
9204 b2n = *x+(1.0e0-*a);
9205 c = 1.0e0;
9206 S70:
9207 a2nm1 = *x*a2n+c*a2nm1;
9208 b2nm1 = *x*b2n+c*b2nm1;
9209 am0 = a2nm1/b2nm1;
9210 c += 1.0e0;
9211 cma = c-*a;
9212 a2n = a2nm1+cma*a2n;
9213 b2n = b2nm1+cma*b2n;
9214 an0 = a2n/b2n;
9215 if(fabs(an0-am0) >= *eps*an0) goto S70;
9216 *q = *r*an0;
9217 *p = 0.5e0+(0.5e0-*q);
9218 return;
9219 S80:
9220 //
9221 // SPECIAL CASES
9222 //
9223 *p = 0.0e0;
9224 *q = 1.0e0;
9225 return;
9226 S90:
9227 *p = 1.0e0;
9228 *q = 0.0e0;
9229 return;
9230 S100:
9231 if(*x >= 0.25e0) goto S110;
9232 T1 = sqrt(*x);
9233 *p = error_f ( &T1 );
9234 *q = 0.5e0+(0.5e0-*p);
9235 return;
9236 S110:
9237 T3 = sqrt(*x);
9238 *q = error_fc ( &K2, &T3 );
9239 *p = 0.5e0+(0.5e0-*q);
9240 return;
9241 S120:
9242 if(*x <= *a) goto S80;
9243 goto S90;
9244 }
9245 //****************************************************************************80
9246
gamma_values(int * n_data,double * x,double * fx)9247 void gamma_values ( int *n_data, double *x, double *fx )
9248
9249 //****************************************************************************80
9250 //
9251 // Purpose:
9252 //
9253 // GAMMA_VALUES returns some values of the Gamma function.
9254 //
9255 // Definition:
9256 //
9257 // GAMMA(Z) = Integral ( 0 <= T < Infinity) T**(Z-1) EXP(-T) dT
9258 //
9259 // Recursion:
9260 //
9261 // GAMMA(X+1) = X*GAMMA(X)
9262 //
9263 // Restrictions:
9264 //
9265 // 0 < X ( a software restriction).
9266 //
9267 // Special values:
9268 //
9269 // GAMMA(0.5) = sqrt(PI)
9270 //
9271 // For N a positive integer, GAMMA(N+1) = N!, the standard factorial.
9272 //
9273 // Modified:
9274 //
9275 // 31 May 2004
9276 //
9277 // Author:
9278 //
9279 // John Burkardt
9280 //
9281 // Reference:
9282 //
9283 // Milton Abramowitz and Irene Stegun,
9284 // Handbook of Mathematical Functions,
9285 // US Department of Commerce, 1964.
9286 //
9287 // Parameters:
9288 //
9289 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
9290 // first call. On each call, the routine increments N_DATA by 1, and
9291 // returns the corresponding data; when there is no more data, the
9292 // output value of N_DATA will be 0 again.
9293 //
9294 // Output, double *X, the argument of the function.
9295 //
9296 // Output, double *FX, the value of the function.
9297 //
9298 {
9299 # define N_MAX 18
9300
9301 double fx_vec[N_MAX] = {
9302 4.590845E+00, 2.218160E+00, 1.489192E+00, 1.164230E+00,
9303 1.0000000000E+00, 0.9513507699E+00, 0.9181687424E+00, 0.8974706963E+00,
9304 0.8872638175E+00, 0.8862269255E+00, 0.8935153493E+00, 0.9086387329E+00,
9305 0.9313837710E+00, 0.9617658319E+00, 1.0000000000E+00, 3.6288000E+05,
9306 1.2164510E+17, 8.8417620E+30 };
9307 double x_vec[N_MAX] = {
9308 0.2E+00, 0.4E+00, 0.6E+00, 0.8E+00,
9309 1.0E+00, 1.1E+00, 1.2E+00, 1.3E+00,
9310 1.4E+00, 1.5E+00, 1.6E+00, 1.7E+00,
9311 1.8E+00, 1.9E+00, 2.0E+00, 10.0E+00,
9312 20.0E+00, 30.0E+00 };
9313
9314 if ( *n_data < 0 )
9315 {
9316 *n_data = 0;
9317 }
9318
9319 *n_data = *n_data + 1;
9320
9321 if ( N_MAX < *n_data )
9322 {
9323 *n_data = 0;
9324 *x = 0.0E+00;
9325 *fx = 0.0E+00;
9326 }
9327 else
9328 {
9329 *x = x_vec[*n_data-1];
9330 *fx = fx_vec[*n_data-1];
9331 }
9332 return;
9333 # undef N_MAX
9334 }
9335 //****************************************************************************80
9336
gamma_x(double * a)9337 double gamma_x ( double *a )
9338
9339 //****************************************************************************80
9340 //
9341 // Purpose:
9342 //
9343 // GAMMA_X evaluates the gamma function.
9344 //
9345 // Discussion:
9346 //
9347 // This routine was renamed from "GAMMA" to avoid a conflict with the
9348 // C/C++ math library routine.
9349 //
9350 // Author:
9351 //
9352 // Alfred H Morris, Jr,
9353 // Naval Surface Weapons Center,
9354 // Dahlgren, Virginia.
9355 //
9356 // Parameters:
9357 //
9358 // Input, double *A, the argument of the Gamma function.
9359 //
9360 // Output, double GAMMA_X, the value of the Gamma function.
9361 //
9362 {
9363 static double d = .41893853320467274178e0;
9364 static double pi = 3.1415926535898e0;
9365 static double r1 = .820756370353826e-03;
9366 static double r2 = -.595156336428591e-03;
9367 static double r3 = .793650663183693e-03;
9368 static double r4 = -.277777777770481e-02;
9369 static double r5 = .833333333333333e-01;
9370 static double p[7] = {
9371 .539637273585445e-03,.261939260042690e-02,.204493667594920e-01,
9372 .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0
9373 };
9374 static double q[7] = {
9375 -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01,
9376 -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0
9377 };
9378 static int K2 = 3;
9379 static int K3 = 0;
9380 static double Xgamm,bot,g,lnx,s,t,top,w,x,z;
9381 static int i,j,m,n,T1;
9382
9383 Xgamm = 0.0e0;
9384 x = *a;
9385 if(fabs(*a) >= 15.0e0) goto S110;
9386 //
9387 // EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15
9388 //
9389 t = 1.0e0;
9390 m = fifidint(*a)-1;
9391 //
9392 // LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
9393 //
9394 T1 = m;
9395 if(T1 < 0) goto S40;
9396 else if(T1 == 0) goto S30;
9397 else goto S10;
9398 S10:
9399 for ( j = 1; j <= m; j++ )
9400 {
9401 x -= 1.0e0;
9402 t = x*t;
9403 }
9404 S30:
9405 x -= 1.0e0;
9406 goto S80;
9407 S40:
9408 //
9409 // LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
9410 //
9411 t = *a;
9412 if(*a > 0.0e0) goto S70;
9413 m = -m-1;
9414 if(m == 0) goto S60;
9415 for ( j = 1; j <= m; j++ )
9416 {
9417 x += 1.0e0;
9418 t = x*t;
9419 }
9420 S60:
9421 x += (0.5e0+0.5e0);
9422 t = x*t;
9423 if(t == 0.0e0) return Xgamm;
9424 S70:
9425 //
9426 // THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
9427 // CODE MAY BE OMITTED IF DESIRED.
9428 //
9429 if(fabs(t) >= 1.e-30) goto S80;
9430 if(fabs(t)*dpmpar(&K2) <= 1.0001e0) return Xgamm;
9431 Xgamm = 1.0e0/t;
9432 return Xgamm;
9433 S80:
9434 //
9435 // COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1
9436 //
9437 top = p[0];
9438 bot = q[0];
9439 for ( i = 1; i < 7; i++ )
9440 {
9441 top = p[i]+x*top;
9442 bot = q[i]+x*bot;
9443 }
9444 Xgamm = top/bot;
9445 //
9446 // TERMINATION
9447 //
9448 if(*a < 1.0e0) goto S100;
9449 Xgamm *= t;
9450 return Xgamm;
9451 S100:
9452 Xgamm /= t;
9453 return Xgamm;
9454 S110:
9455 //
9456 // EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15
9457 //
9458 if(fabs(*a) >= 1.e3) return Xgamm;
9459 if(*a > 0.0e0) goto S120;
9460 x = -*a;
9461 n = ( int ) x;
9462 t = x-(double)n;
9463 if(t > 0.9e0) t = 1.0e0-t;
9464 s = sin(pi*t)/pi;
9465 if(fifmod(n,2) == 0) s = -s;
9466 if(s == 0.0e0) return Xgamm;
9467 S120:
9468 //
9469 // COMPUTE THE MODIFIED ASYMPTOTIC SUM
9470 //
9471 t = 1.0e0/(x*x);
9472 g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x;
9473 //
9474 // ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X)
9475 // BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.
9476 //
9477 lnx = log(x);
9478 //
9479 // FINAL ASSEMBLY
9480 //
9481 z = x;
9482 g = d+g+(z-0.5e0)*(lnx-1.e0);
9483 w = g;
9484 t = g-w;
9485 if(w > 0.99999e0*exparg(&K3)) return Xgamm;
9486 Xgamm = exp(w)*(1.0e0+t);
9487 if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x;
9488 return Xgamm;
9489 }
9490 //****************************************************************************80
9491
gsumln(double * a,double * b)9492 double gsumln ( double *a, double *b )
9493
9494 //****************************************************************************80
9495 //
9496 // Purpose:
9497 //
9498 // GSUMLN evaluates the function ln(Gamma(A + B)).
9499 //
9500 // Discussion:
9501 //
9502 // GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2
9503 //
9504 // Parameters:
9505 //
9506 // Input, double *A, *B, values whose sum is the argument of
9507 // the Gamma function.
9508 //
9509 // Output, double GSUMLN, the value of ln(Gamma(A+B)).
9510 //
9511 {
9512 static double gsumln,x,T1,T2;
9513
9514 x = *a+*b-2.e0;
9515 if(x > 0.25e0) goto S10;
9516 T1 = 1.0e0+x;
9517 gsumln = gamma_ln1 ( &T1 );
9518 return gsumln;
9519 S10:
9520 if(x > 1.25e0) goto S20;
9521 gsumln = gamma_ln1 ( &x ) + alnrel ( &x );
9522 return gsumln;
9523 S20:
9524 T2 = x-1.0e0;
9525 gsumln = gamma_ln1 ( &T2 ) + log ( x * ( 1.0e0 + x ) );
9526 return gsumln;
9527 }
9528 //****************************************************************************80
9529
ipmpar(int * i)9530 int ipmpar ( int *i )
9531
9532 //****************************************************************************80
9533 //
9534 // Purpose:
9535 //
9536 // IPMPAR returns integer machine constants.
9537 //
9538 // Discussion:
9539 //
9540 // Input arguments 1 through 3 are queries about integer arithmetic.
9541 // We assume integers are represented in the N-digit, base-A form
9542 //
9543 // sign * ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
9544 //
9545 // where 0 <= X(0:N-1) < A.
9546 //
9547 // Then:
9548 //
9549 // IPMPAR(1) = A, the base of integer arithmetic;
9550 // IPMPAR(2) = N, the number of base A digits;
9551 // IPMPAR(3) = A**N - 1, the largest magnitude.
9552 //
9553 // It is assumed that the single and double precision floating
9554 // point arithmetics have the same base, say B, and that the
9555 // nonzero numbers are represented in the form
9556 //
9557 // sign * (B**E) * (X(1)/B + ... + X(M)/B**M)
9558 //
9559 // where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and
9560 // EMIN <= E <= EMAX.
9561 //
9562 // Input argument 4 is a query about the base of real arithmetic:
9563 //
9564 // IPMPAR(4) = B, the base of single and double precision arithmetic.
9565 //
9566 // Input arguments 5 through 7 are queries about single precision
9567 // floating point arithmetic:
9568 //
9569 // IPMPAR(5) = M, the number of base B digits for single precision.
9570 // IPMPAR(6) = EMIN, the smallest exponent E for single precision.
9571 // IPMPAR(7) = EMAX, the largest exponent E for single precision.
9572 //
9573 // Input arguments 8 through 10 are queries about double precision
9574 // floating point arithmetic:
9575 //
9576 // IPMPAR(8) = M, the number of base B digits for double precision.
9577 // IPMPAR(9) = EMIN, the smallest exponent E for double precision.
9578 // IPMPAR(10) = EMAX, the largest exponent E for double precision.
9579 //
9580 // Reference:
9581 //
9582 // Phyllis Fox, Andrew Hall, and Norman Schryer,
9583 // Algorithm 528,
9584 // Framework for a Portable FORTRAN Subroutine Library,
9585 // ACM Transactions on Mathematical Software,
9586 // Volume 4, 1978, pages 176-188.
9587 //
9588 // Parameters:
9589 //
9590 // Input, int *I, the index of the desired constant.
9591 //
9592 // Output, int IPMPAR, the value of the desired constant.
9593 //
9594 {
9595 static int imach[11];
9596 static int ipmpar;
9597 // MACHINE CONSTANTS FOR AMDAHL MACHINES.
9598 //
9599 // imach[1] = 2;
9600 // imach[2] = 31;
9601 // imach[3] = 2147483647;
9602 // imach[4] = 16;
9603 // imach[5] = 6;
9604 // imach[6] = -64;
9605 // imach[7] = 63;
9606 // imach[8] = 14;
9607 // imach[9] = -64;
9608 // imach[10] = 63;
9609 //
9610 // MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T
9611 // PC 7300, AND AT&T 6300.
9612 //
9613 // imach[1] = 2;
9614 // imach[2] = 31;
9615 // imach[3] = 2147483647;
9616 // imach[4] = 2;
9617 // imach[5] = 24;
9618 // imach[6] = -125;
9619 // imach[7] = 128;
9620 // imach[8] = 53;
9621 // imach[9] = -1021;
9622 // imach[10] = 1024;
9623 //
9624 // MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
9625 //
9626 // imach[1] = 2;
9627 // imach[2] = 33;
9628 // imach[3] = 8589934591;
9629 // imach[4] = 2;
9630 // imach[5] = 24;
9631 // imach[6] = -256;
9632 // imach[7] = 255;
9633 // imach[8] = 60;
9634 // imach[9] = -256;
9635 // imach[10] = 255;
9636 //
9637 // MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
9638 //
9639 // imach[1] = 2;
9640 // imach[2] = 39;
9641 // imach[3] = 549755813887;
9642 // imach[4] = 8;
9643 // imach[5] = 13;
9644 // imach[6] = -50;
9645 // imach[7] = 76;
9646 // imach[8] = 26;
9647 // imach[9] = -50;
9648 // imach[10] = 76;
9649 //
9650 // MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
9651 //
9652 // imach[1] = 2;
9653 // imach[2] = 39;
9654 // imach[3] = 549755813887;
9655 // imach[4] = 8;
9656 // imach[5] = 13;
9657 // imach[6] = -50;
9658 // imach[7] = 76;
9659 // imach[8] = 26;
9660 // imach[9] = -32754;
9661 // imach[10] = 32780;
9662 //
9663 // MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
9664 // 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT
9665 // ARITHMETIC (NOS OPERATING SYSTEM).
9666 //
9667 // imach[1] = 2;
9668 // imach[2] = 48;
9669 // imach[3] = 281474976710655;
9670 // imach[4] = 2;
9671 // imach[5] = 48;
9672 // imach[6] = -974;
9673 // imach[7] = 1070;
9674 // imach[8] = 95;
9675 // imach[9] = -926;
9676 // imach[10] = 1070;
9677 //
9678 // MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT
9679 // ARITHMETIC (NOS/VE OPERATING SYSTEM).
9680 //
9681 // imach[1] = 2;
9682 // imach[2] = 63;
9683 // imach[3] = 9223372036854775807;
9684 // imach[4] = 2;
9685 // imach[5] = 48;
9686 // imach[6] = -4096;
9687 // imach[7] = 4095;
9688 // imach[8] = 96;
9689 // imach[9] = -4096;
9690 // imach[10] = 4095;
9691 //
9692 // MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
9693 //
9694 // imach[1] = 2;
9695 // imach[2] = 63;
9696 // imach[3] = 9223372036854775807;
9697 // imach[4] = 2;
9698 // imach[5] = 47;
9699 // imach[6] = -8189;
9700 // imach[7] = 8190;
9701 // imach[8] = 94;
9702 // imach[9] = -8099;
9703 // imach[10] = 8190;
9704 //
9705 // MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200.
9706 //
9707 // imach[1] = 2;
9708 // imach[2] = 15;
9709 // imach[3] = 32767;
9710 // imach[4] = 16;
9711 // imach[5] = 6;
9712 // imach[6] = -64;
9713 // imach[7] = 63;
9714 // imach[8] = 14;
9715 // imach[9] = -64;
9716 // imach[10] = 63;
9717 //
9718 // MACHINE CONSTANTS FOR THE HARRIS 220.
9719 //
9720 // imach[1] = 2;
9721 // imach[2] = 23;
9722 // imach[3] = 8388607;
9723 // imach[4] = 2;
9724 // imach[5] = 23;
9725 // imach[6] = -127;
9726 // imach[7] = 127;
9727 // imach[8] = 38;
9728 // imach[9] = -127;
9729 // imach[10] = 127;
9730 //
9731 // MACHINE CONSTANTS FOR THE HONEYWELL 600/6000
9732 // AND DPS 8/70 SERIES.
9733 //
9734 // imach[1] = 2;
9735 // imach[2] = 35;
9736 // imach[3] = 34359738367;
9737 // imach[4] = 2;
9738 // imach[5] = 27;
9739 // imach[6] = -127;
9740 // imach[7] = 127;
9741 // imach[8] = 63;
9742 // imach[9] = -127;
9743 // imach[10] = 127;
9744 //
9745 // MACHINE CONSTANTS FOR THE HP 2100
9746 // 3 WORD DOUBLE PRECISION OPTION WITH FTN4
9747 //
9748 // imach[1] = 2;
9749 // imach[2] = 15;
9750 // imach[3] = 32767;
9751 // imach[4] = 2;
9752 // imach[5] = 23;
9753 // imach[6] = -128;
9754 // imach[7] = 127;
9755 // imach[8] = 39;
9756 // imach[9] = -128;
9757 // imach[10] = 127;
9758 //
9759 // MACHINE CONSTANTS FOR THE HP 2100
9760 // 4 WORD DOUBLE PRECISION OPTION WITH FTN4
9761 //
9762 // imach[1] = 2;
9763 // imach[2] = 15;
9764 // imach[3] = 32767;
9765 // imach[4] = 2;
9766 // imach[5] = 23;
9767 // imach[6] = -128;
9768 // imach[7] = 127;
9769 // imach[8] = 55;
9770 // imach[9] = -128;
9771 // imach[10] = 127;
9772 //
9773 // MACHINE CONSTANTS FOR THE HP 9000.
9774 //
9775 // imach[1] = 2;
9776 // imach[2] = 31;
9777 // imach[3] = 2147483647;
9778 // imach[4] = 2;
9779 // imach[5] = 24;
9780 // imach[6] = -126;
9781 // imach[7] = 128;
9782 // imach[8] = 53;
9783 // imach[9] = -1021;
9784 // imach[10] = 1024;
9785 //
9786 // MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
9787 // THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA
9788 // 5/7/9 AND THE SEL SYSTEMS 85/86.
9789 //
9790 // imach[1] = 2;
9791 // imach[2] = 31;
9792 // imach[3] = 2147483647;
9793 // imach[4] = 16;
9794 // imach[5] = 6;
9795 // imach[6] = -64;
9796 // imach[7] = 63;
9797 // imach[8] = 14;
9798 // imach[9] = -64;
9799 // imach[10] = 63;
9800 //
9801 // MACHINE CONSTANTS FOR THE IBM PC.
9802 //
9803 // imach[1] = 2;
9804 // imach[2] = 31;
9805 // imach[3] = 2147483647;
9806 // imach[4] = 2;
9807 // imach[5] = 24;
9808 // imach[6] = -125;
9809 // imach[7] = 128;
9810 // imach[8] = 53;
9811 // imach[9] = -1021;
9812 // imach[10] = 1024;
9813 //
9814 // MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT
9815 // MACFORTRAN II.
9816 //
9817 // imach[1] = 2;
9818 // imach[2] = 31;
9819 // imach[3] = 2147483647;
9820 // imach[4] = 2;
9821 // imach[5] = 24;
9822 // imach[6] = -125;
9823 // imach[7] = 128;
9824 // imach[8] = 53;
9825 // imach[9] = -1021;
9826 // imach[10] = 1024;
9827 //
9828 // MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN.
9829 //
9830 // imach[1] = 2;
9831 // imach[2] = 31;
9832 // imach[3] = 2147483647;
9833 // imach[4] = 2;
9834 // imach[5] = 24;
9835 // imach[6] = -127;
9836 // imach[7] = 127;
9837 // imach[8] = 56;
9838 // imach[9] = -127;
9839 // imach[10] = 127;
9840 //
9841 // MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
9842 //
9843 // imach[1] = 2;
9844 // imach[2] = 35;
9845 // imach[3] = 34359738367;
9846 // imach[4] = 2;
9847 // imach[5] = 27;
9848 // imach[6] = -128;
9849 // imach[7] = 127;
9850 // imach[8] = 54;
9851 // imach[9] = -101;
9852 // imach[10] = 127;
9853 //
9854 // MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
9855 //
9856 // imach[1] = 2;
9857 // imach[2] = 35;
9858 // imach[3] = 34359738367;
9859 // imach[4] = 2;
9860 // imach[5] = 27;
9861 // imach[6] = -128;
9862 // imach[7] = 127;
9863 // imach[8] = 62;
9864 // imach[9] = -128;
9865 // imach[10] = 127;
9866 //
9867 // MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
9868 // 32-BIT INTEGER ARITHMETIC.
9869 //
9870 // imach[1] = 2;
9871 // imach[2] = 31;
9872 // imach[3] = 2147483647;
9873 // imach[4] = 2;
9874 // imach[5] = 24;
9875 // imach[6] = -127;
9876 // imach[7] = 127;
9877 // imach[8] = 56;
9878 // imach[9] = -127;
9879 // imach[10] = 127;
9880 //
9881 // MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
9882 //
9883 // imach[1] = 2;
9884 // imach[2] = 31;
9885 // imach[3] = 2147483647;
9886 // imach[4] = 2;
9887 // imach[5] = 24;
9888 // imach[6] = -125;
9889 // imach[7] = 128;
9890 // imach[8] = 53;
9891 // imach[9] = -1021;
9892 // imach[10] = 1024;
9893 //
9894 // MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D
9895 // SERIES (MIPS R3000 PROCESSOR).
9896 //
9897 // imach[1] = 2;
9898 // imach[2] = 31;
9899 // imach[3] = 2147483647;
9900 // imach[4] = 2;
9901 // imach[5] = 24;
9902 // imach[6] = -125;
9903 // imach[7] = 128;
9904 // imach[8] = 53;
9905 // imach[9] = -1021;
9906 // imach[10] = 1024;
9907 //
9908 // MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
9909 // 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
9910 // PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
9911
9912 imach[1] = 2;
9913 imach[2] = 31;
9914 imach[3] = 2147483647;
9915 imach[4] = 2;
9916 imach[5] = 24;
9917 imach[6] = -125;
9918 imach[7] = 128;
9919 imach[8] = 53;
9920 imach[9] = -1021;
9921 imach[10] = 1024;
9922
9923 // MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
9924 //
9925 // imach[1] = 2;
9926 // imach[2] = 35;
9927 // imach[3] = 34359738367;
9928 // imach[4] = 2;
9929 // imach[5] = 27;
9930 // imach[6] = -128;
9931 // imach[7] = 127;
9932 // imach[8] = 60;
9933 // imach[9] = -1024;
9934 // imach[10] = 1023;
9935 //
9936 // MACHINE CONSTANTS FOR THE VAX 11/780.
9937 //
9938 // imach[1] = 2;
9939 // imach[2] = 31;
9940 // imach[3] = 2147483647;
9941 // imach[4] = 2;
9942 // imach[5] = 24;
9943 // imach[6] = -127;
9944 // imach[7] = 127;
9945 // imach[8] = 56;
9946 // imach[9] = -127;
9947 // imach[10] = 127;
9948 //
9949 ipmpar = imach[*i];
9950 return ipmpar;
9951 }
9952 //****************************************************************************80
9953
negative_binomial_cdf_values(int * n_data,int * f,int * s,double * p,double * cdf)9954 void negative_binomial_cdf_values ( int *n_data, int *f, int *s, double *p,
9955 double *cdf )
9956
9957 //****************************************************************************80
9958 //
9959 // Purpose:
9960 //
9961 // NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF.
9962 //
9963 // Discussion:
9964 //
9965 // Assume that a coin has a probability P of coming up heads on
9966 // any one trial. Suppose that we plan to flip the coin until we
9967 // achieve a total of S heads. If we let F represent the number of
9968 // tails that occur in this process, then the value of F satisfies
9969 // a negative binomial PDF:
9970 //
9971 // PDF(F,S,P) = Choose ( F from F+S-1 ) * P**S * (1-P)**F
9972 //
9973 // The negative binomial CDF is the probability that there are F or
9974 // fewer failures upon the attainment of the S-th success. Thus,
9975 //
9976 // CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P)
9977 //
9978 // Modified:
9979 //
9980 // 07 June 2004
9981 //
9982 // Author:
9983 //
9984 // John Burkardt
9985 //
9986 // Reference:
9987 //
9988 // F C Powell,
9989 // Statistical Tables for Sociology, Biology and Physical Sciences,
9990 // Cambridge University Press, 1982.
9991 //
9992 // Parameters:
9993 //
9994 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
9995 // first call. On each call, the routine increments N_DATA by 1, and
9996 // returns the corresponding data; when there is no more data, the
9997 // output value of N_DATA will be 0 again.
9998 //
9999 // Output, int *F, the maximum number of failures.
10000 //
10001 // Output, int *S, the number of successes.
10002 //
10003 // Output, double *P, the probability of a success on one trial.
10004 //
10005 // Output, double *CDF, the probability of at most F failures before the
10006 // S-th success.
10007 //
10008 {
10009 # define N_MAX 27
10010
10011 double cdf_vec[N_MAX] = {
10012 0.6367, 0.3633, 0.1445,
10013 0.5000, 0.2266, 0.0625,
10014 0.3438, 0.1094, 0.0156,
10015 0.1792, 0.0410, 0.0041,
10016 0.0705, 0.0109, 0.0007,
10017 0.9862, 0.9150, 0.7472,
10018 0.8499, 0.5497, 0.2662,
10019 0.6513, 0.2639, 0.0702,
10020 1.0000, 0.0199, 0.0001 };
10021 int f_vec[N_MAX] = {
10022 4, 3, 2,
10023 3, 2, 1,
10024 2, 1, 0,
10025 2, 1, 0,
10026 2, 1, 0,
10027 11, 10, 9,
10028 17, 16, 15,
10029 9, 8, 7,
10030 2, 1, 0 };
10031 double p_vec[N_MAX] = {
10032 0.50, 0.50, 0.50,
10033 0.50, 0.50, 0.50,
10034 0.50, 0.50, 0.50,
10035 0.40, 0.40, 0.40,
10036 0.30, 0.30, 0.30,
10037 0.30, 0.30, 0.30,
10038 0.10, 0.10, 0.10,
10039 0.10, 0.10, 0.10,
10040 0.01, 0.01, 0.01 };
10041 int s_vec[N_MAX] = {
10042 4, 5, 6,
10043 4, 5, 6,
10044 4, 5, 6,
10045 4, 5, 6,
10046 4, 5, 6,
10047 1, 2, 3,
10048 1, 2, 3,
10049 1, 2, 3,
10050 0, 1, 2 };
10051
10052 if ( *n_data < 0 )
10053 {
10054 *n_data = 0;
10055 }
10056
10057 *n_data = *n_data + 1;
10058
10059 if ( N_MAX < *n_data )
10060 {
10061 *n_data = 0;
10062 *f = 0;
10063 *s = 0;
10064 *p = 0.0E+00;
10065 *cdf = 0.0E+00;
10066 }
10067 else
10068 {
10069 *f = f_vec[*n_data-1];
10070 *s = s_vec[*n_data-1];
10071 *p = p_vec[*n_data-1];
10072 *cdf = cdf_vec[*n_data-1];
10073 }
10074
10075 return;
10076 # undef N_MAX
10077 }
10078 //****************************************************************************80
10079
normal_cdf_values(int * n_data,double * x,double * fx)10080 void normal_cdf_values ( int *n_data, double *x, double *fx )
10081
10082 //****************************************************************************80
10083 //
10084 // Purpose:
10085 //
10086 // NORMAL_CDF_VALUES returns some values of the Normal CDF.
10087 //
10088 // Modified:
10089 //
10090 // 31 May 2004
10091 //
10092 // Author:
10093 //
10094 // John Burkardt
10095 //
10096 // Reference:
10097 //
10098 // Milton Abramowitz and Irene Stegun,
10099 // Handbook of Mathematical Functions,
10100 // US Department of Commerce, 1964.
10101 //
10102 // Parameters:
10103 //
10104 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10105 // first call. On each call, the routine increments N_DATA by 1, and
10106 // returns the corresponding data; when there is no more data, the
10107 // output value of N_DATA will be 0 again.
10108 //
10109 // Output, double *X, the argument of the function.
10110 //
10111 // Output double *FX, the value of the function.
10112 //
10113 {
10114 # define N_MAX 13
10115
10116 double fx_vec[N_MAX] = {
10117 0.500000000000000E+00, 0.539827837277029E+00, 0.579259709439103E+00,
10118 0.617911422188953E+00, 0.655421741610324E+00, 0.691462461274013E+00,
10119 0.725746882249927E+00, 0.758036347776927E+00, 0.788144601416604E+00,
10120 0.815939874653241E+00, 0.841344746068543E+00, 0.933192798731142E+00,
10121 0.977249868051821E+00 };
10122 double x_vec[N_MAX] = {
10123 0.00E+00, 0.10E+00, 0.20E+00,
10124 0.30E+00, 0.40E+00, 0.50E+00,
10125 0.60E+00, 0.70E+00, 0.80E+00,
10126 0.90E+00, 1.00E+00, 1.50E+00,
10127 2.00E+00 };
10128
10129 if ( *n_data < 0 )
10130 {
10131 *n_data = 0;
10132 }
10133
10134 *n_data = *n_data + 1;
10135
10136 if ( N_MAX < *n_data )
10137 {
10138 *n_data = 0;
10139 *x = 0.0E+00;
10140 *fx = 0.0E+00;
10141 }
10142 else
10143 {
10144 *x = x_vec[*n_data-1];
10145 *fx = fx_vec[*n_data-1];
10146 }
10147
10148 return;
10149 # undef N_MAX
10150 }
10151 //****************************************************************************80
10152
poisson_cdf_values(int * n_data,double * a,int * x,double * fx)10153 void poisson_cdf_values ( int *n_data, double *a, int *x, double *fx )
10154
10155 //****************************************************************************80
10156 //
10157 // Purpose:
10158 //
10159 // POISSON_CDF_VALUES returns some values of the Poisson CDF.
10160 //
10161 // Discussion:
10162 //
10163 // CDF(X)(A) is the probability of at most X successes in unit time,
10164 // given that the expected mean number of successes is A.
10165 //
10166 // Modified:
10167 //
10168 // 31 May 2004
10169 //
10170 // Author:
10171 //
10172 // John Burkardt
10173 //
10174 // Reference:
10175 //
10176 // Milton Abramowitz and Irene Stegun,
10177 // Handbook of Mathematical Functions,
10178 // US Department of Commerce, 1964.
10179 //
10180 // Daniel Zwillinger,
10181 // CRC Standard Mathematical Tables and Formulae,
10182 // 30th Edition, CRC Press, 1996, pages 653-658.
10183 //
10184 // Parameters:
10185 //
10186 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10187 // first call. On each call, the routine increments N_DATA by 1, and
10188 // returns the corresponding data; when there is no more data, the
10189 // output value of N_DATA will be 0 again.
10190 //
10191 // Output, double *A, the parameter of the function.
10192 //
10193 // Output, int *X, the argument of the function.
10194 //
10195 // Output, double *FX, the value of the function.
10196 //
10197 {
10198 # define N_MAX 21
10199
10200 double a_vec[N_MAX] = {
10201 0.02E+00, 0.10E+00, 0.10E+00, 0.50E+00,
10202 0.50E+00, 0.50E+00, 1.00E+00, 1.00E+00,
10203 1.00E+00, 1.00E+00, 2.00E+00, 2.00E+00,
10204 2.00E+00, 2.00E+00, 5.00E+00, 5.00E+00,
10205 5.00E+00, 5.00E+00, 5.00E+00, 5.00E+00,
10206 5.00E+00 };
10207 double fx_vec[N_MAX] = {
10208 0.980E+00, 0.905E+00, 0.995E+00, 0.607E+00,
10209 0.910E+00, 0.986E+00, 0.368E+00, 0.736E+00,
10210 0.920E+00, 0.981E+00, 0.135E+00, 0.406E+00,
10211 0.677E+00, 0.857E+00, 0.007E+00, 0.040E+00,
10212 0.125E+00, 0.265E+00, 0.441E+00, 0.616E+00,
10213 0.762E+00 };
10214 int x_vec[N_MAX] = {
10215 0, 0, 1, 0,
10216 1, 2, 0, 1,
10217 2, 3, 0, 1,
10218 2, 3, 0, 1,
10219 2, 3, 4, 5,
10220 6 };
10221
10222 if ( *n_data < 0 )
10223 {
10224 *n_data = 0;
10225 }
10226
10227 *n_data = *n_data + 1;
10228
10229 if ( N_MAX < *n_data )
10230 {
10231 *n_data = 0;
10232 *a = 0.0E+00;
10233 *x = 0;
10234 *fx = 0.0E+00;
10235 }
10236 else
10237 {
10238 *a = a_vec[*n_data-1];
10239 *x = x_vec[*n_data-1];
10240 *fx = fx_vec[*n_data-1];
10241 }
10242 return;
10243 # undef N_MAX
10244 }
10245 //****************************************************************************80
10246
psi(double * xx)10247 double psi ( double *xx )
10248
10249 //****************************************************************************80
10250 //
10251 // Purpose:
10252 //
10253 // PSI evaluates the psi or digamma function, d/dx ln(gamma(x)).
10254 //
10255 // Discussion:
10256 //
10257 // The main computation involves evaluation of rational Chebyshev
10258 // approximations. PSI was written at Argonne National Laboratory
10259 // for FUNPACK, and subsequently modified by A. H. Morris of NSWC.
10260 //
10261 // Reference:
10262 //
10263 // William Cody, Strecok and Thacher,
10264 // Chebyshev Approximations for the Psi Function,
10265 // Mathematics of Computation,
10266 // Volume 27, 1973, pages 123-127.
10267 //
10268 // Parameters:
10269 //
10270 // Input, double *XX, the argument of the psi function.
10271 //
10272 // Output, double PSI, the value of the psi function. PSI
10273 // is assigned the value 0 when the psi function is undefined.
10274 //
10275 {
10276 static double dx0 = 1.461632144968362341262659542325721325e0;
10277 static double piov4 = .785398163397448e0;
10278 static double p1[7] = {
10279 .895385022981970e-02,.477762828042627e+01,.142441585084029e+03,
10280 .118645200713425e+04,.363351846806499e+04,.413810161269013e+04,
10281 .130560269827897e+04
10282 };
10283 static double p2[4] = {
10284 -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01,
10285 -.648157123766197e+00
10286 };
10287 static double q1[6] = {
10288 .448452573429826e+02,.520752771467162e+03,.221000799247830e+04,
10289 .364127349079381e+04,.190831076596300e+04,.691091682714533e-05
10290 };
10291 static double q2[4] = {
10292 .322703493791143e+02,.892920700481861e+02,.546117738103215e+02,
10293 .777788548522962e+01
10294 };
10295 static int K1 = 3;
10296 static int K2 = 1;
10297 static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z;
10298 static int i,m,n,nq;
10299 //
10300 // MACHINE DEPENDENT CONSTANTS ...
10301 // XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
10302 // WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED
10303 // AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
10304 // ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
10305 // PSI MAY BE REPRESENTED AS ALOG(X).
10306 // XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
10307 // MAY BE REPRESENTED BY 1/X.
10308 //
10309 xmax1 = ipmpar(&K1);
10310 xmax1 = fifdmin1(xmax1,1.0e0/dpmpar(&K2));
10311 xsmall = 1.e-9;
10312 x = *xx;
10313 aug = 0.0e0;
10314 if(x >= 0.5e0) goto S50;
10315 //
10316 // X .LT. 0.5, USE REFLECTION FORMULA
10317 // PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
10318 //
10319 if(fabs(x) > xsmall) goto S10;
10320 if(x == 0.0e0) goto S100;
10321 //
10322 // 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE
10323 // FOR PI*COTAN(PI*X)
10324 //
10325 aug = -(1.0e0/x);
10326 goto S40;
10327 S10:
10328 //
10329 // REDUCTION OF ARGUMENT FOR COTAN
10330 //
10331 w = -x;
10332 sgn = piov4;
10333 if(w > 0.0e0) goto S20;
10334 w = -w;
10335 sgn = -sgn;
10336 S20:
10337 //
10338 // MAKE AN ERROR EXIT IF X .LE. -XMAX1
10339 //
10340 if(w >= xmax1) goto S100;
10341 nq = fifidint(w);
10342 w -= (double)nq;
10343 nq = fifidint(w*4.0e0);
10344 w = 4.0e0*(w-(double)nq*.25e0);
10345 //
10346 // W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X.
10347 // ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
10348 // QUADRANT AND DETERMINE SIGN
10349 //
10350 n = nq/2;
10351 if(n+n != nq) w = 1.0e0-w;
10352 z = piov4*w;
10353 m = n/2;
10354 if(m+m != n) sgn = -sgn;
10355 //
10356 // DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X)
10357 //
10358 n = (nq+1)/2;
10359 m = n/2;
10360 m += m;
10361 if(m != n) goto S30;
10362 //
10363 // CHECK FOR SINGULARITY
10364 //
10365 if(z == 0.0e0) goto S100;
10366 //
10367 // USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
10368 // SIN/COS AS A SUBSTITUTE FOR TAN
10369 //
10370 aug = sgn*(cos(z)/sin(z)*4.0e0);
10371 goto S40;
10372 S30:
10373 aug = sgn*(sin(z)/cos(z)*4.0e0);
10374 S40:
10375 x = 1.0e0-x;
10376 S50:
10377 if(x > 3.0e0) goto S70;
10378 //
10379 // 0.5 .LE. X .LE. 3.0
10380 //
10381 den = x;
10382 upper = p1[0]*x;
10383 for ( i = 1; i <= 5; i++ )
10384 {
10385 den = (den+q1[i-1])*x;
10386 upper = (upper+p1[i+1-1])*x;
10387 }
10388 den = (upper+p1[6])/(den+q1[5]);
10389 xmx0 = x-dx0;
10390 psi = den*xmx0+aug;
10391 return psi;
10392 S70:
10393 //
10394 // IF X .GE. XMAX1, PSI = LN(X)
10395 //
10396 if(x >= xmax1) goto S90;
10397 //
10398 // 3.0 .LT. X .LT. XMAX1
10399 //
10400 w = 1.0e0/(x*x);
10401 den = w;
10402 upper = p2[0]*w;
10403 for ( i = 1; i <= 3; i++ )
10404 {
10405 den = (den+q2[i-1])*w;
10406 upper = (upper+p2[i+1-1])*w;
10407 }
10408 aug = upper/(den+q2[3])-0.5e0/x+aug;
10409 S90:
10410 psi = aug+log(x);
10411 return psi;
10412 S100:
10413 //
10414 // ERROR RETURN
10415 //
10416 psi = 0.0e0;
10417 return psi;
10418 }
10419 //****************************************************************************80
10420
psi_values(int * n_data,double * x,double * fx)10421 void psi_values ( int *n_data, double *x, double *fx )
10422
10423 //****************************************************************************80
10424 //
10425 // Purpose:
10426 //
10427 // PSI_VALUES returns some values of the Psi or Digamma function.
10428 //
10429 // Discussion:
10430 //
10431 // PSI(X) = d LN ( Gamma ( X ) ) / d X = Gamma'(X) / Gamma(X)
10432 //
10433 // PSI(1) = - Euler's constant.
10434 //
10435 // PSI(X+1) = PSI(X) + 1 / X.
10436 //
10437 // Modified:
10438 //
10439 // 31 May 2004
10440 //
10441 // Author:
10442 //
10443 // John Burkardt
10444 //
10445 // Reference:
10446 //
10447 // Milton Abramowitz and Irene Stegun,
10448 // Handbook of Mathematical Functions,
10449 // US Department of Commerce, 1964.
10450 //
10451 // Parameters:
10452 //
10453 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10454 // first call. On each call, the routine increments N_DATA by 1, and
10455 // returns the corresponding data; when there is no more data, the
10456 // output value of N_DATA will be 0 again.
10457 //
10458 // Output, double *X, the argument of the function.
10459 //
10460 // Output, double *FX, the value of the function.
10461 //
10462 {
10463 # define N_MAX 11
10464
10465 double fx_vec[N_MAX] = {
10466 -0.5772156649E+00, -0.4237549404E+00, -0.2890398966E+00,
10467 -0.1691908889E+00, -0.0613845446E+00, -0.0364899740E+00,
10468 0.1260474528E+00, 0.2085478749E+00, 0.2849914333E+00,
10469 0.3561841612E+00, 0.4227843351E+00 };
10470 double x_vec[N_MAX] = {
10471 1.0E+00, 1.1E+00, 1.2E+00,
10472 1.3E+00, 1.4E+00, 1.5E+00,
10473 1.6E+00, 1.7E+00, 1.8E+00,
10474 1.9E+00, 2.0E+00 };
10475
10476 if ( *n_data < 0 )
10477 {
10478 *n_data = 0;
10479 }
10480
10481 *n_data = *n_data + 1;
10482
10483 if ( N_MAX < *n_data )
10484 {
10485 *n_data = 0;
10486 *x = 0.0E+00;
10487 *fx = 0.0E+00;
10488 }
10489 else
10490 {
10491 *x = x_vec[*n_data-1];
10492 *fx = fx_vec[*n_data-1];
10493 }
10494 return;
10495 # undef N_MAX
10496 }
10497 //****************************************************************************80
10498
rcomp(double * a,double * x)10499 double rcomp ( double *a, double *x )
10500
10501 //****************************************************************************80
10502 //
10503 // Purpose:
10504 //
10505 // RCOMP evaluates exp(-X) * X**A / Gamma(A).
10506 //
10507 // Parameters:
10508 //
10509 // Input, double *A, *X, arguments of the quantity to be computed.
10510 //
10511 // Output, double RCOMP, the value of exp(-X) * X**A / Gamma(A).
10512 //
10513 // Local parameters:
10514 //
10515 // RT2PIN = 1/SQRT(2*PI)
10516 //
10517 {
10518 static double rt2pin = .398942280401433e0;
10519 static double rcomp,t,t1,u;
10520 rcomp = 0.0e0;
10521 if(*a >= 20.0e0) goto S20;
10522 t = *a*log(*x)-*x;
10523 if(*a >= 1.0e0) goto S10;
10524 rcomp = *a*exp(t)*(1.0e0+gam1(a));
10525 return rcomp;
10526 S10:
10527 rcomp = exp(t)/ gamma_x(a);
10528 return rcomp;
10529 S20:
10530 u = *x/ *a;
10531 if(u == 0.0e0) return rcomp;
10532 t = pow(1.0e0/ *a,2.0);
10533 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
10534 t1 -= (*a*rlog(&u));
10535 rcomp = rt2pin*sqrt(*a)*exp(t1);
10536 return rcomp;
10537 }
10538 //****************************************************************************80
10539
rexp(double * x)10540 double rexp ( double *x )
10541
10542 //****************************************************************************80
10543 //
10544 // Purpose:
10545 //
10546 // REXP evaluates the function EXP(X) - 1.
10547 //
10548 // Modified:
10549 //
10550 // 09 December 1999
10551 //
10552 // Parameters:
10553 //
10554 // Input, double *X, the argument of the function.
10555 //
10556 // Output, double REXP, the value of EXP(X)-1.
10557 //
10558 {
10559 static double p1 = .914041914819518e-09;
10560 static double p2 = .238082361044469e-01;
10561 static double q1 = -.499999999085958e+00;
10562 static double q2 = .107141568980644e+00;
10563 static double q3 = -.119041179760821e-01;
10564 static double q4 = .595130811860248e-03;
10565 static double rexp,w;
10566
10567 if(fabs(*x) > 0.15e0) goto S10;
10568 rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
10569 return rexp;
10570 S10:
10571 w = exp(*x);
10572 if(*x > 0.0e0) goto S20;
10573 rexp = w-0.5e0-0.5e0;
10574 return rexp;
10575 S20:
10576 rexp = w*(0.5e0+(0.5e0-1.0e0/w));
10577 return rexp;
10578 }
10579 //****************************************************************************80
10580
rlog(double * x)10581 double rlog ( double *x )
10582
10583 //****************************************************************************80
10584 //
10585 // Purpose:
10586 //
10587 // RLOG computes X - 1 - LN(X).
10588 //
10589 // Modified:
10590 //
10591 // 09 December 1999
10592 //
10593 // Parameters:
10594 //
10595 // Input, double *X, the argument of the function.
10596 //
10597 // Output, double RLOG, the value of the function.
10598 //
10599 {
10600 static double a = .566749439387324e-01;
10601 static double b = .456512608815524e-01;
10602 static double p0 = .333333333333333e+00;
10603 static double p1 = -.224696413112536e+00;
10604 static double p2 = .620886815375787e-02;
10605 static double q1 = -.127408923933623e+01;
10606 static double q2 = .354508718369557e+00;
10607 static double rlog,r,t,u,w,w1;
10608
10609 if(*x < 0.61e0 || *x > 1.57e0) goto S40;
10610 if(*x < 0.82e0) goto S10;
10611 if(*x > 1.18e0) goto S20;
10612 //
10613 // ARGUMENT REDUCTION
10614 //
10615 u = *x-0.5e0-0.5e0;
10616 w1 = 0.0e0;
10617 goto S30;
10618 S10:
10619 u = *x-0.7e0;
10620 u /= 0.7e0;
10621 w1 = a-u*0.3e0;
10622 goto S30;
10623 S20:
10624 u = 0.75e0**x-1.e0;
10625 w1 = b+u/3.0e0;
10626 S30:
10627 //
10628 // SERIES EXPANSION
10629 //
10630 r = u/(u+2.0e0);
10631 t = r*r;
10632 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
10633 rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
10634 return rlog;
10635 S40:
10636 r = *x-0.5e0-0.5e0;
10637 rlog = r-log(*x);
10638 return rlog;
10639 }
10640 //****************************************************************************80
10641
rlog1(double * x)10642 double rlog1 ( double *x )
10643
10644 //****************************************************************************80
10645 //
10646 // Purpose:
10647 //
10648 // RLOG1 evaluates the function X - ln ( 1 + X ).
10649 //
10650 // Parameters:
10651 //
10652 // Input, double *X, the argument.
10653 //
10654 // Output, double RLOG1, the value of X - ln ( 1 + X ).
10655 //
10656 {
10657 static double a = .566749439387324e-01;
10658 static double b = .456512608815524e-01;
10659 static double p0 = .333333333333333e+00;
10660 static double p1 = -.224696413112536e+00;
10661 static double p2 = .620886815375787e-02;
10662 static double q1 = -.127408923933623e+01;
10663 static double q2 = .354508718369557e+00;
10664 static double rlog1,h,r,t,w,w1;
10665
10666 if(*x < -0.39e0 || *x > 0.57e0) goto S40;
10667 if(*x < -0.18e0) goto S10;
10668 if(*x > 0.18e0) goto S20;
10669 //
10670 // ARGUMENT REDUCTION
10671 //
10672 h = *x;
10673 w1 = 0.0e0;
10674 goto S30;
10675 S10:
10676 h = *x+0.3e0;
10677 h /= 0.7e0;
10678 w1 = a-h*0.3e0;
10679 goto S30;
10680 S20:
10681 h = 0.75e0**x-0.25e0;
10682 w1 = b+h/3.0e0;
10683 S30:
10684 //
10685 // SERIES EXPANSION
10686 //
10687 r = h/(h+2.0e0);
10688 t = r*r;
10689 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
10690 rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
10691 return rlog1;
10692 S40:
10693 w = *x+0.5e0+0.5e0;
10694 rlog1 = *x-log(w);
10695 return rlog1;
10696 }
10697 //****************************************************************************80
10698
student_cdf_values(int * n_data,int * a,double * x,double * fx)10699 void student_cdf_values ( int *n_data, int *a, double *x, double *fx )
10700
10701 //****************************************************************************80
10702 //
10703 // Purpose:
10704 //
10705 // STUDENT_CDF_VALUES returns some values of the Student CDF.
10706 //
10707 // Modified:
10708 //
10709 // 31 May 2004
10710 //
10711 // Author:
10712 //
10713 // John Burkardt
10714 //
10715 // Reference:
10716 //
10717 // Milton Abramowitz and Irene Stegun,
10718 // Handbook of Mathematical Functions,
10719 // US Department of Commerce, 1964.
10720 //
10721 // Parameters:
10722 //
10723 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10724 // first call. On each call, the routine increments N_DATA by 1, and
10725 // returns the corresponding data; when there is no more data, the
10726 // output value of N_DATA will be 0 again.
10727 //
10728 // Output, int *A, the parameter of the function.
10729 //
10730 // Output, double *X, the argument of the function.
10731 //
10732 // Output, double *FX, the value of the function.
10733 //
10734 {
10735 # define N_MAX 13
10736
10737 int a_vec[N_MAX] = {
10738 1, 2, 3, 4,
10739 5, 2, 5, 2,
10740 5, 2, 3, 4,
10741 5 };
10742 double fx_vec[N_MAX] = {
10743 0.60E+00, 0.60E+00, 0.60E+00, 0.60E+00,
10744 0.60E+00, 0.75E+00, 0.75E+00, 0.95E+00,
10745 0.95E+00, 0.99E+00, 0.99E+00, 0.99E+00,
10746 0.99E+00 };
10747 double x_vec[N_MAX] = {
10748 0.325E+00, 0.289E+00, 0.277E+00, 0.271E+00,
10749 0.267E+00, 0.816E+00, 0.727E+00, 2.920E+00,
10750 2.015E+00, 6.965E+00, 4.541E+00, 3.747E+00,
10751 3.365E+00 };
10752
10753 if ( *n_data < 0 )
10754 {
10755 *n_data = 0;
10756 }
10757
10758 *n_data = *n_data + 1;
10759
10760 if ( N_MAX < *n_data )
10761 {
10762 *n_data = 0;
10763 *a = 0;
10764 *x = 0.0E+00;
10765 *fx = 0.0E+00;
10766 }
10767 else
10768 {
10769 *a = a_vec[*n_data-1];
10770 *x = x_vec[*n_data-1];
10771 *fx = fx_vec[*n_data-1];
10772 }
10773
10774 return;
10775 # undef N_MAX
10776 }
10777 //****************************************************************************80
10778
stvaln(double * p)10779 double stvaln ( double *p )
10780
10781 //****************************************************************************80
10782 //
10783 // Purpose:
10784 //
10785 // STVALN provides starting values for the inverse of the normal distribution.
10786 //
10787 // Discussion:
10788 //
10789 // The routine returns X such that
10790 // P = CUMNOR(X),
10791 // that is,
10792 // P = Integral from -infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU.
10793 //
10794 // Reference:
10795 //
10796 // Kennedy and Gentle,
10797 // Statistical Computing,
10798 // Marcel Dekker, NY, 1980, page 95,
10799 // QA276.4 K46
10800 //
10801 // Parameters:
10802 //
10803 // Input, double *P, the probability whose normal deviate
10804 // is sought.
10805 //
10806 // Output, double STVALN, the normal deviate whose probability
10807 // is P.
10808 //
10809 {
10810 static double xden[5] = {
10811 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0,
10812 0.38560700634e-2
10813 };
10814 static double xnum[5] = {
10815 -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1,
10816 -0.453642210148e-4
10817 };
10818 static int K1 = 5;
10819 static double stvaln,sign,y,z;
10820
10821 if(!(*p <= 0.5e0)) goto S10;
10822 sign = -1.0e0;
10823 z = *p;
10824 goto S20;
10825 S10:
10826 sign = 1.0e0;
10827 z = 1.0e0-*p;
10828 S20:
10829 y = sqrt(-(2.0e0*log(z)));
10830 stvaln = y+ eval_pol ( xnum, &K1, &y ) / eval_pol ( xden, &K1, &y );
10831 stvaln = sign*stvaln;
10832 return stvaln;
10833 }
10834 //**************************************************************************80
10835
10836 #if !defined(TIMESTAMP)
10837 #define TIMESTAMP
timestamp()10838 void timestamp ( )
10839
10840 //**************************************************************************80
10841 //
10842 // Purpose:
10843 //
10844 // TIMESTAMP prints the current YMDHMS date as a time stamp.
10845 //
10846 // Example:
10847 //
10848 // May 31 2001 09:45:54 AM
10849 //
10850 // Modified:
10851 //
10852 // 24 September 2003
10853 //
10854 // Author:
10855 //
10856 // John Burkardt
10857 //
10858 // Parameters:
10859 //
10860 // None
10861 //
10862 {
10863 # define TIME_SIZE 40
10864
10865 static char time_buffer[TIME_SIZE];
10866 const struct tm *tm;
10867 size_t len;
10868 time_t now;
10869
10870 now = time ( NULL );
10871 tm = localtime ( &now );
10872
10873 len = strftime ( time_buffer, TIME_SIZE, "%d %B %Y %I:%M:%S %p", tm );
10874
10875 cout << time_buffer << "\n";
10876
10877 return;
10878 # undef TIME_SIZE
10879 }
10880
10881
10882 #endif
10883