Personal tools

Difference between revisions of "Ping"

From MohidWiki

Jump to: navigation, search
Line 2: Line 2:
  
 
!        IST/MARETEC, Water Modelling Group, Mohid modelling system
 
!        IST/MARETEC, Water Modelling Group, Mohid modelling system
 +
 
!------------------------------------------------------------------------------
 
!------------------------------------------------------------------------------
 +
 
!
 
!
 +
 
! TITLE        : ping
 
! TITLE        : ping
 +
 
! PROJECT      : Example of the actor model using Fortran and MPI
 
! PROJECT      : Example of the actor model using Fortran and MPI
 +
 
! URL          : http://www.mohid.com
 
! URL          : http://www.mohid.com
 +
 
! AFFILIATION  : IST/MARETEC, Marine Modelling Group
 
! AFFILIATION  : IST/MARETEC, Marine Modelling Group
 +
 
! DATE          : Nov 2014
 
! DATE          : Nov 2014
 +
 
! REVISION      : Rciardo Miranda - v1.0
 
! REVISION      : Rciardo Miranda - v1.0
 +
 
!
 
!
 +
 
!------------------------------------------------------------------------------
 
!------------------------------------------------------------------------------
 +
 
!
 
!
 +
 
!This program is free software; you can redistribute it and/or
 
!This program is free software; you can redistribute it and/or
 +
 
!modify it under the terms of the GNU General Public License
 
!modify it under the terms of the GNU General Public License
 +
 
!version 2, as published by the Free Software Foundation.
 
!version 2, as published by the Free Software Foundation.
 +
 
!
 
!
 +
 
!This program is distributed in the hope that it will be useful,
 
!This program is distributed in the hope that it will be useful,
 +
 
!but WITHOUT ANY WARRANTY; without even the implied warranty of
 
!but WITHOUT ANY WARRANTY; without even the implied warranty of
 +
 
!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +
 
!GNU General Public License for more details.
 
!GNU General Public License for more details.
 +
 
!
 
!
 +
 
!You should have received a copy of the GNU General Public License
 
!You should have received a copy of the GNU General Public License
 +
 
!along with this program; if not, write to the Free Software
 
!along with this program; if not, write to the Free Software
 +
 
!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 +
 
!
 
!
 +
 
!------------------------------------------------------------------------------
 
!------------------------------------------------------------------------------
 +
 
!
 
!
 +
 
! Compile:
 
! Compile:
 +
 
! mpif90 -o /myDirectory/projects/lang/fortran/MPI/pingPong/ping  /myDirectory/projects/lang/fortran/MPI/pingPong/moduleMPImanagemnt.f90  /myDirectory/projects/lang/fortran/MPI/pingPong/ping.f90
 
! mpif90 -o /myDirectory/projects/lang/fortran/MPI/pingPong/ping  /myDirectory/projects/lang/fortran/MPI/pingPong/moduleMPImanagemnt.f90  /myDirectory/projects/lang/fortran/MPI/pingPong/ping.f90
 +
 
!
 
!
 +
 
! Run:
 
! Run:
 +
 
! /opt/mpich/bin/mpiexec -n 1 /myDirectory/projects/lang/fortran/MPI/pingPong/pong : -n  /myDirectory/projects/lang/fortran/MPI/pingPong/ping
 
! /opt/mpich/bin/mpiexec -n 1 /myDirectory/projects/lang/fortran/MPI/pingPong/pong : -n  /myDirectory/projects/lang/fortran/MPI/pingPong/ping
  

Revision as of 18:12, 30 November 2014

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

! IST/MARETEC, Water Modelling Group, Mohid modelling system

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

!

! TITLE  : ping

! PROJECT  : Example of the actor model using Fortran and MPI

! URL  : http://www.mohid.com

! AFFILIATION  : IST/MARETEC, Marine Modelling Group

! DATE  : Nov 2014

! REVISION  : Rciardo Miranda - v1.0

!

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

!

!This program is free software; you can redistribute it and/or

!modify it under the terms of the GNU General Public License

!version 2, as published by the Free Software Foundation.

!

!This program is distributed in the hope that it will be useful,

!but WITHOUT ANY WARRANTY; without even the implied warranty of

!MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

!GNU General Public License for more details.

!

!You should have received a copy of the GNU General Public License

!along with this program; if not, write to the Free Software

!Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

!

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

!

! Compile:

! mpif90 -o /myDirectory/projects/lang/fortran/MPI/pingPong/ping /myDirectory/projects/lang/fortran/MPI/pingPong/moduleMPImanagemnt.f90 /myDirectory/projects/lang/fortran/MPI/pingPong/ping.f90

!

! Run:

! /opt/mpich/bin/mpiexec -n 1 /myDirectory/projects/lang/fortran/MPI/pingPong/pong : -n /myDirectory/projects/lang/fortran/MPI/pingPong/ping

program ping

   use mpi
   use moduleMPImanagemnt
   implicit none
   integer, parameter :: UNDEFINED   =-99
   integer, parameter :: SUCCESS     = 0
   integer, parameter :: NULL_INT    =-999999
   type T_pingPong
       integer :: myMPI_id      = NULL_INT
       logical :: hasBall       =.FALSE.
       logical :: gameON        =.TRUE.
       integer :: counting      = NULL_INT
       integer :: otherCounting = NULL_INT
       integer :: otherMPI_id   = NULL_INT
   end type T_pingPong
   call main()
   contains
   !---------------------------------------------------------------------------
   subroutine main()
       type(T_pingPong), pointer :: pingPong
       integer :: STAT_CALL
       STAT_CALL = UNDEFINED
       pingPong => constructPingPong()
       STAT_CALL = startGame(pingPong)

if1 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "subroutine main, error calling startGame, ERR01"
       end if if1
       call loop(pingPong)
       call EXIT(SUCCESS)
   end subroutine main
   !---------------------------------------------------------------------------
   function constructPingPong()
       type(T_pingPong), pointer   :: constructPingPong
       type(T_pingPong), pointer   :: newPingPong
       allocate(newPingPong)
       newPingPong%myMPI_id = startMPI(newPingPong)
       constructPingPong => newPingPong
   end function constructPingPong
   !---------------------------------------------------------------------------
   integer function startGame(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       integer                     :: counting
       integer,dimension(8)        :: values
       integer                     :: sec, rand, aux, I
       STAT_CALL = UNDEFINED
       call DATE_AND_TIME(VALUES=values)
       sec = values(7)
       call SRAND(sec)
       aux = rand(0)

do1 : do I = -10, aux

           counting  = MAX(5, rand(0) / 100000)
       end do do1
       STAT_CALL = setCounting(pingPong, counting = counting)

if2 : if (STAT_CALL .NE. SUCCESS) then

               print*, "STAT_CALL = ", STAT_CALL
               stop "function startGame, error calling setCounting, ERR01"
           end if if2
       STAT_CALL = sendBall1(pingPong)

if3 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function startGame, error calling sendBall1, ERR02"
       end if if3
       startGame = SUCCESS
   end function startGame
   !---------------------------------------------------------------------------
   integer function startMPI(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL, myMPI_id, numprocs
       STAT_CALL = UNDEFINED
       myMPI_id  = NULL_INT
       numprocs  = NULL_INT
       call MPI_INIT(IERROR = STAT_CALL)

if1 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function startMPI, error calling MPI_INIT, ERR01"
       end if if1
       call MPI_COMM_RANK(MPI_COMM_WORLD,                             &
                          myMPI_id,                                   &
                          IERROR = STAT_CALL)

if2 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function startMPI, error calling MPI_COMM_RANK, ERR02.1"
       end if if2
       STAT_CALL = setMyMPI_id(pingPong, myMPI_id)

if21 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function startMPI, error calling setMyMPI_id, ERR02.2"
       end if if21
       call MPI_COMM_SIZE(MPI_COMM_WORLD,                               &
                          numprocs,                                     &
                          IERROR = STAT_CALL)

if3 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function startMPI, error calling MPI_COMM_SIZE, ERR03"
       end if if3
       print *, 'Process ', myMPI_id, ' of ', numprocs, ' is alive'

if5 : if (getMyMPI_id(pingPong) .EQ. 0) then

           STAT_CALL = setOtherMPI_id(pingPong, otherMPI_id = 1)

if51 : if (STAT_CALL .NE. SUCCESS) then

               print*, "STAT_CALL = ", STAT_CALL
               stop "function startMPI, error calling setOtherMPI_id, ERR05"
           end if if51
       else if (getMyMPI_id(pingPong) .EQ. 1) then if5
           STAT_CALL = setOtherMPI_id(pingPong, otherMPI_id = 0)

if52 : if (STAT_CALL .NE. SUCCESS) then

               print*, "STAT_CALL = ", STAT_CALL
               stop "function startMPI, error calling setOtherMPI_id, ERR06"
           end if if52
       else if5
           stop "function startMPI, ERR07"
       end if if5
       startMPI = myMPI_id
   end function startMPI
   !---------------------------------------------------------------------------
   integer function getCounting(pingPong)
       type(T_pingPong), pointer   :: pingPong
       getCounting = pingPong%counting
   end function getCounting
   !---------------------------------------------------------------------------
   integer function getOtherCounting(pingPong)
       type(T_pingPong), pointer   :: pingPong
       getOtherCounting = pingPong%otherCounting
   end function getOtherCounting
   !---------------------------------------------------------------------------
   integer function getMyMPI_id(pingPong)
       type(T_pingPong), pointer   :: pingPong
       getMyMPI_id = pingPong%myMPI_id
   end function getMyMPI_id
   !---------------------------------------------------------------------------
   integer function getOtherMPI_id(pingPong)
       type(T_pingPong), pointer   :: pingPong
       getOtherMPI_id = pingPong%otherMPI_id
   end function getOtherMPI_id
   !---------------------------------------------------------------------------
   integer function setOtherCounting(pingPong, otherCounting)
       type(T_pingPong), pointer   :: pingPong
       integer, intent(IN)         :: otherCounting
       pingPong%otherCounting = otherCounting
       setOtherCounting = SUCCESS
   end function setOtherCounting
   !---------------------------------------------------------------------------
   integer function setCounting(pingPong, counting)
       type(T_pingPong), pointer   :: pingPong
       integer, intent(IN)         :: counting
       pingPong%counting = counting
       setCounting = SUCCESS
   end function setCounting
   !---------------------------------------------------------------------------
   integer function decreaseCounting(pingPong)
       type(T_pingPong), pointer   :: pingPong
       pingPong%counting = getCounting(pingPong)-1
       decreaseCounting = SUCCESS
   end function decreaseCounting
   !---------------------------------------------------------------------------
   integer function setMyMPI_id(pingPong, myMPI_id)
       type(T_pingPong), pointer   :: pingPong
       integer, intent(IN)         :: myMPI_id
       pingPong%myMPI_id = myMPI_id
       setMyMPI_id = SUCCESS
   end function setMyMPI_id
   !---------------------------------------------------------------------------
   integer function setOtherMPI_id(pingPong, otherMPI_id)
       type(T_pingPong), pointer   :: pingPong
       integer, intent(IN)         :: otherMPI_id
       pingPong%otherMPI_id = otherMPI_id
       setOtherMPI_id = SUCCESS
   end function setOtherMPI_id
   !---------------------------------------------------------------------------
   integer function setHasBall(pingPong)
       type(T_pingPong), pointer   :: pingPong
       pingPong%hasBall =.TRUE.
       setHasBall = SUCCESS
   end function setHasBall
   !---------------------------------------------------------------------------
   integer function setHasNoBall(pingPong)
       type(T_pingPong), pointer   :: pingPong
       pingPong%hasBall =.FALSE.
       setHasNoBall = SUCCESS
   end function setHasNoBall
   !---------------------------------------------------------------------------
   integer function setGameOFF(pingPong)
       type(T_pingPong), pointer   :: pingPong
       pingPong%gameON =.FALSE.
       setGameOFF = SUCCESS
   end function setGameOFF
   !---------------------------------------------------------------------------
   recursive subroutine loop(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       integer                     :: STATUS(MPI_STATUS_SIZE)
       STAT_CALL = UNDEFINED
       call MPI_PROBE(MPI_ANY_SOURCE,                                          &
                      MPI_ANY_TAG,                                             &
                      MPI_COMM_WORLD,                                          &
                      STATUS,                                                  &
                      STAT_CALL)

if25 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "subroutine loop, error calling MPI_PROBE, ERR01"
       end if if25

if41 : if (STATUS(MPI_SOURCE) .EQ. getOtherMPI_id(pingPong)) then if42 : if (STATUS(MPI_TAG) .EQ. getMsgPlayBall3Tag()) then

               STAT_CALL = receiveBall(pingPong, STATUS(MPI_TAG))

if4 : if (STAT_CALL .NE. SUCCESS) then

                   print*, "STAT_CALL = ", STAT_CALL
                   stop "subroutine loop, error calling receiveBall, ERR02"
               end if if4
           else if (STATUS(MPI_TAG) .EQ. getMsgEndGameTag()) then if42
               STAT_CALL = killPingPong(pingPong)

if2 : if (STAT_CALL .NE. SUCCESS) then

                   print*, "STAT_CALL = ", STAT_CALL
                   stop "subroutine main, error calling killPingPong, ERR02"
               end if if2
           end if if42
       end if if41


       if (pingPong%gameON) call loop(pingPong)
   end subroutine loop
   !---------------------------------------------------------------------------
   integer function receiveBall(pingPong, msgTag)
       type(T_pingPong), pointer   :: pingPong
       integer, intent(IN)         :: msgTag
       integer                     :: STATUS(MPI_STATUS_SIZE)
       integer                     :: counting
       integer                     :: STAT_CALL
       integer                     :: i1, i2
       STAT_CALL  = UNDEFINED
       counting   = NULL_INT
       call MPI_RECV(counting,                                                 &
                     1,                                                        &
                     MPI_INTEGER,                                              &
                     getOtherMPI_id(pingPong),                                 &
                     getMsgPlayBall3Tag(),                                     &
                     MPI_COMM_WORLD,                                           &
                     STATUS,                                                   &
                     STAT_CALL)

if5 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function receiveBall, error calling MPI_RECV, ERR01b"
       end if if5
       STAT_CALL = setOtherCounting(pingPong, otherCounting = counting)

if6 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function receiveBall, error calling setOtherCounting, ERR04"
       end if if6
       print*, "ping, receiveBall getMyMPI_id =", getMyMPI_id(pingPong), &
               "getCounting =", getCounting(pingPong),                   &
               "getOtherCounting =", getOtherCounting(pingPong)
       call doSomething()

if71 : if (getCounting(pingPong) .GT. 0) then if70 : if ( mod(getCounting(pingPong), 2) .EQ. 0) then

               STAT_CALL = sendBall1(pingPong)

if7 : if (STAT_CALL .NE. SUCCESS) then

                   print*, "STAT_CALL = ", STAT_CALL
                   stop "function receiveBall, error calling sendBall1, ERR01"
               end if if7
           else if ((mod(getCounting(pingPong), 3) .EQ. 0) .AND.         &
                    (mod(getCounting(pingPong), 2) .NE. 0)) then if70
               STAT_CALL = sendBall2(pingPong)

if75 : if (STAT_CALL .NE. SUCCESS) then

                   print*, "STAT_CALL = ", STAT_CALL
                   stop "function receiveBall, error calling sendBall2, ERR01"
               end if if75
           else if70
               STAT_CALL = sendBall3(pingPong)

if76 : if (STAT_CALL .NE. SUCCESS) then

                   print*, "STAT_CALL = ", STAT_CALL
                   stop "function receiveBall, error calling sendBall3, ERR01"
               end if if76
           end if if70
       else if71
           ! Program terminates because there are no more plays
           STAT_CALL = sendKillGame(pingPong)

if3 : if (STAT_CALL .NE. SUCCESS) then

               print*, "STAT_CALL = ", STAT_CALL
               stop "subroutine main, error calling killPingPong, ERR02"
           end if if3
           STAT_CALL = killPingPong(pingPong)

if2 : if (STAT_CALL .NE. SUCCESS) then

               print*, "STAT_CALL = ", STAT_CALL
               stop "subroutine main, error calling killPingPong, ERR03"
           end if if2
       end if if71
       receiveBall = SUCCESS
   end function receiveBall
   !---------------------------------------------------------------------------
   subroutine doSomething
       integer                     :: i,j,k, res1, res2, res3
       call sleep(10)

do1 : do i=1,1000 do2 : do j=1,1000 do3 : do k=1,1000

           res1=i*j+j/(k**2)*(-1.0)
           res2=i*j+j/(k**2)*(-21.0)
           res3=MAX(res1, res2)
       end do do3
       end do do2
       end do do1
   end subroutine doSomething
   !---------------------------------------------------------------------------
   integer function sendBall1(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       STAT_CALL  = UNDEFINED
       STAT_CALL = decreaseCounting(pingPong)

if1 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall1, error calling decreaseCounting, ERR01"
       end if if1
       call MPI_SEND(getCounting(pingPong),                                    &
                     1,                                                        &
                     MPI_INTEGER,                                              &
                     getOtherMPI_id(pingPong),                                 &
                     getMsgPlayBall1Tag(),                                     &
                     MPI_COMM_WORLD,                                           &
                     STAT_CALL)

if16 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall1, error calling MPI_SEND, ERR012"
       end if if16
       sendBall1 = SUCCESS
   end function sendBall1
   !---------------------------------------------------------------------------
   integer function sendBall2(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       STAT_CALL  = UNDEFINED
       STAT_CALL = decreaseCounting(pingPong)

if1 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall2, error calling decreaseCounting, ERR01"
       end if if1
       call MPI_SEND(getCounting(pingPong),                                    &
                     1,                                                        &
                     MPI_INTEGER,                                              &
                     getOtherMPI_id(pingPong),                                 &
                     getMsgPlayBall2Tag(),                                     &
                     MPI_COMM_WORLD,                                           &
                     STAT_CALL)

if16 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall2, error calling MPI_SEND, ERR012"
       end if if16
       sendBall2 = SUCCESS
   end function sendBall2
   !---------------------------------------------------------------------------
   integer function sendBall3(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       STAT_CALL  = UNDEFINED
       STAT_CALL = decreaseCounting(pingPong)

if1 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall3, error calling decreaseCounting, ERR01"
       end if if1
       call MPI_SEND(getCounting(pingPong),                                    &
                     1,                                                        &
                     MPI_INTEGER,                                              &
                     getOtherMPI_id(pingPong),                                 &
                     getMsgPlayBall3Tag(),                                     &
                     MPI_COMM_WORLD,                                           &
                     STAT_CALL)

if16 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendBall3, error calling MPI_SEND, ERR012"
       end if if16
       sendBall3 = SUCCESS
   end function sendBall3
   !---------------------------------------------------------------------------
   integer function sendKillGame(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       STAT_CALL  = UNDEFINED
       call MPI_SEND(NULL_INT,                                                 &
                     1,                                                        &
                     MPI_INTEGER,                                              &
                     getOtherMPI_id(pingPong),                                 &
                     getMsgEndGameTag(),                                       &
                     MPI_COMM_WORLD,                                           &
                     STAT_CALL)

if16 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function sendKillGame, error calling MPI_SEND, ERR01"
       end if if16
       sendKillGame = SUCCESS
   end function sendKillGame
   !---------------------------------------------------------------------------
   integer function killPingPong(pingPong)
       type(T_pingPong), pointer   :: pingPong
       integer                     :: STAT_CALL
       STAT_CALL = UNDEFINED
       STAT_CALL = stopMPI()

if2 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function killPingPong, error calling stopMPI, ERR01"
       end if if2
       print*, "Ping Pong Terminated, ping"
       STAT_CALL = setGameOFF(pingPong)

if3 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function killPingPong, error calling setGameOFF, ERR01"
       end if if3
       killPingPong = SUCCESS
   end function killPingPong
   !---------------------------------------------------------------------------
   integer function stopMPI()
       integer                     :: STAT_CALL
       STAT_CALL = UNDEFINED
       call MPI_BARRIER(MPI_COMM_WORLD,                               &
                        IERROR = STAT_CALL)

if6 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function stopMPI, error calling MPI_BARRIER, ERR01"
       end if if6
       call MPI_FINALIZE(STAT_CALL)

if2 : if (STAT_CALL .NE. SUCCESS) then

           print*, "STAT_CALL = ", STAT_CALL
           stop "function stopMPI, error calling MPI_FINALIZE, ERR02"
       end if if2
       stopMPI =  SUCCESS
   end function stopMPI

end program ping