IMPLEMENTATION MODULE UNIFNR; FROM MYINOUT IMPORT WriteLongCard, WriteInt, WriteString, WriteLn; FROM NUM IMPORT WriteLI, LIToLR, OneLR, ZeroLR; FROM UNIFORM IMPORT Gen, WrGen, WriteState; CONST NTab = 32; NTabp8 = 40; TYPE BinSet = SET OF [0..31]; VAR i, j : INTEGER; (* Compteurs *) chaine : ARRAY [0..60] OF CHAR; (* noms de procedures *) k, z, (* Variables de travail. *) S1, S2, (* Etats *) A1, A2, (* Multiplicateurs *) M1, M2, M1m1, (* Modulos *) q1, q2, (* qi := mi DIV ai *) r1, r2 : LONGINT; (* ri := mi MOD ai *) UnSurM1 : LONGREAL; (* UnSurMi := 1 / Mi. *) Tab : ARRAY [1..NTabp8] OF LONGINT; NDiv : LONGINT; RNMX : LONGREAL; Mask : BinSet; (******************************************************************************) PROCEDURE Erreur (str : ARRAY OF CHAR); BEGIN WriteString ("************************"); WriteLn; WriteLn; WriteString (str); WriteLn; WriteLn; WriteString ("************************"); WriteLn; HALT END Erreur; (******************************************************************************) PROCEDURE ran0 () : LONGREAL; BEGIN k := S1 DIV q1; S1 := A1 * (S1 - k * q1) - k * r1; IF (S1 < 0) THEN S1 := S1 + M1 END; RETURN (UnSurM1 * LIToLR (S1)) END ran0; PROCEDURE ran1 () : LONGREAL; BEGIN k := S1 DIV q1; S1 := A1 * (S1 - k * q1) - k * r1; IF (S1 < 0) THEN S1 := S1 + M1 END; j := VAL (INTEGER, 1 + z DIV NDiv); z := Tab [j]; Tab [j] := S1; (* Ceci est legerement different de Press et Teukolsky : *) RETURN (UnSurM1 * LIToLR (z)) END ran1; PROCEDURE ran2 () : LONGREAL; BEGIN k := S1 DIV q1; S1 := A1 * (S1 - k * q1) - k * r1; IF (S1 < 0) THEN S1 := S1 + M1 END; k := S2 DIV q2; S2 := A2 * (S2 - k * q2) - k * r2; IF (S2 < 0) THEN S2 := S2 + M2 END; j := VAL (INTEGER, 1 + z DIV NDiv); z := Tab [j] - S2; Tab [j] := S1; IF (z < 1) THEN z := z + M1m1 END; (* Ceci est legerement different de Press et Teukolsky : *) RETURN LIToLR (z) * UnSurM1 END ran2; PROCEDURE Wr0 (); BEGIN WriteString ("ran0 from UNIFNR"); WriteLn; WriteString ("s : "); WriteLI (S1, 1); WriteLn; END Wr0; PROCEDURE Wr1 (); BEGIN WriteString ("ran1 from UNIFNR"); WriteLn; WriteString ("s : "); WriteLI (S1, 1); WriteLn; WriteString ("j : "); WriteInt (j, 1); WriteLn; FOR j := 1 TO NTab DO WriteString (" Tab["); WriteInt (j, 2); WriteString ("] = "); WriteLI (Tab[j], 18); WriteLn END END Wr1; PROCEDURE Wr2 (); BEGIN WriteString ("ran2 from UNIFNR"); WriteLn; WriteString ("s1 : "); WriteLI (S1, 1); WriteString (" "); WriteString ("s2 : "); WriteLI (S2, 1); WriteLn (); WriteString ("j : "); WriteInt (j, 1); WriteLn; FOR j := 1 TO NTab DO WriteString (" Tab["); WriteInt (j, 2); WriteString ("] = "); WriteLI (Tab[j], 18); WriteLn END END Wr2; (******************************************************************************) PROCEDURE Setran0 (s : LONGINT); BEGIN Mask := BinSet (123459876); IF (BinSet (s) = Mask) THEN s := 0 END; S1 := LONGINT (Mask * BinSet (s)); Gen := ran0; WrGen := Wr0; M1 := 2147483647; A1 := 16807; q1 := 127773; r1 := 2836; UnSurM1 := OneLR / LIToLR (M1); END Setran0; PROCEDURE Setran1 (s : LONGINT); BEGIN IF s = 0 THEN s := 1 END; S1 := s; Gen := ran1; WrGen := Wr1; M1 := 2147483647; A1 := 16807; q1 := 127773; r1 := 2836; NDiv := 1 + (M1 - 1) DIV NTab; RNMX := 1.0 - 0.00000012; UnSurM1 := OneLR / LIToLR (M1); FOR j := NTabp8 TO 1 BY -1 DO k := S1 DIV q1; S1 := A1 * (S1 - k * q1) - k * r1; IF (S1 < 0) THEN S1 := S1 + M1 END; IF (j <= NTab) THEN Tab [j] := S1 END; END; z := Tab [1] END Setran1; PROCEDURE Setran2 (s : LONGINT); BEGIN IF s = 0 THEN s := 1 END; S1 := s; S2 := s; Gen := ran2; WrGen := Wr2; M1 := 2147483563; M2 := 2147483399; M1m1 := 2147483562; A1 := 40014; A2 := 40692; q1 := 53668; q2 := 52774; r1 := 12211; r2 := 3791; NDiv := 1 + M1m1 DIV NTab; i := 0; RNMX := 1.0 - 0.00000012; UnSurM1 := OneLR / LIToLR (M1m1); FOR j := NTabp8 TO 1 BY -1 DO k := S1 DIV q1; S1 := A1 * (S1 - k * q1) - k * r1; IF (S1 < 0) THEN S1 := S1 + M1 END; IF (j <= NTab) THEN Tab [j] := S1 END; END; z := Tab [1] END Setran2; (******************************************************************************) PROCEDURE NotInit () : LONGREAL; BEGIN Erreur ("Erreur module UNIFNR: generateur non initialise."); RETURN ZeroLR END NotInit; PROCEDURE WrNotInit (); BEGIN Erreur ("Erreur module UNIFNR: generateur non initialise."); END WrNotInit; (******************************************************************************) BEGIN Gen := NotInit; WrGen := WrNotInit; END UNIFNR.