src/sim_rnd.f

Fortran project SIMRES, source module src/sim_rnd.f.

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