
! deadlock.f90

! This program is an example of bad MPI.
!
! This program causes MPI_Send/MPI_Recv to deadlock (freeze up
!   with sender waiting for receiver and vice versa).

      PROGRAM deadlock

          IMPLICIT NONE
          INCLUDE "mpif.h"

          INTEGER,PARAMETER :: executable_cmdlinearg        =      0
          INTEGER,PARAMETER :: should_send_first_cmdlinearg =      1
          INTEGER,PARAMETER :: message_length_cmdlinearg    =      2
          INTEGER,PARAMETER :: number_of_cmdlineargs        =      2
          INTEGER,PARAMETER :: maximum_argument_length      =   1000
          INTEGER,PARAMETER :: maximum_buffer_length        = 800000
          INTEGER,PARAMETER :: minimum_message_length       =      1
          INTEGER,PARAMETER :: maximum_message_length       =  &
     &                             maximum_buffer_length
          INTEGER,PARAMETER :: the_tag                      =    999

!........ MPI_Recv requires the MPI_Status array, which includes the
!........ following fields:
!........   mpi_status.MPI_SOURCE: which rank sent the message to this rank
!........   mpi_status.MPI_TAG: what the tag of the message was
!........   mpi_status.MPI_ERROR: the error code returned by MPI_Recv
!........
!........ Calls to MPI_Recv and related MPI routines require that this
!........ variable be used as an argument.
!........
!........ However, for most such calls in most MPI programs in real life,
!........ no one bothers to check the values of those fields, because the
!........ values of MPI_SOURCE and MPI_TAG have to match what was passed
!........ in to the MPI_Recv routine, and MPI_ERROR will matche the error
!........ code returned by that call to the MPI routine.
!........
!........ The exception would be if the requested source was MPI_ANY_SOURCE
!........ and/or the requested tag was MPI_ANY_TAG.

          INTEGER,DIMENSION(MPI_STATUS_SIZE) :: mpi_status

!........ These arrays are "buffers" (arrays that temporarily contain a
!........ particular piece of data).
!........
!........ Specifically, send_buffer and recv_buffer are used to hold
!........ the message being sent (when this rank is sending) and the
!........ message that was received (when this rank is receiving).

          INTEGER,DIMENSION(maximum_buffer_length) :: send_buffer
          INTEGER,DIMENSION(maximum_buffer_length) :: recv_buffer

!........ A buffer for obtaining command line arguments.

          CHARACTER (LEN=maximum_argument_length) :: argument_buffer

          INTEGER :: rank_to_communicate_with
          INTEGER :: message_length
          INTEGER :: number_of_processes, my_rank
          INTEGER :: mpi_error_code
          LOGICAL :: should_send_first

!........ Start the MPI run.
!........
!........ In ***EVERY*** MPI program, MPI_Init should be the
!........ ***VERY FIRST EXECUTABLE STATEMENT***.

          CALL MPI_Init(mpi_error_code)

!........ What is this process's rank? That is, who am I?

          CALL MPI_Comm_rank(MPI_COMM_WORLD, my_rank, mpi_error_code)

!........ How many processes are being used in this MPI run? That is,
!........ how many of us are there?

          CALL MPI_Comm_size(MPI_COMM_WORLD, number_of_processes,  &
     &                       mpi_error_code)

!........ This particular example program should use exactly
!........ 2 processes.

          IF (number_of_processes /= 2) THEN

              WRITE (0,*) "ERROR: wrong number of processes ",  &
     &            number_of_processes, "."

!............ Exit this MPI run cleanly, via MPI's self-killing routine.

              CALL MPI_Abort(MPI_COMM_WORLD, mpi_error_code,  &
     &                       mpi_error_code)

          END IF !! (number_of_processes /= 2)

!........ Input, from standard input, the flag for whether to send
!........ first, and the size of the message being communicated.

          IF (IARGC() < number_of_cmdlineargs) THEN

              WRITE (0,*)                                      &
     &            "ERROR: not enough command line arguments",  &
     &            " (should be ", number_of_cmdlineargs, ")."

!............ Exit this MPI run cleanly, via MPI's self-killing routine.

              CALL MPI_Abort(MPI_COMM_WORLD, mpi_error_code,  &
     &                       mpi_error_code)

          END IF !! (IARGC() < number_of_cmdlineargs)

          CALL GETARG(should_send_first_cmdlinearg, argument_buffer)
          READ (argument_buffer,*) should_send_first

          CALL GETARG(message_length_cmdlinearg, argument_buffer)
          READ (argument_buffer,*) message_length

          IF ((message_length < minimum_message_length) .OR.  &
     &        (message_length > maximum_message_length)) THEN

              WRITE (0,*)                                      &
     &            "ERROR: message length should be between ",  &
     &            minimum_message_length, " and ",             &
     &            maximum_message_length, "."

!............ Exit this MPI run cleanly, via MPI's self-killing routine.

              CALL MPI_Abort(MPI_COMM_WORLD, mpi_error_code,  &
     &                       mpi_error_code)

          END IF !! ((message_length < minimum_message_length) || ...)

!........ Determine which rank to communicate with.

          rank_to_communicate_with = MOD(my_rank + 1, 2)

!........ Communicate with the other rank.

          IF (should_send_first) THEN

!............ Send this rank's message to the other rank.
!............
!............ NOTE: Because this is a toy demonstration program, we
!............       don't care about the contents of the message.
!............       In a real program, we would care.

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 1st, about to send ", message_length,       &
     &            " integers"

              CALL MPI_Send(send_buffer, message_length,         &
     &                 MPI_INTEGER, rank_to_communicate_with,    &
     &                 the_tag, MPI_COMM_WORLD,                  &
     &                 mpi_error_code)

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 1st, done sending  ", message_length,       &
     &            " integers"

!............ Receive the other rank's message.

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 2nd, about to receive ", message_length,    &
     &            " integers"

              CALL MPI_Recv(recv_buffer, maximum_buffer_length,  &
     &                 MPI_INTEGER, rank_to_communicate_with,    &
     &                 the_tag, MPI_COMM_WORLD,                  &
                       mpi_status, mpi_error_code)

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 2nd, done receiving   ", message_length,    &
     &            " integers"

          ELSE   !! (should_send_first)

!............ Receive the other rank's message.
!............
!............ NOTE: Because this is a toy demonstration program, we
!............       don't care about the contents of the message.
!............       In a real program, we would care.

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 1st, about to receive ", message_length,    &
     &            " integers"

              CALL MPI_Recv(recv_buffer, maximum_buffer_length,  &
     &                 MPI_INTEGER, rank_to_communicate_with,    &
     &                 the_tag, MPI_COMM_WORLD,                  &
     &                 mpi_status, mpi_error_code)

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 1st, done receiving   ", message_length,    &
     &            " integers"

!............ Send this rank's message to the other rank.

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 2nd, about to send ", message_length,       &
     &            " integers"

              CALL MPI_Send(send_buffer, message_length,         &
     &                 MPI_INTEGER, rank_to_communicate_with,    &
     &                 the_tag, MPI_COMM_WORLD,                  &
     &                 mpi_error_code)

              WRITE (0,*) my_rank, " of ", number_of_processes,  &
     &            ": 2nd, done sending  ", message_length,       &
     &            " integers"

          END IF !! (should_send_first)...ELSE

!........ End this MPI run.

          CALL MPI_Finalize(mpi_error_code)

      END PROGRAM deadlock

