!===============================================================================
!
! ran/ranlux-3.2/ran.F90 - luxury (Luscher) random numbers
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 2008-2016 Hinnerk Stueben
!
! This file is part of BQCD -- Berlin Quantum ChromoDynamics program
!
! BQCD is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! BQCD is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with BQCD.  If not, see <http://www.gnu.org/licenses/>.
!
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
module module_ranlux

  use iso_c_binding

  integer, parameter :: state_size = 105
  integer            :: state(state_size)
  integer            :: my_state(state_size)

  character(*), parameter :: fmt1 = "(i10,x)"
  character(*), parameter :: fmt105 = "(105(i10,x))"

  interface
     subroutine ranlxd(r, n) bind(c)
       use iso_c_binding
       real(c_double) :: r(*)
       integer(c_int), value :: n
     end subroutine ranlxd

     subroutine rlxd_init(level, seed) bind(c)
       use iso_c_binding
       integer(c_int), value :: level
       integer(c_int), value :: seed
     end subroutine rlxd_init

     function rlxd_size() bind(c)
       use iso_c_binding
       integer(c_int) :: rlxd_size
     end function rlxd_size

     subroutine rlxd_get(state) bind(c)
       use iso_c_binding
       integer(c_int) :: state(*)
     end subroutine rlxd_get

     subroutine rlxd_reset(state) bind(c)
       use iso_c_binding
       integer(c_int) :: state(*)
     end subroutine rlxd_reset

  end interface

end

!-------------------------------------------------------------------------------
RAN_NAME function ran_name()

  use module_input
  implicit none
  character :: c_level(2) = (/'1', '2'/)
  integer   :: level
  RAN_NAME, external :: ranfield_name

  level = input%ran_ranlux_level

  CHECK(level == 1 .or. level == 2)

  ran_name = "ranlux-3.2 level " // c_level(level) // ranfield_name()
end

!-------------------------------------------------------------------------------
subroutine ran_init(seed)

  use module_input
  use module_ranlux
  implicit none
  SEED, intent(in) :: seed
!!SEED, parameter  :: mask31 = 2**31 - 1
  SEED, parameter  :: mask31 = 2147483647
  integer          :: seed32
  integer          :: level

  level = input%ran_ranlux_level

  CHECK(level == 1 .or. level == 2)

  if (seed > mask31) call warn("ran_init(): seed cut to lowest 31 bits")

  seed32 = iand(mask31, seed)

  call rlxd_init(level, seed32)
  call ranfield_init(seed)
end

!-------------------------------------------------------------------------------
REAL function ran_number()

  use module_ranlux
  implicit none
  real(c_double) :: r(1)
  
  call ranlxd(r, 1)
  ran_number = r(1)
end

!-------------------------------------------------------------------------------
subroutine ran_vector(n, x)

  use module_ranlux
  implicit none
  integer, intent(in) :: n
  REAL, intent(out)   :: x(n)
  integer             :: i

  call ranlxd(x, n)
end

!-------------------------------------------------------------------------------
subroutine ran_skip(n)

  use module_ranlux
  implicit none
  integer, intent(in) :: n
  real(c_double)      :: x(1)
  integer             :: i

  do i = 1, n
     call ranlxd(x, 1)
  enddo
end

!-------------------------------------------------------------------------------
subroutine ran_dump(unit)

  use module_function_decl
  use module_ranlux
  implicit none
  integer, intent(in) :: unit
  FILENAME, external :: ran_file
  integer            :: i

  ASSERT(state_size == rlxd_size())

  call ran_check()

  call rlxd_get(state)

  if (my_pe() == 0) then
     if (unit == URAN) open(unit, file = trim(ran_file()), action = "write")
     do i = 1, state_size
        write(unit, *) state(i)
     enddo
  endif

  call ranfield_dump(unit)

  if (my_pe() == 0) then
     if (unit == URAN) close(unit)
  endif

end

!-------------------------------------------------------------------------------
subroutine ran_restore(unit)

  use module_ranlux
  use module_ildg_restart_info
  implicit none
  integer, intent(in) :: unit
  FILENAME, external :: ran_file
  character(ildg_restart_info%len_ran_state) :: astate
  integer            :: i

  ASSERT(state_size == rlxd_size())

  astate = ""
  if (ildg_restart_info%ran_state_is_initialised) then
     do i = 1, ildg_restart_info%len_ran_state
        astate(i:i) = ildg_restart_info%ran_state(i)
     enddo
     read(astate, *) state(:)
  else
     if (unit == URAN) open(unit, file = trim(ran_file()), action = "read", status = "old")
     do i = 1, state_size
        read(unit, *) state(i)
     enddo
     call ranfield_restore(unit)
     if (unit == URAN) close(unit)
  endif

  call rlxd_reset(state)
end

!-------------------------------------------------------------------------------
SEED function ran_get_seed()

  implicit none

  ran_get_seed = -1
end

!-------------------------------------------------------------------------------
subroutine ran_check()

  use module_function_decl
  use module_ranlux
  implicit none
  integer :: i

  call rlxd_get(my_state)

  if (my_pe() == 0) then
     state(:) = my_state(:)
  else 
     state(:) = -1
  endif

  call comm_broadcast_i4(state, state_size)

  do i = 1, state_size
     ASSERT(state(i) == my_state(i))
  enddo

end

!-------------------------------------------------------------------------------
integer function ran_state_strlen()

  use module_ranlux
  implicit none
  ran_state_strlen = state_size * 11
end

!-------------------------------------------------------------------------------
subroutine ran_state_to_string(s)

  use module_ranlux
  implicit none
  character(*), intent(out) :: s
  integer :: i, j

  call rlxd_get(state)

  j = 0
  do i = 1, state_size
     write(s(j+1:j+11), fmt1) state(i)
     j = j + 11
  enddo
end

!-------------------------------------------------------------------------------
subroutine ran_field(m, mx, field)

  use module_input
  use module_lattice
  implicit none
  integer, intent(in) :: m
  integer, intent(in) :: mx  ! typically: mx = nxh (or: mx = nx)
  REAL, intent(out)   :: field(m, 0:mx-1, 0:ny-1, 0:nz-1, 0:nt-1)

  integer :: kx
  integer :: n_vector
  integer :: i_pe(DIM)
  integer :: block(3:4)
  integer :: x0, y0
  integer :: x, y, z, t
  integer, external :: i_global
  REAL, dimension(:,:,:), allocatable :: vector

  kx = mx * npe(1)
  n_vector = m * kx * ly

  allocate(vector(m, 0:kx-1, 0:ly-1))

  call my_coord(i_pe)

  x0 = i_global(0, mx, i_pe(1))
  y0 = i_global(0, ny, i_pe(2))

  if (input%tuning_ran_field_parallel == 0) then
     block(3) = n_vector * nz
     block(4) = n_vector * lz * nt
  else
     block(3) = 0  ! => no ran_skip (i.e. no serial random number generation)
     block(4) = 0  ! => no ran_skip
  endif

  call ran_skip(block(4) * i_pe(4));  do t = 0, nt - 1
  call ran_skip(block(3) * i_pe(3));  do z = 0, nz - 1

     if (input%tuning_ran_field_parallel == 0) then
        call ran_vector(n_vector, vector)
     else
        call ranfield_vector(n_vector, vector, z, t)
     endif
     do y = 0, ny - 1
     do x = 0, mx - 1
        field(:, x, y, z, t) = vector(:, x0 + x, y0 + y) 
     enddo
     enddo

  enddo;  call ran_skip(block(3) * (npe(3) - 1 - i_pe(3))) 
  enddo;  call ran_skip(block(4) * (npe(4) - 1 - i_pe(4))) 

  deallocate(vector)
end

!===============================================================================
