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