!************************************************************************
! * This file has been written as a sample solution to an exercise in a 
! * course given at the Edinburgh Parallel Computing Centre. It is made
! * freely available with the understanding that every copy of this file
! * must include this header and that EPCC takes no responsibility for
! * the use of the enclosed teaching material.
! *
! * Authors:     Joel Malard, Alan Simpson
! *
! * Contact:     epcc-tec@epcc.ed.ac.uk
! *
! * Purpose:     A program to experiment with point-to-point
! *              communications.   
! *
! * Contents:    F90 source code.
! *
! ************************************************************************/

module pingpongdata
  include "mpif.h"
  integer, parameter :: proc_A = 0, &
                        proc_B = 1, &
                        ping   = 101, &
                        pong   = 101, &
                        nmax   = 700000

  real buffer(2*nmax)
end module pingpongdata


program main
  use pingpongdata
  integer ierror, rank, size

  call MPI_Init(ierror)
  call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror)
  
  buffer = 1.0
  if (rank == proc_A) then 
     call processor_A()
  else 
     if (rank == proc_B) call processor_B()
  endif

  call MPI_Finalize(ierror)
  
  stop
end program main


subroutine processor_A( )
  use pingpongdata
  integer i, ierror
  integer status(MPI_STATUS_SIZE)
  real*8 start, finish, ttime
  integer length
  
  write(*, '("Length    Total Time   Transfer Rate(MB/s)")')
  
  length = 1
  do while(length <= nmax)
     start = MPI_Wtime()
     
     do i = 1,100
        call MPI_Ssend(buffer, length, MPI_REAL, proc_B, ping, &
             MPI_COMM_WORLD, ierror)
        call MPI_Recv( buffer, length, MPI_REAL, proc_B, pong,  &
             MPI_COMM_WORLD, status, ierror)
     enddo
     
     finish = MPI_Wtime()
     ttime = finish - start

     write(*, '(i6, "    ",f9.6,"     ",f7.3)')  length, ttime/200.,  &
        (2 * 4 * 100 * length)/(1000000.0*ttime)

     length = 2*length
  enddo
  return
end subroutine processor_A


subroutine processor_B( )
  use pingpongdata
  integer i, ierror
  integer status(MPI_STATUS_SIZE)
  integer length
  
  length = 1
  do while(length <= nmax)

     do i = 1,100
        call MPI_Recv( buffer, length, MPI_REAL, proc_A, ping, &
                         MPI_COMM_WORLD, status, ierror)
        call MPI_Ssend(buffer, length, MPI_REAL, proc_A, pong, &
                         MPI_COMM_WORLD, ierror)
     enddo
     length = 2*length
  enddo

  return
end subroutine processor_B