c-------------------------------------------------------------------- c Test runlux routines c-------------------------------------------------------------------- PARAMETER (Ntot =20 ) ! total number of rand numbs DIMENSION RanNum(5) ,RR(Ntot) real*8 sig, xmean iseed = 9121071 CALL rluxgo(2,iseed,0,0) icurr = 0 10 call ranlux(RanNum,5) c icurr=icurr +1 do i=1,5 icurr=icurr +1 RR(icurr) = RanNum(i) EndDo If(icurr.le.Ntot-5)goto 10 write (*,*) ' done' c open(1,file='set2.dat') c write (1,*) RR sig =0. xmean =0. i1 = 0 im1 = 0 i15 = 0 im15 = 0 i2 = 0 im2 = 0 i25 = 0 im25 = 0 i3 = 0 im3 = 0 i4 = 0 im4 = 0 Ntry =1e8 s1 = 0.15866 s15 = 6.681e-2 s2 = 2.275e-2 s25 = 6.21e-3 s3 = 1.35e-3 s4 = 3.17e-5 Do i=1,Ntry c xx = GAUSS(iseed) xx = GAUSS3() sig = sig +xx**2 xmean = xmean + xx if(xx.gt.1.d+0)i1 =i1+1 if(xx.lt.-1.d+0)im1 =im1+1 if(xx.gt.1.5d+0)i15 =i15+1 if(xx.lt.-1.5d+0)im15 =im15+1 if(xx.gt.2.d+0)i2 =i2+1 if(xx.lt.-2.d+0)im2 =im2+1 if(xx.lt.-2.5d+0)im25 =im25+1 if(xx.gt.2.5d+0)i25 =i25+1 if(xx.gt.3.d+0)i3 =i3+1 if(xx.lt.-3.d+0)im3 =im3+1 if(xx.gt.4.d+0)i4 =i4+1 if(xx.lt.-4.d+0)im4 =im4+1 EndDo write (*,*) ' N= ',Ntry,' GAUSS3+ranlux ------' at =float (Ntry) write (*,'(" sigma=",g12.5," mean=",g12.5)') sig/at,xmean/at write (*,*) ' sigma Frac(>sig) Frac(<-sig) True', & ' n(>) n(<)' write (*,'(f6.2,3g11.4,2i9)') 1.0,i1/at, im1/at,s1,i1,im1 write (*,'(f6.2,3g11.4,2i9)') 1.5,i15/at, im15/at,s15,i15,im15 write (*,'(f6.2,3g11.4,2i9)') 2.0,i2/at, im2/at,s2,i2,im2 write (*,'(f6.2,3g11.4,2i9)') 2.5,i25/at, im25/at,s25,i25,im25 write (*,'(f6.2,3g11.4,2i9)') 3.0,i3/at, im3/at,s3,i3,im3 write (*,'(f6.2,3g11.4,2i9)') 4.0,i4/at, im4/at,s4,i4,im4 Stop End c-------------------------------------------------------------------- ! LUXURY LEVELS. ! level 0 (p=24): equivalent to the original RCARRY of Marsaglia ! and Zaman, very long period, but fails many tests. ! level 1 (p=48): considerable improvement in quality over level 0, ! now passes the gap test, but still fails spectral test. ! level 2 (p=97): passes all known tests, but theoretically still ! defective. ! level 3 (p=223): DEFAULT VALUE. Any theoretically possible ! correlations have very small chance of being observed. ! level 4 (p=389): highest possible luxury, all 24 bits chaotic. c--------------------------------------------- SUBROUTINE ranlux(rvec, lenv) c returns a vector RVEC of LEN c 32-bit random floating point numbers between c zero (not included) and one (also not incl.). c Next call to ranlux gives next LEN of random numbers c--------------------------------------------- INTEGER lenv REAL rvec(lenv) INTEGER iseeds(24) INCLUDE 'luxury.h' DATA ndskip/ 0, 24, 73, 199, 365 / DATA i24,j24,luxlev/24,10,lxdflt/ DATA notyet/.true./ DATA in24,kount,mkount,carry/0,0,0,0./ ! NOTYET is .TRUE. if no initialization has been performed yet. ! Default Initialization by Multiplicative Congruential IF (notyet) THEN notyet = .false. jseed = jsdflt inseed = jseed WRITE (6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ', jseed luxlev = lxdflt nskip = ndskip(luxlev) lp = nskip + 24 in24 = 0 kount = 0 mkount = 0 WRITE (6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL= ', luxlev, & ' p =', lp twom24 = 1. DO i = 1, 24 twom24 = twom24 * 0.5 k = jseed / 53668 jseed = 40014 * (jseed-k*53668) - k * 12211 IF (jseed.LT.0) jseed = jseed + icons iseeds(i) = MOD(jseed,itwo24) END DO twom12 = twom24 * 4096. DO i = 1, 24 seeds(i) = REAL(iseeds(i)) * twom24 next(i) = i - 1 END DO next(1) = 24 i24 = 24 j24 = 10 carry = 0. IF (seeds(24).EQ.0.) carry = twom24 END IF ! The Generator proper: "Subtract-with-borrow", ! as proposed by Marsaglia and Zaman, ! Florida State University, March, 1989 DO ivec = 1, lenv uni = seeds(j24) - seeds(i24) - carry IF (uni.LT.0.) THEN uni = uni + 1.0 carry = twom24 ELSE carry = 0. END IF seeds(i24) = uni i24 = next(i24) j24 = next(j24) rvec(ivec) = uni ! small numbers (with less than 12 "significant" bits) are "padded". IF (uni.LT.twom12) THEN rvec(ivec) = rvec(ivec) + twom24 * seeds(j24) ! and zero is forbidden in case someone takes a logarithm IF (rvec(ivec).EQ.0.) rvec(ivec) = twom24 * twom24 END IF ! Skipping to luxury. As proposed by Martin Luscher. in24 = in24 + 1 IF (in24.EQ.24) THEN in24 = 0 kount = kount + nskip DO isk = 1, nskip uni = seeds(j24) - seeds(i24) - carry IF (uni.LT.0.) THEN uni = uni + 1.0 carry = twom24 ELSE carry = 0. END IF seeds(i24) = uni i24 = next(i24) j24 = next(j24) END DO END IF END DO kount = kount + lenv IF (kount.GE.igiga) THEN mkount = mkount + 1 kount = kount - igiga END IF RETURN END ! SUBROUTINE ranlux c--------------------------------------------- c Subroutine to initialize from one or three integers SUBROUTINE rluxgo(lux, ins, k1, k2) c initializes the generator from c one 32-bit integer INT and sets Luxury Level LUX c which is integer between zero and MAXLEV, or if c LUX .GT. 24, it sets p=LUX directly. K1 and K2 c should be set to zero unless restarting at a break c point given by output of RLUXAT c--------------------------------------------- INCLUDE 'luxury.h' INTEGER iseeds(24) IF (lux.LT.0) THEN luxlev = lxdflt ELSE IF (lux.LE.maxlev) THEN luxlev = lux ELSE IF (lux.LT.24.OR.lux.GT.2000) THEN luxlev = maxlev WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ', lux ELSE luxlev = lux DO ilx = 0, maxlev IF (lux.EQ.ndskip(ilx)+24) luxlev = ilx END DO END IF IF (luxlev.LE.maxlev) THEN nskip = ndskip(luxlev) WRITE (6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', & luxlev,' P=', nskip + 24 ELSE nskip = luxlev - 24 WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:', luxlev END IF in24 = 0 IF (ins.LT.0) WRITE (6,'(A)') & ' Illegal initialization by RLUXGO, negative input seed' IF (ins.GT.0) THEN jseed = ins WRITE (6,'(A,3I12)')' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', & jseed, k1, k2 ELSE jseed = jsdflt WRITE (6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' END IF inseed = jseed notyet = .false. twom24 = 1. DO i = 1, 24 twom24 = twom24 * 0.5 k = jseed / 53668 jseed = 40014 * (jseed-k*53668) - k * 12211 IF (jseed.LT.0) jseed = jseed + icons iseeds(i) = MOD(jseed,itwo24) END DO twom12 = twom24 * 4096. DO i = 1, 24 seeds(i) = REAL(iseeds(i)) * twom24 next(i) = i - 1 END DO next(1) = 24 i24 = 24 j24 = 10 carry = 0. IF (seeds(24).EQ.0.) carry = twom24 ! If restarting at a break point, skip K1 + IGIGA*K2 ! Note that this is the number of numbers delivered to ! the user PLUS the number skipped (if luxury .GT. 0). kount = k1 mkount = k2 IF (k1+k2.NE.0) THEN DO iouter = 1, k2 + 1 inner = igiga IF (iouter.EQ.k2+1) inner = k1 DO isk = 1, inner uni = seeds(j24) - seeds(i24) - carry IF (uni.LT.0.) THEN uni = uni + 1.0 carry = twom24 ELSE carry = 0. END IF seeds(i24) = uni i24 = next(i24) j24 = next(j24) END DO END DO ! Get the right value of IN24 by direct calculation in24 = MOD(kount,nskip+24) IF (mkount.GT.0) THEN izip = MOD(igiga, nskip+24) izip2 = mkount * izip + in24 in24 = MOD(izip2, nskip+24) END IF ! Now IN24 had better be between zero and 23 inclusive IF (in24.GT.23) THEN WRITE (6,'(A/A,3I11,A,I5)') & ' Error in RESTARTING with RLUXGO:', ' The values', ins, & k1, k2, ' cannot occur at luxury level', luxlev in24 = 0 END IF END IF RETURN END ! SUBROUTINE rluxgo C-------------------------------------- C normal random numbers FUNCTION GAUSS1() C Uses ranlux for homogenous rand numbers C sum of 5 random numbers + corrections C It is quite slow: needs 5 calls to ranlux C N =1e8 C sigma Frac(>sig) Frac(<-sig) True n(>) n(<) c 1.00 0.1580 0.1580 0.1587 15796874 15798080 c 1.50 0.6674E-01 0.6676E-01 0.6681E-01 6673965 6675533 c 2.00 0.2279E-01 0.2281E-01 0.2275E-01 2278910 2281013 c 2.50 0.6106E-02 0.6108E-02 0.6210E-02 610575 610813 c 3.00 0.1153E-02 0.1151E-02 0.1350E-02 115341 115052 c 4.00 0.2230E-05 0.2070E-05 0.3170E-04 223 207 C-------------------------------------- DIMENSION RanNum(5) X=0. CALL ranlux(RanNum,5) DO I=1,5 X=X+RanNum(I) EndDo X2 =1.5491933*(X-2.5) GAUSS1=X2 *(1.-0.012*(3.-X2*X2)) RETURN END C-------------------------------------- C normal random numbers FUNCTION GAUSS2(M) C Uses ranndd for homogenous rand numbers C sum of 12 random numbers + corrections C It is slow: very (10 times than GAUSS3) C Quality is very good: upto 4 sigma c sigma Frac(>sig) Frac(<-sig) True n(>) n(<) c 1.00 0.1586 0.1586 0.1587 15857116 15857711 c 1.50 0.6678E-01 0.6680E-01 0.6681E-01 6678110 6679725 c 2.00 0.2277E-01 0.2275E-01 0.2275E-01 2277430 2274868 c 2.50 0.6197E-02 0.6189E-02 0.6210E-02 619732 618895 c 3.00 0.1327E-02 0.1319E-02 0.1350E-02 132713 131929 c 4.00 0.2664E-04 0.2727E-04 0.3170E-04 2664 2727 C c-------------------------------------------------------------------- X=0. DO I=1,12 X=X+Randd(M) EndDo X2 = X-6.0 GAUSS2 =X2 *(1.-0.0045*(3.-X2*X2)) RETURN END C-------------------------------------- C normal random numbers FUNCTION GAUSS3() C Uses ranlux for homogenous rand numbers C Uses Box-Muller inversion for gaussian C Excellent quality and speed c N= 100000000 GAUSS3+ranlux ------ c sigma= 0.99997 mean= 0.18692E-03 c sigma Frac(>sig) Frac(<-sig) True n(>) n(<) c 1.00 0.1587 0.1586 0.1587 15869095 15857724 c 1.50 0.6682E-01 0.6680E-01 0.6681E-01 6681652 6679768 c 2.00 0.2277E-01 0.2273E-01 0.2275E-01 2276651 2273197 c 2.50 0.6222E-02 0.6206E-02 0.6210E-02 622190 620610 c 3.00 0.1356E-02 0.1347E-02 0.1350E-02 135628 134674 c 4.00 0.3242E-04 0.3145E-04 0.3170E-04 3242 3145 c C-------------------------------------- DIMENSION RanNum(2) DATA iFlag/0/ SAVE gSet If(iFlag.eq.0)Then 1 CALL ranlux(RanNum,2) x1 = 2.*RanNum(1)-1. x2 = 2.*RanNum(2)-1. R =x1**2+x2**2 If(R.ge.1.)GoTo 1 F =sqrt(-2.*LOG(R)/R) gSet = x1*F GAUSS3 = x2*F iFlag = 1 Else GAUSS3 = gSet iFlag = 0 EndIf RETURN END C------------------------------------------- random number generator FUNCTION RANDd(M) C------------------------------------------------ DATA LC,AM,KI,K1,K2,K3,K4,L1,L2,L3,L4 + /453815927,2147483648.,2147483647,536870912,131072,256, + 16777216,4,16384,8388608,128/ ML=M/K1*K1 M1=(M-ML)*L1 ML=M/K2*K2 M2=(M-ML)*L2 ML=M/K3*K3 M3=(M-ML)*L3 ML=M/K4*K4 M4=(M-ML)*L4 M5=KI-M IF(M1.GE.M5)M1=M1-KI-1 ML=M+M1 M5=KI-ML IF(M2.GE.M5)M2=M2-KI-1 ML=ML+M2 M5=KI-ML IF(M3.GE.M5)M3=M3-KI-1 ML=ML+M3 M5=KI-ML IF(M4.GE.M5)M4=M4-KI-1 ML=ML+M4 M5=KI-ML IF(LC.GE.M5)ML=ML-KI-1 M=ML+LC RANDd=M/AM RETURN END C-------------------------------------- C normal random numbers FUNCTION GAUSS(M) C Uses RANDd() + 5 random numbers with correction C Old code used in many simulations C N=1e8 sigma= 0.99556 mean= 0.10542E-03 c sigma Frac(>sig) Frac(<-sig) True n(>) n(<) c 1.00 0.1589 0.1589 0.1587 15894145 15889594 c 1.50 0.6704E-01 0.6702E-01 0.6681E-01 6703736 6702430 c 2.00 0.2258E-01 0.2256E-01 0.2275E-01 2258038 2256030 c 2.50 0.5841E-02 0.5843E-02 0.6210E-02 584148 584264 c 3.00 0.1031E-02 0.1028E-02 0.1350E-02 103141 102783 c 4.00 0.5900E-06 0.6100E-06 0.3170E-04 59 61 C C-------------------------------------- X=0. DO I=1,5 X=X+RANDd(M) EndDo X2 =1.5491933*(X-2.5) GAUSS=X2*(1.-0.01*(3.-X2*X2)) RETURN END