lib/dcdflib/dcdflib.c

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