lib/dcdflib/dcdflib.c

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