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, n
    INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status
    CHARACTER(LEN=50) :: filename
    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

    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
        DO n = 0,nprocs-1
            DO
                CALL MPI_Recv(message,length,MPI_CHARACTER,    &
                    n,tag,MPI_COMM_WORLD,status,error)
                CALL MPI_Get_count(status,MPI_CHARACTER,size,error)
                IF (size == LEN(TRIM(eot)) .AND.    &
                        message(1:size) == eot)    &
                    EXIT
                WRITE (*,"(A)") message(1:size)
            END DO
            WRITE (*,*)
        END DO
    END IF

    n = 1024
    CALL MPI_Buffer_detach(buffer,n,error)
    CALL MPI_Finalize(error)

END PROGRAM main
