PRACE NPT

!-----------------------------------------------------------!

! Contains the point-to-point pingping mixed mode           !

! OpenMP/MPI benchmarks.                                    !

! This includes: -masteronly pingping                       !

!                -funnelled pingping                        !

!                -multiple pingping                         ! 

!-----------------------------------------------------------!

MODULE pt_to_pt_pingPing

  use parallelEnvironment

  use omp_lib

  use benchmarkSetup

  use output

  implicit none

!Module variables

  integer :: pingRankA, pingRankB !ranks of 2 pingping processes

  integer :: sizeofBuffer

  integer, dimension(:), allocatable :: pingSendBuf, pingRecvBuf

  integer, dimension(:), allocatable :: finalRecvBuf, testBuf

CONTAINS

  !---------------------------------------------------------!

  ! Subroutine: pingPing                                    !

  !                                                         !

  ! Driver subroutine for the pingping benchmark.           !

  !---------------------------------------------------------!

  SUBROUTINE pingPing(benchmarkType)

    integer, intent(in) :: benchmarkType

    integer :: dataSizeIter

    logical :: sameNode

    pingRankA = PPRanks(1)

    pingRankB = PPRanks(2)

    !Check if pingRankA and pingRankB are on the same node

    sameNode = compareProcNames(pingRankA, pingRankB)

    IF (myMPIRank == 0) THEN

       !print message saying if benchmark is inter or intra node

       CALL printNodeReport(sameNode,pingRankA,pingRankB)

       !..then print benchmark report column headings.

       CALL printBenchHeader()

    END IF

    !initialise totalReps to defaultReps

    totalReps = defaultReps

    !Start loop over data sizes

    dataSizeIter = minDataSize !initialise dataSizeIter

    DO WHILE (dataSizeIter <= maxDataSize)

       !set size of buffer

       sizeofBuffer = dataSizeIter * numThreads

       !Allocate space for main data arrays

       CALL allocateData(sizeofBuffer)

       !warm-up for benchmarkType

       IF (benchmarkType == MASTERONLY) THEN

          !Masteronly warmup sweep

          CALL masteronlyPingping(warmUpIters, dataSizeIter)

       ELSE IF (benchmarkType == FUNNELLED) THEN

          !funnelled warmup

          CALL funnelledPingping(warmUpIters, dataSizeIter)

       ELSE IF (benchmarkType == MULTIPLE) THEN

          !perform multiple pinping warmup

          CALL multiplePingping(warmUpIters, dataSizeIter)

       END IF

       !Perform verification test for pingping

       !this is only done by pingRankA and pingRankB

       CALL testPingping(sizeofBuffer, dataSizeIter)

       !Initialise the benchmark

       repsToDo = totalReps

       benchComplete = .false.

       !Execute benchmark until target time is reached

       DO WHILE (benchComplete .NEQV. .true.)

          !Start timer.

          CALL MPI_Barrier(comm, ierr)

          startTime = MPI_Wtime()

          !Execute benchmarkType for repsToDo repetitions

          IF (benchmarkType == MASTERONLY) THEN

             CALL masteronlyPingping(repsToDo, dataSizeIter)

          ELSE IF (benchmarkType == FUNNELLED) THEN

             CALL funnelledPingping(repsToDo, dataSizeIter)

          ELSE IF (benchmarkType == MULTIPLE) THEN

             CALL multiplePingping(repsToDo, dataSizeIter)

          END IF

          !Stop timer.

          CALL MPI_Barrier(comm, ierr)

          finishTime = MPI_Wtime()

          totalTime = finishTime - startTime

          !Test if target time was reached with number of

          !repetitions.

          benchComplete = repTimeCheck(totalTime, repsToDo)

       END DO !End of benchComplete loop

       !Master process sets benchmark results

       IF (myMPIRank == 0) THEN

          CALL setReportParams(dataSizeIter,repsToDo,totalTime)

          CALL printReport()

       END IF

       !Free allocated data

       CALL freeData()

       !Double dataSize and loop again

       dataSizeIter = dataSizeIter * 2

    END DO !End loop over data sizes

  END SUBROUTINE pingPing

  !---------------------------------------------------------!

  !Subroutine: masteronlyPingPing                           !

  !                                                         !

  ! Two processes send a message to each other using the    !

  ! MPI_Isend, MPI_Recv and MPI_Wait routines.              !

  ! Inter-process communication takes place outside of the  !

  ! parallel region.                                        !

  !---------------------------------------------------------!

  SUBROUTINE masteronlyPingping(totalReps, dataSize)

    integer, intent(in) :: totalReps, dataSize

    integer ::  repIter, i

    integer :: destRank

    !set destRank to ID of other process

    IF (myMPIRank == pingRankA) THEN

       destRank = pingRankB

    ELSE IF (myMPIRank == pingRankB) THEN

       destRank = pingRankA

    END IF

    DO repIter = 1, totalReps !loop totalReps times

       IF(myMPIRank == pingRankA .or. myMPIRank == pingRankB) THEN

          !Each thread writes its globalID to pingSendBuf

          !using a PARALLEL DO directive.

!$OMP PARALLEL DO DEFAULT(NONE), &

!$OMP PRIVATE(i), &

!$OMP SHARED(pingSendBuf,dataSize,sizeofBuffer,globalIDarray), &

!$OMP SCHEDULE(STATIC,dataSize)

          DO i = 1, sizeofBuffer

             pingSendBuf(i) = globalIDarray(myThreadID)

          END DO

!$OMP END PARALLEL DO

          !Process calls non-blocking send to start transfer of

          !pingSendBuf to other process.

          CALL MPI_ISend(pingSendBuf, sizeofBuffer, MPI_INTEGER, &

            destRank, tag, comm, requestID, ierr)

       !Process then waits for message from other process.

       CALL MPI_Recv(pingRecvBuf, sizeofBuffer, MPI_INTEGER, &

            destRank, tag, comm, status, ierr)

       !Finish the Send operation with an MPI_Wait

       CALL MPI_Wait(requestID, status, ierr)

       !Each thread under the MPI process now reads its part 

       !of the received buffer.

!$OMP PARALLEL DO DEFAULT(NONE), &

!$OMP PRIVATE(i), &

!$OMP SHARED(finalRecvBuf,dataSize,sizeofBuffer,pingRecvBuf), &

!$OMP SCHEDULE(STATIC,dataSize)

       DO i = 1, sizeofBuffer

          finalRecvBuf(i) = pingRecvBuf(i)

       END DO

!$OMP END PARALLEL DO

    END IF

 END DO !End repetitions loop

END SUBROUTINE masteronlyPingping

  !---------------------------------------------------------!

  !Subroutine: funnelledPingPing                            !

  !                                                         !

  ! Two processes send a message to each other using the    !

  ! MPI_Isend, MPI_Recv and MPI_Wait routines.              !

  ! Inter-process communication takes place inside the      !

  ! OpenMP parallel region.                                 !

  !---------------------------------------------------------!

  SUBROUTINE funnelledPingping(totalReps, dataSize)

    integer, intent(in) :: totalReps, dataSize

    integer :: repIter, i

    integer :: destRank

    !set destRank to ID of other process

    IF (myMPIRank == pingRankA) THEN

       destRank = pingRankB

    ELSE IF (myMPIRank == pingRankB) THEN

       destRank = pingRankA

    END IF

    !Open the parallel region

!$OMP PARALLEL DEFAULT(NONE), &

!$OMP PRIVATE(i,repIter), &

!$OMP SHARED(dataSize,sizeofBuffer,pingSendBuf,globalIDarray), &

!$OMP SHARED(pingRecvBuf,finalRecvBuf,status,requestID,ierr), &

!$OMP SHARED(destRank,comm,myMPIRank,pingRankA,pingRankB,totalReps)

    DO repIter = 1, totalReps !loop totalRep times

       IF(myMPIRank == pingRankA .or. myMPIRank == pingRankB) THEN

          !Each threads write its globalID to its part of

          !pingSendBuf.

!$OMP DO SCHEDULE(STATIC,dataSize)

          DO i = 1,sizeofBuffer

             pingSendBuf(i) = globalIDarray(myThreadID)

          END DO

!$OMP END DO

!Implicit barrier here takes care of necessary synchronisation.

!$OMP MASTER

          !Master thread starts send of buffer

          CALL MPI_Isend(pingSendBuf, sizeofBuffer, MPI_INTEGER,&

               destRank, tag, comm, requestID, ierr)

          !then waits for message from other process.

          CALL MPI_Recv(pingRecvBuf, sizeofBuffer, MPI_INTEGER,&

               destRank, tag, comm, status, ierr)

          !Master thread then completes send using MPI_Wait.

          CALL MPI_Wait(requestID, status, ierr)

!$OMP END MASTER

!Barrier needed to ensure master thread has completed transfer.

!$OMP BARRIER

          !Each thread reads its part of the received buffer

!$OMP DO SCHEDULE(STATIC,dataSize)

          DO i = 1,sizeofBuffer

             finalRecvBuf(i) = pingRecvBuf(i)

          END DO

!$OMP END DO

       END IF

    END DO !End repetitions loop

!$OMP END PARALLEL

  END SUBROUTINE funnelledPingping

  !---------------------------------------------------------!

  ! Subroutine: multiplePingping                            !

  !                                                         !

  ! With this algorithmn multiple threads take place in the !

  ! communication and computation.                          !

  ! Each thread sends its portion of the pingSendBuf to the !

  ! other process using MPI_Isend/ MPI_Recv/ MPI_Wait       !

  ! routines.                                               !

  !---------------------------------------------------------!

  SUBROUTINE multiplePingping(totalReps, dataSize)

    integer, intent(in) :: totalReps, dataSize

    integer :: repIter, i

    integer :: destRank 

    integer :: lBound, uBound

     !set destRank to be ID of other process

    IF (myMPIRank == pingRankA) THEN

       destRank = pingRankB

    ELSE IF (myMPIRank == pingRankB) THEN

       destRank = pingRankA

    END IF

     !Open parallel region

!$OMP PARALLEL DEFAULT(NONE), &

!$OMP PRIVATE(i,lBound,uBound,requestID,status,ierr,repIter), &

!$OMP SHARED(pingSendBuf,pingRecvBuf,finalRecvBuf,sizeofBuffer),&

!$OMP SHARED(destRank,myMPIRank,pingRankA,pingRankB,totalReps),&

!$OMP SHARED(dataSize,globalIDarray,comm)

    DO repIter = 1,totalReps !Loop totalReps times

       IF(myMPIRank == pingRankA .or. myMPIRank == pingRankB) THEN

           !Calculate lower and upper bound of each threads 

           !portion of the data arrays

           lBound = ((myThreadID-1)* dataSize) + 1

           uBound = (myThreadID * dataSize)

           !Each thread writes to its part of pingSendBuf

!$OMP DO SCHEDULE(STATIC,dataSize)

           DO i = 1,sizeofBuffer

              pingSendBuf(i) = globalIDarray(myThreadID)

           END DO

!$OMP END DO NOWAIT

           !Each thread starts send of dataSize items of 

           !pingSendBuf to process with rank = destRank

           CALL MPI_Isend(pingSendBuf(lBound:uBound), dataSize,&

                MPI_INTEGER, destRank, myThreadID, comm,&

                requestID, ierr)

           !Thread then waits for message from destRank with 

           !tag equal to its thread id.

           CALL MPI_Recv(pingRecvBuf(lBound:uBound), dataSize,&

                MPI_INTEGER, destRank, myThreadID, comm,&

                status, ierr)

           !Thread completes send using MPI_Wait

           CALL MPI_Wait(requestID, status, ierr)

           !Each thread reads its part of received buffer.

!$OMP DO SCHEDULE(STATIC,dataSize)

           DO i = 1, sizeofBuffer

              finalRecvBuf(i) = pingRecvBuf(i)

           END DO

!$OMP END DO NOWAIT

        END IF

     END DO !End repetitions loop

!$OMP END PARALLEL

   END SUBROUTINE multiplePingping

  !---------------------------------------------------------!

  ! Subroutine: allocateData                                !

  !                                                         !

  ! Allocate memory for the main data arrays in pingping.   !

  !---------------------------------------------------------!

  SUBROUTINE allocateData(bufferSize)

    integer, intent(in) :: bufferSize

    allocate(pingSendBuf(bufferSize), pingRecvBuf(bufferSize))

    allocate(finalRecvBuf(bufferSize))

  END SUBROUTINE allocateData

  !---------------------------------------------------------!

  ! Subroutine: freeData                                    !

  !                                                         !

  ! Free allocated memory for main data arrays.             !

  !---------------------------------------------------------!

  SUBROUTINE freeData()

    deallocate(pingSendBuf, pingRecvBuf)

    deallocate(finalRecvBuf)

  END SUBROUTINE freeData

  !---------------------------------------------------------!

  ! Subroutine: testPingPing                                !

  !                                                         !

  ! Verifies that the Ping Ping benchmark worked correctly. !

  !---------------------------------------------------------!

  SUBROUTINE testPingPing(sizeofBuffer, dataSize)

    integer, intent(in) :: sizeofBuffer, dataSize

    integer :: otherPingRank, i

    logical :: testFlag, reduceFlag

    !set testFlag to true

    testFlag = .true.

    !Testing only needs to be done by pingRankA & pingRankB

    IF (myMPIRank == pingRankA .or. myMPIRank == pingRankB) THEN

       !allocate space for testBuf

       allocate(testBuf(sizeofBuffer))

       !set the ID of other pingRank

       IF (myMPIRank == pingRankA) THEN

          otherPingRank = pingRankB

       ELSE IF (myMPIRank == pingRankB) THEN

          otherPingRank = pingRankA

       END IF

       !Construct testBuf with correct values

!$OMP PARALLEL DO DEFAULT(NONE), &

!$OMP PRIVATE(i), &

!$OMP SHARED(otherPingRank,numThreads,dataSize), &

!$OMP SHARED(sizeofBuffer,testBuf), &

!$OMP SCHEDULE(STATIC,dataSize)

       DO i = 1, sizeofBuffer

          !calculate globalID of thread expected in finalRecvBuf

          !this is done by using otherPingRank

          testBuf(i) = (otherPingRank * numThreads) + myThreadID

       END DO

!$OMP END PARALLEL DO

       !Compare each element of testBuf and finalRecvBuf

       DO i = 1, sizeofBuffer

          IF (testBuf(i) /= finalRecvBuf(i)) THEN

             testFlag = .false.

          END IF

       END DO

       !free space for testBuf

       deallocate(testBuf)

    END IF !End test loop

    !Reduce testFlag into master with logical AND logical

    CALL MPI_Reduce(testFlag, reduceFlag, 1, MPI_LOGICAL, &

         MPI_LAND, 0, comm, ierr)

    !master sets testOutcome flag

    IF (myMPIRank == 0) THEN

       CALL setTestOutcome(reduceFlag)

    END IF

  END SUBROUTINE testPingPing

END MODULE pt_to_pt_pingPing