program foo

!Simple test of inplace gatherv by Ross Walker

  use mpi

  implicit none

  integer, parameter :: array_size = 100
  integer :: rec_array(array_size), send_array(array_size)
 
  integer :: ierr, i
  integer :: mytaskid, numtasks
  integer :: my_array_count, my_array_offset, rec_counts(64), rec_offsets(64)

  call mpi_init(ierr)  
  call mpi_comm_rank(mpi_comm_world, mytaskid, ierr)
  call mpi_comm_size(mpi_comm_world, numtasks, ierr)

  print *,'Hello from rank: ',mytaskid,' of ',numtasks
  call flush(6)
  call mpi_barrier(mpi_comm_world,ierr)

  !Prepare arrays for gatherv
  rec_array(1:array_size) = 0
  send_array(1:array_size) = mytaskid

  !Fill send_array
  my_array_count = array_size / numtasks
  my_array_offset =  ( my_array_count * mytaskid ) + 1 
  print *,'Rank:',mytaskid,' my_array_offset=',my_array_offset, ' my_array_count=',my_array_count
  call flush(6)
  call mpi_barrier(mpi_comm_world,ierr)

  if (mytaskid == 0) then
    do i = 1, numtasks
      rec_counts(i) = my_array_count
      rec_offsets(i) = (my_array_count * (i-1)) + 1
    end do
  end if

  !This should work, send buff and receive buff are different.
  !---------------------------------------------
  !Send each tasks chunk of send array to the receive array on the master
  call mpi_gatherv(send_array(my_array_offset), my_array_count, MPI_INTEGER, rec_array, rec_counts, rec_offsets, MPI_INTEGER, 0, mpi_comm_world, ierr)

  !Write final arrays
  call mpi_barrier(mpi_comm_world,ierr)
  write(10+mytaskid, *) rec_array(1:array_size)
  !---------------------------------------------

  !This SHOULD work - for MPI2 ONLY
  !---------------------------------------------
  !Send each tasks chunk of send array to the send array on the master - using MPI v2 ONLY MPI_IN_PLACE
  !This is MESSY since it needs a different call on the master and the other threads necessitating an 
  !additional if statement. Additionally I see no requirement in the MPI v1 specification of 
  !mpi_gatherv that says send and rec buffers cannot alias each other.
  if (mytaskid==0) then 
    call mpi_gatherv(MPI_IN_PLACE, my_array_count, MPI_INTEGER, send_array, rec_counts, rec_offsets, MPI_INTEGER, 0, mpi_comm_world, ierr)
  else
    call mpi_gatherv(send_array(my_array_offset), my_array_count, MPI_INTEGER, send_array, rec_counts, rec_offsets, MPI_INTEGER, 0, mpi_comm_world, ierr)
  end if

  !Write final arrays
  call mpi_barrier(mpi_comm_world,ierr)
  write(20+mytaskid, *) send_array(1:array_size)
  !---------------------------------------------

  !This will NOT work with mpich2-1.2.1p1 - although it always worked before with EVERY OTHER MPI Implementation
  !---------------------------------------------
  !Send each tasks chunk of send array to the send array on the master
  call mpi_gatherv(send_array(my_array_offset), my_array_count, MPI_INTEGER, send_array, rec_counts, rec_offsets, MPI_INTEGER, 0, mpi_comm_world, ierr)

  !Write final arrays
  call mpi_barrier(mpi_comm_world,ierr)
  write(30+mytaskid, *) send_array(1:array_size)
  !---------------------------------------------

  call MPI_Finalize ( ierr )

end program foo