! -*- Mode: Fortran; -*-
!
!  (C) 2014 by Argonne National Laboratory.
!  See COPYRIGHT in top-level directory.
!
program main
use mpi_f08

implicit none
!include 'mpif.h'

! Fortran 2008 equivalent of src/mpi/romio/test/coll_test.c

integer FILESIZE
parameter (FILESIZE=32*32*32*4)

! A 32^3 array. For other array sizes, change FILESIZE above and
! array_of_gsizes below.

! Uses collective I/O. Writes a 3D block-distributed array to a file
! corresponding to the global array in row-major (C) order, reads it
! back, and checks that the data read is correct.

! Note that the file access pattern is noncontiguous.

integer i, ndims, array_of_gsizes(3)
integer order, intsize, nprocs, j, array_of_distribs(3)
integer array_of_dargs(3), array_of_psizes(3)
integer readbuf(FILESIZE), writebuf(FILESIZE), bufcount
integer mynod, tmpbuf(FILESIZE), array_size, argc
integer ierr
character*256 str   ! used to store the filename
integer errs, toterrs
integer(MPI_OFFSET_KIND) :: disp

type(MPI_Datatype) ::  newtype
type(MPI_Status) :: status
type(MPI_Request) :: request
type(MPI_File) :: fh

errs = 0
str = "iotest.txt"

call MPI_INIT(ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mynod, ierr)

! create the distributed array filetype

ndims = 3
order = MPI_ORDER_FORTRAN

array_of_gsizes(1) = 32
array_of_gsizes(2) = 32
array_of_gsizes(3) = 32

array_of_distribs(1) = MPI_DISTRIBUTE_BLOCK
array_of_distribs(2) = MPI_DISTRIBUTE_BLOCK
array_of_distribs(3) = MPI_DISTRIBUTE_BLOCK

array_of_dargs(1) = MPI_DISTRIBUTE_DFLT_DARG
array_of_dargs(2) = MPI_DISTRIBUTE_DFLT_DARG
array_of_dargs(3) = MPI_DISTRIBUTE_DFLT_DARG

do i=1, ndims
   array_of_psizes(i) = 0
end do

call MPI_DIMS_CREATE(nprocs, ndims, array_of_psizes, ierr)

call MPI_TYPE_CREATE_DARRAY(nprocs, mynod, ndims,   &
     array_of_gsizes, array_of_distribs, array_of_dargs,  &
     array_of_psizes, order, MPI_INTEGER, newtype, ierr)

call MPI_TYPE_COMMIT(newtype, ierr)

! initialize writebuf

call MPI_TYPE_SIZE(newtype, bufcount, ierr)
call MPI_TYPE_SIZE(MPI_INTEGER, intsize, ierr)
bufcount = bufcount/intsize
do i=1, bufcount
   writebuf(i) = 1
end do

do i=1, FILESIZE
   tmpbuf(i) = 0
end do

call MPI_IRECV(tmpbuf, 1, newtype, mynod, 10, MPI_COMM_WORLD, request, ierr)
call MPI_SEND(writebuf, bufcount, MPI_INTEGER, mynod, 10, MPI_COMM_WORLD, ierr)
call MPI_WAIT(request, status, ierr)

j = 1
array_size = array_of_gsizes(1) * array_of_gsizes(2) * array_of_gsizes(3)
do i=1, array_size
   if (tmpbuf(i) .ne. 0) then
      writebuf(j) = i
      j = j + 1
   end if
end do

! end of initialization

! write the array to the file

call MPI_FILE_OPEN(MPI_COMM_WORLD, str, MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)

disp = 0
call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", MPI_INFO_NULL, ierr)
call MPI_FILE_IWRITE_ALL(fh, writebuf, bufcount, MPI_INTEGER, request, ierr)
call MPI_WAIT(request, status, ierr)
call MPI_FILE_CLOSE(fh, ierr)

!now read it back

call MPI_FILE_OPEN(MPI_COMM_WORLD, str, MPI_MODE_CREATE+MPI_MODE_RDWR, MPI_INFO_NULL, fh, ierr)

call MPI_FILE_SET_VIEW(fh, disp, MPI_INTEGER, newtype, "native", MPI_INFO_NULL, ierr)
call MPI_FILE_IREAD_ALL(fh, readbuf, bufcount, MPI_INTEGER, request, ierr)
call MPI_WAIT(request, status, ierr)
call MPI_FILE_CLOSE(fh, ierr)

! check the data read
do i=1, bufcount
   if (readbuf(i) .ne. writebuf(i)) then
      errs = errs + 1
       print *, 'Node ', mynod, '  readbuf ', readbuf(i),  &
          '  writebuf ', writebuf(i), '  i', i
   end if
end do

call MPI_TYPE_FREE(newtype, ierr)

if (mynod .eq. 0) then
    call MPI_FILE_DELETE(str, MPI_INFO_NULL, ierr)
    if (ierr .ne. MPI_SUCCESS) then
        errs = errs + 1
    endif
endif

call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr )

if (mynod .eq. 0) then
  if( toterrs .gt. 0 ) then
     print *, 'Found ', toterrs, ' errors'
  else
     print *, ' No Errors'
  endif
endif

call MPI_FINALIZE(ierr)

stop
end