1
2 /************************************************************************/
3 /** Functions to compute cumulative distributions and their inverses **/
4 /** for the NIfTI-1 statistical types. Much of this code is taken **/
5 /** from other sources. In particular, the cdflib functions by **/
6 /** Brown and Lovato make up the bulk of this file. That code **/
7 /** was placed in the public domain. The code by K. Krishnamoorthy **/
8 /** is also released for unrestricted use. Finally, the other parts **/
9 /** of this file (by RW Cox) are released to the public domain. **/
10 /** **/
11 /** Most of this file comprises a set of "static" functions, to be **/
12 /** called by the user-level functions at the very end of the file. **/
13 /** At the end of the file is a simple main program to drive these **/
14 /** functions. **/
15 /** **/
16 /** To find the user-level functions, search forward for the string **/
17 /** "nifti_", which will be at about line 11000. **/
18 /************************************************************************/
19 /*****==============================================================*****/
20 /***** Neither the National Institutes of Health (NIH), the DFWG, *****/
21 /***** nor any of the members or employees of these institutions *****/
22 /***** imply any warranty of usefulness of this material for any *****/
23 /***** purpose, and do not assume any liability for damages, *****/
24 /***** incidental or otherwise, caused by any use of this document. *****/
25 /***** If these conditions are not acceptable, do not use this! *****/
26 /*****==============================================================*****/
27 /************************************************************************/
28
29 /*.......................................................................
30 To compile with gcc, for example:
31
32 gcc -O3 -ffast-math -o nifti_stats nifti_stats.c -lm
33 ........................................................................*/
34
35 #include "nifti1.h" /* for the NIFTI_INTENT_* constants */
36 #include <stdio.h>
37 #include <stdlib.h>
38 #include <math.h>
39
40 /************************************************************************/
41 /************ Include all the cdflib functions here and now *************/
42 /************ [about 9900 lines of code below here] *************/
43 /************************************************************************/
44
45 /** Prototypes for cdflib functions **/
46
47 static double algdiv(double*,double*);
48 static double alngam(double*);
49 static double alnrel(double*);
50 static double apser(double*,double*,double*,double*);
51 static double basym(double*,double*,double*,double*);
52 static double bcorr(double*,double*);
53 static double betaln(double*,double*);
54 static double bfrac(double*,double*,double*,double*,double*,double*);
55 static void bgrat(double*,double*,double*,double*,double*,double*,int*i);
56 static double bpser(double*,double*,double*,double*);
57 static void bratio(double*,double*,double*,double*,double*,double*,int*);
58 static double brcmp1(int*,double*,double*,double*,double*);
59 static double brcomp(double*,double*,double*,double*);
60 static double bup(double*,double*,double*,double*,int*,double*);
61 static void cdfbet(int*,double*,double*,double*,double*,double*,double*,
62 int*,double*);
63 static void cdfbin(int*,double*,double*,double*,double*,double*,double*,
64 int*,double*);
65 static void cdfchi(int*,double*,double*,double*,double*,int*,double*);
66 static void cdfchn(int*,double*,double*,double*,double*,double*,int*,double*);
67 static void cdff(int*,double*,double*,double*,double*,double*,int*,double*);
68 static void cdffnc(int*,double*,double*,double*,double*,double*,double*,
69 int*s,double*);
70 static void cdfgam(int*,double*,double*,double*,double*,double*,int*,double*);
71 static void cdfnbn(int*,double*,double*,double*,double*,double*,double*,
72 int*,double*);
73 static void cdfnor(int*,double*,double*,double*,double*,double*,int*,double*);
74 static void cdfpoi(int*,double*,double*,double*,double*,int*,double*);
75 static void cdft(int*,double*,double*,double*,double*,int*,double*);
76 static void cumbet(double*,double*,double*,double*,double*,double*);
77 static void cumbin(double*,double*,double*,double*,double*,double*);
78 static void cumchi(double*,double*,double*,double*);
79 static void cumchn(double*,double*,double*,double*,double*);
80 static void cumf(double*,double*,double*,double*,double*);
81 static void cumfnc(double*,double*,double*,double*,double*,double*);
82 static void cumgam(double*,double*,double*,double*);
83 static void cumnbn(double*,double*,double*,double*,double*,double*);
84 static void cumnor(double*,double*,double*);
85 static void cumpoi(double*,double*,double*,double*);
86 static void cumt(double*,double*,double*,double*);
87 static double dbetrm(double*,double*);
88 static double devlpl(double [],int*,double*);
89 static double dexpm1(double*);
90 static double dinvnr(double *p,double *q);
91 static void E0000(int,int*,double*,double*,unsigned long*,
92 unsigned long*,double*,double*,double*,
93 double*,double*,double*,double*);
94 static void dinvr(int*,double*,double*,unsigned long*,unsigned long*);
95 static void dstinv(double*,double*,double*,double*,double*,double*,
96 double*);
97 static double dlanor(double*);
98 static double dln1mx(double*);
99 static double dln1px(double*);
100 static double dlnbet(double*,double*);
101 static double dlngam(double*);
102 static double dstrem(double*);
103 static double dt1(double*,double*,double*);
104 static void E0001(int,int*,double*,double*,double*,double*,
105 unsigned long*,unsigned long*,double*,double*,
106 double*,double*);
107 static void dzror(int*,double*,double*,double*,double *,
108 unsigned long*,unsigned long*);
109 static void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl);
110 static double erf1(double*);
111 static double erfc1(int*,double*);
112 static double esum(int*,double*);
113 static double exparg(int*);
114 static double fpser(double*,double*,double*,double*);
115 static double gam1(double*);
116 static void gaminv(double*,double*,double*,double*,double*,int*);
117 static double gamln(double*);
118 static double gamln1(double*);
119 static double Xgamm(double*);
120 static void grat1(double*,double*,double*,double*,double*,double*);
121 static void gratio(double*,double*,double*,double*,int*);
122 static double gsumln(double*,double*);
123 static double psi(double*);
124 static double rcomp(double*,double*);
125 static double rexp(double*);
126 static double rlog(double*);
127 static double rlog1(double*);
128 static double spmpar(int*);
129 static double stvaln(double*);
130 static double fifdint(double);
131 static double fifdmax1(double,double);
132 static double fifdmin1(double,double);
133 static double fifdsign(double,double);
134 static long fifidint(double);
135 static long fifmod(long,long);
136 static void ftnstop(char*);
137 static int ipmpar(int*);
138
139 /***=====================================================================***/
algdiv(double * a,double * b)140 static double algdiv(double *a,double *b)
141 /*
142 -----------------------------------------------------------------------
143
144 COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8
145
146 --------
147
148 IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
149 LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
150
151 -----------------------------------------------------------------------
152 */
153 {
154 static double c0 = .833333333333333e-01;
155 static double c1 = -.277777777760991e-02;
156 static double c2 = .793650666825390e-03;
157 static double c3 = -.595202931351870e-03;
158 static double c4 = .837308034031215e-03;
159 static double c5 = -.165322962780713e-02;
160 static double algdiv,c,d,h,s11,s3,s5,s7,s9,t,u,v,w,x,x2,T1;
161 /*
162 ..
163 .. Executable Statements ..
164 */
165 if(*a <= *b) goto S10;
166 h = *b/ *a;
167 c = 1.0e0/(1.0e0+h);
168 x = h/(1.0e0+h);
169 d = *a+(*b-0.5e0);
170 goto S20;
171 S10:
172 h = *a/ *b;
173 c = h/(1.0e0+h);
174 x = 1.0e0/(1.0e0+h);
175 d = *b+(*a-0.5e0);
176 S20:
177 /*
178 SET SN = (1 - X**N)/(1 - X)
179 */
180 x2 = x*x;
181 s3 = 1.0e0+(x+x2);
182 s5 = 1.0e0+(x+x2*s3);
183 s7 = 1.0e0+(x+x2*s5);
184 s9 = 1.0e0+(x+x2*s7);
185 s11 = 1.0e0+(x+x2*s9);
186 /*
187 SET W = DEL(B) - DEL(A + B)
188 */
189 t = pow(1.0e0/ *b,2.0);
190 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0;
191 w *= (c/ *b);
192 /*
193 COMBINE THE RESULTS
194 */
195 T1 = *a/ *b;
196 u = d*alnrel(&T1);
197 v = *a*(log(*b)-1.0e0);
198 if(u <= v) goto S30;
199 algdiv = w-v-u;
200 return algdiv;
201 S30:
202 algdiv = w-u-v;
203 return algdiv;
204 } /* END */
205
206 /***=====================================================================***/
alngam(double * x)207 static double alngam(double *x)
208 /*
209 **********************************************************************
210
211 double alngam(double *x)
212 double precision LN of the GAMma function
213
214
215 Function
216
217
218 Returns the natural logarithm of GAMMA(X).
219
220
221 Arguments
222
223
224 X --> value at which scaled log gamma is to be returned
225 X is DOUBLE PRECISION
226
227
228 Method
229
230
231 If X .le. 6.0, then use recursion to get X below 3
232 then apply rational approximation number 5236 of
233 Hart et al, Computer Approximations, John Wiley and
234 Sons, NY, 1968.
235
236 If X .gt. 6.0, then use recursion to get X to at least 12 and
237 then use formula 5423 of the same source.
238
239 **********************************************************************
240 */
241 {
242 #define hln2pi 0.91893853320467274178e0
243 static double coef[5] = {
244 0.83333333333333023564e-1,-0.27777777768818808e-2,0.79365006754279e-3,
245 -0.594997310889e-3,0.8065880899e-3
246 };
247 static double scoefd[4] = {
248 0.62003838007126989331e2,0.9822521104713994894e1,-0.8906016659497461257e1,
249 0.1000000000000000000e1
250 };
251 static double scoefn[9] = {
252 0.62003838007127258804e2,0.36036772530024836321e2,0.20782472531792126786e2,
253 0.6338067999387272343e1,0.215994312846059073e1,0.3980671310203570498e0,
254 0.1093115956710439502e0,0.92381945590275995e-2,0.29737866448101651e-2
255 };
256 static int K1 = 9;
257 static int K3 = 4;
258 static int K5 = 5;
259 static double alngam,offset,prod,xx;
260 static int i,n;
261 static double T2,T4,T6;
262 /*
263 ..
264 .. Executable Statements ..
265 */
266 if(!(*x <= 6.0e0)) goto S70;
267 prod = 1.0e0;
268 xx = *x;
269 if(!(*x > 3.0e0)) goto S30;
270 S10:
271 if(!(xx > 3.0e0)) goto S20;
272 xx -= 1.0e0;
273 prod *= xx;
274 goto S10;
275 S30:
276 S20:
277 if(!(*x < 2.0e0)) goto S60;
278 S40:
279 if(!(xx < 2.0e0)) goto S50;
280 prod /= xx;
281 xx += 1.0e0;
282 goto S40;
283 S60:
284 S50:
285 T2 = xx-2.0e0;
286 T4 = xx-2.0e0;
287 alngam = devlpl(scoefn,&K1,&T2)/devlpl(scoefd,&K3,&T4);
288 /*
289 COMPUTE RATIONAL APPROXIMATION TO GAMMA(X)
290 */
291 alngam *= prod;
292 alngam = log(alngam);
293 goto S110;
294 S70:
295 offset = hln2pi;
296 /*
297 IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET
298 */
299 n = fifidint(12.0e0-*x);
300 if(!(n > 0)) goto S90;
301 prod = 1.0e0;
302 for(i=1; i<=n; i++) prod *= (*x+(double)(i-1));
303 offset -= log(prod);
304 xx = *x+(double)n;
305 goto S100;
306 S90:
307 xx = *x;
308 S100:
309 /*
310 COMPUTE POWER SERIES
311 */
312 T6 = 1.0e0/pow(xx,2.0);
313 alngam = devlpl(coef,&K5,&T6)/xx;
314 alngam += (offset+(xx-0.5e0)*log(xx)-xx);
315 S110:
316 return alngam;
317 #undef hln2pi
318 } /* END */
319
320 /***=====================================================================***/
alnrel(double * a)321 static double alnrel(double *a)
322 /*
323 -----------------------------------------------------------------------
324 EVALUATION OF THE FUNCTION LN(1 + A)
325 -----------------------------------------------------------------------
326 */
327 {
328 static double p1 = -.129418923021993e+01;
329 static double p2 = .405303492862024e+00;
330 static double p3 = -.178874546012214e-01;
331 static double q1 = -.162752256355323e+01;
332 static double q2 = .747811014037616e+00;
333 static double q3 = -.845104217945565e-01;
334 static double alnrel,t,t2,w,x;
335 /*
336 ..
337 .. Executable Statements ..
338 */
339 if(fabs(*a) > 0.375e0) goto S10;
340 t = *a/(*a+2.0e0);
341 t2 = t*t;
342 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0);
343 alnrel = 2.0e0*t*w;
344 return alnrel;
345 S10:
346 x = 1.e0+*a;
347 alnrel = log(x);
348 return alnrel;
349 } /* END */
350
351 /***=====================================================================***/
apser(double * a,double * b,double * x,double * eps)352 static double apser(double *a,double *b,double *x,double *eps)
353 /*
354 -----------------------------------------------------------------------
355 APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR
356 A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN
357 A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED.
358 -----------------------------------------------------------------------
359 */
360 {
361 static double g = .577215664901533e0;
362 static double apser,aj,bx,c,j,s,t,tol;
363 /*
364 ..
365 .. Executable Statements ..
366 */
367 bx = *b**x;
368 t = *x-bx;
369 if(*b**eps > 2.e-2) goto S10;
370 c = log(*x)+psi(b)+g+t;
371 goto S20;
372 S10:
373 c = log(bx)+g+t;
374 S20:
375 tol = 5.0e0**eps*fabs(c);
376 j = 1.0e0;
377 s = 0.0e0;
378 S30:
379 j += 1.0e0;
380 t *= (*x-bx/j);
381 aj = t/j;
382 s += aj;
383 if(fabs(aj) > tol) goto S30;
384 apser = -(*a*(c+s));
385 return apser;
386 } /* END */
387
388 /***=====================================================================***/
basym(double * a,double * b,double * lambda,double * eps)389 static double basym(double *a,double *b,double *lambda,double *eps)
390 /*
391 -----------------------------------------------------------------------
392 ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B.
393 LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED.
394 IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT
395 A AND B ARE GREATER THAN OR EQUAL TO 15.
396 -----------------------------------------------------------------------
397 */
398 {
399 static double e0 = 1.12837916709551e0;
400 static double e1 = .353553390593274e0;
401 static int num = 20;
402 /*
403 ------------------------
404 ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP
405 ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN.
406 THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1.
407 ------------------------
408 E0 = 2/SQRT(PI)
409 E1 = 2**(-3/2)
410 ------------------------
411 */
412 static int K3 = 1;
413 static double basym,bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0,
414 z2,zn,znm1;
415 static int i,im1,imj,j,m,mm1,mmj,n,np1;
416 static double a0[21],b0[21],c[21],d[21],T1,T2;
417 /*
418 ..
419 .. Executable Statements ..
420 */
421 basym = 0.0e0;
422 if(*a >= *b) goto S10;
423 h = *a/ *b;
424 r0 = 1.0e0/(1.0e0+h);
425 r1 = (*b-*a)/ *b;
426 w0 = 1.0e0/sqrt(*a*(1.0e0+h));
427 goto S20;
428 S10:
429 h = *b/ *a;
430 r0 = 1.0e0/(1.0e0+h);
431 r1 = (*b-*a)/ *a;
432 w0 = 1.0e0/sqrt(*b*(1.0e0+h));
433 S20:
434 T1 = -(*lambda/ *a);
435 T2 = *lambda/ *b;
436 f = *a*rlog1(&T1)+*b*rlog1(&T2);
437 t = exp(-f);
438 if(t == 0.0e0) return basym;
439 z0 = sqrt(f);
440 z = 0.5e0*(z0/e1);
441 z2 = f+f;
442 a0[0] = 2.0e0/3.0e0*r1;
443 c[0] = -(0.5e0*a0[0]);
444 d[0] = -c[0];
445 j0 = 0.5e0/e0*erfc1(&K3,&z0);
446 j1 = e1;
447 sum = j0+d[0]*w0*j1;
448 s = 1.0e0;
449 h2 = h*h;
450 hn = 1.0e0;
451 w = w0;
452 znm1 = z;
453 zn = z2;
454 for(n=2; n<=num; n+=2) {
455 hn = h2*hn;
456 a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0);
457 np1 = n+1;
458 s += hn;
459 a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0);
460 for(i=n; i<=np1; i++) {
461 r = -(0.5e0*((double)i+1.0e0));
462 b0[0] = r*a0[0];
463 for(m=2; m<=i; m++) {
464 bsum = 0.0e0;
465 mm1 = m-1;
466 for(j=1; j<=mm1; j++) {
467 mmj = m-j;
468 bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]);
469 }
470 b0[m-1] = r*a0[m-1]+bsum/(double)m;
471 }
472 c[i-1] = b0[i-1]/((double)i+1.0e0);
473 dsum = 0.0e0;
474 im1 = i-1;
475 for(j=1; j<=im1; j++) {
476 imj = i-j;
477 dsum += (d[imj-1]*c[j-1]);
478 }
479 d[i-1] = -(dsum+c[i-1]);
480 }
481 j0 = e1*znm1+((double)n-1.0e0)*j0;
482 j1 = e1*zn+(double)n*j1;
483 znm1 = z2*znm1;
484 zn = z2*zn;
485 w = w0*w;
486 t0 = d[n-1]*w*j0;
487 w = w0*w;
488 t1 = d[np1-1]*w*j1;
489 sum += (t0+t1);
490 if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80;
491 }
492 S80:
493 u = exp(-bcorr(a,b));
494 basym = e0*t*u*sum;
495 return basym;
496 } /* END */
497
498 /***=====================================================================***/
bcorr(double * a0,double * b0)499 static double bcorr(double *a0,double *b0)
500 /*
501 -----------------------------------------------------------------------
502
503 EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE
504 LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A).
505 IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8.
506
507 -----------------------------------------------------------------------
508 */
509 {
510 static double c0 = .833333333333333e-01;
511 static double c1 = -.277777777760991e-02;
512 static double c2 = .793650666825390e-03;
513 static double c3 = -.595202931351870e-03;
514 static double c4 = .837308034031215e-03;
515 static double c5 = -.165322962780713e-02;
516 static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2;
517 /*
518 ..
519 .. Executable Statements ..
520 */
521 a = fifdmin1(*a0,*b0);
522 b = fifdmax1(*a0,*b0);
523 h = a/b;
524 c = h/(1.0e0+h);
525 x = 1.0e0/(1.0e0+h);
526 x2 = x*x;
527 /*
528 SET SN = (1 - X**N)/(1 - X)
529 */
530 s3 = 1.0e0+(x+x2);
531 s5 = 1.0e0+(x+x2*s3);
532 s7 = 1.0e0+(x+x2*s5);
533 s9 = 1.0e0+(x+x2*s7);
534 s11 = 1.0e0+(x+x2*s9);
535 /*
536 SET W = DEL(B) - DEL(A + B)
537 */
538 t = pow(1.0e0/b,2.0);
539 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0;
540 w *= (c/b);
541 /*
542 COMPUTE DEL(A) + W
543 */
544 t = pow(1.0e0/a,2.0);
545 bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a+w;
546 return bcorr;
547 } /* END */
548
549 /***=====================================================================***/
betaln(double * a0,double * b0)550 static double betaln(double *a0,double *b0)
551 /*
552 -----------------------------------------------------------------------
553 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
554 -----------------------------------------------------------------------
555 E = 0.5*LN(2*PI)
556 --------------------------
557 */
558 {
559 static double e = .918938533204673e0;
560 static double betaln,a,b,c,h,u,v,w,z;
561 static int i,n;
562 static double T1;
563 /*
564 ..
565 .. Executable Statements ..
566 */
567 a = fifdmin1(*a0,*b0);
568 b = fifdmax1(*a0,*b0);
569 if(a >= 8.0e0) goto S100;
570 if(a >= 1.0e0) goto S20;
571 /*
572 -----------------------------------------------------------------------
573 PROCEDURE WHEN A .LT. 1
574 -----------------------------------------------------------------------
575 */
576 if(b >= 8.0e0) goto S10;
577 T1 = a+b;
578 betaln = gamln(&a)+(gamln(&b)-gamln(&T1));
579 return betaln;
580 S10:
581 betaln = gamln(&a)+algdiv(&a,&b);
582 return betaln;
583 S20:
584 /*
585 -----------------------------------------------------------------------
586 PROCEDURE WHEN 1 .LE. A .LT. 8
587 -----------------------------------------------------------------------
588 */
589 if(a > 2.0e0) goto S40;
590 if(b > 2.0e0) goto S30;
591 betaln = gamln(&a)+gamln(&b)-gsumln(&a,&b);
592 return betaln;
593 S30:
594 w = 0.0e0;
595 if(b < 8.0e0) goto S60;
596 betaln = gamln(&a)+algdiv(&a,&b);
597 return betaln;
598 S40:
599 /*
600 REDUCTION OF A WHEN B .LE. 1000
601 */
602 if(b > 1000.0e0) goto S80;
603 n = a-1.0e0;
604 w = 1.0e0;
605 for(i=1; i<=n; i++) {
606 a -= 1.0e0;
607 h = a/b;
608 w *= (h/(1.0e0+h));
609 }
610 w = log(w);
611 if(b < 8.0e0) goto S60;
612 betaln = w+gamln(&a)+algdiv(&a,&b);
613 return betaln;
614 S60:
615 /*
616 REDUCTION OF B WHEN B .LT. 8
617 */
618 n = b-1.0e0;
619 z = 1.0e0;
620 for(i=1; i<=n; i++) {
621 b -= 1.0e0;
622 z *= (b/(a+b));
623 }
624 betaln = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b)));
625 return betaln;
626 S80:
627 /*
628 REDUCTION OF A WHEN B .GT. 1000
629 */
630 n = a-1.0e0;
631 w = 1.0e0;
632 for(i=1; i<=n; i++) {
633 a -= 1.0e0;
634 w *= (a/(1.0e0+a/b));
635 }
636 betaln = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b));
637 return betaln;
638 S100:
639 /*
640 -----------------------------------------------------------------------
641 PROCEDURE WHEN A .GE. 8
642 -----------------------------------------------------------------------
643 */
644 w = bcorr(&a,&b);
645 h = a/b;
646 c = h/(1.0e0+h);
647 u = -((a-0.5e0)*log(c));
648 v = b*alnrel(&h);
649 if(u <= v) goto S110;
650 betaln = -(0.5e0*log(b))+e+w-v-u;
651 return betaln;
652 S110:
653 betaln = -(0.5e0*log(b))+e+w-u-v;
654 return betaln;
655 } /* END */
656
657 /***=====================================================================***/
bfrac(double * a,double * b,double * x,double * y,double * lambda,double * eps)658 static double bfrac(double *a,double *b,double *x,double *y,double *lambda,
659 double *eps)
660 /*
661 -----------------------------------------------------------------------
662 CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1.
663 IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B.
664 -----------------------------------------------------------------------
665 */
666 {
667 static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1;
668 /*
669 ..
670 .. Executable Statements ..
671 */
672 bfrac = brcomp(a,b,x,y);
673 if(bfrac == 0.0e0) return bfrac;
674 c = 1.0e0+*lambda;
675 c0 = *b/ *a;
676 c1 = 1.0e0+1.0e0/ *a;
677 yp1 = *y+1.0e0;
678 n = 0.0e0;
679 p = 1.0e0;
680 s = *a+1.0e0;
681 an = 0.0e0;
682 bn = anp1 = 1.0e0;
683 bnp1 = c/c1;
684 r = c1/c;
685 S10:
686 /*
687 CONTINUED FRACTION CALCULATION
688 */
689 n += 1.0e0;
690 t = n/ *a;
691 w = n*(*b-n)**x;
692 e = *a/s;
693 alpha = p*(p+c0)*e*e*(w**x);
694 e = (1.0e0+t)/(c1+t+t);
695 beta = n+w/s+e*(c+n*yp1);
696 p = 1.0e0+t;
697 s += 2.0e0;
698 /*
699 UPDATE AN, BN, ANP1, AND BNP1
700 */
701 t = alpha*an+beta*anp1;
702 an = anp1;
703 anp1 = t;
704 t = alpha*bn+beta*bnp1;
705 bn = bnp1;
706 bnp1 = t;
707 r0 = r;
708 r = anp1/bnp1;
709 if(fabs(r-r0) <= *eps*r) goto S20;
710 /*
711 RESCALE AN, BN, ANP1, AND BNP1
712 */
713 an /= bnp1;
714 bn /= bnp1;
715 anp1 = r;
716 bnp1 = 1.0e0;
717 goto S10;
718 S20:
719 /*
720 TERMINATION
721 */
722 bfrac *= r;
723 return bfrac;
724 } /* END */
725
726 /***=====================================================================***/
bgrat(double * a,double * b,double * x,double * y,double * w,double * eps,int * ierr)727 static void bgrat(double *a,double *b,double *x,double *y,double *w,
728 double *eps,int *ierr)
729 /*
730 -----------------------------------------------------------------------
731 ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B.
732 THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED
733 THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED.
734 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
735 -----------------------------------------------------------------------
736 */
737 {
738 static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z;
739 static int i,n,nm1;
740 static double c[30],d[30],T1;
741 /*
742 ..
743 .. Executable Statements ..
744 */
745 bm1 = *b-0.5e0-0.5e0;
746 nu = *a+0.5e0*bm1;
747 if(*y > 0.375e0) goto S10;
748 T1 = -*y;
749 lnx = alnrel(&T1);
750 goto S20;
751 S10:
752 lnx = log(*x);
753 S20:
754 z = -(nu*lnx);
755 if(*b*z == 0.0e0) goto S70;
756 /*
757 COMPUTATION OF THE EXPANSION
758 SET R = EXP(-Z)*Z**B/GAMMA(B)
759 */
760 r = *b*(1.0e0+gam1(b))*exp(*b*log(z));
761 r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx));
762 u = algdiv(b,a)+*b*log(nu);
763 u = r*exp(-u);
764 if(u == 0.0e0) goto S70;
765 grat1(b,&z,&r,&p,&q,eps);
766 v = 0.25e0*pow(1.0e0/nu,2.0);
767 t2 = 0.25e0*lnx*lnx;
768 l = *w/u;
769 j = q/r;
770 sum = j;
771 t = cn = 1.0e0;
772 n2 = 0.0e0;
773 for(n=1; n<=30; n++) {
774 bp2n = *b+n2;
775 j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v;
776 n2 += 2.0e0;
777 t *= t2;
778 cn /= (n2*(n2+1.0e0));
779 c[n-1] = cn;
780 s = 0.0e0;
781 if(n == 1) goto S40;
782 nm1 = n-1;
783 coef = *b-(double)n;
784 for(i=1; i<=nm1; i++) {
785 s += (coef*c[i-1]*d[n-i-1]);
786 coef += *b;
787 }
788 S40:
789 d[n-1] = bm1*cn+s/(double)n;
790 dj = d[n-1]*j;
791 sum += dj;
792 if(sum <= 0.0e0) goto S70;
793 if(fabs(dj) <= *eps*(sum+l)) goto S60;
794 }
795 S60:
796 /*
797 ADD THE RESULTS TO W
798 */
799 *ierr = 0;
800 *w += (u*sum);
801 return;
802 S70:
803 /*
804 THE EXPANSION CANNOT BE COMPUTED
805 */
806 *ierr = 1;
807 return;
808 } /* END */
809
810 /***=====================================================================***/
bpser(double * a,double * b,double * x,double * eps)811 static double bpser(double *a,double *b,double *x,double *eps)
812 /*
813 -----------------------------------------------------------------------
814 POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1
815 OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED.
816 -----------------------------------------------------------------------
817 */
818 {
819 static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z;
820 static int i,m;
821 /*
822 ..
823 .. Executable Statements ..
824 */
825 bpser = 0.0e0;
826 if(*x == 0.0e0) return bpser;
827 /*
828 -----------------------------------------------------------------------
829 COMPUTE THE FACTOR X**A/(A*BETA(A,B))
830 -----------------------------------------------------------------------
831 */
832 a0 = fifdmin1(*a,*b);
833 if(a0 < 1.0e0) goto S10;
834 z = *a*log(*x)-betaln(a,b);
835 bpser = exp(z)/ *a;
836 goto S100;
837 S10:
838 b0 = fifdmax1(*a,*b);
839 if(b0 >= 8.0e0) goto S90;
840 if(b0 > 1.0e0) goto S40;
841 /*
842 PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1
843 */
844 bpser = pow(*x,*a);
845 if(bpser == 0.0e0) return bpser;
846 apb = *a+*b;
847 if(apb > 1.0e0) goto S20;
848 z = 1.0e0+gam1(&apb);
849 goto S30;
850 S20:
851 u = *a+*b-1.e0;
852 z = (1.0e0+gam1(&u))/apb;
853 S30:
854 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
855 bpser *= (c*(*b/apb));
856 goto S100;
857 S40:
858 /*
859 PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8
860 */
861 u = gamln1(&a0);
862 m = b0-1.0e0;
863 if(m < 1) goto S60;
864 c = 1.0e0;
865 for(i=1; i<=m; i++) {
866 b0 -= 1.0e0;
867 c *= (b0/(a0+b0));
868 }
869 u = log(c)+u;
870 S60:
871 z = *a*log(*x)-u;
872 b0 -= 1.0e0;
873 apb = a0+b0;
874 if(apb > 1.0e0) goto S70;
875 t = 1.0e0+gam1(&apb);
876 goto S80;
877 S70:
878 u = a0+b0-1.e0;
879 t = (1.0e0+gam1(&u))/apb;
880 S80:
881 bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t;
882 goto S100;
883 S90:
884 /*
885 PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8
886 */
887 u = gamln1(&a0)+algdiv(&a0,&b0);
888 z = *a*log(*x)-u;
889 bpser = a0/ *a*exp(z);
890 S100:
891 if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser;
892 /*
893 -----------------------------------------------------------------------
894 COMPUTE THE SERIES
895 -----------------------------------------------------------------------
896 */
897 sum = n = 0.0e0;
898 c = 1.0e0;
899 tol = *eps/ *a;
900 S110:
901 n += 1.0e0;
902 c *= ((0.5e0+(0.5e0-*b/n))**x);
903 w = c/(*a+n);
904 sum += w;
905 if(fabs(w) > tol) goto S110;
906 bpser *= (1.0e0+*a*sum);
907 return bpser;
908 } /* END */
909
910 /***=====================================================================***/
bratio(double * a,double * b,double * x,double * y,double * w,double * w1,int * ierr)911 static void bratio(double *a,double *b,double *x,double *y,double *w,
912 double *w1,int *ierr)
913 /*
914 -----------------------------------------------------------------------
915
916 EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B)
917
918 --------------------
919
920 IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1
921 AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES
922
923 W = IX(A,B)
924 W1 = 1 - IX(A,B)
925
926 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
927 IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND
928 W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED,
929 THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO
930 ONE OF THE FOLLOWING VALUES ...
931
932 IERR = 1 IF A OR B IS NEGATIVE
933 IERR = 2 IF A = B = 0
934 IERR = 3 IF X .LT. 0 OR X .GT. 1
935 IERR = 4 IF Y .LT. 0 OR Y .GT. 1
936 IERR = 5 IF X + Y .NE. 1
937 IERR = 6 IF X = A = 0
938 IERR = 7 IF Y = B = 0
939
940 --------------------
941 WRITTEN BY ALFRED H. MORRIS, JR.
942 NAVAL SURFACE WARFARE CENTER
943 DAHLGREN, VIRGINIA
944 REVISED ... NOV 1991
945 -----------------------------------------------------------------------
946 */
947 {
948 static int K1 = 1;
949 static double a0,b0,eps,lambda,t,x0,y0,z;
950 static int ierr1,ind,n;
951 static double T2,T3,T4,T5;
952 /*
953 ..
954 .. Executable Statements ..
955 */
956 /*
957 ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST
958 FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0
959 */
960 eps = spmpar(&K1);
961 *w = *w1 = 0.0e0;
962 if(*a < 0.0e0 || *b < 0.0e0) goto S270;
963 if(*a == 0.0e0 && *b == 0.0e0) goto S280;
964 if(*x < 0.0e0 || *x > 1.0e0) goto S290;
965 if(*y < 0.0e0 || *y > 1.0e0) goto S300;
966 z = *x+*y-0.5e0-0.5e0;
967 if(fabs(z) > 3.0e0*eps) goto S310;
968 *ierr = 0;
969 if(*x == 0.0e0) goto S210;
970 if(*y == 0.0e0) goto S230;
971 if(*a == 0.0e0) goto S240;
972 if(*b == 0.0e0) goto S220;
973 eps = fifdmax1(eps,1.e-15);
974 if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260;
975 ind = 0;
976 a0 = *a;
977 b0 = *b;
978 x0 = *x;
979 y0 = *y;
980 if(fifdmin1(a0,b0) > 1.0e0) goto S40;
981 /*
982 PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1
983 */
984 if(*x <= 0.5e0) goto S10;
985 ind = 1;
986 a0 = *b;
987 b0 = *a;
988 x0 = *y;
989 y0 = *x;
990 S10:
991 if(b0 < fifdmin1(eps,eps*a0)) goto S90;
992 if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100;
993 if(fifdmax1(a0,b0) > 1.0e0) goto S20;
994 if(a0 >= fifdmin1(0.2e0,b0)) goto S110;
995 if(pow(x0,a0) <= 0.9e0) goto S110;
996 if(x0 >= 0.3e0) goto S120;
997 n = 20;
998 goto S140;
999 S20:
1000 if(b0 <= 1.0e0) goto S110;
1001 if(x0 >= 0.3e0) goto S120;
1002 if(x0 >= 0.1e0) goto S30;
1003 if(pow(x0*b0,a0) <= 0.7e0) goto S110;
1004 S30:
1005 if(b0 > 15.0e0) goto S150;
1006 n = 20;
1007 goto S140;
1008 S40:
1009 /*
1010 PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1
1011 */
1012 if(*a > *b) goto S50;
1013 lambda = *a-(*a+*b)**x;
1014 goto S60;
1015 S50:
1016 lambda = (*a+*b)**y-*b;
1017 S60:
1018 if(lambda >= 0.0e0) goto S70;
1019 ind = 1;
1020 a0 = *b;
1021 b0 = *a;
1022 x0 = *y;
1023 y0 = *x;
1024 lambda = fabs(lambda);
1025 S70:
1026 if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110;
1027 if(b0 < 40.0e0) goto S160;
1028 if(a0 > b0) goto S80;
1029 if(a0 <= 100.0e0) goto S130;
1030 if(lambda > 0.03e0*a0) goto S130;
1031 goto S200;
1032 S80:
1033 if(b0 <= 100.0e0) goto S130;
1034 if(lambda > 0.03e0*b0) goto S130;
1035 goto S200;
1036 S90:
1037 /*
1038 EVALUATION OF THE APPROPRIATE ALGORITHM
1039 */
1040 *w = fpser(&a0,&b0,&x0,&eps);
1041 *w1 = 0.5e0+(0.5e0-*w);
1042 goto S250;
1043 S100:
1044 *w1 = apser(&a0,&b0,&x0,&eps);
1045 *w = 0.5e0+(0.5e0-*w1);
1046 goto S250;
1047 S110:
1048 *w = bpser(&a0,&b0,&x0,&eps);
1049 *w1 = 0.5e0+(0.5e0-*w);
1050 goto S250;
1051 S120:
1052 *w1 = bpser(&b0,&a0,&y0,&eps);
1053 *w = 0.5e0+(0.5e0-*w1);
1054 goto S250;
1055 S130:
1056 T2 = 15.0e0*eps;
1057 *w = bfrac(&a0,&b0,&x0,&y0,&lambda,&T2);
1058 *w1 = 0.5e0+(0.5e0-*w);
1059 goto S250;
1060 S140:
1061 *w1 = bup(&b0,&a0,&y0,&x0,&n,&eps);
1062 b0 += (double)n;
1063 S150:
1064 T3 = 15.0e0*eps;
1065 bgrat(&b0,&a0,&y0,&x0,w1,&T3,&ierr1);
1066 *w = 0.5e0+(0.5e0-*w1);
1067 goto S250;
1068 S160:
1069 n = b0;
1070 b0 -= (double)n;
1071 if(b0 != 0.0e0) goto S170;
1072 n -= 1;
1073 b0 = 1.0e0;
1074 S170:
1075 *w = bup(&b0,&a0,&y0,&x0,&n,&eps);
1076 if(x0 > 0.7e0) goto S180;
1077 *w += bpser(&a0,&b0,&x0,&eps);
1078 *w1 = 0.5e0+(0.5e0-*w);
1079 goto S250;
1080 S180:
1081 if(a0 > 15.0e0) goto S190;
1082 n = 20;
1083 *w += bup(&a0,&b0,&x0,&y0,&n,&eps);
1084 a0 += (double)n;
1085 S190:
1086 T4 = 15.0e0*eps;
1087 bgrat(&a0,&b0,&x0,&y0,w,&T4,&ierr1);
1088 *w1 = 0.5e0+(0.5e0-*w);
1089 goto S250;
1090 S200:
1091 T5 = 100.0e0*eps;
1092 *w = basym(&a0,&b0,&lambda,&T5);
1093 *w1 = 0.5e0+(0.5e0-*w);
1094 goto S250;
1095 S210:
1096 /*
1097 TERMINATION OF THE PROCEDURE
1098 */
1099 if(*a == 0.0e0) goto S320;
1100 S220:
1101 *w = 0.0e0;
1102 *w1 = 1.0e0;
1103 return;
1104 S230:
1105 if(*b == 0.0e0) goto S330;
1106 S240:
1107 *w = 1.0e0;
1108 *w1 = 0.0e0;
1109 return;
1110 S250:
1111 if(ind == 0) return;
1112 t = *w;
1113 *w = *w1;
1114 *w1 = t;
1115 return;
1116 S260:
1117 /*
1118 PROCEDURE FOR A AND B .LT. 1.E-3*EPS
1119 */
1120 *w = *b/(*a+*b);
1121 *w1 = *a/(*a+*b);
1122 return;
1123 S270:
1124 /*
1125 ERROR RETURN
1126 */
1127 *ierr = 1;
1128 return;
1129 S280:
1130 *ierr = 2;
1131 return;
1132 S290:
1133 *ierr = 3;
1134 return;
1135 S300:
1136 *ierr = 4;
1137 return;
1138 S310:
1139 *ierr = 5;
1140 return;
1141 S320:
1142 *ierr = 6;
1143 return;
1144 S330:
1145 *ierr = 7;
1146 return;
1147 } /* END */
1148
1149 /***=====================================================================***/
brcmp1(int * mu,double * a,double * b,double * x,double * y)1150 static double brcmp1(int *mu,double *a,double *b,double *x,double *y)
1151 /*
1152 -----------------------------------------------------------------------
1153 EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B))
1154 -----------------------------------------------------------------------
1155 */
1156 {
1157 static double Const = .398942280401433e0;
1158 static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1159 static int i,n;
1160 /*
1161 -----------------
1162 CONST = 1/SQRT(2*PI)
1163 -----------------
1164 */
1165 static double T1,T2,T3,T4;
1166 /*
1167 ..
1168 .. Executable Statements ..
1169 */
1170 a0 = fifdmin1(*a,*b);
1171 if(a0 >= 8.0e0) goto S130;
1172 if(*x > 0.375e0) goto S10;
1173 lnx = log(*x);
1174 T1 = -*x;
1175 lny = alnrel(&T1);
1176 goto S30;
1177 S10:
1178 if(*y > 0.375e0) goto S20;
1179 T2 = -*y;
1180 lnx = alnrel(&T2);
1181 lny = log(*y);
1182 goto S30;
1183 S20:
1184 lnx = log(*x);
1185 lny = log(*y);
1186 S30:
1187 z = *a*lnx+*b*lny;
1188 if(a0 < 1.0e0) goto S40;
1189 z -= betaln(a,b);
1190 brcmp1 = esum(mu,&z);
1191 return brcmp1;
1192 S40:
1193 /*
1194 -----------------------------------------------------------------------
1195 PROCEDURE FOR A .LT. 1 OR B .LT. 1
1196 -----------------------------------------------------------------------
1197 */
1198 b0 = fifdmax1(*a,*b);
1199 if(b0 >= 8.0e0) goto S120;
1200 if(b0 > 1.0e0) goto S70;
1201 /*
1202 ALGORITHM FOR B0 .LE. 1
1203 */
1204 brcmp1 = esum(mu,&z);
1205 if(brcmp1 == 0.0e0) return brcmp1;
1206 apb = *a+*b;
1207 if(apb > 1.0e0) goto S50;
1208 z = 1.0e0+gam1(&apb);
1209 goto S60;
1210 S50:
1211 u = *a+*b-1.e0;
1212 z = (1.0e0+gam1(&u))/apb;
1213 S60:
1214 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1215 brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0);
1216 return brcmp1;
1217 S70:
1218 /*
1219 ALGORITHM FOR 1 .LT. B0 .LT. 8
1220 */
1221 u = gamln1(&a0);
1222 n = b0-1.0e0;
1223 if(n < 1) goto S90;
1224 c = 1.0e0;
1225 for(i=1; i<=n; i++) {
1226 b0 -= 1.0e0;
1227 c *= (b0/(a0+b0));
1228 }
1229 u = log(c)+u;
1230 S90:
1231 z -= u;
1232 b0 -= 1.0e0;
1233 apb = a0+b0;
1234 if(apb > 1.0e0) goto S100;
1235 t = 1.0e0+gam1(&apb);
1236 goto S110;
1237 S100:
1238 u = a0+b0-1.e0;
1239 t = (1.0e0+gam1(&u))/apb;
1240 S110:
1241 brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t;
1242 return brcmp1;
1243 S120:
1244 /*
1245 ALGORITHM FOR B0 .GE. 8
1246 */
1247 u = gamln1(&a0)+algdiv(&a0,&b0);
1248 T3 = z-u;
1249 brcmp1 = a0*esum(mu,&T3);
1250 return brcmp1;
1251 S130:
1252 /*
1253 -----------------------------------------------------------------------
1254 PROCEDURE FOR A .GE. 8 AND B .GE. 8
1255 -----------------------------------------------------------------------
1256 */
1257 if(*a > *b) goto S140;
1258 h = *a/ *b;
1259 x0 = h/(1.0e0+h);
1260 y0 = 1.0e0/(1.0e0+h);
1261 lambda = *a-(*a+*b)**x;
1262 goto S150;
1263 S140:
1264 h = *b/ *a;
1265 x0 = 1.0e0/(1.0e0+h);
1266 y0 = h/(1.0e0+h);
1267 lambda = (*a+*b)**y-*b;
1268 S150:
1269 e = -(lambda/ *a);
1270 if(fabs(e) > 0.6e0) goto S160;
1271 u = rlog1(&e);
1272 goto S170;
1273 S160:
1274 u = e-log(*x/x0);
1275 S170:
1276 e = lambda/ *b;
1277 if(fabs(e) > 0.6e0) goto S180;
1278 v = rlog1(&e);
1279 goto S190;
1280 S180:
1281 v = e-log(*y/y0);
1282 S190:
1283 T4 = -(*a*u+*b*v);
1284 z = esum(mu,&T4);
1285 brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1286 return brcmp1;
1287 } /* END */
1288
1289 /***=====================================================================***/
brcomp(double * a,double * b,double * x,double * y)1290 static double brcomp(double *a,double *b,double *x,double *y)
1291 /*
1292 -----------------------------------------------------------------------
1293 EVALUATION OF X**A*Y**B/BETA(A,B)
1294 -----------------------------------------------------------------------
1295 */
1296 {
1297 static double Const = .398942280401433e0;
1298 static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z;
1299 static int i,n;
1300 /*
1301 -----------------
1302 CONST = 1/SQRT(2*PI)
1303 -----------------
1304 */
1305 static double T1,T2;
1306 /*
1307 ..
1308 .. Executable Statements ..
1309 */
1310 brcomp = 0.0e0;
1311 if(*x == 0.0e0 || *y == 0.0e0) return brcomp;
1312 a0 = fifdmin1(*a,*b);
1313 if(a0 >= 8.0e0) goto S130;
1314 if(*x > 0.375e0) goto S10;
1315 lnx = log(*x);
1316 T1 = -*x;
1317 lny = alnrel(&T1);
1318 goto S30;
1319 S10:
1320 if(*y > 0.375e0) goto S20;
1321 T2 = -*y;
1322 lnx = alnrel(&T2);
1323 lny = log(*y);
1324 goto S30;
1325 S20:
1326 lnx = log(*x);
1327 lny = log(*y);
1328 S30:
1329 z = *a*lnx+*b*lny;
1330 if(a0 < 1.0e0) goto S40;
1331 z -= betaln(a,b);
1332 brcomp = exp(z);
1333 return brcomp;
1334 S40:
1335 /*
1336 -----------------------------------------------------------------------
1337 PROCEDURE FOR A .LT. 1 OR B .LT. 1
1338 -----------------------------------------------------------------------
1339 */
1340 b0 = fifdmax1(*a,*b);
1341 if(b0 >= 8.0e0) goto S120;
1342 if(b0 > 1.0e0) goto S70;
1343 /*
1344 ALGORITHM FOR B0 .LE. 1
1345 */
1346 brcomp = exp(z);
1347 if(brcomp == 0.0e0) return brcomp;
1348 apb = *a+*b;
1349 if(apb > 1.0e0) goto S50;
1350 z = 1.0e0+gam1(&apb);
1351 goto S60;
1352 S50:
1353 u = *a+*b-1.e0;
1354 z = (1.0e0+gam1(&u))/apb;
1355 S60:
1356 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z;
1357 brcomp = brcomp*(a0*c)/(1.0e0+a0/b0);
1358 return brcomp;
1359 S70:
1360 /*
1361 ALGORITHM FOR 1 .LT. B0 .LT. 8
1362 */
1363 u = gamln1(&a0);
1364 n = b0-1.0e0;
1365 if(n < 1) goto S90;
1366 c = 1.0e0;
1367 for(i=1; i<=n; i++) {
1368 b0 -= 1.0e0;
1369 c *= (b0/(a0+b0));
1370 }
1371 u = log(c)+u;
1372 S90:
1373 z -= u;
1374 b0 -= 1.0e0;
1375 apb = a0+b0;
1376 if(apb > 1.0e0) goto S100;
1377 t = 1.0e0+gam1(&apb);
1378 goto S110;
1379 S100:
1380 u = a0+b0-1.e0;
1381 t = (1.0e0+gam1(&u))/apb;
1382 S110:
1383 brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t;
1384 return brcomp;
1385 S120:
1386 /*
1387 ALGORITHM FOR B0 .GE. 8
1388 */
1389 u = gamln1(&a0)+algdiv(&a0,&b0);
1390 brcomp = a0*exp(z-u);
1391 return brcomp;
1392 S130:
1393 /*
1394 -----------------------------------------------------------------------
1395 PROCEDURE FOR A .GE. 8 AND B .GE. 8
1396 -----------------------------------------------------------------------
1397 */
1398 if(*a > *b) goto S140;
1399 h = *a/ *b;
1400 x0 = h/(1.0e0+h);
1401 y0 = 1.0e0/(1.0e0+h);
1402 lambda = *a-(*a+*b)**x;
1403 goto S150;
1404 S140:
1405 h = *b/ *a;
1406 x0 = 1.0e0/(1.0e0+h);
1407 y0 = h/(1.0e0+h);
1408 lambda = (*a+*b)**y-*b;
1409 S150:
1410 e = -(lambda/ *a);
1411 if(fabs(e) > 0.6e0) goto S160;
1412 u = rlog1(&e);
1413 goto S170;
1414 S160:
1415 u = e-log(*x/x0);
1416 S170:
1417 e = lambda/ *b;
1418 if(fabs(e) > 0.6e0) goto S180;
1419 v = rlog1(&e);
1420 goto S190;
1421 S180:
1422 v = e-log(*y/y0);
1423 S190:
1424 z = exp(-(*a*u+*b*v));
1425 brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b));
1426 return brcomp;
1427 } /* END */
1428
1429 /***=====================================================================***/
bup(double * a,double * b,double * x,double * y,int * n,double * eps)1430 static double bup(double *a,double *b,double *x,double *y,int *n,double *eps)
1431 /*
1432 -----------------------------------------------------------------------
1433 EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER.
1434 EPS IS THE TOLERANCE USED.
1435 -----------------------------------------------------------------------
1436 */
1437 {
1438 static int K1 = 1;
1439 static int K2 = 0;
1440 static double bup,ap1,apb,d,l,r,t,w;
1441 static int i,k,kp1,mu,nm1;
1442 /*
1443 ..
1444 .. Executable Statements ..
1445 */
1446 /*
1447 OBTAIN THE SCALING FACTOR EXP(-MU) AND
1448 EXP(MU)*(X**A*Y**B/BETA(A,B))/A
1449 */
1450 apb = *a+*b;
1451 ap1 = *a+1.0e0;
1452 mu = 0;
1453 d = 1.0e0;
1454 if(*n == 1 || *a < 1.0e0) goto S10;
1455 if(apb < 1.1e0*ap1) goto S10;
1456 mu = fabs(exparg(&K1));
1457 k = exparg(&K2);
1458 if(k < mu) mu = k;
1459 t = mu;
1460 d = exp(-t);
1461 S10:
1462 bup = brcmp1(&mu,a,b,x,y)/ *a;
1463 if(*n == 1 || bup == 0.0e0) return bup;
1464 nm1 = *n-1;
1465 w = d;
1466 /*
1467 LET K BE THE INDEX OF THE MAXIMUM TERM
1468 */
1469 k = 0;
1470 if(*b <= 1.0e0) goto S50;
1471 if(*y > 1.e-4) goto S20;
1472 k = nm1;
1473 goto S30;
1474 S20:
1475 r = (*b-1.0e0)**x/ *y-*a;
1476 if(r < 1.0e0) goto S50;
1477 k = t = nm1;
1478 if(r < t) k = r;
1479 S30:
1480 /*
1481 ADD THE INCREASING TERMS OF THE SERIES
1482 */
1483 for(i=1; i<=k; i++) {
1484 l = i-1;
1485 d = (apb+l)/(ap1+l)**x*d;
1486 w += d;
1487 }
1488 if(k == nm1) goto S70;
1489 S50:
1490 /*
1491 ADD THE REMAINING TERMS OF THE SERIES
1492 */
1493 kp1 = k+1;
1494 for(i=kp1; i<=nm1; i++) {
1495 l = i-1;
1496 d = (apb+l)/(ap1+l)**x*d;
1497 w += d;
1498 if(d <= *eps*w) goto S70;
1499 }
1500 S70:
1501 /*
1502 TERMINATE THE PROCEDURE
1503 */
1504 bup *= w;
1505 return bup;
1506 } /* END */
1507
1508 /***=====================================================================***/
cdfbet(int * which,double * p,double * q,double * x,double * y,double * a,double * b,int * status,double * bound)1509 static void cdfbet(int *which,double *p,double *q,double *x,double *y,
1510 double *a,double *b,int *status,double *bound)
1511 /**********************************************************************
1512
1513 void cdfbet(int *which,double *p,double *q,double *x,double *y,
1514 double *a,double *b,int *status,double *bound)
1515
1516 Cumulative Distribution Function
1517 BETa Distribution
1518
1519
1520 Function
1521
1522
1523 Calculates any one parameter of the beta distribution given
1524 values for the others.
1525
1526
1527 Arguments
1528
1529
1530 WHICH --> Integer indicating which of the next four argument
1531 values is to be calculated from the others.
1532 Legal range: 1..4
1533 iwhich = 1 : Calculate P and Q from X,Y,A and B
1534 iwhich = 2 : Calculate X and Y from P,Q,A and B
1535 iwhich = 3 : Calculate A from P,Q,X,Y and B
1536 iwhich = 4 : Calculate B from P,Q,X,Y and A
1537
1538 P <--> The integral from 0 to X of the chi-square
1539 distribution.
1540 Input range: [0, 1].
1541
1542 Q <--> 1-P.
1543 Input range: [0, 1].
1544 P + Q = 1.0.
1545
1546 X <--> Upper limit of integration of beta density.
1547 Input range: [0,1].
1548 Search range: [0,1]
1549
1550 Y <--> 1-X.
1551 Input range: [0,1].
1552 Search range: [0,1]
1553 X + Y = 1.0.
1554
1555 A <--> The first parameter of the beta density.
1556 Input range: (0, +infinity).
1557 Search range: [1D-300,1D300]
1558
1559 B <--> The second parameter of the beta density.
1560 Input range: (0, +infinity).
1561 Search range: [1D-300,1D300]
1562
1563 STATUS <-- 0 if calculation completed correctly
1564 -I if input parameter number I is out of range
1565 1 if answer appears to be lower than lowest
1566 search bound
1567 2 if answer appears to be higher than greatest
1568 search bound
1569 3 if P + Q .ne. 1
1570 4 if X + Y .ne. 1
1571
1572 BOUND <-- Undefined if STATUS is 0
1573
1574 Bound exceeded by parameter number I if STATUS
1575 is negative.
1576
1577 Lower search bound if STATUS is 1.
1578
1579 Upper search bound if STATUS is 2.
1580
1581
1582 Method
1583
1584
1585 Cumulative distribution function (P) is calculated directly by
1586 code associated with the following reference.
1587
1588 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
1589 Digit Computation of the Incomplete Beta Function Ratios. ACM
1590 Trans. Math. Softw. 18 (1993), 360-373.
1591
1592 Computation of other parameters involve a seach for a value that
1593 produces the desired value of P. The search relies on the
1594 monotinicity of P with the other parameter.
1595
1596
1597 Note
1598
1599
1600 The beta density is proportional to
1601 t^(A-1) * (1-t)^(B-1)
1602
1603 **********************************************************************/
1604 {
1605 #define tol (1.0e-8)
1606 #define atol (1.0e-50)
1607 #define zero (1.0e-300)
1608 #define inf 1.0e300
1609 #define one 1.0e0
1610 static int K1 = 1;
1611 static double K2 = 0.0e0;
1612 static double K3 = 1.0e0;
1613 static double K8 = 0.5e0;
1614 static double K9 = 5.0e0;
1615 static double fx,xhi,xlo,cum,ccum,xy,pq;
1616 static unsigned long qhi,qleft,qporq;
1617 static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15;
1618 /*
1619 ..
1620 .. Executable Statements ..
1621 */
1622 /*
1623 Check arguments
1624 */
1625 if(!(*which < 1 || *which > 4)) goto S30;
1626 if(!(*which < 1)) goto S10;
1627 *bound = 1.0e0;
1628 goto S20;
1629 S10:
1630 *bound = 4.0e0;
1631 S20:
1632 *status = -1;
1633 return;
1634 S30:
1635 if(*which == 1) goto S70;
1636 /*
1637 P
1638 */
1639 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
1640 if(!(*p < 0.0e0)) goto S40;
1641 *bound = 0.0e0;
1642 goto S50;
1643 S40:
1644 *bound = 1.0e0;
1645 S50:
1646 *status = -2;
1647 return;
1648 S70:
1649 S60:
1650 if(*which == 1) goto S110;
1651 /*
1652 Q
1653 */
1654 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
1655 if(!(*q < 0.0e0)) goto S80;
1656 *bound = 0.0e0;
1657 goto S90;
1658 S80:
1659 *bound = 1.0e0;
1660 S90:
1661 *status = -3;
1662 return;
1663 S110:
1664 S100:
1665 if(*which == 2) goto S150;
1666 /*
1667 X
1668 */
1669 if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140;
1670 if(!(*x < 0.0e0)) goto S120;
1671 *bound = 0.0e0;
1672 goto S130;
1673 S120:
1674 *bound = 1.0e0;
1675 S130:
1676 *status = -4;
1677 return;
1678 S150:
1679 S140:
1680 if(*which == 2) goto S190;
1681 /*
1682 Y
1683 */
1684 if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180;
1685 if(!(*y < 0.0e0)) goto S160;
1686 *bound = 0.0e0;
1687 goto S170;
1688 S160:
1689 *bound = 1.0e0;
1690 S170:
1691 *status = -5;
1692 return;
1693 S190:
1694 S180:
1695 if(*which == 3) goto S210;
1696 /*
1697 A
1698 */
1699 if(!(*a <= 0.0e0)) goto S200;
1700 *bound = 0.0e0;
1701 *status = -6;
1702 return;
1703 S210:
1704 S200:
1705 if(*which == 4) goto S230;
1706 /*
1707 B
1708 */
1709 if(!(*b <= 0.0e0)) goto S220;
1710 *bound = 0.0e0;
1711 *status = -7;
1712 return;
1713 S230:
1714 S220:
1715 if(*which == 1) goto S270;
1716 /*
1717 P + Q
1718 */
1719 pq = *p+*q;
1720 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260;
1721 if(!(pq < 0.0e0)) goto S240;
1722 *bound = 0.0e0;
1723 goto S250;
1724 S240:
1725 *bound = 1.0e0;
1726 S250:
1727 *status = 3;
1728 return;
1729 S270:
1730 S260:
1731 if(*which == 2) goto S310;
1732 /*
1733 X + Y
1734 */
1735 xy = *x+*y;
1736 if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300;
1737 if(!(xy < 0.0e0)) goto S280;
1738 *bound = 0.0e0;
1739 goto S290;
1740 S280:
1741 *bound = 1.0e0;
1742 S290:
1743 *status = 4;
1744 return;
1745 S310:
1746 S300:
1747 if(!(*which == 1)) qporq = *p <= *q;
1748 /*
1749 Select the minimum of P or Q
1750 Calculate ANSWERS
1751 */
1752 if(1 == *which) {
1753 /*
1754 Calculating P and Q
1755 */
1756 cumbet(x,y,a,b,p,q);
1757 *status = 0;
1758 }
1759 else if(2 == *which) {
1760 /*
1761 Calculating X and Y
1762 */
1763 T4 = atol;
1764 T5 = tol;
1765 dstzr(&K2,&K3,&T4,&T5);
1766 if(!qporq) goto S340;
1767 *status = 0;
1768 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1769 *y = one-*x;
1770 S320:
1771 if(!(*status == 1)) goto S330;
1772 cumbet(x,y,a,b,&cum,&ccum);
1773 fx = cum-*p;
1774 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi);
1775 *y = one-*x;
1776 goto S320;
1777 S330:
1778 goto S370;
1779 S340:
1780 *status = 0;
1781 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1782 *x = one-*y;
1783 S350:
1784 if(!(*status == 1)) goto S360;
1785 cumbet(x,y,a,b,&cum,&ccum);
1786 fx = ccum-*q;
1787 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi);
1788 *x = one-*y;
1789 goto S350;
1790 S370:
1791 S360:
1792 if(!(*status == -1)) goto S400;
1793 if(!qleft) goto S380;
1794 *status = 1;
1795 *bound = 0.0e0;
1796 goto S390;
1797 S380:
1798 *status = 2;
1799 *bound = 1.0e0;
1800 S400:
1801 S390:
1802 ;
1803 }
1804 else if(3 == *which) {
1805 /*
1806 Computing A
1807 */
1808 *a = 5.0e0;
1809 T6 = zero;
1810 T7 = inf;
1811 T10 = atol;
1812 T11 = tol;
1813 dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11);
1814 *status = 0;
1815 dinvr(status,a,&fx,&qleft,&qhi);
1816 S410:
1817 if(!(*status == 1)) goto S440;
1818 cumbet(x,y,a,b,&cum,&ccum);
1819 if(!qporq) goto S420;
1820 fx = cum-*p;
1821 goto S430;
1822 S420:
1823 fx = ccum-*q;
1824 S430:
1825 dinvr(status,a,&fx,&qleft,&qhi);
1826 goto S410;
1827 S440:
1828 if(!(*status == -1)) goto S470;
1829 if(!qleft) goto S450;
1830 *status = 1;
1831 *bound = zero;
1832 goto S460;
1833 S450:
1834 *status = 2;
1835 *bound = inf;
1836 S470:
1837 S460:
1838 ;
1839 }
1840 else if(4 == *which) {
1841 /*
1842 Computing B
1843 */
1844 *b = 5.0e0;
1845 T12 = zero;
1846 T13 = inf;
1847 T14 = atol;
1848 T15 = tol;
1849 dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15);
1850 *status = 0;
1851 dinvr(status,b,&fx,&qleft,&qhi);
1852 S480:
1853 if(!(*status == 1)) goto S510;
1854 cumbet(x,y,a,b,&cum,&ccum);
1855 if(!qporq) goto S490;
1856 fx = cum-*p;
1857 goto S500;
1858 S490:
1859 fx = ccum-*q;
1860 S500:
1861 dinvr(status,b,&fx,&qleft,&qhi);
1862 goto S480;
1863 S510:
1864 if(!(*status == -1)) goto S540;
1865 if(!qleft) goto S520;
1866 *status = 1;
1867 *bound = zero;
1868 goto S530;
1869 S520:
1870 *status = 2;
1871 *bound = inf;
1872 S530:
1873 ;
1874 }
1875 S540:
1876 return;
1877 #undef tol
1878 #undef atol
1879 #undef zero
1880 #undef inf
1881 #undef one
1882 } /* END */
1883
1884 /***=====================================================================***/
cdfbin(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)1885 static void cdfbin(int *which,double *p,double *q,double *s,double *xn,
1886 double *pr,double *ompr,int *status,double *bound)
1887 /**********************************************************************
1888
1889 void cdfbin(int *which,double *p,double *q,double *s,double *xn,
1890 double *pr,double *ompr,int *status,double *bound)
1891
1892 Cumulative Distribution Function
1893 BINomial distribution
1894
1895
1896 Function
1897
1898
1899 Calculates any one parameter of the binomial
1900 distribution given values for the others.
1901
1902
1903 Arguments
1904
1905
1906 WHICH --> Integer indicating which of the next four argument
1907 values is to be calculated from the others.
1908 Legal range: 1..4
1909 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
1910 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
1911 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
1912 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
1913
1914 P <--> The cumulation from 0 to S of the binomial distribution.
1915 (Probablility of S or fewer successes in XN trials each
1916 with probability of success PR.)
1917 Input range: [0,1].
1918
1919 Q <--> 1-P.
1920 Input range: [0, 1].
1921 P + Q = 1.0.
1922
1923 S <--> The number of successes observed.
1924 Input range: [0, XN]
1925 Search range: [0, XN]
1926
1927 XN <--> The number of binomial trials.
1928 Input range: (0, +infinity).
1929 Search range: [1E-300, 1E300]
1930
1931 PR <--> The probability of success in each binomial trial.
1932 Input range: [0,1].
1933 Search range: [0,1]
1934
1935 OMPR <--> 1-PR
1936 Input range: [0,1].
1937 Search range: [0,1]
1938 PR + OMPR = 1.0
1939
1940 STATUS <-- 0 if calculation completed correctly
1941 -I if input parameter number I is out of range
1942 1 if answer appears to be lower than lowest
1943 search bound
1944 2 if answer appears to be higher than greatest
1945 search bound
1946 3 if P + Q .ne. 1
1947 4 if PR + OMPR .ne. 1
1948
1949 BOUND <-- Undefined if STATUS is 0
1950
1951 Bound exceeded by parameter number I if STATUS
1952 is negative.
1953
1954 Lower search bound if STATUS is 1.
1955
1956 Upper search bound if STATUS is 2.
1957
1958
1959 Method
1960
1961
1962 Formula 26.5.24 of Abramowitz and Stegun, Handbook of
1963 Mathematical Functions (1966) is used to reduce the binomial
1964 distribution to the cumulative incomplete beta distribution.
1965
1966 Computation of other parameters involve a seach for a value that
1967 produces the desired value of P. The search relies on the
1968 monotinicity of P with the other parameter.
1969
1970
1971 **********************************************************************/
1972 {
1973 #define atol (1.0e-50)
1974 #define tol (1.0e-8)
1975 #define zero (1.0e-300)
1976 #define inf 1.0e300
1977 #define one 1.0e0
1978 static int K1 = 1;
1979 static double K2 = 0.0e0;
1980 static double K3 = 0.5e0;
1981 static double K4 = 5.0e0;
1982 static double K11 = 1.0e0;
1983 static double fx,xhi,xlo,cum,ccum,pq,prompr;
1984 static unsigned long qhi,qleft,qporq;
1985 static double T5,T6,T7,T8,T9,T10,T12,T13;
1986 /*
1987 ..
1988 .. Executable Statements ..
1989 */
1990 /*
1991 Check arguments
1992 */
1993 if(!(*which < 1 && *which > 4)) goto S30;
1994 if(!(*which < 1)) goto S10;
1995 *bound = 1.0e0;
1996 goto S20;
1997 S10:
1998 *bound = 4.0e0;
1999 S20:
2000 *status = -1;
2001 return;
2002 S30:
2003 if(*which == 1) goto S70;
2004 /*
2005 P
2006 */
2007 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2008 if(!(*p < 0.0e0)) goto S40;
2009 *bound = 0.0e0;
2010 goto S50;
2011 S40:
2012 *bound = 1.0e0;
2013 S50:
2014 *status = -2;
2015 return;
2016 S70:
2017 S60:
2018 if(*which == 1) goto S110;
2019 /*
2020 Q
2021 */
2022 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100;
2023 if(!(*q < 0.0e0)) goto S80;
2024 *bound = 0.0e0;
2025 goto S90;
2026 S80:
2027 *bound = 1.0e0;
2028 S90:
2029 *status = -3;
2030 return;
2031 S110:
2032 S100:
2033 if(*which == 3) goto S130;
2034 /*
2035 XN
2036 */
2037 if(!(*xn <= 0.0e0)) goto S120;
2038 *bound = 0.0e0;
2039 *status = -5;
2040 return;
2041 S130:
2042 S120:
2043 if(*which == 2) goto S170;
2044 /*
2045 S
2046 */
2047 if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160;
2048 if(!(*s < 0.0e0)) goto S140;
2049 *bound = 0.0e0;
2050 goto S150;
2051 S140:
2052 *bound = *xn;
2053 S150:
2054 *status = -4;
2055 return;
2056 S170:
2057 S160:
2058 if(*which == 4) goto S210;
2059 /*
2060 PR
2061 */
2062 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200;
2063 if(!(*pr < 0.0e0)) goto S180;
2064 *bound = 0.0e0;
2065 goto S190;
2066 S180:
2067 *bound = 1.0e0;
2068 S190:
2069 *status = -6;
2070 return;
2071 S210:
2072 S200:
2073 if(*which == 4) goto S250;
2074 /*
2075 OMPR
2076 */
2077 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240;
2078 if(!(*ompr < 0.0e0)) goto S220;
2079 *bound = 0.0e0;
2080 goto S230;
2081 S220:
2082 *bound = 1.0e0;
2083 S230:
2084 *status = -7;
2085 return;
2086 S250:
2087 S240:
2088 if(*which == 1) goto S290;
2089 /*
2090 P + Q
2091 */
2092 pq = *p+*q;
2093 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S280;
2094 if(!(pq < 0.0e0)) goto S260;
2095 *bound = 0.0e0;
2096 goto S270;
2097 S260:
2098 *bound = 1.0e0;
2099 S270:
2100 *status = 3;
2101 return;
2102 S290:
2103 S280:
2104 if(*which == 4) goto S330;
2105 /*
2106 PR + OMPR
2107 */
2108 prompr = *pr+*ompr;
2109 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S320;
2110 if(!(prompr < 0.0e0)) goto S300;
2111 *bound = 0.0e0;
2112 goto S310;
2113 S300:
2114 *bound = 1.0e0;
2115 S310:
2116 *status = 4;
2117 return;
2118 S330:
2119 S320:
2120 if(!(*which == 1)) qporq = *p <= *q;
2121 /*
2122 Select the minimum of P or Q
2123 Calculate ANSWERS
2124 */
2125 if(1 == *which) {
2126 /*
2127 Calculating P
2128 */
2129 cumbin(s,xn,pr,ompr,p,q);
2130 *status = 0;
2131 }
2132 else if(2 == *which) {
2133 /*
2134 Calculating S
2135 */
2136 *s = 5.0e0;
2137 T5 = atol;
2138 T6 = tol;
2139 dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6);
2140 *status = 0;
2141 dinvr(status,s,&fx,&qleft,&qhi);
2142 S340:
2143 if(!(*status == 1)) goto S370;
2144 cumbin(s,xn,pr,ompr,&cum,&ccum);
2145 if(!qporq) goto S350;
2146 fx = cum-*p;
2147 goto S360;
2148 S350:
2149 fx = ccum-*q;
2150 S360:
2151 dinvr(status,s,&fx,&qleft,&qhi);
2152 goto S340;
2153 S370:
2154 if(!(*status == -1)) goto S400;
2155 if(!qleft) goto S380;
2156 *status = 1;
2157 *bound = 0.0e0;
2158 goto S390;
2159 S380:
2160 *status = 2;
2161 *bound = *xn;
2162 S400:
2163 S390:
2164 ;
2165 }
2166 else if(3 == *which) {
2167 /*
2168 Calculating XN
2169 */
2170 *xn = 5.0e0;
2171 T7 = zero;
2172 T8 = inf;
2173 T9 = atol;
2174 T10 = tol;
2175 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2176 *status = 0;
2177 dinvr(status,xn,&fx,&qleft,&qhi);
2178 S410:
2179 if(!(*status == 1)) goto S440;
2180 cumbin(s,xn,pr,ompr,&cum,&ccum);
2181 if(!qporq) goto S420;
2182 fx = cum-*p;
2183 goto S430;
2184 S420:
2185 fx = ccum-*q;
2186 S430:
2187 dinvr(status,xn,&fx,&qleft,&qhi);
2188 goto S410;
2189 S440:
2190 if(!(*status == -1)) goto S470;
2191 if(!qleft) goto S450;
2192 *status = 1;
2193 *bound = zero;
2194 goto S460;
2195 S450:
2196 *status = 2;
2197 *bound = inf;
2198 S470:
2199 S460:
2200 ;
2201 }
2202 else if(4 == *which) {
2203 /*
2204 Calculating PR and OMPR
2205 */
2206 T12 = atol;
2207 T13 = tol;
2208 dstzr(&K2,&K11,&T12,&T13);
2209 if(!qporq) goto S500;
2210 *status = 0;
2211 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2212 *ompr = one-*pr;
2213 S480:
2214 if(!(*status == 1)) goto S490;
2215 cumbin(s,xn,pr,ompr,&cum,&ccum);
2216 fx = cum-*p;
2217 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
2218 *ompr = one-*pr;
2219 goto S480;
2220 S490:
2221 goto S530;
2222 S500:
2223 *status = 0;
2224 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2225 *pr = one-*ompr;
2226 S510:
2227 if(!(*status == 1)) goto S520;
2228 cumbin(s,xn,pr,ompr,&cum,&ccum);
2229 fx = ccum-*q;
2230 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
2231 *pr = one-*ompr;
2232 goto S510;
2233 S530:
2234 S520:
2235 if(!(*status == -1)) goto S560;
2236 if(!qleft) goto S540;
2237 *status = 1;
2238 *bound = 0.0e0;
2239 goto S550;
2240 S540:
2241 *status = 2;
2242 *bound = 1.0e0;
2243 S550:
2244 ;
2245 }
2246 S560:
2247 return;
2248 #undef atol
2249 #undef tol
2250 #undef zero
2251 #undef inf
2252 #undef one
2253 } /* END */
2254
2255 /***=====================================================================***/
cdfchi(int * which,double * p,double * q,double * x,double * df,int * status,double * bound)2256 static void cdfchi(int *which,double *p,double *q,double *x,double *df,
2257 int *status,double *bound)
2258 /**********************************************************************
2259
2260 void cdfchi(int *which,double *p,double *q,double *x,double *df,
2261 int *status,double *bound)
2262
2263 Cumulative Distribution Function
2264 CHI-Square distribution
2265
2266
2267 Function
2268
2269
2270 Calculates any one parameter of the chi-square
2271 distribution given values for the others.
2272
2273
2274 Arguments
2275
2276
2277 WHICH --> Integer indicating which of the next three argument
2278 values is to be calculated from the others.
2279 Legal range: 1..3
2280 iwhich = 1 : Calculate P and Q from X and DF
2281 iwhich = 2 : Calculate X from P,Q and DF
2282 iwhich = 3 : Calculate DF from P,Q and X
2283
2284 P <--> The integral from 0 to X of the chi-square
2285 distribution.
2286 Input range: [0, 1].
2287
2288 Q <--> 1-P.
2289 Input range: (0, 1].
2290 P + Q = 1.0.
2291
2292 X <--> Upper limit of integration of the non-central
2293 chi-square distribution.
2294 Input range: [0, +infinity).
2295 Search range: [0,1E300]
2296
2297 DF <--> Degrees of freedom of the
2298 chi-square distribution.
2299 Input range: (0, +infinity).
2300 Search range: [ 1E-300, 1E300]
2301
2302 STATUS <-- 0 if calculation completed correctly
2303 -I if input parameter number I is out of range
2304 1 if answer appears to be lower than lowest
2305 search bound
2306 2 if answer appears to be higher than greatest
2307 search bound
2308 3 if P + Q .ne. 1
2309 10 indicates error returned from cumgam. See
2310 references in cdfgam
2311
2312 BOUND <-- Undefined if STATUS is 0
2313
2314 Bound exceeded by parameter number I if STATUS
2315 is negative.
2316
2317 Lower search bound if STATUS is 1.
2318
2319 Upper search bound if STATUS is 2.
2320
2321
2322 Method
2323
2324
2325 Formula 26.4.19 of Abramowitz and Stegun, Handbook of
2326 Mathematical Functions (1966) is used to reduce the chisqure
2327 distribution to the incomplete distribution.
2328
2329 Computation of other parameters involve a seach for a value that
2330 produces the desired value of P. The search relies on the
2331 monotinicity of P with the other parameter.
2332
2333 **********************************************************************/
2334 {
2335 #define tol (1.0e-8)
2336 #define atol (1.0e-50)
2337 #define zero (1.0e-300)
2338 #define inf 1.0e300
2339 static int K1 = 1;
2340 static double K2 = 0.0e0;
2341 static double K4 = 0.5e0;
2342 static double K5 = 5.0e0;
2343 static double fx,cum,ccum,pq,porq;
2344 static unsigned long qhi,qleft,qporq;
2345 static double T3,T6,T7,T8,T9,T10,T11;
2346 /*
2347 ..
2348 .. Executable Statements ..
2349 */
2350 /*
2351 Check arguments
2352 */
2353 if(!(*which < 1 || *which > 3)) goto S30;
2354 if(!(*which < 1)) goto S10;
2355 *bound = 1.0e0;
2356 goto S20;
2357 S10:
2358 *bound = 3.0e0;
2359 S20:
2360 *status = -1;
2361 return;
2362 S30:
2363 if(*which == 1) goto S70;
2364 /*
2365 P
2366 */
2367 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2368 if(!(*p < 0.0e0)) goto S40;
2369 *bound = 0.0e0;
2370 goto S50;
2371 S40:
2372 *bound = 1.0e0;
2373 S50:
2374 *status = -2;
2375 return;
2376 S70:
2377 S60:
2378 if(*which == 1) goto S110;
2379 /*
2380 Q
2381 */
2382 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2383 if(!(*q <= 0.0e0)) goto S80;
2384 *bound = 0.0e0;
2385 goto S90;
2386 S80:
2387 *bound = 1.0e0;
2388 S90:
2389 *status = -3;
2390 return;
2391 S110:
2392 S100:
2393 if(*which == 2) goto S130;
2394 /*
2395 X
2396 */
2397 if(!(*x < 0.0e0)) goto S120;
2398 *bound = 0.0e0;
2399 *status = -4;
2400 return;
2401 S130:
2402 S120:
2403 if(*which == 3) goto S150;
2404 /*
2405 DF
2406 */
2407 if(!(*df <= 0.0e0)) goto S140;
2408 *bound = 0.0e0;
2409 *status = -5;
2410 return;
2411 S150:
2412 S140:
2413 if(*which == 1) goto S190;
2414 /*
2415 P + Q
2416 */
2417 pq = *p+*q;
2418 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180;
2419 if(!(pq < 0.0e0)) goto S160;
2420 *bound = 0.0e0;
2421 goto S170;
2422 S160:
2423 *bound = 1.0e0;
2424 S170:
2425 *status = 3;
2426 return;
2427 S190:
2428 S180:
2429 if(*which == 1) goto S220;
2430 /*
2431 Select the minimum of P or Q
2432 */
2433 qporq = *p <= *q;
2434 if(!qporq) goto S200;
2435 porq = *p;
2436 goto S210;
2437 S200:
2438 porq = *q;
2439 S220:
2440 S210:
2441 /*
2442 Calculate ANSWERS
2443 */
2444 if(1 == *which) {
2445 /*
2446 Calculating P and Q
2447 */
2448 *status = 0;
2449 cumchi(x,df,p,q);
2450 if(porq > 1.5e0) {
2451 *status = 10;
2452 return;
2453 }
2454 }
2455 else if(2 == *which) {
2456 /*
2457 Calculating X
2458 */
2459 *x = 5.0e0;
2460 T3 = inf;
2461 T6 = atol;
2462 T7 = tol;
2463 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
2464 *status = 0;
2465 dinvr(status,x,&fx,&qleft,&qhi);
2466 S230:
2467 if(!(*status == 1)) goto S270;
2468 cumchi(x,df,&cum,&ccum);
2469 if(!qporq) goto S240;
2470 fx = cum-*p;
2471 goto S250;
2472 S240:
2473 fx = ccum-*q;
2474 S250:
2475 if(!(fx+porq > 1.5e0)) goto S260;
2476 *status = 10;
2477 return;
2478 S260:
2479 dinvr(status,x,&fx,&qleft,&qhi);
2480 goto S230;
2481 S270:
2482 if(!(*status == -1)) goto S300;
2483 if(!qleft) goto S280;
2484 *status = 1;
2485 *bound = 0.0e0;
2486 goto S290;
2487 S280:
2488 *status = 2;
2489 *bound = inf;
2490 S300:
2491 S290:
2492 ;
2493 }
2494 else if(3 == *which) {
2495 /*
2496 Calculating DF
2497 */
2498 *df = 5.0e0;
2499 T8 = zero;
2500 T9 = inf;
2501 T10 = atol;
2502 T11 = tol;
2503 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
2504 *status = 0;
2505 dinvr(status,df,&fx,&qleft,&qhi);
2506 S310:
2507 if(!(*status == 1)) goto S350;
2508 cumchi(x,df,&cum,&ccum);
2509 if(!qporq) goto S320;
2510 fx = cum-*p;
2511 goto S330;
2512 S320:
2513 fx = ccum-*q;
2514 S330:
2515 if(!(fx+porq > 1.5e0)) goto S340;
2516 *status = 10;
2517 return;
2518 S340:
2519 dinvr(status,df,&fx,&qleft,&qhi);
2520 goto S310;
2521 S350:
2522 if(!(*status == -1)) goto S380;
2523 if(!qleft) goto S360;
2524 *status = 1;
2525 *bound = zero;
2526 goto S370;
2527 S360:
2528 *status = 2;
2529 *bound = inf;
2530 S370:
2531 ;
2532 }
2533 S380:
2534 return;
2535 #undef tol
2536 #undef atol
2537 #undef zero
2538 #undef inf
2539 } /* END */
2540
2541 /***=====================================================================***/
cdfchn(int * which,double * p,double * q,double * x,double * df,double * pnonc,int * status,double * bound)2542 static void cdfchn(int *which,double *p,double *q,double *x,double *df,
2543 double *pnonc,int *status,double *bound)
2544 /**********************************************************************
2545
2546 void cdfchn(int *which,double *p,double *q,double *x,double *df,
2547 double *pnonc,int *status,double *bound)
2548
2549 Cumulative Distribution Function
2550 Non-central Chi-Square
2551
2552
2553 Function
2554
2555
2556 Calculates any one parameter of the non-central chi-square
2557 distribution given values for the others.
2558
2559
2560 Arguments
2561
2562
2563 WHICH --> Integer indicating which of the next three argument
2564 values is to be calculated from the others.
2565 Input range: 1..4
2566 iwhich = 1 : Calculate P and Q from X and DF
2567 iwhich = 2 : Calculate X from P,DF and PNONC
2568 iwhich = 3 : Calculate DF from P,X and PNONC
2569 iwhich = 3 : Calculate PNONC from P,X and DF
2570
2571 P <--> The integral from 0 to X of the non-central chi-square
2572 distribution.
2573 Input range: [0, 1-1E-16).
2574
2575 Q <--> 1-P.
2576 Q is not used by this subroutine and is only included
2577 for similarity with other cdf* routines.
2578
2579 X <--> Upper limit of integration of the non-central
2580 chi-square distribution.
2581 Input range: [0, +infinity).
2582 Search range: [0,1E300]
2583
2584 DF <--> Degrees of freedom of the non-central
2585 chi-square distribution.
2586 Input range: (0, +infinity).
2587 Search range: [ 1E-300, 1E300]
2588
2589 PNONC <--> Non-centrality parameter of the non-central
2590 chi-square distribution.
2591 Input range: [0, +infinity).
2592 Search range: [0,1E4]
2593
2594 STATUS <-- 0 if calculation completed correctly
2595 -I if input parameter number I is out of range
2596 1 if answer appears to be lower than lowest
2597 search bound
2598 2 if answer appears to be higher than greatest
2599 search bound
2600
2601 BOUND <-- Undefined if STATUS is 0
2602
2603 Bound exceeded by parameter number I if STATUS
2604 is negative.
2605
2606 Lower search bound if STATUS is 1.
2607
2608 Upper search bound if STATUS is 2.
2609
2610
2611 Method
2612
2613
2614 Formula 26.4.25 of Abramowitz and Stegun, Handbook of
2615 Mathematical Functions (1966) is used to compute the cumulative
2616 distribution function.
2617
2618 Computation of other parameters involve a seach for a value that
2619 produces the desired value of P. The search relies on the
2620 monotinicity of P with the other parameter.
2621
2622
2623 WARNING
2624
2625 The computation time required for this routine is proportional
2626 to the noncentrality parameter (PNONC). Very large values of
2627 this parameter can consume immense computer resources. This is
2628 why the search range is bounded by 10,000.
2629
2630 **********************************************************************/
2631 {
2632 #define tent4 1.0e4
2633 #define tol (1.0e-8)
2634 #define atol (1.0e-50)
2635 #define zero (1.0e-300)
2636 #define one (1.0e0-1.0e-16)
2637 #define inf 1.0e300
2638 static double K1 = 0.0e0;
2639 static double K3 = 0.5e0;
2640 static double K4 = 5.0e0;
2641 static double fx,cum,ccum;
2642 static unsigned long qhi,qleft;
2643 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13;
2644 /*
2645 ..
2646 .. Executable Statements ..
2647 */
2648 /*
2649 Check arguments
2650 */
2651 if(!(*which < 1 || *which > 4)) goto S30;
2652 if(!(*which < 1)) goto S10;
2653 *bound = 1.0e0;
2654 goto S20;
2655 S10:
2656 *bound = 4.0e0;
2657 S20:
2658 *status = -1;
2659 return;
2660 S30:
2661 if(*which == 1) goto S70;
2662 /*
2663 P
2664 */
2665 if(!(*p < 0.0e0 || *p > one)) goto S60;
2666 if(!(*p < 0.0e0)) goto S40;
2667 *bound = 0.0e0;
2668 goto S50;
2669 S40:
2670 *bound = one;
2671 S50:
2672 *status = -2;
2673 return;
2674 S70:
2675 S60:
2676 if(*which == 2) goto S90;
2677 /*
2678 X
2679 */
2680 if(!(*x < 0.0e0)) goto S80;
2681 *bound = 0.0e0;
2682 *status = -4;
2683 return;
2684 S90:
2685 S80:
2686 if(*which == 3) goto S110;
2687 /*
2688 DF
2689 */
2690 if(!(*df <= 0.0e0)) goto S100;
2691 *bound = 0.0e0;
2692 *status = -5;
2693 return;
2694 S110:
2695 S100:
2696 if(*which == 4) goto S130;
2697 /*
2698 PNONC
2699 */
2700 if(!(*pnonc < 0.0e0)) goto S120;
2701 *bound = 0.0e0;
2702 *status = -6;
2703 return;
2704 S130:
2705 S120:
2706 /*
2707 Calculate ANSWERS
2708 */
2709 if(1 == *which) {
2710 /*
2711 Calculating P and Q
2712 */
2713 cumchn(x,df,pnonc,p,q);
2714 *status = 0;
2715 }
2716 else if(2 == *which) {
2717 /*
2718 Calculating X
2719 */
2720 *x = 5.0e0;
2721 T2 = inf;
2722 T5 = atol;
2723 T6 = tol;
2724 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
2725 *status = 0;
2726 dinvr(status,x,&fx,&qleft,&qhi);
2727 S140:
2728 if(!(*status == 1)) goto S150;
2729 cumchn(x,df,pnonc,&cum,&ccum);
2730 fx = cum-*p;
2731 dinvr(status,x,&fx,&qleft,&qhi);
2732 goto S140;
2733 S150:
2734 if(!(*status == -1)) goto S180;
2735 if(!qleft) goto S160;
2736 *status = 1;
2737 *bound = 0.0e0;
2738 goto S170;
2739 S160:
2740 *status = 2;
2741 *bound = inf;
2742 S180:
2743 S170:
2744 ;
2745 }
2746 else if(3 == *which) {
2747 /*
2748 Calculating DF
2749 */
2750 *df = 5.0e0;
2751 T7 = zero;
2752 T8 = inf;
2753 T9 = atol;
2754 T10 = tol;
2755 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
2756 *status = 0;
2757 dinvr(status,df,&fx,&qleft,&qhi);
2758 S190:
2759 if(!(*status == 1)) goto S200;
2760 cumchn(x,df,pnonc,&cum,&ccum);
2761 fx = cum-*p;
2762 dinvr(status,df,&fx,&qleft,&qhi);
2763 goto S190;
2764 S200:
2765 if(!(*status == -1)) goto S230;
2766 if(!qleft) goto S210;
2767 *status = 1;
2768 *bound = zero;
2769 goto S220;
2770 S210:
2771 *status = 2;
2772 *bound = inf;
2773 S230:
2774 S220:
2775 ;
2776 }
2777 else if(4 == *which) {
2778 /*
2779 Calculating PNONC
2780 */
2781 *pnonc = 5.0e0;
2782 T11 = tent4;
2783 T12 = atol;
2784 T13 = tol;
2785 dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13);
2786 *status = 0;
2787 dinvr(status,pnonc,&fx,&qleft,&qhi);
2788 S240:
2789 if(!(*status == 1)) goto S250;
2790 cumchn(x,df,pnonc,&cum,&ccum);
2791 fx = cum-*p;
2792 dinvr(status,pnonc,&fx,&qleft,&qhi);
2793 goto S240;
2794 S250:
2795 if(!(*status == -1)) goto S280;
2796 if(!qleft) goto S260;
2797 *status = 1;
2798 *bound = zero;
2799 goto S270;
2800 S260:
2801 *status = 2;
2802 *bound = tent4;
2803 S270:
2804 ;
2805 }
2806 S280:
2807 return;
2808 #undef tent4
2809 #undef tol
2810 #undef atol
2811 #undef zero
2812 #undef one
2813 #undef inf
2814 } /* END */
2815
2816 /***=====================================================================***/
cdff(int * which,double * p,double * q,double * f,double * dfn,double * dfd,int * status,double * bound)2817 static void cdff(int *which,double *p,double *q,double *f,double *dfn,
2818 double *dfd,int *status,double *bound)
2819 /**********************************************************************
2820
2821 void cdff(int *which,double *p,double *q,double *f,double *dfn,
2822 double *dfd,int *status,double *bound)
2823
2824 Cumulative Distribution Function
2825 F distribution
2826
2827
2828 Function
2829
2830
2831 Calculates any one parameter of the F distribution
2832 given values for the others.
2833
2834
2835 Arguments
2836
2837
2838 WHICH --> Integer indicating which of the next four argument
2839 values is to be calculated from the others.
2840 Legal range: 1..4
2841 iwhich = 1 : Calculate P and Q from F,DFN and DFD
2842 iwhich = 2 : Calculate F from P,Q,DFN and DFD
2843 iwhich = 3 : Calculate DFN from P,Q,F and DFD
2844 iwhich = 4 : Calculate DFD from P,Q,F and DFN
2845
2846 P <--> The integral from 0 to F of the f-density.
2847 Input range: [0,1].
2848
2849 Q <--> 1-P.
2850 Input range: (0, 1].
2851 P + Q = 1.0.
2852
2853 F <--> Upper limit of integration of the f-density.
2854 Input range: [0, +infinity).
2855 Search range: [0,1E300]
2856
2857 DFN < --> Degrees of freedom of the numerator sum of squares.
2858 Input range: (0, +infinity).
2859 Search range: [ 1E-300, 1E300]
2860
2861 DFD < --> Degrees of freedom of the denominator sum of squares.
2862 Input range: (0, +infinity).
2863 Search range: [ 1E-300, 1E300]
2864
2865 STATUS <-- 0 if calculation completed correctly
2866 -I if input parameter number I is out of range
2867 1 if answer appears to be lower than lowest
2868 search bound
2869 2 if answer appears to be higher than greatest
2870 search bound
2871 3 if P + Q .ne. 1
2872
2873 BOUND <-- Undefined if STATUS is 0
2874
2875 Bound exceeded by parameter number I if STATUS
2876 is negative.
2877
2878 Lower search bound if STATUS is 1.
2879
2880 Upper search bound if STATUS is 2.
2881
2882
2883 Method
2884
2885
2886 Formula 26.6.2 of Abramowitz and Stegun, Handbook of
2887 Mathematical Functions (1966) is used to reduce the computation
2888 of the cumulative distribution function for the F variate to
2889 that of an incomplete beta.
2890
2891 Computation of other parameters involve a seach for a value that
2892 produces the desired value of P. The search relies on the
2893 monotinicity of P with the other parameter.
2894
2895 WARNING
2896
2897 The value of the cumulative F distribution is not necessarily
2898 monotone in either degrees of freedom. There thus may be two
2899 values that provide a given CDF value. This routine assumes
2900 monotonicity and will find an arbitrary one of the two values.
2901
2902 **********************************************************************/
2903 {
2904 #define tol (1.0e-8)
2905 #define atol (1.0e-50)
2906 #define zero (1.0e-300)
2907 #define inf 1.0e300
2908 static int K1 = 1;
2909 static double K2 = 0.0e0;
2910 static double K4 = 0.5e0;
2911 static double K5 = 5.0e0;
2912 static double pq,fx,cum,ccum;
2913 static unsigned long qhi,qleft,qporq;
2914 static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15;
2915 /*
2916 ..
2917 .. Executable Statements ..
2918 */
2919 /*
2920 Check arguments
2921 */
2922 if(!(*which < 1 || *which > 4)) goto S30;
2923 if(!(*which < 1)) goto S10;
2924 *bound = 1.0e0;
2925 goto S20;
2926 S10:
2927 *bound = 4.0e0;
2928 S20:
2929 *status = -1;
2930 return;
2931 S30:
2932 if(*which == 1) goto S70;
2933 /*
2934 P
2935 */
2936 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
2937 if(!(*p < 0.0e0)) goto S40;
2938 *bound = 0.0e0;
2939 goto S50;
2940 S40:
2941 *bound = 1.0e0;
2942 S50:
2943 *status = -2;
2944 return;
2945 S70:
2946 S60:
2947 if(*which == 1) goto S110;
2948 /*
2949 Q
2950 */
2951 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
2952 if(!(*q <= 0.0e0)) goto S80;
2953 *bound = 0.0e0;
2954 goto S90;
2955 S80:
2956 *bound = 1.0e0;
2957 S90:
2958 *status = -3;
2959 return;
2960 S110:
2961 S100:
2962 if(*which == 2) goto S130;
2963 /*
2964 F
2965 */
2966 if(!(*f < 0.0e0)) goto S120;
2967 *bound = 0.0e0;
2968 *status = -4;
2969 return;
2970 S130:
2971 S120:
2972 if(*which == 3) goto S150;
2973 /*
2974 DFN
2975 */
2976 if(!(*dfn <= 0.0e0)) goto S140;
2977 *bound = 0.0e0;
2978 *status = -5;
2979 return;
2980 S150:
2981 S140:
2982 if(*which == 4) goto S170;
2983 /*
2984 DFD
2985 */
2986 if(!(*dfd <= 0.0e0)) goto S160;
2987 *bound = 0.0e0;
2988 *status = -6;
2989 return;
2990 S170:
2991 S160:
2992 if(*which == 1) goto S210;
2993 /*
2994 P + Q
2995 */
2996 pq = *p+*q;
2997 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200;
2998 if(!(pq < 0.0e0)) goto S180;
2999 *bound = 0.0e0;
3000 goto S190;
3001 S180:
3002 *bound = 1.0e0;
3003 S190:
3004 *status = 3;
3005 return;
3006 S210:
3007 S200:
3008 if(!(*which == 1)) qporq = *p <= *q;
3009 /*
3010 Select the minimum of P or Q
3011 Calculate ANSWERS
3012 */
3013 if(1 == *which) {
3014 /*
3015 Calculating P
3016 */
3017 cumf(f,dfn,dfd,p,q);
3018 *status = 0;
3019 }
3020 else if(2 == *which) {
3021 /*
3022 Calculating F
3023 */
3024 *f = 5.0e0;
3025 T3 = inf;
3026 T6 = atol;
3027 T7 = tol;
3028 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
3029 *status = 0;
3030 dinvr(status,f,&fx,&qleft,&qhi);
3031 S220:
3032 if(!(*status == 1)) goto S250;
3033 cumf(f,dfn,dfd,&cum,&ccum);
3034 if(!qporq) goto S230;
3035 fx = cum-*p;
3036 goto S240;
3037 S230:
3038 fx = ccum-*q;
3039 S240:
3040 dinvr(status,f,&fx,&qleft,&qhi);
3041 goto S220;
3042 S250:
3043 if(!(*status == -1)) goto S280;
3044 if(!qleft) goto S260;
3045 *status = 1;
3046 *bound = 0.0e0;
3047 goto S270;
3048 S260:
3049 *status = 2;
3050 *bound = inf;
3051 S280:
3052 S270:
3053 ;
3054 }
3055 else if(3 == *which) {
3056 /*
3057 Calculating DFN
3058 */
3059 *dfn = 5.0e0;
3060 T8 = zero;
3061 T9 = inf;
3062 T10 = atol;
3063 T11 = tol;
3064 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
3065 *status = 0;
3066 dinvr(status,dfn,&fx,&qleft,&qhi);
3067 S290:
3068 if(!(*status == 1)) goto S320;
3069 cumf(f,dfn,dfd,&cum,&ccum);
3070 if(!qporq) goto S300;
3071 fx = cum-*p;
3072 goto S310;
3073 S300:
3074 fx = ccum-*q;
3075 S310:
3076 dinvr(status,dfn,&fx,&qleft,&qhi);
3077 goto S290;
3078 S320:
3079 if(!(*status == -1)) goto S350;
3080 if(!qleft) goto S330;
3081 *status = 1;
3082 *bound = zero;
3083 goto S340;
3084 S330:
3085 *status = 2;
3086 *bound = inf;
3087 S350:
3088 S340:
3089 ;
3090 }
3091 else if(4 == *which) {
3092 /*
3093 Calculating DFD
3094 */
3095 *dfd = 5.0e0;
3096 T12 = zero;
3097 T13 = inf;
3098 T14 = atol;
3099 T15 = tol;
3100 dstinv(&T12,&T13,&K4,&K4,&K5,&T14,&T15);
3101 *status = 0;
3102 dinvr(status,dfd,&fx,&qleft,&qhi);
3103 S360:
3104 if(!(*status == 1)) goto S390;
3105 cumf(f,dfn,dfd,&cum,&ccum);
3106 if(!qporq) goto S370;
3107 fx = cum-*p;
3108 goto S380;
3109 S370:
3110 fx = ccum-*q;
3111 S380:
3112 dinvr(status,dfd,&fx,&qleft,&qhi);
3113 goto S360;
3114 S390:
3115 if(!(*status == -1)) goto S420;
3116 if(!qleft) goto S400;
3117 *status = 1;
3118 *bound = zero;
3119 goto S410;
3120 S400:
3121 *status = 2;
3122 *bound = inf;
3123 S410:
3124 ;
3125 }
3126 S420:
3127 return;
3128 #undef tol
3129 #undef atol
3130 #undef zero
3131 #undef inf
3132 } /* END */
3133
3134 /***=====================================================================***/
cdffnc(int * which,double * p,double * q,double * f,double * dfn,double * dfd,double * phonc,int * status,double * bound)3135 static void cdffnc(int *which,double *p,double *q,double *f,double *dfn,
3136 double *dfd,double *phonc,int *status,double *bound)
3137 /**********************************************************************
3138
3139 void cdffnc(int *which,double *p,double *q,double *f,double *dfn,
3140 double *dfd,double *phonc,int *status,double *bound)
3141
3142 Cumulative Distribution Function
3143 Non-central F distribution
3144
3145
3146 Function
3147
3148
3149 Calculates any one parameter of the Non-central F
3150 distribution given values for the others.
3151
3152
3153 Arguments
3154
3155
3156 WHICH --> Integer indicating which of the next five argument
3157 values is to be calculated from the others.
3158 Legal range: 1..5
3159 iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC
3160 iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC
3161 iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC
3162 iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC
3163 iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD
3164
3165 P <--> The integral from 0 to F of the non-central f-density.
3166 Input range: [0,1-1E-16).
3167
3168 Q <--> 1-P.
3169 Q is not used by this subroutine and is only included
3170 for similarity with other cdf* routines.
3171
3172 F <--> Upper limit of integration of the non-central f-density.
3173 Input range: [0, +infinity).
3174 Search range: [0,1E300]
3175
3176 DFN < --> Degrees of freedom of the numerator sum of squares.
3177 Input range: (0, +infinity).
3178 Search range: [ 1E-300, 1E300]
3179
3180 DFD < --> Degrees of freedom of the denominator sum of squares.
3181 Must be in range: (0, +infinity).
3182 Input range: (0, +infinity).
3183 Search range: [ 1E-300, 1E300]
3184
3185 PNONC <-> The non-centrality parameter
3186 Input range: [0,infinity)
3187 Search range: [0,1E4]
3188
3189 STATUS <-- 0 if calculation completed correctly
3190 -I if input parameter number I is out of range
3191 1 if answer appears to be lower than lowest
3192 search bound
3193 2 if answer appears to be higher than greatest
3194 search bound
3195 3 if P + Q .ne. 1
3196
3197 BOUND <-- Undefined if STATUS is 0
3198
3199 Bound exceeded by parameter number I if STATUS
3200 is negative.
3201
3202 Lower search bound if STATUS is 1.
3203
3204 Upper search bound if STATUS is 2.
3205
3206
3207 Method
3208
3209
3210 Formula 26.6.20 of Abramowitz and Stegun, Handbook of
3211 Mathematical Functions (1966) is used to compute the cumulative
3212 distribution function.
3213
3214 Computation of other parameters involve a seach for a value that
3215 produces the desired value of P. The search relies on the
3216 monotinicity of P with the other parameter.
3217
3218 WARNING
3219
3220 The computation time required for this routine is proportional
3221 to the noncentrality parameter (PNONC). Very large values of
3222 this parameter can consume immense computer resources. This is
3223 why the search range is bounded by 10,000.
3224
3225 WARNING
3226
3227 The value of the cumulative noncentral F distribution is not
3228 necessarily monotone in either degrees of freedom. There thus
3229 may be two values that provide a given CDF value. This routine
3230 assumes monotonicity and will find an arbitrary one of the two
3231 values.
3232
3233 **********************************************************************/
3234 {
3235 #define tent4 1.0e4
3236 #define tol (1.0e-8)
3237 #define atol (1.0e-50)
3238 #define zero (1.0e-300)
3239 #define one (1.0e0-1.0e-16)
3240 #define inf 1.0e300
3241 static double K1 = 0.0e0;
3242 static double K3 = 0.5e0;
3243 static double K4 = 5.0e0;
3244 static double fx,cum,ccum;
3245 static unsigned long qhi,qleft;
3246 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17;
3247 /*
3248 ..
3249 .. Executable Statements ..
3250 */
3251 /*
3252 Check arguments
3253 */
3254 if(!(*which < 1 || *which > 5)) goto S30;
3255 if(!(*which < 1)) goto S10;
3256 *bound = 1.0e0;
3257 goto S20;
3258 S10:
3259 *bound = 5.0e0;
3260 S20:
3261 *status = -1;
3262 return;
3263 S30:
3264 if(*which == 1) goto S70;
3265 /*
3266 P
3267 */
3268 if(!(*p < 0.0e0 || *p > one)) goto S60;
3269 if(!(*p < 0.0e0)) goto S40;
3270 *bound = 0.0e0;
3271 goto S50;
3272 S40:
3273 *bound = one;
3274 S50:
3275 *status = -2;
3276 return;
3277 S70:
3278 S60:
3279 if(*which == 2) goto S90;
3280 /*
3281 F
3282 */
3283 if(!(*f < 0.0e0)) goto S80;
3284 *bound = 0.0e0;
3285 *status = -4;
3286 return;
3287 S90:
3288 S80:
3289 if(*which == 3) goto S110;
3290 /*
3291 DFN
3292 */
3293 if(!(*dfn <= 0.0e0)) goto S100;
3294 *bound = 0.0e0;
3295 *status = -5;
3296 return;
3297 S110:
3298 S100:
3299 if(*which == 4) goto S130;
3300 /*
3301 DFD
3302 */
3303 if(!(*dfd <= 0.0e0)) goto S120;
3304 *bound = 0.0e0;
3305 *status = -6;
3306 return;
3307 S130:
3308 S120:
3309 if(*which == 5) goto S150;
3310 /*
3311 PHONC
3312 */
3313 if(!(*phonc < 0.0e0)) goto S140;
3314 *bound = 0.0e0;
3315 *status = -7;
3316 return;
3317 S150:
3318 S140:
3319 /*
3320 Calculate ANSWERS
3321 */
3322 if(1 == *which) {
3323 /*
3324 Calculating P
3325 */
3326 cumfnc(f,dfn,dfd,phonc,p,q);
3327 *status = 0;
3328 }
3329 else if(2 == *which) {
3330 /*
3331 Calculating F
3332 */
3333 *f = 5.0e0;
3334 T2 = inf;
3335 T5 = atol;
3336 T6 = tol;
3337 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6);
3338 *status = 0;
3339 dinvr(status,f,&fx,&qleft,&qhi);
3340 S160:
3341 if(!(*status == 1)) goto S170;
3342 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3343 fx = cum-*p;
3344 dinvr(status,f,&fx,&qleft,&qhi);
3345 goto S160;
3346 S170:
3347 if(!(*status == -1)) goto S200;
3348 if(!qleft) goto S180;
3349 *status = 1;
3350 *bound = 0.0e0;
3351 goto S190;
3352 S180:
3353 *status = 2;
3354 *bound = inf;
3355 S200:
3356 S190:
3357 ;
3358 }
3359 else if(3 == *which) {
3360 /*
3361 Calculating DFN
3362 */
3363 *dfn = 5.0e0;
3364 T7 = zero;
3365 T8 = inf;
3366 T9 = atol;
3367 T10 = tol;
3368 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10);
3369 *status = 0;
3370 dinvr(status,dfn,&fx,&qleft,&qhi);
3371 S210:
3372 if(!(*status == 1)) goto S220;
3373 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3374 fx = cum-*p;
3375 dinvr(status,dfn,&fx,&qleft,&qhi);
3376 goto S210;
3377 S220:
3378 if(!(*status == -1)) goto S250;
3379 if(!qleft) goto S230;
3380 *status = 1;
3381 *bound = zero;
3382 goto S240;
3383 S230:
3384 *status = 2;
3385 *bound = inf;
3386 S250:
3387 S240:
3388 ;
3389 }
3390 else if(4 == *which) {
3391 /*
3392 Calculating DFD
3393 */
3394 *dfd = 5.0e0;
3395 T11 = zero;
3396 T12 = inf;
3397 T13 = atol;
3398 T14 = tol;
3399 dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14);
3400 *status = 0;
3401 dinvr(status,dfd,&fx,&qleft,&qhi);
3402 S260:
3403 if(!(*status == 1)) goto S270;
3404 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3405 fx = cum-*p;
3406 dinvr(status,dfd,&fx,&qleft,&qhi);
3407 goto S260;
3408 S270:
3409 if(!(*status == -1)) goto S300;
3410 if(!qleft) goto S280;
3411 *status = 1;
3412 *bound = zero;
3413 goto S290;
3414 S280:
3415 *status = 2;
3416 *bound = inf;
3417 S300:
3418 S290:
3419 ;
3420 }
3421 else if(5 == *which) {
3422 /*
3423 Calculating PHONC
3424 */
3425 *phonc = 5.0e0;
3426 T15 = tent4;
3427 T16 = atol;
3428 T17 = tol;
3429 dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17);
3430 *status = 0;
3431 dinvr(status,phonc,&fx,&qleft,&qhi);
3432 S310:
3433 if(!(*status == 1)) goto S320;
3434 cumfnc(f,dfn,dfd,phonc,&cum,&ccum);
3435 fx = cum-*p;
3436 dinvr(status,phonc,&fx,&qleft,&qhi);
3437 goto S310;
3438 S320:
3439 if(!(*status == -1)) goto S350;
3440 if(!qleft) goto S330;
3441 *status = 1;
3442 *bound = 0.0e0;
3443 goto S340;
3444 S330:
3445 *status = 2;
3446 *bound = tent4;
3447 S340:
3448 ;
3449 }
3450 S350:
3451 return;
3452 #undef tent4
3453 #undef tol
3454 #undef atol
3455 #undef zero
3456 #undef one
3457 #undef inf
3458 } /* END */
3459
3460 /***=====================================================================***/
cdfgam(int * which,double * p,double * q,double * x,double * shape,double * scale,int * status,double * bound)3461 static void cdfgam(int *which,double *p,double *q,double *x,double *shape,
3462 double *scale,int *status,double *bound)
3463 /**********************************************************************
3464
3465 void cdfgam(int *which,double *p,double *q,double *x,double *shape,
3466 double *scale,int *status,double *bound)
3467
3468 Cumulative Distribution Function
3469 GAMma Distribution
3470
3471
3472 Function
3473
3474
3475 Calculates any one parameter of the gamma
3476 distribution given values for the others.
3477
3478
3479 Arguments
3480
3481
3482 WHICH --> Integer indicating which of the next four argument
3483 values is to be calculated from the others.
3484 Legal range: 1..4
3485 iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE
3486 iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE
3487 iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE
3488 iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE
3489
3490 P <--> The integral from 0 to X of the gamma density.
3491 Input range: [0,1].
3492
3493 Q <--> 1-P.
3494 Input range: (0, 1].
3495 P + Q = 1.0.
3496
3497 X <--> The upper limit of integration of the gamma density.
3498 Input range: [0, +infinity).
3499 Search range: [0,1E300]
3500
3501 SHAPE <--> The shape parameter of the gamma density.
3502 Input range: (0, +infinity).
3503 Search range: [1E-300,1E300]
3504
3505 SCALE <--> The scale parameter of the gamma density.
3506 Input range: (0, +infinity).
3507 Search range: (1E-300,1E300]
3508
3509 STATUS <-- 0 if calculation completed correctly
3510 -I if input parameter number I is out of range
3511 1 if answer appears to be lower than lowest
3512 search bound
3513 2 if answer appears to be higher than greatest
3514 search bound
3515 3 if P + Q .ne. 1
3516 10 if the gamma or inverse gamma routine cannot
3517 compute the answer. Usually happens only for
3518 X and SHAPE very large (gt 1E10 or more)
3519
3520 BOUND <-- Undefined if STATUS is 0
3521
3522 Bound exceeded by parameter number I if STATUS
3523 is negative.
3524
3525 Lower search bound if STATUS is 1.
3526
3527 Upper search bound if STATUS is 2.
3528
3529
3530 Method
3531
3532
3533 Cumulative distribution function (P) is calculated directly by
3534 the code associated with:
3535
3536 DiDinato, A. R. and Morris, A. H. Computation of the incomplete
3537 gamma function ratios and their inverse. ACM Trans. Math.
3538 Softw. 12 (1986), 377-393.
3539
3540 Computation of other parameters involve a seach for a value that
3541 produces the desired value of P. The search relies on the
3542 monotinicity of P with the other parameter.
3543
3544
3545 Note
3546
3547
3548
3549 The gamma density is proportional to
3550 T**(SHAPE - 1) * EXP(- SCALE * T)
3551
3552 **********************************************************************/
3553 {
3554 #define tol (1.0e-8)
3555 #define atol (1.0e-50)
3556 #define zero (1.0e-300)
3557 #define inf 1.0e300
3558 static int K1 = 1;
3559 static double K5 = 0.5e0;
3560 static double K6 = 5.0e0;
3561 static double xx,fx,xscale,cum,ccum,pq,porq;
3562 static int ierr;
3563 static unsigned long qhi,qleft,qporq;
3564 static double T2,T3,T4,T7,T8,T9;
3565 /*
3566 ..
3567 .. Executable Statements ..
3568 */
3569 /*
3570 Check arguments
3571 */
3572 if(!(*which < 1 || *which > 4)) goto S30;
3573 if(!(*which < 1)) goto S10;
3574 *bound = 1.0e0;
3575 goto S20;
3576 S10:
3577 *bound = 4.0e0;
3578 S20:
3579 *status = -1;
3580 return;
3581 S30:
3582 if(*which == 1) goto S70;
3583 /*
3584 P
3585 */
3586 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3587 if(!(*p < 0.0e0)) goto S40;
3588 *bound = 0.0e0;
3589 goto S50;
3590 S40:
3591 *bound = 1.0e0;
3592 S50:
3593 *status = -2;
3594 return;
3595 S70:
3596 S60:
3597 if(*which == 1) goto S110;
3598 /*
3599 Q
3600 */
3601 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3602 if(!(*q <= 0.0e0)) goto S80;
3603 *bound = 0.0e0;
3604 goto S90;
3605 S80:
3606 *bound = 1.0e0;
3607 S90:
3608 *status = -3;
3609 return;
3610 S110:
3611 S100:
3612 if(*which == 2) goto S130;
3613 /*
3614 X
3615 */
3616 if(!(*x < 0.0e0)) goto S120;
3617 *bound = 0.0e0;
3618 *status = -4;
3619 return;
3620 S130:
3621 S120:
3622 if(*which == 3) goto S150;
3623 /*
3624 SHAPE
3625 */
3626 if(!(*shape <= 0.0e0)) goto S140;
3627 *bound = 0.0e0;
3628 *status = -5;
3629 return;
3630 S150:
3631 S140:
3632 if(*which == 4) goto S170;
3633 /*
3634 SCALE
3635 */
3636 if(!(*scale <= 0.0e0)) goto S160;
3637 *bound = 0.0e0;
3638 *status = -6;
3639 return;
3640 S170:
3641 S160:
3642 if(*which == 1) goto S210;
3643 /*
3644 P + Q
3645 */
3646 pq = *p+*q;
3647 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200;
3648 if(!(pq < 0.0e0)) goto S180;
3649 *bound = 0.0e0;
3650 goto S190;
3651 S180:
3652 *bound = 1.0e0;
3653 S190:
3654 *status = 3;
3655 return;
3656 S210:
3657 S200:
3658 if(*which == 1) goto S240;
3659 /*
3660 Select the minimum of P or Q
3661 */
3662 qporq = *p <= *q;
3663 if(!qporq) goto S220;
3664 porq = *p;
3665 goto S230;
3666 S220:
3667 porq = *q;
3668 S240:
3669 S230:
3670 /*
3671 Calculate ANSWERS
3672 */
3673 if(1 == *which) {
3674 /*
3675 Calculating P
3676 */
3677 *status = 0;
3678 xscale = *x**scale;
3679 cumgam(&xscale,shape,p,q);
3680 if(porq > 1.5e0) *status = 10;
3681 }
3682 else if(2 == *which) {
3683 /*
3684 Computing X
3685 */
3686 T2 = -1.0e0;
3687 gaminv(shape,&xx,&T2,p,q,&ierr);
3688 if(ierr < 0.0e0) {
3689 *status = 10;
3690 return;
3691 }
3692 else {
3693 *x = xx/ *scale;
3694 *status = 0;
3695 }
3696 }
3697 else if(3 == *which) {
3698 /*
3699 Computing SHAPE
3700 */
3701 *shape = 5.0e0;
3702 xscale = *x**scale;
3703 T3 = zero;
3704 T4 = inf;
3705 T7 = atol;
3706 T8 = tol;
3707 dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8);
3708 *status = 0;
3709 dinvr(status,shape,&fx,&qleft,&qhi);
3710 S250:
3711 if(!(*status == 1)) goto S290;
3712 cumgam(&xscale,shape,&cum,&ccum);
3713 if(!qporq) goto S260;
3714 fx = cum-*p;
3715 goto S270;
3716 S260:
3717 fx = ccum-*q;
3718 S270:
3719 if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280;
3720 *status = 10;
3721 return;
3722 S280:
3723 dinvr(status,shape,&fx,&qleft,&qhi);
3724 goto S250;
3725 S290:
3726 if(!(*status == -1)) goto S320;
3727 if(!qleft) goto S300;
3728 *status = 1;
3729 *bound = zero;
3730 goto S310;
3731 S300:
3732 *status = 2;
3733 *bound = inf;
3734 S320:
3735 S310:
3736 ;
3737 }
3738 else if(4 == *which) {
3739 /*
3740 Computing SCALE
3741 */
3742 T9 = -1.0e0;
3743 gaminv(shape,&xx,&T9,p,q,&ierr);
3744 if(ierr < 0.0e0) {
3745 *status = 10;
3746 return;
3747 }
3748 else {
3749 *scale = xx/ *x;
3750 *status = 0;
3751 }
3752 }
3753 return;
3754 #undef tol
3755 #undef atol
3756 #undef zero
3757 #undef inf
3758 } /* END */
3759
3760 /***=====================================================================***/
cdfnbn(int * which,double * p,double * q,double * s,double * xn,double * pr,double * ompr,int * status,double * bound)3761 static void cdfnbn(int *which,double *p,double *q,double *s,double *xn,
3762 double *pr,double *ompr,int *status,double *bound)
3763 /**********************************************************************
3764
3765 void cdfnbn(int *which,double *p,double *q,double *s,double *xn,
3766 double *pr,double *ompr,int *status,double *bound)
3767
3768 Cumulative Distribution Function
3769 Negative BiNomial distribution
3770
3771
3772 Function
3773
3774
3775 Calculates any one parameter of the negative binomial
3776 distribution given values for the others.
3777
3778 The cumulative negative binomial distribution returns the
3779 probability that there will be F or fewer failures before the
3780 XNth success in binomial trials each of which has probability of
3781 success PR.
3782
3783 The individual term of the negative binomial is the probability of
3784 S failures before XN successes and is
3785 Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S
3786
3787
3788 Arguments
3789
3790
3791 WHICH --> Integer indicating which of the next four argument
3792 values is to be calculated from the others.
3793 Legal range: 1..4
3794 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
3795 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
3796 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
3797 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
3798
3799 P <--> The cumulation from 0 to S of the negative
3800 binomial distribution.
3801 Input range: [0,1].
3802
3803 Q <--> 1-P.
3804 Input range: (0, 1].
3805 P + Q = 1.0.
3806
3807 S <--> The upper limit of cumulation of the binomial distribution.
3808 There are F or fewer failures before the XNth success.
3809 Input range: [0, +infinity).
3810 Search range: [0, 1E300]
3811
3812 XN <--> The number of successes.
3813 Input range: [0, +infinity).
3814 Search range: [0, 1E300]
3815
3816 PR <--> The probability of success in each binomial trial.
3817 Input range: [0,1].
3818 Search range: [0,1].
3819
3820 OMPR <--> 1-PR
3821 Input range: [0,1].
3822 Search range: [0,1]
3823 PR + OMPR = 1.0
3824
3825 STATUS <-- 0 if calculation completed correctly
3826 -I if input parameter number I is out of range
3827 1 if answer appears to be lower than lowest
3828 search bound
3829 2 if answer appears to be higher than greatest
3830 search bound
3831 3 if P + Q .ne. 1
3832 4 if PR + OMPR .ne. 1
3833
3834 BOUND <-- Undefined if STATUS is 0
3835
3836 Bound exceeded by parameter number I if STATUS
3837 is negative.
3838
3839 Lower search bound if STATUS is 1.
3840
3841 Upper search bound if STATUS is 2.
3842
3843
3844 Method
3845
3846
3847 Formula 26.5.26 of Abramowitz and Stegun, Handbook of
3848 Mathematical Functions (1966) is used to reduce calculation of
3849 the cumulative distribution function to that of an incomplete
3850 beta.
3851
3852 Computation of other parameters involve a seach for a value that
3853 produces the desired value of P. The search relies on the
3854 monotinicity of P with the other parameter.
3855
3856 **********************************************************************/
3857 {
3858 #define tol (1.0e-8)
3859 #define atol (1.0e-50)
3860 #define inf 1.0e300
3861 #define one 1.0e0
3862 static int K1 = 1;
3863 static double K2 = 0.0e0;
3864 static double K4 = 0.5e0;
3865 static double K5 = 5.0e0;
3866 static double K11 = 1.0e0;
3867 static double fx,xhi,xlo,pq,prompr,cum,ccum;
3868 static unsigned long qhi,qleft,qporq;
3869 static double T3,T6,T7,T8,T9,T10,T12,T13;
3870 /*
3871 ..
3872 .. Executable Statements ..
3873 */
3874 /*
3875 Check arguments
3876 */
3877 if(!(*which < 1 || *which > 4)) goto S30;
3878 if(!(*which < 1)) goto S10;
3879 *bound = 1.0e0;
3880 goto S20;
3881 S10:
3882 *bound = 4.0e0;
3883 S20:
3884 *status = -1;
3885 return;
3886 S30:
3887 if(*which == 1) goto S70;
3888 /*
3889 P
3890 */
3891 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
3892 if(!(*p < 0.0e0)) goto S40;
3893 *bound = 0.0e0;
3894 goto S50;
3895 S40:
3896 *bound = 1.0e0;
3897 S50:
3898 *status = -2;
3899 return;
3900 S70:
3901 S60:
3902 if(*which == 1) goto S110;
3903 /*
3904 Q
3905 */
3906 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
3907 if(!(*q <= 0.0e0)) goto S80;
3908 *bound = 0.0e0;
3909 goto S90;
3910 S80:
3911 *bound = 1.0e0;
3912 S90:
3913 *status = -3;
3914 return;
3915 S110:
3916 S100:
3917 if(*which == 2) goto S130;
3918 /*
3919 S
3920 */
3921 if(!(*s < 0.0e0)) goto S120;
3922 *bound = 0.0e0;
3923 *status = -4;
3924 return;
3925 S130:
3926 S120:
3927 if(*which == 3) goto S150;
3928 /*
3929 XN
3930 */
3931 if(!(*xn < 0.0e0)) goto S140;
3932 *bound = 0.0e0;
3933 *status = -5;
3934 return;
3935 S150:
3936 S140:
3937 if(*which == 4) goto S190;
3938 /*
3939 PR
3940 */
3941 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180;
3942 if(!(*pr < 0.0e0)) goto S160;
3943 *bound = 0.0e0;
3944 goto S170;
3945 S160:
3946 *bound = 1.0e0;
3947 S170:
3948 *status = -6;
3949 return;
3950 S190:
3951 S180:
3952 if(*which == 4) goto S230;
3953 /*
3954 OMPR
3955 */
3956 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220;
3957 if(!(*ompr < 0.0e0)) goto S200;
3958 *bound = 0.0e0;
3959 goto S210;
3960 S200:
3961 *bound = 1.0e0;
3962 S210:
3963 *status = -7;
3964 return;
3965 S230:
3966 S220:
3967 if(*which == 1) goto S270;
3968 /*
3969 P + Q
3970 */
3971 pq = *p+*q;
3972 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260;
3973 if(!(pq < 0.0e0)) goto S240;
3974 *bound = 0.0e0;
3975 goto S250;
3976 S240:
3977 *bound = 1.0e0;
3978 S250:
3979 *status = 3;
3980 return;
3981 S270:
3982 S260:
3983 if(*which == 4) goto S310;
3984 /*
3985 PR + OMPR
3986 */
3987 prompr = *pr+*ompr;
3988 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300;
3989 if(!(prompr < 0.0e0)) goto S280;
3990 *bound = 0.0e0;
3991 goto S290;
3992 S280:
3993 *bound = 1.0e0;
3994 S290:
3995 *status = 4;
3996 return;
3997 S310:
3998 S300:
3999 if(!(*which == 1)) qporq = *p <= *q;
4000 /*
4001 Select the minimum of P or Q
4002 Calculate ANSWERS
4003 */
4004 if(1 == *which) {
4005 /*
4006 Calculating P
4007 */
4008 cumnbn(s,xn,pr,ompr,p,q);
4009 *status = 0;
4010 }
4011 else if(2 == *which) {
4012 /*
4013 Calculating S
4014 */
4015 *s = 5.0e0;
4016 T3 = inf;
4017 T6 = atol;
4018 T7 = tol;
4019 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4020 *status = 0;
4021 dinvr(status,s,&fx,&qleft,&qhi);
4022 S320:
4023 if(!(*status == 1)) goto S350;
4024 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4025 if(!qporq) goto S330;
4026 fx = cum-*p;
4027 goto S340;
4028 S330:
4029 fx = ccum-*q;
4030 S340:
4031 dinvr(status,s,&fx,&qleft,&qhi);
4032 goto S320;
4033 S350:
4034 if(!(*status == -1)) goto S380;
4035 if(!qleft) goto S360;
4036 *status = 1;
4037 *bound = 0.0e0;
4038 goto S370;
4039 S360:
4040 *status = 2;
4041 *bound = inf;
4042 S380:
4043 S370:
4044 ;
4045 }
4046 else if(3 == *which) {
4047 /*
4048 Calculating XN
4049 */
4050 *xn = 5.0e0;
4051 T8 = inf;
4052 T9 = atol;
4053 T10 = tol;
4054 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4055 *status = 0;
4056 dinvr(status,xn,&fx,&qleft,&qhi);
4057 S390:
4058 if(!(*status == 1)) goto S420;
4059 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4060 if(!qporq) goto S400;
4061 fx = cum-*p;
4062 goto S410;
4063 S400:
4064 fx = ccum-*q;
4065 S410:
4066 dinvr(status,xn,&fx,&qleft,&qhi);
4067 goto S390;
4068 S420:
4069 if(!(*status == -1)) goto S450;
4070 if(!qleft) goto S430;
4071 *status = 1;
4072 *bound = 0.0e0;
4073 goto S440;
4074 S430:
4075 *status = 2;
4076 *bound = inf;
4077 S450:
4078 S440:
4079 ;
4080 }
4081 else if(4 == *which) {
4082 /*
4083 Calculating PR and OMPR
4084 */
4085 T12 = atol;
4086 T13 = tol;
4087 dstzr(&K2,&K11,&T12,&T13);
4088 if(!qporq) goto S480;
4089 *status = 0;
4090 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4091 *ompr = one-*pr;
4092 S460:
4093 if(!(*status == 1)) goto S470;
4094 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4095 fx = cum-*p;
4096 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi);
4097 *ompr = one-*pr;
4098 goto S460;
4099 S470:
4100 goto S510;
4101 S480:
4102 *status = 0;
4103 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4104 *pr = one-*ompr;
4105 S490:
4106 if(!(*status == 1)) goto S500;
4107 cumnbn(s,xn,pr,ompr,&cum,&ccum);
4108 fx = ccum-*q;
4109 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi);
4110 *pr = one-*ompr;
4111 goto S490;
4112 S510:
4113 S500:
4114 if(!(*status == -1)) goto S540;
4115 if(!qleft) goto S520;
4116 *status = 1;
4117 *bound = 0.0e0;
4118 goto S530;
4119 S520:
4120 *status = 2;
4121 *bound = 1.0e0;
4122 S530:
4123 ;
4124 }
4125 S540:
4126 return;
4127 #undef tol
4128 #undef atol
4129 #undef inf
4130 #undef one
4131 } /* END */
4132
4133 /***=====================================================================***/
cdfnor(int * which,double * p,double * q,double * x,double * mean,double * sd,int * status,double * bound)4134 static void cdfnor(int *which,double *p,double *q,double *x,double *mean,
4135 double *sd,int *status,double *bound)
4136 /**********************************************************************
4137
4138 void cdfnor(int *which,double *p,double *q,double *x,double *mean,
4139 double *sd,int *status,double *bound)
4140
4141 Cumulative Distribution Function
4142 NORmal distribution
4143
4144
4145 Function
4146
4147
4148 Calculates any one parameter of the normal
4149 distribution given values for the others.
4150
4151
4152 Arguments
4153
4154
4155 WHICH --> Integer indicating which of the next parameter
4156 values is to be calculated using values of the others.
4157 Legal range: 1..4
4158 iwhich = 1 : Calculate P and Q from X,MEAN and SD
4159 iwhich = 2 : Calculate X from P,Q,MEAN and SD
4160 iwhich = 3 : Calculate MEAN from P,Q,X and SD
4161 iwhich = 4 : Calculate SD from P,Q,X and MEAN
4162
4163 P <--> The integral from -infinity to X of the normal density.
4164 Input range: (0,1].
4165
4166 Q <--> 1-P.
4167 Input range: (0, 1].
4168 P + Q = 1.0.
4169
4170 X < --> Upper limit of integration of the normal-density.
4171 Input range: ( -infinity, +infinity)
4172
4173 MEAN <--> The mean of the normal density.
4174 Input range: (-infinity, +infinity)
4175
4176 SD <--> Standard Deviation of the normal density.
4177 Input range: (0, +infinity).
4178
4179 STATUS <-- 0 if calculation completed correctly
4180 -I if input parameter number I is out of range
4181 1 if answer appears to be lower than lowest
4182 search bound
4183 2 if answer appears to be higher than greatest
4184 search bound
4185 3 if P + Q .ne. 1
4186
4187 BOUND <-- Undefined if STATUS is 0
4188
4189 Bound exceeded by parameter number I if STATUS
4190 is negative.
4191
4192 Lower search bound if STATUS is 1.
4193
4194 Upper search bound if STATUS is 2.
4195
4196
4197 Method
4198
4199
4200
4201
4202 A slightly modified version of ANORM from
4203
4204 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
4205 Package of Special Function Routines and Test Drivers"
4206 acm Transactions on Mathematical Software. 19, 22-32.
4207
4208 is used to calulate the cumulative standard normal distribution.
4209
4210 The rational functions from pages 90-95 of Kennedy and Gentle,
4211 Statistical Computing, Marcel Dekker, NY, 1980 are used as
4212 starting values to Newton's Iterations which compute the inverse
4213 standard normal. Therefore no searches are necessary for any
4214 parameter.
4215
4216 For X < -15, the asymptotic expansion for the normal is used as
4217 the starting value in finding the inverse standard normal.
4218 This is formula 26.2.12 of Abramowitz and Stegun.
4219
4220
4221 Note
4222
4223
4224 The normal density is proportional to
4225 exp( - 0.5 * (( X - MEAN)/SD)**2)
4226
4227 **********************************************************************/
4228 {
4229 static int K1 = 1;
4230 static double z,pq;
4231 /*
4232 ..
4233 .. Executable Statements ..
4234 */
4235 /*
4236 Check arguments
4237 */
4238 *status = 0;
4239 if(!(*which < 1 || *which > 4)) goto S30;
4240 if(!(*which < 1)) goto S10;
4241 *bound = 1.0e0;
4242 goto S20;
4243 S10:
4244 *bound = 4.0e0;
4245 S20:
4246 *status = -1;
4247 return;
4248 S30:
4249 if(*which == 1) goto S70;
4250 /*
4251 P
4252 */
4253 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4254 if(!(*p <= 0.0e0)) goto S40;
4255 *bound = 0.0e0;
4256 goto S50;
4257 S40:
4258 *bound = 1.0e0;
4259 S50:
4260 *status = -2;
4261 return;
4262 S70:
4263 S60:
4264 if(*which == 1) goto S110;
4265 /*
4266 Q
4267 */
4268 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4269 if(!(*q <= 0.0e0)) goto S80;
4270 *bound = 0.0e0;
4271 goto S90;
4272 S80:
4273 *bound = 1.0e0;
4274 S90:
4275 *status = -3;
4276 return;
4277 S110:
4278 S100:
4279 if(*which == 1) goto S150;
4280 /*
4281 P + Q
4282 */
4283 pq = *p+*q;
4284 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S140;
4285 if(!(pq < 0.0e0)) goto S120;
4286 *bound = 0.0e0;
4287 goto S130;
4288 S120:
4289 *bound = 1.0e0;
4290 S130:
4291 *status = 3;
4292 return;
4293 S150:
4294 S140:
4295 if(*which == 4) goto S170;
4296 /*
4297 SD
4298 */
4299 if(!(*sd <= 0.0e0)) goto S160;
4300 *bound = 0.0e0;
4301 *status = -6;
4302 return;
4303 S170:
4304 S160:
4305 /*
4306 Calculate ANSWERS
4307 */
4308 if(1 == *which) {
4309 /*
4310 Computing P
4311 */
4312 z = (*x-*mean)/ *sd;
4313 cumnor(&z,p,q);
4314 }
4315 else if(2 == *which) {
4316 /*
4317 Computing X
4318 */
4319 z = dinvnr(p,q);
4320 *x = *sd*z+*mean;
4321 }
4322 else if(3 == *which) {
4323 /*
4324 Computing the MEAN
4325 */
4326 z = dinvnr(p,q);
4327 *mean = *x-*sd*z;
4328 }
4329 else if(4 == *which) {
4330 /*
4331 Computing SD
4332 */
4333 z = dinvnr(p,q);
4334 *sd = (*x-*mean)/z;
4335 }
4336 return;
4337 } /* END */
4338
4339 /***=====================================================================***/
cdfpoi(int * which,double * p,double * q,double * s,double * xlam,int * status,double * bound)4340 static void cdfpoi(int *which,double *p,double *q,double *s,double *xlam,
4341 int *status,double *bound)
4342 /**********************************************************************
4343
4344 void cdfpoi(int *which,double *p,double *q,double *s,double *xlam,
4345 int *status,double *bound)
4346
4347 Cumulative Distribution Function
4348 POIsson distribution
4349
4350
4351 Function
4352
4353
4354 Calculates any one parameter of the Poisson
4355 distribution given values for the others.
4356
4357
4358 Arguments
4359
4360
4361 WHICH --> Integer indicating which argument
4362 value is to be calculated from the others.
4363 Legal range: 1..3
4364 iwhich = 1 : Calculate P and Q from S and XLAM
4365 iwhich = 2 : Calculate A from P,Q and XLAM
4366 iwhich = 3 : Calculate XLAM from P,Q and S
4367
4368 P <--> The cumulation from 0 to S of the poisson density.
4369 Input range: [0,1].
4370
4371 Q <--> 1-P.
4372 Input range: (0, 1].
4373 P + Q = 1.0.
4374
4375 S <--> Upper limit of cumulation of the Poisson.
4376 Input range: [0, +infinity).
4377 Search range: [0,1E300]
4378
4379 XLAM <--> Mean of the Poisson distribution.
4380 Input range: [0, +infinity).
4381 Search range: [0,1E300]
4382
4383 STATUS <-- 0 if calculation completed correctly
4384 -I if input parameter number I is out of range
4385 1 if answer appears to be lower than lowest
4386 search bound
4387 2 if answer appears to be higher than greatest
4388 search bound
4389 3 if P + Q .ne. 1
4390
4391 BOUND <-- Undefined if STATUS is 0
4392
4393 Bound exceeded by parameter number I if STATUS
4394 is negative.
4395
4396 Lower search bound if STATUS is 1.
4397
4398 Upper search bound if STATUS is 2.
4399
4400
4401 Method
4402
4403
4404 Formula 26.4.21 of Abramowitz and Stegun, Handbook of
4405 Mathematical Functions (1966) is used to reduce the computation
4406 of the cumulative distribution function to that of computing a
4407 chi-square, hence an incomplete gamma function.
4408
4409 Cumulative distribution function (P) is calculated directly.
4410 Computation of other parameters involve a seach for a value that
4411 produces the desired value of P. The search relies on the
4412 monotinicity of P with the other parameter.
4413
4414 **********************************************************************/
4415 {
4416 #define tol (1.0e-8)
4417 #define atol (1.0e-50)
4418 #define inf 1.0e300
4419 static int K1 = 1;
4420 static double K2 = 0.0e0;
4421 static double K4 = 0.5e0;
4422 static double K5 = 5.0e0;
4423 static double fx,cum,ccum,pq;
4424 static unsigned long qhi,qleft,qporq;
4425 static double T3,T6,T7,T8,T9,T10;
4426 /*
4427 ..
4428 .. Executable Statements ..
4429 */
4430 /*
4431 Check arguments
4432 */
4433 if(!(*which < 1 || *which > 3)) goto S30;
4434 if(!(*which < 1)) goto S10;
4435 *bound = 1.0e0;
4436 goto S20;
4437 S10:
4438 *bound = 3.0e0;
4439 S20:
4440 *status = -1;
4441 return;
4442 S30:
4443 if(*which == 1) goto S70;
4444 /*
4445 P
4446 */
4447 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60;
4448 if(!(*p < 0.0e0)) goto S40;
4449 *bound = 0.0e0;
4450 goto S50;
4451 S40:
4452 *bound = 1.0e0;
4453 S50:
4454 *status = -2;
4455 return;
4456 S70:
4457 S60:
4458 if(*which == 1) goto S110;
4459 /*
4460 Q
4461 */
4462 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4463 if(!(*q <= 0.0e0)) goto S80;
4464 *bound = 0.0e0;
4465 goto S90;
4466 S80:
4467 *bound = 1.0e0;
4468 S90:
4469 *status = -3;
4470 return;
4471 S110:
4472 S100:
4473 if(*which == 2) goto S130;
4474 /*
4475 S
4476 */
4477 if(!(*s < 0.0e0)) goto S120;
4478 *bound = 0.0e0;
4479 *status = -4;
4480 return;
4481 S130:
4482 S120:
4483 if(*which == 3) goto S150;
4484 /*
4485 XLAM
4486 */
4487 if(!(*xlam < 0.0e0)) goto S140;
4488 *bound = 0.0e0;
4489 *status = -5;
4490 return;
4491 S150:
4492 S140:
4493 if(*which == 1) goto S190;
4494 /*
4495 P + Q
4496 */
4497 pq = *p+*q;
4498 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180;
4499 if(!(pq < 0.0e0)) goto S160;
4500 *bound = 0.0e0;
4501 goto S170;
4502 S160:
4503 *bound = 1.0e0;
4504 S170:
4505 *status = 3;
4506 return;
4507 S190:
4508 S180:
4509 if(!(*which == 1)) qporq = *p <= *q;
4510 /*
4511 Select the minimum of P or Q
4512 Calculate ANSWERS
4513 */
4514 if(1 == *which) {
4515 /*
4516 Calculating P
4517 */
4518 cumpoi(s,xlam,p,q);
4519 *status = 0;
4520 }
4521 else if(2 == *which) {
4522 /*
4523 Calculating S
4524 */
4525 *s = 5.0e0;
4526 T3 = inf;
4527 T6 = atol;
4528 T7 = tol;
4529 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7);
4530 *status = 0;
4531 dinvr(status,s,&fx,&qleft,&qhi);
4532 S200:
4533 if(!(*status == 1)) goto S230;
4534 cumpoi(s,xlam,&cum,&ccum);
4535 if(!qporq) goto S210;
4536 fx = cum-*p;
4537 goto S220;
4538 S210:
4539 fx = ccum-*q;
4540 S220:
4541 dinvr(status,s,&fx,&qleft,&qhi);
4542 goto S200;
4543 S230:
4544 if(!(*status == -1)) goto S260;
4545 if(!qleft) goto S240;
4546 *status = 1;
4547 *bound = 0.0e0;
4548 goto S250;
4549 S240:
4550 *status = 2;
4551 *bound = inf;
4552 S260:
4553 S250:
4554 ;
4555 }
4556 else if(3 == *which) {
4557 /*
4558 Calculating XLAM
4559 */
4560 *xlam = 5.0e0;
4561 T8 = inf;
4562 T9 = atol;
4563 T10 = tol;
4564 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10);
4565 *status = 0;
4566 dinvr(status,xlam,&fx,&qleft,&qhi);
4567 S270:
4568 if(!(*status == 1)) goto S300;
4569 cumpoi(s,xlam,&cum,&ccum);
4570 if(!qporq) goto S280;
4571 fx = cum-*p;
4572 goto S290;
4573 S280:
4574 fx = ccum-*q;
4575 S290:
4576 dinvr(status,xlam,&fx,&qleft,&qhi);
4577 goto S270;
4578 S300:
4579 if(!(*status == -1)) goto S330;
4580 if(!qleft) goto S310;
4581 *status = 1;
4582 *bound = 0.0e0;
4583 goto S320;
4584 S310:
4585 *status = 2;
4586 *bound = inf;
4587 S320:
4588 ;
4589 }
4590 S330:
4591 return;
4592 #undef tol
4593 #undef atol
4594 #undef inf
4595 } /* END */
4596
4597 /***=====================================================================***/
cdft(int * which,double * p,double * q,double * t,double * df,int * status,double * bound)4598 static void cdft(int *which,double *p,double *q,double *t,double *df,
4599 int *status,double *bound)
4600 /**********************************************************************
4601
4602 void cdft(int *which,double *p,double *q,double *t,double *df,
4603 int *status,double *bound)
4604
4605 Cumulative Distribution Function
4606 T distribution
4607
4608
4609 Function
4610
4611
4612 Calculates any one parameter of the t distribution given
4613 values for the others.
4614
4615
4616 Arguments
4617
4618
4619 WHICH --> Integer indicating which argument
4620 values is to be calculated from the others.
4621 Legal range: 1..3
4622 iwhich = 1 : Calculate P and Q from T and DF
4623 iwhich = 2 : Calculate T from P,Q and DF
4624 iwhich = 3 : Calculate DF from P,Q and T
4625
4626 P <--> The integral from -infinity to t of the t-density.
4627 Input range: (0,1].
4628
4629 Q <--> 1-P.
4630 Input range: (0, 1].
4631 P + Q = 1.0.
4632
4633 T <--> Upper limit of integration of the t-density.
4634 Input range: ( -infinity, +infinity).
4635 Search range: [ -1E300, 1E300 ]
4636
4637 DF <--> Degrees of freedom of the t-distribution.
4638 Input range: (0 , +infinity).
4639 Search range: [1e-300, 1E10]
4640
4641 STATUS <-- 0 if calculation completed correctly
4642 -I if input parameter number I is out of range
4643 1 if answer appears to be lower than lowest
4644 search bound
4645 2 if answer appears to be higher than greatest
4646 search bound
4647 3 if P + Q .ne. 1
4648
4649 BOUND <-- Undefined if STATUS is 0
4650
4651 Bound exceeded by parameter number I if STATUS
4652 is negative.
4653
4654 Lower search bound if STATUS is 1.
4655
4656 Upper search bound if STATUS is 2.
4657
4658
4659 Method
4660
4661
4662 Formula 26.5.27 of Abramowitz and Stegun, Handbook of
4663 Mathematical Functions (1966) is used to reduce the computation
4664 of the cumulative distribution function to that of an incomplete
4665 beta.
4666
4667 Computation of other parameters involve a seach for a value that
4668 produces the desired value of P. The search relies on the
4669 monotinicity of P with the other parameter.
4670
4671 **********************************************************************/
4672 {
4673 #define tol (1.0e-8)
4674 #define atol (1.0e-50)
4675 #define zero (1.0e-300)
4676 #define inf 1.0e300
4677 #define maxdf 1.0e10
4678 static int K1 = 1;
4679 static double K4 = 0.5e0;
4680 static double K5 = 5.0e0;
4681 static double fx,cum,ccum,pq;
4682 static unsigned long qhi,qleft,qporq;
4683 static double T2,T3,T6,T7,T8,T9,T10,T11;
4684 /*
4685 ..
4686 .. Executable Statements ..
4687 */
4688 /*
4689 Check arguments
4690 */
4691 if(!(*which < 1 || *which > 3)) goto S30;
4692 if(!(*which < 1)) goto S10;
4693 *bound = 1.0e0;
4694 goto S20;
4695 S10:
4696 *bound = 3.0e0;
4697 S20:
4698 *status = -1;
4699 return;
4700 S30:
4701 if(*which == 1) goto S70;
4702 /*
4703 P
4704 */
4705 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60;
4706 if(!(*p <= 0.0e0)) goto S40;
4707 *bound = 0.0e0;
4708 goto S50;
4709 S40:
4710 *bound = 1.0e0;
4711 S50:
4712 *status = -2;
4713 return;
4714 S70:
4715 S60:
4716 if(*which == 1) goto S110;
4717 /*
4718 Q
4719 */
4720 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100;
4721 if(!(*q <= 0.0e0)) goto S80;
4722 *bound = 0.0e0;
4723 goto S90;
4724 S80:
4725 *bound = 1.0e0;
4726 S90:
4727 *status = -3;
4728 return;
4729 S110:
4730 S100:
4731 if(*which == 3) goto S130;
4732 /*
4733 DF
4734 */
4735 if(!(*df <= 0.0e0)) goto S120;
4736 *bound = 0.0e0;
4737 *status = -5;
4738 return;
4739 S130:
4740 S120:
4741 if(*which == 1) goto S170;
4742 /*
4743 P + Q
4744 */
4745 pq = *p+*q;
4746 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S160;
4747 if(!(pq < 0.0e0)) goto S140;
4748 *bound = 0.0e0;
4749 goto S150;
4750 S140:
4751 *bound = 1.0e0;
4752 S150:
4753 *status = 3;
4754 return;
4755 S170:
4756 S160:
4757 if(!(*which == 1)) qporq = *p <= *q;
4758 /*
4759 Select the minimum of P or Q
4760 Calculate ANSWERS
4761 */
4762 if(1 == *which) {
4763 /*
4764 Computing P and Q
4765 */
4766 cumt(t,df,p,q);
4767 *status = 0;
4768 }
4769 else if(2 == *which) {
4770 /*
4771 Computing T
4772 .. Get initial approximation for T
4773 */
4774 *t = dt1(p,q,df);
4775 T2 = -inf;
4776 T3 = inf;
4777 T6 = atol;
4778 T7 = tol;
4779 dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7);
4780 *status = 0;
4781 dinvr(status,t,&fx,&qleft,&qhi);
4782 S180:
4783 if(!(*status == 1)) goto S210;
4784 cumt(t,df,&cum,&ccum);
4785 if(!qporq) goto S190;
4786 fx = cum-*p;
4787 goto S200;
4788 S190:
4789 fx = ccum-*q;
4790 S200:
4791 dinvr(status,t,&fx,&qleft,&qhi);
4792 goto S180;
4793 S210:
4794 if(!(*status == -1)) goto S240;
4795 if(!qleft) goto S220;
4796 *status = 1;
4797 *bound = -inf;
4798 goto S230;
4799 S220:
4800 *status = 2;
4801 *bound = inf;
4802 S240:
4803 S230:
4804 ;
4805 }
4806 else if(3 == *which) {
4807 /*
4808 Computing DF
4809 */
4810 *df = 5.0e0;
4811 T8 = zero;
4812 T9 = maxdf;
4813 T10 = atol;
4814 T11 = tol;
4815 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11);
4816 *status = 0;
4817 dinvr(status,df,&fx,&qleft,&qhi);
4818 S250:
4819 if(!(*status == 1)) goto S280;
4820 cumt(t,df,&cum,&ccum);
4821 if(!qporq) goto S260;
4822 fx = cum-*p;
4823 goto S270;
4824 S260:
4825 fx = ccum-*q;
4826 S270:
4827 dinvr(status,df,&fx,&qleft,&qhi);
4828 goto S250;
4829 S280:
4830 if(!(*status == -1)) goto S310;
4831 if(!qleft) goto S290;
4832 *status = 1;
4833 *bound = zero;
4834 goto S300;
4835 S290:
4836 *status = 2;
4837 *bound = maxdf;
4838 S300:
4839 ;
4840 }
4841 S310:
4842 return;
4843 #undef tol
4844 #undef atol
4845 #undef zero
4846 #undef inf
4847 #undef maxdf
4848 } /* END */
4849
4850 /***=====================================================================***/
cumbet(double * x,double * y,double * a,double * b,double * cum,double * ccum)4851 static void cumbet(double *x,double *y,double *a,double *b,double *cum,
4852 double *ccum)
4853 /*
4854 **********************************************************************
4855
4856 void cumbet(double *x,double *y,double *a,double *b,double *cum,
4857 double *ccum)
4858
4859 Double precision cUMulative incomplete BETa distribution
4860
4861
4862 Function
4863
4864
4865 Calculates the cdf to X of the incomplete beta distribution
4866 with parameters a and b. This is the integral from 0 to x
4867 of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1)
4868
4869
4870 Arguments
4871
4872
4873 X --> Upper limit of integration.
4874 X is DOUBLE PRECISION
4875
4876 Y --> 1 - X.
4877 Y is DOUBLE PRECISION
4878
4879 A --> First parameter of the beta distribution.
4880 A is DOUBLE PRECISION
4881
4882 B --> Second parameter of the beta distribution.
4883 B is DOUBLE PRECISION
4884
4885 CUM <-- Cumulative incomplete beta distribution.
4886 CUM is DOUBLE PRECISION
4887
4888 CCUM <-- Compliment of Cumulative incomplete beta distribution.
4889 CCUM is DOUBLE PRECISION
4890
4891
4892 Method
4893
4894
4895 Calls the routine BRATIO.
4896
4897 References
4898
4899 Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim
4900 708 Significant Digit Computation of the Incomplete Beta Function
4901 Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373.
4902
4903 **********************************************************************
4904 */
4905 {
4906 static int ierr;
4907 /*
4908 ..
4909 .. Executable Statements ..
4910 */
4911 if(!(*x <= 0.0e0)) goto S10;
4912 *cum = 0.0e0;
4913 *ccum = 1.0e0;
4914 return;
4915 S10:
4916 if(!(*y <= 0.0e0)) goto S20;
4917 *cum = 1.0e0;
4918 *ccum = 0.0e0;
4919 return;
4920 S20:
4921 bratio(a,b,x,y,cum,ccum,&ierr);
4922 /*
4923 Call bratio routine
4924 */
4925 return;
4926 } /* END */
4927
4928 /***=====================================================================***/
cumbin(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)4929 static void cumbin(double *s,double *xn,double *pr,double *ompr,
4930 double *cum,double *ccum)
4931 /*
4932 **********************************************************************
4933
4934 void cumbin(double *s,double *xn,double *pr,double *ompr,
4935 double *cum,double *ccum)
4936
4937 CUmulative BINomial distribution
4938
4939
4940 Function
4941
4942
4943 Returns the probability of 0 to S successes in XN binomial
4944 trials, each of which has a probability of success, PBIN.
4945
4946
4947 Arguments
4948
4949
4950 S --> The upper limit of cumulation of the binomial distribution.
4951 S is DOUBLE PRECISION
4952
4953 XN --> The number of binomial trials.
4954 XN is DOUBLE PRECISIO
4955
4956 PBIN --> The probability of success in each binomial trial.
4957 PBIN is DOUBLE PRECIS
4958
4959 OMPR --> 1 - PBIN
4960 OMPR is DOUBLE PRECIS
4961
4962 CUM <-- Cumulative binomial distribution.
4963 CUM is DOUBLE PRECISI
4964
4965 CCUM <-- Compliment of Cumulative binomial distribution.
4966 CCUM is DOUBLE PRECIS
4967
4968
4969 Method
4970
4971
4972 Formula 26.5.24 of Abramowitz and Stegun, Handbook of
4973 Mathematical Functions (1966) is used to reduce the binomial
4974 distribution to the cumulative beta distribution.
4975
4976 **********************************************************************
4977 */
4978 {
4979 static double T1,T2;
4980 /*
4981 ..
4982 .. Executable Statements ..
4983 */
4984 if(!(*s < *xn)) goto S10;
4985 T1 = *s+1.0e0;
4986 T2 = *xn-*s;
4987 cumbet(pr,ompr,&T1,&T2,ccum,cum);
4988 goto S20;
4989 S10:
4990 *cum = 1.0e0;
4991 *ccum = 0.0e0;
4992 S20:
4993 return;
4994 } /* END */
4995
4996 /***=====================================================================***/
cumchi(double * x,double * df,double * cum,double * ccum)4997 static void cumchi(double *x,double *df,double *cum,double *ccum)
4998 /*
4999 **********************************************************************
5000
5001 void cumchi(double *x,double *df,double *cum,double *ccum)
5002 CUMulative of the CHi-square distribution
5003
5004
5005 Function
5006
5007
5008 Calculates the cumulative chi-square distribution.
5009
5010
5011 Arguments
5012
5013
5014 X --> Upper limit of integration of the
5015 chi-square distribution.
5016 X is DOUBLE PRECISION
5017
5018 DF --> Degrees of freedom of the
5019 chi-square distribution.
5020 DF is DOUBLE PRECISION
5021
5022 CUM <-- Cumulative chi-square distribution.
5023 CUM is DOUBLE PRECISIO
5024
5025 CCUM <-- Compliment of Cumulative chi-square distribution.
5026 CCUM is DOUBLE PRECISI
5027
5028
5029 Method
5030
5031
5032 Calls incomplete gamma function (CUMGAM)
5033
5034 **********************************************************************
5035 */
5036 {
5037 static double a,xx;
5038 /*
5039 ..
5040 .. Executable Statements ..
5041 */
5042 a = *df*0.5e0;
5043 xx = *x*0.5e0;
5044 cumgam(&xx,&a,cum,ccum);
5045 return;
5046 } /* END */
5047
5048 /***=====================================================================***/
cumchn(double * x,double * df,double * pnonc,double * cum,double * ccum)5049 static void cumchn(double *x,double *df,double *pnonc,double *cum,
5050 double *ccum)
5051 /*
5052 **********************************************************************
5053
5054 void cumchn(double *x,double *df,double *pnonc,double *cum,
5055 double *ccum)
5056
5057 CUMulative of the Non-central CHi-square distribution
5058
5059
5060 Function
5061
5062
5063 Calculates the cumulative non-central chi-square
5064 distribution, i.e., the probability that a random variable
5065 which follows the non-central chi-square distribution, with
5066 non-centrality parameter PNONC and continuous degrees of
5067 freedom DF, is less than or equal to X.
5068
5069
5070 Arguments
5071
5072
5073 X --> Upper limit of integration of the non-central
5074 chi-square distribution.
5075 X is DOUBLE PRECISION
5076
5077 DF --> Degrees of freedom of the non-central
5078 chi-square distribution.
5079 DF is DOUBLE PRECISION
5080
5081 PNONC --> Non-centrality parameter of the non-central
5082 chi-square distribution.
5083 PNONC is DOUBLE PRECIS
5084
5085 CUM <-- Cumulative non-central chi-square distribution.
5086 CUM is DOUBLE PRECISIO
5087
5088 CCUM <-- Compliment of Cumulative non-central chi-square distribut
5089 CCUM is DOUBLE PRECISI
5090
5091
5092 Method
5093
5094
5095 Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of
5096 Mathematical Functions, US NBS (1966) to calculate the
5097 non-central chi-square.
5098
5099
5100 Variables
5101
5102
5103 EPS --- Convergence criterion. The sum stops when a
5104 term is less than EPS*SUM.
5105 EPS is DOUBLE PRECISIO
5106
5107 NTIRED --- Maximum number of terms to be evaluated
5108 in each sum.
5109 NTIRED is INTEGER
5110
5111 QCONV --- .TRUE. if convergence achieved -
5112 i.e., program did not stop on NTIRED criterion.
5113 QCONV is LOGICAL
5114
5115 CCUM <-- Compliment of Cumulative non-central
5116 chi-square distribution.
5117 CCUM is DOUBLE PRECISI
5118
5119 **********************************************************************
5120 */
5121 {
5122 #define dg(i) (*df+2.0e0*(double)(i))
5123 #define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum)
5124 #define qtired(i) (int)((i) > ntired)
5125 static double eps = 1.0e-5;
5126 static int ntired = 1000;
5127 static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum,
5128 sumadj,term,wt,xnonc;
5129 static int i,icent,iterb,iterf;
5130 static double T1,T2,T3;
5131 /*
5132 ..
5133 .. Executable Statements ..
5134 */
5135 if(!(*x <= 0.0e0)) goto S10;
5136 *cum = 0.0e0;
5137 *ccum = 1.0e0;
5138 return;
5139 S10:
5140 if(!(*pnonc <= 1.0e-10)) goto S20;
5141 /*
5142 When non-centrality parameter is (essentially) zero,
5143 use cumulative chi-square distribution
5144 */
5145 cumchi(x,df,cum,ccum);
5146 return;
5147 S20:
5148 xnonc = *pnonc/2.0e0;
5149 /*
5150 **********************************************************************
5151 The following code calcualtes the weight, chi-square, and
5152 adjustment term for the central term in the infinite series.
5153 The central term is the one in which the poisson weight is
5154 greatest. The adjustment term is the amount that must
5155 be subtracted from the chi-square to move up two degrees
5156 of freedom.
5157 **********************************************************************
5158 */
5159 icent = fifidint(xnonc);
5160 if(icent == 0) icent = 1;
5161 chid2 = *x/2.0e0;
5162 /*
5163 Calculate central weight term
5164 */
5165 T1 = (double)(icent+1);
5166 lfact = alngam(&T1);
5167 lcntwt = -xnonc+(double)icent*log(xnonc)-lfact;
5168 centwt = exp(lcntwt);
5169 /*
5170 Calculate central chi-square
5171 */
5172 T2 = dg(icent);
5173 cumchi(x,&T2,&pcent,ccum);
5174 /*
5175 Calculate central adjustment term
5176 */
5177 dfd2 = dg(icent)/2.0e0;
5178 T3 = 1.0e0+dfd2;
5179 lfact = alngam(&T3);
5180 lcntaj = dfd2*log(chid2)-chid2-lfact;
5181 centaj = exp(lcntaj);
5182 sum = centwt*pcent;
5183 /*
5184 **********************************************************************
5185 Sum backwards from the central term towards zero.
5186 Quit whenever either
5187 (1) the zero term is reached, or
5188 (2) the term gets small relative to the sum, or
5189 (3) More than NTIRED terms are totaled.
5190 **********************************************************************
5191 */
5192 iterb = 0;
5193 sumadj = 0.0e0;
5194 adj = centaj;
5195 wt = centwt;
5196 i = icent;
5197 goto S40;
5198 S30:
5199 if(qtired(iterb) || qsmall(term) || i == 0) goto S50;
5200 S40:
5201 dfd2 = dg(i)/2.0e0;
5202 /*
5203 Adjust chi-square for two fewer degrees of freedom.
5204 The adjusted value ends up in PTERM.
5205 */
5206 adj = adj*dfd2/chid2;
5207 sumadj += adj;
5208 pterm = pcent+sumadj;
5209 /*
5210 Adjust poisson weight for J decreased by one
5211 */
5212 wt *= ((double)i/xnonc);
5213 term = wt*pterm;
5214 sum += term;
5215 i -= 1;
5216 iterb += 1;
5217 goto S30;
5218 S50:
5219 iterf = 0;
5220 /*
5221 **********************************************************************
5222 Now sum forward from the central term towards infinity.
5223 Quit when either
5224 (1) the term gets small relative to the sum, or
5225 (2) More than NTIRED terms are totaled.
5226 **********************************************************************
5227 */
5228 sumadj = adj = centaj;
5229 wt = centwt;
5230 i = icent;
5231 goto S70;
5232 S60:
5233 if(qtired(iterf) || qsmall(term)) goto S80;
5234 S70:
5235 /*
5236 Update weights for next higher J
5237 */
5238 wt *= (xnonc/(double)(i+1));
5239 /*
5240 Calculate PTERM and add term to sum
5241 */
5242 pterm = pcent-sumadj;
5243 term = wt*pterm;
5244 sum += term;
5245 /*
5246 Update adjustment term for DF for next iteration
5247 */
5248 i += 1;
5249 dfd2 = dg(i)/2.0e0;
5250 adj = adj*chid2/dfd2;
5251 sumadj += adj;
5252 iterf += 1;
5253 goto S60;
5254 S80:
5255 *cum = sum;
5256 *ccum = 0.5e0+(0.5e0-*cum);
5257 return;
5258 #undef dg
5259 #undef qsmall
5260 #undef qtired
5261 } /* END */
5262
5263 /***=====================================================================***/
cumf(double * f,double * dfn,double * dfd,double * cum,double * ccum)5264 static void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum)
5265 /*
5266 **********************************************************************
5267
5268 void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum)
5269 CUMulative F distribution
5270
5271
5272 Function
5273
5274
5275 Computes the integral from 0 to F of the f-density with DFN
5276 and DFD degrees of freedom.
5277
5278
5279 Arguments
5280
5281
5282 F --> Upper limit of integration of the f-density.
5283 F is DOUBLE PRECISION
5284
5285 DFN --> Degrees of freedom of the numerator sum of squares.
5286 DFN is DOUBLE PRECISI
5287
5288 DFD --> Degrees of freedom of the denominator sum of squares.
5289 DFD is DOUBLE PRECISI
5290
5291 CUM <-- Cumulative f distribution.
5292 CUM is DOUBLE PRECISI
5293
5294 CCUM <-- Compliment of Cumulative f distribution.
5295 CCUM is DOUBLE PRECIS
5296
5297
5298 Method
5299
5300
5301 Formula 26.5.28 of Abramowitz and Stegun is used to reduce
5302 the cumulative F to a cumulative beta distribution.
5303
5304
5305 Note
5306
5307
5308 If F is less than or equal to 0, 0 is returned.
5309
5310 **********************************************************************
5311 */
5312 {
5313 #define half 0.5e0
5314 #define done 1.0e0
5315 static double dsum,prod,xx,yy;
5316 static int ierr;
5317 static double T1,T2;
5318 /*
5319 ..
5320 .. Executable Statements ..
5321 */
5322 if(!(*f <= 0.0e0)) goto S10;
5323 *cum = 0.0e0;
5324 *ccum = 1.0e0;
5325 return;
5326 S10:
5327 prod = *dfn**f;
5328 /*
5329 XX is such that the incomplete beta with parameters
5330 DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM
5331 YY is 1 - XX
5332 Calculate the smaller of XX and YY accurately
5333 */
5334 dsum = *dfd+prod;
5335 xx = *dfd/dsum;
5336 if(xx > half) {
5337 yy = prod/dsum;
5338 xx = done-yy;
5339 }
5340 else yy = done-xx;
5341 T1 = *dfd*half;
5342 T2 = *dfn*half;
5343 bratio(&T1,&T2,&xx,&yy,ccum,cum,&ierr);
5344 return;
5345 #undef half
5346 #undef done
5347 } /* END */
5348
5349 /***=====================================================================***/
cumfnc(double * f,double * dfn,double * dfd,double * pnonc,double * cum,double * ccum)5350 static void cumfnc(double *f,double *dfn,double *dfd,double *pnonc,
5351 double *cum,double *ccum)
5352 /*
5353 **********************************************************************
5354
5355 F -NON- -C-ENTRAL F DISTRIBUTION
5356
5357
5358
5359 Function
5360
5361
5362 COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD
5363 DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC
5364
5365
5366 Arguments
5367
5368
5369 X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION
5370
5371 DFN --> DEGREES OF FREEDOM OF NUMERATOR
5372
5373 DFD --> DEGREES OF FREEDOM OF DENOMINATOR
5374
5375 PNONC --> NONCENTRALITY PARAMETER.
5376
5377 CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION
5378
5379 CCUM <-- COMPLIMENT OF CUMMULATIVE
5380
5381
5382 Method
5383
5384
5385 USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES.
5386 SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2
5387 (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL
5388 THE CONVERGENCE CRITERION IS MET.
5389
5390 FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED
5391 BY FORMULA 26.5.16.
5392
5393
5394 REFERENCE
5395
5396
5397 HANDBOOD OF MATHEMATICAL FUNCTIONS
5398 EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN
5399 NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55
5400 MARCH 1965
5401 P 947, EQUATIONS 26.6.17, 26.6.18
5402
5403
5404 Note
5405
5406
5407 THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS
5408 TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS
5409 SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED.
5410
5411 **********************************************************************
5412 */
5413 {
5414 #define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum)
5415 #define half 0.5e0
5416 #define done 1.0e0
5417 static double eps = 1.0e-4;
5418 static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum,
5419 upterm,xmult,xnonc;
5420 static int i,icent,ierr;
5421 static double T1,T2,T3,T4,T5,T6;
5422 /*
5423 ..
5424 .. Executable Statements ..
5425 */
5426 if(!(*f <= 0.0e0)) goto S10;
5427 *cum = 0.0e0;
5428 *ccum = 1.0e0;
5429 return;
5430 S10:
5431 if(!(*pnonc < 1.0e-10)) goto S20;
5432 /*
5433 Handle case in which the non-centrality parameter is
5434 (essentially) zero.
5435 */
5436 cumf(f,dfn,dfd,cum,ccum);
5437 return;
5438 S20:
5439 xnonc = *pnonc/2.0e0;
5440 /*
5441 Calculate the central term of the poisson weighting factor.
5442 */
5443 icent = xnonc;
5444 if(icent == 0) icent = 1;
5445 /*
5446 Compute central weight term
5447 */
5448 T1 = (double)(icent+1);
5449 centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1));
5450 /*
5451 Compute central incomplete beta term
5452 Assure that minimum of arg to beta and 1 - arg is computed
5453 accurately.
5454 */
5455 prod = *dfn**f;
5456 dsum = *dfd+prod;
5457 yy = *dfd/dsum;
5458 if(yy > half) {
5459 xx = prod/dsum;
5460 yy = done-xx;
5461 }
5462 else xx = done-yy;
5463 T2 = *dfn*half+(double)icent;
5464 T3 = *dfd*half;
5465 bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr);
5466 adn = *dfn/2.0e0+(double)icent;
5467 aup = adn;
5468 b = *dfd/2.0e0;
5469 betup = betdn;
5470 sum = centwt*betdn;
5471 /*
5472 Now sum terms backward from icent until convergence or all done
5473 */
5474 xmult = centwt;
5475 i = icent;
5476 T4 = adn+b;
5477 T5 = adn+1.0e0;
5478 dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy));
5479 S30:
5480 if(qsmall(xmult*betdn) || i <= 0) goto S40;
5481 xmult *= ((double)i/xnonc);
5482 i -= 1;
5483 adn -= 1.0;
5484 dnterm = (adn+1.0)/((adn+b)*xx)*dnterm;
5485 betdn += dnterm;
5486 sum += (xmult*betdn);
5487 goto S30;
5488 S40:
5489 i = icent+1;
5490 /*
5491 Now sum forwards until convergence
5492 */
5493 xmult = centwt;
5494 if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+
5495 b*log(yy));
5496 else {
5497 T6 = aup-1.0+b;
5498 upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b*
5499 log(yy));
5500 }
5501 goto S60;
5502 S50:
5503 if(qsmall(xmult*betup)) goto S70;
5504 S60:
5505 xmult *= (xnonc/(double)i);
5506 i += 1;
5507 aup += 1.0;
5508 upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm;
5509 betup -= upterm;
5510 sum += (xmult*betup);
5511 goto S50;
5512 S70:
5513 *cum = sum;
5514 *ccum = 0.5e0+(0.5e0-*cum);
5515 return;
5516 #undef qsmall
5517 #undef half
5518 #undef done
5519 } /* END */
5520
5521 /***=====================================================================***/
cumgam(double * x,double * a,double * cum,double * ccum)5522 static void cumgam(double *x,double *a,double *cum,double *ccum)
5523 /*
5524 **********************************************************************
5525
5526 void cumgam(double *x,double *a,double *cum,double *ccum)
5527 Double precision cUMulative incomplete GAMma distribution
5528
5529
5530 Function
5531
5532
5533 Computes the cumulative of the incomplete gamma
5534 distribution, i.e., the integral from 0 to X of
5535 (1/GAM(A))*EXP(-T)*T**(A-1) DT
5536 where GAM(A) is the complete gamma function of A, i.e.,
5537 GAM(A) = integral from 0 to infinity of
5538 EXP(-T)*T**(A-1) DT
5539
5540
5541 Arguments
5542
5543
5544 X --> The upper limit of integration of the incomplete gamma.
5545 X is DOUBLE PRECISION
5546
5547 A --> The shape parameter of the incomplete gamma.
5548 A is DOUBLE PRECISION
5549
5550 CUM <-- Cumulative incomplete gamma distribution.
5551 CUM is DOUBLE PRECISION
5552
5553 CCUM <-- Compliment of Cumulative incomplete gamma distribution.
5554 CCUM is DOUBLE PRECISIO
5555
5556
5557 Method
5558
5559
5560 Calls the routine GRATIO.
5561
5562 **********************************************************************
5563 */
5564 {
5565 static int K1 = 0;
5566 /*
5567 ..
5568 .. Executable Statements ..
5569 */
5570 if(!(*x <= 0.0e0)) goto S10;
5571 *cum = 0.0e0;
5572 *ccum = 1.0e0;
5573 return;
5574 S10:
5575 gratio(a,x,cum,ccum,&K1);
5576 /*
5577 Call gratio routine
5578 */
5579 return;
5580 } /* END */
5581
5582 /***=====================================================================***/
cumnbn(double * s,double * xn,double * pr,double * ompr,double * cum,double * ccum)5583 static void cumnbn(double *s,double *xn,double *pr,double *ompr,
5584 double *cum,double *ccum)
5585 /*
5586 **********************************************************************
5587
5588 void cumnbn(double *s,double *xn,double *pr,double *ompr,
5589 double *cum,double *ccum)
5590
5591 CUmulative Negative BINomial distribution
5592
5593
5594 Function
5595
5596
5597 Returns the probability that it there will be S or fewer failures
5598 before there are XN successes, with each binomial trial having
5599 a probability of success PR.
5600
5601 Prob(# failures = S | XN successes, PR) =
5602 ( XN + S - 1 )
5603 ( ) * PR^XN * (1-PR)^S
5604 ( S )
5605
5606
5607 Arguments
5608
5609
5610 S --> The number of failures
5611 S is DOUBLE PRECISION
5612
5613 XN --> The number of successes
5614 XN is DOUBLE PRECISIO
5615
5616 PR --> The probability of success in each binomial trial.
5617 PR is DOUBLE PRECISIO
5618
5619 OMPR --> 1 - PR
5620 OMPR is DOUBLE PRECIS
5621
5622 CUM <-- Cumulative negative binomial distribution.
5623 CUM is DOUBLE PRECISI
5624
5625 CCUM <-- Compliment of Cumulative negative binomial distribution.
5626 CCUM is DOUBLE PRECIS
5627
5628
5629 Method
5630
5631
5632 Formula 26.5.26 of Abramowitz and Stegun, Handbook of
5633 Mathematical Functions (1966) is used to reduce the negative
5634 binomial distribution to the cumulative beta distribution.
5635
5636 **********************************************************************
5637 */
5638 {
5639 static double T1;
5640 /*
5641 ..
5642 .. Executable Statements ..
5643 */
5644 T1 = *s+1.e0;
5645 cumbet(pr,ompr,xn,&T1,cum,ccum);
5646 return;
5647 } /* END */
5648
5649 /***=====================================================================***/
cumnor(double * arg,double * result,double * ccum)5650 static void cumnor(double *arg,double *result,double *ccum)
5651 /*
5652 **********************************************************************
5653
5654 void cumnor(double *arg,double *result,double *ccum)
5655
5656
5657 Function
5658
5659
5660 Computes the cumulative of the normal distribution, i.e.,
5661 the integral from -infinity to x of
5662 (1/sqrt(2*pi)) exp(-u*u/2) du
5663
5664 X --> Upper limit of integration.
5665 X is DOUBLE PRECISION
5666
5667 RESULT <-- Cumulative normal distribution.
5668 RESULT is DOUBLE PRECISION
5669
5670 CCUM <-- Compliment of Cumulative normal distribution.
5671 CCUM is DOUBLE PRECISION
5672
5673 Renaming of function ANORM from:
5674
5675 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
5676 Package of Special Function Routines and Test Drivers"
5677 acm Transactions on Mathematical Software. 19, 22-32.
5678
5679 with slight modifications to return ccum and to deal with
5680 machine constants.
5681
5682 **********************************************************************
5683 Original Comments:
5684 ------------------------------------------------------------------
5685
5686 This function evaluates the normal distribution function:
5687
5688 / x
5689 1 | -t*t/2
5690 P(x) = ----------- | e dt
5691 sqrt(2 pi) |
5692 /-oo
5693
5694 The main computation evaluates near-minimax approximations
5695 derived from those in "Rational Chebyshev approximations for
5696 the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
5697 This transportable program uses rational functions that
5698 theoretically approximate the normal distribution function to
5699 at least 18 significant decimal digits. The accuracy achieved
5700 depends on the arithmetic system, the compiler, the intrinsic
5701 functions, and proper selection of the machine-dependent
5702 constants.
5703
5704 *******************************************************************
5705 *******************************************************************
5706
5707 Explanation of machine-dependent constants.
5708
5709 MIN = smallest machine representable number.
5710
5711 EPS = argument below which anorm(x) may be represented by
5712 0.5 and above which x*x will not underflow.
5713 A conservative value is the largest machine number X
5714 such that 1.0 + X = 1.0 to machine precision.
5715 *******************************************************************
5716 *******************************************************************
5717
5718 Error returns
5719
5720 The program returns ANORM = 0 for ARG .LE. XLOW.
5721
5722
5723 Intrinsic functions required are:
5724
5725 ABS, AINT, EXP
5726
5727
5728 Author: W. J. Cody
5729 Mathematics and Computer Science Division
5730 Argonne National Laboratory
5731 Argonne, IL 60439
5732
5733 Latest modification: March 15, 1992
5734
5735 ------------------------------------------------------------------
5736 */
5737 {
5738 static double a[5] = {
5739 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03,
5740 1.8154981253343561249e04,6.5682337918207449113e-2
5741 };
5742 static double b[4] = {
5743 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04,
5744 4.5507789335026729956e04
5745 };
5746 static double c[9] = {
5747 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01,
5748 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03,
5749 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8
5750 };
5751 static double d[8] = {
5752 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03,
5753 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04,
5754 3.8912003286093271411e04,1.9685429676859990727e04
5755 };
5756 static double half = 0.5e0;
5757 static double p[6] = {
5758 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2,
5759 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2
5760 };
5761 static double one = 1.0e0;
5762 static double q[5] = {
5763 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2,
5764 3.78239633202758244e-3,7.29751555083966205e-5
5765 };
5766 static double sixten = 1.60e0;
5767 static double sqrpi = 3.9894228040143267794e-1;
5768 static double thrsh = 0.66291e0;
5769 static double root32 = 5.656854248e0;
5770 static double zero = 0.0e0;
5771 static int K1 = 1;
5772 static int K2 = 2;
5773 static int i;
5774 static double del,eps,temp,x,xden,xnum,y,xsq,min;
5775 /*
5776 ------------------------------------------------------------------
5777 Machine dependent constants
5778 ------------------------------------------------------------------
5779 */
5780 eps = spmpar(&K1)*0.5e0;
5781 min = spmpar(&K2);
5782 x = *arg;
5783 y = fabs(x);
5784 if(y <= thrsh) {
5785 /*
5786 ------------------------------------------------------------------
5787 Evaluate anorm for |X| <= 0.66291
5788 ------------------------------------------------------------------
5789 */
5790 xsq = zero;
5791 if(y > eps) xsq = x*x;
5792 xnum = a[4]*xsq;
5793 xden = xsq;
5794 for(i=0; i<3; i++) {
5795 xnum = (xnum+a[i])*xsq;
5796 xden = (xden+b[i])*xsq;
5797 }
5798 *result = x*(xnum+a[3])/(xden+b[3]);
5799 temp = *result;
5800 *result = half+temp;
5801 *ccum = half-temp;
5802 }
5803 /*
5804 ------------------------------------------------------------------
5805 Evaluate anorm for 0.66291 <= |X| <= sqrt(32)
5806 ------------------------------------------------------------------
5807 */
5808 else if(y <= root32) {
5809 xnum = c[8]*y;
5810 xden = y;
5811 for(i=0; i<7; i++) {
5812 xnum = (xnum+c[i])*y;
5813 xden = (xden+d[i])*y;
5814 }
5815 *result = (xnum+c[7])/(xden+d[7]);
5816 xsq = fifdint(y*sixten)/sixten;
5817 del = (y-xsq)*(y+xsq);
5818 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
5819 *ccum = one-*result;
5820 if(x > zero) {
5821 temp = *result;
5822 *result = *ccum;
5823 *ccum = temp;
5824 }
5825 }
5826 /*
5827 ------------------------------------------------------------------
5828 Evaluate anorm for |X| > sqrt(32)
5829 ------------------------------------------------------------------
5830 */
5831 else {
5832 *result = zero;
5833 xsq = one/(x*x);
5834 xnum = p[5]*xsq;
5835 xden = xsq;
5836 for(i=0; i<4; i++) {
5837 xnum = (xnum+p[i])*xsq;
5838 xden = (xden+q[i])*xsq;
5839 }
5840 *result = xsq*(xnum+p[4])/(xden+q[4]);
5841 *result = (sqrpi-*result)/y;
5842 xsq = fifdint(x*sixten)/sixten;
5843 del = (x-xsq)*(x+xsq);
5844 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result;
5845 *ccum = one-*result;
5846 if(x > zero) {
5847 temp = *result;
5848 *result = *ccum;
5849 *ccum = temp;
5850 }
5851 }
5852 if(*result < min) *result = 0.0e0;
5853 /*
5854 ------------------------------------------------------------------
5855 Fix up for negative argument, erf, etc.
5856 ------------------------------------------------------------------
5857 ----------Last card of ANORM ----------
5858 */
5859 if(*ccum < min) *ccum = 0.0e0;
5860 } /* END */
5861
5862 /***=====================================================================***/
cumpoi(double * s,double * xlam,double * cum,double * ccum)5863 static void cumpoi(double *s,double *xlam,double *cum,double *ccum)
5864 /*
5865 **********************************************************************
5866
5867 void cumpoi(double *s,double *xlam,double *cum,double *ccum)
5868 CUMulative POIsson distribution
5869
5870
5871 Function
5872
5873
5874 Returns the probability of S or fewer events in a Poisson
5875 distribution with mean XLAM.
5876
5877
5878 Arguments
5879
5880
5881 S --> Upper limit of cumulation of the Poisson.
5882 S is DOUBLE PRECISION
5883
5884 XLAM --> Mean of the Poisson distribution.
5885 XLAM is DOUBLE PRECIS
5886
5887 CUM <-- Cumulative poisson distribution.
5888 CUM is DOUBLE PRECISION
5889
5890 CCUM <-- Compliment of Cumulative poisson distribution.
5891 CCUM is DOUBLE PRECIS
5892
5893
5894 Method
5895
5896
5897 Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of
5898 Mathematical Functions to reduce the cumulative Poisson to
5899 the cumulative chi-square distribution.
5900
5901 **********************************************************************
5902 */
5903 {
5904 static double chi,df;
5905 /*
5906 ..
5907 .. Executable Statements ..
5908 */
5909 df = 2.0e0*(*s+1.0e0);
5910 chi = 2.0e0**xlam;
5911 cumchi(&chi,&df,ccum,cum);
5912 return;
5913 } /* END */
5914
5915 /***=====================================================================***/
cumt(double * t,double * df,double * cum,double * ccum)5916 static void cumt(double *t,double *df,double *cum,double *ccum)
5917 /*
5918 **********************************************************************
5919
5920 void cumt(double *t,double *df,double *cum,double *ccum)
5921 CUMulative T-distribution
5922
5923
5924 Function
5925
5926
5927 Computes the integral from -infinity to T of the t-density.
5928
5929
5930 Arguments
5931
5932
5933 T --> Upper limit of integration of the t-density.
5934 T is DOUBLE PRECISION
5935
5936 DF --> Degrees of freedom of the t-distribution.
5937 DF is DOUBLE PRECISIO
5938
5939 CUM <-- Cumulative t-distribution.
5940 CCUM is DOUBLE PRECIS
5941
5942 CCUM <-- Compliment of Cumulative t-distribution.
5943 CCUM is DOUBLE PRECIS
5944
5945
5946 Method
5947
5948
5949 Formula 26.5.27 of Abramowitz and Stegun, Handbook of
5950 Mathematical Functions is used to reduce the t-distribution
5951 to an incomplete beta.
5952
5953 **********************************************************************
5954 */
5955 {
5956 static double K2 = 0.5e0;
5957 static double xx,a,oma,tt,yy,dfptt,T1;
5958 /*
5959 ..
5960 .. Executable Statements ..
5961 */
5962 tt = *t**t;
5963 dfptt = *df+tt;
5964 xx = *df/dfptt;
5965 yy = tt/dfptt;
5966 T1 = 0.5e0**df;
5967 cumbet(&xx,&yy,&T1,&K2,&a,&oma);
5968 if(!(*t <= 0.0e0)) goto S10;
5969 *cum = 0.5e0*a;
5970 *ccum = oma+*cum;
5971 goto S20;
5972 S10:
5973 *ccum = 0.5e0*a;
5974 *cum = oma+*ccum;
5975 S20:
5976 return;
5977 } /* END */
5978
5979 /***=====================================================================***/
dbetrm(double * a,double * b)5980 static double dbetrm(double *a,double *b)
5981 /*
5982 **********************************************************************
5983
5984 double dbetrm(double *a,double *b)
5985 Double Precision Sterling Remainder for Complete
5986 Beta Function
5987
5988
5989 Function
5990
5991
5992 Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
5993 where Lgamma is the log of the (complete) gamma function
5994
5995 Let ZZ be approximation obtained if each log gamma is approximated
5996 by Sterling's formula, i.e.,
5997 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
5998
5999 Returns Log(Beta(A,B)) - ZZ
6000
6001
6002 Arguments
6003
6004
6005 A --> One argument of the Beta
6006 DOUBLE PRECISION A
6007
6008 B --> The other argument of the Beta
6009 DOUBLE PRECISION B
6010
6011 **********************************************************************
6012 */
6013 {
6014 static double dbetrm,T1,T2,T3;
6015 /*
6016 ..
6017 .. Executable Statements ..
6018 */
6019 /*
6020 Try to sum from smallest to largest
6021 */
6022 T1 = *a+*b;
6023 dbetrm = -dstrem(&T1);
6024 T2 = fifdmax1(*a,*b);
6025 dbetrm += dstrem(&T2);
6026 T3 = fifdmin1(*a,*b);
6027 dbetrm += dstrem(&T3);
6028 return dbetrm;
6029 } /* END */
6030
6031 /***=====================================================================***/
devlpl(double a[],int * n,double * x)6032 static double devlpl(double a[],int *n,double *x)
6033 /*
6034 **********************************************************************
6035
6036 double devlpl(double a[],int *n,double *x)
6037 Double precision EVALuate a PoLynomial at X
6038
6039
6040 Function
6041
6042
6043 returns
6044 A(1) + A(2)*X + ... + A(N)*X**(N-1)
6045
6046
6047 Arguments
6048
6049
6050 A --> Array of coefficients of the polynomial.
6051 A is DOUBLE PRECISION(N)
6052
6053 N --> Length of A, also degree of polynomial - 1.
6054 N is INTEGER
6055
6056 X --> Point at which the polynomial is to be evaluated.
6057 X is DOUBLE PRECISION
6058
6059 **********************************************************************
6060 */
6061 {
6062 static double devlpl,term;
6063 static int i;
6064 /*
6065 ..
6066 .. Executable Statements ..
6067 */
6068 term = a[*n-1];
6069 for(i= *n-1-1; i>=0; i--) term = a[i]+term**x;
6070 devlpl = term;
6071 return devlpl;
6072 } /* END */
6073
6074 /***=====================================================================***/
dexpm1(double * x)6075 static double dexpm1(double *x)
6076 /*
6077 **********************************************************************
6078
6079 double dexpm1(double *x)
6080 Evaluation of the function EXP(X) - 1
6081
6082
6083 Arguments
6084
6085
6086 X --> Argument at which exp(x)-1 desired
6087 DOUBLE PRECISION X
6088
6089
6090 Method
6091
6092
6093 Renaming of function rexp from code of:
6094
6095 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6096 Digit Computation of the Incomplete Beta Function Ratios. ACM
6097 Trans. Math. Softw. 18 (1993), 360-373.
6098
6099 **********************************************************************
6100 */
6101 {
6102 static double p1 = .914041914819518e-09;
6103 static double p2 = .238082361044469e-01;
6104 static double q1 = -.499999999085958e+00;
6105 static double q2 = .107141568980644e+00;
6106 static double q3 = -.119041179760821e-01;
6107 static double q4 = .595130811860248e-03;
6108 static double dexpm1,w;
6109 /*
6110 ..
6111 .. Executable Statements ..
6112 */
6113 if(fabs(*x) > 0.15e0) goto S10;
6114 dexpm1 = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
6115 return dexpm1;
6116 S10:
6117 w = exp(*x);
6118 if(*x > 0.0e0) goto S20;
6119 dexpm1 = w-0.5e0-0.5e0;
6120 return dexpm1;
6121 S20:
6122 dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w));
6123 return dexpm1;
6124 } /* END */
6125
6126 /***=====================================================================***/
dinvnr(double * p,double * q)6127 static double dinvnr(double *p,double *q)
6128 /*
6129 **********************************************************************
6130
6131 double dinvnr(double *p,double *q)
6132 Double precision NoRmal distribution INVerse
6133
6134
6135 Function
6136
6137
6138 Returns X such that CUMNOR(X) = P, i.e., the integral from -
6139 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
6140
6141
6142 Arguments
6143
6144
6145 P --> The probability whose normal deviate is sought.
6146 P is DOUBLE PRECISION
6147
6148 Q --> 1-P
6149 P is DOUBLE PRECISION
6150
6151
6152 Method
6153
6154
6155 The rational function on page 95 of Kennedy and Gentle,
6156 Statistical Computing, Marcel Dekker, NY , 1980 is used as a start
6157 value for the Newton method of finding roots.
6158
6159
6160 Note
6161
6162
6163 If P or Q .lt. machine EPS returns +/- DINVNR(EPS)
6164
6165 **********************************************************************
6166 */
6167 {
6168 #define maxit 100
6169 #define eps (1.0e-13)
6170 #define r2pi 0.3989422804014326e0
6171 #define nhalf (-0.5e0)
6172 #define dennor(x) (r2pi*exp(nhalf*(x)*(x)))
6173 static double dinvnr,strtx,xcur,cum,ccum,pp,dx;
6174 static int i;
6175 static unsigned long qporq;
6176 /*
6177 ..
6178 .. Executable Statements ..
6179 */
6180 /*
6181 FIND MINIMUM OF P AND Q
6182 */
6183 qporq = *p <= *q;
6184 if(!qporq) goto S10;
6185 pp = *p;
6186 goto S20;
6187 S10:
6188 pp = *q;
6189 S20:
6190 /*
6191 INITIALIZATION STEP
6192 */
6193 strtx = stvaln(&pp);
6194 xcur = strtx;
6195 /*
6196 NEWTON INTERATIONS
6197 */
6198 for(i=1; i<=maxit; i++) {
6199 cumnor(&xcur,&cum,&ccum);
6200 dx = (cum-pp)/dennor(xcur);
6201 xcur -= dx;
6202 if(fabs(dx/xcur) < eps) goto S40;
6203 }
6204 dinvnr = strtx;
6205 /*
6206 IF WE GET HERE, NEWTON HAS FAILED
6207 */
6208 if(!qporq) dinvnr = -dinvnr;
6209 return dinvnr;
6210 S40:
6211 /*
6212 IF WE GET HERE, NEWTON HAS SUCCEDED
6213 */
6214 dinvnr = xcur;
6215 if(!qporq) dinvnr = -dinvnr;
6216 return dinvnr;
6217 #undef maxit
6218 #undef eps
6219 #undef r2pi
6220 #undef nhalf
6221 #undef dennor
6222 } /* END */
6223
6224 /***=====================================================================***/
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)6225 static void E0000(int IENTRY,int *status,double *x,double *fx,
6226 unsigned long *qleft,unsigned long *qhi,double *zabsst,
6227 double *zabsto,double *zbig,double *zrelst,
6228 double *zrelto,double *zsmall,double *zstpmu)
6229 {
6230 #define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz))
6231 static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi,
6232 xlb,xlo,xsave,xub,yy;
6233 static int i99999;
6234 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup;
6235 switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;}
6236 DINVR:
6237 if(*status > 0) goto S310;
6238 qcond = !qxmon(small,*x,big);
6239 if(qcond){ ftnstop("SMALL,X,BIG nonmonotone in E0000"); *status=-1; return;}
6240 xsave = *x;
6241 /*
6242 See that SMALL and BIG bound the zero and set QINCR
6243 */
6244 *x = small;
6245 /*
6246 GET-FUNCTION-VALUE
6247 */
6248 i99999 = 1;
6249 goto S300;
6250 S10:
6251 fsmall = *fx;
6252 *x = big;
6253 /*
6254 GET-FUNCTION-VALUE
6255 */
6256 i99999 = 2;
6257 goto S300;
6258 S20:
6259 fbig = *fx;
6260 qincr = fbig > fsmall;
6261 if(!qincr) goto S50;
6262 if(fsmall <= 0.0e0) goto S30;
6263 *status = -1;
6264 *qleft = *qhi = 1;
6265 return;
6266 S30:
6267 if(fbig >= 0.0e0) goto S40;
6268 *status = -1;
6269 *qleft = *qhi = 0;
6270 return;
6271 S40:
6272 goto S80;
6273 S50:
6274 if(fsmall >= 0.0e0) goto S60;
6275 *status = -1;
6276 *qleft = 1;
6277 *qhi = 0;
6278 return;
6279 S60:
6280 if(fbig <= 0.0e0) goto S70;
6281 *status = -1;
6282 *qleft = 0;
6283 *qhi = 1;
6284 return;
6285 S80:
6286 S70:
6287 *x = xsave;
6288 step = fifdmax1(absstp,relstp*fabs(*x));
6289 /*
6290 YY = F(X) - Y
6291 GET-FUNCTION-VALUE
6292 */
6293 i99999 = 3;
6294 goto S300;
6295 S90:
6296 yy = *fx;
6297 if(!(yy == 0.0e0)) goto S100;
6298 *status = 0;
6299 qok = 1;
6300 return;
6301 S100:
6302 qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0;
6303 /*
6304 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6305 HANDLE CASE IN WHICH WE MUST STEP HIGHER
6306 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6307 */
6308 if(!qup) goto S170;
6309 xlb = xsave;
6310 xub = fifdmin1(xlb+step,big);
6311 goto S120;
6312 S110:
6313 if(qcond) goto S150;
6314 S120:
6315 /*
6316 YY = F(XUB) - Y
6317 */
6318 *x = xub;
6319 /*
6320 GET-FUNCTION-VALUE
6321 */
6322 i99999 = 4;
6323 goto S300;
6324 S130:
6325 yy = *fx;
6326 qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0;
6327 qlim = xub >= big;
6328 qcond = qbdd || qlim;
6329 if(qcond) goto S140;
6330 step = stpmul*step;
6331 xlb = xub;
6332 xub = fifdmin1(xlb+step,big);
6333 S140:
6334 goto S110;
6335 S150:
6336 if(!(qlim && !qbdd)) goto S160;
6337 *status = -1;
6338 *qleft = 0;
6339 *qhi = !qincr;
6340 *x = big;
6341 return;
6342 S160:
6343 goto S240;
6344 S170:
6345 /*
6346 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6347 HANDLE CASE IN WHICH WE MUST STEP LOWER
6348 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6349 */
6350 xub = xsave;
6351 xlb = fifdmax1(xub-step,small);
6352 goto S190;
6353 S180:
6354 if(qcond) goto S220;
6355 S190:
6356 /*
6357 YY = F(XLB) - Y
6358 */
6359 *x = xlb;
6360 /*
6361 GET-FUNCTION-VALUE
6362 */
6363 i99999 = 5;
6364 goto S300;
6365 S200:
6366 yy = *fx;
6367 qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0;
6368 qlim = xlb <= small;
6369 qcond = qbdd || qlim;
6370 if(qcond) goto S210;
6371 step = stpmul*step;
6372 xub = xlb;
6373 xlb = fifdmax1(xub-step,small);
6374 S210:
6375 goto S180;
6376 S220:
6377 if(!(qlim && !qbdd)) goto S230;
6378 *status = -1;
6379 *qleft = 1;
6380 *qhi = qincr;
6381 *x = small;
6382 return;
6383 S240:
6384 S230:
6385 dstzr(&xlb,&xub,&abstol,&reltol);
6386 /*
6387 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6388 IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F.
6389 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
6390 */
6391 *status = 0;
6392 goto S260;
6393 S250:
6394 if(!(*status == 1)) goto S290;
6395 S260:
6396 dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2);
6397 if(!(*status == 1)) goto S280;
6398 /*
6399 GET-FUNCTION-VALUE
6400 */
6401 i99999 = 6;
6402 goto S300;
6403 S280:
6404 S270:
6405 goto S250;
6406 S290:
6407 *x = xlo;
6408 *status = 0;
6409 return;
6410 DSTINV:
6411 small = *zsmall;
6412 big = *zbig;
6413 absstp = *zabsst;
6414 relstp = *zrelst;
6415 stpmul = *zstpmu;
6416 abstol = *zabsto;
6417 reltol = *zrelto;
6418 return;
6419 S300:
6420 /*
6421 TO GET-FUNCTION-VALUE
6422 */
6423 *status = 1;
6424 return;
6425 S310:
6426 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case
6427 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;}
6428 #undef qxmon
6429 } /* END */
6430
6431 /***=====================================================================***/
dinvr(int * status,double * x,double * fx,unsigned long * qleft,unsigned long * qhi)6432 static void dinvr(int *status,double *x,double *fx,
6433 unsigned long *qleft,unsigned long *qhi)
6434 /*
6435 **********************************************************************
6436
6437 void dinvr(int *status,double *x,double *fx,
6438 unsigned long *qleft,unsigned long *qhi)
6439
6440 Double precision
6441 bounds the zero of the function and invokes zror
6442 Reverse Communication
6443
6444
6445 Function
6446
6447
6448 Bounds the function and invokes ZROR to perform the zero
6449 finding. STINVR must have been called before this routine
6450 in order to set its parameters.
6451
6452
6453 Arguments
6454
6455
6456 STATUS <--> At the beginning of a zero finding problem, STATUS
6457 should be set to 0 and INVR invoked. (The value
6458 of parameters other than X will be ignored on this cal
6459
6460 When INVR needs the function evaluated, it will set
6461 STATUS to 1 and return. The value of the function
6462 should be set in FX and INVR again called without
6463 changing any of its other parameters.
6464
6465 When INVR has finished without error, it will return
6466 with STATUS 0. In that case X is approximately a root
6467 of F(X).
6468
6469 If INVR cannot bound the function, it returns status
6470 -1 and sets QLEFT and QHI.
6471 INTEGER STATUS
6472
6473 X <-- The value of X at which F(X) is to be evaluated.
6474 DOUBLE PRECISION X
6475
6476 FX --> The value of F(X) calculated when INVR returns with
6477 STATUS = 1.
6478 DOUBLE PRECISION FX
6479
6480 QLEFT <-- Defined only if QMFINV returns .FALSE. In that
6481 case it is .TRUE. If the stepping search terminated
6482 unsucessfully at SMALL. If it is .FALSE. the search
6483 terminated unsucessfully at BIG.
6484 QLEFT is LOGICAL
6485
6486 QHI <-- Defined only if QMFINV returns .FALSE. In that
6487 case it is .TRUE. if F(X) .GT. Y at the termination
6488 of the search and .FALSE. if F(X) .LT. Y at the
6489 termination of the search.
6490 QHI is LOGICAL
6491
6492 **********************************************************************
6493 */
6494 {
6495 E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL);
6496 } /* END */
6497
6498 /***=====================================================================***/
dstinv(double * zsmall,double * zbig,double * zabsst,double * zrelst,double * zstpmu,double * zabsto,double * zrelto)6499 static void dstinv(double *zsmall,double *zbig,double *zabsst,
6500 double *zrelst,double *zstpmu,double *zabsto,
6501 double *zrelto)
6502 /*
6503 **********************************************************************
6504 void dstinv(double *zsmall,double *zbig,double *zabsst,
6505 double *zrelst,double *zstpmu,double *zabsto,
6506 double *zrelto)
6507
6508 Double Precision - SeT INverse finder - Reverse Communication
6509 Function
6510 Concise Description - Given a monotone function F finds X
6511 such that F(X) = Y. Uses Reverse communication -- see invr.
6512 This routine sets quantities needed by INVR.
6513 More Precise Description of INVR -
6514 F must be a monotone function, the results of QMFINV are
6515 otherwise undefined. QINCR must be .TRUE. if F is non-
6516 decreasing and .FALSE. if F is non-increasing.
6517 QMFINV will return .TRUE. if and only if F(SMALL) and
6518 F(BIG) bracket Y, i. e.,
6519 QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or
6520 QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL)
6521 if QMFINV returns .TRUE., then the X returned satisfies
6522 the following condition. let
6523 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
6524 then if QINCR is .TRUE.,
6525 F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X))
6526 and if QINCR is .FALSE.
6527 F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X))
6528 Arguments
6529 SMALL --> The left endpoint of the interval to be
6530 searched for a solution.
6531 SMALL is DOUBLE PRECISION
6532 BIG --> The right endpoint of the interval to be
6533 searched for a solution.
6534 BIG is DOUBLE PRECISION
6535 ABSSTP, RELSTP --> The initial step size in the search
6536 is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm.
6537 ABSSTP is DOUBLE PRECISION
6538 RELSTP is DOUBLE PRECISION
6539 STPMUL --> When a step doesn't bound the zero, the step
6540 size is multiplied by STPMUL and another step
6541 taken. A popular value is 2.0
6542 DOUBLE PRECISION STPMUL
6543 ABSTOL, RELTOL --> Two numbers that determine the accuracy
6544 of the solution. See function for a precise definition.
6545 ABSTOL is DOUBLE PRECISION
6546 RELTOL is DOUBLE PRECISION
6547 Method
6548 Compares F(X) with Y for the input value of X then uses QINCR
6549 to determine whether to step left or right to bound the
6550 desired x. the initial step size is
6551 MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X.
6552 Iteratively steps right or left until it bounds X.
6553 At each step which doesn't bound X, the step size is doubled.
6554 The routine is careful never to step beyond SMALL or BIG. If
6555 it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE.
6556 after setting QLEFT and QHI.
6557 If X is successfully bounded then Algorithm R of the paper
6558 'Two Efficient Algorithms with Guaranteed Convergence for
6559 Finding a Zero of a Function' by J. C. P. Bus and
6560 T. J. Dekker in ACM Transactions on Mathematical
6561 Software, Volume 1, No. 4 page 330 (DEC. '75) is employed
6562 to find the zero of the function F(X)-Y. This is routine
6563 QRZERO.
6564 **********************************************************************
6565 */
6566 {
6567 E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall,
6568 zstpmu);
6569 } /* END */
6570
6571 /***=====================================================================***/
dlanor(double * x)6572 static double dlanor(double *x)
6573 /*
6574 **********************************************************************
6575
6576 double dlanor(double *x)
6577 Double precision Logarith of the Asymptotic Normal
6578
6579
6580 Function
6581
6582
6583 Computes the logarithm of the cumulative normal distribution
6584 from abs( x ) to infinity for abs( x ) >= 5.
6585
6586
6587 Arguments
6588
6589
6590 X --> Value at which cumulative normal to be evaluated
6591 DOUBLE PRECISION X
6592
6593
6594 Method
6595
6596
6597 23 term expansion of formula 26.2.12 of Abramowitz and Stegun.
6598 The relative error at X = 5 is about 0.5E-5.
6599
6600
6601 Note
6602
6603
6604 ABS(X) must be >= 5 else there is an error stop.
6605
6606 **********************************************************************
6607 */
6608 {
6609 #define dlsqpi 0.91893853320467274177e0
6610 static double coef[12] = {
6611 -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0,
6612 -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0
6613 };
6614 static int K1 = 12;
6615 static double dlanor,approx,correc,xx,xx2,T2;
6616 /*
6617 ..
6618 .. Executable Statements ..
6619 */
6620 xx = fabs(*x);
6621 if(xx < 5.0e0){ ftnstop("Argument too small in DLANOR"); return 66.6; }
6622 approx = -dlsqpi-0.5e0*xx*xx-log(xx);
6623 xx2 = xx*xx;
6624 T2 = 1.0e0/xx2;
6625 correc = devlpl(coef,&K1,&T2)/xx2;
6626 correc = dln1px(&correc);
6627 dlanor = approx+correc;
6628 return dlanor;
6629 #undef dlsqpi
6630 } /* END */
6631
6632 /***=====================================================================***/
dln1mx(double * x)6633 static double dln1mx(double *x)
6634 /*
6635 **********************************************************************
6636
6637 double dln1mx(double *x)
6638 Double precision LN(1-X)
6639
6640
6641 Function
6642
6643
6644 Returns ln(1-x) for small x (good accuracy if x .le. 0.1).
6645 Note that the obvious code of
6646 LOG(1.0-X)
6647 won't work for small X because 1.0-X loses accuracy
6648
6649
6650 Arguments
6651
6652
6653 X --> Value for which ln(1-x) is desired.
6654 X is DOUBLE PRECISION
6655
6656
6657 Method
6658
6659
6660 If X > 0.1, the obvious code above is used ELSE
6661 The Taylor series for 1-x is expanded to 20 terms.
6662
6663 **********************************************************************
6664 */
6665 {
6666 static double dln1mx,T1;
6667 /*
6668 ..
6669 .. Executable Statements ..
6670 */
6671 T1 = -*x;
6672 dln1mx = dln1px(&T1);
6673 return dln1mx;
6674 } /* END */
6675
6676 /***=====================================================================***/
dln1px(double * a)6677 static double dln1px(double *a)
6678 /*
6679 **********************************************************************
6680
6681 double dln1px(double *a)
6682 Double precision LN(1+X)
6683
6684
6685 Function
6686
6687
6688 Returns ln(1+x)
6689 Note that the obvious code of
6690 LOG(1.0+X)
6691 won't work for small X because 1.0+X loses accuracy
6692
6693
6694 Arguments
6695
6696
6697 X --> Value for which ln(1-x) is desired.
6698 X is DOUBLE PRECISION
6699
6700
6701 Method
6702
6703
6704 Renames ALNREL from:
6705 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6706 Digit Computation of the Incomplete Beta Function Ratios. ACM
6707 Trans. Math. Softw. 18 (1993), 360-373.
6708
6709 **********************************************************************
6710 -----------------------------------------------------------------------
6711 EVALUATION OF THE FUNCTION LN(1 + A)
6712 -----------------------------------------------------------------------
6713 */
6714 {
6715 static double p1 = -.129418923021993e+01;
6716 static double p2 = .405303492862024e+00;
6717 static double p3 = -.178874546012214e-01;
6718 static double q1 = -.162752256355323e+01;
6719 static double q2 = .747811014037616e+00;
6720 static double q3 = -.845104217945565e-01;
6721 static double dln1px,t,t2,w,x;
6722 /*
6723 ..
6724 .. Executable Statements ..
6725 */
6726 if(fabs(*a) > 0.375e0) goto S10;
6727 t = *a/(*a+2.0e0);
6728 t2 = t*t;
6729 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0);
6730 dln1px = 2.0e0*t*w;
6731 return dln1px;
6732 S10:
6733 x = 1.e0+*a;
6734 dln1px = log(x);
6735 return dln1px;
6736 } /* END */
6737
6738 /***=====================================================================***/
dlnbet(double * a0,double * b0)6739 static double dlnbet(double *a0,double *b0)
6740 /*
6741 **********************************************************************
6742
6743 double dlnbet(a0,b0)
6744 Double precision LN of the complete BETa
6745
6746
6747 Function
6748
6749
6750 Returns the natural log of the complete beta function,
6751 i.e.,
6752
6753 ln( Gamma(a)*Gamma(b) / Gamma(a+b)
6754
6755
6756 Arguments
6757
6758
6759 A,B --> The (symmetric) arguments to the complete beta
6760 DOUBLE PRECISION A, B
6761
6762
6763 Method
6764
6765
6766 Renames BETALN from:
6767 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6768 Digit Computation of the Incomplete Beta Function Ratios. ACM
6769 Trans. Math. Softw. 18 (1993), 360-373.
6770
6771 **********************************************************************
6772 -----------------------------------------------------------------------
6773 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
6774 -----------------------------------------------------------------------
6775 E = 0.5*LN(2*PI)
6776 --------------------------
6777 */
6778 {
6779 static double e = .918938533204673e0;
6780 static double dlnbet,a,b,c,h,u,v,w,z;
6781 static int i,n;
6782 static double T1;
6783 /*
6784 ..
6785 .. Executable Statements ..
6786 */
6787 a = fifdmin1(*a0,*b0);
6788 b = fifdmax1(*a0,*b0);
6789 if(a >= 8.0e0) goto S100;
6790 if(a >= 1.0e0) goto S20;
6791 /*
6792 -----------------------------------------------------------------------
6793 PROCEDURE WHEN A .LT. 1
6794 -----------------------------------------------------------------------
6795 */
6796 if(b >= 8.0e0) goto S10;
6797 T1 = a+b;
6798 dlnbet = gamln(&a)+(gamln(&b)-gamln(&T1));
6799 return dlnbet;
6800 S10:
6801 dlnbet = gamln(&a)+algdiv(&a,&b);
6802 return dlnbet;
6803 S20:
6804 /*
6805 -----------------------------------------------------------------------
6806 PROCEDURE WHEN 1 .LE. A .LT. 8
6807 -----------------------------------------------------------------------
6808 */
6809 if(a > 2.0e0) goto S40;
6810 if(b > 2.0e0) goto S30;
6811 dlnbet = gamln(&a)+gamln(&b)-gsumln(&a,&b);
6812 return dlnbet;
6813 S30:
6814 w = 0.0e0;
6815 if(b < 8.0e0) goto S60;
6816 dlnbet = gamln(&a)+algdiv(&a,&b);
6817 return dlnbet;
6818 S40:
6819 /*
6820 REDUCTION OF A WHEN B .LE. 1000
6821 */
6822 if(b > 1000.0e0) goto S80;
6823 n = a-1.0e0;
6824 w = 1.0e0;
6825 for(i=1; i<=n; i++) {
6826 a -= 1.0e0;
6827 h = a/b;
6828 w *= (h/(1.0e0+h));
6829 }
6830 w = log(w);
6831 if(b < 8.0e0) goto S60;
6832 dlnbet = w+gamln(&a)+algdiv(&a,&b);
6833 return dlnbet;
6834 S60:
6835 /*
6836 REDUCTION OF B WHEN B .LT. 8
6837 */
6838 n = b-1.0e0;
6839 z = 1.0e0;
6840 for(i=1; i<=n; i++) {
6841 b -= 1.0e0;
6842 z *= (b/(a+b));
6843 }
6844 dlnbet = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b)));
6845 return dlnbet;
6846 S80:
6847 /*
6848 REDUCTION OF A WHEN B .GT. 1000
6849 */
6850 n = a-1.0e0;
6851 w = 1.0e0;
6852 for(i=1; i<=n; i++) {
6853 a -= 1.0e0;
6854 w *= (a/(1.0e0+a/b));
6855 }
6856 dlnbet = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b));
6857 return dlnbet;
6858 S100:
6859 /*
6860 -----------------------------------------------------------------------
6861 PROCEDURE WHEN A .GE. 8
6862 -----------------------------------------------------------------------
6863 */
6864 w = bcorr(&a,&b);
6865 h = a/b;
6866 c = h/(1.0e0+h);
6867 u = -((a-0.5e0)*log(c));
6868 v = b*alnrel(&h);
6869 if(u <= v) goto S110;
6870 dlnbet = -(0.5e0*log(b))+e+w-v-u;
6871 return dlnbet;
6872 S110:
6873 dlnbet = -(0.5e0*log(b))+e+w-u-v;
6874 return dlnbet;
6875 } /* END */
6876
6877 /***=====================================================================***/
dlngam(double * a)6878 static double dlngam(double *a)
6879 /*
6880 **********************************************************************
6881
6882 double dlngam(double *a)
6883 Double precision LN of the GAMma function
6884
6885
6886 Function
6887
6888
6889 Returns the natural logarithm of GAMMA(X).
6890
6891
6892 Arguments
6893
6894
6895 X --> value at which scaled log gamma is to be returned
6896 X is DOUBLE PRECISION
6897
6898
6899 Method
6900
6901
6902 Renames GAMLN from:
6903 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant
6904 Digit Computation of the Incomplete Beta Function Ratios. ACM
6905 Trans. Math. Softw. 18 (1993), 360-373.
6906
6907 **********************************************************************
6908 -----------------------------------------------------------------------
6909 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
6910 -----------------------------------------------------------------------
6911 WRITTEN BY ALFRED H. MORRIS
6912 NAVAL SURFACE WARFARE CENTER
6913 DAHLGREN, VIRGINIA
6914 --------------------------
6915 D = 0.5*(LN(2*PI) - 1)
6916 --------------------------
6917 */
6918 {
6919 static double c0 = .833333333333333e-01;
6920 static double c1 = -.277777777760991e-02;
6921 static double c2 = .793650666825390e-03;
6922 static double c3 = -.595202931351870e-03;
6923 static double c4 = .837308034031215e-03;
6924 static double c5 = -.165322962780713e-02;
6925 static double d = .418938533204673e0;
6926 static double dlngam,t,w;
6927 static int i,n;
6928 static double T1;
6929 /*
6930 ..
6931 .. Executable Statements ..
6932 */
6933 if(*a > 0.8e0) goto S10;
6934 dlngam = gamln1(a)-log(*a);
6935 return dlngam;
6936 S10:
6937 if(*a > 2.25e0) goto S20;
6938 t = *a-0.5e0-0.5e0;
6939 dlngam = gamln1(&t);
6940 return dlngam;
6941 S20:
6942 if(*a >= 10.0e0) goto S40;
6943 n = *a-1.25e0;
6944 t = *a;
6945 w = 1.0e0;
6946 for(i=1; i<=n; i++) {
6947 t -= 1.0e0;
6948 w = t*w;
6949 }
6950 T1 = t-1.0e0;
6951 dlngam = gamln1(&T1)+log(w);
6952 return dlngam;
6953 S40:
6954 t = pow(1.0e0/ *a,2.0);
6955 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
6956 dlngam = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
6957 return dlngam;
6958 } /* END */
6959
6960 /***=====================================================================***/
dstrem(double * z)6961 static double dstrem(double *z)
6962 {
6963 /*
6964 **********************************************************************
6965 double dstrem(double *z)
6966 Double precision Sterling Remainder
6967 Function
6968 Returns Log(Gamma(Z)) - Sterling(Z) where Sterling(Z) is
6969 Sterling's Approximation to Log(Gamma(Z))
6970 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
6971 Arguments
6972 Z --> Value at which Sterling remainder calculated
6973 Must be positive.
6974 DOUBLE PRECISION Z
6975 Method
6976 If Z >= 6 uses 9 terms of series in Bernoulli numbers
6977 (Values calculated using Maple)
6978 Otherwise computes difference explicitly
6979 **********************************************************************
6980 */
6981 #define hln2pi 0.91893853320467274178e0
6982 #define ncoef 10
6983 static double coef[ncoef] = {
6984 0.0e0,0.0833333333333333333333333333333e0,
6985 -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0,
6986 -0.000595238095238095238095238095238e0,
6987 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0,
6988 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0,
6989 0.179644372368830573164938490016e0
6990 };
6991 static int K1 = 10;
6992 static double dstrem,sterl,T2;
6993 /*
6994 ..
6995 .. Executable Statements ..
6996 */
6997 /*
6998 For information, here are the next 11 coefficients of the
6999 remainder term in Sterling's formula
7000 -1.39243221690590111642743221691
7001 13.4028640441683919944789510007
7002 -156.848284626002017306365132452
7003 2193.10333333333333333333333333
7004 -36108.7712537249893571732652192
7005 691472.268851313067108395250776
7006 -0.152382215394074161922833649589D8
7007 0.382900751391414141414141414141D9
7008 -0.108822660357843910890151491655D11
7009 0.347320283765002252252252252252D12
7010 -0.123696021422692744542517103493D14
7011 */
7012 if(*z <= 0.0e0){ ftnstop("nonpositive argument in DSTREM"); return 66.6; }
7013 if(!(*z > 6.0e0)) goto S10;
7014 T2 = 1.0e0/pow(*z,2.0);
7015 dstrem = devlpl(coef,&K1,&T2)**z;
7016 goto S20;
7017 S10:
7018 sterl = hln2pi+(*z-0.5e0)*log(*z)-*z;
7019 dstrem = dlngam(z)-sterl;
7020 S20:
7021 return dstrem;
7022 #undef hln2pi
7023 #undef ncoef
7024 } /* END */
7025
7026 /***=====================================================================***/
dt1(double * p,double * q,double * df)7027 static double dt1(double *p,double *q,double *df)
7028 /*
7029 **********************************************************************
7030
7031 double dt1(double *p,double *q,double *df)
7032 Double precision Initalize Approximation to
7033 INVerse of the cumulative T distribution
7034
7035
7036 Function
7037
7038
7039 Returns the inverse of the T distribution function, i.e.,
7040 the integral from 0 to INVT of the T density is P. This is an
7041 initial approximation
7042
7043
7044 Arguments
7045
7046
7047 P --> The p-value whose inverse from the T distribution is
7048 desired.
7049 P is DOUBLE PRECISION
7050
7051 Q --> 1-P.
7052 Q is DOUBLE PRECISION
7053
7054 DF --> Degrees of freedom of the T distribution.
7055 DF is DOUBLE PRECISION
7056
7057 **********************************************************************
7058 */
7059 {
7060 static double coef[4][5] = {
7061 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0,
7062 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0
7063 };
7064 static double denom[4] = {
7065 4.0e0,96.0e0,384.0e0,92160.0e0
7066 };
7067 static int ideg[4] = {
7068 2,3,4,5
7069 };
7070 static double dt1,denpow,sum,term,x,xp,xx;
7071 static int i;
7072 /*
7073 ..
7074 .. Executable Statements ..
7075 */
7076 x = fabs(dinvnr(p,q));
7077 xx = x*x;
7078 sum = x;
7079 denpow = 1.0e0;
7080 for(i=0; i<4; i++) {
7081 term = devlpl(&coef[i][0],&ideg[i],&xx)*x;
7082 denpow *= *df;
7083 sum += (term/(denpow*denom[i]));
7084 }
7085 if(!(*p >= 0.5e0)) goto S20;
7086 xp = sum;
7087 goto S30;
7088 S20:
7089 xp = -sum;
7090 S30:
7091 dt1 = xp;
7092 return dt1;
7093 } /* END */
7094
7095 /***=====================================================================***/
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)7096 static void E0001(int IENTRY,int *status,double *x,double *fx,
7097 double *xlo,double *xhi,unsigned long *qleft,
7098 unsigned long *qhi,double *zabstl,double *zreltl,
7099 double *zxhi,double *zxlo)
7100 {
7101 #define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx))))
7102 static double a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo;
7103 static int ext,i99999;
7104 static unsigned long first,qrzero;
7105 switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;}
7106 DZROR:
7107 if(*status > 0) goto S280;
7108 *xlo = xxlo;
7109 *xhi = xxhi;
7110 b = *x = *xlo;
7111 /*
7112 GET-FUNCTION-VALUE
7113 */
7114 i99999 = 1;
7115 goto S270;
7116 S10:
7117 fb = *fx;
7118 *xlo = *xhi;
7119 a = *x = *xlo;
7120 /*
7121 GET-FUNCTION-VALUE
7122 */
7123 i99999 = 2;
7124 goto S270;
7125 S20:
7126 /*
7127 Check that F(ZXLO) < 0 < F(ZXHI) or
7128 F(ZXLO) > 0 > F(ZXHI)
7129 */
7130 if(!(fb < 0.0e0)) goto S40;
7131 if(!(*fx < 0.0e0)) goto S30;
7132 *status = -1;
7133 *qleft = *fx < fb;
7134 *qhi = 0;
7135 return;
7136 S40:
7137 S30:
7138 if(!(fb > 0.0e0)) goto S60;
7139 if(!(*fx > 0.0e0)) goto S50;
7140 *status = -1;
7141 *qleft = *fx > fb;
7142 *qhi = 1;
7143 return;
7144 S60:
7145 S50:
7146 fa = *fx;
7147 first = 1;
7148 S70:
7149 c = a;
7150 fc = fa;
7151 ext = 0;
7152 S80:
7153 if(!(fabs(fc) < fabs(fb))) goto S100;
7154 if(!(c != a)) goto S90;
7155 d = a;
7156 fd = fa;
7157 S90:
7158 a = b;
7159 fa = fb;
7160 *xlo = c;
7161 b = *xlo;
7162 fb = fc;
7163 c = a;
7164 fc = fa;
7165 S100:
7166 tol = ftol(*xlo);
7167 m = (c+b)*.5e0;
7168 mb = m-b;
7169 if(!(fabs(mb) > tol)) goto S240;
7170 if(!(ext > 3)) goto S110;
7171 w = mb;
7172 goto S190;
7173 S110:
7174 tol = fifdsign(tol,mb);
7175 p = (b-a)*fb;
7176 if(!first) goto S120;
7177 q = fa-fb;
7178 first = 0;
7179 goto S130;
7180 S120:
7181 fdb = (fd-fb)/(d-b);
7182 fda = (fd-fa)/(d-a);
7183 p = fda*p;
7184 q = fdb*fa-fda*fb;
7185 S130:
7186 if(!(p < 0.0e0)) goto S140;
7187 p = -p;
7188 q = -q;
7189 S140:
7190 if(ext == 3) p *= 2.0e0;
7191 if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150;
7192 w = tol;
7193 goto S180;
7194 S150:
7195 if(!(p < mb*q)) goto S160;
7196 w = p/q;
7197 goto S170;
7198 S160:
7199 w = mb;
7200 S190:
7201 S180:
7202 S170:
7203 d = a;
7204 fd = fa;
7205 a = b;
7206 fa = fb;
7207 b += w;
7208 *xlo = b;
7209 *x = *xlo;
7210 /*
7211 GET-FUNCTION-VALUE
7212 */
7213 i99999 = 3;
7214 goto S270;
7215 S200:
7216 fb = *fx;
7217 if(!(fc*fb >= 0.0e0)) goto S210;
7218 goto S70;
7219 S210:
7220 if(!(w == mb)) goto S220;
7221 ext = 0;
7222 goto S230;
7223 S220:
7224 ext += 1;
7225 S230:
7226 goto S80;
7227 S240:
7228 *xhi = c;
7229 qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0;
7230 if(!qrzero) goto S250;
7231 *status = 0;
7232 goto S260;
7233 S250:
7234 *status = -1;
7235 S260:
7236 return;
7237 DSTZR:
7238 xxlo = *zxlo;
7239 xxhi = *zxhi;
7240 abstol = *zabstl;
7241 reltol = *zreltl;
7242 return;
7243 S270:
7244 /*
7245 TO GET-FUNCTION-VALUE
7246 */
7247 *status = 1;
7248 return;
7249 S280:
7250 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200;
7251 default: break;}
7252 #undef ftol
7253 } /* END */
7254
7255 /***=====================================================================***/
dzror(int * status,double * x,double * fx,double * xlo,double * xhi,unsigned long * qleft,unsigned long * qhi)7256 static void dzror(int *status,double *x,double *fx,double *xlo,
7257 double *xhi,unsigned long *qleft,unsigned long *qhi)
7258 /*
7259 **********************************************************************
7260
7261 void dzror(int *status,double *x,double *fx,double *xlo,
7262 double *xhi,unsigned long *qleft,unsigned long *qhi)
7263
7264 Double precision ZeRo of a function -- Reverse Communication
7265
7266
7267 Function
7268
7269
7270 Performs the zero finding. STZROR must have been called before
7271 this routine in order to set its parameters.
7272
7273
7274 Arguments
7275
7276
7277 STATUS <--> At the beginning of a zero finding problem, STATUS
7278 should be set to 0 and ZROR invoked. (The value
7279 of other parameters will be ignored on this call.)
7280
7281 When ZROR needs the function evaluated, it will set
7282 STATUS to 1 and return. The value of the function
7283 should be set in FX and ZROR again called without
7284 changing any of its other parameters.
7285
7286 When ZROR has finished without error, it will return
7287 with STATUS 0. In that case (XLO,XHI) bound the answe
7288
7289 If ZROR finds an error (which implies that F(XLO)-Y an
7290 F(XHI)-Y have the same sign, it returns STATUS -1. In
7291 this case, XLO and XHI are undefined.
7292 INTEGER STATUS
7293
7294 X <-- The value of X at which F(X) is to be evaluated.
7295 DOUBLE PRECISION X
7296
7297 FX --> The value of F(X) calculated when ZROR returns with
7298 STATUS = 1.
7299 DOUBLE PRECISION FX
7300
7301 XLO <-- When ZROR returns with STATUS = 0, XLO bounds the
7302 inverval in X containing the solution below.
7303 DOUBLE PRECISION XLO
7304
7305 XHI <-- When ZROR returns with STATUS = 0, XHI bounds the
7306 inverval in X containing the solution above.
7307 DOUBLE PRECISION XHI
7308
7309 QLEFT <-- .TRUE. if the stepping search terminated unsucessfully
7310 at XLO. If it is .FALSE. the search terminated
7311 unsucessfully at XHI.
7312 QLEFT is LOGICAL
7313
7314 QHI <-- .TRUE. if F(X) .GT. Y at the termination of the
7315 search and .FALSE. if F(X) .LT. Y at the
7316 termination of the search.
7317 QHI is LOGICAL
7318
7319 **********************************************************************
7320 */
7321 {
7322 E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL);
7323 } /* END */
7324
7325 /***=====================================================================***/
dstzr(double * zxlo,double * zxhi,double * zabstl,double * zreltl)7326 static void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl)
7327 /*
7328 **********************************************************************
7329 void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl)
7330 Double precision SeT ZeRo finder - Reverse communication version
7331 Function
7332 Sets quantities needed by ZROR. The function of ZROR
7333 and the quantities set is given here.
7334 Concise Description - Given a function F
7335 find XLO such that F(XLO) = 0.
7336 More Precise Description -
7337 Input condition. F is a double precision function of a single
7338 double precision argument and XLO and XHI are such that
7339 F(XLO)*F(XHI) .LE. 0.0
7340 If the input condition is met, QRZERO returns .TRUE.
7341 and output values of XLO and XHI satisfy the following
7342 F(XLO)*F(XHI) .LE. 0.
7343 ABS(F(XLO) .LE. ABS(F(XHI)
7344 ABS(XLO-XHI) .LE. TOL(X)
7345 where
7346 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X))
7347 If this algorithm does not find XLO and XHI satisfying
7348 these conditions then QRZERO returns .FALSE. This
7349 implies that the input condition was not met.
7350 Arguments
7351 XLO --> The left endpoint of the interval to be
7352 searched for a solution.
7353 XLO is DOUBLE PRECISION
7354 XHI --> The right endpoint of the interval to be
7355 for a solution.
7356 XHI is DOUBLE PRECISION
7357 ABSTOL, RELTOL --> Two numbers that determine the accuracy
7358 of the solution. See function for a
7359 precise definition.
7360 ABSTOL is DOUBLE PRECISION
7361 RELTOL is DOUBLE PRECISION
7362 Method
7363 Algorithm R of the paper 'Two Efficient Algorithms with
7364 Guaranteed Convergence for Finding a Zero of a Function'
7365 by J. C. P. Bus and T. J. Dekker in ACM Transactions on
7366 Mathematical Software, Volume 1, no. 4 page 330
7367 (Dec. '75) is employed to find the zero of F(X)-Y.
7368 **********************************************************************
7369 */
7370 {
7371 E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo);
7372 } /* END */
7373
7374 /***=====================================================================***/
erf1(double * x)7375 static double erf1(double *x)
7376 /*
7377 -----------------------------------------------------------------------
7378 EVALUATION OF THE REAL ERROR FUNCTION
7379 -----------------------------------------------------------------------
7380 */
7381 {
7382 static double c = .564189583547756e0;
7383 static double a[5] = {
7384 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7385 .479137145607681e-01,.128379167095513e+00
7386 };
7387 static double b[3] = {
7388 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7389 };
7390 static double p[8] = {
7391 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7392 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7393 4.51918953711873e+02,3.00459261020162e+02
7394 };
7395 static double q[8] = {
7396 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7397 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7398 7.90950925327898e+02,3.00459260956983e+02
7399 };
7400 static double r[5] = {
7401 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7402 4.65807828718470e+00,2.82094791773523e-01
7403 };
7404 static double s[4] = {
7405 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7406 1.80124575948747e+01
7407 };
7408 static double erf1,ax,bot,t,top,x2;
7409 /*
7410 ..
7411 .. Executable Statements ..
7412 */
7413 ax = fabs(*x);
7414 if(ax > 0.5e0) goto S10;
7415 t = *x**x;
7416 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7417 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7418 erf1 = *x*(top/bot);
7419 return erf1;
7420 S10:
7421 if(ax > 4.0e0) goto S20;
7422 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7423 7];
7424 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7425 7];
7426 erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot);
7427 if(*x < 0.0e0) erf1 = -erf1;
7428 return erf1;
7429 S20:
7430 if(ax >= 5.8e0) goto S30;
7431 x2 = *x**x;
7432 t = 1.0e0/x2;
7433 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7434 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7435 erf1 = (c-top/(x2*bot))/ax;
7436 erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1);
7437 if(*x < 0.0e0) erf1 = -erf1;
7438 return erf1;
7439 S30:
7440 erf1 = fifdsign(1.0e0,*x);
7441 return erf1;
7442 } /* END */
7443
7444 /***=====================================================================***/
erfc1(int * ind,double * x)7445 static double erfc1(int *ind,double *x)
7446 /*
7447 -----------------------------------------------------------------------
7448 EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION
7449
7450 ERFC1(IND,X) = ERFC(X) IF IND = 0
7451 ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE
7452 -----------------------------------------------------------------------
7453 */
7454 {
7455 static double c = .564189583547756e0;
7456 static double a[5] = {
7457 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01,
7458 .479137145607681e-01,.128379167095513e+00
7459 };
7460 static double b[3] = {
7461 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00
7462 };
7463 static double p[8] = {
7464 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00,
7465 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02,
7466 4.51918953711873e+02,3.00459261020162e+02
7467 };
7468 static double q[8] = {
7469 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01,
7470 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02,
7471 7.90950925327898e+02,3.00459260956983e+02
7472 };
7473 static double r[5] = {
7474 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01,
7475 4.65807828718470e+00,2.82094791773523e-01
7476 };
7477 static double s[4] = {
7478 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01,
7479 1.80124575948747e+01
7480 };
7481 static int K1 = 1;
7482 static double erfc1,ax,bot,e,t,top,w;
7483 /*
7484 ..
7485 .. Executable Statements ..
7486 */
7487 /*
7488 ABS(X) .LE. 0.5
7489 */
7490 ax = fabs(*x);
7491 if(ax > 0.5e0) goto S10;
7492 t = *x**x;
7493 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0;
7494 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0;
7495 erfc1 = 0.5e0+(0.5e0-*x*(top/bot));
7496 if(*ind != 0) erfc1 = exp(t)*erfc1;
7497 return erfc1;
7498 S10:
7499 /*
7500 0.5 .LT. ABS(X) .LE. 4
7501 */
7502 if(ax > 4.0e0) goto S20;
7503 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[
7504 7];
7505 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[
7506 7];
7507 erfc1 = top/bot;
7508 goto S40;
7509 S20:
7510 /*
7511 ABS(X) .GT. 4
7512 */
7513 if(*x <= -5.6e0) goto S60;
7514 if(*ind != 0) goto S30;
7515 if(*x > 100.0e0) goto S70;
7516 if(*x**x > -exparg(&K1)) goto S70;
7517 S30:
7518 t = pow(1.0e0/ *x,2.0);
7519 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4];
7520 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0;
7521 erfc1 = (c-t*top/bot)/ax;
7522 S40:
7523 /*
7524 FINAL ASSEMBLY
7525 */
7526 if(*ind == 0) goto S50;
7527 if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1;
7528 return erfc1;
7529 S50:
7530 w = *x**x;
7531 t = w;
7532 e = w-t;
7533 erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1;
7534 if(*x < 0.0e0) erfc1 = 2.0e0-erfc1;
7535 return erfc1;
7536 S60:
7537 /*
7538 LIMIT VALUE FOR LARGE NEGATIVE X
7539 */
7540 erfc1 = 2.0e0;
7541 if(*ind != 0) erfc1 = 2.0e0*exp(*x**x);
7542 return erfc1;
7543 S70:
7544 /*
7545 LIMIT VALUE FOR LARGE POSITIVE X
7546 WHEN IND = 0
7547 */
7548 erfc1 = 0.0e0;
7549 return erfc1;
7550 } /* END */
7551
7552 /***=====================================================================***/
esum(int * mu,double * x)7553 static double esum(int *mu,double *x)
7554 /*
7555 -----------------------------------------------------------------------
7556 EVALUATION OF EXP(MU + X)
7557 -----------------------------------------------------------------------
7558 */
7559 {
7560 static double esum,w;
7561 /*
7562 ..
7563 .. Executable Statements ..
7564 */
7565 if(*x > 0.0e0) goto S10;
7566 if(*mu < 0) goto S20;
7567 w = (double)*mu+*x;
7568 if(w > 0.0e0) goto S20;
7569 esum = exp(w);
7570 return esum;
7571 S10:
7572 if(*mu > 0) goto S20;
7573 w = (double)*mu+*x;
7574 if(w < 0.0e0) goto S20;
7575 esum = exp(w);
7576 return esum;
7577 S20:
7578 w = *mu;
7579 esum = exp(w)*exp(*x);
7580 return esum;
7581 } /* END */
7582
7583 /***=====================================================================***/
exparg(int * l)7584 static double exparg(int *l)
7585 /*
7586 --------------------------------------------------------------------
7587 IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
7588 EXP(W) CAN BE COMPUTED.
7589
7590 IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR
7591 WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
7592
7593 NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED.
7594 --------------------------------------------------------------------
7595 */
7596 {
7597 static int K1 = 4;
7598 static int K2 = 9;
7599 static int K3 = 10;
7600 static double exparg,lnb;
7601 static int b,m;
7602 /*
7603 ..
7604 .. Executable Statements ..
7605 */
7606 b = ipmpar(&K1);
7607 if(b != 2) goto S10;
7608 lnb = .69314718055995e0;
7609 goto S40;
7610 S10:
7611 if(b != 8) goto S20;
7612 lnb = 2.0794415416798e0;
7613 goto S40;
7614 S20:
7615 if(b != 16) goto S30;
7616 lnb = 2.7725887222398e0;
7617 goto S40;
7618 S30:
7619 lnb = log((double)b);
7620 S40:
7621 if(*l == 0) goto S50;
7622 m = ipmpar(&K2)-1;
7623 exparg = 0.99999e0*((double)m*lnb);
7624 return exparg;
7625 S50:
7626 m = ipmpar(&K3);
7627 exparg = 0.99999e0*((double)m*lnb);
7628 return exparg;
7629 } /* END */
7630
7631 /***=====================================================================***/
fpser(double * a,double * b,double * x,double * eps)7632 static double fpser(double *a,double *b,double *x,double *eps)
7633 /*
7634 -----------------------------------------------------------------------
7635
7636 EVALUATION OF I (A,B)
7637 X
7638
7639 FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5.
7640
7641 -----------------------------------------------------------------------
7642
7643 SET FPSER = X**A
7644 */
7645 {
7646 static int K1 = 1;
7647 static double fpser,an,c,s,t,tol;
7648 /*
7649 ..
7650 .. Executable Statements ..
7651 */
7652 fpser = 1.0e0;
7653 if(*a <= 1.e-3**eps) goto S10;
7654 fpser = 0.0e0;
7655 t = *a*log(*x);
7656 if(t < exparg(&K1)) return fpser;
7657 fpser = exp(t);
7658 S10:
7659 /*
7660 NOTE THAT 1/B(A,B) = B
7661 */
7662 fpser = *b/ *a*fpser;
7663 tol = *eps/ *a;
7664 an = *a+1.0e0;
7665 t = *x;
7666 s = t/an;
7667 S20:
7668 an += 1.0e0;
7669 t = *x*t;
7670 c = t/an;
7671 s += c;
7672 if(fabs(c) > tol) goto S20;
7673 fpser *= (1.0e0+*a*s);
7674 return fpser;
7675 } /* END */
7676
7677 /***=====================================================================***/
gam1(double * a)7678 static double gam1(double *a)
7679 /*
7680 ------------------------------------------------------------------
7681 COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5
7682 ------------------------------------------------------------------
7683 */
7684 {
7685 static double s1 = .273076135303957e+00;
7686 static double s2 = .559398236957378e-01;
7687 static double p[7] = {
7688 .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00,
7689 .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02,
7690 .589597428611429e-03
7691 };
7692 static double q[5] = {
7693 .100000000000000e+01,.427569613095214e+00,.158451672430138e+00,
7694 .261132021441447e-01,.423244297896961e-02
7695 };
7696 static double r[9] = {
7697 -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00,
7698 .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01,
7699 .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03
7700 };
7701 static double gam1,bot,d,t,top,w,T1;
7702 /*
7703 ..
7704 .. Executable Statements ..
7705 */
7706 t = *a;
7707 d = *a-0.5e0;
7708 if(d > 0.0e0) t = d-0.5e0;
7709 T1 = t;
7710 if(T1 < 0) goto S40;
7711 else if(T1 == 0) goto S10;
7712 else goto S20;
7713 S10:
7714 gam1 = 0.0e0;
7715 return gam1;
7716 S20:
7717 top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0];
7718 bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0;
7719 w = top/bot;
7720 if(d > 0.0e0) goto S30;
7721 gam1 = *a*w;
7722 return gam1;
7723 S30:
7724 gam1 = t/ *a*(w-0.5e0-0.5e0);
7725 return gam1;
7726 S40:
7727 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+
7728 r[0];
7729 bot = (s2*t+s1)*t+1.0e0;
7730 w = top/bot;
7731 if(d > 0.0e0) goto S50;
7732 gam1 = *a*(w+0.5e0+0.5e0);
7733 return gam1;
7734 S50:
7735 gam1 = t*w/ *a;
7736 return gam1;
7737 } /* END */
7738
7739 /***=====================================================================***/
gaminv(double * a,double * x,double * x0,double * p,double * q,int * ierr)7740 static void gaminv(double *a,double *x,double *x0,double *p,double *q,
7741 int *ierr)
7742 /*
7743 ----------------------------------------------------------------------
7744 INVERSE INCOMPLETE GAMMA RATIO FUNCTION
7745
7746 GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1.
7747 THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER
7748 ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X
7749 TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE
7750 PARTICULAR COMPUTER ARITHMETIC BEING USED.
7751
7752 ------------
7753
7754 X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0,
7755 AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT
7756 NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN
7757 A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE
7758 IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X.
7759
7760 X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER
7761 DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET
7762 X0 .LE. 0.
7763
7764 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS.
7765 WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING
7766 VALUES ...
7767
7768 IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS
7769 NOT USED.
7770 IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS
7771 WERE PERFORMED.
7772 IERR = -2 (INPUT ERROR) A .LE. 0
7773 IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A
7774 IS TOO LARGE.
7775 IERR = -4 (INPUT ERROR) P + Q .NE. 1
7776 IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST
7777 RECENT VALUE OBTAINED FOR X IS GIVEN.
7778 THIS CANNOT OCCUR IF X0 .LE. 0.
7779 IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X.
7780 THIS MAY OCCUR WHEN X IS APPROXIMATELY 0.
7781 IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE
7782 ROUTINE IS NOT CERTAIN OF ITS ACCURACY.
7783 ITERATION CANNOT BE PERFORMED IN THIS
7784 CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY
7785 WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS
7786 POSITIVE THEN THIS CAN OCCUR WHEN A IS
7787 EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY
7788 LARGE (SAY A .GE. 1.E20).
7789 ----------------------------------------------------------------------
7790 WRITTEN BY ALFRED H. MORRIS, JR.
7791 NAVAL SURFACE WEAPONS CENTER
7792 DAHLGREN, VIRGINIA
7793 -------------------
7794 */
7795 {
7796 static double a0 = 3.31125922108741e0;
7797 static double a1 = 11.6616720288968e0;
7798 static double a2 = 4.28342155967104e0;
7799 static double a3 = .213623493715853e0;
7800 static double b1 = 6.61053765625462e0;
7801 static double b2 = 6.40691597760039e0;
7802 static double b3 = 1.27364489782223e0;
7803 static double b4 = .036117081018842e0;
7804 static double c = .577215664901533e0;
7805 static double ln10 = 2.302585e0;
7806 static double tol = 1.e-5;
7807 static double amin[2] = {
7808 500.0e0,100.0e0
7809 };
7810 static double bmin[2] = {
7811 1.e-28,1.e-13
7812 };
7813 static double dmin[2] = {
7814 1.e-06,1.e-04
7815 };
7816 static double emin[2] = {
7817 2.e-03,6.e-03
7818 };
7819 static double eps0[2] = {
7820 1.e-10,1.e-08
7821 };
7822 static int K1 = 1;
7823 static int K2 = 2;
7824 static int K3 = 3;
7825 static int K8 = 0;
7826 static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn,
7827 r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z;
7828 static int iop;
7829 static double T4,T5,T6,T7,T9;
7830 /*
7831 ..
7832 .. Executable Statements ..
7833 */
7834 /*
7835 ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS.
7836 E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0.
7837 XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE
7838 LARGEST POSITIVE NUMBER.
7839 */
7840 e = spmpar(&K1);
7841 xmin = spmpar(&K2);
7842 xmax = spmpar(&K3);
7843 *x = 0.0e0;
7844 if(*a <= 0.0e0) goto S300;
7845 t = *p+*q-1.e0;
7846 if(fabs(t) > e) goto S320;
7847 *ierr = 0;
7848 if(*p == 0.0e0) return;
7849 if(*q == 0.0e0) goto S270;
7850 if(*a == 1.0e0) goto S280;
7851 e2 = 2.0e0*e;
7852 amax = 0.4e-10/(e*e);
7853 iop = 1;
7854 if(e > 1.e-10) iop = 2;
7855 eps = eps0[iop-1];
7856 xn = *x0;
7857 if(*x0 > 0.0e0) goto S160;
7858 /*
7859 SELECTION OF THE INITIAL APPROXIMATION XN OF X
7860 WHEN A .LT. 1
7861 */
7862 if(*a > 1.0e0) goto S80;
7863 T4 = *a+1.0e0;
7864 g = Xgamm(&T4);
7865 qg = *q*g;
7866 if(qg == 0.0e0) goto S360;
7867 b = qg/ *a;
7868 if(qg > 0.6e0**a) goto S40;
7869 if(*a >= 0.30e0 || b < 0.35e0) goto S10;
7870 t = exp(-(b+c));
7871 u = t*exp(t);
7872 xn = t*exp(u);
7873 goto S160;
7874 S10:
7875 if(b >= 0.45e0) goto S40;
7876 if(b == 0.0e0) goto S360;
7877 y = -log(b);
7878 s = 0.5e0+(0.5e0-*a);
7879 z = log(y);
7880 t = y-s*z;
7881 if(b < 0.15e0) goto S20;
7882 xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0));
7883 goto S220;
7884 S20:
7885 if(b <= 0.01e0) goto S30;
7886 u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0);
7887 xn = y-s*log(t)-log(u);
7888 goto S220;
7889 S30:
7890 c1 = -(s*z);
7891 c2 = -(s*(1.0e0+c1));
7892 c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a));
7893 c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+(
7894 (11.0e0**a-46.0)**a+47.0e0)/6.0e0));
7895 c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)*
7896 *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+((
7897 (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0));
7898 xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y;
7899 if(*a > 1.0e0) goto S220;
7900 if(b > bmin[iop-1]) goto S220;
7901 *x = xn;
7902 return;
7903 S40:
7904 if(b**q > 1.e-8) goto S50;
7905 xn = exp(-(*q/ *a+c));
7906 goto S70;
7907 S50:
7908 if(*p <= 0.9e0) goto S60;
7909 T5 = -*q;
7910 xn = exp((alnrel(&T5)+gamln1(a))/ *a);
7911 goto S70;
7912 S60:
7913 xn = exp(log(*p*g)/ *a);
7914 S70:
7915 if(xn == 0.0e0) goto S310;
7916 t = 0.5e0+(0.5e0-xn/(*a+1.0e0));
7917 xn /= t;
7918 goto S160;
7919 S80:
7920 /*
7921 SELECTION OF THE INITIAL APPROXIMATION XN OF X
7922 WHEN A .GT. 1
7923 */
7924 if(*q <= 0.5e0) goto S90;
7925 w = log(*p);
7926 goto S100;
7927 S90:
7928 w = log(*q);
7929 S100:
7930 t = sqrt(-(2.0e0*w));
7931 s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0);
7932 if(*q > 0.5e0) s = -s;
7933 rta = sqrt(*a);
7934 s2 = s*s;
7935 xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)*
7936 s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a*
7937 rta);
7938 xn = fifdmax1(xn,0.0e0);
7939 if(*a < amin[iop-1]) goto S110;
7940 *x = xn;
7941 d = 0.5e0+(0.5e0-*x/ *a);
7942 if(fabs(d) <= dmin[iop-1]) return;
7943 S110:
7944 if(*p <= 0.5e0) goto S130;
7945 if(xn < 3.0e0**a) goto S220;
7946 y = -(w+gamln(a));
7947 d = fifdmax1(2.0e0,*a*(*a-1.0e0));
7948 if(y < ln10*d) goto S120;
7949 s = 1.0e0-*a;
7950 z = log(y);
7951 goto S30;
7952 S120:
7953 t = *a-1.0e0;
7954 T6 = -(t/(xn+1.0e0));
7955 xn = y+t*log(xn)-alnrel(&T6);
7956 T7 = -(t/(xn+1.0e0));
7957 xn = y+t*log(xn)-alnrel(&T7);
7958 goto S220;
7959 S130:
7960 ap1 = *a+1.0e0;
7961 if(xn > 0.70e0*ap1) goto S170;
7962 w += gamln(&ap1);
7963 if(xn > 0.15e0*ap1) goto S140;
7964 ap2 = *a+2.0e0;
7965 ap3 = *a+3.0e0;
7966 *x = exp((w+*x)/ *a);
7967 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
7968 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a);
7969 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a);
7970 xn = *x;
7971 if(xn > 1.e-2*ap1) goto S140;
7972 if(xn <= emin[iop-1]*ap1) return;
7973 goto S170;
7974 S140:
7975 apn = ap1;
7976 t = xn/apn;
7977 sum = 1.0e0+t;
7978 S150:
7979 apn += 1.0e0;
7980 t *= (xn/apn);
7981 sum += t;
7982 if(t > 1.e-4) goto S150;
7983 t = w-log(sum);
7984 xn = exp((xn+t)/ *a);
7985 xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn));
7986 goto S170;
7987 S160:
7988 /*
7989 SCHRODER ITERATION USING P
7990 */
7991 if(*p > 0.5e0) goto S220;
7992 S170:
7993 if(*p <= 1.e10*xmin) goto S350;
7994 am1 = *a-0.5e0-0.5e0;
7995 S180:
7996 if(*a <= amax) goto S190;
7997 d = 0.5e0+(0.5e0-xn/ *a);
7998 if(fabs(d) <= e2) goto S350;
7999 S190:
8000 if(*ierr >= 20) goto S330;
8001 *ierr += 1;
8002 gratio(a,&xn,&pn,&qn,&K8);
8003 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8004 r = rcomp(a,&xn);
8005 if(r == 0.0e0) goto S350;
8006 t = (pn-*p)/r;
8007 w = 0.5e0*(am1-xn);
8008 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200;
8009 *x = xn*(1.0e0-t);
8010 if(*x <= 0.0e0) goto S340;
8011 d = fabs(t);
8012 goto S210;
8013 S200:
8014 h = t*(1.0e0+w*t);
8015 *x = xn*(1.0e0-h);
8016 if(*x <= 0.0e0) goto S340;
8017 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8018 d = fabs(h);
8019 S210:
8020 xn = *x;
8021 if(d > tol) goto S180;
8022 if(d <= eps) return;
8023 if(fabs(*p-pn) <= tol**p) return;
8024 goto S180;
8025 S220:
8026 /*
8027 SCHRODER ITERATION USING Q
8028 */
8029 if(*q <= 1.e10*xmin) goto S350;
8030 am1 = *a-0.5e0-0.5e0;
8031 S230:
8032 if(*a <= amax) goto S240;
8033 d = 0.5e0+(0.5e0-xn/ *a);
8034 if(fabs(d) <= e2) goto S350;
8035 S240:
8036 if(*ierr >= 20) goto S330;
8037 *ierr += 1;
8038 gratio(a,&xn,&pn,&qn,&K8);
8039 if(pn == 0.0e0 || qn == 0.0e0) goto S350;
8040 r = rcomp(a,&xn);
8041 if(r == 0.0e0) goto S350;
8042 t = (*q-qn)/r;
8043 w = 0.5e0*(am1-xn);
8044 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250;
8045 *x = xn*(1.0e0-t);
8046 if(*x <= 0.0e0) goto S340;
8047 d = fabs(t);
8048 goto S260;
8049 S250:
8050 h = t*(1.0e0+w*t);
8051 *x = xn*(1.0e0-h);
8052 if(*x <= 0.0e0) goto S340;
8053 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return;
8054 d = fabs(h);
8055 S260:
8056 xn = *x;
8057 if(d > tol) goto S230;
8058 if(d <= eps) return;
8059 if(fabs(*q-qn) <= tol**q) return;
8060 goto S230;
8061 S270:
8062 /*
8063 SPECIAL CASES
8064 */
8065 *x = xmax;
8066 return;
8067 S280:
8068 if(*q < 0.9e0) goto S290;
8069 T9 = -*p;
8070 *x = -alnrel(&T9);
8071 return;
8072 S290:
8073 *x = -log(*q);
8074 return;
8075 S300:
8076 /*
8077 ERROR RETURN
8078 */
8079 *ierr = -2;
8080 return;
8081 S310:
8082 *ierr = -3;
8083 return;
8084 S320:
8085 *ierr = -4;
8086 return;
8087 S330:
8088 *ierr = -6;
8089 return;
8090 S340:
8091 *ierr = -7;
8092 return;
8093 S350:
8094 *x = xn;
8095 *ierr = -8;
8096 return;
8097 S360:
8098 *x = xmax;
8099 *ierr = -8;
8100 return;
8101 } /* END */
8102
8103 /***=====================================================================***/
gamln(double * a)8104 static double gamln(double *a)
8105 /*
8106 -----------------------------------------------------------------------
8107 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
8108 -----------------------------------------------------------------------
8109 WRITTEN BY ALFRED H. MORRIS
8110 NAVAL SURFACE WARFARE CENTER
8111 DAHLGREN, VIRGINIA
8112 --------------------------
8113 D = 0.5*(LN(2*PI) - 1)
8114 --------------------------
8115 */
8116 {
8117 static double c0 = .833333333333333e-01;
8118 static double c1 = -.277777777760991e-02;
8119 static double c2 = .793650666825390e-03;
8120 static double c3 = -.595202931351870e-03;
8121 static double c4 = .837308034031215e-03;
8122 static double c5 = -.165322962780713e-02;
8123 static double d = .418938533204673e0;
8124 static double gamln,t,w;
8125 static int i,n;
8126 static double T1;
8127 /*
8128 ..
8129 .. Executable Statements ..
8130 */
8131 if(*a > 0.8e0) goto S10;
8132 gamln = gamln1(a)-log(*a);
8133 return gamln;
8134 S10:
8135 if(*a > 2.25e0) goto S20;
8136 t = *a-0.5e0-0.5e0;
8137 gamln = gamln1(&t);
8138 return gamln;
8139 S20:
8140 if(*a >= 10.0e0) goto S40;
8141 n = *a-1.25e0;
8142 t = *a;
8143 w = 1.0e0;
8144 for(i=1; i<=n; i++) {
8145 t -= 1.0e0;
8146 w = t*w;
8147 }
8148 T1 = t-1.0e0;
8149 gamln = gamln1(&T1)+log(w);
8150 return gamln;
8151 S40:
8152 t = pow(1.0e0/ *a,2.0);
8153 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a;
8154 gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0);
8155 return gamln;
8156 } /* END */
8157
8158 /***=====================================================================***/
gamln1(double * a)8159 static double gamln1(double *a)
8160 /*
8161 -----------------------------------------------------------------------
8162 EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25
8163 -----------------------------------------------------------------------
8164 */
8165 {
8166 static double p0 = .577215664901533e+00;
8167 static double p1 = .844203922187225e+00;
8168 static double p2 = -.168860593646662e+00;
8169 static double p3 = -.780427615533591e+00;
8170 static double p4 = -.402055799310489e+00;
8171 static double p5 = -.673562214325671e-01;
8172 static double p6 = -.271935708322958e-02;
8173 static double q1 = .288743195473681e+01;
8174 static double q2 = .312755088914843e+01;
8175 static double q3 = .156875193295039e+01;
8176 static double q4 = .361951990101499e+00;
8177 static double q5 = .325038868253937e-01;
8178 static double q6 = .667465618796164e-03;
8179 static double r0 = .422784335098467e+00;
8180 static double r1 = .848044614534529e+00;
8181 static double r2 = .565221050691933e+00;
8182 static double r3 = .156513060486551e+00;
8183 static double r4 = .170502484022650e-01;
8184 static double r5 = .497958207639485e-03;
8185 static double s1 = .124313399877507e+01;
8186 static double s2 = .548042109832463e+00;
8187 static double s3 = .101552187439830e+00;
8188 static double s4 = .713309612391000e-02;
8189 static double s5 = .116165475989616e-03;
8190 static double gamln1,w,x;
8191 /*
8192 ..
8193 .. Executable Statements ..
8194 */
8195 if(*a >= 0.6e0) goto S10;
8196 w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+
8197 q4)**a+q3)**a+q2)**a+q1)**a+1.0e0);
8198 gamln1 = -(*a*w);
8199 return gamln1;
8200 S10:
8201 x = *a-0.5e0-0.5e0;
8202 w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x
8203 +1.0e0);
8204 gamln1 = x*w;
8205 return gamln1;
8206 } /* END */
8207
8208 /***=====================================================================***/
Xgamm(double * a)8209 static double Xgamm(double *a)
8210 /*
8211 -----------------------------------------------------------------------
8212
8213 EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS
8214
8215 -----------
8216
8217 GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT
8218 BE COMPUTED.
8219
8220 -----------------------------------------------------------------------
8221 WRITTEN BY ALFRED H. MORRIS, JR.
8222 NAVAL SURFACE WEAPONS CENTER
8223 DAHLGREN, VIRGINIA
8224 -----------------------------------------------------------------------
8225 */
8226 {
8227 static double d = .41893853320467274178e0;
8228 static double pi = 3.1415926535898e0;
8229 static double r1 = .820756370353826e-03;
8230 static double r2 = -.595156336428591e-03;
8231 static double r3 = .793650663183693e-03;
8232 static double r4 = -.277777777770481e-02;
8233 static double r5 = .833333333333333e-01;
8234 static double p[7] = {
8235 .539637273585445e-03,.261939260042690e-02,.204493667594920e-01,
8236 .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0
8237 };
8238 static double q[7] = {
8239 -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01,
8240 -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0
8241 };
8242 static int K2 = 3;
8243 static int K3 = 0;
8244 static double Xgamm,bot,g,lnx,s,t,top,w,x,z;
8245 static int i,j,m,n,T1;
8246 /*
8247 ..
8248 .. Executable Statements ..
8249 */
8250 Xgamm = 0.0e0;
8251 x = *a;
8252 if(fabs(*a) >= 15.0e0) goto S110;
8253 /*
8254 -----------------------------------------------------------------------
8255 EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15
8256 -----------------------------------------------------------------------
8257 */
8258 t = 1.0e0;
8259 m = fifidint(*a)-1;
8260 /*
8261 LET T BE THE PRODUCT OF A-J WHEN A .GE. 2
8262 */
8263 T1 = m;
8264 if(T1 < 0) goto S40;
8265 else if(T1 == 0) goto S30;
8266 else goto S10;
8267 S10:
8268 for(j=1; j<=m; j++) {
8269 x -= 1.0e0;
8270 t = x*t;
8271 }
8272 S30:
8273 x -= 1.0e0;
8274 goto S80;
8275 S40:
8276 /*
8277 LET T BE THE PRODUCT OF A+J WHEN A .LT. 1
8278 */
8279 t = *a;
8280 if(*a > 0.0e0) goto S70;
8281 m = -m-1;
8282 if(m == 0) goto S60;
8283 for(j=1; j<=m; j++) {
8284 x += 1.0e0;
8285 t = x*t;
8286 }
8287 S60:
8288 x += (0.5e0+0.5e0);
8289 t = x*t;
8290 if(t == 0.0e0) return Xgamm;
8291 S70:
8292 /*
8293 THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS
8294 CODE MAY BE OMITTED IF DESIRED.
8295 */
8296 if(fabs(t) >= 1.e-30) goto S80;
8297 if(fabs(t)*spmpar(&K2) <= 1.0001e0) return Xgamm;
8298 Xgamm = 1.0e0/t;
8299 return Xgamm;
8300 S80:
8301 /*
8302 COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1
8303 */
8304 top = p[0];
8305 bot = q[0];
8306 for(i=1; i<7; i++) {
8307 top = p[i]+x*top;
8308 bot = q[i]+x*bot;
8309 }
8310 Xgamm = top/bot;
8311 /*
8312 TERMINATION
8313 */
8314 if(*a < 1.0e0) goto S100;
8315 Xgamm *= t;
8316 return Xgamm;
8317 S100:
8318 Xgamm /= t;
8319 return Xgamm;
8320 S110:
8321 /*
8322 -----------------------------------------------------------------------
8323 EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15
8324 -----------------------------------------------------------------------
8325 */
8326 if(fabs(*a) >= 1.e3) return Xgamm;
8327 if(*a > 0.0e0) goto S120;
8328 x = -*a;
8329 n = x;
8330 t = x-(double)n;
8331 if(t > 0.9e0) t = 1.0e0-t;
8332 s = sin(pi*t)/pi;
8333 if(fifmod(n,2) == 0) s = -s;
8334 if(s == 0.0e0) return Xgamm;
8335 S120:
8336 /*
8337 COMPUTE THE MODIFIED ASYMPTOTIC SUM
8338 */
8339 t = 1.0e0/(x*x);
8340 g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x;
8341 /*
8342 ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X)
8343 BUT LESS ACCURACY WILL NORMALLY BE OBTAINED.
8344 */
8345 lnx = log(x);
8346 /*
8347 FINAL ASSEMBLY
8348 */
8349 z = x;
8350 g = d+g+(z-0.5e0)*(lnx-1.e0);
8351 w = g;
8352 t = g-w;
8353 if(w > 0.99999e0*exparg(&K3)) return Xgamm;
8354 Xgamm = exp(w)*(1.0e0+t);
8355 if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x;
8356 return Xgamm;
8357 } /* END */
8358
8359 /***=====================================================================***/
grat1(double * a,double * x,double * r,double * p,double * q,double * eps)8360 static void grat1(double *a,double *x,double *r,double *p,double *q,
8361 double *eps)
8362 {
8363 static int K2 = 0;
8364 static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3;
8365 /*
8366 ..
8367 .. Executable Statements ..
8368 */
8369 /*
8370 -----------------------------------------------------------------------
8371 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
8372 P(A,X) AND Q(A,X)
8373 IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED.
8374 THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A).
8375 -----------------------------------------------------------------------
8376 */
8377 if(*a**x == 0.0e0) goto S120;
8378 if(*a == 0.5e0) goto S100;
8379 if(*x < 1.1e0) goto S10;
8380 goto S60;
8381 S10:
8382 /*
8383 TAYLOR SERIES FOR P(A,X)/X**A
8384 */
8385 an = 3.0e0;
8386 c = *x;
8387 sum = *x/(*a+3.0e0);
8388 tol = 0.1e0**eps/(*a+1.0e0);
8389 S20:
8390 an += 1.0e0;
8391 c = -(c*(*x/an));
8392 t = c/(*a+an);
8393 sum += t;
8394 if(fabs(t) > tol) goto S20;
8395 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8396 z = *a*log(*x);
8397 h = gam1(a);
8398 g = 1.0e0+h;
8399 if(*x < 0.25e0) goto S30;
8400 if(*a < *x/2.59e0) goto S50;
8401 goto S40;
8402 S30:
8403 if(z > -.13394e0) goto S50;
8404 S40:
8405 w = exp(z);
8406 *p = w*g*(0.5e0+(0.5e0-j));
8407 *q = 0.5e0+(0.5e0-*p);
8408 return;
8409 S50:
8410 l = rexp(&z);
8411 w = 0.5e0+(0.5e0+l);
8412 *q = (w*j-l)*g-h;
8413 if(*q < 0.0e0) goto S90;
8414 *p = 0.5e0+(0.5e0-*q);
8415 return;
8416 S60:
8417 /*
8418 CONTINUED FRACTION EXPANSION
8419 */
8420 a2nm1 = a2n = 1.0e0;
8421 b2nm1 = *x;
8422 b2n = *x+(1.0e0-*a);
8423 c = 1.0e0;
8424 S70:
8425 a2nm1 = *x*a2n+c*a2nm1;
8426 b2nm1 = *x*b2n+c*b2nm1;
8427 am0 = a2nm1/b2nm1;
8428 c += 1.0e0;
8429 cma = c-*a;
8430 a2n = a2nm1+cma*a2n;
8431 b2n = b2nm1+cma*b2n;
8432 an0 = a2n/b2n;
8433 if(fabs(an0-am0) >= *eps*an0) goto S70;
8434 *q = *r*an0;
8435 *p = 0.5e0+(0.5e0-*q);
8436 return;
8437 S80:
8438 /*
8439 SPECIAL CASES
8440 */
8441 *p = 0.0e0;
8442 *q = 1.0e0;
8443 return;
8444 S90:
8445 *p = 1.0e0;
8446 *q = 0.0e0;
8447 return;
8448 S100:
8449 if(*x >= 0.25e0) goto S110;
8450 T1 = sqrt(*x);
8451 *p = erf1(&T1);
8452 *q = 0.5e0+(0.5e0-*p);
8453 return;
8454 S110:
8455 T3 = sqrt(*x);
8456 *q = erfc1(&K2,&T3);
8457 *p = 0.5e0+(0.5e0-*q);
8458 return;
8459 S120:
8460 if(*x <= *a) goto S80;
8461 goto S90;
8462 } /* END */
8463
8464 /***=====================================================================***/
gratio(double * a,double * x,double * ans,double * qans,int * ind)8465 static void gratio(double *a,double *x,double *ans,double *qans,int *ind)
8466 /*
8467 ----------------------------------------------------------------------
8468 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
8469 P(A,X) AND Q(A,X)
8470
8471 ----------
8472
8473 IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X
8474 ARE NOT BOTH 0.
8475
8476 ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE
8477 P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER.
8478 IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS
8479 POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF
8480 IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE
8481 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY
8482 IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT.
8483
8484 ERROR RETURN ...
8485 ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE,
8486 WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT.
8487 P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN
8488 X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE.
8489 ----------------------------------------------------------------------
8490 WRITTEN BY ALFRED H. MORRIS, JR.
8491 NAVAL SURFACE WEAPONS CENTER
8492 DAHLGREN, VIRGINIA
8493 --------------------
8494 */
8495 {
8496 static double alog10 = 2.30258509299405e0;
8497 static double d10 = -.185185185185185e-02;
8498 static double d20 = .413359788359788e-02;
8499 static double d30 = .649434156378601e-03;
8500 static double d40 = -.861888290916712e-03;
8501 static double d50 = -.336798553366358e-03;
8502 static double d60 = .531307936463992e-03;
8503 static double d70 = .344367606892378e-03;
8504 static double rt2pin = .398942280401433e0;
8505 static double rtpi = 1.77245385090552e0;
8506 static double third = .333333333333333e0;
8507 static double acc0[3] = {
8508 5.e-15,5.e-7,5.e-4
8509 };
8510 static double big[3] = {
8511 20.0e0,14.0e0,10.0e0
8512 };
8513 static double d0[13] = {
8514 .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02,
8515 .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04,
8516 -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06,
8517 -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07,
8518 -.438203601845335e-08
8519 };
8520 static double d1[12] = {
8521 -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03,
8522 .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04,
8523 .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08,
8524 .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07
8525 };
8526 static double d2[10] = {
8527 -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05,
8528 -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04,
8529 .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06,
8530 .142806142060642e-06
8531 };
8532 static double d3[8] = {
8533 .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03,
8534 -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04,
8535 -.567495282699160e-05,.142309007324359e-05
8536 };
8537 static double d4[6] = {
8538 .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05,
8539 .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04
8540 };
8541 static double d5[4] = {
8542 -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03,
8543 .679778047793721e-04
8544 };
8545 static double d6[2] = {
8546 -.592166437353694e-03,.270878209671804e-03
8547 };
8548 static double e00[3] = {
8549 .25e-3,.25e-1,.14e0
8550 };
8551 static double x00[3] = {
8552 31.0e0,17.0e0,9.7e0
8553 };
8554 static int K1 = 1;
8555 static int K2 = 0;
8556 static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6,
8557 cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z;
8558 static int i,iop,m,max,n;
8559 static double wk[20],T3;
8560 static int T4,T5;
8561 static double T6,T7;
8562 /*
8563 ..
8564 .. Executable Statements ..
8565 */
8566 /*
8567 --------------------
8568 ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST
8569 FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 .
8570 */
8571 e = spmpar(&K1);
8572 if(*a < 0.0e0 || *x < 0.0e0) goto S430;
8573 if(*a == 0.0e0 && *x == 0.0e0) goto S430;
8574 if(*a**x == 0.0e0) goto S420;
8575 iop = *ind+1;
8576 if(iop != 1 && iop != 2) iop = 3;
8577 acc = fifdmax1(acc0[iop-1],e);
8578 e0 = e00[iop-1];
8579 x0 = x00[iop-1];
8580 /*
8581 SELECT THE APPROPRIATE ALGORITHM
8582 */
8583 if(*a >= 1.0e0) goto S10;
8584 if(*a == 0.5e0) goto S390;
8585 if(*x < 1.1e0) goto S160;
8586 t1 = *a*log(*x)-*x;
8587 u = *a*exp(t1);
8588 if(u == 0.0e0) goto S380;
8589 r = u*(1.0e0+gam1(a));
8590 goto S250;
8591 S10:
8592 if(*a >= big[iop-1]) goto S30;
8593 if(*a > *x || *x >= x0) goto S20;
8594 twoa = *a+*a;
8595 m = fifidint(twoa);
8596 if(twoa != (double)m) goto S20;
8597 i = m/2;
8598 if(*a == (double)i) goto S210;
8599 goto S220;
8600 S20:
8601 t1 = *a*log(*x)-*x;
8602 r = exp(t1)/Xgamm(a);
8603 goto S40;
8604 S30:
8605 l = *x/ *a;
8606 if(l == 0.0e0) goto S370;
8607 s = 0.5e0+(0.5e0-l);
8608 z = rlog(&l);
8609 if(z >= 700.0e0/ *a) goto S410;
8610 y = *a*z;
8611 rta = sqrt(*a);
8612 if(fabs(s) <= e0/rta) goto S330;
8613 if(fabs(s) <= 0.4e0) goto S270;
8614 t = pow(1.0e0/ *a,2.0);
8615 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
8616 t1 -= y;
8617 r = rt2pin*rta*exp(t1);
8618 S40:
8619 if(r == 0.0e0) goto S420;
8620 if(*x <= fifdmax1(*a,alog10)) goto S50;
8621 if(*x < x0) goto S250;
8622 goto S100;
8623 S50:
8624 /*
8625 TAYLOR SERIES FOR P/R
8626 */
8627 apn = *a+1.0e0;
8628 t = *x/apn;
8629 wk[0] = t;
8630 for(n=2; n<=20; n++) {
8631 apn += 1.0e0;
8632 t *= (*x/apn);
8633 if(t <= 1.e-3) goto S70;
8634 wk[n-1] = t;
8635 }
8636 n = 20;
8637 S70:
8638 sum = t;
8639 tol = 0.5e0*acc;
8640 S80:
8641 apn += 1.0e0;
8642 t *= (*x/apn);
8643 sum += t;
8644 if(t > tol) goto S80;
8645 max = n-1;
8646 for(m=1; m<=max; m++) {
8647 n -= 1;
8648 sum += wk[n-1];
8649 }
8650 *ans = r/ *a*(1.0e0+sum);
8651 *qans = 0.5e0+(0.5e0-*ans);
8652 return;
8653 S100:
8654 /*
8655 ASYMPTOTIC EXPANSION
8656 */
8657 amn = *a-1.0e0;
8658 t = amn/ *x;
8659 wk[0] = t;
8660 for(n=2; n<=20; n++) {
8661 amn -= 1.0e0;
8662 t *= (amn/ *x);
8663 if(fabs(t) <= 1.e-3) goto S120;
8664 wk[n-1] = t;
8665 }
8666 n = 20;
8667 S120:
8668 sum = t;
8669 S130:
8670 if(fabs(t) <= acc) goto S140;
8671 amn -= 1.0e0;
8672 t *= (amn/ *x);
8673 sum += t;
8674 goto S130;
8675 S140:
8676 max = n-1;
8677 for(m=1; m<=max; m++) {
8678 n -= 1;
8679 sum += wk[n-1];
8680 }
8681 *qans = r/ *x*(1.0e0+sum);
8682 *ans = 0.5e0+(0.5e0-*qans);
8683 return;
8684 S160:
8685 /*
8686 TAYLOR SERIES FOR P(A,X)/X**A
8687 */
8688 an = 3.0e0;
8689 c = *x;
8690 sum = *x/(*a+3.0e0);
8691 tol = 3.0e0*acc/(*a+1.0e0);
8692 S170:
8693 an += 1.0e0;
8694 c = -(c*(*x/an));
8695 t = c/(*a+an);
8696 sum += t;
8697 if(fabs(t) > tol) goto S170;
8698 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0));
8699 z = *a*log(*x);
8700 h = gam1(a);
8701 g = 1.0e0+h;
8702 if(*x < 0.25e0) goto S180;
8703 if(*a < *x/2.59e0) goto S200;
8704 goto S190;
8705 S180:
8706 if(z > -.13394e0) goto S200;
8707 S190:
8708 w = exp(z);
8709 *ans = w*g*(0.5e0+(0.5e0-j));
8710 *qans = 0.5e0+(0.5e0-*ans);
8711 return;
8712 S200:
8713 l = rexp(&z);
8714 w = 0.5e0+(0.5e0+l);
8715 *qans = (w*j-l)*g-h;
8716 if(*qans < 0.0e0) goto S380;
8717 *ans = 0.5e0+(0.5e0-*qans);
8718 return;
8719 S210:
8720 /*
8721 FINITE SUMS FOR Q WHEN A .GE. 1
8722 AND 2*A IS AN INTEGER
8723 */
8724 sum = exp(-*x);
8725 t = sum;
8726 n = 1;
8727 c = 0.0e0;
8728 goto S230;
8729 S220:
8730 rtx = sqrt(*x);
8731 sum = erfc1(&K2,&rtx);
8732 t = exp(-*x)/(rtpi*rtx);
8733 n = 0;
8734 c = -0.5e0;
8735 S230:
8736 if(n == i) goto S240;
8737 n += 1;
8738 c += 1.0e0;
8739 t = *x*t/c;
8740 sum += t;
8741 goto S230;
8742 S240:
8743 *qans = sum;
8744 *ans = 0.5e0+(0.5e0-*qans);
8745 return;
8746 S250:
8747 /*
8748 CONTINUED FRACTION EXPANSION
8749 */
8750 tol = fifdmax1(5.0e0*e,acc);
8751 a2nm1 = a2n = 1.0e0;
8752 b2nm1 = *x;
8753 b2n = *x+(1.0e0-*a);
8754 c = 1.0e0;
8755 S260:
8756 a2nm1 = *x*a2n+c*a2nm1;
8757 b2nm1 = *x*b2n+c*b2nm1;
8758 am0 = a2nm1/b2nm1;
8759 c += 1.0e0;
8760 cma = c-*a;
8761 a2n = a2nm1+cma*a2n;
8762 b2n = b2nm1+cma*b2n;
8763 an0 = a2n/b2n;
8764 if(fabs(an0-am0) >= tol*an0) goto S260;
8765 *qans = r*an0;
8766 *ans = 0.5e0+(0.5e0-*qans);
8767 return;
8768 S270:
8769 /*
8770 GENERAL TEMME EXPANSION
8771 */
8772 if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430;
8773 c = exp(-y);
8774 T3 = sqrt(y);
8775 w = 0.5e0*erfc1(&K1,&T3);
8776 u = 1.0e0/ *a;
8777 z = sqrt(z+z);
8778 if(l < 1.0e0) z = -z;
8779 T4 = iop-2;
8780 if(T4 < 0) goto S280;
8781 else if(T4 == 0) goto S290;
8782 else goto S300;
8783 S280:
8784 if(fabs(s) <= 1.e-3) goto S340;
8785 c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[
8786 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8787 c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5]
8788 )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8789 c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+
8790 d2[2])*z+d2[1])*z+d2[0])*z+d20;
8791 c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+
8792 d3[0])*z+d30;
8793 c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40;
8794 c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50;
8795 c6 = (d6[1]*z+d6[0])*z+d60;
8796 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8797 goto S310;
8798 S290:
8799 c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third;
8800 c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8801 c2 = d2[0]*z+d20;
8802 t = (c2*u+c1)*u+c0;
8803 goto S310;
8804 S300:
8805 t = ((d0[2]*z+d0[1])*z+d0[0])*z-third;
8806 S310:
8807 if(l < 1.0e0) goto S320;
8808 *qans = c*(w+rt2pin*t/rta);
8809 *ans = 0.5e0+(0.5e0-*qans);
8810 return;
8811 S320:
8812 *ans = c*(w-rt2pin*t/rta);
8813 *qans = 0.5e0+(0.5e0-*ans);
8814 return;
8815 S330:
8816 /*
8817 TEMME EXPANSION FOR L = 1
8818 */
8819 if(*a*e*e > 3.28e-3) goto S430;
8820 c = 0.5e0+(0.5e0-y);
8821 w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c;
8822 u = 1.0e0/ *a;
8823 z = sqrt(z+z);
8824 if(l < 1.0e0) z = -z;
8825 T5 = iop-2;
8826 if(T5 < 0) goto S340;
8827 else if(T5 == 0) goto S350;
8828 else goto S360;
8829 S340:
8830 c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-
8831 third;
8832 c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10;
8833 c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20;
8834 c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30;
8835 c4 = (d4[1]*z+d4[0])*z+d40;
8836 c5 = (d5[1]*z+d5[0])*z+d50;
8837 c6 = d6[0]*z+d60;
8838 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0;
8839 goto S310;
8840 S350:
8841 c0 = (d0[1]*z+d0[0])*z-third;
8842 c1 = d1[0]*z+d10;
8843 t = (d20*u+c1)*u+c0;
8844 goto S310;
8845 S360:
8846 t = d0[0]*z-third;
8847 goto S310;
8848 S370:
8849 /*
8850 SPECIAL CASES
8851 */
8852 *ans = 0.0e0;
8853 *qans = 1.0e0;
8854 return;
8855 S380:
8856 *ans = 1.0e0;
8857 *qans = 0.0e0;
8858 return;
8859 S390:
8860 if(*x >= 0.25e0) goto S400;
8861 T6 = sqrt(*x);
8862 *ans = erf1(&T6);
8863 *qans = 0.5e0+(0.5e0-*ans);
8864 return;
8865 S400:
8866 T7 = sqrt(*x);
8867 *qans = erfc1(&K2,&T7);
8868 *ans = 0.5e0+(0.5e0-*qans);
8869 return;
8870 S410:
8871 if(fabs(s) <= 2.0e0*e) goto S430;
8872 S420:
8873 if(*x <= *a) goto S370;
8874 goto S380;
8875 S430:
8876 /*
8877 ERROR RETURN
8878 */
8879 *ans = 2.0e0;
8880 return;
8881 } /* END */
8882
8883 /***=====================================================================***/
gsumln(double * a,double * b)8884 static double gsumln(double *a,double *b)
8885 /*
8886 -----------------------------------------------------------------------
8887 EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
8888 FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2
8889 -----------------------------------------------------------------------
8890 */
8891 {
8892 static double gsumln,x,T1,T2;
8893 /*
8894 ..
8895 .. Executable Statements ..
8896 */
8897 x = *a+*b-2.e0;
8898 if(x > 0.25e0) goto S10;
8899 T1 = 1.0e0+x;
8900 gsumln = gamln1(&T1);
8901 return gsumln;
8902 S10:
8903 if(x > 1.25e0) goto S20;
8904 gsumln = gamln1(&x)+alnrel(&x);
8905 return gsumln;
8906 S20:
8907 T2 = x-1.0e0;
8908 gsumln = gamln1(&T2)+log(x*(1.0e0+x));
8909 return gsumln;
8910 } /* END */
8911
8912 /***=====================================================================***/
psi(double * xx)8913 static double psi(double *xx)
8914 /*
8915 ---------------------------------------------------------------------
8916
8917 EVALUATION OF THE DIGAMMA FUNCTION
8918
8919 -----------
8920
8921 PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT
8922 BE COMPUTED.
8923
8924 THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV
8925 APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY
8926 CODY, STRECOK AND THACHER.
8927
8928 ---------------------------------------------------------------------
8929 PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK
8930 PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY
8931 A.H. MORRIS (NSWC).
8932 ---------------------------------------------------------------------
8933 */
8934 {
8935 static double dx0 = 1.461632144968362341262659542325721325e0;
8936 static double piov4 = .785398163397448e0;
8937 static double p1[7] = {
8938 .895385022981970e-02,.477762828042627e+01,.142441585084029e+03,
8939 .118645200713425e+04,.363351846806499e+04,.413810161269013e+04,
8940 .130560269827897e+04
8941 };
8942 static double p2[4] = {
8943 -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01,
8944 -.648157123766197e+00
8945 };
8946 static double q1[6] = {
8947 .448452573429826e+02,.520752771467162e+03,.221000799247830e+04,
8948 .364127349079381e+04,.190831076596300e+04,.691091682714533e-05
8949 };
8950 static double q2[4] = {
8951 .322703493791143e+02,.892920700481861e+02,.546117738103215e+02,
8952 .777788548522962e+01
8953 };
8954 static int K1 = 3;
8955 static int K2 = 1;
8956 static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z;
8957 static int i,m,n,nq;
8958 /*
8959 ..
8960 .. Executable Statements ..
8961 */
8962 /*
8963 ---------------------------------------------------------------------
8964 MACHINE DEPENDENT CONSTANTS ...
8965 XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT
8966 WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED
8967 AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE
8968 ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH
8969 PSI MAY BE REPRESENTED AS ALOG(X).
8970 XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X)
8971 MAY BE REPRESENTED BY 1/X.
8972 ---------------------------------------------------------------------
8973 */
8974 xmax1 = ipmpar(&K1);
8975 xmax1 = fifdmin1(xmax1,1.0e0/spmpar(&K2));
8976 xsmall = 1.e-9;
8977 x = *xx;
8978 aug = 0.0e0;
8979 if(x >= 0.5e0) goto S50;
8980 /*
8981 ---------------------------------------------------------------------
8982 X .LT. 0.5, USE REFLECTION FORMULA
8983 PSI(1-X) = PSI(X) + PI * COTAN(PI*X)
8984 ---------------------------------------------------------------------
8985 */
8986 if(fabs(x) > xsmall) goto S10;
8987 if(x == 0.0e0) goto S100;
8988 /*
8989 ---------------------------------------------------------------------
8990 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE
8991 FOR PI*COTAN(PI*X)
8992 ---------------------------------------------------------------------
8993 */
8994 aug = -(1.0e0/x);
8995 goto S40;
8996 S10:
8997 /*
8998 ---------------------------------------------------------------------
8999 REDUCTION OF ARGUMENT FOR COTAN
9000 ---------------------------------------------------------------------
9001 */
9002 w = -x;
9003 sgn = piov4;
9004 if(w > 0.0e0) goto S20;
9005 w = -w;
9006 sgn = -sgn;
9007 S20:
9008 /*
9009 ---------------------------------------------------------------------
9010 MAKE AN ERROR EXIT IF X .LE. -XMAX1
9011 ---------------------------------------------------------------------
9012 */
9013 if(w >= xmax1) goto S100;
9014 nq = fifidint(w);
9015 w -= (double)nq;
9016 nq = fifidint(w*4.0e0);
9017 w = 4.0e0*(w-(double)nq*.25e0);
9018 /*
9019 ---------------------------------------------------------------------
9020 W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X.
9021 ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST
9022 QUADRANT AND DETERMINE SIGN
9023 ---------------------------------------------------------------------
9024 */
9025 n = nq/2;
9026 if(n+n != nq) w = 1.0e0-w;
9027 z = piov4*w;
9028 m = n/2;
9029 if(m+m != n) sgn = -sgn;
9030 /*
9031 ---------------------------------------------------------------------
9032 DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X)
9033 ---------------------------------------------------------------------
9034 */
9035 n = (nq+1)/2;
9036 m = n/2;
9037 m += m;
9038 if(m != n) goto S30;
9039 /*
9040 ---------------------------------------------------------------------
9041 CHECK FOR SINGULARITY
9042 ---------------------------------------------------------------------
9043 */
9044 if(z == 0.0e0) goto S100;
9045 /*
9046 ---------------------------------------------------------------------
9047 USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND
9048 SIN/COS AS A SUBSTITUTE FOR TAN
9049 ---------------------------------------------------------------------
9050 */
9051 aug = sgn*(cos(z)/sin(z)*4.0e0);
9052 goto S40;
9053 S30:
9054 aug = sgn*(sin(z)/cos(z)*4.0e0);
9055 S40:
9056 x = 1.0e0-x;
9057 S50:
9058 if(x > 3.0e0) goto S70;
9059 /*
9060 ---------------------------------------------------------------------
9061 0.5 .LE. X .LE. 3.0
9062 ---------------------------------------------------------------------
9063 */
9064 den = x;
9065 upper = p1[0]*x;
9066 for(i=1; i<=5; i++) {
9067 den = (den+q1[i-1])*x;
9068 upper = (upper+p1[i+1-1])*x;
9069 }
9070 den = (upper+p1[6])/(den+q1[5]);
9071 xmx0 = x-dx0;
9072 psi = den*xmx0+aug;
9073 return psi;
9074 S70:
9075 /*
9076 ---------------------------------------------------------------------
9077 IF X .GE. XMAX1, PSI = LN(X)
9078 ---------------------------------------------------------------------
9079 */
9080 if(x >= xmax1) goto S90;
9081 /*
9082 ---------------------------------------------------------------------
9083 3.0 .LT. X .LT. XMAX1
9084 ---------------------------------------------------------------------
9085 */
9086 w = 1.0e0/(x*x);
9087 den = w;
9088 upper = p2[0]*w;
9089 for(i=1; i<=3; i++) {
9090 den = (den+q2[i-1])*w;
9091 upper = (upper+p2[i+1-1])*w;
9092 }
9093 aug = upper/(den+q2[3])-0.5e0/x+aug;
9094 S90:
9095 psi = aug+log(x);
9096 return psi;
9097 S100:
9098 /*
9099 ---------------------------------------------------------------------
9100 ERROR RETURN
9101 ---------------------------------------------------------------------
9102 */
9103 psi = 0.0e0;
9104 return psi;
9105 } /* END */
9106
9107 /***=====================================================================***/
rcomp(double * a,double * x)9108 static double rcomp(double *a,double *x)
9109 /*
9110 -------------------
9111 EVALUATION OF EXP(-X)*X**A/GAMMA(A)
9112 -------------------
9113 RT2PIN = 1/SQRT(2*PI)
9114 -------------------
9115 */
9116 {
9117 static double rt2pin = .398942280401433e0;
9118 static double rcomp,t,t1,u;
9119 /*
9120 ..
9121 .. Executable Statements ..
9122 */
9123 rcomp = 0.0e0;
9124 if(*a >= 20.0e0) goto S20;
9125 t = *a*log(*x)-*x;
9126 if(*a >= 1.0e0) goto S10;
9127 rcomp = *a*exp(t)*(1.0e0+gam1(a));
9128 return rcomp;
9129 S10:
9130 rcomp = exp(t)/Xgamm(a);
9131 return rcomp;
9132 S20:
9133 u = *x/ *a;
9134 if(u == 0.0e0) return rcomp;
9135 t = pow(1.0e0/ *a,2.0);
9136 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0);
9137 t1 -= (*a*rlog(&u));
9138 rcomp = rt2pin*sqrt(*a)*exp(t1);
9139 return rcomp;
9140 } /* END */
9141
9142 /***=====================================================================***/
rexp(double * x)9143 static double rexp(double *x)
9144 /*
9145 -----------------------------------------------------------------------
9146 EVALUATION OF THE FUNCTION EXP(X) - 1
9147 -----------------------------------------------------------------------
9148 */
9149 {
9150 static double p1 = .914041914819518e-09;
9151 static double p2 = .238082361044469e-01;
9152 static double q1 = -.499999999085958e+00;
9153 static double q2 = .107141568980644e+00;
9154 static double q3 = -.119041179760821e-01;
9155 static double q4 = .595130811860248e-03;
9156 static double rexp,w;
9157 /*
9158 ..
9159 .. Executable Statements ..
9160 */
9161 if(fabs(*x) > 0.15e0) goto S10;
9162 rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0));
9163 return rexp;
9164 S10:
9165 w = exp(*x);
9166 if(*x > 0.0e0) goto S20;
9167 rexp = w-0.5e0-0.5e0;
9168 return rexp;
9169 S20:
9170 rexp = w*(0.5e0+(0.5e0-1.0e0/w));
9171 return rexp;
9172 } /* END */
9173
9174 /***=====================================================================***/
rlog(double * x)9175 static double rlog(double *x)
9176 /*
9177 -------------------
9178 COMPUTATION OF X - 1 - LN(X)
9179 -------------------
9180 */
9181 {
9182 static double a = .566749439387324e-01;
9183 static double b = .456512608815524e-01;
9184 static double p0 = .333333333333333e+00;
9185 static double p1 = -.224696413112536e+00;
9186 static double p2 = .620886815375787e-02;
9187 static double q1 = -.127408923933623e+01;
9188 static double q2 = .354508718369557e+00;
9189 static double rlog,r,t,u,w,w1;
9190 /*
9191 ..
9192 .. Executable Statements ..
9193 */
9194 if(*x < 0.61e0 || *x > 1.57e0) goto S40;
9195 if(*x < 0.82e0) goto S10;
9196 if(*x > 1.18e0) goto S20;
9197 /*
9198 ARGUMENT REDUCTION
9199 */
9200 u = *x-0.5e0-0.5e0;
9201 w1 = 0.0e0;
9202 goto S30;
9203 S10:
9204 u = *x-0.7e0;
9205 u /= 0.7e0;
9206 w1 = a-u*0.3e0;
9207 goto S30;
9208 S20:
9209 u = 0.75e0**x-1.e0;
9210 w1 = b+u/3.0e0;
9211 S30:
9212 /*
9213 SERIES EXPANSION
9214 */
9215 r = u/(u+2.0e0);
9216 t = r*r;
9217 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
9218 rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
9219 return rlog;
9220 S40:
9221 r = *x-0.5e0-0.5e0;
9222 rlog = r-log(*x);
9223 return rlog;
9224 } /* END */
9225
9226 /***=====================================================================***/
rlog1(double * x)9227 static double rlog1(double *x)
9228 /*
9229 -----------------------------------------------------------------------
9230 EVALUATION OF THE FUNCTION X - LN(1 + X)
9231 -----------------------------------------------------------------------
9232 */
9233 {
9234 static double a = .566749439387324e-01;
9235 static double b = .456512608815524e-01;
9236 static double p0 = .333333333333333e+00;
9237 static double p1 = -.224696413112536e+00;
9238 static double p2 = .620886815375787e-02;
9239 static double q1 = -.127408923933623e+01;
9240 static double q2 = .354508718369557e+00;
9241 static double rlog1,h,r,t,w,w1;
9242 /*
9243 ..
9244 .. Executable Statements ..
9245 */
9246 if(*x < -0.39e0 || *x > 0.57e0) goto S40;
9247 if(*x < -0.18e0) goto S10;
9248 if(*x > 0.18e0) goto S20;
9249 /*
9250 ARGUMENT REDUCTION
9251 */
9252 h = *x;
9253 w1 = 0.0e0;
9254 goto S30;
9255 S10:
9256 h = *x+0.3e0;
9257 h /= 0.7e0;
9258 w1 = a-h*0.3e0;
9259 goto S30;
9260 S20:
9261 h = 0.75e0**x-0.25e0;
9262 w1 = b+h/3.0e0;
9263 S30:
9264 /*
9265 SERIES EXPANSION
9266 */
9267 r = h/(h+2.0e0);
9268 t = r*r;
9269 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0);
9270 rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1;
9271 return rlog1;
9272 S40:
9273 w = *x+0.5e0+0.5e0;
9274 rlog1 = *x-log(w);
9275 return rlog1;
9276 } /* END */
9277
9278 /***=====================================================================***/
spmpar(int * i)9279 static double spmpar(int *i)
9280 /*
9281 -----------------------------------------------------------------------
9282
9283 SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR
9284 THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT
9285 I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE
9286 SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND
9287 ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN
9288
9289 SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION,
9290
9291 SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE,
9292
9293 SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE.
9294
9295 -----------------------------------------------------------------------
9296 WRITTEN BY
9297 ALFRED H. MORRIS, JR.
9298 NAVAL SURFACE WARFARE CENTER
9299 DAHLGREN VIRGINIA
9300 -----------------------------------------------------------------------
9301 -----------------------------------------------------------------------
9302 MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE
9303 CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS
9304 MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION
9305 -----------------------------------------------------------------------
9306 */
9307 {
9308 static int K1 = 4;
9309 static int K2 = 8;
9310 static int K3 = 9;
9311 static int K4 = 10;
9312 static double spmpar,b,binv,bm1,one,w,z;
9313 static int emax,emin,ibeta,m;
9314 /*
9315 ..
9316 .. Executable Statements ..
9317 */
9318 if(*i > 1) goto S10;
9319 b = ipmpar(&K1);
9320 m = ipmpar(&K2);
9321 spmpar = pow(b,(double)(1-m));
9322 return spmpar;
9323 S10:
9324 if(*i > 2) goto S20;
9325 b = ipmpar(&K1);
9326 emin = ipmpar(&K3);
9327 one = 1.0;
9328 binv = one/b;
9329 w = pow(b,(double)(emin+2));
9330 spmpar = w*binv*binv*binv;
9331 return spmpar;
9332 S20:
9333 ibeta = ipmpar(&K1);
9334 m = ipmpar(&K2);
9335 emax = ipmpar(&K4);
9336 b = ibeta;
9337 bm1 = ibeta-1;
9338 one = 1.0;
9339 z = pow(b,(double)(m-1));
9340 w = ((z-one)*b+bm1)/(b*z);
9341 z = pow(b,(double)(emax-2));
9342 spmpar = w*z*b*b;
9343 return spmpar;
9344 } /* END */
9345
9346 /***=====================================================================***/
stvaln(double * p)9347 static double stvaln(double *p)
9348 /*
9349 **********************************************************************
9350
9351 double stvaln(double *p)
9352 STarting VALue for Neton-Raphon
9353 calculation of Normal distribution Inverse
9354
9355
9356 Function
9357
9358
9359 Returns X such that CUMNOR(X) = P, i.e., the integral from -
9360 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P
9361
9362
9363 Arguments
9364
9365
9366 P --> The probability whose normal deviate is sought.
9367 P is DOUBLE PRECISION
9368
9369
9370 Method
9371
9372
9373 The rational function on page 95 of Kennedy and Gentle,
9374 Statistical Computing, Marcel Dekker, NY , 1980.
9375
9376 **********************************************************************
9377 */
9378 {
9379 static double xden[5] = {
9380 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0,
9381 0.38560700634e-2
9382 };
9383 static double xnum[5] = {
9384 -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1,
9385 -0.453642210148e-4
9386 };
9387 static int K1 = 5;
9388 static double stvaln,sign,y,z;
9389 /*
9390 ..
9391 .. Executable Statements ..
9392 */
9393 if(!(*p <= 0.5e0)) goto S10;
9394 sign = -1.0e0;
9395 z = *p;
9396 goto S20;
9397 S10:
9398 sign = 1.0e0;
9399 z = 1.0e0-*p;
9400 S20:
9401 y = sqrt(-(2.0e0*log(z)));
9402 stvaln = y+devlpl(xnum,&K1,&y)/devlpl(xden,&K1,&y);
9403 stvaln = sign*stvaln;
9404 return stvaln;
9405 } /* END */
9406
9407 /***=====================================================================***/
fifdint(double a)9408 static double fifdint(double a)
9409 /************************************************************************
9410 FIFDINT:
9411 Truncates a double precision number to an integer and returns the
9412 value in a double.
9413 ************************************************************************/
9414 /* a - number to be truncated */
9415 {
9416 return (double) ((int) a);
9417 } /* END */
9418
9419 /***=====================================================================***/
fifdmax1(double a,double b)9420 static double fifdmax1(double a,double b)
9421 /************************************************************************
9422 FIFDMAX1:
9423 returns the maximum of two numbers a and b
9424 ************************************************************************/
9425 /* a - first number */
9426 /* b - second number */
9427 {
9428 if (a < b) return b;
9429 else return a;
9430 } /* END */
9431
9432 /***=====================================================================***/
fifdmin1(double a,double b)9433 static double fifdmin1(double a,double b)
9434 /************************************************************************
9435 FIFDMIN1:
9436 returns the minimum of two numbers a and b
9437 ************************************************************************/
9438 /* a - first number */
9439 /* b - second number */
9440 {
9441 if (a < b) return a;
9442 else return b;
9443 } /* END */
9444
9445 /***=====================================================================***/
fifdsign(double mag,double sign)9446 static double fifdsign(double mag,double sign)
9447 /************************************************************************
9448 FIFDSIGN:
9449 transfers the sign of the variable "sign" to the variable "mag"
9450 ************************************************************************/
9451 /* mag - magnitude */
9452 /* sign - sign to be transfered */
9453 {
9454 if (mag < 0) mag = -mag;
9455 if (sign < 0) mag = -mag;
9456 return mag;
9457
9458 } /* END */
9459
9460 /***=====================================================================***/
fifidint(double a)9461 static long fifidint(double a)
9462 /************************************************************************
9463 FIFIDINT:
9464 Truncates a double precision number to a long integer
9465 ************************************************************************/
9466 /* a - number to be truncated */
9467 {
9468 if (a < 1.0) return (long) 0;
9469 else return (long) a;
9470 } /* END */
9471
9472 /***=====================================================================***/
fifmod(long a,long b)9473 static long fifmod(long a,long b)
9474 /************************************************************************
9475 FIFMOD:
9476 returns the modulo of a and b
9477 ************************************************************************/
9478 /* a - numerator */
9479 /* b - denominator */
9480 {
9481 return a % b;
9482 } /* END */
9483
9484 /***=====================================================================***/
ftnstop(char * msg)9485 static void ftnstop(char* msg)
9486 /************************************************************************
9487 FTNSTOP:
9488 Prints msg to standard error and then exits
9489 ************************************************************************/
9490 /* msg - error message */
9491 {
9492 if (msg != NULL) fprintf(stderr,"*** CDFLIB ERROR: %s\n",msg);
9493 /** exit(1); **/ /** RWCox - DON'T EXIT */
9494 } /* END */
9495
9496 /***=====================================================================***/
ipmpar(int * i)9497 static int ipmpar(int *i)
9498 /*
9499 -----------------------------------------------------------------------
9500
9501 IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER
9502 THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER
9503 HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ...
9504
9505 INTEGERS.
9506
9507 ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM
9508
9509 SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) )
9510
9511 WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1.
9512
9513 IPMPAR(1) = A, THE BASE.
9514
9515 IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS.
9516
9517 IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE.
9518
9519 FLOATING-POINT NUMBERS.
9520
9521 IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING
9522 POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE
9523 NONZERO NUMBERS ARE REPRESENTED IN THE FORM
9524
9525 SIGN (B**E) * (X(1)/B + ... + X(M)/B**M)
9526
9527 WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M,
9528 X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX.
9529
9530 IPMPAR(4) = B, THE BASE.
9531
9532 SINGLE-PRECISION
9533
9534 IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS.
9535
9536 IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E.
9537
9538 IPMPAR(7) = EMAX, THE LARGEST EXPONENT E.
9539
9540 DOUBLE-PRECISION
9541
9542 IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS.
9543
9544 IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E.
9545
9546 IPMPAR(10) = EMAX, THE LARGEST EXPONENT E.
9547
9548 -----------------------------------------------------------------------
9549
9550 TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED REMOVE
9551 THE COMMENT DELIMITORS FROM THE DEFINITIONS DIRECTLY BELOW THE NAME
9552 OF THE MACHINE
9553
9554 *** RWCox: at this time, the IEEE parameters are enabled.
9555
9556 -----------------------------------------------------------------------
9557
9558 IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY
9559 P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES).
9560 IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE
9561 FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES.
9562
9563 -----------------------------------------------------------------------
9564 .. Scalar Arguments ..
9565 */
9566 {
9567 static int imach[11];
9568 static int outval ;
9569 /* MACHINE CONSTANTS FOR AMDAHL MACHINES. */
9570 /*
9571 imach[1] = 2;
9572 imach[2] = 31;
9573 imach[3] = 2147483647;
9574 imach[4] = 16;
9575 imach[5] = 6;
9576 imach[6] = -64;
9577 imach[7] = 63;
9578 imach[8] = 14;
9579 imach[9] = -64;
9580 imach[10] = 63;
9581 */
9582 /* MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T
9583 PC 7300, AND AT&T 6300. */
9584 /*
9585 imach[1] = 2;
9586 imach[2] = 31;
9587 imach[3] = 2147483647;
9588 imach[4] = 2;
9589 imach[5] = 24;
9590 imach[6] = -125;
9591 imach[7] = 128;
9592 imach[8] = 53;
9593 imach[9] = -1021;
9594 imach[10] = 1024;
9595 */
9596 /* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. */
9597 /*
9598 imach[1] = 2;
9599 imach[2] = 33;
9600 imach[3] = 8589934591;
9601 imach[4] = 2;
9602 imach[5] = 24;
9603 imach[6] = -256;
9604 imach[7] = 255;
9605 imach[8] = 60;
9606 imach[9] = -256;
9607 imach[10] = 255;
9608 */
9609 /* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. */
9610 /*
9611 imach[1] = 2;
9612 imach[2] = 39;
9613 imach[3] = 549755813887;
9614 imach[4] = 8;
9615 imach[5] = 13;
9616 imach[6] = -50;
9617 imach[7] = 76;
9618 imach[8] = 26;
9619 imach[9] = -50;
9620 imach[10] = 76;
9621 */
9622 /* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. */
9623 /*
9624 imach[1] = 2;
9625 imach[2] = 39;
9626 imach[3] = 549755813887;
9627 imach[4] = 8;
9628 imach[5] = 13;
9629 imach[6] = -50;
9630 imach[7] = 76;
9631 imach[8] = 26;
9632 imach[9] = -32754;
9633 imach[10] = 32780;
9634 */
9635 /* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
9636 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT
9637 ARITHMETIC (NOS OPERATING SYSTEM). */
9638 /*
9639 imach[1] = 2;
9640 imach[2] = 48;
9641 imach[3] = 281474976710655;
9642 imach[4] = 2;
9643 imach[5] = 48;
9644 imach[6] = -974;
9645 imach[7] = 1070;
9646 imach[8] = 95;
9647 imach[9] = -926;
9648 imach[10] = 1070;
9649 */
9650 /* MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT
9651 ARITHMETIC (NOS/VE OPERATING SYSTEM). */
9652 /*
9653 imach[1] = 2;
9654 imach[2] = 63;
9655 imach[3] = 9223372036854775807;
9656 imach[4] = 2;
9657 imach[5] = 48;
9658 imach[6] = -4096;
9659 imach[7] = 4095;
9660 imach[8] = 96;
9661 imach[9] = -4096;
9662 imach[10] = 4095;
9663 */
9664 /* MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. */
9665 /*
9666 imach[1] = 2;
9667 imach[2] = 63;
9668 imach[3] = 9223372036854775807;
9669 imach[4] = 2;
9670 imach[5] = 47;
9671 imach[6] = -8189;
9672 imach[7] = 8190;
9673 imach[8] = 94;
9674 imach[9] = -8099;
9675 imach[10] = 8190;
9676 */
9677 /* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. */
9678 /*
9679 imach[1] = 2;
9680 imach[2] = 15;
9681 imach[3] = 32767;
9682 imach[4] = 16;
9683 imach[5] = 6;
9684 imach[6] = -64;
9685 imach[7] = 63;
9686 imach[8] = 14;
9687 imach[9] = -64;
9688 imach[10] = 63;
9689 */
9690 /* MACHINE CONSTANTS FOR THE HARRIS 220. */
9691 /*
9692 imach[1] = 2;
9693 imach[2] = 23;
9694 imach[3] = 8388607;
9695 imach[4] = 2;
9696 imach[5] = 23;
9697 imach[6] = -127;
9698 imach[7] = 127;
9699 imach[8] = 38;
9700 imach[9] = -127;
9701 imach[10] = 127;
9702 */
9703 /* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000
9704 AND DPS 8/70 SERIES. */
9705 /*
9706 imach[1] = 2;
9707 imach[2] = 35;
9708 imach[3] = 34359738367;
9709 imach[4] = 2;
9710 imach[5] = 27;
9711 imach[6] = -127;
9712 imach[7] = 127;
9713 imach[8] = 63;
9714 imach[9] = -127;
9715 imach[10] = 127;
9716 */
9717 /* MACHINE CONSTANTS FOR THE HP 2100
9718 3 WORD DOUBLE PRECISION OPTION WITH FTN4 */
9719 /*
9720 imach[1] = 2;
9721 imach[2] = 15;
9722 imach[3] = 32767;
9723 imach[4] = 2;
9724 imach[5] = 23;
9725 imach[6] = -128;
9726 imach[7] = 127;
9727 imach[8] = 39;
9728 imach[9] = -128;
9729 imach[10] = 127;
9730 */
9731 /* MACHINE CONSTANTS FOR THE HP 2100
9732 4 WORD DOUBLE PRECISION OPTION WITH FTN4 */
9733 /*
9734 imach[1] = 2;
9735 imach[2] = 15;
9736 imach[3] = 32767;
9737 imach[4] = 2;
9738 imach[5] = 23;
9739 imach[6] = -128;
9740 imach[7] = 127;
9741 imach[8] = 55;
9742 imach[9] = -128;
9743 imach[10] = 127;
9744 */
9745 /* MACHINE CONSTANTS FOR THE HP 9000. */
9746 /*
9747 imach[1] = 2;
9748 imach[2] = 31;
9749 imach[3] = 2147483647;
9750 imach[4] = 2;
9751 imach[5] = 24;
9752 imach[6] = -126;
9753 imach[7] = 128;
9754 imach[8] = 53;
9755 imach[9] = -1021;
9756 imach[10] = 1024;
9757 */
9758 /* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
9759 THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA
9760 5/7/9 AND THE SEL SYSTEMS 85/86. */
9761 /*
9762 imach[1] = 2;
9763 imach[2] = 31;
9764 imach[3] = 2147483647;
9765 imach[4] = 16;
9766 imach[5] = 6;
9767 imach[6] = -64;
9768 imach[7] = 63;
9769 imach[8] = 14;
9770 imach[9] = -64;
9771 imach[10] = 63;
9772 */
9773 /* MACHINE CONSTANTS FOR THE IBM PC. */
9774 /*
9775 imach[1] = 2;
9776 imach[2] = 31;
9777 imach[3] = 2147483647;
9778 imach[4] = 2;
9779 imach[5] = 24;
9780 imach[6] = -125;
9781 imach[7] = 128;
9782 imach[8] = 53;
9783 imach[9] = -1021;
9784 imach[10] = 1024;
9785 */
9786 /* MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT
9787 MACFORTRAN II. */
9788 /*
9789 imach[1] = 2;
9790 imach[2] = 31;
9791 imach[3] = 2147483647;
9792 imach[4] = 2;
9793 imach[5] = 24;
9794 imach[6] = -125;
9795 imach[7] = 128;
9796 imach[8] = 53;
9797 imach[9] = -1021;
9798 imach[10] = 1024;
9799 */
9800 /* MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN. */
9801 /*
9802 imach[1] = 2;
9803 imach[2] = 31;
9804 imach[3] = 2147483647;
9805 imach[4] = 2;
9806 imach[5] = 24;
9807 imach[6] = -127;
9808 imach[7] = 127;
9809 imach[8] = 56;
9810 imach[9] = -127;
9811 imach[10] = 127;
9812 */
9813 /* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). */
9814 /*
9815 imach[1] = 2;
9816 imach[2] = 35;
9817 imach[3] = 34359738367;
9818 imach[4] = 2;
9819 imach[5] = 27;
9820 imach[6] = -128;
9821 imach[7] = 127;
9822 imach[8] = 54;
9823 imach[9] = -101;
9824 imach[10] = 127;
9825 */
9826 /* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). */
9827 /*
9828 imach[1] = 2;
9829 imach[2] = 35;
9830 imach[3] = 34359738367;
9831 imach[4] = 2;
9832 imach[5] = 27;
9833 imach[6] = -128;
9834 imach[7] = 127;
9835 imach[8] = 62;
9836 imach[9] = -128;
9837 imach[10] = 127;
9838 */
9839 /* MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING
9840 32-BIT INTEGER ARITHMETIC. */
9841 /*
9842 imach[1] = 2;
9843 imach[2] = 31;
9844 imach[3] = 2147483647;
9845 imach[4] = 2;
9846 imach[5] = 24;
9847 imach[6] = -127;
9848 imach[7] = 127;
9849 imach[8] = 56;
9850 imach[9] = -127;
9851 imach[10] = 127;
9852 */
9853 /* MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. */
9854 /*
9855 imach[1] = 2;
9856 imach[2] = 31;
9857 imach[3] = 2147483647;
9858 imach[4] = 2;
9859 imach[5] = 24;
9860 imach[6] = -125;
9861 imach[7] = 128;
9862 imach[8] = 53;
9863 imach[9] = -1021;
9864 imach[10] = 1024;
9865 */
9866 /* MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D
9867 SERIES (MIPS R3000 PROCESSOR). */
9868 /*
9869 imach[1] = 2;
9870 imach[2] = 31;
9871 imach[3] = 2147483647;
9872 imach[4] = 2;
9873 imach[5] = 24;
9874 imach[6] = -125;
9875 imach[7] = 128;
9876 imach[8] = 53;
9877 imach[9] = -1021;
9878 imach[10] = 1024;
9879 */
9880 /* MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
9881 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
9882 PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). */
9883
9884 imach[1] = 2;
9885 imach[2] = 31;
9886 imach[3] = 2147483647;
9887 imach[4] = 2;
9888 imach[5] = 24;
9889 imach[6] = -125;
9890 imach[7] = 128;
9891 imach[8] = 53;
9892 imach[9] = -1021;
9893 imach[10] = 1024;
9894
9895 /* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. */
9896 /*
9897 imach[1] = 2;
9898 imach[2] = 35;
9899 imach[3] = 34359738367;
9900 imach[4] = 2;
9901 imach[5] = 27;
9902 imach[6] = -128;
9903 imach[7] = 127;
9904 imach[8] = 60;
9905 imach[9] = -1024;
9906 imach[10] = 1023;
9907 */
9908 /* MACHINE CONSTANTS FOR THE VAX 11/780. */
9909 /*
9910 imach[1] = 2;
9911 imach[2] = 31;
9912 imach[3] = 2147483647;
9913 imach[4] = 2;
9914 imach[5] = 24;
9915 imach[6] = -127;
9916 imach[7] = 127;
9917 imach[8] = 56;
9918 imach[9] = -127;
9919 imach[10] = 127;
9920 */
9921 outval = imach[*i];
9922 return outval ;
9923 }
9924
9925 /*************************************************************************/
9926 /*************************************************************************/
9927 /************************ End of cdflib inclusion ************************/
9928 /*************************************************************************/
9929 /*************************************************************************/
9930
9931 /*-----------------------------------------------------------------------*/
9932 typedef struct { double p,q ; } pqpair ; /* for returning p=cdf q=1-cdf */
9933 /*-----------------------------------------------------------------------*/
9934 #undef BIGG
9935 #define BIGG 9.99e+37 /* a really big number (duh) */
9936 /*-----------------------------------------------------------------------*/
9937
9938 /*************************************************************************/
9939 /******** Internal functions for various statistical computations ********/
9940 /*************************************************************************/
9941
9942 /*---------------------------------------------------------------
9943 F statistic
9944 -----------------------------------------------------------------*/
9945
fstat_pq2s(pqpair pq,double dofnum,double dofden)9946 static double fstat_pq2s( pqpair pq , double dofnum , double dofden )
9947 {
9948 int which , status ;
9949 double p , q , f , dfn , dfd , bound ;
9950
9951 which = 2 ;
9952 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
9953 q = pq.q ; if( q <= 0.0 ) return BIGG ;
9954 f = 0.0 ;
9955 dfn = dofnum ;
9956 dfd = dofden ;
9957
9958 cdff( &which , &p , &q , &f , &dfn , &dfd , &status , &bound ) ;
9959 return f ;
9960 }
9961
9962 /*------------------------------*/
9963
fstat_s2pq(double ff,double dofnum,double dofden)9964 static pqpair fstat_s2pq( double ff , double dofnum , double dofden )
9965 {
9966 int which , status ;
9967 double p , q , f , dfn , dfd , bound ;
9968 pqpair pq={0.0,1.0} ;
9969
9970 which = 1 ;
9971 p = 0.0 ;
9972 q = 1.0 ;
9973 f = ff ; if( f <= 0.0 ) return pq;
9974 dfn = dofnum ; if( dfn <= 0.0 ) return pq ;
9975 dfd = dofden ; if( dfd <= 0.0 ) return pq ;
9976
9977 cdff( &which , &p , &q , &f , &dfn , &dfd , &status , &bound ) ;
9978 pq.p = p ; pq.q = q ; return pq ;
9979 }
9980
9981 /*---------------------------------------------------------------
9982 noncentral F statistic
9983 -----------------------------------------------------------------*/
9984
fnonc_pq2s(pqpair pq,double dofnum,double dofden,double nonc)9985 static double fnonc_pq2s( pqpair pq , double dofnum , double dofden , double nonc )
9986 {
9987 int which , status ;
9988 double p , q , f , dfn , dfd , bound , pnonc ;
9989
9990 which = 2 ;
9991 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
9992 q = pq.q ; if( q <= 0.0 ) return BIGG ;
9993 f = 0.0 ;
9994 dfn = dofnum ;
9995 dfd = dofden ;
9996 pnonc = nonc ;
9997
9998 cdffnc( &which , &p , &q , &f , &dfn , &dfd , &pnonc , &status , &bound ) ;
9999 return f ;
10000 }
10001
10002 /*------------------------------*/
10003
fnonc_s2pq(double ff,double dofnum,double dofden,double nonc)10004 static pqpair fnonc_s2pq( double ff , double dofnum , double dofden , double nonc )
10005 {
10006 int which , status ;
10007 double p , q , f , dfn , dfd , bound , pnonc ;
10008 pqpair pq={0.0,1.0} ;
10009
10010 which = 1 ;
10011 p = 0.0 ;
10012 q = 1.0 ;
10013 f = ff ; if( f <= 0.0 ) return pq ;
10014 dfn = dofnum ; if( dfn <= 0.0 ) return pq ;
10015 dfd = dofden ; if( dfd <= 0.0 ) return pq ;
10016 pnonc = nonc ; if( pnonc < 0.0 ) return pq ;
10017
10018 cdffnc( &which , &p , &q , &f , &dfn , &dfd , &pnonc , &status , &bound ) ;
10019 pq.p = p ; pq.q = q ; return pq ;
10020 }
10021
10022 /*---------------------------------------------------------------
10023 Standard Normal distribution
10024 -----------------------------------------------------------------*/
10025
normal_s2pq(double zz)10026 static pqpair normal_s2pq( double zz )
10027 {
10028 double p , q , x=zz ;
10029 pqpair pq ;
10030
10031 cumnor( &x, &p, &q ) ;
10032 pq.p = p ; pq.q = q ; return pq ;
10033 }
10034
10035 /*------------------------------*/
10036
normal_pq2s(pqpair pq)10037 static double normal_pq2s( pqpair pq )
10038 {
10039 double p=pq.p , q=pq.q ;
10040
10041 if( p <= 0.0 ) return -BIGG ;
10042 if( q <= 0.0 ) return BIGG ;
10043 return dinvnr( &p,&q ) ;
10044 }
10045
10046 /*----------------------------------------------------------------
10047 Chi-square
10048 ------------------------------------------------------------------*/
10049
chisq_s2pq(double xx,double dof)10050 static pqpair chisq_s2pq( double xx , double dof )
10051 {
10052 int which , status ;
10053 double p,q,x,df,bound ;
10054 pqpair pq={0.0,1.0} ;
10055
10056 which = 1 ;
10057 p = 0.0 ;
10058 q = 1.0 ;
10059 x = xx ; if( x <= 0.0 ) return pq ;
10060 df = dof ; if( dof <= 0.0 ) return pq ;
10061
10062 cdfchi( &which , &p , &q , &x , &df , &status , &bound ) ;
10063 pq.p = p ; pq.q = q ; return pq ;
10064 }
10065
10066 /*------------------------------*/
10067
chisq_pq2s(pqpair pq,double dof)10068 static double chisq_pq2s( pqpair pq , double dof )
10069 {
10070 int which , status ;
10071 double p,q,x,df,bound ;
10072
10073 which = 2 ;
10074 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
10075 q = pq.q ; if( q <= 0.0 ) return BIGG ;
10076 x = 0.0 ;
10077 df = dof ;
10078
10079 cdfchi( &which , &p , &q , &x , &df , &status , &bound ) ;
10080 return x ;
10081 }
10082
10083 /*----------------------------------------------------------------
10084 noncentral Chi-square
10085 ------------------------------------------------------------------*/
10086
chsqnonc_s2pq(double xx,double dof,double nonc)10087 static pqpair chsqnonc_s2pq( double xx , double dof , double nonc )
10088 {
10089 int which , status ;
10090 double p,q,x,df,bound , pnonc ;
10091 pqpair pq={0.0,1.0} ;
10092
10093 which = 1 ;
10094 p = 0.0 ;
10095 q = 1.0 ;
10096 x = xx ; if( x <= 0.0 ) return pq ;
10097 df = dof ; if( df <= 0.0 ) return pq ;
10098 pnonc = nonc ; if( pnonc < 0.0 ) return pq ;
10099
10100 cdfchn( &which , &p , &q , &x , &df , &pnonc , &status , &bound ) ;
10101 pq.p = p ; pq.q = q ; return pq ;
10102 }
10103
10104 /*------------------------------*/
10105
chsqnonc_pq2s(pqpair pq,double dof,double nonc)10106 static double chsqnonc_pq2s( pqpair pq , double dof , double nonc )
10107 {
10108 int which , status ;
10109 double p,q,x,df,bound , pnonc ;
10110
10111 which = 2 ;
10112 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
10113 q = pq.q ; if( q <= 0.0 ) return BIGG ;
10114 x = 0.0 ;
10115 df = dof ;
10116 pnonc = nonc ;
10117
10118 cdfchn( &which , &p , &q , &x , &df , &pnonc , &status , &bound ) ;
10119 return x ;
10120 }
10121
10122 /*----------------------------------------------------------------
10123 Beta distribution
10124 ------------------------------------------------------------------*/
10125
beta_s2pq(double xx,double aa,double bb)10126 static pqpair beta_s2pq( double xx , double aa , double bb )
10127 {
10128 int which , status ;
10129 double p,q,x,y,a,b,bound ;
10130 pqpair pq={0.0,1.0} ;
10131
10132 which = 1 ;
10133 p = 0.0 ;
10134 q = 1.0 ;
10135 x = xx ; if( x <= 0.0 ) return pq ;
10136 y = 1.0 - xx ; if( y <= 0.0 ){ pq.p=1.0; pq.q=0.0; return pq; }
10137 a = aa ; if( a < 0.0 ) return pq ;
10138 b = bb ; if( b < 0.0 ) return pq ;
10139
10140 cdfbet( &which , &p , &q , &x , &y , &a , &b , &status , &bound ) ;
10141 pq.p = p ; pq.q = q ; return pq ;
10142 }
10143
10144 /*------------------------------*/
10145
beta_pq2s(pqpair pq,double aa,double bb)10146 static double beta_pq2s( pqpair pq , double aa , double bb )
10147 {
10148 int which , status ;
10149 double p,q,x,y,a,b,bound ;
10150
10151 which = 2 ;
10152 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
10153 q = pq.q ; if( q <= 0.0 ) return 1.0 ;
10154 x = 0.0 ;
10155 y = 1.0 ;
10156 a = aa ;
10157 b = bb ;
10158
10159 cdfbet( &which , &p , &q , &x , &y , &a , &b , &status , &bound ) ;
10160 return x ;
10161 }
10162
10163 /*----------------------------------------------------------------
10164 Binomial distribution
10165 (that is, the probability that more than ss out of ntrial
10166 trials were successful).
10167 ------------------------------------------------------------------*/
10168
binomial_s2pq(double ss,double ntrial,double ptrial)10169 static pqpair binomial_s2pq( double ss , double ntrial , double ptrial )
10170 {
10171 int which , status ;
10172 double p,q, s,xn,pr,ompr,bound ;
10173 pqpair pq={0.0,1.0} ;
10174
10175 which = 1 ;
10176 p = 0.0 ;
10177 q = 1.0 ;
10178 s = ss ; if( s < 0.0 ) return pq ;
10179 xn = ntrial ; if( xn <= 0.0 ) return pq ;
10180 pr = ptrial ; if( pr < 0.0 ) return pq ;
10181 ompr = 1.0 - ptrial ;
10182
10183 cdfbin( &which , &p , &q , &s , &xn , &pr , &ompr , &status , &bound ) ;
10184 pq.p = p ; pq.q = q ; return pq ;
10185 }
10186
10187 /*------------------------------*/
10188
binomial_pq2s(pqpair pq,double ntrial,double ptrial)10189 static double binomial_pq2s( pqpair pq , double ntrial , double ptrial )
10190 {
10191 int which , status ;
10192 double p,q, s,xn,pr,ompr,bound ;
10193
10194 which = 2 ;
10195 p = pq.p ;
10196 q = pq.q ;
10197 s = 0.0 ;
10198 xn = ntrial ;
10199 pr = ptrial ;
10200 ompr = 1.0 - ptrial ;
10201
10202 cdfbin( &which , &p , &q , &s , &xn , &pr , &ompr , &status , &bound ) ;
10203 return s ;
10204 }
10205
10206 /*----------------------------------------------------------------
10207 Gamma distribution.
10208 ------------------------------------------------------------------*/
10209
gamma_s2pq(double xx,double sh,double sc)10210 static pqpair gamma_s2pq( double xx , double sh , double sc )
10211 {
10212 int which , status ;
10213 double p,q, x,shape,scale,bound ;
10214 pqpair pq={0.0,1.0} ;
10215
10216 which = 1 ;
10217 p = 0.0 ;
10218 q = 1.0 ;
10219 x = xx ; if( x <= 0.0 ) return pq ;
10220 shape = sh ; if( shape <= 0.0 ) return pq ;
10221 scale = sc ; if( scale <= 0.0 ) return pq ;
10222
10223 cdfgam( &which , &p , &q , &x , &shape , &scale , &status , &bound ) ;
10224 pq.p = p ; pq.q = q ; return pq ;
10225 }
10226
10227 /*------------------------------*/
10228
gamma_pq2s(pqpair pq,double sh,double sc)10229 static double gamma_pq2s( pqpair pq , double sh , double sc )
10230 {
10231 int which , status ;
10232 double p,q, x,shape,scale,bound ;
10233
10234 which = 2 ;
10235 p = pq.p ; if( p <= 0.0 ) return 0.0 ;
10236 q = pq.q ; if( q <= 0.0 ) return BIGG ;
10237 x = 0.0 ;
10238 shape = sh ;
10239 scale = sc ;
10240
10241 cdfgam( &which , &p , &q , &x , &shape , &scale , &status , &bound ) ;
10242 return x ;
10243 }
10244
10245 /*----------------------------------------------------------------
10246 Poisson distribution
10247 ------------------------------------------------------------------*/
10248
poisson_s2pq(double xx,double lambda)10249 static pqpair poisson_s2pq( double xx , double lambda )
10250 {
10251 int which , status ;
10252 double p,q, s,xlam,bound ;
10253 pqpair pq={0.0,1.0} ;
10254
10255 which = 1 ;
10256 p = 0.0 ;
10257 q = 1.0 ;
10258 s = xx ; if( s < 0.0 ) return pq ;
10259 xlam = lambda ; if( xlam < 0.0 ) return pq ;
10260
10261 cdfpoi( &which , &p , &q , &s , &xlam , &status , &bound ) ;
10262 pq.p = p ; pq.q = q ; return pq ;
10263 }
10264
10265 /*------------------------------*/
10266
poisson_pq2s(pqpair pq,double lambda)10267 static double poisson_pq2s( pqpair pq , double lambda )
10268 {
10269 int which , status ;
10270 double p,q, s,xlam,bound ;
10271
10272 which = 2 ;
10273 p = pq.p ;
10274 q = pq.q ;
10275 s = 0.0 ;
10276 xlam = lambda ;
10277
10278 cdfpoi( &which , &p , &q , &s , &xlam , &status , &bound ) ;
10279 return s ;
10280 }
10281
10282 /*----------------------------------------------------------------
10283 T distribution.
10284 ------------------------------------------------------------------*/
10285
student_s2pq(double xx,double dof)10286 static pqpair student_s2pq( double xx , double dof )
10287 {
10288 int which , status ;
10289 double p,q, s,xlam,bound ;
10290 pqpair pq={0.0,1.0} ;
10291
10292 which = 1 ;
10293 p = 0.0 ;
10294 q = 1.0 ;
10295 s = xx ;
10296 xlam = dof ; if( xlam <= 0.0 ) return pq ;
10297
10298 cdft( &which , &p , &q , &s , &xlam , &status , &bound ) ;
10299 pq.p = p ; pq.q = q ; return pq ;
10300 }
10301
10302 /*------------------------------*/
10303
student_pq2s(pqpair pq,double dof)10304 double student_pq2s( pqpair pq , double dof )
10305 {
10306 int which , status ;
10307 double p,q, s,xlam,bound ;
10308
10309 which = 2 ;
10310 p = pq.p ;
10311 q = pq.q ;
10312 s = 0.0 ;
10313 xlam = dof ;
10314
10315 cdft( &which , &p , &q , &s , &xlam , &status , &bound ) ;
10316 return s ;
10317 }
10318
10319 /****************************************************************************/
10320 /* For the distributions below here, cdflib can't do what we want directly. */
10321 /****************************************************************************/
10322
10323 /*----------------------------------------------------------------
10324 Null correlation distribution.
10325 Let x = (rr+1)/2; then x is Beta(dof/2,dof/2).
10326 ------------------------------------------------------------------*/
10327
correl_s2pq(double rr,double dof)10328 static pqpair correl_s2pq( double rr , double dof ) /* fake it with cdflib */
10329 {
10330 return beta_s2pq( 0.5*(rr+1.0) , 0.5*dof , 0.5*dof ) ;
10331 }
10332
10333 /*------------------------------*/
10334
correl_pq2s(pqpair pq,double dof)10335 static double correl_pq2s( pqpair pq , double dof )
10336 {
10337 double xx = beta_pq2s( pq , 0.5*dof , 0.5*dof ) ;
10338 return (2.0*xx-1.0) ;
10339 }
10340
10341 /*----------------------------------------------------------------
10342 Uniform U(0,1) distribution.
10343 ------------------------------------------------------------------*/
10344
uniform_s2pq(double xx)10345 static pqpair uniform_s2pq( double xx ) /* this isn't too hard */
10346 {
10347 pqpair pq ;
10348 if( xx <= 0.0 ) pq.p = 0.0 ;
10349 else if( xx >= 1.0 ) pq.p = 1.0 ;
10350 else pq.p = xx ;
10351 pq.q = 1.0-xx ; return pq ;
10352 }
10353
10354 /*------------------------------*/
10355
uniform_pq2s(pqpair pq)10356 static double uniform_pq2s( pqpair pq )
10357 {
10358 return pq.p ; /* that was easy */
10359 }
10360
10361 /*----------------------------------------------------------------
10362 standard Logistic distribution.
10363 ------------------------------------------------------------------*/
10364
logistic_s2pq(double xx)10365 static pqpair logistic_s2pq( double xx ) /* this isn't hard, either */
10366 {
10367 pqpair pq ;
10368 if( xx >= 0.0 ){ pq.q = 1.0/(1.0+exp( xx)); pq.p = 1.0-pq.q; }
10369 else { pq.p = 1.0/(1.0+exp(-xx)); pq.q = 1.0-pq.p; }
10370 return pq ;
10371 }
10372
10373 /*------------------------------*/
10374
logistic_pq2s(pqpair pq)10375 static double logistic_pq2s( pqpair pq )
10376 {
10377 if( pq.p <= 0.0 ) return -BIGG ;
10378 else if( pq.q <= 0.0 ) return BIGG ;
10379
10380 if( pq.p < pq.q ) return -log(1.0/pq.p-1.0) ;
10381 else return log(1.0/pq.q-1.0) ;
10382 }
10383
10384 /*----------------------------------------------------------------
10385 standard Laplace distribution.
10386 ------------------------------------------------------------------*/
10387
laplace_s2pq(double xx)10388 static pqpair laplace_s2pq( double xx ) /* easy */
10389 {
10390 pqpair pq ;
10391
10392 if( xx >= 0.0 ){ pq.q = 0.5*exp(-xx) ; pq.p = 1.0-pq.q ; }
10393 else { pq.p = 0.5*exp( xx) ; pq.q = 1.0-pq.p ; }
10394 return pq ;
10395 }
10396
10397 /*------------------------------*/
10398
laplace_pq2s(pqpair pq)10399 static double laplace_pq2s( pqpair pq )
10400 {
10401 if( pq.p <= 0.0 ) return -BIGG ;
10402 else if( pq.q <= 0.0 ) return BIGG ;
10403
10404 if( pq.p < pq.q ) return log(2.0*pq.p) ;
10405 else return -log(2.0*pq.q) ;
10406 }
10407
10408 /*----------------------------------------------------------------
10409 noncentral T distribution = hard calculation
10410 ------------------------------------------------------------------*/
10411
10412 /****************************************************************************
10413 Noncentral t distribution function by
10414 Professor K. Krishnamoorthy
10415 Department of Mathematics
10416 University of Louisiana at Lafayette
10417 Manually translated from Fortran by RWC.
10418 *****************************************************************************/
10419
10420 #if 0
10421 static double alng( double x ) /* log(Gamma(x)) from K */
10422 {
10423 int indx ;
10424 double xx,fterm,sum,valg ;
10425 double b[9] = { 0.0 ,
10426 8.33333333333333e-2, 3.33333333333333e-2,
10427 2.52380952380952e-1, 5.25606469002695e-1,
10428 1.01152306812684e0, 1.51747364915329e0,
10429 2.26948897420496e0, 3.00991738325940e0 } ;
10430
10431 if( x < 8.0 ){ xx = x + 8.0 ; indx = 1 ; }
10432 else { xx = x ; indx = 0 ; }
10433
10434 fterm = (xx-0.5)*log(xx) - xx + 9.1893853320467e-1 ;
10435 sum = b[1]/(xx+b[2]/(xx+b[3]/(xx+b[4]/(xx+b[5]/(xx+b[6]/
10436 (xx+b[7]/(xx+b[8]))))))) ;
10437 valg = sum + fterm ;
10438 if(indx)
10439 valg = valg-log(x+7.0)-log(x+6.0)-log(x+5.0)
10440 -log(x+4.0)-log(x+3.0)-log(x+2.0)-log(x+1.0)-log(x) ;
10441 return valg ;
10442 }
10443 #else
alng(double x)10444 static double alng( double x ) /*-- replace with cdflib function --*/
10445 {
10446 double xx=x ; return alngam( &xx ) ;
10447 }
10448 #endif
10449
10450 /*---------------------------------------------------------------------------*/
10451
10452 #if 0
10453 static double gaudf( double x ) /* N(0,1) cdf from K */
10454 {
10455 static double p0=913.16744211475570 , p1=1024.60809538333800,
10456 p2=580.109897562908800, p3=202.102090717023000,
10457 p4=46.0649519338751400, p5=6.81311678753268400,
10458 p6=6.047379926867041e-1,p7=2.493381293151434e-2 ;
10459 static double q0=1826.33488422951125, q1=3506.420597749092,
10460 q2=3044.77121163622200, q3=1566.104625828454,
10461 q4=523.596091947383490, q5=116.9795245776655,
10462 q6=17.1406995062577800, q7=1.515843318555982,
10463 q8=6.25e-2 ;
10464 static double sqr2pi=2.506628274631001 ;
10465 int check ;
10466 double reslt,z , first,phi ;
10467
10468 if(x > 0.0){ z = x ; check = 1 ; }
10469 else { z =-x ; check = 0 ; }
10470
10471 if( z > 32.0 ) return (x > 0.0) ? 1.0 : 0.0 ;
10472
10473 first = exp(-0.5*z*z) ;
10474 phi = first/sqr2pi ;
10475
10476 if (z < 7.0)
10477 reslt = first* (((((((p7*z+p6)*z+p5)*z+p4)*z+p3)*z+p2)*z+p1)*z+p0)
10478 /((((((((q8*z+q7)*z+q6)*z+q5)*z+q4)*z+q3)*z+q2)*z+q1)*z+q0);
10479 else
10480 reslt = phi/(z+1.0/(z+2.0/(z+3.0/(z+4.0/(z+6.0/(z+7.0)))))) ;
10481
10482 if(check) reslt = 1.0 - reslt ;
10483 return reslt ;
10484 }
10485 #else
gaudf(double x)10486 static double gaudf( double x ) /*-- replace with cdflib func --*/
10487 {
10488 double xx=x , p,q ;
10489 cumnor( &xx, &p, &q ); return p;
10490 }
10491 #endif
10492
10493 /*---------------------------------------------------------------------------*/
10494
10495 #if 0
10496 static double betadf( double x , double p , double q ) /* Beta cdf from K */
10497 {
10498 int check , ns ;
10499 double result,betf,psq,xx,cx,pp,qq ;
10500 double term,ai,rx,temp ;
10501
10502 if( x >= 1.0 ) return 1.0 ;
10503 if( x <= 0.0 ) return 0.0 ;
10504
10505 betf = alng(p)+alng(q)-alng(p+q) ;
10506 result=x ;
10507 psq=p+q ;
10508 cx=1.0-x ;
10509 if(p < psq*x){ xx=cx ; cx=x ; pp=q ; qq=p ; check=1 ; }
10510 else { xx=x ; pp=p ; qq=q ; check=0 ; }
10511
10512 term=1.0 ;
10513 ai=1.0 ;
10514 result=1.0 ;
10515 ns=(int)(qq+cx*psq) ;
10516 rx=xx/cx ;
10517 L3:
10518 temp=qq-ai ;
10519 if(ns == 0) rx=xx ;
10520 L4:
10521 term=term*temp*rx/(pp+ai) ;
10522 result=result+term ;
10523 temp=fabs(term) ;
10524 if(temp <= 1.e-14 && temp <= 1.e-14*result) goto L5 ;
10525 ai=ai+1.0 ;
10526 ns=ns-1 ;
10527 if(ns >= 0) goto L3 ;
10528 temp=psq ;
10529 psq=psq+1.0 ;
10530 goto L4 ;
10531
10532 L5:
10533 result=result*exp(pp*log(xx)+(qq-1.0)*log(cx)-betf)/pp ;
10534 if(check) result=1.0-result ;
10535 return result ;
10536 }
10537 #else
betadf(double x,double p,double q)10538 static double betadf( double x , double p , double q ) /*-- cdflib func --*/
10539 {
10540 double xx=x,yy=1.0-x , aa=p,bb=q , pp,qq ;
10541 cumbet( &xx,&yy , &aa,&bb , &pp,&qq ) ; return pp ;
10542 }
10543 #endif
10544
10545 /*---------------------------------------------------------------------------*/
10546 /* Krishnamoorthy's function for cdf of noncentral t, for df > 0,
10547 translated into C by RW Cox [Mar 2004].
10548 Note the original fails for delta=0, so we call the cdflib func for this.
10549 A couple of other minor fixes are also included.
10550 -----------------------------------------------------------------------------*/
10551
tnonc_s2pq(double t,double df,double delta)10552 static pqpair tnonc_s2pq( double t , double df , double delta )
10553 {
10554 int indx , k , i ;
10555 double x,del,tnd,ans,y,dels,a,b,c ;
10556 double pkf,pkb,qkf,qkb , pgamf,pgamb,qgamf,qgamb ;
10557 double pbetaf,pbetab,qbetaf,qbetab ;
10558 double ptermf,qtermf,ptermb,qtermb,term ;
10559 double rempois,delosq2,sum,cons,error ;
10560
10561 pqpair pq={0.0,1.0} ; /* will be return value */
10562 double ab1 ;
10563
10564 /*-- stupid user? --*/
10565
10566 if( df <= 0.0 ) return pq ;
10567
10568 /*-- non-centrality = 0? --*/
10569
10570 if( fabs(delta) < 1.e-8 ) return student_s2pq(t,df) ;
10571
10572 /*-- start K's code here --*/
10573
10574 if( t < 0.0 ){ x = -t ; del = -delta ; indx = 1 ; } /* x will be */
10575 else { x = t ; del = delta ; indx = 0 ; } /* positive */
10576
10577 ans = gaudf(-del) ; /* prob that x <= 0 = Normal cdf */
10578
10579 /*-- the nearly trivial case of x=0 --*/
10580
10581 if( x == 0.0 ){ pq.p = ans; pq.q = 1.0-ans; return pq; }
10582
10583 if( df == 1.0 ) df = 1.0000001 ; /** df=1 is BAD **/
10584
10585 y = x*x/(df+x*x) ; /* between 0 and 1 */
10586 dels = 0.5*del*del ; /* will be positive */
10587 k = (int)dels ; /* 0, 1, 2, ... */
10588 a = k+0.5 ; /* might be as small as 0.5 */
10589 c = k+1.0 ;
10590 b = 0.5*df ; /* might be as small as 0.0 */
10591
10592 pkf = exp(-dels+k*log(dels)-alng(k+1.0)) ;
10593 pkb = pkf ;
10594 qkf = exp(-dels+k*log(dels)-alng(k+1.0+0.5)) ;
10595 qkb = qkf ;
10596
10597 pbetaf = betadf(y, a, b) ;
10598 pbetab = pbetaf ;
10599 qbetaf = betadf(y, c, b) ;
10600 qbetab = qbetaf ;
10601
10602 ab1 = a+b-1.0 ; /* might be as small as -0.5 */
10603
10604 /*-- RWCox: if a+b-1 < 0, log(Gamma(a+b-1)) won't work;
10605 instead, use Gamma(a+b-1)=Gamma(a+b)/(a+b-1) --*/
10606
10607 if( ab1 > 0.0 )
10608 pgamf = exp(alng(ab1)-alng(a)-alng(b)+(a-1.0)*log(y)+b*log(1.0-y)) ;
10609 else
10610 pgamf = exp(alng(a+b)-alng(a)-alng(b)+(a-1.0)*log(y)+b*log(1.0-y))/ab1 ;
10611
10612 pgamb = pgamf*y*(ab1)/a ;
10613
10614 /*-- we can't have c+b-1 < 0, so the above patchup isn't needed --*/
10615
10616 qgamf = exp(alng(c+b-1.0)-alng(c)-alng(b)+(c-1.0)*log(y) + b*log(1.0-y)) ;
10617 qgamb = qgamf*y*(c+b-1.0)/c ;
10618
10619 rempois = 1.0 - pkf ;
10620 delosq2 = del/1.4142135623731 ;
10621 sum = pkf*pbetaf+delosq2*qkf*qbetaf ;
10622 cons = 0.5*(1.0 + 0.5*fabs(delta)) ;
10623 i = 0 ;
10624 L1:
10625 i = i + 1 ;
10626 pgamf = pgamf*y*(a+b+i-2.0)/(a+i-1.0) ;
10627 pbetaf = pbetaf - pgamf ;
10628 pkf = pkf*dels/(k+i) ;
10629 ptermf = pkf*pbetaf ;
10630 qgamf = qgamf*y*(c+b+i-2.0)/(c+i-1.0) ;
10631 qbetaf = qbetaf - qgamf ;
10632 qkf = qkf*dels/(k+i-1.0+1.5) ;
10633 qtermf = qkf*qbetaf ;
10634 term = ptermf + delosq2*qtermf ;
10635 sum = sum + term ;
10636 error = rempois*cons*pbetaf ;
10637 rempois = rempois - pkf ;
10638
10639 if( i > k ){
10640 if( error <= 1.e-12 || i >= 9999 ) goto L2 ;
10641 goto L1 ;
10642 } else {
10643 pgamb = pgamb*(a-i+1.0)/(y*(a+b-i)) ;
10644 pbetab = pbetab + pgamb ;
10645 pkb = (k-i+1.0)*pkb/dels ;
10646 ptermb = pkb*pbetab ;
10647 qgamb = qgamb*(c-i+1.0)/(y*(c+b-i)) ;
10648 qbetab = qbetab + qgamb ;
10649 qkb = (k-i+1.0+0.5)*qkb/dels ;
10650 qtermb = qkb*qbetab ;
10651 term = ptermb + delosq2*qtermb ;
10652 sum = sum + term ;
10653 rempois = rempois - pkb ;
10654 if (rempois <= 1.e-12 || i >= 9999) goto L2 ;
10655 goto L1 ;
10656 }
10657 L2:
10658 tnd = 0.5*sum + ans ;
10659
10660 /*-- return a pqpair, not just the cdf --*/
10661
10662 if( indx ){ pq.p = 1.0-tnd; pq.q = tnd ; }
10663 else { pq.p = tnd ; pq.q = 1.0-tnd; }
10664 return pq ;
10665 }
10666
10667 /*------------------------------*/
10668 /* Inverse to above function;
10669 uses cdflib dstinv()/dinvr()
10670 to solve the equation.
10671 --------------------------------*/
10672
tnonc_pq2s(pqpair pq,double dof,double nonc)10673 static double tnonc_pq2s( pqpair pq , double dof , double nonc )
10674 {
10675 double t ; /* will be result */
10676 double tbot,ttop , dt ;
10677 double T6=1.e-50,T7=1.e-8 ;
10678 double K4=0.5,K5=5.0 ;
10679 double fx ;
10680 unsigned long qhi,qleft ;
10681 int status , qporq , ite ;
10682 pqpair tpq ;
10683
10684 if( dof <= 0.0 ) return BIGG ; /* bad user */
10685 if( pq.p <= 0.0 ) return -BIGG ;
10686 if( pq.q <= 0.0 ) return BIGG ;
10687
10688 t = student_pq2s(pq,dof) ; /* initial guess */
10689
10690 if( fabs(nonc) < 1.e-8 ) return t ;
10691
10692 t += 0.5*nonc ; /* adjust up or down */
10693
10694 dt = 0.1 * fabs(t) ; if( dt < 1.0 ) dt = 1.0 ; /* stepsize */
10695
10696 /* scan down for lower bound, below which cdf is < p */
10697
10698 tbot = t ;
10699 for( ite=0 ; ite < 1000 ; ite++ ){
10700 tpq = tnonc_s2pq( tbot , dof , nonc ) ;
10701 if( tpq.p <= pq.p ) break ;
10702 tbot -= dt ;
10703 }
10704 if( ite >= 1000 ) return -BIGG ;
10705
10706 /* scan up for upper bound, above which cdf is > p */
10707
10708 ttop = tbot+0.5*dt ;
10709 for( ite=0 ; ite < 1000 ; ite++ ){
10710 tpq = tnonc_s2pq( ttop , dof , nonc ) ;
10711 if( tpq.p >= pq.p ) break ;
10712 ttop += dt ;
10713 }
10714 if( ite >= 1000 ) return BIGG ;
10715
10716 t = 0.5*(tbot+ttop) ; /* initial guess in middle */
10717
10718 /* initialize searching parameters */
10719
10720 dstinv(&tbot,&ttop,&K4,&K4,&K5,&T6,&T7);
10721
10722 status = 0 ; qporq = (pq.p <= pq.q) ;
10723
10724 while(1){
10725
10726 dinvr(&status,&t,&fx,&qleft,&qhi) ;
10727
10728 if( status != 1 ) return t ; /* done! */
10729
10730 tpq = tnonc_s2pq( t , dof , nonc ) ; /* get cdf */
10731
10732 /* goal of dinvr is to drive fx to zero */
10733
10734 fx = (qporq) ? pq.p-tpq.p : pq.q-tpq.q ;
10735 }
10736
10737 return BIGG ; /* unreachable */
10738 }
10739
10740 /*----------------------------------------------------------------
10741 Chi distribution (sqrt of chi-squared, duh).
10742 ------------------------------------------------------------------*/
10743
chi_s2pq(double xx,double dof)10744 static pqpair chi_s2pq( double xx , double dof )
10745 {
10746 pqpair pq={0.0,1.0} ;
10747
10748 if( xx <= 0.0 || dof <= 0.0 ) return pq ;
10749 return chisq_s2pq( xx*xx , dof ) ;
10750 }
10751
10752 /*------------------------------*/
10753
chi_pq2s(pqpair pq,double dof)10754 static double chi_pq2s( pqpair pq , double dof )
10755 {
10756 if( pq.p <= 0.0 ) return 0.0 ;
10757 if( pq.q <= 0.0 ) return BIGG ;
10758 return sqrt(chisq_pq2s(pq,dof)) ;
10759 }
10760
10761 /*----------------------------------------------------------------
10762 Extreme value type I: cdf(x) = exp(-exp(-x)).
10763 ------------------------------------------------------------------*/
10764
extval1_s2pq(double x)10765 static pqpair extval1_s2pq( double x )
10766 {
10767 double p,q,y ; pqpair pq ;
10768
10769 if( x > -5.0 ){ y = exp(-x) ; p = exp(-y) ; }
10770 else { y = 1.0 ; p = 0.0 ; }
10771
10772 if( y >= 1.e-4 ) q = 1.0-p ;
10773 else q = y*(1.0+y*(-0.5+y*(1.0/6.0-y/24.0))) ;
10774 pq.p = p ; pq.q = q ; return pq ;
10775 }
10776
10777 /*------------------------------*/
10778
extval1_pq2s(pqpair pq)10779 static double extval1_pq2s( pqpair pq )
10780 {
10781 if( pq.p <= 0.0 ) return -BIGG ;
10782 else if( pq.p >= 1.0 ) return BIGG ;
10783 return -log(-log(pq.p)) ;
10784 }
10785
10786 /*----------------------------------------------------------------
10787 Weibull distribution: cdf(x) = 1 - exp( -x^c ) for x>0 and c>0.
10788 ------------------------------------------------------------------*/
10789
weibull_s2pq(double x,double c)10790 static pqpair weibull_s2pq( double x , double c )
10791 {
10792 double y ;
10793 pqpair pq={0.0,1.0} ;
10794
10795 if( x <= 0.0 || c <= 0.0 ) return pq ;
10796
10797 y = pow(x,c) ; pq.q = exp(-y) ;
10798 if( y >= 1.e-4 ) pq.p = 1.0-pq.q ;
10799 else pq.p = y*(1.0+y*(-0.5+y*(1.0/6.0-y/24.0))) ;
10800 return pq ;
10801 }
10802
10803 /*------------------------------*/
10804
weibull_pq2s(pqpair pq,double c)10805 static double weibull_pq2s( pqpair pq , double c )
10806 {
10807 if( pq.p <= 0.0 || c <= 0.0 ) return 0.0 ;
10808 else if( pq.q <= 0.0 ) return BIGG ;
10809 return pow( -log(pq.q) , 1.0/c ) ;
10810 }
10811
10812 /*----------------------------------------------------------------
10813 Inverse Gaussian:
10814 density proportional to exp(-0.5*c(x+1/x))/x^1.5 (x,c >0).
10815 ------------------------------------------------------------------*/
10816
invgauss_s2pq(double x,double c)10817 static pqpair invgauss_s2pq( double x, double c )
10818 {
10819 double y , p1,q1 , p2,q2 , v ;
10820 pqpair pq={0.0,1.0} ;
10821
10822 if( x <= 0.0 || c <= 0.0 ) return pq ;
10823
10824 y = sqrt(c/x) ;
10825 v = y*(x-1.0) ; cumnor( &v , &p1,&q1 ) ;
10826 v = -y*(x+1.0) ; cumnor( &v , &p2,&q2 ) ;
10827 pq.p = p1 ;
10828 if( p2 > 0.0 ) pq.p += exp(2.0*c+log(p2)) ;
10829 pq.q = 1.0-pq.p ; return pq ;
10830 }
10831
10832 /*------------------------------*/
10833 /* Inverse to above function;
10834 uses cdflib dstinv()/dinvr()
10835 to solve the equation.
10836 --------------------------------*/
10837
invgauss_pq2s(pqpair pq,double c)10838 static double invgauss_pq2s( pqpair pq , double c )
10839 {
10840 double t ; /* will be result */
10841 double tbot,ttop , dt ;
10842 double T6=1.e-50,T7=1.e-8 ;
10843 double K4=0.5,K5=5.0 ;
10844 double fx ;
10845 unsigned long qhi,qleft ;
10846 int status , qporq , ite ;
10847 pqpair tpq ;
10848
10849 if( c <= 0.0 ) return BIGG ; /* bad user */
10850 if( pq.p <= 0.0 ) return 0.0 ;
10851 if( pq.q <= 0.0 ) return BIGG ;
10852
10853 /* initial guess is t=1; scan down for lower bound */
10854
10855 tbot = 1.01 ; dt = 0.9 ;
10856 for( ite=0 ; ite < 1000 ; ite++ ){
10857 tpq = invgauss_s2pq( tbot , c ) ;
10858 if( tpq.p <= pq.p ) break ;
10859 tbot *= dt ;
10860 }
10861 if( ite >= 1000 ) return 0.0 ;
10862
10863 /* scan up for upper bound */
10864
10865 dt = 1.1 ; ttop = tbot*dt ;
10866 for( ite=0 ; ite < 1000 ; ite++ ){
10867 tpq = invgauss_s2pq( ttop , c ) ;
10868 if( tpq.p >= pq.p ) break ;
10869 ttop *= dt ;
10870 }
10871 if( ite >= 1000 ) return BIGG ;
10872
10873 t = sqrt(tbot*ttop) ; /* start at geometric mean */
10874
10875 /* initialize searching parameters */
10876
10877 dstinv(&tbot,&ttop,&K4,&K4,&K5,&T6,&T7);
10878
10879 status = 0 ; qporq = (pq.p <= pq.q) ;
10880
10881 while(1){
10882
10883 dinvr(&status,&t,&fx,&qleft,&qhi) ;
10884
10885 if( status != 1 ) return t ; /* done! */
10886
10887 tpq = invgauss_s2pq( t , c ) ;
10888
10889 /* goal is to drive fx to zero */
10890
10891 fx = (qporq) ? pq.p-tpq.p : pq.q-tpq.q ;
10892 }
10893
10894 return BIGG ; /* unreachable */
10895 }
10896
10897 /*--------------------------------------------------------------------------*/
10898 /*! Given a value, calculate both its cdf and reversed cdf (1.0-cdf).
10899 If an error occurs, you'll probably get back {0.0,1.0}.
10900 All the actual work is done in utility functions for each distribution.
10901 ----------------------------------------------------------------------------*/
10902
stat2pq(double val,int code,double p1,double p2,double p3)10903 static pqpair stat2pq( double val, int code, double p1,double p2,double p3 )
10904 {
10905 pqpair pq={0.0,1.0} ;
10906
10907 switch( code ){
10908
10909 case NIFTI_INTENT_CORREL: pq = correl_s2pq ( val, p1 ) ; break;
10910 case NIFTI_INTENT_TTEST: pq = student_s2pq ( val, p1 ) ; break;
10911 case NIFTI_INTENT_FTEST: pq = fstat_s2pq ( val, p1,p2 ) ; break;
10912 case NIFTI_INTENT_ZSCORE: pq = normal_s2pq ( val ) ; break;
10913 case NIFTI_INTENT_CHISQ: pq = chisq_s2pq ( val, p1 ) ; break;
10914 case NIFTI_INTENT_BETA: pq = beta_s2pq ( val, p1,p2 ) ; break;
10915 case NIFTI_INTENT_BINOM: pq = binomial_s2pq( val, p1,p2 ) ; break;
10916 case NIFTI_INTENT_GAMMA: pq = gamma_s2pq ( val, p1,p2 ) ; break;
10917 case NIFTI_INTENT_POISSON: pq = poisson_s2pq ( val, p1 ) ; break;
10918 case NIFTI_INTENT_FTEST_NONC: pq = fnonc_s2pq ( val, p1,p2,p3 ); break;
10919 case NIFTI_INTENT_CHISQ_NONC: pq = chsqnonc_s2pq( val, p1,p2 ); break;
10920 case NIFTI_INTENT_TTEST_NONC: pq = tnonc_s2pq ( val, p1,p2 ) ; break;
10921 case NIFTI_INTENT_CHI: pq = chi_s2pq ( val, p1 ) ; break;
10922
10923 /* these distributions are shifted and scaled copies of a standard case */
10924
10925 case NIFTI_INTENT_INVGAUSS:
10926 if( p1 > 0.0 && p2 > 0.0 ) pq = invgauss_s2pq( val/p1,p2/p1 ) ; break;
10927
10928 case NIFTI_INTENT_WEIBULL:
10929 if( p2 > 0.0 && p3 > 0.0 ) pq = weibull_s2pq ((val-p1)/p2,p3) ; break;
10930
10931 case NIFTI_INTENT_EXTVAL:
10932 if( p2 > 0.0 ) pq = extval1_s2pq ( (val-p1)/p2 ) ; break;
10933
10934 case NIFTI_INTENT_NORMAL:
10935 if( p2 > 0.0 ) pq = normal_s2pq ( (val-p1)/p2 ) ; break;
10936
10937 case NIFTI_INTENT_LOGISTIC:
10938 if( p2 > 0.0 ) pq = logistic_s2pq( (val-p1)/p2 ) ; break;
10939
10940 case NIFTI_INTENT_LAPLACE:
10941 if( p2 > 0.0 ) pq = laplace_s2pq ( (val-p1)/p2 ) ; break;
10942
10943 case NIFTI_INTENT_UNIFORM:
10944 if( p2 > p1 ) pq = uniform_s2pq((val-p1)/(p2-p1)); break;
10945
10946 /* this case is trivial */
10947
10948 case NIFTI_INTENT_PVAL: pq.p = 1.0-val ; pq.q = val ; break;
10949 }
10950
10951 return pq ;
10952 }
10953
10954 /*--------------------------------------------------------------------------*/
10955 /*! Given a pq value (cdf and 1-cdf), compute the value that gives this.
10956 If an error occurs, you'll probably get back a BIGG number.
10957 All the actual work is done in utility functions for each distribution.
10958 ----------------------------------------------------------------------------*/
10959
pq2stat(pqpair pq,int code,double p1,double p2,double p3)10960 static double pq2stat( pqpair pq, int code, double p1,double p2,double p3 )
10961 {
10962 double val=BIGG ;
10963
10964 if( pq.p < 0.0 || pq.q < 0.0 || pq.p > 1.0 || pq.q > 1.0 ) return val ;
10965
10966 switch( code ){
10967
10968 case NIFTI_INTENT_CORREL: val = correl_pq2s ( pq , p1 ) ; break;
10969 case NIFTI_INTENT_TTEST: val = student_pq2s ( pq , p1 ) ; break;
10970 case NIFTI_INTENT_FTEST: val = fstat_pq2s ( pq , p1,p2 ) ; break;
10971 case NIFTI_INTENT_ZSCORE: val = normal_pq2s ( pq ) ; break;
10972 case NIFTI_INTENT_CHISQ: val = chisq_pq2s ( pq , p1 ) ; break;
10973 case NIFTI_INTENT_BETA: val = beta_pq2s ( pq , p1,p2 ) ; break;
10974 case NIFTI_INTENT_BINOM: val = binomial_pq2s( pq , p1,p2 ) ; break;
10975 case NIFTI_INTENT_GAMMA: val = gamma_pq2s ( pq , p1,p2 ) ; break;
10976 case NIFTI_INTENT_POISSON: val = poisson_pq2s ( pq , p1 ) ; break;
10977 case NIFTI_INTENT_FTEST_NONC: val = fnonc_pq2s ( pq , p1,p2,p3 ); break;
10978 case NIFTI_INTENT_CHISQ_NONC: val = chsqnonc_pq2s( pq , p1,p2 ); break;
10979 case NIFTI_INTENT_TTEST_NONC: val = tnonc_pq2s ( pq , p1,p2 ) ; break;
10980 case NIFTI_INTENT_CHI: val = chi_pq2s ( pq , p1 ) ; break;
10981
10982 /* these distributions are shifted and scaled copies of a standard case */
10983
10984 case NIFTI_INTENT_INVGAUSS:
10985 if( p1 > 0.0 && p2 > 0.0 ) val = p1*invgauss_pq2s ( pq,p2/p1); break;
10986
10987 case NIFTI_INTENT_WEIBULL:
10988 if( p2 > 0.0 && p3 > 0.0 ) val = p1+p2*weibull_pq2s ( pq, p3 ) ; break;
10989
10990 case NIFTI_INTENT_EXTVAL:
10991 if( p2 > 0.0 ) val = p1+p2*extval1_pq2s ( pq ) ; break;
10992
10993 case NIFTI_INTENT_NORMAL:
10994 if( p2 > 0.0 ) val = p1+p2*normal_pq2s ( pq ) ; break;
10995
10996 case NIFTI_INTENT_LOGISTIC:
10997 if( p2 > 0.0 ) val = p1+p2*logistic_pq2s( pq ) ; break;
10998
10999 case NIFTI_INTENT_LAPLACE:
11000 if( p2 > 0.0 ) val = p1+p2*laplace_pq2s ( pq ) ; break;
11001
11002 case NIFTI_INTENT_UNIFORM:
11003 if( p2 > p1 ) val = p1+(p2-p1)*uniform_pq2s(pq) ; break;
11004
11005 /* this case is trivial */
11006
11007 case NIFTI_INTENT_PVAL: val = pq.q ; break;
11008 }
11009
11010 return val ;
11011 }
11012
11013 /****************************************************************************/
11014 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/
11015 /*..........................................................................*/
11016 /*............. AT LAST! Functions to be called by the user! ..............*/
11017 /*..........................................................................*/
11018 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/
11019 /****************************************************************************/
11020
11021 /****************************************************************************
11022 Statistical codes implemented here:
11023
11024 NIFTI_INTENT_CORREL = correlation statistic
11025 NIFTI_INTENT_TTEST = t statistic (central)
11026 NIFTI_INTENT_FTEST = F statistic (central)
11027 NIFTI_INTENT_ZSCORE = N(0,1) statistic
11028 NIFTI_INTENT_CHISQ = Chi-squared (central)
11029 NIFTI_INTENT_BETA = Beta variable (central)
11030 NIFTI_INTENT_BINOM = Binomial variable
11031 NIFTI_INTENT_GAMMA = Gamma distribution
11032 NIFTI_INTENT_POISSON = Poisson distribution
11033 NIFTI_INTENT_FTEST_NONC = noncentral F statistic
11034 NIFTI_INTENT_CHISQ_NONC = noncentral chi-squared
11035 NIFTI_INTENT_TTEST_NONC = noncentral t statistic
11036 NIFTI_INTENT_CHI = Chi statistic (central)
11037 NIFTI_INTENT_INVGAUSS = inverse Gaussian variable
11038 NIFTI_INTENT_WEIBULL = Weibull distribution
11039 NIFTI_INTENT_EXTVAL = Extreme value type I
11040 NIFTI_INTENT_NORMAL = N(mu,variance) normal
11041 NIFTI_INTENT_LOGISTIC = Logistic distribution
11042 NIFTI_INTENT_LAPLACE = Laplace distribution
11043 NIFTI_INTENT_UNIFORM = Uniform distribution
11044 NIFTI_INTENT_PVAL = "p-value"
11045 *****************************************************************************/
11046
11047 static char *inam[]={ NULL , NULL ,
11048 "CORREL" , "TTEST" , "FTEST" , "ZSCORE" ,
11049 "CHISQ" , "BETA" , "BINOM" , "GAMMA" ,
11050 "POISSON" , "NORMAL" , "FTEST_NONC" , "CHISQ_NONC" ,
11051 "LOGISTIC" , "LAPLACE" , "UNIFORM" , "TTEST_NONC" ,
11052 "WEIBULL" , "CHI" , "INVGAUSS" , "EXTVAL" ,
11053 "PVAL" ,
11054 NULL } ;
11055
11056 #include <ctype.h>
11057 #include <string.h>
11058
11059 /*--------------------------------------------------------------------------*/
11060 /*! Given a string name for a statistic, return its integer code.
11061 Returns -1 if not found.
11062 ----------------------------------------------------------------------------*/
11063
nifti_intent_code(char * name)11064 int nifti_intent_code( char *name )
11065 {
11066 char *unam , *upt ;
11067 int ii ;
11068
11069 if( name == NULL || *name == '\0' ) return -1 ;
11070
11071 unam = strdup(name) ;
11072 for( upt=unam ; *upt != '\0' ; upt++ ) *upt = (char)toupper(*upt) ;
11073
11074 for( ii=NIFTI_FIRST_STATCODE ; ii <= NIFTI_LAST_STATCODE ; ii++ )
11075 if( strcmp(inam[ii],unam) == 0 ) break ;
11076
11077 free(unam) ;
11078 return (ii <= NIFTI_LAST_STATCODE) ? ii : -1 ;
11079 }
11080
11081 /*--------------------------------------------------------------------------*/
11082 /*! Given a value, return its cumulative distribution function (cdf):
11083 - val = statistic
11084 - code = NIFTI_INTENT_* statistical code
11085 - p1,p2,p3 = parameters of the distribution
11086
11087 If an error occurs, you'll probably get back 0.0.
11088 ----------------------------------------------------------------------------*/
11089
nifti_stat2cdf(double val,int code,double p1,double p2,double p3)11090 double nifti_stat2cdf( double val, int code, double p1,double p2,double p3 )
11091 {
11092 pqpair pq ;
11093 pq = stat2pq( val, code, p1,p2,p3 ) ;
11094 return pq.p ;
11095 }
11096
11097 /*--------------------------------------------------------------------------*/
11098 /*! Given a value, return its reversed cumulative distribution function
11099 (1-cdf):
11100 - val = statistic
11101 - code = NIFTI_INTENT_* statistical code
11102 - p1,p2,p3 = parameters of the distribution
11103
11104 If an error transpires, you'll probably get back 1.0.
11105 ----------------------------------------------------------------------------*/
11106
nifti_stat2rcdf(double val,int code,double p1,double p2,double p3)11107 double nifti_stat2rcdf( double val, int code, double p1,double p2,double p3 )
11108 {
11109 pqpair pq ;
11110 pq = stat2pq( val, code, p1,p2,p3 ) ;
11111 return pq.q ;
11112 }
11113
11114 /*--------------------------------------------------------------------------*/
11115 /*! Given a cdf probability, find the value that gave rise to it.
11116 - p = cdf; 0 < p < 1
11117 - code = NIFTI_INTENT_* statistical code
11118 - p1,p2,p3 = parameters of the distribution
11119
11120 If an error transpires, you'll probably get back a BIGG number.
11121 ----------------------------------------------------------------------------*/
11122
nifti_cdf2stat(double p,int code,double p1,double p2,double p3)11123 double nifti_cdf2stat( double p , int code, double p1,double p2,double p3 )
11124 {
11125 pqpair pq ;
11126 pq.p = p ; pq.q = 1.0-p ;
11127 return pq2stat(pq,code,p1,p2,p3) ;
11128 }
11129
11130 /*--------------------------------------------------------------------------*/
11131 /*! Given a reversed cdf probability, find the value that gave rise to it.
11132 - q = 1-cdf; 0 < q < 1
11133 - code = NIFTI_INTENT_* statistical code
11134 - p1,p2,p3 = parameters of the distribution
11135
11136 If an error transpires, you'll probably get back a BIGG number.
11137 ----------------------------------------------------------------------------*/
11138
nifti_rcdf2stat(double q,int code,double p1,double p2,double p3)11139 double nifti_rcdf2stat( double q , int code, double p1,double p2,double p3 )
11140 {
11141 pqpair pq ;
11142 pq.p = 1.0-q ; pq.q = q ;
11143 return pq2stat(pq,code,p1,p2,p3) ;
11144 }
11145
11146 /*--------------------------------------------------------------------------*/
11147 /*! Given a statistic, compute a z-score from it. That is, the output
11148 is z such that cdf(z) of a N(0,1) variable is the same as the cdf
11149 of the given distribution at val.
11150 ----------------------------------------------------------------------------*/
11151
nifti_stat2zscore(double val,int code,double p1,double p2,double p3)11152 double nifti_stat2zscore( double val , int code, double p1,double p2,double p3 )
11153 {
11154 pqpair pq ;
11155
11156 if( code == NIFTI_INTENT_ZSCORE ) return val ; /* trivial */
11157 if( code == NIFTI_INTENT_NORMAL ) return (val-p1)/p2 ; /* almost so */
11158
11159 pq = stat2pq( val, code, p1,p2,p3 ) ; /* find cdf */
11160 return normal_pq2s( pq ) ; /* find z */
11161 }
11162
11163 /*--------------------------------------------------------------------------*/
11164 /*! Given a statistic, compute a half-z-score from it. That is, the output
11165 is z such that cdf(z) of a half-N(0,1) variable is the same as the cdf
11166 of the given distribution at val. A half-N(0,1) variable has density
11167 zero for z < 0 and twice the usual N(0,1) density for z > 0.
11168 ----------------------------------------------------------------------------*/
11169
nifti_stat2hzscore(double val,int code,double p1,double p2,double p3)11170 double nifti_stat2hzscore( double val, int code, double p1,double p2,double p3 )
11171 {
11172 pqpair pq ;
11173
11174 pq = stat2pq( val, code, p1,p2,p3 ) ; /* find cdf */
11175 pq.q = 0.5*(1.0-pq.p) ; pq.p = 0.5*(1.0+pq.p) ; /* mangle it */
11176 return normal_pq2s( pq ) ; /* find z */
11177 }
11178
11179 /****************************************************************************/
11180 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/
11181 /****************************************************************************/
11182
11183 /*--------------------------------------------------------------------------*/
11184 /* Sample program to test the above functions. Otherwise unimportant.
11185 ----------------------------------------------------------------------------*/
11186
main(int argc,char * argv[])11187 int main( int argc , char *argv[] )
11188 {
11189 double val , p , q , p1=0.0,p2=0.0,p3=0.0 ;
11190 double vbot,vtop,vdel ;
11191 int code , iarg=1 , doq=0 , dod=0 , doi=0 , doz=0 , doh=0 ;
11192
11193 /*-- print some help for the pitiful user --*/
11194
11195 if( argc < 3 || strstr(argv[1],"help") != NULL ){
11196 int ii ;
11197 printf("\n") ;
11198 printf("Demo program for computing NIfTI statistical functions.\n") ;
11199 printf("Usage: nifti_stats [-q|-d|-1|-z] val CODE [p1 p2 p3]\n") ;
11200 printf(" val can be a single number or in the form bot:top:step.\n") ;
11201 printf(" default ==> output p = Prob(statistic < val).\n") ;
11202 printf(" -q ==> output is 1-p.\n") ;
11203 printf(" -d ==> output is density.\n") ;
11204 printf(" -1 ==> output is x such that Prob(statistic < x) = val.\n") ;
11205 printf(" -z ==> output is z such that Normal cdf(z) = p(val).\n") ;
11206 printf(" -h ==> output is z such that 1/2-Normal cdf(z) = p(val).\n");
11207 printf(" Allowable CODEs:\n") ;
11208 for( ii=NIFTI_FIRST_STATCODE ; ii <= NIFTI_LAST_STATCODE ; ii++ ){
11209 printf(" %-10s",inam[ii]); if((ii-NIFTI_FIRST_STATCODE)%6==5)printf("\n");
11210 }
11211 printf("\n") ;
11212 printf(" Following CODE are distributional parameters, as needed.\n");
11213 printf("\n") ;
11214 printf("Results are written to stdout, 1 number per output line.\n") ;
11215 printf("Example (piping output into AFNI program 1dplot):\n") ;
11216 printf(" nifti_stats -d 0:4:.001 INVGAUSS 1 3 | 1dplot -dx 0.001 -stdin\n");
11217 printf("\n") ;
11218 printf("Author - RW Cox - SSCC/NIMH/NIH/DHHS/USA/EARTH - March 2004\n") ;
11219 printf("\n") ;
11220 exit(0) ;
11221 }
11222
11223 /*-- check first arg to see if it is an output option;
11224 if so, set the appropriate output flag to determine what to compute --*/
11225
11226 if( strcmp(argv[iarg],"-q") == 0 ){ doq = 1 ; iarg++ ; }
11227 else if( strcmp(argv[iarg],"-d") == 0 ){ dod = 1 ; iarg++ ; }
11228 else if( strcmp(argv[iarg],"-1") == 0 ){ doi = 1 ; iarg++ ; }
11229 else if( strcmp(argv[iarg],"-z") == 0 ){ doz = 1 ; iarg++ ; }
11230 else if( strcmp(argv[iarg],"-h") == 0 ){ doh = 1 ; iarg++ ; }
11231
11232 /*-- get the value(s) to process --*/
11233
11234 vbot=vtop=vdel = 0.0 ;
11235 sscanf( argv[iarg++] , "%lf:%lf:%lf" , &vbot,&vtop,&vdel ) ;
11236 if( vbot >= vtop ) vdel = 0.0 ;
11237 if( vdel <= 0.0 ) vtop = vbot ;
11238
11239 /*-- decode the CODE into the integer signifying the distribution --*/
11240
11241 code = nifti_intent_code(argv[iarg++]) ;
11242 if( code < 0 ){ fprintf(stderr,"illegal code=%s\n",argv[iarg-1]); exit(1); }
11243
11244 /*-- get the parameters, if present (defaults are 0) --*/
11245
11246 if( argc > iarg ) p1 = strtod(argv[iarg++],NULL) ;
11247 if( argc > iarg ) p2 = strtod(argv[iarg++],NULL) ;
11248 if( argc > iarg ) p3 = strtod(argv[iarg++],NULL) ;
11249
11250 /*-- loop over input value(s), compute output, write to stdout --*/
11251
11252 for( val=vbot ; val <= vtop ; val += vdel ){
11253 if( doq ) /* output = 1-cdf */
11254 p = nifti_stat2rcdf( val , code,p1,p2,p3 ) ;
11255 else if( dod ) /* output = density */
11256 p = 1000.0*( nifti_stat2cdf(val+.001,code,p1,p2,p3)
11257 -nifti_stat2cdf(val ,code,p1,p2,p3)) ;
11258 else if( doi ) /* output = inverse */
11259 p = nifti_cdf2stat( val , code,p1,p2,p3 ) ;
11260 else if( doz ) /* output = z score */
11261 p = nifti_stat2zscore( val , code,p1,p2,p3 ) ;
11262 else if( doh ) /* output = halfz score */
11263 p = nifti_stat2hzscore( val , code,p1,p2,p3 ) ;
11264 else /* output = cdf */
11265 p = nifti_stat2cdf( val , code,p1,p2,p3 ) ;
11266
11267 printf("%.9g\n",p) ;
11268 if( vdel <= 0.0 ) break ; /* the case of just 1 value */
11269 }
11270
11271 /*-- terminus est --*/
11272
11273 exit(0) ;
11274 }
11275