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(nprocs), requests(nprocs),    &
            status(MPI_STATUS_SIZE), index, error, n
        
        DO n = 1,nprocs
            IF (n-1 /= root) THEN
                CALL MPI_Irecv(data(n),1,MPI_INTEGER,n-1,tag,    &
                    MPI_COMM_WORLD,requests(n),error)
            ELSE
                requests(n) = MPI_REQUEST_NULL
            END IF
        END DO
        DO
            CALL MPI_Waitany(nprocs,requests,index,status,error)
            IF (index == MPI_UNDEFINED) EXIT
            PRINT *, index-1, data(index)
            IF (data(index) > 1)    &
                CALL MPI_Irecv(data(index),1,MPI_INTEGER,index-1,tag,    &
                    MPI_COMM_WORLD,requests(index),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
