1366 lines
44 KiB
Fortran
1366 lines
44 KiB
Fortran
!Fixed file to make debugging with warnings possible
|
|
!Removed a few not used variables
|
|
!NW 22.05.2015
|
|
|
|
|
|
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
c 18.03.2010 A Viel
|
|
c interface for genetic to call Marius Lewerenz random generator copied here
|
|
c seed : initialization seed: large negative integer - negative forced
|
|
c ierr=6 : output for error
|
|
c n: number of random number requested
|
|
c
|
|
c initialization
|
|
c call vranf(Rand,0,seed,ierr)
|
|
c Random array with uniform distribution
|
|
c call vranf(rand,n,0,ierr)
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
function rn(seed,gtype,cont)
|
|
implicit none
|
|
integer i,seed,gtype,cont
|
|
integer ierr,iseed
|
|
|
|
double precision rn,rand(1)
|
|
|
|
save ierr
|
|
|
|
c .. initialize new random number stream:
|
|
c.. cont is egal to 1 only once
|
|
do i=1,cont
|
|
ierr=6
|
|
c force seed to be negative integer
|
|
iseed=-iabs(seed)
|
|
c initialize random number with seed=iseed
|
|
call vranf(rand,0,iseed,ierr)
|
|
enddo
|
|
|
|
c.. generate a single random number / uniform distribution
|
|
call vranf(rand,1,0,ierr)
|
|
rn=rand(1)
|
|
|
|
end
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
c Random generator From Marius Lewerenz
|
|
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
subroutine gautrg(gran,nran,iseed,iout)
|
|
c
|
|
c vectorized portable unit standard deviation gaussian random
|
|
c number generator using the box-mueller transformation method.
|
|
c this method is faster than the central limit method, when the
|
|
c uniform random numbers are comparatively expensive.
|
|
c version working on a square with sine and cosine functions. the
|
|
c same sequence is produced independent of the sequence of calls
|
|
c if no calls to other vranf based prn generators are made.
|
|
c
|
|
c gran : vector of length nran returning the random numbers
|
|
c nran : number of desired random numbers, with nran=0 and iseed
|
|
c not 0 only generator initialization is done. no action
|
|
c when both are zero.
|
|
c iseed : if not 0, integer to start generator. use 0 to continue
|
|
c a previously used/initialized random sequence, unchanged
|
|
c on output.
|
|
c iout : unit number for messages.
|
|
c
|
|
c times for the generation of 10**6 prn's:
|
|
c rs6000/350 41 mhz 2.31 s
|
|
c r8000 75 mhz 1.43 s
|
|
c axp21064 200 mhz 1.20 s
|
|
c axp21164 250 mhz 0.572 s
|
|
c t3e-900 450 mhz 0.52 s
|
|
c cray-t90 450 mhz 0.0728 s 1.28*10**7 prn/s
|
|
c
|
|
c subroutines called: vranf, r1mach
|
|
c m. lewerenz 6/may/90, modified 17/jun/91, mar/95
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
parameter (two=2.d0,twom=-two,one=1.d0,npoly=11)
|
|
dimension gran(nran),ccf(npoly),scf(npoly), xran(1)
|
|
save isave,gsave,tiny,twopi,pi4,ccf,scf
|
|
data isave/-1/
|
|
C
|
|
C POLYNOMIAL FROM CHEBYSHEV APPROXIMATION ON [ 0.000, 0.790]
|
|
C FOR COS(X) WITH ABSOLUTE ERROR LESS THAN 0.2220E-14
|
|
C
|
|
DATA ccf/ 0.9999999999999986D+00, 0.6612476846390664D-13,
|
|
# -0.4999999999989523D+00,-0.5434658088910759D-10,
|
|
# 0.4166666737609693D-01,-0.4648977428396692D-08,
|
|
# -0.1388871052129944D-02,-0.4228394738587799D-07,
|
|
# 0.2486361945804866D-04,-0.5317743184071916D-07,
|
|
# -0.2539224676809412D-06/
|
|
C
|
|
C POLYNOMIAL FROM CHEBYSHEV APPROXIMATION ON [ 0.000, 0.790]
|
|
C FOR SIN(X) WITH ABSOLUTE ERROR LESS THAN 0.2220E-14
|
|
C
|
|
DATA scf/-0.9443414574112906D-15, 0.1000000000000244D+01,
|
|
# -0.1224236196202217D-10,-0.1666666664242968D+00,
|
|
# -0.2471495821870120D-08, 0.8333348067492644D-02,
|
|
# -0.5482536616811601D-07,-0.1982815612039858D-03,
|
|
# -0.2017619095413939D-06, 0.2948964053761139D-05,
|
|
# -0.1051448397925916D-06/
|
|
c
|
|
if(isave.lt.0) then
|
|
isave=0
|
|
tiny=r1mach(0)**2
|
|
pi4=atan(one)
|
|
twopi=pi4*8
|
|
end if
|
|
if(iseed.ne.0) call vranf(gran,0,iseed,iout)
|
|
c
|
|
if(nran.gt.0) then
|
|
newran=nran-isave
|
|
if(isave.eq.1) gran(1)=gsave
|
|
call vranf(gran(isave+1),newran,0,iout)
|
|
do 100 i=1,newran-1,2
|
|
fac=sqrt(twom*log(gran(isave+i)+tiny))
|
|
x=pi4*gran(isave+i+1)
|
|
cx=(((((((((ccf(11)*x+ccf(10))*x+ccf(9))*x+ccf(8))*x
|
|
# +ccf(7))*x+ccf(6))*x+ccf(5))*x
|
|
# +ccf(4))*x+ccf(3))*x+ccf(2))*x+ccf(1)
|
|
sx=(((((((((scf(11)*x+scf(10))*x+scf(9))*x+scf(8))*x
|
|
# +scf(7))*x+scf(6))*x+scf(5))*x
|
|
# +scf(4))*x+scf(3))*x+scf(2))*x+scf(1)
|
|
sxi=(two*cx)*sx
|
|
cxi=(two*cx)*cx-one
|
|
sxi=(two*cxi)*sxi
|
|
cxi=(two*cxi)*cxi-one
|
|
sxi=(two*cxi)*sxi
|
|
cxi=(two*cxi)*cxi-one
|
|
gran(isave+i)=fac*sxi
|
|
gran(isave+i+1)=fac*cxi
|
|
100 continue
|
|
c
|
|
if(mod(newran,2).eq.1) then
|
|
call vranf(xran(1),1,0,iout)
|
|
fac=sqrt(twom*log(gran(nran)+tiny))
|
|
trig=twopi*xran(1)
|
|
gran(nran)=fac*sin(trig)
|
|
gsave=fac*cos(trig)
|
|
isave=1
|
|
else
|
|
isave=0
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
C
|
|
C----------------------------------------------------------------------
|
|
C
|
|
FUNCTION R1MACH (IDUM)
|
|
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
|
|
PARAMETER (ONE=1.D0,TWO=2.D0,HALF=0.5D0)
|
|
SAVE ICALL,EPS
|
|
DATA ICALL,EPS/0,ONE/
|
|
C ---------------------------------------------------------------------
|
|
C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE.
|
|
C THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER
|
|
C U SUCH THAT 1.0 + U .NE. 1.0E0
|
|
C ---------------------------------------------------------------------
|
|
IF(ICALL.EQ.0) THEN
|
|
ICALL=1
|
|
U = ONE
|
|
10 U = U*HALF
|
|
COMP = ONE + U
|
|
IF(COMP .NE. ONE) GO TO 10
|
|
EPS = U*TWO
|
|
END IF
|
|
R1MACH = EPS
|
|
RETURN
|
|
END
|
|
c
|
|
c----------------------------------------------------------------------
|
|
c
|
|
subroutine vcopy(v1,v2,nv)
|
|
c
|
|
c copies vector v1 into v2.
|
|
c subroutines called : none m. lewerenz
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
dimension v1(nv),v2(nv)
|
|
c
|
|
if(nv.gt.0) then
|
|
do 10 i=1,nv
|
|
v2(i)=v1(i)
|
|
10 continue
|
|
end if
|
|
return
|
|
end
|
|
|
|
c-----------------------------------------------------------------------
|
|
c-------------------- ranf/vranf uniform random package ----------------
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vranf(ranv,nran,iseed,iout)
|
|
c
|
|
c machine independent portable uniform random number generator for
|
|
c the interval [0,1) based on a floating point subtractive lagged
|
|
c fibonacci method similar to the feedback shift register method
|
|
c proposed by kirkpatrick/stoll. subtractive (or additive) version
|
|
c gives much better prn quality than the original xor operation.
|
|
c an additive variant is given in v r a n f a.
|
|
c
|
|
c v r a n f and r a n f use the same method and can be used to
|
|
c work together on the same random sequence. either of them can be
|
|
c used for initialization. the state of the generator can be saved
|
|
c or retrieved for restart with routine r s a v e f.
|
|
c ----------------------------------------------------------------------
|
|
c
|
|
c ranv : vector of length nran for random numbers; output
|
|
c nran : number of desired random numbers. nran=0 and iseed.ne.0
|
|
c -> only generator initialization. no action when both
|
|
c are zero.; input
|
|
c iseed : if not 0, integer to start generator. use 0 to continue
|
|
c a previously used/initialized random sequence, unchanged
|
|
c on output; input
|
|
c iout : unit number for error messages. silent for iout.le.0
|
|
c
|
|
c ----------------------------------------------------------------------
|
|
c method:
|
|
c x(k+np)=x(k)-x(k+np-nq), initial x array generated by xuinit.
|
|
c ieee standard requires double precision to have at least 48 mantissa bits.
|
|
c with nbit=48 this generator is entirely machine independent
|
|
c and will always give the same random sequence. you can change
|
|
c the period of the generator by setting a different nbit value or
|
|
c changing np and nq appropriately.
|
|
c
|
|
c ----------------------------------------------------------------------
|
|
c this is a floating implementation of a generator described in:
|
|
C M.H. KALOS, P.A. WHITLOCK, MONTE CARLO METHODS, APPENDIX,
|
|
C WILEY 1986
|
|
C D.W. HEERMANN, COMPUTER SIMULATION METHODS, 2ND ED.,SPRINGER 199
|
|
C APPENDIX A1
|
|
c d. stauffer, f.w. hehl, v. winkelmann, j.g. zabolitzky,
|
|
c computer simulation & computer algebra, section 2.2
|
|
c
|
|
c original references:
|
|
c s. kirkpatrick, e.p. stoll, j. comput. phys. 40, 517 (1981)
|
|
c r.c. tausworthe, random numbers generated by linear recurrence
|
|
c modulo 2, math. comp. 19, 201 (1965)
|
|
c t.g. lewis, w.h. payne, generalized feedback shift register
|
|
c pseudorandom number algorithm, j. acm 20, 456 (1973)
|
|
c
|
|
c ----------------------------------------------------------------------
|
|
c other (np,nq) values: (17,5), (250,103), (521,158), (1279,418),
|
|
c (2281,715), (4423,1393), (1279,1063)
|
|
c ref.: Bhanot et al., phys. rev b 33, 7841 (1986);
|
|
c Zierler, inf. control 15, 67 (1961)
|
|
c ----------------------------------------------------------------------
|
|
c alternative additive formulation bypassing if statements:
|
|
c temp=x(k)+x(k+np-nq)
|
|
c x(k)=temp-float(int(temp))
|
|
c
|
|
c alternative subtractive formulation bypassing if statements:
|
|
c temp=x(k)-x(k+np-nq)
|
|
c x(k)=(temp+one)-float(int(temp+one))
|
|
c ----------------------------------------------------------------------
|
|
c
|
|
c timing in s for 10**7 random numbers:
|
|
c
|
|
c machine mhz unroll(4) no unrolling
|
|
c ibm rs6000/350 41 2.67 3.9
|
|
c dec axp3800 200 1.17
|
|
c dec axp3600 150 1.35
|
|
c dec alpha 21164 250 0.45
|
|
c t3e alpha 21164 450 0.40
|
|
c sun ultra1 ??? 1.38
|
|
c ibm 3090vf 58 --- 2.47(vec), 4.57(sc)
|
|
c cray t90 450 0.31 ranf() takes 0.13 s
|
|
c
|
|
c unrolling to depth 6 gives a slight speed increase.
|
|
c ----------------------------------------------------------------------
|
|
c subroutines called: xuinit,errprt m. lewerenz may/91 & nov/93
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (nratio=np/nq,nexec=4,mroll=4,zero=0.d0,one=1.d0)
|
|
dimension ranv(nran)
|
|
common /doctrl/ nroll
|
|
c
|
|
c table initialization by xuinit
|
|
c
|
|
if(iseed.ne.0) then
|
|
call xuinit(x,np,nq,0,nexec,iseed,init,last,iout)
|
|
end if
|
|
c
|
|
c fibonacci generator updates elements of x in a cyclic fashion
|
|
c and copies them into ranv in blocks of max. length np.
|
|
c loop split into chunks of max. length nq to avoid recurrence.
|
|
c unrolling improves performance on superscalar machines.
|
|
c
|
|
if(nran.gt.0) then
|
|
if(init.ne.0) then
|
|
j=0
|
|
left=nran
|
|
10 continue
|
|
if(nroll.gt.1) then
|
|
loop=mod((min(nq,left+last)-last),mroll)
|
|
else
|
|
loop=min(nq,left+last)-last
|
|
end if
|
|
convex, cray, and ibm directives
|
|
c$dir no_recurrence
|
|
cdir$ ivdep
|
|
cibmdir ignore recrdeps
|
|
do 500 i=last+1,last+loop
|
|
x1=x(i)-x(i+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
500 continue
|
|
if(nroll.gt.1) then
|
|
do 501 i=last+loop+1,min(nq,left+last),mroll
|
|
x1=x(i)-x(i+np-nq)
|
|
x2=x(i+1)-x(i+1+np-nq)
|
|
x3=x(i+2)-x(i+2+np-nq)
|
|
x4=x(i+3)-x(i+3+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
501 continue
|
|
end if
|
|
c
|
|
if(last.lt.nratio*nq) then
|
|
do 650 k=1,nratio-1
|
|
limit=min((k+1)*nq,left+last)
|
|
if(nroll.gt.1) then
|
|
loop=mod((limit-max(k*nq,last)),mroll)
|
|
else
|
|
loop=limit-max(k*nq,last)
|
|
end if
|
|
convex, cray, and ibm directives
|
|
c$dir no_recurrence
|
|
cdir$ ivdep
|
|
cibmdir ignore recrdeps
|
|
do 600 i=max(k*nq,last)+1,max(k*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
600 continue
|
|
if(nroll.gt.1) then
|
|
do 601 i=max(k*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
601 continue
|
|
end if
|
|
650 continue
|
|
end if
|
|
c
|
|
limit=min(np,left+last)
|
|
if(nroll.gt.1) then
|
|
loop=mod((limit-max(nratio*nq,last)),mroll)
|
|
else
|
|
loop=limit-max(nratio*nq,last)
|
|
end if
|
|
convex, cray, and ibm directives
|
|
c$dir no_recurrence
|
|
cdir$ ivdep
|
|
cibmdir ignore recrdeps
|
|
do 700 i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
700 continue
|
|
if(nroll.gt.1) then
|
|
do 701 i=max(nratio*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
701 continue
|
|
end if
|
|
c
|
|
last=mod(limit,np)
|
|
left=nran-j
|
|
if(left.gt.0) goto 10
|
|
else
|
|
call errprt(iout,'vranf','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine xuinit(x,np,nq,mode,nexec,iseed,init,last,iout)
|
|
c
|
|
c initializes a (np,nq) lagged fibonacci generator table
|
|
c with random bits generated by a congruential generator using
|
|
c l'ecuyers decomposition. ref.: bratley et al. p. 214
|
|
c
|
|
c x : vector of length np for initial random number table;
|
|
c output
|
|
c np,nq : parameters p and q of feedback shift register generator;
|
|
c input
|
|
c mode : operation for lfg:
|
|
c mode=<0 -> subtractive generator, mode=1 additive
|
|
c nexec : number of warm up cycles for the table. nexec*nbit*np
|
|
c random numbers are generated and discarded; input
|
|
c iseed : integer seed for congruential generator generating
|
|
c the bits of the initial table entries; input
|
|
c init : returns updated seed of congruential generator.
|
|
c 0 if table was not initialized, > 0 if ok; output
|
|
c last : pointer to the last used number in the table; output
|
|
c iout : unit number for messages, silent for iout.le.0; input
|
|
c subroutines called : errprt m. lewerenz mar/93, mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
parameter (ia=40692,ib=52774,ic=3791,ip=2147483399)
|
|
parameter (zero=0.d0,one=1.d0,half=0.5d0,iphalf=ip/2,nbit=48)
|
|
logical high
|
|
dimension x(np)
|
|
c
|
|
if(nq.ge.np.or.iseed.eq.0) then
|
|
call errprt(iout,'xuinit','illegal seed parameter(s)',-1)
|
|
else
|
|
c
|
|
c set table to zero and exercise the bit generator a little
|
|
c
|
|
ix=iabs(iseed)
|
|
if(ix.ne.0) then
|
|
do i=1,np
|
|
x(i)=zero
|
|
k1=ix/ib
|
|
ix=ia*(ix-k1*ib)-k1*ic
|
|
if(ix.lt.0) ix=ix+ip
|
|
end do
|
|
c
|
|
c assemble np numbers with mantissa length nbit from random bits
|
|
c 'high' toggle compensates for bias from odd ip
|
|
c
|
|
high=.true.
|
|
do i=1,np
|
|
add=half
|
|
do j=1,nbit
|
|
k1=ix/ib
|
|
ix=ia*(ix-k1*ib)-k1*ic
|
|
if(ix.lt.0) ix=ix+ip
|
|
if(high) then
|
|
if(ix.ge.iphalf) x(i)=x(i)+add
|
|
high=.false.
|
|
else
|
|
if(ix.gt.iphalf) x(i)=x(i)+add
|
|
high=.true.
|
|
end if
|
|
add=add*half
|
|
end do
|
|
end do
|
|
if(nexec.gt.0) call xuwarm(x,np,nq,mode,nbit*nexec,iout)
|
|
end if
|
|
init=ix
|
|
last=0
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine xuwarm(x,np,nq,mode,nexec,iout)
|
|
c
|
|
c warms up (p,q) lagged fibonacci generators (lfg) by nexec rounds
|
|
c
|
|
c x : vector of length np for initial random number table;
|
|
c output
|
|
c np,nq : parameters p and q of feedback shift register generator;
|
|
c input
|
|
c mode : operation for lfg:
|
|
c mode=<0 -> subtractive generator, mode=1 additive
|
|
c nexec : number of warm up cycles for the table. nexec*nbit*np
|
|
c random numbers are generated and discarded; input
|
|
c iout : unit number for messages, silent for iout.le.0; input
|
|
c subroutines called : errprt m. lewerenz mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
parameter (zero=0.d0,one=1.d0)
|
|
dimension x(np)
|
|
c
|
|
if(nq.ge.np.or.np.eq.0.or.nq.eq.0) then
|
|
call errprt(iout,'xuwarm','illegal table parameter(s)',-1)
|
|
else
|
|
c
|
|
c exercise the generator for nexec rounds of np prn's
|
|
c separate sections for subtractive or additive version
|
|
c
|
|
if(mode.le.0) then
|
|
do k=1,nexec
|
|
do i=1,nq
|
|
x(i)=x(i)-x(i+np-nq)
|
|
if(x(i).lt.zero) x(i)=x(i)+one
|
|
end do
|
|
do i=nq+1,np
|
|
x(i)=x(i)-x(i-nq)
|
|
if(x(i).lt.zero) x(i)=x(i)+one
|
|
end do
|
|
end do
|
|
else
|
|
do k=1,nexec
|
|
do i=1,nq
|
|
x(i)=x(i)+x(i+np-nq)
|
|
if(x(i).ge.one) x(i)=x(i)-one
|
|
end do
|
|
do i=nq+1,np
|
|
x(i)=x(i)+x(i-nq)
|
|
if(x(i).ge.one) x(i)=x(i)-one
|
|
end do
|
|
end do
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vrans(ranv,nran,iseed,iout)
|
|
c
|
|
c floating point subtractive lagged finonacci generator for
|
|
c uniformly distributed random numbers.
|
|
c identical with vranf but split into two separate subroutines.
|
|
c see there for description.
|
|
c
|
|
c ranv : vector of length nran for random numbers; output
|
|
c nran : number of desired random numbers. nran=0 and iseed.ne.0
|
|
c -> only generator initialization. no action when both
|
|
c are zero.; input
|
|
c iseed : if not 0, integer to start generator. use 0 to continue
|
|
c a previously used/initialized random sequence, unchanged
|
|
c on output; input
|
|
c iout : unit number for error messages. silent for iout.le.0
|
|
c
|
|
c times for 10**7 prn: sun ultra1 1.423 s
|
|
c cray-t90 450 mhz 0.307 s
|
|
c
|
|
c subroutines called: xuinit, fslfg, errprt m. lewerenz mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (nexec=4)
|
|
dimension ranv(nran)
|
|
c
|
|
c table initialization by xuinit
|
|
c
|
|
if(iseed.ne.0) then
|
|
call xuinit(x,np,nq,0,nexec,iseed,init,last,iout)
|
|
end if
|
|
c
|
|
c cyclic table update and output vector generation by fslfg
|
|
c
|
|
if(nran.gt.0) then
|
|
if(init.ne.0) then
|
|
call fslfg(x,np,nq,last,ranv,nran,iout)
|
|
else
|
|
call errprt(iout,'vrans','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vrans2(ranv,nran,a,b,iseed,iout)
|
|
c
|
|
c floating point subtractive generator for random numbers with
|
|
c uniform distribution on the interval [a,b).
|
|
c
|
|
c ranv : vector of length nran for random numbers; output
|
|
c nran : number of desired random numbers. nran=0 and iseed.ne.0
|
|
c -> only generator initialization. no action when both
|
|
c are zero.; input
|
|
c a,b : interval limits for random numbers; input
|
|
c iseed : if not 0, integer to start generator. use 0 to continue
|
|
c a previously used/initialized random sequence, unchanged
|
|
c on output; input
|
|
c iout : unit number for error messages. silent for iout.le.0
|
|
c
|
|
c times for 10**7 prn: sun ultra1 1.502 s
|
|
c cray-t90 0.355 s
|
|
c ----------------------------------------------------------------------
|
|
c subroutines called: xuinit, fslfg2, errprt
|
|
c m. lewerenz mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (nexec=4)
|
|
dimension ranv(nran)
|
|
c
|
|
c table initialization by xuinit
|
|
c
|
|
if(iseed.ne.0) then
|
|
call xuinit(x,np,nq,0,nexec,iseed,init,last,iout)
|
|
end if
|
|
c
|
|
c cyclic table update and output vector generation by fslfg2
|
|
c
|
|
if(nran.gt.0) then
|
|
if(init.ne.0) then
|
|
call fslfg2(x,np,nq,last,a,b,ranv,nran,iout)
|
|
else
|
|
call errprt(iout,'vrans2','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vranf2(ranv,nran,a,b,iseed,iout)
|
|
c
|
|
c identical to vrans2, kept to resolve references to vranf2.
|
|
c see vrans2 for description. m. lewerenz mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (nexec=4)
|
|
dimension ranv(nran)
|
|
c
|
|
c table initialization by xuinit
|
|
c
|
|
if(iseed.ne.0) then
|
|
call xuinit(x,np,nq,0,nexec,iseed,init,last,iout)
|
|
end if
|
|
c
|
|
c cyclic table update and output vector generation by fslfg2
|
|
c
|
|
if(nran.gt.0) then
|
|
if(init.ne.0) then
|
|
call fslfg2(x,np,nq,last,a,b,ranv,nran,iout)
|
|
else
|
|
call errprt(iout,'vranf2','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vranfx(ranv,nran,iseed,iout)
|
|
c
|
|
c special version of vranf eliminating the store into the table
|
|
c during the main computation. this version cannot work together
|
|
c with ranf. 0 =< x < 1
|
|
c
|
|
c ranv : vector of length nran returning the random numbers
|
|
c nran : number of desired random numbers. with nran=0 and iseed
|
|
c not 0 only generator initialization is done. no action
|
|
c when both are zero.
|
|
c iseed : if not 0, integer to start generator. use 0 to continue
|
|
c a previously used/initialized random sequence, unchanged
|
|
c on output
|
|
c iout : unit number for error messages. silent for iout.le.0
|
|
c
|
|
c method and references : see comments in vranf
|
|
c subroutines called: xuinit m. lewerenz 19/jan/93
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (nexec=4,zero=0.d0,one=1.d0)
|
|
dimension ranv(nran)
|
|
c
|
|
c ---------- initialization of x-table and warm up ----------
|
|
c
|
|
if(iseed.ne.0) then
|
|
call xuinit(x,np,nq,0,nexec,iseed,init,last,iout)
|
|
end if
|
|
c
|
|
c -------- generation of vector of uniform deviates ----------
|
|
c
|
|
if(nran.gt.0) then
|
|
if(init.ne.0) then
|
|
c
|
|
c expand x-vector into ranv vector, the first loop is
|
|
c not recurrent, recurrence in second loop broken by
|
|
c explicit stripmining with vector lengths of max. nq
|
|
c
|
|
do i=1,min(nran,nq)
|
|
xx=x(i)-x(i+np-nq)
|
|
if(xx.lt.zero) xx=xx+one
|
|
ranv(i)=xx
|
|
end do
|
|
c
|
|
if(nran.gt.nq) then
|
|
istart=nq+1
|
|
150 continue
|
|
cdir$ ivdep
|
|
do i=istart,min(np,istart+nq-1)
|
|
xx=x(i)-ranv(i-nq)
|
|
if(xx.lt.zero) xx=xx+one
|
|
ranv(i)=xx
|
|
end do
|
|
istart=istart+nq
|
|
if(istart.le.np) goto 150
|
|
end if
|
|
c
|
|
c main computation within ranv vector; recurrence broken
|
|
c by explicit stripmining with vector lengths of max. nq
|
|
c
|
|
if(nran.gt.np) then
|
|
istart=np+1
|
|
250 continue
|
|
cdir$ ivdep
|
|
do i=istart,min(nran,istart+nq-1)
|
|
xx=ranv(i-np)-ranv(i-nq)
|
|
if(xx.lt.zero) xx=xx+one
|
|
ranv(i)=xx
|
|
end do
|
|
istart=istart+nq
|
|
if(istart.le.nran) goto 250
|
|
c
|
|
c shift the np most recent prn's back into x vector
|
|
c
|
|
do i=1,np
|
|
x(i)=ranv(nran-np+i)
|
|
end do
|
|
else
|
|
c this may look like a recurrence to some compilers
|
|
cdir$ ivdep
|
|
do i=1,np-nran
|
|
x(i)=x(i+nran)
|
|
end do
|
|
do i=np-nran+1,np
|
|
x(i)=ranv(i+nran-np)
|
|
end do
|
|
end if
|
|
else
|
|
call errprt(iout,'vranfx','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine fslfg(x,np,nq,last,ranv,nran,iout)
|
|
c
|
|
c generic floating point subtractive lagged fibonacci generator.
|
|
c performs internal table update and copies random numbers into
|
|
c output vector. seed table must have been initialized separately
|
|
c e.g. by x u i n i t.
|
|
c ----------------------------------------------------------------------
|
|
c alternative additive formulation bypassing if statements:
|
|
c temp=x(k)+x(k+np-nq)
|
|
c x(k)=temp-float(int(temp))
|
|
c
|
|
c alternative subtractive formulation bypassing if statements:
|
|
c temp=x(k)-x(k+np-nq)
|
|
c x(k)=(temp+one)-float(int(temp+one))
|
|
c ----------------------------------------------------------------------
|
|
c subroutines called: errprt m. lewerenz dec/96, mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
parameter (mroll=4,zero=0.d0,one=1.d0)
|
|
dimension ranv(nran),x(np)
|
|
common /doctrl/ nroll
|
|
c
|
|
if(np.le.0.or.nq.le.0.or.nq.ge.np.or.last.ge.np.or.last.lt.0) then
|
|
call errprt(iout,'fslfg','invalid table parameters',-1)
|
|
else
|
|
if(nran.gt.0) then
|
|
nratio=np/nq
|
|
j=0
|
|
left=nran
|
|
c
|
|
c ------------------- straight loop version first ----------------------
|
|
c --------------------- best for vector machines -----------------------
|
|
c
|
|
if(nroll.le.1) then
|
|
10 continue
|
|
cdir$ ivdep
|
|
do i=last+1,min(nq,left+last)
|
|
x1=x(i)-x(i+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
c
|
|
if(last.lt.nratio*nq) then
|
|
do k=1,nratio-1
|
|
cdir$ ivdep
|
|
do i=max(k*nq,last)+1,min((k+1)*nq,left+last)
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
end do
|
|
end if
|
|
limit=min(np,left+last)
|
|
cdir$ ivdep
|
|
do i=max(nratio*nq,last)+1,limit
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
c
|
|
last=mod(limit,np)
|
|
left=nran-j
|
|
if(left.gt.0) goto 10
|
|
c
|
|
c --------------------- unrolled version of loops ----------------------
|
|
c ---------------------- best for risc machines ------------------------
|
|
c
|
|
else
|
|
20 continue
|
|
loop=mod((min(nq,left+last)-last),mroll)
|
|
do i=last+1,last+loop
|
|
x1=x(i)-x(i+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
do i=last+loop+1,min(nq,left+last),mroll
|
|
x1=x(i)-x(i+np-nq)
|
|
x2=x(i+1)-x(i+1+np-nq)
|
|
x3=x(i+2)-x(i+2+np-nq)
|
|
x4=x(i+3)-x(i+3+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
end do
|
|
c
|
|
if(last.lt.nratio*nq) then
|
|
do k=1,nratio-1
|
|
limit=min((k+1)*nq,left+last)
|
|
loop=mod((limit-max(k*nq,last)),mroll)
|
|
do i=max(k*nq,last)+1,max(k*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
do i=max(k*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
end do
|
|
end do
|
|
end if
|
|
c
|
|
limit=min(np,left+last)
|
|
loop=mod((limit-max(nratio*nq,last)),mroll)
|
|
do i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=x1
|
|
end do
|
|
do i=max(nratio*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=x1
|
|
ranv(j+2)=x2
|
|
ranv(j+3)=x3
|
|
ranv(j+4)=x4
|
|
j=j+4
|
|
end do
|
|
c
|
|
last=mod(limit,np)
|
|
left=nran-j
|
|
if(left.gt.0) goto 20
|
|
end if
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine fslfg2(x,np,nq,last,a,b,ranv,nran,iout)
|
|
c
|
|
c generic floating point subtractive lagged fibonacci generator on
|
|
c the interval [a,b]. works on the same internal table as f s l f g
|
|
c and allows mixed usage.
|
|
c performs internal table update and copies random numbers into
|
|
c output vector. seed table must have been initialized separately
|
|
c e.g. by x u i n i t.
|
|
c subroutines called: errprt m. lewerenz dec/96, mar/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
parameter (mroll=4,zero=0.d0,one=1.d0)
|
|
dimension ranv(nran),x(np)
|
|
common /doctrl/ nroll
|
|
c
|
|
if(np.le.0.or.nq.le.0.or.nq.ge.np.or.last.ge.np.or.last.lt.0) then
|
|
call errprt(iout,'fslfg2','invalid table parameters',-1)
|
|
else
|
|
if(nran.gt.0) then
|
|
nratio=np/nq
|
|
j=0
|
|
left=nran
|
|
range=b-a
|
|
c
|
|
c ------------------- straight loop version first ----------------------
|
|
c --------------------- best for vector machines -----------------------
|
|
c
|
|
if(nroll.le.1) then
|
|
10 continue
|
|
cdir$ ivdep
|
|
do i=last+1,min(nq,left+last)
|
|
x1=x(i)-x(i+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
c
|
|
if(last.lt.nratio*nq) then
|
|
do k=1,nratio-1
|
|
cdir$ ivdep
|
|
do i=max(k*nq,last)+1,min((k+1)*nq,left+last)
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
end do
|
|
end if
|
|
limit=min(np,left+last)
|
|
cdir$ ivdep
|
|
do i=max(nratio*nq,last)+1,limit
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
c
|
|
last=mod(limit,np)
|
|
left=nran-j
|
|
if(left.gt.0) goto 10
|
|
c
|
|
c --------------------- unrolled version of loops ----------------------
|
|
c ---------------------- best for risc machines ------------------------
|
|
c
|
|
else
|
|
20 continue
|
|
loop=mod((min(nq,left+last)-last),mroll)
|
|
do i=last+1,last+loop
|
|
x1=x(i)-x(i+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
do i=last+loop+1,min(nq,left+last),mroll
|
|
x1=x(i)-x(i+np-nq)
|
|
x2=x(i+1)-x(i+1+np-nq)
|
|
x3=x(i+2)-x(i+2+np-nq)
|
|
x4=x(i+3)-x(i+3+np-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=range*x1+a
|
|
ranv(j+2)=range*x2+a
|
|
ranv(j+3)=range*x3+a
|
|
ranv(j+4)=range*x4+a
|
|
j=j+4
|
|
end do
|
|
c
|
|
if(last.lt.nratio*nq) then
|
|
do k=1,nratio-1
|
|
limit=min((k+1)*nq,left+last)
|
|
loop=mod((limit-max(k*nq,last)),mroll)
|
|
do i=max(k*nq,last)+1,max(k*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
do i=max(k*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=range*x1+a
|
|
ranv(j+2)=range*x2+a
|
|
ranv(j+3)=range*x3+a
|
|
ranv(j+4)=range*x4+a
|
|
j=j+4
|
|
end do
|
|
end do
|
|
end if
|
|
c
|
|
limit=min(np,left+last)
|
|
loop=mod((limit-max(nratio*nq,last)),mroll)
|
|
do i=max(nratio*nq,last)+1,max(nratio*nq,last)+loop
|
|
x1=x(i)-x(i-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
x(i)=x1
|
|
j=j+1
|
|
ranv(j)=range*x1+a
|
|
end do
|
|
do i=max(nratio*nq,last)+loop+1,limit,mroll
|
|
x1=x(i)-x(i-nq)
|
|
x2=x(i+1)-x(i+1-nq)
|
|
x3=x(i+2)-x(i+2-nq)
|
|
x4=x(i+3)-x(i+3-nq)
|
|
if(x1.lt.zero) x1=x1+one
|
|
if(x2.lt.zero) x2=x2+one
|
|
if(x3.lt.zero) x3=x3+one
|
|
if(x4.lt.zero) x4=x4+one
|
|
x(i)=x1
|
|
x(i+1)=x2
|
|
x(i+2)=x3
|
|
x(i+3)=x4
|
|
ranv(j+1)=range*x1+a
|
|
ranv(j+2)=range*x2+a
|
|
ranv(j+3)=range*x3+a
|
|
ranv(j+4)=range*x4+a
|
|
j=j+4
|
|
end do
|
|
c
|
|
last=mod(limit,np)
|
|
left=nran-j
|
|
if(left.gt.0) goto 20
|
|
end if
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
function ranf(iseed,iout)
|
|
c
|
|
c generator for uniformly distributed pseudo random numbers using
|
|
c the fibonacci method with 48 bit mantissa output. single output
|
|
c version of vranf. see comments there for method. successive calls
|
|
c generate the same random sequence as vranf. ranf and vranf can be
|
|
c used together, working on the same random sequence, and either
|
|
c one can be used for initialization. this generator is machine
|
|
c independent and gives the same random sequence on any machine.
|
|
c 5.52 s for 1000000 calls on convex c210. 3.06 s on ibm-3090/300s
|
|
c
|
|
c iseed : if not 0, generator is initialized and ranf returns a
|
|
c real echo of iseed; no random number output. iseed is
|
|
c unchanged.
|
|
c if 0, ranf returns the next random number from a
|
|
c previously used or initialized random sequence.
|
|
c iout : unit number for error messages. silent for iout.le.0
|
|
c subroutines called: vranf m. lewerenz 12/may/91
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
parameter (zero=0.d0,one=1.d0)
|
|
dimension dummy(1)
|
|
c
|
|
c table initialization by vranf
|
|
c
|
|
if(iseed.ne.0) then
|
|
call vranf(dummy,0,iseed,iout)
|
|
ranf=iseed
|
|
else
|
|
if(init.ne.0) then
|
|
if(last.lt.nq) then
|
|
ranf=x(last+1)-x(last+1+np-nq)
|
|
else
|
|
ranf=x(last+1)-x(last+1-nq)
|
|
end if
|
|
if(ranf.lt.zero) ranf=ranf+one
|
|
x(last+1)=ranf
|
|
last=mod(last+1,np)
|
|
else
|
|
call errprt(iout,'ranf','incorrect initialization',-1)
|
|
end if
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine rsavef(isave,iout)
|
|
c
|
|
c table backup for routines ranf, vranf, and vranf2.
|
|
c uses unit iabs(isave) to save or retrieve contents of common
|
|
c block /xrandf/ for program restart with continuation of the
|
|
c old random sequence. isave > 0 write, isave < 0 read.
|
|
c iout is a message unit. np and nq must be consistent with
|
|
c vranf and ranf!
|
|
c subroutines called: errprt,xuinit m. lewerenz 12/may/91
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
c
|
|
iunit=iabs(isave)
|
|
if(isave.gt.0) then
|
|
write(iunit) np,nq,last
|
|
write(iunit) x
|
|
else if(isave.lt.0) then
|
|
read(iunit) npp,nqq,last
|
|
if(npp.ne.np.or.nqq.ne.nq.or.nqq.ge.npp.or.last.lt.0.
|
|
# or.last.gt.np) then
|
|
call errprt(iout,'rsavef',
|
|
# 'illegal file contents -> using default seed',0)
|
|
iseed=123456789
|
|
call xuinit(x,np,nq,0,4,iseed,init,last,iout)
|
|
else
|
|
read(iunit) x
|
|
init=1
|
|
end if
|
|
else
|
|
call errprt(iout,'rsavef','illegal unit number',-1)
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine rnsetf(xsave,nx,iflag,iout)
|
|
c
|
|
c sets or gets state of generator table used in routines ranf,
|
|
c vranf, and vranf2.
|
|
c
|
|
c xsave : vector of length nx containing the state of the
|
|
c generator. nx must be > np; input or output
|
|
c nx : length of vector xsave, must be at least np+2 which
|
|
c is currently 252; input
|
|
c iflag : 0 -> xsave returns the state of the generator;
|
|
c else -> generator state is set to xsave; input
|
|
c iout : unit number for messages; silent for iout.le.0; input
|
|
c np and nq must be consistent with settings in vranf and ranf!
|
|
c subroutines called: errprt m. lewerenz jan/94
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
dimension xsave(nx)
|
|
c
|
|
if(nx.ge.(np+2)) then
|
|
if(iflag.eq.0) then
|
|
call vcopy(x,xsave,np)
|
|
xsave(np+1)=last
|
|
xsave(np+2)=init
|
|
else
|
|
call vcopy(xsave,x,np)
|
|
last=xsave(np+1)
|
|
init=xsave(np+2)
|
|
if(init.eq.0) then
|
|
call errprt(iout,'rnsetf','bad generator state',-1)
|
|
end if
|
|
end if
|
|
else
|
|
call errprt(iout,'rnsetf','xsave vector too short',-1)
|
|
end if
|
|
return
|
|
end
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine vrseed(iseed,iout)
|
|
c
|
|
c returns current status of internal congruential generator used
|
|
c to seed the bit tables for ranf/vranf package. useful to seed
|
|
c other copies of ranf/vranf.
|
|
c
|
|
c iseed : seed from current congruential generator status; output
|
|
c iout : unit number for messages; silent for iout.le.0; input
|
|
c subroutines called: errprt m. lewerenz feb/98
|
|
c
|
|
implicit double precision (a-h,o-z)
|
|
include 'ranlfg.inc'
|
|
c
|
|
iseed=init
|
|
if(init.eq.0) call errprt(iout,'vrseed','illegal seed',1)
|
|
return
|
|
end
|
|
c=======================================================================
|
|
c================== last line of ranf/vranf package ====================
|
|
c=======================================================================
|
|
c-----------------------------------------------------------------------
|
|
c-------------------------- error handling -----------------------------
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine errprt(iout,pgname,text,icode)
|
|
c
|
|
c prints error messages from library subroutines
|
|
c
|
|
c iout : unit number for message output, 0-> no output; input
|
|
c pgname : name of the subroutine calling errprt; input
|
|
c text : message text; input
|
|
c icode : severity code: 0 -> warning, < 0 -> fatal error with
|
|
c abort, else -> error but execution continues
|
|
c subroutines called : strlen m. lewerenz dec/93
|
|
c
|
|
character pgname*(*),text*(*),header*20,tail*40
|
|
save nerror,nwarn,icall
|
|
common /errcnt/ maxerr,maxwrn
|
|
data icall/0/
|
|
c
|
|
if(icall.eq.0) then
|
|
icall=1
|
|
nerror=0
|
|
nwarn=0
|
|
end if
|
|
c
|
|
if(icode.lt.0) then
|
|
header=' *** fatal error,'
|
|
tail=', execution aborted ***'
|
|
else if(icode.eq.0) then
|
|
header=' *** warning,'
|
|
tail=' ***'
|
|
nwarn=nwarn+1
|
|
else
|
|
header=' *** error,'
|
|
tail=', return without action ***'
|
|
nerror=nerror+1
|
|
end if
|
|
c
|
|
c write the message on unit iout
|
|
c
|
|
if(iout.gt.0) then
|
|
call strlen(pgname,lname,iout)
|
|
call strlen(text,ltext,iout)
|
|
call strlen(header,lhead,iout)
|
|
call strlen(tail,ltail,iout)
|
|
write(iout,'(/6a/)') header(1:lhead),' ',text(1:ltext),' in ',
|
|
# pgname(1:lname),tail(1:ltail)
|
|
call flush
|
|
end if
|
|
c
|
|
jcode=icode
|
|
if(maxerr.gt.0.and.nerror.ge.maxerr) then
|
|
if(iout.gt.0) write(iout,'(/a)')
|
|
# ' *** maximum number of errors exceeded, program stopped *** '
|
|
jcode=-1
|
|
end if
|
|
if(maxwrn.gt.0.and.nwarn.ge.maxwrn) then
|
|
if(iout.gt.0) write(iout,'(/a)')
|
|
# ' *** maximum number of warnings exceeded, program stopped ***'
|
|
jcode=-1
|
|
end if
|
|
if(iout.gt.0) call flush
|
|
c
|
|
if(jcode.lt.0) stop
|
|
return
|
|
c
|
|
c ---------------------------------------------------------------------
|
|
c error report, returns current number of errors and warning
|
|
c
|
|
entry errnum(nerr,nwrn)
|
|
nerr=nerror
|
|
nwrn=nwarn
|
|
return
|
|
end
|
|
C
|
|
C----------------------------------------------------------------------
|
|
C
|
|
SUBROUTINE STRLEN(STRING,LS,IOUT)
|
|
C
|
|
C DETERMINES LENGTH OF STRING
|
|
C
|
|
CHARACTER STRING*(*)
|
|
C
|
|
LS=LEN(STRING)
|
|
10 IF(LS.GT.0.AND.STRING(LS:LS).EQ.' ') THEN
|
|
LS=LS-1
|
|
GOTO 10
|
|
END IF
|
|
IF(LS.EQ.0) call errprt(iout,'strlen','empty string',0)
|
|
RETURN
|
|
END
|
|
c
|
|
c-----------------------------------------------------------------------
|
|
c
|
|
subroutine flush
|
|
c
|
|
c dummy to resolve calls to the buffer flushing routine
|
|
c available on dec axp and sgi machines
|
|
c
|
|
return
|
|
end
|