C ALGORITHM 668, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 14, NO. 4, PP. 397-398. C C EXAMPLE DRIVER PROGRAM FOR ALGORITHM H2PEC C C IIN : LOGICAL INPUT UNIT C IOUT : LOGICAL OUTPUT UNIT C NS : NUMBER OF RANDOM VARIATES TO BE GENERATED C K, N1, N2 : PARAMETERS OF THE HYPERGEOMETRIC DISTRIBUTION C FK,FN1,FN2: FLOATING POINT PARAMETER VALUES C ISEED : RANDOM NUMBER SEED C JX : HYPERGEOMETRIC RANDOM VARIATE GENERATED C XMEAN : SAMPLE MEAN C SVAR : SAMPLE VARIANCE C TMEAN : TRUE MEAN C TVAR : TRUE VARIANCE C SUM : SUM OF HYPERGEOMETRIC RANDOM VARIATES JX C SUM2 : SUM OF SQUARE OF JX C C DATA IIN/5/, IOUT/6/ 10 WRITE(IOUT,105) 105 FORMAT(' -- ENTER MONTE CARLO SAMPLE SIZE -- EOF TO QUIT') READ(IIN,*,END = 999) NS WRITE(IOUT,*) NS WRITE(IOUT,106) 106 FORMAT(' -- ENTER RANDOM NUMBER SEED') READ(IIN,*,END = 999) ISEED WRITE(IOUT,*) ISEED WRITE(IOUT,107) 107 FORMAT(' -- ENTER PARAMETERS K, N1, AND N2 --') READ(IIN,*) K, N1, N2 WRITE(IOUT,*) K, N1, N2 FK = K FN1 = N1 FN2 = N2 TMEAN = FK * FN1 / (FN1 + FN2) TVAR = TMEAN * (FN1 + FN2 - FK) * FN2 \$ / (FN1 + FN2) / (FN1 + FN2 - 1.) SUM = 0.0 SUM2 = 0.0 DO 20 I = 1, NS CALL H2PEC(K,N1,N2,ISEED,JX) IF (JX .LT. 0) THEN WRITE (IOUT, 109) 109 FORMAT (' INVALID PARAMETER VALUE') GO TO 10 ENDIF X = JX - TMEAN SUM = SUM + X SUM2 = SUM2 + X * X 20 CONTINUE XMEAN = SUM / NS + TMEAN SVAR = SUM2 / NS WRITE(IOUT,110) NS, TMEAN, XMEAN, TVAR, SVAR 110 FORMAT(/5X,'SAMPLE SIZE = ',I10 / \$ 5X,'TRUE MEAN = ',F15.5/ \$ 5X,'SAMPLE MEAN = ',F15.5/ \$ 5X,'TRUE VARIANCE = ',F15.5/ \$ 5X,'SAMPLE VARIANCE = ',F15.5/) GOTO 10 999 STOP END SUBROUTINE H2PEC(KK,NN1,NN2,ISEED,JX) C C HYPERGEOMETRIC RANDOM VARIATE GENERATOR C C METHOD C IF (MODE - MAX(0,KK-NN2) .LT. 10), USE THE INVERSE CDF. C OTHERWISE, USE ALGORITHM H2PE: ACCEPTANCE-REJECTION VIA C THREE REGION COMPOSITION. THE THREE REGIONS ARE A C RECTANGLE, AND EXPONENTIAL LEFT AND RIGHT TAILS. C H2PE REFERS TO HYPERGEOMETRIC-2 POINTS-EXPONENTIAL TAILS. C H2PEC REFERS TO H2PE AND "COMBINED." THUS H2PE IS THE C RESEARCH RESULT AND H2PEC IS THE IMPLEMENTATION OF A C COMPLETE USABLE ALGORITHM. C C REFERENCE C VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER, C "COMPUTER GENERATION OF HYPERGEOMETRIC RANDOM VARIATES," C JOURNAL OF STATISTICAL COMPUTATION AND SIMULATION, C 22(1985), 2, 1985, 127-145. C C REQUIRED SUBPROGRAMS C AFC() : A DOUBLE-PRECISION FUNCTION TO EVALUATE C THE LOGARITHM OF THE FACTORIAL. C RAND(): A UNIFORM (0,1) RANDOM NUMBER GENERATOR. C C ARGUMENTS C NN1 : NUMBER OF WHITE BALLS (INPUT) C NN2 : NUMBER OF BLACK BALLS (INPUT) C KK : NUMBER OF BALLS TO BE DRAWN (INPUT) C ISEED : RANDOM NUMBER SEED (INPUT AND OUTPUT) C JX : NUMBER OF WHITE BALLS DRAWN (OUTPUT) C C STRUCTURAL VARIABLES C REJECT: LOGICAL FLAG TO REJECT THE VARIATE GENERATE BY H2PE. C SETUP1: LOGICAL FLAG TO SETUP FOR NEW VALUES OF NN1 OR NN2. C SETUP2: LOGICAL FLAG TO SETUP FOR NEW VALUES OF KK. C IX : INTEGER CANDIDATE VALUE. C M : DISTRIBUTION MODE. C MINJX : DISTRIBUTION LOWER BOUND. C MAXJX : DISTRIBUTION UPPER BOUND. C KS : SAVED VALUE OF KK FROM THE LAST CALL TO H2PEC. C N1S : SAVED VALUE OF NN1 FROM THE LAST CALL TO H2PEC. C N2S : SAVED VALUE OF NN2 FROM THE LAST CALL TO H2PEC. C K,N1,N2: ALTERNATE VARIABLES FOR KK, NN1, AND NN2 C (ALWAYS (N1 .LE. N2) AND (K .LE. (N1+N2)/2)). C TN : TOTAL NUMBER OF WHITE AND BLACK BALLS C C INVERSE-TRANSFORMATION VARIABLES C CON : NATURAL LOGARITHM OF SCALE. C P : CURRENT SCALED PROBABILITY FOR THE INVERSE CDF. C SCALE : A BIG CONSTANT (1.E25) USED TO SCALE THE C PROBABILITY TO AVOID NUMERICAL UNDERFLOW C U : THE UNIFORM VARIATE BETWEEN (0, 1.E25). C W : SCALED HYPERGEOMETRIC PROBABILITY OF MINJX. C C H2PE VARIABLES C S : DISTRIBUTION STANDARD DEVIATION. C D : HALF THE AREA OF THE RECTANGLE. C XL : LEFT END OF THE RECTANGLE. C XR : RIGHT END OF THE RECTANGLE. C A : A SCALING CONSTANT. C KL : HIGHEST POINT OF THE LEFT-TAIL REGION. C KR : HIGHEST POINT OF THE RIGHT-TAIL REGION. C LAMDL : RATE FOR THE LEFT EXPONENTIAL TAIL. C LAMDR : RATE FOR THE RIGHT EXPONENTIAL TAIL. C P1 : AREA OF THE RECTANGLE. C P2 : AREA OF THE LEFT EXPONENTIAL TAIL PLUS P1. C P3 : AREA OF THE RIGHT EXPONENTIAL TAIL PLUS P2. C U : A UNIFORM (0,P3) RANDOM VARIATE USED FIRST TO SELECT C ONE OF THE THREE REGIONS AND THEN CONDITIONALLY TO C GENERATE A VALUE FROM THE REGION. C V : U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM C VALUE OR TO ACCEPT OR REJECT THE CANDIDATE VALUE. C F : THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE C ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL. C I : INDEX FOR EXPLICIT CALCULATION OF F FOR H2PE. C C THE FOLLOWING VARIABLES ARE TEMPORARY VARIABLES USED IN C COMPUTING THE UPPER AND LOWER BOUNDS OF THE NATURAL LOGARITHM C OF THE SCALED DENSITY. THE DETAILED DESCRIPTION IS GIVEN IN C PROPOSITIONS 2 AND 3 OF THE APPENDIX IN THE REFERENCE. C Y, Y1, YM, YN, YK, NK, R, S, T, E, G, DG, GU, GL, XM, C XN, XK, NM C C Y : PRELIMINARY CONTINUOUS CANDIDATE VALUE, FLOAT(IX) C UB : UPPER BOUND FOR THE NATURAL LOGARITHM OF THE SCALED C DENSITY. C ALV : NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V. C DR, DS, DT, DE: ONE OF MANY TERMS SUBTRACTED FROM THE UPPER C BOUND TO OBTAIN THE LOWER BOUND ON THE NATURAL C LOGARITHM OF THE SCALED DENSITY. C DELTAU: A CONSTANT, THE VALUE 0.0034 IS OBTAINED BY SETTING C N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN C THE FUNCTION DELTA_U IN LEMMA 1 AND ROUNDING THE C VALUE TO FOUR DECIMAL PLACES. C DELTAL: A CONSTANT, THE VALUE 0.0078 IS OBTAINED BY SETTING C N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN C THE FUNCTION DELTA_L IN LEMMA 1 AND ROUNDING THE C VALUE TO FOUR DECIMAL PLACES. C SAVE DOUBLE PRECISION AFC,CON,P,SCALE,U,W,A,XL,XR REAL KL,KR,LAMDL,LAMDR,NK,NM LOGICAL REJECT,SETUP1,SETUP2 DATA KS,N1S,N2S/-1,-1,-1/ DATA CON,DELTAL,DELTAU,SCALE/57.56462733D0,0.0078,0.0034,1.D25/ C C*****CHECK PARAMETER VALIDITY C IF ( (NN1 .LT. 0) .OR. \$ (NN2 .LT. 0) .OR. \$ (KK .LT. 0) .OR. \$ (KK .GT. NN1 + NN2 ) ) THEN JX = -1 RETURN ENDIF C C*****IF NEW PARAMETER VALUES, INITIALIZE C REJECT = .TRUE. SETUP1 = .FALSE. SETUP2 = .FALSE. IF ((NN1 .NE. N1S) .OR. (NN2 .NE. N2S)) THEN SETUP1 = .TRUE. SETUP2 = .TRUE. ELSEIF (KK .NE. KS) THEN SETUP2 = .TRUE. ENDIF C IF (SETUP1) THEN N1S = NN1 N2S = NN2 TN = NN1 + NN2 IF (NN1 .LE. NN2) THEN N1 = NN1 N2 = NN2 ELSE N1 = NN2 N2 = NN1 ENDIF ENDIF C IF (SETUP2) THEN KS = KK IF (KK+KK .GE. TN) THEN K = TN - KK ELSE K = KK ENDIF ENDIF C IF (SETUP1 .OR. SETUP2) THEN M = INT ((K+1.) * (N1+1.) / (TN+2.)) MINJX = MAX (0, K-N2) MAXJX = MIN (N1, K) ENDIF C C*****GENERATE RANDOM VARIATE C IF (MINJX .EQ. MAXJX) THEN C C ...DEGENERATE DISTRIBUTION... C IX = MAXJX RETURN ELSEIF (M-MINJX .LT. 10) THEN C C ...INVERSE TRANSFORMATION... C IF (SETUP1 .OR. SETUP2) THEN IF (K .LT. N2) THEN W = EXP (CON + AFC(N2) + AFC(N1+N2-K) \$ - AFC(N2-K) - AFC(N1+N2)) ELSE W = EXP (CON + AFC(N1) + AFC(K) \$ - AFC(K-N2) - AFC(N1+N2)) ENDIF ENDIF C 10 P = W IX = MINJX U = RAND (ISEED) * SCALE 20 IF (U .GT. P) THEN U = U - P P = P * (N1-IX)*(K-IX) IX = IX + 1 P = P / IX / (N2-K+IX) IF (IX .GT. MAXJX) GO TO 10 GO TO 20 ENDIF ELSE C C ...H2PE... C IF (SETUP1 .OR. SETUP2) THEN S = SQRT ((TN-K) * K * N1 * N2 / (TN-1) / TN /TN) C C ...REMARK: D IS DEFINED IN REFERENCE WITHOUT INT. C THE TRUNCATION CENTERS THE CELL BOUNDARIES AT 0.5 C D = INT (1.5*S) + .5 XL = M - D + .5 XR = M + D + .5 A = AFC(M) + AFC(N1-M) + AFC(K-M) + AFC(N2-K+M) KL = EXP (A - AFC(INT(XL)) - AFC(INT(N1-XL)) \$ - AFC(INT(K-XL)) - AFC(INT(N2-K+XL))) KR = EXP (A - AFC(INT(XR-1)) - AFC(INT(N1-XR+1)) \$ - AFC(INT(K-XR+1)) - AFC(INT(N2-K+XR-1))) LAMDL = -LOG (XL * (N2-K+XL) / (N1-XL+1) / (K-XL+1)) LAMDR = -LOG ((N1-XR+1) * (K-XR+1) / XR / (N2-K+XR)) P1 = D + D P2 = P1 + KL / LAMDL P3 = P2 + KR / LAMDR ENDIF C 30 U = RAND (ISEED) * P3 V = RAND (ISEED) IF (U .LT. P1) THEN C C ...RECTANGULAR REGION... C IX = XL + U ELSEIF (U .LE. P2) THEN C C ...LEFT TAIL... C IX = XL + LOG(V)/LAMDL IF (IX .LT. MINJX) GO TO 30 V = V * (U-P1) * LAMDL ELSE C C ...RIGHT TAIL... C IX = XR - LOG(V)/LAMDR IF (IX .GT. MAXJX) GO TO 30 V = V * (U-P2) * LAMDR ENDIF C C ...ACCEPTANCE/REJECTION TEST... C IF (M .LT. 100 .OR. IX .LE. 50) THEN C C ...EXPLICIT EVALUATION... C F = 1.0 IF (M .LT. IX) THEN DO 40 I = M+1,IX 40 F = F * (N1-I+1) * (K-I+1) / (N2-K+I) / I ELSEIF (M .GT. IX) THEN DO 50 I = IX+1,M 50 F = F * I * (N2-K+I) / (N1-I) / (K-I) ENDIF IF (V .LE. F) THEN REJECT = .FALSE. ENDIF ELSE C C ...SQUEEZE USING UPPER AND LOWER BOUNDS... C Y = IX Y1 = Y + 1. YM = Y - M YN = N1 - Y + 1. YK = K - Y + 1. NK = N2 - K + Y1 R = -YM / Y1 S = YM / YN T = YM / YK E = -YM / NK G = YN * YK / (Y1*NK) - 1. DG = 1. IF (G .LT. 0.) DG = 1.+G GU = G * (1.+G*(-.5+G/3.)) GL = GU - .25 * (G*G)**2 / DG XM = M + .5 XN = N1 - M + .5 XK = K - M + .5 NM = N2 - K + XM UB = Y * GU - M * GL + DELTAU \$ + XM * R * (1.+R*(-.5+R/3.)) \$ + XN * S * (1.+S*(-.5+S/3.)) \$ + XK * T * (1.+T*(-.5+T/3.)) \$ + NM * E * (1.+E*(-.5+E/3.)) C C ...TEST AGAINST UPPER BOUND... C ALV = LOG(V) IF (ALV .GT. UB) THEN REJECT = .TRUE. ELSE C C ...TEST AGAINST LOWER BOUND... C DR = XM * (R*R)**2 IF (R .LT. 0.) DR = DR / (1.+R) DS = XN * (S*S)**2 IF (S .LT. 0.) DS = DS / (1.+S) DT = XK * (T*T)**2 IF (T .LT. 0.) DT = DT / (1.+T) DE = NM * (E*E)**2 IF (E .LT. 0.) DE = DE / (1.+E) IF (ALV .LT. UB-.25*(DR+DS+DT+DE) \$ +(Y+M)*(GL-GU)-DELTAL) THEN REJECT = .FALSE. ELSE C C ...STIRLING'S FORMULA TO MACHINE ACCURACY... C IF (ALV .LE. (A - AFC(IX) - AFC(N1-IX) \$ - AFC(K-IX) - AFC(N2-K+IX)) ) THEN REJECT = .FALSE. ELSE REJECT = .TRUE. ENDIF ENDIF ENDIF ENDIF IF (REJECT) GO TO 30 ENDIF C C*****RETURN APPROPRIATE VARIATE C IF (KK + KK .GE. TN) THEN IF (NN1 .GT. NN2) THEN IX = KK - NN2 + IX ELSE IX = NN1 - IX ENDIF ELSE IF (NN1 .GT. NN2) IX = KK - IX ENDIF JX = IX RETURN END DOUBLE PRECISION FUNCTION AFC(I) C C FUNCTION TO EVALUATE LOGARITHM OF THE FACTORIAL I C IF (I .GT. 7), USE STIRLING'S APPROXIMATION C OTHERWISE, USE TABLE LOOKUP C DOUBLE PRECISION AL(8), DI DATA AL/0.D0,0.D0,0.6931471806D0,1.791759469D0,3.178053830D0, \$ 4.787491743D0,6.579251212D0,8.525161361D0/ IF (I .LE. 7) THEN AFC = AL(I+1) ELSE DI = I 1 AFC = (DI+0.5D0) * LOG(DI) - DI + 0.08333333333333D0/DI \$ -0.00277777777777D0/DI/DI/DI + 0.9189385332D0 ENDIF RETURN END FUNCTION RAND(IX) C C UNIFORM RANDOM NUMBER GENERATOR C REFERENCE: L. SCHRAGE, C "A MORE PORTABLE FORTRAN RANDOM NUMBER GENERATOR," C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, C 5(1979), 132-138. C INTEGER A,P,IX,B15,B16,XHI,XALO,LEFTLO,FHI,K DATA A/16807/,B15/32768/,B16/65536/,P/2147483647/ XHI = IX/B16 XALO = (IX-XHI * B16) * A LEFTLO = XALO/B16 FHI = XHI * A + LEFTLO K = FHI / B15 IX = (((XALO - LEFTLO * B16) - P) \$ + (FHI - K * B15) * B16) + K IF (IX .LT. 0) IX = IX + P RAND = FLOAT(IX) * 4.656612875E-10 RETURN END