PROGRAM Deadlock
!-----------------------------------------------------------------------
! Basic MPI Send and Receive primitives are BLOCKING,
! i.e. the program waits for their completion before proceeding.
! A DEADLOCK occurs when all processes in a set wait for another
! to take an action before proceeding.
!
! MPI_SEND is completed when all the data are sent and the
!   array may be overwritten.
! NOTE: no guarantee the data are actually received!
! MPI_RECV is completed when all the data are received and may be used
!
! In this example, two process exchange data in a symmetric way,
!   each one sending before receiving.
! NOTE: if only "few" data are exchanged, NO deadlock occurs.
!   A deadlock DOES occur, if the amount of data exchanged 
!   is large enough to fill up the buffer used for communicating.
!------------------------------------------------------------------------

IMPLICIT NONE
INCLUDE "mpif.h"
INTEGER:: err, nproc, myid
INTEGER, DIMENSION(MPI_STATUS_SIZE):: status
INTEGER, PARAMETER:: N=1000000  ! This controls deadlock occurrence
REAL:: a(N), b(N)

CALL MPI_INIT (err)
CALL MPI_COMM_SIZE (MPI_COMM_WORLD, nproc, err)
CALL MPI_COMM_RANK (MPI_COMM_WORLD, myid, err)

IF (myid==0)  THEN
    a = 0
    CALL MPI_SEND (a, N, MPI_REAL, 1, 9, MPI_COMM_WORLD, err)
    CALL MPI_RECV (b, N, MPI_REAL, 1, 8, MPI_COMM_WORLD, status, err)
    WRITE(*,*) "Process", myid, ": b =", b(1:3), "..."
ELSE
    b = 1
    CALL MPI_SEND (b, N, MPI_REAL, 0, 8, MPI_COMM_WORLD, err)
    CALL MPI_RECV (a, N, MPI_REAL, 0, 9, MPI_COMM_WORLD, status, err)
    WRITE(*,*) "Process", myid, ": a =", a(1:3), "..."
END IF

CALL MPI_FINALIZE (err)
END PROGRAM Deadlock
