PROGRAM main
    USE double
    USE mpi
    IMPLICIT NONE
    INTEGER, PARAMETER :: procs = 4, root = 0, tag = 123
    INTEGER :: nprocs, myrank, error

    CALL MPI_Init(error)
    CALL MPI_Comm_size(MPI_COMM_WORLD,nprocs,error)
    IF (nprocs /= procs) THEN
        PRINT *, 'Invalid number of processes'
        CALL MPI_Abort(MPI_COMM_WORLD,1,error)
    END IF
    CALL MPI_Comm_rank(MPI_COMM_WORLD,myrank,error)
    IF (myrank == root) THEN
        CALL Rootproc(nprocs)
    ELSE
        CALL Otherproc(myrank)
    END IF
    CALL MPI_Finalize(error)

CONTAINS

    SUBROUTINE Rootproc (nprocs)
        INTEGER, INTENT(IN) :: nprocs
        INTEGER :: data, request, status(MPI_STATUS_SIZE),    &
            error, count

        CALL MPI_Irecv(data,1,MPI_INTEGER,MPI_ANY_SOURCE,    &
            tag,MPI_COMM_WORLD,request,error)
        count = 0
        DO
            CALL MPI_Wait(request,status,error)
            PRINT *, status(MPI_SOURCE), data
            IF (data <= 1) count = count+1
            IF (count >= nprocs-1) EXIT
            CALL MPI_Irecv(data,1,MPI_INTEGER,MPI_ANY_SOURCE,    &
                tag,MPI_COMM_WORLD,request,error)
        END DO
    END SUBROUTINE Rootproc

    SUBROUTINE Otherproc (rank)
        INTEGER, INTENT(IN) :: rank
        INTEGER :: n

        n = 1
        DO
            n = MOD((rank+1)*n,32)
            CALL MPI_Send(n,1,MPI_INTEGER,root,tag,MPI_COMM_WORLD,error)
            IF (n <= 1) EXIT
        END DO
    END SUBROUTINE Otherproc

END PROGRAM main
