1 # include <cstdlib>
2 # include <iostream>
3 # include <iomanip>
4 # include <cmath>
5 # include <ctime>
6 # include <cstring>
7
8 using namespace std;
9
10 # include "cdflib.hpp"
11
12 //****************************************************************************80
13
algdiv(double * a,double * b)14 double algdiv ( double *a, double *b )
15
16 //****************************************************************************80
17 //
18 // Purpose:
19 //
20 // ALGDIV computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B.
21 //
22 // Discussion:
23 //
24 // In this algorithm, DEL(X) is the function defined by
25 //
26 // ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI )
27 // + DEL(X).
28 //
29 // Parameters:
30 //
31 // Input, double *A, *B, define the arguments.
32 //
33 // Output, double ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)).
34 //
35 {
36 static double algdiv;
37 static double c;
38 static double c0 = 0.833333333333333e-01;
39 static double c1 = -0.277777777760991e-02;
40 static double c2 = 0.793650666825390e-03;
41 static double c3 = -0.595202931351870e-03;
42 static double c4 = 0.837308034031215e-03;
43 static double c5 = -0.165322962780713e-02;
44 static double d;
45 static double h;
46 static double s11;
47 static double s3;
48 static double s5;
49 static double s7;
50 static double s9;
51 static double t;
52 static double T1;
53 static double u;
54 static double v;
55 static double w;
56 static double x;
57 static double x2;
58
59 if ( *b <= *a )
60 {
61 h = *b / *a;
62 c = 1.0e0 / ( 1.0e0 + h );
63 x = h / ( 1.0e0 + h );
64 d = *a + ( *b - 0.5e0 );
65 }
66 else
67 {
68 h = *a / *b;
69 c = h / ( 1.0e0 + h );
70 x = 1.0e0 / ( 1.0e0 + h );
71 d = *b + ( *a - 0.5e0 );
72 }
73 //
74 // SET SN = (1 - X**N)/(1 - X)
75 //
76 x2 = x * x;
77 s3 = 1.0e0 + ( x + x2 );
78 s5 = 1.0e0 + ( x + x2 * s3 );
79 s7 = 1.0e0 + ( x + x2 * s5 );
80 s9 = 1.0e0 + ( x + x2 * s7 );
81 s11 = 1.0e0 + ( x + x2 * s9 );
82 //
83 // SET W = DEL(B) - DEL(A + B)
84 //
85 t = pow ( 1.0e0 / *b, 2.0 );
86
87 w = (((( c5 * s11 * t
88 + c4 * s9 ) * t
89 + c3 * s7 ) * t
90 + c2 * s5 ) * t
91 + c1 * s3 ) * t
92 + c0;
93
94 w *= ( c / *b );
95 //
96 // Combine the results.
97 //
98 T1 = *a / *b;
99 u = d * alnrel ( &T1 );
100 v = *a * ( log ( *b ) - 1.0e0 );
101
102 if ( v < u )
103 {
104 algdiv = w - v - u;
105 }
106 else
107 {
108 algdiv = w - u - v;
109 }
110 return algdiv;
111 }
112 //****************************************************************************80
113
alnrel(double * a)114 double alnrel ( double *a )
115
116 //****************************************************************************80
117 //
118 // Purpose:
119 //
120 // ALNREL evaluates the function ln ( 1 + A ).
121 //
122 // Modified:
123 //
124 // 17 November 2006
125 //
126 // Reference:
127 //
128 // Armido DiDinato, Alfred Morris,
129 // Algorithm 708:
130 // Significant Digit Computation of the Incomplete Beta Function Ratios,
131 // ACM Transactions on Mathematical Software,
132 // Volume 18, 1993, pages 360-373.
133 //
134 // Parameters:
135 //
136 // Input, double *A, the argument.
137 //
138 // Output, double ALNREL, the value of ln ( 1 + A ).
139 //
140 {
141 double alnrel;
142 static double p1 = -0.129418923021993e+01;
143 static double p2 = 0.405303492862024e+00;
144 static double p3 = -0.178874546012214e-01;
145 static double q1 = -0.162752256355323e+01;
146 static double q2 = 0.747811014037616e+00;
147 static double q3 = -0.845104217945565e-01;
148 double t;
149 double t2;
150 double w;
151 double x;
152
153 if ( fabs ( *a ) <= 0.375e0 )
154 {
155 t = *a / ( *a + 2.0e0 );
156 t2 = t * t;
157 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)
158 / (((q3*t2+q2)*t2+q1)*t2+1.0e0);
159 alnrel = 2.0e0 * t * w;
160 }
161 else
162 {
163 x = 1.0e0 + *a;
164 alnrel = log ( x );
165 }
166 return alnrel;
167 }
168 //****************************************************************************80
169
apser(double * a,double * b,double * x,double * eps)170 double apser ( double *a, double *b, double *x, double *eps )
171
172 //****************************************************************************80
173 //
174 // Purpose:
175 //
176 // APSER computes the incomplete beta ratio I(SUB(1-X))(B,A).
177 //
178 // Discussion:
179 //
180 // APSER is used only for cases where
181 //
182 // A <= min ( EPS, EPS * B ),
183 // B * X <= 1, and
184 // X <= 0.5.
185 //
186 // Parameters:
187 //
188 // Input, double *A, *B, *X, the parameters of teh
189 // incomplete beta ratio.
190 //
191 // Input, double *EPS, a tolerance.
192 //
193 // Output, double APSER, the computed value of the
194 // incomplete beta ratio.
195 //
196 {
197 static double g = 0.577215664901533e0;
198 static double apser,aj,bx,c,j,s,t,tol;
199
200 bx = *b**x;
201 t = *x-bx;
202 if(*b**eps > 2.e-2) goto S10;
203 c = log(*x)+psi(b)+g+t;
204 goto S20;
205 S10:
206 c = log(bx)+g+t;
207 S20:
208 tol = 5.0e0**eps*fabs(c);
209 j = 1.0e0;
210 s = 0.0e0;
211 S30:
212 j = j + 1.0e0;
213 t = t * (*x-bx/j);
214 aj = t/j;
215 s = s + aj;
216 if(fabs(aj) > tol) goto S30;
217 apser = -(*a*(c+s));
218 return apser;
219 }
220 //****************************************************************************80
221
bcorr(double * a0,double * b0)222 double bcorr ( double *a0, double *b0 )
223
224 //****************************************************************************80
225 //
226 // Purpose:
227 //
228 // BCORR evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0).
229 //
230 // Discussion:
231 //
232 // The function DEL(A) is a remainder term that is used in the expression:
233 //
234 // ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A )
235 // - A + 0.5 * ln ( 2 * PI ) + DEL ( A ),
236 //
237 // or, in other words, DEL ( A ) is defined as:
238 //
239 // DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A )
240 // + A + 0.5 * ln ( 2 * PI ).
241 //
242 // Parameters:
243 //
244 // Input, double *A0, *B0, the arguments.
245 // It is assumed that 8 <= A0 and 8 <= B0.
246 //
247 // Output, double *BCORR, the value of the function.
248 //
249 {
250 static double c0 = 0.833333333333333e-01;
251 static double c1 = -0.277777777760991e-02;
252 static double c2 = 0.793650666825390e-03;
253 static double c3 = -0.595202931351870e-03;
254 static double c4 = 0.837308034031215e-03;
255 static double c5 = -0.165322962780713e-02;
256 static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2;
257
258 a = fifdmin1 ( *a0, *b0 );
259 b = fifdmax1 ( *a0, *b0 );
260 h = a / b;
261 c = h / ( 1.0e0 + h );
262 x = 1.0e0 / ( 1.0e0 + h );
263 x2 = x * x;
264 //
265 // SET SN = (1 - X**N)/(1 - X)
266 //
267 s3 = 1.0e0 + ( x + x2 );
268 s5 = 1.0e0 + ( x + x2 * s3 );
269 s7 = 1.0e0 + ( x + x2 * s5 );
270 s9 = 1.0e0 + ( x + x2 * s7 );
271 s11 = 1.0e0 + ( x + x2 * s9 );
272 //
273 // SET W = DEL(B) - DEL(A + B)
274 //
275 t = pow ( 1.0e0 / b, 2.0 );
276
277 w = (((( c5 * s11 * t + c4
278 * s9 ) * t + c3
279 * s7 ) * t + c2
280 * s5 ) * t + c1
281 * s3 ) * t + c0;
282 w *= ( c / b );
283 //
284 // COMPUTE DEL(A) + W
285 //
286 t = pow ( 1.0e0 / a, 2.0 );
287
288 bcorr = ((((( c5 * t + c4 )
289 * t + c3 )
290 * t + c2 )
291 * t + c1 )
292 * t + c0 ) / a + w;
293 return bcorr;
294 }
295 //****************************************************************************80
296
beta(double a,double b)297 double beta ( double a, double b )
298
299 //****************************************************************************80
300 //
301 // Purpose:
302 //
303 // BETA evaluates the beta function.
304 //
305 // Modified:
306 //
307 // 03 December 1999
308 //
309 // Author:
310 //
311 // John Burkardt
312 //
313 // Parameters:
314 //
315 // Input, double A, B, the arguments of the beta function.
316 //
317 // Output, double BETA, the value of the beta function.
318 //
319 {
320 return ( exp ( beta_log ( &a, &b ) ) );
321 }
322 //****************************************************************************80
323
beta_asym(double * a,double * b,double * lambda,double * eps)324 double beta_asym ( double *a, double *b, double *lambda, double *eps )
325
326 //****************************************************************************80
327 //
328 // Purpose:
329 //
330 // BETA_ASYM computes an asymptotic expansion for IX(A,B), for large A and B.
331 //
332 // Parameters:
333 //
334 // Input, double *A, *B, the parameters of the function.
335 // A and B should be nonnegative. It is assumed that both A and B
336 // are greater than or equal to 15.
337 //
338 // Input, double *LAMBDA, the value of ( A + B ) * Y - B.
339 // It is assumed that 0 <= LAMBDA.
340 //
341 // Input, double *EPS, the tolerance.
342 //
343 {
344 static double e0 = 1.12837916709551e0;
345 static double e1 = .353553390593274e0;
346 static int num = 20;
347 //
348 // NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
349 // ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
350 // THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
351 // E0 = 2/SQRT(PI)
352 // E1 = 2**(-3/2)
353 //
354 static int K3 = 1;
355 static double value;
356 static double bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0,
357 z2,zn,znm1;
358 static int i,im1,imj,j,m,mm1,mmj,n,np1;
359 static double a0[21],b0[21],c[21],d[21],T1,T2;
360
361 value = 0.0e0;
362 if(*a >= *b) goto S10;
363 h = *a/ *b;
364 r0 = 1.0e0/(1.0e0+h);
365 r1 = (*b-*a)/ *b;
366 w0 = 1.0e0/sqrt(*a*(1.0e0+h));
367 goto S20;
368 S10:
369 h = *b/ *a;
370 r0 = 1.0e0/(1.0e0+h);
371 r1 = (*b-*a)/ *a;
372 w0 = 1.0e0/sqrt(*b*(1.0e0+h));
373 S20:
374 T1 = -(*lambda/ *a);
375 T2 = *lambda/ *b;
376 f = *a*rlog1(&T1)+*b*rlog1(&T2);
377 t = exp(-f);
378 if(t == 0.0e0) return value;
379 z0 = sqrt(f);
380 z = 0.5e0*(z0/e1);
381 z2 = f+f;
382 a0[0] = 2.0e0/3.0e0*r1;
383 c[0] = -(0.5e0*a0[0]);
384 d[0] = -c[0];
385 j0 = 0.5e0/e0 * error_fc ( &K3, &z0 );
386 j1 = e1;
387 sum = j0+d[0]*w0*j1;
388 s = 1.0e0;
389 h2 = h*h;
390 hn = 1.0e0;
391 w = w0;
392 znm1 = z;
393 zn = z2;
394 for ( n = 2; n <= num; n += 2 )
395 {
396 hn = h2*hn;
397 a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0);
398 np1 = n+1;
399 s += hn;
400 a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0);
401 for ( i = n; i <= np1; i++ )
402 {
403 r = -(0.5e0*((double)i+1.0e0));
404 b0[0] = r*a0[0];
405 for ( m = 2; m <= i; m++ )
406 {
407 bsum = 0.0e0;
408 mm1 = m-1;
409 for ( j = 1; j <= mm1; j++ )
410 {
411 mmj = m-j;
412 bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]);
413 }
414 b0[m-1] = r*a0[m-1]+bsum/(double)m;
415 }
416 c[i-1] = b0[i-1]/((double)i+1.0e0);
417 dsum = 0.0e0;
418 im1 = i-1;
419 for ( j = 1; j <= im1; j++ )
420 {
421 imj = i-j;
422 dsum += (d[imj-1]*c[j-1]);
423 }
424 d[i-1] = -(dsum+c[i-1]);
425 }
426 j0 = e1*znm1+((double)n-1.0e0)*j0;
427 j1 = e1*zn+(double)n*j1;
428 znm1 = z2*znm1;
429 zn = z2*zn;
430 w = w0*w;
431 t0 = d[n-1]*w*j0;
432 w = w0*w;
433 t1 = d[np1-1]*w*j1;
434 sum += (t0+t1);
435 if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80;
436 }
437 S80:
438 u = exp(-bcorr(a,b));
439 value = e0*t*u*sum;
440 return value;
441 }
442 //****************************************************************************80
443
beta_frac(double * a,double * b,double * x,double * y,double * lambda,double * eps)444 double beta_frac ( double *a, double *b, double *x, double *y, double *lambda,
445 double *eps )
446
447 //****************************************************************************80
448 //
449 // Purpose:
450 //
451 // BETA_FRAC evaluates a continued fraction expansion for IX(A,B).
452 //
453 // Parameters:
454 //
455 // Input, double *A, *B, the parameters of the function.
456 // A and B should be nonnegative. It is assumed that both A and
457 // B are greater than 1.
458 //
459 // Input, double *X, *Y. X is the argument of the
460 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
461 //
462 // Input, double *LAMBDA, the value of ( A + B ) * Y - B.
463 //
464 // Input, double *EPS, a tolerance.
465 //
466 // Output, double BETA_FRAC, the value of the continued
467 // fraction approximation for IX(A,B).
468 //
469 {
470 static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1;
471
472 bfrac = beta_rcomp ( a, b, x, y );
473
474 if ( bfrac == 0.0e0 )
475 {
476 return bfrac;
477 }
478
479 c = 1.0e0+*lambda;
480 c0 = *b/ *a;
481 c1 = 1.0e0+1.0e0/ *a;
482 yp1 = *y+1.0e0;
483 n = 0.0e0;
484 p = 1.0e0;
485 s = *a+1.0e0;
486 an = 0.0e0;
487 bn = anp1 = 1.0e0;
488 bnp1 = c/c1;
489 r = c1/c;
490 //
491 // CONTINUED FRACTION CALCULATION
492 //
493 S10:
494 n = n + 1.0e0;
495 t = n/ *a;
496 w = n*(*b-n)**x;
497 e = *a/s;
498 alpha = p*(p+c0)*e*e*(w**x);
499 e = (1.0e0+t)/(c1+t+t);
500 beta = n+w/s+e*(c+n*yp1);
501 p = 1.0e0+t;
502 s += 2.0e0;
503 //
504 // UPDATE AN, BN, ANP1, AND BNP1
505 //
506 t = alpha*an+beta*anp1;
507 an = anp1;
508 anp1 = t;
509 t = alpha*bn+beta*bnp1;
510 bn = bnp1;
511 bnp1 = t;
512 r0 = r;
513 r = anp1/bnp1;
514
515 if ( fabs(r-r0) <= (*eps) * r )
516 {
517 goto S20;
518 }
519 //
520 // RESCALE AN, BN, ANP1, AND BNP1
521 //
522 an /= bnp1;
523 bn /= bnp1;
524 anp1 = r;
525 bnp1 = 1.0e0;
526 goto S10;
527 //
528 // TERMINATION
529 //
530 S20:
531 bfrac = bfrac * r;
532 return bfrac;
533 }
534 //****************************************************************************80
535
beta_grat(double * a,double * b,double * x,double * y,double * w,double * eps,int * ierr)536 void beta_grat ( double *a, double *b, double *x, double *y, double *w,
537 double *eps,int *ierr )
538
539 //****************************************************************************80
540 //
541 // Purpose:
542 //
543 // BETA_GRAT evaluates an asymptotic expansion for IX(A,B).
544 //
545 // Parameters:
546 //
547 // Input, double *A, *B, the parameters of the function.
548 // A and B should be nonnegative. It is assumed that 15 <= A
549 // and B <= 1, and that B is less than A.
550 //
551 // Input, double *X, *Y. X is the argument of the
552 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
553 //
554 // Input/output, double *W, a quantity to which the
555 // result of the computation is to be added on output.
556 //
557 // Input, double *EPS, a tolerance.
558 //
559 // Output, int *IERR, an error flag, which is 0 if no error
560 // was detected.
561 //
562 {
563 static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z;
564 static int i,n,nm1;
565 static double c[30],d[30],T1;
566
567 bm1 = *b-0.5e0-0.5e0;
568 nu = *a+0.5e0*bm1;
569 if(*y > 0.375e0) goto S10;
570 T1 = -*y;
571 lnx = alnrel(&T1);
572 goto S20;
573 S10:
574 lnx = log(*x);
575 S20:
576 z = -(nu*lnx);
577 if(*b*z == 0.0e0) goto S70;
578 //
579 // COMPUTATION OF THE EXPANSION
580 // SET R = EXP(-Z)*Z**B/GAMMA(B)
581 //
582 r = *b*(1.0e0+gam1(b))*exp(*b*log(z));
583 r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx));
584 u = algdiv(b,a)+*b*log(nu);
585 u = r*exp(-u);
586 if(u == 0.0e0) goto S70;
587 gamma_rat1 ( b, &z, &r, &p, &q, eps );
588 v = 0.25e0*pow(1.0e0/nu,2.0);
589 t2 = 0.25e0*lnx*lnx;
590 l = *w/u;
591 j = q/r;
592 sum = j;
593 t = cn = 1.0e0;
594 n2 = 0.0e0;
595 for ( n = 1; n <= 30; n++ )
596 {
597 bp2n = *b+n2;
598 j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v;
599 n2 = n2 + 2.0e0;
600 t *= t2;
601 cn /= (n2*(n2+1.0e0));
602 c[n-1] = cn;
603 s = 0.0e0;
604 if(n == 1) goto S40;
605 nm1 = n-1;
606 coef = *b-(double)n;
607 for ( i = 1; i <= nm1; i++ )
608 {
609 s = s + (coef*c[i-1]*d[n-i-1]);
610 coef = coef + *b;
611 }
612 S40:
613 d[n-1] = bm1*cn+s/(double)n;
614 dj = d[n-1]*j;
615 sum = sum + dj;
616 if(sum <= 0.0e0) goto S70;
617 if(fabs(dj) <= *eps*(sum+l)) goto S60;
618 }
619 S60:
620 //
621 // ADD THE RESULTS TO W
622 //
623 *ierr = 0;
624 *w = *w + (u*sum);
625 return;
626 S70:
627 //
628 // THE EXPANSION CANNOT BE COMPUTED
629 //
630 *ierr = 1;
631 return;
632 }
633 //****************************************************************************80
634
beta_inc(double * a,double * b,double * x,double * y,double * w,double * w1,int * ierr)635 void beta_inc ( double *a, double *b, double *x, double *y, double *w,
636 double *w1, int *ierr )
637
638 //****************************************************************************80
639 //
640 // Purpose:
641 //
642 // BETA_INC evaluates the incomplete beta function IX(A,B).
643 //
644 // Author:
645 //
646 // Alfred H Morris, Jr,
647 // Naval Surface Weapons Center,
648 // Dahlgren, Virginia.
649 //
650 // Parameters:
651 //
652 // Input, double *A, *B, the parameters of the function.
653 // A and B should be nonnegative.
654 //
655 // Input, double *X, *Y. X is the argument of the
656 // function, and should satisy 0 <= X <= 1. Y should equal 1 - X.
657 //
658 // Output, double *W, *W1, the values of IX(A,B) and
659 // 1-IX(A,B).
660 //
661 // Output, int *IERR, the error flag.
662 // 0, no error was detected.
663 // 1, A or B is negative;
664 // 2, A = B = 0;
665 // 3, X < 0 or 1 < X;
666 // 4, Y < 0 or 1 < Y;
667 // 5, X + Y /= 1;
668 // 6, X = A = 0;
669 // 7, Y = B = 0.
670 //
671 {
672 static int K1 = 1;
673 static double a0,b0,eps,lambda,t,x0,y0,z;
674 static int ierr1,ind,n;
675 static double T2,T3,T4,T5;
676 //
677 // EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
678 // NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
679 //
680 eps = dpmpar ( &K1 );
681 *w = *w1 = 0.0e0;
682 if(*a < 0.0e0 || *b < 0.0e0) goto S270;
683 if(*a == 0.0e0 && *b == 0.0e0) goto S280;
684 if(*x < 0.0e0 || *x > 1.0e0) goto S290;
685 if(*y < 0.0e0 || *y > 1.0e0) goto S300;
686 z = *x+*y-0.5e0-0.5e0;
687 if(fabs(z) > 3.0e0*eps) goto S310;
688 *ierr = 0;
689 if(*x == 0.0e0) goto S210;
690 if(*y == 0.0e0) goto S230;
691 if(*a == 0.0e0) goto S240;
692 if(*b == 0.0e0) goto S220;
693 eps = fifdmax1(eps,1.e-15);
694 if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260;
695 ind = 0;
696 a0 = *a;
697 b0 = *b;
698 x0 = *x;
699 y0 = *y;
700 if(fifdmin1(a0,b0) > 1.0e0) goto S40;
701 //
702 // PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
703 //
704 if(*x <= 0.5e0) goto S10;
705 ind = 1;
706 a0 = *b;
707 b0 = *a;
708 x0 = *y;
709 y0 = *x;
710 S10:
711 if(b0 < fifdmin1(eps,eps*a0)) goto S90;
712 if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100;
713 if(fifdmax1(a0,b0) > 1.0e0) goto S20;
714 if(a0 >= fifdmin1(0.2e0,b0)) goto S110;
715 if(pow(x0,a0) <= 0.9e0) goto S110;
716 if(x0 >= 0.3e0) goto S120;
717 n = 20;
718 goto S140;
719 S20:
720 if(b0 <= 1.0e0) goto S110;
721 if(x0 >= 0.3e0) goto S120;
722 if(x0 >= 0.1e0) goto S30;
723 if(pow(x0*b0,a0) <= 0.7e0) goto S110;
724 S30:
725 if(b0 > 15.0e0) goto S150;
726 n = 20;
727 goto S140;
728 S40:
729 //
730 // PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
731 //
732 if(*a > *b) goto S50;
733 lambda = *a-(*a+*b)**x;
734 goto S60;
735 S50:
736 lambda = (*a+*b)**y-*b;
737 S60:
738 if(lambda >= 0.0e0) goto S70;
739 ind = 1;
740 a0 = *b;
741 b0 = *a;
742 x0 = *y;
743 y0 = *x;
744 lambda = fabs(lambda);
745 S70:
746 if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110;
747 if(b0 < 40.0e0) goto S160;
748 if(a0 > b0) goto S80;
749 if(a0 <= 100.0e0) goto S130;
750 if(lambda > 0.03e0*a0) goto S130;
751 goto S200;
752 S80:
753 if(b0 <= 100.0e0) goto S130;
754 if(lambda > 0.03e0*b0) goto S130;
755 goto S200;
756 S90:
757 //
758 // EVALUATION OF THE APPROPRIATE ALGORITHM
759 //
760 *w = fpser(&a0,&b0,&x0,&eps);
761 *w1 = 0.5e0+(0.5e0-*w);
762 goto S250;
763 S100:
764 *w1 = apser(&a0,&b0,&x0,&eps);
765 *w = 0.5e0+(0.5e0-*w1);
766 goto S250;
767 S110:
768 *w = beta_pser(&a0,&b0,&x0,&eps);
769 *w1 = 0.5e0+(0.5e0-*w);
770 goto S250;
771 S120:
772 *w1 = beta_pser(&b0,&a0,&y0,&eps);
773 *w = 0.5e0+(0.5e0-*w1);
774 goto S250;
775 S130:
776 T2 = 15.0e0*eps;
777 *w = beta_frac ( &a0,&b0,&x0,&y0,&lambda,&T2 );
778 *w1 = 0.5e0+(0.5e0-*w);
779 goto S250;
780 S140:
781 *w1 = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );
782 b0 = b0 + (double)n;
783 S150:
784 T3 = 15.0e0*eps;
785 beta_grat (&b0,&a0,&y0,&x0,w1,&T3,&ierr1);
786 *w = 0.5e0+(0.5e0-*w1);
787 goto S250;
788 S160:
789 n = ( int ) b0;
790 b0 -= (double)n;
791 if(b0 != 0.0e0) goto S170;
792 n -= 1;
793 b0 = 1.0e0;
794 S170:
795 *w = beta_up ( &b0, &a0, &y0, &x0, &n, &eps );
796 if(x0 > 0.7e0) goto S180;
797 *w = *w + beta_pser(&a0,&b0,&x0,&eps);
798 *w1 = 0.5e0+(0.5e0-*w);
799 goto S250;
800 S180:
801 if(a0 > 15.0e0) goto S190;
802 n = 20;
803 *w = *w + beta_up ( &a0, &b0, &x0, &y0, &n, &eps );
804 a0 = a0 + (double)n;
805 S190:
806 T4 = 15.0e0*eps;
807 beta_grat ( &a0, &b0, &x0, &y0, w, &T4, &ierr1 );
808 *w1 = 0.5e0+(0.5e0-*w);
809 goto S250;
810 S200:
811 T5 = 100.0e0*eps;
812 *w = beta_asym ( &a0, &b0, &lambda, &T5 );
813 *w1 = 0.5e0+(0.5e0-*w);
814 goto S250;
815 S210:
816 //
817 // TERMINATION OF THE PROCEDURE
818 //
819 if(*a == 0.0e0) goto S320;
820 S220:
821 *w = 0.0e0;
822 *w1 = 1.0e0;
823 return;
824 S230:
825 if(*b == 0.0e0) goto S330;
826 S240:
827 *w = 1.0e0;
828 *w1 = 0.0e0;
829 return;
830 S250:
831 if(ind == 0) return;
832 t = *w;
833 *w = *w1;
834 *w1 = t;
835 return;
836 S260:
837 //
838 // PROCEDURE FOR A AND B .LT. 1.E-3*EPS
839 //
840 *w = *b/(*a+*b);
841 *w1 = *a/(*a+*b);
842 return;
843 S270:
844 //
845 // ERROR RETURN
846 //
847 *ierr = 1;
848 return;
849 S280:
850 *ierr = 2;
851 return;
852 S290:
853 *ierr = 3;
854 return;
855 S300:
856 *ierr = 4;
857 return;
858 S310:
859 *ierr = 5;
860 return;
861 S320:
862 *ierr = 6;
863 return;
864 S330:
865 *ierr = 7;
866 return;
867 }
868 //****************************************************************************80
869
beta_inc_values(int * n_data,double * a,double * b,double * x,double * fx)870 void beta_inc_values ( int *n_data, double *a, double *b, double *x,
871 double *fx )
872
873 //****************************************************************************80
874 //
875 // Purpose:
876 //
877 // BETA_INC_VALUES returns some values of the incomplete Beta function.
878 //
879 // Discussion:
880 //
881 // The incomplete Beta function may be written
882 //
883 // BETA_INC(A,B,X) = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT
884 // / Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT
885 //
886 // Thus,
887 //
888 // BETA_INC(A,B,0.0) = 0.0
889 // BETA_INC(A,B,1.0) = 1.0
890 //
891 // Note that in Mathematica, the expressions:
892 //
893 // BETA[A,B] = Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT
894 // BETA[X,A,B] = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT
895 //
896 // and thus, to evaluate the incomplete Beta function requires:
897 //
898 // BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B]
899 //
900 // Modified:
901 //
902 // 09 June 2004
903 //
904 // Author:
905 //
906 // John Burkardt
907 //
908 // Reference:
909 //
910 // Milton Abramowitz and Irene Stegun,
911 // Handbook of Mathematical Functions,
912 // US Department of Commerce, 1964.
913 //
914 // Karl Pearson,
915 // Tables of the Incomplete Beta Function,
916 // Cambridge University Press, 1968.
917 //
918 // Parameters:
919 //
920 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
921 // first call. On each call, the routine increments N_DATA by 1, and
922 // returns the corresponding data; when there is no more data, the
923 // output value of N_DATA will be 0 again.
924 //
925 // Output, double *A, *B, the parameters of the function.
926 //
927 // Output, double *X, the argument of the function.
928 //
929 // Output, double *FX, the value of the function.
930 //
931 {
932 # define N_MAX 30
933
934 double a_vec[N_MAX] = {
935 0.5E+00, 0.5E+00, 0.5E+00, 1.0E+00,
936 1.0E+00, 1.0E+00, 1.0E+00, 1.0E+00,
937 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
938 2.0E+00, 2.0E+00, 2.0E+00, 2.0E+00,
939 2.0E+00, 5.5E+00, 10.0E+00, 10.0E+00,
940 10.0E+00, 10.0E+00, 20.0E+00, 20.0E+00,
941 20.0E+00, 20.0E+00, 20.0E+00, 30.0E+00,
942 30.0E+00, 40.0E+00 };
943 double b_vec[N_MAX] = {
944 0.5E+00, 0.5E+00, 0.5E+00, 0.5E+00,
945 0.5E+00, 0.5E+00, 0.5E+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.0E+00, 0.5E+00, 5.0E+00,
949 5.0E+00, 10.0E+00, 5.0E+00, 10.0E+00,
950 10.0E+00, 20.0E+00, 20.0E+00, 10.0E+00,
951 10.0E+00, 20.0E+00 };
952 double fx_vec[N_MAX] = {
953 0.0637686E+00, 0.2048328E+00, 1.0000000E+00, 0.0E+00,
954 0.0050126E+00, 0.0513167E+00, 0.2928932E+00, 0.5000000E+00,
955 0.028E+00, 0.104E+00, 0.216E+00, 0.352E+00,
956 0.500E+00, 0.648E+00, 0.784E+00, 0.896E+00,
957 0.972E+00, 0.4361909E+00, 0.1516409E+00, 0.0897827E+00,
958 1.0000000E+00, 0.5000000E+00, 0.4598773E+00, 0.2146816E+00,
959 0.9507365E+00, 0.5000000E+00, 0.8979414E+00, 0.2241297E+00,
960 0.7586405E+00, 0.7001783E+00 };
961 double x_vec[N_MAX] = {
962 0.01E+00, 0.10E+00, 1.00E+00, 0.0E+00,
963 0.01E+00, 0.10E+00, 0.50E+00, 0.50E+00,
964 0.1E+00, 0.2E+00, 0.3E+00, 0.4E+00,
965 0.5E+00, 0.6E+00, 0.7E+00, 0.8E+00,
966 0.9E+00, 0.50E+00, 0.90E+00, 0.50E+00,
967 1.00E+00, 0.50E+00, 0.80E+00, 0.60E+00,
968 0.80E+00, 0.50E+00, 0.60E+00, 0.70E+00,
969 0.80E+00, 0.70E+00 };
970
971 if ( *n_data < 0 )
972 {
973 *n_data = 0;
974 }
975
976 *n_data = *n_data + 1;
977
978 if ( N_MAX < *n_data )
979 {
980 *n_data = 0;
981 *a = 0.0E+00;
982 *b = 0.0E+00;
983 *x = 0.0E+00;
984 *fx = 0.0E+00;
985 }
986 else
987 {
988 *a = a_vec[*n_data-1];
989 *b = b_vec[*n_data-1];
990 *x = x_vec[*n_data-1];
991 *fx = fx_vec[*n_data-1];
992 }
993 return;
994 # undef N_MAX
995 }
996 //****************************************************************************80
997
beta_log(double * a0,double * b0)998 double beta_log ( double *a0, double *b0 )
999
1000 //****************************************************************************80
1001 //
1002 // Purpose:
1003 //
1004 // BETA_LOG evaluates the logarithm of the beta function.
1005 //
1006 // Reference:
1007 //
1008 // Armido DiDinato and Alfred Morris,
1009 // Algorithm 708:
1010 // Significant Digit Computation of the Incomplete Beta Function Ratios,
1011 // ACM Transactions on Mathematical Software,
1012 // Volume 18, 1993, pages 360-373.
1013 //
1014 // Parameters:
1015 //
1016 // Input, double *A0, *B0, the parameters of the function.
1017 // A0 and B0 should be nonnegative.
1018 //
1019 // Output, double *BETA_LOG, the value of the logarithm
1020 // of the Beta function.
1021 //
1022 {
1023 static double e = .918938533204673e0;
1024 static double value,a,b,c,h,u,v,w,z;
1025 static int i,n;
1026 static double T1;
1027
1028 a = fifdmin1(*a0,*b0);
1029 b = fifdmax1(*a0,*b0);
1030 if(a >= 8.0e0) goto S100;
1031 if(a >= 1.0e0) goto S20;
1032 //
1033 // PROCEDURE WHEN A .LT. 1
1034 //
1035 if(b >= 8.0e0) goto S10;
1036 T1 = a+b;
1037 value = gamma_log ( &a )+( gamma_log ( &b )- gamma_log ( &T1 ));
1038 return value;
1039 S10:
1040 value = gamma_log ( &a )+algdiv(&a,&b);
1041 return value;
1042 S20:
1043 //
1044 // PROCEDURE WHEN 1 .LE. A .LT. 8
1045 //
1046 if(a > 2.0e0) goto S40;
1047 if(b > 2.0e0) goto S30;
1048 value = gamma_log ( &a )+ gamma_log ( &b )-gsumln(&a,&b);
1049 return value;
1050 S30:
1051 w = 0.0e0;
1052 if(b < 8.0e0) goto S60;
1053 value = gamma_log ( &a )+algdiv(&a,&b);
1054 return value;
1055 S40:
1056 //
1057 // REDUCTION OF A WHEN B .LE. 1000
1058 //
1059 if(b > 1000.0e0) goto S80;
1060 n = ( int ) ( a - 1.0e0 );
1061 w = 1.0e0;
1062 for ( i = 1; i <= n; i++ )
1063 {
1064 a -= 1.0e0;
1065 h = a/b;
1066 w *= (h/(1.0e0+h));
1067 }
1068 w = log(w);
1069 if(b < 8.0e0) goto S60;
1070 value = w+ gamma_log ( &a )+algdiv(&a,&b);
1071 return value;
1072 S60:
1073 //
1074 // REDUCTION OF B WHEN B .LT. 8
1075 //
1076 n = ( int ) ( b - 1.0e0 );
1077 z = 1.0e0;
1078 for ( i = 1; i <= n; i++ )
1079 {
1080 b -= 1.0e0;
1081 z *= (b/(a+b));
1082 }
1083 value = w+log(z)+( gamma_log ( &a )+( gamma_log ( &b )-gsumln(&a,&b)));
1084 return value;
1085 S80:
1086 //
1087 // REDUCTION OF A WHEN B .GT. 1000
1088 //
1089 n = ( int ) ( a - 1.0e0 );
1090 w = 1.0e0;
1091 for ( i = 1; i <= n; i++ )
1092 {
1093 a -= 1.0e0;
1094 w *= (a/(1.0e0+a/b));
1095 }
1096 value = log(w)-(double)n*log(b)+( gamma_log ( &a )+algdiv(&a,&b));
1097 return value;
1098 S100:
1099 //
1100 // PROCEDURE WHEN A .GE. 8
1101 //
1102 w = bcorr(&a,&b);
1103 h = a/b;
1104 c = h/(1.0e0+h);
1105 u = -((a-0.5e0)*log(c));
1106 v = b*alnrel(&h);
1107 if(u <= v) goto S110;
1108 value = -(0.5e0*log(b))+e+w-v-u;
1109 return value;
1110 S110:
1111 value = -(0.5e0*log(b))+e+w-u-v;
1112 return value;
1113 }
1114 //****************************************************************************80
1115
beta_pser(double * a,double * b,double * x,double * eps)1116 double beta_pser ( double *a, double *b, double *x, double *eps )
1117
1118 //****************************************************************************80
1119 //
1120 // Purpose:
1121 //
1122 // BETA_PSER uses a power series expansion to evaluate IX(A,B)(X).
1123 //
1124 // Discussion:
1125 //
1126 // BETA_PSER is used when B <= 1 or B*X <= 0.7.
1127 //
1128 // Parameters:
1129 //
1130 // Input, double *A, *B, the parameters.
1131 //
1132 // Input, double *X, the point where the function
1133 // is to be evaluated.
1134 //
1135 // Input, double *EPS, the tolerance.
1136 //
1137 // Output, double BETA_PSER, the approximate value of IX(A,B)(X).
1138 //
1139 {
1140 static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z;
1141 static int i,m;
1142
1143 bpser = 0.0e0;
1144 if(*x == 0.0e0) return bpser;
1145 //
1146 // COMPUTE THE FACTOR X**A/(A*BETA(A,B))
1147 //
1148 a0 = fifdmin1(*a,*b);
1149 if(a0 < 1.0e0) goto S10;
1150 z = *a*log(*x)-beta_log(a,b);
1151 bpser = exp(z)/ *a;
1152 goto S100;
1153 S10:
1154 b0 = fifdmax1(*a,*b);
1155 if(b0 >= 8.0e0) goto S90;
1156 if(b0 > 1.0e0) goto S40;
1157 //
1158 // PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
1159 //
1160 bpser = pow(*x,*a);
1161 if(bpser == 0.0e0) return bpser;
1162 apb = *a+*b;
1163 if(apb > 1.0e0) goto S20;
1164 z = 1.0e0+gam1(&apb);
1165 goto S30;
1166 S20:
1167 u = *a+*b-1.e0;
1168 z = (1.0e0+gam1(&u))/apb;
1169 S30:
1170 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1171 bpser *= (c*(*b/apb));
1172 goto S100;
1173 S40:
1174 //
1175 // PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
1176 //
1177 u = gamma_ln1 ( &a0 );
1178 m = ( int ) ( b0 - 1.0e0 );
1179 if(m < 1) goto S60;
1180 c = 1.0e0;
1181 for ( i = 1; i <= m; i++ )
1182 {
1183 b0 -= 1.0e0;
1184 c *= (b0/(a0+b0));
1185 }
1186 u = log(c)+u;
1187 S60:
1188 z = *a*log(*x)-u;
1189 b0 -= 1.0e0;
1190 apb = a0+b0;
1191 if(apb > 1.0e0) goto S70;
1192 t = 1.0e0+gam1(&apb);
1193 goto S80;
1194 S70:
1195 u = a0+b0-1.e0;
1196 t = (1.0e0+gam1(&u))/apb;
1197 S80:
1198 bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t;
1199 goto S100;
1200 S90:
1201 //
1202 // PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
1203 //
1204 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1205 z = *a*log(*x)-u;
1206 bpser = a0/ *a*exp(z);
1207 S100:
1208 if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser;
1209 //
1210 // COMPUTE THE SERIES
1211 //
1212 sum = n = 0.0e0;
1213 c = 1.0e0;
1214 tol = *eps/ *a;
1215 S110:
1216 n = n + 1.0e0;
1217 c *= ((0.5e0+(0.5e0-*b/n))**x);
1218 w = c/(*a+n);
1219 sum = sum + w;
1220 if(fabs(w) > tol) goto S110;
1221 bpser *= (1.0e0+*a*sum);
1222 return bpser;
1223 }
1224 //****************************************************************************80
1225
beta_rcomp(double * a,double * b,double * x,double * y)1226 double beta_rcomp ( double *a, double *b, double *x, double *y )
1227
1228 //****************************************************************************80
1229 //
1230 // Purpose:
1231 //
1232 // BETA_RCOMP evaluates X**A * Y**B / Beta(A,B).
1233 //
1234 // Parameters:
1235 //
1236 // Input, double *A, *B, the parameters of the Beta function.
1237 // A and B should be nonnegative.
1238 //
1239 // Input, double *X, *Y, define the numerator of the fraction.
1240 //
1241 // Output, double BETA_RCOMP, the value of X**A * Y**B / Beta(A,B).
1242 //
1243 {
1244 static double Const = .398942280401433e0;
1245 static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1246 static int i,n;
1247 //
1248 // CONST = 1/SQRT(2*PI)
1249 //
1250 static double T1,T2;
1251
1252 brcomp = 0.0e0;
1253 if(*x == 0.0e0 || *y == 0.0e0) return brcomp;
1254 a0 = fifdmin1(*a,*b);
1255 if(a0 >= 8.0e0) goto S130;
1256 if(*x > 0.375e0) goto S10;
1257 lnx = log(*x);
1258 T1 = -*x;
1259 lny = alnrel(&T1);
1260 goto S30;
1261 S10:
1262 if(*y > 0.375e0) goto S20;
1263 T2 = -*y;
1264 lnx = alnrel(&T2);
1265 lny = log(*y);
1266 goto S30;
1267 S20:
1268 lnx = log(*x);
1269 lny = log(*y);
1270 S30:
1271 z = *a*lnx+*b*lny;
1272 if(a0 < 1.0e0) goto S40;
1273 z -= beta_log(a,b);
1274 brcomp = exp(z);
1275 return brcomp;
1276 S40:
1277 //
1278 // PROCEDURE FOR A .LT. 1 OR B .LT. 1
1279 //
1280 b0 = fifdmax1(*a,*b);
1281 if(b0 >= 8.0e0) goto S120;
1282 if(b0 > 1.0e0) goto S70;
1283 //
1284 // ALGORITHM FOR B0 .LE. 1
1285 //
1286 brcomp = exp(z);
1287 if(brcomp == 0.0e0) return brcomp;
1288 apb = *a+*b;
1289 if(apb > 1.0e0) goto S50;
1290 z = 1.0e0+gam1(&apb);
1291 goto S60;
1292 S50:
1293 u = *a+*b-1.e0;
1294 z = (1.0e0+gam1(&u))/apb;
1295 S60:
1296 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1297 brcomp = brcomp*(a0*c)/(1.0e0+a0/b0);
1298 return brcomp;
1299 S70:
1300 //
1301 // ALGORITHM FOR 1 .LT. B0 .LT. 8
1302 //
1303 u = gamma_ln1 ( &a0 );
1304 n = ( int ) ( b0 - 1.0e0 );
1305 if(n < 1) goto S90;
1306 c = 1.0e0;
1307 for ( i = 1; i <= n; i++ )
1308 {
1309 b0 -= 1.0e0;
1310 c *= (b0/(a0+b0));
1311 }
1312 u = log(c)+u;
1313 S90:
1314 z -= u;
1315 b0 -= 1.0e0;
1316 apb = a0+b0;
1317 if(apb > 1.0e0) goto S100;
1318 t = 1.0e0+gam1(&apb);
1319 goto S110;
1320 S100:
1321 u = a0+b0-1.e0;
1322 t = (1.0e0+gam1(&u))/apb;
1323 S110:
1324 brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t;
1325 return brcomp;
1326 S120:
1327 //
1328 // ALGORITHM FOR B0 .GE. 8
1329 //
1330 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1331 brcomp = a0*exp(z-u);
1332 return brcomp;
1333 S130:
1334 //
1335 // PROCEDURE FOR A .GE. 8 AND B .GE. 8
1336 //
1337 if(*a > *b) goto S140;
1338 h = *a/ *b;
1339 x0 = h/(1.0e0+h);
1340 y0 = 1.0e0/(1.0e0+h);
1341 lambda = *a-(*a+*b)**x;
1342 goto S150;
1343 S140:
1344 h = *b/ *a;
1345 x0 = 1.0e0/(1.0e0+h);
1346 y0 = h/(1.0e0+h);
1347 lambda = (*a+*b)**y-*b;
1348 S150:
1349 e = -(lambda/ *a);
1350 if(fabs(e) > 0.6e0) goto S160;
1351 u = rlog1(&e);
1352 goto S170;
1353 S160:
1354 u = e-log(*x/x0);
1355 S170:
1356 e = lambda/ *b;
1357 if(fabs(e) > 0.6e0) goto S180;
1358 v = rlog1(&e);
1359 goto S190;
1360 S180:
1361 v = e-log(*y/y0);
1362 S190:
1363 z = exp(-(*a*u+*b*v));
1364 brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1365 return brcomp;
1366 }
1367 //****************************************************************************80
1368
beta_rcomp1(int * mu,double * a,double * b,double * x,double * y)1369 double beta_rcomp1 ( int *mu, double *a, double *b, double *x, double *y )
1370
1371 //****************************************************************************80
1372 //
1373 // Purpose:
1374 //
1375 // BETA_RCOMP1 evaluates exp(MU) * X**A * Y**B / Beta(A,B).
1376 //
1377 // Parameters:
1378 //
1379 // Input, int MU, ?
1380 //
1381 // Input, double A, B, the parameters of the Beta function.
1382 // A and B should be nonnegative.
1383 //
1384 // Input, double X, Y, ?
1385 //
1386 // Output, double BETA_RCOMP1, the value of
1387 // exp(MU) * X**A * Y**B / Beta(A,B).
1388 //
1389 {
1390 static double Const = .398942280401433e0;
1391 static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1392 static int i,n;
1393 //
1394 // CONST = 1/SQRT(2*PI)
1395 //
1396 static double T1,T2,T3,T4;
1397
1398 a0 = fifdmin1(*a,*b);
1399 if(a0 >= 8.0e0) goto S130;
1400 if(*x > 0.375e0) goto S10;
1401 lnx = log(*x);
1402 T1 = -*x;
1403 lny = alnrel(&T1);
1404 goto S30;
1405 S10:
1406 if(*y > 0.375e0) goto S20;
1407 T2 = -*y;
1408 lnx = alnrel(&T2);
1409 lny = log(*y);
1410 goto S30;
1411 S20:
1412 lnx = log(*x);
1413 lny = log(*y);
1414 S30:
1415 z = *a*lnx+*b*lny;
1416 if(a0 < 1.0e0) goto S40;
1417 z -= beta_log(a,b);
1418 brcmp1 = esum(mu,&z);
1419 return brcmp1;
1420 S40:
1421 //
1422 // PROCEDURE FOR A .LT. 1 OR B .LT. 1
1423 //
1424 b0 = fifdmax1(*a,*b);
1425 if(b0 >= 8.0e0) goto S120;
1426 if(b0 > 1.0e0) goto S70;
1427 //
1428 // ALGORITHM FOR B0 .LE. 1
1429 //
1430 brcmp1 = esum(mu,&z);
1431 if(brcmp1 == 0.0e0) return brcmp1;
1432 apb = *a+*b;
1433 if(apb > 1.0e0) goto S50;
1434 z = 1.0e0+gam1(&apb);
1435 goto S60;
1436 S50:
1437 u = *a+*b-1.e0;
1438 z = (1.0e0+gam1(&u))/apb;
1439 S60:
1440 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1441 brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0);
1442 return brcmp1;
1443 S70:
1444 //
1445 // ALGORITHM FOR 1 .LT. B0 .LT. 8
1446 //
1447 u = gamma_ln1 ( &a0 );
1448 n = ( int ) ( b0 - 1.0e0 );
1449 if(n < 1) goto S90;
1450 c = 1.0e0;
1451 for ( i = 1; i <= n; i++ )
1452 {
1453 b0 -= 1.0e0;
1454 c *= (b0/(a0+b0));
1455 }
1456 u = log(c)+u;
1457 S90:
1458 z -= u;
1459 b0 -= 1.0e0;
1460 apb = a0+b0;
1461 if(apb > 1.0e0) goto S100;
1462 t = 1.0e0+gam1(&apb);
1463 goto S110;
1464 S100:
1465 u = a0+b0-1.e0;
1466 t = (1.0e0+gam1(&u))/apb;
1467 S110:
1468 brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t;
1469 return brcmp1;
1470 S120:
1471 //
1472 // ALGORITHM FOR B0 .GE. 8
1473 //
1474 u = gamma_ln1 ( &a0 ) + algdiv ( &a0, &b0 );
1475 T3 = z-u;
1476 brcmp1 = a0*esum(mu,&T3);
1477 return brcmp1;
1478 S130:
1479 //
1480 // PROCEDURE FOR A .GE. 8 AND B .GE. 8
1481 //
1482 if(*a > *b) goto S140;
1483 h = *a/ *b;
1484 x0 = h/(1.0e0+h);
1485 y0 = 1.0e0/(1.0e0+h);
1486 lambda = *a-(*a+*b)**x;
1487 goto S150;
1488 S140:
1489 h = *b/ *a;
1490 x0 = 1.0e0/(1.0e0+h);
1491 y0 = h/(1.0e0+h);
1492 lambda = (*a+*b)**y-*b;
1493 S150:
1494 e = -(lambda/ *a);
1495 if(fabs(e) > 0.6e0) goto S160;
1496 u = rlog1(&e);
1497 goto S170;
1498 S160:
1499 u = e-log(*x/x0);
1500 S170:
1501 e = lambda/ *b;
1502 if(fabs(e) > 0.6e0) goto S180;
1503 v = rlog1(&e);
1504 goto S190;
1505 S180:
1506 v = e-log(*y/y0);
1507 S190:
1508 T4 = -(*a*u+*b*v);
1509 z = esum(mu,&T4);
1510 brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1511 return brcmp1;
1512 }
1513 //****************************************************************************80
1514
beta_up(double * a,double * b,double * x,double * y,int * n,double * eps)1515 double beta_up ( double *a, double *b, double *x, double *y, int *n,
1516 double *eps )
1517
1518 //****************************************************************************80
1519 //
1520 // Purpose:
1521 //
1522 // BETA_UP evaluates IX(A,B) - IX(A+N,B) where N is a positive integer.
1523 //
1524 // Parameters:
1525 //
1526 // Input, double *A, *B, the parameters of the function.
1527 // A and B should be nonnegative.
1528 //
1529 // Input, double *X, *Y, ?
1530 //
1531 // Input, int *N, ?
1532 //
1533 // Input, double *EPS, the tolerance.
1534 //
1535 // Output, double BETA_UP, the value of IX(A,B) - IX(A+N,B).
1536 //
1537 {
1538 static int K1 = 1;
1539 static int K2 = 0;
1540 static double bup,ap1,apb,d,l,r,t,w;
1541 static int i,k,kp1,mu,nm1;
1542 //
1543 // OBTAIN THE SCALING FACTOR EXP(-MU) AND
1544 // EXP(MU)*(X**A*Y**B/BETA(A,B))/A
1545 //
1546 apb = *a+*b;
1547 ap1 = *a+1.0e0;
1548 mu = 0;
1549 d = 1.0e0;
1550 if(*n == 1 || *a < 1.0e0) goto S10;
1551 if(apb < 1.1e0*ap1) goto S10;
1552 mu = ( int ) fabs ( exparg(&K1) );
1553 k = ( int ) exparg ( &K2 );
1554 if(k < mu) mu = k;
1555 t = mu;
1556 d = exp(-t);
1557 S10:
1558 bup = beta_rcomp1 ( &mu, a, b, x, y ) / *a;
1559 if(*n == 1 || bup == 0.0e0) return bup;
1560 nm1 = *n-1;
1561 w = d;
1562 //
1563 // LET K BE THE INDEX OF THE MAXIMUM TERM
1564 //
1565 k = 0;
1566 if(*b <= 1.0e0) goto S50;
1567 if(*y > 1.e-4) goto S20;
1568 k = nm1;
1569 goto S30;
1570 S20:
1571 r = (*b-1.0e0)**x/ *y-*a;
1572 if(r < 1.0e0) goto S50;
1573 t = ( double ) nm1;
1574 k = nm1;
1575 if ( r < t ) k = ( int ) r;
1576 S30:
1577 //
1578 // ADD THE INCREASING TERMS OF THE SERIES
1579 //
1580 for ( i = 1; i <= k; i++ )
1581 {
1582 l = i-1;
1583 d = (apb+l)/(ap1+l)**x*d;
1584 w = w + d;
1585 }
1586 if(k == nm1) goto S70;
1587 S50:
1588 //
1589 // ADD THE REMAINING TERMS OF THE SERIES
1590 //
1591 kp1 = k+1;
1592 for ( i = kp1; i <= nm1; i++ )
1593 {
1594 l = i-1;
1595 d = (apb+l)/(ap1+l)**x*d;
1596 w = w + d;
1597 if(d <= *eps*w) goto S70;
1598 }
1599 S70:
1600 //
1601 // TERMINATE THE PROCEDURE
1602 //
1603 bup *= w;
1604 return bup;
1605 }
1606 //****************************************************************************80
1607
binomial_cdf_values(int * n_data,int * a,double * b,int * x,double * fx)1608 void binomial_cdf_values ( int *n_data, int *a, double *b, int *x, double *fx )
1609
1610 //****************************************************************************80
1611 //
1612 // Purpose:
1613 //
1614 // BINOMIAL_CDF_VALUES returns some values of the binomial CDF.
1615 //
1616 // Discussion:
1617 //
1618 // CDF(X)(A,B) is the probability of at most X successes in A trials,
1619 // given that the probability of success on a single trial is B.
1620 //
1621 // Modified:
1622 //
1623 // 31 May 2004
1624 //
1625 // Author:
1626 //
1627 // John Burkardt
1628 //
1629 // Reference:
1630 //
1631 // Milton Abramowitz and Irene Stegun,
1632 // Handbook of Mathematical Functions,
1633 // US Department of Commerce, 1964.
1634 //
1635 // Daniel Zwillinger,
1636 // CRC Standard Mathematical Tables and Formulae,
1637 // 30th Edition, CRC Press, 1996, pages 651-652.
1638 //
1639 // Parameters:
1640 //
1641 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
1642 // first call. On each call, the routine increments N_DATA by 1, and
1643 // returns the corresponding data; when there is no more data, the
1644 // output value of N_DATA will be 0 again.
1645 //
1646 // Output, int *A, double *B, the parameters of the function.
1647 //
1648 // Output, int *X, the argument of the function.
1649 //
1650 // Output, double *FX, the value of the function.
1651 //
1652 {
1653 # define N_MAX 17
1654
1655 int a_vec[N_MAX] = {
1656 2, 2, 2, 2,
1657 2, 4, 4, 4,
1658 4, 10, 10, 10,
1659 10, 10, 10, 10,
1660 10 };
1661 double b_vec[N_MAX] = {
1662 0.05E+00, 0.05E+00, 0.05E+00, 0.50E+00,
1663 0.50E+00, 0.25E+00, 0.25E+00, 0.25E+00,
1664 0.25E+00, 0.05E+00, 0.10E+00, 0.15E+00,
1665 0.20E+00, 0.25E+00, 0.30E+00, 0.40E+00,
1666 0.50E+00 };
1667 double fx_vec[N_MAX] = {
1668 0.9025E+00, 0.9975E+00, 1.0000E+00, 0.2500E+00,
1669 0.7500E+00, 0.3164E+00, 0.7383E+00, 0.9492E+00,
1670 0.9961E+00, 0.9999E+00, 0.9984E+00, 0.9901E+00,
1671 0.9672E+00, 0.9219E+00, 0.8497E+00, 0.6331E+00,
1672 0.3770E+00 };
1673 int x_vec[N_MAX] = {
1674 0, 1, 2, 0,
1675 1, 0, 1, 2,
1676 3, 4, 4, 4,
1677 4, 4, 4, 4,
1678 4 };
1679
1680 if ( *n_data < 0 )
1681 {
1682 *n_data = 0;
1683 }
1684
1685 *n_data = *n_data + 1;
1686
1687 if ( N_MAX < *n_data )
1688 {
1689 *n_data = 0;
1690 *a = 0;
1691 *b = 0.0E+00;
1692 *x = 0;
1693 *fx = 0.0E+00;
1694 }
1695 else
1696 {
1697 *a = a_vec[*n_data-1];
1698 *b = b_vec[*n_data-1];
1699 *x = x_vec[*n_data-1];
1700 *fx = fx_vec[*n_data-1];
1701 }
1702 return;
1703 # undef N_MAX
1704 }
1705 //****************************************************************************80
1706
cdfbet(int * which,double * p,double * q,double * x,double * y,double * a,double * b,int * status,double * bound)1707 void cdfbet ( int *which, double *p, double *q, double *x, double *y,
1708 double *a, double *b, int *status, double *bound )
1709
1710 //****************************************************************************80
1711 //
1712 // Purpose:
1713 //
1714 // CDFBET evaluates the CDF of the Beta Distribution.
1715 //
1716 // Discussion:
1717 //
1718 // This routine calculates any one parameter of the beta distribution
1719 // given the others.
1720 //
1721 // The value P of the cumulative distribution function is calculated
1722 // directly by code associated with the reference.
1723 //
1724 // Computation of the other parameters involves a seach for a value that
1725 // produces the desired value of P. The search relies on the
1726 // monotonicity of P with respect to the other parameters.
1727 //
1728 // The beta density is proportional to t^(A-1) * (1-t)^(B-1).
1729 //
1730 // Modified:
1731 //
1732 // 09 June 2004
1733 //
1734 // Reference:
1735 //
1736 // Armido DiDinato and Alfred Morris,
1737 // Algorithm 708:
1738 // Significant Digit Computation of the Incomplete Beta Function Ratios,
1739 // ACM Transactions on Mathematical Software,
1740 // Volume 18, 1993, pages 360-373.
1741 //
1742 // Parameters:
1743 //
1744 // Input, int *WHICH, indicates which of the next four argument
1745 // values is to be calculated from the others.
1746 // 1: Calculate P and Q from X, Y, A and B;
1747 // 2: Calculate X and Y from P, Q, A and B;
1748 // 3: Calculate A from P, Q, X, Y and B;
1749 // 4: Calculate B from P, Q, X, Y and A.
1750 //
1751 // Input/output, double *P, the integral from 0 to X of the
1752 // chi-square distribution. Input range: [0, 1].
1753 //
1754 // Input/output, double *Q, equals 1-P. Input range: [0, 1].
1755 //
1756 // Input/output, double *X, the upper limit of integration
1757 // of the beta density. If it is an input value, it should lie in
1758 // the range [0,1]. If it is an output value, it will be searched for
1759 // in the range [0,1].
1760 //
1761 // Input/output, double *Y, equal to 1-X. If it is an input
1762 // value, it should lie in the range [0,1]. If it is an output value,
1763 // it will be searched for in the range [0,1].
1764 //
1765 // Input/output, double *A, the first parameter of the beta
1766 // density. If it is an input value, it should lie in the range
1767 // (0, +infinity). If it is an output value, it will be searched
1768 // for in the range [1D-300,1D300].
1769 //
1770 // Input/output, double *B, the second parameter of the beta
1771 // density. If it is an input value, it should lie in the range
1772 // (0, +infinity). If it is an output value, it will be searched
1773 // for in the range [1D-300,1D300].
1774 //
1775 // Output, int *STATUS, reports the status of the computation.
1776 // 0, if the calculation completed correctly;
1777 // -I, if the input parameter number I is out of range;
1778 // +1, if the answer appears to be lower than lowest search bound;
1779 // +2, if the answer appears to be higher than greatest search bound;
1780 // +3, if P + Q /= 1;
1781 // +4, if X + Y /= 1.
1782 //
1783 // Output, double *BOUND, is only defined if STATUS is nonzero.
1784 // If STATUS is negative, then this is the value exceeded by parameter I.
1785 // if STATUS is 1 or 2, this is the search bound that was exceeded.
1786 //
1787 {
1788 # define tol (1.0e-8)
1789 # define atol (1.0e-50)
1790 # define zero (1.0e-300)
1791 # define inf 1.0e300
1792 # define one 1.0e0
1793
1794 static int K1 = 1;
1795 static double K2 = 0.0e0;
1796 static double K3 = 1.0e0;
1797 static double K8 = 0.5e0;
1798 static double K9 = 5.0e0;
1799 static double fx,xhi,xlo,cum,ccum,xy,pq;
1800 static unsigned long qhi,qleft,qporq;
1801 static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15;
1802
1803 *status = 0;
1804 *bound = 0.0;
1805 //
1806 // Check arguments
1807 //
1808 if(!(*which < 1 || *which > 4)) goto S30;
1809 if(!(*which < 1)) goto S10;
1810 *bound = 1.0e0;
1811 goto S20;
1812 S10:
1813 *bound = 4.0e0;
1814 S20:
1815 *status = -1;
1816 return;
1817 S30:
1818 if(*which == 1) goto S70;
1819 //
1820 // P
1821 //
1822 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
1823 if(!(*p < 0.0e0)) goto S40;
1824 *bound = 0.0e0;
1825 goto S50;
1826 S40:
1827 *bound = 1.0e0;
1828 S50:
1829 *status = -2;
1830 return;
1831 S70:
1832 S60:
1833 if(*which == 1) goto S110;
1834 //
1835 // Q
1836 //
1837 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
1838 if(!(*q < 0.0e0)) goto S80;
1839 *bound = 0.0e0;
1840 goto S90;
1841 S80:
1842 *bound = 1.0e0;
1843 S90:
1844 *status = -3;
1845 return;
1846 S110:
1847 S100:
1848 if(*which == 2) goto S150;
1849 //
1850 // X
1851 //
1852 if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140;
1853 if(!(*x < 0.0e0)) goto S120;
1854 *bound = 0.0e0;
1855 goto S130;
1856 S120:
1857 *bound = 1.0e0;
1858 S130:
1859 *status = -4;
1860 return;
1861 S150:
1862 S140:
1863 if(*which == 2) goto S190;
1864 //
1865 // Y
1866 //
1867 if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180;
1868 if(!(*y < 0.0e0)) goto S160;
1869 *bound = 0.0e0;
1870 goto S170;
1871 S160:
1872 *bound = 1.0e0;
1873 S170:
1874 *status = -5;
1875 return;
1876 S190:
1877 S180:
1878 if(*which == 3) goto S210;
1879 //
1880 // A
1881 //
1882 if(!(*a <= 0.0e0)) goto S200;
1883 *bound = 0.0e0;
1884 *status = -6;
1885 return;
1886 S210:
1887 S200:
1888 if(*which == 4) goto S230;
1889 //
1890 // B
1891 //
1892 if(!(*b <= 0.0e0)) goto S220;
1893 *bound = 0.0e0;
1894 *status = -7;
1895 return;
1896 S230:
1897 S220:
1898 if(*which == 1) goto S270;
1899 //
1900 // P + Q
1901 //
1902 pq = *p+*q;
1903 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S260;
1904 if(!(pq < 0.0e0)) goto S240;
1905 *bound = 0.0e0;
1906 goto S250;
1907 S240:
1908 *bound = 1.0e0;
1909 S250:
1910 *status = 3;
1911 return;
1912 S270:
1913 S260:
1914 if(*which == 2) goto S310;
1915 //
1916 // X + Y
1917 //
1918 xy = *x+*y;
1919 if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S300;
1920 if(!(xy < 0.0e0)) goto S280;
1921 *bound = 0.0e0;
1922 goto S290;
1923 S280:
1924 *bound = 1.0e0;
1925 S290:
1926 *status = 4;
1927 return;
1928 S310:
1929 S300:
1930 if(!(*which == 1)) qporq = *p <= *q;
1931 //
1932 // Select the minimum of P or Q
1933 // Calculate ANSWERS
1934 //
1935 if(1 == *which) {
1936 //
1937 // Calculating P and Q
1938 //
1939 cumbet(x,y,a,b,p,q);
1940 *status = 0;
1941 }
1942 else if(2 == *which) {
1943 //
1944 // Calculating X and Y
1945 //
1946 T4 = atol;
1947 T5 = tol;
1948 dstzr(&K2,&K3,&T4,&T5);
1949 if(!qporq) goto S340;
1950 *status = 0;
1951 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1952 *y = one-*x;
1953 S320:
1954 if(!(*status == 1)) goto S330;
1955 cumbet(x,y,a,b,&cum,&ccum);
1956 fx = cum-*p;
1957 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1958 *y = one-*x;
1959 goto S320;
1960 S330:
1961 goto S370;
1962 S340:
1963 *status = 0;
1964 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1965 *x = one-*y;
1966 S350:
1967 if(!(*status == 1)) goto S360;
1968 cumbet(x,y,a,b,&cum,&ccum);
1969 fx = ccum-*q;
1970 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1971 *x = one-*y;
1972 goto S350;
1973 S370:
1974 S360:
1975 if(!(*status == -1)) goto S400;
1976 if(!qleft) goto S380;
1977 *status = 1;
1978 *bound = 0.0e0;
1979 goto S390;
1980 S380:
1981 *status = 2;
1982 *bound = 1.0e0;
1983 S400:
1984 S390:
1985 ;
1986 }
1987 else if(3 == *which) {
1988 //
1989 // Computing A
1990 //
1991 *a = 5.0e0;
1992 T6 = zero;
1993 T7 = inf;
1994 T10 = atol;
1995 T11 = tol;
1996 dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11);
1997 *status = 0;
1998 dinvr(status,a,&fx,&qleft,&qhi);
1999 S410:
2000 if(!(*status == 1)) goto S440;
2001 cumbet(x,y,a,b,&cum,&ccum);
2002 if(!qporq) goto S420;
2003 fx = cum-*p;
2004 goto S430;
2005 S420:
2006 fx = ccum-*q;
2007 S430:
2008 dinvr(status,a,&fx,&qleft,&qhi);
2009 goto S410;
2010 S440:
2011 if(!(*status == -1)) goto S470;
2012 if(!qleft) goto S450;
2013 *status = 1;
2014 *bound = zero;
2015 goto S460;
2016 S450:
2017 *status = 2;
2018 *bound = inf;
2019 S470:
2020 S460:
2021 ;
2022 }
2023 else if(4 == *which) {
2024 //
2025 // Computing B
2026 //
2027 *b = 5.0e0;
2028 T12 = zero;
2029 T13 = inf;
2030 T14 = atol;
2031 T15 = tol;
2032 dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15);
2033 *status = 0;
2034 dinvr(status,b,&fx,&qleft,&qhi);
2035 S480:
2036 if(!(*status == 1)) goto S510;
2037 cumbet(x,y,a,b,&cum,&ccum);
2038 if(!qporq) goto S490;
2039 fx = cum-*p;
2040 goto S500;
2041 S490:
2042 fx = ccum-*q;
2043 S500:
2044 dinvr(status,b,&fx,&qleft,&qhi);
2045 goto S480;
2046 S510:
2047 if(!(*status == -1)) goto S540;
2048 if(!qleft) goto S520;
2049 *status = 1;
2050 *bound = zero;
2051 goto S530;
2052 S520:
2053 *status = 2;
2054 *bound = inf;
2055 S530:
2056 ;
2057 }
2058 S540:
2059 return;
2060 # undef tol
2061 # undef atol
2062 # undef zero
2063 # undef inf
2064 # undef one
2065 }
2066 //****************************************************************************80
2067
cdfbin(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)2068 void cdfbin ( int *which, double *p, double *q, double *s, double *xn,
2069 double *pr, double *ompr, int *status, double *bound )
2070
2071 //****************************************************************************80
2072 //
2073 // Purpose:
2074 //
2075 // CDFBIN evaluates the CDF of the Binomial distribution.
2076 //
2077 // Discussion:
2078 //
2079 // This routine calculates any one parameter of the binomial distribution
2080 // given the others.
2081 //
2082 // The value P of the cumulative distribution function is calculated
2083 // directly.
2084 //
2085 // Computation of the other parameters involves a seach for a value that
2086 // produces the desired value of P. The search relies on the
2087 // monotonicity of P with respect to the other parameters.
2088 //
2089 // P is the probablility of S or fewer successes in XN binomial trials,
2090 // each trial having an individual probability of success of PR.
2091 //
2092 // Modified:
2093 //
2094 // 09 June 2004
2095 //
2096 // Reference:
2097 //
2098 // Milton Abramowitz and Irene Stegun,
2099 // Handbook of Mathematical Functions
2100 // 1966, Formula 26.5.24.
2101 //
2102 // Parameters:
2103 //
2104 // Input, int *WHICH, indicates which of argument values is to
2105 // be calculated from the others.
2106 // 1: Calculate P and Q from S, XN, PR and OMPR;
2107 // 2: Calculate S from P, Q, XN, PR and OMPR;
2108 // 3: Calculate XN from P, Q, S, PR and OMPR;
2109 // 4: Calculate PR and OMPR from P, Q, S and XN.
2110 //
2111 // Input/output, double *P, the cumulation, from 0 to S,
2112 // of the binomial distribution. If P is an input value, it should
2113 // lie in the range [0,1].
2114 //
2115 // Input/output, double *Q, equal to 1-P. If Q is an input
2116 // value, it should lie in the range [0,1]. If Q is an output value,
2117 // it will lie in the range [0,1].
2118 //
2119 // Input/output, double *S, the number of successes observed.
2120 // Whether this is an input or output value, it should lie in the
2121 // range [0,XN].
2122 //
2123 // Input/output, double *XN, the number of binomial trials.
2124 // If this is an input value it should lie in the range: (0, +infinity).
2125 // If it is an output value it will be searched for in the
2126 // range [1.0D-300, 1.0D+300].
2127 //
2128 // Input/output, double *PR, the probability of success in each
2129 // binomial trial. Whether this is an input or output value, it should
2130 // lie in the range: [0,1].
2131 //
2132 // Input/output, double *OMPR, equal to 1-PR. Whether this is an
2133 // input or output value, it should lie in the range [0,1]. Also, it should
2134 // be the case that PR + OMPR = 1.
2135 //
2136 // Output, int *STATUS, reports the status of the computation.
2137 // 0, if the calculation completed correctly;
2138 // -I, if the input parameter number I is out of range;
2139 // +1, if the answer appears to be lower than lowest search bound;
2140 // +2, if the answer appears to be higher than greatest search bound;
2141 // +3, if P + Q /= 1;
2142 // +4, if PR + OMPR /= 1.
2143 //
2144 // Output, double *BOUND, is only defined if STATUS is nonzero.
2145 // If STATUS is negative, then this is the value exceeded by parameter I.
2146 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2147 //
2148 {
2149 # define atol (1.0e-50)
2150 # define tol (1.0e-8)
2151 # define zero (1.0e-300)
2152 # define inf 1.0e300
2153 # define one 1.0e0
2154
2155 static int K1 = 1;
2156 static double K2 = 0.0e0;
2157 static double K3 = 0.5e0;
2158 static double K4 = 5.0e0;
2159 static double K11 = 1.0e0;
2160 static double fx,xhi,xlo,cum,ccum,pq,prompr;
2161 static unsigned long qhi,qleft,qporq;
2162 static double T5,T6,T7,T8,T9,T10,T12,T13;
2163
2164 *status = 0;
2165 *bound = 0.0;
2166 //
2167 // Check arguments
2168 //
2169 if(!(*which < 1 && *which > 4)) goto S30;
2170 if(!(*which < 1)) goto S10;
2171 *bound = 1.0e0;
2172 goto S20;
2173 S10:
2174 *bound = 4.0e0;
2175 S20:
2176 *status = -1;
2177 return;
2178 S30:
2179 if(*which == 1) goto S70;
2180 //
2181 // P
2182 //
2183 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2184 if(!(*p < 0.0e0)) goto S40;
2185 *bound = 0.0e0;
2186 goto S50;
2187 S40:
2188 *bound = 1.0e0;
2189 S50:
2190 *status = -2;
2191 return;
2192 S70:
2193 S60:
2194 if(*which == 1) goto S110;
2195 //
2196 // Q
2197 //
2198 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
2199 if(!(*q < 0.0e0)) goto S80;
2200 *bound = 0.0e0;
2201 goto S90;
2202 S80:
2203 *bound = 1.0e0;
2204 S90:
2205 *status = -3;
2206 return;
2207 S110:
2208 S100:
2209 if(*which == 3) goto S130;
2210 //
2211 // XN
2212 //
2213 if(!(*xn <= 0.0e0)) goto S120;
2214 *bound = 0.0e0;
2215 *status = -5;
2216 return;
2217 S130:
2218 S120:
2219 if(*which == 2) goto S170;
2220 //
2221 // S
2222 //
2223 if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160;
2224 if(!(*s < 0.0e0)) goto S140;
2225 *bound = 0.0e0;
2226 goto S150;
2227 S140:
2228 *bound = *xn;
2229 S150:
2230 *status = -4;
2231 return;
2232 S170:
2233 S160:
2234 if(*which == 4) goto S210;
2235 //
2236 // PR
2237 //
2238 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200;
2239 if(!(*pr < 0.0e0)) goto S180;
2240 *bound = 0.0e0;
2241 goto S190;
2242 S180:
2243 *bound = 1.0e0;
2244 S190:
2245 *status = -6;
2246 return;
2247 S210:
2248 S200:
2249 if(*which == 4) goto S250;
2250 //
2251 // OMPR
2252 //
2253 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240;
2254 if(!(*ompr < 0.0e0)) goto S220;
2255 *bound = 0.0e0;
2256 goto S230;
2257 S220:
2258 *bound = 1.0e0;
2259 S230:
2260 *status = -7;
2261 return;
2262 S250:
2263 S240:
2264 if(*which == 1) goto S290;
2265 //
2266 // P + Q
2267 //
2268 pq = *p+*q;
2269 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S280;
2270 if(!(pq < 0.0e0)) goto S260;
2271 *bound = 0.0e0;
2272 goto S270;
2273 S260:
2274 *bound = 1.0e0;
2275 S270:
2276 *status = 3;
2277 return;
2278 S290:
2279 S280:
2280 if(*which == 4) goto S330;
2281 //
2282 // PR + OMPR
2283 //
2284 prompr = *pr+*ompr;
2285 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S320;
2286 if(!(prompr < 0.0e0)) goto S300;
2287 *bound = 0.0e0;
2288 goto S310;
2289 S300:
2290 *bound = 1.0e0;
2291 S310:
2292 *status = 4;
2293 return;
2294 S330:
2295 S320:
2296 if(!(*which == 1)) qporq = *p <= *q;
2297 //
2298 // Select the minimum of P or Q
2299 // Calculate ANSWERS
2300 //
2301 if(1 == *which) {
2302 //
2303 // Calculating P
2304 //
2305 cumbin(s,xn,pr,ompr,p,q);
2306 *status = 0;
2307 }
2308 else if(2 == *which) {
2309 //
2310 // Calculating S
2311 //
2312 *s = 5.0e0;
2313 T5 = atol;
2314 T6 = tol;
2315 dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6);
2316 *status = 0;
2317 dinvr(status,s,&fx,&qleft,&qhi);
2318 S340:
2319 if(!(*status == 1)) goto S370;
2320 cumbin(s,xn,pr,ompr,&cum,&ccum);
2321 if(!qporq) goto S350;
2322 fx = cum-*p;
2323 goto S360;
2324 S350:
2325 fx = ccum-*q;
2326 S360:
2327 dinvr(status,s,&fx,&qleft,&qhi);
2328 goto S340;
2329 S370:
2330 if(!(*status == -1)) goto S400;
2331 if(!qleft) goto S380;
2332 *status = 1;
2333 *bound = 0.0e0;
2334 goto S390;
2335 S380:
2336 *status = 2;
2337 *bound = *xn;
2338 S400:
2339 S390:
2340 ;
2341 }
2342 else if(3 == *which) {
2343 //
2344 // Calculating XN
2345 //
2346 *xn = 5.0e0;
2347 T7 = zero;
2348 T8 = inf;
2349 T9 = atol;
2350 T10 = tol;
2351 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2352 *status = 0;
2353 dinvr(status,xn,&fx,&qleft,&qhi);
2354 S410:
2355 if(!(*status == 1)) goto S440;
2356 cumbin(s,xn,pr,ompr,&cum,&ccum);
2357 if(!qporq) goto S420;
2358 fx = cum-*p;
2359 goto S430;
2360 S420:
2361 fx = ccum-*q;
2362 S430:
2363 dinvr(status,xn,&fx,&qleft,&qhi);
2364 goto S410;
2365 S440:
2366 if(!(*status == -1)) goto S470;
2367 if(!qleft) goto S450;
2368 *status = 1;
2369 *bound = zero;
2370 goto S460;
2371 S450:
2372 *status = 2;
2373 *bound = inf;
2374 S470:
2375 S460:
2376 ;
2377 }
2378 else if(4 == *which) {
2379 //
2380 // Calculating PR and OMPR
2381 //
2382 T12 = atol;
2383 T13 = tol;
2384 dstzr(&K2,&K11,&T12,&T13);
2385 if(!qporq) goto S500;
2386 *status = 0;
2387 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2388 *ompr = one-*pr;
2389 S480:
2390 if(!(*status == 1)) goto S490;
2391 cumbin(s,xn,pr,ompr,&cum,&ccum);
2392 fx = cum-*p;
2393 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2394 *ompr = one-*pr;
2395 goto S480;
2396 S490:
2397 goto S530;
2398 S500:
2399 *status = 0;
2400 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2401 *pr = one-*ompr;
2402 S510:
2403 if(!(*status == 1)) goto S520;
2404 cumbin(s,xn,pr,ompr,&cum,&ccum);
2405 fx = ccum-*q;
2406 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2407 *pr = one-*ompr;
2408 goto S510;
2409 S530:
2410 S520:
2411 if(!(*status == -1)) goto S560;
2412 if(!qleft) goto S540;
2413 *status = 1;
2414 *bound = 0.0e0;
2415 goto S550;
2416 S540:
2417 *status = 2;
2418 *bound = 1.0e0;
2419 S550:
2420 ;
2421 }
2422 S560:
2423 return;
2424 # undef atol
2425 # undef tol
2426 # undef zero
2427 # undef inf
2428 # undef one
2429 }
2430 //****************************************************************************80
2431
cdfchi(int * which,double * p,double * q,double * x,double * df,int * status,double * bound)2432 void cdfchi ( int *which, double *p, double *q, double *x, double *df,
2433 int *status, double *bound )
2434
2435 //****************************************************************************80
2436 //
2437 // Purpose:
2438 //
2439 // CDFCHI evaluates the CDF of the chi square distribution.
2440 //
2441 // Discussion:
2442 //
2443 // This routine calculates any one parameter of the chi square distribution
2444 // given the others.
2445 //
2446 // The value P of the cumulative distribution function is calculated
2447 // directly.
2448 //
2449 // Computation of the other parameters involves a seach for a value that
2450 // produces the desired value of P. The search relies on the
2451 // monotonicity of P with respect to the other parameters.
2452 //
2453 // The CDF of the chi square distribution can be evaluated
2454 // within Mathematica by commands such as:
2455 //
2456 // Needs["Statistics`ContinuousDistributions`"]
2457 // CDF [ ChiSquareDistribution [ DF ], X ]
2458 //
2459 // Reference:
2460 //
2461 // Milton Abramowitz and Irene Stegun,
2462 // Handbook of Mathematical Functions
2463 // 1966, Formula 26.4.19.
2464 //
2465 // Stephen Wolfram,
2466 // The Mathematica Book,
2467 // Fourth Edition,
2468 // Wolfram Media / Cambridge University Press, 1999.
2469 //
2470 // Parameters:
2471 //
2472 // Input, int *WHICH, indicates which argument is to be calculated
2473 // from the others.
2474 // 1: Calculate P and Q from X and DF;
2475 // 2: Calculate X from P, Q and DF;
2476 // 3: Calculate DF from P, Q and X.
2477 //
2478 // Input/output, double *P, the integral from 0 to X of
2479 // the chi-square distribution. If this is an input value, it should
2480 // lie in the range [0,1].
2481 //
2482 // Input/output, double *Q, equal to 1-P. If Q is an input
2483 // value, it should lie in the range [0,1]. If Q is an output value,
2484 // it will lie in the range [0,1].
2485 //
2486 // Input/output, double *X, the upper limit of integration
2487 // of the chi-square distribution. If this is an input
2488 // value, it should lie in the range: [0, +infinity). If it is an output
2489 // value, it will be searched for in the range: [0,1.0D+300].
2490 //
2491 // Input/output, double *DF, the degrees of freedom of the
2492 // chi-square distribution. If this is an input value, it should lie
2493 // in the range: (0, +infinity). If it is an output value, it will be
2494 // searched for in the range: [ 1.0D-300, 1.0D+300].
2495 //
2496 // Output, int *STATUS, reports the status of the computation.
2497 // 0, if the calculation completed correctly;
2498 // -I, if the input parameter number I is out of range;
2499 // +1, if the answer appears to be lower than lowest search bound;
2500 // +2, if the answer appears to be higher than greatest search bound;
2501 // +3, if P + Q /= 1;
2502 // +10, an error was returned from CUMGAM.
2503 //
2504 // Output, double *BOUND, is only defined if STATUS is nonzero.
2505 // If STATUS is negative, then this is the value exceeded by parameter I.
2506 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2507 //
2508 {
2509 # define tol (1.0e-8)
2510 # define atol (1.0e-50)
2511 # define zero (1.0e-300)
2512 # define inf 1.0e300
2513
2514 static int K1 = 1;
2515 static double K2 = 0.0e0;
2516 static double K4 = 0.5e0;
2517 static double K5 = 5.0e0;
2518 static double fx,cum,ccum,pq,porq;
2519 static unsigned long qhi,qleft,qporq;
2520 static double T3,T6,T7,T8,T9,T10,T11;
2521
2522 *status = 0;
2523 *bound = 0.0;
2524 //
2525 // Check arguments
2526 //
2527 if(!(*which < 1 || *which > 3)) goto S30;
2528 if(!(*which < 1)) goto S10;
2529 *bound = 1.0e0;
2530 goto S20;
2531 S10:
2532 *bound = 3.0e0;
2533 S20:
2534 *status = -1;
2535 return;
2536 S30:
2537 if(*which == 1) goto S70;
2538 //
2539 // P
2540 //
2541 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2542 if(!(*p < 0.0e0)) goto S40;
2543 *bound = 0.0e0;
2544 goto S50;
2545 S40:
2546 *bound = 1.0e0;
2547 S50:
2548 *status = -2;
2549 return;
2550 S70:
2551 S60:
2552 if(*which == 1) goto S110;
2553 //
2554 // Q
2555 //
2556 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2557 if(!(*q <= 0.0e0)) goto S80;
2558 *bound = 0.0e0;
2559 goto S90;
2560 S80:
2561 *bound = 1.0e0;
2562 S90:
2563 *status = -3;
2564 return;
2565 S110:
2566 S100:
2567 if(*which == 2) goto S130;
2568 //
2569 // X
2570 //
2571 if(!(*x < 0.0e0)) goto S120;
2572 *bound = 0.0e0;
2573 *status = -4;
2574 return;
2575 S130:
2576 S120:
2577 if(*which == 3) goto S150;
2578 //
2579 // DF
2580 //
2581 if(!(*df <= 0.0e0)) goto S140;
2582 *bound = 0.0e0;
2583 *status = -5;
2584 return;
2585 S150:
2586 S140:
2587 if(*which == 1) goto S190;
2588 //
2589 // P + Q
2590 //
2591 pq = *p+*q;
2592 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S180;
2593 if(!(pq < 0.0e0)) goto S160;
2594 *bound = 0.0e0;
2595 goto S170;
2596 S160:
2597 *bound = 1.0e0;
2598 S170:
2599 *status = 3;
2600 return;
2601 S190:
2602 S180:
2603 if(*which == 1) goto S220;
2604 //
2605 // Select the minimum of P or Q
2606 //
2607 qporq = *p <= *q;
2608 if(!qporq) goto S200;
2609 porq = *p;
2610 goto S210;
2611 S200:
2612 porq = *q;
2613 S220:
2614 S210:
2615 //
2616 // Calculate ANSWERS
2617 //
2618 if(1 == *which) {
2619 //
2620 // Calculating P and Q
2621 //
2622 *status = 0;
2623 cumchi(x,df,p,q);
2624 if(porq > 1.5e0) {
2625 *status = 10;
2626 return;
2627 }
2628 }
2629 else if(2 == *which) {
2630 //
2631 // Calculating X
2632 //
2633 *x = 5.0e0;
2634 T3 = inf;
2635 T6 = atol;
2636 T7 = tol;
2637 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
2638 *status = 0;
2639 dinvr(status,x,&fx,&qleft,&qhi);
2640 S230:
2641 if(!(*status == 1)) goto S270;
2642 cumchi(x,df,&cum,&ccum);
2643 if(!qporq) goto S240;
2644 fx = cum-*p;
2645 goto S250;
2646 S240:
2647 fx = ccum-*q;
2648 S250:
2649 if(!(fx+porq > 1.5e0)) goto S260;
2650 *status = 10;
2651 return;
2652 S260:
2653 dinvr(status,x,&fx,&qleft,&qhi);
2654 goto S230;
2655 S270:
2656 if(!(*status == -1)) goto S300;
2657 if(!qleft) goto S280;
2658 *status = 1;
2659 *bound = 0.0e0;
2660 goto S290;
2661 S280:
2662 *status = 2;
2663 *bound = inf;
2664 S300:
2665 S290:
2666 ;
2667 }
2668 else if(3 == *which) {
2669 //
2670 // Calculating DF
2671 //
2672 *df = 5.0e0;
2673 T8 = zero;
2674 T9 = inf;
2675 T10 = atol;
2676 T11 = tol;
2677 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
2678 *status = 0;
2679 dinvr(status,df,&fx,&qleft,&qhi);
2680 S310:
2681 if(!(*status == 1)) goto S350;
2682 cumchi(x,df,&cum,&ccum);
2683 if(!qporq) goto S320;
2684 fx = cum-*p;
2685 goto S330;
2686 S320:
2687 fx = ccum-*q;
2688 S330:
2689 if(!(fx+porq > 1.5e0)) goto S340;
2690 *status = 10;
2691 return;
2692 S340:
2693 dinvr(status,df,&fx,&qleft,&qhi);
2694 goto S310;
2695 S350:
2696 if(!(*status == -1)) goto S380;
2697 if(!qleft) goto S360;
2698 *status = 1;
2699 *bound = zero;
2700 goto S370;
2701 S360:
2702 *status = 2;
2703 *bound = inf;
2704 S370:
2705 ;
2706 }
2707 S380:
2708 return;
2709 # undef tol
2710 # undef atol
2711 # undef zero
2712 # undef inf
2713 }
2714 //****************************************************************************80
2715
cdfchn(int * which,double * p,double * q,double * x,double * df,double * pnonc,int * status,double * bound)2716 void cdfchn ( int *which, double *p, double *q, double *x, double *df,
2717 double *pnonc, int *status, double *bound )
2718
2719 //****************************************************************************80
2720 //
2721 // Purpose:
2722 //
2723 // CDFCHN evaluates the CDF of the Noncentral Chi-Square.
2724 //
2725 // Discussion:
2726 //
2727 // This routine calculates any one parameter of the noncentral chi-square
2728 // distribution given values for the others.
2729 //
2730 // The value P of the cumulative distribution function is calculated
2731 // directly.
2732 //
2733 // Computation of the other parameters involves a seach for a value that
2734 // produces the desired value of P. The search relies on the
2735 // monotonicity of P with respect to the other parameters.
2736 //
2737 // The computation time required for this routine is proportional
2738 // to the noncentrality parameter (PNONC). Very large values of
2739 // this parameter can consume immense computer resources. This is
2740 // why the search range is bounded by 10,000.
2741 //
2742 // The CDF of the noncentral chi square distribution can be evaluated
2743 // within Mathematica by commands such as:
2744 //
2745 // Needs["Statistics`ContinuousDistributions`"]
2746 // CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
2747 //
2748 // Reference:
2749 //
2750 // Milton Abramowitz and Irene Stegun,
2751 // Handbook of Mathematical Functions
2752 // 1966, Formula 26.5.25.
2753 //
2754 // Stephen Wolfram,
2755 // The Mathematica Book,
2756 // Fourth Edition,
2757 // Wolfram Media / Cambridge University Press, 1999.
2758 //
2759 // Parameters:
2760 //
2761 // Input, int *WHICH, indicates which argument is to be calculated
2762 // from the others.
2763 // 1: Calculate P and Q from X, DF and PNONC;
2764 // 2: Calculate X from P, DF and PNONC;
2765 // 3: Calculate DF from P, X and PNONC;
2766 // 4: Calculate PNONC from P, X and DF.
2767 //
2768 // Input/output, double *P, the integral from 0 to X of
2769 // the noncentral chi-square distribution. If this is an input
2770 // value, it should lie in the range: [0, 1.0-1.0D-16).
2771 //
2772 // Input/output, double *Q, is generally not used by this
2773 // subroutine and is only included for similarity with other routines.
2774 // However, if P is to be computed, then a value will also be computed
2775 // for Q.
2776 //
2777 // Input, double *X, the upper limit of integration of the
2778 // noncentral chi-square distribution. If this is an input value, it
2779 // should lie in the range: [0, +infinity). If it is an output value,
2780 // it will be sought in the range: [0,1.0D+300].
2781 //
2782 // Input/output, double *DF, the number of degrees of freedom
2783 // of the noncentral chi-square distribution. If this is an input value,
2784 // it should lie in the range: (0, +infinity). If it is an output value,
2785 // it will be searched for in the range: [ 1.0D-300, 1.0D+300].
2786 //
2787 // Input/output, double *PNONC, the noncentrality parameter of
2788 // the noncentral chi-square distribution. If this is an input value, it
2789 // should lie in the range: [0, +infinity). If it is an output value,
2790 // it will be searched for in the range: [0,1.0D+4]
2791 //
2792 // Output, int *STATUS, reports on the calculation.
2793 // 0, if calculation completed correctly;
2794 // -I, if input parameter number I is out of range;
2795 // 1, if the answer appears to be lower than the lowest search bound;
2796 // 2, if the answer appears to be higher than the greatest search bound.
2797 //
2798 // Output, double *BOUND, is only defined if STATUS is nonzero.
2799 // If STATUS is negative, then this is the value exceeded by parameter I.
2800 // if STATUS is 1 or 2, this is the search bound that was exceeded.
2801 //
2802 {
2803 # define tent4 1.0e4
2804 # define tol (1.0e-8)
2805 # define atol (1.0e-50)
2806 # define zero (1.0e-300)
2807 # define one (1.0e0-1.0e-16)
2808 # define inf 1.0e300
2809
2810 static double K1 = 0.0e0;
2811 static double K3 = 0.5e0;
2812 static double K4 = 5.0e0;
2813 static double fx,cum,ccum;
2814 static unsigned long qhi,qleft;
2815 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13;
2816
2817 *status = 0;
2818 *bound = 0.0;
2819 //
2820 // Check arguments
2821 //
2822 if(!(*which < 1 || *which > 4)) goto S30;
2823 if(!(*which < 1)) goto S10;
2824 *bound = 1.0e0;
2825 goto S20;
2826 S10:
2827 *bound = 4.0e0;
2828 S20:
2829 *status = -1;
2830 return;
2831 S30:
2832 if(*which == 1) goto S70;
2833 //
2834 // P
2835 //
2836 if(!(*p < 0.0e0 || *p > one)) goto S60;
2837 if(!(*p < 0.0e0)) goto S40;
2838 *bound = 0.0e0;
2839 goto S50;
2840 S40:
2841 *bound = one;
2842 S50:
2843 *status = -2;
2844 return;
2845 S70:
2846 S60:
2847 if(*which == 2) goto S90;
2848 //
2849 // X
2850 //
2851 if(!(*x < 0.0e0)) goto S80;
2852 *bound = 0.0e0;
2853 *status = -4;
2854 return;
2855 S90:
2856 S80:
2857 if(*which == 3) goto S110;
2858 //
2859 // DF
2860 //
2861 if(!(*df <= 0.0e0)) goto S100;
2862 *bound = 0.0e0;
2863 *status = -5;
2864 return;
2865 S110:
2866 S100:
2867 if(*which == 4) goto S130;
2868 //
2869 // PNONC
2870 //
2871 if(!(*pnonc < 0.0e0)) goto S120;
2872 *bound = 0.0e0;
2873 *status = -6;
2874 return;
2875 S130:
2876 S120:
2877 //
2878 // Calculate ANSWERS
2879 //
2880 if(1 == *which) {
2881 //
2882 // Calculating P and Q
2883 //
2884 cumchn(x,df,pnonc,p,q);
2885 *status = 0;
2886 }
2887 else if(2 == *which) {
2888 //
2889 // Calculating X
2890 //
2891 *x = 5.0e0;
2892 T2 = inf;
2893 T5 = atol;
2894 T6 = tol;
2895 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
2896 *status = 0;
2897 dinvr(status,x,&fx,&qleft,&qhi);
2898 S140:
2899 if(!(*status == 1)) goto S150;
2900 cumchn(x,df,pnonc,&cum,&ccum);
2901 fx = cum-*p;
2902 dinvr(status,x,&fx,&qleft,&qhi);
2903 goto S140;
2904 S150:
2905 if(!(*status == -1)) goto S180;
2906 if(!qleft) goto S160;
2907 *status = 1;
2908 *bound = 0.0e0;
2909 goto S170;
2910 S160:
2911 *status = 2;
2912 *bound = inf;
2913 S180:
2914 S170:
2915 ;
2916 }
2917 else if(3 == *which) {
2918 //
2919 // Calculating DF
2920 //
2921 *df = 5.0e0;
2922 T7 = zero;
2923 T8 = inf;
2924 T9 = atol;
2925 T10 = tol;
2926 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2927 *status = 0;
2928 dinvr(status,df,&fx,&qleft,&qhi);
2929 S190:
2930 if(!(*status == 1)) goto S200;
2931 cumchn(x,df,pnonc,&cum,&ccum);
2932 fx = cum-*p;
2933 dinvr(status,df,&fx,&qleft,&qhi);
2934 goto S190;
2935 S200:
2936 if(!(*status == -1)) goto S230;
2937 if(!qleft) goto S210;
2938 *status = 1;
2939 *bound = zero;
2940 goto S220;
2941 S210:
2942 *status = 2;
2943 *bound = inf;
2944 S230:
2945 S220:
2946 ;
2947 }
2948 else if(4 == *which) {
2949 //
2950 // Calculating PNONC
2951 //
2952 *pnonc = 5.0e0;
2953 T11 = tent4;
2954 T12 = atol;
2955 T13 = tol;
2956 dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13);
2957 *status = 0;
2958 dinvr(status,pnonc,&fx,&qleft,&qhi);
2959 S240:
2960 if(!(*status == 1)) goto S250;
2961 cumchn(x,df,pnonc,&cum,&ccum);
2962 fx = cum-*p;
2963 dinvr(status,pnonc,&fx,&qleft,&qhi);
2964 goto S240;
2965 S250:
2966 if(!(*status == -1)) goto S280;
2967 if(!qleft) goto S260;
2968 *status = 1;
2969 *bound = zero;
2970 goto S270;
2971 S260:
2972 *status = 2;
2973 *bound = tent4;
2974 S270:
2975 ;
2976 }
2977 S280:
2978 return;
2979 # undef tent4
2980 # undef tol
2981 # undef atol
2982 # undef zero
2983 # undef one
2984 # undef inf
2985 }
2986 //****************************************************************************80
2987
cdff(int * which,double * p,double * q,double * f,double * dfn,double * dfd,int * status,double * bound)2988 void cdff ( int *which, double *p, double *q, double *f, double *dfn,
2989 double *dfd, int *status, double *bound )
2990
2991 //****************************************************************************80
2992 //
2993 // Purpose:
2994 //
2995 // CDFF evaluates the CDF of the F distribution.
2996 //
2997 // Discussion:
2998 //
2999 // This routine calculates any one parameter of the F distribution
3000 // given the others.
3001 //
3002 // The value P of the cumulative distribution function is calculated
3003 // directly.
3004 //
3005 // Computation of the other parameters involves a seach for a value that
3006 // produces the desired value of P. The search relies on the
3007 // monotonicity of P with respect to the other parameters.
3008 //
3009 // The value of the cumulative F distribution is not necessarily
3010 // monotone in either degree of freedom. There thus may be two
3011 // values that provide a given CDF value. This routine assumes
3012 // monotonicity and will find an arbitrary one of the two values.
3013 //
3014 // Modified:
3015 //
3016 // 14 April 2007
3017 //
3018 // Reference:
3019 //
3020 // Milton Abramowitz, Irene Stegun,
3021 // Handbook of Mathematical Functions
3022 // 1966, Formula 26.6.2.
3023 //
3024 // Parameters:
3025 //
3026 // Input, int *WHICH, indicates which argument is to be calculated
3027 // from the others.
3028 // 1: Calculate P and Q from F, DFN and DFD;
3029 // 2: Calculate F from P, Q, DFN and DFD;
3030 // 3: Calculate DFN from P, Q, F and DFD;
3031 // 4: Calculate DFD from P, Q, F and DFN.
3032 //
3033 // Input/output, double *P, the integral from 0 to F of
3034 // the F-density. If it is an input value, it should lie in the
3035 // range [0,1].
3036 //
3037 // Input/output, double *Q, equal to 1-P. If Q is an input
3038 // value, it should lie in the range [0,1]. If Q is an output value,
3039 // it will lie in the range [0,1].
3040 //
3041 // Input/output, double *F, the upper limit of integration
3042 // of the F-density. If this is an input value, it should lie in the
3043 // range [0, +infinity). If it is an output value, it will be searched
3044 // for in the range [0,1.0D+300].
3045 //
3046 // Input/output, double *DFN, the number of degrees of
3047 // freedom of the numerator sum of squares. If this is an input value,
3048 // it should lie in the range: (0, +infinity). If it is an output value,
3049 // it will be searched for in the range: [ 1.0D-300, 1.0D+300].
3050 //
3051 // Input/output, double *DFD, the number of degrees of freedom
3052 // of the denominator sum of squares. If this is an input value, it should
3053 // lie in the range: (0, +infinity). If it is an output value, it will
3054 // be searched for in the range: [ 1.0D-300, 1.0D+300].
3055 //
3056 // Output, int *STATUS, reports the status of the computation.
3057 // 0, if the calculation completed correctly;
3058 // -I, if the input parameter number I is out of range;
3059 // +1, if the answer appears to be lower than lowest search bound;
3060 // +2, if the answer appears to be higher than greatest search bound;
3061 // +3, if P + Q /= 1.
3062 //
3063 // Output, double *BOUND, is only defined if STATUS is nonzero.
3064 // If STATUS is negative, then this is the value exceeded by parameter I.
3065 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3066 //
3067 {
3068 # define tol (1.0e-8)
3069 # define atol (1.0e-50)
3070 # define zero (1.0e-300)
3071 # define inf 1.0e300
3072
3073 static int K1 = 1;
3074 static double K2 = 0.0e0;
3075 static double K4 = 0.5e0;
3076 static double K5 = 5.0e0;
3077 static double pq,fx,cum,ccum;
3078 static unsigned long qhi,qleft,qporq;
3079 static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15;
3080
3081 *status = 0;
3082 *bound = 0.0;
3083 //
3084 // Check arguments
3085 //
3086 if(!(*which < 1 || *which > 4)) goto S30;
3087 if(!(*which < 1)) goto S10;
3088 *bound = 1.0e0;
3089 goto S20;
3090 S10:
3091 *bound = 4.0e0;
3092 S20:
3093 *status = -1;
3094 return;
3095 S30:
3096 if(*which == 1) goto S70;
3097 //
3098 // P
3099 //
3100 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3101 if(!(*p < 0.0e0)) goto S40;
3102 *bound = 0.0e0;
3103 goto S50;
3104 S40:
3105 *bound = 1.0e0;
3106 S50:
3107 *status = -2;
3108 return;
3109 S70:
3110 S60:
3111 if(*which == 1) goto S110;
3112 //
3113 // Q
3114 //
3115 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3116 if(!(*q <= 0.0e0)) goto S80;
3117 *bound = 0.0e0;
3118 goto S90;
3119 S80:
3120 *bound = 1.0e0;
3121 S90:
3122 *status = -3;
3123 return;
3124 S110:
3125 S100:
3126 if(*which == 2) goto S130;
3127 //
3128 // F
3129 //
3130 if(!(*f < 0.0e0)) goto S120;
3131 *bound = 0.0e0;
3132 *status = -4;
3133 return;
3134 S130:
3135 S120:
3136 if(*which == 3) goto S150;
3137 //
3138 // DFN
3139 //
3140 if(!(*dfn <= 0.0e0)) goto S140;
3141 *bound = 0.0e0;
3142 *status = -5;
3143 return;
3144 S150:
3145 S140:
3146 if(*which == 4) goto S170;
3147 //
3148 // DFD
3149 //
3150 if(!(*dfd <= 0.0e0)) goto S160;
3151 *bound = 0.0e0;
3152 *status = -6;
3153 return;
3154 S170:
3155 S160:
3156 if(*which == 1) goto S210;
3157 //
3158 // P + Q
3159 //
3160 pq = *p+*q;
3161 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0 * dpmpar ( &K1 ) ) ) goto S200;
3162 if(!(pq < 0.0e0)) goto S180;
3163 *bound = 0.0e0;
3164 goto S190;
3165 S180:
3166 *bound = 1.0e0;
3167 S190:
3168 *status = 3;
3169 return;
3170 S210:
3171 S200:
3172 if(!(*which == 1)) qporq = *p <= *q;
3173 //
3174 // Select the minimum of P or Q
3175 // Calculate ANSWERS
3176 //
3177 if(1 == *which) {
3178 //
3179 // Calculating P
3180 //
3181 cumf(f,dfn,dfd,p,q);
3182 *status = 0;
3183 }
3184 else if(2 == *which) {
3185 //
3186 // Calculating F
3187 //
3188 *f = 5.0e0;
3189 T3 = inf;
3190 T6 = atol;
3191 T7 = tol;
3192 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
3193 *status = 0;
3194 dinvr(status,f,&fx,&qleft,&qhi);
3195 S220:
3196 if(!(*status == 1)) goto S250;
3197 cumf(f,dfn,dfd,&cum,&ccum);
3198 if(!qporq) goto S230;
3199 fx = cum-*p;
3200 goto S240;
3201 S230:
3202 fx = ccum-*q;
3203 S240:
3204 dinvr(status,f,&fx,&qleft,&qhi);
3205 goto S220;
3206 S250:
3207 if(!(*status == -1)) goto S280;
3208 if(!qleft) goto S260;
3209 *status = 1;
3210 *bound = 0.0e0;
3211 goto S270;
3212 S260:
3213 *status = 2;
3214 *bound = inf;
3215 S280:
3216 S270:
3217 ;
3218 }
3219 //
3220 // Calculate DFN.
3221 //
3222 // Note that, in the original calculation, the lower bound for DFN was 0.
3223 // Using DFN = 0 causes an error in CUMF when it calls BETA_INC.
3224 // The lower bound was set to the more reasonable value of 1.
3225 // JVB, 14 April 2007.
3226 //
3227 else if ( 3 == *which )
3228 {
3229
3230 T8 = 1.0;
3231 T9 = inf;
3232 T10 = atol;
3233 T11 = tol;
3234 dstinv ( &T8, &T9, &K4, &K4, &K5, &T10, &T11 );
3235
3236 *status = 0;
3237 *dfn = 5.0;
3238 fx = 0.0;
3239
3240 dinvr ( status, dfn, &fx, &qleft, &qhi );
3241
3242 while ( *status == 1 )
3243 {
3244 cumf ( f, dfn, dfd, &cum, &ccum );
3245
3246 if ( *p <= *q )
3247 {
3248 fx = cum - *p;
3249 }
3250 else
3251 {
3252 fx = ccum - *q;
3253 }
3254 dinvr ( status, dfn, &fx, &qleft, &qhi );
3255 }
3256
3257 if ( *status == -1 )
3258 {
3259 if ( qleft )
3260 {
3261 *status = 1;
3262 *bound = 1.0;
3263 }
3264 else
3265 {
3266 *status = 2;
3267 *bound = inf;
3268 }
3269 }
3270 }
3271 //
3272 // Calculate DFD.
3273 //
3274 // Note that, in the original calculation, the lower bound for DFD was 0.
3275 // Using DFD = 0 causes an error in CUMF when it calls BETA_INC.
3276 // The lower bound was set to the more reasonable value of 1.
3277 // JVB, 14 April 2007.
3278 //
3279 //
3280 else if ( 4 == *which )
3281 {
3282
3283 T12 = 1.0;
3284 T13 = inf;
3285 T14 = atol;
3286 T15 = tol;
3287 dstinv ( &T12, &T13, &K4, &K4, &K5, &T14, &T15 );
3288
3289 *status = 0;
3290 *dfd = 5.0;
3291 fx = 0.0;
3292 dinvr ( status, dfd, &fx, &qleft, &qhi );
3293
3294 while ( *status == 1 )
3295 {
3296 cumf ( f, dfn, dfd, &cum, &ccum );
3297
3298 if ( *p <= *q )
3299 {
3300 fx = cum - *p;
3301 }
3302 else
3303 {
3304 fx = ccum - *q;
3305 }
3306 dinvr ( status, dfd, &fx, &qleft, &qhi );
3307 }
3308
3309 if ( *status == -1 )
3310 {
3311 if ( qleft )
3312 {
3313 *status = 1;
3314 *bound = 1.0;
3315 }
3316 else
3317 {
3318 *status = 2;
3319 *bound = inf;
3320 }
3321 }
3322 }
3323
3324 return;
3325 # undef tol
3326 # undef atol
3327 # undef zero
3328 # undef inf
3329 }
3330 //****************************************************************************80
3331
cdffnc(int * which,double * p,double * q,double * f,double * dfn,double * dfd,double * phonc,int * status,double * bound)3332 void cdffnc ( int *which, double *p, double *q, double *f, double *dfn,
3333 double *dfd, double *phonc, int *status, double *bound )
3334
3335 //****************************************************************************80
3336 //
3337 // Purpose:
3338 //
3339 // CDFFNC evaluates the CDF of the Noncentral F distribution.
3340 //
3341 // Discussion:
3342 //
3343 // This routine originally used 1.0E+300 as the upper bound for the
3344 // interval in which many of the missing parameters are to be sought.
3345 // Since the underlying rootfinder routine needs to evaluate the
3346 // function at this point, it is no surprise that the program was
3347 // experiencing overflows. A less extravagant upper bound
3348 // is being tried for now!
3349 //
3350 //
3351 // This routine calculates any one parameter of the Noncentral F distribution
3352 // given the others.
3353 //
3354 // The value P of the cumulative distribution function is calculated
3355 // directly.
3356 //
3357 // Computation of the other parameters involves a seach for a value that
3358 // produces the desired value of P. The search relies on the
3359 // monotonicity of P with respect to the other parameters.
3360 //
3361 // The computation time required for this routine is proportional
3362 // to the noncentrality parameter PNONC. Very large values of
3363 // this parameter can consume immense computer resources. This is
3364 // why the search range is bounded by 10,000.
3365 //
3366 // The value of the cumulative noncentral F distribution is not
3367 // necessarily monotone in either degree of freedom. There thus
3368 // may be two values that provide a given CDF value. This routine
3369 // assumes monotonicity and will find an arbitrary one of the two
3370 // values.
3371 //
3372 // The CDF of the noncentral F distribution can be evaluated
3373 // within Mathematica by commands such as:
3374 //
3375 // Needs["Statistics`ContinuousDistributions`"]
3376 // CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ]
3377 //
3378 // Modified:
3379 //
3380 // 15 June 2004
3381 //
3382 // Reference:
3383 //
3384 // Milton Abramowitz and Irene Stegun,
3385 // Handbook of Mathematical Functions
3386 // 1966, Formula 26.6.20.
3387 //
3388 // Stephen Wolfram,
3389 // The Mathematica Book,
3390 // Fourth Edition,
3391 // Wolfram Media / Cambridge University Press, 1999.
3392 //
3393 // Parameters:
3394 //
3395 // Input, int *WHICH, indicates which argument is to be calculated
3396 // from the others.
3397 // 1: Calculate P and Q from F, DFN, DFD and PNONC;
3398 // 2: Calculate F from P, Q, DFN, DFD and PNONC;
3399 // 3: Calculate DFN from P, Q, F, DFD and PNONC;
3400 // 4: Calculate DFD from P, Q, F, DFN and PNONC;
3401 // 5: Calculate PNONC from P, Q, F, DFN and DFD.
3402 //
3403 // Input/output, double *P, the integral from 0 to F of
3404 // the noncentral F-density. If P is an input value it should
3405 // lie in the range [0,1) (Not including 1!).
3406 //
3407 // Dummy, double *Q, is not used by this subroutine,
3408 // and is only included for similarity with the other routines.
3409 // Its input value is not checked. If P is to be computed, the
3410 // Q is set to 1 - P.
3411 //
3412 // Input/output, double *F, the upper limit of integration
3413 // of the noncentral F-density. If this is an input value, it should
3414 // lie in the range: [0, +infinity). If it is an output value, it
3415 // will be searched for in the range: [0,1.0D+30].
3416 //
3417 // Input/output, double *DFN, the number of degrees of freedom
3418 // of the numerator sum of squares. If this is an input value, it should
3419 // lie in the range: (0, +infinity). If it is an output value, it will
3420 // be searched for in the range: [ 1.0, 1.0D+30].
3421 //
3422 // Input/output, double *DFD, the number of degrees of freedom
3423 // of the denominator sum of squares. If this is an input value, it should
3424 // be in range: (0, +infinity). If it is an output value, it will be
3425 // searched for in the range [1.0, 1.0D+30].
3426 //
3427 // Input/output, double *PNONC, the noncentrality parameter
3428 // If this is an input value, it should be nonnegative.
3429 // If it is an output value, it will be searched for in the range: [0,1.0D+4].
3430 //
3431 // Output, int *STATUS, reports the status of the computation.
3432 // 0, if the calculation completed correctly;
3433 // -I, if the input parameter number I is out of range;
3434 // +1, if the answer appears to be lower than lowest search bound;
3435 // +2, if the answer appears to be higher than greatest search bound;
3436 // +3, if P + Q /= 1.
3437 //
3438 // Output, double *BOUND, is only defined if STATUS is nonzero.
3439 // If STATUS is negative, then this is the value exceeded by parameter I.
3440 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3441 //
3442 {
3443 # define tent4 1.0e4
3444 # define tol (1.0e-8)
3445 # define atol (1.0e-50)
3446 # define zero (1.0e-300)
3447 # define one (1.0e0-1.0e-16)
3448 # define inf 1.0e300
3449
3450 static double K1 = 0.0e0;
3451 static double K3 = 0.5e0;
3452 static double K4 = 5.0e0;
3453 static double fx,cum,ccum;
3454 static unsigned long qhi,qleft;
3455 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17;
3456
3457 *status = 0;
3458 *bound = 0.0;
3459 //
3460 // Check arguments
3461 //
3462 if(!(*which < 1 || *which > 5)) goto S30;
3463 if(!(*which < 1)) goto S10;
3464 *bound = 1.0e0;
3465 goto S20;
3466 S10:
3467 *bound = 5.0e0;
3468 S20:
3469 *status = -1;
3470 return;
3471 S30:
3472 if(*which == 1) goto S70;
3473 //
3474 // P
3475 //
3476 if(!(*p < 0.0e0 || *p > one)) goto S60;
3477 if(!(*p < 0.0e0)) goto S40;
3478 *bound = 0.0e0;
3479 goto S50;
3480 S40:
3481 *bound = one;
3482 S50:
3483 *status = -2;
3484 return;
3485 S70:
3486 S60:
3487 if(*which == 2) goto S90;
3488 //
3489 // F
3490 //
3491 if(!(*f < 0.0e0)) goto S80;
3492 *bound = 0.0e0;
3493 *status = -4;
3494 return;
3495 S90:
3496 S80:
3497 if(*which == 3) goto S110;
3498 //
3499 // DFN
3500 //
3501 if(!(*dfn <= 0.0e0)) goto S100;
3502 *bound = 0.0e0;
3503 *status = -5;
3504 return;
3505 S110:
3506 S100:
3507 if(*which == 4) goto S130;
3508 //
3509 // DFD
3510 //
3511 if(!(*dfd <= 0.0e0)) goto S120;
3512 *bound = 0.0e0;
3513 *status = -6;
3514 return;
3515 S130:
3516 S120:
3517 if(*which == 5) goto S150;
3518 //
3519 // PHONC
3520 //
3521 if(!(*phonc < 0.0e0)) goto S140;
3522 *bound = 0.0e0;
3523 *status = -7;
3524 return;
3525 S150:
3526 S140:
3527 //
3528 // Calculate ANSWERS
3529 //
3530 if(1 == *which) {
3531 //
3532 // Calculating P
3533 //
3534 cumfnc(f,dfn,dfd,phonc,p,q);
3535 *status = 0;
3536 }
3537 else if(2 == *which) {
3538 //
3539 // Calculating F
3540 //
3541 *f = 5.0e0;
3542 T2 = inf;
3543 T5 = atol;
3544 T6 = tol;
3545 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
3546 *status = 0;
3547 dinvr(status,f,&fx,&qleft,&qhi);
3548 S160:
3549 if(!(*status == 1)) goto S170;
3550 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3551 fx = cum-*p;
3552 dinvr(status,f,&fx,&qleft,&qhi);
3553 goto S160;
3554 S170:
3555 if(!(*status == -1)) goto S200;
3556 if(!qleft) goto S180;
3557 *status = 1;
3558 *bound = 0.0e0;
3559 goto S190;
3560 S180:
3561 *status = 2;
3562 *bound = inf;
3563 S200:
3564 S190:
3565 ;
3566 }
3567 else if(3 == *which) {
3568 //
3569 // Calculating DFN
3570 //
3571 *dfn = 5.0e0;
3572 T7 = zero;
3573 T8 = inf;
3574 T9 = atol;
3575 T10 = tol;
3576 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
3577 *status = 0;
3578 dinvr(status,dfn,&fx,&qleft,&qhi);
3579 S210:
3580 if(!(*status == 1)) goto S220;
3581 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3582 fx = cum-*p;
3583 dinvr(status,dfn,&fx,&qleft,&qhi);
3584 goto S210;
3585 S220:
3586 if(!(*status == -1)) goto S250;
3587 if(!qleft) goto S230;
3588 *status = 1;
3589 *bound = zero;
3590 goto S240;
3591 S230:
3592 *status = 2;
3593 *bound = inf;
3594 S250:
3595 S240:
3596 ;
3597 }
3598 else if(4 == *which) {
3599 //
3600 // Calculating DFD
3601 //
3602 *dfd = 5.0e0;
3603 T11 = zero;
3604 T12 = inf;
3605 T13 = atol;
3606 T14 = tol;
3607 dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14);
3608 *status = 0;
3609 dinvr(status,dfd,&fx,&qleft,&qhi);
3610 S260:
3611 if(!(*status == 1)) goto S270;
3612 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3613 fx = cum-*p;
3614 dinvr(status,dfd,&fx,&qleft,&qhi);
3615 goto S260;
3616 S270:
3617 if(!(*status == -1)) goto S300;
3618 if(!qleft) goto S280;
3619 *status = 1;
3620 *bound = zero;
3621 goto S290;
3622 S280:
3623 *status = 2;
3624 *bound = inf;
3625 S300:
3626 S290:
3627 ;
3628 }
3629 else if(5 == *which) {
3630 //
3631 // Calculating PHONC
3632 //
3633 *phonc = 5.0e0;
3634 T15 = tent4;
3635 T16 = atol;
3636 T17 = tol;
3637 dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17);
3638 *status = 0;
3639 dinvr(status,phonc,&fx,&qleft,&qhi);
3640 S310:
3641 if(!(*status == 1)) goto S320;
3642 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3643 fx = cum-*p;
3644 dinvr(status,phonc,&fx,&qleft,&qhi);
3645 goto S310;
3646 S320:
3647 if(!(*status == -1)) goto S350;
3648 if(!qleft) goto S330;
3649 *status = 1;
3650 *bound = 0.0e0;
3651 goto S340;
3652 S330:
3653 *status = 2;
3654 *bound = tent4;
3655 S340:
3656 ;
3657 }
3658 S350:
3659 return;
3660 # undef tent4
3661 # undef tol
3662 # undef atol
3663 # undef zero
3664 # undef one
3665 # undef inf
3666 }
3667 //****************************************************************************80
3668
cdfgam(int * which,double * p,double * q,double * x,double * shape,double * scale,int * status,double * bound)3669 void cdfgam ( int *which, double *p, double *q, double *x, double *shape,
3670 double *scale, int *status, double *bound )
3671
3672 //****************************************************************************80
3673 //
3674 // Purpose:
3675 //
3676 // CDFGAM evaluates the CDF of the Gamma Distribution.
3677 //
3678 // Discussion:
3679 //
3680 // This routine calculates any one parameter of the Gamma distribution
3681 // given the others.
3682 //
3683 // The cumulative distribution function P is calculated directly.
3684 //
3685 // Computation of the other parameters involves a seach for a value that
3686 // produces the desired value of P. The search relies on the
3687 // monotonicity of P with respect to the other parameters.
3688 //
3689 // The gamma density is proportional to T**(SHAPE - 1) * EXP(- SCALE * T)
3690 //
3691 // Reference:
3692 //
3693 // Armido DiDinato and Alfred Morris,
3694 // Computation of the incomplete gamma function ratios and their inverse,
3695 // ACM Transactions on Mathematical Software,
3696 // Volume 12, 1986, pages 377-393.
3697 //
3698 // Parameters:
3699 //
3700 // Input, int *WHICH, indicates which argument is to be calculated
3701 // from the others.
3702 // 1: Calculate P and Q from X, SHAPE and SCALE;
3703 // 2: Calculate X from P, Q, SHAPE and SCALE;
3704 // 3: Calculate SHAPE from P, Q, X and SCALE;
3705 // 4: Calculate SCALE from P, Q, X and SHAPE.
3706 //
3707 // Input/output, double *P, the integral from 0 to X of the
3708 // Gamma density. If this is an input value, it should lie in the
3709 // range: [0,1].
3710 //
3711 // Input/output, double *Q, equal to 1-P. If Q is an input
3712 // value, it should lie in the range [0,1]. If Q is an output value,
3713 // it will lie in the range [0,1].
3714 //
3715 // Input/output, double *X, the upper limit of integration of
3716 // the Gamma density. If this is an input value, it should lie in the
3717 // range: [0, +infinity). If it is an output value, it will lie in
3718 // the range: [0,1E300].
3719 //
3720 // Input/output, double *SHAPE, the shape parameter of the
3721 // Gamma density. If this is an input value, it should lie in the range:
3722 // (0, +infinity). If it is an output value, it will be searched for
3723 // in the range: [1.0D-300,1.0D+300].
3724 //
3725 // Input/output, double *SCALE, the scale parameter of the
3726 // Gamma density. If this is an input value, it should lie in the range
3727 // (0, +infinity). If it is an output value, it will be searched for
3728 // in the range: (1.0D-300,1.0D+300].
3729 //
3730 // Output, int *STATUS, reports the status of the computation.
3731 // 0, if the calculation completed correctly;
3732 // -I, if the input parameter number I is out of range;
3733 // +1, if the answer appears to be lower than lowest search bound;
3734 // +2, if the answer appears to be higher than greatest search bound;
3735 // +3, if P + Q /= 1;
3736 // +10, if the Gamma or inverse Gamma routine cannot compute the answer.
3737 // This usually happens only for X and SHAPE very large (more than 1.0D+10.
3738 //
3739 // Output, double *BOUND, is only defined if STATUS is nonzero.
3740 // If STATUS is negative, then this is the value exceeded by parameter I.
3741 // if STATUS is 1 or 2, this is the search bound that was exceeded.
3742 //
3743 {
3744 # define tol (1.0e-8)
3745 # define atol (1.0e-50)
3746 # define zero (1.0e-300)
3747 # define inf 1.0e300
3748
3749 static int K1 = 1;
3750 static double K5 = 0.5e0;
3751 static double K6 = 5.0e0;
3752 static double xx,fx,xscale,cum,ccum,pq,porq;
3753 static int ierr;
3754 static unsigned long qhi,qleft,qporq;
3755 static double T2,T3,T4,T7,T8,T9;
3756
3757 *status = 0;
3758 *bound = 0.0;
3759 //
3760 // Check arguments
3761 //
3762 if(!(*which < 1 || *which > 4)) goto S30;
3763 if(!(*which < 1)) goto S10;
3764 *bound = 1.0e0;
3765 goto S20;
3766 S10:
3767 *bound = 4.0e0;
3768 S20:
3769 *status = -1;
3770 return;
3771 S30:
3772 if(*which == 1) goto S70;
3773 //
3774 // P
3775 //
3776 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3777 if(!(*p < 0.0e0)) goto S40;
3778 *bound = 0.0e0;
3779 goto S50;
3780 S40:
3781 *bound = 1.0e0;
3782 S50:
3783 *status = -2;
3784 return;
3785 S70:
3786 S60:
3787 if(*which == 1) goto S110;
3788 //
3789 // Q
3790 //
3791 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3792 if(!(*q <= 0.0e0)) goto S80;
3793 *bound = 0.0e0;
3794 goto S90;
3795 S80:
3796 *bound = 1.0e0;
3797 S90:
3798 *status = -3;
3799 return;
3800 S110:
3801 S100:
3802 if(*which == 2) goto S130;
3803 //
3804 // X
3805 //
3806 if(!(*x < 0.0e0)) goto S120;
3807 *bound = 0.0e0;
3808 *status = -4;
3809 return;
3810 S130:
3811 S120:
3812 if(*which == 3) goto S150;
3813 //
3814 // SHAPE
3815 //
3816 if(!(*shape <= 0.0e0)) goto S140;
3817 *bound = 0.0e0;
3818 *status = -5;
3819 return;
3820 S150:
3821 S140:
3822 if(*which == 4) goto S170;
3823 //
3824 // SCALE
3825 //
3826 if(!(*scale <= 0.0e0)) goto S160;
3827 *bound = 0.0e0;
3828 *status = -6;
3829 return;
3830 S170:
3831 S160:
3832 if(*which == 1) goto S210;
3833 //
3834 // P + Q
3835 //
3836 pq = *p+*q;
3837 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S200;
3838 if(!(pq < 0.0e0)) goto S180;
3839 *bound = 0.0e0;
3840 goto S190;
3841 S180:
3842 *bound = 1.0e0;
3843 S190:
3844 *status = 3;
3845 return;
3846 S210:
3847 S200:
3848 if(*which == 1) goto S240;
3849 //
3850 // Select the minimum of P or Q
3851 //
3852 qporq = *p <= *q;
3853 if(!qporq) goto S220;
3854 porq = *p;
3855 goto S230;
3856 S220:
3857 porq = *q;
3858 S240:
3859 S230:
3860 //
3861 // Calculate ANSWERS
3862 //
3863 if(1 == *which) {
3864 //
3865 // Calculating P
3866 //
3867 *status = 0;
3868 xscale = *x**scale;
3869 cumgam(&xscale,shape,p,q);
3870 if(porq > 1.5e0) *status = 10;
3871 }
3872 else if(2 == *which) {
3873 //
3874 // Computing X
3875 //
3876 T2 = -1.0e0;
3877 gamma_inc_inv ( shape, &xx, &T2, p, q, &ierr );
3878 if(ierr < 0.0e0) {
3879 *status = 10;
3880 return;
3881 }
3882 else {
3883 *x = xx/ *scale;
3884 *status = 0;
3885 }
3886 }
3887 else if(3 == *which) {
3888 //
3889 // Computing SHAPE
3890 //
3891 *shape = 5.0e0;
3892 xscale = *x**scale;
3893 T3 = zero;
3894 T4 = inf;
3895 T7 = atol;
3896 T8 = tol;
3897 dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8);
3898 *status = 0;
3899 dinvr(status,shape,&fx,&qleft,&qhi);
3900 S250:
3901 if(!(*status == 1)) goto S290;
3902 cumgam(&xscale,shape,&cum,&ccum);
3903 if(!qporq) goto S260;
3904 fx = cum-*p;
3905 goto S270;
3906 S260:
3907 fx = ccum-*q;
3908 S270:
3909 if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280;
3910 *status = 10;
3911 return;
3912 S280:
3913 dinvr(status,shape,&fx,&qleft,&qhi);
3914 goto S250;
3915 S290:
3916 if(!(*status == -1)) goto S320;
3917 if(!qleft) goto S300;
3918 *status = 1;
3919 *bound = zero;
3920 goto S310;
3921 S300:
3922 *status = 2;
3923 *bound = inf;
3924 S320:
3925 S310:
3926 ;
3927 }
3928 else if(4 == *which) {
3929 //
3930 // Computing SCALE
3931 //
3932 T9 = -1.0e0;
3933 gamma_inc_inv ( shape, &xx, &T9, p, q, &ierr );
3934 if(ierr < 0.0e0) {
3935 *status = 10;
3936 return;
3937 }
3938 else {
3939 *scale = xx/ *x;
3940 *status = 0;
3941 }
3942 }
3943 return;
3944 # undef tol
3945 # undef atol
3946 # undef zero
3947 # undef inf
3948 }
3949 //****************************************************************************80
3950
cdfnbn(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)3951 void cdfnbn ( int *which, double *p, double *q, double *s, double *xn,
3952 double *pr, double *ompr, int *status, double *bound )
3953
3954 //****************************************************************************80
3955 //
3956 // Purpose:
3957 //
3958 // CDFNBN evaluates the CDF of the Negative Binomial distribution
3959 //
3960 // Discussion:
3961 //
3962 // This routine calculates any one parameter of the negative binomial
3963 // distribution given values for the others.
3964 //
3965 // The cumulative negative binomial distribution returns the
3966 // probability that there will be F or fewer failures before the
3967 // S-th success in binomial trials each of which has probability of
3968 // success PR.
3969 //
3970 // The individual term of the negative binomial is the probability of
3971 // F failures before S successes and is
3972 // Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F
3973 //
3974 // Computation of other parameters involve a seach for a value that
3975 // produces the desired value of P. The search relies on the
3976 // monotonicity of P with respect to the other parameters.
3977 //
3978 // Reference:
3979 //
3980 // Milton Abramowitz and Irene Stegun,
3981 // Handbook of Mathematical Functions
3982 // 1966, Formula 26.5.26.
3983 //
3984 // Parameters:
3985 //
3986 // Input, int WHICH, indicates which argument is to be calculated
3987 // from the others.
3988 // 1: Calculate P and Q from F, S, PR and OMPR;
3989 // 2: Calculate F from P, Q, S, PR and OMPR;
3990 // 3: Calculate S from P, Q, F, PR and OMPR;
3991 // 4: Calculate PR and OMPR from P, Q, F and S.
3992 //
3993 // Input/output, double P, the cumulation from 0 to F of
3994 // the negative binomial distribution. If P is an input value, it
3995 // should lie in the range [0,1].
3996 //
3997 // Input/output, double Q, equal to 1-P. If Q is an input
3998 // value, it should lie in the range [0,1]. If Q is an output value,
3999 // it will lie in the range [0,1].
4000 //
4001 // Input/output, double F, the upper limit of cumulation of
4002 // the binomial distribution. There are F or fewer failures before
4003 // the S-th success. If this is an input value, it may lie in the
4004 // range [0,+infinity), and if it is an output value, it will be searched
4005 // for in the range [0,1.0D+300].
4006 //
4007 // Input/output, double S, the number of successes.
4008 // If this is an input value, it should lie in the range: [0, +infinity).
4009 // If it is an output value, it will be searched for in the range:
4010 // [0, 1.0D+300].
4011 //
4012 // Input/output, double PR, the probability of success in each
4013 // binomial trial. Whether an input or output value, it should lie in the
4014 // range [0,1].
4015 //
4016 // Input/output, double OMPR, the value of (1-PR). Whether an
4017 // input or output value, it should lie in the range [0,1].
4018 //
4019 // Output, int STATUS, reports the status of the computation.
4020 // 0, if the calculation completed correctly;
4021 // -I, if the input parameter number I is out of range;
4022 // +1, if the answer appears to be lower than lowest search bound;
4023 // +2, if the answer appears to be higher than greatest search bound;
4024 // +3, if P + Q /= 1;
4025 // +4, if PR + OMPR /= 1.
4026 //
4027 // Output, double BOUND, is only defined if STATUS is nonzero.
4028 // If STATUS is negative, then this is the value exceeded by parameter I.
4029 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4030 //
4031 {
4032 # define tol (1.0e-8)
4033 # define atol (1.0e-50)
4034 # define inf 1.0e300
4035 # define one 1.0e0
4036
4037 static int K1 = 1;
4038 static double K2 = 0.0e0;
4039 static double K4 = 0.5e0;
4040 static double K5 = 5.0e0;
4041 static double K11 = 1.0e0;
4042 static double fx,xhi,xlo,pq,prompr,cum,ccum;
4043 static unsigned long qhi,qleft,qporq;
4044 static double T3,T6,T7,T8,T9,T10,T12,T13;
4045
4046 *status = 0;
4047 *bound = 0.0;
4048 //
4049 // Check arguments
4050 //
4051 if(!(*which < 1 || *which > 4)) goto S30;
4052 if(!(*which < 1)) goto S10;
4053 *bound = 1.0e0;
4054 goto S20;
4055 S10:
4056 *bound = 4.0e0;
4057 S20:
4058 *status = -1;
4059 return;
4060 S30:
4061 if(*which == 1) goto S70;
4062 //
4063 // P
4064 //
4065 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4066 if(!(*p < 0.0e0)) goto S40;
4067 *bound = 0.0e0;
4068 goto S50;
4069 S40:
4070 *bound = 1.0e0;
4071 S50:
4072 *status = -2;
4073 return;
4074 S70:
4075 S60:
4076 if(*which == 1) goto S110;
4077 //
4078 // Q
4079 //
4080 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4081 if(!(*q <= 0.0e0)) goto S80;
4082 *bound = 0.0e0;
4083 goto S90;
4084 S80:
4085 *bound = 1.0e0;
4086 S90:
4087 *status = -3;
4088 return;
4089 S110:
4090 S100:
4091 if(*which == 2) goto S130;
4092 //
4093 // S
4094 //
4095 if(!(*s < 0.0e0)) goto S120;
4096 *bound = 0.0e0;
4097 *status = -4;
4098 return;
4099 S130:
4100 S120:
4101 if(*which == 3) goto S150;
4102 //
4103 // XN
4104 //
4105 if(!(*xn < 0.0e0)) goto S140;
4106 *bound = 0.0e0;
4107 *status = -5;
4108 return;
4109 S150:
4110 S140:
4111 if(*which == 4) goto S190;
4112 //
4113 // PR
4114 //
4115 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180;
4116 if(!(*pr < 0.0e0)) goto S160;
4117 *bound = 0.0e0;
4118 goto S170;
4119 S160:
4120 *bound = 1.0e0;
4121 S170:
4122 *status = -6;
4123 return;
4124 S190:
4125 S180:
4126 if(*which == 4) goto S230;
4127 //
4128 // OMPR
4129 //
4130 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220;
4131 if(!(*ompr < 0.0e0)) goto S200;
4132 *bound = 0.0e0;
4133 goto S210;
4134 S200:
4135 *bound = 1.0e0;
4136 S210:
4137 *status = -7;
4138 return;
4139 S230:
4140 S220:
4141 if(*which == 1) goto S270;
4142 //
4143 // P + Q
4144 //
4145 pq = *p+*q;
4146 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S260;
4147 if(!(pq < 0.0e0)) goto S240;
4148 *bound = 0.0e0;
4149 goto S250;
4150 S240:
4151 *bound = 1.0e0;
4152 S250:
4153 *status = 3;
4154 return;
4155 S270:
4156 S260:
4157 if(*which == 4) goto S310;
4158 //
4159 // PR + OMPR
4160 //
4161 prompr = *pr+*ompr;
4162 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S300;
4163 if(!(prompr < 0.0e0)) goto S280;
4164 *bound = 0.0e0;
4165 goto S290;
4166 S280:
4167 *bound = 1.0e0;
4168 S290:
4169 *status = 4;
4170 return;
4171 S310:
4172 S300:
4173 if(!(*which == 1)) qporq = *p <= *q;
4174 //
4175 // Select the minimum of P or Q
4176 // Calculate ANSWERS
4177 //
4178 if(1 == *which) {
4179 //
4180 // Calculating P
4181 //
4182 cumnbn(s,xn,pr,ompr,p,q);
4183 *status = 0;
4184 }
4185 else if(2 == *which) {
4186 //
4187 // Calculating S
4188 //
4189 *s = 5.0e0;
4190 T3 = inf;
4191 T6 = atol;
4192 T7 = tol;
4193 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4194 *status = 0;
4195 dinvr(status,s,&fx,&qleft,&qhi);
4196 S320:
4197 if(!(*status == 1)) goto S350;
4198 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4199 if(!qporq) goto S330;
4200 fx = cum-*p;
4201 goto S340;
4202 S330:
4203 fx = ccum-*q;
4204 S340:
4205 dinvr(status,s,&fx,&qleft,&qhi);
4206 goto S320;
4207 S350:
4208 if(!(*status == -1)) goto S380;
4209 if(!qleft) goto S360;
4210 *status = 1;
4211 *bound = 0.0e0;
4212 goto S370;
4213 S360:
4214 *status = 2;
4215 *bound = inf;
4216 S380:
4217 S370:
4218 ;
4219 }
4220 else if(3 == *which) {
4221 //
4222 // Calculating XN
4223 //
4224 *xn = 5.0e0;
4225 T8 = inf;
4226 T9 = atol;
4227 T10 = tol;
4228 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4229 *status = 0;
4230 dinvr(status,xn,&fx,&qleft,&qhi);
4231 S390:
4232 if(!(*status == 1)) goto S420;
4233 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4234 if(!qporq) goto S400;
4235 fx = cum-*p;
4236 goto S410;
4237 S400:
4238 fx = ccum-*q;
4239 S410:
4240 dinvr(status,xn,&fx,&qleft,&qhi);
4241 goto S390;
4242 S420:
4243 if(!(*status == -1)) goto S450;
4244 if(!qleft) goto S430;
4245 *status = 1;
4246 *bound = 0.0e0;
4247 goto S440;
4248 S430:
4249 *status = 2;
4250 *bound = inf;
4251 S450:
4252 S440:
4253 ;
4254 }
4255 else if(4 == *which) {
4256 //
4257 // Calculating PR and OMPR
4258 //
4259 T12 = atol;
4260 T13 = tol;
4261 dstzr(&K2,&K11,&T12,&T13);
4262 if(!qporq) goto S480;
4263 *status = 0;
4264 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4265 *ompr = one-*pr;
4266 S460:
4267 if(!(*status == 1)) goto S470;
4268 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4269 fx = cum-*p;
4270 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4271 *ompr = one-*pr;
4272 goto S460;
4273 S470:
4274 goto S510;
4275 S480:
4276 *status = 0;
4277 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4278 *pr = one-*ompr;
4279 S490:
4280 if(!(*status == 1)) goto S500;
4281 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4282 fx = ccum-*q;
4283 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4284 *pr = one-*ompr;
4285 goto S490;
4286 S510:
4287 S500:
4288 if(!(*status == -1)) goto S540;
4289 if(!qleft) goto S520;
4290 *status = 1;
4291 *bound = 0.0e0;
4292 goto S530;
4293 S520:
4294 *status = 2;
4295 *bound = 1.0e0;
4296 S530:
4297 ;
4298 }
4299 S540:
4300 return;
4301 # undef tol
4302 # undef atol
4303 # undef inf
4304 # undef one
4305 }
4306 //****************************************************************************80
4307
cdfnor(int * which,double * p,double * q,double * x,double * mean,double * sd,int * status,double * bound)4308 void cdfnor ( int *which, double *p, double *q, double *x, double *mean,
4309 double *sd, int *status, double *bound )
4310
4311 //****************************************************************************80
4312 //
4313 // Purpose:
4314 //
4315 // CDFNOR evaluates the CDF of the Normal distribution.
4316 //
4317 // Discussion:
4318 //
4319 // A slightly modified version of ANORM from SPECFUN
4320 // is used to calculate the cumulative standard normal distribution.
4321 //
4322 // The rational functions from pages 90-95 of Kennedy and Gentle
4323 // are used as starting values to Newton's Iterations which
4324 // compute the inverse standard normal. Therefore no searches are
4325 // necessary for any parameter.
4326 //
4327 // For X < -15, the asymptotic expansion for the normal is used as
4328 // the starting value in finding the inverse standard normal.
4329 //
4330 // The normal density is proportional to
4331 // exp( - 0.5D+00 * (( X - MEAN)/SD)**2)
4332 //
4333 // Reference:
4334 //
4335 // Milton Abramowitz and Irene Stegun,
4336 // Handbook of Mathematical Functions
4337 // 1966, Formula 26.2.12.
4338 //
4339 // William Cody,
4340 // Algorithm 715: SPECFUN - A Portable FORTRAN Package of
4341 // Special Function Routines and Test Drivers,
4342 // ACM Transactions on Mathematical Software,
4343 // Volume 19, pages 22-32, 1993.
4344 //
4345 // Kennedy and Gentle,
4346 // Statistical Computing,
4347 // Marcel Dekker, NY, 1980,
4348 // QA276.4 K46
4349 //
4350 // Parameters:
4351 //
4352 // Input, int *WHICH, indicates which argument is to be calculated
4353 // from the others.
4354 // 1: Calculate P and Q from X, MEAN and SD;
4355 // 2: Calculate X from P, Q, MEAN and SD;
4356 // 3: Calculate MEAN from P, Q, X and SD;
4357 // 4: Calculate SD from P, Q, X and MEAN.
4358 //
4359 // Input/output, double *P, the integral from -infinity to X
4360 // of the Normal density. If this is an input or output value, it will
4361 // lie in the range [0,1].
4362 //
4363 // Input/output, double *Q, equal to 1-P. If Q is an input
4364 // value, it should lie in the range [0,1]. If Q is an output value,
4365 // it will lie in the range [0,1].
4366 //
4367 // Input/output, double *X, the upper limit of integration of
4368 // the Normal density.
4369 //
4370 // Input/output, double *MEAN, the mean of the Normal density.
4371 //
4372 // Input/output, double *SD, the standard deviation of the
4373 // Normal density. If this is an input value, it should lie in the
4374 // range (0,+infinity).
4375 //
4376 // Output, int *STATUS, the status of the calculation.
4377 // 0, if calculation completed correctly;
4378 // -I, if input parameter number I is out of range;
4379 // 1, if answer appears to be lower than lowest search bound;
4380 // 2, if answer appears to be higher than greatest search bound;
4381 // 3, if P + Q /= 1.
4382 //
4383 // Output, double *BOUND, is only defined if STATUS is nonzero.
4384 // If STATUS is negative, then this is the value exceeded by parameter I.
4385 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4386 //
4387 {
4388 static int K1 = 1;
4389 static double z,pq;
4390
4391 *status = 0;
4392 *bound = 0.0;
4393 //
4394 // Check arguments
4395 //
4396 *status = 0;
4397 if(!(*which < 1 || *which > 4)) goto S30;
4398 if(!(*which < 1)) goto S10;
4399 *bound = 1.0e0;
4400 goto S20;
4401 S10:
4402 *bound = 4.0e0;
4403 S20:
4404 *status = -1;
4405 return;
4406 S30:
4407 if(*which == 1) goto S70;
4408 //
4409 // P
4410 //
4411 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4412 if(!(*p <= 0.0e0)) goto S40;
4413 *bound = 0.0e0;
4414 goto S50;
4415 S40:
4416 *bound = 1.0e0;
4417 S50:
4418 *status = -2;
4419 return;
4420 S70:
4421 S60:
4422 if(*which == 1) goto S110;
4423 //
4424 // Q
4425 //
4426 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4427 if(!(*q <= 0.0e0)) goto S80;
4428 *bound = 0.0e0;
4429 goto S90;
4430 S80:
4431 *bound = 1.0e0;
4432 S90:
4433 *status = -3;
4434 return;
4435 S110:
4436 S100:
4437 if(*which == 1) goto S150;
4438 //
4439 // P + Q
4440 //
4441 pq = *p+*q;
4442 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S140;
4443 if(!(pq < 0.0e0)) goto S120;
4444 *bound = 0.0e0;
4445 goto S130;
4446 S120:
4447 *bound = 1.0e0;
4448 S130:
4449 *status = 3;
4450 return;
4451 S150:
4452 S140:
4453 if(*which == 4) goto S170;
4454 //
4455 // SD
4456 //
4457 if(!(*sd <= 0.0e0)) goto S160;
4458 *bound = 0.0e0;
4459 *status = -6;
4460 return;
4461 S170:
4462 S160:
4463 //
4464 // Calculate ANSWERS
4465 //
4466 if(1 == *which) {
4467 //
4468 // Computing P
4469 //
4470 z = (*x-*mean)/ *sd;
4471 cumnor(&z,p,q);
4472 }
4473 else if(2 == *which) {
4474 //
4475 // Computing X
4476 //
4477 z = dinvnr(p,q);
4478 *x = *sd*z+*mean;
4479 }
4480 else if(3 == *which) {
4481 //
4482 // Computing the MEAN
4483 //
4484 z = dinvnr(p,q);
4485 *mean = *x-*sd*z;
4486 }
4487 else if(4 == *which) {
4488 //
4489 // Computing SD
4490 //
4491 z = dinvnr(p,q);
4492 *sd = (*x-*mean)/z;
4493 }
4494 return;
4495 }
4496 //****************************************************************************80
4497
cdfpoi(int * which,double * p,double * q,double * s,double * xlam,int * status,double * bound)4498 void cdfpoi ( int *which, double *p, double *q, double *s, double *xlam,
4499 int *status, double *bound )
4500
4501 //****************************************************************************80
4502 //
4503 // Purpose:
4504 //
4505 // CDFPOI evaluates the CDF of the Poisson distribution.
4506 //
4507 // Discussion:
4508 //
4509 // This routine calculates any one parameter of the Poisson distribution
4510 // given the others.
4511 //
4512 // The value P of the cumulative distribution function is calculated
4513 // directly.
4514 //
4515 // Computation of other parameters involve a seach for a value that
4516 // produces the desired value of P. The search relies on the
4517 // monotonicity of P with respect to the other parameters.
4518 //
4519 // Reference:
4520 //
4521 // Milton Abramowitz and Irene Stegun,
4522 // Handbook of Mathematical Functions
4523 // 1966, Formula 26.4.21.
4524 //
4525 // Parameters:
4526 //
4527 // Input, int *WHICH, indicates which argument is to be calculated
4528 // from the others.
4529 // 1: Calculate P and Q from S and XLAM;
4530 // 2: Calculate A from P, Q and XLAM;
4531 // 3: Calculate XLAM from P, Q and S.
4532 //
4533 // Input/output, double *P, the cumulation from 0 to S of the
4534 // Poisson density. Whether this is an input or output value, it will
4535 // lie in the range [0,1].
4536 //
4537 // Input/output, double *Q, equal to 1-P. If Q is an input
4538 // value, it should lie in the range [0,1]. If Q is an output value,
4539 // it will lie in the range [0,1].
4540 //
4541 // Input/output, double *S, the upper limit of cumulation of
4542 // the Poisson CDF. If this is an input value, it should lie in
4543 // the range: [0, +infinity). If it is an output value, it will be
4544 // searched for in the range: [0,1.0D+300].
4545 //
4546 // Input/output, double *XLAM, the mean of the Poisson
4547 // distribution. If this is an input value, it should lie in the range
4548 // [0, +infinity). If it is an output value, it will be searched for
4549 // in the range: [0,1E300].
4550 //
4551 // Output, int *STATUS, reports the status of the computation.
4552 // 0, if the calculation completed correctly;
4553 // -I, if the input parameter number I is out of range;
4554 // +1, if the answer appears to be lower than lowest search bound;
4555 // +2, if the answer appears to be higher than greatest search bound;
4556 // +3, if P + Q /= 1.
4557 //
4558 // Output, double *BOUND, is only defined if STATUS is nonzero.
4559 // If STATUS is negative, then this is the value exceeded by parameter I.
4560 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4561 //
4562 {
4563 # define tol (1.0e-8)
4564 # define atol (1.0e-50)
4565 # define inf 1.0e300
4566
4567 static int K1 = 1;
4568 static double K2 = 0.0e0;
4569 static double K4 = 0.5e0;
4570 static double K5 = 5.0e0;
4571 static double fx,cum,ccum,pq;
4572 static unsigned long qhi,qleft,qporq;
4573 static double T3,T6,T7,T8,T9,T10;
4574
4575 *status = 0;
4576 *bound = 0.0;
4577 //
4578 // Check arguments
4579 //
4580 if(!(*which < 1 || *which > 3)) goto S30;
4581 if(!(*which < 1)) goto S10;
4582 *bound = 1.0e0;
4583 goto S20;
4584 S10:
4585 *bound = 3.0e0;
4586 S20:
4587 *status = -1;
4588 return;
4589 S30:
4590 if(*which == 1) goto S70;
4591 //
4592 // P
4593 //
4594 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4595 if(!(*p < 0.0e0)) goto S40;
4596 *bound = 0.0e0;
4597 goto S50;
4598 S40:
4599 *bound = 1.0e0;
4600 S50:
4601 *status = -2;
4602 return;
4603 S70:
4604 S60:
4605 if(*which == 1) goto S110;
4606 //
4607 // Q
4608 //
4609 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4610 if(!(*q <= 0.0e0)) goto S80;
4611 *bound = 0.0e0;
4612 goto S90;
4613 S80:
4614 *bound = 1.0e0;
4615 S90:
4616 *status = -3;
4617 return;
4618 S110:
4619 S100:
4620 if(*which == 2) goto S130;
4621 //
4622 // S
4623 //
4624 if(!(*s < 0.0e0)) goto S120;
4625 *bound = 0.0e0;
4626 *status = -4;
4627 return;
4628 S130:
4629 S120:
4630 if(*which == 3) goto S150;
4631 //
4632 // XLAM
4633 //
4634 if(!(*xlam < 0.0e0)) goto S140;
4635 *bound = 0.0e0;
4636 *status = -5;
4637 return;
4638 S150:
4639 S140:
4640 if(*which == 1) goto S190;
4641 //
4642 // P + Q
4643 //
4644 pq = *p+*q;
4645 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S180;
4646 if(!(pq < 0.0e0)) goto S160;
4647 *bound = 0.0e0;
4648 goto S170;
4649 S160:
4650 *bound = 1.0e0;
4651 S170:
4652 *status = 3;
4653 return;
4654 S190:
4655 S180:
4656 if(!(*which == 1)) qporq = *p <= *q;
4657 //
4658 // Select the minimum of P or Q
4659 // Calculate ANSWERS
4660 //
4661 if(1 == *which) {
4662 //
4663 // Calculating P
4664 //
4665 cumpoi(s,xlam,p,q);
4666 *status = 0;
4667 }
4668 else if(2 == *which) {
4669 //
4670 // Calculating S
4671 //
4672 *s = 5.0e0;
4673 T3 = inf;
4674 T6 = atol;
4675 T7 = tol;
4676 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4677 *status = 0;
4678 dinvr(status,s,&fx,&qleft,&qhi);
4679 S200:
4680 if(!(*status == 1)) goto S230;
4681 cumpoi(s,xlam,&cum,&ccum);
4682 if(!qporq) goto S210;
4683 fx = cum-*p;
4684 goto S220;
4685 S210:
4686 fx = ccum-*q;
4687 S220:
4688 dinvr(status,s,&fx,&qleft,&qhi);
4689 goto S200;
4690 S230:
4691 if(!(*status == -1)) goto S260;
4692 if(!qleft) goto S240;
4693 *status = 1;
4694 *bound = 0.0e0;
4695 goto S250;
4696 S240:
4697 *status = 2;
4698 *bound = inf;
4699 S260:
4700 S250:
4701 ;
4702 }
4703 else if(3 == *which) {
4704 //
4705 // Calculating XLAM
4706 //
4707 *xlam = 5.0e0;
4708 T8 = inf;
4709 T9 = atol;
4710 T10 = tol;
4711 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4712 *status = 0;
4713 dinvr(status,xlam,&fx,&qleft,&qhi);
4714 S270:
4715 if(!(*status == 1)) goto S300;
4716 cumpoi(s,xlam,&cum,&ccum);
4717 if(!qporq) goto S280;
4718 fx = cum-*p;
4719 goto S290;
4720 S280:
4721 fx = ccum-*q;
4722 S290:
4723 dinvr(status,xlam,&fx,&qleft,&qhi);
4724 goto S270;
4725 S300:
4726 if(!(*status == -1)) goto S330;
4727 if(!qleft) goto S310;
4728 *status = 1;
4729 *bound = 0.0e0;
4730 goto S320;
4731 S310:
4732 *status = 2;
4733 *bound = inf;
4734 S320:
4735 ;
4736 }
4737 S330:
4738 return;
4739 # undef tol
4740 # undef atol
4741 # undef inf
4742 }
4743 //****************************************************************************80
4744
cdft(int * which,double * p,double * q,double * t,double * df,int * status,double * bound)4745 void cdft ( int *which, double *p, double *q, double *t, double *df,
4746 int *status, double *bound )
4747
4748 //****************************************************************************80
4749 //
4750 // Purpose:
4751 //
4752 // CDFT evaluates the CDF of the T distribution.
4753 //
4754 // Discussion:
4755 //
4756 // This routine calculates any one parameter of the T distribution
4757 // given the others.
4758 //
4759 // The value P of the cumulative distribution function is calculated
4760 // directly.
4761 //
4762 // Computation of other parameters involve a seach for a value that
4763 // produces the desired value of P. The search relies on the
4764 // monotonicity of P with respect to the other parameters.
4765 //
4766 // The original version of this routine allowed the search interval
4767 // to extend from -1.0E+300 to +1.0E+300, which is fine until you
4768 // try to evaluate a function at such a point!
4769 //
4770 // Reference:
4771 //
4772 // Milton Abramowitz and Irene Stegun,
4773 // Handbook of Mathematical Functions
4774 // 1966, Formula 26.5.27.
4775 //
4776 // Parameters:
4777 //
4778 // Input, int *WHICH, indicates which argument is to be calculated
4779 // from the others.
4780 // 1 : Calculate P and Q from T and DF;
4781 // 2 : Calculate T from P, Q and DF;
4782 // 3 : Calculate DF from P, Q and T.
4783 //
4784 // Input/output, double *P, the integral from -infinity to T of
4785 // the T-density. Whether an input or output value, this will lie in the
4786 // range [0,1].
4787 //
4788 // Input/output, double *Q, equal to 1-P. If Q is an input
4789 // value, it should lie in the range [0,1]. If Q is an output value,
4790 // it will lie in the range [0,1].
4791 //
4792 // Input/output, double *T, the upper limit of integration of
4793 // the T-density. If this is an input value, it may have any value.
4794 // It it is an output value, it will be searched for in the range
4795 // [ -1.0D+30, 1.0D+30 ].
4796 //
4797 // Input/output, double *DF, the number of degrees of freedom
4798 // of the T distribution. If this is an input value, it should lie
4799 // in the range: (0 , +infinity). If it is an output value, it will be
4800 // searched for in the range: [1, 1.0D+10].
4801 //
4802 // Output, int *STATUS, reports the status of the computation.
4803 // 0, if the calculation completed correctly;
4804 // -I, if the input parameter number I is out of range;
4805 // +1, if the answer appears to be lower than lowest search bound;
4806 // +2, if the answer appears to be higher than greatest search bound;
4807 // +3, if P + Q /= 1.
4808 //
4809 // Output, double *BOUND, is only defined if STATUS is nonzero.
4810 // If STATUS is negative, then this is the value exceeded by parameter I.
4811 // if STATUS is 1 or 2, this is the search bound that was exceeded.
4812 //
4813 {
4814 # define tol (1.0e-8)
4815 # define atol (1.0e-50)
4816 # define zero (1.0e-300)
4817 # define inf 1.0e30
4818 # define maxdf 1.0e10
4819
4820 static int K1 = 1;
4821 static double K4 = 0.5e0;
4822 static double K5 = 5.0e0;
4823 static double fx,cum,ccum,pq;
4824 static unsigned long qhi,qleft,qporq;
4825 static double T2,T3,T6,T7,T8,T9,T10,T11;
4826
4827 *status = 0;
4828 *bound = 0.0;
4829 //
4830 // Check arguments
4831 //
4832 if(!(*which < 1 || *which > 3)) goto S30;
4833 if(!(*which < 1)) goto S10;
4834 *bound = 1.0e0;
4835 goto S20;
4836 S10:
4837 *bound = 3.0e0;
4838 S20:
4839 *status = -1;
4840 return;
4841 S30:
4842 if(*which == 1) goto S70;
4843 //
4844 // P
4845 //
4846 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4847 if(!(*p <= 0.0e0)) goto S40;
4848 *bound = 0.0e0;
4849 goto S50;
4850 S40:
4851 *bound = 1.0e0;
4852 S50:
4853 *status = -2;
4854 return;
4855 S70:
4856 S60:
4857 if(*which == 1) goto S110;
4858 //
4859 // Q
4860 //
4861 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4862 if(!(*q <= 0.0e0)) goto S80;
4863 *bound = 0.0e0;
4864 goto S90;
4865 S80:
4866 *bound = 1.0e0;
4867 S90:
4868 *status = -3;
4869 return;
4870 S110:
4871 S100:
4872 if(*which == 3) goto S130;
4873 //
4874 // DF
4875 //
4876 if(!(*df <= 0.0e0)) goto S120;
4877 *bound = 0.0e0;
4878 *status = -5;
4879 return;
4880 S130:
4881 S120:
4882 if(*which == 1) goto S170;
4883 //
4884 // P + Q
4885 //
4886 pq = *p+*q;
4887 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*dpmpar(&K1))) goto S160;
4888 if(!(pq < 0.0e0)) goto S140;
4889 *bound = 0.0e0;
4890 goto S150;
4891 S140:
4892 *bound = 1.0e0;
4893 S150:
4894 *status = 3;
4895 return;
4896 S170:
4897 S160:
4898 if(!(*which == 1)) qporq = *p <= *q;
4899 //
4900 // Select the minimum of P or Q
4901 // Calculate ANSWERS
4902 //
4903 if(1 == *which) {
4904 //
4905 // Computing P and Q
4906 //
4907 cumt(t,df,p,q);
4908 *status = 0;
4909 }
4910 else if(2 == *which) {
4911 //
4912 // Computing T
4913 // .. Get initial approximation for T
4914 //
4915 *t = dt1(p,q,df);
4916 T2 = -inf;
4917 T3 = inf;
4918 T6 = atol;
4919 T7 = tol;
4920 dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7);
4921 *status = 0;
4922 dinvr(status,t,&fx,&qleft,&qhi);
4923 S180:
4924 if(!(*status == 1)) goto S210;
4925 cumt(t,df,&cum,&ccum);
4926 if(!qporq) goto S190;
4927 fx = cum-*p;
4928 goto S200;
4929 S190:
4930 fx = ccum-*q;
4931 S200:
4932 dinvr(status,t,&fx,&qleft,&qhi);
4933 goto S180;
4934 S210:
4935 if(!(*status == -1)) goto S240;
4936 if(!qleft) goto S220;
4937 *status = 1;
4938 *bound = -inf;
4939 goto S230;
4940 S220:
4941 *status = 2;
4942 *bound = inf;
4943 S240:
4944 S230:
4945 ;
4946 }
4947 else if(3 == *which) {
4948 //
4949 // Computing DF
4950 //
4951 *df = 5.0e0;
4952 T8 = zero;
4953 T9 = maxdf;
4954 T10 = atol;
4955 T11 = tol;
4956 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
4957 *status = 0;
4958 dinvr(status,df,&fx,&qleft,&qhi);
4959 S250:
4960 if(!(*status == 1)) goto S280;
4961 cumt(t,df,&cum,&ccum);
4962 if(!qporq) goto S260;
4963 fx = cum-*p;
4964 goto S270;
4965 S260:
4966 fx = ccum-*q;
4967 S270:
4968 dinvr(status,df,&fx,&qleft,&qhi);
4969 goto S250;
4970 S280:
4971 if(!(*status == -1)) goto S310;
4972 if(!qleft) goto S290;
4973 *status = 1;
4974 *bound = zero;
4975 goto S300;
4976 S290:
4977 *status = 2;
4978 *bound = maxdf;
4979 S300:
4980 ;
4981 }
4982 S310:
4983 return;
4984 # undef tol
4985 # undef atol
4986 # undef zero
4987 # undef inf
4988 # undef maxdf
4989 }
4990 //****************************************************************************80
4991
chi_noncentral_cdf_values(int * n_data,double * x,double * lambda,int * df,double * cdf)4992 void chi_noncentral_cdf_values ( int *n_data, double *x, double *lambda,
4993 int *df, double *cdf )
4994
4995 //****************************************************************************80
4996 //
4997 // Purpose:
4998 //
4999 // CHI_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF.
5000 //
5001 // Discussion:
5002 //
5003 // The CDF of the noncentral chi square distribution can be evaluated
5004 // within Mathematica by commands such as:
5005 //
5006 // Needs["Statistics`ContinuousDistributions`"]
5007 // CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ]
5008 //
5009 // Modified:
5010 //
5011 // 12 June 2004
5012 //
5013 // Author:
5014 //
5015 // John Burkardt
5016 //
5017 // Reference:
5018 //
5019 // Stephen Wolfram,
5020 // The Mathematica Book,
5021 // Fourth Edition,
5022 // Wolfram Media / Cambridge University Press, 1999.
5023 //
5024 // Parameters:
5025 //
5026 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
5027 // first call. On each call, the routine increments N_DATA by 1, and
5028 // returns the corresponding data; when there is no more data, the
5029 // output value of N_DATA will be 0 again.
5030 //
5031 // Output, double *X, the argument of the function.
5032 //
5033 // Output, double *LAMBDA, the noncentrality parameter.
5034 //
5035 // Output, int *DF, the number of degrees of freedom.
5036 //
5037 // Output, double *CDF, the noncentral chi CDF.
5038 //
5039 {
5040 # define N_MAX 27
5041
5042 double cdf_vec[N_MAX] = {
5043 0.839944E+00, 0.695906E+00, 0.535088E+00,
5044 0.764784E+00, 0.620644E+00, 0.469167E+00,
5045 0.307088E+00, 0.220382E+00, 0.150025E+00,
5046 0.307116E-02, 0.176398E-02, 0.981679E-03,
5047 0.165175E-01, 0.202342E-03, 0.498448E-06,
5048 0.151325E-01, 0.209041E-02, 0.246502E-03,
5049 0.263684E-01, 0.185798E-01, 0.130574E-01,
5050 0.583804E-01, 0.424978E-01, 0.308214E-01,
5051 0.105788E+00, 0.794084E-01, 0.593201E-01 };
5052 int df_vec[N_MAX] = {
5053 1, 2, 3,
5054 1, 2, 3,
5055 1, 2, 3,
5056 1, 2, 3,
5057 60, 80, 100,
5058 1, 2, 3,
5059 10, 10, 10,
5060 10, 10, 10,
5061 10, 10, 10 };
5062 double lambda_vec[N_MAX] = {
5063 0.5E+00, 0.5E+00, 0.5E+00,
5064 1.0E+00, 1.0E+00, 1.0E+00,
5065 5.0E+00, 5.0E+00, 5.0E+00,
5066 20.0E+00, 20.0E+00, 20.0E+00,
5067 30.0E+00, 30.0E+00, 30.0E+00,
5068 5.0E+00, 5.0E+00, 5.0E+00,
5069 2.0E+00, 3.0E+00, 4.0E+00,
5070 2.0E+00, 3.0E+00, 4.0E+00,
5071 2.0E+00, 3.0E+00, 4.0E+00 };
5072 double x_vec[N_MAX] = {
5073 3.000E+00, 3.000E+00, 3.000E+00,
5074 3.000E+00, 3.000E+00, 3.000E+00,
5075 3.000E+00, 3.000E+00, 3.000E+00,
5076 3.000E+00, 3.000E+00, 3.000E+00,
5077 60.000E+00, 60.000E+00, 60.000E+00,
5078 0.050E+00, 0.050E+00, 0.050E+00,
5079 4.000E+00, 4.000E+00, 4.000E+00,
5080 5.000E+00, 5.000E+00, 5.000E+00,
5081 6.000E+00, 6.000E+00, 6.000E+00 };
5082
5083 if ( *n_data < 0 )
5084 {
5085 *n_data = 0;
5086 }
5087
5088 *n_data = *n_data + 1;
5089
5090 if ( N_MAX < *n_data )
5091 {
5092 *n_data = 0;
5093 *x = 0.0E+00;
5094 *lambda = 0.0E+00;
5095 *df = 0;
5096 *cdf = 0.0E+00;
5097 }
5098 else
5099 {
5100 *x = x_vec[*n_data-1];
5101 *lambda = lambda_vec[*n_data-1];
5102 *df = df_vec[*n_data-1];
5103 *cdf = cdf_vec[*n_data-1];
5104 }
5105
5106 return;
5107 # undef N_MAX
5108 }
5109 //****************************************************************************80
5110
chi_square_cdf_values(int * n_data,int * a,double * x,double * fx)5111 void chi_square_cdf_values ( int *n_data, int *a, double *x, double *fx )
5112
5113 //****************************************************************************80
5114 //
5115 // Purpose:
5116 //
5117 // CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF.
5118 //
5119 // Discussion:
5120 //
5121 // The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by
5122 // commands like:
5123 //
5124 // Needs["Statistics`ContinuousDistributions`"]
5125 // CDF[ChiSquareDistribution[DF], X ]
5126 //
5127 // Modified:
5128 //
5129 // 11 June 2004
5130 //
5131 // Author:
5132 //
5133 // John Burkardt
5134 //
5135 // Reference:
5136 //
5137 // Milton Abramowitz and Irene Stegun,
5138 // Handbook of Mathematical Functions,
5139 // US Department of Commerce, 1964.
5140 //
5141 // Stephen Wolfram,
5142 // The Mathematica Book,
5143 // Fourth Edition,
5144 // Wolfram Media / Cambridge University Press, 1999.
5145 //
5146 // Parameters:
5147 //
5148 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
5149 // first call. On each call, the routine increments N_DATA by 1, and
5150 // returns the corresponding data; when there is no more data, the
5151 // output value of N_DATA will be 0 again.
5152 //
5153 // Output, int *A, the parameter of the function.
5154 //
5155 // Output, double *X, the argument of the function.
5156 //
5157 // Output, double *FX, the value of the function.
5158 //
5159 {
5160 # define N_MAX 21
5161
5162 int a_vec[N_MAX] = {
5163 1, 2, 1, 2,
5164 1, 2, 3, 4,
5165 1, 2, 3, 4,
5166 5, 3, 3, 3,
5167 3, 3, 10, 10,
5168 10 };
5169 double fx_vec[N_MAX] = {
5170 0.0796557E+00, 0.00498752E+00, 0.112463E+00, 0.00995017E+00,
5171 0.472911E+00, 0.181269E+00, 0.0597575E+00, 0.0175231E+00,
5172 0.682689E+00, 0.393469E+00, 0.198748E+00, 0.090204E+00,
5173 0.0374342E+00, 0.427593E+00, 0.608375E+00, 0.738536E+00,
5174 0.828203E+00, 0.88839E+00, 0.000172116E+00, 0.00365985E+00,
5175 0.0185759E+00 };
5176 double x_vec[N_MAX] = {
5177 0.01E+00, 0.01E+00, 0.02E+00, 0.02E+00,
5178 0.40E+00, 0.40E+00, 0.40E+00, 0.40E+00,
5179 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
5180 1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,
5181 5.00E+00, 6.00E+00, 1.00E+00, 2.00E+00,
5182 3.00E+00 };
5183
5184 if ( *n_data < 0 )
5185 {
5186 *n_data = 0;
5187 }
5188
5189 *n_data = *n_data + 1;
5190
5191 if ( N_MAX < *n_data )
5192 {
5193 *n_data = 0;
5194 *a = 0;
5195 *x = 0.0E+00;
5196 *fx = 0.0E+00;
5197 }
5198 else
5199 {
5200 *a = a_vec[*n_data-1];
5201 *x = x_vec[*n_data-1];
5202 *fx = fx_vec[*n_data-1];
5203 }
5204 return;
5205 # undef N_MAX
5206 }
5207 //****************************************************************************80
5208
cumbet(double * x,double * y,double * a,double * b,double * cum,double * ccum)5209 void cumbet ( double *x, double *y, double *a, double *b, double *cum,
5210 double *ccum )
5211
5212 //****************************************************************************80
5213 //
5214 // Purpose:
5215 //
5216 // CUMBET evaluates the cumulative incomplete beta distribution.
5217 //
5218 // Discussion:
5219 //
5220 // This routine calculates the CDF to X of the incomplete beta distribution
5221 // with parameters A and B. This is the integral from 0 to x
5222 // of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
5223 //
5224 // Modified:
5225 //
5226 // 14 March 2006
5227 //
5228 // Reference:
5229 //
5230 // A R Didonato and Alfred Morris,
5231 // Algorithm 708:
5232 // Significant Digit Computation of the Incomplete Beta Function Ratios.
5233 // ACM Transactions on Mathematical Software,
5234 // Volume 18, Number 3, September 1992, pages 360-373.
5235 //
5236 // Parameters:
5237 //
5238 // Input, double *X, the upper limit of integration.
5239 //
5240 // Input, double *Y, the value of 1-X.
5241 //
5242 // Input, double *A, *B, the parameters of the distribution.
5243 //
5244 // Output, double *CUM, *CCUM, the values of the cumulative
5245 // density function and complementary cumulative density function.
5246 //
5247 {
5248 static int ierr;
5249
5250 if ( *x <= 0.0 )
5251 {
5252 *cum = 0.0;
5253 *ccum = 1.0;
5254 }
5255 else if ( *y <= 0.0 )
5256 {
5257 *cum = 1.0;
5258 *ccum = 0.0;
5259 }
5260 else
5261 {
5262 beta_inc ( a, b, x, y, cum, ccum, &ierr );
5263 }
5264 return;
5265 }
5266 //****************************************************************************80
5267
cumbin(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5268 void cumbin ( double *s, double *xn, double *pr, double *ompr,
5269 double *cum, double *ccum )
5270
5271 //****************************************************************************80
5272 //
5273 // Purpose:
5274 //
5275 // CUMBIN evaluates the cumulative binomial distribution.
5276 //
5277 // Discussion:
5278 //
5279 // This routine returns the probability of 0 to S successes in XN binomial
5280 // trials, each of which has a probability of success, PR.
5281 //
5282 // Modified:
5283 //
5284 // 14 March 2006
5285 //
5286 // Reference:
5287 //
5288 // Milton Abramowitz and Irene Stegun,
5289 // Handbook of Mathematical Functions
5290 // 1966, Formula 26.5.24.
5291 //
5292 // Parameters:
5293 //
5294 // Input, double *S, the upper limit of summation.
5295 //
5296 // Input, double *XN, the number of trials.
5297 //
5298 // Input, double *PR, the probability of success in one trial.
5299 //
5300 // Input, double *OMPR, equals ( 1 - PR ).
5301 //
5302 // Output, double *CUM, the cumulative binomial distribution.
5303 //
5304 // Output, double *CCUM, the complement of the cumulative
5305 // binomial distribution.
5306 //
5307 {
5308 static double T1,T2;
5309
5310 if ( *s < *xn )
5311 {
5312 T1 = *s + 1.0;
5313 T2 = *xn - *s;
5314 cumbet ( pr, ompr, &T1, &T2, ccum, cum );
5315 }
5316 else
5317 {
5318 *cum = 1.0;
5319 *ccum = 0.0;
5320 }
5321 return;
5322 }
5323 //****************************************************************************80
5324
cumchi(double * x,double * df,double * cum,double * ccum)5325 void cumchi ( double *x, double *df, double *cum, double *ccum )
5326
5327 //****************************************************************************80
5328 //
5329 // Purpose:
5330 //
5331 // CUMCHI evaluates the cumulative chi-square distribution.
5332 //
5333 // Parameters:
5334 //
5335 // Input, double *X, the upper limit of integration.
5336 //
5337 // Input, double *DF, the degrees of freedom of the
5338 // chi-square distribution.
5339 //
5340 // Output, double *CUM, the cumulative chi-square distribution.
5341 //
5342 // Output, double *CCUM, the complement of the cumulative
5343 // chi-square distribution.
5344 //
5345 {
5346 static double a;
5347 static double xx;
5348
5349 a = *df * 0.5;
5350 xx = *x * 0.5;
5351 cumgam ( &xx, &a, cum, ccum );
5352 return;
5353 }
5354 //****************************************************************************80
5355
cumchn(double * x,double * df,double * pnonc,double * cum,double * ccum)5356 void cumchn ( double *x, double *df, double *pnonc, double *cum,
5357 double *ccum )
5358
5359 //****************************************************************************80
5360 //
5361 // Purpose:
5362 //
5363 // CUMCHN evaluates the cumulative noncentral chi-square distribution.
5364 //
5365 // Discussion:
5366 //
5367 // Calculates the cumulative noncentral chi-square
5368 // distribution, i.e., the probability that a random variable
5369 // which follows the noncentral chi-square distribution, with
5370 // noncentrality parameter PNONC and continuous degrees of
5371 // freedom DF, is less than or equal to X.
5372 //
5373 // Reference:
5374 //
5375 // Milton Abramowitz and Irene Stegun,
5376 // Handbook of Mathematical Functions
5377 // 1966, Formula 26.4.25.
5378 //
5379 // Parameters:
5380 //
5381 // Input, double *X, the upper limit of integration.
5382 //
5383 // Input, double *DF, the number of degrees of freedom.
5384 //
5385 // Input, double *PNONC, the noncentrality parameter of
5386 // the noncentral chi-square distribution.
5387 //
5388 // Output, double *CUM, *CCUM, the CDF and complementary
5389 // CDF of the noncentral chi-square distribution.
5390 //
5391 // Local Parameters:
5392 //
5393 // Local, double EPS, the convergence criterion. The sum
5394 // stops when a term is less than EPS*SUM.
5395 //
5396 // Local, int NTIRED, the maximum number of terms to be evaluated
5397 // in each sum.
5398 //
5399 // Local, bool QCONV, is TRUE if convergence was achieved, that is,
5400 // the program did not stop on NTIRED criterion.
5401 //
5402 {
5403 # define dg(i) (*df+2.0e0*(double)(i))
5404 # define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum)
5405 # define qtired(i) (int)((i) > ntired)
5406
5407 static double eps = 1.0e-5;
5408 static int ntired = 1000;
5409 static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum,
5410 sumadj,term,wt,xnonc;
5411 static int i,icent,iterb,iterf;
5412 static double T1,T2,T3;
5413
5414 if(!(*x <= 0.0e0)) goto S10;
5415 *cum = 0.0e0;
5416 *ccum = 1.0e0;
5417 return;
5418 S10:
5419 if(!(*pnonc <= 1.0e-10)) goto S20;
5420 //
5421 // When non-centrality parameter is (essentially) zero,
5422 // use cumulative chi-square distribution
5423 //
5424 cumchi(x,df,cum,ccum);
5425 return;
5426 S20:
5427 xnonc = *pnonc/2.0e0;
5428 //
5429 // The following code calculates the weight, chi-square, and
5430 // adjustment term for the central term in the infinite series.
5431 // The central term is the one in which the poisson weight is
5432 // greatest. The adjustment term is the amount that must
5433 // be subtracted from the chi-square to move up two degrees
5434 // of freedom.
5435 //
5436 icent = fifidint(xnonc);
5437 if(icent == 0) icent = 1;
5438 chid2 = *x/2.0e0;
5439 //
5440 // Calculate central weight term
5441 //
5442 T1 = (double)(icent+1);
5443 lfact = gamma_log ( &T1 );
5444 lcntwt = -xnonc+(double)icent*log(xnonc)-lfact;
5445 centwt = exp(lcntwt);
5446 //
5447 // Calculate central chi-square
5448 //
5449 T2 = dg(icent);
5450 cumchi(x,&T2,&pcent,ccum);
5451 //
5452 // Calculate central adjustment term
5453 //
5454 dfd2 = dg(icent)/2.0e0;
5455 T3 = 1.0e0+dfd2;
5456 lfact = gamma_log ( &T3 );
5457 lcntaj = dfd2*log(chid2)-chid2-lfact;
5458 centaj = exp(lcntaj);
5459 sum = centwt*pcent;
5460 //
5461 // Sum backwards from the central term towards zero.
5462 // Quit whenever either
5463 // (1) the zero term is reached, or
5464 // (2) the term gets small relative to the sum, or
5465 // (3) More than NTIRED terms are totaled.
5466 //
5467 iterb = 0;
5468 sumadj = 0.0e0;
5469 adj = centaj;
5470 wt = centwt;
5471 i = icent;
5472 goto S40;
5473 S30:
5474 if(qtired(iterb) || qsmall(term) || i == 0) goto S50;
5475 S40:
5476 dfd2 = dg(i)/2.0e0;
5477 //
5478 // Adjust chi-square for two fewer degrees of freedom.
5479 // The adjusted value ends up in PTERM.
5480 //
5481 adj = adj*dfd2/chid2;
5482 sumadj = sumadj + adj;
5483 pterm = pcent+sumadj;
5484 //
5485 // Adjust poisson weight for J decreased by one
5486 //
5487 wt *= ((double)i/xnonc);
5488 term = wt*pterm;
5489 sum = sum + term;
5490 i -= 1;
5491 iterb = iterb + 1;
5492 goto S30;
5493 S50:
5494 iterf = 0;
5495 //
5496 // Now sum forward from the central term towards infinity.
5497 // Quit when either
5498 // (1) the term gets small relative to the sum, or
5499 // (2) More than NTIRED terms are totaled.
5500 //
5501 sumadj = adj = centaj;
5502 wt = centwt;
5503 i = icent;
5504 goto S70;
5505 S60:
5506 if(qtired(iterf) || qsmall(term)) goto S80;
5507 S70:
5508 //
5509 // Update weights for next higher J
5510 //
5511 wt *= (xnonc/(double)(i+1));
5512 //
5513 // Calculate PTERM and add term to sum
5514 //
5515 pterm = pcent-sumadj;
5516 term = wt*pterm;
5517 sum = sum + term;
5518 //
5519 // Update adjustment term for DF for next iteration
5520 //
5521 i = i + 1;
5522 dfd2 = dg(i)/2.0e0;
5523 adj = adj*chid2/dfd2;
5524 sumadj = sum + adj;
5525 iterf = iterf + 1;
5526 goto S60;
5527 S80:
5528 *cum = sum;
5529 *ccum = 0.5e0+(0.5e0-*cum);
5530 return;
5531 # undef dg
5532 # undef qsmall
5533 # undef qtired
5534 }
5535 //****************************************************************************80
5536
cumf(double * f,double * dfn,double * dfd,double * cum,double * ccum)5537 void cumf ( double *f, double *dfn, double *dfd, double *cum, double *ccum )
5538
5539 //****************************************************************************80
5540 //
5541 // Purpose:
5542 //
5543 // CUMF evaluates the cumulative F distribution.
5544 //
5545 // Discussion:
5546 //
5547 // CUMF computes the integral from 0 to F of the F density with DFN
5548 // numerator and DFD denominator degrees of freedom.
5549 //
5550 // Reference:
5551 //
5552 // Milton Abramowitz and Irene Stegun,
5553 // Handbook of Mathematical Functions
5554 // 1966, Formula 26.5.28.
5555 //
5556 // Parameters:
5557 //
5558 // Input, double *F, the upper limit of integration.
5559 //
5560 // Input, double *DFN, *DFD, the number of degrees of
5561 // freedom for the numerator and denominator.
5562 //
5563 // Output, double *CUM, *CCUM, the value of the F CDF and
5564 // the complementary F CDF.
5565 //
5566 {
5567 # define half 0.5e0
5568 # define done 1.0e0
5569
5570 static double dsum,prod,xx,yy;
5571 static int ierr;
5572 static double T1,T2;
5573
5574 if(!(*f <= 0.0e0)) goto S10;
5575 *cum = 0.0e0;
5576 *ccum = 1.0e0;
5577 return;
5578 S10:
5579 prod = *dfn**f;
5580 //
5581 // XX is such that the incomplete beta with parameters
5582 // DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
5583 // YY is 1 - XX
5584 // Calculate the smaller of XX and YY accurately
5585 //
5586 dsum = *dfd+prod;
5587 xx = *dfd/dsum;
5588
5589 if ( xx > half )
5590 {
5591 yy = prod/dsum;
5592 xx = done-yy;
5593 }
5594 else
5595 {
5596 yy = done-xx;
5597 }
5598
5599 T1 = *dfd*half;
5600 T2 = *dfn*half;
5601 beta_inc ( &T1, &T2, &xx, &yy, ccum, cum, &ierr );
5602 return;
5603 # undef half
5604 # undef done
5605 }
5606 //****************************************************************************80
5607
cumfnc(double * f,double * dfn,double * dfd,double * pnonc,double * cum,double * ccum)5608 void cumfnc ( double *f, double *dfn, double *dfd, double *pnonc,
5609 double *cum, double *ccum )
5610
5611 //****************************************************************************80
5612 //
5613 // Purpose:
5614 //
5615 // CUMFNC evaluates the cumulative noncentral F distribution.
5616 //
5617 // Discussion:
5618 //
5619 // This routine computes the noncentral F distribution with DFN and DFD
5620 // degrees of freedom and noncentrality parameter PNONC.
5621 //
5622 // The series is calculated backward and forward from J = LAMBDA/2
5623 // (this is the term with the largest Poisson weight) until
5624 // the convergence criterion is met.
5625 //
5626 // The sum continues until a succeeding term is less than EPS
5627 // times the sum (or the sum is less than 1.0e-20). EPS is
5628 // set to 1.0e-4 in a data statement which can be changed.
5629 //
5630 //
5631 // The original version of this routine allowed the input values
5632 // of DFN and DFD to be negative (nonsensical) or zero (which
5633 // caused numerical overflow.) I have forced both these values
5634 // to be at least 1.
5635 //
5636 // Modified:
5637 //
5638 // 15 June 2004
5639 //
5640 // Reference:
5641 //
5642 // Milton Abramowitz and Irene Stegun,
5643 // Handbook of Mathematical Functions
5644 // 1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20.
5645 //
5646 // Parameters:
5647 //
5648 // Input, double *F, the upper limit of integration.
5649 //
5650 // Input, double *DFN, *DFD, the number of degrees of freedom
5651 // in the numerator and denominator. Both DFN and DFD must be positive,
5652 // and normally would be integers. This routine requires that they
5653 // be no less than 1.
5654 //
5655 // Input, double *PNONC, the noncentrality parameter.
5656 //
5657 // Output, double *CUM, *CCUM, the noncentral F CDF and
5658 // complementary CDF.
5659 //
5660 {
5661 # define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)
5662 # define half 0.5e0
5663 # define done 1.0e0
5664
5665 static double eps = 1.0e-4;
5666 static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,
5667 upterm,xmult,xnonc;
5668 static int i,icent,ierr;
5669 static double T1,T2,T3,T4,T5,T6;
5670
5671 if(!(*f <= 0.0e0)) goto S10;
5672 *cum = 0.0e0;
5673 *ccum = 1.0e0;
5674 return;
5675 S10:
5676 if(!(*pnonc < 1.0e-10)) goto S20;
5677 //
5678 // Handle case in which the non-centrality parameter is
5679 // (essentially) zero.
5680 //
5681 cumf(f,dfn,dfd,cum,ccum);
5682 return;
5683 S20:
5684 xnonc = *pnonc/2.0e0;
5685 //
5686 // Calculate the central term of the poisson weighting factor.
5687 //
5688 icent = ( int ) xnonc;
5689 if(icent == 0) icent = 1;
5690 //
5691 // Compute central weight term
5692 //
5693 T1 = (double)(icent+1);
5694 centwt = exp(-xnonc+(double)icent*log(xnonc)- gamma_log ( &T1 ) );
5695 //
5696 // Compute central incomplete beta term
5697 // Assure that minimum of arg to beta and 1 - arg is computed
5698 // accurately.
5699 //
5700 prod = *dfn**f;
5701 dsum = *dfd+prod;
5702 yy = *dfd/dsum;
5703 if(yy > half) {
5704 xx = prod/dsum;
5705 yy = done-xx;
5706 }
5707 else xx = done-yy;
5708 T2 = *dfn*half+(double)icent;
5709 T3 = *dfd*half;
5710 beta_inc ( &T2, &T3, &xx, &yy, &betdn, &dummy, &ierr );
5711 adn = *dfn/2.0e0+(double)icent;
5712 aup = adn;
5713 b = *dfd/2.0e0;
5714 betup = betdn;
5715 sum = centwt*betdn;
5716 //
5717 // Now sum terms backward from icent until convergence or all done
5718 //
5719 xmult = centwt;
5720 i = icent;
5721 T4 = adn+b;
5722 T5 = adn+1.0e0;
5723 dnterm = exp( gamma_log ( &T4 ) - gamma_log ( &T5 )
5724 - gamma_log ( &b ) + adn * log ( xx ) + b * log(yy));
5725 S30:
5726 if(qsmall(xmult*betdn) || i <= 0) goto S40;
5727 xmult *= ((double)i/xnonc);
5728 i -= 1;
5729 adn -= 1.0;
5730 dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;
5731 betdn += dnterm;
5732 sum += (xmult*betdn);
5733 goto S30;
5734 S40:
5735 i = icent+1;
5736 //
5737 // Now sum forwards until convergence
5738 //
5739 xmult = centwt;
5740 if(aup-1.0+b == 0) upterm = exp(-gamma_log ( &aup )
5741 - gamma_log ( &b ) + (aup-1.0)*log(xx)+
5742 b*log(yy));
5743 else {
5744 T6 = aup-1.0+b;
5745 upterm = exp( gamma_log ( &T6 ) - gamma_log ( &aup )
5746 - gamma_log ( &b ) + (aup-1.0)*log(xx)+b*
5747 log(yy));
5748 }
5749 goto S60;
5750 S50:
5751 if(qsmall(xmult*betup)) goto S70;
5752 S60:
5753 xmult *= (xnonc/(double)i);
5754 i += 1;
5755 aup += 1.0;
5756 upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;
5757 betup -= upterm;
5758 sum += (xmult*betup);
5759 goto S50;
5760 S70:
5761 *cum = sum;
5762 *ccum = 0.5e0+(0.5e0-*cum);
5763 return;
5764 # undef qsmall
5765 # undef half
5766 # undef done
5767 }
5768 //****************************************************************************80
5769
cumgam(double * x,double * a,double * cum,double * ccum)5770 void cumgam ( double *x, double *a, double *cum, double *ccum )
5771
5772 //****************************************************************************80
5773 //
5774 // Purpose:
5775 //
5776 // CUMGAM evaluates the cumulative incomplete gamma distribution.
5777 //
5778 // Discussion:
5779 //
5780 // This routine computes the cumulative distribution function of the
5781 // incomplete gamma distribution, i.e., the integral from 0 to X of
5782 //
5783 // (1/GAM(A))*EXP(-T)*T**(A-1) DT
5784 //
5785 // where GAM(A) is the complete gamma function of A, i.e.,
5786 //
5787 // GAM(A) = integral from 0 to infinity of EXP(-T)*T**(A-1) DT
5788 //
5789 // Parameters:
5790 //
5791 // Input, double *X, the upper limit of integration.
5792 //
5793 // Input, double *A, the shape parameter of the incomplete
5794 // Gamma distribution.
5795 //
5796 // Output, double *CUM, *CCUM, the incomplete Gamma CDF and
5797 // complementary CDF.
5798 //
5799 {
5800 static int K1 = 0;
5801
5802 if(!(*x <= 0.0e0)) goto S10;
5803 *cum = 0.0e0;
5804 *ccum = 1.0e0;
5805 return;
5806 S10:
5807 gamma_inc ( a, x, cum, ccum, &K1 );
5808 //
5809 // Call gratio routine
5810 //
5811 return;
5812 }
5813 //****************************************************************************80
5814
cumnbn(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5815 void cumnbn ( double *s, double *xn, double *pr, double *ompr,
5816 double *cum, double *ccum )
5817
5818 //****************************************************************************80
5819 //
5820 // Purpose:
5821 //
5822 // CUMNBN evaluates the cumulative negative binomial distribution.
5823 //
5824 // Discussion:
5825 //
5826 // This routine returns the probability that there will be F or
5827 // fewer failures before there are S successes, with each binomial
5828 // trial having a probability of success PR.
5829 //
5830 // Prob(# failures = F | S successes, PR) =
5831 // ( S + F - 1 )
5832 // ( ) * PR^S * (1-PR)^F
5833 // ( F )
5834 //
5835 // Reference:
5836 //
5837 // Milton Abramowitz and Irene Stegun,
5838 // Handbook of Mathematical Functions
5839 // 1966, Formula 26.5.26.
5840 //
5841 // Parameters:
5842 //
5843 // Input, double *F, the number of failures.
5844 //
5845 // Input, double *S, the number of successes.
5846 //
5847 // Input, double *PR, *OMPR, the probability of success on
5848 // each binomial trial, and the value of (1-PR).
5849 //
5850 // Output, double *CUM, *CCUM, the negative binomial CDF,
5851 // and the complementary CDF.
5852 //
5853 {
5854 static double T1;
5855
5856 T1 = *s+1.e0;
5857 cumbet(pr,ompr,xn,&T1,cum,ccum);
5858 return;
5859 }
5860 //****************************************************************************80
5861
cumnor(double * arg,double * result,double * ccum)5862 void cumnor ( double *arg, double *result, double *ccum )
5863
5864 //****************************************************************************80
5865 //
5866 // Purpose:
5867 //
5868 // CUMNOR computes the cumulative normal distribution.
5869 //
5870 // Discussion:
5871 //
5872 // This function evaluates the normal distribution function:
5873 //
5874 // / x
5875 // 1 | -t*t/2
5876 // P(x) = ----------- | e dt
5877 // sqrt(2 pi) |
5878 // /-oo
5879 //
5880 // This transportable program uses rational functions that
5881 // theoretically approximate the normal distribution function to
5882 // at least 18 significant decimal digits. The accuracy achieved
5883 // depends on the arithmetic system, the compiler, the intrinsic
5884 // functions, and proper selection of the machine-dependent
5885 // constants.
5886 //
5887 // Author:
5888 //
5889 // William Cody
5890 // Mathematics and Computer Science Division
5891 // Argonne National Laboratory
5892 // Argonne, IL 60439
5893 //
5894 // Reference:
5895 //
5896 // William Cody,
5897 // Rational Chebyshev approximations for the error function,
5898 // Mathematics of Computation,
5899 // 1969, pages 631-637.
5900 //
5901 // William Cody,
5902 // Algorithm 715:
5903 // SPECFUN - A Portable FORTRAN Package of Special Function Routines
5904 // and Test Drivers,
5905 // ACM Transactions on Mathematical Software,
5906 // Volume 19, 1993, pages 22-32.
5907 //
5908 // Parameters:
5909 //
5910 // Input, double *ARG, the upper limit of integration.
5911 //
5912 // Output, double *CUM, *CCUM, the Normal density CDF and
5913 // complementary CDF.
5914 //
5915 // Local Parameters:
5916 //
5917 // Local, double EPS, the argument below which anorm(x)
5918 // may be represented by 0.5D+00 and above which x*x will not underflow.
5919 // A conservative value is the largest machine number X
5920 // such that 1.0D+00 + X = 1.0D+00 to machine precision.
5921 //
5922 {
5923 static double a[5] = {
5924 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03,
5925 1.8154981253343561249e04,6.5682337918207449113e-2
5926 };
5927 static double b[4] = {
5928 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04,
5929 4.5507789335026729956e04
5930 };
5931 static double c[9] = {
5932 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01,
5933 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03,
5934 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8
5935 };
5936 static double d[8] = {
5937 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03,
5938 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04,
5939 3.8912003286093271411e04,1.9685429676859990727e04
5940 };
5941 static double half = 0.5e0;
5942 static double p[6] = {
5943 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2,
5944 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2
5945 };
5946 static double one = 1.0e0;
5947 static double q[5] = {
5948 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2,
5949 3.78239633202758244e-3,7.29751555083966205e-5
5950 };
5951 static double sixten = 1.60e0;
5952 static double sqrpi = 3.9894228040143267794e-1;
5953 static double thrsh = 0.66291e0;
5954 static double root32 = 5.656854248e0;
5955 static double zero = 0.0e0;
5956 static int K1 = 1;
5957 static int K2 = 2;
5958 static int i;
5959 static double del,eps,temp,x,xden,xnum,y,xsq,min;
5960 //
5961 // Machine dependent constants
5962 //
5963 eps = dpmpar(&K1)*0.5e0;
5964 min = dpmpar(&K2);
5965 x = *arg;
5966 y = fabs(x);
5967 if(y <= thrsh) {
5968 //
5969 // Evaluate anorm for |X| <= 0.66291
5970 //
5971 xsq = zero;
5972 if(y > eps) xsq = x*x;
5973 xnum = a[4]*xsq;
5974 xden = xsq;
5975 for ( i = 0; i < 3; i++ )
5976 {
5977 xnum = (xnum+a[i])*xsq;
5978 xden = (xden+b[i])*xsq;
5979 }
5980 *result = x*(xnum+a[3])/(xden+b[3]);
5981 temp = *result;
5982 *result = half+temp;
5983 *ccum = half-temp;
5984 }
5985 //
5986 // Evaluate anorm for 0.66291 <= |X| <= sqrt(32)
5987 //
5988 else if(y <= root32) {
5989 xnum = c[8]*y;
5990 xden = y;
5991 for ( i = 0; i < 7; i++ )
5992 {
5993 xnum = (xnum+c[i])*y;
5994 xden = (xden+d[i])*y;
5995 }
5996 *result = (xnum+c[7])/(xden+d[7]);
5997 xsq = fifdint(y*sixten)/sixten;
5998 del = (y-xsq)*(y+xsq);
5999 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
6000 *ccum = one-*result;
6001 if(x > zero) {
6002 temp = *result;
6003 *result = *ccum;
6004 *ccum = temp;
6005 }
6006 }
6007 //
6008 // Evaluate anorm for |X| > sqrt(32)
6009 //
6010 else {
6011 *result = zero;
6012 xsq = one/(x*x);
6013 xnum = p[5]*xsq;
6014 xden = xsq;
6015 for ( i = 0; i < 4; i++ )
6016 {
6017 xnum = (xnum+p[i])*xsq;
6018 xden = (xden+q[i])*xsq;
6019 }
6020 *result = xsq*(xnum+p[4])/(xden+q[4]);
6021 *result = (sqrpi-*result)/y;
6022 xsq = fifdint(x*sixten)/sixten;
6023 del = (x-xsq)*(x+xsq);
6024 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
6025 *ccum = one-*result;
6026 if(x > zero) {
6027 temp = *result;
6028 *result = *ccum;
6029 *ccum = temp;
6030 }
6031 }
6032 if(*result < min) *result = 0.0e0;
6033 //
6034 // Fix up for negative argument, erf, etc.
6035 //
6036 if(*ccum < min) *ccum = 0.0e0;
6037 }
6038 //****************************************************************************80
6039
cumpoi(double * s,double * xlam,double * cum,double * ccum)6040 void cumpoi ( double *s, double *xlam, double *cum, double *ccum )
6041
6042 //****************************************************************************80
6043 //
6044 // Purpose:
6045 //
6046 // CUMPOI evaluates the cumulative Poisson distribution.
6047 //
6048 // Discussion:
6049 //
6050 // CUMPOI returns the probability of S or fewer events in a Poisson
6051 // distribution with mean XLAM.
6052 //
6053 // Reference:
6054 //
6055 // Milton Abramowitz and Irene Stegun,
6056 // Handbook of Mathematical Functions,
6057 // Formula 26.4.21.
6058 //
6059 // Parameters:
6060 //
6061 // Input, double *S, the upper limit of cumulation of the
6062 // Poisson density function.
6063 //
6064 // Input, double *XLAM, the mean of the Poisson distribution.
6065 //
6066 // Output, double *CUM, *CCUM, the Poisson density CDF and
6067 // complementary CDF.
6068 //
6069 {
6070 static double chi,df;
6071
6072 df = 2.0e0*(*s+1.0e0);
6073 chi = 2.0e0**xlam;
6074 cumchi(&chi,&df,ccum,cum);
6075 return;
6076 }
6077 //****************************************************************************80
6078
cumt(double * t,double * df,double * cum,double * ccum)6079 void cumt ( double *t, double *df, double *cum, double *ccum )
6080
6081 //****************************************************************************80
6082 //
6083 // Purpose:
6084 //
6085 // CUMT evaluates the cumulative T distribution.
6086 //
6087 // Reference:
6088 //
6089 // Milton Abramowitz and Irene Stegun,
6090 // Handbook of Mathematical Functions,
6091 // Formula 26.5.27.
6092 //
6093 // Parameters:
6094 //
6095 // Input, double *T, the upper limit of integration.
6096 //
6097 // Input, double *DF, the number of degrees of freedom of
6098 // the T distribution.
6099 //
6100 // Output, double *CUM, *CCUM, the T distribution CDF and
6101 // complementary CDF.
6102 //
6103 {
6104 static double a;
6105 static double dfptt;
6106 static double K2 = 0.5e0;
6107 static double oma;
6108 static double T1;
6109 static double tt;
6110 static double xx;
6111 static double yy;
6112
6113 tt = (*t) * (*t);
6114 dfptt = ( *df ) + tt;
6115 xx = *df / dfptt;
6116 yy = tt / dfptt;
6117 T1 = 0.5e0 * ( *df );
6118 cumbet ( &xx, &yy, &T1, &K2, &a, &oma );
6119
6120 if ( *t <= 0.0e0 )
6121 {
6122 *cum = 0.5e0 * a;
6123 *ccum = oma + ( *cum );
6124 }
6125 else
6126 {
6127 *ccum = 0.5e0 * a;
6128 *cum = oma + ( *ccum );
6129 }
6130 return;
6131 }
6132 //****************************************************************************80
6133
dbetrm(double * a,double * b)6134 double dbetrm ( double *a, double *b )
6135
6136 //****************************************************************************80
6137 //
6138 // Purpose:
6139 //
6140 // DBETRM computes the Sterling remainder for the complete beta function.
6141 //
6142 // Discussion:
6143 //
6144 // Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
6145 // where Lgamma is the log of the (complete) gamma function
6146 //
6147 // Let ZZ be approximation obtained if each log gamma is approximated
6148 // by Sterling's formula, i.e.,
6149 // Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5D+00 ) * LOG( Z ) - Z
6150 //
6151 // The Sterling remainder is Log(Beta(A,B)) - ZZ.
6152 //
6153 // Parameters:
6154 //
6155 // Input, double *A, *B, the parameters of the Beta function.
6156 //
6157 // Output, double DBETRM, the Sterling remainder.
6158 //
6159 {
6160 static double dbetrm,T1,T2,T3;
6161 //
6162 // Try to sum from smallest to largest
6163 //
6164 T1 = *a+*b;
6165 dbetrm = -dstrem(&T1);
6166 T2 = fifdmax1(*a,*b);
6167 dbetrm += dstrem(&T2);
6168 T3 = fifdmin1(*a,*b);
6169 dbetrm += dstrem(&T3);
6170 return dbetrm;
6171 }
6172 //****************************************************************************80
6173
dexpm1(double * x)6174 double dexpm1 ( double *x )
6175
6176 //****************************************************************************80
6177 //
6178 // Purpose:
6179 //
6180 // DEXPM1 evaluates the function EXP(X) - 1.
6181 //
6182 // Reference:
6183 //
6184 // Armido DiDinato and Alfred Morris,
6185 // Algorithm 708:
6186 // Significant Digit Computation of the Incomplete Beta Function Ratios,
6187 // ACM Transactions on Mathematical Software,
6188 // Volume 18, 1993, pages 360-373.
6189 //
6190 // Parameters:
6191 //
6192 // Input, double *X, the value at which exp(X)-1 is desired.
6193 //
6194 // Output, double DEXPM1, the value of exp(X)-1.
6195 //
6196 {
6197 static double p1 = .914041914819518e-09;
6198 static double p2 = .238082361044469e-01;
6199 static double q1 = -.499999999085958e+00;
6200 static double q2 = .107141568980644e+00;
6201 static double q3 = -.119041179760821e-01;
6202 static double q4 = .595130811860248e-03;
6203 static double dexpm1;
6204 double w;
6205
6206 if ( fabs(*x) <= 0.15e0 )
6207 {
6208 dexpm1 = *x * ( ( (
6209 p2 * *x
6210 + p1 ) * *x
6211 + 1.0e0 )
6212 /((((
6213 q4 * *x
6214 + q3 ) * *x
6215 + q2 ) * *x
6216 + q1 ) * *x
6217 + 1.0e0 ) );
6218 }
6219 else if ( *x <= 0.0e0 )
6220 {
6221 w = exp(*x);
6222 dexpm1 = w-0.5e0-0.5e0;
6223 }
6224 else
6225 {
6226 w = exp(*x);
6227 dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w));
6228 }
6229
6230 return dexpm1;
6231 }
6232 //****************************************************************************80
6233
dinvnr(double * p,double * q)6234 double dinvnr ( double *p, double *q )
6235
6236 //****************************************************************************80
6237 //
6238 // Purpose:
6239 //
6240 // DINVNR computes the inverse of the normal distribution.
6241 //
6242 // Discussion:
6243 //
6244 // Returns X such that CUMNOR(X) = P, i.e., the integral from -
6245 // infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
6246 //
6247 // The rational function on page 95 of Kennedy and Gentle is used as a start
6248 // value for the Newton method of finding roots.
6249 //
6250 // Reference:
6251 //
6252 // Kennedy and Gentle,
6253 // Statistical Computing,
6254 // Marcel Dekker, NY, 1980,
6255 // QA276.4 K46
6256 //
6257 // Parameters:
6258 //
6259 // Input, double *P, *Q, the probability, and the complementary
6260 // probability.
6261 //
6262 // Output, double DINVNR, the argument X for which the
6263 // Normal CDF has the value P.
6264 //
6265 {
6266 # define maxit 100
6267 # define eps (1.0e-13)
6268 # define r2pi 0.3989422804014326e0
6269 # define nhalf (-0.5e0)
6270 # define dennor(x) (r2pi*exp(nhalf*(x)*(x)))
6271
6272 static double dinvnr,strtx,xcur,cum,ccum,pp,dx;
6273 static int i;
6274 static unsigned long qporq;
6275
6276 //
6277 // FIND MINIMUM OF P AND Q
6278 //
6279 qporq = *p <= *q;
6280 if(!qporq) goto S10;
6281 pp = *p;
6282 goto S20;
6283 S10:
6284 pp = *q;
6285 S20:
6286 //
6287 // INITIALIZATION STEP
6288 //
6289 strtx = stvaln(&pp);
6290 xcur = strtx;
6291 //
6292 // NEWTON INTERATIONS
6293 //
6294 for ( i = 1; i <= maxit; i++ )
6295 {
6296 cumnor(&xcur,&cum,&ccum);
6297 dx = (cum-pp)/dennor(xcur);
6298 xcur -= dx;
6299 if(fabs(dx/xcur) < eps) goto S40;
6300 }
6301 dinvnr = strtx;
6302 //
6303 // IF WE GET HERE, NEWTON HAS FAILED
6304 //
6305 if(!qporq) dinvnr = -dinvnr;
6306 return dinvnr;
6307 S40:
6308 //
6309 // IF WE GET HERE, NEWTON HAS SUCCEDED
6310 //
6311 dinvnr = xcur;
6312 if(!qporq) dinvnr = -dinvnr;
6313 return dinvnr;
6314 # undef maxit
6315 # undef eps
6316 # undef r2pi
6317 # undef nhalf
6318 # undef dennor
6319 }
6320 //****************************************************************************80
6321
dinvr(int * status,double * x,double * fx,unsigned long * qleft,unsigned long * qhi)6322 void dinvr ( int *status, double *x, double *fx,
6323 unsigned long *qleft, unsigned long *qhi )
6324
6325 //****************************************************************************80
6326 //
6327 // Purpose:
6328 //
6329 // DINVR bounds the zero of the function and invokes DZROR.
6330 //
6331 // Discussion:
6332 //
6333 // This routine seeks to find bounds on a root of the function and
6334 // invokes ZROR to perform the zero finding. STINVR must have been
6335 // called before this routine in order to set its parameters.
6336 //
6337 // Reference:
6338 //
6339 // J C P Bus and T J Dekker,
6340 // Two Efficient Algorithms with Guaranteed Convergence for
6341 // Finding a Zero of a Function,
6342 // ACM Transactions on Mathematical Software,
6343 // Volume 1, Number 4, pages 330-345, 1975.
6344 //
6345 // Parameters:
6346 //
6347 // Input/output, integer STATUS. At the beginning of a zero finding
6348 // problem, STATUS should be set to 0 and INVR invoked. The value
6349 // of parameters other than X will be ignored on this call.
6350 // If INVR needs the function to be evaluated, it will set STATUS to 1
6351 // and return. The value of the function should be set in FX and INVR
6352 // again called without changing any of its other parameters.
6353 // If INVR finishes without error, it returns with STATUS 0, and X an
6354 // approximate root of F(X).
6355 // If INVR cannot bound the function, it returns a negative STATUS and
6356 // sets QLEFT and QHI.
6357 //
6358 // Output, double precision X, the value at which F(X) is to be evaluated.
6359 //
6360 // Input, double precision FX, the value of F(X) calculated by the user
6361 // on the previous call, when INVR returned with STATUS = 1.
6362 //
6363 // Output, logical QLEFT, is defined only if QMFINV returns FALSE. In that
6364 // case, QLEFT is TRUE if the stepping search terminated unsucessfully
6365 // at SMALL, and FALSE if the search terminated unsucessfully at BIG.
6366 //
6367 // Output, logical QHI, is defined only if QMFINV returns FALSE. In that
6368 // case, it is TRUE if Y < F(X) at the termination of the search and FALSE
6369 // if F(X) < Y.
6370 //
6371 {
6372 E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL);
6373 }
6374 //****************************************************************************80
6375
dlanor(double * x)6376 double dlanor ( double *x )
6377
6378 //****************************************************************************80
6379 //
6380 // Purpose:
6381 //
6382 // DLANOR evaluates the logarithm of the asymptotic Normal CDF.
6383 //
6384 // Discussion:
6385 //
6386 // This routine computes the logarithm of the cumulative normal distribution
6387 // from abs ( x ) to infinity for 5 <= abs ( X ).
6388 //
6389 // The relative error at X = 5 is about 0.5D-5.
6390 //
6391 // Reference:
6392 //
6393 // Milton Abramowitz and Irene Stegun,
6394 // Handbook of Mathematical Functions
6395 // 1966, Formula 26.2.12.
6396 //
6397 // Parameters:
6398 //
6399 // Input, double *X, the value at which the Normal CDF is to be
6400 // evaluated. It is assumed that 5 <= abs ( X ).
6401 //
6402 // Output, double DLANOR, the logarithm of the asymptotic
6403 // Normal CDF.
6404 //
6405 {
6406 # define dlsqpi 0.91893853320467274177e0
6407
6408 static double coef[12] = {
6409 -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0,
6410 -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0
6411 };
6412 static int K1 = 12;
6413 static double dlanor,approx,correc,xx,xx2,T2;
6414
6415 xx = fabs(*x);
6416 if ( xx < 5.0e0 )
6417 {
6418 ftnstop(" Argument too small in DLANOR");
6419 }
6420 approx = -dlsqpi-0.5e0*xx*xx-log(xx);
6421 xx2 = xx*xx;
6422 T2 = 1.0e0/xx2;
6423 correc = eval_pol ( coef, &K1, &T2 ) / xx2;
6424 correc = alnrel ( &correc );
6425 dlanor = approx+correc;
6426 return dlanor;
6427 # undef dlsqpi
6428 }
6429 //****************************************************************************80
6430
dpmpar(int * i)6431 double dpmpar ( int *i )
6432
6433 //****************************************************************************80
6434 //
6435 // Purpose:
6436 //
6437 // DPMPAR provides machine constants for double precision arithmetic.
6438 //
6439 // Discussion:
6440 //
6441 // DPMPAR PROVIDES THE double PRECISION MACHINE CONSTANTS FOR
6442 // THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
6443 // I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
6444 // double PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
6445 // ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
6446 //
6447 // DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
6448 //
6449 // DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
6450 //
6451 // DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
6452 //
6453 // WRITTEN BY
6454 // ALFRED H. MORRIS, JR.
6455 // NAVAL SURFACE WARFARE CENTER
6456 // DAHLGREN VIRGINIA
6457 //
6458 // MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE
6459 // CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS
6460 // MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION
6461 //
6462 {
6463 static int K1 = 4;
6464 static int K2 = 8;
6465 static int K3 = 9;
6466 static int K4 = 10;
6467 static double value,b,binv,bm1,one,w,z;
6468 static int emax,emin,ibeta,m;
6469
6470 if(*i > 1) goto S10;
6471 b = ipmpar(&K1);
6472 m = ipmpar(&K2);
6473 value = pow(b,(double)(1-m));
6474 return value;
6475 S10:
6476 if(*i > 2) goto S20;
6477 b = ipmpar(&K1);
6478 emin = ipmpar(&K3);
6479 one = 1.0;
6480 binv = one/b;
6481 w = pow(b,(double)(emin+2));
6482 value = w*binv*binv*binv;
6483 return value;
6484 S20:
6485 ibeta = ipmpar(&K1);
6486 m = ipmpar(&K2);
6487 emax = ipmpar(&K4);
6488 b = ibeta;
6489 bm1 = ibeta-1;
6490 one = 1.0;
6491 z = pow(b,(double)(m-1));
6492 w = ((z-one)*b+bm1)/(b*z);
6493 z = pow(b,(double)(emax-2));
6494 value = w*z*b*b;
6495 return value;
6496 }
6497 //****************************************************************************80
6498
dstinv(double * zsmall,double * zbig,double * zabsst,double * zrelst,double * zstpmu,double * zabsto,double * zrelto)6499 void dstinv ( double *zsmall, double *zbig, double *zabsst,
6500 double *zrelst, double *zstpmu, double *zabsto, double *zrelto )
6501
6502 //****************************************************************************80
6503 //
6504 // Purpose:
6505 //
6506 // DSTINV seeks a value X such that F(X) = Y.
6507 //
6508 // Discussion:
6509 //
6510 // Double Precision - SeT INverse finder - Reverse Communication
6511 // Function
6512 // Concise Description - Given a monotone function F finds X
6513 // such that F(X) = Y. Uses Reverse communication -- see invr.
6514 // This routine sets quantities needed by INVR.
6515 // More Precise Description of INVR -
6516 // F must be a monotone function, the results of QMFINV are
6517 // otherwise undefined. QINCR must be .TRUE. if F is non-
6518 // decreasing and .FALSE. if F is non-increasing.
6519 // QMFINV will return .TRUE. if and only if F(SMALL) and
6520 // F(BIG) bracket Y, i. e.,
6521 // QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or
6522 // QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL)
6523 // if QMFINV returns .TRUE., then the X returned satisfies
6524 // the following condition. let
6525 // TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6526 // then if QINCR is .TRUE.,
6527 // F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X))
6528 // and if QINCR is .FALSE.
6529 // F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
6530 // Arguments
6531 // SMALL --> The left endpoint of the interval to be
6532 // searched for a solution.
6533 // SMALL is DOUBLE PRECISION
6534 // BIG --> The right endpoint of the interval to be
6535 // searched for a solution.
6536 // BIG is DOUBLE PRECISION
6537 // ABSSTP, RELSTP --> The initial step size in the search
6538 // is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm.
6539 // ABSSTP is DOUBLE PRECISION
6540 // RELSTP is DOUBLE PRECISION
6541 // STPMUL --> When a step doesn't bound the zero, the step
6542 // size is multiplied by STPMUL and another step
6543 // taken. A popular value is 2.0
6544 // DOUBLE PRECISION STPMUL
6545 // ABSTOL, RELTOL --> Two numbers that determine the accuracy
6546 // of the solution. See function for a precise definition.
6547 // ABSTOL is DOUBLE PRECISION
6548 // RELTOL is DOUBLE PRECISION
6549 // Method
6550 // Compares F(X) with Y for the input value of X then uses QINCR
6551 // to determine whether to step left or right to bound the
6552 // desired x. the initial step size is
6553 // MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X.
6554 // Iteratively steps right or left until it bounds X.
6555 // At each step which doesn't bound X, the step size is doubled.
6556 // The routine is careful never to step beyond SMALL or BIG. If
6557 // it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE.
6558 // after setting QLEFT and QHI.
6559 // If X is successfully bounded then Algorithm R of the paper
6560 // 'Two Efficient Algorithms with Guaranteed Convergence for
6561 // Finding a Zero of a Function' by J. C. P. Bus and
6562 // T. J. Dekker in ACM Transactions on Mathematical
6563 // Software, Volume 1, No. 4 page 330 (DEC. '75) is employed
6564 // to find the zero of the function F(X)-Y. This is routine
6565 // QRZERO.
6566 //
6567 {
6568 E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall,
6569 zstpmu);
6570 }
6571 //****************************************************************************80
6572
dstrem(double * z)6573 double dstrem ( double *z )
6574
6575 //****************************************************************************80
6576 //
6577 // Purpose:
6578 //
6579 // DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ).
6580 //
6581 // Discussion:
6582 //
6583 // This routine returns
6584 //
6585 // ln ( Gamma ( Z ) ) - Sterling ( Z )
6586 //
6587 // where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ).
6588 //
6589 // Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z
6590 //
6591 // If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers,
6592 // with values calculated using Maple.
6593 //
6594 // Otherwise, the difference is computed explicitly.
6595 //
6596 // Modified:
6597 //
6598 // 14 June 2004
6599 //
6600 // Parameters:
6601 //
6602 // Input, double *Z, the value at which the Sterling
6603 // remainder is to be calculated. Z must be positive.
6604 //
6605 // Output, double DSTREM, the Sterling remainder.
6606 //
6607 {
6608 # define hln2pi 0.91893853320467274178e0
6609 # define ncoef 10
6610
6611 static double coef[ncoef] = {
6612 0.0e0,0.0833333333333333333333333333333e0,
6613 -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0,
6614 -0.000595238095238095238095238095238e0,
6615 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0,
6616 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0,
6617 0.179644372368830573164938490016e0
6618 };
6619 static int K1 = 10;
6620 static double dstrem,sterl,T2;
6621 //
6622 // For information, here are the next 11 coefficients of the
6623 // remainder term in Sterling's formula
6624 // -1.39243221690590111642743221691
6625 // 13.4028640441683919944789510007
6626 // -156.848284626002017306365132452
6627 // 2193.10333333333333333333333333
6628 // -36108.7712537249893571732652192
6629 // 691472.268851313067108395250776
6630 // -0.152382215394074161922833649589D8
6631 // 0.382900751391414141414141414141D9
6632 // -0.108822660357843910890151491655D11
6633 // 0.347320283765002252252252252252D12
6634 // -0.123696021422692744542517103493D14
6635 //
6636 if(*z <= 0.0e0)
6637 {
6638 ftnstop ( "Zero or negative argument in DSTREM" );
6639 }
6640 if(!(*z > 6.0e0)) goto S10;
6641 T2 = 1.0e0/pow(*z,2.0);
6642 dstrem = eval_pol ( coef, &K1, &T2 )**z;
6643 goto S20;
6644 S10:
6645 sterl = hln2pi+(*z-0.5e0)*log(*z)-*z;
6646 dstrem = gamma_log ( z ) - sterl;
6647 S20:
6648 return dstrem;
6649 # undef hln2pi
6650 # undef ncoef
6651 }
6652 //****************************************************************************80
6653
dstzr(double * zxlo,double * zxhi,double * zabstl,double * zreltl)6654 void dstzr ( double *zxlo, double *zxhi, double *zabstl, double *zreltl )
6655
6656 //****************************************************************************80
6657 //
6658 // Purpose:
6659 //
6660 // DSTXR sets quantities needed by the zero finder.
6661 //
6662 // Discussion:
6663 //
6664 // Double precision SeT ZeRo finder - Reverse communication version
6665 // Function
6666 // Sets quantities needed by ZROR. The function of ZROR
6667 // and the quantities set is given here.
6668 // Concise Description - Given a function F
6669 // find XLO such that F(XLO) = 0.
6670 // More Precise Description -
6671 // Input condition. F is a double function of a single
6672 // double argument and XLO and XHI are such that
6673 // F(XLO)*F(XHI) .LE. 0.0
6674 // If the input condition is met, QRZERO returns .TRUE.
6675 // and output values of XLO and XHI satisfy the following
6676 // F(XLO)*F(XHI) .LE. 0.
6677 // ABS(F(XLO) .LE. ABS(F(XHI)
6678 // ABS(XLO-XHI) .LE. TOL(X)
6679 // where
6680 // TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6681 // If this algorithm does not find XLO and XHI satisfying
6682 // these conditions then QRZERO returns .FALSE. This
6683 // implies that the input condition was not met.
6684 // Arguments
6685 // XLO --> The left endpoint of the interval to be
6686 // searched for a solution.
6687 // XLO is DOUBLE PRECISION
6688 // XHI --> The right endpoint of the interval to be
6689 // for a solution.
6690 // XHI is DOUBLE PRECISION
6691 // ABSTOL, RELTOL --> Two numbers that determine the accuracy
6692 // of the solution. See function for a
6693 // precise definition.
6694 // ABSTOL is DOUBLE PRECISION
6695 // RELTOL is DOUBLE PRECISION
6696 // Method
6697 // Algorithm R of the paper 'Two Efficient Algorithms with
6698 // Guaranteed Convergence for Finding a Zero of a Function'
6699 // by J. C. P. Bus and T. J. Dekker in ACM Transactions on
6700 // Mathematical Software, Volume 1, no. 4 page 330
6701 // (Dec. '75) is employed to find the zero of F(X)-Y.
6702 //
6703 {
6704 E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo);
6705 }
6706 //****************************************************************************80
6707
dt1(double * p,double * q,double * df)6708 double dt1 ( double *p, double *q, double *df )
6709
6710 //****************************************************************************80
6711 //
6712 // Purpose:
6713 //
6714 // DT1 computes an approximate inverse of the cumulative T distribution.
6715 //
6716 // Discussion:
6717 //
6718 // Returns the inverse of the T distribution function, i.e.,
6719 // the integral from 0 to INVT of the T density is P. This is an
6720 // initial approximation.
6721 //
6722 // Parameters:
6723 //
6724 // Input, double *P, *Q, the value whose inverse from the
6725 // T distribution CDF is desired, and the value (1-P).
6726 //
6727 // Input, double *DF, the number of degrees of freedom of the
6728 // T distribution.
6729 //
6730 // Output, double DT1, the approximate value of X for which
6731 // the T density CDF with DF degrees of freedom has value P.
6732 //
6733 {
6734 static double coef[4][5] = {
6735 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0,
6736 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0
6737 };
6738 static double denom[4] = {
6739 4.0e0,96.0e0,384.0e0,92160.0e0
6740 };
6741 static int ideg[4] = {
6742 2,3,4,5
6743 };
6744 static double dt1,denpow,sum,term,x,xp,xx;
6745 static int i;
6746
6747 x = fabs(dinvnr(p,q));
6748 xx = x*x;
6749 sum = x;
6750 denpow = 1.0e0;
6751 for ( i = 0; i < 4; i++ )
6752 {
6753 term = eval_pol ( &coef[i][0], &ideg[i], &xx ) * x;
6754 denpow *= *df;
6755 sum += (term/(denpow*denom[i]));
6756 }
6757 if(!(*p >= 0.5e0)) goto S20;
6758 xp = sum;
6759 goto S30;
6760 S20:
6761 xp = -sum;
6762 S30:
6763 dt1 = xp;
6764 return dt1;
6765 }
6766 //****************************************************************************80
6767
dzror(int * status,double * x,double * fx,double * xlo,double * xhi,unsigned long * qleft,unsigned long * qhi)6768 void dzror ( int *status, double *x, double *fx, double *xlo,
6769 double *xhi, unsigned long *qleft, unsigned long *qhi )
6770
6771 //****************************************************************************80
6772 //
6773 // Purpose:
6774 //
6775 // DZROR seeks the zero of a function using reverse communication.
6776 //
6777 // Discussion:
6778 //
6779 // Performs the zero finding. STZROR must have been called before
6780 // this routine in order to set its parameters.
6781 //
6782 //
6783 // Arguments
6784 //
6785 //
6786 // STATUS <--> At the beginning of a zero finding problem, STATUS
6787 // should be set to 0 and ZROR invoked. (The value
6788 // of other parameters will be ignored on this call.)
6789 //
6790 // When ZROR needs the function evaluated, it will set
6791 // STATUS to 1 and return. The value of the function
6792 // should be set in FX and ZROR again called without
6793 // changing any of its other parameters.
6794 //
6795 // When ZROR has finished without error, it will return
6796 // with STATUS 0. In that case (XLO,XHI) bound the answe
6797 //
6798 // If ZROR finds an error (which implies that F(XLO)-Y an
6799 // F(XHI)-Y have the same sign, it returns STATUS -1. In
6800 // this case, XLO and XHI are undefined.
6801 // INTEGER STATUS
6802 //
6803 // X <-- The value of X at which F(X) is to be evaluated.
6804 // DOUBLE PRECISION X
6805 //
6806 // FX --> The value of F(X) calculated when ZROR returns with
6807 // STATUS = 1.
6808 // DOUBLE PRECISION FX
6809 //
6810 // XLO <-- When ZROR returns with STATUS = 0, XLO bounds the
6811 // inverval in X containing the solution below.
6812 // DOUBLE PRECISION XLO
6813 //
6814 // XHI <-- When ZROR returns with STATUS = 0, XHI bounds the
6815 // inverval in X containing the solution above.
6816 // DOUBLE PRECISION XHI
6817 //
6818 // QLEFT <-- .TRUE. if the stepping search terminated unsucessfully
6819 // at XLO. If it is .FALSE. the search terminated
6820 // unsucessfully at XHI.
6821 // QLEFT is LOGICAL
6822 //
6823 // QHI <-- .TRUE. if F(X) .GT. Y at the termination of the
6824 // search and .FALSE. if F(X) .LT. Y at the
6825 // termination of the search.
6826 // QHI is LOGICAL
6827 //
6828 //
6829 {
6830 E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL);
6831 }
6832 //****************************************************************************80
6833
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)6834 static void E0000 ( int IENTRY, int *status, double *x, double *fx,
6835 unsigned long *qleft, unsigned long *qhi, double *zabsst,
6836 double *zabsto, double *zbig, double *zrelst,
6837 double *zrelto, double *zsmall, double *zstpmu )
6838
6839 //****************************************************************************80
6840 //
6841 // Purpose:
6842 //
6843 // E0000 is a reverse-communication zero bounder.
6844 //
6845 {
6846 # define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))
6847
6848 static double absstp;
6849 static double abstol;
6850 static double big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,
6851 xlb,xlo,xsave,xub,yy;
6852 static int i99999;
6853 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;
6854 switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}
6855 DINVR:
6856 if(*status > 0) goto S310;
6857 qcond = !qxmon(small,*x,big);
6858 if(qcond)
6859 {
6860 ftnstop(" SMALL, X, BIG not monotone in INVR");
6861 }
6862 xsave = *x;
6863 //
6864 // See that SMALL and BIG bound the zero and set QINCR
6865 //
6866 *x = small;
6867 //
6868 // GET-FUNCTION-VALUE
6869 //
6870 i99999 = 1;
6871 goto S300;
6872 S10:
6873 fsmall = *fx;
6874 *x = big;
6875 //
6876 // GET-FUNCTION-VALUE
6877 //
6878 i99999 = 2;
6879 goto S300;
6880 S20:
6881 fbig = *fx;
6882 qincr = fbig > fsmall;
6883 if(!qincr) goto S50;
6884 if(fsmall <= 0.0e0) goto S30;
6885 *status = -1;
6886 *qleft = *qhi = 1;
6887 return;
6888 S30:
6889 if(fbig >= 0.0e0) goto S40;
6890 *status = -1;
6891 *qleft = *qhi = 0;
6892 return;
6893 S40:
6894 goto S80;
6895 S50:
6896 if(fsmall >= 0.0e0) goto S60;
6897 *status = -1;
6898 *qleft = 1;
6899 *qhi = 0;
6900 return;
6901 S60:
6902 if(fbig <= 0.0e0) goto S70;
6903 *status = -1;
6904 *qleft = 0;
6905 *qhi = 1;
6906 return;
6907 S80:
6908 S70:
6909 *x = xsave;
6910 step = fifdmax1(absstp,relstp*fabs(*x));
6911 //
6912 // YY = F(X) - Y
6913 // GET-FUNCTION-VALUE
6914 //
6915 i99999 = 3;
6916 goto S300;
6917 S90:
6918 yy = *fx;
6919 if(!(yy == 0.0e0)) goto S100;
6920 *status = 0;
6921 qok = 1;
6922 return;
6923 S100:
6924 qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;
6925 //
6926 // HANDLE CASE IN WHICH WE MUST STEP HIGHER
6927 //
6928 if(!qup) goto S170;
6929 xlb = xsave;
6930 xub = fifdmin1(xlb+step,big);
6931 goto S120;
6932 S110:
6933 if(qcond) goto S150;
6934 S120:
6935 //
6936 // YY = F(XUB) - Y
6937 //
6938 *x = xub;
6939 //
6940 // GET-FUNCTION-VALUE
6941 //
6942 i99999 = 4;
6943 goto S300;
6944 S130:
6945 yy = *fx;
6946 qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;
6947 qlim = xub >= big;
6948 qcond = qbdd || qlim;
6949 if(qcond) goto S140;
6950 step = stpmul*step;
6951 xlb = xub;
6952 xub = fifdmin1(xlb+step,big);
6953 S140:
6954 goto S110;
6955 S150:
6956 if(!(qlim && !qbdd)) goto S160;
6957 *status = -1;
6958 *qleft = 0;
6959 *qhi = !qincr;
6960 *x = big;
6961 return;
6962 S160:
6963 goto S240;
6964 S170:
6965 //
6966 // HANDLE CASE IN WHICH WE MUST STEP LOWER
6967 //
6968 xub = xsave;
6969 xlb = fifdmax1(xub-step,small);
6970 goto S190;
6971 S180:
6972 if(qcond) goto S220;
6973 S190:
6974 //
6975 // YY = F(XLB) - Y
6976 //
6977 *x = xlb;
6978 //
6979 // GET-FUNCTION-VALUE
6980 //
6981 i99999 = 5;
6982 goto S300;
6983 S200:
6984 yy = *fx;
6985 qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;
6986 qlim = xlb <= small;
6987 qcond = qbdd || qlim;
6988 if(qcond) goto S210;
6989 step = stpmul*step;
6990 xub = xlb;
6991 xlb = fifdmax1(xub-step,small);
6992 S210:
6993 goto S180;
6994 S220:
6995 if(!(qlim && !qbdd)) goto S230;
6996 *status = -1;
6997 *qleft = 1;
6998 *qhi = qincr;
6999 *x = small;
7000 return;
7001 S240:
7002 S230:
7003 dstzr(&xlb,&xub,&abstol,&reltol);
7004 //
7005 // IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.
7006 //
7007 *status = 0;
7008 goto S260;
7009 S250:
7010 if(!(*status == 1)) goto S290;
7011 S260:
7012 dzror ( status, x, fx, &xlo, &xhi, &qdum1, &qdum2 );
7013 if(!(*status == 1)) goto S280;
7014 //
7015 // GET-FUNCTION-VALUE
7016 //
7017 i99999 = 6;
7018 goto S300;
7019 S280:
7020 S270:
7021 goto S250;
7022 S290:
7023 *x = xlo;
7024 *status = 0;
7025 return;
7026 DSTINV:
7027 small = *zsmall;
7028 big = *zbig;
7029 absstp = *zabsst;
7030 relstp = *zrelst;
7031 stpmul = *zstpmu;
7032 abstol = *zabsto;
7033 reltol = *zrelto;
7034 return;
7035 S300:
7036 //
7037 // TO GET-FUNCTION-VALUE
7038 //
7039 *status = 1;
7040 return;
7041 S310:
7042 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case
7043 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}
7044 # undef qxmon
7045 }
7046 //****************************************************************************80
7047
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)7048 static void E0001 ( int IENTRY, int *status, double *x, double *fx,
7049 double *xlo, double *xhi, unsigned long *qleft,
7050 unsigned long *qhi, double *zabstl, double *zreltl,
7051 double *zxhi, double *zxlo )
7052
7053 //****************************************************************************80
7054 //
7055 // Purpose:
7056 //
7057 // E00001 is a reverse-communication zero finder.
7058 //
7059 {
7060 # define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx))))
7061
7062 static double a,abstol,b,c,d,fa,fb,fc,fd,fda;
7063 static double fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo;
7064 static int ext,i99999;
7065 static unsigned long first,qrzero;
7066 switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;}
7067 DZROR:
7068 if(*status > 0) goto S280;
7069 *xlo = xxlo;
7070 *xhi = xxhi;
7071 b = *x = *xlo;
7072 //
7073 // GET-FUNCTION-VALUE
7074 //
7075 i99999 = 1;
7076 goto S270;
7077 S10:
7078 fb = *fx;
7079 *xlo = *xhi;
7080 a = *x = *xlo;
7081 //
7082 // GET-FUNCTION-VALUE
7083 //
7084 i99999 = 2;
7085 goto S270;
7086 S20:
7087 //
7088 // Check that F(ZXLO) < 0 < F(ZXHI) or
7089 // F(ZXLO) > 0 > F(ZXHI)
7090 //
7091 if(!(fb < 0.0e0)) goto S40;
7092 if(!(*fx < 0.0e0)) goto S30;
7093 *status = -1;
7094 *qleft = *fx < fb;
7095 *qhi = 0;
7096 return;
7097 S40:
7098 S30:
7099 if(!(fb > 0.0e0)) goto S60;
7100 if(!(*fx > 0.0e0)) goto S50;
7101 *status = -1;
7102 *qleft = *fx > fb;
7103 *qhi = 1;
7104 return;
7105 S60:
7106 S50:
7107 fa = *fx;
7108 first = 1;
7109 S70:
7110 c = a;
7111 fc = fa;
7112 ext = 0;
7113 S80:
7114 if(!(fabs(fc) < fabs(fb))) goto S100;
7115 if(!(c != a)) goto S90;
7116 d = a;
7117 fd = fa;
7118 S90:
7119 a = b;
7120 fa = fb;
7121 *xlo = c;
7122 b = *xlo;
7123 fb = fc;
7124 c = a;
7125 fc = fa;
7126 S100:
7127 tol = ftol(*xlo);
7128 m = (c+b)*.5e0;
7129 mb = m-b;
7130 if(!(fabs(mb) > tol)) goto S240;
7131 if(!(ext > 3)) goto S110;
7132 w = mb;
7133 goto S190;
7134 S110:
7135 tol = fifdsign(tol,mb);
7136 p = (b-a)*fb;
7137 if(!first) goto S120;
7138 q = fa-fb;
7139 first = 0;
7140 goto S130;
7141 S120:
7142 fdb = (fd-fb)/(d-b);
7143 fda = (fd-fa)/(d-a);
7144 p = fda*p;
7145 q = fdb*fa-fda*fb;
7146 S130:
7147 if(!(p < 0.0e0)) goto S140;
7148 p = -p;
7149 q = -q;
7150 S140:
7151 if(ext == 3) p *= 2.0e0;
7152 if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150;
7153 w = tol;
7154 goto S180;
7155 S150:
7156 if(!(p < mb*q)) goto S160;
7157 w = p/q;
7158 goto S170;
7159 S160:
7160 w = mb;
7161 S190:
7162 S180:
7163 S170:
7164 d = a;
7165 fd = fa;
7166 a = b;
7167 fa = fb;
7168 b += w;
7169 *xlo = b;
7170 *x = *xlo;
7171 //
7172 // GET-FUNCTION-VALUE
7173 //
7174 i99999 = 3;
7175 goto S270;
7176 S200:
7177 fb = *fx;
7178 if(!(fc*fb >= 0.0e0)) goto S210;
7179 goto S70;
7180 S210:
7181 if(!(w == mb)) goto S220;
7182 ext = 0;
7183 goto S230;
7184 S220:
7185 ext += 1;
7186 S230:
7187 goto S80;
7188 S240:
7189 *xhi = c;
7190 qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0;
7191 if(!qrzero) goto S250;
7192 *status = 0;
7193 goto S260;
7194 S250:
7195 *status = -1;
7196 S260:
7197 return;
7198 DSTZR:
7199 xxlo = *zxlo;
7200 xxhi = *zxhi;
7201 abstol = *zabstl;
7202 reltol = *zreltl;
7203 return;
7204 S270:
7205 //
7206 // TO GET-FUNCTION-VALUE
7207 //
7208 *status = 1;
7209 return;
7210 S280:
7211 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200;
7212 default: break;}
7213 # undef ftol
7214 }
7215 //****************************************************************************80
7216
erf_values(int * n_data,double * x,double * fx)7217 void erf_values ( int *n_data, double *x, double *fx )
7218
7219 //****************************************************************************80
7220 //
7221 // Purpose:
7222 //
7223 // ERF_VALUES returns some values of the ERF or "error" function.
7224 //
7225 // Definition:
7226 //
7227 // ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT
7228 //
7229 // Modified:
7230 //
7231 // 31 May 2004
7232 //
7233 // Author:
7234 //
7235 // John Burkardt
7236 //
7237 // Reference:
7238 //
7239 // Milton Abramowitz and Irene Stegun,
7240 // Handbook of Mathematical Functions,
7241 // US Department of Commerce, 1964.
7242 //
7243 // Parameters:
7244 //
7245 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7246 // first call. On each call, the routine increments N_DATA by 1, and
7247 // returns the corresponding data; when there is no more data, the
7248 // output value of N_DATA will be 0 again.
7249 //
7250 // Output, double *X, the argument of the function.
7251 //
7252 // Output, double *FX, the value of the function.
7253 //
7254 {
7255 # define N_MAX 21
7256
7257 double fx_vec[N_MAX] = {
7258 0.0000000000E+00, 0.1124629160E+00, 0.2227025892E+00, 0.3286267595E+00,
7259 0.4283923550E+00, 0.5204998778E+00, 0.6038560908E+00, 0.6778011938E+00,
7260 0.7421009647E+00, 0.7969082124E+00, 0.8427007929E+00, 0.8802050696E+00,
7261 0.9103139782E+00, 0.9340079449E+00, 0.9522851198E+00, 0.9661051465E+00,
7262 0.9763483833E+00, 0.9837904586E+00, 0.9890905016E+00, 0.9927904292E+00,
7263 0.9953222650E+00 };
7264 double x_vec[N_MAX] = {
7265 0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00,
7266 0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00,
7267 0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00,
7268 1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00,
7269 1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00,
7270 2.0E+00 };
7271
7272 if ( *n_data < 0 )
7273 {
7274 *n_data = 0;
7275 }
7276
7277 *n_data = *n_data + 1;
7278
7279 if ( N_MAX < *n_data )
7280 {
7281 *n_data = 0;
7282 *x = 0.0E+00;
7283 *fx = 0.0E+00;
7284 }
7285 else
7286 {
7287 *x = x_vec[*n_data-1];
7288 *fx = fx_vec[*n_data-1];
7289 }
7290 return;
7291 # undef N_MAX
7292 }
7293 //****************************************************************************80
7294
error_f(double * x)7295 double error_f ( double *x )
7296
7297 //****************************************************************************80
7298 //
7299 // Purpose:
7300 //
7301 // ERROR_F evaluates the error function ERF.
7302 //
7303 // Parameters:
7304 //
7305 // Input, double *X, the argument.
7306 //
7307 // Output, double ERROR_F, the value of the error function at X.
7308 //
7309 {
7310 static double c = .564189583547756e0;
7311 static double a[5] = {
7312 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7313 .479137145607681e-01,.128379167095513e+00
7314 };
7315 static double b[3] = {
7316 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7317 };
7318 static double p[8] = {
7319 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7320 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7321 4.51918953711873e+02,3.00459261020162e+02
7322 };
7323 static double q[8] = {
7324 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7325 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7326 7.90950925327898e+02,3.00459260956983e+02
7327 };
7328 static double r[5] = {
7329 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7330 4.65807828718470e+00,2.82094791773523e-01
7331 };
7332 static double s[4] = {
7333 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7334 1.80124575948747e+01
7335 };
7336 static double erf1,ax,bot,t,top,x2;
7337
7338 ax = fabs(*x);
7339 if(ax > 0.5e0) goto S10;
7340 t = *x**x;
7341 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7342 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7343 erf1 = *x*(top/bot);
7344 return erf1;
7345 S10:
7346 if(ax > 4.0e0) goto S20;
7347 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7348 7];
7349 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7350 7];
7351 erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot);
7352 if(*x < 0.0e0) erf1 = -erf1;
7353 return erf1;
7354 S20:
7355 if(ax >= 5.8e0) goto S30;
7356 x2 = *x**x;
7357 t = 1.0e0/x2;
7358 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7359 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7360 erf1 = (c-top/(x2*bot))/ax;
7361 erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1);
7362 if(*x < 0.0e0) erf1 = -erf1;
7363 return erf1;
7364 S30:
7365 erf1 = fifdsign(1.0e0,*x);
7366 return erf1;
7367 }
7368 //****************************************************************************80
7369
error_fc(int * ind,double * x)7370 double error_fc ( int *ind, double *x )
7371
7372 //****************************************************************************80
7373 //
7374 // Purpose:
7375 //
7376 // ERROR_FC evaluates the complementary error function ERFC.
7377 //
7378 // Modified:
7379 //
7380 // 09 December 1999
7381 //
7382 // Parameters:
7383 //
7384 // Input, int *IND, chooses the scaling.
7385 // If IND is nonzero, then the value returned has been multiplied by
7386 // EXP(X*X).
7387 //
7388 // Input, double *X, the argument of the function.
7389 //
7390 // Output, double ERROR_FC, the value of the complementary
7391 // error function.
7392 //
7393 {
7394 static double c = .564189583547756e0;
7395 static double a[5] = {
7396 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7397 .479137145607681e-01,.128379167095513e+00
7398 };
7399 static double b[3] = {
7400 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7401 };
7402 static double p[8] = {
7403 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7404 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7405 4.51918953711873e+02,3.00459261020162e+02
7406 };
7407 static double q[8] = {
7408 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7409 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7410 7.90950925327898e+02,3.00459260956983e+02
7411 };
7412 static double r[5] = {
7413 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7414 4.65807828718470e+00,2.82094791773523e-01
7415 };
7416 static double s[4] = {
7417 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7418 1.80124575948747e+01
7419 };
7420 static int K1 = 1;
7421 static double erfc1,ax,bot,e,t,top,w;
7422
7423 //
7424 // ABS(X) .LE. 0.5
7425 //
7426 ax = fabs(*x);
7427 if(ax > 0.5e0) goto S10;
7428 t = *x**x;
7429 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7430 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7431 erfc1 = 0.5e0+(0.5e0-*x*(top/bot));
7432 if(*ind != 0) erfc1 = exp(t)*erfc1;
7433 return erfc1;
7434 S10:
7435 //
7436 // 0.5 .LT. ABS(X) .LE. 4
7437 //
7438 if(ax > 4.0e0) goto S20;
7439 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7440 7];
7441 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7442 7];
7443 erfc1 = top/bot;
7444 goto S40;
7445 S20:
7446 //
7447 // ABS(X) .GT. 4
7448 //
7449 if(*x <= -5.6e0) goto S60;
7450 if(*ind != 0) goto S30;
7451 if(*x > 100.0e0) goto S70;
7452 if(*x**x > -exparg(&K1)) goto S70;
7453 S30:
7454 t = pow(1.0e0/ *x,2.0);
7455 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7456 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7457 erfc1 = (c-t*top/bot)/ax;
7458 S40:
7459 //
7460 // FINAL ASSEMBLY
7461 //
7462 if(*ind == 0) goto S50;
7463 if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1;
7464 return erfc1;
7465 S50:
7466 w = *x**x;
7467 t = w;
7468 e = w-t;
7469 erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1;
7470 if(*x < 0.0e0) erfc1 = 2.0e0-erfc1;
7471 return erfc1;
7472 S60:
7473 //
7474 // LIMIT VALUE FOR LARGE NEGATIVE X
7475 //
7476 erfc1 = 2.0e0;
7477 if(*ind != 0) erfc1 = 2.0e0*exp(*x**x);
7478 return erfc1;
7479 S70:
7480 //
7481 // LIMIT VALUE FOR LARGE POSITIVE X
7482 // WHEN IND = 0
7483 //
7484 erfc1 = 0.0e0;
7485 return erfc1;
7486 }
7487 //****************************************************************************80
7488
esum(int * mu,double * x)7489 double esum ( int *mu, double *x )
7490
7491 //****************************************************************************80
7492 //
7493 // Purpose:
7494 //
7495 // ESUM evaluates exp ( MU + X ).
7496 //
7497 // Parameters:
7498 //
7499 // Input, int *MU, part of the argument.
7500 //
7501 // Input, double *X, part of the argument.
7502 //
7503 // Output, double ESUM, the value of exp ( MU + X ).
7504 //
7505 {
7506 static double esum,w;
7507
7508 if(*x > 0.0e0) goto S10;
7509 if(*mu < 0) goto S20;
7510 w = (double)*mu+*x;
7511 if(w > 0.0e0) goto S20;
7512 esum = exp(w);
7513 return esum;
7514 S10:
7515 if(*mu > 0) goto S20;
7516 w = (double)*mu+*x;
7517 if(w < 0.0e0) goto S20;
7518 esum = exp(w);
7519 return esum;
7520 S20:
7521 w = *mu;
7522 esum = exp(w)*exp(*x);
7523 return esum;
7524 }
7525 //****************************************************************************80
7526
eval_pol(double a[],int * n,double * x)7527 double eval_pol ( double a[], int *n, double *x )
7528
7529 //****************************************************************************80
7530 //
7531 // Purpose:
7532 //
7533 // EVAL_POL evaluates a polynomial at X.
7534 //
7535 // Discussion:
7536 //
7537 // EVAL_POL = A(0) + A(1)*X + ... + A(N)*X**N
7538 //
7539 // Modified:
7540 //
7541 // 15 December 1999
7542 //
7543 // Parameters:
7544 //
7545 // Input, double precision A(0:N), coefficients of the polynomial.
7546 //
7547 // Input, int *N, length of A.
7548 //
7549 // Input, double *X, the point at which the polynomial
7550 // is to be evaluated.
7551 //
7552 // Output, double EVAL_POL, the value of the polynomial at X.
7553 //
7554 {
7555 static double devlpl,term;
7556 static int i;
7557
7558 term = a[*n-1];
7559 for ( i = *n-1-1; i >= 0; i-- )
7560 {
7561 term = a[i]+term**x;
7562 }
7563
7564 devlpl = term;
7565 return devlpl;
7566 }
7567 //****************************************************************************80
7568
exparg(int * l)7569 double exparg ( int *l )
7570
7571 //****************************************************************************80
7572 //
7573 // Purpose:
7574 //
7575 // EXPARG returns the largest or smallest legal argument for EXP.
7576 //
7577 // Discussion:
7578 //
7579 // Only an approximate limit for the argument of EXP is desired.
7580 //
7581 // Modified:
7582 //
7583 // 09 December 1999
7584 //
7585 // Parameters:
7586 //
7587 // Input, int *L, indicates which limit is desired.
7588 // If L = 0, then the largest positive argument for EXP is desired.
7589 // Otherwise, the largest negative argument for EXP for which the
7590 // result is nonzero is desired.
7591 //
7592 // Output, double EXPARG, the desired value.
7593 //
7594 {
7595 static int K1 = 4;
7596 static int K2 = 9;
7597 static int K3 = 10;
7598 static double exparg,lnb;
7599 static int b,m;
7600
7601 b = ipmpar(&K1);
7602 if(b != 2) goto S10;
7603 lnb = .69314718055995e0;
7604 goto S40;
7605 S10:
7606 if(b != 8) goto S20;
7607 lnb = 2.0794415416798e0;
7608 goto S40;
7609 S20:
7610 if(b != 16) goto S30;
7611 lnb = 2.7725887222398e0;
7612 goto S40;
7613 S30:
7614 lnb = log((double)b);
7615 S40:
7616 if(*l == 0) goto S50;
7617 m = ipmpar(&K2)-1;
7618 exparg = 0.99999e0*((double)m*lnb);
7619 return exparg;
7620 S50:
7621 m = ipmpar(&K3);
7622 exparg = 0.99999e0*((double)m*lnb);
7623 return exparg;
7624 }
7625 //****************************************************************************80
7626
f_cdf_values(int * n_data,int * a,int * b,double * x,double * fx)7627 void f_cdf_values ( int *n_data, int *a, int *b, double *x, double *fx )
7628
7629 //****************************************************************************80
7630 //
7631 // Purpose:
7632 //
7633 // F_CDF_VALUES returns some values of the F CDF test function.
7634 //
7635 // Discussion:
7636 //
7637 // The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by
7638 // commands like:
7639 //
7640 // Needs["Statistics`ContinuousDistributions`"]
7641 // CDF[FRatioDistribution[ DFN, DFD ], X ]
7642 //
7643 // Modified:
7644 //
7645 // 11 June 2004
7646 //
7647 // Author:
7648 //
7649 // John Burkardt
7650 //
7651 // Reference:
7652 //
7653 // Milton Abramowitz and Irene Stegun,
7654 // Handbook of Mathematical Functions,
7655 // US Department of Commerce, 1964.
7656 //
7657 // Stephen Wolfram,
7658 // The Mathematica Book,
7659 // Fourth Edition,
7660 // Wolfram Media / Cambridge University Press, 1999.
7661 //
7662 // Parameters:
7663 //
7664 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7665 // first call. On each call, the routine increments N_DATA by 1, and
7666 // returns the corresponding data; when there is no more data, the
7667 // output value of N_DATA will be 0 again.
7668 //
7669 // Output, int *A, int *B, the parameters of the function.
7670 //
7671 // Output, double *X, the argument of the function.
7672 //
7673 // Output, double *FX, the value of the function.
7674 //
7675 {
7676 # define N_MAX 20
7677
7678 int a_vec[N_MAX] = {
7679 1, 1, 5, 1,
7680 2, 4, 1, 6,
7681 8, 1, 3, 6,
7682 1, 1, 1, 1,
7683 2, 3, 4, 5 };
7684 int b_vec[N_MAX] = {
7685 1, 5, 1, 5,
7686 10, 20, 5, 6,
7687 16, 5, 10, 12,
7688 5, 5, 5, 5,
7689 5, 5, 5, 5 };
7690 double fx_vec[N_MAX] = {
7691 0.500000E+00, 0.499971E+00, 0.499603E+00, 0.749699E+00,
7692 0.750466E+00, 0.751416E+00, 0.899987E+00, 0.899713E+00,
7693 0.900285E+00, 0.950025E+00, 0.950057E+00, 0.950193E+00,
7694 0.975013E+00, 0.990002E+00, 0.994998E+00, 0.999000E+00,
7695 0.568799E+00, 0.535145E+00, 0.514343E+00, 0.500000E+00 };
7696 double x_vec[N_MAX] = {
7697 1.00E+00, 0.528E+00, 1.89E+00, 1.69E+00,
7698 1.60E+00, 1.47E+00, 4.06E+00, 3.05E+00,
7699 2.09E+00, 6.61E+00, 3.71E+00, 3.00E+00,
7700 10.01E+00, 16.26E+00, 22.78E+00, 47.18E+00,
7701 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00 };
7702
7703 if ( *n_data < 0 )
7704 {
7705 *n_data = 0;
7706 }
7707
7708 *n_data = *n_data + 1;
7709
7710 if ( N_MAX < *n_data )
7711 {
7712 *n_data = 0;
7713 *a = 0;
7714 *b = 0;
7715 *x = 0.0E+00;
7716 *fx = 0.0E+00;
7717 }
7718 else
7719 {
7720 *a = a_vec[*n_data-1];
7721 *b = b_vec[*n_data-1];
7722 *x = x_vec[*n_data-1];
7723 *fx = fx_vec[*n_data-1];
7724 }
7725 return;
7726 # undef N_MAX
7727 }
7728 //****************************************************************************80
7729
f_noncentral_cdf_values(int * n_data,int * a,int * b,double * lambda,double * x,double * fx)7730 void f_noncentral_cdf_values ( int *n_data, int *a, int *b, double *lambda,
7731 double *x, double *fx )
7732
7733 //****************************************************************************80
7734 //
7735 // Purpose:
7736 //
7737 // F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function.
7738 //
7739 // Discussion:
7740 //
7741 // The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated
7742 // in Mathematica by commands like:
7743 //
7744 // Needs["Statistics`ContinuousDistributions`"]
7745 // CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ]
7746 //
7747 // Modified:
7748 //
7749 // 12 June 2004
7750 //
7751 // Author:
7752 //
7753 // John Burkardt
7754 //
7755 // Reference:
7756 //
7757 // Milton Abramowitz and Irene Stegun,
7758 // Handbook of Mathematical Functions,
7759 // US Department of Commerce, 1964.
7760 //
7761 // Stephen Wolfram,
7762 // The Mathematica Book,
7763 // Fourth Edition,
7764 // Wolfram Media / Cambridge University Press, 1999.
7765 //
7766 // Parameters:
7767 //
7768 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
7769 // first call. On each call, the routine increments N_DATA by 1, and
7770 // returns the corresponding data; when there is no more data, the
7771 // output value of N_DATA will be 0 again.
7772 //
7773 // Output, int *A, int *B, double *LAMBDA, the
7774 // parameters of the function.
7775 //
7776 // Output, double *X, the argument of the function.
7777 //
7778 // Output, double *FX, the value of the function.
7779 //
7780 {
7781 # define N_MAX 22
7782
7783 int a_vec[N_MAX] = {
7784 1, 1, 1, 1,
7785 1, 1, 1, 1,
7786 1, 1, 2, 2,
7787 3, 3, 4, 4,
7788 5, 5, 6, 6,
7789 8, 16 };
7790 int b_vec[N_MAX] = {
7791 1, 5, 5, 5,
7792 5, 5, 5, 5,
7793 5, 5, 5, 10,
7794 5, 5, 5, 5,
7795 1, 5, 6, 12,
7796 16, 8 };
7797 double fx_vec[N_MAX] = {
7798 0.500000E+00, 0.636783E+00, 0.584092E+00, 0.323443E+00,
7799 0.450119E+00, 0.607888E+00, 0.705928E+00, 0.772178E+00,
7800 0.819105E+00, 0.317035E+00, 0.432722E+00, 0.450270E+00,
7801 0.426188E+00, 0.337744E+00, 0.422911E+00, 0.692767E+00,
7802 0.363217E+00, 0.421005E+00, 0.426667E+00, 0.446402E+00,
7803 0.844589E+00, 0.816368E+00 };
7804 double lambda_vec[N_MAX] = {
7805 0.00E+00, 0.000E+00, 0.25E+00, 1.00E+00,
7806 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7807 1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,
7808 1.00E+00, 2.00E+00, 1.00E+00, 1.00E+00,
7809 0.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7810 1.00E+00, 1.00E+00 };
7811 double x_vec[N_MAX] = {
7812 1.00E+00, 1.00E+00, 1.00E+00, 0.50E+00,
7813 1.00E+00, 2.00E+00, 3.00E+00, 4.00E+00,
7814 5.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7815 1.00E+00, 1.00E+00, 1.00E+00, 2.00E+00,
7816 1.00E+00, 1.00E+00, 1.00E+00, 1.00E+00,
7817 2.00E+00, 2.00E+00 };
7818
7819 if ( *n_data < 0 )
7820 {
7821 *n_data = 0;
7822 }
7823
7824 *n_data = *n_data + 1;
7825
7826 if ( N_MAX < *n_data )
7827 {
7828 *n_data = 0;
7829 *a = 0;
7830 *b = 0;
7831 *lambda = 0.0E+00;
7832 *x = 0.0E+00;
7833 *fx = 0.0E+00;
7834 }
7835 else
7836 {
7837 *a = a_vec[*n_data-1];
7838 *b = b_vec[*n_data-1];
7839 *lambda = lambda_vec[*n_data-1];
7840 *x = x_vec[*n_data-1];
7841 *fx = fx_vec[*n_data-1];
7842 }
7843
7844 return;
7845 # undef N_MAX
7846 }
7847 //****************************************************************************80
7848
fifdint(double a)7849 double fifdint ( double a )
7850
7851 //****************************************************************************80
7852 //
7853 // Purpose:
7854 //
7855 // FIFDINT truncates a double number to an integer.
7856 //
7857 // Parameters:
7858 //
7859 // a - number to be truncated
7860 {
7861 return (double) ((int) a);
7862 }
7863 //****************************************************************************80
7864
fifdmax1(double a,double b)7865 double fifdmax1 ( double a, double b )
7866
7867 //****************************************************************************80
7868 //
7869 // Purpose:
7870 //
7871 // FIFDMAX1 returns the maximum of two numbers a and b
7872 //
7873 // Parameters:
7874 //
7875 // a - first number
7876 // b - second number
7877 //
7878 {
7879 if ( a < b )
7880 {
7881 return b;
7882 }
7883 else
7884 {
7885 return a;
7886 }
7887 }
7888 //****************************************************************************80
7889
fifdmin1(double a,double b)7890 double fifdmin1 ( double a, double b )
7891
7892 //****************************************************************************80
7893 //
7894 // Purpose:
7895 //
7896 // FIFDMIN1 returns the minimum of two numbers.
7897 //
7898 // Parameters:
7899 //
7900 // a - first number
7901 // b - second number
7902 //
7903 {
7904 if (a < b) return a;
7905 else return b;
7906 }
7907 //****************************************************************************80
7908
fifdsign(double mag,double sign)7909 double fifdsign ( double mag, double sign )
7910
7911 //****************************************************************************80
7912 //
7913 // Purpose:
7914 //
7915 // FIFDSIGN transfers the sign of the variable "sign" to the variable "mag"
7916 //
7917 // Parameters:
7918 //
7919 // mag - magnitude
7920 // sign - sign to be transfered
7921 //
7922 {
7923 if (mag < 0) mag = -mag;
7924 if (sign < 0) mag = -mag;
7925 return mag;
7926
7927 }
7928 //****************************************************************************80
7929
fifidint(double a)7930 long fifidint ( double a )
7931
7932 //****************************************************************************80
7933 //
7934 // Purpose:
7935 //
7936 // FIFIDINT truncates a double number to a long integer
7937 //
7938 // Parameters:
7939 //
7940 // a - number to be truncated
7941 //
7942 {
7943 if ( a < 1.0 )
7944 {
7945 return (long) 0;
7946 }
7947 else
7948 {
7949 return ( long ) a;
7950 }
7951 }
7952 //****************************************************************************80
7953
fifmod(long a,long b)7954 long fifmod ( long a, long b )
7955
7956 //****************************************************************************80
7957 //
7958 // Purpose:
7959 //
7960 // FIFMOD returns the modulo of a and b
7961 //
7962 // Parameters:
7963 //
7964 // a - numerator
7965 // b - denominator
7966 //
7967 {
7968 return ( a % b );
7969 }
7970 //****************************************************************************80
7971
fpser(double * a,double * b,double * x,double * eps)7972 double fpser ( double *a, double *b, double *x, double *eps )
7973
7974 //****************************************************************************80
7975 //
7976 // Purpose:
7977 //
7978 // FPSER evaluates IX(A,B)(X) for very small B.
7979 //
7980 // Discussion:
7981 //
7982 // This routine is appropriate for use when
7983 //
7984 // B < min ( EPS, EPS * A )
7985 //
7986 // and
7987 //
7988 // X <= 0.5.
7989 //
7990 // Parameters:
7991 //
7992 // Input, double *A, *B, parameters of the function.
7993 //
7994 // Input, double *X, the point at which the function is to
7995 // be evaluated.
7996 //
7997 // Input, double *EPS, a tolerance.
7998 //
7999 // Output, double FPSER, the value of IX(A,B)(X).
8000 //
8001 {
8002 static int K1 = 1;
8003 static double fpser,an,c,s,t,tol;
8004
8005 fpser = 1.0e0;
8006 if(*a <= 1.e-3**eps) goto S10;
8007 fpser = 0.0e0;
8008 t = *a*log(*x);
8009 if(t < exparg(&K1)) return fpser;
8010 fpser = exp(t);
8011 S10:
8012 //
8013 // NOTE THAT 1/B(A,B) = B
8014 //
8015 fpser = *b/ *a*fpser;
8016 tol = *eps/ *a;
8017 an = *a+1.0e0;
8018 t = *x;
8019 s = t/an;
8020 S20:
8021 an += 1.0e0;
8022 t = *x*t;
8023 c = t/an;
8024 s += c;
8025 if(fabs(c) > tol) goto S20;
8026 fpser *= (1.0e0+*a*s);
8027 return fpser;
8028 }
8029 //****************************************************************************80
8030
ftnstop(string msg)8031 void ftnstop ( string msg )
8032
8033 //****************************************************************************80
8034 //
8035 // Purpose:
8036 //
8037 // FTNSTOP prints a message to standard error and then exits.
8038 //
8039 // Parameters:
8040 //
8041 // Input, string MSG, the message to be printed.
8042 //
8043 {
8044 cerr << msg << "\n";
8045
8046 exit ( 0 );
8047 }
8048 //****************************************************************************80
8049
gam1(double * a)8050 double gam1 ( double *a )
8051
8052 //****************************************************************************80
8053 //
8054 // Purpose:
8055 //
8056 // GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5D+00 <= A <= 1.5
8057 //
8058 // Parameters:
8059 //
8060 // Input, double *A, forms the argument of the Gamma function.
8061 //
8062 // Output, double GAM1, the value of 1 / GAMMA ( A + 1 ) - 1.
8063 //
8064 {
8065 static double s1 = .273076135303957e+00;
8066 static double s2 = .559398236957378e-01;
8067 static double p[7] = {
8068 .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00,
8069 .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02,
8070 .589597428611429e-03
8071 };
8072 static double q[5] = {
8073 .100000000000000e+01,.427569613095214e+00,.158451672430138e+00,
8074 .261132021441447e-01,.423244297896961e-02
8075 };
8076 static double r[9] = {
8077 -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00,
8078 .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01,
8079 .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03
8080 };
8081 static double gam1,bot,d,t,top,w,T1;
8082
8083 t = *a;
8084 d = *a-0.5e0;
8085 if(d > 0.0e0) t = d-0.5e0;
8086 T1 = t;
8087 if(T1 < 0) goto S40;
8088 else if(T1 == 0) goto S10;
8089 else goto S20;
8090 S10:
8091 gam1 = 0.0e0;
8092 return gam1;
8093 S20:
8094 top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0];
8095 bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0;
8096 w = top/bot;
8097 if(d > 0.0e0) goto S30;
8098 gam1 = *a*w;
8099 return gam1;
8100 S30:
8101 gam1 = t/ *a*(w-0.5e0-0.5e0);
8102 return gam1;
8103 S40:
8104 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+
8105 r[0];
8106 bot = (s2*t+s1)*t+1.0e0;
8107 w = top/bot;
8108 if(d > 0.0e0) goto S50;
8109 gam1 = *a*(w+0.5e0+0.5e0);
8110 return gam1;
8111 S50:
8112 gam1 = t*w/ *a;
8113 return gam1;
8114 }
8115 //****************************************************************************80
8116
gamma_inc(double * a,double * x,double * ans,double * qans,int * ind)8117 void gamma_inc ( double *a, double *x, double *ans, double *qans, int *ind )
8118
8119 //****************************************************************************80
8120 //
8121 // Purpose:
8122 //
8123 // GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
8124 //
8125 // Discussion:
8126 //
8127 // This is certified spaghetti code.
8128 //
8129 // Author:
8130 //
8131 // Alfred H Morris, Jr,
8132 // Naval Surface Weapons Center,
8133 // Dahlgren, Virginia.
8134 //
8135 // Parameters:
8136 //
8137 // Input, double *A, *X, the arguments of the incomplete
8138 // gamma ratio. A and X must be nonnegative. A and X cannot
8139 // both be zero.
8140 //
8141 // Output, double *ANS, *QANS. On normal output,
8142 // ANS = P(A,X) and QANS = Q(A,X). However, ANS is set to 2 if
8143 // A or X is negative, or both are 0, or when the answer is
8144 // computationally indeterminate because A is extremely large
8145 // and X is very close to A.
8146 //
8147 // Input, int *IND, indicates the accuracy request:
8148 // 0, as much accuracy as possible.
8149 // 1, to within 1 unit of the 6-th significant digit,
8150 // otherwise, to within 1 unit of the 3rd significant digit.
8151 //
8152 {
8153 static double alog10 = 2.30258509299405e0;
8154 static double d10 = -.185185185185185e-02;
8155 static double d20 = .413359788359788e-02;
8156 static double d30 = .649434156378601e-03;
8157 static double d40 = -.861888290916712e-03;
8158 static double d50 = -.336798553366358e-03;
8159 static double d60 = .531307936463992e-03;
8160 static double d70 = .344367606892378e-03;
8161 static double rt2pin = .398942280401433e0;
8162 static double rtpi = 1.77245385090552e0;
8163 static double third = .333333333333333e0;
8164 static double acc0[3] = {
8165 5.e-15,5.e-7,5.e-4
8166 };
8167 static double big[3] = {
8168 20.0e0,14.0e0,10.0e0
8169 };
8170 static double d0[13] = {
8171 .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02,
8172 .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04,
8173 -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06,
8174 -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07,
8175 -.438203601845335e-08
8176 };
8177 static double d1[12] = {
8178 -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03,
8179 .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04,
8180 .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08,
8181 .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07
8182 };
8183 static double d2[10] = {
8184 -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05,
8185 -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04,
8186 .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06,
8187 .142806142060642e-06
8188 };
8189 static double d3[8] = {
8190 .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03,
8191 -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04,
8192 -.567495282699160e-05,.142309007324359e-05
8193 };
8194 static double d4[6] = {
8195 .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05,
8196 .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04
8197 };
8198 static double d5[4] = {
8199 -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03,
8200 .679778047793721e-04
8201 };
8202 static double d6[2] = {
8203 -.592166437353694e-03,.270878209671804e-03
8204 };
8205 static double e00[3] = {
8206 .25e-3,.25e-1,.14e0
8207 };
8208 static double x00[3] = {
8209 31.0e0,17.0e0,9.7e0
8210 };
8211 static int K1 = 1;
8212 static int K2 = 0;
8213 static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6,
8214 cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z;
8215 static int i,iop,m,max,n;
8216 static double wk[20],T3;
8217 static int T4,T5;
8218 static double T6,T7;
8219
8220 //
8221 // E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
8222 // NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
8223 //
8224 e = dpmpar(&K1);
8225 if(*a < 0.0e0 || *x < 0.0e0) goto S430;
8226 if(*a == 0.0e0 && *x == 0.0e0) goto S430;
8227 if(*a**x == 0.0e0) goto S420;
8228 iop = *ind+1;
8229 if(iop != 1 && iop != 2) iop = 3;
8230 acc = fifdmax1(acc0[iop-1],e);
8231 e0 = e00[iop-1];
8232 x0 = x00[iop-1];
8233 //
8234 // SELECT THE APPROPRIATE ALGORITHM
8235 //
8236 if(*a >= 1.0e0) goto S10;
8237 if(*a == 0.5e0) goto S390;
8238 if(*x < 1.1e0) goto S160;
8239 t1 = *a*log(*x)-*x;
8240 u = *a*exp(t1);
8241 if(u == 0.0e0) goto S380;
8242 r = u*(1.0e0+gam1(a));
8243 goto S250;
8244 S10:
8245 if(*a >= big[iop-1]) goto S30;
8246 if(*a > *x || *x >= x0) goto S20;
8247 twoa = *a+*a;
8248 m = fifidint(twoa);
8249 if(twoa != (double)m) goto S20;
8250 i = m/2;
8251 if(*a == (double)i) goto S210;
8252 goto S220;
8253 S20:
8254 t1 = *a*log(*x)-*x;
8255 r = exp(t1)/ gamma_x(a);
8256 goto S40;
8257 S30:
8258 l = *x/ *a;
8259 if(l == 0.0e0) goto S370;
8260 s = 0.5e0+(0.5e0-l);
8261 z = rlog(&l);
8262 if(z >= 700.0e0/ *a) goto S410;
8263 y = *a*z;
8264 rta = sqrt(*a);
8265 if(fabs(s) <= e0/rta) goto S330;
8266 if(fabs(s) <= 0.4e0) goto S270;
8267 t = pow(1.0e0/ *a,2.0);
8268 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
8269 t1 -= y;
8270 r = rt2pin*rta*exp(t1);
8271 S40:
8272 if(r == 0.0e0) goto S420;
8273 if(*x <= fifdmax1(*a,alog10)) goto S50;
8274 if(*x < x0) goto S250;
8275 goto S100;
8276 S50:
8277 //
8278 // TAYLOR SERIES FOR P/R
8279 //
8280 apn = *a+1.0e0;
8281 t = *x/apn;
8282 wk[0] = t;
8283 for ( n = 2; n <= 20; n++ )
8284 {
8285 apn += 1.0e0;
8286 t *= (*x/apn);
8287 if(t <= 1.e-3) goto S70;
8288 wk[n-1] = t;
8289 }
8290 n = 20;
8291 S70:
8292 sum = t;
8293 tol = 0.5e0*acc;
8294 S80:
8295 apn += 1.0e0;
8296 t *= (*x/apn);
8297 sum += t;
8298 if(t > tol) goto S80;
8299 max = n-1;
8300 for ( m = 1; m <= max; m++ )
8301 {
8302 n -= 1;
8303 sum += wk[n-1];
8304 }
8305 *ans = r/ *a*(1.0e0+sum);
8306 *qans = 0.5e0+(0.5e0-*ans);
8307 return;
8308 S100:
8309 //
8310 // ASYMPTOTIC EXPANSION
8311 //
8312 amn = *a-1.0e0;
8313 t = amn/ *x;
8314 wk[0] = t;
8315 for ( n = 2; n <= 20; n++ )
8316 {
8317 amn -= 1.0e0;
8318 t *= (amn/ *x);
8319 if(fabs(t) <= 1.e-3) goto S120;
8320 wk[n-1] = t;
8321 }
8322 n = 20;
8323 S120:
8324 sum = t;
8325 S130:
8326 if(fabs(t) <= acc) goto S140;
8327 amn -= 1.0e0;
8328 t *= (amn/ *x);
8329 sum += t;
8330 goto S130;
8331 S140:
8332 max = n-1;
8333 for ( m = 1; m <= max; m++ )
8334 {
8335 n -= 1;
8336 sum += wk[n-1];
8337 }
8338 *qans = r/ *x*(1.0e0+sum);
8339 *ans = 0.5e0+(0.5e0-*qans);
8340 return;
8341 S160:
8342 //
8343 // TAYLOR SERIES FOR P(A,X)/X**A
8344 //
8345 an = 3.0e0;
8346 c = *x;
8347 sum = *x/(*a+3.0e0);
8348 tol = 3.0e0*acc/(*a+1.0e0);
8349 S170:
8350 an += 1.0e0;
8351 c = -(c*(*x/an));
8352 t = c/(*a+an);
8353 sum += t;
8354 if(fabs(t) > tol) goto S170;
8355 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8356 z = *a*log(*x);
8357 h = gam1(a);
8358 g = 1.0e0+h;
8359 if(*x < 0.25e0) goto S180;
8360 if(*a < *x/2.59e0) goto S200;
8361 goto S190;
8362 S180:
8363 if(z > -.13394e0) goto S200;
8364 S190:
8365 w = exp(z);
8366 *ans = w*g*(0.5e0+(0.5e0-j));
8367 *qans = 0.5e0+(0.5e0-*ans);
8368 return;
8369 S200:
8370 l = rexp(&z);
8371 w = 0.5e0+(0.5e0+l);
8372 *qans = (w*j-l)*g-h;
8373 if(*qans < 0.0e0) goto S380;
8374 *ans = 0.5e0+(0.5e0-*qans);
8375 return;
8376 S210:
8377 //
8378 // FINITE SUMS FOR Q WHEN A .GE. 1 AND 2*A IS AN INTEGER
8379 //
8380 sum = exp(-*x);
8381 t = sum;
8382 n = 1;
8383 c = 0.0e0;
8384 goto S230;
8385 S220:
8386 rtx = sqrt(*x);
8387 sum = error_fc ( &K2, &rtx );
8388 t = exp(-*x)/(rtpi*rtx);
8389 n = 0;
8390 c = -0.5e0;
8391 S230:
8392 if(n == i) goto S240;
8393 n += 1;
8394 c += 1.0e0;
8395 t = *x*t/c;
8396 sum += t;
8397 goto S230;
8398 S240:
8399 *qans = sum;
8400 *ans = 0.5e0+(0.5e0-*qans);
8401 return;
8402 S250:
8403 //
8404 // CONTINUED FRACTION EXPANSION
8405 //
8406 tol = fifdmax1(5.0e0*e,acc);
8407 a2nm1 = a2n = 1.0e0;
8408 b2nm1 = *x;
8409 b2n = *x+(1.0e0-*a);
8410 c = 1.0e0;
8411 S260:
8412 a2nm1 = *x*a2n+c*a2nm1;
8413 b2nm1 = *x*b2n+c*b2nm1;
8414 am0 = a2nm1/b2nm1;
8415 c += 1.0e0;
8416 cma = c-*a;
8417 a2n = a2nm1+cma*a2n;
8418 b2n = b2nm1+cma*b2n;
8419 an0 = a2n/b2n;
8420 if(fabs(an0-am0) >= tol*an0) goto S260;
8421 *qans = r*an0;
8422 *ans = 0.5e0+(0.5e0-*qans);
8423 return;
8424 S270:
8425 //
8426 // GENERAL TEMME EXPANSION
8427 //
8428 if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430;
8429 c = exp(-y);
8430 T3 = sqrt(y);
8431 w = 0.5e0 * error_fc ( &K1, &T3 );
8432 u = 1.0e0/ *a;
8433 z = sqrt(z+z);
8434 if(l < 1.0e0) z = -z;
8435 T4 = iop-2;
8436 if(T4 < 0) goto S280;
8437 else if(T4 == 0) goto S290;
8438 else goto S300;
8439 S280:
8440 if(fabs(s) <= 1.e-3) goto S340;
8441 c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[
8442 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8443 c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5]
8444 )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8445 c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+
8446 d2[2])*z+d2[1])*z+d2[0])*z+d20;
8447 c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+
8448 d3[0])*z+d30;
8449 c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40;
8450 c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50;
8451 c6 = (d6[1]*z+d6[0])*z+d60;
8452 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8453 goto S310;
8454 S290:
8455 c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8456 c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8457 c2 = d2[0]*z+d20;
8458 t = (c2*u+c1)*u+c0;
8459 goto S310;
8460 S300:
8461 t = ((d0[2]*z+d0[1])*z+d0[0])*z-third;
8462 S310:
8463 if(l < 1.0e0) goto S320;
8464 *qans = c*(w+rt2pin*t/rta);
8465 *ans = 0.5e0+(0.5e0-*qans);
8466 return;
8467 S320:
8468 *ans = c*(w-rt2pin*t/rta);
8469 *qans = 0.5e0+(0.5e0-*ans);
8470 return;
8471 S330:
8472 //
8473 // TEMME EXPANSION FOR L = 1
8474 //
8475 if(*a*e*e > 3.28e-3) goto S430;
8476 c = 0.5e0+(0.5e0-y);
8477 w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c;
8478 u = 1.0e0/ *a;
8479 z = sqrt(z+z);
8480 if(l < 1.0e0) z = -z;
8481 T5 = iop-2;
8482 if(T5 < 0) goto S340;
8483 else if(T5 == 0) goto S350;
8484 else goto S360;
8485 S340:
8486 c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-
8487 third;
8488 c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8489 c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20;
8490 c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30;
8491 c4 = (d4[1]*z+d4[0])*z+d40;
8492 c5 = (d5[1]*z+d5[0])*z+d50;
8493 c6 = d6[0]*z+d60;
8494 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8495 goto S310;
8496 S350:
8497 c0 = (d0[1]*z+d0[0])*z-third;
8498 c1 = d1[0]*z+d10;
8499 t = (d20*u+c1)*u+c0;
8500 goto S310;
8501 S360:
8502 t = d0[0]*z-third;
8503 goto S310;
8504 S370:
8505 //
8506 // SPECIAL CASES
8507 //
8508 *ans = 0.0e0;
8509 *qans = 1.0e0;
8510 return;
8511 S380:
8512 *ans = 1.0e0;
8513 *qans = 0.0e0;
8514 return;
8515 S390:
8516 if(*x >= 0.25e0) goto S400;
8517 T6 = sqrt(*x);
8518 *ans = error_f ( &T6 );
8519 *qans = 0.5e0+(0.5e0-*ans);
8520 return;
8521 S400:
8522 T7 = sqrt(*x);
8523 *qans = error_fc ( &K2, &T7 );
8524 *ans = 0.5e0+(0.5e0-*qans);
8525 return;
8526 S410:
8527 if(fabs(s) <= 2.0e0*e) goto S430;
8528 S420:
8529 if(*x <= *a) goto S370;
8530 goto S380;
8531 S430:
8532 //
8533 // ERROR RETURN
8534 //
8535 *ans = 2.0e0;
8536 return;
8537 }
8538 //****************************************************************************80
8539
gamma_inc_inv(double * a,double * x,double * x0,double * p,double * q,int * ierr)8540 void gamma_inc_inv ( double *a, double *x, double *x0, double *p, double *q,
8541 int *ierr )
8542
8543 //****************************************************************************80
8544 //
8545 // Purpose:
8546 //
8547 // GAMMA_INC_INV computes the inverse incomplete gamma ratio function.
8548 //
8549 // Discussion:
8550 //
8551 // The routine is given positive A, and nonnegative P and Q where P + Q = 1.
8552 // The value X is computed with the property that P(A,X) = P and Q(A,X) = Q.
8553 // Schroder iteration is employed. The routine attempts to compute X
8554 // to 10 significant digits if this is possible for the particular computer
8555 // arithmetic being used.
8556 //
8557 // Author:
8558 //
8559 // Alfred H Morris, Jr,
8560 // Naval Surface Weapons Center,
8561 // Dahlgren, Virginia.
8562 //
8563 // Parameters:
8564 //
8565 // Input, double *A, the parameter in the incomplete gamma
8566 // ratio. A must be positive.
8567 //
8568 // Output, double *X, the computed point for which the
8569 // incomplete gamma functions have the values P and Q.
8570 //
8571 // Input, double *X0, an optional initial approximation
8572 // for the solution X. If the user does not want to supply an
8573 // initial approximation, then X0 should be set to 0, or a negative
8574 // value.
8575 //
8576 // Input, double *P, *Q, the values of the incomplete gamma
8577 // functions, for which the corresponding argument is desired.
8578 //
8579 // Output, int *IERR, error flag.
8580 // 0, the solution was obtained. Iteration was not used.
8581 // 0 < K, The solution was obtained. IERR iterations were performed.
8582 // -2, A <= 0
8583 // -3, No solution was obtained. The ratio Q/A is too large.
8584 // -4, P + Q /= 1
8585 // -6, 20 iterations were performed. The most recent value obtained
8586 // for X is given. This cannot occur if X0 <= 0.
8587 // -7, Iteration failed. No value is given for X.
8588 // This may occur when X is approximately 0.
8589 // -8, A value for X has been obtained, but the routine is not certain
8590 // of its accuracy. Iteration cannot be performed in this
8591 // case. If X0 <= 0, this can occur only when P or Q is
8592 // approximately 0. If X0 is positive then this can occur when A is
8593 // exceedingly close to X and A is extremely large (say A .GE. 1.E20).
8594 //
8595 {
8596 static double a0 = 3.31125922108741e0;
8597 static double a1 = 11.6616720288968e0;
8598 static double a2 = 4.28342155967104e0;
8599 static double a3 = .213623493715853e0;
8600 static double b1 = 6.61053765625462e0;
8601 static double b2 = 6.40691597760039e0;
8602 static double b3 = 1.27364489782223e0;
8603 static double b4 = .036117081018842e0;
8604 static double c = .577215664901533e0;
8605 static double ln10 = 2.302585e0;
8606 static double tol = 1.e-5;
8607 static double amin[2] = {
8608 500.0e0,100.0e0
8609 };
8610 static double bmin[2] = {
8611 1.e-28,1.e-13
8612 };
8613 static double dmin[2] = {
8614 1.e-06,1.e-04
8615 };
8616 static double emin[2] = {
8617 2.e-03,6.e-03
8618 };
8619 static double eps0[2] = {
8620 1.e-10,1.e-08
8621 };
8622 static int K1 = 1;
8623 static int K2 = 2;
8624 static int K3 = 3;
8625 static int K8 = 0;
8626 static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn,
8627 r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z;
8628 static int iop;
8629 static double T4,T5,T6,T7,T9;
8630
8631 //
8632 // E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.
8633 // E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.
8634 // XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE
8635 // LARGEST POSITIVE NUMBER.
8636 //
8637 e = dpmpar(&K1);
8638 xmin = dpmpar(&K2);
8639 xmax = dpmpar(&K3);
8640 *x = 0.0e0;
8641 if(*a <= 0.0e0) goto S300;
8642 t = *p+*q-1.e0;
8643 if(fabs(t) > e) goto S320;
8644 *ierr = 0;
8645 if(*p == 0.0e0) return;
8646 if(*q == 0.0e0) goto S270;
8647 if(*a == 1.0e0) goto S280;
8648 e2 = 2.0e0*e;
8649 amax = 0.4e-10/(e*e);
8650 iop = 1;
8651 if(e > 1.e-10) iop = 2;
8652 eps = eps0[iop-1];
8653 xn = *x0;
8654 if(*x0 > 0.0e0) goto S160;
8655 //
8656 // SELECTION OF THE INITIAL APPROXIMATION XN OF X
8657 // WHEN A .LT. 1
8658 //
8659 if(*a > 1.0e0) goto S80;
8660 T4 = *a+1.0e0;
8661 g = gamma_x(&T4);
8662 qg = *q*g;
8663 if(qg == 0.0e0) goto S360;
8664 b = qg/ *a;
8665 if(qg > 0.6e0**a) goto S40;
8666 if(*a >= 0.30e0 || b < 0.35e0) goto S10;
8667 t = exp(-(b+c));
8668 u = t*exp(t);
8669 xn = t*exp(u);
8670 goto S160;
8671 S10:
8672 if(b >= 0.45e0) goto S40;
8673 if(b == 0.0e0) goto S360;
8674 y = -log(b);
8675 s = 0.5e0+(0.5e0-*a);
8676 z = log(y);
8677 t = y-s*z;
8678 if(b < 0.15e0) goto S20;
8679 xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0));
8680 goto S220;
8681 S20:
8682 if(b <= 0.01e0) goto S30;
8683 u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0);
8684 xn = y-s*log(t)-log(u);
8685 goto S220;
8686 S30:
8687 c1 = -(s*z);
8688 c2 = -(s*(1.0e0+c1));
8689 c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a));
8690 c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+(
8691 (11.0e0**a-46.0)**a+47.0e0)/6.0e0));
8692 c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)*
8693 *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+((
8694 (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0));
8695 xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y;
8696 if(*a > 1.0e0) goto S220;
8697 if(b > bmin[iop-1]) goto S220;
8698 *x = xn;
8699 return;
8700 S40:
8701 if(b**q > 1.e-8) goto S50;
8702 xn = exp(-(*q/ *a+c));
8703 goto S70;
8704 S50:
8705 if(*p <= 0.9e0) goto S60;
8706 T5 = -*q;
8707 xn = exp((alnrel(&T5)+ gamma_ln1 ( a ) ) / *a );
8708 goto S70;
8709 S60:
8710 xn = exp(log(*p*g)/ *a);
8711 S70:
8712 if(xn == 0.0e0) goto S310;
8713 t = 0.5e0+(0.5e0-xn/(*a+1.0e0));
8714 xn /= t;
8715 goto S160;
8716 S80:
8717 //
8718 // SELECTION OF THE INITIAL APPROXIMATION XN OF X
8719 // WHEN A .GT. 1
8720 //
8721 if(*q <= 0.5e0) goto S90;
8722 w = log(*p);
8723 goto S100;
8724 S90:
8725 w = log(*q);
8726 S100:
8727 t = sqrt(-(2.0e0*w));
8728 s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0);
8729 if(*q > 0.5e0) s = -s;
8730 rta = sqrt(*a);
8731 s2 = s*s;
8732 xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)*
8733 s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a*
8734 rta);
8735 xn = fifdmax1(xn,0.0e0);
8736 if(*a < amin[iop-1]) goto S110;
8737 *x = xn;
8738 d = 0.5e0+(0.5e0-*x/ *a);
8739 if(fabs(d) <= dmin[iop-1]) return;
8740 S110:
8741 if(*p <= 0.5e0) goto S130;
8742 if(xn < 3.0e0**a) goto S220;
8743 y = -(w+ gamma_log ( a ) );
8744 d = fifdmax1(2.0e0,*a*(*a-1.0e0));
8745 if(y < ln10*d) goto S120;
8746 s = 1.0e0-*a;
8747 z = log(y);
8748 goto S30;
8749 S120:
8750 t = *a-1.0e0;
8751 T6 = -(t/(xn+1.0e0));
8752 xn = y+t*log(xn)-alnrel(&T6);
8753 T7 = -(t/(xn+1.0e0));
8754 xn = y+t*log(xn)-alnrel(&T7);
8755 goto S220;
8756 S130:
8757 ap1 = *a+1.0e0;
8758 if(xn > 0.70e0*ap1) goto S170;
8759 w += gamma_log ( &ap1 );
8760 if(xn > 0.15e0*ap1) goto S140;
8761 ap2 = *a+2.0e0;
8762 ap3 = *a+3.0e0;
8763 *x = exp((w+*x)/ *a);
8764 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
8765 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
8766 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a);
8767 xn = *x;
8768 if(xn > 1.e-2*ap1) goto S140;
8769 if(xn <= emin[iop-1]*ap1) return;
8770 goto S170;
8771 S140:
8772 apn = ap1;
8773 t = xn/apn;
8774 sum = 1.0e0+t;
8775 S150:
8776 apn += 1.0e0;
8777 t *= (xn/apn);
8778 sum += t;
8779 if(t > 1.e-4) goto S150;
8780 t = w-log(sum);
8781 xn = exp((xn+t)/ *a);
8782 xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn));
8783 goto S170;
8784 S160:
8785 //
8786 // SCHRODER ITERATION USING P
8787 //
8788 if(*p > 0.5e0) goto S220;
8789 S170:
8790 if(*p <= 1.e10*xmin) goto S350;
8791 am1 = *a-0.5e0-0.5e0;
8792 S180:
8793 if(*a <= amax) goto S190;
8794 d = 0.5e0+(0.5e0-xn/ *a);
8795 if(fabs(d) <= e2) goto S350;
8796 S190:
8797 if(*ierr >= 20) goto S330;
8798 *ierr += 1;
8799 gamma_inc ( a, &xn, &pn, &qn, &K8 );
8800 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8801 r = rcomp(a,&xn);
8802 if(r == 0.0e0) goto S350;
8803 t = (pn-*p)/r;
8804 w = 0.5e0*(am1-xn);
8805 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200;
8806 *x = xn*(1.0e0-t);
8807 if(*x <= 0.0e0) goto S340;
8808 d = fabs(t);
8809 goto S210;
8810 S200:
8811 h = t*(1.0e0+w*t);
8812 *x = xn*(1.0e0-h);
8813 if(*x <= 0.0e0) goto S340;
8814 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8815 d = fabs(h);
8816 S210:
8817 xn = *x;
8818 if(d > tol) goto S180;
8819 if(d <= eps) return;
8820 if(fabs(*p-pn) <= tol**p) return;
8821 goto S180;
8822 S220:
8823 //
8824 // SCHRODER ITERATION USING Q
8825 //
8826 if(*q <= 1.e10*xmin) goto S350;
8827 am1 = *a-0.5e0-0.5e0;
8828 S230:
8829 if(*a <= amax) goto S240;
8830 d = 0.5e0+(0.5e0-xn/ *a);
8831 if(fabs(d) <= e2) goto S350;
8832 S240:
8833 if(*ierr >= 20) goto S330;
8834 *ierr += 1;
8835 gamma_inc ( a, &xn, &pn, &qn, &K8 );
8836 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8837 r = rcomp(a,&xn);
8838 if(r == 0.0e0) goto S350;
8839 t = (*q-qn)/r;
8840 w = 0.5e0*(am1-xn);
8841 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250;
8842 *x = xn*(1.0e0-t);
8843 if(*x <= 0.0e0) goto S340;
8844 d = fabs(t);
8845 goto S260;
8846 S250:
8847 h = t*(1.0e0+w*t);
8848 *x = xn*(1.0e0-h);
8849 if(*x <= 0.0e0) goto S340;
8850 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8851 d = fabs(h);
8852 S260:
8853 xn = *x;
8854 if(d > tol) goto S230;
8855 if(d <= eps) return;
8856 if(fabs(*q-qn) <= tol**q) return;
8857 goto S230;
8858 S270:
8859 //
8860 // SPECIAL CASES
8861 //
8862 *x = xmax;
8863 return;
8864 S280:
8865 if(*q < 0.9e0) goto S290;
8866 T9 = -*p;
8867 *x = -alnrel(&T9);
8868 return;
8869 S290:
8870 *x = -log(*q);
8871 return;
8872 S300:
8873 //
8874 // ERROR RETURN
8875 //
8876 *ierr = -2;
8877 return;
8878 S310:
8879 *ierr = -3;
8880 return;
8881 S320:
8882 *ierr = -4;
8883 return;
8884 S330:
8885 *ierr = -6;
8886 return;
8887 S340:
8888 *ierr = -7;
8889 return;
8890 S350:
8891 *x = xn;
8892 *ierr = -8;
8893 return;
8894 S360:
8895 *x = xmax;
8896 *ierr = -8;
8897 return;
8898 }
8899 //****************************************************************************80
8900
gamma_inc_values(int * n_data,double * a,double * x,double * fx)8901 void gamma_inc_values ( int *n_data, double *a, double *x, double *fx )
8902
8903 //****************************************************************************80
8904 //
8905 // Purpose:
8906 //
8907 // GAMMA_INC_VALUES returns some values of the incomplete Gamma function.
8908 //
8909 // Discussion:
8910 //
8911 // The (normalized) incomplete Gamma function P(A,X) is defined as:
8912 //
8913 // PN(A,X) = 1/GAMMA(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT.
8914 //
8915 // With this definition, for all A and X,
8916 //
8917 // 0 <= PN(A,X) <= 1
8918 //
8919 // and
8920 //
8921 // PN(A,INFINITY) = 1.0
8922 //
8923 // Mathematica can compute this value as
8924 //
8925 // 1 - GammaRegularized[A,X]
8926 //
8927 // Modified:
8928 //
8929 // 31 May 2004
8930 //
8931 // Author:
8932 //
8933 // John Burkardt
8934 //
8935 // Reference:
8936 //
8937 // Milton Abramowitz and Irene Stegun,
8938 // Handbook of Mathematical Functions,
8939 // US Department of Commerce, 1964.
8940 //
8941 // Parameters:
8942 //
8943 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
8944 // first call. On each call, the routine increments N_DATA by 1, and
8945 // returns the corresponding data; when there is no more data, the
8946 // output value of N_DATA will be 0 again.
8947 //
8948 // Output, double *A, the parameter of the function.
8949 //
8950 // Output, double *X, the argument of the function.
8951 //
8952 // Output, double *FX, the value of the function.
8953 //
8954 {
8955 # define N_MAX 20
8956
8957 double a_vec[N_MAX] = {
8958 0.1E+00, 0.1E+00, 0.1E+00, 0.5E+00,
8959 0.5E+00, 0.5E+00, 1.0E+00, 1.0E+00,
8960 1.0E+00, 1.1E+00, 1.1E+00, 1.1E+00,
8961 2.0E+00, 2.0E+00, 2.0E+00, 6.0E+00,
8962 6.0E+00, 11.0E+00, 26.0E+00, 41.0E+00 };
8963 double fx_vec[N_MAX] = {
8964 0.7420263E+00, 0.9119753E+00, 0.9898955E+00, 0.2931279E+00,
8965 0.7656418E+00, 0.9921661E+00, 0.0951626E+00, 0.6321206E+00,
8966 0.9932621E+00, 0.0757471E+00, 0.6076457E+00, 0.9933425E+00,
8967 0.0091054E+00, 0.4130643E+00, 0.9931450E+00, 0.0387318E+00,
8968 0.9825937E+00, 0.9404267E+00, 0.4863866E+00, 0.7359709E+00 };
8969 double x_vec[N_MAX] = {
8970 3.1622777E-02, 3.1622777E-01, 1.5811388E+00, 7.0710678E-02,
8971 7.0710678E-01, 3.5355339E+00, 0.1000000E+00, 1.0000000E+00,
8972 5.0000000E+00, 1.0488088E-01, 1.0488088E+00, 5.2440442E+00,
8973 1.4142136E-01, 1.4142136E+00, 7.0710678E+00, 2.4494897E+00,
8974 1.2247449E+01, 1.6583124E+01, 2.5495098E+01, 4.4821870E+01 };
8975
8976 if ( *n_data < 0 )
8977 {
8978 *n_data = 0;
8979 }
8980
8981 *n_data = *n_data + 1;
8982
8983 if ( N_MAX < *n_data )
8984 {
8985 *n_data = 0;
8986 *a = 0.0E+00;
8987 *x = 0.0E+00;
8988 *fx = 0.0E+00;
8989 }
8990 else
8991 {
8992 *a = a_vec[*n_data-1];
8993 *x = x_vec[*n_data-1];
8994 *fx = fx_vec[*n_data-1];
8995 }
8996 return;
8997 # undef N_MAX
8998 }
8999 //****************************************************************************80
9000
gamma_ln1(double * a)9001 double gamma_ln1 ( double *a )
9002
9003 //****************************************************************************80
9004 //
9005 // Purpose:
9006 //
9007 // GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25.
9008 //
9009 // Parameters:
9010 //
9011 // Input, double *A, defines the argument of the function.
9012 //
9013 // Output, double GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ).
9014 //
9015 {
9016 static double p0 = .577215664901533e+00;
9017 static double p1 = .844203922187225e+00;
9018 static double p2 = -.168860593646662e+00;
9019 static double p3 = -.780427615533591e+00;
9020 static double p4 = -.402055799310489e+00;
9021 static double p5 = -.673562214325671e-01;
9022 static double p6 = -.271935708322958e-02;
9023 static double q1 = .288743195473681e+01;
9024 static double q2 = .312755088914843e+01;
9025 static double q3 = .156875193295039e+01;
9026 static double q4 = .361951990101499e+00;
9027 static double q5 = .325038868253937e-01;
9028 static double q6 = .667465618796164e-03;
9029 static double r0 = .422784335098467e+00;
9030 static double r1 = .848044614534529e+00;
9031 static double r2 = .565221050691933e+00;
9032 static double r3 = .156513060486551e+00;
9033 static double r4 = .170502484022650e-01;
9034 static double r5 = .497958207639485e-03;
9035 static double s1 = .124313399877507e+01;
9036 static double s2 = .548042109832463e+00;
9037 static double s3 = .101552187439830e+00;
9038 static double s4 = .713309612391000e-02;
9039 static double s5 = .116165475989616e-03;
9040 static double gamln1,w,x;
9041
9042 if(*a >= 0.6e0) goto S10;
9043 w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+
9044 q4)**a+q3)**a+q2)**a+q1)**a+1.0e0);
9045 gamln1 = -(*a*w);
9046 return gamln1;
9047 S10:
9048 x = *a-0.5e0-0.5e0;
9049 w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x
9050 +1.0e0);
9051 gamln1 = x*w;
9052 return gamln1;
9053 }
9054 //****************************************************************************80
9055
gamma_log(double * a)9056 double gamma_log ( double *a )
9057
9058 //****************************************************************************80
9059 //
9060 // Purpose:
9061 //
9062 // GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A.
9063 //
9064 // Author:
9065 //
9066 // Alfred H Morris, Jr,
9067 // Naval Surface Weapons Center,
9068 // Dahlgren, Virginia.
9069 //
9070 // Reference:
9071 //
9072 // Armido DiDinato and Alfred Morris,
9073 // Algorithm 708:
9074 // Significant Digit Computation of the Incomplete Beta Function Ratios,
9075 // ACM Transactions on Mathematical Software,
9076 // Volume 18, 1993, pages 360-373.
9077 //
9078 // Parameters:
9079 //
9080 // Input, double *A, the argument of the function.
9081 // A should be positive.
9082 //
9083 // Output, double GAMMA_LOG, the value of ln ( Gamma ( A ) ).
9084 //
9085 {
9086 static double c0 = .833333333333333e-01;
9087 static double c1 = -.277777777760991e-02;
9088 static double c2 = .793650666825390e-03;
9089 static double c3 = -.595202931351870e-03;
9090 static double c4 = .837308034031215e-03;
9091 static double c5 = -.165322962780713e-02;
9092 static double d = .418938533204673e0;
9093 static double gamln,t,w;
9094 static int i,n;
9095 static double T1;
9096
9097 if(*a > 0.8e0) goto S10;
9098 gamln = gamma_ln1 ( a ) - log ( *a );
9099 return gamln;
9100 S10:
9101 if(*a > 2.25e0) goto S20;
9102 t = *a-0.5e0-0.5e0;
9103 gamln = gamma_ln1 ( &t );
9104 return gamln;
9105 S20:
9106 if(*a >= 10.0e0) goto S40;
9107 n = ( int ) ( *a - 1.25e0 );
9108 t = *a;
9109 w = 1.0e0;
9110 for ( i = 1; i <= n; i++ )
9111 {
9112 t -= 1.0e0;
9113 w = t*w;
9114 }
9115 T1 = t-1.0e0;
9116 gamln = gamma_ln1 ( &T1 ) + log ( w );
9117 return gamln;
9118 S40:
9119 t = pow(1.0e0/ *a,2.0);
9120 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
9121 gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
9122 return gamln;
9123 }
9124 //****************************************************************************80
9125
gamma_rat1(double * a,double * x,double * r,double * p,double * q,double * eps)9126 void gamma_rat1 ( double *a, double *x, double *r, double *p, double *q,
9127 double *eps )
9128
9129 //****************************************************************************80
9130 //
9131 // Purpose:
9132 //
9133 // GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X).
9134 //
9135 // Parameters:
9136 //
9137 // Input, double *A, *X, the parameters of the functions.
9138 // It is assumed that A <= 1.
9139 //
9140 // Input, double *R, the value exp(-X) * X**A / Gamma(A).
9141 //
9142 // Output, double *P, *Q, the values of P(A,X) and Q(A,X).
9143 //
9144 // Input, double *EPS, the tolerance.
9145 //
9146 {
9147 static int K2 = 0;
9148 static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3;
9149
9150 if(*a**x == 0.0e0) goto S120;
9151 if(*a == 0.5e0) goto S100;
9152 if(*x < 1.1e0) goto S10;
9153 goto S60;
9154 S10:
9155 //
9156 // TAYLOR SERIES FOR P(A,X)/X**A
9157 //
9158 an = 3.0e0;
9159 c = *x;
9160 sum = *x/(*a+3.0e0);
9161 tol = 0.1e0**eps/(*a+1.0e0);
9162 S20:
9163 an += 1.0e0;
9164 c = -(c*(*x/an));
9165 t = c/(*a+an);
9166 sum += t;
9167 if(fabs(t) > tol) goto S20;
9168 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
9169 z = *a*log(*x);
9170 h = gam1(a);
9171 g = 1.0e0+h;
9172 if(*x < 0.25e0) goto S30;
9173 if(*a < *x/2.59e0) goto S50;
9174 goto S40;
9175 S30:
9176 if(z > -.13394e0) goto S50;
9177 S40:
9178 w = exp(z);
9179 *p = w*g*(0.5e0+(0.5e0-j));
9180 *q = 0.5e0+(0.5e0-*p);
9181 return;
9182 S50:
9183 l = rexp(&z);
9184 w = 0.5e0+(0.5e0+l);
9185 *q = (w*j-l)*g-h;
9186 if(*q < 0.0e0) goto S90;
9187 *p = 0.5e0+(0.5e0-*q);
9188 return;
9189 S60:
9190 //
9191 // CONTINUED FRACTION EXPANSION
9192 //
9193 a2nm1 = a2n = 1.0e0;
9194 b2nm1 = *x;
9195 b2n = *x+(1.0e0-*a);
9196 c = 1.0e0;
9197 S70:
9198 a2nm1 = *x*a2n+c*a2nm1;
9199 b2nm1 = *x*b2n+c*b2nm1;
9200 am0 = a2nm1/b2nm1;
9201 c += 1.0e0;
9202 cma = c-*a;
9203 a2n = a2nm1+cma*a2n;
9204 b2n = b2nm1+cma*b2n;
9205 an0 = a2n/b2n;
9206 if(fabs(an0-am0) >= *eps*an0) goto S70;
9207 *q = *r*an0;
9208 *p = 0.5e0+(0.5e0-*q);
9209 return;
9210 S80:
9211 //
9212 // SPECIAL CASES
9213 //
9214 *p = 0.0e0;
9215 *q = 1.0e0;
9216 return;
9217 S90:
9218 *p = 1.0e0;
9219 *q = 0.0e0;
9220 return;
9221 S100:
9222 if(*x >= 0.25e0) goto S110;
9223 T1 = sqrt(*x);
9224 *p = error_f ( &T1 );
9225 *q = 0.5e0+(0.5e0-*p);
9226 return;
9227 S110:
9228 T3 = sqrt(*x);
9229 *q = error_fc ( &K2, &T3 );
9230 *p = 0.5e0+(0.5e0-*q);
9231 return;
9232 S120:
9233 if(*x <= *a) goto S80;
9234 goto S90;
9235 }
9236 //****************************************************************************80
9237
gamma_values(int * n_data,double * x,double * fx)9238 void gamma_values ( int *n_data, double *x, double *fx )
9239
9240 //****************************************************************************80
9241 //
9242 // Purpose:
9243 //
9244 // GAMMA_VALUES returns some values of the Gamma function.
9245 //
9246 // Definition:
9247 //
9248 // GAMMA(Z) = Integral ( 0 <= T < Infinity) T**(Z-1) EXP(-T) dT
9249 //
9250 // Recursion:
9251 //
9252 // GAMMA(X+1) = X*GAMMA(X)
9253 //
9254 // Restrictions:
9255 //
9256 // 0 < X ( a software restriction).
9257 //
9258 // Special values:
9259 //
9260 // GAMMA(0.5) = sqrt(PI)
9261 //
9262 // For N a positive integer, GAMMA(N+1) = N!, the standard factorial.
9263 //
9264 // Modified:
9265 //
9266 // 31 May 2004
9267 //
9268 // Author:
9269 //
9270 // John Burkardt
9271 //
9272 // Reference:
9273 //
9274 // Milton Abramowitz and Irene Stegun,
9275 // Handbook of Mathematical Functions,
9276 // US Department of Commerce, 1964.
9277 //
9278 // Parameters:
9279 //
9280 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
9281 // first call. On each call, the routine increments N_DATA by 1, and
9282 // returns the corresponding data; when there is no more data, the
9283 // output value of N_DATA will be 0 again.
9284 //
9285 // Output, double *X, the argument of the function.
9286 //
9287 // Output, double *FX, the value of the function.
9288 //
9289 {
9290 # define N_MAX 18
9291
9292 double fx_vec[N_MAX] = {
9293 4.590845E+00, 2.218160E+00, 1.489192E+00, 1.164230E+00,
9294 1.0000000000E+00, 0.9513507699E+00, 0.9181687424E+00, 0.8974706963E+00,
9295 0.8872638175E+00, 0.8862269255E+00, 0.8935153493E+00, 0.9086387329E+00,
9296 0.9313837710E+00, 0.9617658319E+00, 1.0000000000E+00, 3.6288000E+05,
9297 1.2164510E+17, 8.8417620E+30 };
9298 double x_vec[N_MAX] = {
9299 0.2E+00, 0.4E+00, 0.6E+00, 0.8E+00,
9300 1.0E+00, 1.1E+00, 1.2E+00, 1.3E+00,
9301 1.4E+00, 1.5E+00, 1.6E+00, 1.7E+00,
9302 1.8E+00, 1.9E+00, 2.0E+00, 10.0E+00,
9303 20.0E+00, 30.0E+00 };
9304
9305 if ( *n_data < 0 )
9306 {
9307 *n_data = 0;
9308 }
9309
9310 *n_data = *n_data + 1;
9311
9312 if ( N_MAX < *n_data )
9313 {
9314 *n_data = 0;
9315 *x = 0.0E+00;
9316 *fx = 0.0E+00;
9317 }
9318 else
9319 {
9320 *x = x_vec[*n_data-1];
9321 *fx = fx_vec[*n_data-1];
9322 }
9323 return;
9324 # undef N_MAX
9325 }
9326 //****************************************************************************80
9327
gamma_x(double * a)9328 double gamma_x ( double *a )
9329
9330 //****************************************************************************80
9331 //
9332 // Purpose:
9333 //
9334 // GAMMA_X evaluates the gamma function.
9335 //
9336 // Discussion:
9337 //
9338 // This routine was renamed from "GAMMA" to avoid a conflict with the
9339 // C/C++ math library routine.
9340 //
9341 // Author:
9342 //
9343 // Alfred H Morris, Jr,
9344 // Naval Surface Weapons Center,
9345 // Dahlgren, Virginia.
9346 //
9347 // Parameters:
9348 //
9349 // Input, double *A, the argument of the Gamma function.
9350 //
9351 // Output, double GAMMA_X, the value of the Gamma function.
9352 //
9353 {
9354 static double d = .41893853320467274178e0;
9355 static double pi = 3.1415926535898e0;
9356 static double r1 = .820756370353826e-03;
9357 static double r2 = -.595156336428591e-03;
9358 static double r3 = .793650663183693e-03;
9359 static double r4 = -.277777777770481e-02;
9360 static double r5 = .833333333333333e-01;
9361 static double p[7] = {
9362 .539637273585445e-03,.261939260042690e-02,.204493667594920e-01,
9363 .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0
9364 };
9365 static double q[7] = {
9366 -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01,
9367 -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0
9368 };
9369 static int K2 = 3;
9370 static int K3 = 0;
9371 static double Xgamm,bot,g,lnx,s,t,top,w,x,z;
9372 static int i,j,m,n,T1;
9373
9374 Xgamm = 0.0e0;
9375 x = *a;
9376 if(fabs(*a) >= 15.0e0) goto S110;
9377 //
9378 // EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15
9379 //
9380 t = 1.0e0;
9381 m = fifidint(*a)-1;
9382 //
9383 // LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
9384 //
9385 T1 = m;
9386 if(T1 < 0) goto S40;
9387 else if(T1 == 0) goto S30;
9388 else goto S10;
9389 S10:
9390 for ( j = 1; j <= m; j++ )
9391 {
9392 x -= 1.0e0;
9393 t = x*t;
9394 }
9395 S30:
9396 x -= 1.0e0;
9397 goto S80;
9398 S40:
9399 //
9400 // LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
9401 //
9402 t = *a;
9403 if(*a > 0.0e0) goto S70;
9404 m = -m-1;
9405 if(m == 0) goto S60;
9406 for ( j = 1; j <= m; j++ )
9407 {
9408 x += 1.0e0;
9409 t = x*t;
9410 }
9411 S60:
9412 x += (0.5e0+0.5e0);
9413 t = x*t;
9414 if(t == 0.0e0) return Xgamm;
9415 S70:
9416 //
9417 // THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
9418 // CODE MAY BE OMITTED IF DESIRED.
9419 //
9420 if(fabs(t) >= 1.e-30) goto S80;
9421 if(fabs(t)*dpmpar(&K2) <= 1.0001e0) return Xgamm;
9422 Xgamm = 1.0e0/t;
9423 return Xgamm;
9424 S80:
9425 //
9426 // COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1
9427 //
9428 top = p[0];
9429 bot = q[0];
9430 for ( i = 1; i < 7; i++ )
9431 {
9432 top = p[i]+x*top;
9433 bot = q[i]+x*bot;
9434 }
9435 Xgamm = top/bot;
9436 //
9437 // TERMINATION
9438 //
9439 if(*a < 1.0e0) goto S100;
9440 Xgamm *= t;
9441 return Xgamm;
9442 S100:
9443 Xgamm /= t;
9444 return Xgamm;
9445 S110:
9446 //
9447 // EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15
9448 //
9449 if(fabs(*a) >= 1.e3) return Xgamm;
9450 if(*a > 0.0e0) goto S120;
9451 x = -*a;
9452 n = ( int ) x;
9453 t = x-(double)n;
9454 if(t > 0.9e0) t = 1.0e0-t;
9455 s = sin(pi*t)/pi;
9456 if(fifmod(n,2) == 0) s = -s;
9457 if(s == 0.0e0) return Xgamm;
9458 S120:
9459 //
9460 // COMPUTE THE MODIFIED ASYMPTOTIC SUM
9461 //
9462 t = 1.0e0/(x*x);
9463 g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x;
9464 //
9465 // ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X)
9466 // BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.
9467 //
9468 lnx = log(x);
9469 //
9470 // FINAL ASSEMBLY
9471 //
9472 z = x;
9473 g = d+g+(z-0.5e0)*(lnx-1.e0);
9474 w = g;
9475 t = g-w;
9476 if(w > 0.99999e0*exparg(&K3)) return Xgamm;
9477 Xgamm = exp(w)*(1.0e0+t);
9478 if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x;
9479 return Xgamm;
9480 }
9481 //****************************************************************************80
9482
gsumln(double * a,double * b)9483 double gsumln ( double *a, double *b )
9484
9485 //****************************************************************************80
9486 //
9487 // Purpose:
9488 //
9489 // GSUMLN evaluates the function ln(Gamma(A + B)).
9490 //
9491 // Discussion:
9492 //
9493 // GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2
9494 //
9495 // Parameters:
9496 //
9497 // Input, double *A, *B, values whose sum is the argument of
9498 // the Gamma function.
9499 //
9500 // Output, double GSUMLN, the value of ln(Gamma(A+B)).
9501 //
9502 {
9503 static double gsumln,x,T1,T2;
9504
9505 x = *a+*b-2.e0;
9506 if(x > 0.25e0) goto S10;
9507 T1 = 1.0e0+x;
9508 gsumln = gamma_ln1 ( &T1 );
9509 return gsumln;
9510 S10:
9511 if(x > 1.25e0) goto S20;
9512 gsumln = gamma_ln1 ( &x ) + alnrel ( &x );
9513 return gsumln;
9514 S20:
9515 T2 = x-1.0e0;
9516 gsumln = gamma_ln1 ( &T2 ) + log ( x * ( 1.0e0 + x ) );
9517 return gsumln;
9518 }
9519 //****************************************************************************80
9520
ipmpar(int * i)9521 int ipmpar ( int *i )
9522
9523 //****************************************************************************80
9524 //
9525 // Purpose:
9526 //
9527 // IPMPAR returns integer machine constants.
9528 //
9529 // Discussion:
9530 //
9531 // Input arguments 1 through 3 are queries about integer arithmetic.
9532 // We assume integers are represented in the N-digit, base-A form
9533 //
9534 // sign * ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
9535 //
9536 // where 0 <= X(0:N-1) < A.
9537 //
9538 // Then:
9539 //
9540 // IPMPAR(1) = A, the base of integer arithmetic;
9541 // IPMPAR(2) = N, the number of base A digits;
9542 // IPMPAR(3) = A**N - 1, the largest magnitude.
9543 //
9544 // It is assumed that the single and double precision floating
9545 // point arithmetics have the same base, say B, and that the
9546 // nonzero numbers are represented in the form
9547 //
9548 // sign * (B**E) * (X(1)/B + ... + X(M)/B**M)
9549 //
9550 // where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and
9551 // EMIN <= E <= EMAX.
9552 //
9553 // Input argument 4 is a query about the base of real arithmetic:
9554 //
9555 // IPMPAR(4) = B, the base of single and double precision arithmetic.
9556 //
9557 // Input arguments 5 through 7 are queries about single precision
9558 // floating point arithmetic:
9559 //
9560 // IPMPAR(5) = M, the number of base B digits for single precision.
9561 // IPMPAR(6) = EMIN, the smallest exponent E for single precision.
9562 // IPMPAR(7) = EMAX, the largest exponent E for single precision.
9563 //
9564 // Input arguments 8 through 10 are queries about double precision
9565 // floating point arithmetic:
9566 //
9567 // IPMPAR(8) = M, the number of base B digits for double precision.
9568 // IPMPAR(9) = EMIN, the smallest exponent E for double precision.
9569 // IPMPAR(10) = EMAX, the largest exponent E for double precision.
9570 //
9571 // Reference:
9572 //
9573 // Phyllis Fox, Andrew Hall, and Norman Schryer,
9574 // Algorithm 528,
9575 // Framework for a Portable FORTRAN Subroutine Library,
9576 // ACM Transactions on Mathematical Software,
9577 // Volume 4, 1978, pages 176-188.
9578 //
9579 // Parameters:
9580 //
9581 // Input, int *I, the index of the desired constant.
9582 //
9583 // Output, int IPMPAR, the value of the desired constant.
9584 //
9585 {
9586 static int imach[11];
9587 static int ipmpar;
9588 // MACHINE CONSTANTS FOR AMDAHL MACHINES.
9589 //
9590 // imach[1] = 2;
9591 // imach[2] = 31;
9592 // imach[3] = 2147483647;
9593 // imach[4] = 16;
9594 // imach[5] = 6;
9595 // imach[6] = -64;
9596 // imach[7] = 63;
9597 // imach[8] = 14;
9598 // imach[9] = -64;
9599 // imach[10] = 63;
9600 //
9601 // MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T
9602 // PC 7300, AND AT&T 6300.
9603 //
9604 // imach[1] = 2;
9605 // imach[2] = 31;
9606 // imach[3] = 2147483647;
9607 // imach[4] = 2;
9608 // imach[5] = 24;
9609 // imach[6] = -125;
9610 // imach[7] = 128;
9611 // imach[8] = 53;
9612 // imach[9] = -1021;
9613 // imach[10] = 1024;
9614 //
9615 // MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
9616 //
9617 // imach[1] = 2;
9618 // imach[2] = 33;
9619 // imach[3] = 8589934591;
9620 // imach[4] = 2;
9621 // imach[5] = 24;
9622 // imach[6] = -256;
9623 // imach[7] = 255;
9624 // imach[8] = 60;
9625 // imach[9] = -256;
9626 // imach[10] = 255;
9627 //
9628 // MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
9629 //
9630 // imach[1] = 2;
9631 // imach[2] = 39;
9632 // imach[3] = 549755813887;
9633 // imach[4] = 8;
9634 // imach[5] = 13;
9635 // imach[6] = -50;
9636 // imach[7] = 76;
9637 // imach[8] = 26;
9638 // imach[9] = -50;
9639 // imach[10] = 76;
9640 //
9641 // MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
9642 //
9643 // imach[1] = 2;
9644 // imach[2] = 39;
9645 // imach[3] = 549755813887;
9646 // imach[4] = 8;
9647 // imach[5] = 13;
9648 // imach[6] = -50;
9649 // imach[7] = 76;
9650 // imach[8] = 26;
9651 // imach[9] = -32754;
9652 // imach[10] = 32780;
9653 //
9654 // MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
9655 // 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT
9656 // ARITHMETIC (NOS OPERATING SYSTEM).
9657 //
9658 // imach[1] = 2;
9659 // imach[2] = 48;
9660 // imach[3] = 281474976710655;
9661 // imach[4] = 2;
9662 // imach[5] = 48;
9663 // imach[6] = -974;
9664 // imach[7] = 1070;
9665 // imach[8] = 95;
9666 // imach[9] = -926;
9667 // imach[10] = 1070;
9668 //
9669 // MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT
9670 // ARITHMETIC (NOS/VE OPERATING SYSTEM).
9671 //
9672 // imach[1] = 2;
9673 // imach[2] = 63;
9674 // imach[3] = 9223372036854775807;
9675 // imach[4] = 2;
9676 // imach[5] = 48;
9677 // imach[6] = -4096;
9678 // imach[7] = 4095;
9679 // imach[8] = 96;
9680 // imach[9] = -4096;
9681 // imach[10] = 4095;
9682 //
9683 // MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
9684 //
9685 // imach[1] = 2;
9686 // imach[2] = 63;
9687 // imach[3] = 9223372036854775807;
9688 // imach[4] = 2;
9689 // imach[5] = 47;
9690 // imach[6] = -8189;
9691 // imach[7] = 8190;
9692 // imach[8] = 94;
9693 // imach[9] = -8099;
9694 // imach[10] = 8190;
9695 //
9696 // MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200.
9697 //
9698 // imach[1] = 2;
9699 // imach[2] = 15;
9700 // imach[3] = 32767;
9701 // imach[4] = 16;
9702 // imach[5] = 6;
9703 // imach[6] = -64;
9704 // imach[7] = 63;
9705 // imach[8] = 14;
9706 // imach[9] = -64;
9707 // imach[10] = 63;
9708 //
9709 // MACHINE CONSTANTS FOR THE HARRIS 220.
9710 //
9711 // imach[1] = 2;
9712 // imach[2] = 23;
9713 // imach[3] = 8388607;
9714 // imach[4] = 2;
9715 // imach[5] = 23;
9716 // imach[6] = -127;
9717 // imach[7] = 127;
9718 // imach[8] = 38;
9719 // imach[9] = -127;
9720 // imach[10] = 127;
9721 //
9722 // MACHINE CONSTANTS FOR THE HONEYWELL 600/6000
9723 // AND DPS 8/70 SERIES.
9724 //
9725 // imach[1] = 2;
9726 // imach[2] = 35;
9727 // imach[3] = 34359738367;
9728 // imach[4] = 2;
9729 // imach[5] = 27;
9730 // imach[6] = -127;
9731 // imach[7] = 127;
9732 // imach[8] = 63;
9733 // imach[9] = -127;
9734 // imach[10] = 127;
9735 //
9736 // MACHINE CONSTANTS FOR THE HP 2100
9737 // 3 WORD DOUBLE PRECISION OPTION WITH FTN4
9738 //
9739 // imach[1] = 2;
9740 // imach[2] = 15;
9741 // imach[3] = 32767;
9742 // imach[4] = 2;
9743 // imach[5] = 23;
9744 // imach[6] = -128;
9745 // imach[7] = 127;
9746 // imach[8] = 39;
9747 // imach[9] = -128;
9748 // imach[10] = 127;
9749 //
9750 // MACHINE CONSTANTS FOR THE HP 2100
9751 // 4 WORD DOUBLE PRECISION OPTION WITH FTN4
9752 //
9753 // imach[1] = 2;
9754 // imach[2] = 15;
9755 // imach[3] = 32767;
9756 // imach[4] = 2;
9757 // imach[5] = 23;
9758 // imach[6] = -128;
9759 // imach[7] = 127;
9760 // imach[8] = 55;
9761 // imach[9] = -128;
9762 // imach[10] = 127;
9763 //
9764 // MACHINE CONSTANTS FOR THE HP 9000.
9765 //
9766 // imach[1] = 2;
9767 // imach[2] = 31;
9768 // imach[3] = 2147483647;
9769 // imach[4] = 2;
9770 // imach[5] = 24;
9771 // imach[6] = -126;
9772 // imach[7] = 128;
9773 // imach[8] = 53;
9774 // imach[9] = -1021;
9775 // imach[10] = 1024;
9776 //
9777 // MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
9778 // THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA
9779 // 5/7/9 AND THE SEL SYSTEMS 85/86.
9780 //
9781 // imach[1] = 2;
9782 // imach[2] = 31;
9783 // imach[3] = 2147483647;
9784 // imach[4] = 16;
9785 // imach[5] = 6;
9786 // imach[6] = -64;
9787 // imach[7] = 63;
9788 // imach[8] = 14;
9789 // imach[9] = -64;
9790 // imach[10] = 63;
9791 //
9792 // MACHINE CONSTANTS FOR THE IBM PC.
9793 //
9794 // imach[1] = 2;
9795 // imach[2] = 31;
9796 // imach[3] = 2147483647;
9797 // imach[4] = 2;
9798 // imach[5] = 24;
9799 // imach[6] = -125;
9800 // imach[7] = 128;
9801 // imach[8] = 53;
9802 // imach[9] = -1021;
9803 // imach[10] = 1024;
9804 //
9805 // MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT
9806 // MACFORTRAN II.
9807 //
9808 // imach[1] = 2;
9809 // imach[2] = 31;
9810 // imach[3] = 2147483647;
9811 // imach[4] = 2;
9812 // imach[5] = 24;
9813 // imach[6] = -125;
9814 // imach[7] = 128;
9815 // imach[8] = 53;
9816 // imach[9] = -1021;
9817 // imach[10] = 1024;
9818 //
9819 // MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN.
9820 //
9821 // imach[1] = 2;
9822 // imach[2] = 31;
9823 // imach[3] = 2147483647;
9824 // imach[4] = 2;
9825 // imach[5] = 24;
9826 // imach[6] = -127;
9827 // imach[7] = 127;
9828 // imach[8] = 56;
9829 // imach[9] = -127;
9830 // imach[10] = 127;
9831 //
9832 // MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
9833 //
9834 // imach[1] = 2;
9835 // imach[2] = 35;
9836 // imach[3] = 34359738367;
9837 // imach[4] = 2;
9838 // imach[5] = 27;
9839 // imach[6] = -128;
9840 // imach[7] = 127;
9841 // imach[8] = 54;
9842 // imach[9] = -101;
9843 // imach[10] = 127;
9844 //
9845 // MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
9846 //
9847 // imach[1] = 2;
9848 // imach[2] = 35;
9849 // imach[3] = 34359738367;
9850 // imach[4] = 2;
9851 // imach[5] = 27;
9852 // imach[6] = -128;
9853 // imach[7] = 127;
9854 // imach[8] = 62;
9855 // imach[9] = -128;
9856 // imach[10] = 127;
9857 //
9858 // MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
9859 // 32-BIT INTEGER ARITHMETIC.
9860 //
9861 // imach[1] = 2;
9862 // imach[2] = 31;
9863 // imach[3] = 2147483647;
9864 // imach[4] = 2;
9865 // imach[5] = 24;
9866 // imach[6] = -127;
9867 // imach[7] = 127;
9868 // imach[8] = 56;
9869 // imach[9] = -127;
9870 // imach[10] = 127;
9871 //
9872 // MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
9873 //
9874 // imach[1] = 2;
9875 // imach[2] = 31;
9876 // imach[3] = 2147483647;
9877 // imach[4] = 2;
9878 // imach[5] = 24;
9879 // imach[6] = -125;
9880 // imach[7] = 128;
9881 // imach[8] = 53;
9882 // imach[9] = -1021;
9883 // imach[10] = 1024;
9884 //
9885 // MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D
9886 // SERIES (MIPS R3000 PROCESSOR).
9887 //
9888 // imach[1] = 2;
9889 // imach[2] = 31;
9890 // imach[3] = 2147483647;
9891 // imach[4] = 2;
9892 // imach[5] = 24;
9893 // imach[6] = -125;
9894 // imach[7] = 128;
9895 // imach[8] = 53;
9896 // imach[9] = -1021;
9897 // imach[10] = 1024;
9898 //
9899 // MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
9900 // 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
9901 // PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300).
9902
9903 imach[1] = 2;
9904 imach[2] = 31;
9905 imach[3] = 2147483647;
9906 imach[4] = 2;
9907 imach[5] = 24;
9908 imach[6] = -125;
9909 imach[7] = 128;
9910 imach[8] = 53;
9911 imach[9] = -1021;
9912 imach[10] = 1024;
9913
9914 // MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
9915 //
9916 // imach[1] = 2;
9917 // imach[2] = 35;
9918 // imach[3] = 34359738367;
9919 // imach[4] = 2;
9920 // imach[5] = 27;
9921 // imach[6] = -128;
9922 // imach[7] = 127;
9923 // imach[8] = 60;
9924 // imach[9] = -1024;
9925 // imach[10] = 1023;
9926 //
9927 // MACHINE CONSTANTS FOR THE VAX 11/780.
9928 //
9929 // imach[1] = 2;
9930 // imach[2] = 31;
9931 // imach[3] = 2147483647;
9932 // imach[4] = 2;
9933 // imach[5] = 24;
9934 // imach[6] = -127;
9935 // imach[7] = 127;
9936 // imach[8] = 56;
9937 // imach[9] = -127;
9938 // imach[10] = 127;
9939 //
9940 ipmpar = imach[*i];
9941 return ipmpar;
9942 }
9943 //****************************************************************************80
9944
negative_binomial_cdf_values(int * n_data,int * f,int * s,double * p,double * cdf)9945 void negative_binomial_cdf_values ( int *n_data, int *f, int *s, double *p,
9946 double *cdf )
9947
9948 //****************************************************************************80
9949 //
9950 // Purpose:
9951 //
9952 // NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF.
9953 //
9954 // Discussion:
9955 //
9956 // Assume that a coin has a probability P of coming up heads on
9957 // any one trial. Suppose that we plan to flip the coin until we
9958 // achieve a total of S heads. If we let F represent the number of
9959 // tails that occur in this process, then the value of F satisfies
9960 // a negative binomial PDF:
9961 //
9962 // PDF(F,S,P) = Choose ( F from F+S-1 ) * P**S * (1-P)**F
9963 //
9964 // The negative binomial CDF is the probability that there are F or
9965 // fewer failures upon the attainment of the S-th success. Thus,
9966 //
9967 // CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P)
9968 //
9969 // Modified:
9970 //
9971 // 07 June 2004
9972 //
9973 // Author:
9974 //
9975 // John Burkardt
9976 //
9977 // Reference:
9978 //
9979 // F C Powell,
9980 // Statistical Tables for Sociology, Biology and Physical Sciences,
9981 // Cambridge University Press, 1982.
9982 //
9983 // Parameters:
9984 //
9985 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
9986 // first call. On each call, the routine increments N_DATA by 1, and
9987 // returns the corresponding data; when there is no more data, the
9988 // output value of N_DATA will be 0 again.
9989 //
9990 // Output, int *F, the maximum number of failures.
9991 //
9992 // Output, int *S, the number of successes.
9993 //
9994 // Output, double *P, the probability of a success on one trial.
9995 //
9996 // Output, double *CDF, the probability of at most F failures before the
9997 // S-th success.
9998 //
9999 {
10000 # define N_MAX 27
10001
10002 double cdf_vec[N_MAX] = {
10003 0.6367, 0.3633, 0.1445,
10004 0.5000, 0.2266, 0.0625,
10005 0.3438, 0.1094, 0.0156,
10006 0.1792, 0.0410, 0.0041,
10007 0.0705, 0.0109, 0.0007,
10008 0.9862, 0.9150, 0.7472,
10009 0.8499, 0.5497, 0.2662,
10010 0.6513, 0.2639, 0.0702,
10011 1.0000, 0.0199, 0.0001 };
10012 int f_vec[N_MAX] = {
10013 4, 3, 2,
10014 3, 2, 1,
10015 2, 1, 0,
10016 2, 1, 0,
10017 2, 1, 0,
10018 11, 10, 9,
10019 17, 16, 15,
10020 9, 8, 7,
10021 2, 1, 0 };
10022 double p_vec[N_MAX] = {
10023 0.50, 0.50, 0.50,
10024 0.50, 0.50, 0.50,
10025 0.50, 0.50, 0.50,
10026 0.40, 0.40, 0.40,
10027 0.30, 0.30, 0.30,
10028 0.30, 0.30, 0.30,
10029 0.10, 0.10, 0.10,
10030 0.10, 0.10, 0.10,
10031 0.01, 0.01, 0.01 };
10032 int s_vec[N_MAX] = {
10033 4, 5, 6,
10034 4, 5, 6,
10035 4, 5, 6,
10036 4, 5, 6,
10037 4, 5, 6,
10038 1, 2, 3,
10039 1, 2, 3,
10040 1, 2, 3,
10041 0, 1, 2 };
10042
10043 if ( *n_data < 0 )
10044 {
10045 *n_data = 0;
10046 }
10047
10048 *n_data = *n_data + 1;
10049
10050 if ( N_MAX < *n_data )
10051 {
10052 *n_data = 0;
10053 *f = 0;
10054 *s = 0;
10055 *p = 0.0E+00;
10056 *cdf = 0.0E+00;
10057 }
10058 else
10059 {
10060 *f = f_vec[*n_data-1];
10061 *s = s_vec[*n_data-1];
10062 *p = p_vec[*n_data-1];
10063 *cdf = cdf_vec[*n_data-1];
10064 }
10065
10066 return;
10067 # undef N_MAX
10068 }
10069 //****************************************************************************80
10070
normal_cdf_values(int * n_data,double * x,double * fx)10071 void normal_cdf_values ( int *n_data, double *x, double *fx )
10072
10073 //****************************************************************************80
10074 //
10075 // Purpose:
10076 //
10077 // NORMAL_CDF_VALUES returns some values of the Normal CDF.
10078 //
10079 // Modified:
10080 //
10081 // 31 May 2004
10082 //
10083 // Author:
10084 //
10085 // John Burkardt
10086 //
10087 // Reference:
10088 //
10089 // Milton Abramowitz and Irene Stegun,
10090 // Handbook of Mathematical Functions,
10091 // US Department of Commerce, 1964.
10092 //
10093 // Parameters:
10094 //
10095 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10096 // first call. On each call, the routine increments N_DATA by 1, and
10097 // returns the corresponding data; when there is no more data, the
10098 // output value of N_DATA will be 0 again.
10099 //
10100 // Output, double *X, the argument of the function.
10101 //
10102 // Output double *FX, the value of the function.
10103 //
10104 {
10105 # define N_MAX 13
10106
10107 double fx_vec[N_MAX] = {
10108 0.500000000000000E+00, 0.539827837277029E+00, 0.579259709439103E+00,
10109 0.617911422188953E+00, 0.655421741610324E+00, 0.691462461274013E+00,
10110 0.725746882249927E+00, 0.758036347776927E+00, 0.788144601416604E+00,
10111 0.815939874653241E+00, 0.841344746068543E+00, 0.933192798731142E+00,
10112 0.977249868051821E+00 };
10113 double x_vec[N_MAX] = {
10114 0.00E+00, 0.10E+00, 0.20E+00,
10115 0.30E+00, 0.40E+00, 0.50E+00,
10116 0.60E+00, 0.70E+00, 0.80E+00,
10117 0.90E+00, 1.00E+00, 1.50E+00,
10118 2.00E+00 };
10119
10120 if ( *n_data < 0 )
10121 {
10122 *n_data = 0;
10123 }
10124
10125 *n_data = *n_data + 1;
10126
10127 if ( N_MAX < *n_data )
10128 {
10129 *n_data = 0;
10130 *x = 0.0E+00;
10131 *fx = 0.0E+00;
10132 }
10133 else
10134 {
10135 *x = x_vec[*n_data-1];
10136 *fx = fx_vec[*n_data-1];
10137 }
10138
10139 return;
10140 # undef N_MAX
10141 }
10142 //****************************************************************************80
10143
poisson_cdf_values(int * n_data,double * a,int * x,double * fx)10144 void poisson_cdf_values ( int *n_data, double *a, int *x, double *fx )
10145
10146 //****************************************************************************80
10147 //
10148 // Purpose:
10149 //
10150 // POISSON_CDF_VALUES returns some values of the Poisson CDF.
10151 //
10152 // Discussion:
10153 //
10154 // CDF(X)(A) is the probability of at most X successes in unit time,
10155 // given that the expected mean number of successes is A.
10156 //
10157 // Modified:
10158 //
10159 // 31 May 2004
10160 //
10161 // Author:
10162 //
10163 // John Burkardt
10164 //
10165 // Reference:
10166 //
10167 // Milton Abramowitz and Irene Stegun,
10168 // Handbook of Mathematical Functions,
10169 // US Department of Commerce, 1964.
10170 //
10171 // Daniel Zwillinger,
10172 // CRC Standard Mathematical Tables and Formulae,
10173 // 30th Edition, CRC Press, 1996, pages 653-658.
10174 //
10175 // Parameters:
10176 //
10177 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10178 // first call. On each call, the routine increments N_DATA by 1, and
10179 // returns the corresponding data; when there is no more data, the
10180 // output value of N_DATA will be 0 again.
10181 //
10182 // Output, double *A, the parameter of the function.
10183 //
10184 // Output, int *X, the argument of the function.
10185 //
10186 // Output, double *FX, the value of the function.
10187 //
10188 {
10189 # define N_MAX 21
10190
10191 double a_vec[N_MAX] = {
10192 0.02E+00, 0.10E+00, 0.10E+00, 0.50E+00,
10193 0.50E+00, 0.50E+00, 1.00E+00, 1.00E+00,
10194 1.00E+00, 1.00E+00, 2.00E+00, 2.00E+00,
10195 2.00E+00, 2.00E+00, 5.00E+00, 5.00E+00,
10196 5.00E+00, 5.00E+00, 5.00E+00, 5.00E+00,
10197 5.00E+00 };
10198 double fx_vec[N_MAX] = {
10199 0.980E+00, 0.905E+00, 0.995E+00, 0.607E+00,
10200 0.910E+00, 0.986E+00, 0.368E+00, 0.736E+00,
10201 0.920E+00, 0.981E+00, 0.135E+00, 0.406E+00,
10202 0.677E+00, 0.857E+00, 0.007E+00, 0.040E+00,
10203 0.125E+00, 0.265E+00, 0.441E+00, 0.616E+00,
10204 0.762E+00 };
10205 int x_vec[N_MAX] = {
10206 0, 0, 1, 0,
10207 1, 2, 0, 1,
10208 2, 3, 0, 1,
10209 2, 3, 0, 1,
10210 2, 3, 4, 5,
10211 6 };
10212
10213 if ( *n_data < 0 )
10214 {
10215 *n_data = 0;
10216 }
10217
10218 *n_data = *n_data + 1;
10219
10220 if ( N_MAX < *n_data )
10221 {
10222 *n_data = 0;
10223 *a = 0.0E+00;
10224 *x = 0;
10225 *fx = 0.0E+00;
10226 }
10227 else
10228 {
10229 *a = a_vec[*n_data-1];
10230 *x = x_vec[*n_data-1];
10231 *fx = fx_vec[*n_data-1];
10232 }
10233 return;
10234 # undef N_MAX
10235 }
10236 //****************************************************************************80
10237
psi(double * xx)10238 double psi ( double *xx )
10239
10240 //****************************************************************************80
10241 //
10242 // Purpose:
10243 //
10244 // PSI evaluates the psi or digamma function, d/dx ln(gamma(x)).
10245 //
10246 // Discussion:
10247 //
10248 // The main computation involves evaluation of rational Chebyshev
10249 // approximations. PSI was written at Argonne National Laboratory
10250 // for FUNPACK, and subsequently modified by A. H. Morris of NSWC.
10251 //
10252 // Reference:
10253 //
10254 // William Cody, Strecok and Thacher,
10255 // Chebyshev Approximations for the Psi Function,
10256 // Mathematics of Computation,
10257 // Volume 27, 1973, pages 123-127.
10258 //
10259 // Parameters:
10260 //
10261 // Input, double *XX, the argument of the psi function.
10262 //
10263 // Output, double PSI, the value of the psi function. PSI
10264 // is assigned the value 0 when the psi function is undefined.
10265 //
10266 {
10267 static double dx0 = 1.461632144968362341262659542325721325e0;
10268 static double piov4 = .785398163397448e0;
10269 static double p1[7] = {
10270 .895385022981970e-02,.477762828042627e+01,.142441585084029e+03,
10271 .118645200713425e+04,.363351846806499e+04,.413810161269013e+04,
10272 .130560269827897e+04
10273 };
10274 static double p2[4] = {
10275 -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01,
10276 -.648157123766197e+00
10277 };
10278 static double q1[6] = {
10279 .448452573429826e+02,.520752771467162e+03,.221000799247830e+04,
10280 .364127349079381e+04,.190831076596300e+04,.691091682714533e-05
10281 };
10282 static double q2[4] = {
10283 .322703493791143e+02,.892920700481861e+02,.546117738103215e+02,
10284 .777788548522962e+01
10285 };
10286 static int K1 = 3;
10287 static int K2 = 1;
10288 static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z;
10289 static int i,m,n,nq;
10290 //
10291 // MACHINE DEPENDENT CONSTANTS ...
10292 // XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
10293 // WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED
10294 // AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
10295 // ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
10296 // PSI MAY BE REPRESENTED AS ALOG(X).
10297 // XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
10298 // MAY BE REPRESENTED BY 1/X.
10299 //
10300 xmax1 = ipmpar(&K1);
10301 xmax1 = fifdmin1(xmax1,1.0e0/dpmpar(&K2));
10302 xsmall = 1.e-9;
10303 x = *xx;
10304 aug = 0.0e0;
10305 if(x >= 0.5e0) goto S50;
10306 //
10307 // X .LT. 0.5, USE REFLECTION FORMULA
10308 // PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
10309 //
10310 if(fabs(x) > xsmall) goto S10;
10311 if(x == 0.0e0) goto S100;
10312 //
10313 // 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE
10314 // FOR PI*COTAN(PI*X)
10315 //
10316 aug = -(1.0e0/x);
10317 goto S40;
10318 S10:
10319 //
10320 // REDUCTION OF ARGUMENT FOR COTAN
10321 //
10322 w = -x;
10323 sgn = piov4;
10324 if(w > 0.0e0) goto S20;
10325 w = -w;
10326 sgn = -sgn;
10327 S20:
10328 //
10329 // MAKE AN ERROR EXIT IF X .LE. -XMAX1
10330 //
10331 if(w >= xmax1) goto S100;
10332 nq = fifidint(w);
10333 w -= (double)nq;
10334 nq = fifidint(w*4.0e0);
10335 w = 4.0e0*(w-(double)nq*.25e0);
10336 //
10337 // W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X.
10338 // ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
10339 // QUADRANT AND DETERMINE SIGN
10340 //
10341 n = nq/2;
10342 if(n+n != nq) w = 1.0e0-w;
10343 z = piov4*w;
10344 m = n/2;
10345 if(m+m != n) sgn = -sgn;
10346 //
10347 // DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X)
10348 //
10349 n = (nq+1)/2;
10350 m = n/2;
10351 m += m;
10352 if(m != n) goto S30;
10353 //
10354 // CHECK FOR SINGULARITY
10355 //
10356 if(z == 0.0e0) goto S100;
10357 //
10358 // USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
10359 // SIN/COS AS A SUBSTITUTE FOR TAN
10360 //
10361 aug = sgn*(cos(z)/sin(z)*4.0e0);
10362 goto S40;
10363 S30:
10364 aug = sgn*(sin(z)/cos(z)*4.0e0);
10365 S40:
10366 x = 1.0e0-x;
10367 S50:
10368 if(x > 3.0e0) goto S70;
10369 //
10370 // 0.5 .LE. X .LE. 3.0
10371 //
10372 den = x;
10373 upper = p1[0]*x;
10374 for ( i = 1; i <= 5; i++ )
10375 {
10376 den = (den+q1[i-1])*x;
10377 upper = (upper+p1[i+1-1])*x;
10378 }
10379 den = (upper+p1[6])/(den+q1[5]);
10380 xmx0 = x-dx0;
10381 psi = den*xmx0+aug;
10382 return psi;
10383 S70:
10384 //
10385 // IF X .GE. XMAX1, PSI = LN(X)
10386 //
10387 if(x >= xmax1) goto S90;
10388 //
10389 // 3.0 .LT. X .LT. XMAX1
10390 //
10391 w = 1.0e0/(x*x);
10392 den = w;
10393 upper = p2[0]*w;
10394 for ( i = 1; i <= 3; i++ )
10395 {
10396 den = (den+q2[i-1])*w;
10397 upper = (upper+p2[i+1-1])*w;
10398 }
10399 aug = upper/(den+q2[3])-0.5e0/x+aug;
10400 S90:
10401 psi = aug+log(x);
10402 return psi;
10403 S100:
10404 //
10405 // ERROR RETURN
10406 //
10407 psi = 0.0e0;
10408 return psi;
10409 }
10410 //****************************************************************************80
10411
psi_values(int * n_data,double * x,double * fx)10412 void psi_values ( int *n_data, double *x, double *fx )
10413
10414 //****************************************************************************80
10415 //
10416 // Purpose:
10417 //
10418 // PSI_VALUES returns some values of the Psi or Digamma function.
10419 //
10420 // Discussion:
10421 //
10422 // PSI(X) = d LN ( Gamma ( X ) ) / d X = Gamma'(X) / Gamma(X)
10423 //
10424 // PSI(1) = - Euler's constant.
10425 //
10426 // PSI(X+1) = PSI(X) + 1 / X.
10427 //
10428 // Modified:
10429 //
10430 // 31 May 2004
10431 //
10432 // Author:
10433 //
10434 // John Burkardt
10435 //
10436 // Reference:
10437 //
10438 // Milton Abramowitz and Irene Stegun,
10439 // Handbook of Mathematical Functions,
10440 // US Department of Commerce, 1964.
10441 //
10442 // Parameters:
10443 //
10444 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10445 // first call. On each call, the routine increments N_DATA by 1, and
10446 // returns the corresponding data; when there is no more data, the
10447 // output value of N_DATA will be 0 again.
10448 //
10449 // Output, double *X, the argument of the function.
10450 //
10451 // Output, double *FX, the value of the function.
10452 //
10453 {
10454 # define N_MAX 11
10455
10456 double fx_vec[N_MAX] = {
10457 -0.5772156649E+00, -0.4237549404E+00, -0.2890398966E+00,
10458 -0.1691908889E+00, -0.0613845446E+00, -0.0364899740E+00,
10459 0.1260474528E+00, 0.2085478749E+00, 0.2849914333E+00,
10460 0.3561841612E+00, 0.4227843351E+00 };
10461 double x_vec[N_MAX] = {
10462 1.0E+00, 1.1E+00, 1.2E+00,
10463 1.3E+00, 1.4E+00, 1.5E+00,
10464 1.6E+00, 1.7E+00, 1.8E+00,
10465 1.9E+00, 2.0E+00 };
10466
10467 if ( *n_data < 0 )
10468 {
10469 *n_data = 0;
10470 }
10471
10472 *n_data = *n_data + 1;
10473
10474 if ( N_MAX < *n_data )
10475 {
10476 *n_data = 0;
10477 *x = 0.0E+00;
10478 *fx = 0.0E+00;
10479 }
10480 else
10481 {
10482 *x = x_vec[*n_data-1];
10483 *fx = fx_vec[*n_data-1];
10484 }
10485 return;
10486 # undef N_MAX
10487 }
10488 //****************************************************************************80
10489
rcomp(double * a,double * x)10490 double rcomp ( double *a, double *x )
10491
10492 //****************************************************************************80
10493 //
10494 // Purpose:
10495 //
10496 // RCOMP evaluates exp(-X) * X**A / Gamma(A).
10497 //
10498 // Parameters:
10499 //
10500 // Input, double *A, *X, arguments of the quantity to be computed.
10501 //
10502 // Output, double RCOMP, the value of exp(-X) * X**A / Gamma(A).
10503 //
10504 // Local parameters:
10505 //
10506 // RT2PIN = 1/SQRT(2*PI)
10507 //
10508 {
10509 static double rt2pin = .398942280401433e0;
10510 static double rcomp,t,t1,u;
10511 rcomp = 0.0e0;
10512 if(*a >= 20.0e0) goto S20;
10513 t = *a*log(*x)-*x;
10514 if(*a >= 1.0e0) goto S10;
10515 rcomp = *a*exp(t)*(1.0e0+gam1(a));
10516 return rcomp;
10517 S10:
10518 rcomp = exp(t)/ gamma_x(a);
10519 return rcomp;
10520 S20:
10521 u = *x/ *a;
10522 if(u == 0.0e0) return rcomp;
10523 t = pow(1.0e0/ *a,2.0);
10524 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
10525 t1 -= (*a*rlog(&u));
10526 rcomp = rt2pin*sqrt(*a)*exp(t1);
10527 return rcomp;
10528 }
10529 //****************************************************************************80
10530
rexp(double * x)10531 double rexp ( double *x )
10532
10533 //****************************************************************************80
10534 //
10535 // Purpose:
10536 //
10537 // REXP evaluates the function EXP(X) - 1.
10538 //
10539 // Modified:
10540 //
10541 // 09 December 1999
10542 //
10543 // Parameters:
10544 //
10545 // Input, double *X, the argument of the function.
10546 //
10547 // Output, double REXP, the value of EXP(X)-1.
10548 //
10549 {
10550 static double p1 = .914041914819518e-09;
10551 static double p2 = .238082361044469e-01;
10552 static double q1 = -.499999999085958e+00;
10553 static double q2 = .107141568980644e+00;
10554 static double q3 = -.119041179760821e-01;
10555 static double q4 = .595130811860248e-03;
10556 static double rexp,w;
10557
10558 if(fabs(*x) > 0.15e0) goto S10;
10559 rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
10560 return rexp;
10561 S10:
10562 w = exp(*x);
10563 if(*x > 0.0e0) goto S20;
10564 rexp = w-0.5e0-0.5e0;
10565 return rexp;
10566 S20:
10567 rexp = w*(0.5e0+(0.5e0-1.0e0/w));
10568 return rexp;
10569 }
10570 //****************************************************************************80
10571
rlog(double * x)10572 double rlog ( double *x )
10573
10574 //****************************************************************************80
10575 //
10576 // Purpose:
10577 //
10578 // RLOG computes X - 1 - LN(X).
10579 //
10580 // Modified:
10581 //
10582 // 09 December 1999
10583 //
10584 // Parameters:
10585 //
10586 // Input, double *X, the argument of the function.
10587 //
10588 // Output, double RLOG, the value of the function.
10589 //
10590 {
10591 static double a = .566749439387324e-01;
10592 static double b = .456512608815524e-01;
10593 static double p0 = .333333333333333e+00;
10594 static double p1 = -.224696413112536e+00;
10595 static double p2 = .620886815375787e-02;
10596 static double q1 = -.127408923933623e+01;
10597 static double q2 = .354508718369557e+00;
10598 static double rlog,r,t,u,w,w1;
10599
10600 if(*x < 0.61e0 || *x > 1.57e0) goto S40;
10601 if(*x < 0.82e0) goto S10;
10602 if(*x > 1.18e0) goto S20;
10603 //
10604 // ARGUMENT REDUCTION
10605 //
10606 u = *x-0.5e0-0.5e0;
10607 w1 = 0.0e0;
10608 goto S30;
10609 S10:
10610 u = *x-0.7e0;
10611 u /= 0.7e0;
10612 w1 = a-u*0.3e0;
10613 goto S30;
10614 S20:
10615 u = 0.75e0**x-1.e0;
10616 w1 = b+u/3.0e0;
10617 S30:
10618 //
10619 // SERIES EXPANSION
10620 //
10621 r = u/(u+2.0e0);
10622 t = r*r;
10623 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
10624 rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
10625 return rlog;
10626 S40:
10627 r = *x-0.5e0-0.5e0;
10628 rlog = r-log(*x);
10629 return rlog;
10630 }
10631 //****************************************************************************80
10632
rlog1(double * x)10633 double rlog1 ( double *x )
10634
10635 //****************************************************************************80
10636 //
10637 // Purpose:
10638 //
10639 // RLOG1 evaluates the function X - ln ( 1 + X ).
10640 //
10641 // Parameters:
10642 //
10643 // Input, double *X, the argument.
10644 //
10645 // Output, double RLOG1, the value of X - ln ( 1 + X ).
10646 //
10647 {
10648 static double a = .566749439387324e-01;
10649 static double b = .456512608815524e-01;
10650 static double p0 = .333333333333333e+00;
10651 static double p1 = -.224696413112536e+00;
10652 static double p2 = .620886815375787e-02;
10653 static double q1 = -.127408923933623e+01;
10654 static double q2 = .354508718369557e+00;
10655 static double rlog1,h,r,t,w,w1;
10656
10657 if(*x < -0.39e0 || *x > 0.57e0) goto S40;
10658 if(*x < -0.18e0) goto S10;
10659 if(*x > 0.18e0) goto S20;
10660 //
10661 // ARGUMENT REDUCTION
10662 //
10663 h = *x;
10664 w1 = 0.0e0;
10665 goto S30;
10666 S10:
10667 h = *x+0.3e0;
10668 h /= 0.7e0;
10669 w1 = a-h*0.3e0;
10670 goto S30;
10671 S20:
10672 h = 0.75e0**x-0.25e0;
10673 w1 = b+h/3.0e0;
10674 S30:
10675 //
10676 // SERIES EXPANSION
10677 //
10678 r = h/(h+2.0e0);
10679 t = r*r;
10680 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
10681 rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
10682 return rlog1;
10683 S40:
10684 w = *x+0.5e0+0.5e0;
10685 rlog1 = *x-log(w);
10686 return rlog1;
10687 }
10688 //****************************************************************************80
10689
student_cdf_values(int * n_data,int * a,double * x,double * fx)10690 void student_cdf_values ( int *n_data, int *a, double *x, double *fx )
10691
10692 //****************************************************************************80
10693 //
10694 // Purpose:
10695 //
10696 // STUDENT_CDF_VALUES returns some values of the Student CDF.
10697 //
10698 // Modified:
10699 //
10700 // 31 May 2004
10701 //
10702 // Author:
10703 //
10704 // John Burkardt
10705 //
10706 // Reference:
10707 //
10708 // Milton Abramowitz and Irene Stegun,
10709 // Handbook of Mathematical Functions,
10710 // US Department of Commerce, 1964.
10711 //
10712 // Parameters:
10713 //
10714 // Input/output, int *N_DATA. The user sets N_DATA to 0 before the
10715 // first call. On each call, the routine increments N_DATA by 1, and
10716 // returns the corresponding data; when there is no more data, the
10717 // output value of N_DATA will be 0 again.
10718 //
10719 // Output, int *A, the parameter of the function.
10720 //
10721 // Output, double *X, the argument of the function.
10722 //
10723 // Output, double *FX, the value of the function.
10724 //
10725 {
10726 # define N_MAX 13
10727
10728 int a_vec[N_MAX] = {
10729 1, 2, 3, 4,
10730 5, 2, 5, 2,
10731 5, 2, 3, 4,
10732 5 };
10733 double fx_vec[N_MAX] = {
10734 0.60E+00, 0.60E+00, 0.60E+00, 0.60E+00,
10735 0.60E+00, 0.75E+00, 0.75E+00, 0.95E+00,
10736 0.95E+00, 0.99E+00, 0.99E+00, 0.99E+00,
10737 0.99E+00 };
10738 double x_vec[N_MAX] = {
10739 0.325E+00, 0.289E+00, 0.277E+00, 0.271E+00,
10740 0.267E+00, 0.816E+00, 0.727E+00, 2.920E+00,
10741 2.015E+00, 6.965E+00, 4.541E+00, 3.747E+00,
10742 3.365E+00 };
10743
10744 if ( *n_data < 0 )
10745 {
10746 *n_data = 0;
10747 }
10748
10749 *n_data = *n_data + 1;
10750
10751 if ( N_MAX < *n_data )
10752 {
10753 *n_data = 0;
10754 *a = 0;
10755 *x = 0.0E+00;
10756 *fx = 0.0E+00;
10757 }
10758 else
10759 {
10760 *a = a_vec[*n_data-1];
10761 *x = x_vec[*n_data-1];
10762 *fx = fx_vec[*n_data-1];
10763 }
10764
10765 return;
10766 # undef N_MAX
10767 }
10768 //****************************************************************************80
10769
stvaln(double * p)10770 double stvaln ( double *p )
10771
10772 //****************************************************************************80
10773 //
10774 // Purpose:
10775 //
10776 // STVALN provides starting values for the inverse of the normal distribution.
10777 //
10778 // Discussion:
10779 //
10780 // The routine returns X such that
10781 // P = CUMNOR(X),
10782 // that is,
10783 // P = Integral from -infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU.
10784 //
10785 // Reference:
10786 //
10787 // Kennedy and Gentle,
10788 // Statistical Computing,
10789 // Marcel Dekker, NY, 1980, page 95,
10790 // QA276.4 K46
10791 //
10792 // Parameters:
10793 //
10794 // Input, double *P, the probability whose normal deviate
10795 // is sought.
10796 //
10797 // Output, double STVALN, the normal deviate whose probability
10798 // is P.
10799 //
10800 {
10801 static double xden[5] = {
10802 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0,
10803 0.38560700634e-2
10804 };
10805 static double xnum[5] = {
10806 -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1,
10807 -0.453642210148e-4
10808 };
10809 static int K1 = 5;
10810 static double stvaln,sign,y,z;
10811
10812 if(!(*p <= 0.5e0)) goto S10;
10813 sign = -1.0e0;
10814 z = *p;
10815 goto S20;
10816 S10:
10817 sign = 1.0e0;
10818 z = 1.0e0-*p;
10819 S20:
10820 y = sqrt(-(2.0e0*log(z)));
10821 stvaln = y+ eval_pol ( xnum, &K1, &y ) / eval_pol ( xden, &K1, &y );
10822 stvaln = sign*stvaln;
10823 return stvaln;
10824 }
10825 //**************************************************************************80
10826
10827 #if !defined(TIMESTAMP)
10828 #define TIMESTAMP
timestamp()10829 void timestamp ( )
10830
10831 //**************************************************************************80
10832 //
10833 // Purpose:
10834 //
10835 // TIMESTAMP prints the current YMDHMS date as a time stamp.
10836 //
10837 // Example:
10838 //
10839 // May 31 2001 09:45:54 AM
10840 //
10841 // Modified:
10842 //
10843 // 24 September 2003
10844 //
10845 // Author:
10846 //
10847 // John Burkardt
10848 //
10849 // Parameters:
10850 //
10851 // None
10852 //
10853 {
10854 # define TIME_SIZE 40
10855
10856 static char time_buffer[TIME_SIZE];
10857 const struct tm *tm;
10858 size_t len;
10859 time_t now;
10860
10861 now = time ( NULL );
10862 tm = localtime ( &now );
10863
10864 len = strftime ( time_buffer, TIME_SIZE, "%d %B %Y %I:%M:%S %p", tm );
10865
10866 cout << time_buffer << "\n";
10867
10868 return;
10869 # undef TIME_SIZE
10870 }
10871
10872
10873 #endif
10874