1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <math.h>
4 #include "cdflib.h"
5 #include "ipmpar.h"
6
7 /*
8 -----------------------------------------------------------------------
9
10 COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8
11
12 --------
13
14 IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
15 LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
16
17 -----------------------------------------------------------------------
18 */
algdiv(double * a,double * b)19 double algdiv(double *a,double *b)
20 {
21 static double c0 = .833333333333333e-01;
22 static double c1 = -.277777777760991e-02;
23 static double c2 = .793650666825390e-03;
24 static double c3 = -.595202931351870e-03;
25 static double c4 = .837308034031215e-03;
26 static double c5 = -.165322962780713e-02;
27 static double algdiv,c,d,h,s11,s3,s5,s7,s9,t,u,v,w,x,x2,T1;
28 /*
29 ..
30 .. Executable Statements ..
31 */
32 if(*a <= *b) goto S10;
33 h = *b/ *a;
34 c = 1.0e0/(1.0e0+h);
35 x = h/(1.0e0+h);
36 d = *a+(*b-0.5e0);
37 goto S20;
38 S10:
39 h = *a/ *b;
40 c = h/(1.0e0+h);
41 x = 1.0e0/(1.0e0+h);
42 d = *b+(*a-0.5e0);
43 S20:
44 /*
45 SET SN = (1 - X**N)/(1 - X)
46 */
47 x2 = x*x;
48 s3 = 1.0e0+(x+x2);
49 s5 = 1.0e0+(x+x2*s3);
50 s7 = 1.0e0+(x+x2*s5);
51 s9 = 1.0e0+(x+x2*s7);
52 s11 = 1.0e0+(x+x2*s9);
53 /*
54 SET W = DEL(B) - DEL(A + B)
55 */
56 t = pow(1.0e0/ *b,2.0);
57 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0;
58 w *= (c/ *b);
59 /*
60 COMBINE THE RESULTS
61 */
62 T1 = *a/ *b;
63 u = d*alnrel(&T1);
64 v = *a*(log(*b)-1.0e0);
65 if(u <= v) goto S30;
66 algdiv = w-v-u;
67 return algdiv;
68 S30:
69 algdiv = w-u-v;
70 return algdiv;
71 }
alngam(double * x)72 double alngam(double *x)
73 /*
74 **********************************************************************
75
76 double alngam(double *x)
77 double precision LN of the GAMma function
78
79
80 Function
81
82
83 Returns the natural logarithm of GAMMA(X).
84
85
86 Arguments
87
88
89 X --> value at which scaled log gamma is to be returned
90 X is DOUBLE PRECISION
91
92
93 Method
94
95
96 If X .le. 6.0, then use recursion to get X below 3
97 then apply rational approximation number 5236 of
98 Hart et al, Computer Approximations, John Wiley and
99 Sons, NY, 1968.
100
101 If X .gt. 6.0, then use recursion to get X to at least 12 and
102 then use formula 5423 of the same source.
103
104 **********************************************************************
105 */
106 {
107 #define hln2pi 0.91893853320467274178e0
108 static double coef[5] = {
109 0.83333333333333023564e-1,-0.27777777768818808e-2,0.79365006754279e-3,
110 -0.594997310889e-3,0.8065880899e-3
111 };
112 static double scoefd[4] = {
113 0.62003838007126989331e2,0.9822521104713994894e1,-0.8906016659497461257e1,
114 0.1000000000000000000e1
115 };
116 static double scoefn[9] = {
117 0.62003838007127258804e2,0.36036772530024836321e2,0.20782472531792126786e2,
118 0.6338067999387272343e1,0.215994312846059073e1,0.3980671310203570498e0,
119 0.1093115956710439502e0,0.92381945590275995e-2,0.29737866448101651e-2
120 };
121 static int K1 = 9;
122 static int K3 = 4;
123 static int K5 = 5;
124 static double alngam,offset,prod,xx;
125 static int i,n;
126 static double T2,T4,T6;
127 /*
128 ..
129 .. Executable Statements ..
130 */
131 if(!(*x <= 6.0e0)) goto S70;
132 prod = 1.0e0;
133 xx = *x;
134 if(!(*x > 3.0e0)) goto S30;
135 S10:
136 if(!(xx > 3.0e0)) goto S20;
137 xx -= 1.0e0;
138 prod *= xx;
139 goto S10;
140 S30:
141 S20:
142 if(!(*x < 2.0e0)) goto S60;
143 S40:
144 if(!(xx < 2.0e0)) goto S50;
145 prod /= xx;
146 xx += 1.0e0;
147 goto S40;
148 S60:
149 S50:
150 T2 = xx-2.0e0;
151 T4 = xx-2.0e0;
152 alngam = devlpl(scoefn,&K1,&T2)/devlpl(scoefd,&K3,&T4);
153 /*
154 COMPUTE RATIONAL APPROXIMATION TO GAMMA(X)
155 */
156 alngam *= prod;
157 alngam = log(alngam);
158 goto S110;
159 S70:
160 offset = hln2pi;
161 /*
162 IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET
163 */
164 n = fifidint(12.0e0-*x);
165 if(!(n > 0)) goto S90;
166 prod = 1.0e0;
167 for(i=1; i<=n; i++) prod *= (*x+(double)(i-1));
168 offset -= log(prod);
169 xx = *x+(double)n;
170 goto S100;
171 S90:
172 xx = *x;
173 S100:
174 /*
175 COMPUTE POWER SERIES
176 */
177 T6 = 1.0e0/pow(xx,2.0);
178 alngam = devlpl(coef,&K5,&T6)/xx;
179 alngam += (offset+(xx-0.5e0)*log(xx)-xx);
180 S110:
181 return alngam;
182 #undef hln2pi
183 }
alnrel(double * a)184 double alnrel(double *a)
185 /*
186 -----------------------------------------------------------------------
187 EVALUATION OF THE FUNCTION LN(1 + A)
188 -----------------------------------------------------------------------
189 */
190 {
191 static double p1 = -.129418923021993e+01;
192 static double p2 = .405303492862024e+00;
193 static double p3 = -.178874546012214e-01;
194 static double q1 = -.162752256355323e+01;
195 static double q2 = .747811014037616e+00;
196 static double q3 = -.845104217945565e-01;
197 static double alnrel,t,t2,w,x;
198 /*
199 ..
200 .. Executable Statements ..
201 */
202 if(fabs(*a) > 0.375e0) goto S10;
203 t = *a/(*a+2.0e0);
204 t2 = t*t;
205 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0);
206 alnrel = 2.0e0*t*w;
207 return alnrel;
208 S10:
209 x = 1.e0+*a;
210 alnrel = log(x);
211 return alnrel;
212 }
apser(double * a,double * b,double * x,double * eps)213 double apser(double *a,double *b,double *x,double *eps)
214 /*
215 -----------------------------------------------------------------------
216 APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR
217 A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN
218 A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED.
219 -----------------------------------------------------------------------
220 */
221 {
222 static double g = .577215664901533e0;
223 static double apser,aj,bx,c,j,s,t,tol;
224 /*
225 ..
226 .. Executable Statements ..
227 */
228 bx = *b**x;
229 t = *x-bx;
230 if(*b**eps > 2.e-2) goto S10;
231 c = log(*x)+psi(b)+g+t;
232 goto S20;
233 S10:
234 c = log(bx)+g+t;
235 S20:
236 tol = 5.0e0**eps*fabs(c);
237 j = 1.0e0;
238 s = 0.0e0;
239 S30:
240 j += 1.0e0;
241 t *= (*x-bx/j);
242 aj = t/j;
243 s += aj;
244 if(fabs(aj) > tol) goto S30;
245 apser = -(*a*(c+s));
246 return apser;
247 }
basym(double * a,double * b,double * lambda,double * eps)248 double basym(double *a,double *b,double *lambda,double *eps)
249 /*
250 -----------------------------------------------------------------------
251 ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B.
252 LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED.
253 IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT
254 A AND B ARE GREATER THAN OR EQUAL TO 15.
255 -----------------------------------------------------------------------
256 */
257 {
258 static double e0 = 1.12837916709551e0;
259 static double e1 = .353553390593274e0;
260 static int num = 20;
261 /*
262 ------------------------
263 ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
264 ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
265 THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
266 ------------------------
267 E0 = 2/SQRT(PI)
268 E1 = 2**(-3/2)
269 ------------------------
270 */
271 static int K3 = 1;
272 static double basym,bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0,
273 z2,zn,znm1;
274 static int i,im1,imj,j,m,mm1,mmj,n,np1;
275 static double a0[21],b0[21],c[21],d[21],T1,T2;
276 /*
277 ..
278 .. Executable Statements ..
279 */
280 basym = 0.0e0;
281 if(*a >= *b) goto S10;
282 h = *a/ *b;
283 r0 = 1.0e0/(1.0e0+h);
284 r1 = (*b-*a)/ *b;
285 w0 = 1.0e0/sqrt(*a*(1.0e0+h));
286 goto S20;
287 S10:
288 h = *b/ *a;
289 r0 = 1.0e0/(1.0e0+h);
290 r1 = (*b-*a)/ *a;
291 w0 = 1.0e0/sqrt(*b*(1.0e0+h));
292 S20:
293 T1 = -(*lambda/ *a);
294 T2 = *lambda/ *b;
295 f = *a*rlog1(&T1)+*b*rlog1(&T2);
296 t = exp(-f);
297 if(t == 0.0e0) return basym;
298 z0 = sqrt(f);
299 z = 0.5e0*(z0/e1);
300 z2 = f+f;
301 a0[0] = 2.0e0/3.0e0*r1;
302 c[0] = -(0.5e0*a0[0]);
303 d[0] = -c[0];
304 j0 = 0.5e0/e0*erfc1(&K3,&z0);
305 j1 = e1;
306 sum = j0+d[0]*w0*j1;
307 s = 1.0e0;
308 h2 = h*h;
309 hn = 1.0e0;
310 w = w0;
311 znm1 = z;
312 zn = z2;
313 for(n=2; n<=num; n+=2) {
314 hn = h2*hn;
315 a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0);
316 np1 = n+1;
317 s += hn;
318 a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0);
319 for(i=n; i<=np1; i++) {
320 r = -(0.5e0*((double)i+1.0e0));
321 b0[0] = r*a0[0];
322 for(m=2; m<=i; m++) {
323 bsum = 0.0e0;
324 mm1 = m-1;
325 for(j=1; j<=mm1; j++) {
326 mmj = m-j;
327 bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]);
328 }
329 b0[m-1] = r*a0[m-1]+bsum/(double)m;
330 }
331 c[i-1] = b0[i-1]/((double)i+1.0e0);
332 dsum = 0.0e0;
333 im1 = i-1;
334 for(j=1; j<=im1; j++) {
335 imj = i-j;
336 dsum += (d[imj-1]*c[j-1]);
337 }
338 d[i-1] = -(dsum+c[i-1]);
339 }
340 j0 = e1*znm1+((double)n-1.0e0)*j0;
341 j1 = e1*zn+(double)n*j1;
342 znm1 = z2*znm1;
343 zn = z2*zn;
344 w = w0*w;
345 t0 = d[n-1]*w*j0;
346 w = w0*w;
347 t1 = d[np1-1]*w*j1;
348 sum += (t0+t1);
349 if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80;
350 }
351 S80:
352 u = exp(-bcorr(a,b));
353 basym = e0*t*u*sum;
354 return basym;
355 }
bcorr(double * a0,double * b0)356 double bcorr(double *a0,double *b0)
357 /*
358 -----------------------------------------------------------------------
359
360 EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE
361 LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A).
362 IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8.
363
364 -----------------------------------------------------------------------
365 */
366 {
367 static double c0 = .833333333333333e-01;
368 static double c1 = -.277777777760991e-02;
369 static double c2 = .793650666825390e-03;
370 static double c3 = -.595202931351870e-03;
371 static double c4 = .837308034031215e-03;
372 static double c5 = -.165322962780713e-02;
373 static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2;
374 /*
375 ..
376 .. Executable Statements ..
377 */
378 a = fifdmin1(*a0,*b0);
379 b = fifdmax1(*a0,*b0);
380 h = a/b;
381 c = h/(1.0e0+h);
382 x = 1.0e0/(1.0e0+h);
383 x2 = x*x;
384 /*
385 SET SN = (1 - X**N)/(1 - X)
386 */
387 s3 = 1.0e0+(x+x2);
388 s5 = 1.0e0+(x+x2*s3);
389 s7 = 1.0e0+(x+x2*s5);
390 s9 = 1.0e0+(x+x2*s7);
391 s11 = 1.0e0+(x+x2*s9);
392 /*
393 SET W = DEL(B) - DEL(A + B)
394 */
395 t = pow(1.0e0/b,2.0);
396 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0;
397 w *= (c/b);
398 /*
399 COMPUTE DEL(A) + W
400 */
401 t = pow(1.0e0/a,2.0);
402 bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a+w;
403 return bcorr;
404 }
betaln(double * a0,double * b0)405 double betaln(double *a0,double *b0)
406 /*
407 -----------------------------------------------------------------------
408 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
409 -----------------------------------------------------------------------
410 E = 0.5*LN(2*PI)
411 --------------------------
412 */
413 {
414 static double e = .918938533204673e0;
415 static double betaln,a,b,c,h,u,v,w,z;
416 static int i,n;
417 static double T1;
418 /*
419 ..
420 .. Executable Statements ..
421 */
422 a = fifdmin1(*a0,*b0);
423 b = fifdmax1(*a0,*b0);
424 if(a >= 8.0e0) goto S100;
425 if(a >= 1.0e0) goto S20;
426 /*
427 -----------------------------------------------------------------------
428 PROCEDURE WHEN A .LT. 1
429 -----------------------------------------------------------------------
430 */
431 if(b >= 8.0e0) goto S10;
432 T1 = a+b;
433 betaln = gamln(&a)+(gamln(&b)-gamln(&T1));
434 return betaln;
435 S10:
436 betaln = gamln(&a)+algdiv(&a,&b);
437 return betaln;
438 S20:
439 /*
440 -----------------------------------------------------------------------
441 PROCEDURE WHEN 1 .LE. A .LT. 8
442 -----------------------------------------------------------------------
443 */
444 if(a > 2.0e0) goto S40;
445 if(b > 2.0e0) goto S30;
446 betaln = gamln(&a)+gamln(&b)-gsumln(&a,&b);
447 return betaln;
448 S30:
449 w = 0.0e0;
450 if(b < 8.0e0) goto S60;
451 betaln = gamln(&a)+algdiv(&a,&b);
452 return betaln;
453 S40:
454 /*
455 REDUCTION OF A WHEN B .LE. 1000
456 */
457 if(b > 1000.0e0) goto S80;
458 n = int(a-1.0e0);
459 w = 1.0e0;
460 for(i=1; i<=n; i++) {
461 a -= 1.0e0;
462 h = a/b;
463 w *= (h/(1.0e0+h));
464 }
465 w = log(w);
466 if(b < 8.0e0) goto S60;
467 betaln = w+gamln(&a)+algdiv(&a,&b);
468 return betaln;
469 S60:
470 /*
471 REDUCTION OF B WHEN B .LT. 8
472 */
473 n = int(b-1.0e0);
474 z = 1.0e0;
475 for(i=1; i<=n; i++) {
476 b -= 1.0e0;
477 z *= (b/(a+b));
478 }
479 betaln = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b)));
480 return betaln;
481 S80:
482 /*
483 REDUCTION OF A WHEN B .GT. 1000
484 */
485 n = int(a-1.0e0);
486 w = 1.0e0;
487 for(i=1; i<=n; i++) {
488 a -= 1.0e0;
489 w *= (a/(1.0e0+a/b));
490 }
491 betaln = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b));
492 return betaln;
493 S100:
494 /*
495 -----------------------------------------------------------------------
496 PROCEDURE WHEN A .GE. 8
497 -----------------------------------------------------------------------
498 */
499 w = bcorr(&a,&b);
500 h = a/b;
501 c = h/(1.0e0+h);
502 u = -((a-0.5e0)*log(c));
503 v = b*alnrel(&h);
504 if(u <= v) goto S110;
505 betaln = -(0.5e0*log(b))+e+w-v-u;
506 return betaln;
507 S110:
508 betaln = -(0.5e0*log(b))+e+w-u-v;
509 return betaln;
510 }
bfrac(double * a,double * b,double * x,double * y,double * lambda,double * eps)511 double bfrac(double *a,double *b,double *x,double *y,double *lambda,
512 double *eps)
513 /*
514 -----------------------------------------------------------------------
515 CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1.
516 IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B.
517 -----------------------------------------------------------------------
518 */
519 {
520 static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1;
521 /*
522 ..
523 .. Executable Statements ..
524 */
525 bfrac = brcomp(a,b,x,y);
526 if(bfrac == 0.0e0) return bfrac;
527 c = 1.0e0+*lambda;
528 c0 = *b/ *a;
529 c1 = 1.0e0+1.0e0/ *a;
530 yp1 = *y+1.0e0;
531 n = 0.0e0;
532 p = 1.0e0;
533 s = *a+1.0e0;
534 an = 0.0e0;
535 bn = anp1 = 1.0e0;
536 bnp1 = c/c1;
537 r = c1/c;
538 S10:
539 /*
540 CONTINUED FRACTION CALCULATION
541 */
542 n += 1.0e0;
543 t = n/ *a;
544 w = n*(*b-n)**x;
545 e = *a/s;
546 alpha = p*(p+c0)*e*e*(w**x);
547 e = (1.0e0+t)/(c1+t+t);
548 beta = n+w/s+e*(c+n*yp1);
549 p = 1.0e0+t;
550 s += 2.0e0;
551 /*
552 UPDATE AN, BN, ANP1, AND BNP1
553 */
554 t = alpha*an+beta*anp1;
555 an = anp1;
556 anp1 = t;
557 t = alpha*bn+beta*bnp1;
558 bn = bnp1;
559 bnp1 = t;
560 r0 = r;
561 r = anp1/bnp1;
562 if(fabs(r-r0) <= *eps*r) goto S20;
563 /*
564 RESCALE AN, BN, ANP1, AND BNP1
565 */
566 an /= bnp1;
567 bn /= bnp1;
568 anp1 = r;
569 bnp1 = 1.0e0;
570 goto S10;
571 S20:
572 /*
573 TERMINATION
574 */
575 bfrac *= r;
576 return bfrac;
577 }
bgrat(double * a,double * b,double * x,double * y,double * w,double * eps,int * ierr)578 void bgrat(double *a,double *b,double *x,double *y,double *w,
579 double *eps,int *ierr)
580 /*
581 -----------------------------------------------------------------------
582 ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B.
583 THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED
584 THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED.
585 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
586 -----------------------------------------------------------------------
587 */
588 {
589 static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z;
590 static int i,n,nm1;
591 static double c[30],d[30],T1;
592 /*
593 ..
594 .. Executable Statements ..
595 */
596 bm1 = *b-0.5e0-0.5e0;
597 nu = *a+0.5e0*bm1;
598 if(*y > 0.375e0) goto S10;
599 T1 = -*y;
600 lnx = alnrel(&T1);
601 goto S20;
602 S10:
603 lnx = log(*x);
604 S20:
605 z = -(nu*lnx);
606 if(*b*z == 0.0e0) goto S70;
607 /*
608 COMPUTATION OF THE EXPANSION
609 SET R = EXP(-Z)*Z**B/GAMMA(B)
610 */
611 r = *b*(1.0e0+gam1(b))*exp(*b*log(z));
612 r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx));
613 u = algdiv(b,a)+*b*log(nu);
614 u = r*exp(-u);
615 if(u == 0.0e0) goto S70;
616 grat1(b,&z,&r,&p,&q,eps);
617 v = 0.25e0*pow(1.0e0/nu,2.0);
618 t2 = 0.25e0*lnx*lnx;
619 l = *w/u;
620 j = q/r;
621 sum = j;
622 t = cn = 1.0e0;
623 n2 = 0.0e0;
624 for(n=1; n<=30; n++) {
625 bp2n = *b+n2;
626 j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v;
627 n2 += 2.0e0;
628 t *= t2;
629 cn /= (n2*(n2+1.0e0));
630 c[n-1] = cn;
631 s = 0.0e0;
632 if(n == 1) goto S40;
633 nm1 = n-1;
634 coef = *b-(double)n;
635 for(i=1; i<=nm1; i++) {
636 s += (coef*c[i-1]*d[n-i-1]);
637 coef += *b;
638 }
639 S40:
640 d[n-1] = bm1*cn+s/(double)n;
641 dj = d[n-1]*j;
642 sum += dj;
643 if(sum <= 0.0e0) goto S70;
644 if(fabs(dj) <= *eps*(sum+l)) goto S60;
645 }
646 S60:
647 /*
648 ADD THE RESULTS TO W
649 */
650 *ierr = 0;
651 *w += (u*sum);
652 return;
653 S70:
654 /*
655 THE EXPANSION CANNOT BE COMPUTED
656 */
657 *ierr = 1;
658 return;
659 }
bpser(double * a,double * b,double * x,double * eps)660 double bpser(double *a,double *b,double *x,double *eps)
661 /*
662 -----------------------------------------------------------------------
663 POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1
664 OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED.
665 -----------------------------------------------------------------------
666 */
667 {
668 static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z;
669 static int i,m;
670 /*
671 ..
672 .. Executable Statements ..
673 */
674 bpser = 0.0e0;
675 if(*x == 0.0e0) return bpser;
676 /*
677 -----------------------------------------------------------------------
678 COMPUTE THE FACTOR X**A/(A*BETA(A,B))
679 -----------------------------------------------------------------------
680 */
681 a0 = fifdmin1(*a,*b);
682 if(a0 < 1.0e0) goto S10;
683 z = *a*log(*x)-betaln(a,b);
684 bpser = exp(z)/ *a;
685 goto S100;
686 S10:
687 b0 = fifdmax1(*a,*b);
688 if(b0 >= 8.0e0) goto S90;
689 if(b0 > 1.0e0) goto S40;
690 /*
691 PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
692 */
693 bpser = pow(*x,*a);
694 if(bpser == 0.0e0) return bpser;
695 apb = *a+*b;
696 if(apb > 1.0e0) goto S20;
697 z = 1.0e0+gam1(&apb);
698 goto S30;
699 S20:
700 u = *a+*b-1.e0;
701 z = (1.0e0+gam1(&u))/apb;
702 S30:
703 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
704 bpser *= (c*(*b/apb));
705 goto S100;
706 S40:
707 /*
708 PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
709 */
710 u = gamln1(&a0);
711 m = int(b0-1.0e0);
712 if(m < 1) goto S60;
713 c = 1.0e0;
714 for(i=1; i<=m; i++) {
715 b0 -= 1.0e0;
716 c *= (b0/(a0+b0));
717 }
718 u = log(c)+u;
719 S60:
720 z = *a*log(*x)-u;
721 b0 -= 1.0e0;
722 apb = a0+b0;
723 if(apb > 1.0e0) goto S70;
724 t = 1.0e0+gam1(&apb);
725 goto S80;
726 S70:
727 u = a0+b0-1.e0;
728 t = (1.0e0+gam1(&u))/apb;
729 S80:
730 bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t;
731 goto S100;
732 S90:
733 /*
734 PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
735 */
736 u = gamln1(&a0)+algdiv(&a0,&b0);
737 z = *a*log(*x)-u;
738 bpser = a0/ *a*exp(z);
739 S100:
740 if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser;
741 /*
742 -----------------------------------------------------------------------
743 COMPUTE THE SERIES
744 -----------------------------------------------------------------------
745 */
746 sum = n = 0.0e0;
747 c = 1.0e0;
748 tol = *eps/ *a;
749 S110:
750 n += 1.0e0;
751 c *= ((0.5e0+(0.5e0-*b/n))**x);
752 w = c/(*a+n);
753 sum += w;
754 if(fabs(w) > tol) goto S110;
755 bpser *= (1.0e0+*a*sum);
756 return bpser;
757 }
bratio(double * a,double * b,double * x,double * y,double * w,double * w1,int * ierr)758 void bratio(double *a,double *b,double *x,double *y,double *w,
759 double *w1,int *ierr)
760 /*
761 -----------------------------------------------------------------------
762
763 EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B)
764
765 --------------------
766
767 IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1
768 AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES
769
770 W = IX(A,B)
771 W1 = 1 - IX(A,B)
772
773 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
774 IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND
775 W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED,
776 THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO
777 ONE OF THE FOLLOWING VALUES ...
778
779 IERR = 1 IF A OR B IS NEGATIVE
780 IERR = 2 IF A = B = 0
781 IERR = 3 IF X .LT. 0 OR X .GT. 1
782 IERR = 4 IF Y .LT. 0 OR Y .GT. 1
783 IERR = 5 IF X + Y .NE. 1
784 IERR = 6 IF X = A = 0
785 IERR = 7 IF Y = B = 0
786
787 --------------------
788 WRITTEN BY ALFRED H. MORRIS, JR.
789 NAVAL SURFACE WARFARE CENTER
790 DAHLGREN, VIRGINIA
791 REVISED ... NOV 1991
792 -----------------------------------------------------------------------
793 */
794 {
795 static int K1 = 1;
796 static double a0,b0,eps,lambda,t,x0,y0,z;
797 static int ierr1,ind,n;
798 static double T2,T3,T4,T5;
799 /*
800 ..
801 .. Executable Statements ..
802 */
803 /*
804 ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
805 FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
806 */
807 eps = spmpar(&K1);
808 *w = *w1 = 0.0e0;
809 if(*a < 0.0e0 || *b < 0.0e0) goto S270;
810 if(*a == 0.0e0 && *b == 0.0e0) goto S280;
811 if(*x < 0.0e0 || *x > 1.0e0) goto S290;
812 if(*y < 0.0e0 || *y > 1.0e0) goto S300;
813 z = *x+*y-0.5e0-0.5e0;
814 if(fabs(z) > 3.0e0*eps) goto S310;
815 *ierr = 0;
816 if(*x == 0.0e0) goto S210;
817 if(*y == 0.0e0) goto S230;
818 if(*a == 0.0e0) goto S240;
819 if(*b == 0.0e0) goto S220;
820 eps = fifdmax1(eps,1.e-15);
821 if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260;
822 ind = 0;
823 a0 = *a;
824 b0 = *b;
825 x0 = *x;
826 y0 = *y;
827 if(fifdmin1(a0,b0) > 1.0e0) goto S40;
828 /*
829 PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
830 */
831 if(*x <= 0.5e0) goto S10;
832 ind = 1;
833 a0 = *b;
834 b0 = *a;
835 x0 = *y;
836 y0 = *x;
837 S10:
838 if(b0 < fifdmin1(eps,eps*a0)) goto S90;
839 if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100;
840 if(fifdmax1(a0,b0) > 1.0e0) goto S20;
841 if(a0 >= fifdmin1(0.2e0,b0)) goto S110;
842 if(pow(x0,a0) <= 0.9e0) goto S110;
843 if(x0 >= 0.3e0) goto S120;
844 n = 20;
845 goto S140;
846 S20:
847 if(b0 <= 1.0e0) goto S110;
848 if(x0 >= 0.3e0) goto S120;
849 if(x0 >= 0.1e0) goto S30;
850 if(pow(x0*b0,a0) <= 0.7e0) goto S110;
851 S30:
852 if(b0 > 15.0e0) goto S150;
853 n = 20;
854 goto S140;
855 S40:
856 /*
857 PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
858 */
859 if(*a > *b) goto S50;
860 lambda = *a-(*a+*b)**x;
861 goto S60;
862 S50:
863 lambda = (*a+*b)**y-*b;
864 S60:
865 if(lambda >= 0.0e0) goto S70;
866 ind = 1;
867 a0 = *b;
868 b0 = *a;
869 x0 = *y;
870 y0 = *x;
871 lambda = fabs(lambda);
872 S70:
873 if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110;
874 if(b0 < 40.0e0) goto S160;
875 if(a0 > b0) goto S80;
876 if(a0 <= 100.0e0) goto S130;
877 if(lambda > 0.03e0*a0) goto S130;
878 goto S200;
879 S80:
880 if(b0 <= 100.0e0) goto S130;
881 if(lambda > 0.03e0*b0) goto S130;
882 goto S200;
883 S90:
884 /*
885 EVALUATION OF THE APPROPRIATE ALGORITHM
886 */
887 *w = fpser(&a0,&b0,&x0,&eps);
888 *w1 = 0.5e0+(0.5e0-*w);
889 goto S250;
890 S100:
891 *w1 = apser(&a0,&b0,&x0,&eps);
892 *w = 0.5e0+(0.5e0-*w1);
893 goto S250;
894 S110:
895 *w = bpser(&a0,&b0,&x0,&eps);
896 *w1 = 0.5e0+(0.5e0-*w);
897 goto S250;
898 S120:
899 *w1 = bpser(&b0,&a0,&y0,&eps);
900 *w = 0.5e0+(0.5e0-*w1);
901 goto S250;
902 S130:
903 T2 = 15.0e0*eps;
904 *w = bfrac(&a0,&b0,&x0,&y0,&lambda,&T2);
905 *w1 = 0.5e0+(0.5e0-*w);
906 goto S250;
907 S140:
908 *w1 = bup(&b0,&a0,&y0,&x0,&n,&eps);
909 b0 += (double)n;
910 S150:
911 T3 = 15.0e0*eps;
912 bgrat(&b0,&a0,&y0,&x0,w1,&T3,&ierr1);
913 *w = 0.5e0+(0.5e0-*w1);
914 goto S250;
915 S160:
916 n = (int)b0;
917 b0 -= (double)n;
918 if(b0 != 0.0e0) goto S170;
919 n -= 1;
920 b0 = 1.0e0;
921 S170:
922 *w = bup(&b0,&a0,&y0,&x0,&n,&eps);
923 if(x0 > 0.7e0) goto S180;
924 *w += bpser(&a0,&b0,&x0,&eps);
925 *w1 = 0.5e0+(0.5e0-*w);
926 goto S250;
927 S180:
928 if(a0 > 15.0e0) goto S190;
929 n = 20;
930 *w += bup(&a0,&b0,&x0,&y0,&n,&eps);
931 a0 += (double)n;
932 S190:
933 T4 = 15.0e0*eps;
934 bgrat(&a0,&b0,&x0,&y0,w,&T4,&ierr1);
935 *w1 = 0.5e0+(0.5e0-*w);
936 goto S250;
937 S200:
938 T5 = 100.0e0*eps;
939 *w = basym(&a0,&b0,&lambda,&T5);
940 *w1 = 0.5e0+(0.5e0-*w);
941 goto S250;
942 S210:
943 /*
944 TERMINATION OF THE PROCEDURE
945 */
946 if(*a == 0.0e0) goto S320;
947 S220:
948 *w = 0.0e0;
949 *w1 = 1.0e0;
950 return;
951 S230:
952 if(*b == 0.0e0) goto S330;
953 S240:
954 *w = 1.0e0;
955 *w1 = 0.0e0;
956 return;
957 S250:
958 if(ind == 0) return;
959 t = *w;
960 *w = *w1;
961 *w1 = t;
962 return;
963 S260:
964 /*
965 PROCEDURE FOR A AND B .LT. 1.E-3*EPS
966 */
967 *w = *b/(*a+*b);
968 *w1 = *a/(*a+*b);
969 return;
970 S270:
971 /*
972 ERROR RETURN
973 */
974 *ierr = 1;
975 return;
976 S280:
977 *ierr = 2;
978 return;
979 S290:
980 *ierr = 3;
981 return;
982 S300:
983 *ierr = 4;
984 return;
985 S310:
986 *ierr = 5;
987 return;
988 S320:
989 *ierr = 6;
990 return;
991 S330:
992 *ierr = 7;
993 return;
994 }
brcmp1(int * mu,double * a,double * b,double * x,double * y)995 double brcmp1(int *mu,double *a,double *b,double *x,double *y)
996 /*
997 -----------------------------------------------------------------------
998 EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B))
999 -----------------------------------------------------------------------
1000 */
1001 {
1002 static double Const = .398942280401433e0;
1003 static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1004 static int i,n;
1005 /*
1006 -----------------
1007 CONST = 1/SQRT(2*PI)
1008 -----------------
1009 */
1010 static double T1,T2,T3,T4;
1011 /*
1012 ..
1013 .. Executable Statements ..
1014 */
1015 a0 = fifdmin1(*a,*b);
1016 if(a0 >= 8.0e0) goto S130;
1017 if(*x > 0.375e0) goto S10;
1018 lnx = log(*x);
1019 T1 = -*x;
1020 lny = alnrel(&T1);
1021 goto S30;
1022 S10:
1023 if(*y > 0.375e0) goto S20;
1024 T2 = -*y;
1025 lnx = alnrel(&T2);
1026 lny = log(*y);
1027 goto S30;
1028 S20:
1029 lnx = log(*x);
1030 lny = log(*y);
1031 S30:
1032 z = *a*lnx+*b*lny;
1033 if(a0 < 1.0e0) goto S40;
1034 z -= betaln(a,b);
1035 brcmp1 = esum(mu,&z);
1036 return brcmp1;
1037 S40:
1038 /*
1039 -----------------------------------------------------------------------
1040 PROCEDURE FOR A .LT. 1 OR B .LT. 1
1041 -----------------------------------------------------------------------
1042 */
1043 b0 = fifdmax1(*a,*b);
1044 if(b0 >= 8.0e0) goto S120;
1045 if(b0 > 1.0e0) goto S70;
1046 /*
1047 ALGORITHM FOR B0 .LE. 1
1048 */
1049 brcmp1 = esum(mu,&z);
1050 if(brcmp1 == 0.0e0) return brcmp1;
1051 apb = *a+*b;
1052 if(apb > 1.0e0) goto S50;
1053 z = 1.0e0+gam1(&apb);
1054 goto S60;
1055 S50:
1056 u = *a+*b-1.e0;
1057 z = (1.0e0+gam1(&u))/apb;
1058 S60:
1059 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1060 brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0);
1061 return brcmp1;
1062 S70:
1063 /*
1064 ALGORITHM FOR 1 .LT. B0 .LT. 8
1065 */
1066 u = gamln1(&a0);
1067 n = int(b0-1.0e0);
1068 if(n < 1) goto S90;
1069 c = 1.0e0;
1070 for(i=1; i<=n; i++) {
1071 b0 -= 1.0e0;
1072 c *= (b0/(a0+b0));
1073 }
1074 u = log(c)+u;
1075 S90:
1076 z -= u;
1077 b0 -= 1.0e0;
1078 apb = a0+b0;
1079 if(apb > 1.0e0) goto S100;
1080 t = 1.0e0+gam1(&apb);
1081 goto S110;
1082 S100:
1083 u = a0+b0-1.e0;
1084 t = (1.0e0+gam1(&u))/apb;
1085 S110:
1086 brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t;
1087 return brcmp1;
1088 S120:
1089 /*
1090 ALGORITHM FOR B0 .GE. 8
1091 */
1092 u = gamln1(&a0)+algdiv(&a0,&b0);
1093 T3 = z-u;
1094 brcmp1 = a0*esum(mu,&T3);
1095 return brcmp1;
1096 S130:
1097 /*
1098 -----------------------------------------------------------------------
1099 PROCEDURE FOR A .GE. 8 AND B .GE. 8
1100 -----------------------------------------------------------------------
1101 */
1102 if(*a > *b) goto S140;
1103 h = *a/ *b;
1104 x0 = h/(1.0e0+h);
1105 y0 = 1.0e0/(1.0e0+h);
1106 lambda = *a-(*a+*b)**x;
1107 goto S150;
1108 S140:
1109 h = *b/ *a;
1110 x0 = 1.0e0/(1.0e0+h);
1111 y0 = h/(1.0e0+h);
1112 lambda = (*a+*b)**y-*b;
1113 S150:
1114 e = -(lambda/ *a);
1115 if(fabs(e) > 0.6e0) goto S160;
1116 u = rlog1(&e);
1117 goto S170;
1118 S160:
1119 u = e-log(*x/x0);
1120 S170:
1121 e = lambda/ *b;
1122 if(fabs(e) > 0.6e0) goto S180;
1123 v = rlog1(&e);
1124 goto S190;
1125 S180:
1126 v = e-log(*y/y0);
1127 S190:
1128 T4 = -(*a*u+*b*v);
1129 z = esum(mu,&T4);
1130 brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1131 return brcmp1;
1132 }
brcomp(double * a,double * b,double * x,double * y)1133 double brcomp(double *a,double *b,double *x,double *y)
1134 /*
1135 -----------------------------------------------------------------------
1136 EVALUATION OF X**A*Y**B/BETA(A,B)
1137 -----------------------------------------------------------------------
1138 */
1139 {
1140 static double Const = .398942280401433e0;
1141 static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1142 static int i,n;
1143 /*
1144 -----------------
1145 CONST = 1/SQRT(2*PI)
1146 -----------------
1147 */
1148 static double T1,T2;
1149 /*
1150 ..
1151 .. Executable Statements ..
1152 */
1153 brcomp = 0.0e0;
1154 if(*x == 0.0e0 || *y == 0.0e0) return brcomp;
1155 a0 = fifdmin1(*a,*b);
1156 if(a0 >= 8.0e0) goto S130;
1157 if(*x > 0.375e0) goto S10;
1158 lnx = log(*x);
1159 T1 = -*x;
1160 lny = alnrel(&T1);
1161 goto S30;
1162 S10:
1163 if(*y > 0.375e0) goto S20;
1164 T2 = -*y;
1165 lnx = alnrel(&T2);
1166 lny = log(*y);
1167 goto S30;
1168 S20:
1169 lnx = log(*x);
1170 lny = log(*y);
1171 S30:
1172 z = *a*lnx+*b*lny;
1173 if(a0 < 1.0e0) goto S40;
1174 z -= betaln(a,b);
1175 brcomp = exp(z);
1176 return brcomp;
1177 S40:
1178 /*
1179 -----------------------------------------------------------------------
1180 PROCEDURE FOR A .LT. 1 OR B .LT. 1
1181 -----------------------------------------------------------------------
1182 */
1183 b0 = fifdmax1(*a,*b);
1184 if(b0 >= 8.0e0) goto S120;
1185 if(b0 > 1.0e0) goto S70;
1186 /*
1187 ALGORITHM FOR B0 .LE. 1
1188 */
1189 brcomp = exp(z);
1190 if(brcomp == 0.0e0) return brcomp;
1191 apb = *a+*b;
1192 if(apb > 1.0e0) goto S50;
1193 z = 1.0e0+gam1(&apb);
1194 goto S60;
1195 S50:
1196 u = *a+*b-1.e0;
1197 z = (1.0e0+gam1(&u))/apb;
1198 S60:
1199 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1200 brcomp = brcomp*(a0*c)/(1.0e0+a0/b0);
1201 return brcomp;
1202 S70:
1203 /*
1204 ALGORITHM FOR 1 .LT. B0 .LT. 8
1205 */
1206 u = gamln1(&a0);
1207 n = int(b0-1.0e0);
1208 if(n < 1) goto S90;
1209 c = 1.0e0;
1210 for(i=1; i<=n; i++) {
1211 b0 -= 1.0e0;
1212 c *= (b0/(a0+b0));
1213 }
1214 u = log(c)+u;
1215 S90:
1216 z -= u;
1217 b0 -= 1.0e0;
1218 apb = a0+b0;
1219 if(apb > 1.0e0) goto S100;
1220 t = 1.0e0+gam1(&apb);
1221 goto S110;
1222 S100:
1223 u = a0+b0-1.e0;
1224 t = (1.0e0+gam1(&u))/apb;
1225 S110:
1226 brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t;
1227 return brcomp;
1228 S120:
1229 /*
1230 ALGORITHM FOR B0 .GE. 8
1231 */
1232 u = gamln1(&a0)+algdiv(&a0,&b0);
1233 brcomp = a0*exp(z-u);
1234 return brcomp;
1235 S130:
1236 /*
1237 -----------------------------------------------------------------------
1238 PROCEDURE FOR A .GE. 8 AND B .GE. 8
1239 -----------------------------------------------------------------------
1240 */
1241 if(*a > *b) goto S140;
1242 h = *a/ *b;
1243 x0 = h/(1.0e0+h);
1244 y0 = 1.0e0/(1.0e0+h);
1245 lambda = *a-(*a+*b)**x;
1246 goto S150;
1247 S140:
1248 h = *b/ *a;
1249 x0 = 1.0e0/(1.0e0+h);
1250 y0 = h/(1.0e0+h);
1251 lambda = (*a+*b)**y-*b;
1252 S150:
1253 e = -(lambda/ *a);
1254 if(fabs(e) > 0.6e0) goto S160;
1255 u = rlog1(&e);
1256 goto S170;
1257 S160:
1258 u = e-log(*x/x0);
1259 S170:
1260 e = lambda/ *b;
1261 if(fabs(e) > 0.6e0) goto S180;
1262 v = rlog1(&e);
1263 goto S190;
1264 S180:
1265 v = e-log(*y/y0);
1266 S190:
1267 z = exp(-(*a*u+*b*v));
1268 brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1269 return brcomp;
1270 }
bup(double * a,double * b,double * x,double * y,int * n,double * eps)1271 double bup(double *a,double *b,double *x,double *y,int *n,double *eps)
1272 /*
1273 -----------------------------------------------------------------------
1274 EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER.
1275 EPS IS THE TOLERANCE USED.
1276 -----------------------------------------------------------------------
1277 */
1278 {
1279 static int K1 = 1;
1280 static int K2 = 0;
1281 static double bup,ap1,apb,d,l,r,t,w;
1282 static int i,k,kp1,mu,nm1;
1283 /*
1284 ..
1285 .. Executable Statements ..
1286 */
1287 /*
1288 OBTAIN THE SCALING FACTOR EXP(-MU) AND
1289 EXP(MU)*(X**A*Y**B/BETA(A,B))/A
1290 */
1291 apb = *a+*b;
1292 ap1 = *a+1.0e0;
1293 mu = 0;
1294 d = 1.0e0;
1295 if(*n == 1 || *a < 1.0e0) goto S10;
1296 if(apb < 1.1e0*ap1) goto S10;
1297 mu = int(fabs(exparg(&K1)));
1298 k = int(exparg(&K2));
1299 if(k < mu) mu = k;
1300 t = mu;
1301 d = exp(-t);
1302 S10:
1303 bup = brcmp1(&mu,a,b,x,y)/ *a;
1304 if(*n == 1 || bup == 0.0e0) return bup;
1305 nm1 = *n-1;
1306 w = d;
1307 /*
1308 LET K BE THE INDEX OF THE MAXIMUM TERM
1309 */
1310 k = 0;
1311 if(*b <= 1.0e0) goto S50;
1312 if(*y > 1.e-4) goto S20;
1313 k = nm1;
1314 goto S30;
1315 S20:
1316 r = (*b-1.0e0)**x/ *y-*a;
1317 if(r < 1.0e0) goto S50;
1318 t = nm1; k = nm1;
1319 if(r < t) k = (int)r;
1320 S30:
1321 /*
1322 ADD THE INCREASING TERMS OF THE SERIES
1323 */
1324 for(i=1; i<=k; i++) {
1325 l = i-1;
1326 d = (apb+l)/(ap1+l)**x*d;
1327 w += d;
1328 }
1329 if(k == nm1) goto S70;
1330 S50:
1331 /*
1332 ADD THE REMAINING TERMS OF THE SERIES
1333 */
1334 kp1 = k+1;
1335 for(i=kp1; i<=nm1; i++) {
1336 l = i-1;
1337 d = (apb+l)/(ap1+l)**x*d;
1338 w += d;
1339 if(d <= *eps*w) goto S70;
1340 }
1341 S70:
1342 /*
1343 TERMINATE THE PROCEDURE
1344 */
1345 bup *= w;
1346 return bup;
1347 }
cdfbet(int * which,double * p,double * q,double * x,double * y,double * a,double * b,int * status,double * bound)1348 void cdfbet(int *which,double *p,double *q,double *x,double *y,
1349 double *a,double *b,int *status,double *bound)
1350 /**********************************************************************
1351
1352 void cdfbet(int *which,double *p,double *q,double *x,double *y,
1353 double *a,double *b,int *status,double *bound)
1354
1355 Cumulative Distribution Function
1356 BETa Distribution
1357
1358
1359 Function
1360
1361
1362 Calculates any one parameter of the beta distribution given
1363 values for the others.
1364
1365
1366 Arguments
1367
1368
1369 WHICH --> Integer indicating which of the next four argument
1370 values is to be calculated from the others.
1371 Legal range: 1..4
1372 iwhich = 1 : Calculate P and Q from X,Y,A and B
1373 iwhich = 2 : Calculate X and Y from P,Q,A and B
1374 iwhich = 3 : Calculate A from P,Q,X,Y and B
1375 iwhich = 4 : Calculate B from P,Q,X,Y and A
1376
1377 P <--> The integral from 0 to X of the chi-square
1378 distribution.
1379 Input range: [0, 1].
1380
1381 Q <--> 1-P.
1382 Input range: [0, 1].
1383 P + Q = 1.0.
1384
1385 X <--> Upper limit of integration of beta density.
1386 Input range: [0,1].
1387 Search range: [0,1]
1388
1389 Y <--> 1-X.
1390 Input range: [0,1].
1391 Search range: [0,1]
1392 X + Y = 1.0.
1393
1394 A <--> The first parameter of the beta density.
1395 Input range: (0, +infinity).
1396 Search range: [1D-300,1D300]
1397
1398 B <--> The second parameter of the beta density.
1399 Input range: (0, +infinity).
1400 Search range: [1D-300,1D300]
1401
1402 STATUS <-- 0 if calculation completed correctly
1403 -I if input parameter number I is out of range
1404 1 if answer appears to be lower than lowest
1405 search bound
1406 2 if answer appears to be higher than greatest
1407 search bound
1408 3 if P + Q .ne. 1
1409 4 if X + Y .ne. 1
1410
1411 BOUND <-- Undefined if STATUS is 0
1412
1413 Bound exceeded by parameter number I if STATUS
1414 is negative.
1415
1416 Lower search bound if STATUS is 1.
1417
1418 Upper search bound if STATUS is 2.
1419
1420
1421 Method
1422
1423
1424 Cumulative distribution function (P) is calculated directly by
1425 code associated with the following reference.
1426
1427 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
1428 Digit Computation of the Incomplete Beta Function Ratios. ACM
1429 Trans. Math. Softw. 18 (1993), 360-373.
1430
1431 Computation of other parameters involve a seach for a value that
1432 produces the desired value of P. The search relies on the
1433 monotinicity of P with the other parameter.
1434
1435
1436 Note
1437
1438
1439 The beta density is proportional to
1440 t^(A-1) * (1-t)^(B-1)
1441
1442 **********************************************************************/
1443 {
1444 #define tol (1.0e-8)
1445 #define atol (1.0e-50)
1446 #define zero (1.0e-300)
1447 #define inf 1.0e300
1448 #define one 1.0e0
1449 static int K1 = 1;
1450 static double K2 = 0.0e0;
1451 static double K3 = 1.0e0;
1452 static double K8 = 0.5e0;
1453 static double K9 = 5.0e0;
1454 static double fx,xhi,xlo,cum,ccum,xy,pq;
1455 static unsigned long qhi,qleft,qporq;
1456 static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15;
1457 /*
1458 ..
1459 .. Executable Statements ..
1460 */
1461 /*
1462 Check arguments
1463 */
1464 if(!(*which < 1 || *which > 4)) goto S30;
1465 if(!(*which < 1)) goto S10;
1466 *bound = 1.0e0;
1467 goto S20;
1468 S10:
1469 *bound = 4.0e0;
1470 S20:
1471 *status = -1;
1472 return;
1473 S30:
1474 if(*which == 1) goto S70;
1475 /*
1476 P
1477 */
1478 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
1479 if(!(*p < 0.0e0)) goto S40;
1480 *bound = 0.0e0;
1481 goto S50;
1482 S40:
1483 *bound = 1.0e0;
1484 S50:
1485 *status = -2;
1486 return;
1487 S70:
1488 S60:
1489 if(*which == 1) goto S110;
1490 /*
1491 Q
1492 */
1493 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
1494 if(!(*q < 0.0e0)) goto S80;
1495 *bound = 0.0e0;
1496 goto S90;
1497 S80:
1498 *bound = 1.0e0;
1499 S90:
1500 *status = -3;
1501 return;
1502 S110:
1503 S100:
1504 if(*which == 2) goto S150;
1505 /*
1506 X
1507 */
1508 if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140;
1509 if(!(*x < 0.0e0)) goto S120;
1510 *bound = 0.0e0;
1511 goto S130;
1512 S120:
1513 *bound = 1.0e0;
1514 S130:
1515 *status = -4;
1516 return;
1517 S150:
1518 S140:
1519 if(*which == 2) goto S190;
1520 /*
1521 Y
1522 */
1523 if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180;
1524 if(!(*y < 0.0e0)) goto S160;
1525 *bound = 0.0e0;
1526 goto S170;
1527 S160:
1528 *bound = 1.0e0;
1529 S170:
1530 *status = -5;
1531 return;
1532 S190:
1533 S180:
1534 if(*which == 3) goto S210;
1535 /*
1536 A
1537 */
1538 if(!(*a <= 0.0e0)) goto S200;
1539 *bound = 0.0e0;
1540 *status = -6;
1541 return;
1542 S210:
1543 S200:
1544 if(*which == 4) goto S230;
1545 /*
1546 B
1547 */
1548 if(!(*b <= 0.0e0)) goto S220;
1549 *bound = 0.0e0;
1550 *status = -7;
1551 return;
1552 S230:
1553 S220:
1554 if(*which == 1) goto S270;
1555 /*
1556 P + Q
1557 */
1558 pq = *p+*q;
1559 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260;
1560 if(!(pq < 0.0e0)) goto S240;
1561 *bound = 0.0e0;
1562 goto S250;
1563 S240:
1564 *bound = 1.0e0;
1565 S250:
1566 *status = 3;
1567 return;
1568 S270:
1569 S260:
1570 if(*which == 2) goto S310;
1571 /*
1572 X + Y
1573 */
1574 xy = *x+*y;
1575 if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300;
1576 if(!(xy < 0.0e0)) goto S280;
1577 *bound = 0.0e0;
1578 goto S290;
1579 S280:
1580 *bound = 1.0e0;
1581 S290:
1582 *status = 4;
1583 return;
1584 S310:
1585 S300:
1586 if(!(*which == 1)) qporq = *p <= *q;
1587 /*
1588 Select the minimum of P or Q
1589 Calculate ANSWERS
1590 */
1591 if(1 == *which) {
1592 /*
1593 Calculating P and Q
1594 */
1595 cumbet(x,y,a,b,p,q);
1596 *status = 0;
1597 }
1598 else if(2 == *which) {
1599 /*
1600 Calculating X and Y
1601 */
1602 T4 = atol;
1603 T5 = tol;
1604 dstzr(&K2,&K3,&T4,&T5);
1605 if(!qporq) goto S340;
1606 *status = 0;
1607 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1608 *y = one-*x;
1609 S320:
1610 if(!(*status == 1)) goto S330;
1611 cumbet(x,y,a,b,&cum,&ccum);
1612 fx = cum-*p;
1613 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1614 *y = one-*x;
1615 goto S320;
1616 S330:
1617 goto S370;
1618 S340:
1619 *status = 0;
1620 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1621 *x = one-*y;
1622 S350:
1623 if(!(*status == 1)) goto S360;
1624 cumbet(x,y,a,b,&cum,&ccum);
1625 fx = ccum-*q;
1626 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1627 *x = one-*y;
1628 goto S350;
1629 S370:
1630 S360:
1631 if(!(*status == -1)) goto S400;
1632 if(!qleft) goto S380;
1633 *status = 1;
1634 *bound = 0.0e0;
1635 goto S390;
1636 S380:
1637 *status = 2;
1638 *bound = 1.0e0;
1639 S400:
1640 S390:
1641 ;
1642 }
1643 else if(3 == *which) {
1644 /*
1645 Computing A
1646 */
1647 *a = 5.0e0;
1648 T6 = zero;
1649 T7 = inf;
1650 T10 = atol;
1651 T11 = tol;
1652 dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11);
1653 *status = 0;
1654 dinvr(status,a,&fx,&qleft,&qhi);
1655 S410:
1656 if(!(*status == 1)) goto S440;
1657 cumbet(x,y,a,b,&cum,&ccum);
1658 if(!qporq) goto S420;
1659 fx = cum-*p;
1660 goto S430;
1661 S420:
1662 fx = ccum-*q;
1663 S430:
1664 dinvr(status,a,&fx,&qleft,&qhi);
1665 goto S410;
1666 S440:
1667 if(!(*status == -1)) goto S470;
1668 if(!qleft) goto S450;
1669 *status = 1;
1670 *bound = zero;
1671 goto S460;
1672 S450:
1673 *status = 2;
1674 *bound = inf;
1675 S470:
1676 S460:
1677 ;
1678 }
1679 else if(4 == *which) {
1680 /*
1681 Computing B
1682 */
1683 *b = 5.0e0;
1684 T12 = zero;
1685 T13 = inf;
1686 T14 = atol;
1687 T15 = tol;
1688 dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15);
1689 *status = 0;
1690 dinvr(status,b,&fx,&qleft,&qhi);
1691 S480:
1692 if(!(*status == 1)) goto S510;
1693 cumbet(x,y,a,b,&cum,&ccum);
1694 if(!qporq) goto S490;
1695 fx = cum-*p;
1696 goto S500;
1697 S490:
1698 fx = ccum-*q;
1699 S500:
1700 dinvr(status,b,&fx,&qleft,&qhi);
1701 goto S480;
1702 S510:
1703 if(!(*status == -1)) goto S540;
1704 if(!qleft) goto S520;
1705 *status = 1;
1706 *bound = zero;
1707 goto S530;
1708 S520:
1709 *status = 2;
1710 *bound = inf;
1711 S530:
1712 ;
1713 }
1714 S540:
1715 return;
1716 #undef tol
1717 #undef atol
1718 #undef zero
1719 #undef inf
1720 #undef one
1721 }
cdfbin(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)1722 void cdfbin(int *which,double *p,double *q,double *s,double *xn,
1723 double *pr,double *ompr,int *status,double *bound)
1724 /**********************************************************************
1725
1726 void cdfbin(int *which,double *p,double *q,double *s,double *xn,
1727 double *pr,double *ompr,int *status,double *bound)
1728
1729 Cumulative Distribution Function
1730 BINomial distribution
1731
1732
1733 Function
1734
1735
1736 Calculates any one parameter of the binomial
1737 distribution given values for the others.
1738
1739
1740 Arguments
1741
1742
1743 WHICH --> Integer indicating which of the next four argument
1744 values is to be calculated from the others.
1745 Legal range: 1..4
1746 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
1747 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
1748 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
1749 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
1750
1751 P <--> The cumulation from 0 to S of the binomial distribution.
1752 (Probablility of S or fewer successes in XN trials each
1753 with probability of success PR.)
1754 Input range: [0,1].
1755
1756 Q <--> 1-P.
1757 Input range: [0, 1].
1758 P + Q = 1.0.
1759
1760 S <--> The number of successes observed.
1761 Input range: [0, XN]
1762 Search range: [0, XN]
1763
1764 XN <--> The number of binomial trials.
1765 Input range: (0, +infinity).
1766 Search range: [1E-300, 1E300]
1767
1768 PR <--> The probability of success in each binomial trial.
1769 Input range: [0,1].
1770 Search range: [0,1]
1771
1772 OMPR <--> 1-PR
1773 Input range: [0,1].
1774 Search range: [0,1]
1775 PR + OMPR = 1.0
1776
1777 STATUS <-- 0 if calculation completed correctly
1778 -I if input parameter number I is out of range
1779 1 if answer appears to be lower than lowest
1780 search bound
1781 2 if answer appears to be higher than greatest
1782 search bound
1783 3 if P + Q .ne. 1
1784 4 if PR + OMPR .ne. 1
1785
1786 BOUND <-- Undefined if STATUS is 0
1787
1788 Bound exceeded by parameter number I if STATUS
1789 is negative.
1790
1791 Lower search bound if STATUS is 1.
1792
1793 Upper search bound if STATUS is 2.
1794
1795
1796 Method
1797
1798
1799 Formula 26.5.24 of Abramowitz and Stegun, Handbook of
1800 Mathematical Functions (1966) is used to reduce the binomial
1801 distribution to the cumulative incomplete beta distribution.
1802
1803 Computation of other parameters involve a seach for a value that
1804 produces the desired value of P. The search relies on the
1805 monotinicity of P with the other parameter.
1806
1807
1808 **********************************************************************/
1809 {
1810 #define atol (1.0e-50)
1811 #define tol (1.0e-8)
1812 #define zero (1.0e-300)
1813 #define inf 1.0e300
1814 #define one 1.0e0
1815 static int K1 = 1;
1816 static double K2 = 0.0e0;
1817 static double K3 = 0.5e0;
1818 static double K4 = 5.0e0;
1819 static double K11 = 1.0e0;
1820 static double fx,xhi,xlo,cum,ccum,pq,prompr;
1821 static unsigned long qhi,qleft,qporq;
1822 static double T5,T6,T7,T8,T9,T10,T12,T13;
1823 /*
1824 ..
1825 .. Executable Statements ..
1826 */
1827 /*
1828 Check arguments
1829 */
1830 if(!(*which < 1 && *which > 4)) goto S30;
1831 if(!(*which < 1)) goto S10;
1832 *bound = 1.0e0;
1833 goto S20;
1834 S10:
1835 *bound = 4.0e0;
1836 S20:
1837 *status = -1;
1838 return;
1839 S30:
1840 if(*which == 1) goto S70;
1841 /*
1842 P
1843 */
1844 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
1845 if(!(*p < 0.0e0)) goto S40;
1846 *bound = 0.0e0;
1847 goto S50;
1848 S40:
1849 *bound = 1.0e0;
1850 S50:
1851 *status = -2;
1852 return;
1853 S70:
1854 S60:
1855 if(*which == 1) goto S110;
1856 /*
1857 Q
1858 */
1859 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
1860 if(!(*q < 0.0e0)) goto S80;
1861 *bound = 0.0e0;
1862 goto S90;
1863 S80:
1864 *bound = 1.0e0;
1865 S90:
1866 *status = -3;
1867 return;
1868 S110:
1869 S100:
1870 if(*which == 3) goto S130;
1871 /*
1872 XN
1873 */
1874 if(!(*xn <= 0.0e0)) goto S120;
1875 *bound = 0.0e0;
1876 *status = -5;
1877 return;
1878 S130:
1879 S120:
1880 if(*which == 2) goto S170;
1881 /*
1882 S
1883 */
1884 if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160;
1885 if(!(*s < 0.0e0)) goto S140;
1886 *bound = 0.0e0;
1887 goto S150;
1888 S140:
1889 *bound = *xn;
1890 S150:
1891 *status = -4;
1892 return;
1893 S170:
1894 S160:
1895 if(*which == 4) goto S210;
1896 /*
1897 PR
1898 */
1899 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200;
1900 if(!(*pr < 0.0e0)) goto S180;
1901 *bound = 0.0e0;
1902 goto S190;
1903 S180:
1904 *bound = 1.0e0;
1905 S190:
1906 *status = -6;
1907 return;
1908 S210:
1909 S200:
1910 if(*which == 4) goto S250;
1911 /*
1912 OMPR
1913 */
1914 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240;
1915 if(!(*ompr < 0.0e0)) goto S220;
1916 *bound = 0.0e0;
1917 goto S230;
1918 S220:
1919 *bound = 1.0e0;
1920 S230:
1921 *status = -7;
1922 return;
1923 S250:
1924 S240:
1925 if(*which == 1) goto S290;
1926 /*
1927 P + Q
1928 */
1929 pq = *p+*q;
1930 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S280;
1931 if(!(pq < 0.0e0)) goto S260;
1932 *bound = 0.0e0;
1933 goto S270;
1934 S260:
1935 *bound = 1.0e0;
1936 S270:
1937 *status = 3;
1938 return;
1939 S290:
1940 S280:
1941 if(*which == 4) goto S330;
1942 /*
1943 PR + OMPR
1944 */
1945 prompr = *pr+*ompr;
1946 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S320;
1947 if(!(prompr < 0.0e0)) goto S300;
1948 *bound = 0.0e0;
1949 goto S310;
1950 S300:
1951 *bound = 1.0e0;
1952 S310:
1953 *status = 4;
1954 return;
1955 S330:
1956 S320:
1957 if(!(*which == 1)) qporq = *p <= *q;
1958 /*
1959 Select the minimum of P or Q
1960 Calculate ANSWERS
1961 */
1962 if(1 == *which) {
1963 /*
1964 Calculating P
1965 */
1966 cumbin(s,xn,pr,ompr,p,q);
1967 *status = 0;
1968 }
1969 else if(2 == *which) {
1970 /*
1971 Calculating S
1972 */
1973 *s = 5.0e0;
1974 T5 = atol;
1975 T6 = tol;
1976 dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6);
1977 *status = 0;
1978 dinvr(status,s,&fx,&qleft,&qhi);
1979 S340:
1980 if(!(*status == 1)) goto S370;
1981 cumbin(s,xn,pr,ompr,&cum,&ccum);
1982 if(!qporq) goto S350;
1983 fx = cum-*p;
1984 goto S360;
1985 S350:
1986 fx = ccum-*q;
1987 S360:
1988 dinvr(status,s,&fx,&qleft,&qhi);
1989 goto S340;
1990 S370:
1991 if(!(*status == -1)) goto S400;
1992 if(!qleft) goto S380;
1993 *status = 1;
1994 *bound = 0.0e0;
1995 goto S390;
1996 S380:
1997 *status = 2;
1998 *bound = *xn;
1999 S400:
2000 S390:
2001 ;
2002 }
2003 else if(3 == *which) {
2004 /*
2005 Calculating XN
2006 */
2007 *xn = 5.0e0;
2008 T7 = zero;
2009 T8 = inf;
2010 T9 = atol;
2011 T10 = tol;
2012 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2013 *status = 0;
2014 dinvr(status,xn,&fx,&qleft,&qhi);
2015 S410:
2016 if(!(*status == 1)) goto S440;
2017 cumbin(s,xn,pr,ompr,&cum,&ccum);
2018 if(!qporq) goto S420;
2019 fx = cum-*p;
2020 goto S430;
2021 S420:
2022 fx = ccum-*q;
2023 S430:
2024 dinvr(status,xn,&fx,&qleft,&qhi);
2025 goto S410;
2026 S440:
2027 if(!(*status == -1)) goto S470;
2028 if(!qleft) goto S450;
2029 *status = 1;
2030 *bound = zero;
2031 goto S460;
2032 S450:
2033 *status = 2;
2034 *bound = inf;
2035 S470:
2036 S460:
2037 ;
2038 }
2039 else if(4 == *which) {
2040 /*
2041 Calculating PR and OMPR
2042 */
2043 T12 = atol;
2044 T13 = tol;
2045 dstzr(&K2,&K11,&T12,&T13);
2046 if(!qporq) goto S500;
2047 *status = 0;
2048 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2049 *ompr = one-*pr;
2050 S480:
2051 if(!(*status == 1)) goto S490;
2052 cumbin(s,xn,pr,ompr,&cum,&ccum);
2053 fx = cum-*p;
2054 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2055 *ompr = one-*pr;
2056 goto S480;
2057 S490:
2058 goto S530;
2059 S500:
2060 *status = 0;
2061 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2062 *pr = one-*ompr;
2063 S510:
2064 if(!(*status == 1)) goto S520;
2065 cumbin(s,xn,pr,ompr,&cum,&ccum);
2066 fx = ccum-*q;
2067 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2068 *pr = one-*ompr;
2069 goto S510;
2070 S530:
2071 S520:
2072 if(!(*status == -1)) goto S560;
2073 if(!qleft) goto S540;
2074 *status = 1;
2075 *bound = 0.0e0;
2076 goto S550;
2077 S540:
2078 *status = 2;
2079 *bound = 1.0e0;
2080 S550:
2081 ;
2082 }
2083 S560:
2084 return;
2085 #undef atol
2086 #undef tol
2087 #undef zero
2088 #undef inf
2089 #undef one
2090 }
cdfchi(int * which,double * p,double * q,double * x,double * df,int * status,double * bound)2091 void cdfchi(int *which,double *p,double *q,double *x,double *df,
2092 int *status,double *bound)
2093 /**********************************************************************
2094
2095 void cdfchi(int *which,double *p,double *q,double *x,double *df,
2096 int *status,double *bound)
2097
2098 Cumulative Distribution Function
2099 CHI-Square distribution
2100
2101
2102 Function
2103
2104
2105 Calculates any one parameter of the chi-square
2106 distribution given values for the others.
2107
2108
2109 Arguments
2110
2111
2112 WHICH --> Integer indicating which of the next three argument
2113 values is to be calculated from the others.
2114 Legal range: 1..3
2115 iwhich = 1 : Calculate P and Q from X and DF
2116 iwhich = 2 : Calculate X from P,Q and DF
2117 iwhich = 3 : Calculate DF from P,Q and X
2118
2119 P <--> The integral from 0 to X of the chi-square
2120 distribution.
2121 Input range: [0, 1].
2122
2123 Q <--> 1-P.
2124 Input range: (0, 1].
2125 P + Q = 1.0.
2126
2127 X <--> Upper limit of integration of the non-central
2128 chi-square distribution.
2129 Input range: [0, +infinity).
2130 Search range: [0,1E300]
2131
2132 DF <--> Degrees of freedom of the
2133 chi-square distribution.
2134 Input range: (0, +infinity).
2135 Search range: [ 1E-300, 1E300]
2136
2137 STATUS <-- 0 if calculation completed correctly
2138 -I if input parameter number I is out of range
2139 1 if answer appears to be lower than lowest
2140 search bound
2141 2 if answer appears to be higher than greatest
2142 search bound
2143 3 if P + Q .ne. 1
2144 10 indicates error returned from cumgam. See
2145 references in cdfgam
2146
2147 BOUND <-- Undefined if STATUS is 0
2148
2149 Bound exceeded by parameter number I if STATUS
2150 is negative.
2151
2152 Lower search bound if STATUS is 1.
2153
2154 Upper search bound if STATUS is 2.
2155
2156
2157 Method
2158
2159
2160 Formula 26.4.19 of Abramowitz and Stegun, Handbook of
2161 Mathematical Functions (1966) is used to reduce the chisqure
2162 distribution to the incomplete distribution.
2163
2164 Computation of other parameters involve a seach for a value that
2165 produces the desired value of P. The search relies on the
2166 monotinicity of P with the other parameter.
2167
2168 **********************************************************************/
2169 {
2170 #define tol (1.0e-8)
2171 #define atol (1.0e-50)
2172 #define zero (1.0e-300)
2173 #define inf 1.0e300
2174 static int K1 = 1;
2175 static double K2 = 0.0e0;
2176 static double K4 = 0.5e0;
2177 static double K5 = 5.0e0;
2178 static double fx,cum,ccum,pq,porq;
2179 static unsigned long qhi,qleft,qporq;
2180 static double T3,T6,T7,T8,T9,T10,T11;
2181 /*
2182 ..
2183 .. Executable Statements ..
2184 */
2185 /*
2186 Check arguments
2187 */
2188 if(!(*which < 1 || *which > 3)) goto S30;
2189 if(!(*which < 1)) goto S10;
2190 *bound = 1.0e0;
2191 goto S20;
2192 S10:
2193 *bound = 3.0e0;
2194 S20:
2195 *status = -1;
2196 return;
2197 S30:
2198 if(*which == 1) goto S70;
2199 /*
2200 P
2201 */
2202 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2203 if(!(*p < 0.0e0)) goto S40;
2204 *bound = 0.0e0;
2205 goto S50;
2206 S40:
2207 *bound = 1.0e0;
2208 S50:
2209 *status = -2;
2210 return;
2211 S70:
2212 S60:
2213 if(*which == 1) goto S110;
2214 /*
2215 Q
2216 */
2217 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2218 if(!(*q <= 0.0e0)) goto S80;
2219 *bound = 0.0e0;
2220 goto S90;
2221 S80:
2222 *bound = 1.0e0;
2223 S90:
2224 *status = -3;
2225 return;
2226 S110:
2227 S100:
2228 if(*which == 2) goto S130;
2229 /*
2230 X
2231 */
2232 if(!(*x < 0.0e0)) goto S120;
2233 *bound = 0.0e0;
2234 *status = -4;
2235 return;
2236 S130:
2237 S120:
2238 if(*which == 3) goto S150;
2239 /*
2240 DF
2241 */
2242 if(!(*df <= 0.0e0)) goto S140;
2243 *bound = 0.0e0;
2244 *status = -5;
2245 return;
2246 S150:
2247 S140:
2248 if(*which == 1) goto S190;
2249 /*
2250 P + Q
2251 */
2252 pq = *p+*q;
2253 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180;
2254 if(!(pq < 0.0e0)) goto S160;
2255 *bound = 0.0e0;
2256 goto S170;
2257 S160:
2258 *bound = 1.0e0;
2259 S170:
2260 *status = 3;
2261 return;
2262 S190:
2263 S180:
2264 if(*which == 1) goto S220;
2265 /*
2266 Select the minimum of P or Q
2267 */
2268 qporq = *p <= *q;
2269 if(!qporq) goto S200;
2270 porq = *p;
2271 goto S210;
2272 S200:
2273 porq = *q;
2274 S220:
2275 S210:
2276 /*
2277 Calculate ANSWERS
2278 */
2279 if(1 == *which) {
2280 /*
2281 Calculating P and Q
2282 */
2283 *status = 0;
2284 cumchi(x,df,p,q);
2285 if(porq > 1.5e0) {
2286 *status = 10;
2287 return;
2288 }
2289 }
2290 else if(2 == *which) {
2291 /*
2292 Calculating X
2293 */
2294 *x = 5.0e0;
2295 T3 = inf;
2296 T6 = atol;
2297 T7 = tol;
2298 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
2299 *status = 0;
2300 dinvr(status,x,&fx,&qleft,&qhi);
2301 S230:
2302 if(!(*status == 1)) goto S270;
2303 cumchi(x,df,&cum,&ccum);
2304 if(!qporq) goto S240;
2305 fx = cum-*p;
2306 goto S250;
2307 S240:
2308 fx = ccum-*q;
2309 S250:
2310 if(!(fx+porq > 1.5e0)) goto S260;
2311 *status = 10;
2312 return;
2313 S260:
2314 dinvr(status,x,&fx,&qleft,&qhi);
2315 goto S230;
2316 S270:
2317 if(!(*status == -1)) goto S300;
2318 if(!qleft) goto S280;
2319 *status = 1;
2320 *bound = 0.0e0;
2321 goto S290;
2322 S280:
2323 *status = 2;
2324 *bound = inf;
2325 S300:
2326 S290:
2327 ;
2328 }
2329 else if(3 == *which) {
2330 /*
2331 Calculating DF
2332 */
2333 *df = 5.0e0;
2334 T8 = zero;
2335 T9 = inf;
2336 T10 = atol;
2337 T11 = tol;
2338 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
2339 *status = 0;
2340 dinvr(status,df,&fx,&qleft,&qhi);
2341 S310:
2342 if(!(*status == 1)) goto S350;
2343 cumchi(x,df,&cum,&ccum);
2344 if(!qporq) goto S320;
2345 fx = cum-*p;
2346 goto S330;
2347 S320:
2348 fx = ccum-*q;
2349 S330:
2350 if(!(fx+porq > 1.5e0)) goto S340;
2351 *status = 10;
2352 return;
2353 S340:
2354 dinvr(status,df,&fx,&qleft,&qhi);
2355 goto S310;
2356 S350:
2357 if(!(*status == -1)) goto S380;
2358 if(!qleft) goto S360;
2359 *status = 1;
2360 *bound = zero;
2361 goto S370;
2362 S360:
2363 *status = 2;
2364 *bound = inf;
2365 S370:
2366 ;
2367 }
2368 S380:
2369 return;
2370 #undef tol
2371 #undef atol
2372 #undef zero
2373 #undef inf
2374 }
cdfchn(int * which,double * p,double * q,double * x,double * df,double * pnonc,int * status,double * bound)2375 void cdfchn(int *which,double *p,double *q,double *x,double *df,
2376 double *pnonc,int *status,double *bound)
2377 /**********************************************************************
2378
2379 void cdfchn(int *which,double *p,double *q,double *x,double *df,
2380 double *pnonc,int *status,double *bound)
2381
2382 Cumulative Distribution Function
2383 Non-central Chi-Square
2384
2385
2386 Function
2387
2388
2389 Calculates any one parameter of the non-central chi-square
2390 distribution given values for the others.
2391
2392
2393 Arguments
2394
2395
2396 WHICH --> Integer indicating which of the next three argument
2397 values is to be calculated from the others.
2398 Input range: 1..4
2399 iwhich = 1 : Calculate P and Q from X and DF
2400 iwhich = 2 : Calculate X from P,DF and PNONC
2401 iwhich = 3 : Calculate DF from P,X and PNONC
2402 iwhich = 3 : Calculate PNONC from P,X and DF
2403
2404 P <--> The integral from 0 to X of the non-central chi-square
2405 distribution.
2406 Input range: [0, 1-1E-16).
2407
2408 Q <--> 1-P.
2409 Q is not used by this subroutine and is only included
2410 for similarity with other cdf* routines.
2411
2412 X <--> Upper limit of integration of the non-central
2413 chi-square distribution.
2414 Input range: [0, +infinity).
2415 Search range: [0,1E300]
2416
2417 DF <--> Degrees of freedom of the non-central
2418 chi-square distribution.
2419 Input range: (0, +infinity).
2420 Search range: [ 1E-300, 1E300]
2421
2422 PNONC <--> Non-centrality parameter of the non-central
2423 chi-square distribution.
2424 Input range: [0, +infinity).
2425 Search range: [0,1E4]
2426
2427 STATUS <-- 0 if calculation completed correctly
2428 -I if input parameter number I is out of range
2429 1 if answer appears to be lower than lowest
2430 search bound
2431 2 if answer appears to be higher than greatest
2432 search bound
2433
2434 BOUND <-- Undefined if STATUS is 0
2435
2436 Bound exceeded by parameter number I if STATUS
2437 is negative.
2438
2439 Lower search bound if STATUS is 1.
2440
2441 Upper search bound if STATUS is 2.
2442
2443
2444 Method
2445
2446
2447 Formula 26.4.25 of Abramowitz and Stegun, Handbook of
2448 Mathematical Functions (1966) is used to compute the cumulative
2449 distribution function.
2450
2451 Computation of other parameters involve a seach for a value that
2452 produces the desired value of P. The search relies on the
2453 monotinicity of P with the other parameter.
2454
2455
2456 WARNING
2457
2458 The computation time required for this routine is proportional
2459 to the noncentrality parameter (PNONC). Very large values of
2460 this parameter can consume immense computer resources. This is
2461 why the search range is bounded by 10,000.
2462
2463 **********************************************************************/
2464 {
2465 #define tent4 1.0e4
2466 #define tol (1.0e-8)
2467 #define atol (1.0e-50)
2468 #define zero (1.0e-300)
2469 #define one (1.0e0-1.0e-16)
2470 #define inf 1.0e300
2471 static double K1 = 0.0e0;
2472 static double K3 = 0.5e0;
2473 static double K4 = 5.0e0;
2474 static double fx,cum,ccum;
2475 static unsigned long qhi,qleft;
2476 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13;
2477 /*
2478 ..
2479 .. Executable Statements ..
2480 */
2481 /*
2482 Check arguments
2483 */
2484 if(!(*which < 1 || *which > 4)) goto S30;
2485 if(!(*which < 1)) goto S10;
2486 *bound = 1.0e0;
2487 goto S20;
2488 S10:
2489 *bound = 4.0e0;
2490 S20:
2491 *status = -1;
2492 return;
2493 S30:
2494 if(*which == 1) goto S70;
2495 /*
2496 P
2497 */
2498 if(!(*p < 0.0e0 || *p > one)) goto S60;
2499 if(!(*p < 0.0e0)) goto S40;
2500 *bound = 0.0e0;
2501 goto S50;
2502 S40:
2503 *bound = one;
2504 S50:
2505 *status = -2;
2506 return;
2507 S70:
2508 S60:
2509 if(*which == 2) goto S90;
2510 /*
2511 X
2512 */
2513 if(!(*x < 0.0e0)) goto S80;
2514 *bound = 0.0e0;
2515 *status = -4;
2516 return;
2517 S90:
2518 S80:
2519 if(*which == 3) goto S110;
2520 /*
2521 DF
2522 */
2523 if(!(*df <= 0.0e0)) goto S100;
2524 *bound = 0.0e0;
2525 *status = -5;
2526 return;
2527 S110:
2528 S100:
2529 if(*which == 4) goto S130;
2530 /*
2531 PNONC
2532 */
2533 if(!(*pnonc < 0.0e0)) goto S120;
2534 *bound = 0.0e0;
2535 *status = -6;
2536 return;
2537 S130:
2538 S120:
2539 /*
2540 Calculate ANSWERS
2541 */
2542 if(1 == *which) {
2543 /*
2544 Calculating P and Q
2545 */
2546 cumchn(x,df,pnonc,p,q);
2547 *status = 0;
2548 }
2549 else if(2 == *which) {
2550 /*
2551 Calculating X
2552 */
2553 *x = 5.0e0;
2554 T2 = inf;
2555 T5 = atol;
2556 T6 = tol;
2557 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
2558 *status = 0;
2559 dinvr(status,x,&fx,&qleft,&qhi);
2560 S140:
2561 if(!(*status == 1)) goto S150;
2562 cumchn(x,df,pnonc,&cum,&ccum);
2563 fx = cum-*p;
2564 dinvr(status,x,&fx,&qleft,&qhi);
2565 goto S140;
2566 S150:
2567 if(!(*status == -1)) goto S180;
2568 if(!qleft) goto S160;
2569 *status = 1;
2570 *bound = 0.0e0;
2571 goto S170;
2572 S160:
2573 *status = 2;
2574 *bound = inf;
2575 S180:
2576 S170:
2577 ;
2578 }
2579 else if(3 == *which) {
2580 /*
2581 Calculating DF
2582 */
2583 *df = 5.0e0;
2584 T7 = zero;
2585 T8 = inf;
2586 T9 = atol;
2587 T10 = tol;
2588 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2589 *status = 0;
2590 dinvr(status,df,&fx,&qleft,&qhi);
2591 S190:
2592 if(!(*status == 1)) goto S200;
2593 cumchn(x,df,pnonc,&cum,&ccum);
2594 fx = cum-*p;
2595 dinvr(status,df,&fx,&qleft,&qhi);
2596 goto S190;
2597 S200:
2598 if(!(*status == -1)) goto S230;
2599 if(!qleft) goto S210;
2600 *status = 1;
2601 *bound = zero;
2602 goto S220;
2603 S210:
2604 *status = 2;
2605 *bound = inf;
2606 S230:
2607 S220:
2608 ;
2609 }
2610 else if(4 == *which) {
2611 /*
2612 Calculating PNONC
2613 */
2614 *pnonc = 5.0e0;
2615 T11 = tent4;
2616 T12 = atol;
2617 T13 = tol;
2618 dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13);
2619 *status = 0;
2620 dinvr(status,pnonc,&fx,&qleft,&qhi);
2621 S240:
2622 if(!(*status == 1)) goto S250;
2623 cumchn(x,df,pnonc,&cum,&ccum);
2624 fx = cum-*p;
2625 dinvr(status,pnonc,&fx,&qleft,&qhi);
2626 goto S240;
2627 S250:
2628 if(!(*status == -1)) goto S280;
2629 if(!qleft) goto S260;
2630 *status = 1;
2631 *bound = zero;
2632 goto S270;
2633 S260:
2634 *status = 2;
2635 *bound = tent4;
2636 S270:
2637 ;
2638 }
2639 S280:
2640 return;
2641 #undef tent4
2642 #undef tol
2643 #undef atol
2644 #undef zero
2645 #undef one
2646 #undef inf
2647 }
cdff(int * which,double * p,double * q,double * f,double * dfn,double * dfd,int * status,double * bound)2648 void cdff(int *which,double *p,double *q,double *f,double *dfn,
2649 double *dfd,int *status,double *bound)
2650 /**********************************************************************
2651
2652 void cdff(int *which,double *p,double *q,double *f,double *dfn,
2653 double *dfd,int *status,double *bound)
2654
2655 Cumulative Distribution Function
2656 F distribution
2657
2658
2659 Function
2660
2661
2662 Calculates any one parameter of the F distribution
2663 given values for the others.
2664
2665
2666 Arguments
2667
2668
2669 WHICH --> Integer indicating which of the next four argument
2670 values is to be calculated from the others.
2671 Legal range: 1..4
2672 iwhich = 1 : Calculate P and Q from F,DFN and DFD
2673 iwhich = 2 : Calculate F from P,Q,DFN and DFD
2674 iwhich = 3 : Calculate DFN from P,Q,F and DFD
2675 iwhich = 4 : Calculate DFD from P,Q,F and DFN
2676
2677 P <--> The integral from 0 to F of the f-density.
2678 Input range: [0,1].
2679
2680 Q <--> 1-P.
2681 Input range: (0, 1].
2682 P + Q = 1.0.
2683
2684 F <--> Upper limit of integration of the f-density.
2685 Input range: [0, +infinity).
2686 Search range: [0,1E300]
2687
2688 DFN < --> Degrees of freedom of the numerator sum of squares.
2689 Input range: (0, +infinity).
2690 Search range: [ 1E-300, 1E300]
2691
2692 DFD < --> Degrees of freedom of the denominator sum of squares.
2693 Input range: (0, +infinity).
2694 Search range: [ 1E-300, 1E300]
2695
2696 STATUS <-- 0 if calculation completed correctly
2697 -I if input parameter number I is out of range
2698 1 if answer appears to be lower than lowest
2699 search bound
2700 2 if answer appears to be higher than greatest
2701 search bound
2702 3 if P + Q .ne. 1
2703
2704 BOUND <-- Undefined if STATUS is 0
2705
2706 Bound exceeded by parameter number I if STATUS
2707 is negative.
2708
2709 Lower search bound if STATUS is 1.
2710
2711 Upper search bound if STATUS is 2.
2712
2713
2714 Method
2715
2716
2717 Formula 26.6.2 of Abramowitz and Stegun, Handbook of
2718 Mathematical Functions (1966) is used to reduce the computation
2719 of the cumulative distribution function for the F variate to
2720 that of an incomplete beta.
2721
2722 Computation of other parameters involve a seach for a value that
2723 produces the desired value of P. The search relies on the
2724 monotinicity of P with the other parameter.
2725
2726 WARNING
2727
2728 The value of the cumulative F distribution is not necessarily
2729 monotone in either degrees of freedom. There thus may be two
2730 values that provide a given CDF value. This routine assumes
2731 monotonicity and will find an arbitrary one of the two values.
2732
2733 **********************************************************************/
2734 {
2735 #define tol (1.0e-8)
2736 #define atol (1.0e-50)
2737 #define zero (1.0e-300)
2738 #define inf 1.0e300
2739 static int K1 = 1;
2740 static double K2 = 0.0e0;
2741 static double K4 = 0.5e0;
2742 static double K5 = 5.0e0;
2743 static double pq,fx,cum,ccum;
2744 static unsigned long qhi,qleft,qporq;
2745 static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15;
2746 /*
2747 ..
2748 .. Executable Statements ..
2749 */
2750 /*
2751 Check arguments
2752 */
2753 if(!(*which < 1 || *which > 4)) goto S30;
2754 if(!(*which < 1)) goto S10;
2755 *bound = 1.0e0;
2756 goto S20;
2757 S10:
2758 *bound = 4.0e0;
2759 S20:
2760 *status = -1;
2761 return;
2762 S30:
2763 if(*which == 1) goto S70;
2764 /*
2765 P
2766 */
2767 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2768 if(!(*p < 0.0e0)) goto S40;
2769 *bound = 0.0e0;
2770 goto S50;
2771 S40:
2772 *bound = 1.0e0;
2773 S50:
2774 *status = -2;
2775 return;
2776 S70:
2777 S60:
2778 if(*which == 1) goto S110;
2779 /*
2780 Q
2781 */
2782 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2783 if(!(*q <= 0.0e0)) goto S80;
2784 *bound = 0.0e0;
2785 goto S90;
2786 S80:
2787 *bound = 1.0e0;
2788 S90:
2789 *status = -3;
2790 return;
2791 S110:
2792 S100:
2793 if(*which == 2) goto S130;
2794 /*
2795 F
2796 */
2797 if(!(*f < 0.0e0)) goto S120;
2798 *bound = 0.0e0;
2799 *status = -4;
2800 return;
2801 S130:
2802 S120:
2803 if(*which == 3) goto S150;
2804 /*
2805 DFN
2806 */
2807 if(!(*dfn <= 0.0e0)) goto S140;
2808 *bound = 0.0e0;
2809 *status = -5;
2810 return;
2811 S150:
2812 S140:
2813 if(*which == 4) goto S170;
2814 /*
2815 DFD
2816 */
2817 if(!(*dfd <= 0.0e0)) goto S160;
2818 *bound = 0.0e0;
2819 *status = -6;
2820 return;
2821 S170:
2822 S160:
2823 if(*which == 1) goto S210;
2824 /*
2825 P + Q
2826 */
2827 pq = *p+*q;
2828 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200;
2829 if(!(pq < 0.0e0)) goto S180;
2830 *bound = 0.0e0;
2831 goto S190;
2832 S180:
2833 *bound = 1.0e0;
2834 S190:
2835 *status = 3;
2836 return;
2837 S210:
2838 S200:
2839 if(!(*which == 1)) qporq = *p <= *q;
2840 /*
2841 Select the minimum of P or Q
2842 Calculate ANSWERS
2843 */
2844 if(1 == *which) {
2845 /*
2846 Calculating P
2847 */
2848 cumf(f,dfn,dfd,p,q);
2849 *status = 0;
2850 }
2851 else if(2 == *which) {
2852 /*
2853 Calculating F
2854 */
2855 *f = 5.0e0;
2856 T3 = inf;
2857 T6 = atol;
2858 T7 = tol;
2859 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
2860 *status = 0;
2861 dinvr(status,f,&fx,&qleft,&qhi);
2862 S220:
2863 if(!(*status == 1)) goto S250;
2864 cumf(f,dfn,dfd,&cum,&ccum);
2865 if(!qporq) goto S230;
2866 fx = cum-*p;
2867 goto S240;
2868 S230:
2869 fx = ccum-*q;
2870 S240:
2871 dinvr(status,f,&fx,&qleft,&qhi);
2872 goto S220;
2873 S250:
2874 if(!(*status == -1)) goto S280;
2875 if(!qleft) goto S260;
2876 *status = 1;
2877 *bound = 0.0e0;
2878 goto S270;
2879 S260:
2880 *status = 2;
2881 *bound = inf;
2882 S280:
2883 S270:
2884 ;
2885 }
2886 else if(3 == *which) {
2887 /*
2888 Calculating DFN
2889 */
2890 *dfn = 5.0e0;
2891 T8 = zero;
2892 T9 = inf;
2893 T10 = atol;
2894 T11 = tol;
2895 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
2896 *status = 0;
2897 dinvr(status,dfn,&fx,&qleft,&qhi);
2898 S290:
2899 if(!(*status == 1)) goto S320;
2900 cumf(f,dfn,dfd,&cum,&ccum);
2901 if(!qporq) goto S300;
2902 fx = cum-*p;
2903 goto S310;
2904 S300:
2905 fx = ccum-*q;
2906 S310:
2907 dinvr(status,dfn,&fx,&qleft,&qhi);
2908 goto S290;
2909 S320:
2910 if(!(*status == -1)) goto S350;
2911 if(!qleft) goto S330;
2912 *status = 1;
2913 *bound = zero;
2914 goto S340;
2915 S330:
2916 *status = 2;
2917 *bound = inf;
2918 S350:
2919 S340:
2920 ;
2921 }
2922 else if(4 == *which) {
2923 /*
2924 Calculating DFD
2925 */
2926 *dfd = 5.0e0;
2927 T12 = zero;
2928 T13 = inf;
2929 T14 = atol;
2930 T15 = tol;
2931 dstinv(&T12,&T13,&K4,&K4,&K5,&T14,&T15);
2932 *status = 0;
2933 dinvr(status,dfd,&fx,&qleft,&qhi);
2934 S360:
2935 if(!(*status == 1)) goto S390;
2936 cumf(f,dfn,dfd,&cum,&ccum);
2937 if(!qporq) goto S370;
2938 fx = cum-*p;
2939 goto S380;
2940 S370:
2941 fx = ccum-*q;
2942 S380:
2943 dinvr(status,dfd,&fx,&qleft,&qhi);
2944 goto S360;
2945 S390:
2946 if(!(*status == -1)) goto S420;
2947 if(!qleft) goto S400;
2948 *status = 1;
2949 *bound = zero;
2950 goto S410;
2951 S400:
2952 *status = 2;
2953 *bound = inf;
2954 S410:
2955 ;
2956 }
2957 S420:
2958 return;
2959 #undef tol
2960 #undef atol
2961 #undef zero
2962 #undef inf
2963 }
cdffnc(int * which,double * p,double * q,double * f,double * dfn,double * dfd,double * phonc,int * status,double * bound)2964 void cdffnc(int *which,double *p,double *q,double *f,double *dfn,
2965 double *dfd,double *phonc,int *status,double *bound)
2966 /**********************************************************************
2967
2968 void cdffnc(int *which,double *p,double *q,double *f,double *dfn,
2969 double *dfd,double *phonc,int *status,double *bound)
2970
2971 Cumulative Distribution Function
2972 Non-central F distribution
2973
2974
2975 Function
2976
2977
2978 Calculates any one parameter of the Non-central F
2979 distribution given values for the others.
2980
2981
2982 Arguments
2983
2984
2985 WHICH --> Integer indicating which of the next five argument
2986 values is to be calculated from the others.
2987 Legal range: 1..5
2988 iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC
2989 iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC
2990 iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC
2991 iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC
2992 iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD
2993
2994 P <--> The integral from 0 to F of the non-central f-density.
2995 Input range: [0,1-1E-16).
2996
2997 Q <--> 1-P.
2998 Q is not used by this subroutine and is only included
2999 for similarity with other cdf* routines.
3000
3001 F <--> Upper limit of integration of the non-central f-density.
3002 Input range: [0, +infinity).
3003 Search range: [0,1E300]
3004
3005 DFN < --> Degrees of freedom of the numerator sum of squares.
3006 Input range: (0, +infinity).
3007 Search range: [ 1E-300, 1E300]
3008
3009 DFD < --> Degrees of freedom of the denominator sum of squares.
3010 Must be in range: (0, +infinity).
3011 Input range: (0, +infinity).
3012 Search range: [ 1E-300, 1E300]
3013
3014 PNONC <-> The non-centrality parameter
3015 Input range: [0,infinity)
3016 Search range: [0,1E4]
3017
3018 STATUS <-- 0 if calculation completed correctly
3019 -I if input parameter number I is out of range
3020 1 if answer appears to be lower than lowest
3021 search bound
3022 2 if answer appears to be higher than greatest
3023 search bound
3024 3 if P + Q .ne. 1
3025
3026 BOUND <-- Undefined if STATUS is 0
3027
3028 Bound exceeded by parameter number I if STATUS
3029 is negative.
3030
3031 Lower search bound if STATUS is 1.
3032
3033 Upper search bound if STATUS is 2.
3034
3035
3036 Method
3037
3038
3039 Formula 26.6.20 of Abramowitz and Stegun, Handbook of
3040 Mathematical Functions (1966) is used to compute the cumulative
3041 distribution function.
3042
3043 Computation of other parameters involve a seach for a value that
3044 produces the desired value of P. The search relies on the
3045 monotinicity of P with the other parameter.
3046
3047 WARNING
3048
3049 The computation time required for this routine is proportional
3050 to the noncentrality parameter (PNONC). Very large values of
3051 this parameter can consume immense computer resources. This is
3052 why the search range is bounded by 10,000.
3053
3054 WARNING
3055
3056 The value of the cumulative noncentral F distribution is not
3057 necessarily monotone in either degrees of freedom. There thus
3058 may be two values that provide a given CDF value. This routine
3059 assumes monotonicity and will find an arbitrary one of the two
3060 values.
3061
3062 **********************************************************************/
3063 {
3064 #define tent4 1.0e4
3065 #define tol (1.0e-8)
3066 #define atol (1.0e-50)
3067 #define zero (1.0e-300)
3068 #define one (1.0e0-1.0e-16)
3069 #define inf 1.0e300
3070 static double K1 = 0.0e0;
3071 static double K3 = 0.5e0;
3072 static double K4 = 5.0e0;
3073 static double fx,cum,ccum;
3074 static unsigned long qhi,qleft;
3075 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17;
3076 /*
3077 ..
3078 .. Executable Statements ..
3079 */
3080 /*
3081 Check arguments
3082 */
3083 if(!(*which < 1 || *which > 5)) goto S30;
3084 if(!(*which < 1)) goto S10;
3085 *bound = 1.0e0;
3086 goto S20;
3087 S10:
3088 *bound = 5.0e0;
3089 S20:
3090 *status = -1;
3091 return;
3092 S30:
3093 if(*which == 1) goto S70;
3094 /*
3095 P
3096 */
3097 if(!(*p < 0.0e0 || *p > one)) goto S60;
3098 if(!(*p < 0.0e0)) goto S40;
3099 *bound = 0.0e0;
3100 goto S50;
3101 S40:
3102 *bound = one;
3103 S50:
3104 *status = -2;
3105 return;
3106 S70:
3107 S60:
3108 if(*which == 2) goto S90;
3109 /*
3110 F
3111 */
3112 if(!(*f < 0.0e0)) goto S80;
3113 *bound = 0.0e0;
3114 *status = -4;
3115 return;
3116 S90:
3117 S80:
3118 if(*which == 3) goto S110;
3119 /*
3120 DFN
3121 */
3122 if(!(*dfn <= 0.0e0)) goto S100;
3123 *bound = 0.0e0;
3124 *status = -5;
3125 return;
3126 S110:
3127 S100:
3128 if(*which == 4) goto S130;
3129 /*
3130 DFD
3131 */
3132 if(!(*dfd <= 0.0e0)) goto S120;
3133 *bound = 0.0e0;
3134 *status = -6;
3135 return;
3136 S130:
3137 S120:
3138 if(*which == 5) goto S150;
3139 /*
3140 PHONC
3141 */
3142 if(!(*phonc < 0.0e0)) goto S140;
3143 *bound = 0.0e0;
3144 *status = -7;
3145 return;
3146 S150:
3147 S140:
3148 /*
3149 Calculate ANSWERS
3150 */
3151 if(1 == *which) {
3152 /*
3153 Calculating P
3154 */
3155 cumfnc(f,dfn,dfd,phonc,p,q);
3156 *status = 0;
3157 }
3158 else if(2 == *which) {
3159 /*
3160 Calculating F
3161 */
3162 *f = 5.0e0;
3163 T2 = inf;
3164 T5 = atol;
3165 T6 = tol;
3166 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
3167 *status = 0;
3168 dinvr(status,f,&fx,&qleft,&qhi);
3169 S160:
3170 if(!(*status == 1)) goto S170;
3171 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3172 fx = cum-*p;
3173 dinvr(status,f,&fx,&qleft,&qhi);
3174 goto S160;
3175 S170:
3176 if(!(*status == -1)) goto S200;
3177 if(!qleft) goto S180;
3178 *status = 1;
3179 *bound = 0.0e0;
3180 goto S190;
3181 S180:
3182 *status = 2;
3183 *bound = inf;
3184 S200:
3185 S190:
3186 ;
3187 }
3188 else if(3 == *which) {
3189 /*
3190 Calculating DFN
3191 */
3192 *dfn = 5.0e0;
3193 T7 = zero;
3194 T8 = inf;
3195 T9 = atol;
3196 T10 = tol;
3197 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
3198 *status = 0;
3199 dinvr(status,dfn,&fx,&qleft,&qhi);
3200 S210:
3201 if(!(*status == 1)) goto S220;
3202 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3203 fx = cum-*p;
3204 dinvr(status,dfn,&fx,&qleft,&qhi);
3205 goto S210;
3206 S220:
3207 if(!(*status == -1)) goto S250;
3208 if(!qleft) goto S230;
3209 *status = 1;
3210 *bound = zero;
3211 goto S240;
3212 S230:
3213 *status = 2;
3214 *bound = inf;
3215 S250:
3216 S240:
3217 ;
3218 }
3219 else if(4 == *which) {
3220 /*
3221 Calculating DFD
3222 */
3223 *dfd = 5.0e0;
3224 T11 = zero;
3225 T12 = inf;
3226 T13 = atol;
3227 T14 = tol;
3228 dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14);
3229 *status = 0;
3230 dinvr(status,dfd,&fx,&qleft,&qhi);
3231 S260:
3232 if(!(*status == 1)) goto S270;
3233 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3234 fx = cum-*p;
3235 dinvr(status,dfd,&fx,&qleft,&qhi);
3236 goto S260;
3237 S270:
3238 if(!(*status == -1)) goto S300;
3239 if(!qleft) goto S280;
3240 *status = 1;
3241 *bound = zero;
3242 goto S290;
3243 S280:
3244 *status = 2;
3245 *bound = inf;
3246 S300:
3247 S290:
3248 ;
3249 }
3250 else if(5 == *which) {
3251 /*
3252 Calculating PHONC
3253 */
3254 *phonc = 5.0e0;
3255 T15 = tent4;
3256 T16 = atol;
3257 T17 = tol;
3258 dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17);
3259 *status = 0;
3260 dinvr(status,phonc,&fx,&qleft,&qhi);
3261 S310:
3262 if(!(*status == 1)) goto S320;
3263 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3264 fx = cum-*p;
3265 dinvr(status,phonc,&fx,&qleft,&qhi);
3266 goto S310;
3267 S320:
3268 if(!(*status == -1)) goto S350;
3269 if(!qleft) goto S330;
3270 *status = 1;
3271 *bound = 0.0e0;
3272 goto S340;
3273 S330:
3274 *status = 2;
3275 *bound = tent4;
3276 S340:
3277 ;
3278 }
3279 S350:
3280 return;
3281 #undef tent4
3282 #undef tol
3283 #undef atol
3284 #undef zero
3285 #undef one
3286 #undef inf
3287 }
cdfgam(int * which,double * p,double * q,double * x,double * shape,double * scale,int * status,double * bound)3288 void cdfgam(int *which,double *p,double *q,double *x,double *shape,
3289 double *scale,int *status,double *bound)
3290 /**********************************************************************
3291
3292 void cdfgam(int *which,double *p,double *q,double *x,double *shape,
3293 double *scale,int *status,double *bound)
3294
3295 Cumulative Distribution Function
3296 GAMma Distribution
3297
3298
3299 Function
3300
3301
3302 Calculates any one parameter of the gamma
3303 distribution given values for the others.
3304
3305
3306 Arguments
3307
3308
3309 WHICH --> Integer indicating which of the next four argument
3310 values is to be calculated from the others.
3311 Legal range: 1..4
3312 iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE
3313 iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE
3314 iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE
3315 iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE
3316
3317 P <--> The integral from 0 to X of the gamma density.
3318 Input range: [0,1].
3319
3320 Q <--> 1-P.
3321 Input range: (0, 1].
3322 P + Q = 1.0.
3323
3324 X <--> The upper limit of integration of the gamma density.
3325 Input range: [0, +infinity).
3326 Search range: [0,1E300]
3327
3328 SHAPE <--> The shape parameter of the gamma density.
3329 Input range: (0, +infinity).
3330 Search range: [1E-300,1E300]
3331
3332 SCALE <--> The scale parameter of the gamma density.
3333 Input range: (0, +infinity).
3334 Search range: (1E-300,1E300]
3335
3336 STATUS <-- 0 if calculation completed correctly
3337 -I if input parameter number I is out of range
3338 1 if answer appears to be lower than lowest
3339 search bound
3340 2 if answer appears to be higher than greatest
3341 search bound
3342 3 if P + Q .ne. 1
3343 10 if the gamma or inverse gamma routine cannot
3344 compute the answer. Usually happens only for
3345 X and SHAPE very large (gt 1E10 or more)
3346
3347 BOUND <-- Undefined if STATUS is 0
3348
3349 Bound exceeded by parameter number I if STATUS
3350 is negative.
3351
3352 Lower search bound if STATUS is 1.
3353
3354 Upper search bound if STATUS is 2.
3355
3356
3357 Method
3358
3359
3360 Cumulative distribution function (P) is calculated directly by
3361 the code associated with:
3362
3363 DiDinato, A. R. and Morris, A. H. Computation of the incomplete
3364 gamma function ratios and their inverse. ACM Trans. Math.
3365 Softw. 12 (1986), 377-393.
3366
3367 Computation of other parameters involve a seach for a value that
3368 produces the desired value of P. The search relies on the
3369 monotinicity of P with the other parameter.
3370
3371
3372 Note
3373
3374
3375
3376 The gamma density is proportional to
3377 T**(SHAPE - 1) * EXP(- SCALE * T)
3378
3379 **********************************************************************/
3380 {
3381 #define tol (1.0e-8)
3382 #define atol (1.0e-50)
3383 #define zero (1.0e-300)
3384 #define inf 1.0e300
3385 static int K1 = 1;
3386 static double K5 = 0.5e0;
3387 static double K6 = 5.0e0;
3388 static double xx,fx,xscale,cum,ccum,pq,porq;
3389 static int ierr;
3390 static unsigned long qhi,qleft,qporq;
3391 static double T2,T3,T4,T7,T8,T9;
3392 /*
3393 ..
3394 .. Executable Statements ..
3395 */
3396 /*
3397 Check arguments
3398 */
3399 if(!(*which < 1 || *which > 4)) goto S30;
3400 if(!(*which < 1)) goto S10;
3401 *bound = 1.0e0;
3402 goto S20;
3403 S10:
3404 *bound = 4.0e0;
3405 S20:
3406 *status = -1;
3407 return;
3408 S30:
3409 if(*which == 1) goto S70;
3410 /*
3411 P
3412 */
3413 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3414 if(!(*p < 0.0e0)) goto S40;
3415 *bound = 0.0e0;
3416 goto S50;
3417 S40:
3418 *bound = 1.0e0;
3419 S50:
3420 *status = -2;
3421 return;
3422 S70:
3423 S60:
3424 if(*which == 1) goto S110;
3425 /*
3426 Q
3427 */
3428 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3429 if(!(*q <= 0.0e0)) goto S80;
3430 *bound = 0.0e0;
3431 goto S90;
3432 S80:
3433 *bound = 1.0e0;
3434 S90:
3435 *status = -3;
3436 return;
3437 S110:
3438 S100:
3439 if(*which == 2) goto S130;
3440 /*
3441 X
3442 */
3443 if(!(*x < 0.0e0)) goto S120;
3444 *bound = 0.0e0;
3445 *status = -4;
3446 return;
3447 S130:
3448 S120:
3449 if(*which == 3) goto S150;
3450 /*
3451 SHAPE
3452 */
3453 if(!(*shape <= 0.0e0)) goto S140;
3454 *bound = 0.0e0;
3455 *status = -5;
3456 return;
3457 S150:
3458 S140:
3459 if(*which == 4) goto S170;
3460 /*
3461 SCALE
3462 */
3463 if(!(*scale <= 0.0e0)) goto S160;
3464 *bound = 0.0e0;
3465 *status = -6;
3466 return;
3467 S170:
3468 S160:
3469 if(*which == 1) goto S210;
3470 /*
3471 P + Q
3472 */
3473 pq = *p+*q;
3474 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200;
3475 if(!(pq < 0.0e0)) goto S180;
3476 *bound = 0.0e0;
3477 goto S190;
3478 S180:
3479 *bound = 1.0e0;
3480 S190:
3481 *status = 3;
3482 return;
3483 S210:
3484 S200:
3485 if(*which == 1) goto S240;
3486 /*
3487 Select the minimum of P or Q
3488 */
3489 qporq = *p <= *q;
3490 if(!qporq) goto S220;
3491 porq = *p;
3492 goto S230;
3493 S220:
3494 porq = *q;
3495 S240:
3496 S230:
3497 /*
3498 Calculate ANSWERS
3499 */
3500 if(1 == *which) {
3501 /*
3502 Calculating P
3503 */
3504 *status = 0;
3505 xscale = *x**scale;
3506 cumgam(&xscale,shape,p,q);
3507 if(porq > 1.5e0) *status = 10;
3508 }
3509 else if(2 == *which) {
3510 /*
3511 Computing X
3512 */
3513 T2 = -1.0e0;
3514 gaminv(shape,&xx,&T2,p,q,&ierr);
3515 if(ierr < 0.0e0) {
3516 *status = 10;
3517 return;
3518 }
3519 else {
3520 *x = xx/ *scale;
3521 *status = 0;
3522 }
3523 }
3524 else if(3 == *which) {
3525 /*
3526 Computing SHAPE
3527 */
3528 *shape = 5.0e0;
3529 xscale = *x**scale;
3530 T3 = zero;
3531 T4 = inf;
3532 T7 = atol;
3533 T8 = tol;
3534 dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8);
3535 *status = 0;
3536 dinvr(status,shape,&fx,&qleft,&qhi);
3537 S250:
3538 if(!(*status == 1)) goto S290;
3539 cumgam(&xscale,shape,&cum,&ccum);
3540 if(!qporq) goto S260;
3541 fx = cum-*p;
3542 goto S270;
3543 S260:
3544 fx = ccum-*q;
3545 S270:
3546 if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280;
3547 *status = 10;
3548 return;
3549 S280:
3550 dinvr(status,shape,&fx,&qleft,&qhi);
3551 goto S250;
3552 S290:
3553 if(!(*status == -1)) goto S320;
3554 if(!qleft) goto S300;
3555 *status = 1;
3556 *bound = zero;
3557 goto S310;
3558 S300:
3559 *status = 2;
3560 *bound = inf;
3561 S320:
3562 S310:
3563 ;
3564 }
3565 else if(4 == *which) {
3566 /*
3567 Computing SCALE
3568 */
3569 T9 = -1.0e0;
3570 gaminv(shape,&xx,&T9,p,q,&ierr);
3571 if(ierr < 0.0e0) {
3572 *status = 10;
3573 return;
3574 }
3575 else {
3576 *scale = xx/ *x;
3577 *status = 0;
3578 }
3579 }
3580 return;
3581 #undef tol
3582 #undef atol
3583 #undef zero
3584 #undef inf
3585 }
cdfnbn(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)3586 void cdfnbn(int *which,double *p,double *q,double *s,double *xn,
3587 double *pr,double *ompr,int *status,double *bound)
3588 /**********************************************************************
3589
3590 void cdfnbn(int *which,double *p,double *q,double *s,double *xn,
3591 double *pr,double *ompr,int *status,double *bound)
3592
3593 Cumulative Distribution Function
3594 Negative BiNomial distribution
3595
3596
3597 Function
3598
3599
3600 Calculates any one parameter of the negative binomial
3601 distribution given values for the others.
3602
3603 The cumulative negative binomial distribution returns the
3604 probability that there will be F or fewer failures before the
3605 XNth success in binomial trials each of which has probability of
3606 success PR.
3607
3608 The individual term of the negative binomial is the probability of
3609 S failures before XN successes and is
3610 Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S
3611
3612
3613 Arguments
3614
3615
3616 WHICH --> Integer indicating which of the next four argument
3617 values is to be calculated from the others.
3618 Legal range: 1..4
3619 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
3620 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
3621 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
3622 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
3623
3624 P <--> The cumulation from 0 to S of the negative
3625 binomial distribution.
3626 Input range: [0,1].
3627
3628 Q <--> 1-P.
3629 Input range: (0, 1].
3630 P + Q = 1.0.
3631
3632 S <--> The upper limit of cumulation of the binomial distribution.
3633 There are F or fewer failures before the XNth success.
3634 Input range: [0, +infinity).
3635 Search range: [0, 1E300]
3636
3637 XN <--> The number of successes.
3638 Input range: [0, +infinity).
3639 Search range: [0, 1E300]
3640
3641 PR <--> The probability of success in each binomial trial.
3642 Input range: [0,1].
3643 Search range: [0,1].
3644
3645 OMPR <--> 1-PR
3646 Input range: [0,1].
3647 Search range: [0,1]
3648 PR + OMPR = 1.0
3649
3650 STATUS <-- 0 if calculation completed correctly
3651 -I if input parameter number I is out of range
3652 1 if answer appears to be lower than lowest
3653 search bound
3654 2 if answer appears to be higher than greatest
3655 search bound
3656 3 if P + Q .ne. 1
3657 4 if PR + OMPR .ne. 1
3658
3659 BOUND <-- Undefined if STATUS is 0
3660
3661 Bound exceeded by parameter number I if STATUS
3662 is negative.
3663
3664 Lower search bound if STATUS is 1.
3665
3666 Upper search bound if STATUS is 2.
3667
3668
3669 Method
3670
3671
3672 Formula 26.5.26 of Abramowitz and Stegun, Handbook of
3673 Mathematical Functions (1966) is used to reduce calculation of
3674 the cumulative distribution function to that of an incomplete
3675 beta.
3676
3677 Computation of other parameters involve a seach for a value that
3678 produces the desired value of P. The search relies on the
3679 monotinicity of P with the other parameter.
3680
3681 **********************************************************************/
3682 {
3683 #define tol (1.0e-8)
3684 #define atol (1.0e-50)
3685 #define inf 1.0e300
3686 #define one 1.0e0
3687 static int K1 = 1;
3688 static double K2 = 0.0e0;
3689 static double K4 = 0.5e0;
3690 static double K5 = 5.0e0;
3691 static double K11 = 1.0e0;
3692 static double fx,xhi,xlo,pq,prompr,cum,ccum;
3693 static unsigned long qhi,qleft,qporq;
3694 static double T3,T6,T7,T8,T9,T10,T12,T13;
3695 /*
3696 ..
3697 .. Executable Statements ..
3698 */
3699 /*
3700 Check arguments
3701 */
3702 if(!(*which < 1 || *which > 4)) goto S30;
3703 if(!(*which < 1)) goto S10;
3704 *bound = 1.0e0;
3705 goto S20;
3706 S10:
3707 *bound = 4.0e0;
3708 S20:
3709 *status = -1;
3710 return;
3711 S30:
3712 if(*which == 1) goto S70;
3713 /*
3714 P
3715 */
3716 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3717 if(!(*p < 0.0e0)) goto S40;
3718 *bound = 0.0e0;
3719 goto S50;
3720 S40:
3721 *bound = 1.0e0;
3722 S50:
3723 *status = -2;
3724 return;
3725 S70:
3726 S60:
3727 if(*which == 1) goto S110;
3728 /*
3729 Q
3730 */
3731 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3732 if(!(*q <= 0.0e0)) goto S80;
3733 *bound = 0.0e0;
3734 goto S90;
3735 S80:
3736 *bound = 1.0e0;
3737 S90:
3738 *status = -3;
3739 return;
3740 S110:
3741 S100:
3742 if(*which == 2) goto S130;
3743 /*
3744 S
3745 */
3746 if(!(*s < 0.0e0)) goto S120;
3747 *bound = 0.0e0;
3748 *status = -4;
3749 return;
3750 S130:
3751 S120:
3752 if(*which == 3) goto S150;
3753 /*
3754 XN
3755 */
3756 if(!(*xn < 0.0e0)) goto S140;
3757 *bound = 0.0e0;
3758 *status = -5;
3759 return;
3760 S150:
3761 S140:
3762 if(*which == 4) goto S190;
3763 /*
3764 PR
3765 */
3766 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180;
3767 if(!(*pr < 0.0e0)) goto S160;
3768 *bound = 0.0e0;
3769 goto S170;
3770 S160:
3771 *bound = 1.0e0;
3772 S170:
3773 *status = -6;
3774 return;
3775 S190:
3776 S180:
3777 if(*which == 4) goto S230;
3778 /*
3779 OMPR
3780 */
3781 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220;
3782 if(!(*ompr < 0.0e0)) goto S200;
3783 *bound = 0.0e0;
3784 goto S210;
3785 S200:
3786 *bound = 1.0e0;
3787 S210:
3788 *status = -7;
3789 return;
3790 S230:
3791 S220:
3792 if(*which == 1) goto S270;
3793 /*
3794 P + Q
3795 */
3796 pq = *p+*q;
3797 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260;
3798 if(!(pq < 0.0e0)) goto S240;
3799 *bound = 0.0e0;
3800 goto S250;
3801 S240:
3802 *bound = 1.0e0;
3803 S250:
3804 *status = 3;
3805 return;
3806 S270:
3807 S260:
3808 if(*which == 4) goto S310;
3809 /*
3810 PR + OMPR
3811 */
3812 prompr = *pr+*ompr;
3813 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300;
3814 if(!(prompr < 0.0e0)) goto S280;
3815 *bound = 0.0e0;
3816 goto S290;
3817 S280:
3818 *bound = 1.0e0;
3819 S290:
3820 *status = 4;
3821 return;
3822 S310:
3823 S300:
3824 if(!(*which == 1)) qporq = *p <= *q;
3825 /*
3826 Select the minimum of P or Q
3827 Calculate ANSWERS
3828 */
3829 if(1 == *which) {
3830 /*
3831 Calculating P
3832 */
3833 cumnbn(s,xn,pr,ompr,p,q);
3834 *status = 0;
3835 }
3836 else if(2 == *which) {
3837 /*
3838 Calculating S
3839 */
3840 *s = 5.0e0;
3841 T3 = inf;
3842 T6 = atol;
3843 T7 = tol;
3844 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
3845 *status = 0;
3846 dinvr(status,s,&fx,&qleft,&qhi);
3847 S320:
3848 if(!(*status == 1)) goto S350;
3849 cumnbn(s,xn,pr,ompr,&cum,&ccum);
3850 if(!qporq) goto S330;
3851 fx = cum-*p;
3852 goto S340;
3853 S330:
3854 fx = ccum-*q;
3855 S340:
3856 dinvr(status,s,&fx,&qleft,&qhi);
3857 goto S320;
3858 S350:
3859 if(!(*status == -1)) goto S380;
3860 if(!qleft) goto S360;
3861 *status = 1;
3862 *bound = 0.0e0;
3863 goto S370;
3864 S360:
3865 *status = 2;
3866 *bound = inf;
3867 S380:
3868 S370:
3869 ;
3870 }
3871 else if(3 == *which) {
3872 /*
3873 Calculating XN
3874 */
3875 *xn = 5.0e0;
3876 T8 = inf;
3877 T9 = atol;
3878 T10 = tol;
3879 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
3880 *status = 0;
3881 dinvr(status,xn,&fx,&qleft,&qhi);
3882 S390:
3883 if(!(*status == 1)) goto S420;
3884 cumnbn(s,xn,pr,ompr,&cum,&ccum);
3885 if(!qporq) goto S400;
3886 fx = cum-*p;
3887 goto S410;
3888 S400:
3889 fx = ccum-*q;
3890 S410:
3891 dinvr(status,xn,&fx,&qleft,&qhi);
3892 goto S390;
3893 S420:
3894 if(!(*status == -1)) goto S450;
3895 if(!qleft) goto S430;
3896 *status = 1;
3897 *bound = 0.0e0;
3898 goto S440;
3899 S430:
3900 *status = 2;
3901 *bound = inf;
3902 S450:
3903 S440:
3904 ;
3905 }
3906 else if(4 == *which) {
3907 /*
3908 Calculating PR and OMPR
3909 */
3910 T12 = atol;
3911 T13 = tol;
3912 dstzr(&K2,&K11,&T12,&T13);
3913 if(!qporq) goto S480;
3914 *status = 0;
3915 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
3916 *ompr = one-*pr;
3917 S460:
3918 if(!(*status == 1)) goto S470;
3919 cumnbn(s,xn,pr,ompr,&cum,&ccum);
3920 fx = cum-*p;
3921 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
3922 *ompr = one-*pr;
3923 goto S460;
3924 S470:
3925 goto S510;
3926 S480:
3927 *status = 0;
3928 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
3929 *pr = one-*ompr;
3930 S490:
3931 if(!(*status == 1)) goto S500;
3932 cumnbn(s,xn,pr,ompr,&cum,&ccum);
3933 fx = ccum-*q;
3934 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
3935 *pr = one-*ompr;
3936 goto S490;
3937 S510:
3938 S500:
3939 if(!(*status == -1)) goto S540;
3940 if(!qleft) goto S520;
3941 *status = 1;
3942 *bound = 0.0e0;
3943 goto S530;
3944 S520:
3945 *status = 2;
3946 *bound = 1.0e0;
3947 S530:
3948 ;
3949 }
3950 S540:
3951 return;
3952 #undef tol
3953 #undef atol
3954 #undef inf
3955 #undef one
3956 }
cdfnor(int * which,double * p,double * q,double * x,double * mean,double * sd,int * status,double * bound)3957 void cdfnor(int *which,double *p,double *q,double *x,double *mean,
3958 double *sd,int *status,double *bound)
3959 /**********************************************************************
3960
3961 void cdfnor(int *which,double *p,double *q,double *x,double *mean,
3962 double *sd,int *status,double *bound)
3963
3964 Cumulative Distribution Function
3965 NORmal distribution
3966
3967
3968 Function
3969
3970
3971 Calculates any one parameter of the normal
3972 distribution given values for the others.
3973
3974
3975 Arguments
3976
3977
3978 WHICH --> Integer indicating which of the next parameter
3979 values is to be calculated using values of the others.
3980 Legal range: 1..4
3981 iwhich = 1 : Calculate P and Q from X,MEAN and SD
3982 iwhich = 2 : Calculate X from P,Q,MEAN and SD
3983 iwhich = 3 : Calculate MEAN from P,Q,X and SD
3984 iwhich = 4 : Calculate SD from P,Q,X and MEAN
3985
3986 P <--> The integral from -infinity to X of the normal density.
3987 Input range: (0,1].
3988
3989 Q <--> 1-P.
3990 Input range: (0, 1].
3991 P + Q = 1.0.
3992
3993 X < --> Upper limit of integration of the normal-density.
3994 Input range: ( -infinity, +infinity)
3995
3996 MEAN <--> The mean of the normal density.
3997 Input range: (-infinity, +infinity)
3998
3999 SD <--> Standard Deviation of the normal density.
4000 Input range: (0, +infinity).
4001
4002 STATUS <-- 0 if calculation completed correctly
4003 -I if input parameter number I is out of range
4004 1 if answer appears to be lower than lowest
4005 search bound
4006 2 if answer appears to be higher than greatest
4007 search bound
4008 3 if P + Q .ne. 1
4009
4010 BOUND <-- Undefined if STATUS is 0
4011
4012 Bound exceeded by parameter number I if STATUS
4013 is negative.
4014
4015 Lower search bound if STATUS is 1.
4016
4017 Upper search bound if STATUS is 2.
4018
4019
4020 Method
4021
4022
4023
4024
4025 A slightly modified version of ANORM from
4026
4027 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
4028 Package of Special Function Routines and Test Drivers"
4029 acm Transactions on Mathematical Software. 19, 22-32.
4030
4031 is used to calulate the cumulative standard normal distribution.
4032
4033 The rational functions from pages 90-95 of Kennedy and Gentle,
4034 Statistical Computing, Marcel Dekker, NY, 1980 are used as
4035 starting values to Newton's Iterations which compute the inverse
4036 standard normal. Therefore no searches are necessary for any
4037 parameter.
4038
4039 For X < -15, the asymptotic expansion for the normal is used as
4040 the starting value in finding the inverse standard normal.
4041 This is formula 26.2.12 of Abramowitz and Stegun.
4042
4043
4044 Note
4045
4046
4047 The normal density is proportional to
4048 exp( - 0.5 * (( X - MEAN)/SD)**2)
4049
4050 **********************************************************************/
4051 {
4052 static int K1 = 1;
4053 static double z,pq;
4054 /*
4055 ..
4056 .. Executable Statements ..
4057 */
4058 /*
4059 Check arguments
4060 */
4061 *status = 0;
4062 if(!(*which < 1 || *which > 4)) goto S30;
4063 if(!(*which < 1)) goto S10;
4064 *bound = 1.0e0;
4065 goto S20;
4066 S10:
4067 *bound = 4.0e0;
4068 S20:
4069 *status = -1;
4070 return;
4071 S30:
4072 if(*which == 1) goto S70;
4073 /*
4074 P
4075 */
4076 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4077 if(!(*p <= 0.0e0)) goto S40;
4078 *bound = 0.0e0;
4079 goto S50;
4080 S40:
4081 *bound = 1.0e0;
4082 S50:
4083 *status = -2;
4084 return;
4085 S70:
4086 S60:
4087 if(*which == 1) goto S110;
4088 /*
4089 Q
4090 */
4091 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4092 if(!(*q <= 0.0e0)) goto S80;
4093 *bound = 0.0e0;
4094 goto S90;
4095 S80:
4096 *bound = 1.0e0;
4097 S90:
4098 *status = -3;
4099 return;
4100 S110:
4101 S100:
4102 if(*which == 1) goto S150;
4103 /*
4104 P + Q
4105 */
4106 pq = *p+*q;
4107 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S140;
4108 if(!(pq < 0.0e0)) goto S120;
4109 *bound = 0.0e0;
4110 goto S130;
4111 S120:
4112 *bound = 1.0e0;
4113 S130:
4114 *status = 3;
4115 return;
4116 S150:
4117 S140:
4118 if(*which == 4) goto S170;
4119 /*
4120 SD
4121 */
4122 if(!(*sd <= 0.0e0)) goto S160;
4123 *bound = 0.0e0;
4124 *status = -6;
4125 return;
4126 S170:
4127 S160:
4128 /*
4129 Calculate ANSWERS
4130 */
4131 if(1 == *which) {
4132 /*
4133 Computing P
4134 */
4135 z = (*x-*mean)/ *sd;
4136 cumnor(&z,p,q);
4137 }
4138 else if(2 == *which) {
4139 /*
4140 Computing X
4141 */
4142 z = dinvnr(p,q);
4143 *x = *sd*z+*mean;
4144 }
4145 else if(3 == *which) {
4146 /*
4147 Computing the MEAN
4148 */
4149 z = dinvnr(p,q);
4150 *mean = *x-*sd*z;
4151 }
4152 else if(4 == *which) {
4153 /*
4154 Computing SD
4155 */
4156 z = dinvnr(p,q);
4157 *sd = (*x-*mean)/z;
4158 }
4159 return;
4160 }
cdfpoi(int * which,double * p,double * q,double * s,double * xlam,int * status,double * bound)4161 void cdfpoi(int *which,double *p,double *q,double *s,double *xlam,
4162 int *status,double *bound)
4163 /**********************************************************************
4164
4165 void cdfpoi(int *which,double *p,double *q,double *s,double *xlam,
4166 int *status,double *bound)
4167
4168 Cumulative Distribution Function
4169 POIsson distribution
4170
4171
4172 Function
4173
4174
4175 Calculates any one parameter of the Poisson
4176 distribution given values for the others.
4177
4178
4179 Arguments
4180
4181
4182 WHICH --> Integer indicating which argument
4183 value is to be calculated from the others.
4184 Legal range: 1..3
4185 iwhich = 1 : Calculate P and Q from S and XLAM
4186 iwhich = 2 : Calculate A from P,Q and XLAM
4187 iwhich = 3 : Calculate XLAM from P,Q and S
4188
4189 P <--> The cumulation from 0 to S of the poisson density.
4190 Input range: [0,1].
4191
4192 Q <--> 1-P.
4193 Input range: (0, 1].
4194 P + Q = 1.0.
4195
4196 S <--> Upper limit of cumulation of the Poisson.
4197 Input range: [0, +infinity).
4198 Search range: [0,1E300]
4199
4200 XLAM <--> Mean of the Poisson distribution.
4201 Input range: [0, +infinity).
4202 Search range: [0,1E300]
4203
4204 STATUS <-- 0 if calculation completed correctly
4205 -I if input parameter number I is out of range
4206 1 if answer appears to be lower than lowest
4207 search bound
4208 2 if answer appears to be higher than greatest
4209 search bound
4210 3 if P + Q .ne. 1
4211
4212 BOUND <-- Undefined if STATUS is 0
4213
4214 Bound exceeded by parameter number I if STATUS
4215 is negative.
4216
4217 Lower search bound if STATUS is 1.
4218
4219 Upper search bound if STATUS is 2.
4220
4221
4222 Method
4223
4224
4225 Formula 26.4.21 of Abramowitz and Stegun, Handbook of
4226 Mathematical Functions (1966) is used to reduce the computation
4227 of the cumulative distribution function to that of computing a
4228 chi-square, hence an incomplete gamma function.
4229
4230 Cumulative distribution function (P) is calculated directly.
4231 Computation of other parameters involve a seach for a value that
4232 produces the desired value of P. The search relies on the
4233 monotinicity of P with the other parameter.
4234
4235 **********************************************************************/
4236 {
4237 #define tol (1.0e-8)
4238 #define atol (1.0e-50)
4239 #define inf 1.0e300
4240 static int K1 = 1;
4241 static double K2 = 0.0e0;
4242 static double K4 = 0.5e0;
4243 static double K5 = 5.0e0;
4244 static double fx,cum,ccum,pq;
4245 static unsigned long qhi,qleft,qporq;
4246 static double T3,T6,T7,T8,T9,T10;
4247 /*
4248 ..
4249 .. Executable Statements ..
4250 */
4251 /*
4252 Check arguments
4253 */
4254 if(!(*which < 1 || *which > 3)) goto S30;
4255 if(!(*which < 1)) goto S10;
4256 *bound = 1.0e0;
4257 goto S20;
4258 S10:
4259 *bound = 3.0e0;
4260 S20:
4261 *status = -1;
4262 return;
4263 S30:
4264 if(*which == 1) goto S70;
4265 /*
4266 P
4267 */
4268 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4269 if(!(*p < 0.0e0)) goto S40;
4270 *bound = 0.0e0;
4271 goto S50;
4272 S40:
4273 *bound = 1.0e0;
4274 S50:
4275 *status = -2;
4276 return;
4277 S70:
4278 S60:
4279 if(*which == 1) goto S110;
4280 /*
4281 Q
4282 */
4283 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4284 if(!(*q <= 0.0e0)) goto S80;
4285 *bound = 0.0e0;
4286 goto S90;
4287 S80:
4288 *bound = 1.0e0;
4289 S90:
4290 *status = -3;
4291 return;
4292 S110:
4293 S100:
4294 if(*which == 2) goto S130;
4295 /*
4296 S
4297 */
4298 if(!(*s < 0.0e0)) goto S120;
4299 *bound = 0.0e0;
4300 *status = -4;
4301 return;
4302 S130:
4303 S120:
4304 if(*which == 3) goto S150;
4305 /*
4306 XLAM
4307 */
4308 if(!(*xlam < 0.0e0)) goto S140;
4309 *bound = 0.0e0;
4310 *status = -5;
4311 return;
4312 S150:
4313 S140:
4314 if(*which == 1) goto S190;
4315 /*
4316 P + Q
4317 */
4318 pq = *p+*q;
4319 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180;
4320 if(!(pq < 0.0e0)) goto S160;
4321 *bound = 0.0e0;
4322 goto S170;
4323 S160:
4324 *bound = 1.0e0;
4325 S170:
4326 *status = 3;
4327 return;
4328 S190:
4329 S180:
4330 if(!(*which == 1)) qporq = *p <= *q;
4331 /*
4332 Select the minimum of P or Q
4333 Calculate ANSWERS
4334 */
4335 if(1 == *which) {
4336 /*
4337 Calculating P
4338 */
4339 cumpoi(s,xlam,p,q);
4340 *status = 0;
4341 }
4342 else if(2 == *which) {
4343 /*
4344 Calculating S
4345 */
4346 *s = 5.0e0;
4347 T3 = inf;
4348 T6 = atol;
4349 T7 = tol;
4350 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4351 *status = 0;
4352 dinvr(status,s,&fx,&qleft,&qhi);
4353 S200:
4354 if(!(*status == 1)) goto S230;
4355 cumpoi(s,xlam,&cum,&ccum);
4356 if(!qporq) goto S210;
4357 fx = cum-*p;
4358 goto S220;
4359 S210:
4360 fx = ccum-*q;
4361 S220:
4362 dinvr(status,s,&fx,&qleft,&qhi);
4363 goto S200;
4364 S230:
4365 if(!(*status == -1)) goto S260;
4366 if(!qleft) goto S240;
4367 *status = 1;
4368 *bound = 0.0e0;
4369 goto S250;
4370 S240:
4371 *status = 2;
4372 *bound = inf;
4373 S260:
4374 S250:
4375 ;
4376 }
4377 else if(3 == *which) {
4378 /*
4379 Calculating XLAM
4380 */
4381 *xlam = 5.0e0;
4382 T8 = inf;
4383 T9 = atol;
4384 T10 = tol;
4385 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4386 *status = 0;
4387 dinvr(status,xlam,&fx,&qleft,&qhi);
4388 S270:
4389 if(!(*status == 1)) goto S300;
4390 cumpoi(s,xlam,&cum,&ccum);
4391 if(!qporq) goto S280;
4392 fx = cum-*p;
4393 goto S290;
4394 S280:
4395 fx = ccum-*q;
4396 S290:
4397 dinvr(status,xlam,&fx,&qleft,&qhi);
4398 goto S270;
4399 S300:
4400 if(!(*status == -1)) goto S330;
4401 if(!qleft) goto S310;
4402 *status = 1;
4403 *bound = 0.0e0;
4404 goto S320;
4405 S310:
4406 *status = 2;
4407 *bound = inf;
4408 S320:
4409 ;
4410 }
4411 S330:
4412 return;
4413 #undef tol
4414 #undef atol
4415 #undef inf
4416 }
cdft(int * which,double * p,double * q,double * t,double * df,int * status,double * bound)4417 void cdft(int *which,double *p,double *q,double *t,double *df,
4418 int *status,double *bound)
4419 /**********************************************************************
4420
4421 void cdft(int *which,double *p,double *q,double *t,double *df,
4422 int *status,double *bound)
4423
4424 Cumulative Distribution Function
4425 T distribution
4426
4427
4428 Function
4429
4430
4431 Calculates any one parameter of the t distribution given
4432 values for the others.
4433
4434
4435 Arguments
4436
4437
4438 WHICH --> Integer indicating which argument
4439 values is to be calculated from the others.
4440 Legal range: 1..3
4441 iwhich = 1 : Calculate P and Q from T and DF
4442 iwhich = 2 : Calculate T from P,Q and DF
4443 iwhich = 3 : Calculate DF from P,Q and T
4444
4445 P <--> The integral from -infinity to t of the t-density.
4446 Input range: (0,1].
4447
4448 Q <--> 1-P.
4449 Input range: (0, 1].
4450 P + Q = 1.0.
4451
4452 T <--> Upper limit of integration of the t-density.
4453 Input range: ( -infinity, +infinity).
4454 Search range: [ -1E300, 1E300 ]
4455
4456 DF <--> Degrees of freedom of the t-distribution.
4457 Input range: (0 , +infinity).
4458 Search range: [1e-300, 1E10]
4459
4460 STATUS <-- 0 if calculation completed correctly
4461 -I if input parameter number I is out of range
4462 1 if answer appears to be lower than lowest
4463 search bound
4464 2 if answer appears to be higher than greatest
4465 search bound
4466 3 if P + Q .ne. 1
4467
4468 BOUND <-- Undefined if STATUS is 0
4469
4470 Bound exceeded by parameter number I if STATUS
4471 is negative.
4472
4473 Lower search bound if STATUS is 1.
4474
4475 Upper search bound if STATUS is 2.
4476
4477
4478 Method
4479
4480
4481 Formula 26.5.27 of Abramowitz and Stegun, Handbook of
4482 Mathematical Functions (1966) is used to reduce the computation
4483 of the cumulative distribution function to that of an incomplete
4484 beta.
4485
4486 Computation of other parameters involve a seach for a value that
4487 produces the desired value of P. The search relies on the
4488 monotinicity of P with the other parameter.
4489
4490 **********************************************************************/
4491 {
4492 #define tol (1.0e-8)
4493 #define atol (1.0e-50)
4494 #define zero (1.0e-300)
4495 #define inf 1.0e300
4496 #define maxdf 1.0e10
4497 static int K1 = 1;
4498 static double K4 = 0.5e0;
4499 static double K5 = 5.0e0;
4500 static double fx,cum,ccum,pq;
4501 static unsigned long qhi,qleft,qporq;
4502 static double T2,T3,T6,T7,T8,T9,T10,T11;
4503 /*
4504 ..
4505 .. Executable Statements ..
4506 */
4507 /*
4508 Check arguments
4509 */
4510 if(!(*which < 1 || *which > 3)) goto S30;
4511 if(!(*which < 1)) goto S10;
4512 *bound = 1.0e0;
4513 goto S20;
4514 S10:
4515 *bound = 3.0e0;
4516 S20:
4517 *status = -1;
4518 return;
4519 S30:
4520 if(*which == 1) goto S70;
4521 /*
4522 P
4523 */
4524 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4525 if(!(*p <= 0.0e0)) goto S40;
4526 *bound = 0.0e0;
4527 goto S50;
4528 S40:
4529 *bound = 1.0e0;
4530 S50:
4531 *status = -2;
4532 return;
4533 S70:
4534 S60:
4535 if(*which == 1) goto S110;
4536 /*
4537 Q
4538 */
4539 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4540 if(!(*q <= 0.0e0)) goto S80;
4541 *bound = 0.0e0;
4542 goto S90;
4543 S80:
4544 *bound = 1.0e0;
4545 S90:
4546 *status = -3;
4547 return;
4548 S110:
4549 S100:
4550 if(*which == 3) goto S130;
4551 /*
4552 DF
4553 */
4554 if(!(*df <= 0.0e0)) goto S120;
4555 *bound = 0.0e0;
4556 *status = -5;
4557 return;
4558 S130:
4559 S120:
4560 if(*which == 1) goto S170;
4561 /*
4562 P + Q
4563 */
4564 pq = *p+*q;
4565 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S160;
4566 if(!(pq < 0.0e0)) goto S140;
4567 *bound = 0.0e0;
4568 goto S150;
4569 S140:
4570 *bound = 1.0e0;
4571 S150:
4572 *status = 3;
4573 return;
4574 S170:
4575 S160:
4576 if(!(*which == 1)) qporq = *p <= *q;
4577 /*
4578 Select the minimum of P or Q
4579 Calculate ANSWERS
4580 */
4581 if(1 == *which) {
4582 /*
4583 Computing P and Q
4584 */
4585 cumt(t,df,p,q);
4586 *status = 0;
4587 }
4588 else if(2 == *which) {
4589 /*
4590 Computing T
4591 .. Get initial approximation for T
4592 */
4593 *t = dt1(p,q,df);
4594 T2 = -inf;
4595 T3 = inf;
4596 T6 = atol;
4597 T7 = tol;
4598 dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7);
4599 *status = 0;
4600 dinvr(status,t,&fx,&qleft,&qhi);
4601 S180:
4602 if(!(*status == 1)) goto S210;
4603 cumt(t,df,&cum,&ccum);
4604 if(!qporq) goto S190;
4605 fx = cum-*p;
4606 goto S200;
4607 S190:
4608 fx = ccum-*q;
4609 S200:
4610 dinvr(status,t,&fx,&qleft,&qhi);
4611 goto S180;
4612 S210:
4613 if(!(*status == -1)) goto S240;
4614 if(!qleft) goto S220;
4615 *status = 1;
4616 *bound = -inf;
4617 goto S230;
4618 S220:
4619 *status = 2;
4620 *bound = inf;
4621 S240:
4622 S230:
4623 ;
4624 }
4625 else if(3 == *which) {
4626 /*
4627 Computing DF
4628 */
4629 *df = 5.0e0;
4630 T8 = zero;
4631 T9 = maxdf;
4632 T10 = atol;
4633 T11 = tol;
4634 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
4635 *status = 0;
4636 dinvr(status,df,&fx,&qleft,&qhi);
4637 S250:
4638 if(!(*status == 1)) goto S280;
4639 cumt(t,df,&cum,&ccum);
4640 if(!qporq) goto S260;
4641 fx = cum-*p;
4642 goto S270;
4643 S260:
4644 fx = ccum-*q;
4645 S270:
4646 dinvr(status,df,&fx,&qleft,&qhi);
4647 goto S250;
4648 S280:
4649 if(!(*status == -1)) goto S310;
4650 if(!qleft) goto S290;
4651 *status = 1;
4652 *bound = zero;
4653 goto S300;
4654 S290:
4655 *status = 2;
4656 *bound = maxdf;
4657 S300:
4658 ;
4659 }
4660 S310:
4661 return;
4662 #undef tol
4663 #undef atol
4664 #undef zero
4665 #undef inf
4666 #undef maxdf
4667 }
cumbet(double * x,double * y,double * a,double * b,double * cum,double * ccum)4668 void cumbet(double *x,double *y,double *a,double *b,double *cum,
4669 double *ccum)
4670 /*
4671 **********************************************************************
4672
4673 void cumbet(double *x,double *y,double *a,double *b,double *cum,
4674 double *ccum)
4675
4676 Double precision cUMulative incomplete BETa distribution
4677
4678
4679 Function
4680
4681
4682 Calculates the cdf to X of the incomplete beta distribution
4683 with parameters a and b. This is the integral from 0 to x
4684 of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
4685
4686
4687 Arguments
4688
4689
4690 X --> Upper limit of integration.
4691 X is DOUBLE PRECISION
4692
4693 Y --> 1 - X.
4694 Y is DOUBLE PRECISION
4695
4696 A --> First parameter of the beta distribution.
4697 A is DOUBLE PRECISION
4698
4699 B --> Second parameter of the beta distribution.
4700 B is DOUBLE PRECISION
4701
4702 CUM <-- Cumulative incomplete beta distribution.
4703 CUM is DOUBLE PRECISION
4704
4705 CCUM <-- Compliment of Cumulative incomplete beta distribution.
4706 CCUM is DOUBLE PRECISION
4707
4708
4709 Method
4710
4711
4712 Calls the routine BRATIO.
4713
4714 References
4715
4716 Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim
4717 708 Significant Digit Computation of the Incomplete Beta Function
4718 Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373.
4719
4720 **********************************************************************
4721 */
4722 {
4723 static int ierr;
4724 /*
4725 ..
4726 .. Executable Statements ..
4727 */
4728 if(!(*x <= 0.0e0)) goto S10;
4729 *cum = 0.0e0;
4730 *ccum = 1.0e0;
4731 return;
4732 S10:
4733 if(!(*y <= 0.0e0)) goto S20;
4734 *cum = 1.0e0;
4735 *ccum = 0.0e0;
4736 return;
4737 S20:
4738 bratio(a,b,x,y,cum,ccum,&ierr);
4739 /*
4740 Call bratio routine
4741 */
4742 return;
4743 }
cumbin(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)4744 void cumbin(double *s,double *xn,double *pr,double *ompr,
4745 double *cum,double *ccum)
4746 /*
4747 **********************************************************************
4748
4749 void cumbin(double *s,double *xn,double *pr,double *ompr,
4750 double *cum,double *ccum)
4751
4752 CUmulative BINomial distribution
4753
4754
4755 Function
4756
4757
4758 Returns the probability of 0 to S successes in XN binomial
4759 trials, each of which has a probability of success, PBIN.
4760
4761
4762 Arguments
4763
4764
4765 S --> The upper limit of cumulation of the binomial distribution.
4766 S is DOUBLE PRECISION
4767
4768 XN --> The number of binomial trials.
4769 XN is DOUBLE PRECISIO
4770
4771 PBIN --> The probability of success in each binomial trial.
4772 PBIN is DOUBLE PRECIS
4773
4774 OMPR --> 1 - PBIN
4775 OMPR is DOUBLE PRECIS
4776
4777 CUM <-- Cumulative binomial distribution.
4778 CUM is DOUBLE PRECISI
4779
4780 CCUM <-- Compliment of Cumulative binomial distribution.
4781 CCUM is DOUBLE PRECIS
4782
4783
4784 Method
4785
4786
4787 Formula 26.5.24 of Abramowitz and Stegun, Handbook of
4788 Mathematical Functions (1966) is used to reduce the binomial
4789 distribution to the cumulative beta distribution.
4790
4791 **********************************************************************
4792 */
4793 {
4794 static double T1,T2;
4795 /*
4796 ..
4797 .. Executable Statements ..
4798 */
4799 if(!(*s < *xn)) goto S10;
4800 T1 = *s+1.0e0;
4801 T2 = *xn-*s;
4802 cumbet(pr,ompr,&T1,&T2,ccum,cum);
4803 goto S20;
4804 S10:
4805 *cum = 1.0e0;
4806 *ccum = 0.0e0;
4807 S20:
4808 return;
4809 }
cumchi(double * x,double * df,double * cum,double * ccum)4810 void cumchi(double *x,double *df,double *cum,double *ccum)
4811 /*
4812 **********************************************************************
4813
4814 void cumchi(double *x,double *df,double *cum,double *ccum)
4815 CUMulative of the CHi-square distribution
4816
4817
4818 Function
4819
4820
4821 Calculates the cumulative chi-square distribution.
4822
4823
4824 Arguments
4825
4826
4827 X --> Upper limit of integration of the
4828 chi-square distribution.
4829 X is DOUBLE PRECISION
4830
4831 DF --> Degrees of freedom of the
4832 chi-square distribution.
4833 DF is DOUBLE PRECISION
4834
4835 CUM <-- Cumulative chi-square distribution.
4836 CUM is DOUBLE PRECISIO
4837
4838 CCUM <-- Compliment of Cumulative chi-square distribution.
4839 CCUM is DOUBLE PRECISI
4840
4841
4842 Method
4843
4844
4845 Calls incomplete gamma function (CUMGAM)
4846
4847 **********************************************************************
4848 */
4849 {
4850 static double a,xx;
4851 /*
4852 ..
4853 .. Executable Statements ..
4854 */
4855 a = *df*0.5e0;
4856 xx = *x*0.5e0;
4857 cumgam(&xx,&a,cum,ccum);
4858 return;
4859 }
cumchn(double * x,double * df,double * pnonc,double * cum,double * ccum)4860 void cumchn(double *x,double *df,double *pnonc,double *cum,
4861 double *ccum)
4862 /*
4863 **********************************************************************
4864
4865 void cumchn(double *x,double *df,double *pnonc,double *cum,
4866 double *ccum)
4867
4868 CUMulative of the Non-central CHi-square distribution
4869
4870
4871 Function
4872
4873
4874 Calculates the cumulative non-central chi-square
4875 distribution, i.e., the probability that a random variable
4876 which follows the non-central chi-square distribution, with
4877 non-centrality parameter PNONC and continuous degrees of
4878 freedom DF, is less than or equal to X.
4879
4880
4881 Arguments
4882
4883
4884 X --> Upper limit of integration of the non-central
4885 chi-square distribution.
4886 X is DOUBLE PRECISION
4887
4888 DF --> Degrees of freedom of the non-central
4889 chi-square distribution.
4890 DF is DOUBLE PRECISION
4891
4892 PNONC --> Non-centrality parameter of the non-central
4893 chi-square distribution.
4894 PNONC is DOUBLE PRECIS
4895
4896 CUM <-- Cumulative non-central chi-square distribution.
4897 CUM is DOUBLE PRECISIO
4898
4899 CCUM <-- Compliment of Cumulative non-central chi-square distribut
4900 CCUM is DOUBLE PRECISI
4901
4902
4903 Method
4904
4905
4906 Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of
4907 Mathematical Functions, US NBS (1966) to calculate the
4908 non-central chi-square.
4909
4910
4911 Variables
4912
4913
4914 EPS --- Convergence criterion. The sum stops when a
4915 term is less than EPS*SUM.
4916 EPS is DOUBLE PRECISIO
4917
4918 NTIRED --- Maximum number of terms to be evaluated
4919 in each sum.
4920 NTIRED is INTEGER
4921
4922 QCONV --- .TRUE. if convergence achieved -
4923 i.e., program did not stop on NTIRED criterion.
4924 QCONV is LOGICAL
4925
4926 CCUM <-- Compliment of Cumulative non-central
4927 chi-square distribution.
4928 CCUM is DOUBLE PRECISI
4929
4930 **********************************************************************
4931 */
4932 {
4933 #define dg(i) (*df+2.0e0*(double)(i))
4934 #define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum)
4935 #define qtired(i) (int)((i) > ntired)
4936 static double eps = 1.0e-5;
4937 static int ntired = 1000;
4938 static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum,
4939 sumadj,term,wt,xnonc;
4940 static int i,icent,iterb,iterf;
4941 static double T1,T2,T3;
4942 /*
4943 ..
4944 .. Executable Statements ..
4945 */
4946 if(!(*x <= 0.0e0)) goto S10;
4947 *cum = 0.0e0;
4948 *ccum = 1.0e0;
4949 return;
4950 S10:
4951 if(!(*pnonc <= 1.0e-10)) goto S20;
4952 /*
4953 When non-centrality parameter is (essentially) zero,
4954 use cumulative chi-square distribution
4955 */
4956 cumchi(x,df,cum,ccum);
4957 return;
4958 S20:
4959 xnonc = *pnonc/2.0e0;
4960 /*
4961 **********************************************************************
4962 The following code calcualtes the weight, chi-square, and
4963 adjustment term for the central term in the infinite series.
4964 The central term is the one in which the poisson weight is
4965 greatest. The adjustment term is the amount that must
4966 be subtracted from the chi-square to move up two degrees
4967 of freedom.
4968 **********************************************************************
4969 */
4970 icent = fifidint(xnonc);
4971 if(icent == 0) icent = 1;
4972 chid2 = *x/2.0e0;
4973 /*
4974 Calculate central weight term
4975 */
4976 T1 = (double)(icent+1);
4977 lfact = alngam(&T1);
4978 lcntwt = -xnonc+(double)icent*log(xnonc)-lfact;
4979 centwt = exp(lcntwt);
4980 /*
4981 Calculate central chi-square
4982 */
4983 T2 = dg(icent);
4984 cumchi(x,&T2,&pcent,ccum);
4985 /*
4986 Calculate central adjustment term
4987 */
4988 dfd2 = dg(icent)/2.0e0;
4989 T3 = 1.0e0+dfd2;
4990 lfact = alngam(&T3);
4991 lcntaj = dfd2*log(chid2)-chid2-lfact;
4992 centaj = exp(lcntaj);
4993 sum = centwt*pcent;
4994 /*
4995 **********************************************************************
4996 Sum backwards from the central term towards zero.
4997 Quit whenever either
4998 (1) the zero term is reached, or
4999 (2) the term gets small relative to the sum, or
5000 (3) More than NTIRED terms are totaled.
5001 **********************************************************************
5002 */
5003 iterb = 0;
5004 sumadj = 0.0e0;
5005 adj = centaj;
5006 wt = centwt;
5007 i = icent;
5008 goto S40;
5009 S30:
5010 if(qtired(iterb) || qsmall(term) || i == 0) goto S50;
5011 S40:
5012 dfd2 = dg(i)/2.0e0;
5013 /*
5014 Adjust chi-square for two fewer degrees of freedom.
5015 The adjusted value ends up in PTERM.
5016 */
5017 adj = adj*dfd2/chid2;
5018 sumadj += adj;
5019 pterm = pcent+sumadj;
5020 /*
5021 Adjust poisson weight for J decreased by one
5022 */
5023 wt *= ((double)i/xnonc);
5024 term = wt*pterm;
5025 sum += term;
5026 i -= 1;
5027 iterb += 1;
5028 goto S30;
5029 S50:
5030 iterf = 0;
5031 /*
5032 **********************************************************************
5033 Now sum forward from the central term towards infinity.
5034 Quit when either
5035 (1) the term gets small relative to the sum, or
5036 (2) More than NTIRED terms are totaled.
5037 **********************************************************************
5038 */
5039 sumadj = adj = centaj;
5040 wt = centwt;
5041 i = icent;
5042 goto S70;
5043 S60:
5044 if(qtired(iterf) || qsmall(term)) goto S80;
5045 S70:
5046 /*
5047 Update weights for next higher J
5048 */
5049 wt *= (xnonc/(double)(i+1));
5050 /*
5051 Calculate PTERM and add term to sum
5052 */
5053 pterm = pcent-sumadj;
5054 term = wt*pterm;
5055 sum += term;
5056 /*
5057 Update adjustment term for DF for next iteration
5058 */
5059 i += 1;
5060 dfd2 = dg(i)/2.0e0;
5061 adj = adj*chid2/dfd2;
5062 sumadj += adj;
5063 iterf += 1;
5064 goto S60;
5065 S80:
5066 *cum = sum;
5067 *ccum = 0.5e0+(0.5e0-*cum);
5068 return;
5069 #undef dg
5070 #undef qsmall
5071 #undef qtired
5072 }
cumf(double * f,double * dfn,double * dfd,double * cum,double * ccum)5073 void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum)
5074 /*
5075 **********************************************************************
5076
5077 void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum)
5078 CUMulative F distribution
5079
5080
5081 Function
5082
5083
5084 Computes the integral from 0 to F of the f-density with DFN
5085 and DFD degrees of freedom.
5086
5087
5088 Arguments
5089
5090
5091 F --> Upper limit of integration of the f-density.
5092 F is DOUBLE PRECISION
5093
5094 DFN --> Degrees of freedom of the numerator sum of squares.
5095 DFN is DOUBLE PRECISI
5096
5097 DFD --> Degrees of freedom of the denominator sum of squares.
5098 DFD is DOUBLE PRECISI
5099
5100 CUM <-- Cumulative f distribution.
5101 CUM is DOUBLE PRECISI
5102
5103 CCUM <-- Compliment of Cumulative f distribution.
5104 CCUM is DOUBLE PRECIS
5105
5106
5107 Method
5108
5109
5110 Formula 26.5.28 of Abramowitz and Stegun is used to reduce
5111 the cumulative F to a cumulative beta distribution.
5112
5113
5114 Note
5115
5116
5117 If F is less than or equal to 0, 0 is returned.
5118
5119 **********************************************************************
5120 */
5121 {
5122 #define half 0.5e0
5123 #define done 1.0e0
5124 static double dsum,prod,xx,yy;
5125 static int ierr;
5126 static double T1,T2;
5127 /*
5128 ..
5129 .. Executable Statements ..
5130 */
5131 if(!(*f <= 0.0e0)) goto S10;
5132 *cum = 0.0e0;
5133 *ccum = 1.0e0;
5134 return;
5135 S10:
5136 prod = *dfn**f;
5137 /*
5138 XX is such that the incomplete beta with parameters
5139 DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
5140 YY is 1 - XX
5141 Calculate the smaller of XX and YY accurately
5142 */
5143 dsum = *dfd+prod;
5144 xx = *dfd/dsum;
5145 if(xx > half) {
5146 yy = prod/dsum;
5147 xx = done-yy;
5148 }
5149 else yy = done-xx;
5150 T1 = *dfd*half;
5151 T2 = *dfn*half;
5152 bratio(&T1,&T2,&xx,&yy,ccum,cum,&ierr);
5153 return;
5154 #undef half
5155 #undef done
5156 }
cumfnc(double * f,double * dfn,double * dfd,double * pnonc,double * cum,double * ccum)5157 void cumfnc(double *f,double *dfn,double *dfd,double *pnonc,
5158 double *cum,double *ccum)
5159 /*
5160 **********************************************************************
5161
5162 F -NON- -C-ENTRAL F DISTRIBUTION
5163
5164
5165
5166 Function
5167
5168
5169 COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD
5170 DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC
5171
5172
5173 Arguments
5174
5175
5176 X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION
5177
5178 DFN --> DEGREES OF FREEDOM OF NUMERATOR
5179
5180 DFD --> DEGREES OF FREEDOM OF DENOMINATOR
5181
5182 PNONC --> NONCENTRALITY PARAMETER.
5183
5184 CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION
5185
5186 CCUM <-- COMPLIMENT OF CUMMULATIVE
5187
5188
5189 Method
5190
5191
5192 USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES.
5193 SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2
5194 (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL
5195 THE CONVERGENCE CRITERION IS MET.
5196
5197 FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED
5198 BY FORMULA 26.5.16.
5199
5200
5201 REFERENCE
5202
5203
5204 HANDBOOD OF MATHEMATICAL FUNCTIONS
5205 EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN
5206 NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55
5207 MARCH 1965
5208 P 947, EQUATIONS 26.6.17, 26.6.18
5209
5210
5211 Note
5212
5213
5214 THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS
5215 TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS
5216 SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED.
5217
5218 **********************************************************************
5219 */
5220 {
5221 #define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)
5222 #define half 0.5e0
5223 #define done 1.0e0
5224 static double eps = 1.0e-4;
5225 static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,
5226 upterm,xmult,xnonc;
5227 static int i,icent,ierr;
5228 static double T1,T2,T3,T4,T5,T6;
5229 /*
5230 ..
5231 .. Executable Statements ..
5232 */
5233 if(!(*f <= 0.0e0)) goto S10;
5234 *cum = 0.0e0;
5235 *ccum = 1.0e0;
5236 return;
5237 S10:
5238 if(!(*pnonc < 1.0e-10)) goto S20;
5239 /*
5240 Handle case in which the non-centrality parameter is
5241 (essentially) zero.
5242 */
5243 cumf(f,dfn,dfd,cum,ccum);
5244 return;
5245 S20:
5246 xnonc = *pnonc/2.0e0;
5247 /*
5248 Calculate the central term of the poisson weighting factor.
5249 */
5250 icent = (int)xnonc;
5251 if(icent == 0) icent = 1;
5252 /*
5253 Compute central weight term
5254 */
5255 T1 = (double)(icent+1);
5256 centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1));
5257 /*
5258 Compute central incomplete beta term
5259 Assure that minimum of arg to beta and 1 - arg is computed
5260 accurately.
5261 */
5262 prod = *dfn**f;
5263 dsum = *dfd+prod;
5264 yy = *dfd/dsum;
5265 if(yy > half) {
5266 xx = prod/dsum;
5267 yy = done-xx;
5268 }
5269 else xx = done-yy;
5270 T2 = *dfn*half+(double)icent;
5271 T3 = *dfd*half;
5272 bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr);
5273 adn = *dfn/2.0e0+(double)icent;
5274 aup = adn;
5275 b = *dfd/2.0e0;
5276 betup = betdn;
5277 sum = centwt*betdn;
5278 /*
5279 Now sum terms backward from icent until convergence or all done
5280 */
5281 xmult = centwt;
5282 i = icent;
5283 T4 = adn+b;
5284 T5 = adn+1.0e0;
5285 dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy));
5286 S30:
5287 if(qsmall(xmult*betdn) || i <= 0) goto S40;
5288 xmult *= ((double)i/xnonc);
5289 i -= 1;
5290 adn -= 1.0;
5291 dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;
5292 betdn += dnterm;
5293 sum += (xmult*betdn);
5294 goto S30;
5295 S40:
5296 i = icent+1;
5297 /*
5298 Now sum forwards until convergence
5299 */
5300 xmult = centwt;
5301 if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+
5302 b*log(yy));
5303 else {
5304 T6 = aup-1.0+b;
5305 upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b*
5306 log(yy));
5307 }
5308 goto S60;
5309 S50:
5310 if(qsmall(xmult*betup)) goto S70;
5311 S60:
5312 xmult *= (xnonc/(double)i);
5313 i += 1;
5314 aup += 1.0;
5315 upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;
5316 betup -= upterm;
5317 sum += (xmult*betup);
5318 goto S50;
5319 S70:
5320 *cum = sum;
5321 *ccum = 0.5e0+(0.5e0-*cum);
5322 return;
5323 #undef qsmall
5324 #undef half
5325 #undef done
5326 }
cumgam(double * x,double * a,double * cum,double * ccum)5327 void cumgam(double *x,double *a,double *cum,double *ccum)
5328 /*
5329 **********************************************************************
5330
5331 void cumgam(double *x,double *a,double *cum,double *ccum)
5332 Double precision cUMulative incomplete GAMma distribution
5333
5334
5335 Function
5336
5337
5338 Computes the cumulative of the incomplete gamma
5339 distribution, i.e., the integral from 0 to X of
5340 (1/GAM(A))*EXP(-T)*T**(A-1) DT
5341 where GAM(A) is the complete gamma function of A, i.e.,
5342 GAM(A) = integral from 0 to infinity of
5343 EXP(-T)*T**(A-1) DT
5344
5345
5346 Arguments
5347
5348
5349 X --> The upper limit of integration of the incomplete gamma.
5350 X is DOUBLE PRECISION
5351
5352 A --> The shape parameter of the incomplete gamma.
5353 A is DOUBLE PRECISION
5354
5355 CUM <-- Cumulative incomplete gamma distribution.
5356 CUM is DOUBLE PRECISION
5357
5358 CCUM <-- Compliment of Cumulative incomplete gamma distribution.
5359 CCUM is DOUBLE PRECISIO
5360
5361
5362 Method
5363
5364
5365 Calls the routine GRATIO.
5366
5367 **********************************************************************
5368 */
5369 {
5370 static int K1 = 0;
5371 /*
5372 ..
5373 .. Executable Statements ..
5374 */
5375 if(!(*x <= 0.0e0)) goto S10;
5376 *cum = 0.0e0;
5377 *ccum = 1.0e0;
5378 return;
5379 S10:
5380 gratio(a,x,cum,ccum,&K1);
5381 /*
5382 Call gratio routine
5383 */
5384 return;
5385 }
cumnbn(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5386 void cumnbn(double *s,double *xn,double *pr,double *ompr,
5387 double *cum,double *ccum)
5388 /*
5389 **********************************************************************
5390
5391 void cumnbn(double *s,double *xn,double *pr,double *ompr,
5392 double *cum,double *ccum)
5393
5394 CUmulative Negative BINomial distribution
5395
5396
5397 Function
5398
5399
5400 Returns the probability that it there will be S or fewer failures
5401 before there are XN successes, with each binomial trial having
5402 a probability of success PR.
5403
5404 Prob(# failures = S | XN successes, PR) =
5405 ( XN + S - 1 )
5406 ( ) * PR^XN * (1-PR)^S
5407 ( S )
5408
5409
5410 Arguments
5411
5412
5413 S --> The number of failures
5414 S is DOUBLE PRECISION
5415
5416 XN --> The number of successes
5417 XN is DOUBLE PRECISIO
5418
5419 PR --> The probability of success in each binomial trial.
5420 PR is DOUBLE PRECISIO
5421
5422 OMPR --> 1 - PR
5423 OMPR is DOUBLE PRECIS
5424
5425 CUM <-- Cumulative negative binomial distribution.
5426 CUM is DOUBLE PRECISI
5427
5428 CCUM <-- Compliment of Cumulative negative binomial distribution.
5429 CCUM is DOUBLE PRECIS
5430
5431
5432 Method
5433
5434
5435 Formula 26.5.26 of Abramowitz and Stegun, Handbook of
5436 Mathematical Functions (1966) is used to reduce the negative
5437 binomial distribution to the cumulative beta distribution.
5438
5439 **********************************************************************
5440 */
5441 {
5442 static double T1;
5443 /*
5444 ..
5445 .. Executable Statements ..
5446 */
5447 T1 = *s+1.e0;
5448 cumbet(pr,ompr,xn,&T1,cum,ccum);
5449 return;
5450 }
cumnor(double * arg,double * result,double * ccum)5451 void cumnor(double *arg,double *result,double *ccum)
5452 /*
5453 **********************************************************************
5454
5455 void cumnor(double *arg,double *result,double *ccum)
5456
5457
5458 Function
5459
5460
5461 Computes the cumulative of the normal distribution, i.e.,
5462 the integral from -infinity to x of
5463 (1/sqrt(2*pi)) exp(-u*u/2) du
5464
5465 X --> Upper limit of integration.
5466 X is DOUBLE PRECISION
5467
5468 RESULT <-- Cumulative normal distribution.
5469 RESULT is DOUBLE PRECISION
5470
5471 CCUM <-- Compliment of Cumulative normal distribution.
5472 CCUM is DOUBLE PRECISION
5473
5474 Renaming of function ANORM from:
5475
5476 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
5477 Package of Special Function Routines and Test Drivers"
5478 acm Transactions on Mathematical Software. 19, 22-32.
5479
5480 with slight modifications to return ccum and to deal with
5481 machine constants.
5482
5483 **********************************************************************
5484 Original Comments:
5485 ------------------------------------------------------------------
5486
5487 This function evaluates the normal distribution function:
5488
5489 / x
5490 1 | -t*t/2
5491 P(x) = ----------- | e dt
5492 sqrt(2 pi) |
5493 /-oo
5494
5495 The main computation evaluates near-minimax approximations
5496 derived from those in "Rational Chebyshev approximations for
5497 the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
5498 This transportable program uses rational functions that
5499 theoretically approximate the normal distribution function to
5500 at least 18 significant decimal digits. The accuracy achieved
5501 depends on the arithmetic system, the compiler, the intrinsic
5502 functions, and proper selection of the machine-dependent
5503 constants.
5504
5505 *******************************************************************
5506 *******************************************************************
5507
5508 Explanation of machine-dependent constants.
5509
5510 MIN = smallest machine representable number.
5511
5512 EPS = argument below which anorm(x) may be represented by
5513 0.5 and above which x*x will not underflow.
5514 A conservative value is the largest machine number X
5515 such that 1.0 + X = 1.0 to machine precision.
5516 *******************************************************************
5517 *******************************************************************
5518
5519 Error returns
5520
5521 The program returns ANORM = 0 for ARG .LE. XLOW.
5522
5523
5524 Intrinsic functions required are:
5525
5526 ABS, AINT, EXP
5527
5528
5529 Author: W. J. Cody
5530 Mathematics and Computer Science Division
5531 Argonne National Laboratory
5532 Argonne, IL 60439
5533
5534 Latest modification: March 15, 1992
5535
5536 ------------------------------------------------------------------
5537 */
5538 {
5539 static double a[5] = {
5540 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03,
5541 1.8154981253343561249e04,6.5682337918207449113e-2
5542 };
5543 static double b[4] = {
5544 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04,
5545 4.5507789335026729956e04
5546 };
5547 static double c[9] = {
5548 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01,
5549 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03,
5550 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8
5551 };
5552 static double d[8] = {
5553 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03,
5554 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04,
5555 3.8912003286093271411e04,1.9685429676859990727e04
5556 };
5557 static double half = 0.5e0;
5558 static double p[6] = {
5559 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2,
5560 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2
5561 };
5562 static double one = 1.0e0;
5563 static double q[5] = {
5564 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2,
5565 3.78239633202758244e-3,7.29751555083966205e-5
5566 };
5567 static double sixten = 1.60e0;
5568 static double sqrpi = 3.9894228040143267794e-1;
5569 static double thrsh = 0.66291e0;
5570 static double root32 = 5.656854248e0;
5571 static double zero = 0.0e0;
5572 static int K1 = 1;
5573 static int K2 = 2;
5574 static int i;
5575 static double del,eps,temp,x,xden,xnum,y,xsq,min;
5576 /*
5577 ------------------------------------------------------------------
5578 Machine dependent constants
5579 ------------------------------------------------------------------
5580 */
5581 eps = spmpar(&K1)*0.5e0;
5582 min = spmpar(&K2);
5583 x = *arg;
5584 y = fabs(x);
5585 if(y <= thrsh) {
5586 /*
5587 ------------------------------------------------------------------
5588 Evaluate anorm for |X| <= 0.66291
5589 ------------------------------------------------------------------
5590 */
5591 xsq = zero;
5592 if(y > eps) xsq = x*x;
5593 xnum = a[4]*xsq;
5594 xden = xsq;
5595 for(i=0; i<3; i++) {
5596 xnum = (xnum+a[i])*xsq;
5597 xden = (xden+b[i])*xsq;
5598 }
5599 *result = x*(xnum+a[3])/(xden+b[3]);
5600 temp = *result;
5601 *result = half+temp;
5602 *ccum = half-temp;
5603 }
5604 /*
5605 ------------------------------------------------------------------
5606 Evaluate anorm for 0.66291 <= |X| <= sqrt(32)
5607 ------------------------------------------------------------------
5608 */
5609 else if(y <= root32) {
5610 xnum = c[8]*y;
5611 xden = y;
5612 for(i=0; i<7; i++) {
5613 xnum = (xnum+c[i])*y;
5614 xden = (xden+d[i])*y;
5615 }
5616 *result = (xnum+c[7])/(xden+d[7]);
5617 xsq = fifdint(y*sixten)/sixten;
5618 del = (y-xsq)*(y+xsq);
5619 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
5620 *ccum = one-*result;
5621 if(x > zero) {
5622 temp = *result;
5623 *result = *ccum;
5624 *ccum = temp;
5625 }
5626 }
5627 /*
5628 ------------------------------------------------------------------
5629 Evaluate anorm for |X| > sqrt(32)
5630 ------------------------------------------------------------------
5631 */
5632 else {
5633 *result = zero;
5634 xsq = one/(x*x);
5635 xnum = p[5]*xsq;
5636 xden = xsq;
5637 for(i=0; i<4; i++) {
5638 xnum = (xnum+p[i])*xsq;
5639 xden = (xden+q[i])*xsq;
5640 }
5641 *result = xsq*(xnum+p[4])/(xden+q[4]);
5642 *result = (sqrpi-*result)/y;
5643 xsq = fifdint(x*sixten)/sixten;
5644 del = (x-xsq)*(x+xsq);
5645 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
5646 *ccum = one-*result;
5647 if(x > zero) {
5648 temp = *result;
5649 *result = *ccum;
5650 *ccum = temp;
5651 }
5652 }
5653 if(*result < min) *result = 0.0e0;
5654 /*
5655 ------------------------------------------------------------------
5656 Fix up for negative argument, erf, etc.
5657 ------------------------------------------------------------------
5658 ----------Last card of ANORM ----------
5659 */
5660 if(*ccum < min) *ccum = 0.0e0;
5661 }
cumpoi(double * s,double * xlam,double * cum,double * ccum)5662 void cumpoi(double *s,double *xlam,double *cum,double *ccum)
5663 /*
5664 **********************************************************************
5665
5666 void cumpoi(double *s,double *xlam,double *cum,double *ccum)
5667 CUMulative POIsson distribution
5668
5669
5670 Function
5671
5672
5673 Returns the probability of S or fewer events in a Poisson
5674 distribution with mean XLAM.
5675
5676
5677 Arguments
5678
5679
5680 S --> Upper limit of cumulation of the Poisson.
5681 S is DOUBLE PRECISION
5682
5683 XLAM --> Mean of the Poisson distribution.
5684 XLAM is DOUBLE PRECIS
5685
5686 CUM <-- Cumulative poisson distribution.
5687 CUM is DOUBLE PRECISION
5688
5689 CCUM <-- Compliment of Cumulative poisson distribution.
5690 CCUM is DOUBLE PRECIS
5691
5692
5693 Method
5694
5695
5696 Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of
5697 Mathematical Functions to reduce the cumulative Poisson to
5698 the cumulative chi-square distribution.
5699
5700 **********************************************************************
5701 */
5702 {
5703 static double chi,df;
5704 /*
5705 ..
5706 .. Executable Statements ..
5707 */
5708 df = 2.0e0*(*s+1.0e0);
5709 chi = 2.0e0**xlam;
5710 cumchi(&chi,&df,ccum,cum);
5711 return;
5712 }
cumt(double * t,double * df,double * cum,double * ccum)5713 void cumt(double *t,double *df,double *cum,double *ccum)
5714 /*
5715 **********************************************************************
5716
5717 void cumt(double *t,double *df,double *cum,double *ccum)
5718 CUMulative T-distribution
5719
5720
5721 Function
5722
5723
5724 Computes the integral from -infinity to T of the t-density.
5725
5726
5727 Arguments
5728
5729
5730 T --> Upper limit of integration of the t-density.
5731 T is DOUBLE PRECISION
5732
5733 DF --> Degrees of freedom of the t-distribution.
5734 DF is DOUBLE PRECISIO
5735
5736 CUM <-- Cumulative t-distribution.
5737 CCUM is DOUBLE PRECIS
5738
5739 CCUM <-- Compliment of Cumulative t-distribution.
5740 CCUM is DOUBLE PRECIS
5741
5742
5743 Method
5744
5745
5746 Formula 26.5.27 of Abramowitz and Stegun, Handbook of
5747 Mathematical Functions is used to reduce the t-distribution
5748 to an incomplete beta.
5749
5750 **********************************************************************
5751 */
5752 {
5753 static double K2 = 0.5e0;
5754 static double xx,a,oma,tt,yy,dfptt,T1;
5755 /*
5756 ..
5757 .. Executable Statements ..
5758 */
5759 tt = *t**t;
5760 dfptt = *df+tt;
5761 xx = *df/dfptt;
5762 yy = tt/dfptt;
5763 T1 = 0.5e0**df;
5764 cumbet(&xx,&yy,&T1,&K2,&a,&oma);
5765 if(!(*t <= 0.0e0)) goto S10;
5766 *cum = 0.5e0*a;
5767 *ccum = oma+*cum;
5768 goto S20;
5769 S10:
5770 *ccum = 0.5e0*a;
5771 *cum = oma+*ccum;
5772 S20:
5773 return;
5774 }
dbetrm(double * a,double * b)5775 double dbetrm(double *a,double *b)
5776 /*
5777 **********************************************************************
5778
5779 double dbetrm(double *a,double *b)
5780 Double Precision Sterling Remainder for Complete
5781 Beta Function
5782
5783
5784 Function
5785
5786
5787 Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
5788 where Lgamma is the log of the (complete) gamma function
5789
5790 Let ZZ be approximation obtained if each log gamma is approximated
5791 by Sterling's formula, i.e.,
5792 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
5793
5794 Returns Log(Beta(A,B)) - ZZ
5795
5796
5797 Arguments
5798
5799
5800 A --> One argument of the Beta
5801 DOUBLE PRECISION A
5802
5803 B --> The other argument of the Beta
5804 DOUBLE PRECISION B
5805
5806 **********************************************************************
5807 */
5808 {
5809 static double dbetrm,T1,T2,T3;
5810 /*
5811 ..
5812 .. Executable Statements ..
5813 */
5814 /*
5815 Try to sum from smallest to largest
5816 */
5817 T1 = *a+*b;
5818 dbetrm = -dstrem(&T1);
5819 T2 = fifdmax1(*a,*b);
5820 dbetrm += dstrem(&T2);
5821 T3 = fifdmin1(*a,*b);
5822 dbetrm += dstrem(&T3);
5823 return dbetrm;
5824 }
devlpl(double a[],int * n,double * x)5825 double devlpl(double a[],int *n,double *x)
5826 /*
5827 **********************************************************************
5828
5829 double devlpl(double a[],int *n,double *x)
5830 Double precision EVALuate a PoLynomial at X
5831
5832
5833 Function
5834
5835
5836 returns
5837 A(1) + A(2)*X + ... + A(N)*X**(N-1)
5838
5839
5840 Arguments
5841
5842
5843 A --> Array of coefficients of the polynomial.
5844 A is DOUBLE PRECISION(N)
5845
5846 N --> Length of A, also degree of polynomial - 1.
5847 N is INTEGER
5848
5849 X --> Point at which the polynomial is to be evaluated.
5850 X is DOUBLE PRECISION
5851
5852 **********************************************************************
5853 */
5854 {
5855 static double devlpl,term;
5856 static int i;
5857 /*
5858 ..
5859 .. Executable Statements ..
5860 */
5861 term = a[*n-1];
5862 for(i= *n-1-1; i>=0; i--) term = a[i]+term**x;
5863 devlpl = term;
5864 return devlpl;
5865 }
dexpm1(double * x)5866 double dexpm1(double *x)
5867 /*
5868 **********************************************************************
5869
5870 double dexpm1(double *x)
5871 Evaluation of the function EXP(X) - 1
5872
5873
5874 Arguments
5875
5876
5877 X --> Argument at which exp(x)-1 desired
5878 DOUBLE PRECISION X
5879
5880
5881 Method
5882
5883
5884 Renaming of function rexp from code of:
5885
5886 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
5887 Digit Computation of the Incomplete Beta Function Ratios. ACM
5888 Trans. Math. Softw. 18 (1993), 360-373.
5889
5890 **********************************************************************
5891 */
5892 {
5893 static double p1 = .914041914819518e-09;
5894 static double p2 = .238082361044469e-01;
5895 static double q1 = -.499999999085958e+00;
5896 static double q2 = .107141568980644e+00;
5897 static double q3 = -.119041179760821e-01;
5898 static double q4 = .595130811860248e-03;
5899 static double dexpm1,w;
5900 /*
5901 ..
5902 .. Executable Statements ..
5903 */
5904 if(fabs(*x) > 0.15e0) goto S10;
5905 dexpm1 = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
5906 return dexpm1;
5907 S10:
5908 w = exp(*x);
5909 if(*x > 0.0e0) goto S20;
5910 dexpm1 = w-0.5e0-0.5e0;
5911 return dexpm1;
5912 S20:
5913 dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w));
5914 return dexpm1;
5915 }
dinvnr(double * p,double * q)5916 double dinvnr(double *p,double *q)
5917 /*
5918 **********************************************************************
5919
5920 double dinvnr(double *p,double *q)
5921 Double precision NoRmal distribution INVerse
5922
5923
5924 Function
5925
5926
5927 Returns X such that CUMNOR(X) = P, i.e., the integral from -
5928 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
5929
5930
5931 Arguments
5932
5933
5934 P --> The probability whose normal deviate is sought.
5935 P is DOUBLE PRECISION
5936
5937 Q --> 1-P
5938 P is DOUBLE PRECISION
5939
5940
5941 Method
5942
5943
5944 The rational function on page 95 of Kennedy and Gentle,
5945 Statistical Computing, Marcel Dekker, NY , 1980 is used as a start
5946 value for the Newton method of finding roots.
5947
5948
5949 Note
5950
5951
5952 If P or Q .lt. machine EPS returns +/- DINVNR(EPS)
5953
5954 **********************************************************************
5955 */
5956 {
5957 #define maxit 100
5958 #define eps (1.0e-13)
5959 #define r2pi 0.3989422804014326e0
5960 #define nhalf (-0.5e0)
5961 #define dennor(x) (r2pi*exp(nhalf*(x)*(x)))
5962 static double dinvnr,strtx,xcur,cum,ccum,pp,dx;
5963 static int i;
5964 static unsigned long qporq;
5965 /*
5966 ..
5967 .. Executable Statements ..
5968 */
5969 /*
5970 FIND MINIMUM OF P AND Q
5971 */
5972 qporq = *p <= *q;
5973 if(!qporq) goto S10;
5974 pp = *p;
5975 goto S20;
5976 S10:
5977 pp = *q;
5978 S20:
5979 /*
5980 INITIALIZATION STEP
5981 */
5982 strtx = stvaln(&pp);
5983 xcur = strtx;
5984 /*
5985 NEWTON INTERATIONS
5986 */
5987 for(i=1; i<=maxit; i++) {
5988 cumnor(&xcur,&cum,&ccum);
5989 dx = (cum-pp)/dennor(xcur);
5990 xcur -= dx;
5991 if(fabs(dx/xcur) < eps) goto S40;
5992 }
5993 dinvnr = strtx;
5994 /*
5995 IF WE GET HERE, NEWTON HAS FAILED
5996 */
5997 if(!qporq) dinvnr = -dinvnr;
5998 return dinvnr;
5999 S40:
6000 /*
6001 IF WE GET HERE, NEWTON HAS SUCCEDED
6002 */
6003 dinvnr = xcur;
6004 if(!qporq) dinvnr = -dinvnr;
6005 return dinvnr;
6006 #undef maxit
6007 #undef eps
6008 #undef r2pi
6009 #undef nhalf
6010 #undef dennor
6011 }
6012 /* DEFINE DINVR */
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)6013 static void E0000(int IENTRY,int *status,double *x,double *fx,
6014 unsigned long *qleft,unsigned long *qhi,double *zabsst,
6015 double *zabsto,double *zbig,double *zrelst,
6016 double *zrelto,double *zsmall,double *zstpmu)
6017 {
6018 #define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))
6019 static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,
6020 xlb,xlo,xsave,xub,yy;
6021 static int i99999;
6022 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;
6023 switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}
6024 DINVR:
6025 if(*status > 0) goto S310;
6026 qcond = !qxmon(small,*x,big);
6027 if(qcond) ftnstop(" SMALL, X, BIG not monotone in INVR");
6028 xsave = *x;
6029 /*
6030 See that SMALL and BIG bound the zero and set QINCR
6031 */
6032 *x = small;
6033 /*
6034 GET-FUNCTION-VALUE
6035 */
6036 i99999 = 1;
6037 goto S300;
6038 S10:
6039 fsmall = *fx;
6040 *x = big;
6041 /*
6042 GET-FUNCTION-VALUE
6043 */
6044 i99999 = 2;
6045 goto S300;
6046 S20:
6047 fbig = *fx;
6048 qincr = fbig > fsmall;
6049 if(!qincr) goto S50;
6050 if(fsmall <= 0.0e0) goto S30;
6051 *status = -1;
6052 *qleft = *qhi = 1;
6053 return;
6054 S30:
6055 if(fbig >= 0.0e0) goto S40;
6056 *status = -1;
6057 *qleft = *qhi = 0;
6058 return;
6059 S40:
6060 goto S80;
6061 S50:
6062 if(fsmall >= 0.0e0) goto S60;
6063 *status = -1;
6064 *qleft = 1;
6065 *qhi = 0;
6066 return;
6067 S60:
6068 if(fbig <= 0.0e0) goto S70;
6069 *status = -1;
6070 *qleft = 0;
6071 *qhi = 1;
6072 return;
6073 S80:
6074 S70:
6075 *x = xsave;
6076 step = fifdmax1(absstp,relstp*fabs(*x));
6077 /*
6078 YY = F(X) - Y
6079 GET-FUNCTION-VALUE
6080 */
6081 i99999 = 3;
6082 goto S300;
6083 S90:
6084 yy = *fx;
6085 if(!(yy == 0.0e0)) goto S100;
6086 *status = 0;
6087 qok = 1;
6088 return;
6089 S100:
6090 qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;
6091 /*
6092 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6093 HANDLE CASE IN WHICH WE MUST STEP HIGHER
6094 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6095 */
6096 if(!qup) goto S170;
6097 xlb = xsave;
6098 xub = fifdmin1(xlb+step,big);
6099 goto S120;
6100 S110:
6101 if(qcond) goto S150;
6102 S120:
6103 /*
6104 YY = F(XUB) - Y
6105 */
6106 *x = xub;
6107 /*
6108 GET-FUNCTION-VALUE
6109 */
6110 i99999 = 4;
6111 goto S300;
6112 S130:
6113 yy = *fx;
6114 qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;
6115 qlim = xub >= big;
6116 qcond = qbdd || qlim;
6117 if(qcond) goto S140;
6118 step = stpmul*step;
6119 xlb = xub;
6120 xub = fifdmin1(xlb+step,big);
6121 S140:
6122 goto S110;
6123 S150:
6124 if(!(qlim && !qbdd)) goto S160;
6125 *status = -1;
6126 *qleft = 0;
6127 *qhi = !qincr;
6128 *x = big;
6129 return;
6130 S160:
6131 goto S240;
6132 S170:
6133 /*
6134 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6135 HANDLE CASE IN WHICH WE MUST STEP LOWER
6136 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6137 */
6138 xub = xsave;
6139 xlb = fifdmax1(xub-step,small);
6140 goto S190;
6141 S180:
6142 if(qcond) goto S220;
6143 S190:
6144 /*
6145 YY = F(XLB) - Y
6146 */
6147 *x = xlb;
6148 /*
6149 GET-FUNCTION-VALUE
6150 */
6151 i99999 = 5;
6152 goto S300;
6153 S200:
6154 yy = *fx;
6155 qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;
6156 qlim = xlb <= small;
6157 qcond = qbdd || qlim;
6158 if(qcond) goto S210;
6159 step = stpmul*step;
6160 xub = xlb;
6161 xlb = fifdmax1(xub-step,small);
6162 S210:
6163 goto S180;
6164 S220:
6165 if(!(qlim && !qbdd)) goto S230;
6166 *status = -1;
6167 *qleft = 1;
6168 *qhi = qincr;
6169 *x = small;
6170 return;
6171 S240:
6172 S230:
6173 dstzr(&xlb,&xub,&abstol,&reltol);
6174 /*
6175 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6176 IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.
6177 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6178 */
6179 *status = 0;
6180 goto S260;
6181 S250:
6182 if(!(*status == 1)) goto S290;
6183 S260:
6184 dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2);
6185 if(!(*status == 1)) goto S280;
6186 /*
6187 GET-FUNCTION-VALUE
6188 */
6189 i99999 = 6;
6190 goto S300;
6191 S280:
6192 S270:
6193 goto S250;
6194 S290:
6195 *x = xlo;
6196 *status = 0;
6197 return;
6198 DSTINV:
6199 small = *zsmall;
6200 big = *zbig;
6201 absstp = *zabsst;
6202 relstp = *zrelst;
6203 stpmul = *zstpmu;
6204 abstol = *zabsto;
6205 reltol = *zrelto;
6206 return;
6207 S300:
6208 /*
6209 TO GET-FUNCTION-VALUE
6210 */
6211 *status = 1;
6212 return;
6213 S310:
6214 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case
6215 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}
6216 #undef qxmon
6217 }
dinvr(int * status,double * x,double * fx,unsigned long * qleft,unsigned long * qhi)6218 void dinvr(int *status,double *x,double *fx,
6219 unsigned long *qleft,unsigned long *qhi)
6220 /*
6221 **********************************************************************
6222
6223 void dinvr(int *status,double *x,double *fx,
6224 unsigned long *qleft,unsigned long *qhi)
6225
6226 Double precision
6227 bounds the zero of the function and invokes zror
6228 Reverse Communication
6229
6230
6231 Function
6232
6233
6234 Bounds the function and invokes ZROR to perform the zero
6235 finding. STINVR must have been called before this routine
6236 in order to set its parameters.
6237
6238
6239 Arguments
6240
6241
6242 STATUS <--> At the beginning of a zero finding problem, STATUS
6243 should be set to 0 and INVR invoked. (The value
6244 of parameters other than X will be ignored on this cal
6245
6246 When INVR needs the function evaluated, it will set
6247 STATUS to 1 and return. The value of the function
6248 should be set in FX and INVR again called without
6249 changing any of its other parameters.
6250
6251 When INVR has finished without error, it will return
6252 with STATUS 0. In that case X is approximately a root
6253 of F(X).
6254
6255 If INVR cannot bound the function, it returns status
6256 -1 and sets QLEFT and QHI.
6257 INTEGER STATUS
6258
6259 X <-- The value of X at which F(X) is to be evaluated.
6260 DOUBLE PRECISION X
6261
6262 FX --> The value of F(X) calculated when INVR returns with
6263 STATUS = 1.
6264 DOUBLE PRECISION FX
6265
6266 QLEFT <-- Defined only if QMFINV returns .FALSE. In that
6267 case it is .TRUE. If the stepping search terminated
6268 unsucessfully at SMALL. If it is .FALSE. the search
6269 terminated unsucessfully at BIG.
6270 QLEFT is LOGICAL
6271
6272 QHI <-- Defined only if QMFINV returns .FALSE. In that
6273 case it is .TRUE. if F(X) .GT. Y at the termination
6274 of the search and .FALSE. if F(X) .LT. Y at the
6275 termination of the search.
6276 QHI is LOGICAL
6277
6278 **********************************************************************
6279 */
6280 {
6281 E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL);
6282 }
dstinv(double * zsmall,double * zbig,double * zabsst,double * zrelst,double * zstpmu,double * zabsto,double * zrelto)6283 void dstinv(double *zsmall,double *zbig,double *zabsst,
6284 double *zrelst,double *zstpmu,double *zabsto,
6285 double *zrelto)
6286 /*
6287 **********************************************************************
6288 void dstinv(double *zsmall,double *zbig,double *zabsst,
6289 double *zrelst,double *zstpmu,double *zabsto,
6290 double *zrelto)
6291
6292 Double Precision - SeT INverse finder - Reverse Communication
6293 Function
6294 Concise Description - Given a monotone function F finds X
6295 such that F(X) = Y. Uses Reverse communication -- see invr.
6296 This routine sets quantities needed by INVR.
6297 More Precise Description of INVR -
6298 F must be a monotone function, the results of QMFINV are
6299 otherwise undefined. QINCR must be .TRUE. if F is non-
6300 decreasing and .FALSE. if F is non-increasing.
6301 QMFINV will return .TRUE. if and only if F(SMALL) and
6302 F(BIG) bracket Y, i. e.,
6303 QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or
6304 QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL)
6305 if QMFINV returns .TRUE., then the X returned satisfies
6306 the following condition. let
6307 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6308 then if QINCR is .TRUE.,
6309 F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X))
6310 and if QINCR is .FALSE.
6311 F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
6312 Arguments
6313 SMALL --> The left endpoint of the interval to be
6314 searched for a solution.
6315 SMALL is DOUBLE PRECISION
6316 BIG --> The right endpoint of the interval to be
6317 searched for a solution.
6318 BIG is DOUBLE PRECISION
6319 ABSSTP, RELSTP --> The initial step size in the search
6320 is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm.
6321 ABSSTP is DOUBLE PRECISION
6322 RELSTP is DOUBLE PRECISION
6323 STPMUL --> When a step doesn't bound the zero, the step
6324 size is multiplied by STPMUL and another step
6325 taken. A popular value is 2.0
6326 DOUBLE PRECISION STPMUL
6327 ABSTOL, RELTOL --> Two numbers that determine the accuracy
6328 of the solution. See function for a precise definition.
6329 ABSTOL is DOUBLE PRECISION
6330 RELTOL is DOUBLE PRECISION
6331 Method
6332 Compares F(X) with Y for the input value of X then uses QINCR
6333 to determine whether to step left or right to bound the
6334 desired x. the initial step size is
6335 MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X.
6336 Iteratively steps right or left until it bounds X.
6337 At each step which doesn't bound X, the step size is doubled.
6338 The routine is careful never to step beyond SMALL or BIG. If
6339 it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE.
6340 after setting QLEFT and QHI.
6341 If X is successfully bounded then Algorithm R of the paper
6342 'Two Efficient Algorithms with Guaranteed Convergence for
6343 Finding a Zero of a Function' by J. C. P. Bus and
6344 T. J. Dekker in ACM Transactions on Mathematical
6345 Software, Volume 1, No. 4 page 330 (DEC. '75) is employed
6346 to find the zero of the function F(X)-Y. This is routine
6347 QRZERO.
6348 **********************************************************************
6349 */
6350 {
6351 E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall,
6352 zstpmu);
6353 }
dlanor(double * x)6354 double dlanor(double *x)
6355 /*
6356 **********************************************************************
6357
6358 double dlanor(double *x)
6359 Double precision Logarith of the Asymptotic Normal
6360
6361
6362 Function
6363
6364
6365 Computes the logarithm of the cumulative normal distribution
6366 from abs( x ) to infinity for abs( x ) >= 5.
6367
6368
6369 Arguments
6370
6371
6372 X --> Value at which cumulative normal to be evaluated
6373 DOUBLE PRECISION X
6374
6375
6376 Method
6377
6378
6379 23 term expansion of formula 26.2.12 of Abramowitz and Stegun.
6380 The relative error at X = 5 is about 0.5E-5.
6381
6382
6383 Note
6384
6385
6386 ABS(X) must be >= 5 else there is an error stop.
6387
6388 **********************************************************************
6389 */
6390 {
6391 #define dlsqpi 0.91893853320467274177e0
6392 static double coef[12] = {
6393 -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0,
6394 -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0
6395 };
6396 static int K1 = 12;
6397 static double dlanor,approx,correc,xx,xx2,T2;
6398 /*
6399 ..
6400 .. Executable Statements ..
6401 */
6402 xx = fabs(*x);
6403 if(xx < 5.0e0) ftnstop(" Argument too small in DLANOR");
6404 approx = -dlsqpi-0.5e0*xx*xx-log(xx);
6405 xx2 = xx*xx;
6406 T2 = 1.0e0/xx2;
6407 correc = devlpl(coef,&K1,&T2)/xx2;
6408 correc = dln1px(&correc);
6409 dlanor = approx+correc;
6410 return dlanor;
6411 #undef dlsqpi
6412 }
dln1mx(double * x)6413 double dln1mx(double *x)
6414 /*
6415 **********************************************************************
6416
6417 double dln1mx(double *x)
6418 Double precision LN(1-X)
6419
6420
6421 Function
6422
6423
6424 Returns ln(1-x) for small x (good accuracy if x .le. 0.1).
6425 Note that the obvious code of
6426 LOG(1.0-X)
6427 won't work for small X because 1.0-X loses accuracy
6428
6429
6430 Arguments
6431
6432
6433 X --> Value for which ln(1-x) is desired.
6434 X is DOUBLE PRECISION
6435
6436
6437 Method
6438
6439
6440 If X > 0.1, the obvious code above is used ELSE
6441 The Taylor series for 1-x is expanded to 20 terms.
6442
6443 **********************************************************************
6444 */
6445 {
6446 static double dln1mx,T1;
6447 /*
6448 ..
6449 .. Executable Statements ..
6450 */
6451 T1 = -*x;
6452 dln1mx = dln1px(&T1);
6453 return dln1mx;
6454 }
dln1px(double * a)6455 double dln1px(double *a)
6456 /*
6457 **********************************************************************
6458
6459 double dln1px(double *a)
6460 Double precision LN(1+X)
6461
6462
6463 Function
6464
6465
6466 Returns ln(1+x)
6467 Note that the obvious code of
6468 LOG(1.0+X)
6469 won't work for small X because 1.0+X loses accuracy
6470
6471
6472 Arguments
6473
6474
6475 X --> Value for which ln(1-x) is desired.
6476 X is DOUBLE PRECISION
6477
6478
6479 Method
6480
6481
6482 Renames ALNREL from:
6483 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6484 Digit Computation of the Incomplete Beta Function Ratios. ACM
6485 Trans. Math. Softw. 18 (1993), 360-373.
6486
6487 **********************************************************************
6488 -----------------------------------------------------------------------
6489 EVALUATION OF THE FUNCTION LN(1 + A)
6490 -----------------------------------------------------------------------
6491 */
6492 {
6493 static double p1 = -.129418923021993e+01;
6494 static double p2 = .405303492862024e+00;
6495 static double p3 = -.178874546012214e-01;
6496 static double q1 = -.162752256355323e+01;
6497 static double q2 = .747811014037616e+00;
6498 static double q3 = -.845104217945565e-01;
6499 static double dln1px,t,t2,w,x;
6500 /*
6501 ..
6502 .. Executable Statements ..
6503 */
6504 if(fabs(*a) > 0.375e0) goto S10;
6505 t = *a/(*a+2.0e0);
6506 t2 = t*t;
6507 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0);
6508 dln1px = 2.0e0*t*w;
6509 return dln1px;
6510 S10:
6511 x = 1.e0+*a;
6512 dln1px = log(x);
6513 return dln1px;
6514 }
dlnbet(double * a0,double * b0)6515 double dlnbet(double *a0,double *b0)
6516 /*
6517 **********************************************************************
6518
6519 double dlnbet(a0,b0)
6520 Double precision LN of the complete BETa
6521
6522
6523 Function
6524
6525
6526 Returns the natural log of the complete beta function,
6527 i.e.,
6528
6529 ln( Gamma(a)*Gamma(b) / Gamma(a+b)
6530
6531
6532 Arguments
6533
6534
6535 A,B --> The (symmetric) arguments to the complete beta
6536 DOUBLE PRECISION A, B
6537
6538
6539 Method
6540
6541
6542 Renames BETALN from:
6543 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6544 Digit Computation of the Incomplete Beta Function Ratios. ACM
6545 Trans. Math. Softw. 18 (1993), 360-373.
6546
6547 **********************************************************************
6548 -----------------------------------------------------------------------
6549 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
6550 -----------------------------------------------------------------------
6551 E = 0.5*LN(2*PI)
6552 --------------------------
6553 */
6554 {
6555 static double e = .918938533204673e0;
6556 static double dlnbet,a,b,c,h,u,v,w,z;
6557 static int i,n;
6558 static double T1;
6559 /*
6560 ..
6561 .. Executable Statements ..
6562 */
6563 a = fifdmin1(*a0,*b0);
6564 b = fifdmax1(*a0,*b0);
6565 if(a >= 8.0e0) goto S100;
6566 if(a >= 1.0e0) goto S20;
6567 /*
6568 -----------------------------------------------------------------------
6569 PROCEDURE WHEN A .LT. 1
6570 -----------------------------------------------------------------------
6571 */
6572 if(b >= 8.0e0) goto S10;
6573 T1 = a+b;
6574 dlnbet = gamln(&a)+(gamln(&b)-gamln(&T1));
6575 return dlnbet;
6576 S10:
6577 dlnbet = gamln(&a)+algdiv(&a,&b);
6578 return dlnbet;
6579 S20:
6580 /*
6581 -----------------------------------------------------------------------
6582 PROCEDURE WHEN 1 .LE. A .LT. 8
6583 -----------------------------------------------------------------------
6584 */
6585 if(a > 2.0e0) goto S40;
6586 if(b > 2.0e0) goto S30;
6587 dlnbet = gamln(&a)+gamln(&b)-gsumln(&a,&b);
6588 return dlnbet;
6589 S30:
6590 w = 0.0e0;
6591 if(b < 8.0e0) goto S60;
6592 dlnbet = gamln(&a)+algdiv(&a,&b);
6593 return dlnbet;
6594 S40:
6595 /*
6596 REDUCTION OF A WHEN B .LE. 1000
6597 */
6598 if(b > 1000.0e0) goto S80;
6599 n = int(a-1.0e0);
6600 w = 1.0e0;
6601 for(i=1; i<=n; i++) {
6602 a -= 1.0e0;
6603 h = a/b;
6604 w *= (h/(1.0e0+h));
6605 }
6606 w = log(w);
6607 if(b < 8.0e0) goto S60;
6608 dlnbet = w+gamln(&a)+algdiv(&a,&b);
6609 return dlnbet;
6610 S60:
6611 /*
6612 REDUCTION OF B WHEN B .LT. 8
6613 */
6614 n = int(b-1.0e0);
6615 z = 1.0e0;
6616 for(i=1; i<=n; i++) {
6617 b -= 1.0e0;
6618 z *= (b/(a+b));
6619 }
6620 dlnbet = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b)));
6621 return dlnbet;
6622 S80:
6623 /*
6624 REDUCTION OF A WHEN B .GT. 1000
6625 */
6626 n = int(a-1.0e0);
6627 w = 1.0e0;
6628 for(i=1; i<=n; i++) {
6629 a -= 1.0e0;
6630 w *= (a/(1.0e0+a/b));
6631 }
6632 dlnbet = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b));
6633 return dlnbet;
6634 S100:
6635 /*
6636 -----------------------------------------------------------------------
6637 PROCEDURE WHEN A .GE. 8
6638 -----------------------------------------------------------------------
6639 */
6640 w = bcorr(&a,&b);
6641 h = a/b;
6642 c = h/(1.0e0+h);
6643 u = -((a-0.5e0)*log(c));
6644 v = b*alnrel(&h);
6645 if(u <= v) goto S110;
6646 dlnbet = -(0.5e0*log(b))+e+w-v-u;
6647 return dlnbet;
6648 S110:
6649 dlnbet = -(0.5e0*log(b))+e+w-u-v;
6650 return dlnbet;
6651 }
dlngam(double * a)6652 double dlngam(double *a)
6653 /*
6654 **********************************************************************
6655
6656 double dlngam(double *a)
6657 Double precision LN of the GAMma function
6658
6659
6660 Function
6661
6662
6663 Returns the natural logarithm of GAMMA(X).
6664
6665
6666 Arguments
6667
6668
6669 X --> value at which scaled log gamma is to be returned
6670 X is DOUBLE PRECISION
6671
6672
6673 Method
6674
6675
6676 Renames GAMLN from:
6677 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6678 Digit Computation of the Incomplete Beta Function Ratios. ACM
6679 Trans. Math. Softw. 18 (1993), 360-373.
6680
6681 **********************************************************************
6682 -----------------------------------------------------------------------
6683 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
6684 -----------------------------------------------------------------------
6685 WRITTEN BY ALFRED H. MORRIS
6686 NAVAL SURFACE WARFARE CENTER
6687 DAHLGREN, VIRGINIA
6688 --------------------------
6689 D = 0.5*(LN(2*PI) - 1)
6690 --------------------------
6691 */
6692 {
6693 static double c0 = .833333333333333e-01;
6694 static double c1 = -.277777777760991e-02;
6695 static double c2 = .793650666825390e-03;
6696 static double c3 = -.595202931351870e-03;
6697 static double c4 = .837308034031215e-03;
6698 static double c5 = -.165322962780713e-02;
6699 static double d = .418938533204673e0;
6700 static double dlngam,t,w;
6701 static int i,n;
6702 static double T1;
6703 /*
6704 ..
6705 .. Executable Statements ..
6706 */
6707 if(*a > 0.8e0) goto S10;
6708 dlngam = gamln1(a)-log(*a);
6709 return dlngam;
6710 S10:
6711 if(*a > 2.25e0) goto S20;
6712 t = *a-0.5e0-0.5e0;
6713 dlngam = gamln1(&t);
6714 return dlngam;
6715 S20:
6716 if(*a >= 10.0e0) goto S40;
6717 n = int(*a-1.25e0);
6718 t = *a;
6719 w = 1.0e0;
6720 for(i=1; i<=n; i++) {
6721 t -= 1.0e0;
6722 w = t*w;
6723 }
6724 T1 = t-1.0e0;
6725 dlngam = gamln1(&T1)+log(w);
6726 return dlngam;
6727 S40:
6728 t = pow(1.0e0/ *a,2.0);
6729 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
6730 dlngam = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
6731 return dlngam;
6732 }
dstrem(double * z)6733 double dstrem(double *z)
6734 {
6735 /*
6736 **********************************************************************
6737 double dstrem(double *z)
6738 Double precision Sterling Remainder
6739 Function
6740 Returns Log(Gamma(Z)) - Sterling(Z) where Sterling(Z) is
6741 Sterling's Approximation to Log(Gamma(Z))
6742 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
6743 Arguments
6744 Z --> Value at which Sterling remainder calculated
6745 Must be positive.
6746 DOUBLE PRECISION Z
6747 Method
6748 If Z >= 6 uses 9 terms of series in Bernoulli numbers
6749 (Values calculated using Maple)
6750 Otherwise computes difference explicitly
6751 **********************************************************************
6752 */
6753 #define hln2pi 0.91893853320467274178e0
6754 #define ncoef 10
6755 static double coef[ncoef] = {
6756 0.0e0,0.0833333333333333333333333333333e0,
6757 -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0,
6758 -0.000595238095238095238095238095238e0,
6759 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0,
6760 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0,
6761 0.179644372368830573164938490016e0
6762 };
6763 static int K1 = 10;
6764 static double dstrem,sterl,T2;
6765 /*
6766 ..
6767 .. Executable Statements ..
6768 */
6769 /*
6770 For information, here are the next 11 coefficients of the
6771 remainder term in Sterling's formula
6772 -1.39243221690590111642743221691
6773 13.4028640441683919944789510007
6774 -156.848284626002017306365132452
6775 2193.10333333333333333333333333
6776 -36108.7712537249893571732652192
6777 691472.268851313067108395250776
6778 -0.152382215394074161922833649589D8
6779 0.382900751391414141414141414141D9
6780 -0.108822660357843910890151491655D11
6781 0.347320283765002252252252252252D12
6782 -0.123696021422692744542517103493D14
6783 */
6784 if(*z <= 0.0e0) ftnstop("Zero or negative argument in DSTREM");
6785 if(!(*z > 6.0e0)) goto S10;
6786 T2 = 1.0e0/pow(*z,2.0);
6787 dstrem = devlpl(coef,&K1,&T2)**z;
6788 goto S20;
6789 S10:
6790 sterl = hln2pi+(*z-0.5e0)*log(*z)-*z;
6791 dstrem = dlngam(z)-sterl;
6792 S20:
6793 return dstrem;
6794 #undef hln2pi
6795 #undef ncoef
6796 }
dt1(double * p,double * q,double * df)6797 double dt1(double *p,double *q,double *df)
6798 /*
6799 **********************************************************************
6800
6801 double dt1(double *p,double *q,double *df)
6802 Double precision Initalize Approximation to
6803 INVerse of the cumulative T distribution
6804
6805
6806 Function
6807
6808
6809 Returns the inverse of the T distribution function, i.e.,
6810 the integral from 0 to INVT of the T density is P. This is an
6811 initial approximation
6812
6813
6814 Arguments
6815
6816
6817 P --> The p-value whose inverse from the T distribution is
6818 desired.
6819 P is DOUBLE PRECISION
6820
6821 Q --> 1-P.
6822 Q is DOUBLE PRECISION
6823
6824 DF --> Degrees of freedom of the T distribution.
6825 DF is DOUBLE PRECISION
6826
6827 **********************************************************************
6828 */
6829 {
6830 static double coef[4][5] = {
6831 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0,
6832 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0
6833 };
6834 static double denom[4] = {
6835 4.0e0,96.0e0,384.0e0,92160.0e0
6836 };
6837 static int ideg[4] = {
6838 2,3,4,5
6839 };
6840 static double dt1,denpow,sum,term,x,xp,xx;
6841 static int i;
6842 /*
6843 ..
6844 .. Executable Statements ..
6845 */
6846 x = fabs(dinvnr(p,q));
6847 xx = x*x;
6848 sum = x;
6849 denpow = 1.0e0;
6850 for(i=0; i<4; i++) {
6851 term = devlpl(&coef[i][0],&ideg[i],&xx)*x;
6852 denpow *= *df;
6853 sum += (term/(denpow*denom[i]));
6854 }
6855 if(!(*p >= 0.5e0)) goto S20;
6856 xp = sum;
6857 goto S30;
6858 S20:
6859 xp = -sum;
6860 S30:
6861 dt1 = xp;
6862 return dt1;
6863 }
6864 /* DEFINE DZROR */
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)6865 static void E0001(int IENTRY,int *status,double *x,double *fx,
6866 double *xlo,double *xhi,unsigned long *qleft,
6867 unsigned long *qhi,double *zabstl,double *zreltl,
6868 double *zxhi,double *zxlo)
6869 {
6870 #define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx))))
6871 static double a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo;
6872 static int ext,i99999;
6873 static unsigned long first,qrzero;
6874 switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;}
6875 DZROR:
6876 if(*status > 0) goto S280;
6877 *xlo = xxlo;
6878 *xhi = xxhi;
6879 b = *x = *xlo;
6880 /*
6881 GET-FUNCTION-VALUE
6882 */
6883 i99999 = 1;
6884 goto S270;
6885 S10:
6886 fb = *fx;
6887 *xlo = *xhi;
6888 a = *x = *xlo;
6889 /*
6890 GET-FUNCTION-VALUE
6891 */
6892 i99999 = 2;
6893 goto S270;
6894 S20:
6895 /*
6896 Check that F(ZXLO) < 0 < F(ZXHI) or
6897 F(ZXLO) > 0 > F(ZXHI)
6898 */
6899 if(!(fb < 0.0e0)) goto S40;
6900 if(!(*fx < 0.0e0)) goto S30;
6901 *status = -1;
6902 *qleft = *fx < fb;
6903 *qhi = 0;
6904 return;
6905 S40:
6906 S30:
6907 if(!(fb > 0.0e0)) goto S60;
6908 if(!(*fx > 0.0e0)) goto S50;
6909 *status = -1;
6910 *qleft = *fx > fb;
6911 *qhi = 1;
6912 return;
6913 S60:
6914 S50:
6915 fa = *fx;
6916 first = 1;
6917 S70:
6918 c = a;
6919 fc = fa;
6920 ext = 0;
6921 S80:
6922 if(!(fabs(fc) < fabs(fb))) goto S100;
6923 if(!(c != a)) goto S90;
6924 d = a;
6925 fd = fa;
6926 S90:
6927 a = b;
6928 fa = fb;
6929 *xlo = c;
6930 b = *xlo;
6931 fb = fc;
6932 c = a;
6933 fc = fa;
6934 S100:
6935 tol = ftol(*xlo);
6936 m = (c+b)*.5e0;
6937 mb = m-b;
6938 if(!(fabs(mb) > tol)) goto S240;
6939 if(!(ext > 3)) goto S110;
6940 w = mb;
6941 goto S190;
6942 S110:
6943 tol = fifdsign(tol,mb);
6944 p = (b-a)*fb;
6945 if(!first) goto S120;
6946 q = fa-fb;
6947 first = 0;
6948 goto S130;
6949 S120:
6950 fdb = (fd-fb)/(d-b);
6951 fda = (fd-fa)/(d-a);
6952 p = fda*p;
6953 q = fdb*fa-fda*fb;
6954 S130:
6955 if(!(p < 0.0e0)) goto S140;
6956 p = -p;
6957 q = -q;
6958 S140:
6959 if(ext == 3) p *= 2.0e0;
6960 if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150;
6961 w = tol;
6962 goto S180;
6963 S150:
6964 if(!(p < mb*q)) goto S160;
6965 w = p/q;
6966 goto S170;
6967 S160:
6968 w = mb;
6969 S190:
6970 S180:
6971 S170:
6972 d = a;
6973 fd = fa;
6974 a = b;
6975 fa = fb;
6976 b += w;
6977 *xlo = b;
6978 *x = *xlo;
6979 /*
6980 GET-FUNCTION-VALUE
6981 */
6982 i99999 = 3;
6983 goto S270;
6984 S200:
6985 fb = *fx;
6986 if(!(fc*fb >= 0.0e0)) goto S210;
6987 goto S70;
6988 S210:
6989 if(!(w == mb)) goto S220;
6990 ext = 0;
6991 goto S230;
6992 S220:
6993 ext += 1;
6994 S230:
6995 goto S80;
6996 S240:
6997 *xhi = c;
6998 qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0;
6999 if(!qrzero) goto S250;
7000 *status = 0;
7001 goto S260;
7002 S250:
7003 *status = -1;
7004 S260:
7005 return;
7006 DSTZR:
7007 xxlo = *zxlo;
7008 xxhi = *zxhi;
7009 abstol = *zabstl;
7010 reltol = *zreltl;
7011 return;
7012 S270:
7013 /*
7014 TO GET-FUNCTION-VALUE
7015 */
7016 *status = 1;
7017 return;
7018 S280:
7019 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200;
7020 default: break;}
7021 #undef ftol
7022 }
dzror(int * status,double * x,double * fx,double * xlo,double * xhi,unsigned long * qleft,unsigned long * qhi)7023 void dzror(int *status,double *x,double *fx,double *xlo,
7024 double *xhi,unsigned long *qleft,unsigned long *qhi)
7025 /*
7026 **********************************************************************
7027
7028 void dzror(int *status,double *x,double *fx,double *xlo,
7029 double *xhi,unsigned long *qleft,unsigned long *qhi)
7030
7031 Double precision ZeRo of a function -- Reverse Communication
7032
7033
7034 Function
7035
7036
7037 Performs the zero finding. STZROR must have been called before
7038 this routine in order to set its parameters.
7039
7040
7041 Arguments
7042
7043
7044 STATUS <--> At the beginning of a zero finding problem, STATUS
7045 should be set to 0 and ZROR invoked. (The value
7046 of other parameters will be ignored on this call.)
7047
7048 When ZROR needs the function evaluated, it will set
7049 STATUS to 1 and return. The value of the function
7050 should be set in FX and ZROR again called without
7051 changing any of its other parameters.
7052
7053 When ZROR has finished without error, it will return
7054 with STATUS 0. In that case (XLO,XHI) bound the answe
7055
7056 If ZROR finds an error (which implies that F(XLO)-Y an
7057 F(XHI)-Y have the same sign, it returns STATUS -1. In
7058 this case, XLO and XHI are undefined.
7059 INTEGER STATUS
7060
7061 X <-- The value of X at which F(X) is to be evaluated.
7062 DOUBLE PRECISION X
7063
7064 FX --> The value of F(X) calculated when ZROR returns with
7065 STATUS = 1.
7066 DOUBLE PRECISION FX
7067
7068 XLO <-- When ZROR returns with STATUS = 0, XLO bounds the
7069 inverval in X containing the solution below.
7070 DOUBLE PRECISION XLO
7071
7072 XHI <-- When ZROR returns with STATUS = 0, XHI bounds the
7073 inverval in X containing the solution above.
7074 DOUBLE PRECISION XHI
7075
7076 QLEFT <-- .TRUE. if the stepping search terminated unsucessfully
7077 at XLO. If it is .FALSE. the search terminated
7078 unsucessfully at XHI.
7079 QLEFT is LOGICAL
7080
7081 QHI <-- .TRUE. if F(X) .GT. Y at the termination of the
7082 search and .FALSE. if F(X) .LT. Y at the
7083 termination of the search.
7084 QHI is LOGICAL
7085
7086 **********************************************************************
7087 */
7088 {
7089 E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL);
7090 }
dstzr(double * zxlo,double * zxhi,double * zabstl,double * zreltl)7091 void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl)
7092 /*
7093 **********************************************************************
7094 void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl)
7095 Double precision SeT ZeRo finder - Reverse communication version
7096 Function
7097 Sets quantities needed by ZROR. The function of ZROR
7098 and the quantities set is given here.
7099 Concise Description - Given a function F
7100 find XLO such that F(XLO) = 0.
7101 More Precise Description -
7102 Input condition. F is a double precision function of a single
7103 double precision argument and XLO and XHI are such that
7104 F(XLO)*F(XHI) .LE. 0.0
7105 If the input condition is met, QRZERO returns .TRUE.
7106 and output values of XLO and XHI satisfy the following
7107 F(XLO)*F(XHI) .LE. 0.
7108 ABS(F(XLO) .LE. ABS(F(XHI)
7109 ABS(XLO-XHI) .LE. TOL(X)
7110 where
7111 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
7112 If this algorithm does not find XLO and XHI satisfying
7113 these conditions then QRZERO returns .FALSE. This
7114 implies that the input condition was not met.
7115 Arguments
7116 XLO --> The left endpoint of the interval to be
7117 searched for a solution.
7118 XLO is DOUBLE PRECISION
7119 XHI --> The right endpoint of the interval to be
7120 for a solution.
7121 XHI is DOUBLE PRECISION
7122 ABSTOL, RELTOL --> Two numbers that determine the accuracy
7123 of the solution. See function for a
7124 precise definition.
7125 ABSTOL is DOUBLE PRECISION
7126 RELTOL is DOUBLE PRECISION
7127 Method
7128 Algorithm R of the paper 'Two Efficient Algorithms with
7129 Guaranteed Convergence for Finding a Zero of a Function'
7130 by J. C. P. Bus and T. J. Dekker in ACM Transactions on
7131 Mathematical Software, Volume 1, no. 4 page 330
7132 (Dec. '75) is employed to find the zero of F(X)-Y.
7133 **********************************************************************
7134 */
7135 {
7136 E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo);
7137 }
erf1(double * x)7138 double erf1(double *x)
7139 /*
7140 -----------------------------------------------------------------------
7141 EVALUATION OF THE REAL ERROR FUNCTION
7142 -----------------------------------------------------------------------
7143 */
7144 {
7145 static double c = .564189583547756e0;
7146 static double a[5] = {
7147 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7148 .479137145607681e-01,.128379167095513e+00
7149 };
7150 static double b[3] = {
7151 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7152 };
7153 static double p[8] = {
7154 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7155 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7156 4.51918953711873e+02,3.00459261020162e+02
7157 };
7158 static double q[8] = {
7159 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7160 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7161 7.90950925327898e+02,3.00459260956983e+02
7162 };
7163 static double r[5] = {
7164 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7165 4.65807828718470e+00,2.82094791773523e-01
7166 };
7167 static double s[4] = {
7168 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7169 1.80124575948747e+01
7170 };
7171 static double erf1,ax,bot,t,top,x2;
7172 /*
7173 ..
7174 .. Executable Statements ..
7175 */
7176 ax = fabs(*x);
7177 if(ax > 0.5e0) goto S10;
7178 t = *x**x;
7179 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7180 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7181 erf1 = *x*(top/bot);
7182 return erf1;
7183 S10:
7184 if(ax > 4.0e0) goto S20;
7185 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7186 7];
7187 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7188 7];
7189 erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot);
7190 if(*x < 0.0e0) erf1 = -erf1;
7191 return erf1;
7192 S20:
7193 if(ax >= 5.8e0) goto S30;
7194 x2 = *x**x;
7195 t = 1.0e0/x2;
7196 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7197 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7198 erf1 = (c-top/(x2*bot))/ax;
7199 erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1);
7200 if(*x < 0.0e0) erf1 = -erf1;
7201 return erf1;
7202 S30:
7203 erf1 = fifdsign(1.0e0,*x);
7204 return erf1;
7205 }
erfc1(int * ind,double * x)7206 double erfc1(int *ind,double *x)
7207 /*
7208 -----------------------------------------------------------------------
7209 EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
7210
7211 ERFC1(IND,X) = ERFC(X) IF IND = 0
7212 ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE
7213 -----------------------------------------------------------------------
7214 */
7215 {
7216 static double c = .564189583547756e0;
7217 static double a[5] = {
7218 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7219 .479137145607681e-01,.128379167095513e+00
7220 };
7221 static double b[3] = {
7222 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7223 };
7224 static double p[8] = {
7225 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7226 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7227 4.51918953711873e+02,3.00459261020162e+02
7228 };
7229 static double q[8] = {
7230 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7231 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7232 7.90950925327898e+02,3.00459260956983e+02
7233 };
7234 static double r[5] = {
7235 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7236 4.65807828718470e+00,2.82094791773523e-01
7237 };
7238 static double s[4] = {
7239 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7240 1.80124575948747e+01
7241 };
7242 static int K1 = 1;
7243 static double erfc1,ax,bot,e,t,top,w;
7244 /*
7245 ..
7246 .. Executable Statements ..
7247 */
7248 /*
7249 ABS(X) .LE. 0.5
7250 */
7251 ax = fabs(*x);
7252 if(ax > 0.5e0) goto S10;
7253 t = *x**x;
7254 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7255 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7256 erfc1 = 0.5e0+(0.5e0-*x*(top/bot));
7257 if(*ind != 0) erfc1 = exp(t)*erfc1;
7258 return erfc1;
7259 S10:
7260 /*
7261 0.5 .LT. ABS(X) .LE. 4
7262 */
7263 if(ax > 4.0e0) goto S20;
7264 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7265 7];
7266 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7267 7];
7268 erfc1 = top/bot;
7269 goto S40;
7270 S20:
7271 /*
7272 ABS(X) .GT. 4
7273 */
7274 if(*x <= -5.6e0) goto S60;
7275 if(*ind != 0) goto S30;
7276 if(*x > 100.0e0) goto S70;
7277 if(*x**x > -exparg(&K1)) goto S70;
7278 S30:
7279 t = pow(1.0e0/ *x,2.0);
7280 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7281 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7282 erfc1 = (c-t*top/bot)/ax;
7283 S40:
7284 /*
7285 FINAL ASSEMBLY
7286 */
7287 if(*ind == 0) goto S50;
7288 if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1;
7289 return erfc1;
7290 S50:
7291 w = *x**x;
7292 t = w;
7293 e = w-t;
7294 erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1;
7295 if(*x < 0.0e0) erfc1 = 2.0e0-erfc1;
7296 return erfc1;
7297 S60:
7298 /*
7299 LIMIT VALUE FOR LARGE NEGATIVE X
7300 */
7301 erfc1 = 2.0e0;
7302 if(*ind != 0) erfc1 = 2.0e0*exp(*x**x);
7303 return erfc1;
7304 S70:
7305 /*
7306 LIMIT VALUE FOR LARGE POSITIVE X
7307 WHEN IND = 0
7308 */
7309 erfc1 = 0.0e0;
7310 return erfc1;
7311 }
esum(int * mu,double * x)7312 double esum(int *mu,double *x)
7313 /*
7314 -----------------------------------------------------------------------
7315 EVALUATION OF EXP(MU + X)
7316 -----------------------------------------------------------------------
7317 */
7318 {
7319 static double esum,w;
7320 /*
7321 ..
7322 .. Executable Statements ..
7323 */
7324 if(*x > 0.0e0) goto S10;
7325 if(*mu < 0) goto S20;
7326 w = (double)*mu+*x;
7327 if(w > 0.0e0) goto S20;
7328 esum = exp(w);
7329 return esum;
7330 S10:
7331 if(*mu > 0) goto S20;
7332 w = (double)*mu+*x;
7333 if(w < 0.0e0) goto S20;
7334 esum = exp(w);
7335 return esum;
7336 S20:
7337 w = *mu;
7338 esum = exp(w)*exp(*x);
7339 return esum;
7340 }
exparg(int * l)7341 double exparg(int *l)
7342 /*
7343 --------------------------------------------------------------------
7344 IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
7345 EXP(W) CAN BE COMPUTED.
7346
7347 IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR
7348 WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
7349
7350 NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED.
7351 --------------------------------------------------------------------
7352 */
7353 {
7354 static int K1 = 4;
7355 static int K2 = 9;
7356 static int K3 = 10;
7357 static double exparg,lnb;
7358 static int b,m;
7359 /*
7360 ..
7361 .. Executable Statements ..
7362 */
7363 b = ipmpar(&K1);
7364 if(b != 2) goto S10;
7365 lnb = .69314718055995e0;
7366 goto S40;
7367 S10:
7368 if(b != 8) goto S20;
7369 lnb = 2.0794415416798e0;
7370 goto S40;
7371 S20:
7372 if(b != 16) goto S30;
7373 lnb = 2.7725887222398e0;
7374 goto S40;
7375 S30:
7376 lnb = log((double)b);
7377 S40:
7378 if(*l == 0) goto S50;
7379 m = ipmpar(&K2)-1;
7380 exparg = 0.99999e0*((double)m*lnb);
7381 return exparg;
7382 S50:
7383 m = ipmpar(&K3);
7384 exparg = 0.99999e0*((double)m*lnb);
7385 return exparg;
7386 }
fpser(double * a,double * b,double * x,double * eps)7387 double fpser(double *a,double *b,double *x,double *eps)
7388 /*
7389 -----------------------------------------------------------------------
7390
7391 EVALUATION OF I (A,B)
7392 X
7393
7394 FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5.
7395
7396 -----------------------------------------------------------------------
7397
7398 SET FPSER = X**A
7399 */
7400 {
7401 static int K1 = 1;
7402 static double fpser,an,c,s,t,tol;
7403 /*
7404 ..
7405 .. Executable Statements ..
7406 */
7407 fpser = 1.0e0;
7408 if(*a <= 1.e-3**eps) goto S10;
7409 fpser = 0.0e0;
7410 t = *a*log(*x);
7411 if(t < exparg(&K1)) return fpser;
7412 fpser = exp(t);
7413 S10:
7414 /*
7415 NOTE THAT 1/B(A,B) = B
7416 */
7417 fpser = *b/ *a*fpser;
7418 tol = *eps/ *a;
7419 an = *a+1.0e0;
7420 t = *x;
7421 s = t/an;
7422 S20:
7423 an += 1.0e0;
7424 t = *x*t;
7425 c = t/an;
7426 s += c;
7427 if(fabs(c) > tol) goto S20;
7428 fpser *= (1.0e0+*a*s);
7429 return fpser;
7430 }
gam1(double * a)7431 double gam1(double *a)
7432 /*
7433 ------------------------------------------------------------------
7434 COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5
7435 ------------------------------------------------------------------
7436 */
7437 {
7438 static double s1 = .273076135303957e+00;
7439 static double s2 = .559398236957378e-01;
7440 static double p[7] = {
7441 .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00,
7442 .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02,
7443 .589597428611429e-03
7444 };
7445 static double q[5] = {
7446 .100000000000000e+01,.427569613095214e+00,.158451672430138e+00,
7447 .261132021441447e-01,.423244297896961e-02
7448 };
7449 static double r[9] = {
7450 -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00,
7451 .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01,
7452 .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03
7453 };
7454 static double gam1,bot,d,t,top,w,T1;
7455 /*
7456 ..
7457 .. Executable Statements ..
7458 */
7459 t = *a;
7460 d = *a-0.5e0;
7461 if(d > 0.0e0) t = d-0.5e0;
7462 T1 = t;
7463 if(T1 < 0) goto S40;
7464 else if(T1 == 0) goto S10;
7465 else goto S20;
7466 S10:
7467 gam1 = 0.0e0;
7468 return gam1;
7469 S20:
7470 top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0];
7471 bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0;
7472 w = top/bot;
7473 if(d > 0.0e0) goto S30;
7474 gam1 = *a*w;
7475 return gam1;
7476 S30:
7477 gam1 = t/ *a*(w-0.5e0-0.5e0);
7478 return gam1;
7479 S40:
7480 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+
7481 r[0];
7482 bot = (s2*t+s1)*t+1.0e0;
7483 w = top/bot;
7484 if(d > 0.0e0) goto S50;
7485 gam1 = *a*(w+0.5e0+0.5e0);
7486 return gam1;
7487 S50:
7488 gam1 = t*w/ *a;
7489 return gam1;
7490 }
gaminv(double * a,double * x,double * x0,double * p,double * q,int * ierr)7491 void gaminv(double *a,double *x,double *x0,double *p,double *q,
7492 int *ierr)
7493 /*
7494 ----------------------------------------------------------------------
7495 INVERSE INCOMPLETE GAMMA RATIO FUNCTION
7496
7497 GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1.
7498 THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER
7499 ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X
7500 TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE
7501 PARTICULAR COMPUTER ARITHMETIC BEING USED.
7502
7503 ------------
7504
7505 X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0,
7506 AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT
7507 NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN
7508 A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE
7509 IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X.
7510
7511 X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER
7512 DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET
7513 X0 .LE. 0.
7514
7515 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
7516 WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING
7517 VALUES ...
7518
7519 IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS
7520 NOT USED.
7521 IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS
7522 WERE PERFORMED.
7523 IERR = -2 (INPUT ERROR) A .LE. 0
7524 IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A
7525 IS TOO LARGE.
7526 IERR = -4 (INPUT ERROR) P + Q .NE. 1
7527 IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST
7528 RECENT VALUE OBTAINED FOR X IS GIVEN.
7529 THIS CANNOT OCCUR IF X0 .LE. 0.
7530 IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X.
7531 THIS MAY OCCUR WHEN X IS APPROXIMATELY 0.
7532 IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE
7533 ROUTINE IS NOT CERTAIN OF ITS ACCURACY.
7534 ITERATION CANNOT BE PERFORMED IN THIS
7535 CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY
7536 WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS
7537 POSITIVE THEN THIS CAN OCCUR WHEN A IS
7538 EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY
7539 LARGE (SAY A .GE. 1.E20).
7540 ----------------------------------------------------------------------
7541 WRITTEN BY ALFRED H. MORRIS, JR.
7542 NAVAL SURFACE WEAPONS CENTER
7543 DAHLGREN, VIRGINIA
7544 -------------------
7545 */
7546 {
7547 static double a0 = 3.31125922108741e0;
7548 static double a1 = 11.6616720288968e0;
7549 static double a2 = 4.28342155967104e0;
7550 static double a3 = .213623493715853e0;
7551 static double b1 = 6.61053765625462e0;
7552 static double b2 = 6.40691597760039e0;
7553 static double b3 = 1.27364489782223e0;
7554 static double b4 = .036117081018842e0;
7555 static double c = .577215664901533e0;
7556 static double ln10 = 2.302585e0;
7557 static double tol = 1.e-5;
7558 static double amin[2] = {
7559 500.0e0,100.0e0
7560 };
7561 static double bmin[2] = {
7562 1.e-28,1.e-13
7563 };
7564 static double dmin[2] = {
7565 1.e-06,1.e-04
7566 };
7567 static double emin[2] = {
7568 2.e-03,6.e-03
7569 };
7570 static double eps0[2] = {
7571 1.e-10,1.e-08
7572 };
7573 static int K1 = 1;
7574 static int K2 = 2;
7575 static int K3 = 3;
7576 static int K8 = 0;
7577 static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn,
7578 r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z;
7579 static int iop;
7580 static double T4,T5,T6,T7,T9;
7581 /*
7582 ..
7583 .. Executable Statements ..
7584 */
7585 /*
7586 ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.
7587 E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.
7588 XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE
7589 LARGEST POSITIVE NUMBER.
7590 */
7591 e = spmpar(&K1);
7592 xmin = spmpar(&K2);
7593 xmax = spmpar(&K3);
7594 *x = 0.0e0;
7595 if(*a <= 0.0e0) goto S300;
7596 t = *p+*q-1.e0;
7597 if(fabs(t) > e) goto S320;
7598 *ierr = 0;
7599 if(*p == 0.0e0) return;
7600 if(*q == 0.0e0) goto S270;
7601 if(*a == 1.0e0) goto S280;
7602 e2 = 2.0e0*e;
7603 amax = 0.4e-10/(e*e);
7604 iop = 1;
7605 if(e > 1.e-10) iop = 2;
7606 eps = eps0[iop-1];
7607 xn = *x0;
7608 if(*x0 > 0.0e0) goto S160;
7609 /*
7610 SELECTION OF THE INITIAL APPROXIMATION XN OF X
7611 WHEN A .LT. 1
7612 */
7613 if(*a > 1.0e0) goto S80;
7614 T4 = *a+1.0e0;
7615 g = Xgamm(&T4);
7616 qg = *q*g;
7617 if(qg == 0.0e0) goto S360;
7618 b = qg/ *a;
7619 if(qg > 0.6e0**a) goto S40;
7620 if(*a >= 0.30e0 || b < 0.35e0) goto S10;
7621 t = exp(-(b+c));
7622 u = t*exp(t);
7623 xn = t*exp(u);
7624 goto S160;
7625 S10:
7626 if(b >= 0.45e0) goto S40;
7627 if(b == 0.0e0) goto S360;
7628 y = -log(b);
7629 s = 0.5e0+(0.5e0-*a);
7630 z = log(y);
7631 t = y-s*z;
7632 if(b < 0.15e0) goto S20;
7633 xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0));
7634 goto S220;
7635 S20:
7636 if(b <= 0.01e0) goto S30;
7637 u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0);
7638 xn = y-s*log(t)-log(u);
7639 goto S220;
7640 S30:
7641 c1 = -(s*z);
7642 c2 = -(s*(1.0e0+c1));
7643 c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a));
7644 c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+(
7645 (11.0e0**a-46.0)**a+47.0e0)/6.0e0));
7646 c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)*
7647 *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+((
7648 (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0));
7649 xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y;
7650 if(*a > 1.0e0) goto S220;
7651 if(b > bmin[iop-1]) goto S220;
7652 *x = xn;
7653 return;
7654 S40:
7655 if(b**q > 1.e-8) goto S50;
7656 xn = exp(-(*q/ *a+c));
7657 goto S70;
7658 S50:
7659 if(*p <= 0.9e0) goto S60;
7660 T5 = -*q;
7661 xn = exp((alnrel(&T5)+gamln1(a))/ *a);
7662 goto S70;
7663 S60:
7664 xn = exp(log(*p*g)/ *a);
7665 S70:
7666 if(xn == 0.0e0) goto S310;
7667 t = 0.5e0+(0.5e0-xn/(*a+1.0e0));
7668 xn /= t;
7669 goto S160;
7670 S80:
7671 /*
7672 SELECTION OF THE INITIAL APPROXIMATION XN OF X
7673 WHEN A .GT. 1
7674 */
7675 if(*q <= 0.5e0) goto S90;
7676 w = log(*p);
7677 goto S100;
7678 S90:
7679 w = log(*q);
7680 S100:
7681 t = sqrt(-(2.0e0*w));
7682 s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0);
7683 if(*q > 0.5e0) s = -s;
7684 rta = sqrt(*a);
7685 s2 = s*s;
7686 xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)*
7687 s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a*
7688 rta);
7689 xn = fifdmax1(xn,0.0e0);
7690 if(*a < amin[iop-1]) goto S110;
7691 *x = xn;
7692 d = 0.5e0+(0.5e0-*x/ *a);
7693 if(fabs(d) <= dmin[iop-1]) return;
7694 S110:
7695 if(*p <= 0.5e0) goto S130;
7696 if(xn < 3.0e0**a) goto S220;
7697 y = -(w+gamln(a));
7698 d = fifdmax1(2.0e0,*a*(*a-1.0e0));
7699 if(y < ln10*d) goto S120;
7700 s = 1.0e0-*a;
7701 z = log(y);
7702 goto S30;
7703 S120:
7704 t = *a-1.0e0;
7705 T6 = -(t/(xn+1.0e0));
7706 xn = y+t*log(xn)-alnrel(&T6);
7707 T7 = -(t/(xn+1.0e0));
7708 xn = y+t*log(xn)-alnrel(&T7);
7709 goto S220;
7710 S130:
7711 ap1 = *a+1.0e0;
7712 if(xn > 0.70e0*ap1) goto S170;
7713 w += gamln(&ap1);
7714 if(xn > 0.15e0*ap1) goto S140;
7715 ap2 = *a+2.0e0;
7716 ap3 = *a+3.0e0;
7717 *x = exp((w+*x)/ *a);
7718 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
7719 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
7720 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a);
7721 xn = *x;
7722 if(xn > 1.e-2*ap1) goto S140;
7723 if(xn <= emin[iop-1]*ap1) return;
7724 goto S170;
7725 S140:
7726 apn = ap1;
7727 t = xn/apn;
7728 sum = 1.0e0+t;
7729 S150:
7730 apn += 1.0e0;
7731 t *= (xn/apn);
7732 sum += t;
7733 if(t > 1.e-4) goto S150;
7734 t = w-log(sum);
7735 xn = exp((xn+t)/ *a);
7736 xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn));
7737 goto S170;
7738 S160:
7739 /*
7740 SCHRODER ITERATION USING P
7741 */
7742 if(*p > 0.5e0) goto S220;
7743 S170:
7744 if(*p <= 1.e10*xmin) goto S350;
7745 am1 = *a-0.5e0-0.5e0;
7746 S180:
7747 if(*a <= amax) goto S190;
7748 d = 0.5e0+(0.5e0-xn/ *a);
7749 if(fabs(d) <= e2) goto S350;
7750 S190:
7751 if(*ierr >= 20) goto S330;
7752 *ierr += 1;
7753 gratio(a,&xn,&pn,&qn,&K8);
7754 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
7755 r = rcomp(a,&xn);
7756 if(r == 0.0e0) goto S350;
7757 t = (pn-*p)/r;
7758 w = 0.5e0*(am1-xn);
7759 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200;
7760 *x = xn*(1.0e0-t);
7761 if(*x <= 0.0e0) goto S340;
7762 d = fabs(t);
7763 goto S210;
7764 S200:
7765 h = t*(1.0e0+w*t);
7766 *x = xn*(1.0e0-h);
7767 if(*x <= 0.0e0) goto S340;
7768 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
7769 d = fabs(h);
7770 S210:
7771 xn = *x;
7772 if(d > tol) goto S180;
7773 if(d <= eps) return;
7774 if(fabs(*p-pn) <= tol**p) return;
7775 goto S180;
7776 S220:
7777 /*
7778 SCHRODER ITERATION USING Q
7779 */
7780 if(*q <= 1.e10*xmin) goto S350;
7781 am1 = *a-0.5e0-0.5e0;
7782 S230:
7783 if(*a <= amax) goto S240;
7784 d = 0.5e0+(0.5e0-xn/ *a);
7785 if(fabs(d) <= e2) goto S350;
7786 S240:
7787 if(*ierr >= 20) goto S330;
7788 *ierr += 1;
7789 gratio(a,&xn,&pn,&qn,&K8);
7790 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
7791 r = rcomp(a,&xn);
7792 if(r == 0.0e0) goto S350;
7793 t = (*q-qn)/r;
7794 w = 0.5e0*(am1-xn);
7795 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250;
7796 *x = xn*(1.0e0-t);
7797 if(*x <= 0.0e0) goto S340;
7798 d = fabs(t);
7799 goto S260;
7800 S250:
7801 h = t*(1.0e0+w*t);
7802 *x = xn*(1.0e0-h);
7803 if(*x <= 0.0e0) goto S340;
7804 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
7805 d = fabs(h);
7806 S260:
7807 xn = *x;
7808 if(d > tol) goto S230;
7809 if(d <= eps) return;
7810 if(fabs(*q-qn) <= tol**q) return;
7811 goto S230;
7812 S270:
7813 /*
7814 SPECIAL CASES
7815 */
7816 *x = xmax;
7817 return;
7818 S280:
7819 if(*q < 0.9e0) goto S290;
7820 T9 = -*p;
7821 *x = -alnrel(&T9);
7822 return;
7823 S290:
7824 *x = -log(*q);
7825 return;
7826 S300:
7827 /*
7828 ERROR RETURN
7829 */
7830 *ierr = -2;
7831 return;
7832 S310:
7833 *ierr = -3;
7834 return;
7835 S320:
7836 *ierr = -4;
7837 return;
7838 S330:
7839 *ierr = -6;
7840 return;
7841 S340:
7842 *ierr = -7;
7843 return;
7844 S350:
7845 *x = xn;
7846 *ierr = -8;
7847 return;
7848 S360:
7849 *x = xmax;
7850 *ierr = -8;
7851 return;
7852 }
gamln(double * a)7853 double gamln(double *a)
7854 /*
7855 -----------------------------------------------------------------------
7856 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
7857 -----------------------------------------------------------------------
7858 WRITTEN BY ALFRED H. MORRIS
7859 NAVAL SURFACE WARFARE CENTER
7860 DAHLGREN, VIRGINIA
7861 --------------------------
7862 D = 0.5*(LN(2*PI) - 1)
7863 --------------------------
7864 */
7865 {
7866 static double c0 = .833333333333333e-01;
7867 static double c1 = -.277777777760991e-02;
7868 static double c2 = .793650666825390e-03;
7869 static double c3 = -.595202931351870e-03;
7870 static double c4 = .837308034031215e-03;
7871 static double c5 = -.165322962780713e-02;
7872 static double d = .418938533204673e0;
7873 static double gamln,t,w;
7874 static int i,n;
7875 static double T1;
7876 /*
7877 ..
7878 .. Executable Statements ..
7879 */
7880 if(*a > 0.8e0) goto S10;
7881 gamln = gamln1(a)-log(*a);
7882 return gamln;
7883 S10:
7884 if(*a > 2.25e0) goto S20;
7885 t = *a-0.5e0-0.5e0;
7886 gamln = gamln1(&t);
7887 return gamln;
7888 S20:
7889 if(*a >= 10.0e0) goto S40;
7890 n = int(*a-1.25e0);
7891 t = *a;
7892 w = 1.0e0;
7893 for(i=1; i<=n; i++) {
7894 t -= 1.0e0;
7895 w = t*w;
7896 }
7897 T1 = t-1.0e0;
7898 gamln = gamln1(&T1)+log(w);
7899 return gamln;
7900 S40:
7901 t = pow(1.0e0/ *a,2.0);
7902 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
7903 gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
7904 return gamln;
7905 }
gamln1(double * a)7906 double gamln1(double *a)
7907 /*
7908 -----------------------------------------------------------------------
7909 EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25
7910 -----------------------------------------------------------------------
7911 */
7912 {
7913 static double p0 = .577215664901533e+00;
7914 static double p1 = .844203922187225e+00;
7915 static double p2 = -.168860593646662e+00;
7916 static double p3 = -.780427615533591e+00;
7917 static double p4 = -.402055799310489e+00;
7918 static double p5 = -.673562214325671e-01;
7919 static double p6 = -.271935708322958e-02;
7920 static double q1 = .288743195473681e+01;
7921 static double q2 = .312755088914843e+01;
7922 static double q3 = .156875193295039e+01;
7923 static double q4 = .361951990101499e+00;
7924 static double q5 = .325038868253937e-01;
7925 static double q6 = .667465618796164e-03;
7926 static double r0 = .422784335098467e+00;
7927 static double r1 = .848044614534529e+00;
7928 static double r2 = .565221050691933e+00;
7929 static double r3 = .156513060486551e+00;
7930 static double r4 = .170502484022650e-01;
7931 static double r5 = .497958207639485e-03;
7932 static double s1 = .124313399877507e+01;
7933 static double s2 = .548042109832463e+00;
7934 static double s3 = .101552187439830e+00;
7935 static double s4 = .713309612391000e-02;
7936 static double s5 = .116165475989616e-03;
7937 static double gamln1,w,x;
7938 /*
7939 ..
7940 .. Executable Statements ..
7941 */
7942 if(*a >= 0.6e0) goto S10;
7943 w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+
7944 q4)**a+q3)**a+q2)**a+q1)**a+1.0e0);
7945 gamln1 = -(*a*w);
7946 return gamln1;
7947 S10:
7948 x = *a-0.5e0-0.5e0;
7949 w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x
7950 +1.0e0);
7951 gamln1 = x*w;
7952 return gamln1;
7953 }
Xgamm(double * a)7954 double Xgamm(double *a)
7955 /*
7956 -----------------------------------------------------------------------
7957
7958 EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS
7959
7960 -----------
7961
7962 GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT
7963 BE COMPUTED.
7964
7965 -----------------------------------------------------------------------
7966 WRITTEN BY ALFRED H. MORRIS, JR.
7967 NAVAL SURFACE WEAPONS CENTER
7968 DAHLGREN, VIRGINIA
7969 -----------------------------------------------------------------------
7970 */
7971 {
7972 static double d = .41893853320467274178e0;
7973 static double pi = 3.1415926535898e0;
7974 static double r1 = .820756370353826e-03;
7975 static double r2 = -.595156336428591e-03;
7976 static double r3 = .793650663183693e-03;
7977 static double r4 = -.277777777770481e-02;
7978 static double r5 = .833333333333333e-01;
7979 static double p[7] = {
7980 .539637273585445e-03,.261939260042690e-02,.204493667594920e-01,
7981 .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0
7982 };
7983 static double q[7] = {
7984 -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01,
7985 -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0
7986 };
7987 static int K2 = 3;
7988 static int K3 = 0;
7989 static double Xgamm,bot,g,lnx,s,t,top,w,x,z;
7990 static int i,j,m,n,T1;
7991 /*
7992 ..
7993 .. Executable Statements ..
7994 */
7995 Xgamm = 0.0e0;
7996 x = *a;
7997 if(fabs(*a) >= 15.0e0) goto S110;
7998 /*
7999 -----------------------------------------------------------------------
8000 EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15
8001 -----------------------------------------------------------------------
8002 */
8003 t = 1.0e0;
8004 m = fifidint(*a)-1;
8005 /*
8006 LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
8007 */
8008 T1 = m;
8009 if(T1 < 0) goto S40;
8010 else if(T1 == 0) goto S30;
8011 else goto S10;
8012 S10:
8013 for(j=1; j<=m; j++) {
8014 x -= 1.0e0;
8015 t = x*t;
8016 }
8017 S30:
8018 x -= 1.0e0;
8019 goto S80;
8020 S40:
8021 /*
8022 LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
8023 */
8024 t = *a;
8025 if(*a > 0.0e0) goto S70;
8026 m = -m-1;
8027 if(m == 0) goto S60;
8028 for(j=1; j<=m; j++) {
8029 x += 1.0e0;
8030 t = x*t;
8031 }
8032 S60:
8033 x += (0.5e0+0.5e0);
8034 t = x*t;
8035 if(t == 0.0e0) return Xgamm;
8036 S70:
8037 /*
8038 THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
8039 CODE MAY BE OMITTED IF DESIRED.
8040 */
8041 if(fabs(t) >= 1.e-30) goto S80;
8042 if(fabs(t)*spmpar(&K2) <= 1.0001e0) return Xgamm;
8043 Xgamm = 1.0e0/t;
8044 return Xgamm;
8045 S80:
8046 /*
8047 COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1
8048 */
8049 top = p[0];
8050 bot = q[0];
8051 for(i=1; i<7; i++) {
8052 top = p[i]+x*top;
8053 bot = q[i]+x*bot;
8054 }
8055 Xgamm = top/bot;
8056 /*
8057 TERMINATION
8058 */
8059 if(*a < 1.0e0) goto S100;
8060 Xgamm *= t;
8061 return Xgamm;
8062 S100:
8063 Xgamm /= t;
8064 return Xgamm;
8065 S110:
8066 /*
8067 -----------------------------------------------------------------------
8068 EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15
8069 -----------------------------------------------------------------------
8070 */
8071 if(fabs(*a) >= 1.e3) return Xgamm;
8072 if(*a > 0.0e0) goto S120;
8073 x = -*a;
8074 n = (int)x;
8075 t = x-(double)n;
8076 if(t > 0.9e0) t = 1.0e0-t;
8077 s = sin(pi*t)/pi;
8078 if(fifmod(n,2) == 0) s = -s;
8079 if(s == 0.0e0) return Xgamm;
8080 S120:
8081 /*
8082 COMPUTE THE MODIFIED ASYMPTOTIC SUM
8083 */
8084 t = 1.0e0/(x*x);
8085 g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x;
8086 /*
8087 ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X)
8088 BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.
8089 */
8090 lnx = log(x);
8091 /*
8092 FINAL ASSEMBLY
8093 */
8094 z = x;
8095 g = d+g+(z-0.5e0)*(lnx-1.e0);
8096 w = g;
8097 t = g-w;
8098 if(w > 0.99999e0*exparg(&K3)) return Xgamm;
8099 Xgamm = exp(w)*(1.0e0+t);
8100 if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x;
8101 return Xgamm;
8102 }
grat1(double * a,double * x,double * r,double * p,double * q,double * eps)8103 void grat1(double *a,double *x,double *r,double *p,double *q,
8104 double *eps)
8105 {
8106 static int K2 = 0;
8107 static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3;
8108 /*
8109 ..
8110 .. Executable Statements ..
8111 */
8112 /*
8113 -----------------------------------------------------------------------
8114 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
8115 P(A,X) AND Q(A,X)
8116 IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED.
8117 THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A).
8118 -----------------------------------------------------------------------
8119 */
8120 if(*a**x == 0.0e0) goto S120;
8121 if(*a == 0.5e0) goto S100;
8122 if(*x < 1.1e0) goto S10;
8123 goto S60;
8124 S10:
8125 /*
8126 TAYLOR SERIES FOR P(A,X)/X**A
8127 */
8128 an = 3.0e0;
8129 c = *x;
8130 sum = *x/(*a+3.0e0);
8131 tol = 0.1e0**eps/(*a+1.0e0);
8132 S20:
8133 an += 1.0e0;
8134 c = -(c*(*x/an));
8135 t = c/(*a+an);
8136 sum += t;
8137 if(fabs(t) > tol) goto S20;
8138 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8139 z = *a*log(*x);
8140 h = gam1(a);
8141 g = 1.0e0+h;
8142 if(*x < 0.25e0) goto S30;
8143 if(*a < *x/2.59e0) goto S50;
8144 goto S40;
8145 S30:
8146 if(z > -.13394e0) goto S50;
8147 S40:
8148 w = exp(z);
8149 *p = w*g*(0.5e0+(0.5e0-j));
8150 *q = 0.5e0+(0.5e0-*p);
8151 return;
8152 S50:
8153 l = rexp(&z);
8154 w = 0.5e0+(0.5e0+l);
8155 *q = (w*j-l)*g-h;
8156 if(*q < 0.0e0) goto S90;
8157 *p = 0.5e0+(0.5e0-*q);
8158 return;
8159 S60:
8160 /*
8161 CONTINUED FRACTION EXPANSION
8162 */
8163 a2nm1 = a2n = 1.0e0;
8164 b2nm1 = *x;
8165 b2n = *x+(1.0e0-*a);
8166 c = 1.0e0;
8167 S70:
8168 a2nm1 = *x*a2n+c*a2nm1;
8169 b2nm1 = *x*b2n+c*b2nm1;
8170 am0 = a2nm1/b2nm1;
8171 c += 1.0e0;
8172 cma = c-*a;
8173 a2n = a2nm1+cma*a2n;
8174 b2n = b2nm1+cma*b2n;
8175 an0 = a2n/b2n;
8176 if(fabs(an0-am0) >= *eps*an0) goto S70;
8177 *q = *r*an0;
8178 *p = 0.5e0+(0.5e0-*q);
8179 return;
8180 S80:
8181 /*
8182 SPECIAL CASES
8183 */
8184 *p = 0.0e0;
8185 *q = 1.0e0;
8186 return;
8187 S90:
8188 *p = 1.0e0;
8189 *q = 0.0e0;
8190 return;
8191 S100:
8192 if(*x >= 0.25e0) goto S110;
8193 T1 = sqrt(*x);
8194 *p = erf1(&T1);
8195 *q = 0.5e0+(0.5e0-*p);
8196 return;
8197 S110:
8198 T3 = sqrt(*x);
8199 *q = erfc1(&K2,&T3);
8200 *p = 0.5e0+(0.5e0-*q);
8201 return;
8202 S120:
8203 if(*x <= *a) goto S80;
8204 goto S90;
8205 }
gratio(double * a,double * x,double * ans,double * qans,int * ind)8206 void gratio(double *a,double *x,double *ans,double *qans,int *ind)
8207 /*
8208 ----------------------------------------------------------------------
8209 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
8210 P(A,X) AND Q(A,X)
8211
8212 ----------
8213
8214 IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X
8215 ARE NOT BOTH 0.
8216
8217 ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE
8218 P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER.
8219 IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS
8220 POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF
8221 IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE
8222 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY
8223 IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT.
8224
8225 ERROR RETURN ...
8226 ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE,
8227 WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT.
8228 P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN
8229 X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE.
8230 ----------------------------------------------------------------------
8231 WRITTEN BY ALFRED H. MORRIS, JR.
8232 NAVAL SURFACE WEAPONS CENTER
8233 DAHLGREN, VIRGINIA
8234 --------------------
8235 */
8236 {
8237 static double alog10 = 2.30258509299405e0;
8238 static double d10 = -.185185185185185e-02;
8239 static double d20 = .413359788359788e-02;
8240 static double d30 = .649434156378601e-03;
8241 static double d40 = -.861888290916712e-03;
8242 static double d50 = -.336798553366358e-03;
8243 static double d60 = .531307936463992e-03;
8244 static double d70 = .344367606892378e-03;
8245 static double rt2pin = .398942280401433e0;
8246 static double rtpi = 1.77245385090552e0;
8247 static double third = .333333333333333e0;
8248 static double acc0[3] = {
8249 5.e-15,5.e-7,5.e-4
8250 };
8251 static double big[3] = {
8252 20.0e0,14.0e0,10.0e0
8253 };
8254 static double d0[13] = {
8255 .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02,
8256 .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04,
8257 -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06,
8258 -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07,
8259 -.438203601845335e-08
8260 };
8261 static double d1[12] = {
8262 -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03,
8263 .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04,
8264 .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08,
8265 .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07
8266 };
8267 static double d2[10] = {
8268 -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05,
8269 -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04,
8270 .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06,
8271 .142806142060642e-06
8272 };
8273 static double d3[8] = {
8274 .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03,
8275 -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04,
8276 -.567495282699160e-05,.142309007324359e-05
8277 };
8278 static double d4[6] = {
8279 .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05,
8280 .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04
8281 };
8282 static double d5[4] = {
8283 -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03,
8284 .679778047793721e-04
8285 };
8286 static double d6[2] = {
8287 -.592166437353694e-03,.270878209671804e-03
8288 };
8289 static double e00[3] = {
8290 .25e-3,.25e-1,.14e0
8291 };
8292 static double x00[3] = {
8293 31.0e0,17.0e0,9.7e0
8294 };
8295 static int K1 = 1;
8296 static int K2 = 0;
8297 static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6,
8298 cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z;
8299 static int i,iop,m,max,n;
8300 static double wk[20],T3;
8301 static int T4,T5;
8302 static double T6,T7;
8303 /*
8304 ..
8305 .. Executable Statements ..
8306 */
8307 /*
8308 --------------------
8309 ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
8310 FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
8311 */
8312 e = spmpar(&K1);
8313 if(*a < 0.0e0 || *x < 0.0e0) goto S430;
8314 if(*a == 0.0e0 && *x == 0.0e0) goto S430;
8315 if(*a**x == 0.0e0) goto S420;
8316 iop = *ind+1;
8317 if(iop != 1 && iop != 2) iop = 3;
8318 acc = fifdmax1(acc0[iop-1],e);
8319 e0 = e00[iop-1];
8320 x0 = x00[iop-1];
8321 /*
8322 SELECT THE APPROPRIATE ALGORITHM
8323 */
8324 if(*a >= 1.0e0) goto S10;
8325 if(*a == 0.5e0) goto S390;
8326 if(*x < 1.1e0) goto S160;
8327 t1 = *a*log(*x)-*x;
8328 u = *a*exp(t1);
8329 if(u == 0.0e0) goto S380;
8330 r = u*(1.0e0+gam1(a));
8331 goto S250;
8332 S10:
8333 if(*a >= big[iop-1]) goto S30;
8334 if(*a > *x || *x >= x0) goto S20;
8335 twoa = *a+*a;
8336 m = fifidint(twoa);
8337 if(twoa != (double)m) goto S20;
8338 i = m/2;
8339 if(*a == (double)i) goto S210;
8340 goto S220;
8341 S20:
8342 t1 = *a*log(*x)-*x;
8343 r = exp(t1)/Xgamm(a);
8344 goto S40;
8345 S30:
8346 l = *x/ *a;
8347 if(l == 0.0e0) goto S370;
8348 s = 0.5e0+(0.5e0-l);
8349 z = rlog(&l);
8350 if(z >= 700.0e0/ *a) goto S410;
8351 y = *a*z;
8352 rta = sqrt(*a);
8353 if(fabs(s) <= e0/rta) goto S330;
8354 if(fabs(s) <= 0.4e0) goto S270;
8355 t = pow(1.0e0/ *a,2.0);
8356 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
8357 t1 -= y;
8358 r = rt2pin*rta*exp(t1);
8359 S40:
8360 if(r == 0.0e0) goto S420;
8361 if(*x <= fifdmax1(*a,alog10)) goto S50;
8362 if(*x < x0) goto S250;
8363 goto S100;
8364 S50:
8365 /*
8366 TAYLOR SERIES FOR P/R
8367 */
8368 apn = *a+1.0e0;
8369 t = *x/apn;
8370 wk[0] = t;
8371 for(n=2; n<=20; n++) {
8372 apn += 1.0e0;
8373 t *= (*x/apn);
8374 if(t <= 1.e-3) goto S70;
8375 wk[n-1] = t;
8376 }
8377 n = 20;
8378 S70:
8379 sum = t;
8380 tol = 0.5e0*acc;
8381 S80:
8382 apn += 1.0e0;
8383 t *= (*x/apn);
8384 sum += t;
8385 if(t > tol) goto S80;
8386 max = n-1;
8387 for(m=1; m<=max; m++) {
8388 n -= 1;
8389 sum += wk[n-1];
8390 }
8391 *ans = r/ *a*(1.0e0+sum);
8392 *qans = 0.5e0+(0.5e0-*ans);
8393 return;
8394 S100:
8395 /*
8396 ASYMPTOTIC EXPANSION
8397 */
8398 amn = *a-1.0e0;
8399 t = amn/ *x;
8400 wk[0] = t;
8401 for(n=2; n<=20; n++) {
8402 amn -= 1.0e0;
8403 t *= (amn/ *x);
8404 if(fabs(t) <= 1.e-3) goto S120;
8405 wk[n-1] = t;
8406 }
8407 n = 20;
8408 S120:
8409 sum = t;
8410 S130:
8411 if(fabs(t) <= acc) goto S140;
8412 amn -= 1.0e0;
8413 t *= (amn/ *x);
8414 sum += t;
8415 goto S130;
8416 S140:
8417 max = n-1;
8418 for(m=1; m<=max; m++) {
8419 n -= 1;
8420 sum += wk[n-1];
8421 }
8422 *qans = r/ *x*(1.0e0+sum);
8423 *ans = 0.5e0+(0.5e0-*qans);
8424 return;
8425 S160:
8426 /*
8427 TAYLOR SERIES FOR P(A,X)/X**A
8428 */
8429 an = 3.0e0;
8430 c = *x;
8431 sum = *x/(*a+3.0e0);
8432 tol = 3.0e0*acc/(*a+1.0e0);
8433 S170:
8434 an += 1.0e0;
8435 c = -(c*(*x/an));
8436 t = c/(*a+an);
8437 sum += t;
8438 if(fabs(t) > tol) goto S170;
8439 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8440 z = *a*log(*x);
8441 h = gam1(a);
8442 g = 1.0e0+h;
8443 if(*x < 0.25e0) goto S180;
8444 if(*a < *x/2.59e0) goto S200;
8445 goto S190;
8446 S180:
8447 if(z > -.13394e0) goto S200;
8448 S190:
8449 w = exp(z);
8450 *ans = w*g*(0.5e0+(0.5e0-j));
8451 *qans = 0.5e0+(0.5e0-*ans);
8452 return;
8453 S200:
8454 l = rexp(&z);
8455 w = 0.5e0+(0.5e0+l);
8456 *qans = (w*j-l)*g-h;
8457 if(*qans < 0.0e0) goto S380;
8458 *ans = 0.5e0+(0.5e0-*qans);
8459 return;
8460 S210:
8461 /*
8462 FINITE SUMS FOR Q WHEN A .GE. 1
8463 AND 2*A IS AN INTEGER
8464 */
8465 sum = exp(-*x);
8466 t = sum;
8467 n = 1;
8468 c = 0.0e0;
8469 goto S230;
8470 S220:
8471 rtx = sqrt(*x);
8472 sum = erfc1(&K2,&rtx);
8473 t = exp(-*x)/(rtpi*rtx);
8474 n = 0;
8475 c = -0.5e0;
8476 S230:
8477 if(n == i) goto S240;
8478 n += 1;
8479 c += 1.0e0;
8480 t = *x*t/c;
8481 sum += t;
8482 goto S230;
8483 S240:
8484 *qans = sum;
8485 *ans = 0.5e0+(0.5e0-*qans);
8486 return;
8487 S250:
8488 /*
8489 CONTINUED FRACTION EXPANSION
8490 */
8491 tol = fifdmax1(5.0e0*e,acc);
8492 a2nm1 = a2n = 1.0e0;
8493 b2nm1 = *x;
8494 b2n = *x+(1.0e0-*a);
8495 c = 1.0e0;
8496 S260:
8497 a2nm1 = *x*a2n+c*a2nm1;
8498 b2nm1 = *x*b2n+c*b2nm1;
8499 am0 = a2nm1/b2nm1;
8500 c += 1.0e0;
8501 cma = c-*a;
8502 a2n = a2nm1+cma*a2n;
8503 b2n = b2nm1+cma*b2n;
8504 an0 = a2n/b2n;
8505 if(fabs(an0-am0) >= tol*an0) goto S260;
8506 *qans = r*an0;
8507 *ans = 0.5e0+(0.5e0-*qans);
8508 return;
8509 S270:
8510 /*
8511 GENERAL TEMME EXPANSION
8512 */
8513 if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430;
8514 c = exp(-y);
8515 T3 = sqrt(y);
8516 w = 0.5e0*erfc1(&K1,&T3);
8517 u = 1.0e0/ *a;
8518 z = sqrt(z+z);
8519 if(l < 1.0e0) z = -z;
8520 T4 = iop-2;
8521 if(T4 < 0) goto S280;
8522 else if(T4 == 0) goto S290;
8523 else goto S300;
8524 S280:
8525 if(fabs(s) <= 1.e-3) goto S340;
8526 c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[
8527 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8528 c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5]
8529 )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8530 c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+
8531 d2[2])*z+d2[1])*z+d2[0])*z+d20;
8532 c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+
8533 d3[0])*z+d30;
8534 c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40;
8535 c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50;
8536 c6 = (d6[1]*z+d6[0])*z+d60;
8537 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8538 goto S310;
8539 S290:
8540 c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8541 c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8542 c2 = d2[0]*z+d20;
8543 t = (c2*u+c1)*u+c0;
8544 goto S310;
8545 S300:
8546 t = ((d0[2]*z+d0[1])*z+d0[0])*z-third;
8547 S310:
8548 if(l < 1.0e0) goto S320;
8549 *qans = c*(w+rt2pin*t/rta);
8550 *ans = 0.5e0+(0.5e0-*qans);
8551 return;
8552 S320:
8553 *ans = c*(w-rt2pin*t/rta);
8554 *qans = 0.5e0+(0.5e0-*ans);
8555 return;
8556 S330:
8557 /*
8558 TEMME EXPANSION FOR L = 1
8559 */
8560 if(*a*e*e > 3.28e-3) goto S430;
8561 c = 0.5e0+(0.5e0-y);
8562 w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c;
8563 u = 1.0e0/ *a;
8564 z = sqrt(z+z);
8565 if(l < 1.0e0) z = -z;
8566 T5 = iop-2;
8567 if(T5 < 0) goto S340;
8568 else if(T5 == 0) goto S350;
8569 else goto S360;
8570 S340:
8571 c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-
8572 third;
8573 c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8574 c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20;
8575 c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30;
8576 c4 = (d4[1]*z+d4[0])*z+d40;
8577 c5 = (d5[1]*z+d5[0])*z+d50;
8578 c6 = d6[0]*z+d60;
8579 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8580 goto S310;
8581 S350:
8582 c0 = (d0[1]*z+d0[0])*z-third;
8583 c1 = d1[0]*z+d10;
8584 t = (d20*u+c1)*u+c0;
8585 goto S310;
8586 S360:
8587 t = d0[0]*z-third;
8588 goto S310;
8589 S370:
8590 /*
8591 SPECIAL CASES
8592 */
8593 *ans = 0.0e0;
8594 *qans = 1.0e0;
8595 return;
8596 S380:
8597 *ans = 1.0e0;
8598 *qans = 0.0e0;
8599 return;
8600 S390:
8601 if(*x >= 0.25e0) goto S400;
8602 T6 = sqrt(*x);
8603 *ans = erf1(&T6);
8604 *qans = 0.5e0+(0.5e0-*ans);
8605 return;
8606 S400:
8607 T7 = sqrt(*x);
8608 *qans = erfc1(&K2,&T7);
8609 *ans = 0.5e0+(0.5e0-*qans);
8610 return;
8611 S410:
8612 if(fabs(s) <= 2.0e0*e) goto S430;
8613 S420:
8614 if(*x <= *a) goto S370;
8615 goto S380;
8616 S430:
8617 /*
8618 ERROR RETURN
8619 */
8620 *ans = 2.0e0;
8621 return;
8622 }
gsumln(double * a,double * b)8623 double gsumln(double *a,double *b)
8624 /*
8625 -----------------------------------------------------------------------
8626 EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
8627 FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2
8628 -----------------------------------------------------------------------
8629 */
8630 {
8631 static double gsumln,x,T1,T2;
8632 /*
8633 ..
8634 .. Executable Statements ..
8635 */
8636 x = *a+*b-2.e0;
8637 if(x > 0.25e0) goto S10;
8638 T1 = 1.0e0+x;
8639 gsumln = gamln1(&T1);
8640 return gsumln;
8641 S10:
8642 if(x > 1.25e0) goto S20;
8643 gsumln = gamln1(&x)+alnrel(&x);
8644 return gsumln;
8645 S20:
8646 T2 = x-1.0e0;
8647 gsumln = gamln1(&T2)+log(x*(1.0e0+x));
8648 return gsumln;
8649 }
psi(double * xx)8650 double psi(double *xx)
8651 /*
8652 ---------------------------------------------------------------------
8653
8654 EVALUATION OF THE DIGAMMA FUNCTION
8655
8656 -----------
8657
8658 PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT
8659 BE COMPUTED.
8660
8661 THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV
8662 APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY
8663 CODY, STRECOK AND THACHER.
8664
8665 ---------------------------------------------------------------------
8666 PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK
8667 PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY
8668 A.H. MORRIS (NSWC).
8669 ---------------------------------------------------------------------
8670 */
8671 {
8672 static double dx0 = 1.461632144968362341262659542325721325e0;
8673 static double piov4 = .785398163397448e0;
8674 static double p1[7] = {
8675 .895385022981970e-02,.477762828042627e+01,.142441585084029e+03,
8676 .118645200713425e+04,.363351846806499e+04,.413810161269013e+04,
8677 .130560269827897e+04
8678 };
8679 static double p2[4] = {
8680 -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01,
8681 -.648157123766197e+00
8682 };
8683 static double q1[6] = {
8684 .448452573429826e+02,.520752771467162e+03,.221000799247830e+04,
8685 .364127349079381e+04,.190831076596300e+04,.691091682714533e-05
8686 };
8687 static double q2[4] = {
8688 .322703493791143e+02,.892920700481861e+02,.546117738103215e+02,
8689 .777788548522962e+01
8690 };
8691 static int K1 = 3;
8692 static int K2 = 1;
8693 static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z;
8694 static int i,m,n,nq;
8695 /*
8696 ..
8697 .. Executable Statements ..
8698 */
8699 /*
8700 ---------------------------------------------------------------------
8701 MACHINE DEPENDENT CONSTANTS ...
8702 XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
8703 WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED
8704 AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
8705 ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
8706 PSI MAY BE REPRESENTED AS ALOG(X).
8707 XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
8708 MAY BE REPRESENTED BY 1/X.
8709 ---------------------------------------------------------------------
8710 */
8711 xmax1 = ipmpar(&K1);
8712 xmax1 = fifdmin1(xmax1,1.0e0/spmpar(&K2));
8713 xsmall = 1.e-9;
8714 x = *xx;
8715 aug = 0.0e0;
8716 if(x >= 0.5e0) goto S50;
8717 /*
8718 ---------------------------------------------------------------------
8719 X .LT. 0.5, USE REFLECTION FORMULA
8720 PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
8721 ---------------------------------------------------------------------
8722 */
8723 if(fabs(x) > xsmall) goto S10;
8724 if(x == 0.0e0) goto S100;
8725 /*
8726 ---------------------------------------------------------------------
8727 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE
8728 FOR PI*COTAN(PI*X)
8729 ---------------------------------------------------------------------
8730 */
8731 aug = -(1.0e0/x);
8732 goto S40;
8733 S10:
8734 /*
8735 ---------------------------------------------------------------------
8736 REDUCTION OF ARGUMENT FOR COTAN
8737 ---------------------------------------------------------------------
8738 */
8739 w = -x;
8740 sgn = piov4;
8741 if(w > 0.0e0) goto S20;
8742 w = -w;
8743 sgn = -sgn;
8744 S20:
8745 /*
8746 ---------------------------------------------------------------------
8747 MAKE AN ERROR EXIT IF X .LE. -XMAX1
8748 ---------------------------------------------------------------------
8749 */
8750 if(w >= xmax1) goto S100;
8751 nq = fifidint(w);
8752 w -= (double)nq;
8753 nq = fifidint(w*4.0e0);
8754 w = 4.0e0*(w-(double)nq*.25e0);
8755 /*
8756 ---------------------------------------------------------------------
8757 W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X.
8758 ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
8759 QUADRANT AND DETERMINE SIGN
8760 ---------------------------------------------------------------------
8761 */
8762 n = nq/2;
8763 if(n+n != nq) w = 1.0e0-w;
8764 z = piov4*w;
8765 m = n/2;
8766 if(m+m != n) sgn = -sgn;
8767 /*
8768 ---------------------------------------------------------------------
8769 DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X)
8770 ---------------------------------------------------------------------
8771 */
8772 n = (nq+1)/2;
8773 m = n/2;
8774 m += m;
8775 if(m != n) goto S30;
8776 /*
8777 ---------------------------------------------------------------------
8778 CHECK FOR SINGULARITY
8779 ---------------------------------------------------------------------
8780 */
8781 if(z == 0.0e0) goto S100;
8782 /*
8783 ---------------------------------------------------------------------
8784 USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
8785 SIN/COS AS A SUBSTITUTE FOR TAN
8786 ---------------------------------------------------------------------
8787 */
8788 aug = sgn*(cos(z)/sin(z)*4.0e0);
8789 goto S40;
8790 S30:
8791 aug = sgn*(sin(z)/cos(z)*4.0e0);
8792 S40:
8793 x = 1.0e0-x;
8794 S50:
8795 if(x > 3.0e0) goto S70;
8796 /*
8797 ---------------------------------------------------------------------
8798 0.5 .LE. X .LE. 3.0
8799 ---------------------------------------------------------------------
8800 */
8801 den = x;
8802 upper = p1[0]*x;
8803 for(i=1; i<=5; i++) {
8804 den = (den+q1[i-1])*x;
8805 upper = (upper+p1[i+1-1])*x;
8806 }
8807 den = (upper+p1[6])/(den+q1[5]);
8808 xmx0 = x-dx0;
8809 psi = den*xmx0+aug;
8810 return psi;
8811 S70:
8812 /*
8813 ---------------------------------------------------------------------
8814 IF X .GE. XMAX1, PSI = LN(X)
8815 ---------------------------------------------------------------------
8816 */
8817 if(x >= xmax1) goto S90;
8818 /*
8819 ---------------------------------------------------------------------
8820 3.0 .LT. X .LT. XMAX1
8821 ---------------------------------------------------------------------
8822 */
8823 w = 1.0e0/(x*x);
8824 den = w;
8825 upper = p2[0]*w;
8826 for(i=1; i<=3; i++) {
8827 den = (den+q2[i-1])*w;
8828 upper = (upper+p2[i+1-1])*w;
8829 }
8830 aug = upper/(den+q2[3])-0.5e0/x+aug;
8831 S90:
8832 psi = aug+log(x);
8833 return psi;
8834 S100:
8835 /*
8836 ---------------------------------------------------------------------
8837 ERROR RETURN
8838 ---------------------------------------------------------------------
8839 */
8840 psi = 0.0e0;
8841 return psi;
8842 }
rcomp(double * a,double * x)8843 double rcomp(double *a,double *x)
8844 /*
8845 -------------------
8846 EVALUATION OF EXP(-X)*X**A/GAMMA(A)
8847 -------------------
8848 RT2PIN = 1/SQRT(2*PI)
8849 -------------------
8850 */
8851 {
8852 static double rt2pin = .398942280401433e0;
8853 static double rcomp,t,t1,u;
8854 /*
8855 ..
8856 .. Executable Statements ..
8857 */
8858 rcomp = 0.0e0;
8859 if(*a >= 20.0e0) goto S20;
8860 t = *a*log(*x)-*x;
8861 if(*a >= 1.0e0) goto S10;
8862 rcomp = *a*exp(t)*(1.0e0+gam1(a));
8863 return rcomp;
8864 S10:
8865 rcomp = exp(t)/Xgamm(a);
8866 return rcomp;
8867 S20:
8868 u = *x/ *a;
8869 if(u == 0.0e0) return rcomp;
8870 t = pow(1.0e0/ *a,2.0);
8871 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
8872 t1 -= (*a*rlog(&u));
8873 rcomp = rt2pin*sqrt(*a)*exp(t1);
8874 return rcomp;
8875 }
rexp(double * x)8876 double rexp(double *x)
8877 /*
8878 -----------------------------------------------------------------------
8879 EVALUATION OF THE FUNCTION EXP(X) - 1
8880 -----------------------------------------------------------------------
8881 */
8882 {
8883 static double p1 = .914041914819518e-09;
8884 static double p2 = .238082361044469e-01;
8885 static double q1 = -.499999999085958e+00;
8886 static double q2 = .107141568980644e+00;
8887 static double q3 = -.119041179760821e-01;
8888 static double q4 = .595130811860248e-03;
8889 static double rexp,w;
8890 /*
8891 ..
8892 .. Executable Statements ..
8893 */
8894 if(fabs(*x) > 0.15e0) goto S10;
8895 rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
8896 return rexp;
8897 S10:
8898 w = exp(*x);
8899 if(*x > 0.0e0) goto S20;
8900 rexp = w-0.5e0-0.5e0;
8901 return rexp;
8902 S20:
8903 rexp = w*(0.5e0+(0.5e0-1.0e0/w));
8904 return rexp;
8905 }
rlog(double * x)8906 double rlog(double *x)
8907 /*
8908 -------------------
8909 COMPUTATION OF X - 1 - LN(X)
8910 -------------------
8911 */
8912 {
8913 static double a = .566749439387324e-01;
8914 static double b = .456512608815524e-01;
8915 static double p0 = .333333333333333e+00;
8916 static double p1 = -.224696413112536e+00;
8917 static double p2 = .620886815375787e-02;
8918 static double q1 = -.127408923933623e+01;
8919 static double q2 = .354508718369557e+00;
8920 static double rlog,r,t,u,w,w1;
8921 /*
8922 ..
8923 .. Executable Statements ..
8924 */
8925 if(*x < 0.61e0 || *x > 1.57e0) goto S40;
8926 if(*x < 0.82e0) goto S10;
8927 if(*x > 1.18e0) goto S20;
8928 /*
8929 ARGUMENT REDUCTION
8930 */
8931 u = *x-0.5e0-0.5e0;
8932 w1 = 0.0e0;
8933 goto S30;
8934 S10:
8935 u = *x-0.7e0;
8936 u /= 0.7e0;
8937 w1 = a-u*0.3e0;
8938 goto S30;
8939 S20:
8940 u = 0.75e0**x-1.e0;
8941 w1 = b+u/3.0e0;
8942 S30:
8943 /*
8944 SERIES EXPANSION
8945 */
8946 r = u/(u+2.0e0);
8947 t = r*r;
8948 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
8949 rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
8950 return rlog;
8951 S40:
8952 r = *x-0.5e0-0.5e0;
8953 rlog = r-log(*x);
8954 return rlog;
8955 }
rlog1(double * x)8956 double rlog1(double *x)
8957 /*
8958 -----------------------------------------------------------------------
8959 EVALUATION OF THE FUNCTION X - LN(1 + X)
8960 -----------------------------------------------------------------------
8961 */
8962 {
8963 static double a = .566749439387324e-01;
8964 static double b = .456512608815524e-01;
8965 static double p0 = .333333333333333e+00;
8966 static double p1 = -.224696413112536e+00;
8967 static double p2 = .620886815375787e-02;
8968 static double q1 = -.127408923933623e+01;
8969 static double q2 = .354508718369557e+00;
8970 static double rlog1,h,r,t,w,w1;
8971 /*
8972 ..
8973 .. Executable Statements ..
8974 */
8975 if(*x < -0.39e0 || *x > 0.57e0) goto S40;
8976 if(*x < -0.18e0) goto S10;
8977 if(*x > 0.18e0) goto S20;
8978 /*
8979 ARGUMENT REDUCTION
8980 */
8981 h = *x;
8982 w1 = 0.0e0;
8983 goto S30;
8984 S10:
8985 h = *x+0.3e0;
8986 h /= 0.7e0;
8987 w1 = a-h*0.3e0;
8988 goto S30;
8989 S20:
8990 h = 0.75e0**x-0.25e0;
8991 w1 = b+h/3.0e0;
8992 S30:
8993 /*
8994 SERIES EXPANSION
8995 */
8996 r = h/(h+2.0e0);
8997 t = r*r;
8998 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
8999 rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
9000 return rlog1;
9001 S40:
9002 w = *x+0.5e0+0.5e0;
9003 rlog1 = *x-log(w);
9004 return rlog1;
9005 }
spmpar(int * i)9006 double spmpar(int *i)
9007 /*
9008 -----------------------------------------------------------------------
9009
9010 SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
9011 THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
9012 I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
9013 SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
9014 ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
9015
9016 SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
9017
9018 SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
9019
9020 SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
9021
9022 -----------------------------------------------------------------------
9023 WRITTEN BY
9024 ALFRED H. MORRIS, JR.
9025 NAVAL SURFACE WARFARE CENTER
9026 DAHLGREN VIRGINIA
9027 -----------------------------------------------------------------------
9028 -----------------------------------------------------------------------
9029 MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE
9030 CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS
9031 MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION
9032 -----------------------------------------------------------------------
9033 */
9034 {
9035 static int K1 = 4;
9036 static int K2 = 8;
9037 static int K3 = 9;
9038 static int K4 = 10;
9039 static double spmpar,b,binv,bm1,one,w,z;
9040 static int emax,emin,ibeta,m;
9041 /*
9042 ..
9043 .. Executable Statements ..
9044 */
9045 if(*i > 1) goto S10;
9046 b = ipmpar(&K1);
9047 m = ipmpar(&K2);
9048 spmpar = pow(b,(double)(1-m));
9049 return spmpar;
9050 S10:
9051 if(*i > 2) goto S20;
9052 b = ipmpar(&K1);
9053 emin = ipmpar(&K3);
9054 one = 1.0;
9055 binv = one/b;
9056 w = pow(b,(double)(emin+2));
9057 spmpar = w*binv*binv*binv;
9058 return spmpar;
9059 S20:
9060 ibeta = ipmpar(&K1);
9061 m = ipmpar(&K2);
9062 emax = ipmpar(&K4);
9063 b = ibeta;
9064 bm1 = ibeta-1;
9065 one = 1.0;
9066 z = pow(b,(double)(m-1));
9067 w = ((z-one)*b+bm1)/(b*z);
9068 z = pow(b,(double)(emax-2));
9069 spmpar = w*z*b*b;
9070 return spmpar;
9071 }
stvaln(double * p)9072 double stvaln(double *p)
9073 /*
9074 **********************************************************************
9075
9076 double stvaln(double *p)
9077 STarting VALue for Neton-Raphon
9078 calculation of Normal distribution Inverse
9079
9080
9081 Function
9082
9083
9084 Returns X such that CUMNOR(X) = P, i.e., the integral from -
9085 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
9086
9087
9088 Arguments
9089
9090
9091 P --> The probability whose normal deviate is sought.
9092 P is DOUBLE PRECISION
9093
9094
9095 Method
9096
9097
9098 The rational function on page 95 of Kennedy and Gentle,
9099 Statistical Computing, Marcel Dekker, NY , 1980.
9100
9101 **********************************************************************
9102 */
9103 {
9104 static double xden[5] = {
9105 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0,
9106 0.38560700634e-2
9107 };
9108 static double xnum[5] = {
9109 -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1,
9110 -0.453642210148e-4
9111 };
9112 static int K1 = 5;
9113 static double stvaln,sign,y,z;
9114 /*
9115 ..
9116 .. Executable Statements ..
9117 */
9118 if(!(*p <= 0.5e0)) goto S10;
9119 sign = -1.0e0;
9120 z = *p;
9121 goto S20;
9122 S10:
9123 sign = 1.0e0;
9124 z = 1.0e0-*p;
9125 S20:
9126 y = sqrt(-(2.0e0*log(z)));
9127 stvaln = y+devlpl(xnum,&K1,&y)/devlpl(xden,&K1,&y);
9128 stvaln = sign*stvaln;
9129 return stvaln;
9130 }
9131 /************************************************************************
9132 FIFDINT:
9133 Truncates a double precision number to an integer and returns the
9134 value in a double.
9135 ************************************************************************/
fifdint(double a)9136 double fifdint(double a)
9137 /* a - number to be truncated */
9138 {
9139 return (double) ((int) a);
9140 }
9141 /************************************************************************
9142 FIFDMAX1:
9143 returns the maximum of two numbers a and b
9144 ************************************************************************/
fifdmax1(double a,double b)9145 double fifdmax1(double a,double b)
9146 /* a - first number */
9147 /* b - second number */
9148 {
9149 if (a < b) return b;
9150 else return a;
9151 }
9152 /************************************************************************
9153 FIFDMIN1:
9154 returns the minimum of two numbers a and b
9155 ************************************************************************/
fifdmin1(double a,double b)9156 double fifdmin1(double a,double b)
9157 /* a - first number */
9158 /* b - second number */
9159 {
9160 if (a < b) return a;
9161 else return b;
9162 }
9163 /************************************************************************
9164 FIFDSIGN:
9165 transfers the sign of the variable "sign" to the variable "mag"
9166 ************************************************************************/
fifdsign(double mag,double sign)9167 double fifdsign(double mag,double sign)
9168 /* mag - magnitude */
9169 /* sign - sign to be transfered */
9170 {
9171 if (mag < 0) mag = -mag;
9172 if (sign < 0) mag = -mag;
9173 return mag;
9174
9175 }
9176 /************************************************************************
9177 FIFIDINT:
9178 Truncates a double precision number to a long integer
9179 ************************************************************************/
fifidint(double a)9180 long fifidint(double a)
9181 /* a - number to be truncated */
9182 {
9183 if (a < 1.0) return (long) 0;
9184 else return (long) a;
9185 }
9186 /************************************************************************
9187 FIFMOD:
9188 returns the modulo of a and b
9189 ************************************************************************/
fifmod(long a,long b)9190 long fifmod(long a,long b)
9191 /* a - numerator */
9192 /* b - denominator */
9193 {
9194 return a % b;
9195 }
9196 /************************************************************************
9197 FTNSTOP:
9198 Prints msg to standard error and then exits
9199 ************************************************************************/
ftnstop(char * msg)9200 void ftnstop(char* msg)
9201 /* msg - error message */
9202 {
9203 if (msg != NULL) fprintf(stderr,"%s\n",msg);
9204 exit(0);
9205 }
9206