pong.f - an MP_Lite example

Download pong.f sourcecode?


c-----------------------------------------------------------------------
c     Pong.f was written by Bogdan Vasiliu of Ames Lab.
c     It was converted from a C version by Dave Turner.
c-----------------------------------------------------------------------
      PROGRAM Pong

      IMPLICIT NONE

      INTEGER myproc, nprocs, tag
      INTEGER size, other_node, i, last
      REAL*8 t1, t2, time
      REAL*8 max_rate, min_latency
      REAL*8 a(132000), b(132000)
      REAL*8 mp_time
      INTEGER irid, irid_a, irid_b


c-----------------------------------------------------------------------
c       Init MP_Lite
c-----------------------------------------------------------------------


      CALL MP_Init(0,0)
      CALL MP_Myproc( myproc )
      CALL MP_Nprocs( nprocs )

      min_latency = 10e6
      max_rate = 0.0

      DO i = 1,132000
        a(i) = i
        b(i) = 0.0d0
      ENDDO

      IF( nprocs .NE. 2) STOP'You must choose 2 processors'

      other_node = MOD(myproc + 1, 2)

c     PRINT*,'Hello from ',myproc,' of ',nprocs
      CALL MP_Sync()

c-----------------------------------------------------------------------
c       Timer accuracy test       
c-----------------------------------------------------------------------

      t1 = MP_Time()
   10 t2 = MP_Time()
      IF(t2 .EQ. t1) GOTO 10

      IF(myproc .EQ. 0)THEN
        PRINT*,'Timer accuracy of ',(t2-t1)*1000000, 'usecs'
      ENDIF

c-----------------------------------------------------------------------
c Communications between nodes
c   - Blocking sends and recvs
c   - No guarantee of prepost, so data might pass through the comm buffer
c-----------------------------------------------------------------------

      CALL MP_Enter('Blocking')

      size = 8
      tag = 0

   20 DO i = 1, size/8
        a(i) = i
        b(i) = 0.0
      ENDDO

      last = size/8
      CALL MP_Sync()
      t1 = MP_Time()

      IF(myproc .EQ. 0)THEN
        CALL MP_Send(a, size, other_node, tag)
        tag = tag + 1
        CALL MP_Recv(b, size, other_node, tag)
      ELSE
        CALL MP_Recv(b, size, other_node, tag)
        b(1) = b(1) + 1.0
        IF( last .NE. 1) b(last) = b(last) + 1.0
        tag = tag + 1
        CALL MP_Send(b, size, other_node, tag)
      ENDIF

      t2 = MP_Time()
      time = 1e6 * (t2 - t1)
      CALL MP_Sync()

      IF( (b(1) .NE. 2.0) .OR. (b(last) .NE. last + 1) )THEN
        PRINT*,'ERROR - b[1] = ',b(1),' b[',last,'] = ',b(last)
        STOP
      ENDIF
      DO i = 2, last - 1
        IF( b(i) .NE. i) PRINT*,'ERROR - b[',i,'] = ',b(i)
      ENDDO

      IF( (myproc .EQ. 0) .AND. (time .GT. 0.000001) )THEN

        PRINT 1000,size,' bytes took ',time,' usec (',2.0*size/time,
     &              ' MB/sec)'
 1000   FORMAT(I8, A, F10.1, A, F8.3, A )

        IF(2*size/time .GT. max_rate) max_rate = 2 * size / time
        IF(time / 2 .LT. min_latency) min_latency = time / 2

      ELSE

        IF( myproc .EQ. 0 )THEN
          PRINT*,size,' bytes took less than the timer accuracy'
        ENDIF

      ENDIF

      size = size * 2
      IF(size .LE. 1048576) GOTO 20

      CALL MP_Leave(0.0d0)


c-----------------------------------------------------------------------
c Async communications
c   - Prepost receives to guarantee bypassing the comm buffer
c-----------------------------------------------------------------------

      CALL MP_Enter('Asynchronous ping-pong')

      IF( myproc .EQ. 0 )THEN
        PRINT*,' '
        PRINT*,'Asynchronous ping-pong'
        PRINT*,' '
      ENDIF

      size = 8
   30 DO i = 1, size/8
        a(i) = i
        b(i) = 0.0
      ENDDO
      last = size/8
      tag = tag + 1

      CALL MP_Arecv(b, size, other_node, tag, irid)
      CALL MP_Sync()
      t1 = MP_Time()

      IF(myproc .EQ. 0)THEN
        CALL MP_Send(a, size, other_node, tag)
        CALL MP_Wait(irid)
      ELSE
        CALL MP_Wait(irid)
        b(1) = b(1) + 1.0
        IF( last .NE. 1) b(last) = b(last) + 1.0
        CALL MP_Send(b, size, other_node, tag)
      ENDIF

      t2 = MP_Time()
      time = 1e6 * (t2 - t1)
      CALL MP_Sync()

      IF( (b(1) .NE. 2.0) .OR. (b(last) .NE. last + 1) )THEN
        PRINT*,'ERROR - b[1] = ',b(1),' b[',last,'] = ',b(last)
        STOP
      ENDIF
      DO i = 2, last - 1
        IF( b(i) .NE. i) PRINT*,'ERROR - b[',i,'] = ',b(i)
      ENDDO

      IF( (myproc .EQ. 0) .AND. (time .GT. 0.000001) )THEN
        PRINT 1000,size,' bytes took ',time,' usec (',2.0*size/time,
     &              ' MB/sec)'
        IF(2*size/time .GT. max_rate) max_rate = 2 * size / time

        IF(time / 2 .LT. min_latency) min_latency = time / 2
      ELSE
        IF( myproc .EQ. 0 )THEN
          PRINT*,size,' bytes took less than the timer accuracy'
        ENDIF
      ENDIF

      size = size * 2
      IF(size .LE. 1048576) GOTO 30

      CALL MP_Leave(0.0d0)


c-----------------------------------------------------------------------
c         Bi-directional asynchronous ping-pong
c-----------------------------------------------------------------------

      IF( myproc .EQ. 0 )THEN
        PRINT*,' '
        PRINT*,'Bi-directional asynchronous ping-pong'
        PRINT*,' '
      ENDIF
      CALL MP_Enter('Bi-directional')
      size = 8
      tag = tag + 1

   40 DO i = 1, size/8
        a(i) = i
        b(i) = 0.0
      ENDDO

      last = size/8
      CALL MP_Arecv(b, size, other_node, tag, irid_b)
      CALL MP_Arecv(a, size, other_node, tag+1, irid_a)
      CALL MP_Sync()
      t1 = MP_Time()


      CALL MP_Send(a, size, other_node, tag)
      CALL MP_Wait(irid_b)

      b(1) = b(1) + 1.0
      IF( last .NE. 1) b(last) = b(last) + 1.0
      tag = tag + 1

      CALL MP_Send(b, size, other_node, tag)
      CALL MP_Wait(irid_a)

      t2 = MP_Time()
      time = 1e6 * (t2 - t1)
      CALL MP_Sync()

      IF( (b(1) .NE. 2.0) .OR. (b(last) .NE. last + 1) )THEN
        PRINT*,'ERROR - b[1] = ',b(1),' b[',last,'] = ',b(last)
        STOP
      ENDIF
      DO i = 2, last - 1
        IF( b(i) .NE. i) PRINT*,'ERROR - b[',i,'] = ',b(i)
      ENDDO

      IF( (myproc .EQ. 0) .AND. (time .GT. 0.000001) )THEN

        PRINT 1000,size,' bytes took ',time,' usec (',2.0*size/time,
     &              ' MB/sec)'

        IF(2*size/time .GT. max_rate) max_rate = 2 * size / time
        IF(time / 2 .LT. min_latency) min_latency = time / 2

      ELSE

        IF( myproc .EQ. 0 )THEN
          PRINT*,size,' bytes took less than the timer accuracy'
        ENDIF

      ENDIF

      size = size * 2
      IF(size .LE. 1048576) GOTO 40

      CALL MP_Leave(0.0d0)


c-----------------------------------------------------------------------
c       Max rate, Min latency
c-----------------------------------------------------------------------

      IF( myproc .EQ. 0 )THEN
        PRINT*,' '
        PRINT 1030,'Max rate = ',max_rate,' MB/sec Min latency = ',
     &             min_latency
 1030   FORMAT(A, F10.7, A, F25.12)
        PRINT*,' '
      ENDIF

c-----------------------------------------------------------------------
c       Leave MP_LITE
c-----------------------------------------------------------------------

      CALL MP_Time_Report('pong_f.out')
      CALL MP_Finalize()

      END