Source module last modified on Sun, 27 Mar 2005, 19:16;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.1
#////
#//// Monte Carlo 4D-integration routines
#////
#//// * SUBROUTINE MCRES1(IOCONS,ICOM)
#//// * SUBROUTINE MCPROFIL(IOCONS)
#//// * FUNCTION GASDEV1(IDUM,centre,limits)
#//// * FUNCTION GASDEV(IDUM)
#//// * FUNCTION RAN1(IDUM)
#////
#//////////////////////////////////////////////////////////////////////
# -----------------------------------
SUBROUTINE M16XV16(it,m,a,b,c)
# -----------------------------------
INCLUDE 'randvars.inc'
real*8 a(crnd,crnd),b(crnd),c(crnd)
integer*4 m
do 10 j=1,m
c(j)=0.
if (it.gt.0) then
do 20 i=1,m
20 c(j)=c(j)+a(j,i)*b(i)
else
do 30 i=1,m
30 c(j)=c(j)+a(i,j)*b(i)
endif
10 continue
return
end
# *** GASDEV with limits ***
real*4 FUNCTION GASDEV1(idum,centre,limits)
# ******************************************
real*4 limits,centre,z
z=2.*limits
do 10 while (abs(z).gt.abs(limits))
10 z=GASDEV(idum)
GASDEV1=z+centre
return
end
# *** Generation of Gaussian deviates by GASDEV from Numerical Recipes ***
real*4 FUNCTION GASDEV(idum)
# ************************************
save iset,gset
data iset/0/
if (iset.eq.0) then
1 v1=2.*RAN1()-1.
v2=2.*RAN1()-1.
r=v1**2+v2**2
if(r.ge.1.)go to 1
fac=sqrt(-2.*log(r)/r)
gset=v1*fac
GASDEV=v2*fac
iset=1
else
GASDEV=gset
iset=0
endif
return
end
#
# ************************************
SUBROUTINE RAN1SEED(idum)
# Initialize random number generator
# ************************************
implicit none
INCLUDE 'randvars.inc'
integer*4 idum
real*4 dum,z
real*4 RAN1NR,rand,secnds
# Generate ISEED from the system time on the first call
if (idum.eq.0) then
z=secnds(0.0)
iseed=2*int(10000.+z)+1
endif
# If argument<>0, use it as a new seed
if (idum.ne.0) iseed=abs(idum)
write(*,*) 'SEED = ',iseed, ' ',irnd
# Initialize required generator
if (irnd.eq.0) call sgrnd(iseed) ! Mersenne Twister
if (irnd.eq.1) dum=RAN1NR(-iseed) ! Numerical Recipes RAN1
if (irnd.eq.2) dum=rand(iseed) ! System generator
end
# *****************************************************************
real*4 FUNCTION RAN1()
# Call random number generator
# generate uniform random numbers in the interval [1e-6..1-1e-6]
# *****************************************************************
implicit none
INCLUDE 'randvars.inc'
real*4 eps,eps1,z
real*4 RAN1NR,rand
real*8 GRND
parameter(eps=1e-6,eps1=1-1e-6)
10 if (irnd.eq.0) then ! Mersenne Twister
z=GRND()
else if (irnd.eq.1) then ! Numerical Recipes RAN1
z=RAN1NR(iseed)
else if (irnd.eq.2) then ! System generator
z=rand(iseed)
endif
# write(*,*) ISEED,' ',Z
# pause
if (z.lt.eps) goto 10
if (z.gt.eps1) goto 10
RAN1=z
end
# **************************************************************
# *** Random number generator from Numerical Recipes (RAN1): ***
# **************************************************************
#
real*4 FUNCTION RAN1NR(idum)
implicit none
INCLUDE 'randvars.inc'
# implicit real*4 (a-h,o-z)
# implicit integer*4 (i-n)
integer*4 m1,m2,m3,ia1,ia2,ia3,ic1,ic2,ic3,ix1,ix2,ix3,j
integer*4 ini,idum
real*4 r(97),rm1,rm2
parameter (m1=259200,ia1=7141,ic1=54773,rm1=3.8580247e-6)
parameter (m2=134456,ia2=8121,ic2=28411,rm2=7.4373773e-6)
parameter (m3=243000,ia3=4561,ic3=51349)
save ix1,ix2,ix3,r
data ini/0/
if (idum.lt.0.or.ini.eq.0) then
iseed=idum
ini=-1
ix1=mod(ic1-iseed,m1)
ix1=mod(ia1*ix1+ic1,m1)
ix2=mod(ix1,m2)
ix1=mod(ia1*ix1+ic1,m1)
ix3=mod(ix1,m3)
do 11 j=1,97
ix1=mod(ia1*ix1+ic1,m1)
ix2=mod(ia2*ix2+ic2,m2)
r(j)=(float(ix1)+float(ix2)*rm2)*rm1
11 continue
iseed=1
endif
12 ix1=mod(ia1*ix1+ic1,m1)
ix2=mod(ia2*ix2+ic2,m2)
ix3=mod(ia3*ix3+ic3,m3)
j=1+(97*ix3)/m3
if(j.gt.97.or.j.lt.1) then
write(*,*) 'RAN1 error:'
write(*,*) j, 'IX = ',ix1, ix2, ix3, 'ISEED = ', iseed
pause
end if
RAN1NR=r(j)
r(j)=(float(ix1)+float(ix2)*rm2)*rm1
return
end
#
# *******************************************
# *** Test Random number covariances
# *******************************************
SUBROUTINE RAN1TEST(n,nev)
implicit none
real*4 RAN1,secnds
integer*4 i,j,n,nev,m,nc,nmax,im,jm
real*4 c(128,128),v(128),mean(128),rw,c0,max,disp,s,s2,z,t1,t2
real*4 w,w2,z0
m=n
if (m.lt.2) m=2
if (m.gt.128) m=128
do i=1,m
mean(i)=0
do j=1,m
c(i,j)=0
enddo
enddo
nmax=nev/m
do nc=1,nmax
do i=1,m
v(i)=RAN1()-0.5
end do
do i=1,m
mean(i)=mean(i)+v(i)
do j=1,m
c(i,j)=c(i,j)+v(i)*v(j)
end do
end do
end do
1 format(e8.2, ' ',$)
max=0.
write(*,*)
write(*,*) 'Covariances:'
do i=1,m
do j=1,m
c0=mean(i)*mean(j)/nmax/nmax
if (i.eq.j) c0=c0+1./12
write(*,1) (c(i,j)/nmax-c0)*12.
if(abs(c(i,j)/nmax-c0).gt.max) then
max=abs(c(i,j)/nmax-c0)
im=i
jm=j
endif
end do
write(*,*)
end do
write(*,*)
write(*,*) 'Mean:'
do i=1,m
write(*,1) mean(i)/nmax
end do
write(*,*)
s=0
s2=0
w=0
w2=0
t1=secnds(0.0)
do i=1,10000
rw=0.
z0=0.
do j=1,10000
z=RAN1()-0.5
if (z.gt.0) then
rw=rw+1.
else
rw=rw-1.
endif
z0=z0+z
enddo
s=s+rw
s2=s2+rw**2
w=w+z0/10000
w2=w2+(z0/10000)**2
enddo
t2=secnds(0.0)
disp=w2/10000-(w/10000)**2
write(*,*)
4 format( 'Variance of mean value: ',g12.6)
write(*,4) sqrt(disp)/sqrt(1./12/(10000-1))
2 format( 'Variance of discrete random walk : ',g12.6)
write(*,2) (s2/10000-(s/10000)**2)/10000
3 format( 'Speed: ',g12.5, '/msec')
write(*,3) 1.e8/(t2-t1)/1000
end