! -*- mode: F90 ; mode: font-lock ; column-number-mode: true  -*-
program mpi_pingpong
  use mpi
  implicit none

  integer :: my_rank, num_procs
  integer :: my_data, tag, status(1:MPI_STATUS_SIZE)
  integer :: i,ierror

  !initialise MPI world
  call MPI_init(ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_init'

  !get size (total number of processors) within MPI world
  call MPI_comm_size(MPI_comm_world,num_procs,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_comm_size'

  !get my rank on each different processor within MPI world (0 to num_procs-1)
  call MPI_comm_rank(MPI_comm_world,my_rank,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_comm_rank'

  !initialise data on all processors
  my_data = my_rank
  tag = 23

  !report to user
  if (my_rank==0) then
     print *,' '
     print *,'Starting with all data = rank'
     print *,' '
  end if
  call MPI_barrier(MPI_comm_world,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_barrier after root print'

  do i=0,num_procs-1
     if (i==my_rank) then
        print *,"On processor",my_rank+1,"data before ping=",my_data
     end if
     call MPI_barrier(MPI_comm_world,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_barrier before ping'
  end do

  !PING - send data from processor 0 to processor 1
  if (num_procs<2) stop 'Not enough processors to proceed - aborting'
  if (my_rank == 0) then
     call MPI_SEND(my_data,1,MPI_INTEGER,1,tag,MPI_comm_world,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_SEND from 0 to 1'
  end if
  if (my_rank == 1) then
     call MPI_RECV(my_data,1,MPI_INTEGER,0,MPI_any_tag,MPI_comm_world,status,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_RECV on 1 from 0'
  endif

  !report to user
  if (my_rank==0) then
     print *,' '
     print *,'Finished PING - sent data from 0 to 1'
     print *,' '
  end if
  call MPI_barrier(MPI_comm_world,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_barrier after root print'

  do i=0,num_procs-1
     if (i==my_rank) then
        print *,"On processor",my_rank+1,"data  after ping=",my_data
     end if
     call MPI_barrier(MPI_comm_world,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_barrier after ping'
  end do

  !modify data on all nodes
  my_data=my_rank**2

  !report to user
  if (my_rank==0) then
     print *,' '
     print *,'Modifying data - now data = my_rank**2 on all nodes'
  end if
  call MPI_barrier(MPI_comm_world,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_barrier after root print'

  !PONG - send data from processor 1 to processor 0
  if (my_rank == 0) then
     call MPI_RECV(my_data,1,MPI_INTEGER,1,MPI_any_tag,MPI_comm_world,status,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_RECV on 0 from 1'
  end if
  if (my_rank == 1) then
     call MPI_SEND(my_data,1,MPI_INTEGER,0,tag,MPI_comm_world,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_SEND from 1 to 0'
  endif

  !report to user
  if (my_rank==0) then
     print *,' '
     print *,'Finished PONG - sent data from 1 to 0'
     print *,' '
  end if
  call MPI_barrier(MPI_comm_world,ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_barrier after root print'

  do i=0,num_procs-1
     if (i==my_rank) then
        print *,"On processor",my_rank+1,"data  after pong=",my_data
     end if
     call MPI_barrier(MPI_comm_world,ierror)
     if (ierror/=MPI_success) stop 'Error in MPI_barrier after pong'
  end do

  call MPI_finalize(ierror)
  if (ierror/=MPI_success) stop 'Error in MPI_finalize'

end program mpi_pingpong
