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