You are here:
nifti_stats.c
Go to the documentation of this file.00001 00002 /************************************************************************/ 00003 /** Functions to compute cumulative distributions and their inverses **/ 00004 /** for the NIfTI-1 statistical types. Much of this code is taken **/ 00005 /** from other sources. In particular, the cdflib functions by **/ 00006 /** Brown and Lovato make up the bulk of this file. That code **/ 00007 /** was placed in the public domain. The code by K. Krishnamoorthy **/ 00008 /** is also released for unrestricted use. Finally, the other parts **/ 00009 /** of this file (by RW Cox) are released to the public domain. **/ 00010 /** **/ 00011 /** Most of this file comprises a set of "static" functions, to be **/ 00012 /** called by the user-level functions at the very end of the file. **/ 00013 /** At the end of the file is a simple main program to drive these **/ 00014 /** functions. **/ 00015 /** **/ 00016 /** To find the user-level functions, search forward for the string **/ 00017 /** "nifti_", which will be at about line 11000. **/ 00018 /************************************************************************/ 00019 /*****==============================================================*****/ 00020 /***** Neither the National Institutes of Health (NIH), the DFWG, *****/ 00021 /***** nor any of the members or employees of these institutions *****/ 00022 /***** imply any warranty of usefulness of this material for any *****/ 00023 /***** purpose, and do not assume any liability for damages, *****/ 00024 /***** incidental or otherwise, caused by any use of this document. *****/ 00025 /***** If these conditions are not acceptable, do not use this! *****/ 00026 /*****==============================================================*****/ 00027 /************************************************************************/ 00028 00029 /*....................................................................... 00030 To compile with gcc, for example: 00031 00032 gcc -O3 -ffast-math -o nifti_stats nifti_stats.c -lm 00033 ........................................................................*/ 00034 00035 #include "nifti1.h" /* for the NIFTI_INTENT_* constants */ 00036 #include <stdio.h> 00037 #include <stdlib.h> 00038 #include <math.h> 00039 00040 /************************************************************************/ 00041 /************ Include all the cdflib functions here and now *************/ 00042 /************ [about 9900 lines of code below here] *************/ 00043 /************************************************************************/ 00044 00045 /** Prototypes for cdflib functions **/ 00046 00047 static double algdiv(double*,double*); 00048 static double alngam(double*); 00049 static double alnrel(double*); 00050 static double apser(double*,double*,double*,double*); 00051 static double basym(double*,double*,double*,double*); 00052 static double bcorr(double*,double*); 00053 static double betaln(double*,double*); 00054 static double bfrac(double*,double*,double*,double*,double*,double*); 00055 static void bgrat(double*,double*,double*,double*,double*,double*,int*i); 00056 static double bpser(double*,double*,double*,double*); 00057 static void bratio(double*,double*,double*,double*,double*,double*,int*); 00058 static double brcmp1(int*,double*,double*,double*,double*); 00059 static double brcomp(double*,double*,double*,double*); 00060 static double bup(double*,double*,double*,double*,int*,double*); 00061 static void cdfbet(int*,double*,double*,double*,double*,double*,double*, 00062 int*,double*); 00063 static void cdfbin(int*,double*,double*,double*,double*,double*,double*, 00064 int*,double*); 00065 static void cdfchi(int*,double*,double*,double*,double*,int*,double*); 00066 static void cdfchn(int*,double*,double*,double*,double*,double*,int*,double*); 00067 static void cdff(int*,double*,double*,double*,double*,double*,int*,double*); 00068 static void cdffnc(int*,double*,double*,double*,double*,double*,double*, 00069 int*s,double*); 00070 static void cdfgam(int*,double*,double*,double*,double*,double*,int*,double*); 00071 static void cdfnbn(int*,double*,double*,double*,double*,double*,double*, 00072 int*,double*); 00073 static void cdfnor(int*,double*,double*,double*,double*,double*,int*,double*); 00074 static void cdfpoi(int*,double*,double*,double*,double*,int*,double*); 00075 static void cdft(int*,double*,double*,double*,double*,int*,double*); 00076 static void cumbet(double*,double*,double*,double*,double*,double*); 00077 static void cumbin(double*,double*,double*,double*,double*,double*); 00078 static void cumchi(double*,double*,double*,double*); 00079 static void cumchn(double*,double*,double*,double*,double*); 00080 static void cumf(double*,double*,double*,double*,double*); 00081 static void cumfnc(double*,double*,double*,double*,double*,double*); 00082 static void cumgam(double*,double*,double*,double*); 00083 static void cumnbn(double*,double*,double*,double*,double*,double*); 00084 static void cumnor(double*,double*,double*); 00085 static void cumpoi(double*,double*,double*,double*); 00086 static void cumt(double*,double*,double*,double*); 00087 static double dbetrm(double*,double*); 00088 static double devlpl(double [],int*,double*); 00089 static double dexpm1(double*); 00090 static double dinvnr(double *p,double *q); 00091 static void E0000(int,int*,double*,double*,unsigned long*, 00092 unsigned long*,double*,double*,double*, 00093 double*,double*,double*,double*); 00094 static void dinvr(int*,double*,double*,unsigned long*,unsigned long*); 00095 static void dstinv(double*,double*,double*,double*,double*,double*, 00096 double*); 00097 static double dlanor(double*); 00098 static double dln1mx(double*); 00099 static double dln1px(double*); 00100 static double dlnbet(double*,double*); 00101 static double dlngam(double*); 00102 static double dstrem(double*); 00103 static double dt1(double*,double*,double*); 00104 static void E0001(int,int*,double*,double*,double*,double*, 00105 unsigned long*,unsigned long*,double*,double*, 00106 double*,double*); 00107 static void dzror(int*,double*,double*,double*,double *, 00108 unsigned long*,unsigned long*); 00109 static void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl); 00110 static double erf1(double*); 00111 static double erfc1(int*,double*); 00112 static double esum(int*,double*); 00113 static double exparg(int*); 00114 static double fpser(double*,double*,double*,double*); 00115 static double gam1(double*); 00116 static void gaminv(double*,double*,double*,double*,double*,int*); 00117 static double gamln(double*); 00118 static double gamln1(double*); 00119 static double Xgamm(double*); 00120 static void grat1(double*,double*,double*,double*,double*,double*); 00121 static void gratio(double*,double*,double*,double*,int*); 00122 static double gsumln(double*,double*); 00123 static double psi(double*); 00124 static double rcomp(double*,double*); 00125 static double rexp(double*); 00126 static double rlog(double*); 00127 static double rlog1(double*); 00128 static double spmpar(int*); 00129 static double stvaln(double*); 00130 static double fifdint(double); 00131 static double fifdmax1(double,double); 00132 static double fifdmin1(double,double); 00133 static double fifdsign(double,double); 00134 static long fifidint(double); 00135 static long fifmod(long,long); 00136 static void ftnstop(char*); 00137 static int ipmpar(int*); 00138 00139 /***=====================================================================***/ 00140 static double algdiv(double *a,double *b) 00141 /* 00142 ----------------------------------------------------------------------- 00143 00144 COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8 00145 00146 -------- 00147 00148 IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY 00149 LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). 00150 00151 ----------------------------------------------------------------------- 00152 */ 00153 { 00154 static double c0 = .833333333333333e-01; 00155 static double c1 = -.277777777760991e-02; 00156 static double c2 = .793650666825390e-03; 00157 static double c3 = -.595202931351870e-03; 00158 static double c4 = .837308034031215e-03; 00159 static double c5 = -.165322962780713e-02; 00160 static double algdiv,c,d,h,s11,s3,s5,s7,s9,t,u,v,w,x,x2,T1; 00161 /* 00162 .. 00163 .. Executable Statements .. 00164 */ 00165 if(*a <= *b) goto S10; 00166 h = *b/ *a; 00167 c = 1.0e0/(1.0e0+h); 00168 x = h/(1.0e0+h); 00169 d = *a+(*b-0.5e0); 00170 goto S20; 00171 S10: 00172 h = *a/ *b; 00173 c = h/(1.0e0+h); 00174 x = 1.0e0/(1.0e0+h); 00175 d = *b+(*a-0.5e0); 00176 S20: 00177 /* 00178 SET SN = (1 - X**N)/(1 - X) 00179 */ 00180 x2 = x*x; 00181 s3 = 1.0e0+(x+x2); 00182 s5 = 1.0e0+(x+x2*s3); 00183 s7 = 1.0e0+(x+x2*s5); 00184 s9 = 1.0e0+(x+x2*s7); 00185 s11 = 1.0e0+(x+x2*s9); 00186 /* 00187 SET W = DEL(B) - DEL(A + B) 00188 */ 00189 t = pow(1.0e0/ *b,2.0); 00190 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; 00191 w *= (c/ *b); 00192 /* 00193 COMBINE THE RESULTS 00194 */ 00195 T1 = *a/ *b; 00196 u = d*alnrel(&T1); 00197 v = *a*(log(*b)-1.0e0); 00198 if(u <= v) goto S30; 00199 algdiv = w-v-u; 00200 return algdiv; 00201 S30: 00202 algdiv = w-u-v; 00203 return algdiv; 00204 } /* END */ 00205 00206 /***=====================================================================***/ 00207 static double alngam(double *x) 00208 /* 00209 ********************************************************************** 00210 00211 double alngam(double *x) 00212 double precision LN of the GAMma function 00213 00214 00215 Function 00216 00217 00218 Returns the natural logarithm of GAMMA(X). 00219 00220 00221 Arguments 00222 00223 00224 X --> value at which scaled log gamma is to be returned 00225 X is DOUBLE PRECISION 00226 00227 00228 Method 00229 00230 00231 If X .le. 6.0, then use recursion to get X below 3 00232 then apply rational approximation number 5236 of 00233 Hart et al, Computer Approximations, John Wiley and 00234 Sons, NY, 1968. 00235 00236 If X .gt. 6.0, then use recursion to get X to at least 12 and 00237 then use formula 5423 of the same source. 00238 00239 ********************************************************************** 00240 */ 00241 { 00242 #define hln2pi 0.91893853320467274178e0 00243 static double coef[5] = { 00244 0.83333333333333023564e-1,-0.27777777768818808e-2,0.79365006754279e-3, 00245 -0.594997310889e-3,0.8065880899e-3 00246 }; 00247 static double scoefd[4] = { 00248 0.62003838007126989331e2,0.9822521104713994894e1,-0.8906016659497461257e1, 00249 0.1000000000000000000e1 00250 }; 00251 static double scoefn[9] = { 00252 0.62003838007127258804e2,0.36036772530024836321e2,0.20782472531792126786e2, 00253 0.6338067999387272343e1,0.215994312846059073e1,0.3980671310203570498e0, 00254 0.1093115956710439502e0,0.92381945590275995e-2,0.29737866448101651e-2 00255 }; 00256 static int K1 = 9; 00257 static int K3 = 4; 00258 static int K5 = 5; 00259 static double alngam,offset,prod,xx; 00260 static int i,n; 00261 static double T2,T4,T6; 00262 /* 00263 .. 00264 .. Executable Statements .. 00265 */ 00266 if(!(*x <= 6.0e0)) goto S70; 00267 prod = 1.0e0; 00268 xx = *x; 00269 if(!(*x > 3.0e0)) goto S30; 00270 S10: 00271 if(!(xx > 3.0e0)) goto S20; 00272 xx -= 1.0e0; 00273 prod *= xx; 00274 goto S10; 00275 S30: 00276 S20: 00277 if(!(*x < 2.0e0)) goto S60; 00278 S40: 00279 if(!(xx < 2.0e0)) goto S50; 00280 prod /= xx; 00281 xx += 1.0e0; 00282 goto S40; 00283 S60: 00284 S50: 00285 T2 = xx-2.0e0; 00286 T4 = xx-2.0e0; 00287 alngam = devlpl(scoefn,&K1,&T2)/devlpl(scoefd,&K3,&T4); 00288 /* 00289 COMPUTE RATIONAL APPROXIMATION TO GAMMA(X) 00290 */ 00291 alngam *= prod; 00292 alngam = log(alngam); 00293 goto S110; 00294 S70: 00295 offset = hln2pi; 00296 /* 00297 IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET 00298 */ 00299 n = fifidint(12.0e0-*x); 00300 if(!(n > 0)) goto S90; 00301 prod = 1.0e0; 00302 for(i=1; i<=n; i++) prod *= (*x+(double)(i-1)); 00303 offset -= log(prod); 00304 xx = *x+(double)n; 00305 goto S100; 00306 S90: 00307 xx = *x; 00308 S100: 00309 /* 00310 COMPUTE POWER SERIES 00311 */ 00312 T6 = 1.0e0/pow(xx,2.0); 00313 alngam = devlpl(coef,&K5,&T6)/xx; 00314 alngam += (offset+(xx-0.5e0)*log(xx)-xx); 00315 S110: 00316 return alngam; 00317 #undef hln2pi 00318 } /* END */ 00319 00320 /***=====================================================================***/ 00321 static double alnrel(double *a) 00322 /* 00323 ----------------------------------------------------------------------- 00324 EVALUATION OF THE FUNCTION LN(1 + A) 00325 ----------------------------------------------------------------------- 00326 */ 00327 { 00328 static double p1 = -.129418923021993e+01; 00329 static double p2 = .405303492862024e+00; 00330 static double p3 = -.178874546012214e-01; 00331 static double q1 = -.162752256355323e+01; 00332 static double q2 = .747811014037616e+00; 00333 static double q3 = -.845104217945565e-01; 00334 static double alnrel,t,t2,w,x; 00335 /* 00336 .. 00337 .. Executable Statements .. 00338 */ 00339 if(fabs(*a) > 0.375e0) goto S10; 00340 t = *a/(*a+2.0e0); 00341 t2 = t*t; 00342 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0); 00343 alnrel = 2.0e0*t*w; 00344 return alnrel; 00345 S10: 00346 x = 1.e0+*a; 00347 alnrel = log(x); 00348 return alnrel; 00349 } /* END */ 00350 00351 /***=====================================================================***/ 00352 static double apser(double *a,double *b,double *x,double *eps) 00353 /* 00354 ----------------------------------------------------------------------- 00355 APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR 00356 A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN 00357 A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. 00358 ----------------------------------------------------------------------- 00359 */ 00360 { 00361 static double g = .577215664901533e0; 00362 static double apser,aj,bx,c,j,s,t,tol; 00363 /* 00364 .. 00365 .. Executable Statements .. 00366 */ 00367 bx = *b**x; 00368 t = *x-bx; 00369 if(*b**eps > 2.e-2) goto S10; 00370 c = log(*x)+psi(b)+g+t; 00371 goto S20; 00372 S10: 00373 c = log(bx)+g+t; 00374 S20: 00375 tol = 5.0e0**eps*fabs(c); 00376 j = 1.0e0; 00377 s = 0.0e0; 00378 S30: 00379 j += 1.0e0; 00380 t *= (*x-bx/j); 00381 aj = t/j; 00382 s += aj; 00383 if(fabs(aj) > tol) goto S30; 00384 apser = -(*a*(c+s)); 00385 return apser; 00386 } /* END */ 00387 00388 /***=====================================================================***/ 00389 static double basym(double *a,double *b,double *lambda,double *eps) 00390 /* 00391 ----------------------------------------------------------------------- 00392 ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. 00393 LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. 00394 IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT 00395 A AND B ARE GREATER THAN OR EQUAL TO 15. 00396 ----------------------------------------------------------------------- 00397 */ 00398 { 00399 static double e0 = 1.12837916709551e0; 00400 static double e1 = .353553390593274e0; 00401 static int num = 20; 00402 /* 00403 ------------------------ 00404 ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP 00405 ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. 00406 THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. 00407 ------------------------ 00408 E0 = 2/SQRT(PI) 00409 E1 = 2**(-3/2) 00410 ------------------------ 00411 */ 00412 static int K3 = 1; 00413 static double basym,bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0, 00414 z2,zn,znm1; 00415 static int i,im1,imj,j,m,mm1,mmj,n,np1; 00416 static double a0[21],b0[21],c[21],d[21],T1,T2; 00417 /* 00418 .. 00419 .. Executable Statements .. 00420 */ 00421 basym = 0.0e0; 00422 if(*a >= *b) goto S10; 00423 h = *a/ *b; 00424 r0 = 1.0e0/(1.0e0+h); 00425 r1 = (*b-*a)/ *b; 00426 w0 = 1.0e0/sqrt(*a*(1.0e0+h)); 00427 goto S20; 00428 S10: 00429 h = *b/ *a; 00430 r0 = 1.0e0/(1.0e0+h); 00431 r1 = (*b-*a)/ *a; 00432 w0 = 1.0e0/sqrt(*b*(1.0e0+h)); 00433 S20: 00434 T1 = -(*lambda/ *a); 00435 T2 = *lambda/ *b; 00436 f = *a*rlog1(&T1)+*b*rlog1(&T2); 00437 t = exp(-f); 00438 if(t == 0.0e0) return basym; 00439 z0 = sqrt(f); 00440 z = 0.5e0*(z0/e1); 00441 z2 = f+f; 00442 a0[0] = 2.0e0/3.0e0*r1; 00443 c[0] = -(0.5e0*a0[0]); 00444 d[0] = -c[0]; 00445 j0 = 0.5e0/e0*erfc1(&K3,&z0); 00446 j1 = e1; 00447 sum = j0+d[0]*w0*j1; 00448 s = 1.0e0; 00449 h2 = h*h; 00450 hn = 1.0e0; 00451 w = w0; 00452 znm1 = z; 00453 zn = z2; 00454 for(n=2; n<=num; n+=2) { 00455 hn = h2*hn; 00456 a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0); 00457 np1 = n+1; 00458 s += hn; 00459 a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0); 00460 for(i=n; i<=np1; i++) { 00461 r = -(0.5e0*((double)i+1.0e0)); 00462 b0[0] = r*a0[0]; 00463 for(m=2; m<=i; m++) { 00464 bsum = 0.0e0; 00465 mm1 = m-1; 00466 for(j=1; j<=mm1; j++) { 00467 mmj = m-j; 00468 bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]); 00469 } 00470 b0[m-1] = r*a0[m-1]+bsum/(double)m; 00471 } 00472 c[i-1] = b0[i-1]/((double)i+1.0e0); 00473 dsum = 0.0e0; 00474 im1 = i-1; 00475 for(j=1; j<=im1; j++) { 00476 imj = i-j; 00477 dsum += (d[imj-1]*c[j-1]); 00478 } 00479 d[i-1] = -(dsum+c[i-1]); 00480 } 00481 j0 = e1*znm1+((double)n-1.0e0)*j0; 00482 j1 = e1*zn+(double)n*j1; 00483 znm1 = z2*znm1; 00484 zn = z2*zn; 00485 w = w0*w; 00486 t0 = d[n-1]*w*j0; 00487 w = w0*w; 00488 t1 = d[np1-1]*w*j1; 00489 sum += (t0+t1); 00490 if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80; 00491 } 00492 S80: 00493 u = exp(-bcorr(a,b)); 00494 basym = e0*t*u*sum; 00495 return basym; 00496 } /* END */ 00497 00498 /***=====================================================================***/ 00499 static double bcorr(double *a0,double *b0) 00500 /* 00501 ----------------------------------------------------------------------- 00502 00503 EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE 00504 LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). 00505 IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. 00506 00507 ----------------------------------------------------------------------- 00508 */ 00509 { 00510 static double c0 = .833333333333333e-01; 00511 static double c1 = -.277777777760991e-02; 00512 static double c2 = .793650666825390e-03; 00513 static double c3 = -.595202931351870e-03; 00514 static double c4 = .837308034031215e-03; 00515 static double c5 = -.165322962780713e-02; 00516 static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2; 00517 /* 00518 .. 00519 .. Executable Statements .. 00520 */ 00521 a = fifdmin1(*a0,*b0); 00522 b = fifdmax1(*a0,*b0); 00523 h = a/b; 00524 c = h/(1.0e0+h); 00525 x = 1.0e0/(1.0e0+h); 00526 x2 = x*x; 00527 /* 00528 SET SN = (1 - X**N)/(1 - X) 00529 */ 00530 s3 = 1.0e0+(x+x2); 00531 s5 = 1.0e0+(x+x2*s3); 00532 s7 = 1.0e0+(x+x2*s5); 00533 s9 = 1.0e0+(x+x2*s7); 00534 s11 = 1.0e0+(x+x2*s9); 00535 /* 00536 SET W = DEL(B) - DEL(A + B) 00537 */ 00538 t = pow(1.0e0/b,2.0); 00539 w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; 00540 w *= (c/b); 00541 /* 00542 COMPUTE DEL(A) + W 00543 */ 00544 t = pow(1.0e0/a,2.0); 00545 bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a+w; 00546 return bcorr; 00547 } /* END */ 00548 00549 /***=====================================================================***/ 00550 static double betaln(double *a0,double *b0) 00551 /* 00552 ----------------------------------------------------------------------- 00553 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION 00554 ----------------------------------------------------------------------- 00555 E = 0.5*LN(2*PI) 00556 -------------------------- 00557 */ 00558 { 00559 static double e = .918938533204673e0; 00560 static double betaln,a,b,c,h,u,v,w,z; 00561 static int i,n; 00562 static double T1; 00563 /* 00564 .. 00565 .. Executable Statements .. 00566 */ 00567 a = fifdmin1(*a0,*b0); 00568 b = fifdmax1(*a0,*b0); 00569 if(a >= 8.0e0) goto S100; 00570 if(a >= 1.0e0) goto S20; 00571 /* 00572 ----------------------------------------------------------------------- 00573 PROCEDURE WHEN A .LT. 1 00574 ----------------------------------------------------------------------- 00575 */ 00576 if(b >= 8.0e0) goto S10; 00577 T1 = a+b; 00578 betaln = gamln(&a)+(gamln(&b)-gamln(&T1)); 00579 return betaln; 00580 S10: 00581 betaln = gamln(&a)+algdiv(&a,&b); 00582 return betaln; 00583 S20: 00584 /* 00585 ----------------------------------------------------------------------- 00586 PROCEDURE WHEN 1 .LE. A .LT. 8 00587 ----------------------------------------------------------------------- 00588 */ 00589 if(a > 2.0e0) goto S40; 00590 if(b > 2.0e0) goto S30; 00591 betaln = gamln(&a)+gamln(&b)-gsumln(&a,&b); 00592 return betaln; 00593 S30: 00594 w = 0.0e0; 00595 if(b < 8.0e0) goto S60; 00596 betaln = gamln(&a)+algdiv(&a,&b); 00597 return betaln; 00598 S40: 00599 /* 00600 REDUCTION OF A WHEN B .LE. 1000 00601 */ 00602 if(b > 1000.0e0) goto S80; 00603 n = a-1.0e0; 00604 w = 1.0e0; 00605 for(i=1; i<=n; i++) { 00606 a -= 1.0e0; 00607 h = a/b; 00608 w *= (h/(1.0e0+h)); 00609 } 00610 w = log(w); 00611 if(b < 8.0e0) goto S60; 00612 betaln = w+gamln(&a)+algdiv(&a,&b); 00613 return betaln; 00614 S60: 00615 /* 00616 REDUCTION OF B WHEN B .LT. 8 00617 */ 00618 n = b-1.0e0; 00619 z = 1.0e0; 00620 for(i=1; i<=n; i++) { 00621 b -= 1.0e0; 00622 z *= (b/(a+b)); 00623 } 00624 betaln = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b))); 00625 return betaln; 00626 S80: 00627 /* 00628 REDUCTION OF A WHEN B .GT. 1000 00629 */ 00630 n = a-1.0e0; 00631 w = 1.0e0; 00632 for(i=1; i<=n; i++) { 00633 a -= 1.0e0; 00634 w *= (a/(1.0e0+a/b)); 00635 } 00636 betaln = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b)); 00637 return betaln; 00638 S100: 00639 /* 00640 ----------------------------------------------------------------------- 00641 PROCEDURE WHEN A .GE. 8 00642 ----------------------------------------------------------------------- 00643 */ 00644 w = bcorr(&a,&b); 00645 h = a/b; 00646 c = h/(1.0e0+h); 00647 u = -((a-0.5e0)*log(c)); 00648 v = b*alnrel(&h); 00649 if(u <= v) goto S110; 00650 betaln = -(0.5e0*log(b))+e+w-v-u; 00651 return betaln; 00652 S110: 00653 betaln = -(0.5e0*log(b))+e+w-u-v; 00654 return betaln; 00655 } /* END */ 00656 00657 /***=====================================================================***/ 00658 static double bfrac(double *a,double *b,double *x,double *y,double *lambda, 00659 double *eps) 00660 /* 00661 ----------------------------------------------------------------------- 00662 CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. 00663 IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. 00664 ----------------------------------------------------------------------- 00665 */ 00666 { 00667 static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1; 00668 /* 00669 .. 00670 .. Executable Statements .. 00671 */ 00672 bfrac = brcomp(a,b,x,y); 00673 if(bfrac == 0.0e0) return bfrac; 00674 c = 1.0e0+*lambda; 00675 c0 = *b/ *a; 00676 c1 = 1.0e0+1.0e0/ *a; 00677 yp1 = *y+1.0e0; 00678 n = 0.0e0; 00679 p = 1.0e0; 00680 s = *a+1.0e0; 00681 an = 0.0e0; 00682 bn = anp1 = 1.0e0; 00683 bnp1 = c/c1; 00684 r = c1/c; 00685 S10: 00686 /* 00687 CONTINUED FRACTION CALCULATION 00688 */ 00689 n += 1.0e0; 00690 t = n/ *a; 00691 w = n*(*b-n)**x; 00692 e = *a/s; 00693 alpha = p*(p+c0)*e*e*(w**x); 00694 e = (1.0e0+t)/(c1+t+t); 00695 beta = n+w/s+e*(c+n*yp1); 00696 p = 1.0e0+t; 00697 s += 2.0e0; 00698 /* 00699 UPDATE AN, BN, ANP1, AND BNP1 00700 */ 00701 t = alpha*an+beta*anp1; 00702 an = anp1; 00703 anp1 = t; 00704 t = alpha*bn+beta*bnp1; 00705 bn = bnp1; 00706 bnp1 = t; 00707 r0 = r; 00708 r = anp1/bnp1; 00709 if(fabs(r-r0) <= *eps*r) goto S20; 00710 /* 00711 RESCALE AN, BN, ANP1, AND BNP1 00712 */ 00713 an /= bnp1; 00714 bn /= bnp1; 00715 anp1 = r; 00716 bnp1 = 1.0e0; 00717 goto S10; 00718 S20: 00719 /* 00720 TERMINATION 00721 */ 00722 bfrac *= r; 00723 return bfrac; 00724 } /* END */ 00725 00726 /***=====================================================================***/ 00727 static void bgrat(double *a,double *b,double *x,double *y,double *w, 00728 double *eps,int *ierr) 00729 /* 00730 ----------------------------------------------------------------------- 00731 ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. 00732 THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED 00733 THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. 00734 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. 00735 ----------------------------------------------------------------------- 00736 */ 00737 { 00738 static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z; 00739 static int i,n,nm1; 00740 static double c[30],d[30],T1; 00741 /* 00742 .. 00743 .. Executable Statements .. 00744 */ 00745 bm1 = *b-0.5e0-0.5e0; 00746 nu = *a+0.5e0*bm1; 00747 if(*y > 0.375e0) goto S10; 00748 T1 = -*y; 00749 lnx = alnrel(&T1); 00750 goto S20; 00751 S10: 00752 lnx = log(*x); 00753 S20: 00754 z = -(nu*lnx); 00755 if(*b*z == 0.0e0) goto S70; 00756 /* 00757 COMPUTATION OF THE EXPANSION 00758 SET R = EXP(-Z)*Z**B/GAMMA(B) 00759 */ 00760 r = *b*(1.0e0+gam1(b))*exp(*b*log(z)); 00761 r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx)); 00762 u = algdiv(b,a)+*b*log(nu); 00763 u = r*exp(-u); 00764 if(u == 0.0e0) goto S70; 00765 grat1(b,&z,&r,&p,&q,eps); 00766 v = 0.25e0*pow(1.0e0/nu,2.0); 00767 t2 = 0.25e0*lnx*lnx; 00768 l = *w/u; 00769 j = q/r; 00770 sum = j; 00771 t = cn = 1.0e0; 00772 n2 = 0.0e0; 00773 for(n=1; n<=30; n++) { 00774 bp2n = *b+n2; 00775 j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v; 00776 n2 += 2.0e0; 00777 t *= t2; 00778 cn /= (n2*(n2+1.0e0)); 00779 c[n-1] = cn; 00780 s = 0.0e0; 00781 if(n == 1) goto S40; 00782 nm1 = n-1; 00783 coef = *b-(double)n; 00784 for(i=1; i<=nm1; i++) { 00785 s += (coef*c[i-1]*d[n-i-1]); 00786 coef += *b; 00787 } 00788 S40: 00789 d[n-1] = bm1*cn+s/(double)n; 00790 dj = d[n-1]*j; 00791 sum += dj; 00792 if(sum <= 0.0e0) goto S70; 00793 if(fabs(dj) <= *eps*(sum+l)) goto S60; 00794 } 00795 S60: 00796 /* 00797 ADD THE RESULTS TO W 00798 */ 00799 *ierr = 0; 00800 *w += (u*sum); 00801 return; 00802 S70: 00803 /* 00804 THE EXPANSION CANNOT BE COMPUTED 00805 */ 00806 *ierr = 1; 00807 return; 00808 } /* END */ 00809 00810 /***=====================================================================***/ 00811 static double bpser(double *a,double *b,double *x,double *eps) 00812 /* 00813 ----------------------------------------------------------------------- 00814 POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 00815 OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. 00816 ----------------------------------------------------------------------- 00817 */ 00818 { 00819 static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z; 00820 static int i,m; 00821 /* 00822 .. 00823 .. Executable Statements .. 00824 */ 00825 bpser = 0.0e0; 00826 if(*x == 0.0e0) return bpser; 00827 /* 00828 ----------------------------------------------------------------------- 00829 COMPUTE THE FACTOR X**A/(A*BETA(A,B)) 00830 ----------------------------------------------------------------------- 00831 */ 00832 a0 = fifdmin1(*a,*b); 00833 if(a0 < 1.0e0) goto S10; 00834 z = *a*log(*x)-betaln(a,b); 00835 bpser = exp(z)/ *a; 00836 goto S100; 00837 S10: 00838 b0 = fifdmax1(*a,*b); 00839 if(b0 >= 8.0e0) goto S90; 00840 if(b0 > 1.0e0) goto S40; 00841 /* 00842 PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 00843 */ 00844 bpser = pow(*x,*a); 00845 if(bpser == 0.0e0) return bpser; 00846 apb = *a+*b; 00847 if(apb > 1.0e0) goto S20; 00848 z = 1.0e0+gam1(&apb); 00849 goto S30; 00850 S20: 00851 u = *a+*b-1.e0; 00852 z = (1.0e0+gam1(&u))/apb; 00853 S30: 00854 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; 00855 bpser *= (c*(*b/apb)); 00856 goto S100; 00857 S40: 00858 /* 00859 PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 00860 */ 00861 u = gamln1(&a0); 00862 m = b0-1.0e0; 00863 if(m < 1) goto S60; 00864 c = 1.0e0; 00865 for(i=1; i<=m; i++) { 00866 b0 -= 1.0e0; 00867 c *= (b0/(a0+b0)); 00868 } 00869 u = log(c)+u; 00870 S60: 00871 z = *a*log(*x)-u; 00872 b0 -= 1.0e0; 00873 apb = a0+b0; 00874 if(apb > 1.0e0) goto S70; 00875 t = 1.0e0+gam1(&apb); 00876 goto S80; 00877 S70: 00878 u = a0+b0-1.e0; 00879 t = (1.0e0+gam1(&u))/apb; 00880 S80: 00881 bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t; 00882 goto S100; 00883 S90: 00884 /* 00885 PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 00886 */ 00887 u = gamln1(&a0)+algdiv(&a0,&b0); 00888 z = *a*log(*x)-u; 00889 bpser = a0/ *a*exp(z); 00890 S100: 00891 if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser; 00892 /* 00893 ----------------------------------------------------------------------- 00894 COMPUTE THE SERIES 00895 ----------------------------------------------------------------------- 00896 */ 00897 sum = n = 0.0e0; 00898 c = 1.0e0; 00899 tol = *eps/ *a; 00900 S110: 00901 n += 1.0e0; 00902 c *= ((0.5e0+(0.5e0-*b/n))**x); 00903 w = c/(*a+n); 00904 sum += w; 00905 if(fabs(w) > tol) goto S110; 00906 bpser *= (1.0e0+*a*sum); 00907 return bpser; 00908 } /* END */ 00909 00910 /***=====================================================================***/ 00911 static void bratio(double *a,double *b,double *x,double *y,double *w, 00912 double *w1,int *ierr) 00913 /* 00914 ----------------------------------------------------------------------- 00915 00916 EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) 00917 00918 -------------------- 00919 00920 IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1 00921 AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES 00922 00923 W = IX(A,B) 00924 W1 = 1 - IX(A,B) 00925 00926 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. 00927 IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND 00928 W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, 00929 THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO 00930 ONE OF THE FOLLOWING VALUES ... 00931 00932 IERR = 1 IF A OR B IS NEGATIVE 00933 IERR = 2 IF A = B = 0 00934 IERR = 3 IF X .LT. 0 OR X .GT. 1 00935 IERR = 4 IF Y .LT. 0 OR Y .GT. 1 00936 IERR = 5 IF X + Y .NE. 1 00937 IERR = 6 IF X = A = 0 00938 IERR = 7 IF Y = B = 0 00939 00940 -------------------- 00941 WRITTEN BY ALFRED H. MORRIS, JR. 00942 NAVAL SURFACE WARFARE CENTER 00943 DAHLGREN, VIRGINIA 00944 REVISED ... NOV 1991 00945 ----------------------------------------------------------------------- 00946 */ 00947 { 00948 static int K1 = 1; 00949 static double a0,b0,eps,lambda,t,x0,y0,z; 00950 static int ierr1,ind,n; 00951 static double T2,T3,T4,T5; 00952 /* 00953 .. 00954 .. Executable Statements .. 00955 */ 00956 /* 00957 ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST 00958 FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 00959 */ 00960 eps = spmpar(&K1); 00961 *w = *w1 = 0.0e0; 00962 if(*a < 0.0e0 || *b < 0.0e0) goto S270; 00963 if(*a == 0.0e0 && *b == 0.0e0) goto S280; 00964 if(*x < 0.0e0 || *x > 1.0e0) goto S290; 00965 if(*y < 0.0e0 || *y > 1.0e0) goto S300; 00966 z = *x+*y-0.5e0-0.5e0; 00967 if(fabs(z) > 3.0e0*eps) goto S310; 00968 *ierr = 0; 00969 if(*x == 0.0e0) goto S210; 00970 if(*y == 0.0e0) goto S230; 00971 if(*a == 0.0e0) goto S240; 00972 if(*b == 0.0e0) goto S220; 00973 eps = fifdmax1(eps,1.e-15); 00974 if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260; 00975 ind = 0; 00976 a0 = *a; 00977 b0 = *b; 00978 x0 = *x; 00979 y0 = *y; 00980 if(fifdmin1(a0,b0) > 1.0e0) goto S40; 00981 /* 00982 PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 00983 */ 00984 if(*x <= 0.5e0) goto S10; 00985 ind = 1; 00986 a0 = *b; 00987 b0 = *a; 00988 x0 = *y; 00989 y0 = *x; 00990 S10: 00991 if(b0 < fifdmin1(eps,eps*a0)) goto S90; 00992 if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100; 00993 if(fifdmax1(a0,b0) > 1.0e0) goto S20; 00994 if(a0 >= fifdmin1(0.2e0,b0)) goto S110; 00995 if(pow(x0,a0) <= 0.9e0) goto S110; 00996 if(x0 >= 0.3e0) goto S120; 00997 n = 20; 00998 goto S140; 00999 S20: 01000 if(b0 <= 1.0e0) goto S110; 01001 if(x0 >= 0.3e0) goto S120; 01002 if(x0 >= 0.1e0) goto S30; 01003 if(pow(x0*b0,a0) <= 0.7e0) goto S110; 01004 S30: 01005 if(b0 > 15.0e0) goto S150; 01006 n = 20; 01007 goto S140; 01008 S40: 01009 /* 01010 PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 01011 */ 01012 if(*a > *b) goto S50; 01013 lambda = *a-(*a+*b)**x; 01014 goto S60; 01015 S50: 01016 lambda = (*a+*b)**y-*b; 01017 S60: 01018 if(lambda >= 0.0e0) goto S70; 01019 ind = 1; 01020 a0 = *b; 01021 b0 = *a; 01022 x0 = *y; 01023 y0 = *x; 01024 lambda = fabs(lambda); 01025 S70: 01026 if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110; 01027 if(b0 < 40.0e0) goto S160; 01028 if(a0 > b0) goto S80; 01029 if(a0 <= 100.0e0) goto S130; 01030 if(lambda > 0.03e0*a0) goto S130; 01031 goto S200; 01032 S80: 01033 if(b0 <= 100.0e0) goto S130; 01034 if(lambda > 0.03e0*b0) goto S130; 01035 goto S200; 01036 S90: 01037 /* 01038 EVALUATION OF THE APPROPRIATE ALGORITHM 01039 */ 01040 *w = fpser(&a0,&b0,&x0,&eps); 01041 *w1 = 0.5e0+(0.5e0-*w); 01042 goto S250; 01043 S100: 01044 *w1 = apser(&a0,&b0,&x0,&eps); 01045 *w = 0.5e0+(0.5e0-*w1); 01046 goto S250; 01047 S110: 01048 *w = bpser(&a0,&b0,&x0,&eps); 01049 *w1 = 0.5e0+(0.5e0-*w); 01050 goto S250; 01051 S120: 01052 *w1 = bpser(&b0,&a0,&y0,&eps); 01053 *w = 0.5e0+(0.5e0-*w1); 01054 goto S250; 01055 S130: 01056 T2 = 15.0e0*eps; 01057 *w = bfrac(&a0,&b0,&x0,&y0,&lambda,&T2); 01058 *w1 = 0.5e0+(0.5e0-*w); 01059 goto S250; 01060 S140: 01061 *w1 = bup(&b0,&a0,&y0,&x0,&n,&eps); 01062 b0 += (double)n; 01063 S150: 01064 T3 = 15.0e0*eps; 01065 bgrat(&b0,&a0,&y0,&x0,w1,&T3,&ierr1); 01066 *w = 0.5e0+(0.5e0-*w1); 01067 goto S250; 01068 S160: 01069 n = b0; 01070 b0 -= (double)n; 01071 if(b0 != 0.0e0) goto S170; 01072 n -= 1; 01073 b0 = 1.0e0; 01074 S170: 01075 *w = bup(&b0,&a0,&y0,&x0,&n,&eps); 01076 if(x0 > 0.7e0) goto S180; 01077 *w += bpser(&a0,&b0,&x0,&eps); 01078 *w1 = 0.5e0+(0.5e0-*w); 01079 goto S250; 01080 S180: 01081 if(a0 > 15.0e0) goto S190; 01082 n = 20; 01083 *w += bup(&a0,&b0,&x0,&y0,&n,&eps); 01084 a0 += (double)n; 01085 S190: 01086 T4 = 15.0e0*eps; 01087 bgrat(&a0,&b0,&x0,&y0,w,&T4,&ierr1); 01088 *w1 = 0.5e0+(0.5e0-*w); 01089 goto S250; 01090 S200: 01091 T5 = 100.0e0*eps; 01092 *w = basym(&a0,&b0,&lambda,&T5); 01093 *w1 = 0.5e0+(0.5e0-*w); 01094 goto S250; 01095 S210: 01096 /* 01097 TERMINATION OF THE PROCEDURE 01098 */ 01099 if(*a == 0.0e0) goto S320; 01100 S220: 01101 *w = 0.0e0; 01102 *w1 = 1.0e0; 01103 return; 01104 S230: 01105 if(*b == 0.0e0) goto S330; 01106 S240: 01107 *w = 1.0e0; 01108 *w1 = 0.0e0; 01109 return; 01110 S250: 01111 if(ind == 0) return; 01112 t = *w; 01113 *w = *w1; 01114 *w1 = t; 01115 return; 01116 S260: 01117 /* 01118 PROCEDURE FOR A AND B .LT. 1.E-3*EPS 01119 */ 01120 *w = *b/(*a+*b); 01121 *w1 = *a/(*a+*b); 01122 return; 01123 S270: 01124 /* 01125 ERROR RETURN 01126 */ 01127 *ierr = 1; 01128 return; 01129 S280: 01130 *ierr = 2; 01131 return; 01132 S290: 01133 *ierr = 3; 01134 return; 01135 S300: 01136 *ierr = 4; 01137 return; 01138 S310: 01139 *ierr = 5; 01140 return; 01141 S320: 01142 *ierr = 6; 01143 return; 01144 S330: 01145 *ierr = 7; 01146 return; 01147 } /* END */ 01148 01149 /***=====================================================================***/ 01150 static double brcmp1(int *mu,double *a,double *b,double *x,double *y) 01151 /* 01152 ----------------------------------------------------------------------- 01153 EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) 01154 ----------------------------------------------------------------------- 01155 */ 01156 { 01157 static double Const = .398942280401433e0; 01158 static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; 01159 static int i,n; 01160 /* 01161 ----------------- 01162 CONST = 1/SQRT(2*PI) 01163 ----------------- 01164 */ 01165 static double T1,T2,T3,T4; 01166 /* 01167 .. 01168 .. Executable Statements .. 01169 */ 01170 a0 = fifdmin1(*a,*b); 01171 if(a0 >= 8.0e0) goto S130; 01172 if(*x > 0.375e0) goto S10; 01173 lnx = log(*x); 01174 T1 = -*x; 01175 lny = alnrel(&T1); 01176 goto S30; 01177 S10: 01178 if(*y > 0.375e0) goto S20; 01179 T2 = -*y; 01180 lnx = alnrel(&T2); 01181 lny = log(*y); 01182 goto S30; 01183 S20: 01184 lnx = log(*x); 01185 lny = log(*y); 01186 S30: 01187 z = *a*lnx+*b*lny; 01188 if(a0 < 1.0e0) goto S40; 01189 z -= betaln(a,b); 01190 brcmp1 = esum(mu,&z); 01191 return brcmp1; 01192 S40: 01193 /* 01194 ----------------------------------------------------------------------- 01195 PROCEDURE FOR A .LT. 1 OR B .LT. 1 01196 ----------------------------------------------------------------------- 01197 */ 01198 b0 = fifdmax1(*a,*b); 01199 if(b0 >= 8.0e0) goto S120; 01200 if(b0 > 1.0e0) goto S70; 01201 /* 01202 ALGORITHM FOR B0 .LE. 1 01203 */ 01204 brcmp1 = esum(mu,&z); 01205 if(brcmp1 == 0.0e0) return brcmp1; 01206 apb = *a+*b; 01207 if(apb > 1.0e0) goto S50; 01208 z = 1.0e0+gam1(&apb); 01209 goto S60; 01210 S50: 01211 u = *a+*b-1.e0; 01212 z = (1.0e0+gam1(&u))/apb; 01213 S60: 01214 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; 01215 brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0); 01216 return brcmp1; 01217 S70: 01218 /* 01219 ALGORITHM FOR 1 .LT. B0 .LT. 8 01220 */ 01221 u = gamln1(&a0); 01222 n = b0-1.0e0; 01223 if(n < 1) goto S90; 01224 c = 1.0e0; 01225 for(i=1; i<=n; i++) { 01226 b0 -= 1.0e0; 01227 c *= (b0/(a0+b0)); 01228 } 01229 u = log(c)+u; 01230 S90: 01231 z -= u; 01232 b0 -= 1.0e0; 01233 apb = a0+b0; 01234 if(apb > 1.0e0) goto S100; 01235 t = 1.0e0+gam1(&apb); 01236 goto S110; 01237 S100: 01238 u = a0+b0-1.e0; 01239 t = (1.0e0+gam1(&u))/apb; 01240 S110: 01241 brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t; 01242 return brcmp1; 01243 S120: 01244 /* 01245 ALGORITHM FOR B0 .GE. 8 01246 */ 01247 u = gamln1(&a0)+algdiv(&a0,&b0); 01248 T3 = z-u; 01249 brcmp1 = a0*esum(mu,&T3); 01250 return brcmp1; 01251 S130: 01252 /* 01253 ----------------------------------------------------------------------- 01254 PROCEDURE FOR A .GE. 8 AND B .GE. 8 01255 ----------------------------------------------------------------------- 01256 */ 01257 if(*a > *b) goto S140; 01258 h = *a/ *b; 01259 x0 = h/(1.0e0+h); 01260 y0 = 1.0e0/(1.0e0+h); 01261 lambda = *a-(*a+*b)**x; 01262 goto S150; 01263 S140: 01264 h = *b/ *a; 01265 x0 = 1.0e0/(1.0e0+h); 01266 y0 = h/(1.0e0+h); 01267 lambda = (*a+*b)**y-*b; 01268 S150: 01269 e = -(lambda/ *a); 01270 if(fabs(e) > 0.6e0) goto S160; 01271 u = rlog1(&e); 01272 goto S170; 01273 S160: 01274 u = e-log(*x/x0); 01275 S170: 01276 e = lambda/ *b; 01277 if(fabs(e) > 0.6e0) goto S180; 01278 v = rlog1(&e); 01279 goto S190; 01280 S180: 01281 v = e-log(*y/y0); 01282 S190: 01283 T4 = -(*a*u+*b*v); 01284 z = esum(mu,&T4); 01285 brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); 01286 return brcmp1; 01287 } /* END */ 01288 01289 /***=====================================================================***/ 01290 static double brcomp(double *a,double *b,double *x,double *y) 01291 /* 01292 ----------------------------------------------------------------------- 01293 EVALUATION OF X**A*Y**B/BETA(A,B) 01294 ----------------------------------------------------------------------- 01295 */ 01296 { 01297 static double Const = .398942280401433e0; 01298 static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; 01299 static int i,n; 01300 /* 01301 ----------------- 01302 CONST = 1/SQRT(2*PI) 01303 ----------------- 01304 */ 01305 static double T1,T2; 01306 /* 01307 .. 01308 .. Executable Statements .. 01309 */ 01310 brcomp = 0.0e0; 01311 if(*x == 0.0e0 || *y == 0.0e0) return brcomp; 01312 a0 = fifdmin1(*a,*b); 01313 if(a0 >= 8.0e0) goto S130; 01314 if(*x > 0.375e0) goto S10; 01315 lnx = log(*x); 01316 T1 = -*x; 01317 lny = alnrel(&T1); 01318 goto S30; 01319 S10: 01320 if(*y > 0.375e0) goto S20; 01321 T2 = -*y; 01322 lnx = alnrel(&T2); 01323 lny = log(*y); 01324 goto S30; 01325 S20: 01326 lnx = log(*x); 01327 lny = log(*y); 01328 S30: 01329 z = *a*lnx+*b*lny; 01330 if(a0 < 1.0e0) goto S40; 01331 z -= betaln(a,b); 01332 brcomp = exp(z); 01333 return brcomp; 01334 S40: 01335 /* 01336 ----------------------------------------------------------------------- 01337 PROCEDURE FOR A .LT. 1 OR B .LT. 1 01338 ----------------------------------------------------------------------- 01339 */ 01340 b0 = fifdmax1(*a,*b); 01341 if(b0 >= 8.0e0) goto S120; 01342 if(b0 > 1.0e0) goto S70; 01343 /* 01344 ALGORITHM FOR B0 .LE. 1 01345 */ 01346 brcomp = exp(z); 01347 if(brcomp == 0.0e0) return brcomp; 01348 apb = *a+*b; 01349 if(apb > 1.0e0) goto S50; 01350 z = 1.0e0+gam1(&apb); 01351 goto S60; 01352 S50: 01353 u = *a+*b-1.e0; 01354 z = (1.0e0+gam1(&u))/apb; 01355 S60: 01356 c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; 01357 brcomp = brcomp*(a0*c)/(1.0e0+a0/b0); 01358 return brcomp; 01359 S70: 01360 /* 01361 ALGORITHM FOR 1 .LT. B0 .LT. 8 01362 */ 01363 u = gamln1(&a0); 01364 n = b0-1.0e0; 01365 if(n < 1) goto S90; 01366 c = 1.0e0; 01367 for(i=1; i<=n; i++) { 01368 b0 -= 1.0e0; 01369 c *= (b0/(a0+b0)); 01370 } 01371 u = log(c)+u; 01372 S90: 01373 z -= u; 01374 b0 -= 1.0e0; 01375 apb = a0+b0; 01376 if(apb > 1.0e0) goto S100; 01377 t = 1.0e0+gam1(&apb); 01378 goto S110; 01379 S100: 01380 u = a0+b0-1.e0; 01381 t = (1.0e0+gam1(&u))/apb; 01382 S110: 01383 brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t; 01384 return brcomp; 01385 S120: 01386 /* 01387 ALGORITHM FOR B0 .GE. 8 01388 */ 01389 u = gamln1(&a0)+algdiv(&a0,&b0); 01390 brcomp = a0*exp(z-u); 01391 return brcomp; 01392 S130: 01393 /* 01394 ----------------------------------------------------------------------- 01395 PROCEDURE FOR A .GE. 8 AND B .GE. 8 01396 ----------------------------------------------------------------------- 01397 */ 01398 if(*a > *b) goto S140; 01399 h = *a/ *b; 01400 x0 = h/(1.0e0+h); 01401 y0 = 1.0e0/(1.0e0+h); 01402 lambda = *a-(*a+*b)**x; 01403 goto S150; 01404 S140: 01405 h = *b/ *a; 01406 x0 = 1.0e0/(1.0e0+h); 01407 y0 = h/(1.0e0+h); 01408 lambda = (*a+*b)**y-*b; 01409 S150: 01410 e = -(lambda/ *a); 01411 if(fabs(e) > 0.6e0) goto S160; 01412 u = rlog1(&e); 01413 goto S170; 01414 S160: 01415 u = e-log(*x/x0); 01416 S170: 01417 e = lambda/ *b; 01418 if(fabs(e) > 0.6e0) goto S180; 01419 v = rlog1(&e); 01420 goto S190; 01421 S180: 01422 v = e-log(*y/y0); 01423 S190: 01424 z = exp(-(*a*u+*b*v)); 01425 brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); 01426 return brcomp; 01427 } /* END */ 01428 01429 /***=====================================================================***/ 01430 static double bup(double *a,double *b,double *x,double *y,int *n,double *eps) 01431 /* 01432 ----------------------------------------------------------------------- 01433 EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. 01434 EPS IS THE TOLERANCE USED. 01435 ----------------------------------------------------------------------- 01436 */ 01437 { 01438 static int K1 = 1; 01439 static int K2 = 0; 01440 static double bup,ap1,apb,d,l,r,t,w; 01441 static int i,k,kp1,mu,nm1; 01442 /* 01443 .. 01444 .. Executable Statements .. 01445 */ 01446 /* 01447 OBTAIN THE SCALING FACTOR EXP(-MU) AND 01448 EXP(MU)*(X**A*Y**B/BETA(A,B))/A 01449 */ 01450 apb = *a+*b; 01451 ap1 = *a+1.0e0; 01452 mu = 0; 01453 d = 1.0e0; 01454 if(*n == 1 || *a < 1.0e0) goto S10; 01455 if(apb < 1.1e0*ap1) goto S10; 01456 mu = fabs(exparg(&K1)); 01457 k = exparg(&K2); 01458 if(k < mu) mu = k; 01459 t = mu; 01460 d = exp(-t); 01461 S10: 01462 bup = brcmp1(&mu,a,b,x,y)/ *a; 01463 if(*n == 1 || bup == 0.0e0) return bup; 01464 nm1 = *n-1; 01465 w = d; 01466 /* 01467 LET K BE THE INDEX OF THE MAXIMUM TERM 01468 */ 01469 k = 0; 01470 if(*b <= 1.0e0) goto S50; 01471 if(*y > 1.e-4) goto S20; 01472 k = nm1; 01473 goto S30; 01474 S20: 01475 r = (*b-1.0e0)**x/ *y-*a; 01476 if(r < 1.0e0) goto S50; 01477 k = t = nm1; 01478 if(r < t) k = r; 01479 S30: 01480 /* 01481 ADD THE INCREASING TERMS OF THE SERIES 01482 */ 01483 for(i=1; i<=k; i++) { 01484 l = i-1; 01485 d = (apb+l)/(ap1+l)**x*d; 01486 w += d; 01487 } 01488 if(k == nm1) goto S70; 01489 S50: 01490 /* 01491 ADD THE REMAINING TERMS OF THE SERIES 01492 */ 01493 kp1 = k+1; 01494 for(i=kp1; i<=nm1; i++) { 01495 l = i-1; 01496 d = (apb+l)/(ap1+l)**x*d; 01497 w += d; 01498 if(d <= *eps*w) goto S70; 01499 } 01500 S70: 01501 /* 01502 TERMINATE THE PROCEDURE 01503 */ 01504 bup *= w; 01505 return bup; 01506 } /* END */ 01507 01508 /***=====================================================================***/ 01509 static void cdfbet(int *which,double *p,double *q,double *x,double *y, 01510 double *a,double *b,int *status,double *bound) 01511 /********************************************************************** 01512 01513 void cdfbet(int *which,double *p,double *q,double *x,double *y, 01514 double *a,double *b,int *status,double *bound) 01515 01516 Cumulative Distribution Function 01517 BETa Distribution 01518 01519 01520 Function 01521 01522 01523 Calculates any one parameter of the beta distribution given 01524 values for the others. 01525 01526 01527 Arguments 01528 01529 01530 WHICH --> Integer indicating which of the next four argument 01531 values is to be calculated from the others. 01532 Legal range: 1..4 01533 iwhich = 1 : Calculate P and Q from X,Y,A and B 01534 iwhich = 2 : Calculate X and Y from P,Q,A and B 01535 iwhich = 3 : Calculate A from P,Q,X,Y and B 01536 iwhich = 4 : Calculate B from P,Q,X,Y and A 01537 01538 P <--> The integral from 0 to X of the chi-square 01539 distribution. 01540 Input range: [0, 1]. 01541 01542 Q <--> 1-P. 01543 Input range: [0, 1]. 01544 P + Q = 1.0. 01545 01546 X <--> Upper limit of integration of beta density. 01547 Input range: [0,1]. 01548 Search range: [0,1] 01549 01550 Y <--> 1-X. 01551 Input range: [0,1]. 01552 Search range: [0,1] 01553 X + Y = 1.0. 01554 01555 A <--> The first parameter of the beta density. 01556 Input range: (0, +infinity). 01557 Search range: [1D-300,1D300] 01558 01559 B <--> The second parameter of the beta density. 01560 Input range: (0, +infinity). 01561 Search range: [1D-300,1D300] 01562 01563 STATUS <-- 0 if calculation completed correctly 01564 -I if input parameter number I is out of range 01565 1 if answer appears to be lower than lowest 01566 search bound 01567 2 if answer appears to be higher than greatest 01568 search bound 01569 3 if P + Q .ne. 1 01570 4 if X + Y .ne. 1 01571 01572 BOUND <-- Undefined if STATUS is 0 01573 01574 Bound exceeded by parameter number I if STATUS 01575 is negative. 01576 01577 Lower search bound if STATUS is 1. 01578 01579 Upper search bound if STATUS is 2. 01580 01581 01582 Method 01583 01584 01585 Cumulative distribution function (P) is calculated directly by 01586 code associated with the following reference. 01587 01588 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant 01589 Digit Computation of the Incomplete Beta Function Ratios. ACM 01590 Trans. Math. Softw. 18 (1993), 360-373. 01591 01592 Computation of other parameters involve a seach for a value that 01593 produces the desired value of P. The search relies on the 01594 monotinicity of P with the other parameter. 01595 01596 01597 Note 01598 01599 01600 The beta density is proportional to 01601 t^(A-1) * (1-t)^(B-1) 01602 01603 **********************************************************************/ 01604 { 01605 #define tol (1.0e-8) 01606 #define atol (1.0e-50) 01607 #define zero (1.0e-300) 01608 #define inf 1.0e300 01609 #define one 1.0e0 01610 static int K1 = 1; 01611 static double K2 = 0.0e0; 01612 static double K3 = 1.0e0; 01613 static double K8 = 0.5e0; 01614 static double K9 = 5.0e0; 01615 static double fx,xhi,xlo,cum,ccum,xy,pq; 01616 static unsigned long qhi,qleft,qporq; 01617 static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15; 01618 /* 01619 .. 01620 .. Executable Statements .. 01621 */ 01622 /* 01623 Check arguments 01624 */ 01625 if(!(*which < 1 || *which > 4)) goto S30; 01626 if(!(*which < 1)) goto S10; 01627 *bound = 1.0e0; 01628 goto S20; 01629 S10: 01630 *bound = 4.0e0; 01631 S20: 01632 *status = -1; 01633 return; 01634 S30: 01635 if(*which == 1) goto S70; 01636 /* 01637 P 01638 */ 01639 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 01640 if(!(*p < 0.0e0)) goto S40; 01641 *bound = 0.0e0; 01642 goto S50; 01643 S40: 01644 *bound = 1.0e0; 01645 S50: 01646 *status = -2; 01647 return; 01648 S70: 01649 S60: 01650 if(*which == 1) goto S110; 01651 /* 01652 Q 01653 */ 01654 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; 01655 if(!(*q < 0.0e0)) goto S80; 01656 *bound = 0.0e0; 01657 goto S90; 01658 S80: 01659 *bound = 1.0e0; 01660 S90: 01661 *status = -3; 01662 return; 01663 S110: 01664 S100: 01665 if(*which == 2) goto S150; 01666 /* 01667 X 01668 */ 01669 if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140; 01670 if(!(*x < 0.0e0)) goto S120; 01671 *bound = 0.0e0; 01672 goto S130; 01673 S120: 01674 *bound = 1.0e0; 01675 S130: 01676 *status = -4; 01677 return; 01678 S150: 01679 S140: 01680 if(*which == 2) goto S190; 01681 /* 01682 Y 01683 */ 01684 if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180; 01685 if(!(*y < 0.0e0)) goto S160; 01686 *bound = 0.0e0; 01687 goto S170; 01688 S160: 01689 *bound = 1.0e0; 01690 S170: 01691 *status = -5; 01692 return; 01693 S190: 01694 S180: 01695 if(*which == 3) goto S210; 01696 /* 01697 A 01698 */ 01699 if(!(*a <= 0.0e0)) goto S200; 01700 *bound = 0.0e0; 01701 *status = -6; 01702 return; 01703 S210: 01704 S200: 01705 if(*which == 4) goto S230; 01706 /* 01707 B 01708 */ 01709 if(!(*b <= 0.0e0)) goto S220; 01710 *bound = 0.0e0; 01711 *status = -7; 01712 return; 01713 S230: 01714 S220: 01715 if(*which == 1) goto S270; 01716 /* 01717 P + Q 01718 */ 01719 pq = *p+*q; 01720 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; 01721 if(!(pq < 0.0e0)) goto S240; 01722 *bound = 0.0e0; 01723 goto S250; 01724 S240: 01725 *bound = 1.0e0; 01726 S250: 01727 *status = 3; 01728 return; 01729 S270: 01730 S260: 01731 if(*which == 2) goto S310; 01732 /* 01733 X + Y 01734 */ 01735 xy = *x+*y; 01736 if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; 01737 if(!(xy < 0.0e0)) goto S280; 01738 *bound = 0.0e0; 01739 goto S290; 01740 S280: 01741 *bound = 1.0e0; 01742 S290: 01743 *status = 4; 01744 return; 01745 S310: 01746 S300: 01747 if(!(*which == 1)) qporq = *p <= *q; 01748 /* 01749 Select the minimum of P or Q 01750 Calculate ANSWERS 01751 */ 01752 if(1 == *which) { 01753 /* 01754 Calculating P and Q 01755 */ 01756 cumbet(x,y,a,b,p,q); 01757 *status = 0; 01758 } 01759 else if(2 == *which) { 01760 /* 01761 Calculating X and Y 01762 */ 01763 T4 = atol; 01764 T5 = tol; 01765 dstzr(&K2,&K3,&T4,&T5); 01766 if(!qporq) goto S340; 01767 *status = 0; 01768 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); 01769 *y = one-*x; 01770 S320: 01771 if(!(*status == 1)) goto S330; 01772 cumbet(x,y,a,b,&cum,&ccum); 01773 fx = cum-*p; 01774 dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); 01775 *y = one-*x; 01776 goto S320; 01777 S330: 01778 goto S370; 01779 S340: 01780 *status = 0; 01781 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); 01782 *x = one-*y; 01783 S350: 01784 if(!(*status == 1)) goto S360; 01785 cumbet(x,y,a,b,&cum,&ccum); 01786 fx = ccum-*q; 01787 dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); 01788 *x = one-*y; 01789 goto S350; 01790 S370: 01791 S360: 01792 if(!(*status == -1)) goto S400; 01793 if(!qleft) goto S380; 01794 *status = 1; 01795 *bound = 0.0e0; 01796 goto S390; 01797 S380: 01798 *status = 2; 01799 *bound = 1.0e0; 01800 S400: 01801 S390: 01802 ; 01803 } 01804 else if(3 == *which) { 01805 /* 01806 Computing A 01807 */ 01808 *a = 5.0e0; 01809 T6 = zero; 01810 T7 = inf; 01811 T10 = atol; 01812 T11 = tol; 01813 dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11); 01814 *status = 0; 01815 dinvr(status,a,&fx,&qleft,&qhi); 01816 S410: 01817 if(!(*status == 1)) goto S440; 01818 cumbet(x,y,a,b,&cum,&ccum); 01819 if(!qporq) goto S420; 01820 fx = cum-*p; 01821 goto S430; 01822 S420: 01823 fx = ccum-*q; 01824 S430: 01825 dinvr(status,a,&fx,&qleft,&qhi); 01826 goto S410; 01827 S440: 01828 if(!(*status == -1)) goto S470; 01829 if(!qleft) goto S450; 01830 *status = 1; 01831 *bound = zero; 01832 goto S460; 01833 S450: 01834 *status = 2; 01835 *bound = inf; 01836 S470: 01837 S460: 01838 ; 01839 } 01840 else if(4 == *which) { 01841 /* 01842 Computing B 01843 */ 01844 *b = 5.0e0; 01845 T12 = zero; 01846 T13 = inf; 01847 T14 = atol; 01848 T15 = tol; 01849 dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15); 01850 *status = 0; 01851 dinvr(status,b,&fx,&qleft,&qhi); 01852 S480: 01853 if(!(*status == 1)) goto S510; 01854 cumbet(x,y,a,b,&cum,&ccum); 01855 if(!qporq) goto S490; 01856 fx = cum-*p; 01857 goto S500; 01858 S490: 01859 fx = ccum-*q; 01860 S500: 01861 dinvr(status,b,&fx,&qleft,&qhi); 01862 goto S480; 01863 S510: 01864 if(!(*status == -1)) goto S540; 01865 if(!qleft) goto S520; 01866 *status = 1; 01867 *bound = zero; 01868 goto S530; 01869 S520: 01870 *status = 2; 01871 *bound = inf; 01872 S530: 01873 ; 01874 } 01875 S540: 01876 return; 01877 #undef tol 01878 #undef atol 01879 #undef zero 01880 #undef inf 01881 #undef one 01882 } /* END */ 01883 01884 /***=====================================================================***/ 01885 static void cdfbin(int *which,double *p,double *q,double *s,double *xn, 01886 double *pr,double *ompr,int *status,double *bound) 01887 /********************************************************************** 01888 01889 void cdfbin(int *which,double *p,double *q,double *s,double *xn, 01890 double *pr,double *ompr,int *status,double *bound) 01891 01892 Cumulative Distribution Function 01893 BINomial distribution 01894 01895 01896 Function 01897 01898 01899 Calculates any one parameter of the binomial 01900 distribution given values for the others. 01901 01902 01903 Arguments 01904 01905 01906 WHICH --> Integer indicating which of the next four argument 01907 values is to be calculated from the others. 01908 Legal range: 1..4 01909 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR 01910 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR 01911 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR 01912 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN 01913 01914 P <--> The cumulation from 0 to S of the binomial distribution. 01915 (Probablility of S or fewer successes in XN trials each 01916 with probability of success PR.) 01917 Input range: [0,1]. 01918 01919 Q <--> 1-P. 01920 Input range: [0, 1]. 01921 P + Q = 1.0. 01922 01923 S <--> The number of successes observed. 01924 Input range: [0, XN] 01925 Search range: [0, XN] 01926 01927 XN <--> The number of binomial trials. 01928 Input range: (0, +infinity). 01929 Search range: [1E-300, 1E300] 01930 01931 PR <--> The probability of success in each binomial trial. 01932 Input range: [0,1]. 01933 Search range: [0,1] 01934 01935 OMPR <--> 1-PR 01936 Input range: [0,1]. 01937 Search range: [0,1] 01938 PR + OMPR = 1.0 01939 01940 STATUS <-- 0 if calculation completed correctly 01941 -I if input parameter number I is out of range 01942 1 if answer appears to be lower than lowest 01943 search bound 01944 2 if answer appears to be higher than greatest 01945 search bound 01946 3 if P + Q .ne. 1 01947 4 if PR + OMPR .ne. 1 01948 01949 BOUND <-- Undefined if STATUS is 0 01950 01951 Bound exceeded by parameter number I if STATUS 01952 is negative. 01953 01954 Lower search bound if STATUS is 1. 01955 01956 Upper search bound if STATUS is 2. 01957 01958 01959 Method 01960 01961 01962 Formula 26.5.24 of Abramowitz and Stegun, Handbook of 01963 Mathematical Functions (1966) is used to reduce the binomial 01964 distribution to the cumulative incomplete beta distribution. 01965 01966 Computation of other parameters involve a seach for a value that 01967 produces the desired value of P. The search relies on the 01968 monotinicity of P with the other parameter. 01969 01970 01971 **********************************************************************/ 01972 { 01973 #define atol (1.0e-50) 01974 #define tol (1.0e-8) 01975 #define zero (1.0e-300) 01976 #define inf 1.0e300 01977 #define one 1.0e0 01978 static int K1 = 1; 01979 static double K2 = 0.0e0; 01980 static double K3 = 0.5e0; 01981 static double K4 = 5.0e0; 01982 static double K11 = 1.0e0; 01983 static double fx,xhi,xlo,cum,ccum,pq,prompr; 01984 static unsigned long qhi,qleft,qporq; 01985 static double T5,T6,T7,T8,T9,T10,T12,T13; 01986 /* 01987 .. 01988 .. Executable Statements .. 01989 */ 01990 /* 01991 Check arguments 01992 */ 01993 if(!(*which < 1 && *which > 4)) goto S30; 01994 if(!(*which < 1)) goto S10; 01995 *bound = 1.0e0; 01996 goto S20; 01997 S10: 01998 *bound = 4.0e0; 01999 S20: 02000 *status = -1; 02001 return; 02002 S30: 02003 if(*which == 1) goto S70; 02004 /* 02005 P 02006 */ 02007 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 02008 if(!(*p < 0.0e0)) goto S40; 02009 *bound = 0.0e0; 02010 goto S50; 02011 S40: 02012 *bound = 1.0e0; 02013 S50: 02014 *status = -2; 02015 return; 02016 S70: 02017 S60: 02018 if(*which == 1) goto S110; 02019 /* 02020 Q 02021 */ 02022 if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; 02023 if(!(*q < 0.0e0)) goto S80; 02024 *bound = 0.0e0; 02025 goto S90; 02026 S80: 02027 *bound = 1.0e0; 02028 S90: 02029 *status = -3; 02030 return; 02031 S110: 02032 S100: 02033 if(*which == 3) goto S130; 02034 /* 02035 XN 02036 */ 02037 if(!(*xn <= 0.0e0)) goto S120; 02038 *bound = 0.0e0; 02039 *status = -5; 02040 return; 02041 S130: 02042 S120: 02043 if(*which == 2) goto S170; 02044 /* 02045 S 02046 */ 02047 if(!(*s < 0.0e0 || *which != 3 && *s > *xn)) goto S160; 02048 if(!(*s < 0.0e0)) goto S140; 02049 *bound = 0.0e0; 02050 goto S150; 02051 S140: 02052 *bound = *xn; 02053 S150: 02054 *status = -4; 02055 return; 02056 S170: 02057 S160: 02058 if(*which == 4) goto S210; 02059 /* 02060 PR 02061 */ 02062 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200; 02063 if(!(*pr < 0.0e0)) goto S180; 02064 *bound = 0.0e0; 02065 goto S190; 02066 S180: 02067 *bound = 1.0e0; 02068 S190: 02069 *status = -6; 02070 return; 02071 S210: 02072 S200: 02073 if(*which == 4) goto S250; 02074 /* 02075 OMPR 02076 */ 02077 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240; 02078 if(!(*ompr < 0.0e0)) goto S220; 02079 *bound = 0.0e0; 02080 goto S230; 02081 S220: 02082 *bound = 1.0e0; 02083 S230: 02084 *status = -7; 02085 return; 02086 S250: 02087 S240: 02088 if(*which == 1) goto S290; 02089 /* 02090 P + Q 02091 */ 02092 pq = *p+*q; 02093 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S280; 02094 if(!(pq < 0.0e0)) goto S260; 02095 *bound = 0.0e0; 02096 goto S270; 02097 S260: 02098 *bound = 1.0e0; 02099 S270: 02100 *status = 3; 02101 return; 02102 S290: 02103 S280: 02104 if(*which == 4) goto S330; 02105 /* 02106 PR + OMPR 02107 */ 02108 prompr = *pr+*ompr; 02109 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S320; 02110 if(!(prompr < 0.0e0)) goto S300; 02111 *bound = 0.0e0; 02112 goto S310; 02113 S300: 02114 *bound = 1.0e0; 02115 S310: 02116 *status = 4; 02117 return; 02118 S330: 02119 S320: 02120 if(!(*which == 1)) qporq = *p <= *q; 02121 /* 02122 Select the minimum of P or Q 02123 Calculate ANSWERS 02124 */ 02125 if(1 == *which) { 02126 /* 02127 Calculating P 02128 */ 02129 cumbin(s,xn,pr,ompr,p,q); 02130 *status = 0; 02131 } 02132 else if(2 == *which) { 02133 /* 02134 Calculating S 02135 */ 02136 *s = 5.0e0; 02137 T5 = atol; 02138 T6 = tol; 02139 dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6); 02140 *status = 0; 02141 dinvr(status,s,&fx,&qleft,&qhi); 02142 S340: 02143 if(!(*status == 1)) goto S370; 02144 cumbin(s,xn,pr,ompr,&cum,&ccum); 02145 if(!qporq) goto S350; 02146 fx = cum-*p; 02147 goto S360; 02148 S350: 02149 fx = ccum-*q; 02150 S360: 02151 dinvr(status,s,&fx,&qleft,&qhi); 02152 goto S340; 02153 S370: 02154 if(!(*status == -1)) goto S400; 02155 if(!qleft) goto S380; 02156 *status = 1; 02157 *bound = 0.0e0; 02158 goto S390; 02159 S380: 02160 *status = 2; 02161 *bound = *xn; 02162 S400: 02163 S390: 02164 ; 02165 } 02166 else if(3 == *which) { 02167 /* 02168 Calculating XN 02169 */ 02170 *xn = 5.0e0; 02171 T7 = zero; 02172 T8 = inf; 02173 T9 = atol; 02174 T10 = tol; 02175 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); 02176 *status = 0; 02177 dinvr(status,xn,&fx,&qleft,&qhi); 02178 S410: 02179 if(!(*status == 1)) goto S440; 02180 cumbin(s,xn,pr,ompr,&cum,&ccum); 02181 if(!qporq) goto S420; 02182 fx = cum-*p; 02183 goto S430; 02184 S420: 02185 fx = ccum-*q; 02186 S430: 02187 dinvr(status,xn,&fx,&qleft,&qhi); 02188 goto S410; 02189 S440: 02190 if(!(*status == -1)) goto S470; 02191 if(!qleft) goto S450; 02192 *status = 1; 02193 *bound = zero; 02194 goto S460; 02195 S450: 02196 *status = 2; 02197 *bound = inf; 02198 S470: 02199 S460: 02200 ; 02201 } 02202 else if(4 == *which) { 02203 /* 02204 Calculating PR and OMPR 02205 */ 02206 T12 = atol; 02207 T13 = tol; 02208 dstzr(&K2,&K11,&T12,&T13); 02209 if(!qporq) goto S500; 02210 *status = 0; 02211 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); 02212 *ompr = one-*pr; 02213 S480: 02214 if(!(*status == 1)) goto S490; 02215 cumbin(s,xn,pr,ompr,&cum,&ccum); 02216 fx = cum-*p; 02217 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); 02218 *ompr = one-*pr; 02219 goto S480; 02220 S490: 02221 goto S530; 02222 S500: 02223 *status = 0; 02224 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); 02225 *pr = one-*ompr; 02226 S510: 02227 if(!(*status == 1)) goto S520; 02228 cumbin(s,xn,pr,ompr,&cum,&ccum); 02229 fx = ccum-*q; 02230 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); 02231 *pr = one-*ompr; 02232 goto S510; 02233 S530: 02234 S520: 02235 if(!(*status == -1)) goto S560; 02236 if(!qleft) goto S540; 02237 *status = 1; 02238 *bound = 0.0e0; 02239 goto S550; 02240 S540: 02241 *status = 2; 02242 *bound = 1.0e0; 02243 S550: 02244 ; 02245 } 02246 S560: 02247 return; 02248 #undef atol 02249 #undef tol 02250 #undef zero 02251 #undef inf 02252 #undef one 02253 } /* END */ 02254 02255 /***=====================================================================***/ 02256 static void cdfchi(int *which,double *p,double *q,double *x,double *df, 02257 int *status,double *bound) 02258 /********************************************************************** 02259 02260 void cdfchi(int *which,double *p,double *q,double *x,double *df, 02261 int *status,double *bound) 02262 02263 Cumulative Distribution Function 02264 CHI-Square distribution 02265 02266 02267 Function 02268 02269 02270 Calculates any one parameter of the chi-square 02271 distribution given values for the others. 02272 02273 02274 Arguments 02275 02276 02277 WHICH --> Integer indicating which of the next three argument 02278 values is to be calculated from the others. 02279 Legal range: 1..3 02280 iwhich = 1 : Calculate P and Q from X and DF 02281 iwhich = 2 : Calculate X from P,Q and DF 02282 iwhich = 3 : Calculate DF from P,Q and X 02283 02284 P <--> The integral from 0 to X of the chi-square 02285 distribution. 02286 Input range: [0, 1]. 02287 02288 Q <--> 1-P. 02289 Input range: (0, 1]. 02290 P + Q = 1.0. 02291 02292 X <--> Upper limit of integration of the non-central 02293 chi-square distribution. 02294 Input range: [0, +infinity). 02295 Search range: [0,1E300] 02296 02297 DF <--> Degrees of freedom of the 02298 chi-square distribution. 02299 Input range: (0, +infinity). 02300 Search range: [ 1E-300, 1E300] 02301 02302 STATUS <-- 0 if calculation completed correctly 02303 -I if input parameter number I is out of range 02304 1 if answer appears to be lower than lowest 02305 search bound 02306 2 if answer appears to be higher than greatest 02307 search bound 02308 3 if P + Q .ne. 1 02309 10 indicates error returned from cumgam. See 02310 references in cdfgam 02311 02312 BOUND <-- Undefined if STATUS is 0 02313 02314 Bound exceeded by parameter number I if STATUS 02315 is negative. 02316 02317 Lower search bound if STATUS is 1. 02318 02319 Upper search bound if STATUS is 2. 02320 02321 02322 Method 02323 02324 02325 Formula 26.4.19 of Abramowitz and Stegun, Handbook of 02326 Mathematical Functions (1966) is used to reduce the chisqure 02327 distribution to the incomplete distribution. 02328 02329 Computation of other parameters involve a seach for a value that 02330 produces the desired value of P. The search relies on the 02331 monotinicity of P with the other parameter. 02332 02333 **********************************************************************/ 02334 { 02335 #define tol (1.0e-8) 02336 #define atol (1.0e-50) 02337 #define zero (1.0e-300) 02338 #define inf 1.0e300 02339 static int K1 = 1; 02340 static double K2 = 0.0e0; 02341 static double K4 = 0.5e0; 02342 static double K5 = 5.0e0; 02343 static double fx,cum,ccum,pq,porq; 02344 static unsigned long qhi,qleft,qporq; 02345 static double T3,T6,T7,T8,T9,T10,T11; 02346 /* 02347 .. 02348 .. Executable Statements .. 02349 */ 02350 /* 02351 Check arguments 02352 */ 02353 if(!(*which < 1 || *which > 3)) goto S30; 02354 if(!(*which < 1)) goto S10; 02355 *bound = 1.0e0; 02356 goto S20; 02357 S10: 02358 *bound = 3.0e0; 02359 S20: 02360 *status = -1; 02361 return; 02362 S30: 02363 if(*which == 1) goto S70; 02364 /* 02365 P 02366 */ 02367 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 02368 if(!(*p < 0.0e0)) goto S40; 02369 *bound = 0.0e0; 02370 goto S50; 02371 S40: 02372 *bound = 1.0e0; 02373 S50: 02374 *status = -2; 02375 return; 02376 S70: 02377 S60: 02378 if(*which == 1) goto S110; 02379 /* 02380 Q 02381 */ 02382 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 02383 if(!(*q <= 0.0e0)) goto S80; 02384 *bound = 0.0e0; 02385 goto S90; 02386 S80: 02387 *bound = 1.0e0; 02388 S90: 02389 *status = -3; 02390 return; 02391 S110: 02392 S100: 02393 if(*which == 2) goto S130; 02394 /* 02395 X 02396 */ 02397 if(!(*x < 0.0e0)) goto S120; 02398 *bound = 0.0e0; 02399 *status = -4; 02400 return; 02401 S130: 02402 S120: 02403 if(*which == 3) goto S150; 02404 /* 02405 DF 02406 */ 02407 if(!(*df <= 0.0e0)) goto S140; 02408 *bound = 0.0e0; 02409 *status = -5; 02410 return; 02411 S150: 02412 S140: 02413 if(*which == 1) goto S190; 02414 /* 02415 P + Q 02416 */ 02417 pq = *p+*q; 02418 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; 02419 if(!(pq < 0.0e0)) goto S160; 02420 *bound = 0.0e0; 02421 goto S170; 02422 S160: 02423 *bound = 1.0e0; 02424 S170: 02425 *status = 3; 02426 return; 02427 S190: 02428 S180: 02429 if(*which == 1) goto S220; 02430 /* 02431 Select the minimum of P or Q 02432 */ 02433 qporq = *p <= *q; 02434 if(!qporq) goto S200; 02435 porq = *p; 02436 goto S210; 02437 S200: 02438 porq = *q; 02439 S220: 02440 S210: 02441 /* 02442 Calculate ANSWERS 02443 */ 02444 if(1 == *which) { 02445 /* 02446 Calculating P and Q 02447 */ 02448 *status = 0; 02449 cumchi(x,df,p,q); 02450 if(porq > 1.5e0) { 02451 *status = 10; 02452 return; 02453 } 02454 } 02455 else if(2 == *which) { 02456 /* 02457 Calculating X 02458 */ 02459 *x = 5.0e0; 02460 T3 = inf; 02461 T6 = atol; 02462 T7 = tol; 02463 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); 02464 *status = 0; 02465 dinvr(status,x,&fx,&qleft,&qhi); 02466 S230: 02467 if(!(*status == 1)) goto S270; 02468 cumchi(x,df,&cum,&ccum); 02469 if(!qporq) goto S240; 02470 fx = cum-*p; 02471 goto S250; 02472 S240: 02473 fx = ccum-*q; 02474 S250: 02475 if(!(fx+porq > 1.5e0)) goto S260; 02476 *status = 10; 02477 return; 02478 S260: 02479 dinvr(status,x,&fx,&qleft,&qhi); 02480 goto S230; 02481 S270: 02482 if(!(*status == -1)) goto S300; 02483 if(!qleft) goto S280; 02484 *status = 1; 02485 *bound = 0.0e0; 02486 goto S290; 02487 S280: 02488 *status = 2; 02489 *bound = inf; 02490 S300: 02491 S290: 02492 ; 02493 } 02494 else if(3 == *which) { 02495 /* 02496 Calculating DF 02497 */ 02498 *df = 5.0e0; 02499 T8 = zero; 02500 T9 = inf; 02501 T10 = atol; 02502 T11 = tol; 02503 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); 02504 *status = 0; 02505 dinvr(status,df,&fx,&qleft,&qhi); 02506 S310: 02507 if(!(*status == 1)) goto S350; 02508 cumchi(x,df,&cum,&ccum); 02509 if(!qporq) goto S320; 02510 fx = cum-*p; 02511 goto S330; 02512 S320: 02513 fx = ccum-*q; 02514 S330: 02515 if(!(fx+porq > 1.5e0)) goto S340; 02516 *status = 10; 02517 return; 02518 S340: 02519 dinvr(status,df,&fx,&qleft,&qhi); 02520 goto S310; 02521 S350: 02522 if(!(*status == -1)) goto S380; 02523 if(!qleft) goto S360; 02524 *status = 1; 02525 *bound = zero; 02526 goto S370; 02527 S360: 02528 *status = 2; 02529 *bound = inf; 02530 S370: 02531 ; 02532 } 02533 S380: 02534 return; 02535 #undef tol 02536 #undef atol 02537 #undef zero 02538 #undef inf 02539 } /* END */ 02540 02541 /***=====================================================================***/ 02542 static void cdfchn(int *which,double *p,double *q,double *x,double *df, 02543 double *pnonc,int *status,double *bound) 02544 /********************************************************************** 02545 02546 void cdfchn(int *which,double *p,double *q,double *x,double *df, 02547 double *pnonc,int *status,double *bound) 02548 02549 Cumulative Distribution Function 02550 Non-central Chi-Square 02551 02552 02553 Function 02554 02555 02556 Calculates any one parameter of the non-central chi-square 02557 distribution given values for the others. 02558 02559 02560 Arguments 02561 02562 02563 WHICH --> Integer indicating which of the next three argument 02564 values is to be calculated from the others. 02565 Input range: 1..4 02566 iwhich = 1 : Calculate P and Q from X and DF 02567 iwhich = 2 : Calculate X from P,DF and PNONC 02568 iwhich = 3 : Calculate DF from P,X and PNONC 02569 iwhich = 3 : Calculate PNONC from P,X and DF 02570 02571 P <--> The integral from 0 to X of the non-central chi-square 02572 distribution. 02573 Input range: [0, 1-1E-16). 02574 02575 Q <--> 1-P. 02576 Q is not used by this subroutine and is only included 02577 for similarity with other cdf* routines. 02578 02579 X <--> Upper limit of integration of the non-central 02580 chi-square distribution. 02581 Input range: [0, +infinity). 02582 Search range: [0,1E300] 02583 02584 DF <--> Degrees of freedom of the non-central 02585 chi-square distribution. 02586 Input range: (0, +infinity). 02587 Search range: [ 1E-300, 1E300] 02588 02589 PNONC <--> Non-centrality parameter of the non-central 02590 chi-square distribution. 02591 Input range: [0, +infinity). 02592 Search range: [0,1E4] 02593 02594 STATUS <-- 0 if calculation completed correctly 02595 -I if input parameter number I is out of range 02596 1 if answer appears to be lower than lowest 02597 search bound 02598 2 if answer appears to be higher than greatest 02599 search bound 02600 02601 BOUND <-- Undefined if STATUS is 0 02602 02603 Bound exceeded by parameter number I if STATUS 02604 is negative. 02605 02606 Lower search bound if STATUS is 1. 02607 02608 Upper search bound if STATUS is 2. 02609 02610 02611 Method 02612 02613 02614 Formula 26.4.25 of Abramowitz and Stegun, Handbook of 02615 Mathematical Functions (1966) is used to compute the cumulative 02616 distribution function. 02617 02618 Computation of other parameters involve a seach for a value that 02619 produces the desired value of P. The search relies on the 02620 monotinicity of P with the other parameter. 02621 02622 02623 WARNING 02624 02625 The computation time required for this routine is proportional 02626 to the noncentrality parameter (PNONC). Very large values of 02627 this parameter can consume immense computer resources. This is 02628 why the search range is bounded by 10,000. 02629 02630 **********************************************************************/ 02631 { 02632 #define tent4 1.0e4 02633 #define tol (1.0e-8) 02634 #define atol (1.0e-50) 02635 #define zero (1.0e-300) 02636 #define one (1.0e0-1.0e-16) 02637 #define inf 1.0e300 02638 static double K1 = 0.0e0; 02639 static double K3 = 0.5e0; 02640 static double K4 = 5.0e0; 02641 static double fx,cum,ccum; 02642 static unsigned long qhi,qleft; 02643 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13; 02644 /* 02645 .. 02646 .. Executable Statements .. 02647 */ 02648 /* 02649 Check arguments 02650 */ 02651 if(!(*which < 1 || *which > 4)) goto S30; 02652 if(!(*which < 1)) goto S10; 02653 *bound = 1.0e0; 02654 goto S20; 02655 S10: 02656 *bound = 4.0e0; 02657 S20: 02658 *status = -1; 02659 return; 02660 S30: 02661 if(*which == 1) goto S70; 02662 /* 02663 P 02664 */ 02665 if(!(*p < 0.0e0 || *p > one)) goto S60; 02666 if(!(*p < 0.0e0)) goto S40; 02667 *bound = 0.0e0; 02668 goto S50; 02669 S40: 02670 *bound = one; 02671 S50: 02672 *status = -2; 02673 return; 02674 S70: 02675 S60: 02676 if(*which == 2) goto S90; 02677 /* 02678 X 02679 */ 02680 if(!(*x < 0.0e0)) goto S80; 02681 *bound = 0.0e0; 02682 *status = -4; 02683 return; 02684 S90: 02685 S80: 02686 if(*which == 3) goto S110; 02687 /* 02688 DF 02689 */ 02690 if(!(*df <= 0.0e0)) goto S100; 02691 *bound = 0.0e0; 02692 *status = -5; 02693 return; 02694 S110: 02695 S100: 02696 if(*which == 4) goto S130; 02697 /* 02698 PNONC 02699 */ 02700 if(!(*pnonc < 0.0e0)) goto S120; 02701 *bound = 0.0e0; 02702 *status = -6; 02703 return; 02704 S130: 02705 S120: 02706 /* 02707 Calculate ANSWERS 02708 */ 02709 if(1 == *which) { 02710 /* 02711 Calculating P and Q 02712 */ 02713 cumchn(x,df,pnonc,p,q); 02714 *status = 0; 02715 } 02716 else if(2 == *which) { 02717 /* 02718 Calculating X 02719 */ 02720 *x = 5.0e0; 02721 T2 = inf; 02722 T5 = atol; 02723 T6 = tol; 02724 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); 02725 *status = 0; 02726 dinvr(status,x,&fx,&qleft,&qhi); 02727 S140: 02728 if(!(*status == 1)) goto S150; 02729 cumchn(x,df,pnonc,&cum,&ccum); 02730 fx = cum-*p; 02731 dinvr(status,x,&fx,&qleft,&qhi); 02732 goto S140; 02733 S150: 02734 if(!(*status == -1)) goto S180; 02735 if(!qleft) goto S160; 02736 *status = 1; 02737 *bound = 0.0e0; 02738 goto S170; 02739 S160: 02740 *status = 2; 02741 *bound = inf; 02742 S180: 02743 S170: 02744 ; 02745 } 02746 else if(3 == *which) { 02747 /* 02748 Calculating DF 02749 */ 02750 *df = 5.0e0; 02751 T7 = zero; 02752 T8 = inf; 02753 T9 = atol; 02754 T10 = tol; 02755 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); 02756 *status = 0; 02757 dinvr(status,df,&fx,&qleft,&qhi); 02758 S190: 02759 if(!(*status == 1)) goto S200; 02760 cumchn(x,df,pnonc,&cum,&ccum); 02761 fx = cum-*p; 02762 dinvr(status,df,&fx,&qleft,&qhi); 02763 goto S190; 02764 S200: 02765 if(!(*status == -1)) goto S230; 02766 if(!qleft) goto S210; 02767 *status = 1; 02768 *bound = zero; 02769 goto S220; 02770 S210: 02771 *status = 2; 02772 *bound = inf; 02773 S230: 02774 S220: 02775 ; 02776 } 02777 else if(4 == *which) { 02778 /* 02779 Calculating PNONC 02780 */ 02781 *pnonc = 5.0e0; 02782 T11 = tent4; 02783 T12 = atol; 02784 T13 = tol; 02785 dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13); 02786 *status = 0; 02787 dinvr(status,pnonc,&fx,&qleft,&qhi); 02788 S240: 02789 if(!(*status == 1)) goto S250; 02790 cumchn(x,df,pnonc,&cum,&ccum); 02791 fx = cum-*p; 02792 dinvr(status,pnonc,&fx,&qleft,&qhi); 02793 goto S240; 02794 S250: 02795 if(!(*status == -1)) goto S280; 02796 if(!qleft) goto S260; 02797 *status = 1; 02798 *bound = zero; 02799 goto S270; 02800 S260: 02801 *status = 2; 02802 *bound = tent4; 02803 S270: 02804 ; 02805 } 02806 S280: 02807 return; 02808 #undef tent4 02809 #undef tol 02810 #undef atol 02811 #undef zero 02812 #undef one 02813 #undef inf 02814 } /* END */ 02815 02816 /***=====================================================================***/ 02817 static void cdff(int *which,double *p,double *q,double *f,double *dfn, 02818 double *dfd,int *status,double *bound) 02819 /********************************************************************** 02820 02821 void cdff(int *which,double *p,double *q,double *f,double *dfn, 02822 double *dfd,int *status,double *bound) 02823 02824 Cumulative Distribution Function 02825 F distribution 02826 02827 02828 Function 02829 02830 02831 Calculates any one parameter of the F distribution 02832 given values for the others. 02833 02834 02835 Arguments 02836 02837 02838 WHICH --> Integer indicating which of the next four argument 02839 values is to be calculated from the others. 02840 Legal range: 1..4 02841 iwhich = 1 : Calculate P and Q from F,DFN and DFD 02842 iwhich = 2 : Calculate F from P,Q,DFN and DFD 02843 iwhich = 3 : Calculate DFN from P,Q,F and DFD 02844 iwhich = 4 : Calculate DFD from P,Q,F and DFN 02845 02846 P <--> The integral from 0 to F of the f-density. 02847 Input range: [0,1]. 02848 02849 Q <--> 1-P. 02850 Input range: (0, 1]. 02851 P + Q = 1.0. 02852 02853 F <--> Upper limit of integration of the f-density. 02854 Input range: [0, +infinity). 02855 Search range: [0,1E300] 02856 02857 DFN < --> Degrees of freedom of the numerator sum of squares. 02858 Input range: (0, +infinity). 02859 Search range: [ 1E-300, 1E300] 02860 02861 DFD < --> Degrees of freedom of the denominator sum of squares. 02862 Input range: (0, +infinity). 02863 Search range: [ 1E-300, 1E300] 02864 02865 STATUS <-- 0 if calculation completed correctly 02866 -I if input parameter number I is out of range 02867 1 if answer appears to be lower than lowest 02868 search bound 02869 2 if answer appears to be higher than greatest 02870 search bound 02871 3 if P + Q .ne. 1 02872 02873 BOUND <-- Undefined if STATUS is 0 02874 02875 Bound exceeded by parameter number I if STATUS 02876 is negative. 02877 02878 Lower search bound if STATUS is 1. 02879 02880 Upper search bound if STATUS is 2. 02881 02882 02883 Method 02884 02885 02886 Formula 26.6.2 of Abramowitz and Stegun, Handbook of 02887 Mathematical Functions (1966) is used to reduce the computation 02888 of the cumulative distribution function for the F variate to 02889 that of an incomplete beta. 02890 02891 Computation of other parameters involve a seach for a value that 02892 produces the desired value of P. The search relies on the 02893 monotinicity of P with the other parameter. 02894 02895 WARNING 02896 02897 The value of the cumulative F distribution is not necessarily 02898 monotone in either degrees of freedom. There thus may be two 02899 values that provide a given CDF value. This routine assumes 02900 monotonicity and will find an arbitrary one of the two values. 02901 02902 **********************************************************************/ 02903 { 02904 #define tol (1.0e-8) 02905 #define atol (1.0e-50) 02906 #define zero (1.0e-300) 02907 #define inf 1.0e300 02908 static int K1 = 1; 02909 static double K2 = 0.0e0; 02910 static double K4 = 0.5e0; 02911 static double K5 = 5.0e0; 02912 static double pq,fx,cum,ccum; 02913 static unsigned long qhi,qleft,qporq; 02914 static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15; 02915 /* 02916 .. 02917 .. Executable Statements .. 02918 */ 02919 /* 02920 Check arguments 02921 */ 02922 if(!(*which < 1 || *which > 4)) goto S30; 02923 if(!(*which < 1)) goto S10; 02924 *bound = 1.0e0; 02925 goto S20; 02926 S10: 02927 *bound = 4.0e0; 02928 S20: 02929 *status = -1; 02930 return; 02931 S30: 02932 if(*which == 1) goto S70; 02933 /* 02934 P 02935 */ 02936 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 02937 if(!(*p < 0.0e0)) goto S40; 02938 *bound = 0.0e0; 02939 goto S50; 02940 S40: 02941 *bound = 1.0e0; 02942 S50: 02943 *status = -2; 02944 return; 02945 S70: 02946 S60: 02947 if(*which == 1) goto S110; 02948 /* 02949 Q 02950 */ 02951 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 02952 if(!(*q <= 0.0e0)) goto S80; 02953 *bound = 0.0e0; 02954 goto S90; 02955 S80: 02956 *bound = 1.0e0; 02957 S90: 02958 *status = -3; 02959 return; 02960 S110: 02961 S100: 02962 if(*which == 2) goto S130; 02963 /* 02964 F 02965 */ 02966 if(!(*f < 0.0e0)) goto S120; 02967 *bound = 0.0e0; 02968 *status = -4; 02969 return; 02970 S130: 02971 S120: 02972 if(*which == 3) goto S150; 02973 /* 02974 DFN 02975 */ 02976 if(!(*dfn <= 0.0e0)) goto S140; 02977 *bound = 0.0e0; 02978 *status = -5; 02979 return; 02980 S150: 02981 S140: 02982 if(*which == 4) goto S170; 02983 /* 02984 DFD 02985 */ 02986 if(!(*dfd <= 0.0e0)) goto S160; 02987 *bound = 0.0e0; 02988 *status = -6; 02989 return; 02990 S170: 02991 S160: 02992 if(*which == 1) goto S210; 02993 /* 02994 P + Q 02995 */ 02996 pq = *p+*q; 02997 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; 02998 if(!(pq < 0.0e0)) goto S180; 02999 *bound = 0.0e0; 03000 goto S190; 03001 S180: 03002 *bound = 1.0e0; 03003 S190: 03004 *status = 3; 03005 return; 03006 S210: 03007 S200: 03008 if(!(*which == 1)) qporq = *p <= *q; 03009 /* 03010 Select the minimum of P or Q 03011 Calculate ANSWERS 03012 */ 03013 if(1 == *which) { 03014 /* 03015 Calculating P 03016 */ 03017 cumf(f,dfn,dfd,p,q); 03018 *status = 0; 03019 } 03020 else if(2 == *which) { 03021 /* 03022 Calculating F 03023 */ 03024 *f = 5.0e0; 03025 T3 = inf; 03026 T6 = atol; 03027 T7 = tol; 03028 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); 03029 *status = 0; 03030 dinvr(status,f,&fx,&qleft,&qhi); 03031 S220: 03032 if(!(*status == 1)) goto S250; 03033 cumf(f,dfn,dfd,&cum,&ccum); 03034 if(!qporq) goto S230; 03035 fx = cum-*p; 03036 goto S240; 03037 S230: 03038 fx = ccum-*q; 03039 S240: 03040 dinvr(status,f,&fx,&qleft,&qhi); 03041 goto S220; 03042 S250: 03043 if(!(*status == -1)) goto S280; 03044 if(!qleft) goto S260; 03045 *status = 1; 03046 *bound = 0.0e0; 03047 goto S270; 03048 S260: 03049 *status = 2; 03050 *bound = inf; 03051 S280: 03052 S270: 03053 ; 03054 } 03055 else if(3 == *which) { 03056 /* 03057 Calculating DFN 03058 */ 03059 *dfn = 5.0e0; 03060 T8 = zero; 03061 T9 = inf; 03062 T10 = atol; 03063 T11 = tol; 03064 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); 03065 *status = 0; 03066 dinvr(status,dfn,&fx,&qleft,&qhi); 03067 S290: 03068 if(!(*status == 1)) goto S320; 03069 cumf(f,dfn,dfd,&cum,&ccum); 03070 if(!qporq) goto S300; 03071 fx = cum-*p; 03072 goto S310; 03073 S300: 03074 fx = ccum-*q; 03075 S310: 03076 dinvr(status,dfn,&fx,&qleft,&qhi); 03077 goto S290; 03078 S320: 03079 if(!(*status == -1)) goto S350; 03080 if(!qleft) goto S330; 03081 *status = 1; 03082 *bound = zero; 03083 goto S340; 03084 S330: 03085 *status = 2; 03086 *bound = inf; 03087 S350: 03088 S340: 03089 ; 03090 } 03091 else if(4 == *which) { 03092 /* 03093 Calculating DFD 03094 */ 03095 *dfd = 5.0e0; 03096 T12 = zero; 03097 T13 = inf; 03098 T14 = atol; 03099 T15 = tol; 03100 dstinv(&T12,&T13,&K4,&K4,&K5,&T14,&T15); 03101 *status = 0; 03102 dinvr(status,dfd,&fx,&qleft,&qhi); 03103 S360: 03104 if(!(*status == 1)) goto S390; 03105 cumf(f,dfn,dfd,&cum,&ccum); 03106 if(!qporq) goto S370; 03107 fx = cum-*p; 03108 goto S380; 03109 S370: 03110 fx = ccum-*q; 03111 S380: 03112 dinvr(status,dfd,&fx,&qleft,&qhi); 03113 goto S360; 03114 S390: 03115 if(!(*status == -1)) goto S420; 03116 if(!qleft) goto S400; 03117 *status = 1; 03118 *bound = zero; 03119 goto S410; 03120 S400: 03121 *status = 2; 03122 *bound = inf; 03123 S410: 03124 ; 03125 } 03126 S420: 03127 return; 03128 #undef tol 03129 #undef atol 03130 #undef zero 03131 #undef inf 03132 } /* END */ 03133 03134 /***=====================================================================***/ 03135 static void cdffnc(int *which,double *p,double *q,double *f,double *dfn, 03136 double *dfd,double *phonc,int *status,double *bound) 03137 /********************************************************************** 03138 03139 void cdffnc(int *which,double *p,double *q,double *f,double *dfn, 03140 double *dfd,double *phonc,int *status,double *bound) 03141 03142 Cumulative Distribution Function 03143 Non-central F distribution 03144 03145 03146 Function 03147 03148 03149 Calculates any one parameter of the Non-central F 03150 distribution given values for the others. 03151 03152 03153 Arguments 03154 03155 03156 WHICH --> Integer indicating which of the next five argument 03157 values is to be calculated from the others. 03158 Legal range: 1..5 03159 iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC 03160 iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC 03161 iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC 03162 iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC 03163 iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD 03164 03165 P <--> The integral from 0 to F of the non-central f-density. 03166 Input range: [0,1-1E-16). 03167 03168 Q <--> 1-P. 03169 Q is not used by this subroutine and is only included 03170 for similarity with other cdf* routines. 03171 03172 F <--> Upper limit of integration of the non-central f-density. 03173 Input range: [0, +infinity). 03174 Search range: [0,1E300] 03175 03176 DFN < --> Degrees of freedom of the numerator sum of squares. 03177 Input range: (0, +infinity). 03178 Search range: [ 1E-300, 1E300] 03179 03180 DFD < --> Degrees of freedom of the denominator sum of squares. 03181 Must be in range: (0, +infinity). 03182 Input range: (0, +infinity). 03183 Search range: [ 1E-300, 1E300] 03184 03185 PNONC <-> The non-centrality parameter 03186 Input range: [0,infinity) 03187 Search range: [0,1E4] 03188 03189 STATUS <-- 0 if calculation completed correctly 03190 -I if input parameter number I is out of range 03191 1 if answer appears to be lower than lowest 03192 search bound 03193 2 if answer appears to be higher than greatest 03194 search bound 03195 3 if P + Q .ne. 1 03196 03197 BOUND <-- Undefined if STATUS is 0 03198 03199 Bound exceeded by parameter number I if STATUS 03200 is negative. 03201 03202 Lower search bound if STATUS is 1. 03203 03204 Upper search bound if STATUS is 2. 03205 03206 03207 Method 03208 03209 03210 Formula 26.6.20 of Abramowitz and Stegun, Handbook of 03211 Mathematical Functions (1966) is used to compute the cumulative 03212 distribution function. 03213 03214 Computation of other parameters involve a seach for a value that 03215 produces the desired value of P. The search relies on the 03216 monotinicity of P with the other parameter. 03217 03218 WARNING 03219 03220 The computation time required for this routine is proportional 03221 to the noncentrality parameter (PNONC). Very large values of 03222 this parameter can consume immense computer resources. This is 03223 why the search range is bounded by 10,000. 03224 03225 WARNING 03226 03227 The value of the cumulative noncentral F distribution is not 03228 necessarily monotone in either degrees of freedom. There thus 03229 may be two values that provide a given CDF value. This routine 03230 assumes monotonicity and will find an arbitrary one of the two 03231 values. 03232 03233 **********************************************************************/ 03234 { 03235 #define tent4 1.0e4 03236 #define tol (1.0e-8) 03237 #define atol (1.0e-50) 03238 #define zero (1.0e-300) 03239 #define one (1.0e0-1.0e-16) 03240 #define inf 1.0e300 03241 static double K1 = 0.0e0; 03242 static double K3 = 0.5e0; 03243 static double K4 = 5.0e0; 03244 static double fx,cum,ccum; 03245 static unsigned long qhi,qleft; 03246 static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17; 03247 /* 03248 .. 03249 .. Executable Statements .. 03250 */ 03251 /* 03252 Check arguments 03253 */ 03254 if(!(*which < 1 || *which > 5)) goto S30; 03255 if(!(*which < 1)) goto S10; 03256 *bound = 1.0e0; 03257 goto S20; 03258 S10: 03259 *bound = 5.0e0; 03260 S20: 03261 *status = -1; 03262 return; 03263 S30: 03264 if(*which == 1) goto S70; 03265 /* 03266 P 03267 */ 03268 if(!(*p < 0.0e0 || *p > one)) goto S60; 03269 if(!(*p < 0.0e0)) goto S40; 03270 *bound = 0.0e0; 03271 goto S50; 03272 S40: 03273 *bound = one; 03274 S50: 03275 *status = -2; 03276 return; 03277 S70: 03278 S60: 03279 if(*which == 2) goto S90; 03280 /* 03281 F 03282 */ 03283 if(!(*f < 0.0e0)) goto S80; 03284 *bound = 0.0e0; 03285 *status = -4; 03286 return; 03287 S90: 03288 S80: 03289 if(*which == 3) goto S110; 03290 /* 03291 DFN 03292 */ 03293 if(!(*dfn <= 0.0e0)) goto S100; 03294 *bound = 0.0e0; 03295 *status = -5; 03296 return; 03297 S110: 03298 S100: 03299 if(*which == 4) goto S130; 03300 /* 03301 DFD 03302 */ 03303 if(!(*dfd <= 0.0e0)) goto S120; 03304 *bound = 0.0e0; 03305 *status = -6; 03306 return; 03307 S130: 03308 S120: 03309 if(*which == 5) goto S150; 03310 /* 03311 PHONC 03312 */ 03313 if(!(*phonc < 0.0e0)) goto S140; 03314 *bound = 0.0e0; 03315 *status = -7; 03316 return; 03317 S150: 03318 S140: 03319 /* 03320 Calculate ANSWERS 03321 */ 03322 if(1 == *which) { 03323 /* 03324 Calculating P 03325 */ 03326 cumfnc(f,dfn,dfd,phonc,p,q); 03327 *status = 0; 03328 } 03329 else if(2 == *which) { 03330 /* 03331 Calculating F 03332 */ 03333 *f = 5.0e0; 03334 T2 = inf; 03335 T5 = atol; 03336 T6 = tol; 03337 dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); 03338 *status = 0; 03339 dinvr(status,f,&fx,&qleft,&qhi); 03340 S160: 03341 if(!(*status == 1)) goto S170; 03342 cumfnc(f,dfn,dfd,phonc,&cum,&ccum); 03343 fx = cum-*p; 03344 dinvr(status,f,&fx,&qleft,&qhi); 03345 goto S160; 03346 S170: 03347 if(!(*status == -1)) goto S200; 03348 if(!qleft) goto S180; 03349 *status = 1; 03350 *bound = 0.0e0; 03351 goto S190; 03352 S180: 03353 *status = 2; 03354 *bound = inf; 03355 S200: 03356 S190: 03357 ; 03358 } 03359 else if(3 == *which) { 03360 /* 03361 Calculating DFN 03362 */ 03363 *dfn = 5.0e0; 03364 T7 = zero; 03365 T8 = inf; 03366 T9 = atol; 03367 T10 = tol; 03368 dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); 03369 *status = 0; 03370 dinvr(status,dfn,&fx,&qleft,&qhi); 03371 S210: 03372 if(!(*status == 1)) goto S220; 03373 cumfnc(f,dfn,dfd,phonc,&cum,&ccum); 03374 fx = cum-*p; 03375 dinvr(status,dfn,&fx,&qleft,&qhi); 03376 goto S210; 03377 S220: 03378 if(!(*status == -1)) goto S250; 03379 if(!qleft) goto S230; 03380 *status = 1; 03381 *bound = zero; 03382 goto S240; 03383 S230: 03384 *status = 2; 03385 *bound = inf; 03386 S250: 03387 S240: 03388 ; 03389 } 03390 else if(4 == *which) { 03391 /* 03392 Calculating DFD 03393 */ 03394 *dfd = 5.0e0; 03395 T11 = zero; 03396 T12 = inf; 03397 T13 = atol; 03398 T14 = tol; 03399 dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14); 03400 *status = 0; 03401 dinvr(status,dfd,&fx,&qleft,&qhi); 03402 S260: 03403 if(!(*status == 1)) goto S270; 03404 cumfnc(f,dfn,dfd,phonc,&cum,&ccum); 03405 fx = cum-*p; 03406 dinvr(status,dfd,&fx,&qleft,&qhi); 03407 goto S260; 03408 S270: 03409 if(!(*status == -1)) goto S300; 03410 if(!qleft) goto S280; 03411 *status = 1; 03412 *bound = zero; 03413 goto S290; 03414 S280: 03415 *status = 2; 03416 *bound = inf; 03417 S300: 03418 S290: 03419 ; 03420 } 03421 else if(5 == *which) { 03422 /* 03423 Calculating PHONC 03424 */ 03425 *phonc = 5.0e0; 03426 T15 = tent4; 03427 T16 = atol; 03428 T17 = tol; 03429 dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17); 03430 *status = 0; 03431 dinvr(status,phonc,&fx,&qleft,&qhi); 03432 S310: 03433 if(!(*status == 1)) goto S320; 03434 cumfnc(f,dfn,dfd,phonc,&cum,&ccum); 03435 fx = cum-*p; 03436 dinvr(status,phonc,&fx,&qleft,&qhi); 03437 goto S310; 03438 S320: 03439 if(!(*status == -1)) goto S350; 03440 if(!qleft) goto S330; 03441 *status = 1; 03442 *bound = 0.0e0; 03443 goto S340; 03444 S330: 03445 *status = 2; 03446 *bound = tent4; 03447 S340: 03448 ; 03449 } 03450 S350: 03451 return; 03452 #undef tent4 03453 #undef tol 03454 #undef atol 03455 #undef zero 03456 #undef one 03457 #undef inf 03458 } /* END */ 03459 03460 /***=====================================================================***/ 03461 static void cdfgam(int *which,double *p,double *q,double *x,double *shape, 03462 double *scale,int *status,double *bound) 03463 /********************************************************************** 03464 03465 void cdfgam(int *which,double *p,double *q,double *x,double *shape, 03466 double *scale,int *status,double *bound) 03467 03468 Cumulative Distribution Function 03469 GAMma Distribution 03470 03471 03472 Function 03473 03474 03475 Calculates any one parameter of the gamma 03476 distribution given values for the others. 03477 03478 03479 Arguments 03480 03481 03482 WHICH --> Integer indicating which of the next four argument 03483 values is to be calculated from the others. 03484 Legal range: 1..4 03485 iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE 03486 iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE 03487 iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE 03488 iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE 03489 03490 P <--> The integral from 0 to X of the gamma density. 03491 Input range: [0,1]. 03492 03493 Q <--> 1-P. 03494 Input range: (0, 1]. 03495 P + Q = 1.0. 03496 03497 X <--> The upper limit of integration of the gamma density. 03498 Input range: [0, +infinity). 03499 Search range: [0,1E300] 03500 03501 SHAPE <--> The shape parameter of the gamma density. 03502 Input range: (0, +infinity). 03503 Search range: [1E-300,1E300] 03504 03505 SCALE <--> The scale parameter of the gamma density. 03506 Input range: (0, +infinity). 03507 Search range: (1E-300,1E300] 03508 03509 STATUS <-- 0 if calculation completed correctly 03510 -I if input parameter number I is out of range 03511 1 if answer appears to be lower than lowest 03512 search bound 03513 2 if answer appears to be higher than greatest 03514 search bound 03515 3 if P + Q .ne. 1 03516 10 if the gamma or inverse gamma routine cannot 03517 compute the answer. Usually happens only for 03518 X and SHAPE very large (gt 1E10 or more) 03519 03520 BOUND <-- Undefined if STATUS is 0 03521 03522 Bound exceeded by parameter number I if STATUS 03523 is negative. 03524 03525 Lower search bound if STATUS is 1. 03526 03527 Upper search bound if STATUS is 2. 03528 03529 03530 Method 03531 03532 03533 Cumulative distribution function (P) is calculated directly by 03534 the code associated with: 03535 03536 DiDinato, A. R. and Morris, A. H. Computation of the incomplete 03537 gamma function ratios and their inverse. ACM Trans. Math. 03538 Softw. 12 (1986), 377-393. 03539 03540 Computation of other parameters involve a seach for a value that 03541 produces the desired value of P. The search relies on the 03542 monotinicity of P with the other parameter. 03543 03544 03545 Note 03546 03547 03548 03549 The gamma density is proportional to 03550 T**(SHAPE - 1) * EXP(- SCALE * T) 03551 03552 **********************************************************************/ 03553 { 03554 #define tol (1.0e-8) 03555 #define atol (1.0e-50) 03556 #define zero (1.0e-300) 03557 #define inf 1.0e300 03558 static int K1 = 1; 03559 static double K5 = 0.5e0; 03560 static double K6 = 5.0e0; 03561 static double xx,fx,xscale,cum,ccum,pq,porq; 03562 static int ierr; 03563 static unsigned long qhi,qleft,qporq; 03564 static double T2,T3,T4,T7,T8,T9; 03565 /* 03566 .. 03567 .. Executable Statements .. 03568 */ 03569 /* 03570 Check arguments 03571 */ 03572 if(!(*which < 1 || *which > 4)) goto S30; 03573 if(!(*which < 1)) goto S10; 03574 *bound = 1.0e0; 03575 goto S20; 03576 S10: 03577 *bound = 4.0e0; 03578 S20: 03579 *status = -1; 03580 return; 03581 S30: 03582 if(*which == 1) goto S70; 03583 /* 03584 P 03585 */ 03586 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 03587 if(!(*p < 0.0e0)) goto S40; 03588 *bound = 0.0e0; 03589 goto S50; 03590 S40: 03591 *bound = 1.0e0; 03592 S50: 03593 *status = -2; 03594 return; 03595 S70: 03596 S60: 03597 if(*which == 1) goto S110; 03598 /* 03599 Q 03600 */ 03601 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 03602 if(!(*q <= 0.0e0)) goto S80; 03603 *bound = 0.0e0; 03604 goto S90; 03605 S80: 03606 *bound = 1.0e0; 03607 S90: 03608 *status = -3; 03609 return; 03610 S110: 03611 S100: 03612 if(*which == 2) goto S130; 03613 /* 03614 X 03615 */ 03616 if(!(*x < 0.0e0)) goto S120; 03617 *bound = 0.0e0; 03618 *status = -4; 03619 return; 03620 S130: 03621 S120: 03622 if(*which == 3) goto S150; 03623 /* 03624 SHAPE 03625 */ 03626 if(!(*shape <= 0.0e0)) goto S140; 03627 *bound = 0.0e0; 03628 *status = -5; 03629 return; 03630 S150: 03631 S140: 03632 if(*which == 4) goto S170; 03633 /* 03634 SCALE 03635 */ 03636 if(!(*scale <= 0.0e0)) goto S160; 03637 *bound = 0.0e0; 03638 *status = -6; 03639 return; 03640 S170: 03641 S160: 03642 if(*which == 1) goto S210; 03643 /* 03644 P + Q 03645 */ 03646 pq = *p+*q; 03647 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; 03648 if(!(pq < 0.0e0)) goto S180; 03649 *bound = 0.0e0; 03650 goto S190; 03651 S180: 03652 *bound = 1.0e0; 03653 S190: 03654 *status = 3; 03655 return; 03656 S210: 03657 S200: 03658 if(*which == 1) goto S240; 03659 /* 03660 Select the minimum of P or Q 03661 */ 03662 qporq = *p <= *q; 03663 if(!qporq) goto S220; 03664 porq = *p; 03665 goto S230; 03666 S220: 03667 porq = *q; 03668 S240: 03669 S230: 03670 /* 03671 Calculate ANSWERS 03672 */ 03673 if(1 == *which) { 03674 /* 03675 Calculating P 03676 */ 03677 *status = 0; 03678 xscale = *x**scale; 03679 cumgam(&xscale,shape,p,q); 03680 if(porq > 1.5e0) *status = 10; 03681 } 03682 else if(2 == *which) { 03683 /* 03684 Computing X 03685 */ 03686 T2 = -1.0e0; 03687 gaminv(shape,&xx,&T2,p,q,&ierr); 03688 if(ierr < 0.0e0) { 03689 *status = 10; 03690 return; 03691 } 03692 else { 03693 *x = xx/ *scale; 03694 *status = 0; 03695 } 03696 } 03697 else if(3 == *which) { 03698 /* 03699 Computing SHAPE 03700 */ 03701 *shape = 5.0e0; 03702 xscale = *x**scale; 03703 T3 = zero; 03704 T4 = inf; 03705 T7 = atol; 03706 T8 = tol; 03707 dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8); 03708 *status = 0; 03709 dinvr(status,shape,&fx,&qleft,&qhi); 03710 S250: 03711 if(!(*status == 1)) goto S290; 03712 cumgam(&xscale,shape,&cum,&ccum); 03713 if(!qporq) goto S260; 03714 fx = cum-*p; 03715 goto S270; 03716 S260: 03717 fx = ccum-*q; 03718 S270: 03719 if(!(qporq && cum > 1.5e0 || !qporq && ccum > 1.5e0)) goto S280; 03720 *status = 10; 03721 return; 03722 S280: 03723 dinvr(status,shape,&fx,&qleft,&qhi); 03724 goto S250; 03725 S290: 03726 if(!(*status == -1)) goto S320; 03727 if(!qleft) goto S300; 03728 *status = 1; 03729 *bound = zero; 03730 goto S310; 03731 S300: 03732 *status = 2; 03733 *bound = inf; 03734 S320: 03735 S310: 03736 ; 03737 } 03738 else if(4 == *which) { 03739 /* 03740 Computing SCALE 03741 */ 03742 T9 = -1.0e0; 03743 gaminv(shape,&xx,&T9,p,q,&ierr); 03744 if(ierr < 0.0e0) { 03745 *status = 10; 03746 return; 03747 } 03748 else { 03749 *scale = xx/ *x; 03750 *status = 0; 03751 } 03752 } 03753 return; 03754 #undef tol 03755 #undef atol 03756 #undef zero 03757 #undef inf 03758 } /* END */ 03759 03760 /***=====================================================================***/ 03761 static void cdfnbn(int *which,double *p,double *q,double *s,double *xn, 03762 double *pr,double *ompr,int *status,double *bound) 03763 /********************************************************************** 03764 03765 void cdfnbn(int *which,double *p,double *q,double *s,double *xn, 03766 double *pr,double *ompr,int *status,double *bound) 03767 03768 Cumulative Distribution Function 03769 Negative BiNomial distribution 03770 03771 03772 Function 03773 03774 03775 Calculates any one parameter of the negative binomial 03776 distribution given values for the others. 03777 03778 The cumulative negative binomial distribution returns the 03779 probability that there will be F or fewer failures before the 03780 XNth success in binomial trials each of which has probability of 03781 success PR. 03782 03783 The individual term of the negative binomial is the probability of 03784 S failures before XN successes and is 03785 Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S 03786 03787 03788 Arguments 03789 03790 03791 WHICH --> Integer indicating which of the next four argument 03792 values is to be calculated from the others. 03793 Legal range: 1..4 03794 iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR 03795 iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR 03796 iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR 03797 iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN 03798 03799 P <--> The cumulation from 0 to S of the negative 03800 binomial distribution. 03801 Input range: [0,1]. 03802 03803 Q <--> 1-P. 03804 Input range: (0, 1]. 03805 P + Q = 1.0. 03806 03807 S <--> The upper limit of cumulation of the binomial distribution. 03808 There are F or fewer failures before the XNth success. 03809 Input range: [0, +infinity). 03810 Search range: [0, 1E300] 03811 03812 XN <--> The number of successes. 03813 Input range: [0, +infinity). 03814 Search range: [0, 1E300] 03815 03816 PR <--> The probability of success in each binomial trial. 03817 Input range: [0,1]. 03818 Search range: [0,1]. 03819 03820 OMPR <--> 1-PR 03821 Input range: [0,1]. 03822 Search range: [0,1] 03823 PR + OMPR = 1.0 03824 03825 STATUS <-- 0 if calculation completed correctly 03826 -I if input parameter number I is out of range 03827 1 if answer appears to be lower than lowest 03828 search bound 03829 2 if answer appears to be higher than greatest 03830 search bound 03831 3 if P + Q .ne. 1 03832 4 if PR + OMPR .ne. 1 03833 03834 BOUND <-- Undefined if STATUS is 0 03835 03836 Bound exceeded by parameter number I if STATUS 03837 is negative. 03838 03839 Lower search bound if STATUS is 1. 03840 03841 Upper search bound if STATUS is 2. 03842 03843 03844 Method 03845 03846 03847 Formula 26.5.26 of Abramowitz and Stegun, Handbook of 03848 Mathematical Functions (1966) is used to reduce calculation of 03849 the cumulative distribution function to that of an incomplete 03850 beta. 03851 03852 Computation of other parameters involve a seach for a value that 03853 produces the desired value of P. The search relies on the 03854 monotinicity of P with the other parameter. 03855 03856 **********************************************************************/ 03857 { 03858 #define tol (1.0e-8) 03859 #define atol (1.0e-50) 03860 #define inf 1.0e300 03861 #define one 1.0e0 03862 static int K1 = 1; 03863 static double K2 = 0.0e0; 03864 static double K4 = 0.5e0; 03865 static double K5 = 5.0e0; 03866 static double K11 = 1.0e0; 03867 static double fx,xhi,xlo,pq,prompr,cum,ccum; 03868 static unsigned long qhi,qleft,qporq; 03869 static double T3,T6,T7,T8,T9,T10,T12,T13; 03870 /* 03871 .. 03872 .. Executable Statements .. 03873 */ 03874 /* 03875 Check arguments 03876 */ 03877 if(!(*which < 1 || *which > 4)) goto S30; 03878 if(!(*which < 1)) goto S10; 03879 *bound = 1.0e0; 03880 goto S20; 03881 S10: 03882 *bound = 4.0e0; 03883 S20: 03884 *status = -1; 03885 return; 03886 S30: 03887 if(*which == 1) goto S70; 03888 /* 03889 P 03890 */ 03891 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 03892 if(!(*p < 0.0e0)) goto S40; 03893 *bound = 0.0e0; 03894 goto S50; 03895 S40: 03896 *bound = 1.0e0; 03897 S50: 03898 *status = -2; 03899 return; 03900 S70: 03901 S60: 03902 if(*which == 1) goto S110; 03903 /* 03904 Q 03905 */ 03906 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 03907 if(!(*q <= 0.0e0)) goto S80; 03908 *bound = 0.0e0; 03909 goto S90; 03910 S80: 03911 *bound = 1.0e0; 03912 S90: 03913 *status = -3; 03914 return; 03915 S110: 03916 S100: 03917 if(*which == 2) goto S130; 03918 /* 03919 S 03920 */ 03921 if(!(*s < 0.0e0)) goto S120; 03922 *bound = 0.0e0; 03923 *status = -4; 03924 return; 03925 S130: 03926 S120: 03927 if(*which == 3) goto S150; 03928 /* 03929 XN 03930 */ 03931 if(!(*xn < 0.0e0)) goto S140; 03932 *bound = 0.0e0; 03933 *status = -5; 03934 return; 03935 S150: 03936 S140: 03937 if(*which == 4) goto S190; 03938 /* 03939 PR 03940 */ 03941 if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180; 03942 if(!(*pr < 0.0e0)) goto S160; 03943 *bound = 0.0e0; 03944 goto S170; 03945 S160: 03946 *bound = 1.0e0; 03947 S170: 03948 *status = -6; 03949 return; 03950 S190: 03951 S180: 03952 if(*which == 4) goto S230; 03953 /* 03954 OMPR 03955 */ 03956 if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220; 03957 if(!(*ompr < 0.0e0)) goto S200; 03958 *bound = 0.0e0; 03959 goto S210; 03960 S200: 03961 *bound = 1.0e0; 03962 S210: 03963 *status = -7; 03964 return; 03965 S230: 03966 S220: 03967 if(*which == 1) goto S270; 03968 /* 03969 P + Q 03970 */ 03971 pq = *p+*q; 03972 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; 03973 if(!(pq < 0.0e0)) goto S240; 03974 *bound = 0.0e0; 03975 goto S250; 03976 S240: 03977 *bound = 1.0e0; 03978 S250: 03979 *status = 3; 03980 return; 03981 S270: 03982 S260: 03983 if(*which == 4) goto S310; 03984 /* 03985 PR + OMPR 03986 */ 03987 prompr = *pr+*ompr; 03988 if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; 03989 if(!(prompr < 0.0e0)) goto S280; 03990 *bound = 0.0e0; 03991 goto S290; 03992 S280: 03993 *bound = 1.0e0; 03994 S290: 03995 *status = 4; 03996 return; 03997 S310: 03998 S300: 03999 if(!(*which == 1)) qporq = *p <= *q; 04000 /* 04001 Select the minimum of P or Q 04002 Calculate ANSWERS 04003 */ 04004 if(1 == *which) { 04005 /* 04006 Calculating P 04007 */ 04008 cumnbn(s,xn,pr,ompr,p,q); 04009 *status = 0; 04010 } 04011 else if(2 == *which) { 04012 /* 04013 Calculating S 04014 */ 04015 *s = 5.0e0; 04016 T3 = inf; 04017 T6 = atol; 04018 T7 = tol; 04019 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); 04020 *status = 0; 04021 dinvr(status,s,&fx,&qleft,&qhi); 04022 S320: 04023 if(!(*status == 1)) goto S350; 04024 cumnbn(s,xn,pr,ompr,&cum,&ccum); 04025 if(!qporq) goto S330; 04026 fx = cum-*p; 04027 goto S340; 04028 S330: 04029 fx = ccum-*q; 04030 S340: 04031 dinvr(status,s,&fx,&qleft,&qhi); 04032 goto S320; 04033 S350: 04034 if(!(*status == -1)) goto S380; 04035 if(!qleft) goto S360; 04036 *status = 1; 04037 *bound = 0.0e0; 04038 goto S370; 04039 S360: 04040 *status = 2; 04041 *bound = inf; 04042 S380: 04043 S370: 04044 ; 04045 } 04046 else if(3 == *which) { 04047 /* 04048 Calculating XN 04049 */ 04050 *xn = 5.0e0; 04051 T8 = inf; 04052 T9 = atol; 04053 T10 = tol; 04054 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); 04055 *status = 0; 04056 dinvr(status,xn,&fx,&qleft,&qhi); 04057 S390: 04058 if(!(*status == 1)) goto S420; 04059 cumnbn(s,xn,pr,ompr,&cum,&ccum); 04060 if(!qporq) goto S400; 04061 fx = cum-*p; 04062 goto S410; 04063 S400: 04064 fx = ccum-*q; 04065 S410: 04066 dinvr(status,xn,&fx,&qleft,&qhi); 04067 goto S390; 04068 S420: 04069 if(!(*status == -1)) goto S450; 04070 if(!qleft) goto S430; 04071 *status = 1; 04072 *bound = 0.0e0; 04073 goto S440; 04074 S430: 04075 *status = 2; 04076 *bound = inf; 04077 S450: 04078 S440: 04079 ; 04080 } 04081 else if(4 == *which) { 04082 /* 04083 Calculating PR and OMPR 04084 */ 04085 T12 = atol; 04086 T13 = tol; 04087 dstzr(&K2,&K11,&T12,&T13); 04088 if(!qporq) goto S480; 04089 *status = 0; 04090 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); 04091 *ompr = one-*pr; 04092 S460: 04093 if(!(*status == 1)) goto S470; 04094 cumnbn(s,xn,pr,ompr,&cum,&ccum); 04095 fx = cum-*p; 04096 dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); 04097 *ompr = one-*pr; 04098 goto S460; 04099 S470: 04100 goto S510; 04101 S480: 04102 *status = 0; 04103 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); 04104 *pr = one-*ompr; 04105 S490: 04106 if(!(*status == 1)) goto S500; 04107 cumnbn(s,xn,pr,ompr,&cum,&ccum); 04108 fx = ccum-*q; 04109 dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); 04110 *pr = one-*ompr; 04111 goto S490; 04112 S510: 04113 S500: 04114 if(!(*status == -1)) goto S540; 04115 if(!qleft) goto S520; 04116 *status = 1; 04117 *bound = 0.0e0; 04118 goto S530; 04119 S520: 04120 *status = 2; 04121 *bound = 1.0e0; 04122 S530: 04123 ; 04124 } 04125 S540: 04126 return; 04127 #undef tol 04128 #undef atol 04129 #undef inf 04130 #undef one 04131 } /* END */ 04132 04133 /***=====================================================================***/ 04134 static void cdfnor(int *which,double *p,double *q,double *x,double *mean, 04135 double *sd,int *status,double *bound) 04136 /********************************************************************** 04137 04138 void cdfnor(int *which,double *p,double *q,double *x,double *mean, 04139 double *sd,int *status,double *bound) 04140 04141 Cumulative Distribution Function 04142 NORmal distribution 04143 04144 04145 Function 04146 04147 04148 Calculates any one parameter of the normal 04149 distribution given values for the others. 04150 04151 04152 Arguments 04153 04154 04155 WHICH --> Integer indicating which of the next parameter 04156 values is to be calculated using values of the others. 04157 Legal range: 1..4 04158 iwhich = 1 : Calculate P and Q from X,MEAN and SD 04159 iwhich = 2 : Calculate X from P,Q,MEAN and SD 04160 iwhich = 3 : Calculate MEAN from P,Q,X and SD 04161 iwhich = 4 : Calculate SD from P,Q,X and MEAN 04162 04163 P <--> The integral from -infinity to X of the normal density. 04164 Input range: (0,1]. 04165 04166 Q <--> 1-P. 04167 Input range: (0, 1]. 04168 P + Q = 1.0. 04169 04170 X < --> Upper limit of integration of the normal-density. 04171 Input range: ( -infinity, +infinity) 04172 04173 MEAN <--> The mean of the normal density. 04174 Input range: (-infinity, +infinity) 04175 04176 SD <--> Standard Deviation of the normal density. 04177 Input range: (0, +infinity). 04178 04179 STATUS <-- 0 if calculation completed correctly 04180 -I if input parameter number I is out of range 04181 1 if answer appears to be lower than lowest 04182 search bound 04183 2 if answer appears to be higher than greatest 04184 search bound 04185 3 if P + Q .ne. 1 04186 04187 BOUND <-- Undefined if STATUS is 0 04188 04189 Bound exceeded by parameter number I if STATUS 04190 is negative. 04191 04192 Lower search bound if STATUS is 1. 04193 04194 Upper search bound if STATUS is 2. 04195 04196 04197 Method 04198 04199 04200 04201 04202 A slightly modified version of ANORM from 04203 04204 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN 04205 Package of Special Function Routines and Test Drivers" 04206 acm Transactions on Mathematical Software. 19, 22-32. 04207 04208 is used to calulate the cumulative standard normal distribution. 04209 04210 The rational functions from pages 90-95 of Kennedy and Gentle, 04211 Statistical Computing, Marcel Dekker, NY, 1980 are used as 04212 starting values to Newton's Iterations which compute the inverse 04213 standard normal. Therefore no searches are necessary for any 04214 parameter. 04215 04216 For X < -15, the asymptotic expansion for the normal is used as 04217 the starting value in finding the inverse standard normal. 04218 This is formula 26.2.12 of Abramowitz and Stegun. 04219 04220 04221 Note 04222 04223 04224 The normal density is proportional to 04225 exp( - 0.5 * (( X - MEAN)/SD)**2) 04226 04227 **********************************************************************/ 04228 { 04229 static int K1 = 1; 04230 static double z,pq; 04231 /* 04232 .. 04233 .. Executable Statements .. 04234 */ 04235 /* 04236 Check arguments 04237 */ 04238 *status = 0; 04239 if(!(*which < 1 || *which > 4)) goto S30; 04240 if(!(*which < 1)) goto S10; 04241 *bound = 1.0e0; 04242 goto S20; 04243 S10: 04244 *bound = 4.0e0; 04245 S20: 04246 *status = -1; 04247 return; 04248 S30: 04249 if(*which == 1) goto S70; 04250 /* 04251 P 04252 */ 04253 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; 04254 if(!(*p <= 0.0e0)) goto S40; 04255 *bound = 0.0e0; 04256 goto S50; 04257 S40: 04258 *bound = 1.0e0; 04259 S50: 04260 *status = -2; 04261 return; 04262 S70: 04263 S60: 04264 if(*which == 1) goto S110; 04265 /* 04266 Q 04267 */ 04268 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 04269 if(!(*q <= 0.0e0)) goto S80; 04270 *bound = 0.0e0; 04271 goto S90; 04272 S80: 04273 *bound = 1.0e0; 04274 S90: 04275 *status = -3; 04276 return; 04277 S110: 04278 S100: 04279 if(*which == 1) goto S150; 04280 /* 04281 P + Q 04282 */ 04283 pq = *p+*q; 04284 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S140; 04285 if(!(pq < 0.0e0)) goto S120; 04286 *bound = 0.0e0; 04287 goto S130; 04288 S120: 04289 *bound = 1.0e0; 04290 S130: 04291 *status = 3; 04292 return; 04293 S150: 04294 S140: 04295 if(*which == 4) goto S170; 04296 /* 04297 SD 04298 */ 04299 if(!(*sd <= 0.0e0)) goto S160; 04300 *bound = 0.0e0; 04301 *status = -6; 04302 return; 04303 S170: 04304 S160: 04305 /* 04306 Calculate ANSWERS 04307 */ 04308 if(1 == *which) { 04309 /* 04310 Computing P 04311 */ 04312 z = (*x-*mean)/ *sd; 04313 cumnor(&z,p,q); 04314 } 04315 else if(2 == *which) { 04316 /* 04317 Computing X 04318 */ 04319 z = dinvnr(p,q); 04320 *x = *sd*z+*mean; 04321 } 04322 else if(3 == *which) { 04323 /* 04324 Computing the MEAN 04325 */ 04326 z = dinvnr(p,q); 04327 *mean = *x-*sd*z; 04328 } 04329 else if(4 == *which) { 04330 /* 04331 Computing SD 04332 */ 04333 z = dinvnr(p,q); 04334 *sd = (*x-*mean)/z; 04335 } 04336 return; 04337 } /* END */ 04338 04339 /***=====================================================================***/ 04340 static void cdfpoi(int *which,double *p,double *q,double *s,double *xlam, 04341 int *status,double *bound) 04342 /********************************************************************** 04343 04344 void cdfpoi(int *which,double *p,double *q,double *s,double *xlam, 04345 int *status,double *bound) 04346 04347 Cumulative Distribution Function 04348 POIsson distribution 04349 04350 04351 Function 04352 04353 04354 Calculates any one parameter of the Poisson 04355 distribution given values for the others. 04356 04357 04358 Arguments 04359 04360 04361 WHICH --> Integer indicating which argument 04362 value is to be calculated from the others. 04363 Legal range: 1..3 04364 iwhich = 1 : Calculate P and Q from S and XLAM 04365 iwhich = 2 : Calculate A from P,Q and XLAM 04366 iwhich = 3 : Calculate XLAM from P,Q and S 04367 04368 P <--> The cumulation from 0 to S of the poisson density. 04369 Input range: [0,1]. 04370 04371 Q <--> 1-P. 04372 Input range: (0, 1]. 04373 P + Q = 1.0. 04374 04375 S <--> Upper limit of cumulation of the Poisson. 04376 Input range: [0, +infinity). 04377 Search range: [0,1E300] 04378 04379 XLAM <--> Mean of the Poisson distribution. 04380 Input range: [0, +infinity). 04381 Search range: [0,1E300] 04382 04383 STATUS <-- 0 if calculation completed correctly 04384 -I if input parameter number I is out of range 04385 1 if answer appears to be lower than lowest 04386 search bound 04387 2 if answer appears to be higher than greatest 04388 search bound 04389 3 if P + Q .ne. 1 04390 04391 BOUND <-- Undefined if STATUS is 0 04392 04393 Bound exceeded by parameter number I if STATUS 04394 is negative. 04395 04396 Lower search bound if STATUS is 1. 04397 04398 Upper search bound if STATUS is 2. 04399 04400 04401 Method 04402 04403 04404 Formula 26.4.21 of Abramowitz and Stegun, Handbook of 04405 Mathematical Functions (1966) is used to reduce the computation 04406 of the cumulative distribution function to that of computing a 04407 chi-square, hence an incomplete gamma function. 04408 04409 Cumulative distribution function (P) is calculated directly. 04410 Computation of other parameters involve a seach for a value that 04411 produces the desired value of P. The search relies on the 04412 monotinicity of P with the other parameter. 04413 04414 **********************************************************************/ 04415 { 04416 #define tol (1.0e-8) 04417 #define atol (1.0e-50) 04418 #define inf 1.0e300 04419 static int K1 = 1; 04420 static double K2 = 0.0e0; 04421 static double K4 = 0.5e0; 04422 static double K5 = 5.0e0; 04423 static double fx,cum,ccum,pq; 04424 static unsigned long qhi,qleft,qporq; 04425 static double T3,T6,T7,T8,T9,T10; 04426 /* 04427 .. 04428 .. Executable Statements .. 04429 */ 04430 /* 04431 Check arguments 04432 */ 04433 if(!(*which < 1 || *which > 3)) goto S30; 04434 if(!(*which < 1)) goto S10; 04435 *bound = 1.0e0; 04436 goto S20; 04437 S10: 04438 *bound = 3.0e0; 04439 S20: 04440 *status = -1; 04441 return; 04442 S30: 04443 if(*which == 1) goto S70; 04444 /* 04445 P 04446 */ 04447 if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; 04448 if(!(*p < 0.0e0)) goto S40; 04449 *bound = 0.0e0; 04450 goto S50; 04451 S40: 04452 *bound = 1.0e0; 04453 S50: 04454 *status = -2; 04455 return; 04456 S70: 04457 S60: 04458 if(*which == 1) goto S110; 04459 /* 04460 Q 04461 */ 04462 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 04463 if(!(*q <= 0.0e0)) goto S80; 04464 *bound = 0.0e0; 04465 goto S90; 04466 S80: 04467 *bound = 1.0e0; 04468 S90: 04469 *status = -3; 04470 return; 04471 S110: 04472 S100: 04473 if(*which == 2) goto S130; 04474 /* 04475 S 04476 */ 04477 if(!(*s < 0.0e0)) goto S120; 04478 *bound = 0.0e0; 04479 *status = -4; 04480 return; 04481 S130: 04482 S120: 04483 if(*which == 3) goto S150; 04484 /* 04485 XLAM 04486 */ 04487 if(!(*xlam < 0.0e0)) goto S140; 04488 *bound = 0.0e0; 04489 *status = -5; 04490 return; 04491 S150: 04492 S140: 04493 if(*which == 1) goto S190; 04494 /* 04495 P + Q 04496 */ 04497 pq = *p+*q; 04498 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; 04499 if(!(pq < 0.0e0)) goto S160; 04500 *bound = 0.0e0; 04501 goto S170; 04502 S160: 04503 *bound = 1.0e0; 04504 S170: 04505 *status = 3; 04506 return; 04507 S190: 04508 S180: 04509 if(!(*which == 1)) qporq = *p <= *q; 04510 /* 04511 Select the minimum of P or Q 04512 Calculate ANSWERS 04513 */ 04514 if(1 == *which) { 04515 /* 04516 Calculating P 04517 */ 04518 cumpoi(s,xlam,p,q); 04519 *status = 0; 04520 } 04521 else if(2 == *which) { 04522 /* 04523 Calculating S 04524 */ 04525 *s = 5.0e0; 04526 T3 = inf; 04527 T6 = atol; 04528 T7 = tol; 04529 dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); 04530 *status = 0; 04531 dinvr(status,s,&fx,&qleft,&qhi); 04532 S200: 04533 if(!(*status == 1)) goto S230; 04534 cumpoi(s,xlam,&cum,&ccum); 04535 if(!qporq) goto S210; 04536 fx = cum-*p; 04537 goto S220; 04538 S210: 04539 fx = ccum-*q; 04540 S220: 04541 dinvr(status,s,&fx,&qleft,&qhi); 04542 goto S200; 04543 S230: 04544 if(!(*status == -1)) goto S260; 04545 if(!qleft) goto S240; 04546 *status = 1; 04547 *bound = 0.0e0; 04548 goto S250; 04549 S240: 04550 *status = 2; 04551 *bound = inf; 04552 S260: 04553 S250: 04554 ; 04555 } 04556 else if(3 == *which) { 04557 /* 04558 Calculating XLAM 04559 */ 04560 *xlam = 5.0e0; 04561 T8 = inf; 04562 T9 = atol; 04563 T10 = tol; 04564 dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); 04565 *status = 0; 04566 dinvr(status,xlam,&fx,&qleft,&qhi); 04567 S270: 04568 if(!(*status == 1)) goto S300; 04569 cumpoi(s,xlam,&cum,&ccum); 04570 if(!qporq) goto S280; 04571 fx = cum-*p; 04572 goto S290; 04573 S280: 04574 fx = ccum-*q; 04575 S290: 04576 dinvr(status,xlam,&fx,&qleft,&qhi); 04577 goto S270; 04578 S300: 04579 if(!(*status == -1)) goto S330; 04580 if(!qleft) goto S310; 04581 *status = 1; 04582 *bound = 0.0e0; 04583 goto S320; 04584 S310: 04585 *status = 2; 04586 *bound = inf; 04587 S320: 04588 ; 04589 } 04590 S330: 04591 return; 04592 #undef tol 04593 #undef atol 04594 #undef inf 04595 } /* END */ 04596 04597 /***=====================================================================***/ 04598 static void cdft(int *which,double *p,double *q,double *t,double *df, 04599 int *status,double *bound) 04600 /********************************************************************** 04601 04602 void cdft(int *which,double *p,double *q,double *t,double *df, 04603 int *status,double *bound) 04604 04605 Cumulative Distribution Function 04606 T distribution 04607 04608 04609 Function 04610 04611 04612 Calculates any one parameter of the t distribution given 04613 values for the others. 04614 04615 04616 Arguments 04617 04618 04619 WHICH --> Integer indicating which argument 04620 values is to be calculated from the others. 04621 Legal range: 1..3 04622 iwhich = 1 : Calculate P and Q from T and DF 04623 iwhich = 2 : Calculate T from P,Q and DF 04624 iwhich = 3 : Calculate DF from P,Q and T 04625 04626 P <--> The integral from -infinity to t of the t-density. 04627 Input range: (0,1]. 04628 04629 Q <--> 1-P. 04630 Input range: (0, 1]. 04631 P + Q = 1.0. 04632 04633 T <--> Upper limit of integration of the t-density. 04634 Input range: ( -infinity, +infinity). 04635 Search range: [ -1E300, 1E300 ] 04636 04637 DF <--> Degrees of freedom of the t-distribution. 04638 Input range: (0 , +infinity). 04639 Search range: [1e-300, 1E10] 04640 04641 STATUS <-- 0 if calculation completed correctly 04642 -I if input parameter number I is out of range 04643 1 if answer appears to be lower than lowest 04644 search bound 04645 2 if answer appears to be higher than greatest 04646 search bound 04647 3 if P + Q .ne. 1 04648 04649 BOUND <-- Undefined if STATUS is 0 04650 04651 Bound exceeded by parameter number I if STATUS 04652 is negative. 04653 04654 Lower search bound if STATUS is 1. 04655 04656 Upper search bound if STATUS is 2. 04657 04658 04659 Method 04660 04661 04662 Formula 26.5.27 of Abramowitz and Stegun, Handbook of 04663 Mathematical Functions (1966) is used to reduce the computation 04664 of the cumulative distribution function to that of an incomplete 04665 beta. 04666 04667 Computation of other parameters involve a seach for a value that 04668 produces the desired value of P. The search relies on the 04669 monotinicity of P with the other parameter. 04670 04671 **********************************************************************/ 04672 { 04673 #define tol (1.0e-8) 04674 #define atol (1.0e-50) 04675 #define zero (1.0e-300) 04676 #define inf 1.0e300 04677 #define maxdf 1.0e10 04678 static int K1 = 1; 04679 static double K4 = 0.5e0; 04680 static double K5 = 5.0e0; 04681 static double fx,cum,ccum,pq; 04682 static unsigned long qhi,qleft,qporq; 04683 static double T2,T3,T6,T7,T8,T9,T10,T11; 04684 /* 04685 .. 04686 .. Executable Statements .. 04687 */ 04688 /* 04689 Check arguments 04690 */ 04691 if(!(*which < 1 || *which > 3)) goto S30; 04692 if(!(*which < 1)) goto S10; 04693 *bound = 1.0e0; 04694 goto S20; 04695 S10: 04696 *bound = 3.0e0; 04697 S20: 04698 *status = -1; 04699 return; 04700 S30: 04701 if(*which == 1) goto S70; 04702 /* 04703 P 04704 */ 04705 if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; 04706 if(!(*p <= 0.0e0)) goto S40; 04707 *bound = 0.0e0; 04708 goto S50; 04709 S40: 04710 *bound = 1.0e0; 04711 S50: 04712 *status = -2; 04713 return; 04714 S70: 04715 S60: 04716 if(*which == 1) goto S110; 04717 /* 04718 Q 04719 */ 04720 if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; 04721 if(!(*q <= 0.0e0)) goto S80; 04722 *bound = 0.0e0; 04723 goto S90; 04724 S80: 04725 *bound = 1.0e0; 04726 S90: 04727 *status = -3; 04728 return; 04729 S110: 04730 S100: 04731 if(*which == 3) goto S130; 04732 /* 04733 DF 04734 */ 04735 if(!(*df <= 0.0e0)) goto S120; 04736 *bound = 0.0e0; 04737 *status = -5; 04738 return; 04739 S130: 04740 S120: 04741 if(*which == 1) goto S170; 04742 /* 04743 P + Q 04744 */ 04745 pq = *p+*q; 04746 if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S160; 04747 if(!(pq < 0.0e0)) goto S140; 04748 *bound = 0.0e0; 04749 goto S150; 04750 S140: 04751 *bound = 1.0e0; 04752 S150: 04753 *status = 3; 04754 return; 04755 S170: 04756 S160: 04757 if(!(*which == 1)) qporq = *p <= *q; 04758 /* 04759 Select the minimum of P or Q 04760 Calculate ANSWERS 04761 */ 04762 if(1 == *which) { 04763 /* 04764 Computing P and Q 04765 */ 04766 cumt(t,df,p,q); 04767 *status = 0; 04768 } 04769 else if(2 == *which) { 04770 /* 04771 Computing T 04772 .. Get initial approximation for T 04773 */ 04774 *t = dt1(p,q,df); 04775 T2 = -inf; 04776 T3 = inf; 04777 T6 = atol; 04778 T7 = tol; 04779 dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7); 04780 *status = 0; 04781 dinvr(status,t,&fx,&qleft,&qhi); 04782 S180: 04783 if(!(*status == 1)) goto S210; 04784 cumt(t,df,&cum,&ccum); 04785 if(!qporq) goto S190; 04786 fx = cum-*p; 04787 goto S200; 04788 S190: 04789 fx = ccum-*q; 04790 S200: 04791 dinvr(status,t,&fx,&qleft,&qhi); 04792 goto S180; 04793 S210: 04794 if(!(*status == -1)) goto S240; 04795 if(!qleft) goto S220; 04796 *status = 1; 04797 *bound = -inf; 04798 goto S230; 04799 S220: 04800 *status = 2; 04801 *bound = inf; 04802 S240: 04803 S230: 04804 ; 04805 } 04806 else if(3 == *which) { 04807 /* 04808 Computing DF 04809 */ 04810 *df = 5.0e0; 04811 T8 = zero; 04812 T9 = maxdf; 04813 T10 = atol; 04814 T11 = tol; 04815 dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); 04816 *status = 0; 04817 dinvr(status,df,&fx,&qleft,&qhi); 04818 S250: 04819 if(!(*status == 1)) goto S280; 04820 cumt(t,df,&cum,&ccum); 04821 if(!qporq) goto S260; 04822 fx = cum-*p; 04823 goto S270; 04824 S260: 04825 fx = ccum-*q; 04826 S270: 04827 dinvr(status,df,&fx,&qleft,&qhi); 04828 goto S250; 04829 S280: 04830 if(!(*status == -1)) goto S310; 04831 if(!qleft) goto S290; 04832 *status = 1; 04833 *bound = zero; 04834 goto S300; 04835 S290: 04836 *status = 2; 04837 *bound = maxdf; 04838 S300: 04839 ; 04840 } 04841 S310: 04842 return; 04843 #undef tol 04844 #undef atol 04845 #undef zero 04846 #undef inf 04847 #undef maxdf 04848 } /* END */ 04849 04850 /***=====================================================================***/ 04851 static void cumbet(double *x,double *y,double *a,double *b,double *cum, 04852 double *ccum) 04853 /* 04854 ********************************************************************** 04855 04856 void cumbet(double *x,double *y,double *a,double *b,double *cum, 04857 double *ccum) 04858 04859 Double precision cUMulative incomplete BETa distribution 04860 04861 04862 Function 04863 04864 04865 Calculates the cdf to X of the incomplete beta distribution 04866 with parameters a and b. This is the integral from 0 to x 04867 of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1) 04868 04869 04870 Arguments 04871 04872 04873 X --> Upper limit of integration. 04874 X is DOUBLE PRECISION 04875 04876 Y --> 1 - X. 04877 Y is DOUBLE PRECISION 04878 04879 A --> First parameter of the beta distribution. 04880 A is DOUBLE PRECISION 04881 04882 B --> Second parameter of the beta distribution. 04883 B is DOUBLE PRECISION 04884 04885 CUM <-- Cumulative incomplete beta distribution. 04886 CUM is DOUBLE PRECISION 04887 04888 CCUM <-- Compliment of Cumulative incomplete beta distribution. 04889 CCUM is DOUBLE PRECISION 04890 04891 04892 Method 04893 04894 04895 Calls the routine BRATIO. 04896 04897 References 04898 04899 Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim 04900 708 Significant Digit Computation of the Incomplete Beta Function 04901 Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373. 04902 04903 ********************************************************************** 04904 */ 04905 { 04906 static int ierr; 04907 /* 04908 .. 04909 .. Executable Statements .. 04910 */ 04911 if(!(*x <= 0.0e0)) goto S10; 04912 *cum = 0.0e0; 04913 *ccum = 1.0e0; 04914 return; 04915 S10: 04916 if(!(*y <= 0.0e0)) goto S20; 04917 *cum = 1.0e0; 04918 *ccum = 0.0e0; 04919 return; 04920 S20: 04921 bratio(a,b,x,y,cum,ccum,&ierr); 04922 /* 04923 Call bratio routine 04924 */ 04925 return; 04926 } /* END */ 04927 04928 /***=====================================================================***/ 04929 static void cumbin(double *s,double *xn,double *pr,double *ompr, 04930 double *cum,double *ccum) 04931 /* 04932 ********************************************************************** 04933 04934 void cumbin(double *s,double *xn,double *pr,double *ompr, 04935 double *cum,double *ccum) 04936 04937 CUmulative BINomial distribution 04938 04939 04940 Function 04941 04942 04943 Returns the probability of 0 to S successes in XN binomial 04944 trials, each of which has a probability of success, PBIN. 04945 04946 04947 Arguments 04948 04949 04950 S --> The upper limit of cumulation of the binomial distribution. 04951 S is DOUBLE PRECISION 04952 04953 XN --> The number of binomial trials. 04954 XN is DOUBLE PRECISIO 04955 04956 PBIN --> The probability of success in each binomial trial. 04957 PBIN is DOUBLE PRECIS 04958 04959 OMPR --> 1 - PBIN 04960 OMPR is DOUBLE PRECIS 04961 04962 CUM <-- Cumulative binomial distribution. 04963 CUM is DOUBLE PRECISI 04964 04965 CCUM <-- Compliment of Cumulative binomial distribution. 04966 CCUM is DOUBLE PRECIS 04967 04968 04969 Method 04970 04971 04972 Formula 26.5.24 of Abramowitz and Stegun, Handbook of 04973 Mathematical Functions (1966) is used to reduce the binomial 04974 distribution to the cumulative beta distribution. 04975 04976 ********************************************************************** 04977 */ 04978 { 04979 static double T1,T2; 04980 /* 04981 .. 04982 .. Executable Statements .. 04983 */ 04984 if(!(*s < *xn)) goto S10; 04985 T1 = *s+1.0e0; 04986 T2 = *xn-*s; 04987 cumbet(pr,ompr,&T1,&T2,ccum,cum); 04988 goto S20; 04989 S10: 04990 *cum = 1.0e0; 04991 *ccum = 0.0e0; 04992 S20: 04993 return; 04994 } /* END */ 04995 04996 /***=====================================================================***/ 04997 static void cumchi(double *x,double *df,double *cum,double *ccum) 04998 /* 04999 ********************************************************************** 05000 05001 void cumchi(double *x,double *df,double *cum,double *ccum) 05002 CUMulative of the CHi-square distribution 05003 05004 05005 Function 05006 05007 05008 Calculates the cumulative chi-square distribution. 05009 05010 05011 Arguments 05012 05013 05014 X --> Upper limit of integration of the 05015 chi-square distribution. 05016 X is DOUBLE PRECISION 05017 05018 DF --> Degrees of freedom of the 05019 chi-square distribution. 05020 DF is DOUBLE PRECISION 05021 05022 CUM <-- Cumulative chi-square distribution. 05023 CUM is DOUBLE PRECISIO 05024 05025 CCUM <-- Compliment of Cumulative chi-square distribution. 05026 CCUM is DOUBLE PRECISI 05027 05028 05029 Method 05030 05031 05032 Calls incomplete gamma function (CUMGAM) 05033 05034 ********************************************************************** 05035 */ 05036 { 05037 static double a,xx; 05038 /* 05039 .. 05040 .. Executable Statements .. 05041 */ 05042 a = *df*0.5e0; 05043 xx = *x*0.5e0; 05044 cumgam(&xx,&a,cum,ccum); 05045 return; 05046 } /* END */ 05047 05048 /***=====================================================================***/ 05049 static void cumchn(double *x,double *df,double *pnonc,double *cum, 05050 double *ccum) 05051 /* 05052 ********************************************************************** 05053 05054 void cumchn(double *x,double *df,double *pnonc,double *cum, 05055 double *ccum) 05056 05057 CUMulative of the Non-central CHi-square distribution 05058 05059 05060 Function 05061 05062 05063 Calculates the cumulative non-central chi-square 05064 distribution, i.e., the probability that a random variable 05065 which follows the non-central chi-square distribution, with 05066 non-centrality parameter PNONC and continuous degrees of 05067 freedom DF, is less than or equal to X. 05068 05069 05070 Arguments 05071 05072 05073 X --> Upper limit of integration of the non-central 05074 chi-square distribution. 05075 X is DOUBLE PRECISION 05076 05077 DF --> Degrees of freedom of the non-central 05078 chi-square distribution. 05079 DF is DOUBLE PRECISION 05080 05081 PNONC --> Non-centrality parameter of the non-central 05082 chi-square distribution. 05083 PNONC is DOUBLE PRECIS 05084 05085 CUM <-- Cumulative non-central chi-square distribution. 05086 CUM is DOUBLE PRECISIO 05087 05088 CCUM <-- Compliment of Cumulative non-central chi-square distribut 05089 CCUM is DOUBLE PRECISI 05090 05091 05092 Method 05093 05094 05095 Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of 05096 Mathematical Functions, US NBS (1966) to calculate the 05097 non-central chi-square. 05098 05099 05100 Variables 05101 05102 05103 EPS --- Convergence criterion. The sum stops when a 05104 term is less than EPS*SUM. 05105 EPS is DOUBLE PRECISIO 05106 05107 NTIRED --- Maximum number of terms to be evaluated 05108 in each sum. 05109 NTIRED is INTEGER 05110 05111 QCONV --- .TRUE. if convergence achieved - 05112 i.e., program did not stop on NTIRED criterion. 05113 QCONV is LOGICAL 05114 05115 CCUM <-- Compliment of Cumulative non-central 05116 chi-square distribution. 05117 CCUM is DOUBLE PRECISI 05118 05119 ********************************************************************** 05120 */ 05121 { 05122 #define dg(i) (*df+2.0e0*(double)(i)) 05123 #define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps*sum) 05124 #define qtired(i) (int)((i) > ntired) 05125 static double eps = 1.0e-5; 05126 static int ntired = 1000; 05127 static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum, 05128 sumadj,term,wt,xnonc; 05129 static int i,icent,iterb,iterf; 05130 static double T1,T2,T3; 05131 /* 05132 .. 05133 .. Executable Statements .. 05134 */ 05135 if(!(*x <= 0.0e0)) goto S10; 05136 *cum = 0.0e0; 05137 *ccum = 1.0e0; 05138 return; 05139 S10: 05140 if(!(*pnonc <= 1.0e-10)) goto S20; 05141 /* 05142 When non-centrality parameter is (essentially) zero, 05143 use cumulative chi-square distribution 05144 */ 05145 cumchi(x,df,cum,ccum); 05146 return; 05147 S20: 05148 xnonc = *pnonc/2.0e0; 05149 /* 05150 ********************************************************************** 05151 The following code calcualtes the weight, chi-square, and 05152 adjustment term for the central term in the infinite series. 05153 The central term is the one in which the poisson weight is 05154 greatest. The adjustment term is the amount that must 05155 be subtracted from the chi-square to move up two degrees 05156 of freedom. 05157 ********************************************************************** 05158 */ 05159 icent = fifidint(xnonc); 05160 if(icent == 0) icent = 1; 05161 chid2 = *x/2.0e0; 05162 /* 05163 Calculate central weight term 05164 */ 05165 T1 = (double)(icent+1); 05166 lfact = alngam(&T1); 05167 lcntwt = -xnonc+(double)icent*log(xnonc)-lfact; 05168 centwt = exp(lcntwt); 05169 /* 05170 Calculate central chi-square 05171 */ 05172 T2 = dg(icent); 05173 cumchi(x,&T2,&pcent,ccum); 05174 /* 05175 Calculate central adjustment term 05176 */ 05177 dfd2 = dg(icent)/2.0e0; 05178 T3 = 1.0e0+dfd2; 05179 lfact = alngam(&T3); 05180 lcntaj = dfd2*log(chid2)-chid2-lfact; 05181 centaj = exp(lcntaj); 05182 sum = centwt*pcent; 05183 /* 05184 ********************************************************************** 05185 Sum backwards from the central term towards zero. 05186 Quit whenever either 05187 (1) the zero term is reached, or 05188 (2) the term gets small relative to the sum, or 05189 (3) More than NTIRED terms are totaled. 05190 ********************************************************************** 05191 */ 05192 iterb = 0; 05193 sumadj = 0.0e0; 05194 adj = centaj; 05195 wt = centwt; 05196 i = icent; 05197 goto S40; 05198 S30: 05199 if(qtired(iterb) || qsmall(term) || i == 0) goto S50; 05200 S40: 05201 dfd2 = dg(i)/2.0e0; 05202 /* 05203 Adjust chi-square for two fewer degrees of freedom. 05204 The adjusted value ends up in PTERM. 05205 */ 05206 adj = adj*dfd2/chid2; 05207 sumadj += adj; 05208 pterm = pcent+sumadj; 05209 /* 05210 Adjust poisson weight for J decreased by one 05211 */ 05212 wt *= ((double)i/xnonc); 05213 term = wt*pterm; 05214 sum += term; 05215 i -= 1; 05216 iterb += 1; 05217 goto S30; 05218 S50: 05219 iterf = 0; 05220 /* 05221 ********************************************************************** 05222 Now sum forward from the central term towards infinity. 05223 Quit when either 05224 (1) the term gets small relative to the sum, or 05225 (2) More than NTIRED terms are totaled. 05226 ********************************************************************** 05227 */ 05228 sumadj = adj = centaj; 05229 wt = centwt; 05230 i = icent; 05231 goto S70; 05232 S60: 05233 if(qtired(iterf) || qsmall(term)) goto S80; 05234 S70: 05235 /* 05236 Update weights for next higher J 05237 */ 05238 wt *= (xnonc/(double)(i+1)); 05239 /* 05240 Calculate PTERM and add term to sum 05241 */ 05242 pterm = pcent-sumadj; 05243 term = wt*pterm; 05244 sum += term; 05245 /* 05246 Update adjustment term for DF for next iteration 05247 */ 05248 i += 1; 05249 dfd2 = dg(i)/2.0e0; 05250 adj = adj*chid2/dfd2; 05251 sumadj += adj; 05252 iterf += 1; 05253 goto S60; 05254 S80: 05255 *cum = sum; 05256 *ccum = 0.5e0+(0.5e0-*cum); 05257 return; 05258 #undef dg 05259 #undef qsmall 05260 #undef qtired 05261 } /* END */ 05262 05263 /***=====================================================================***/ 05264 static void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) 05265 /* 05266 ********************************************************************** 05267 05268 void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) 05269 CUMulative F distribution 05270 05271 05272 Function 05273 05274 05275 Computes the integral from 0 to F of the f-density with DFN 05276 and DFD degrees of freedom. 05277 05278 05279 Arguments 05280 05281 05282 F --> Upper limit of integration of the f-density. 05283 F is DOUBLE PRECISION 05284 05285 DFN --> Degrees of freedom of the numerator sum of squares. 05286 DFN is DOUBLE PRECISI 05287 05288 DFD --> Degrees of freedom of the denominator sum of squares. 05289 DFD is DOUBLE PRECISI 05290 05291 CUM <-- Cumulative f distribution. 05292 CUM is DOUBLE PRECISI 05293 05294 CCUM <-- Compliment of Cumulative f distribution. 05295 CCUM is DOUBLE PRECIS 05296 05297 05298 Method 05299 05300 05301 Formula 26.5.28 of Abramowitz and Stegun is used to reduce 05302 the cumulative F to a cumulative beta distribution. 05303 05304 05305 Note 05306 05307 05308 If F is less than or equal to 0, 0 is returned. 05309 05310 ********************************************************************** 05311 */ 05312 { 05313 #define half 0.5e0 05314 #define done 1.0e0 05315 static double dsum,prod,xx,yy; 05316 static int ierr; 05317 static double T1,T2; 05318 /* 05319 .. 05320 .. Executable Statements .. 05321 */ 05322 if(!(*f <= 0.0e0)) goto S10; 05323 *cum = 0.0e0; 05324 *ccum = 1.0e0; 05325 return; 05326 S10: 05327 prod = *dfn**f; 05328 /* 05329 XX is such that the incomplete beta with parameters 05330 DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM 05331 YY is 1 - XX 05332 Calculate the smaller of XX and YY accurately 05333 */ 05334 dsum = *dfd+prod; 05335 xx = *dfd/dsum; 05336 if(xx > half) { 05337 yy = prod/dsum; 05338 xx = done-yy; 05339 } 05340 else yy = done-xx; 05341 T1 = *dfd*half; 05342 T2 = *dfn*half; 05343 bratio(&T1,&T2,&xx,&yy,ccum,cum,&ierr); 05344 return; 05345 #undef half 05346 #undef done 05347 } /* END */ 05348 05349 /***=====================================================================***/ 05350 static void cumfnc(double *f,double *dfn,double *dfd,double *pnonc, 05351 double *cum,double *ccum) 05352 /* 05353 ********************************************************************** 05354 05355 F -NON- -C-ENTRAL F DISTRIBUTION 05356 05357 05358 05359 Function 05360 05361 05362 COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD 05363 DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC 05364 05365 05366 Arguments 05367 05368 05369 X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION 05370 05371 DFN --> DEGREES OF FREEDOM OF NUMERATOR 05372 05373 DFD --> DEGREES OF FREEDOM OF DENOMINATOR 05374 05375 PNONC --> NONCENTRALITY PARAMETER. 05376 05377 CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION 05378 05379 CCUM <-- COMPLIMENT OF CUMMULATIVE 05380 05381 05382 Method 05383 05384 05385 USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES. 05386 SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2 05387 (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL 05388 THE CONVERGENCE CRITERION IS MET. 05389 05390 FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED 05391 BY FORMULA 26.5.16. 05392 05393 05394 REFERENCE 05395 05396 05397 HANDBOOD OF MATHEMATICAL FUNCTIONS 05398 EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN 05399 NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55 05400 MARCH 1965 05401 P 947, EQUATIONS 26.6.17, 26.6.18 05402 05403 05404 Note 05405 05406 05407 THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS 05408 TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS 05409 SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED. 05410 05411 ********************************************************************** 05412 */ 05413 { 05414 #define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum) 05415 #define half 0.5e0 05416 #define done 1.0e0 05417 static double eps = 1.0e-4; 05418 static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum, 05419 upterm,xmult,xnonc; 05420 static int i,icent,ierr; 05421 static double T1,T2,T3,T4,T5,T6; 05422 /* 05423 .. 05424 .. Executable Statements .. 05425 */ 05426 if(!(*f <= 0.0e0)) goto S10; 05427 *cum = 0.0e0; 05428 *ccum = 1.0e0; 05429 return; 05430 S10: 05431 if(!(*pnonc < 1.0e-10)) goto S20; 05432 /* 05433 Handle case in which the non-centrality parameter is 05434 (essentially) zero. 05435 */ 05436 cumf(f,dfn,dfd,cum,ccum); 05437 return; 05438 S20: 05439 xnonc = *pnonc/2.0e0; 05440 /* 05441 Calculate the central term of the poisson weighting factor. 05442 */ 05443 icent = xnonc; 05444 if(icent == 0) icent = 1; 05445 /* 05446 Compute central weight term 05447 */ 05448 T1 = (double)(icent+1); 05449 centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1)); 05450 /* 05451 Compute central incomplete beta term 05452 Assure that minimum of arg to beta and 1 - arg is computed 05453 accurately. 05454 */ 05455 prod = *dfn**f; 05456 dsum = *dfd+prod; 05457 yy = *dfd/dsum; 05458 if(yy > half) { 05459 xx = prod/dsum; 05460 yy = done-xx; 05461 } 05462 else xx = done-yy; 05463 T2 = *dfn*half+(double)icent; 05464 T3 = *dfd*half; 05465 bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr); 05466 adn = *dfn/2.0e0+(double)icent; 05467 aup = adn; 05468 b = *dfd/2.0e0; 05469 betup = betdn; 05470 sum = centwt*betdn; 05471 /* 05472 Now sum terms backward from icent until convergence or all done 05473 */ 05474 xmult = centwt; 05475 i = icent; 05476 T4 = adn+b; 05477 T5 = adn+1.0e0; 05478 dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy)); 05479 S30: 05480 if(qsmall(xmult*betdn) || i <= 0) goto S40; 05481 xmult *= ((double)i/xnonc); 05482 i -= 1; 05483 adn -= 1.0; 05484 dnterm = (adn+1.0)/((adn+b)*xx)*dnterm; 05485 betdn += dnterm; 05486 sum += (xmult*betdn); 05487 goto S30; 05488 S40: 05489 i = icent+1; 05490 /* 05491 Now sum forwards until convergence 05492 */ 05493 xmult = centwt; 05494 if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+ 05495 b*log(yy)); 05496 else { 05497 T6 = aup-1.0+b; 05498 upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b* 05499 log(yy)); 05500 } 05501 goto S60; 05502 S50: 05503 if(qsmall(xmult*betup)) goto S70; 05504 S60: 05505 xmult *= (xnonc/(double)i); 05506 i += 1; 05507 aup += 1.0; 05508 upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm; 05509 betup -= upterm; 05510 sum += (xmult*betup); 05511 goto S50; 05512 S70: 05513 *cum = sum; 05514 *ccum = 0.5e0+(0.5e0-*cum); 05515 return; 05516 #undef qsmall 05517 #undef half 05518 #undef done 05519 } /* END */ 05520 05521 /***=====================================================================***/ 05522 static void cumgam(double *x,double *a,double *cum,double *ccum) 05523 /* 05524 ********************************************************************** 05525 05526 void cumgam(double *x,double *a,double *cum,double *ccum) 05527 Double precision cUMulative incomplete GAMma distribution 05528 05529 05530 Function 05531 05532 05533 Computes the cumulative of the incomplete gamma 05534 distribution, i.e., the integral from 0 to X of 05535 (1/GAM(A))*EXP(-T)*T**(A-1) DT 05536 where GAM(A) is the complete gamma function of A, i.e., 05537 GAM(A) = integral from 0 to infinity of 05538 EXP(-T)*T**(A-1) DT 05539 05540 05541 Arguments 05542 05543 05544 X --> The upper limit of integration of the incomplete gamma. 05545 X is DOUBLE PRECISION 05546 05547 A --> The shape parameter of the incomplete gamma. 05548 A is DOUBLE PRECISION 05549 05550 CUM <-- Cumulative incomplete gamma distribution. 05551 CUM is DOUBLE PRECISION 05552 05553 CCUM <-- Compliment of Cumulative incomplete gamma distribution. 05554 CCUM is DOUBLE PRECISIO 05555 05556 05557 Method 05558 05559 05560 Calls the routine GRATIO. 05561 05562 ********************************************************************** 05563 */ 05564 { 05565 static int K1 = 0; 05566 /* 05567 .. 05568 .. Executable Statements .. 05569 */ 05570 if(!(*x <= 0.0e0)) goto S10; 05571 *cum = 0.0e0; 05572 *ccum = 1.0e0; 05573 return; 05574 S10: 05575 gratio(a,x,cum,ccum,&K1); 05576 /* 05577 Call gratio routine 05578 */ 05579 return; 05580 } /* END */ 05581 05582 /***=====================================================================***/ 05583 static void cumnbn(double *s,double *xn,double *pr,double *ompr, 05584 double *cum,double *ccum) 05585 /* 05586 ********************************************************************** 05587 05588 void cumnbn(double *s,double *xn,double *pr,double *ompr, 05589 double *cum,double *ccum) 05590 05591 CUmulative Negative BINomial distribution 05592 05593 05594 Function 05595 05596 05597 Returns the probability that it there will be S or fewer failures 05598 before there are XN successes, with each binomial trial having 05599 a probability of success PR. 05600 05601 Prob(# failures = S | XN successes, PR) = 05602 ( XN + S - 1 ) 05603 ( ) * PR^XN * (1-PR)^S 05604 ( S ) 05605 05606 05607 Arguments 05608 05609 05610 S --> The number of failures 05611 S is DOUBLE PRECISION 05612 05613 XN --> The number of successes 05614 XN is DOUBLE PRECISIO 05615 05616 PR --> The probability of success in each binomial trial. 05617 PR is DOUBLE PRECISIO 05618 05619 OMPR --> 1 - PR 05620 OMPR is DOUBLE PRECIS 05621 05622 CUM <-- Cumulative negative binomial distribution. 05623 CUM is DOUBLE PRECISI 05624 05625 CCUM <-- Compliment of Cumulative negative binomial distribution. 05626 CCUM is DOUBLE PRECIS 05627 05628 05629 Method 05630 05631 05632 Formula 26.5.26 of Abramowitz and Stegun, Handbook of 05633 Mathematical Functions (1966) is used to reduce the negative 05634 binomial distribution to the cumulative beta distribution. 05635 05636 ********************************************************************** 05637 */ 05638 { 05639 static double T1; 05640 /* 05641 .. 05642 .. Executable Statements .. 05643 */ 05644 T1 = *s+1.e0; 05645 cumbet(pr,ompr,xn,&T1,cum,ccum); 05646 return; 05647 } /* END */ 05648 05649 /***=====================================================================***/ 05650 static void cumnor(double *arg,double *result,double *ccum) 05651 /* 05652 ********************************************************************** 05653 05654 void cumnor(double *arg,double *result,double *ccum) 05655 05656 05657 Function 05658 05659 05660 Computes the cumulative of the normal distribution, i.e., 05661 the integral from -infinity to x of 05662 (1/sqrt(2*pi)) exp(-u*u/2) du 05663 05664 X --> Upper limit of integration. 05665 X is DOUBLE PRECISION 05666 05667 RESULT <-- Cumulative normal distribution. 05668 RESULT is DOUBLE PRECISION 05669 05670 CCUM <-- Compliment of Cumulative normal distribution. 05671 CCUM is DOUBLE PRECISION 05672 05673 Renaming of function ANORM from: 05674 05675 Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN 05676 Package of Special Function Routines and Test Drivers" 05677 acm Transactions on Mathematical Software. 19, 22-32. 05678 05679 with slight modifications to return ccum and to deal with 05680 machine constants. 05681 05682 ********************************************************************** 05683 Original Comments: 05684 ------------------------------------------------------------------ 05685 05686 This function evaluates the normal distribution function: 05687 05688 / x 05689 1 | -t*t/2 05690 P(x) = ----------- | e dt 05691 sqrt(2 pi) | 05692 /-oo 05693 05694 The main computation evaluates near-minimax approximations 05695 derived from those in "Rational Chebyshev approximations for 05696 the error function" by W. J. Cody, Math. Comp., 1969, 631-637. 05697 This transportable program uses rational functions that 05698 theoretically approximate the normal distribution function to 05699 at least 18 significant decimal digits. The accuracy achieved 05700 depends on the arithmetic system, the compiler, the intrinsic 05701 functions, and proper selection of the machine-dependent 05702 constants. 05703 05704 ******************************************************************* 05705 ******************************************************************* 05706 05707 Explanation of machine-dependent constants. 05708 05709 MIN = smallest machine representable number. 05710 05711 EPS = argument below which anorm(x) may be represented by 05712 0.5 and above which x*x will not underflow. 05713 A conservative value is the largest machine number X 05714 such that 1.0 + X = 1.0 to machine precision. 05715 ******************************************************************* 05716 ******************************************************************* 05717 05718 Error returns 05719 05720 The program returns ANORM = 0 for ARG .LE. XLOW. 05721 05722 05723 Intrinsic functions required are: 05724 05725 ABS, AINT, EXP 05726 05727 05728 Author: W. J. Cody 05729 Mathematics and Computer Science Division 05730 Argonne National Laboratory 05731 Argonne, IL 60439 05732 05733 Latest modification: March 15, 1992 05734 05735 ------------------------------------------------------------------ 05736 */ 05737 { 05738 static double a[5] = { 05739 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03, 05740 1.8154981253343561249e04,6.5682337918207449113e-2 05741 }; 05742 static double b[4] = { 05743 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04, 05744 4.5507789335026729956e04 05745 }; 05746 static double c[9] = { 05747 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01, 05748 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03, 05749 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8 05750 }; 05751 static double d[8] = { 05752 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03, 05753 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04, 05754 3.8912003286093271411e04,1.9685429676859990727e04 05755 }; 05756 static double half = 0.5e0; 05757 static double p[6] = { 05758 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2, 05759 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2 05760 }; 05761 static double one = 1.0e0; 05762 static double q[5] = { 05763 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2, 05764 3.78239633202758244e-3,7.29751555083966205e-5 05765 }; 05766 static double sixten = 1.60e0; 05767 static double sqrpi = 3.9894228040143267794e-1; 05768 static double thrsh = 0.66291e0; 05769 static double root32 = 5.656854248e0; 05770 static double zero = 0.0e0; 05771 static int K1 = 1; 05772 static int K2 = 2; 05773 static int i; 05774 static double del,eps,temp,x,xden,xnum,y,xsq,min; 05775 /* 05776 ------------------------------------------------------------------ 05777 Machine dependent constants 05778 ------------------------------------------------------------------ 05779 */ 05780 eps = spmpar(&K1)*0.5e0; 05781 min = spmpar(&K2); 05782 x = *arg; 05783 y = fabs(x); 05784 if(y <= thrsh) { 05785 /* 05786 ------------------------------------------------------------------ 05787 Evaluate anorm for |X| <= 0.66291 05788 ------------------------------------------------------------------ 05789 */ 05790 xsq = zero; 05791 if(y > eps) xsq = x*x; 05792 xnum = a[4]*xsq; 05793 xden = xsq; 05794 for(i=0; i<3; i++) { 05795 xnum = (xnum+a[i])*xsq; 05796 xden = (xden+b[i])*xsq; 05797 } 05798 *result = x*(xnum+a[3])/(xden+b[3]); 05799 temp = *result; 05800 *result = half+temp; 05801 *ccum = half-temp; 05802 } 05803 /* 05804 ------------------------------------------------------------------ 05805 Evaluate anorm for 0.66291 <= |X| <= sqrt(32) 05806 ------------------------------------------------------------------ 05807 */ 05808 else if(y <= root32) { 05809 xnum = c[8]*y; 05810 xden = y; 05811 for(i=0; i<7; i++) { 05812 xnum = (xnum+c[i])*y; 05813 xden = (xden+d[i])*y; 05814 } 05815 *result = (xnum+c[7])/(xden+d[7]); 05816 xsq = fifdint(y*sixten)/sixten; 05817 del = (y-xsq)*(y+xsq); 05818 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; 05819 *ccum = one-*result; 05820 if(x > zero) { 05821 temp = *result; 05822 *result = *ccum; 05823 *ccum = temp; 05824 } 05825 } 05826 /* 05827 ------------------------------------------------------------------ 05828 Evaluate anorm for |X| > sqrt(32) 05829 ------------------------------------------------------------------ 05830 */ 05831 else { 05832 *result = zero; 05833 xsq = one/(x*x); 05834 xnum = p[5]*xsq; 05835 xden = xsq; 05836 for(i=0; i<4; i++) { 05837 xnum = (xnum+p[i])*xsq; 05838 xden = (xden+q[i])*xsq; 05839 } 05840 *result = xsq*(xnum+p[4])/(xden+q[4]); 05841 *result = (sqrpi-*result)/y; 05842 xsq = fifdint(x*sixten)/sixten; 05843 del = (x-xsq)*(x+xsq); 05844 *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; 05845 *ccum = one-*result; 05846 if(x > zero) { 05847 temp = *result; 05848 *result = *ccum; 05849 *ccum = temp; 05850 } 05851 } 05852 if(*result < min) *result = 0.0e0; 05853 /* 05854 ------------------------------------------------------------------ 05855 Fix up for negative argument, erf, etc. 05856 ------------------------------------------------------------------ 05857 ----------Last card of ANORM ---------- 05858 */ 05859 if(*ccum < min) *ccum = 0.0e0; 05860 } /* END */ 05861 05862 /***=====================================================================***/ 05863 static void cumpoi(double *s,double *xlam,double *cum,double *ccum) 05864 /* 05865 ********************************************************************** 05866 05867 void cumpoi(double *s,double *xlam,double *cum,double *ccum) 05868 CUMulative POIsson distribution 05869 05870 05871 Function 05872 05873 05874 Returns the probability of S or fewer events in a Poisson 05875 distribution with mean XLAM. 05876 05877 05878 Arguments 05879 05880 05881 S --> Upper limit of cumulation of the Poisson. 05882 S is DOUBLE PRECISION 05883 05884 XLAM --> Mean of the Poisson distribution. 05885 XLAM is DOUBLE PRECIS 05886 05887 CUM <-- Cumulative poisson distribution. 05888 CUM is DOUBLE PRECISION 05889 05890 CCUM <-- Compliment of Cumulative poisson distribution. 05891 CCUM is DOUBLE PRECIS 05892 05893 05894 Method 05895 05896 05897 Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of 05898 Mathematical Functions to reduce the cumulative Poisson to 05899 the cumulative chi-square distribution. 05900 05901 ********************************************************************** 05902 */ 05903 { 05904 static double chi,df; 05905 /* 05906 .. 05907 .. Executable Statements .. 05908 */ 05909 df = 2.0e0*(*s+1.0e0); 05910 chi = 2.0e0**xlam; 05911 cumchi(&chi,&df,ccum,cum); 05912 return; 05913 } /* END */ 05914 05915 /***=====================================================================***/ 05916 static void cumt(double *t,double *df,double *cum,double *ccum) 05917 /* 05918 ********************************************************************** 05919 05920 void cumt(double *t,double *df,double *cum,double *ccum) 05921 CUMulative T-distribution 05922 05923 05924 Function 05925 05926 05927 Computes the integral from -infinity to T of the t-density. 05928 05929 05930 Arguments 05931 05932 05933 T --> Upper limit of integration of the t-density. 05934 T is DOUBLE PRECISION 05935 05936 DF --> Degrees of freedom of the t-distribution. 05937 DF is DOUBLE PRECISIO 05938 05939 CUM <-- Cumulative t-distribution. 05940 CCUM is DOUBLE PRECIS 05941 05942 CCUM <-- Compliment of Cumulative t-distribution. 05943 CCUM is DOUBLE PRECIS 05944 05945 05946 Method 05947 05948 05949 Formula 26.5.27 of Abramowitz and Stegun, Handbook of 05950 Mathematical Functions is used to reduce the t-distribution 05951 to an incomplete beta. 05952 05953 ********************************************************************** 05954 */ 05955 { 05956 static double K2 = 0.5e0; 05957 static double xx,a,oma,tt,yy,dfptt,T1; 05958 /* 05959 .. 05960 .. Executable Statements .. 05961 */ 05962 tt = *t**t; 05963 dfptt = *df+tt; 05964 xx = *df/dfptt; 05965 yy = tt/dfptt; 05966 T1 = 0.5e0**df; 05967 cumbet(&xx,&yy,&T1,&K2,&a,&oma); 05968 if(!(*t <= 0.0e0)) goto S10; 05969 *cum = 0.5e0*a; 05970 *ccum = oma+*cum; 05971 goto S20; 05972 S10: 05973 *ccum = 0.5e0*a; 05974 *cum = oma+*ccum; 05975 S20: 05976 return; 05977 } /* END */ 05978 05979 /***=====================================================================***/ 05980 static double dbetrm(double *a,double *b) 05981 /* 05982 ********************************************************************** 05983 05984 double dbetrm(double *a,double *b) 05985 Double Precision Sterling Remainder for Complete 05986 Beta Function 05987 05988 05989 Function 05990 05991 05992 Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B) 05993 where Lgamma is the log of the (complete) gamma function 05994 05995 Let ZZ be approximation obtained if each log gamma is approximated 05996 by Sterling's formula, i.e., 05997 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z 05998 05999 Returns Log(Beta(A,B)) - ZZ 06000 06001 06002 Arguments 06003 06004 06005 A --> One argument of the Beta 06006 DOUBLE PRECISION A 06007 06008 B --> The other argument of the Beta 06009 DOUBLE PRECISION B 06010 06011 ********************************************************************** 06012 */ 06013 { 06014 static double dbetrm,T1,T2,T3; 06015 /* 06016 .. 06017 .. Executable Statements .. 06018 */ 06019 /* 06020 Try to sum from smallest to largest 06021 */ 06022 T1 = *a+*b; 06023 dbetrm = -dstrem(&T1); 06024 T2 = fifdmax1(*a,*b); 06025 dbetrm += dstrem(&T2); 06026 T3 = fifdmin1(*a,*b); 06027 dbetrm += dstrem(&T3); 06028 return dbetrm; 06029 } /* END */ 06030 06031 /***=====================================================================***/ 06032 static double devlpl(double a[],int *n,double *x) 06033 /* 06034 ********************************************************************** 06035 06036 double devlpl(double a[],int *n,double *x) 06037 Double precision EVALuate a PoLynomial at X 06038 06039 06040 Function 06041 06042 06043 returns 06044 A(1) + A(2)*X + ... + A(N)*X**(N-1) 06045 06046 06047 Arguments 06048 06049 06050 A --> Array of coefficients of the polynomial. 06051 A is DOUBLE PRECISION(N) 06052 06053 N --> Length of A, also degree of polynomial - 1. 06054 N is INTEGER 06055 06056 X --> Point at which the polynomial is to be evaluated. 06057 X is DOUBLE PRECISION 06058 06059 ********************************************************************** 06060 */ 06061 { 06062 static double devlpl,term; 06063 static int i; 06064 /* 06065 .. 06066 .. Executable Statements .. 06067 */ 06068 term = a[*n-1]; 06069 for(i= *n-1-1; i>=0; i--) term = a[i]+term**x; 06070 devlpl = term; 06071 return devlpl; 06072 } /* END */ 06073 06074 /***=====================================================================***/ 06075 static double dexpm1(double *x) 06076 /* 06077 ********************************************************************** 06078 06079 double dexpm1(double *x) 06080 Evaluation of the function EXP(X) - 1 06081 06082 06083 Arguments 06084 06085 06086 X --> Argument at which exp(x)-1 desired 06087 DOUBLE PRECISION X 06088 06089 06090 Method 06091 06092 06093 Renaming of function rexp from code of: 06094 06095 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant 06096 Digit Computation of the Incomplete Beta Function Ratios. ACM 06097 Trans. Math. Softw. 18 (1993), 360-373. 06098 06099 ********************************************************************** 06100 */ 06101 { 06102 static double p1 = .914041914819518e-09; 06103 static double p2 = .238082361044469e-01; 06104 static double q1 = -.499999999085958e+00; 06105 static double q2 = .107141568980644e+00; 06106 static double q3 = -.119041179760821e-01; 06107 static double q4 = .595130811860248e-03; 06108 static double dexpm1,w; 06109 /* 06110 .. 06111 .. Executable Statements .. 06112 */ 06113 if(fabs(*x) > 0.15e0) goto S10; 06114 dexpm1 = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0)); 06115 return dexpm1; 06116 S10: 06117 w = exp(*x); 06118 if(*x > 0.0e0) goto S20; 06119 dexpm1 = w-0.5e0-0.5e0; 06120 return dexpm1; 06121 S20: 06122 dexpm1 = w*(0.5e0+(0.5e0-1.0e0/w)); 06123 return dexpm1; 06124 } /* END */ 06125 06126 /***=====================================================================***/ 06127 static double dinvnr(double *p,double *q) 06128 /* 06129 ********************************************************************** 06130 06131 double dinvnr(double *p,double *q) 06132 Double precision NoRmal distribution INVerse 06133 06134 06135 Function 06136 06137 06138 Returns X such that CUMNOR(X) = P, i.e., the integral from - 06139 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P 06140 06141 06142 Arguments 06143 06144 06145 P --> The probability whose normal deviate is sought. 06146 P is DOUBLE PRECISION 06147 06148 Q --> 1-P 06149 P is DOUBLE PRECISION 06150 06151 06152 Method 06153 06154 06155 The rational function on page 95 of Kennedy and Gentle, 06156 Statistical Computing, Marcel Dekker, NY , 1980 is used as a start 06157 value for the Newton method of finding roots. 06158 06159 06160 Note 06161 06162 06163 If P or Q .lt. machine EPS returns +/- DINVNR(EPS) 06164 06165 ********************************************************************** 06166 */ 06167 { 06168 #define maxit 100 06169 #define eps (1.0e-13) 06170 #define r2pi 0.3989422804014326e0 06171 #define nhalf (-0.5e0) 06172 #define dennor(x) (r2pi*exp(nhalf*(x)*(x))) 06173 static double dinvnr,strtx,xcur,cum,ccum,pp,dx; 06174 static int i; 06175 static unsigned long qporq; 06176 /* 06177 .. 06178 .. Executable Statements .. 06179 */ 06180 /* 06181 FIND MINIMUM OF P AND Q 06182 */ 06183 qporq = *p <= *q; 06184 if(!qporq) goto S10; 06185 pp = *p; 06186 goto S20; 06187 S10: 06188 pp = *q; 06189 S20: 06190 /* 06191 INITIALIZATION STEP 06192 */ 06193 strtx = stvaln(&pp); 06194 xcur = strtx; 06195 /* 06196 NEWTON INTERATIONS 06197 */ 06198 for(i=1; i<=maxit; i++) { 06199 cumnor(&xcur,&cum,&ccum); 06200 dx = (cum-pp)/dennor(xcur); 06201 xcur -= dx; 06202 if(fabs(dx/xcur) < eps) goto S40; 06203 } 06204 dinvnr = strtx; 06205 /* 06206 IF WE GET HERE, NEWTON HAS FAILED 06207 */ 06208 if(!qporq) dinvnr = -dinvnr; 06209 return dinvnr; 06210 S40: 06211 /* 06212 IF WE GET HERE, NEWTON HAS SUCCEDED 06213 */ 06214 dinvnr = xcur; 06215 if(!qporq) dinvnr = -dinvnr; 06216 return dinvnr; 06217 #undef maxit 06218 #undef eps 06219 #undef r2pi 06220 #undef nhalf 06221 #undef dennor 06222 } /* END */ 06223 06224 /***=====================================================================***/ 06225 static void E0000(int IENTRY,int *status,double *x,double *fx, 06226 unsigned long *qleft,unsigned long *qhi,double *zabsst, 06227 double *zabsto,double *zbig,double *zrelst, 06228 double *zrelto,double *zsmall,double *zstpmu) 06229 { 06230 #define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz)) 06231 static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi, 06232 xlb,xlo,xsave,xub,yy; 06233 static int i99999; 06234 static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup; 06235 switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;} 06236 DINVR: 06237 if(*status > 0) goto S310; 06238 qcond = !qxmon(small,*x,big); 06239 if(qcond){ ftnstop("SMALL,X,BIG nonmonotone in E0000"); *status=-1; return;} 06240 xsave = *x; 06241 /* 06242 See that SMALL and BIG bound the zero and set QINCR 06243 */ 06244 *x = small; 06245 /* 06246 GET-FUNCTION-VALUE 06247 */ 06248 i99999 = 1; 06249 goto S300; 06250 S10: 06251 fsmall = *fx; 06252 *x = big; 06253 /* 06254 GET-FUNCTION-VALUE 06255 */ 06256 i99999 = 2; 06257 goto S300; 06258 S20: 06259 fbig = *fx; 06260 qincr = fbig > fsmall; 06261 if(!qincr) goto S50; 06262 if(fsmall <= 0.0e0) goto S30; 06263 *status = -1; 06264 *qleft = *qhi = 1; 06265 return; 06266 S30: 06267 if(fbig >= 0.0e0) goto S40; 06268 *status = -1; 06269 *qleft = *qhi = 0; 06270 return; 06271 S40: 06272 goto S80; 06273 S50: 06274 if(fsmall >= 0.0e0) goto S60; 06275 *status = -1; 06276 *qleft = 1; 06277 *qhi = 0; 06278 return; 06279 S60: 06280 if(fbig <= 0.0e0) goto S70; 06281 *status = -1; 06282 *qleft = 0; 06283 *qhi = 1; 06284 return; 06285 S80: 06286 S70: 06287 *x = xsave; 06288 step = fifdmax1(absstp,relstp*fabs(*x)); 06289 /* 06290 YY = F(X) - Y 06291 GET-FUNCTION-VALUE 06292 */ 06293 i99999 = 3; 06294 goto S300; 06295 S90: 06296 yy = *fx; 06297 if(!(yy == 0.0e0)) goto S100; 06298 *status = 0; 06299 qok = 1; 06300 return; 06301 S100: 06302 qup = qincr && yy < 0.0e0 || !qincr && yy > 0.0e0; 06303 /* 06304 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06305 HANDLE CASE IN WHICH WE MUST STEP HIGHER 06306 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06307 */ 06308 if(!qup) goto S170; 06309 xlb = xsave; 06310 xub = fifdmin1(xlb+step,big); 06311 goto S120; 06312 S110: 06313 if(qcond) goto S150; 06314 S120: 06315 /* 06316 YY = F(XUB) - Y 06317 */ 06318 *x = xub; 06319 /* 06320 GET-FUNCTION-VALUE 06321 */ 06322 i99999 = 4; 06323 goto S300; 06324 S130: 06325 yy = *fx; 06326 qbdd = qincr && yy >= 0.0e0 || !qincr && yy <= 0.0e0; 06327 qlim = xub >= big; 06328 qcond = qbdd || qlim; 06329 if(qcond) goto S140; 06330 step = stpmul*step; 06331 xlb = xub; 06332 xub = fifdmin1(xlb+step,big); 06333 S140: 06334 goto S110; 06335 S150: 06336 if(!(qlim && !qbdd)) goto S160; 06337 *status = -1; 06338 *qleft = 0; 06339 *qhi = !qincr; 06340 *x = big; 06341 return; 06342 S160: 06343 goto S240; 06344 S170: 06345 /* 06346 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06347 HANDLE CASE IN WHICH WE MUST STEP LOWER 06348 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06349 */ 06350 xub = xsave; 06351 xlb = fifdmax1(xub-step,small); 06352 goto S190; 06353 S180: 06354 if(qcond) goto S220; 06355 S190: 06356 /* 06357 YY = F(XLB) - Y 06358 */ 06359 *x = xlb; 06360 /* 06361 GET-FUNCTION-VALUE 06362 */ 06363 i99999 = 5; 06364 goto S300; 06365 S200: 06366 yy = *fx; 06367 qbdd = qincr && yy <= 0.0e0 || !qincr && yy >= 0.0e0; 06368 qlim = xlb <= small; 06369 qcond = qbdd || qlim; 06370 if(qcond) goto S210; 06371 step = stpmul*step; 06372 xub = xlb; 06373 xlb = fifdmax1(xub-step,small); 06374 S210: 06375 goto S180; 06376 S220: 06377 if(!(qlim && !qbdd)) goto S230; 06378 *status = -1; 06379 *qleft = 1; 06380 *qhi = qincr; 06381 *x = small; 06382 return; 06383 S240: 06384 S230: 06385 dstzr(&xlb,&xub,&abstol,&reltol); 06386 /* 06387 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06388 IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F. 06389 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 06390 */ 06391 *status = 0; 06392 goto S260; 06393 S250: 06394 if(!(*status == 1)) goto S290; 06395 S260: 06396 dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2); 06397 if(!(*status == 1)) goto S280; 06398 /* 06399 GET-FUNCTION-VALUE 06400 */ 06401 i99999 = 6; 06402 goto S300; 06403 S280: 06404 S270: 06405 goto S250; 06406 S290: 06407 *x = xlo; 06408 *status = 0; 06409 return; 06410 DSTINV: 06411 small = *zsmall; 06412 big = *zbig; 06413 absstp = *zabsst; 06414 relstp = *zrelst; 06415 stpmul = *zstpmu; 06416 abstol = *zabsto; 06417 reltol = *zrelto; 06418 return; 06419 S300: 06420 /* 06421 TO GET-FUNCTION-VALUE 06422 */ 06423 *status = 1; 06424 return; 06425 S310: 06426 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case 06427 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;} 06428 #undef qxmon 06429 } /* END */ 06430 06431 /***=====================================================================***/ 06432 static void dinvr(int *status,double *x,double *fx, 06433 unsigned long *qleft,unsigned long *qhi) 06434 /* 06435 ********************************************************************** 06436 06437 void dinvr(int *status,double *x,double *fx, 06438 unsigned long *qleft,unsigned long *qhi) 06439 06440 Double precision 06441 bounds the zero of the function and invokes zror 06442 Reverse Communication 06443 06444 06445 Function 06446 06447 06448 Bounds the function and invokes ZROR to perform the zero 06449 finding. STINVR must have been called before this routine 06450 in order to set its parameters. 06451 06452 06453 Arguments 06454 06455 06456 STATUS <--> At the beginning of a zero finding problem, STATUS 06457 should be set to 0 and INVR invoked. (The value 06458 of parameters other than X will be ignored on this cal 06459 06460 When INVR needs the function evaluated, it will set 06461 STATUS to 1 and return. The value of the function 06462 should be set in FX and INVR again called without 06463 changing any of its other parameters. 06464 06465 When INVR has finished without error, it will return 06466 with STATUS 0. In that case X is approximately a root 06467 of F(X). 06468 06469 If INVR cannot bound the function, it returns status 06470 -1 and sets QLEFT and QHI. 06471 INTEGER STATUS 06472 06473 X <-- The value of X at which F(X) is to be evaluated. 06474 DOUBLE PRECISION X 06475 06476 FX --> The value of F(X) calculated when INVR returns with 06477 STATUS = 1. 06478 DOUBLE PRECISION FX 06479 06480 QLEFT <-- Defined only if QMFINV returns .FALSE. In that 06481 case it is .TRUE. If the stepping search terminated 06482 unsucessfully at SMALL. If it is .FALSE. the search 06483 terminated unsucessfully at BIG. 06484 QLEFT is LOGICAL 06485 06486 QHI <-- Defined only if QMFINV returns .FALSE. In that 06487 case it is .TRUE. if F(X) .GT. Y at the termination 06488 of the search and .FALSE. if F(X) .LT. Y at the 06489 termination of the search. 06490 QHI is LOGICAL 06491 06492 ********************************************************************** 06493 */ 06494 { 06495 E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL); 06496 } /* END */ 06497 06498 /***=====================================================================***/ 06499 static void dstinv(double *zsmall,double *zbig,double *zabsst, 06500 double *zrelst,double *zstpmu,double *zabsto, 06501 double *zrelto) 06502 /* 06503 ********************************************************************** 06504 void dstinv(double *zsmall,double *zbig,double *zabsst, 06505 double *zrelst,double *zstpmu,double *zabsto, 06506 double *zrelto) 06507 06508 Double Precision - SeT INverse finder - Reverse Communication 06509 Function 06510 Concise Description - Given a monotone function F finds X 06511 such that F(X) = Y. Uses Reverse communication -- see invr. 06512 This routine sets quantities needed by INVR. 06513 More Precise Description of INVR - 06514 F must be a monotone function, the results of QMFINV are 06515 otherwise undefined. QINCR must be .TRUE. if F is non- 06516 decreasing and .FALSE. if F is non-increasing. 06517 QMFINV will return .TRUE. if and only if F(SMALL) and 06518 F(BIG) bracket Y, i. e., 06519 QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or 06520 QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL) 06521 if QMFINV returns .TRUE., then the X returned satisfies 06522 the following condition. let 06523 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) 06524 then if QINCR is .TRUE., 06525 F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X)) 06526 and if QINCR is .FALSE. 06527 F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X)) 06528 Arguments 06529 SMALL --> The left endpoint of the interval to be 06530 searched for a solution. 06531 SMALL is DOUBLE PRECISION 06532 BIG --> The right endpoint of the interval to be 06533 searched for a solution. 06534 BIG is DOUBLE PRECISION 06535 ABSSTP, RELSTP --> The initial step size in the search 06536 is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm. 06537 ABSSTP is DOUBLE PRECISION 06538 RELSTP is DOUBLE PRECISION 06539 STPMUL --> When a step doesn't bound the zero, the step 06540 size is multiplied by STPMUL and another step 06541 taken. A popular value is 2.0 06542 DOUBLE PRECISION STPMUL 06543 ABSTOL, RELTOL --> Two numbers that determine the accuracy 06544 of the solution. See function for a precise definition. 06545 ABSTOL is DOUBLE PRECISION 06546 RELTOL is DOUBLE PRECISION 06547 Method 06548 Compares F(X) with Y for the input value of X then uses QINCR 06549 to determine whether to step left or right to bound the 06550 desired x. the initial step size is 06551 MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X. 06552 Iteratively steps right or left until it bounds X. 06553 At each step which doesn't bound X, the step size is doubled. 06554 The routine is careful never to step beyond SMALL or BIG. If 06555 it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE. 06556 after setting QLEFT and QHI. 06557 If X is successfully bounded then Algorithm R of the paper 06558 'Two Efficient Algorithms with Guaranteed Convergence for 06559 Finding a Zero of a Function' by J. C. P. Bus and 06560 T. J. Dekker in ACM Transactions on Mathematical 06561 Software, Volume 1, No. 4 page 330 (DEC. '75) is employed 06562 to find the zero of the function F(X)-Y. This is routine 06563 QRZERO. 06564 ********************************************************************** 06565 */ 06566 { 06567 E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall, 06568 zstpmu); 06569 } /* END */ 06570 06571 /***=====================================================================***/ 06572 static double dlanor(double *x) 06573 /* 06574 ********************************************************************** 06575 06576 double dlanor(double *x) 06577 Double precision Logarith of the Asymptotic Normal 06578 06579 06580 Function 06581 06582 06583 Computes the logarithm of the cumulative normal distribution 06584 from abs( x ) to infinity for abs( x ) >= 5. 06585 06586 06587 Arguments 06588 06589 06590 X --> Value at which cumulative normal to be evaluated 06591 DOUBLE PRECISION X 06592 06593 06594 Method 06595 06596 06597 23 term expansion of formula 26.2.12 of Abramowitz and Stegun. 06598 The relative error at X = 5 is about 0.5E-5. 06599 06600 06601 Note 06602 06603 06604 ABS(X) must be >= 5 else there is an error stop. 06605 06606 ********************************************************************** 06607 */ 06608 { 06609 #define dlsqpi 0.91893853320467274177e0 06610 static double coef[12] = { 06611 -1.0e0,3.0e0,-15.0e0,105.0e0,-945.0e0,10395.0e0,-135135.0e0,2027025.0e0, 06612 -34459425.0e0,654729075.0e0,-13749310575.e0,316234143225.0e0 06613 }; 06614 static int K1 = 12; 06615 static double dlanor,approx,correc,xx,xx2,T2; 06616 /* 06617 .. 06618 .. Executable Statements .. 06619 */ 06620 xx = fabs(*x); 06621 if(xx < 5.0e0){ ftnstop("Argument too small in DLANOR"); return 66.6; } 06622 approx = -dlsqpi-0.5e0*xx*xx-log(xx); 06623 xx2 = xx*xx; 06624 T2 = 1.0e0/xx2; 06625 correc = devlpl(coef,&K1,&T2)/xx2; 06626 correc = dln1px(&correc); 06627 dlanor = approx+correc; 06628 return dlanor; 06629 #undef dlsqpi 06630 } /* END */ 06631 06632 /***=====================================================================***/ 06633 static double dln1mx(double *x) 06634 /* 06635 ********************************************************************** 06636 06637 double dln1mx(double *x) 06638 Double precision LN(1-X) 06639 06640 06641 Function 06642 06643 06644 Returns ln(1-x) for small x (good accuracy if x .le. 0.1). 06645 Note that the obvious code of 06646 LOG(1.0-X) 06647 won't work for small X because 1.0-X loses accuracy 06648 06649 06650 Arguments 06651 06652 06653 X --> Value for which ln(1-x) is desired. 06654 X is DOUBLE PRECISION 06655 06656 06657 Method 06658 06659 06660 If X > 0.1, the obvious code above is used ELSE 06661 The Taylor series for 1-x is expanded to 20 terms. 06662 06663 ********************************************************************** 06664 */ 06665 { 06666 static double dln1mx,T1; 06667 /* 06668 .. 06669 .. Executable Statements .. 06670 */ 06671 T1 = -*x; 06672 dln1mx = dln1px(&T1); 06673 return dln1mx; 06674 } /* END */ 06675 06676 /***=====================================================================***/ 06677 static double dln1px(double *a) 06678 /* 06679 ********************************************************************** 06680 06681 double dln1px(double *a) 06682 Double precision LN(1+X) 06683 06684 06685 Function 06686 06687 06688 Returns ln(1+x) 06689 Note that the obvious code of 06690 LOG(1.0+X) 06691 won't work for small X because 1.0+X loses accuracy 06692 06693 06694 Arguments 06695 06696 06697 X --> Value for which ln(1-x) is desired. 06698 X is DOUBLE PRECISION 06699 06700 06701 Method 06702 06703 06704 Renames ALNREL from: 06705 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant 06706 Digit Computation of the Incomplete Beta Function Ratios. ACM 06707 Trans. Math. Softw. 18 (1993), 360-373. 06708 06709 ********************************************************************** 06710 ----------------------------------------------------------------------- 06711 EVALUATION OF THE FUNCTION LN(1 + A) 06712 ----------------------------------------------------------------------- 06713 */ 06714 { 06715 static double p1 = -.129418923021993e+01; 06716 static double p2 = .405303492862024e+00; 06717 static double p3 = -.178874546012214e-01; 06718 static double q1 = -.162752256355323e+01; 06719 static double q2 = .747811014037616e+00; 06720 static double q3 = -.845104217945565e-01; 06721 static double dln1px,t,t2,w,x; 06722 /* 06723 .. 06724 .. Executable Statements .. 06725 */ 06726 if(fabs(*a) > 0.375e0) goto S10; 06727 t = *a/(*a+2.0e0); 06728 t2 = t*t; 06729 w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0); 06730 dln1px = 2.0e0*t*w; 06731 return dln1px; 06732 S10: 06733 x = 1.e0+*a; 06734 dln1px = log(x); 06735 return dln1px; 06736 } /* END */ 06737 06738 /***=====================================================================***/ 06739 static double dlnbet(double *a0,double *b0) 06740 /* 06741 ********************************************************************** 06742 06743 double dlnbet(a0,b0) 06744 Double precision LN of the complete BETa 06745 06746 06747 Function 06748 06749 06750 Returns the natural log of the complete beta function, 06751 i.e., 06752 06753 ln( Gamma(a)*Gamma(b) / Gamma(a+b) 06754 06755 06756 Arguments 06757 06758 06759 A,B --> The (symmetric) arguments to the complete beta 06760 DOUBLE PRECISION A, B 06761 06762 06763 Method 06764 06765 06766 Renames BETALN from: 06767 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant 06768 Digit Computation of the Incomplete Beta Function Ratios. ACM 06769 Trans. Math. Softw. 18 (1993), 360-373. 06770 06771 ********************************************************************** 06772 ----------------------------------------------------------------------- 06773 EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION 06774 ----------------------------------------------------------------------- 06775 E = 0.5*LN(2*PI) 06776 -------------------------- 06777 */ 06778 { 06779 static double e = .918938533204673e0; 06780 static double dlnbet,a,b,c,h,u,v,w,z; 06781 static int i,n; 06782 static double T1; 06783 /* 06784 .. 06785 .. Executable Statements .. 06786 */ 06787 a = fifdmin1(*a0,*b0); 06788 b = fifdmax1(*a0,*b0); 06789 if(a >= 8.0e0) goto S100; 06790 if(a >= 1.0e0) goto S20; 06791 /* 06792 ----------------------------------------------------------------------- 06793 PROCEDURE WHEN A .LT. 1 06794 ----------------------------------------------------------------------- 06795 */ 06796 if(b >= 8.0e0) goto S10; 06797 T1 = a+b; 06798 dlnbet = gamln(&a)+(gamln(&b)-gamln(&T1)); 06799 return dlnbet; 06800 S10: 06801 dlnbet = gamln(&a)+algdiv(&a,&b); 06802 return dlnbet; 06803 S20: 06804 /* 06805 ----------------------------------------------------------------------- 06806 PROCEDURE WHEN 1 .LE. A .LT. 8 06807 ----------------------------------------------------------------------- 06808 */ 06809 if(a > 2.0e0) goto S40; 06810 if(b > 2.0e0) goto S30; 06811 dlnbet = gamln(&a)+gamln(&b)-gsumln(&a,&b); 06812 return dlnbet; 06813 S30: 06814 w = 0.0e0; 06815 if(b < 8.0e0) goto S60; 06816 dlnbet = gamln(&a)+algdiv(&a,&b); 06817 return dlnbet; 06818 S40: 06819 /* 06820 REDUCTION OF A WHEN B .LE. 1000 06821 */ 06822 if(b > 1000.0e0) goto S80; 06823 n = a-1.0e0; 06824 w = 1.0e0; 06825 for(i=1; i<=n; i++) { 06826 a -= 1.0e0; 06827 h = a/b; 06828 w *= (h/(1.0e0+h)); 06829 } 06830 w = log(w); 06831 if(b < 8.0e0) goto S60; 06832 dlnbet = w+gamln(&a)+algdiv(&a,&b); 06833 return dlnbet; 06834 S60: 06835 /* 06836 REDUCTION OF B WHEN B .LT. 8 06837 */ 06838 n = b-1.0e0; 06839 z = 1.0e0; 06840 for(i=1; i<=n; i++) { 06841 b -= 1.0e0; 06842 z *= (b/(a+b)); 06843 } 06844 dlnbet = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b))); 06845 return dlnbet; 06846 S80: 06847 /* 06848 REDUCTION OF A WHEN B .GT. 1000 06849 */ 06850 n = a-1.0e0; 06851 w = 1.0e0; 06852 for(i=1; i<=n; i++) { 06853 a -= 1.0e0; 06854 w *= (a/(1.0e0+a/b)); 06855 } 06856 dlnbet = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b)); 06857 return dlnbet; 06858 S100: 06859 /* 06860 ----------------------------------------------------------------------- 06861 PROCEDURE WHEN A .GE. 8 06862 ----------------------------------------------------------------------- 06863 */ 06864 w = bcorr(&a,&b); 06865 h = a/b; 06866 c = h/(1.0e0+h); 06867 u = -((a-0.5e0)*log(c)); 06868 v = b*alnrel(&h); 06869 if(u <= v) goto S110; 06870 dlnbet = -(0.5e0*log(b))+e+w-v-u; 06871 return dlnbet; 06872 S110: 06873 dlnbet = -(0.5e0*log(b))+e+w-u-v; 06874 return dlnbet; 06875 } /* END */ 06876 06877 /***=====================================================================***/ 06878 static double dlngam(double *a) 06879 /* 06880 ********************************************************************** 06881 06882 double dlngam(double *a) 06883 Double precision LN of the GAMma function 06884 06885 06886 Function 06887 06888 06889 Returns the natural logarithm of GAMMA(X). 06890 06891 06892 Arguments 06893 06894 06895 X --> value at which scaled log gamma is to be returned 06896 X is DOUBLE PRECISION 06897 06898 06899 Method 06900 06901 06902 Renames GAMLN from: 06903 DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant 06904 Digit Computation of the Incomplete Beta Function Ratios. ACM 06905 Trans. Math. Softw. 18 (1993), 360-373. 06906 06907 ********************************************************************** 06908 ----------------------------------------------------------------------- 06909 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A 06910 ----------------------------------------------------------------------- 06911 WRITTEN BY ALFRED H. MORRIS 06912 NAVAL SURFACE WARFARE CENTER 06913 DAHLGREN, VIRGINIA 06914 -------------------------- 06915 D = 0.5*(LN(2*PI) - 1) 06916 -------------------------- 06917 */ 06918 { 06919 static double c0 = .833333333333333e-01; 06920 static double c1 = -.277777777760991e-02; 06921 static double c2 = .793650666825390e-03; 06922 static double c3 = -.595202931351870e-03; 06923 static double c4 = .837308034031215e-03; 06924 static double c5 = -.165322962780713e-02; 06925 static double d = .418938533204673e0; 06926 static double dlngam,t,w; 06927 static int i,n; 06928 static double T1; 06929 /* 06930 .. 06931 .. Executable Statements .. 06932 */ 06933 if(*a > 0.8e0) goto S10; 06934 dlngam = gamln1(a)-log(*a); 06935 return dlngam; 06936 S10: 06937 if(*a > 2.25e0) goto S20; 06938 t = *a-0.5e0-0.5e0; 06939 dlngam = gamln1(&t); 06940 return dlngam; 06941 S20: 06942 if(*a >= 10.0e0) goto S40; 06943 n = *a-1.25e0; 06944 t = *a; 06945 w = 1.0e0; 06946 for(i=1; i<=n; i++) { 06947 t -= 1.0e0; 06948 w = t*w; 06949 } 06950 T1 = t-1.0e0; 06951 dlngam = gamln1(&T1)+log(w); 06952 return dlngam; 06953 S40: 06954 t = pow(1.0e0/ *a,2.0); 06955 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a; 06956 dlngam = d+w+(*a-0.5e0)*(log(*a)-1.0e0); 06957 return dlngam; 06958 } /* END */ 06959 06960 /***=====================================================================***/ 06961 static double dstrem(double *z) 06962 { 06963 /* 06964 ********************************************************************** 06965 double dstrem(double *z) 06966 Double precision Sterling Remainder 06967 Function 06968 Returns Log(Gamma(Z)) - Sterling(Z) where Sterling(Z) is 06969 Sterling's Approximation to Log(Gamma(Z)) 06970 Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z 06971 Arguments 06972 Z --> Value at which Sterling remainder calculated 06973 Must be positive. 06974 DOUBLE PRECISION Z 06975 Method 06976 If Z >= 6 uses 9 terms of series in Bernoulli numbers 06977 (Values calculated using Maple) 06978 Otherwise computes difference explicitly 06979 ********************************************************************** 06980 */ 06981 #define hln2pi 0.91893853320467274178e0 06982 #define ncoef 10 06983 static double coef[ncoef] = { 06984 0.0e0,0.0833333333333333333333333333333e0, 06985 -0.00277777777777777777777777777778e0,0.000793650793650793650793650793651e0, 06986 -0.000595238095238095238095238095238e0, 06987 0.000841750841750841750841750841751e0,-0.00191752691752691752691752691753e0, 06988 0.00641025641025641025641025641026e0,-0.0295506535947712418300653594771e0, 06989 0.179644372368830573164938490016e0 06990 }; 06991 static int K1 = 10; 06992 static double dstrem,sterl,T2; 06993 /* 06994 .. 06995 .. Executable Statements .. 06996 */ 06997 /* 06998 For information, here are the next 11 coefficients of the 06999 remainder term in Sterling's formula 07000 -1.39243221690590111642743221691 07001 13.4028640441683919944789510007 07002 -156.848284626002017306365132452 07003 2193.10333333333333333333333333 07004 -36108.7712537249893571732652192 07005 691472.268851313067108395250776 07006 -0.152382215394074161922833649589D8 07007 0.382900751391414141414141414141D9 07008 -0.108822660357843910890151491655D11 07009 0.347320283765002252252252252252D12 07010 -0.123696021422692744542517103493D14 07011 */ 07012 if(*z <= 0.0e0){ ftnstop("nonpositive argument in DSTREM"); return 66.6; } 07013 if(!(*z > 6.0e0)) goto S10; 07014 T2 = 1.0e0/pow(*z,2.0); 07015 dstrem = devlpl(coef,&K1,&T2)**z; 07016 goto S20; 07017 S10: 07018 sterl = hln2pi+(*z-0.5e0)*log(*z)-*z; 07019 dstrem = dlngam(z)-sterl; 07020 S20: 07021 return dstrem; 07022 #undef hln2pi 07023 #undef ncoef 07024 } /* END */ 07025 07026 /***=====================================================================***/ 07027 static double dt1(double *p,double *q,double *df) 07028 /* 07029 ********************************************************************** 07030 07031 double dt1(double *p,double *q,double *df) 07032 Double precision Initalize Approximation to 07033 INVerse of the cumulative T distribution 07034 07035 07036 Function 07037 07038 07039 Returns the inverse of the T distribution function, i.e., 07040 the integral from 0 to INVT of the T density is P. This is an 07041 initial approximation 07042 07043 07044 Arguments 07045 07046 07047 P --> The p-value whose inverse from the T distribution is 07048 desired. 07049 P is DOUBLE PRECISION 07050 07051 Q --> 1-P. 07052 Q is DOUBLE PRECISION 07053 07054 DF --> Degrees of freedom of the T distribution. 07055 DF is DOUBLE PRECISION 07056 07057 ********************************************************************** 07058 */ 07059 { 07060 static double coef[4][5] = { 07061 1.0e0,1.0e0,0.0e0,0.0e0,0.0e0,3.0e0,16.0e0,5.0e0,0.0e0,0.0e0,-15.0e0,17.0e0, 07062 19.0e0,3.0e0,0.0e0,-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0 07063 }; 07064 static double denom[4] = { 07065 4.0e0,96.0e0,384.0e0,92160.0e0 07066 }; 07067 static int ideg[4] = { 07068 2,3,4,5 07069 }; 07070 static double dt1,denpow,sum,term,x,xp,xx; 07071 static int i; 07072 /* 07073 .. 07074 .. Executable Statements .. 07075 */ 07076 x = fabs(dinvnr(p,q)); 07077 xx = x*x; 07078 sum = x; 07079 denpow = 1.0e0; 07080 for(i=0; i<4; i++) { 07081 term = devlpl(&coef[i][0],&ideg[i],&xx)*x; 07082 denpow *= *df; 07083 sum += (term/(denpow*denom[i])); 07084 } 07085 if(!(*p >= 0.5e0)) goto S20; 07086 xp = sum; 07087 goto S30; 07088 S20: 07089 xp = -sum; 07090 S30: 07091 dt1 = xp; 07092 return dt1; 07093 } /* END */ 07094 07095 /***=====================================================================***/ 07096 static void E0001(int IENTRY,int *status,double *x,double *fx, 07097 double *xlo,double *xhi,unsigned long *qleft, 07098 unsigned long *qhi,double *zabstl,double *zreltl, 07099 double *zxhi,double *zxlo) 07100 { 07101 #define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx)))) 07102 static double a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo; 07103 static int ext,i99999; 07104 static unsigned long first,qrzero; 07105 switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;} 07106 DZROR: 07107 if(*status > 0) goto S280; 07108 *xlo = xxlo; 07109 *xhi = xxhi; 07110 b = *x = *xlo; 07111 /* 07112 GET-FUNCTION-VALUE 07113 */ 07114 i99999 = 1; 07115 goto S270; 07116 S10: 07117 fb = *fx; 07118 *xlo = *xhi; 07119 a = *x = *xlo; 07120 /* 07121 GET-FUNCTION-VALUE 07122 */ 07123 i99999 = 2; 07124 goto S270; 07125 S20: 07126 /* 07127 Check that F(ZXLO) < 0 < F(ZXHI) or 07128 F(ZXLO) > 0 > F(ZXHI) 07129 */ 07130 if(!(fb < 0.0e0)) goto S40; 07131 if(!(*fx < 0.0e0)) goto S30; 07132 *status = -1; 07133 *qleft = *fx < fb; 07134 *qhi = 0; 07135 return; 07136 S40: 07137 S30: 07138 if(!(fb > 0.0e0)) goto S60; 07139 if(!(*fx > 0.0e0)) goto S50; 07140 *status = -1; 07141 *qleft = *fx > fb; 07142 *qhi = 1; 07143 return; 07144 S60: 07145 S50: 07146 fa = *fx; 07147 first = 1; 07148 S70: 07149 c = a; 07150 fc = fa; 07151 ext = 0; 07152 S80: 07153 if(!(fabs(fc) < fabs(fb))) goto S100; 07154 if(!(c != a)) goto S90; 07155 d = a; 07156 fd = fa; 07157 S90: 07158 a = b; 07159 fa = fb; 07160 *xlo = c; 07161 b = *xlo; 07162 fb = fc; 07163 c = a; 07164 fc = fa; 07165 S100: 07166 tol = ftol(*xlo); 07167 m = (c+b)*.5e0; 07168 mb = m-b; 07169 if(!(fabs(mb) > tol)) goto S240; 07170 if(!(ext > 3)) goto S110; 07171 w = mb; 07172 goto S190; 07173 S110: 07174 tol = fifdsign(tol,mb); 07175 p = (b-a)*fb; 07176 if(!first) goto S120; 07177 q = fa-fb; 07178 first = 0; 07179 goto S130; 07180 S120: 07181 fdb = (fd-fb)/(d-b); 07182 fda = (fd-fa)/(d-a); 07183 p = fda*p; 07184 q = fdb*fa-fda*fb; 07185 S130: 07186 if(!(p < 0.0e0)) goto S140; 07187 p = -p; 07188 q = -q; 07189 S140: 07190 if(ext == 3) p *= 2.0e0; 07191 if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150; 07192 w = tol; 07193 goto S180; 07194 S150: 07195 if(!(p < mb*q)) goto S160; 07196 w = p/q; 07197 goto S170; 07198 S160: 07199 w = mb; 07200 S190: 07201 S180: 07202 S170: 07203 d = a; 07204 fd = fa; 07205 a = b; 07206 fa = fb; 07207 b += w; 07208 *xlo = b; 07209 *x = *xlo; 07210 /* 07211 GET-FUNCTION-VALUE 07212 */ 07213 i99999 = 3; 07214 goto S270; 07215 S200: 07216 fb = *fx; 07217 if(!(fc*fb >= 0.0e0)) goto S210; 07218 goto S70; 07219 S210: 07220 if(!(w == mb)) goto S220; 07221 ext = 0; 07222 goto S230; 07223 S220: 07224 ext += 1; 07225 S230: 07226 goto S80; 07227 S240: 07228 *xhi = c; 07229 qrzero = fc >= 0.0e0 && fb <= 0.0e0 || fc < 0.0e0 && fb >= 0.0e0; 07230 if(!qrzero) goto S250; 07231 *status = 0; 07232 goto S260; 07233 S250: 07234 *status = -1; 07235 S260: 07236 return; 07237 DSTZR: 07238 xxlo = *zxlo; 07239 xxhi = *zxhi; 07240 abstol = *zabstl; 07241 reltol = *zreltl; 07242 return; 07243 S270: 07244 /* 07245 TO GET-FUNCTION-VALUE 07246 */ 07247 *status = 1; 07248 return; 07249 S280: 07250 switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200; 07251 default: break;} 07252 #undef ftol 07253 } /* END */ 07254 07255 /***=====================================================================***/ 07256 static void dzror(int *status,double *x,double *fx,double *xlo, 07257 double *xhi,unsigned long *qleft,unsigned long *qhi) 07258 /* 07259 ********************************************************************** 07260 07261 void dzror(int *status,double *x,double *fx,double *xlo, 07262 double *xhi,unsigned long *qleft,unsigned long *qhi) 07263 07264 Double precision ZeRo of a function -- Reverse Communication 07265 07266 07267 Function 07268 07269 07270 Performs the zero finding. STZROR must have been called before 07271 this routine in order to set its parameters. 07272 07273 07274 Arguments 07275 07276 07277 STATUS <--> At the beginning of a zero finding problem, STATUS 07278 should be set to 0 and ZROR invoked. (The value 07279 of other parameters will be ignored on this call.) 07280 07281 When ZROR needs the function evaluated, it will set 07282 STATUS to 1 and return. The value of the function 07283 should be set in FX and ZROR again called without 07284 changing any of its other parameters. 07285 07286 When ZROR has finished without error, it will return 07287 with STATUS 0. In that case (XLO,XHI) bound the answe 07288 07289 If ZROR finds an error (which implies that F(XLO)-Y an 07290 F(XHI)-Y have the same sign, it returns STATUS -1. In 07291 this case, XLO and XHI are undefined. 07292 INTEGER STATUS 07293 07294 X <-- The value of X at which F(X) is to be evaluated. 07295 DOUBLE PRECISION X 07296 07297 FX --> The value of F(X) calculated when ZROR returns with 07298 STATUS = 1. 07299 DOUBLE PRECISION FX 07300 07301 XLO <-- When ZROR returns with STATUS = 0, XLO bounds the 07302 inverval in X containing the solution below. 07303 DOUBLE PRECISION XLO 07304 07305 XHI <-- When ZROR returns with STATUS = 0, XHI bounds the 07306 inverval in X containing the solution above. 07307 DOUBLE PRECISION XHI 07308 07309 QLEFT <-- .TRUE. if the stepping search terminated unsucessfully 07310 at XLO. If it is .FALSE. the search terminated 07311 unsucessfully at XHI. 07312 QLEFT is LOGICAL 07313 07314 QHI <-- .TRUE. if F(X) .GT. Y at the termination of the 07315 search and .FALSE. if F(X) .LT. Y at the 07316 termination of the search. 07317 QHI is LOGICAL 07318 07319 ********************************************************************** 07320 */ 07321 { 07322 E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL); 07323 } /* END */ 07324 07325 /***=====================================================================***/ 07326 static void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) 07327 /* 07328 ********************************************************************** 07329 void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) 07330 Double precision SeT ZeRo finder - Reverse communication version 07331 Function 07332 Sets quantities needed by ZROR. The function of ZROR 07333 and the quantities set is given here. 07334 Concise Description - Given a function F 07335 find XLO such that F(XLO) = 0. 07336 More Precise Description - 07337 Input condition. F is a double precision function of a single 07338 double precision argument and XLO and XHI are such that 07339 F(XLO)*F(XHI) .LE. 0.0 07340 If the input condition is met, QRZERO returns .TRUE. 07341 and output values of XLO and XHI satisfy the following 07342 F(XLO)*F(XHI) .LE. 0. 07343 ABS(F(XLO) .LE. ABS(F(XHI) 07344 ABS(XLO-XHI) .LE. TOL(X) 07345 where 07346 TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) 07347 If this algorithm does not find XLO and XHI satisfying 07348 these conditions then QRZERO returns .FALSE. This 07349 implies that the input condition was not met. 07350 Arguments 07351 XLO --> The left endpoint of the interval to be 07352 searched for a solution. 07353 XLO is DOUBLE PRECISION 07354 XHI --> The right endpoint of the interval to be 07355 for a solution. 07356 XHI is DOUBLE PRECISION 07357 ABSTOL, RELTOL --> Two numbers that determine the accuracy 07358 of the solution. See function for a 07359 precise definition. 07360 ABSTOL is DOUBLE PRECISION 07361 RELTOL is DOUBLE PRECISION 07362 Method 07363 Algorithm R of the paper 'Two Efficient Algorithms with 07364 Guaranteed Convergence for Finding a Zero of a Function' 07365 by J. C. P. Bus and T. J. Dekker in ACM Transactions on 07366 Mathematical Software, Volume 1, no. 4 page 330 07367 (Dec. '75) is employed to find the zero of F(X)-Y. 07368 ********************************************************************** 07369 */ 07370 { 07371 E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo); 07372 } /* END */ 07373 07374 /***=====================================================================***/ 07375 static double erf1(double *x) 07376 /* 07377 ----------------------------------------------------------------------- 07378 EVALUATION OF THE REAL ERROR FUNCTION 07379 ----------------------------------------------------------------------- 07380 */ 07381 { 07382 static double c = .564189583547756e0; 07383 static double a[5] = { 07384 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, 07385 .479137145607681e-01,.128379167095513e+00 07386 }; 07387 static double b[3] = { 07388 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 07389 }; 07390 static double p[8] = { 07391 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, 07392 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, 07393 4.51918953711873e+02,3.00459261020162e+02 07394 }; 07395 static double q[8] = { 07396 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, 07397 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, 07398 7.90950925327898e+02,3.00459260956983e+02 07399 }; 07400 static double r[5] = { 07401 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, 07402 4.65807828718470e+00,2.82094791773523e-01 07403 }; 07404 static double s[4] = { 07405 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, 07406 1.80124575948747e+01 07407 }; 07408 static double erf1,ax,bot,t,top,x2; 07409 /* 07410 .. 07411 .. Executable Statements .. 07412 */ 07413 ax = fabs(*x); 07414 if(ax > 0.5e0) goto S10; 07415 t = *x**x; 07416 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; 07417 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; 07418 erf1 = *x*(top/bot); 07419 return erf1; 07420 S10: 07421 if(ax > 4.0e0) goto S20; 07422 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ 07423 7]; 07424 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ 07425 7]; 07426 erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot); 07427 if(*x < 0.0e0) erf1 = -erf1; 07428 return erf1; 07429 S20: 07430 if(ax >= 5.8e0) goto S30; 07431 x2 = *x**x; 07432 t = 1.0e0/x2; 07433 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; 07434 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; 07435 erf1 = (c-top/(x2*bot))/ax; 07436 erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1); 07437 if(*x < 0.0e0) erf1 = -erf1; 07438 return erf1; 07439 S30: 07440 erf1 = fifdsign(1.0e0,*x); 07441 return erf1; 07442 } /* END */ 07443 07444 /***=====================================================================***/ 07445 static double erfc1(int *ind,double *x) 07446 /* 07447 ----------------------------------------------------------------------- 07448 EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION 07449 07450 ERFC1(IND,X) = ERFC(X) IF IND = 0 07451 ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE 07452 ----------------------------------------------------------------------- 07453 */ 07454 { 07455 static double c = .564189583547756e0; 07456 static double a[5] = { 07457 .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, 07458 .479137145607681e-01,.128379167095513e+00 07459 }; 07460 static double b[3] = { 07461 .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 07462 }; 07463 static double p[8] = { 07464 -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, 07465 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, 07466 4.51918953711873e+02,3.00459261020162e+02 07467 }; 07468 static double q[8] = { 07469 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, 07470 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, 07471 7.90950925327898e+02,3.00459260956983e+02 07472 }; 07473 static double r[5] = { 07474 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, 07475 4.65807828718470e+00,2.82094791773523e-01 07476 }; 07477 static double s[4] = { 07478 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, 07479 1.80124575948747e+01 07480 }; 07481 static int K1 = 1; 07482 static double erfc1,ax,bot,e,t,top,w; 07483 /* 07484 .. 07485 .. Executable Statements .. 07486 */ 07487 /* 07488 ABS(X) .LE. 0.5 07489 */ 07490 ax = fabs(*x); 07491 if(ax > 0.5e0) goto S10; 07492 t = *x**x; 07493 top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; 07494 bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; 07495 erfc1 = 0.5e0+(0.5e0-*x*(top/bot)); 07496 if(*ind != 0) erfc1 = exp(t)*erfc1; 07497 return erfc1; 07498 S10: 07499 /* 07500 0.5 .LT. ABS(X) .LE. 4 07501 */ 07502 if(ax > 4.0e0) goto S20; 07503 top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ 07504 7]; 07505 bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ 07506 7]; 07507 erfc1 = top/bot; 07508 goto S40; 07509 S20: 07510 /* 07511 ABS(X) .GT. 4 07512 */ 07513 if(*x <= -5.6e0) goto S60; 07514 if(*ind != 0) goto S30; 07515 if(*x > 100.0e0) goto S70; 07516 if(*x**x > -exparg(&K1)) goto S70; 07517 S30: 07518 t = pow(1.0e0/ *x,2.0); 07519 top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; 07520 bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; 07521 erfc1 = (c-t*top/bot)/ax; 07522 S40: 07523 /* 07524 FINAL ASSEMBLY 07525 */ 07526 if(*ind == 0) goto S50; 07527 if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1; 07528 return erfc1; 07529 S50: 07530 w = *x**x; 07531 t = w; 07532 e = w-t; 07533 erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1; 07534 if(*x < 0.0e0) erfc1 = 2.0e0-erfc1; 07535 return erfc1; 07536 S60: 07537 /* 07538 LIMIT VALUE FOR LARGE NEGATIVE X 07539 */ 07540 erfc1 = 2.0e0; 07541 if(*ind != 0) erfc1 = 2.0e0*exp(*x**x); 07542 return erfc1; 07543 S70: 07544 /* 07545 LIMIT VALUE FOR LARGE POSITIVE X 07546 WHEN IND = 0 07547 */ 07548 erfc1 = 0.0e0; 07549 return erfc1; 07550 } /* END */ 07551 07552 /***=====================================================================***/ 07553 static double esum(int *mu,double *x) 07554 /* 07555 ----------------------------------------------------------------------- 07556 EVALUATION OF EXP(MU + X) 07557 ----------------------------------------------------------------------- 07558 */ 07559 { 07560 static double esum,w; 07561 /* 07562 .. 07563 .. Executable Statements .. 07564 */ 07565 if(*x > 0.0e0) goto S10; 07566 if(*mu < 0) goto S20; 07567 w = (double)*mu+*x; 07568 if(w > 0.0e0) goto S20; 07569 esum = exp(w); 07570 return esum; 07571 S10: 07572 if(*mu > 0) goto S20; 07573 w = (double)*mu+*x; 07574 if(w < 0.0e0) goto S20; 07575 esum = exp(w); 07576 return esum; 07577 S20: 07578 w = *mu; 07579 esum = exp(w)*exp(*x); 07580 return esum; 07581 } /* END */ 07582 07583 /***=====================================================================***/ 07584 static double exparg(int *l) 07585 /* 07586 -------------------------------------------------------------------- 07587 IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH 07588 EXP(W) CAN BE COMPUTED. 07589 07590 IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR 07591 WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO. 07592 07593 NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED. 07594 -------------------------------------------------------------------- 07595 */ 07596 { 07597 static int K1 = 4; 07598 static int K2 = 9; 07599 static int K3 = 10; 07600 static double exparg,lnb; 07601 static int b,m; 07602 /* 07603 .. 07604 .. Executable Statements .. 07605 */ 07606 b = ipmpar(&K1); 07607 if(b != 2) goto S10; 07608 lnb = .69314718055995e0; 07609 goto S40; 07610 S10: 07611 if(b != 8) goto S20; 07612 lnb = 2.0794415416798e0; 07613 goto S40; 07614 S20: 07615 if(b != 16) goto S30; 07616 lnb = 2.7725887222398e0; 07617 goto S40; 07618 S30: 07619 lnb = log((double)b); 07620 S40: 07621 if(*l == 0) goto S50; 07622 m = ipmpar(&K2)-1; 07623 exparg = 0.99999e0*((double)m*lnb); 07624 return exparg; 07625 S50: 07626 m = ipmpar(&K3); 07627 exparg = 0.99999e0*((double)m*lnb); 07628 return exparg; 07629 } /* END */ 07630 07631 /***=====================================================================***/ 07632 static double fpser(double *a,double *b,double *x,double *eps) 07633 /* 07634 ----------------------------------------------------------------------- 07635 07636 EVALUATION OF I (A,B) 07637 X 07638 07639 FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. 07640 07641 ----------------------------------------------------------------------- 07642 07643 SET FPSER = X**A 07644 */ 07645 { 07646 static int K1 = 1; 07647 static double fpser,an,c,s,t,tol; 07648 /* 07649 .. 07650 .. Executable Statements .. 07651 */ 07652 fpser = 1.0e0; 07653 if(*a <= 1.e-3**eps) goto S10; 07654 fpser = 0.0e0; 07655 t = *a*log(*x); 07656 if(t < exparg(&K1)) return fpser; 07657 fpser = exp(t); 07658 S10: 07659 /* 07660 NOTE THAT 1/B(A,B) = B 07661 */ 07662 fpser = *b/ *a*fpser; 07663 tol = *eps/ *a; 07664 an = *a+1.0e0; 07665 t = *x; 07666 s = t/an; 07667 S20: 07668 an += 1.0e0; 07669 t = *x*t; 07670 c = t/an; 07671 s += c; 07672 if(fabs(c) > tol) goto S20; 07673 fpser *= (1.0e0+*a*s); 07674 return fpser; 07675 } /* END */ 07676 07677 /***=====================================================================***/ 07678 static double gam1(double *a) 07679 /* 07680 ------------------------------------------------------------------ 07681 COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 07682 ------------------------------------------------------------------ 07683 */ 07684 { 07685 static double s1 = .273076135303957e+00; 07686 static double s2 = .559398236957378e-01; 07687 static double p[7] = { 07688 .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00, 07689 .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02, 07690 .589597428611429e-03 07691 }; 07692 static double q[5] = { 07693 .100000000000000e+01,.427569613095214e+00,.158451672430138e+00, 07694 .261132021441447e-01,.423244297896961e-02 07695 }; 07696 static double r[9] = { 07697 -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00, 07698 .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01, 07699 .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03 07700 }; 07701 static double gam1,bot,d,t,top,w,T1; 07702 /* 07703 .. 07704 .. Executable Statements .. 07705 */ 07706 t = *a; 07707 d = *a-0.5e0; 07708 if(d > 0.0e0) t = d-0.5e0; 07709 T1 = t; 07710 if(T1 < 0) goto S40; 07711 else if(T1 == 0) goto S10; 07712 else goto S20; 07713 S10: 07714 gam1 = 0.0e0; 07715 return gam1; 07716 S20: 07717 top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0]; 07718 bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0; 07719 w = top/bot; 07720 if(d > 0.0e0) goto S30; 07721 gam1 = *a*w; 07722 return gam1; 07723 S30: 07724 gam1 = t/ *a*(w-0.5e0-0.5e0); 07725 return gam1; 07726 S40: 07727 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+ 07728 r[0]; 07729 bot = (s2*t+s1)*t+1.0e0; 07730 w = top/bot; 07731 if(d > 0.0e0) goto S50; 07732 gam1 = *a*(w+0.5e0+0.5e0); 07733 return gam1; 07734 S50: 07735 gam1 = t*w/ *a; 07736 return gam1; 07737 } /* END */ 07738 07739 /***=====================================================================***/ 07740 static void gaminv(double *a,double *x,double *x0,double *p,double *q, 07741 int *ierr) 07742 /* 07743 ---------------------------------------------------------------------- 07744 INVERSE INCOMPLETE GAMMA RATIO FUNCTION 07745 07746 GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. 07747 THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER 07748 ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X 07749 TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE 07750 PARTICULAR COMPUTER ARITHMETIC BEING USED. 07751 07752 ------------ 07753 07754 X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, 07755 AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT 07756 NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN 07757 A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE 07758 IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. 07759 07760 X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER 07761 DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET 07762 X0 .LE. 0. 07763 07764 IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. 07765 WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING 07766 VALUES ... 07767 07768 IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS 07769 NOT USED. 07770 IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS 07771 WERE PERFORMED. 07772 IERR = -2 (INPUT ERROR) A .LE. 0 07773 IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A 07774 IS TOO LARGE. 07775 IERR = -4 (INPUT ERROR) P + Q .NE. 1 07776 IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST 07777 RECENT VALUE OBTAINED FOR X IS GIVEN. 07778 THIS CANNOT OCCUR IF X0 .LE. 0. 07779 IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. 07780 THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. 07781 IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE 07782 ROUTINE IS NOT CERTAIN OF ITS ACCURACY. 07783 ITERATION CANNOT BE PERFORMED IN THIS 07784 CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY 07785 WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS 07786 POSITIVE THEN THIS CAN OCCUR WHEN A IS 07787 EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY 07788 LARGE (SAY A .GE. 1.E20). 07789 ---------------------------------------------------------------------- 07790 WRITTEN BY ALFRED H. MORRIS, JR. 07791 NAVAL SURFACE WEAPONS CENTER 07792 DAHLGREN, VIRGINIA 07793 ------------------- 07794 */ 07795 { 07796 static double a0 = 3.31125922108741e0; 07797 static double a1 = 11.6616720288968e0; 07798 static double a2 = 4.28342155967104e0; 07799 static double a3 = .213623493715853e0; 07800 static double b1 = 6.61053765625462e0; 07801 static double b2 = 6.40691597760039e0; 07802 static double b3 = 1.27364489782223e0; 07803 static double b4 = .036117081018842e0; 07804 static double c = .577215664901533e0; 07805 static double ln10 = 2.302585e0; 07806 static double tol = 1.e-5; 07807 static double amin[2] = { 07808 500.0e0,100.0e0 07809 }; 07810 static double bmin[2] = { 07811 1.e-28,1.e-13 07812 }; 07813 static double dmin[2] = { 07814 1.e-06,1.e-04 07815 }; 07816 static double emin[2] = { 07817 2.e-03,6.e-03 07818 }; 07819 static double eps0[2] = { 07820 1.e-10,1.e-08 07821 }; 07822 static int K1 = 1; 07823 static int K2 = 2; 07824 static int K3 = 3; 07825 static int K8 = 0; 07826 static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn, 07827 r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z; 07828 static int iop; 07829 static double T4,T5,T6,T7,T9; 07830 /* 07831 .. 07832 .. Executable Statements .. 07833 */ 07834 /* 07835 ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS. 07836 E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0. 07837 XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE 07838 LARGEST POSITIVE NUMBER. 07839 */ 07840 e = spmpar(&K1); 07841 xmin = spmpar(&K2); 07842 xmax = spmpar(&K3); 07843 *x = 0.0e0; 07844 if(*a <= 0.0e0) goto S300; 07845 t = *p+*q-1.e0; 07846 if(fabs(t) > e) goto S320; 07847 *ierr = 0; 07848 if(*p == 0.0e0) return; 07849 if(*q == 0.0e0) goto S270; 07850 if(*a == 1.0e0) goto S280; 07851 e2 = 2.0e0*e; 07852 amax = 0.4e-10/(e*e); 07853 iop = 1; 07854 if(e > 1.e-10) iop = 2; 07855 eps = eps0[iop-1]; 07856 xn = *x0; 07857 if(*x0 > 0.0e0) goto S160; 07858 /* 07859 SELECTION OF THE INITIAL APPROXIMATION XN OF X 07860 WHEN A .LT. 1 07861 */ 07862 if(*a > 1.0e0) goto S80; 07863 T4 = *a+1.0e0; 07864 g = Xgamm(&T4); 07865 qg = *q*g; 07866 if(qg == 0.0e0) goto S360; 07867 b = qg/ *a; 07868 if(qg > 0.6e0**a) goto S40; 07869 if(*a >= 0.30e0 || b < 0.35e0) goto S10; 07870 t = exp(-(b+c)); 07871 u = t*exp(t); 07872 xn = t*exp(u); 07873 goto S160; 07874 S10: 07875 if(b >= 0.45e0) goto S40; 07876 if(b == 0.0e0) goto S360; 07877 y = -log(b); 07878 s = 0.5e0+(0.5e0-*a); 07879 z = log(y); 07880 t = y-s*z; 07881 if(b < 0.15e0) goto S20; 07882 xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0)); 07883 goto S220; 07884 S20: 07885 if(b <= 0.01e0) goto S30; 07886 u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0); 07887 xn = y-s*log(t)-log(u); 07888 goto S220; 07889 S30: 07890 c1 = -(s*z); 07891 c2 = -(s*(1.0e0+c1)); 07892 c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a)); 07893 c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+( 07894 (11.0e0**a-46.0)**a+47.0e0)/6.0e0)); 07895 c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)* 07896 *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+(( 07897 (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0)); 07898 xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y; 07899 if(*a > 1.0e0) goto S220; 07900 if(b > bmin[iop-1]) goto S220; 07901 *x = xn; 07902 return; 07903 S40: 07904 if(b**q > 1.e-8) goto S50; 07905 xn = exp(-(*q/ *a+c)); 07906 goto S70; 07907 S50: 07908 if(*p <= 0.9e0) goto S60; 07909 T5 = -*q; 07910 xn = exp((alnrel(&T5)+gamln1(a))/ *a); 07911 goto S70; 07912 S60: 07913 xn = exp(log(*p*g)/ *a); 07914 S70: 07915 if(xn == 0.0e0) goto S310; 07916 t = 0.5e0+(0.5e0-xn/(*a+1.0e0)); 07917 xn /= t; 07918 goto S160; 07919 S80: 07920 /* 07921 SELECTION OF THE INITIAL APPROXIMATION XN OF X 07922 WHEN A .GT. 1 07923 */ 07924 if(*q <= 0.5e0) goto S90; 07925 w = log(*p); 07926 goto S100; 07927 S90: 07928 w = log(*q); 07929 S100: 07930 t = sqrt(-(2.0e0*w)); 07931 s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0); 07932 if(*q > 0.5e0) s = -s; 07933 rta = sqrt(*a); 07934 s2 = s*s; 07935 xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)* 07936 s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a* 07937 rta); 07938 xn = fifdmax1(xn,0.0e0); 07939 if(*a < amin[iop-1]) goto S110; 07940 *x = xn; 07941 d = 0.5e0+(0.5e0-*x/ *a); 07942 if(fabs(d) <= dmin[iop-1]) return; 07943 S110: 07944 if(*p <= 0.5e0) goto S130; 07945 if(xn < 3.0e0**a) goto S220; 07946 y = -(w+gamln(a)); 07947 d = fifdmax1(2.0e0,*a*(*a-1.0e0)); 07948 if(y < ln10*d) goto S120; 07949 s = 1.0e0-*a; 07950 z = log(y); 07951 goto S30; 07952 S120: 07953 t = *a-1.0e0; 07954 T6 = -(t/(xn+1.0e0)); 07955 xn = y+t*log(xn)-alnrel(&T6); 07956 T7 = -(t/(xn+1.0e0)); 07957 xn = y+t*log(xn)-alnrel(&T7); 07958 goto S220; 07959 S130: 07960 ap1 = *a+1.0e0; 07961 if(xn > 0.70e0*ap1) goto S170; 07962 w += gamln(&ap1); 07963 if(xn > 0.15e0*ap1) goto S140; 07964 ap2 = *a+2.0e0; 07965 ap3 = *a+3.0e0; 07966 *x = exp((w+*x)/ *a); 07967 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); 07968 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); 07969 *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a); 07970 xn = *x; 07971 if(xn > 1.e-2*ap1) goto S140; 07972 if(xn <= emin[iop-1]*ap1) return; 07973 goto S170; 07974 S140: 07975 apn = ap1; 07976 t = xn/apn; 07977 sum = 1.0e0+t; 07978 S150: 07979 apn += 1.0e0; 07980 t *= (xn/apn); 07981 sum += t; 07982 if(t > 1.e-4) goto S150; 07983 t = w-log(sum); 07984 xn = exp((xn+t)/ *a); 07985 xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn)); 07986 goto S170; 07987 S160: 07988 /* 07989 SCHRODER ITERATION USING P 07990 */ 07991 if(*p > 0.5e0) goto S220; 07992 S170: 07993 if(*p <= 1.e10*xmin) goto S350; 07994 am1 = *a-0.5e0-0.5e0; 07995 S180: 07996 if(*a <= amax) goto S190; 07997 d = 0.5e0+(0.5e0-xn/ *a); 07998 if(fabs(d) <= e2) goto S350; 07999 S190: 08000 if(*ierr >= 20) goto S330; 08001 *ierr += 1; 08002 gratio(a,&xn,&pn,&qn,&K8); 08003 if(pn == 0.0e0 || qn == 0.0e0) goto S350; 08004 r = rcomp(a,&xn); 08005 if(r == 0.0e0) goto S350; 08006 t = (pn-*p)/r; 08007 w = 0.5e0*(am1-xn); 08008 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200; 08009 *x = xn*(1.0e0-t); 08010 if(*x <= 0.0e0) goto S340; 08011 d = fabs(t); 08012 goto S210; 08013 S200: 08014 h = t*(1.0e0+w*t); 08015 *x = xn*(1.0e0-h); 08016 if(*x <= 0.0e0) goto S340; 08017 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; 08018 d = fabs(h); 08019 S210: 08020 xn = *x; 08021 if(d > tol) goto S180; 08022 if(d <= eps) return; 08023 if(fabs(*p-pn) <= tol**p) return; 08024 goto S180; 08025 S220: 08026 /* 08027 SCHRODER ITERATION USING Q 08028 */ 08029 if(*q <= 1.e10*xmin) goto S350; 08030 am1 = *a-0.5e0-0.5e0; 08031 S230: 08032 if(*a <= amax) goto S240; 08033 d = 0.5e0+(0.5e0-xn/ *a); 08034 if(fabs(d) <= e2) goto S350; 08035 S240: 08036 if(*ierr >= 20) goto S330; 08037 *ierr += 1; 08038 gratio(a,&xn,&pn,&qn,&K8); 08039 if(pn == 0.0e0 || qn == 0.0e0) goto S350; 08040 r = rcomp(a,&xn); 08041 if(r == 0.0e0) goto S350; 08042 t = (*q-qn)/r; 08043 w = 0.5e0*(am1-xn); 08044 if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250; 08045 *x = xn*(1.0e0-t); 08046 if(*x <= 0.0e0) goto S340; 08047 d = fabs(t); 08048 goto S260; 08049 S250: 08050 h = t*(1.0e0+w*t); 08051 *x = xn*(1.0e0-h); 08052 if(*x <= 0.0e0) goto S340; 08053 if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; 08054 d = fabs(h); 08055 S260: 08056 xn = *x; 08057 if(d > tol) goto S230; 08058 if(d <= eps) return; 08059 if(fabs(*q-qn) <= tol**q) return; 08060 goto S230; 08061 S270: 08062 /* 08063 SPECIAL CASES 08064 */ 08065 *x = xmax; 08066 return; 08067 S280: 08068 if(*q < 0.9e0) goto S290; 08069 T9 = -*p; 08070 *x = -alnrel(&T9); 08071 return; 08072 S290: 08073 *x = -log(*q); 08074 return; 08075 S300: 08076 /* 08077 ERROR RETURN 08078 */ 08079 *ierr = -2; 08080 return; 08081 S310: 08082 *ierr = -3; 08083 return; 08084 S320: 08085 *ierr = -4; 08086 return; 08087 S330: 08088 *ierr = -6; 08089 return; 08090 S340: 08091 *ierr = -7; 08092 return; 08093 S350: 08094 *x = xn; 08095 *ierr = -8; 08096 return; 08097 S360: 08098 *x = xmax; 08099 *ierr = -8; 08100 return; 08101 } /* END */ 08102 08103 /***=====================================================================***/ 08104 static double gamln(double *a) 08105 /* 08106 ----------------------------------------------------------------------- 08107 EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A 08108 ----------------------------------------------------------------------- 08109 WRITTEN BY ALFRED H. MORRIS 08110 NAVAL SURFACE WARFARE CENTER 08111 DAHLGREN, VIRGINIA 08112 -------------------------- 08113 D = 0.5*(LN(2*PI) - 1) 08114 -------------------------- 08115 */ 08116 { 08117 static double c0 = .833333333333333e-01; 08118 static double c1 = -.277777777760991e-02; 08119 static double c2 = .793650666825390e-03; 08120 static double c3 = -.595202931351870e-03; 08121 static double c4 = .837308034031215e-03; 08122 static double c5 = -.165322962780713e-02; 08123 static double d = .418938533204673e0; 08124 static double gamln,t,w; 08125 static int i,n; 08126 static double T1; 08127 /* 08128 .. 08129 .. Executable Statements .. 08130 */ 08131 if(*a > 0.8e0) goto S10; 08132 gamln = gamln1(a)-log(*a); 08133 return gamln; 08134 S10: 08135 if(*a > 2.25e0) goto S20; 08136 t = *a-0.5e0-0.5e0; 08137 gamln = gamln1(&t); 08138 return gamln; 08139 S20: 08140 if(*a >= 10.0e0) goto S40; 08141 n = *a-1.25e0; 08142 t = *a; 08143 w = 1.0e0; 08144 for(i=1; i<=n; i++) { 08145 t -= 1.0e0; 08146 w = t*w; 08147 } 08148 T1 = t-1.0e0; 08149 gamln = gamln1(&T1)+log(w); 08150 return gamln; 08151 S40: 08152 t = pow(1.0e0/ *a,2.0); 08153 w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a; 08154 gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0); 08155 return gamln; 08156 } /* END */ 08157 08158 /***=====================================================================***/ 08159 static double gamln1(double *a) 08160 /* 08161 ----------------------------------------------------------------------- 08162 EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 08163 ----------------------------------------------------------------------- 08164 */ 08165 { 08166 static double p0 = .577215664901533e+00; 08167 static double p1 = .844203922187225e+00; 08168 static double p2 = -.168860593646662e+00; 08169 static double p3 = -.780427615533591e+00; 08170 static double p4 = -.402055799310489e+00; 08171 static double p5 = -.673562214325671e-01; 08172 static double p6 = -.271935708322958e-02; 08173 static double q1 = .288743195473681e+01; 08174 static double q2 = .312755088914843e+01; 08175 static double q3 = .156875193295039e+01; 08176 static double q4 = .361951990101499e+00; 08177 static double q5 = .325038868253937e-01; 08178 static double q6 = .667465618796164e-03; 08179 static double r0 = .422784335098467e+00; 08180 static double r1 = .848044614534529e+00; 08181 static double r2 = .565221050691933e+00; 08182 static double r3 = .156513060486551e+00; 08183 static double r4 = .170502484022650e-01; 08184 static double r5 = .497958207639485e-03; 08185 static double s1 = .124313399877507e+01; 08186 static double s2 = .548042109832463e+00; 08187 static double s3 = .101552187439830e+00; 08188 static double s4 = .713309612391000e-02; 08189 static double s5 = .116165475989616e-03; 08190 static double gamln1,w,x; 08191 /* 08192 .. 08193 .. Executable Statements .. 08194 */ 08195 if(*a >= 0.6e0) goto S10; 08196 w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+ 08197 q4)**a+q3)**a+q2)**a+q1)**a+1.0e0); 08198 gamln1 = -(*a*w); 08199 return gamln1; 08200 S10: 08201 x = *a-0.5e0-0.5e0; 08202 w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x 08203 +1.0e0); 08204 gamln1 = x*w; 08205 return gamln1; 08206 } /* END */ 08207 08208 /***=====================================================================***/ 08209 static double Xgamm(double *a) 08210 /* 08211 ----------------------------------------------------------------------- 08212 08213 EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS 08214 08215 ----------- 08216 08217 GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT 08218 BE COMPUTED. 08219 08220 ----------------------------------------------------------------------- 08221 WRITTEN BY ALFRED H. MORRIS, JR. 08222 NAVAL SURFACE WEAPONS CENTER 08223 DAHLGREN, VIRGINIA 08224 ----------------------------------------------------------------------- 08225 */ 08226 { 08227 static double d = .41893853320467274178e0; 08228 static double pi = 3.1415926535898e0; 08229 static double r1 = .820756370353826e-03; 08230 static double r2 = -.595156336428591e-03; 08231 static double r3 = .793650663183693e-03; 08232 static double r4 = -.277777777770481e-02; 08233 static double r5 = .833333333333333e-01; 08234 static double p[7] = { 08235 .539637273585445e-03,.261939260042690e-02,.204493667594920e-01, 08236 .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0 08237 }; 08238 static double q[7] = { 08239 -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01, 08240 -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0 08241 }; 08242 static int K2 = 3; 08243 static int K3 = 0; 08244 static double Xgamm,bot,g,lnx,s,t,top,w,x,z; 08245 static int i,j,m,n,T1; 08246 /* 08247 .. 08248 .. Executable Statements .. 08249 */ 08250 Xgamm = 0.0e0; 08251 x = *a; 08252 if(fabs(*a) >= 15.0e0) goto S110; 08253 /* 08254 ----------------------------------------------------------------------- 08255 EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 08256 ----------------------------------------------------------------------- 08257 */ 08258 t = 1.0e0; 08259 m = fifidint(*a)-1; 08260 /* 08261 LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 08262 */ 08263 T1 = m; 08264 if(T1 < 0) goto S40; 08265 else if(T1 == 0) goto S30; 08266 else goto S10; 08267 S10: 08268 for(j=1; j<=m; j++) { 08269 x -= 1.0e0; 08270 t = x*t; 08271 } 08272 S30: 08273 x -= 1.0e0; 08274 goto S80; 08275 S40: 08276 /* 08277 LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 08278 */ 08279 t = *a; 08280 if(*a > 0.0e0) goto S70; 08281 m = -m-1; 08282 if(m == 0) goto S60; 08283 for(j=1; j<=m; j++) { 08284 x += 1.0e0; 08285 t = x*t; 08286 } 08287 S60: 08288 x += (0.5e0+0.5e0); 08289 t = x*t; 08290 if(t == 0.0e0) return Xgamm; 08291 S70: 08292 /* 08293 THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS 08294 CODE MAY BE OMITTED IF DESIRED. 08295 */ 08296 if(fabs(t) >= 1.e-30) goto S80; 08297 if(fabs(t)*spmpar(&K2) <= 1.0001e0) return Xgamm; 08298 Xgamm = 1.0e0/t; 08299 return Xgamm; 08300 S80: 08301 /* 08302 COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 08303 */ 08304 top = p[0]; 08305 bot = q[0]; 08306 for(i=1; i<7; i++) { 08307 top = p[i]+x*top; 08308 bot = q[i]+x*bot; 08309 } 08310 Xgamm = top/bot; 08311 /* 08312 TERMINATION 08313 */ 08314 if(*a < 1.0e0) goto S100; 08315 Xgamm *= t; 08316 return Xgamm; 08317 S100: 08318 Xgamm /= t; 08319 return Xgamm; 08320 S110: 08321 /* 08322 ----------------------------------------------------------------------- 08323 EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 08324 ----------------------------------------------------------------------- 08325 */ 08326 if(fabs(*a) >= 1.e3) return Xgamm; 08327 if(*a > 0.0e0) goto S120; 08328 x = -*a; 08329 n = x; 08330 t = x-(double)n; 08331 if(t > 0.9e0) t = 1.0e0-t; 08332 s = sin(pi*t)/pi; 08333 if(fifmod(n,2) == 0) s = -s; 08334 if(s == 0.0e0) return Xgamm; 08335 S120: 08336 /* 08337 COMPUTE THE MODIFIED ASYMPTOTIC SUM 08338 */ 08339 t = 1.0e0/(x*x); 08340 g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x; 08341 /* 08342 ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) 08343 BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. 08344 */ 08345 lnx = log(x); 08346 /* 08347 FINAL ASSEMBLY 08348 */ 08349 z = x; 08350 g = d+g+(z-0.5e0)*(lnx-1.e0); 08351 w = g; 08352 t = g-w; 08353 if(w > 0.99999e0*exparg(&K3)) return Xgamm; 08354 Xgamm = exp(w)*(1.0e0+t); 08355 if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x; 08356 return Xgamm; 08357 } /* END */ 08358 08359 /***=====================================================================***/ 08360 static void grat1(double *a,double *x,double *r,double *p,double *q, 08361 double *eps) 08362 { 08363 static int K2 = 0; 08364 static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3; 08365 /* 08366 .. 08367 .. Executable Statements .. 08368 */ 08369 /* 08370 ----------------------------------------------------------------------- 08371 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS 08372 P(A,X) AND Q(A,X) 08373 IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. 08374 THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). 08375 ----------------------------------------------------------------------- 08376 */ 08377 if(*a**x == 0.0e0) goto S120; 08378 if(*a == 0.5e0) goto S100; 08379 if(*x < 1.1e0) goto S10; 08380 goto S60; 08381 S10: 08382 /* 08383 TAYLOR SERIES FOR P(A,X)/X**A 08384 */ 08385 an = 3.0e0; 08386 c = *x; 08387 sum = *x/(*a+3.0e0); 08388 tol = 0.1e0**eps/(*a+1.0e0); 08389 S20: 08390 an += 1.0e0; 08391 c = -(c*(*x/an)); 08392 t = c/(*a+an); 08393 sum += t; 08394 if(fabs(t) > tol) goto S20; 08395 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); 08396 z = *a*log(*x); 08397 h = gam1(a); 08398 g = 1.0e0+h; 08399 if(*x < 0.25e0) goto S30; 08400 if(*a < *x/2.59e0) goto S50; 08401 goto S40; 08402 S30: 08403 if(z > -.13394e0) goto S50; 08404 S40: 08405 w = exp(z); 08406 *p = w*g*(0.5e0+(0.5e0-j)); 08407 *q = 0.5e0+(0.5e0-*p); 08408 return; 08409 S50: 08410 l = rexp(&z); 08411 w = 0.5e0+(0.5e0+l); 08412 *q = (w*j-l)*g-h; 08413 if(*q < 0.0e0) goto S90; 08414 *p = 0.5e0+(0.5e0-*q); 08415 return; 08416 S60: 08417 /* 08418 CONTINUED FRACTION EXPANSION 08419 */ 08420 a2nm1 = a2n = 1.0e0; 08421 b2nm1 = *x; 08422 b2n = *x+(1.0e0-*a); 08423 c = 1.0e0; 08424 S70: 08425 a2nm1 = *x*a2n+c*a2nm1; 08426 b2nm1 = *x*b2n+c*b2nm1; 08427 am0 = a2nm1/b2nm1; 08428 c += 1.0e0; 08429 cma = c-*a; 08430 a2n = a2nm1+cma*a2n; 08431 b2n = b2nm1+cma*b2n; 08432 an0 = a2n/b2n; 08433 if(fabs(an0-am0) >= *eps*an0) goto S70; 08434 *q = *r*an0; 08435 *p = 0.5e0+(0.5e0-*q); 08436 return; 08437 S80: 08438 /* 08439 SPECIAL CASES 08440 */ 08441 *p = 0.0e0; 08442 *q = 1.0e0; 08443 return; 08444 S90: 08445 *p = 1.0e0; 08446 *q = 0.0e0; 08447 return; 08448 S100: 08449 if(*x >= 0.25e0) goto S110; 08450 T1 = sqrt(*x); 08451 *p = erf1(&T1); 08452 *q = 0.5e0+(0.5e0-*p); 08453 return; 08454 S110: 08455 T3 = sqrt(*x); 08456 *q = erfc1(&K2,&T3); 08457 *p = 0.5e0+(0.5e0-*q); 08458 return; 08459 S120: 08460 if(*x <= *a) goto S80; 08461 goto S90; 08462 } /* END */ 08463 08464 /***=====================================================================***/ 08465 static void gratio(double *a,double *x,double *ans,double *qans,int *ind) 08466 /* 08467 ---------------------------------------------------------------------- 08468 EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS 08469 P(A,X) AND Q(A,X) 08470 08471 ---------- 08472 08473 IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X 08474 ARE NOT BOTH 0. 08475 08476 ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE 08477 P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. 08478 IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS 08479 POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF 08480 IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE 08481 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY 08482 IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. 08483 08484 ERROR RETURN ... 08485 ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, 08486 WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. 08487 P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN 08488 X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. 08489 ---------------------------------------------------------------------- 08490 WRITTEN BY ALFRED H. MORRIS, JR. 08491 NAVAL SURFACE WEAPONS CENTER 08492 DAHLGREN, VIRGINIA 08493 -------------------- 08494 */ 08495 { 08496 static double alog10 = 2.30258509299405e0; 08497 static double d10 = -.185185185185185e-02; 08498 static double d20 = .413359788359788e-02; 08499 static double d30 = .649434156378601e-03; 08500 static double d40 = -.861888290916712e-03; 08501 static double d50 = -.336798553366358e-03; 08502 static double d60 = .531307936463992e-03; 08503 static double d70 = .344367606892378e-03; 08504 static double rt2pin = .398942280401433e0; 08505 static double rtpi = 1.77245385090552e0; 08506 static double third = .333333333333333e0; 08507 static double acc0[3] = { 08508 5.e-15,5.e-7,5.e-4 08509 }; 08510 static double big[3] = { 08511 20.0e0,14.0e0,10.0e0 08512 }; 08513 static double d0[13] = { 08514 .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02, 08515 .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04, 08516 -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06, 08517 -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07, 08518 -.438203601845335e-08 08519 }; 08520 static double d1[12] = { 08521 -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03, 08522 .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04, 08523 .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08, 08524 .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07 08525 }; 08526 static double d2[10] = { 08527 -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05, 08528 -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04, 08529 .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06, 08530 .142806142060642e-06 08531 }; 08532 static double d3[8] = { 08533 .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03, 08534 -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04, 08535 -.567495282699160e-05,.142309007324359e-05 08536 }; 08537 static double d4[6] = { 08538 .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05, 08539 .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04 08540 }; 08541 static double d5[4] = { 08542 -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03, 08543 .679778047793721e-04 08544 }; 08545 static double d6[2] = { 08546 -.592166437353694e-03,.270878209671804e-03 08547 }; 08548 static double e00[3] = { 08549 .25e-3,.25e-1,.14e0 08550 }; 08551 static double x00[3] = { 08552 31.0e0,17.0e0,9.7e0 08553 }; 08554 static int K1 = 1; 08555 static int K2 = 0; 08556 static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6, 08557 cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z; 08558 static int i,iop,m,max,n; 08559 static double wk[20],T3; 08560 static int T4,T5; 08561 static double T6,T7; 08562 /* 08563 .. 08564 .. Executable Statements .. 08565 */ 08566 /* 08567 -------------------- 08568 ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST 08569 FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . 08570 */ 08571 e = spmpar(&K1); 08572 if(*a < 0.0e0 || *x < 0.0e0) goto S430; 08573 if(*a == 0.0e0 && *x == 0.0e0) goto S430; 08574 if(*a**x == 0.0e0) goto S420; 08575 iop = *ind+1; 08576 if(iop != 1 && iop != 2) iop = 3; 08577 acc = fifdmax1(acc0[iop-1],e); 08578 e0 = e00[iop-1]; 08579 x0 = x00[iop-1]; 08580 /* 08581 SELECT THE APPROPRIATE ALGORITHM 08582 */ 08583 if(*a >= 1.0e0) goto S10; 08584 if(*a == 0.5e0) goto S390; 08585 if(*x < 1.1e0) goto S160; 08586 t1 = *a*log(*x)-*x; 08587 u = *a*exp(t1); 08588 if(u == 0.0e0) goto S380; 08589 r = u*(1.0e0+gam1(a)); 08590 goto S250; 08591 S10: 08592 if(*a >= big[iop-1]) goto S30; 08593 if(*a > *x || *x >= x0) goto S20; 08594 twoa = *a+*a; 08595 m = fifidint(twoa); 08596 if(twoa != (double)m) goto S20; 08597 i = m/2; 08598 if(*a == (double)i) goto S210; 08599 goto S220; 08600 S20: 08601 t1 = *a*log(*x)-*x; 08602 r = exp(t1)/Xgamm(a); 08603 goto S40; 08604 S30: 08605 l = *x/ *a; 08606 if(l == 0.0e0) goto S370; 08607 s = 0.5e0+(0.5e0-l); 08608 z = rlog(&l); 08609 if(z >= 700.0e0/ *a) goto S410; 08610 y = *a*z; 08611 rta = sqrt(*a); 08612 if(fabs(s) <= e0/rta) goto S330; 08613 if(fabs(s) <= 0.4e0) goto S270; 08614 t = pow(1.0e0/ *a,2.0); 08615 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); 08616 t1 -= y; 08617 r = rt2pin*rta*exp(t1); 08618 S40: 08619 if(r == 0.0e0) goto S420; 08620 if(*x <= fifdmax1(*a,alog10)) goto S50; 08621 if(*x < x0) goto S250; 08622 goto S100; 08623 S50: 08624 /* 08625 TAYLOR SERIES FOR P/R 08626 */ 08627 apn = *a+1.0e0; 08628 t = *x/apn; 08629 wk[0] = t; 08630 for(n=2; n<=20; n++) { 08631 apn += 1.0e0; 08632 t *= (*x/apn); 08633 if(t <= 1.e-3) goto S70; 08634 wk[n-1] = t; 08635 } 08636 n = 20; 08637 S70: 08638 sum = t; 08639 tol = 0.5e0*acc; 08640 S80: 08641 apn += 1.0e0; 08642 t *= (*x/apn); 08643 sum += t; 08644 if(t > tol) goto S80; 08645 max = n-1; 08646 for(m=1; m<=max; m++) { 08647 n -= 1; 08648 sum += wk[n-1]; 08649 } 08650 *ans = r/ *a*(1.0e0+sum); 08651 *qans = 0.5e0+(0.5e0-*ans); 08652 return; 08653 S100: 08654 /* 08655 ASYMPTOTIC EXPANSION 08656 */ 08657 amn = *a-1.0e0; 08658 t = amn/ *x; 08659 wk[0] = t; 08660 for(n=2; n<=20; n++) { 08661 amn -= 1.0e0; 08662 t *= (amn/ *x); 08663 if(fabs(t) <= 1.e-3) goto S120; 08664 wk[n-1] = t; 08665 } 08666 n = 20; 08667 S120: 08668 sum = t; 08669 S130: 08670 if(fabs(t) <= acc) goto S140; 08671 amn -= 1.0e0; 08672 t *= (amn/ *x); 08673 sum += t; 08674 goto S130; 08675 S140: 08676 max = n-1; 08677 for(m=1; m<=max; m++) { 08678 n -= 1; 08679 sum += wk[n-1]; 08680 } 08681 *qans = r/ *x*(1.0e0+sum); 08682 *ans = 0.5e0+(0.5e0-*qans); 08683 return; 08684 S160: 08685 /* 08686 TAYLOR SERIES FOR P(A,X)/X**A 08687 */ 08688 an = 3.0e0; 08689 c = *x; 08690 sum = *x/(*a+3.0e0); 08691 tol = 3.0e0*acc/(*a+1.0e0); 08692 S170: 08693 an += 1.0e0; 08694 c = -(c*(*x/an)); 08695 t = c/(*a+an); 08696 sum += t; 08697 if(fabs(t) > tol) goto S170; 08698 j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); 08699 z = *a*log(*x); 08700 h = gam1(a); 08701 g = 1.0e0+h; 08702 if(*x < 0.25e0) goto S180; 08703 if(*a < *x/2.59e0) goto S200; 08704 goto S190; 08705 S180: 08706 if(z > -.13394e0) goto S200; 08707 S190: 08708 w = exp(z); 08709 *ans = w*g*(0.5e0+(0.5e0-j)); 08710 *qans = 0.5e0+(0.5e0-*ans); 08711 return; 08712 S200: 08713 l = rexp(&z); 08714 w = 0.5e0+(0.5e0+l); 08715 *qans = (w*j-l)*g-h; 08716 if(*qans < 0.0e0) goto S380; 08717 *ans = 0.5e0+(0.5e0-*qans); 08718 return; 08719 S210: 08720 /* 08721 FINITE SUMS FOR Q WHEN A .GE. 1 08722 AND 2*A IS AN INTEGER 08723 */ 08724 sum = exp(-*x); 08725 t = sum; 08726 n = 1; 08727 c = 0.0e0; 08728 goto S230; 08729 S220: 08730 rtx = sqrt(*x); 08731 sum = erfc1(&K2,&rtx); 08732 t = exp(-*x)/(rtpi*rtx); 08733 n = 0; 08734 c = -0.5e0; 08735 S230: 08736 if(n == i) goto S240; 08737 n += 1; 08738 c += 1.0e0; 08739 t = *x*t/c; 08740 sum += t; 08741 goto S230; 08742 S240: 08743 *qans = sum; 08744 *ans = 0.5e0+(0.5e0-*qans); 08745 return; 08746 S250: 08747 /* 08748 CONTINUED FRACTION EXPANSION 08749 */ 08750 tol = fifdmax1(5.0e0*e,acc); 08751 a2nm1 = a2n = 1.0e0; 08752 b2nm1 = *x; 08753 b2n = *x+(1.0e0-*a); 08754 c = 1.0e0; 08755 S260: 08756 a2nm1 = *x*a2n+c*a2nm1; 08757 b2nm1 = *x*b2n+c*b2nm1; 08758 am0 = a2nm1/b2nm1; 08759 c += 1.0e0; 08760 cma = c-*a; 08761 a2n = a2nm1+cma*a2n; 08762 b2n = b2nm1+cma*b2n; 08763 an0 = a2n/b2n; 08764 if(fabs(an0-am0) >= tol*an0) goto S260; 08765 *qans = r*an0; 08766 *ans = 0.5e0+(0.5e0-*qans); 08767 return; 08768 S270: 08769 /* 08770 GENERAL TEMME EXPANSION 08771 */ 08772 if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430; 08773 c = exp(-y); 08774 T3 = sqrt(y); 08775 w = 0.5e0*erfc1(&K1,&T3); 08776 u = 1.0e0/ *a; 08777 z = sqrt(z+z); 08778 if(l < 1.0e0) z = -z; 08779 T4 = iop-2; 08780 if(T4 < 0) goto S280; 08781 else if(T4 == 0) goto S290; 08782 else goto S300; 08783 S280: 08784 if(fabs(s) <= 1.e-3) goto S340; 08785 c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[ 08786 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; 08787 c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5] 08788 )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; 08789 c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+ 08790 d2[2])*z+d2[1])*z+d2[0])*z+d20; 08791 c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+ 08792 d3[0])*z+d30; 08793 c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40; 08794 c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50; 08795 c6 = (d6[1]*z+d6[0])*z+d60; 08796 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; 08797 goto S310; 08798 S290: 08799 c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; 08800 c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; 08801 c2 = d2[0]*z+d20; 08802 t = (c2*u+c1)*u+c0; 08803 goto S310; 08804 S300: 08805 t = ((d0[2]*z+d0[1])*z+d0[0])*z-third; 08806 S310: 08807 if(l < 1.0e0) goto S320; 08808 *qans = c*(w+rt2pin*t/rta); 08809 *ans = 0.5e0+(0.5e0-*qans); 08810 return; 08811 S320: 08812 *ans = c*(w-rt2pin*t/rta); 08813 *qans = 0.5e0+(0.5e0-*ans); 08814 return; 08815 S330: 08816 /* 08817 TEMME EXPANSION FOR L = 1 08818 */ 08819 if(*a*e*e > 3.28e-3) goto S430; 08820 c = 0.5e0+(0.5e0-y); 08821 w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c; 08822 u = 1.0e0/ *a; 08823 z = sqrt(z+z); 08824 if(l < 1.0e0) z = -z; 08825 T5 = iop-2; 08826 if(T5 < 0) goto S340; 08827 else if(T5 == 0) goto S350; 08828 else goto S360; 08829 S340: 08830 c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z- 08831 third; 08832 c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; 08833 c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20; 08834 c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30; 08835 c4 = (d4[1]*z+d4[0])*z+d40; 08836 c5 = (d5[1]*z+d5[0])*z+d50; 08837 c6 = d6[0]*z+d60; 08838 t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; 08839 goto S310; 08840 S350: 08841 c0 = (d0[1]*z+d0[0])*z-third; 08842 c1 = d1[0]*z+d10; 08843 t = (d20*u+c1)*u+c0; 08844 goto S310; 08845 S360: 08846 t = d0[0]*z-third; 08847 goto S310; 08848 S370: 08849 /* 08850 SPECIAL CASES 08851 */ 08852 *ans = 0.0e0; 08853 *qans = 1.0e0; 08854 return; 08855 S380: 08856 *ans = 1.0e0; 08857 *qans = 0.0e0; 08858 return; 08859 S390: 08860 if(*x >= 0.25e0) goto S400; 08861 T6 = sqrt(*x); 08862 *ans = erf1(&T6); 08863 *qans = 0.5e0+(0.5e0-*ans); 08864 return; 08865 S400: 08866 T7 = sqrt(*x); 08867 *qans = erfc1(&K2,&T7); 08868 *ans = 0.5e0+(0.5e0-*qans); 08869 return; 08870 S410: 08871 if(fabs(s) <= 2.0e0*e) goto S430; 08872 S420: 08873 if(*x <= *a) goto S370; 08874 goto S380; 08875 S430: 08876 /* 08877 ERROR RETURN 08878 */ 08879 *ans = 2.0e0; 08880 return; 08881 } /* END */ 08882 08883 /***=====================================================================***/ 08884 static double gsumln(double *a,double *b) 08885 /* 08886 ----------------------------------------------------------------------- 08887 EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) 08888 FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 08889 ----------------------------------------------------------------------- 08890 */ 08891 { 08892 static double gsumln,x,T1,T2; 08893 /* 08894 .. 08895 .. Executable Statements .. 08896 */ 08897 x = *a+*b-2.e0; 08898 if(x > 0.25e0) goto S10; 08899 T1 = 1.0e0+x; 08900 gsumln = gamln1(&T1); 08901 return gsumln; 08902 S10: 08903 if(x > 1.25e0) goto S20; 08904 gsumln = gamln1(&x)+alnrel(&x); 08905 return gsumln; 08906 S20: 08907 T2 = x-1.0e0; 08908 gsumln = gamln1(&T2)+log(x*(1.0e0+x)); 08909 return gsumln; 08910 } /* END */ 08911 08912 /***=====================================================================***/ 08913 static double psi(double *xx) 08914 /* 08915 --------------------------------------------------------------------- 08916 08917 EVALUATION OF THE DIGAMMA FUNCTION 08918 08919 ----------- 08920 08921 PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT 08922 BE COMPUTED. 08923 08924 THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV 08925 APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY 08926 CODY, STRECOK AND THACHER. 08927 08928 --------------------------------------------------------------------- 08929 PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK 08930 PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY 08931 A.H. MORRIS (NSWC). 08932 --------------------------------------------------------------------- 08933 */ 08934 { 08935 static double dx0 = 1.461632144968362341262659542325721325e0; 08936 static double piov4 = .785398163397448e0; 08937 static double p1[7] = { 08938 .895385022981970e-02,.477762828042627e+01,.142441585084029e+03, 08939 .118645200713425e+04,.363351846806499e+04,.413810161269013e+04, 08940 .130560269827897e+04 08941 }; 08942 static double p2[4] = { 08943 -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01, 08944 -.648157123766197e+00 08945 }; 08946 static double q1[6] = { 08947 .448452573429826e+02,.520752771467162e+03,.221000799247830e+04, 08948 .364127349079381e+04,.190831076596300e+04,.691091682714533e-05 08949 }; 08950 static double q2[4] = { 08951 .322703493791143e+02,.892920700481861e+02,.546117738103215e+02, 08952 .777788548522962e+01 08953 }; 08954 static int K1 = 3; 08955 static int K2 = 1; 08956 static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z; 08957 static int i,m,n,nq; 08958 /* 08959 .. 08960 .. Executable Statements .. 08961 */ 08962 /* 08963 --------------------------------------------------------------------- 08964 MACHINE DEPENDENT CONSTANTS ... 08965 XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT 08966 WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED 08967 AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE 08968 ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH 08969 PSI MAY BE REPRESENTED AS ALOG(X). 08970 XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X) 08971 MAY BE REPRESENTED BY 1/X. 08972 --------------------------------------------------------------------- 08973 */ 08974 xmax1 = ipmpar(&K1); 08975 xmax1 = fifdmin1(xmax1,1.0e0/spmpar(&K2)); 08976 xsmall = 1.e-9; 08977 x = *xx; 08978 aug = 0.0e0; 08979 if(x >= 0.5e0) goto S50; 08980 /* 08981 --------------------------------------------------------------------- 08982 X .LT. 0.5, USE REFLECTION FORMULA 08983 PSI(1-X) = PSI(X) + PI * COTAN(PI*X) 08984 --------------------------------------------------------------------- 08985 */ 08986 if(fabs(x) > xsmall) goto S10; 08987 if(x == 0.0e0) goto S100; 08988 /* 08989 --------------------------------------------------------------------- 08990 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE 08991 FOR PI*COTAN(PI*X) 08992 --------------------------------------------------------------------- 08993 */ 08994 aug = -(1.0e0/x); 08995 goto S40; 08996 S10: 08997 /* 08998 --------------------------------------------------------------------- 08999 REDUCTION OF ARGUMENT FOR COTAN 09000 --------------------------------------------------------------------- 09001 */ 09002 w = -x; 09003 sgn = piov4; 09004 if(w > 0.0e0) goto S20; 09005 w = -w; 09006 sgn = -sgn; 09007 S20: 09008 /* 09009 --------------------------------------------------------------------- 09010 MAKE AN ERROR EXIT IF X .LE. -XMAX1 09011 --------------------------------------------------------------------- 09012 */ 09013 if(w >= xmax1) goto S100; 09014 nq = fifidint(w); 09015 w -= (double)nq; 09016 nq = fifidint(w*4.0e0); 09017 w = 4.0e0*(w-(double)nq*.25e0); 09018 /* 09019 --------------------------------------------------------------------- 09020 W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X. 09021 ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST 09022 QUADRANT AND DETERMINE SIGN 09023 --------------------------------------------------------------------- 09024 */ 09025 n = nq/2; 09026 if(n+n != nq) w = 1.0e0-w; 09027 z = piov4*w; 09028 m = n/2; 09029 if(m+m != n) sgn = -sgn; 09030 /* 09031 --------------------------------------------------------------------- 09032 DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X) 09033 --------------------------------------------------------------------- 09034 */ 09035 n = (nq+1)/2; 09036 m = n/2; 09037 m += m; 09038 if(m != n) goto S30; 09039 /* 09040 --------------------------------------------------------------------- 09041 CHECK FOR SINGULARITY 09042 --------------------------------------------------------------------- 09043 */ 09044 if(z == 0.0e0) goto S100; 09045 /* 09046 --------------------------------------------------------------------- 09047 USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND 09048 SIN/COS AS A SUBSTITUTE FOR TAN 09049 --------------------------------------------------------------------- 09050 */ 09051 aug = sgn*(cos(z)/sin(z)*4.0e0); 09052 goto S40; 09053 S30: 09054 aug = sgn*(sin(z)/cos(z)*4.0e0); 09055 S40: 09056 x = 1.0e0-x; 09057 S50: 09058 if(x > 3.0e0) goto S70; 09059 /* 09060 --------------------------------------------------------------------- 09061 0.5 .LE. X .LE. 3.0 09062 --------------------------------------------------------------------- 09063 */ 09064 den = x; 09065 upper = p1[0]*x; 09066 for(i=1; i<=5; i++) { 09067 den = (den+q1[i-1])*x; 09068 upper = (upper+p1[i+1-1])*x; 09069 } 09070 den = (upper+p1[6])/(den+q1[5]); 09071 xmx0 = x-dx0; 09072 psi = den*xmx0+aug; 09073 return psi; 09074 S70: 09075 /* 09076 --------------------------------------------------------------------- 09077 IF X .GE. XMAX1, PSI = LN(X) 09078 --------------------------------------------------------------------- 09079 */ 09080 if(x >= xmax1) goto S90; 09081 /* 09082 --------------------------------------------------------------------- 09083 3.0 .LT. X .LT. XMAX1 09084 --------------------------------------------------------------------- 09085 */ 09086 w = 1.0e0/(x*x); 09087 den = w; 09088 upper = p2[0]*w; 09089 for(i=1; i<=3; i++) { 09090 den = (den+q2[i-1])*w; 09091 upper = (upper+p2[i+1-1])*w; 09092 } 09093 aug = upper/(den+q2[3])-0.5e0/x+aug; 09094 S90: 09095 psi = aug+log(x); 09096 return psi; 09097 S100: 09098 /* 09099 --------------------------------------------------------------------- 09100 ERROR RETURN 09101 --------------------------------------------------------------------- 09102 */ 09103 psi = 0.0e0; 09104 return psi; 09105 } /* END */ 09106 09107 /***=====================================================================***/ 09108 static double rcomp(double *a,double *x) 09109 /* 09110 ------------------- 09111 EVALUATION OF EXP(-X)*X**A/GAMMA(A) 09112 ------------------- 09113 RT2PIN = 1/SQRT(2*PI) 09114 ------------------- 09115 */ 09116 { 09117 static double rt2pin = .398942280401433e0; 09118 static double rcomp,t,t1,u; 09119 /* 09120 .. 09121 .. Executable Statements .. 09122 */ 09123 rcomp = 0.0e0; 09124 if(*a >= 20.0e0) goto S20; 09125 t = *a*log(*x)-*x; 09126 if(*a >= 1.0e0) goto S10; 09127 rcomp = *a*exp(t)*(1.0e0+gam1(a)); 09128 return rcomp; 09129 S10: 09130 rcomp = exp(t)/Xgamm(a); 09131 return rcomp; 09132 S20: 09133 u = *x/ *a; 09134 if(u == 0.0e0) return rcomp; 09135 t = pow(1.0e0/ *a,2.0); 09136 t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); 09137 t1 -= (*a*rlog(&u)); 09138 rcomp = rt2pin*sqrt(*a)*exp(t1); 09139 return rcomp; 09140 } /* END */ 09141 09142 /***=====================================================================***/ 09143 static double rexp(double *x) 09144 /* 09145 ----------------------------------------------------------------------- 09146 EVALUATION OF THE FUNCTION EXP(X) - 1 09147 ----------------------------------------------------------------------- 09148 */ 09149 { 09150 static double p1 = .914041914819518e-09; 09151 static double p2 = .238082361044469e-01; 09152 static double q1 = -.499999999085958e+00; 09153 static double q2 = .107141568980644e+00; 09154 static double q3 = -.119041179760821e-01; 09155 static double q4 = .595130811860248e-03; 09156 static double rexp,w; 09157 /* 09158 .. 09159 .. Executable Statements .. 09160 */ 09161 if(fabs(*x) > 0.15e0) goto S10; 09162 rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0)); 09163 return rexp; 09164 S10: 09165 w = exp(*x); 09166 if(*x > 0.0e0) goto S20; 09167 rexp = w-0.5e0-0.5e0; 09168 return rexp; 09169 S20: 09170 rexp = w*(0.5e0+(0.5e0-1.0e0/w)); 09171 return rexp; 09172 } /* END */ 09173 09174 /***=====================================================================***/ 09175 static double rlog(double *x) 09176 /* 09177 ------------------- 09178 COMPUTATION OF X - 1 - LN(X) 09179 ------------------- 09180 */ 09181 { 09182 static double a = .566749439387324e-01; 09183 static double b = .456512608815524e-01; 09184 static double p0 = .333333333333333e+00; 09185 static double p1 = -.224696413112536e+00; 09186 static double p2 = .620886815375787e-02; 09187 static double q1 = -.127408923933623e+01; 09188 static double q2 = .354508718369557e+00; 09189 static double rlog,r,t,u,w,w1; 09190 /* 09191 .. 09192 .. Executable Statements .. 09193 */ 09194 if(*x < 0.61e0 || *x > 1.57e0) goto S40; 09195 if(*x < 0.82e0) goto S10; 09196 if(*x > 1.18e0) goto S20; 09197 /* 09198 ARGUMENT REDUCTION 09199 */ 09200 u = *x-0.5e0-0.5e0; 09201 w1 = 0.0e0; 09202 goto S30; 09203 S10: 09204 u = *x-0.7e0; 09205 u /= 0.7e0; 09206 w1 = a-u*0.3e0; 09207 goto S30; 09208 S20: 09209 u = 0.75e0**x-1.e0; 09210 w1 = b+u/3.0e0; 09211 S30: 09212 /* 09213 SERIES EXPANSION 09214 */ 09215 r = u/(u+2.0e0); 09216 t = r*r; 09217 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); 09218 rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; 09219 return rlog; 09220 S40: 09221 r = *x-0.5e0-0.5e0; 09222 rlog = r-log(*x); 09223 return rlog; 09224 } /* END */ 09225 09226 /***=====================================================================***/ 09227 static double rlog1(double *x) 09228 /* 09229 ----------------------------------------------------------------------- 09230 EVALUATION OF THE FUNCTION X - LN(1 + X) 09231 ----------------------------------------------------------------------- 09232 */ 09233 { 09234 static double a = .566749439387324e-01; 09235 static double b = .456512608815524e-01; 09236 static double p0 = .333333333333333e+00; 09237 static double p1 = -.224696413112536e+00; 09238 static double p2 = .620886815375787e-02; 09239 static double q1 = -.127408923933623e+01; 09240 static double q2 = .354508718369557e+00; 09241 static double rlog1,h,r,t,w,w1; 09242 /* 09243 .. 09244 .. Executable Statements .. 09245 */ 09246 if(*x < -0.39e0 || *x > 0.57e0) goto S40; 09247 if(*x < -0.18e0) goto S10; 09248 if(*x > 0.18e0) goto S20; 09249 /* 09250 ARGUMENT REDUCTION 09251 */ 09252 h = *x; 09253 w1 = 0.0e0; 09254 goto S30; 09255 S10: 09256 h = *x+0.3e0; 09257 h /= 0.7e0; 09258 w1 = a-h*0.3e0; 09259 goto S30; 09260 S20: 09261 h = 0.75e0**x-0.25e0; 09262 w1 = b+h/3.0e0; 09263 S30: 09264 /* 09265 SERIES EXPANSION 09266 */ 09267 r = h/(h+2.0e0); 09268 t = r*r; 09269 w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); 09270 rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; 09271 return rlog1; 09272 S40: 09273 w = *x+0.5e0+0.5e0; 09274 rlog1 = *x-log(w); 09275 return rlog1; 09276 } /* END */ 09277 09278 /***=====================================================================***/ 09279 static double spmpar(int *i) 09280 /* 09281 ----------------------------------------------------------------------- 09282 09283 SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR 09284 THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT 09285 I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE 09286 SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND 09287 ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN 09288 09289 SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, 09290 09291 SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, 09292 09293 SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. 09294 09295 ----------------------------------------------------------------------- 09296 WRITTEN BY 09297 ALFRED H. MORRIS, JR. 09298 NAVAL SURFACE WARFARE CENTER 09299 DAHLGREN VIRGINIA 09300 ----------------------------------------------------------------------- 09301 ----------------------------------------------------------------------- 09302 MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE 09303 CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS 09304 MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION 09305 ----------------------------------------------------------------------- 09306 */ 09307 { 09308 static int K1 = 4; 09309 static int K2 = 8; 09310 static int K3 = 9; 09311 static int K4 = 10; 09312 static double spmpar,b,binv,bm1,one,w,z; 09313 static int emax,emin,ibeta,m; 09314 /* 09315 .. 09316 .. Executable Statements .. 09317 */ 09318 if(*i > 1) goto S10; 09319 b = ipmpar(&K1); 09320 m = ipmpar(&K2); 09321 spmpar = pow(b,(double)(1-m)); 09322 return spmpar; 09323 S10: 09324 if(*i > 2) goto S20; 09325 b = ipmpar(&K1); 09326 emin = ipmpar(&K3); 09327 one = 1.0; 09328 binv = one/b; 09329 w = pow(b,(double)(emin+2)); 09330 spmpar = w*binv*binv*binv; 09331 return spmpar; 09332 S20: 09333 ibeta = ipmpar(&K1); 09334 m = ipmpar(&K2); 09335 emax = ipmpar(&K4); 09336 b = ibeta; 09337 bm1 = ibeta-1; 09338 one = 1.0; 09339 z = pow(b,(double)(m-1)); 09340 w = ((z-one)*b+bm1)/(b*z); 09341 z = pow(b,(double)(emax-2)); 09342 spmpar = w*z*b*b; 09343 return spmpar; 09344 } /* END */ 09345 09346 /***=====================================================================***/ 09347 static double stvaln(double *p) 09348 /* 09349 ********************************************************************** 09350 09351 double stvaln(double *p) 09352 STarting VALue for Neton-Raphon 09353 calculation of Normal distribution Inverse 09354 09355 09356 Function 09357 09358 09359 Returns X such that CUMNOR(X) = P, i.e., the integral from - 09360 infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P 09361 09362 09363 Arguments 09364 09365 09366 P --> The probability whose normal deviate is sought. 09367 P is DOUBLE PRECISION 09368 09369 09370 Method 09371 09372 09373 The rational function on page 95 of Kennedy and Gentle, 09374 Statistical Computing, Marcel Dekker, NY , 1980. 09375 09376 ********************************************************************** 09377 */ 09378 { 09379 static double xden[5] = { 09380 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0, 09381 0.38560700634e-2 09382 }; 09383 static double xnum[5] = { 09384 -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1, 09385 -0.453642210148e-4 09386 }; 09387 static int K1 = 5; 09388 static double stvaln,sign,y,z; 09389 /* 09390 .. 09391 .. Executable Statements .. 09392 */ 09393 if(!(*p <= 0.5e0)) goto S10; 09394 sign = -1.0e0; 09395 z = *p; 09396 goto S20; 09397 S10: 09398 sign = 1.0e0; 09399 z = 1.0e0-*p; 09400 S20: 09401 y = sqrt(-(2.0e0*log(z))); 09402 stvaln = y+devlpl(xnum,&K1,&y)/devlpl(xden,&K1,&y); 09403 stvaln = sign*stvaln; 09404 return stvaln; 09405 } /* END */ 09406 09407 /***=====================================================================***/ 09408 static double fifdint(double a) 09409 /************************************************************************ 09410 FIFDINT: 09411 Truncates a double precision number to an integer and returns the 09412 value in a double. 09413 ************************************************************************/ 09414 /* a - number to be truncated */ 09415 { 09416 return (double) ((int) a); 09417 } /* END */ 09418 09419 /***=====================================================================***/ 09420 static double fifdmax1(double a,double b) 09421 /************************************************************************ 09422 FIFDMAX1: 09423 returns the maximum of two numbers a and b 09424 ************************************************************************/ 09425 /* a - first number */ 09426 /* b - second number */ 09427 { 09428 if (a < b) return b; 09429 else return a; 09430 } /* END */ 09431 09432 /***=====================================================================***/ 09433 static double fifdmin1(double a,double b) 09434 /************************************************************************ 09435 FIFDMIN1: 09436 returns the minimum of two numbers a and b 09437 ************************************************************************/ 09438 /* a - first number */ 09439 /* b - second number */ 09440 { 09441 if (a < b) return a; 09442 else return b; 09443 } /* END */ 09444 09445 /***=====================================================================***/ 09446 static double fifdsign(double mag,double sign) 09447 /************************************************************************ 09448 FIFDSIGN: 09449 transfers the sign of the variable "sign" to the variable "mag" 09450 ************************************************************************/ 09451 /* mag - magnitude */ 09452 /* sign - sign to be transfered */ 09453 { 09454 if (mag < 0) mag = -mag; 09455 if (sign < 0) mag = -mag; 09456 return mag; 09457 09458 } /* END */ 09459 09460 /***=====================================================================***/ 09461 static long fifidint(double a) 09462 /************************************************************************ 09463 FIFIDINT: 09464 Truncates a double precision number to a long integer 09465 ************************************************************************/ 09466 /* a - number to be truncated */ 09467 { 09468 if (a < 1.0) return (long) 0; 09469 else return (long) a; 09470 } /* END */ 09471 09472 /***=====================================================================***/ 09473 static long fifmod(long a,long b) 09474 /************************************************************************ 09475 FIFMOD: 09476 returns the modulo of a and b 09477 ************************************************************************/ 09478 /* a - numerator */ 09479 /* b - denominator */ 09480 { 09481 return a % b; 09482 } /* END */ 09483 09484 /***=====================================================================***/ 09485 static void ftnstop(char* msg) 09486 /************************************************************************ 09487 FTNSTOP: 09488 Prints msg to standard error and then exits 09489 ************************************************************************/ 09490 /* msg - error message */ 09491 { 09492 if (msg != NULL) fprintf(stderr,"*** CDFLIB ERROR: %s\n",msg); 09493 /** exit(1); **/ /** RWCox - DON'T EXIT */ 09494 } /* END */ 09495 09496 /***=====================================================================***/ 09497 static int ipmpar(int *i) 09498 /* 09499 ----------------------------------------------------------------------- 09500 09501 IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER 09502 THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER 09503 HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... 09504 09505 INTEGERS. 09506 09507 ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM 09508 09509 SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) 09510 09511 WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. 09512 09513 IPMPAR(1) = A, THE BASE. 09514 09515 IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. 09516 09517 IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. 09518 09519 FLOATING-POINT NUMBERS. 09520 09521 IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING 09522 POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE 09523 NONZERO NUMBERS ARE REPRESENTED IN THE FORM 09524 09525 SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) 09526 09527 WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, 09528 X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. 09529 09530 IPMPAR(4) = B, THE BASE. 09531 09532 SINGLE-PRECISION 09533 09534 IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. 09535 09536 IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. 09537 09538 IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. 09539 09540 DOUBLE-PRECISION 09541 09542 IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. 09543 09544 IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. 09545 09546 IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. 09547 09548 ----------------------------------------------------------------------- 09549 09550 TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED REMOVE 09551 THE COMMENT DELIMITORS FROM THE DEFINITIONS DIRECTLY BELOW THE NAME 09552 OF THE MACHINE 09553 09554 *** RWCox: at this time, the IEEE parameters are enabled. 09555 09556 ----------------------------------------------------------------------- 09557 09558 IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY 09559 P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). 09560 IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE 09561 FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. 09562 09563 ----------------------------------------------------------------------- 09564 .. Scalar Arguments .. 09565 */ 09566 { 09567 static int imach[11]; 09568 static int outval ; 09569 /* MACHINE CONSTANTS FOR AMDAHL MACHINES. */ 09570 /* 09571 imach[1] = 2; 09572 imach[2] = 31; 09573 imach[3] = 2147483647; 09574 imach[4] = 16; 09575 imach[5] = 6; 09576 imach[6] = -64; 09577 imach[7] = 63; 09578 imach[8] = 14; 09579 imach[9] = -64; 09580 imach[10] = 63; 09581 */ 09582 /* MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T 09583 PC 7300, AND AT&T 6300. */ 09584 /* 09585 imach[1] = 2; 09586 imach[2] = 31; 09587 imach[3] = 2147483647; 09588 imach[4] = 2; 09589 imach[5] = 24; 09590 imach[6] = -125; 09591 imach[7] = 128; 09592 imach[8] = 53; 09593 imach[9] = -1021; 09594 imach[10] = 1024; 09595 */ 09596 /* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. */ 09597 /* 09598 imach[1] = 2; 09599 imach[2] = 33; 09600 imach[3] = 8589934591; 09601 imach[4] = 2; 09602 imach[5] = 24; 09603 imach[6] = -256; 09604 imach[7] = 255; 09605 imach[8] = 60; 09606 imach[9] = -256; 09607 imach[10] = 255; 09608 */ 09609 /* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. */ 09610 /* 09611 imach[1] = 2; 09612 imach[2] = 39; 09613 imach[3] = 549755813887; 09614 imach[4] = 8; 09615 imach[5] = 13; 09616 imach[6] = -50; 09617 imach[7] = 76; 09618 imach[8] = 26; 09619 imach[9] = -50; 09620 imach[10] = 76; 09621 */ 09622 /* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. */ 09623 /* 09624 imach[1] = 2; 09625 imach[2] = 39; 09626 imach[3] = 549755813887; 09627 imach[4] = 8; 09628 imach[5] = 13; 09629 imach[6] = -50; 09630 imach[7] = 76; 09631 imach[8] = 26; 09632 imach[9] = -32754; 09633 imach[10] = 32780; 09634 */ 09635 /* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES 09636 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT 09637 ARITHMETIC (NOS OPERATING SYSTEM). */ 09638 /* 09639 imach[1] = 2; 09640 imach[2] = 48; 09641 imach[3] = 281474976710655; 09642 imach[4] = 2; 09643 imach[5] = 48; 09644 imach[6] = -974; 09645 imach[7] = 1070; 09646 imach[8] = 95; 09647 imach[9] = -926; 09648 imach[10] = 1070; 09649 */ 09650 /* MACHINE CONSTANTS FOR THE CDC CYBER 995 64 BIT 09651 ARITHMETIC (NOS/VE OPERATING SYSTEM). */ 09652 /* 09653 imach[1] = 2; 09654 imach[2] = 63; 09655 imach[3] = 9223372036854775807; 09656 imach[4] = 2; 09657 imach[5] = 48; 09658 imach[6] = -4096; 09659 imach[7] = 4095; 09660 imach[8] = 96; 09661 imach[9] = -4096; 09662 imach[10] = 4095; 09663 */ 09664 /* MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. */ 09665 /* 09666 imach[1] = 2; 09667 imach[2] = 63; 09668 imach[3] = 9223372036854775807; 09669 imach[4] = 2; 09670 imach[5] = 47; 09671 imach[6] = -8189; 09672 imach[7] = 8190; 09673 imach[8] = 94; 09674 imach[9] = -8099; 09675 imach[10] = 8190; 09676 */ 09677 /* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. */ 09678 /* 09679 imach[1] = 2; 09680 imach[2] = 15; 09681 imach[3] = 32767; 09682 imach[4] = 16; 09683 imach[5] = 6; 09684 imach[6] = -64; 09685 imach[7] = 63; 09686 imach[8] = 14; 09687 imach[9] = -64; 09688 imach[10] = 63; 09689 */ 09690 /* MACHINE CONSTANTS FOR THE HARRIS 220. */ 09691 /* 09692 imach[1] = 2; 09693 imach[2] = 23; 09694 imach[3] = 8388607; 09695 imach[4] = 2; 09696 imach[5] = 23; 09697 imach[6] = -127; 09698 imach[7] = 127; 09699 imach[8] = 38; 09700 imach[9] = -127; 09701 imach[10] = 127; 09702 */ 09703 /* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 09704 AND DPS 8/70 SERIES. */ 09705 /* 09706 imach[1] = 2; 09707 imach[2] = 35; 09708 imach[3] = 34359738367; 09709 imach[4] = 2; 09710 imach[5] = 27; 09711 imach[6] = -127; 09712 imach[7] = 127; 09713 imach[8] = 63; 09714 imach[9] = -127; 09715 imach[10] = 127; 09716 */ 09717 /* MACHINE CONSTANTS FOR THE HP 2100 09718 3 WORD DOUBLE PRECISION OPTION WITH FTN4 */ 09719 /* 09720 imach[1] = 2; 09721 imach[2] = 15; 09722 imach[3] = 32767; 09723 imach[4] = 2; 09724 imach[5] = 23; 09725 imach[6] = -128; 09726 imach[7] = 127; 09727 imach[8] = 39; 09728 imach[9] = -128; 09729 imach[10] = 127; 09730 */ 09731 /* MACHINE CONSTANTS FOR THE HP 2100 09732 4 WORD DOUBLE PRECISION OPTION WITH FTN4 */ 09733 /* 09734 imach[1] = 2; 09735 imach[2] = 15; 09736 imach[3] = 32767; 09737 imach[4] = 2; 09738 imach[5] = 23; 09739 imach[6] = -128; 09740 imach[7] = 127; 09741 imach[8] = 55; 09742 imach[9] = -128; 09743 imach[10] = 127; 09744 */ 09745 /* MACHINE CONSTANTS FOR THE HP 9000. */ 09746 /* 09747 imach[1] = 2; 09748 imach[2] = 31; 09749 imach[3] = 2147483647; 09750 imach[4] = 2; 09751 imach[5] = 24; 09752 imach[6] = -126; 09753 imach[7] = 128; 09754 imach[8] = 53; 09755 imach[9] = -1021; 09756 imach[10] = 1024; 09757 */ 09758 /* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, 09759 THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA 09760 5/7/9 AND THE SEL SYSTEMS 85/86. */ 09761 /* 09762 imach[1] = 2; 09763 imach[2] = 31; 09764 imach[3] = 2147483647; 09765 imach[4] = 16; 09766 imach[5] = 6; 09767 imach[6] = -64; 09768 imach[7] = 63; 09769 imach[8] = 14; 09770 imach[9] = -64; 09771 imach[10] = 63; 09772 */ 09773 /* MACHINE CONSTANTS FOR THE IBM PC. */ 09774 /* 09775 imach[1] = 2; 09776 imach[2] = 31; 09777 imach[3] = 2147483647; 09778 imach[4] = 2; 09779 imach[5] = 24; 09780 imach[6] = -125; 09781 imach[7] = 128; 09782 imach[8] = 53; 09783 imach[9] = -1021; 09784 imach[10] = 1024; 09785 */ 09786 /* MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT 09787 MACFORTRAN II. */ 09788 /* 09789 imach[1] = 2; 09790 imach[2] = 31; 09791 imach[3] = 2147483647; 09792 imach[4] = 2; 09793 imach[5] = 24; 09794 imach[6] = -125; 09795 imach[7] = 128; 09796 imach[8] = 53; 09797 imach[9] = -1021; 09798 imach[10] = 1024; 09799 */ 09800 /* MACHINE CONSTANTS FOR THE MICROVAX - VMS FORTRAN. */ 09801 /* 09802 imach[1] = 2; 09803 imach[2] = 31; 09804 imach[3] = 2147483647; 09805 imach[4] = 2; 09806 imach[5] = 24; 09807 imach[6] = -127; 09808 imach[7] = 127; 09809 imach[8] = 56; 09810 imach[9] = -127; 09811 imach[10] = 127; 09812 */ 09813 /* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). */ 09814 /* 09815 imach[1] = 2; 09816 imach[2] = 35; 09817 imach[3] = 34359738367; 09818 imach[4] = 2; 09819 imach[5] = 27; 09820 imach[6] = -128; 09821 imach[7] = 127; 09822 imach[8] = 54; 09823 imach[9] = -101; 09824 imach[10] = 127; 09825 */ 09826 /* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). */ 09827 /* 09828 imach[1] = 2; 09829 imach[2] = 35; 09830 imach[3] = 34359738367; 09831 imach[4] = 2; 09832 imach[5] = 27; 09833 imach[6] = -128; 09834 imach[7] = 127; 09835 imach[8] = 62; 09836 imach[9] = -128; 09837 imach[10] = 127; 09838 */ 09839 /* MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING 09840 32-BIT INTEGER ARITHMETIC. */ 09841 /* 09842 imach[1] = 2; 09843 imach[2] = 31; 09844 imach[3] = 2147483647; 09845 imach[4] = 2; 09846 imach[5] = 24; 09847 imach[6] = -127; 09848 imach[7] = 127; 09849 imach[8] = 56; 09850 imach[9] = -127; 09851 imach[10] = 127; 09852 */ 09853 /* MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. */ 09854 /* 09855 imach[1] = 2; 09856 imach[2] = 31; 09857 imach[3] = 2147483647; 09858 imach[4] = 2; 09859 imach[5] = 24; 09860 imach[6] = -125; 09861 imach[7] = 128; 09862 imach[8] = 53; 09863 imach[9] = -1021; 09864 imach[10] = 1024; 09865 */ 09866 /* MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D 09867 SERIES (MIPS R3000 PROCESSOR). */ 09868 /* 09869 imach[1] = 2; 09870 imach[2] = 31; 09871 imach[3] = 2147483647; 09872 imach[4] = 2; 09873 imach[5] = 24; 09874 imach[6] = -125; 09875 imach[7] = 128; 09876 imach[8] = 53; 09877 imach[9] = -1021; 09878 imach[10] = 1024; 09879 */ 09880 /* MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T 09881 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T 09882 PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). */ 09883 09884 imach[1] = 2; 09885 imach[2] = 31; 09886 imach[3] = 2147483647; 09887 imach[4] = 2; 09888 imach[5] = 24; 09889 imach[6] = -125; 09890 imach[7] = 128; 09891 imach[8] = 53; 09892 imach[9] = -1021; 09893 imach[10] = 1024; 09894 09895 /* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. */ 09896 /* 09897 imach[1] = 2; 09898 imach[2] = 35; 09899 imach[3] = 34359738367; 09900 imach[4] = 2; 09901 imach[5] = 27; 09902 imach[6] = -128; 09903 imach[7] = 127; 09904 imach[8] = 60; 09905 imach[9] = -1024; 09906 imach[10] = 1023; 09907 */ 09908 /* MACHINE CONSTANTS FOR THE VAX 11/780. */ 09909 /* 09910 imach[1] = 2; 09911 imach[2] = 31; 09912 imach[3] = 2147483647; 09913 imach[4] = 2; 09914 imach[5] = 24; 09915 imach[6] = -127; 09916 imach[7] = 127; 09917 imach[8] = 56; 09918 imach[9] = -127; 09919 imach[10] = 127; 09920 */ 09921 outval = imach[*i]; 09922 return outval ; 09923 } 09924 09925 /*************************************************************************/ 09926 /*************************************************************************/ 09927 /************************ End of cdflib inclusion ************************/ 09928 /*************************************************************************/ 09929 /*************************************************************************/ 09930 09931 /*-----------------------------------------------------------------------*/ 09932 typedef struct { double p,q ; } pqpair ; /* for returning p=cdf q=1-cdf */ 09933 /*-----------------------------------------------------------------------*/ 09934 #undef BIGG 09935 #define BIGG 9.99e+37 /* a really big number (duh) */ 09936 /*-----------------------------------------------------------------------*/ 09937 09938 /*************************************************************************/ 09939 /******** Internal functions for various statistical computations ********/ 09940 /*************************************************************************/ 09941 09942 /*--------------------------------------------------------------- 09943 F statistic 09944 -----------------------------------------------------------------*/ 09945 09946 static double fstat_pq2s( pqpair pq , double dofnum , double dofden ) 09947 { 09948 int which , status ; 09949 double p , q , f , dfn , dfd , bound ; 09950 09951 which = 2 ; 09952 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 09953 q = pq.q ; if( q <= 0.0 ) return BIGG ; 09954 f = 0.0 ; 09955 dfn = dofnum ; 09956 dfd = dofden ; 09957 09958 cdff( &which , &p , &q , &f , &dfn , &dfd , &status , &bound ) ; 09959 return f ; 09960 } 09961 09962 /*------------------------------*/ 09963 09964 static pqpair fstat_s2pq( double ff , double dofnum , double dofden ) 09965 { 09966 int which , status ; 09967 double p , q , f , dfn , dfd , bound ; 09968 pqpair pq={0.0,1.0} ; 09969 09970 which = 1 ; 09971 p = 0.0 ; 09972 q = 1.0 ; 09973 f = ff ; if( f <= 0.0 ) return pq; 09974 dfn = dofnum ; if( dfn <= 0.0 ) return pq ; 09975 dfd = dofden ; if( dfd <= 0.0 ) return pq ; 09976 09977 cdff( &which , &p , &q , &f , &dfn , &dfd , &status , &bound ) ; 09978 pq.p = p ; pq.q = q ; return pq ; 09979 } 09980 09981 /*--------------------------------------------------------------- 09982 noncentral F statistic 09983 -----------------------------------------------------------------*/ 09984 09985 static double fnonc_pq2s( pqpair pq , double dofnum , double dofden , double nonc ) 09986 { 09987 int which , status ; 09988 double p , q , f , dfn , dfd , bound , pnonc ; 09989 09990 which = 2 ; 09991 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 09992 q = pq.q ; if( q <= 0.0 ) return BIGG ; 09993 f = 0.0 ; 09994 dfn = dofnum ; 09995 dfd = dofden ; 09996 pnonc = nonc ; 09997 09998 cdffnc( &which , &p , &q , &f , &dfn , &dfd , &pnonc , &status , &bound ) ; 09999 return f ; 10000 } 10001 10002 /*------------------------------*/ 10003 10004 static pqpair fnonc_s2pq( double ff , double dofnum , double dofden , double nonc ) 10005 { 10006 int which , status ; 10007 double p , q , f , dfn , dfd , bound , pnonc ; 10008 pqpair pq={0.0,1.0} ; 10009 10010 which = 1 ; 10011 p = 0.0 ; 10012 q = 1.0 ; 10013 f = ff ; if( f <= 0.0 ) return pq ; 10014 dfn = dofnum ; if( dfn <= 0.0 ) return pq ; 10015 dfd = dofden ; if( dfd <= 0.0 ) return pq ; 10016 pnonc = nonc ; if( pnonc < 0.0 ) return pq ; 10017 10018 cdffnc( &which , &p , &q , &f , &dfn , &dfd , &pnonc , &status , &bound ) ; 10019 pq.p = p ; pq.q = q ; return pq ; 10020 } 10021 10022 /*--------------------------------------------------------------- 10023 Standard Normal distribution 10024 -----------------------------------------------------------------*/ 10025 10026 static pqpair normal_s2pq( double zz ) 10027 { 10028 double p , q , x=zz ; 10029 pqpair pq ; 10030 10031 cumnor( &x, &p, &q ) ; 10032 pq.p = p ; pq.q = q ; return pq ; 10033 } 10034 10035 /*------------------------------*/ 10036 10037 static double normal_pq2s( pqpair pq ) 10038 { 10039 double p=pq.p , q=pq.q ; 10040 10041 if( p <= 0.0 ) return -BIGG ; 10042 if( q <= 0.0 ) return BIGG ; 10043 return dinvnr( &p,&q ) ; 10044 } 10045 10046 /*---------------------------------------------------------------- 10047 Chi-square 10048 ------------------------------------------------------------------*/ 10049 10050 static pqpair chisq_s2pq( double xx , double dof ) 10051 { 10052 int which , status ; 10053 double p,q,x,df,bound ; 10054 pqpair pq={0.0,1.0} ; 10055 10056 which = 1 ; 10057 p = 0.0 ; 10058 q = 1.0 ; 10059 x = xx ; if( x <= 0.0 ) return pq ; 10060 df = dof ; if( dof <= 0.0 ) return pq ; 10061 10062 cdfchi( &which , &p , &q , &x , &df , &status , &bound ) ; 10063 pq.p = p ; pq.q = q ; return pq ; 10064 } 10065 10066 /*------------------------------*/ 10067 10068 static double chisq_pq2s( pqpair pq , double dof ) 10069 { 10070 int which , status ; 10071 double p,q,x,df,bound ; 10072 10073 which = 2 ; 10074 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 10075 q = pq.q ; if( q <= 0.0 ) return BIGG ; 10076 x = 0.0 ; 10077 df = dof ; 10078 10079 cdfchi( &which , &p , &q , &x , &df , &status , &bound ) ; 10080 return x ; 10081 } 10082 10083 /*---------------------------------------------------------------- 10084 noncentral Chi-square 10085 ------------------------------------------------------------------*/ 10086 10087 static pqpair chsqnonc_s2pq( double xx , double dof , double nonc ) 10088 { 10089 int which , status ; 10090 double p,q,x,df,bound , pnonc ; 10091 pqpair pq={0.0,1.0} ; 10092 10093 which = 1 ; 10094 p = 0.0 ; 10095 q = 1.0 ; 10096 x = xx ; if( x <= 0.0 ) return pq ; 10097 df = dof ; if( df <= 0.0 ) return pq ; 10098 pnonc = nonc ; if( pnonc < 0.0 ) return pq ; 10099 10100 cdfchn( &which , &p , &q , &x , &df , &pnonc , &status , &bound ) ; 10101 pq.p = p ; pq.q = q ; return pq ; 10102 } 10103 10104 /*------------------------------*/ 10105 10106 static double chsqnonc_pq2s( pqpair pq , double dof , double nonc ) 10107 { 10108 int which , status ; 10109 double p,q,x,df,bound , pnonc ; 10110 10111 which = 2 ; 10112 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 10113 q = pq.q ; if( q <= 0.0 ) return BIGG ; 10114 x = 0.0 ; 10115 df = dof ; 10116 pnonc = nonc ; 10117 10118 cdfchn( &which , &p , &q , &x , &df , &pnonc , &status , &bound ) ; 10119 return x ; 10120 } 10121 10122 /*---------------------------------------------------------------- 10123 Beta distribution 10124 ------------------------------------------------------------------*/ 10125 10126 static pqpair beta_s2pq( double xx , double aa , double bb ) 10127 { 10128 int which , status ; 10129 double p,q,x,y,a,b,bound ; 10130 pqpair pq={0.0,1.0} ; 10131 10132 which = 1 ; 10133 p = 0.0 ; 10134 q = 1.0 ; 10135 x = xx ; if( x <= 0.0 ) return pq ; 10136 y = 1.0 - xx ; if( y <= 0.0 ){ pq.p=1.0; pq.q=0.0; return pq; } 10137 a = aa ; if( a < 0.0 ) return pq ; 10138 b = bb ; if( b < 0.0 ) return pq ; 10139 10140 cdfbet( &which , &p , &q , &x , &y , &a , &b , &status , &bound ) ; 10141 pq.p = p ; pq.q = q ; return pq ; 10142 } 10143 10144 /*------------------------------*/ 10145 10146 static double beta_pq2s( pqpair pq , double aa , double bb ) 10147 { 10148 int which , status ; 10149 double p,q,x,y,a,b,bound ; 10150 10151 which = 2 ; 10152 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 10153 q = pq.q ; if( q <= 0.0 ) return 1.0 ; 10154 x = 0.0 ; 10155 y = 1.0 ; 10156 a = aa ; 10157 b = bb ; 10158 10159 cdfbet( &which , &p , &q , &x , &y , &a , &b , &status , &bound ) ; 10160 return x ; 10161 } 10162 10163 /*---------------------------------------------------------------- 10164 Binomial distribution 10165 (that is, the probability that more than ss out of ntrial 10166 trials were successful). 10167 ------------------------------------------------------------------*/ 10168 10169 static pqpair binomial_s2pq( double ss , double ntrial , double ptrial ) 10170 { 10171 int which , status ; 10172 double p,q, s,xn,pr,ompr,bound ; 10173 pqpair pq={0.0,1.0} ; 10174 10175 which = 1 ; 10176 p = 0.0 ; 10177 q = 1.0 ; 10178 s = ss ; if( s < 0.0 ) return pq ; 10179 xn = ntrial ; if( xn <= 0.0 ) return pq ; 10180 pr = ptrial ; if( pr < 0.0 ) return pq ; 10181 ompr = 1.0 - ptrial ; 10182 10183 cdfbin( &which , &p , &q , &s , &xn , &pr , &ompr , &status , &bound ) ; 10184 pq.p = p ; pq.q = q ; return pq ; 10185 } 10186 10187 /*------------------------------*/ 10188 10189 static double binomial_pq2s( pqpair pq , double ntrial , double ptrial ) 10190 { 10191 int which , status ; 10192 double p,q, s,xn,pr,ompr,bound ; 10193 10194 which = 2 ; 10195 p = pq.p ; 10196 q = pq.q ; 10197 s = 0.0 ; 10198 xn = ntrial ; 10199 pr = ptrial ; 10200 ompr = 1.0 - ptrial ; 10201 10202 cdfbin( &which , &p , &q , &s , &xn , &pr , &ompr , &status , &bound ) ; 10203 return s ; 10204 } 10205 10206 /*---------------------------------------------------------------- 10207 Gamma distribution. 10208 ------------------------------------------------------------------*/ 10209 10210 static pqpair gamma_s2pq( double xx , double sh , double sc ) 10211 { 10212 int which , status ; 10213 double p,q, x,shape,scale,bound ; 10214 pqpair pq={0.0,1.0} ; 10215 10216 which = 1 ; 10217 p = 0.0 ; 10218 q = 1.0 ; 10219 x = xx ; if( x <= 0.0 ) return pq ; 10220 shape = sh ; if( shape <= 0.0 ) return pq ; 10221 scale = sc ; if( scale <= 0.0 ) return pq ; 10222 10223 cdfgam( &which , &p , &q , &x , &shape , &scale , &status , &bound ) ; 10224 pq.p = p ; pq.q = q ; return pq ; 10225 } 10226 10227 /*------------------------------*/ 10228 10229 static double gamma_pq2s( pqpair pq , double sh , double sc ) 10230 { 10231 int which , status ; 10232 double p,q, x,shape,scale,bound ; 10233 10234 which = 2 ; 10235 p = pq.p ; if( p <= 0.0 ) return 0.0 ; 10236 q = pq.q ; if( q <= 0.0 ) return BIGG ; 10237 x = 0.0 ; 10238 shape = sh ; 10239 scale = sc ; 10240 10241 cdfgam( &which , &p , &q , &x , &shape , &scale , &status , &bound ) ; 10242 return x ; 10243 } 10244 10245 /*---------------------------------------------------------------- 10246 Poisson distribution 10247 ------------------------------------------------------------------*/ 10248 10249 static pqpair poisson_s2pq( double xx , double lambda ) 10250 { 10251 int which , status ; 10252 double p,q, s,xlam,bound ; 10253 pqpair pq={0.0,1.0} ; 10254 10255 which = 1 ; 10256 p = 0.0 ; 10257 q = 1.0 ; 10258 s = xx ; if( s < 0.0 ) return pq ; 10259 xlam = lambda ; if( xlam < 0.0 ) return pq ; 10260 10261 cdfpoi( &which , &p , &q , &s , &xlam , &status , &bound ) ; 10262 pq.p = p ; pq.q = q ; return pq ; 10263 } 10264 10265 /*------------------------------*/ 10266 10267 static double poisson_pq2s( pqpair pq , double lambda ) 10268 { 10269 int which , status ; 10270 double p,q, s,xlam,bound ; 10271 10272 which = 2 ; 10273 p = pq.p ; 10274 q = pq.q ; 10275 s = 0.0 ; 10276 xlam = lambda ; 10277 10278 cdfpoi( &which , &p , &q , &s , &xlam , &status , &bound ) ; 10279 return s ; 10280 } 10281 10282 /*---------------------------------------------------------------- 10283 T distribution. 10284 ------------------------------------------------------------------*/ 10285 10286 static pqpair student_s2pq( double xx , double dof ) 10287 { 10288 int which , status ; 10289 double p,q, s,xlam,bound ; 10290 pqpair pq={0.0,1.0} ; 10291 10292 which = 1 ; 10293 p = 0.0 ; 10294 q = 1.0 ; 10295 s = xx ; 10296 xlam = dof ; if( xlam <= 0.0 ) return pq ; 10297 10298 cdft( &which , &p , &q , &s , &xlam , &status , &bound ) ; 10299 pq.p = p ; pq.q = q ; return pq ; 10300 } 10301 10302 /*------------------------------*/ 10303 10304 double student_pq2s( pqpair pq , double dof ) 10305 { 10306 int which , status ; 10307 double p,q, s,xlam,bound ; 10308 10309 which = 2 ; 10310 p = pq.p ; 10311 q = pq.q ; 10312 s = 0.0 ; 10313 xlam = dof ; 10314 10315 cdft( &which , &p , &q , &s , &xlam , &status , &bound ) ; 10316 return s ; 10317 } 10318 10319 /****************************************************************************/ 10320 /* For the distributions below here, cdflib can't do what we want directly. */ 10321 /****************************************************************************/ 10322 10323 /*---------------------------------------------------------------- 10324 Null correlation distribution. 10325 Let x = (rr+1)/2; then x is Beta(dof/2,dof/2). 10326 ------------------------------------------------------------------*/ 10327 10328 static pqpair correl_s2pq( double rr , double dof ) /* fake it with cdflib */ 10329 { 10330 return beta_s2pq( 0.5*(rr+1.0) , 0.5*dof , 0.5*dof ) ; 10331 } 10332 10333 /*------------------------------*/ 10334 10335 static double correl_pq2s( pqpair pq , double dof ) 10336 { 10337 double xx = beta_pq2s( pq , 0.5*dof , 0.5*dof ) ; 10338 return (2.0*xx-1.0) ; 10339 } 10340 10341 /*---------------------------------------------------------------- 10342 Uniform U(0,1) distribution. 10343 ------------------------------------------------------------------*/ 10344 10345 static pqpair uniform_s2pq( double xx ) /* this isn't too hard */ 10346 { 10347 pqpair pq ; 10348 if( xx <= 0.0 ) pq.p = 0.0 ; 10349 else if( xx >= 1.0 ) pq.p = 1.0 ; 10350 else pq.p = xx ; 10351 pq.q = 1.0-xx ; return pq ; 10352 } 10353 10354 /*------------------------------*/ 10355 10356 static double uniform_pq2s( pqpair pq ) 10357 { 10358 return pq.p ; /* that was easy */ 10359 } 10360 10361 /*---------------------------------------------------------------- 10362 standard Logistic distribution. 10363 ------------------------------------------------------------------*/ 10364 10365 static pqpair logistic_s2pq( double xx ) /* this isn't hard, either */ 10366 { 10367 pqpair pq ; 10368 if( xx >= 0.0 ){ pq.q = 1.0/(1.0+exp( xx)); pq.p = 1.0-pq.q; } 10369 else { pq.p = 1.0/(1.0+exp(-xx)); pq.q = 1.0-pq.p; } 10370 return pq ; 10371 } 10372 10373 /*------------------------------*/ 10374 10375 static double logistic_pq2s( pqpair pq ) 10376 { 10377 if( pq.p <= 0.0 ) return -BIGG ; 10378 else if( pq.q <= 0.0 ) return BIGG ; 10379 10380 if( pq.p < pq.q ) return -log(1.0/pq.p-1.0) ; 10381 else return log(1.0/pq.q-1.0) ; 10382 } 10383 10384 /*---------------------------------------------------------------- 10385 standard Laplace distribution. 10386 ------------------------------------------------------------------*/ 10387 10388 static pqpair laplace_s2pq( double xx ) /* easy */ 10389 { 10390 pqpair pq ; 10391 10392 if( xx >= 0.0 ){ pq.q = 0.5*exp(-xx) ; pq.p = 1.0-pq.q ; } 10393 else { pq.p = 0.5*exp( xx) ; pq.q = 1.0-pq.p ; } 10394 return pq ; 10395 } 10396 10397 /*------------------------------*/ 10398 10399 static double laplace_pq2s( pqpair pq ) 10400 { 10401 if( pq.p <= 0.0 ) return -BIGG ; 10402 else if( pq.q <= 0.0 ) return BIGG ; 10403 10404 if( pq.p < pq.q ) return log(2.0*pq.p) ; 10405 else return -log(2.0*pq.q) ; 10406 } 10407 10408 /*---------------------------------------------------------------- 10409 noncentral T distribution = hard calculation 10410 ------------------------------------------------------------------*/ 10411 10412 /**************************************************************************** 10413 Noncentral t distribution function by 10414 Professor K. Krishnamoorthy 10415 Department of Mathematics 10416 University of Louisiana at Lafayette 10417 Manually translated from Fortran by RWC. 10418 *****************************************************************************/ 10419 10420 #if 0 10421 static double alng( double x ) /* log(Gamma(x)) from K */ 10422 { 10423 int indx ; 10424 double xx,fterm,sum,valg ; 10425 double b[9] = { 0.0 , 10426 8.33333333333333e-2, 3.33333333333333e-2, 10427 2.52380952380952e-1, 5.25606469002695e-1, 10428 1.01152306812684e0, 1.51747364915329e0, 10429 2.26948897420496e0, 3.00991738325940e0 } ; 10430 10431 if( x < 8.0 ){ xx = x + 8.0 ; indx = 1 ; } 10432 else { xx = x ; indx = 0 ; } 10433 10434 fterm = (xx-0.5)*log(xx) - xx + 9.1893853320467e-1 ; 10435 sum = b[1]/(xx+b[2]/(xx+b[3]/(xx+b[4]/(xx+b[5]/(xx+b[6]/ 10436 (xx+b[7]/(xx+b[8]))))))) ; 10437 valg = sum + fterm ; 10438 if(indx) 10439 valg = valg-log(x+7.0)-log(x+6.0)-log(x+5.0) 10440 -log(x+4.0)-log(x+3.0)-log(x+2.0)-log(x+1.0)-log(x) ; 10441 return valg ; 10442 } 10443 #else 10444 static double alng( double x ) /*-- replace with cdflib function --*/ 10445 { 10446 double xx=x ; return alngam( &xx ) ; 10447 } 10448 #endif 10449 10450 /*---------------------------------------------------------------------------*/ 10451 10452 #if 0 10453 static double gaudf( double x ) /* N(0,1) cdf from K */ 10454 { 10455 static double p0=913.16744211475570 , p1=1024.60809538333800, 10456 p2=580.109897562908800, p3=202.102090717023000, 10457 p4=46.0649519338751400, p5=6.81311678753268400, 10458 p6=6.047379926867041e-1,p7=2.493381293151434e-2 ; 10459 static double q0=1826.33488422951125, q1=3506.420597749092, 10460 q2=3044.77121163622200, q3=1566.104625828454, 10461 q4=523.596091947383490, q5=116.9795245776655, 10462 q6=17.1406995062577800, q7=1.515843318555982, 10463 q8=6.25e-2 ; 10464 static double sqr2pi=2.506628274631001 ; 10465 int check ; 10466 double reslt,z , first,phi ; 10467 10468 if(x > 0.0){ z = x ; check = 1 ; } 10469 else { z =-x ; check = 0 ; } 10470 10471 if( z > 32.0 ) return (x > 0.0) ? 1.0 : 0.0 ; 10472 10473 first = exp(-0.5*z*z) ; 10474 phi = first/sqr2pi ; 10475 10476 if (z < 7.0) 10477 reslt = first* (((((((p7*z+p6)*z+p5)*z+p4)*z+p3)*z+p2)*z+p1)*z+p0) 10478 /((((((((q8*z+q7)*z+q6)*z+q5)*z+q4)*z+q3)*z+q2)*z+q1)*z+q0); 10479 else 10480 reslt = phi/(z+1.0/(z+2.0/(z+3.0/(z+4.0/(z+6.0/(z+7.0)))))) ; 10481 10482 if(check) reslt = 1.0 - reslt ; 10483 return reslt ; 10484 } 10485 #else 10486 static double gaudf( double x ) /*-- replace with cdflib func --*/ 10487 { 10488 double xx=x , p,q ; 10489 cumnor( &xx, &p, &q ); return p; 10490 } 10491 #endif 10492 10493 /*---------------------------------------------------------------------------*/ 10494 10495 #if 0 10496 static double betadf( double x , double p , double q ) /* Beta cdf from K */ 10497 { 10498 int check , ns ; 10499 double result,betf,psq,xx,cx,pp,qq ; 10500 double term,ai,rx,temp ; 10501 10502 if( x >= 1.0 ) return 1.0 ; 10503 if( x <= 0.0 ) return 0.0 ; 10504 10505 betf = alng(p)+alng(q)-alng(p+q) ; 10506 result=x ; 10507 psq=p+q ; 10508 cx=1.0-x ; 10509 if(p < psq*x){ xx=cx ; cx=x ; pp=q ; qq=p ; check=1 ; } 10510 else { xx=x ; pp=p ; qq=q ; check=0 ; } 10511 10512 term=1.0 ; 10513 ai=1.0 ; 10514 result=1.0 ; 10515 ns=(int)(qq+cx*psq) ; 10516 rx=xx/cx ; 10517 L3: 10518 temp=qq-ai ; 10519 if(ns == 0) rx=xx ; 10520 L4: 10521 term=term*temp*rx/(pp+ai) ; 10522 result=result+term ; 10523 temp=fabs(term) ; 10524 if(temp <= 1.e-14 && temp <= 1.e-14*result) goto L5 ; 10525 ai=ai+1.0 ; 10526 ns=ns-1 ; 10527 if(ns >= 0) goto L3 ; 10528 temp=psq ; 10529 psq=psq+1.0 ; 10530 goto L4 ; 10531 10532 L5: 10533 result=result*exp(pp*log(xx)+(qq-1.0)*log(cx)-betf)/pp ; 10534 if(check) result=1.0-result ; 10535 return result ; 10536 } 10537 #else 10538 static double betadf( double x , double p , double q ) /*-- cdflib func --*/ 10539 { 10540 double xx=x,yy=1.0-x , aa=p,bb=q , pp,qq ; 10541 cumbet( &xx,&yy , &aa,&bb , &pp,&qq ) ; return pp ; 10542 } 10543 #endif 10544 10545 /*---------------------------------------------------------------------------*/ 10546 /* Krishnamoorthy's function for cdf of noncentral t, for df > 0, 10547 translated into C by RW Cox [Mar 2004]. 10548 Note the original fails for delta=0, so we call the cdflib func for this. 10549 A couple of other minor fixes are also included. 10550 -----------------------------------------------------------------------------*/ 10551 10552 static pqpair tnonc_s2pq( double t , double df , double delta ) 10553 { 10554 int indx , k , i ; 10555 double x,del,tnd,ans,y,dels,a,b,c ; 10556 double pkf,pkb,qkf,qkb , pgamf,pgamb,qgamf,qgamb ; 10557 double pbetaf,pbetab,qbetaf,qbetab ; 10558 double ptermf,qtermf,ptermb,qtermb,term ; 10559 double rempois,delosq2,sum,cons,error ; 10560 10561 pqpair pq={0.0,1.0} ; /* will be return value */ 10562 double ab1 ; 10563 10564 /*-- stupid user? --*/ 10565 10566 if( df <= 0.0 ) return pq ; 10567 10568 /*-- non-centrality = 0? --*/ 10569 10570 if( fabs(delta) < 1.e-8 ) return student_s2pq(t,df) ; 10571 10572 /*-- start K's code here --*/ 10573 10574 if( t < 0.0 ){ x = -t ; del = -delta ; indx = 1 ; } /* x will be */ 10575 else { x = t ; del = delta ; indx = 0 ; } /* positive */ 10576 10577 ans = gaudf(-del) ; /* prob that x <= 0 = Normal cdf */ 10578 10579 /*-- the nearly trivial case of x=0 --*/ 10580 10581 if( x == 0.0 ){ pq.p = ans; pq.q = 1.0-ans; return pq; } 10582 10583 if( df == 1.0 ) df = 1.0000001 ; /** df=1 is BAD **/ 10584 10585 y = x*x/(df+x*x) ; /* between 0 and 1 */ 10586 dels = 0.5*del*del ; /* will be positive */ 10587 k = (int)dels ; /* 0, 1, 2, ... */ 10588 a = k+0.5 ; /* might be as small as 0.5 */ 10589 c = k+1.0 ; 10590 b = 0.5*df ; /* might be as small as 0.0 */ 10591 10592 pkf = exp(-dels+k*log(dels)-alng(k+1.0)) ; 10593 pkb = pkf ; 10594 qkf = exp(-dels+k*log(dels)-alng(k+1.0+0.5)) ; 10595 qkb = qkf ; 10596 10597 pbetaf = betadf(y, a, b) ; 10598 pbetab = pbetaf ; 10599 qbetaf = betadf(y, c, b) ; 10600 qbetab = qbetaf ; 10601 10602 ab1 = a+b-1.0 ; /* might be as small as -0.5 */ 10603 10604 /*-- RWCox: if a+b-1 < 0, log(Gamma(a+b-1)) won't work; 10605 instead, use Gamma(a+b-1)=Gamma(a+b)/(a+b-1) --*/ 10606 10607 if( ab1 > 0.0 ) 10608 pgamf = exp(alng(ab1)-alng(a)-alng(b)+(a-1.0)*log(y)+b*log(1.0-y)) ; 10609 else 10610 pgamf = exp(alng(a+b)-alng(a)-alng(b)+(a-1.0)*log(y)+b*log(1.0-y))/ab1 ; 10611 10612 pgamb = pgamf*y*(ab1)/a ; 10613 10614 /*-- we can't have c+b-1 < 0, so the above patchup isn't needed --*/ 10615 10616 qgamf = exp(alng(c+b-1.0)-alng(c)-alng(b)+(c-1.0)*log(y) + b*log(1.0-y)) ; 10617 qgamb = qgamf*y*(c+b-1.0)/c ; 10618 10619 rempois = 1.0 - pkf ; 10620 delosq2 = del/1.4142135623731 ; 10621 sum = pkf*pbetaf+delosq2*qkf*qbetaf ; 10622 cons = 0.5*(1.0 + 0.5*fabs(delta)) ; 10623 i = 0 ; 10624 L1: 10625 i = i + 1 ; 10626 pgamf = pgamf*y*(a+b+i-2.0)/(a+i-1.0) ; 10627 pbetaf = pbetaf - pgamf ; 10628 pkf = pkf*dels/(k+i) ; 10629 ptermf = pkf*pbetaf ; 10630 qgamf = qgamf*y*(c+b+i-2.0)/(c+i-1.0) ; 10631 qbetaf = qbetaf - qgamf ; 10632 qkf = qkf*dels/(k+i-1.0+1.5) ; 10633 qtermf = qkf*qbetaf ; 10634 term = ptermf + delosq2*qtermf ; 10635 sum = sum + term ; 10636 error = rempois*cons*pbetaf ; 10637 rempois = rempois - pkf ; 10638 10639 if( i > k ){ 10640 if( error <= 1.e-12 || i >= 9999 ) goto L2 ; 10641 goto L1 ; 10642 } else { 10643 pgamb = pgamb*(a-i+1.0)/(y*(a+b-i)) ; 10644 pbetab = pbetab + pgamb ; 10645 pkb = (k-i+1.0)*pkb/dels ; 10646 ptermb = pkb*pbetab ; 10647 qgamb = qgamb*(c-i+1.0)/(y*(c+b-i)) ; 10648 qbetab = qbetab + qgamb ; 10649 qkb = (k-i+1.0+0.5)*qkb/dels ; 10650 qtermb = qkb*qbetab ; 10651 term = ptermb + delosq2*qtermb ; 10652 sum = sum + term ; 10653 rempois = rempois - pkb ; 10654 if (rempois <= 1.e-12 || i >= 9999) goto L2 ; 10655 goto L1 ; 10656 } 10657 L2: 10658 tnd = 0.5*sum + ans ; 10659 10660 /*-- return a pqpair, not just the cdf --*/ 10661 10662 if( indx ){ pq.p = 1.0-tnd; pq.q = tnd ; } 10663 else { pq.p = tnd ; pq.q = 1.0-tnd; } 10664 return pq ; 10665 } 10666 10667 /*------------------------------*/ 10668 /* Inverse to above function; 10669 uses cdflib dstinv()/dinvr() 10670 to solve the equation. 10671 --------------------------------*/ 10672 10673 static double tnonc_pq2s( pqpair pq , double dof , double nonc ) 10674 { 10675 double t ; /* will be result */ 10676 double tbot,ttop , dt ; 10677 double T6=1.e-50,T7=1.e-8 ; 10678 double K4=0.5,K5=5.0 ; 10679 double fx ; 10680 unsigned long qhi,qleft ; 10681 int status , qporq , ite ; 10682 pqpair tpq ; 10683 10684 if( dof <= 0.0 ) return BIGG ; /* bad user */ 10685 if( pq.p <= 0.0 ) return -BIGG ; 10686 if( pq.q <= 0.0 ) return BIGG ; 10687 10688 t = student_pq2s(pq,dof) ; /* initial guess */ 10689 10690 if( fabs(nonc) < 1.e-8 ) return t ; 10691 10692 t += 0.5*nonc ; /* adjust up or down */ 10693 10694 dt = 0.1 * fabs(t) ; if( dt < 1.0 ) dt = 1.0 ; /* stepsize */ 10695 10696 /* scan down for lower bound, below which cdf is < p */ 10697 10698 tbot = t ; 10699 for( ite=0 ; ite < 1000 ; ite++ ){ 10700 tpq = tnonc_s2pq( tbot , dof , nonc ) ; 10701 if( tpq.p <= pq.p ) break ; 10702 tbot -= dt ; 10703 } 10704 if( ite >= 1000 ) return -BIGG ; 10705 10706 /* scan up for upper bound, above which cdf is > p */ 10707 10708 ttop = tbot+0.5*dt ; 10709 for( ite=0 ; ite < 1000 ; ite++ ){ 10710 tpq = tnonc_s2pq( ttop , dof , nonc ) ; 10711 if( tpq.p >= pq.p ) break ; 10712 ttop += dt ; 10713 } 10714 if( ite >= 1000 ) return BIGG ; 10715 10716 t = 0.5*(tbot+ttop) ; /* initial guess in middle */ 10717 10718 /* initialize searching parameters */ 10719 10720 dstinv(&tbot,&ttop,&K4,&K4,&K5,&T6,&T7); 10721 10722 status = 0 ; qporq = (pq.p <= pq.q) ; 10723 10724 while(1){ 10725 10726 dinvr(&status,&t,&fx,&qleft,&qhi) ; 10727 10728 if( status != 1 ) return t ; /* done! */ 10729 10730 tpq = tnonc_s2pq( t , dof , nonc ) ; /* get cdf */ 10731 10732 /* goal of dinvr is to drive fx to zero */ 10733 10734 fx = (qporq) ? pq.p-tpq.p : pq.q-tpq.q ; 10735 } 10736 10737 return BIGG ; /* unreachable */ 10738 } 10739 10740 /*---------------------------------------------------------------- 10741 Chi distribution (sqrt of chi-squared, duh). 10742 ------------------------------------------------------------------*/ 10743 10744 static pqpair chi_s2pq( double xx , double dof ) 10745 { 10746 pqpair pq={0.0,1.0} ; 10747 10748 if( xx <= 0.0 || dof <= 0.0 ) return pq ; 10749 return chisq_s2pq( xx*xx , dof ) ; 10750 } 10751 10752 /*------------------------------*/ 10753 10754 static double chi_pq2s( pqpair pq , double dof ) 10755 { 10756 if( pq.p <= 0.0 ) return 0.0 ; 10757 if( pq.q <= 0.0 ) return BIGG ; 10758 return sqrt(chisq_pq2s(pq,dof)) ; 10759 } 10760 10761 /*---------------------------------------------------------------- 10762 Extreme value type I: cdf(x) = exp(-exp(-x)). 10763 ------------------------------------------------------------------*/ 10764 10765 static pqpair extval1_s2pq( double x ) 10766 { 10767 double p,q,y ; pqpair pq ; 10768 10769 if( x > -5.0 ){ y = exp(-x) ; p = exp(-y) ; } 10770 else { y = 1.0 ; p = 0.0 ; } 10771 10772 if( y >= 1.e-4 ) q = 1.0-p ; 10773 else q = y*(1.0+y*(-0.5+y*(1.0/6.0-y/24.0))) ; 10774 pq.p = p ; pq.q = q ; return pq ; 10775 } 10776 10777 /*------------------------------*/ 10778 10779 static double extval1_pq2s( pqpair pq ) 10780 { 10781 if( pq.p <= 0.0 ) return -BIGG ; 10782 else if( pq.p >= 1.0 ) return BIGG ; 10783 return -log(-log(pq.p)) ; 10784 } 10785 10786 /*---------------------------------------------------------------- 10787 Weibull distribution: cdf(x) = 1 - exp( -x^c ) for x>0 and c>0. 10788 ------------------------------------------------------------------*/ 10789 10790 static pqpair weibull_s2pq( double x , double c ) 10791 { 10792 double y ; 10793 pqpair pq={0.0,1.0} ; 10794 10795 if( x <= 0.0 || c <= 0.0 ) return pq ; 10796 10797 y = pow(x,c) ; pq.q = exp(-y) ; 10798 if( y >= 1.e-4 ) pq.p = 1.0-pq.q ; 10799 else pq.p = y*(1.0+y*(-0.5+y*(1.0/6.0-y/24.0))) ; 10800 return pq ; 10801 } 10802 10803 /*------------------------------*/ 10804 10805 static double weibull_pq2s( pqpair pq , double c ) 10806 { 10807 if( pq.p <= 0.0 || c <= 0.0 ) return 0.0 ; 10808 else if( pq.q <= 0.0 ) return BIGG ; 10809 return pow( -log(pq.q) , 1.0/c ) ; 10810 } 10811 10812 /*---------------------------------------------------------------- 10813 Inverse Gaussian: 10814 density proportional to exp(-0.5*c(x+1/x))/x^1.5 (x,c >0). 10815 ------------------------------------------------------------------*/ 10816 10817 static pqpair invgauss_s2pq( double x, double c ) 10818 { 10819 double y , p1,q1 , p2,q2 , v ; 10820 pqpair pq={0.0,1.0} ; 10821 10822 if( x <= 0.0 || c <= 0.0 ) return pq ; 10823 10824 y = sqrt(c/x) ; 10825 v = y*(x-1.0) ; cumnor( &v , &p1,&q1 ) ; 10826 v = -y*(x+1.0) ; cumnor( &v , &p2,&q2 ) ; 10827 pq.p = p1 ; 10828 if( p2 > 0.0 ) pq.p += exp(2.0*c+log(p2)) ; 10829 pq.q = 1.0-pq.p ; return pq ; 10830 } 10831 10832 /*------------------------------*/ 10833 /* Inverse to above function; 10834 uses cdflib dstinv()/dinvr() 10835 to solve the equation. 10836 --------------------------------*/ 10837 10838 static double invgauss_pq2s( pqpair pq , double c ) 10839 { 10840 double t ; /* will be result */ 10841 double tbot,ttop , dt ; 10842 double T6=1.e-50,T7=1.e-8 ; 10843 double K4=0.5,K5=5.0 ; 10844 double fx ; 10845 unsigned long qhi,qleft ; 10846 int status , qporq , ite ; 10847 pqpair tpq ; 10848 10849 if( c <= 0.0 ) return BIGG ; /* bad user */ 10850 if( pq.p <= 0.0 ) return 0.0 ; 10851 if( pq.q <= 0.0 ) return BIGG ; 10852 10853 /* initial guess is t=1; scan down for lower bound */ 10854 10855 tbot = 1.01 ; dt = 0.9 ; 10856 for( ite=0 ; ite < 1000 ; ite++ ){ 10857 tpq = invgauss_s2pq( tbot , c ) ; 10858 if( tpq.p <= pq.p ) break ; 10859 tbot *= dt ; 10860 } 10861 if( ite >= 1000 ) return 0.0 ; 10862 10863 /* scan up for upper bound */ 10864 10865 dt = 1.1 ; ttop = tbot*dt ; 10866 for( ite=0 ; ite < 1000 ; ite++ ){ 10867 tpq = invgauss_s2pq( ttop , c ) ; 10868 if( tpq.p >= pq.p ) break ; 10869 ttop *= dt ; 10870 } 10871 if( ite >= 1000 ) return BIGG ; 10872 10873 t = sqrt(tbot*ttop) ; /* start at geometric mean */ 10874 10875 /* initialize searching parameters */ 10876 10877 dstinv(&tbot,&ttop,&K4,&K4,&K5,&T6,&T7); 10878 10879 status = 0 ; qporq = (pq.p <= pq.q) ; 10880 10881 while(1){ 10882 10883 dinvr(&status,&t,&fx,&qleft,&qhi) ; 10884 10885 if( status != 1 ) return t ; /* done! */ 10886 10887 tpq = invgauss_s2pq( t , c ) ; 10888 10889 /* goal is to drive fx to zero */ 10890 10891 fx = (qporq) ? pq.p-tpq.p : pq.q-tpq.q ; 10892 } 10893 10894 return BIGG ; /* unreachable */ 10895 } 10896 10897 /*--------------------------------------------------------------------------*/ 10898 /*! Given a value, calculate both its cdf and reversed cdf (1.0-cdf). 10899 If an error occurs, you'll probably get back {0.0,1.0}. 10900 All the actual work is done in utility functions for each distribution. 10901 ----------------------------------------------------------------------------*/ 10902 10903 static pqpair stat2pq( double val, int code, double p1,double p2,double p3 ) 10904 { 10905 pqpair pq={0.0,1.0} ; 10906 10907 switch( code ){ 10908 10909 case NIFTI_INTENT_CORREL: pq = correl_s2pq ( val, p1 ) ; break; 10910 case NIFTI_INTENT_TTEST: pq = student_s2pq ( val, p1 ) ; break; 10911 case NIFTI_INTENT_FTEST: pq = fstat_s2pq ( val, p1,p2 ) ; break; 10912 case NIFTI_INTENT_ZSCORE: pq = normal_s2pq ( val ) ; break; 10913 case NIFTI_INTENT_CHISQ: pq = chisq_s2pq ( val, p1 ) ; break; 10914 case NIFTI_INTENT_BETA: pq = beta_s2pq ( val, p1,p2 ) ; break; 10915 case NIFTI_INTENT_BINOM: pq = binomial_s2pq( val, p1,p2 ) ; break; 10916 case NIFTI_INTENT_GAMMA: pq = gamma_s2pq ( val, p1,p2 ) ; break; 10917 case NIFTI_INTENT_POISSON: pq = poisson_s2pq ( val, p1 ) ; break; 10918 case NIFTI_INTENT_FTEST_NONC: pq = fnonc_s2pq ( val, p1,p2,p3 ); break; 10919 case NIFTI_INTENT_CHISQ_NONC: pq = chsqnonc_s2pq( val, p1,p2 ); break; 10920 case NIFTI_INTENT_TTEST_NONC: pq = tnonc_s2pq ( val, p1,p2 ) ; break; 10921 case NIFTI_INTENT_CHI: pq = chi_s2pq ( val, p1 ) ; break; 10922 10923 /* these distributions are shifted and scaled copies of a standard case */ 10924 10925 case NIFTI_INTENT_INVGAUSS: 10926 if( p1 > 0.0 && p2 > 0.0 ) pq = invgauss_s2pq( val/p1,p2/p1 ) ; break; 10927 10928 case NIFTI_INTENT_WEIBULL: 10929 if( p2 > 0.0 && p3 > 0.0 ) pq = weibull_s2pq ((val-p1)/p2,p3) ; break; 10930 10931 case NIFTI_INTENT_EXTVAL: 10932 if( p2 > 0.0 ) pq = extval1_s2pq ( (val-p1)/p2 ) ; break; 10933 10934 case NIFTI_INTENT_NORMAL: 10935 if( p2 > 0.0 ) pq = normal_s2pq ( (val-p1)/p2 ) ; break; 10936 10937 case NIFTI_INTENT_LOGISTIC: 10938 if( p2 > 0.0 ) pq = logistic_s2pq( (val-p1)/p2 ) ; break; 10939 10940 case NIFTI_INTENT_LAPLACE: 10941 if( p2 > 0.0 ) pq = laplace_s2pq ( (val-p1)/p2 ) ; break; 10942 10943 case NIFTI_INTENT_UNIFORM: 10944 if( p2 > p1 ) pq = uniform_s2pq((val-p1)/(p2-p1)); break; 10945 10946 /* this case is trivial */ 10947 10948 case NIFTI_INTENT_PVAL: pq.p = 1.0-val ; pq.q = val ; break; 10949 } 10950 10951 return pq ; 10952 } 10953 10954 /*--------------------------------------------------------------------------*/ 10955 /*! Given a pq value (cdf and 1-cdf), compute the value that gives this. 10956 If an error occurs, you'll probably get back a BIGG number. 10957 All the actual work is done in utility functions for each distribution. 10958 ----------------------------------------------------------------------------*/ 10959 10960 static double pq2stat( pqpair pq, int code, double p1,double p2,double p3 ) 10961 { 10962 double val=BIGG ; 10963 10964 if( pq.p < 0.0 || pq.q < 0.0 || pq.p > 1.0 || pq.q > 1.0 ) return val ; 10965 10966 switch( code ){ 10967 10968 case NIFTI_INTENT_CORREL: val = correl_pq2s ( pq , p1 ) ; break; 10969 case NIFTI_INTENT_TTEST: val = student_pq2s ( pq , p1 ) ; break; 10970 case NIFTI_INTENT_FTEST: val = fstat_pq2s ( pq , p1,p2 ) ; break; 10971 case NIFTI_INTENT_ZSCORE: val = normal_pq2s ( pq ) ; break; 10972 case NIFTI_INTENT_CHISQ: val = chisq_pq2s ( pq , p1 ) ; break; 10973 case NIFTI_INTENT_BETA: val = beta_pq2s ( pq , p1,p2 ) ; break; 10974 case NIFTI_INTENT_BINOM: val = binomial_pq2s( pq , p1,p2 ) ; break; 10975 case NIFTI_INTENT_GAMMA: val = gamma_pq2s ( pq , p1,p2 ) ; break; 10976 case NIFTI_INTENT_POISSON: val = poisson_pq2s ( pq , p1 ) ; break; 10977 case NIFTI_INTENT_FTEST_NONC: val = fnonc_pq2s ( pq , p1,p2,p3 ); break; 10978 case NIFTI_INTENT_CHISQ_NONC: val = chsqnonc_pq2s( pq , p1,p2 ); break; 10979 case NIFTI_INTENT_TTEST_NONC: val = tnonc_pq2s ( pq , p1,p2 ) ; break; 10980 case NIFTI_INTENT_CHI: val = chi_pq2s ( pq , p1 ) ; break; 10981 10982 /* these distributions are shifted and scaled copies of a standard case */ 10983 10984 case NIFTI_INTENT_INVGAUSS: 10985 if( p1 > 0.0 && p2 > 0.0 ) val = p1*invgauss_pq2s ( pq,p2/p1); break; 10986 10987 case NIFTI_INTENT_WEIBULL: 10988 if( p2 > 0.0 && p3 > 0.0 ) val = p1+p2*weibull_pq2s ( pq, p3 ) ; break; 10989 10990 case NIFTI_INTENT_EXTVAL: 10991 if( p2 > 0.0 ) val = p1+p2*extval1_pq2s ( pq ) ; break; 10992 10993 case NIFTI_INTENT_NORMAL: 10994 if( p2 > 0.0 ) val = p1+p2*normal_pq2s ( pq ) ; break; 10995 10996 case NIFTI_INTENT_LOGISTIC: 10997 if( p2 > 0.0 ) val = p1+p2*logistic_pq2s( pq ) ; break; 10998 10999 case NIFTI_INTENT_LAPLACE: 11000 if( p2 > 0.0 ) val = p1+p2*laplace_pq2s ( pq ) ; break; 11001 11002 case NIFTI_INTENT_UNIFORM: 11003 if( p2 > p1 ) val = p1+(p2-p1)*uniform_pq2s(pq) ; break; 11004 11005 /* this case is trivial */ 11006 11007 case NIFTI_INTENT_PVAL: val = pq.q ; break; 11008 } 11009 11010 return val ; 11011 } 11012 11013 /****************************************************************************/ 11014 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/ 11015 /*..........................................................................*/ 11016 /*............. AT LAST! Functions to be called by the user! ..............*/ 11017 /*..........................................................................*/ 11018 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/ 11019 /****************************************************************************/ 11020 11021 /**************************************************************************** 11022 Statistical codes implemented here: 11023 11024 NIFTI_INTENT_CORREL = correlation statistic 11025 NIFTI_INTENT_TTEST = t statistic (central) 11026 NIFTI_INTENT_FTEST = F statistic (central) 11027 NIFTI_INTENT_ZSCORE = N(0,1) statistic 11028 NIFTI_INTENT_CHISQ = Chi-squared (central) 11029 NIFTI_INTENT_BETA = Beta variable (central) 11030 NIFTI_INTENT_BINOM = Binomial variable 11031 NIFTI_INTENT_GAMMA = Gamma distribution 11032 NIFTI_INTENT_POISSON = Poisson distribution 11033 NIFTI_INTENT_FTEST_NONC = noncentral F statistic 11034 NIFTI_INTENT_CHISQ_NONC = noncentral chi-squared 11035 NIFTI_INTENT_TTEST_NONC = noncentral t statistic 11036 NIFTI_INTENT_CHI = Chi statistic (central) 11037 NIFTI_INTENT_INVGAUSS = inverse Gaussian variable 11038 NIFTI_INTENT_WEIBULL = Weibull distribution 11039 NIFTI_INTENT_EXTVAL = Extreme value type I 11040 NIFTI_INTENT_NORMAL = N(mu,variance) normal 11041 NIFTI_INTENT_LOGISTIC = Logistic distribution 11042 NIFTI_INTENT_LAPLACE = Laplace distribution 11043 NIFTI_INTENT_UNIFORM = Uniform distribution 11044 NIFTI_INTENT_PVAL = "p-value" 11045 *****************************************************************************/ 11046 11047 static char *inam[]={ NULL , NULL , 11048 "CORREL" , "TTEST" , "FTEST" , "ZSCORE" , 11049 "CHISQ" , "BETA" , "BINOM" , "GAMMA" , 11050 "POISSON" , "NORMAL" , "FTEST_NONC" , "CHISQ_NONC" , 11051 "LOGISTIC" , "LAPLACE" , "UNIFORM" , "TTEST_NONC" , 11052 "WEIBULL" , "CHI" , "INVGAUSS" , "EXTVAL" , 11053 "PVAL" , 11054 NULL } ; 11055 11056 #include <ctype.h> 11057 #include <string.h> 11058 11059 /*--------------------------------------------------------------------------*/ 11060 /*! Given a string name for a statistic, return its integer code. 11061 Returns -1 if not found. 11062 ----------------------------------------------------------------------------*/ 11063 11064 int nifti_intent_code( char *name ) 11065 { 11066 char *unam , *upt ; 11067 int ii ; 11068 11069 if( name == NULL || *name == '\0' ) return -1 ; 11070 11071 unam = strdup(name) ; 11072 for( upt=unam ; *upt != '\0' ; upt++ ) *upt = (char)toupper(*upt) ; 11073 11074 for( ii=NIFTI_FIRST_STATCODE ; ii <= NIFTI_LAST_STATCODE ; ii++ ) 11075 if( strcmp(inam[ii],unam) == 0 ) break ; 11076 11077 free(unam) ; 11078 return (ii <= NIFTI_LAST_STATCODE) ? ii : -1 ; 11079 } 11080 11081 /*--------------------------------------------------------------------------*/ 11082 /*! Given a value, return its cumulative distribution function (cdf): 11083 - val = statistic 11084 - code = NIFTI_INTENT_* statistical code 11085 - p1,p2,p3 = parameters of the distribution 11086 11087 If an error occurs, you'll probably get back 0.0. 11088 ----------------------------------------------------------------------------*/ 11089 11090 double nifti_stat2cdf( double val, int code, double p1,double p2,double p3 ) 11091 { 11092 pqpair pq ; 11093 pq = stat2pq( val, code, p1,p2,p3 ) ; 11094 return pq.p ; 11095 } 11096 11097 /*--------------------------------------------------------------------------*/ 11098 /*! Given a value, return its reversed cumulative distribution function 11099 (1-cdf): 11100 - val = statistic 11101 - code = NIFTI_INTENT_* statistical code 11102 - p1,p2,p3 = parameters of the distribution 11103 11104 If an error transpires, you'll probably get back 1.0. 11105 ----------------------------------------------------------------------------*/ 11106 11107 double nifti_stat2rcdf( double val, int code, double p1,double p2,double p3 ) 11108 { 11109 pqpair pq ; 11110 pq = stat2pq( val, code, p1,p2,p3 ) ; 11111 return pq.q ; 11112 } 11113 11114 /*--------------------------------------------------------------------------*/ 11115 /*! Given a cdf probability, find the value that gave rise to it. 11116 - p = cdf; 0 < p < 1 11117 - code = NIFTI_INTENT_* statistical code 11118 - p1,p2,p3 = parameters of the distribution 11119 11120 If an error transpires, you'll probably get back a BIGG number. 11121 ----------------------------------------------------------------------------*/ 11122 11123 double nifti_cdf2stat( double p , int code, double p1,double p2,double p3 ) 11124 { 11125 pqpair pq ; 11126 pq.p = p ; pq.q = 1.0-p ; 11127 return pq2stat(pq,code,p1,p2,p3) ; 11128 } 11129 11130 /*--------------------------------------------------------------------------*/ 11131 /*! Given a reversed cdf probability, find the value that gave rise to it. 11132 - q = 1-cdf; 0 < q < 1 11133 - code = NIFTI_INTENT_* statistical code 11134 - p1,p2,p3 = parameters of the distribution 11135 11136 If an error transpires, you'll probably get back a BIGG number. 11137 ----------------------------------------------------------------------------*/ 11138 11139 double nifti_rcdf2stat( double q , int code, double p1,double p2,double p3 ) 11140 { 11141 pqpair pq ; 11142 pq.p = 1.0-q ; pq.q = q ; 11143 return pq2stat(pq,code,p1,p2,p3) ; 11144 } 11145 11146 /*--------------------------------------------------------------------------*/ 11147 /*! Given a statistic, compute a z-score from it. That is, the output 11148 is z such that cdf(z) of a N(0,1) variable is the same as the cdf 11149 of the given distribution at val. 11150 ----------------------------------------------------------------------------*/ 11151 11152 double nifti_stat2zscore( double val , int code, double p1,double p2,double p3 ) 11153 { 11154 pqpair pq ; 11155 11156 if( code == NIFTI_INTENT_ZSCORE ) return val ; /* trivial */ 11157 if( code == NIFTI_INTENT_NORMAL ) return (val-p1)/p2 ; /* almost so */ 11158 11159 pq = stat2pq( val, code, p1,p2,p3 ) ; /* find cdf */ 11160 return normal_pq2s( pq ) ; /* find z */ 11161 } 11162 11163 /*--------------------------------------------------------------------------*/ 11164 /*! Given a statistic, compute a half-z-score from it. That is, the output 11165 is z such that cdf(z) of a half-N(0,1) variable is the same as the cdf 11166 of the given distribution at val. A half-N(0,1) variable has density 11167 zero for z < 0 and twice the usual N(0,1) density for z > 0. 11168 ----------------------------------------------------------------------------*/ 11169 11170 double nifti_stat2hzscore( double val, int code, double p1,double p2,double p3 ) 11171 { 11172 pqpair pq ; 11173 11174 pq = stat2pq( val, code, p1,p2,p3 ) ; /* find cdf */ 11175 pq.q = 0.5*(1.0-pq.p) ; pq.p = 0.5*(1.0+pq.p) ; /* mangle it */ 11176 return normal_pq2s( pq ) ; /* find z */ 11177 } 11178 11179 /****************************************************************************/ 11180 /*[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]*/ 11181 /****************************************************************************/ 11182 11183 /*--------------------------------------------------------------------------*/ 11184 /* Sample program to test the above functions. Otherwise unimportant. 11185 ----------------------------------------------------------------------------*/ 11186 11187 int main( int argc , char *argv[] ) 11188 { 11189 double val , p , q , p1=0.0,p2=0.0,p3=0.0 ; 11190 double vbot,vtop,vdel ; 11191 int code , iarg=1 , doq=0 , dod=0 , doi=0 , doz=0 , doh=0 ; 11192 11193 /*-- print some help for the pitiful user --*/ 11194 11195 if( argc < 3 || strstr(argv[1],"help") != NULL ){ 11196 int ii ; 11197 printf("\n") ; 11198 printf("Demo program for computing NIfTI statistical functions.\n") ; 11199 printf("Usage: nifti_stats [-q|-d|-1|-z] val CODE [p1 p2 p3]\n") ; 11200 printf(" val can be a single number or in the form bot:top:step.\n") ; 11201 printf(" default ==> output p = Prob(statistic < val).\n") ; 11202 printf(" -q ==> output is 1-p.\n") ; 11203 printf(" -d ==> output is density.\n") ; 11204 printf(" -1 ==> output is x such that Prob(statistic < x) = val.\n") ; 11205 printf(" -z ==> output is z such that Normal cdf(z) = p(val).\n") ; 11206 printf(" -h ==> output is z such that 1/2-Normal cdf(z) = p(val).\n"); 11207 printf(" Allowable CODEs:\n") ; 11208 for( ii=NIFTI_FIRST_STATCODE ; ii <= NIFTI_LAST_STATCODE ; ii++ ){ 11209 printf(" %-10s",inam[ii]); if((ii-NIFTI_FIRST_STATCODE)%6==5)printf("\n"); 11210 } 11211 printf("\n") ; 11212 printf(" Following CODE are distributional parameters, as needed.\n"); 11213 printf("\n") ; 11214 printf("Results are written to stdout, 1 number per output line.\n") ; 11215 printf("Example (piping output into AFNI program 1dplot):\n") ; 11216 printf(" nifti_stats -d 0:4:.001 INVGAUSS 1 3 | 1dplot -dx 0.001 -stdin\n"); 11217 printf("\n") ; 11218 printf("Author - RW Cox - SSCC/NIMH/NIH/DHHS/USA/EARTH - March 2004\n") ; 11219 printf("\n") ; 11220 exit(0) ; 11221 } 11222 11223 /*-- check first arg to see if it is an output option; 11224 if so, set the appropriate output flag to determine what to compute --*/ 11225 11226 if( strcmp(argv[iarg],"-q") == 0 ){ doq = 1 ; iarg++ ; } 11227 else if( strcmp(argv[iarg],"-d") == 0 ){ dod = 1 ; iarg++ ; } 11228 else if( strcmp(argv[iarg],"-1") == 0 ){ doi = 1 ; iarg++ ; } 11229 else if( strcmp(argv[iarg],"-z") == 0 ){ doz = 1 ; iarg++ ; } 11230 else if( strcmp(argv[iarg],"-h") == 0 ){ doh = 1 ; iarg++ ; } 11231 11232 /*-- get the value(s) to process --*/ 11233 11234 vbot=vtop=vdel = 0.0 ; 11235 sscanf( argv[iarg++] , "%lf:%lf:%lf" , &vbot,&vtop,&vdel ) ; 11236 if( vbot >= vtop ) vdel = 0.0 ; 11237 if( vdel <= 0.0 ) vtop = vbot ; 11238 11239 /*-- decode the CODE into the integer signifying the distribution --*/ 11240 11241 code = nifti_intent_code(argv[iarg++]) ; 11242 if( code < 0 ){ fprintf(stderr,"illegal code=%s\n",argv[iarg-1]); exit(1); } 11243 11244 /*-- get the parameters, if present (defaults are 0) --*/ 11245 11246 if( argc > iarg ) p1 = strtod(argv[iarg++],NULL) ; 11247 if( argc > iarg ) p2 = strtod(argv[iarg++],NULL) ; 11248 if( argc > iarg ) p3 = strtod(argv[iarg++],NULL) ; 11249 11250 /*-- loop over input value(s), compute output, write to stdout --*/ 11251 11252 for( val=vbot ; val <= vtop ; val += vdel ){ 11253 if( doq ) /* output = 1-cdf */ 11254 p = nifti_stat2rcdf( val , code,p1,p2,p3 ) ; 11255 else if( dod ) /* output = density */ 11256 p = 1000.0*( nifti_stat2cdf(val+.001,code,p1,p2,p3) 11257 -nifti_stat2cdf(val ,code,p1,p2,p3)) ; 11258 else if( doi ) /* output = inverse */ 11259 p = nifti_cdf2stat( val , code,p1,p2,p3 ) ; 11260 else if( doz ) /* output = z score */ 11261 p = nifti_stat2zscore( val , code,p1,p2,p3 ) ; 11262 else if( doh ) /* output = halfz score */ 11263 p = nifti_stat2hzscore( val , code,p1,p2,p3 ) ; 11264 else /* output = cdf */ 11265 p = nifti_stat2cdf( val , code,p1,p2,p3 ) ; 11266 11267 printf("%.9g\n",p) ; 11268 if( vdel <= 0.0 ) break ; /* the case of just 1 value */ 11269 } 11270 11271 /*-- terminus est --*/ 11272 11273 exit(0) ; 11274 }
This site conforms to the following standards:
