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, k, n
    CHARACTER(LEN=50) :: filename
    CHARACTER(LEN=1024) :: buffer
    CHARACTER(LEN=length) :: message
    ! Fortran 2003 has deferred length, which is simpler
    CHARACTER, DIMENSION(:), ALLOCATABLE :: result
    LOGICAL :: flag

    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

    WRITE (filename,"('Programs/textfile.',I0)") myrank
    OPEN (11,file=TRIM(filename),ACTION='READ',STATUS='OLD')
    DO
        READ (11,"(A)",END=10) message
        CALL MPI_Bsend(message,LEN(TRIM(message)),MPI_CHARACTER,    &
            root,tag,MPI_COMM_WORLD,error)
    END DO
10  CONTINUE
    CALL MPI_Bsend(eot,LEN(eot),MPI_CHARACTER,    &
        root,tag,MPI_COMM_WORLD,error)
    CLOSE (11)

    IF (myrank == root) THEN
        n = 0
        DO WHILE (n < nprocs)
            CALL Get_message(result)
            IF (.NOT. ALLOCATED(result)) CYCLE
            ! The following becomes trivial in Fortran 2003
            flag = (SIZE(result) == LEN(EOT))
            DO k = 1,MIN(SIZE(result),LEN(EOT))
                flag = (flag .AND. result(k) == eot(k:k))
                IF (.NOT. flag) EXIT
            END DO
            IF (flag) THEN
                n = n+1
            ELSE
                WRITE (*,"(*(A))") result
            END IF
        END DO
    END IF
    n = 1024
    CALL MPI_Buffer_detach(buffer,n,error)
    CALL MPI_Finalize(error)

CONTAINS

    SUBROUTINE Get_message (line)
        CHARACTER, ALLOCATABLE, INTENT(OUT) :: line(:)
        INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
        LOGICAL :: flag
        INTEGER :: size, error

        CALL MPI_Iprobe(MPI_ANY_SOURCE,tag,MPI_COMM_WORLD,   &
            flag,status,error)
        IF (.NOT. flag) RETURN
        CALL MPI_Get_count(status,MPI_CHARACTER,size,error)
        ALLOCATE(line(size))
        CALL MPI_Recv(line,size,MPI_CHARACTER,    &
            MPI_ANY_SOURCE,tag,MPI_COMM_WORLD,status,error)
    END SUBROUTINE Get_message

END PROGRAM main
