!===============================================================================
!
! field_io_mpi.F90 - I/O routine for gauge and pseudo fermion fields using MPI
!
!-------------------------------------------------------------------------------
!
! Copyright (C) 1998-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"

#ifndef INCLUDE_MPIF_H
#define INCLUDE_MPIF_H include 'mpif.h'
#endif

!-------------------------------------------------------------------------------
module module_field_io

  implicit none
  ! single_pe version needs:
  integer, save :: m2
  integer, save :: mx2
  integer, save :: recl2
  integer, save :: rec2
  character(5), save :: action2
end

!-------------------------------------------------------------------------------
subroutine field_io(action, m, mx, field, cksum, io_format)  ! read or write g- or sc-field

  use typedef_cksum
  use module_decomp
  use module_function_decl
  use module_field_io
  use module_lattice_io
  use module_vol
  implicit none
  INCLUDE_MPIF_H

  character(len = *) :: action
  integer            :: m, mx
  type(type_cksum)   :: cksum(0:LT - 1)
  integer            :: io_format

  REAL :: field(m, 0:mx - 1, 0:NY - 1, 0:NZ - 1, 0:NT - 1)

  REAL :: buffer(0:(m * mx * NPE(1))-1, 0:(NY * NPE(2))-1)

  FILENAME           :: file
  integer            :: i_pe(DIM)
  integer, external  :: i_global
  integer            :: x, y, z, t, t_global, me, pe, size, rec, recl
  integer            :: pe_x, pe_y, pe_z, pe_t
  integer            :: tt, pe_tt, pe_io
  integer            :: status(MPI_STATUS_SIZE), amode, fh, ierror
  integer            :: count, block_length, stride, buf_type
  integer(MPI_OFFSET_KIND) :: offset
  logical            :: io_pe
  INT8               :: size_field
  CHECK_SUM          :: check_sum(2), n_bytes
  character(128)     :: msg


  count        = NY
  block_length = m * mx
  stride       = block_length * NPE(1)

  size         = block_length * NY               ! words in send/recv
  size_field   = block_length * NY * NZ * NT     ! words in "field"
  n_bytes      = size * NPE(1) * NPE(2) * RKIND  ! bytes in "buffer"
  recl         = n_bytes                         ! cast to standard integer

  ASSERT(mod(recl, RECL_UNIT) == 0)
  recl         = recl / RECL_UNIT

  i_pe         = decomp%std%i_pe                 ! pe coordinates
  io_pe        = (i_pe(1) == 0 .and. i_pe(2) == 0 .and. i_pe(3) == 0) ! am I doing IO?

  m2           = m
  mx2          = mx
  recl2        = recl
  rec2         = 0
  action2      = action

  call mpi_type_vector(count, block_length, stride, BQCD_REAL, buf_type, ierror)
  call mpi_type_commit(buf_type, ierror)
  
  if (action == "write") call swap_endian8(size_field, field)

  select case (io_format)
  case(2)
     file = cksum(0)%file
     if (action == "read")  amode = MPI_MODE_RDONLY
     if (action == "write") amode = MPI_MODE_WRONLY + MPI_MODE_CREATE
     call mpi_file_open(MPI_COMM_WORLD, trim(file), amode, MPI_INFO_NULL, fh, ierror)
     call mpi_file_set_errhandler(fh, MPI_ERRORS_ARE_FATAL, ierror)
  end select

  pe_t = i_pe(4)
  do t = 0, NT - 1
     t_global = i_global(t, NT, i_pe(4))
     
     select case (io_format)
     case(1)
        if (io_pe) then
           file = cksum(t_global)%file
           open(UCONF, file = trim(file), action = action, &
                form = "unformatted",  access = "direct", recl = recl)
        endif
     case(2)
        CHECK(file == cksum(t_global)%file)
        offset = n_bytes * LZ * t_global
        if (io_pe) call mpi_file_seek(fh, offset, MPI_SEEK_SET, ierror)
     end select
     
     rec = 0
     call cksum_init()
     
     do pe_z = 0, NPE(3) - 1
        do z = 0, NZ - 1
           rec = rec + 1
           
           if (io_pe .and. action == "read") then
              select case (io_format)
              case(1)
                 read(UCONF, rec = rec) buffer
              case(2)
                 call mpi_file_read(fh, buffer, int(n_bytes), MPI_BYTE, status, ierror) 
              end select
              call cksum_add(buffer, n_bytes)
           endif
           
           do pe_y = 0, NPE(2) - 1
           do pe_x = 0, NPE(1) - 1

              y = count * pe_y
              x = block_length * pe_x

              call field_io_pes(pe, pe_io, (/pe_x, pe_y, pe_z, pe_t/))

              if (io_pe) then
                 CHECK(my_pe() == pe_io)
              endif      

              if (my_pe() == pe .and. my_pe() == pe_io) then
                 call field_io_seq(action, count, block_length, stride, &
                                   field(1,0,0,z,t), buffer(x,y))
              else
                 if (action == "read") then
                    if (my_pe() == pe_io) then
                       call mpi_ssend(buffer(x,y), 1, buf_type, &
                                      pe, 0, MPI_COMM_WORLD, ierror)
                    endif
                    if (my_pe() == pe) then
                       call mpi_recv(field(1,0,0,z,t), size, BQCD_REAL, &
                                     pe_io, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
                    endif
                 else
                    if (my_pe() == pe_io) then
                       call mpi_recv(buffer(x,y), 1, buf_type, &
                                     pe, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
                    endif
                    if (my_pe() == pe) then
                       call mpi_ssend(field(1,0,0,z,t), size, BQCD_REAL, &
                                      pe_io, 0, MPI_COMM_WORLD, ierror)
                    endif
                 endif
              endif
              
           enddo
           enddo

           if (io_pe .and. action == "write") then
              select case (io_format)
              case(1)
                 write(UCONF, rec = rec) buffer
              case(2)
                 call mpi_file_write(fh, buffer, int(n_bytes), MPI_BYTE, status, ierror) 
              end select
              call cksum_add(buffer, n_bytes)
           endif
        enddo
     enddo

     select case (io_format)
     case(1)
        if (io_pe) close(UCONF)
     end select

     if (io_pe) then
        call cksum_get(check_sum(1), check_sum(2))

        if (action == "read") then

           if (check_sum(1) /= cksum(t_global)%sum) then
              write(msg, "(3a,i0)") "field_io(): check sum error in file " &
                   , trim(file) &
                   , " time-slice " &
                   , t_global
              call die(trim(msg))
           endif

        else
           
           if (my_pe() == 0) then
              cksum(t_global)%sum = check_sum(1)
              cksum(t_global)%bytes = check_sum(2)
              do pe_tt = 1, NPE(4) - 1
                 tt = i_global(t, NT, pe_tt)
                 call mpi_recv(check_sum, 2, BQCD_CHECK_SUM, &
                      MPI_ANY_SOURCE, tt, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierror)
                 cksum(tt)%sum = check_sum(1)
                 cksum(tt)%bytes = check_sum(2)
              enddo
           else
              call mpi_ssend(check_sum, 2, BQCD_CHECK_SUM, 0, t_global, &
                   MPI_COMM_WORLD, ierror)
           endif
        endif
     endif
  enddo

  select case (io_format)
  case(2)
     call mpi_file_close(fh, ierror)   
  end select

  call swap_endian8(size_field, field)
  call mpi_type_free(buf_type, ierror)
end

!-------------------------------------------------------------------------------
subroutine field_io_seq(action, count, block_length, stride, field, buffer)

  use module_lattice_io
  use module_vol
  implicit none

  character(len = *) :: action
  integer            :: count, block_length, stride
  REAL               :: field(*)
  REAL               :: buffer(*)
  integer            :: i, j, x, y

  i = 0
  j = 0
  do y = 1, count
     do x = 1, block_length
        i = i + 1
        if (action == "read") then
           field(i) = buffer(j + x)
        else
           buffer(j + x) = field(i)
        endif
     enddo
     j = j + stride
  enddo

end

!-------------------------------------------------------------------------------
subroutine field_io_pes(pe, pe_io, x_std)

  use module_function_decl
  use module_lattice  ! in contrast to the calling routine !!
  implicit none
  integer, intent(out) :: pe, pe_io
  integer, intent(in)  :: x_std(DIM)
  integer              :: x_act(DIM), x_std_io(DIM), x_act_io(DIM)

  x_std_io(1) = 0
  x_std_io(2) = 0
  x_std_io(3) = 0
  x_std_io(4) = x_std(4)

  x_act(1) = x_std(gamma_index(1))
  x_act(2) = x_std(gamma_index(2))
  x_act(3) = x_std(gamma_index(3))
  x_act(4) = x_std(gamma_index(4))

  x_act_io(1) = x_std_io(gamma_index(1))
  x_act_io(2) = x_std_io(gamma_index(2))
  x_act_io(3) = x_std_io(gamma_index(3))
  x_act_io(4) = x_std_io(gamma_index(4))

  pe    = coord2pe(x_act)
  pe_io = coord2pe(x_act_io)

end

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