PROGRAM pingpong

      IMPLICIT NONE

      include "mpif.h"

      INTEGER proc_A
      PARAMETER(proc_A=0)

      INTEGER proc_B
      PARAMETER(proc_B=1)

      INTEGER ierror, rank

C     *----------------*
C     * Initialize MPI *
C     *----------------*

      CALL MPI_INIT(ierror)

C     *--------------------------*
C     * Get my process ID number *
C     *--------------------------*

      CALL MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierror)


      IF (rank .EQ. proc_A) THEN
        CALL processor_A()
      ELSE IF (rank .EQ. proc_B) THEN
        CALL processor_B()
      END IF

C     *--------------*/
C     * Finalize MPI */
C     *--------------*/

      CALL MPI_FINALIZE(ierror)

      END

      SUBROUTINE processor_A()
      IMPLICIT NONE

      include "mpif.h"

      INTEGER ping
      PARAMETER(ping=101)
      INTEGER pong
      PARAMETER(pong=101)

      INTEGER proc_A
      PARAMETER(proc_A=0)

      INTEGER proc_B
      PARAMETER(proc_B=1)

      INTEGER i, ierror
      INTEGER status(MPI_STATUS_SIZE)

      DOUBLE PRECISION start, finish, time

      REAL*4 buffer(10001)
      COMMON /data/ buffer

      INTEGER length

      WRITE(*,25)
 25   FORMAT('length   time/message (sec)   transfer rate (byte/sec)')

C     *---------------------------------*
C     * Process A sets the message size *
C     *---------------------------------*

      DO length = 1, 10001, 1000

C     *-----------------------------------------------------*
C     * Get the start time for the pingpong message passing *
C     *-----------------------------------------------------*

      start = MPI_WTIME()

C     *--------------------------------------------------------------*
C     * Process A sends and then receives the message back 100 times *
C     *--------------------------------------------------------------*

      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)

      END DO

C     *------------------------------------------------------*/
C     * Get the finish time for the pingpong message passing */
C     *------------------------------------------------------*/

      finish = MPI_WTIME()

      time = finish - start

      WRITE(*,50) length, time/200., REAL(2 * 4 * 100 * length)/time
 50   FORMAT(i5,8x,f10.8,13x,f14.2)

      END DO

      RETURN
      END

      SUBROUTINE processor_B()
      IMPLICIT NONE

      include "mpif.h"

      INTEGER ping
      PARAMETER(ping=101)

      INTEGER pong
      PARAMETER(pong=101)

      INTEGER proc_A
      PARAMETER(proc_A=0)

      INTEGER proc_B
      PARAMETER(proc_B=1)

      INTEGER i, ierror
      INTEGER status(MPI_STATUS_SIZE)

      REAL*4 buffer(10001)
      COMMON /data/ buffer

      INTEGER length

C     *---------------------------------*/
C     * Process B sets the message size */
C     *---------------------------------*/

      DO length = 1, 10001, 1000

C     *--------------------------------------------------------------*/
C     * Process B receives and then sends the message back 100 times */
C     *--------------------------------------------------------------*/

        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)

        END DO

      END DO

      RETURN
      END