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, n
    CHARACTER(LEN=1024) :: buffer
    CHARACTER(LEN=length) :: message

    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 (message,"('Process ',I0,' line ',I0)") myrank, n
        CALL MPI_Bsend(message,LEN(TRIM(message)),MPI_CHARACTER,    &
            root,tag,MPI_COMM_WORLD,error)
    END DO
    CALL MPI_Bsend(eot,LEN(eot),MPI_CHARACTER,    &
        root,tag,MPI_COMM_WORLD,error)

    IF (myrank == root) THEN
        n = 0
        DO WHILE (n < nprocs)
            CALL Get_message(message,size)
            IF (size < 0) CYCLE
            IF (message(1:size) == eot) THEN
                n = n+1
            ELSE
                WRITE (*,"(A)") message(1:size)
            END IF
        END DO
    END IF
    n = 1024
    CALL MPI_Buffer_detach(buffer,n,error)
    CALL MPI_Finalize(error)

CONTAINS

    SUBROUTINE Get_message (line, lineline)
        CHARACTER(LEN=*), INTENT(OUT) :: line
        INTEGER, INTENT(OUT) :: lineline
        INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
        LOGICAL :: flag
        CHARACTER(LEN=length) :: message
        INTEGER :: size, error
  
        CALL MPI_Iprobe(MPI_ANY_SOURCE,tag,MPI_COMM_WORLD,   &
            flag,status,error)
        lineline = -1
        IF (.NOT. flag) RETURN
        CALL MPI_Recv(message,LEN(message),MPI_CHARACTER,    &
            MPI_ANY_SOURCE,tag,MPI_COMM_WORLD,status,error)
        CALL MPI_Get_count(status,MPI_CHARACTER,size,error)
        line = message
        lineline = size
    END SUBROUTINE Get_message

END PROGRAM main
