File indexing completed on 2024-04-06 12:13:24
0001 SUBROUTINE RANLUX(RVEC,LENV)
0002
0003
0004
0005
0006
0007
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027
0028
0029
0030
0031
0032
0033
0034
0035
0036
0037
0038
0039
0040
0041
0042
0043
0044
0045 DIMENSION RVEC(LENV)
0046 DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
0047 PARAMETER (MAXLEV=4, LXDFLT=3)
0048 DIMENSION NDSKIP(0:MAXLEV)
0049 DIMENSION NEXT(24)
0050 PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
0051 PARAMETER (ITWO24=2**24, ICONS=2147483563)
0052 SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
0053 SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
0054 INTEGER LUXLEV
0055 LOGICAL NOTYET
0056 DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
0057 DATA I24,J24,CARRY/24,10,0./
0058
0059
0060 DATA NDSKIP/0, 24, 73, 199, 365 /
0061
0062
0063
0064
0065
0066
0067 IF (NOTYET) THEN
0068 NOTYET = .FALSE.
0069 JSEED = JSDFLT
0070 INSEED = JSEED
0071 WRITE(6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
0072 LUXLEV = LXDFLT
0073 NSKIP = NDSKIP(LUXLEV)
0074 LP = NSKIP + 24
0075 IN24 = 0
0076 KOUNT = 0
0077 MKOUNT = 0
0078 WRITE(6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ',
0079 + LUXLEV,' p =',LP
0080 TWOM24 = 1.
0081 DO 25 I= 1, 24
0082 TWOM24 = TWOM24 * 0.5
0083 K = JSEED/53668
0084 JSEED = 40014*(JSEED-K*53668) -K*12211
0085 IF (JSEED .LT. 0) JSEED = JSEED+ICONS
0086 ISEEDS(I) = MOD(JSEED,ITWO24)
0087 25 CONTINUE
0088 TWOM12 = TWOM24 * 4096.
0089 DO 50 I= 1,24
0090 SEEDS(I) = REAL(ISEEDS(I))*TWOM24
0091 NEXT(I) = I-1
0092 50 CONTINUE
0093 NEXT(1) = 24
0094 I24 = 24
0095 J24 = 10
0096 CARRY = 0.
0097 IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
0098 ENDIF
0099
0100
0101
0102
0103
0104 DO 100 IVEC= 1, LENV
0105
0106
0107
0108
0109
0110
0111
0112
0113
0114
0115
0116 uni = BHGPYR(idummy)
0117 rvec(ivec) = uni
0118
0119
0120
0121
0122
0123
0124
0125
0126
0127
0128
0129
0130
0131
0132
0133
0134
0135
0136
0137
0138
0139
0140
0141
0142 100 CONTINUE
0143 KOUNT = KOUNT + LENV
0144 IF (KOUNT .GE. IGIGA) THEN
0145 MKOUNT = MKOUNT + 1
0146 KOUNT = KOUNT - IGIGA
0147 ENDIF
0148 RETURN
0149
0150
0151 ENTRY RLUXIN(ISDEXT)
0152 NOTYET = .FALSE.
0153 TWOM24 = 1.
0154 DO 195 I= 1, 24
0155 NEXT(I) = I-1
0156 195 TWOM24 = TWOM24 * 0.5
0157 NEXT(1) = 24
0158 TWOM12 = TWOM24 * 4096.
0159 WRITE(6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
0160 WRITE(6,'(5X,5I12)') ISDEXT
0161 DO 200 I= 1, 24
0162 SEEDS(I) = REAL(ISDEXT(I))*TWOM24
0163 200 CONTINUE
0164 CARRY = 0.
0165 IF (ISDEXT(25) .LT. 0) CARRY = TWOM24
0166 ISD = IABS(ISDEXT(25))
0167 I24 = MOD(ISD,100)
0168 ISD = ISD/100
0169 J24 = MOD(ISD,100)
0170 ISD = ISD/100
0171 IN24 = MOD(ISD,100)
0172 ISD = ISD/100
0173 LUXLEV = ISD
0174 IF (LUXLEV .LE. MAXLEV) THEN
0175 NSKIP = NDSKIP(LUXLEV)
0176 WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
0177 + LUXLEV
0178 ELSE IF (LUXLEV .GE. 24) THEN
0179 NSKIP = LUXLEV - 24
0180 WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
0181 ELSE
0182 NSKIP = NDSKIP(MAXLEV)
0183 WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
0184 LUXLEV = MAXLEV
0185 ENDIF
0186 INSEED = -1
0187 RETURN
0188
0189
0190 ENTRY RLUXUT(ISDEXT)
0191 DO 300 I= 1, 24
0192 ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
0193 300 CONTINUE
0194 ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
0195 IF (CARRY .GT. 0.) ISDEXT(25) = -ISDEXT(25)
0196 RETURN
0197
0198
0199 ENTRY RLUXAT(LOUT,INOUT,K1,K2)
0200 LOUT = LUXLEV
0201 INOUT = INSEED
0202 K1 = KOUNT
0203 K2 = MKOUNT
0204 RETURN
0205
0206
0207 ENTRY RLUXGO(LUX,INS,K1,K2)
0208 IF (LUX .LT. 0) THEN
0209 LUXLEV = LXDFLT
0210 ELSE IF (LUX .LE. MAXLEV) THEN
0211 LUXLEV = LUX
0212 ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
0213 LUXLEV = MAXLEV
0214 WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
0215 ELSE
0216 LUXLEV = LUX
0217 DO 310 ILX= 0, MAXLEV
0218 IF (LUX .EQ. NDSKIP(ILX)+24) LUXLEV = ILX
0219 310 CONTINUE
0220 ENDIF
0221 IF (LUXLEV .LE. MAXLEV) THEN
0222 NSKIP = NDSKIP(LUXLEV)
0223 WRITE(6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
0224 + LUXLEV,' P=', NSKIP+24
0225 ELSE
0226 NSKIP = LUXLEV - 24
0227 WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
0228 ENDIF
0229 IN24 = 0
0230 IF (INS .LT. 0) WRITE (6,'(A)')
0231 + ' Illegal initialization by RLUXGO, negative input seed'
0232 IF (INS .GT. 0) THEN
0233 JSEED = INS
0234 WRITE(6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
0235 + JSEED, K1,K2
0236 ELSE
0237 JSEED = JSDFLT
0238 WRITE(6,'(A)')' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
0239 ENDIF
0240 INSEED = JSEED
0241 NOTYET = .FALSE.
0242 TWOM24 = 1.
0243 DO 325 I= 1, 24
0244 TWOM24 = TWOM24 * 0.5
0245 K = JSEED/53668
0246 JSEED = 40014*(JSEED-K*53668) -K*12211
0247 IF (JSEED .LT. 0) JSEED = JSEED+ICONS
0248 ISEEDS(I) = MOD(JSEED,ITWO24)
0249 325 CONTINUE
0250 TWOM12 = TWOM24 * 4096.
0251 DO 350 I= 1,24
0252 SEEDS(I) = REAL(ISEEDS(I))*TWOM24
0253 NEXT(I) = I-1
0254 350 CONTINUE
0255 NEXT(1) = 24
0256 I24 = 24
0257 J24 = 10
0258 CARRY = 0.
0259 IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
0260
0261
0262
0263 KOUNT = K1
0264 MKOUNT = K2
0265 IF (K1+K2 .NE. 0) THEN
0266 DO 500 IOUTER= 1, K2+1
0267 INNER = IGIGA
0268 IF (IOUTER .EQ. K2+1) INNER = K1
0269 DO 450 ISK= 1, INNER
0270 UNI = SEEDS(J24) - SEEDS(I24) - CARRY
0271 IF (UNI .LT. 0.) THEN
0272 UNI = UNI + 1.0
0273 CARRY = TWOM24
0274 ELSE
0275 CARRY = 0.
0276 ENDIF
0277 SEEDS(I24) = UNI
0278 I24 = NEXT(I24)
0279 J24 = NEXT(J24)
0280 450 CONTINUE
0281 500 CONTINUE
0282
0283 IN24 = MOD(KOUNT, NSKIP+24)
0284 IF (MKOUNT .GT. 0) THEN
0285 IZIP = MOD(IGIGA, NSKIP+24)
0286 IZIP2 = MKOUNT*IZIP + IN24
0287 IN24 = MOD(IZIP2, NSKIP+24)
0288 ENDIF
0289
0290 IF (IN24 .GT. 23) THEN
0291 WRITE (6,'(A/A,3I11,A,I5)')
0292 + ' Error in RESTARTING with RLUXGO:',' The values', INS,
0293 + K1, K2, ' cannot occur at luxury level', LUXLEV
0294 IN24 = 0
0295 ENDIF
0296 ENDIF
0297 RETURN
0298 END