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