PROGRAM main
    USE double
    USE mpi
    IMPLICIT NONE
    INTEGER, PARAMETER :: procs = 4, root = 0, length = 80, tag = 456
    CHARACTER(LEN=*), PARAMETER :: eot = "+++ End Of Transmission +++"
    INTEGER :: nprocs, myrank, size, error, count,    &
        requests(procs), index, n
    INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
    CHARACTER(LEN=1024) :: buffer
    CHARACTER(LEN=length) :: inmess(procs), outmess

    CALL MPI_Init(error)
    CALL MPI_Buffer_attach(buffer,1024,error)
    CALL MPI_Comm_size(MPI_COMM_WORLD,nprocs,error)
    CALL MPI_Comm_rank(MPI_COMM_WORLD,myrank,error)
    IF (nprocs /= procs) THEN
        PRINT *, 'Invalid number of processes'
        CALL MPI_Abort(MPI_COMM_WORLD,1,error)
    END IF
    IF (myrank == root) THEN
        READ (*,*) count
        IF (count < 1 .OR. count > 1000000) THEN
            WRITE (*,*) "Invalid count specified"
            STOP 1
        END IF
    END IF
    CALL MPI_Bcast(count,1,MPI_INTEGER,MPI_COMM_WORLD,root,error)

    DO n = 1,count
        WRITE (outmess,"('Process ',I0,' line ',I0)") myrank, n
        IF (myrank == root) THEN
            CALL MPI_Bsend(outmess,LEN(TRIM(outmess)),MPI_CHARACTER,    &
                root,tag,MPI_COMM_WORLD,error)
        ELSE
            CALL MPI_Ssend(outmess,LEN(TRIM(outmess)),MPI_CHARACTER,    &
                root,tag,MPI_COMM_WORLD,error)
        END IF
    END DO
    IF (myrank == root) THEN
        CALL MPI_Bsend(eot,LEN(eot),MPI_CHARACTER,    &
            root,tag,MPI_COMM_WORLD,error)
    ELSE
        CALL MPI_Ssend(eot,LEN(eot),MPI_CHARACTER,    &
            root,tag,MPI_COMM_WORLD,error)
    END IF

    IF (myrank == root) THEN
! This is not the only way to do this, but is quite a good one.  Start
! one receive per process, but DON'T restrict them to which process
! they receive from.  Then restart a receive every time we DON'T get
! and EOT marker, and stop when we have got nprocs EOT markers - but
! remember to reuse the right request element and buffer.
        DO n = 1,nprocs
            CALL MPI_Irecv(inmess(n),LEN(inmess(n)),MPI_CHARACTER,    &
                MPI_ANY_SOURCE,tag,MPI_COMM_WORLD,requests(n),error)
        END DO
        n = 0
        DO WHILE (n < nprocs)
            CALL MPI_Waitany(nprocs,requests,index,status,error)
            CALL MPI_Get_count(status,MPI_CHARACTER,size,error)
            IF (inmess(index)(1:size) == eot) THEN
                n = n+1
            ELSE
                WRITE (*,"(A)") inmess(index)(1:size)
                CALL MPI_Irecv(inmess(index),LEN(inmess(index)),    &
                    MPI_CHARACTER,MPI_ANY_SOURCE,tag,    &
                    MPI_COMM_WORLD,requests(index),error)
            END IF
        END DO
    END IF
    CALL MPI_Buffer_detach(buffer,n,error)
    CALL MPI_Finalize(error)

END PROGRAM main
