qmcchem/src/TOOLS/random.irp.f

double precision function qmc_ranf()
! L'Ecuyer, P. (1999) `Tables of maximally equidistributed combined LFSR
! generators', Math. of Comput., 68, 261-269.
 implicit none
 integer*8 :: b(2)
 b(1) = SHIFTR( IEOR( ISHFT(seed(1),1), seed(1)), 53)
 b(2) = SHIFTL( IAND(seed(1),-2_8), 10)
 seed(1) = IEOR( b(2), b(1))

 b(1) = SHIFTR( IEOR( ISHFT(seed(2),24), seed(2)), 50)
 b(2) = SHIFTL( IAND(seed(2),-512_8), 5)
 seed(2) = IEOR( b(2), b(1))

 b(1) = SHIFTR( IEOR( ISHFT(seed(3),3), seed(3)), 23)
 b(2) = SHIFTL( IAND(seed(3),-4096_8), 29)
 seed(3) = IEOR( b(2), b(1))

 b(1) = SHIFTR( IEOR( ISHFT(seed(4),5), seed(4)), 24)
 b(2) = SHIFTL( IAND(seed(4),-131072_8), 23)
 seed(4) = IEOR( b(2), b(1))

 b(1) = SHIFTR( IEOR( ISHFT(seed(5),3), seed(5)), 33)
 b(2) = SHIFTL( IAND(seed(5),-8388608_8), 8)
 seed(5) = IEOR( b(2), b(1))

 qmc_ranf = IEOR( IEOR( IEOR( IEOR(seed(1),seed(2)), seed(3)), &
   seed(4)), seed(5)) * 5.4210108624275221D-20 + 0.5D0
 ASSERT ( qmc_ranf >= 0.d0 )
 ASSERT ( qmc_ranf <= 1.d0 )

end

subroutine ranf_array(isize,res)
 implicit none
 integer :: isize
 double precision :: res(isize)
 integer :: i
 double precision :: qmc_ranf

 do i=1,isize
   res(i) = qmc_ranf()
 enddo
end

BEGIN_PROVIDER  [ integer*8, seed, (5) ]
  implicit none
  BEGIN_DOC  
! Seeds data
! Initialized by init_random
  END_DOC
  integer                        :: iargc
  integer*8                      :: i,j
  integer*4                      :: clock(33)
  double precision               :: r
  integer*8                      :: pid8
  read(current_PID,*) pid8
  pid8 = iand( shiftl(pid8, 32), pid8)
  do i=1,size(clock)
    clock(i) = i
  enddo
  call system_clock(count=clock(1))
  call random_seed(put=clock)
  do i=1,5
    call random_number(r)
    seed(i) = (r-0.5d0)*huge(1_8)
    seed(i) = ieor( seed(i), pid8)
    do j=1,16
      seed(i) = shiftl(seed(i),1)+1
    enddo
  enddo

END_PROVIDER

subroutine gauss_array(isize,res)
  implicit none
  include '../constants.F'
  integer isize
  double precision res(isize)

  double precision u1(isize),u2(isize)
  integer i

  call ranf_array(isize,u1)
  call ranf_array(isize,u2)
  do i=1,isize
    res(i)=sqrt(-2.d0*log(u1(i)))*cos(dtwo_pi*u2(i))
  enddo
end

double precision function gauss()
  implicit none
  include '../constants.F'
  double precision :: qmc_ranf
  double precision :: u1,u2
  u1=qmc_ranf()
  u2=qmc_ranf()
  gauss=dsqrt(-2.d0*dlog(u1))*dcos(dfour_pi*u2)
end