!===============================================================================
!
! ran/ranlux-3.2/ranfield.F90 - 'field-parallel' luxury (Luscher) random numbers
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 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_field

  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_field(r, n) bind(c)
       use iso_c_binding
       real(c_double) :: r(*)
       integer(c_int), value :: n
     end subroutine ranlxd_field

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

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

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

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

     subroutine rlxd_field_init_constants(m1, m2) bind(c)
       use iso_c_binding
       integer(c_int), value :: m1
       integer(c_int), value :: m2
     end subroutine rlxd_field_init_constants
    
     subroutine rlxd_field_select(i1, i2) bind(c)
       use iso_c_binding
       integer(c_int), value :: i1
       integer(c_int), value :: i2
     end subroutine rlxd_field_select
  end interface

end

!-------------------------------------------------------------------------------
RAN_NAME function ranfield_name()

  use module_input
  implicit none

  if (input%tuning_ran_field_parallel == 0) then
     ranfield_name = " "
  else
     ranfield_name = " (field-parallel)"
  endif
end

!-------------------------------------------------------------------------------
subroutine ranfield_init(seed)

  use module_input
  use module_function_decl
  use module_lattice
  use module_ranlux_field
  implicit none

  SEED, intent(in) :: seed
  SEED             :: seed_field
!!SEED, parameter  :: mask31 = 2**31 - 1
  SEED, parameter  :: mask31 = 2147483647
  integer          :: seed32
  integer          :: level
  integer          :: z, t, global(DIM)
  integer, external:: ilex

  if (input%tuning_ran_field_parallel == 0) return

  level = input%ran_ranlux_level

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

  call rlxd_field_init_constants(nz, nt)

  do t = 0, nt - 1
  do z = 0, nz - 1
     call local2global(my_pe(), (/0, 0, z, t/), global)

     seed_field = seed + 23 * (ilex(2, global(3:4), L(3:4)) + 1)

     if (seed_field > mask31) call warn("ranfield_init(): seed_field cut to lowest 31 bits")

     seed32 = iand(mask31, seed_field)

     call rlxd_field_select(z, t)
     call rlxd_field_init(level, seed32)
  enddo
  enddo

end

!-------------------------------------------------------------------------------
subroutine ranfield_vector(n, vec, z, t)

  use module_input
  use module_ranlux_field
  implicit none
  integer, intent(in) :: n
  REAL, intent(out)   :: vec(n)
  integer, intent(in) :: z, t
  integer             :: i

  ASSERT(input%tuning_ran_field_parallel /= 0)

  call rlxd_field_select(z, t)
  call ranlxd_field(vec, n)
end

!-------------------------------------------------------------------------------
subroutine ranfield_dump(unit)
  
  use module_input
  use module_function_decl
  use module_lattice
  use module_ranlux_field
  implicit none
  integer, intent(in) :: unit
  integer :: local(DIM)
  integer :: home, z, t

  if (input%tuning_ran_field_parallel == 0) return

  call ranfield_check()

  do t = 0, lt - 1
  do z = 0, lz - 1
     call global2local((/0, 0, z, t/), home, local)

     if (my_pe() == home) then
        call rlxd_field_select(local(3), local(4))
        call rlxd_field_get(state)

        if (my_pe() /= 0) call comm_send_i4(state, state_size, 0)
     endif

     if (my_pe() == 0) then
        if (home /= 0) call comm_recv_i4(state, state_size, home)

        write(unit, fmt105) state
     endif

  enddo
  enddo
end

!-------------------------------------------------------------------------------
subroutine ranfield_dump_ildg(s, len_s, z, t)
  
  use module_input
  use module_function_decl
  use module_lattice
  use module_ranlux_field
  implicit none
  character(*), intent(out) :: s 
  integer, intent(in) :: len_s
  integer, intent(in) :: z, t
  integer :: local(DIM), global(DIM)
  integer :: home
  integer, external :: ran_state_strlen

  if (input%tuning_ran_field_parallel == 0) return

  if (z == 0 .and. t == 0) then
     call ranfield_check()
     if (my_pe() == 0) write(UREC,*) "ildg-write ranfield-check passed"
  endif

  call local2global(my_pe(), (/0, 0, 0, 0/), global)
  call global2local((/global(1), global(2), z, t/), home, local)

  if (my_pe() == home) then
     call rlxd_field_select(local(3), local(4))
     call rlxd_field_get(state)
     
     if (my_pe() /= 0) call comm_send_i4(state, state_size, 0)
  endif

  if (my_pe() == 0) then
     if (home /= 0) call comm_recv_i4(state, state_size, home)
     
     CHECK(len_s == ran_state_strlen())
     write(s(1:len_s), fmt105) state
  endif
end

!-------------------------------------------------------------------------------
subroutine ranfield_restore(unit)

  use module_input
  use module_function_decl
  use module_lattice
  use module_ranlux_field
  implicit none
  integer, intent(in) :: unit
  integer :: global(DIM), local(DIM)
  integer :: home, z, t

  if (input%tuning_ran_field_parallel == 0) return

  call rlxd_field_init_constants(nz, nt)

  call local2global(my_pe(), (/0, 0, 0, 0/), global)

  do t = 0, lt - 1
  do z = 0, lz - 1

     call global2local((/global(1), global(2), z, t/), home, local)

     if (home == my_pe()) then
        read(unit, fmt105) state
        call rlxd_field_select(local(3), local(4))
        call rlxd_field_reset(state)
     else
        read(unit, *)
     endif
  enddo
  enddo

  call ranfield_check()
end

!-------------------------------------------------------------------------------
subroutine ranfield_restore_ildg(s, len_s, z, t)

  use module_input
  use module_function_decl
  use module_lattice
  use module_ranlux_field
  use module_ildg_restart_info
  implicit none
  character(*), intent(in) :: s
  integer, intent(in) :: len_s
  integer, intent(in) :: z, t
  integer :: global(DIM), local(DIM)
  integer :: home
  integer, external :: ran_state_strlen

  CHECK(len_s == ran_state_strlen())

  if (z == 0 .and. t == 0) then
     CHECK(.not. ildg_restart_info%ranfield_state_is_initialised)
     call rlxd_field_init_constants(nz, nt)
     ildg_restart_info%ranfield_state_is_initialised = .true.
  else
     CHECK(ildg_restart_info%ranfield_state_is_initialised)
  endif

  call local2global(my_pe(), (/0, 0, 0, 0/), global)
  call global2local((/global(1), global(2), z, t/), home, local)

  if (home == my_pe()) then
     read(s(1:len_s), *) state
     call rlxd_field_select(local(3), local(4))
     call rlxd_field_reset(state)
  endif

  if (z == lz - 1 .and. t == lt - 1) then
     call ranfield_check()
     if (my_pe() == 0) write(UREC,*) "ildg-read ranfield-check passed"
  endif
end

!-------------------------------------------------------------------------------
subroutine ranfield_check()

  use module_function_decl
  use module_lattice
  use module_ranlux_field
  implicit none
  integer :: i_pe(DIM)
  integer :: rank, z, t, i

  call comm_field_create(rank)

  do t = 0, nt - 1
  do z = 0, nz - 1
     call rlxd_field_select(z, t)
     call rlxd_field_get(my_state)

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

     call comm_field_broadcast_i4(state, state_size)

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

  call comm_field_free()
end

!-------------------------------------------------------------------------------
subroutine ranfield_info(z, t)  ! used for ILDG files

  use module_input
  use module_lattice
  implicit none
  integer, intent(out) :: z, t

  if (input%tuning_ran_field_parallel == 0) then
     z = 0
     t = 0
  else
     z = lz
     t = lt
  endif

end

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