PROGRAM main
    USE double
    USE mpi
    IMPLICIT NONE
    INTEGER, PARAMETER :: procs = 4, root = 3, tag = 456
    INTEGER :: nprocs, myrank, error, i
    CHARACTER(LEN=1024) :: buffer
    INTEGER, DIMENSION(procs,procs) :: source
    INTEGER, DIMENSION(procs) :: one, two

    source = 0.0_DP
    one = 0.0_DP
    two = 0.0_DP
    CALL MPI_Init(error)
    CALL MPI_Buffer_attach(buffer,1024,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
        OPEN (11,FILE="Programs/integers.input",ACTION="READ")
        READ (11,*) source
        CLOSE(11)
    END IF

    CALL MPI_Scatter(source,procs,MPI_INTEGER,    &
        one,procs,MPI_INTEGER,root,MPI_COMM_WORLD,error)
    WRITE (*,"('Processor ',I0,' first data',100(1X,I0))") myrank,one
    CALL myalltoall(one,1,MPI_INTEGER,    &
        two,1,MPI_INTEGER,MPI_COMM_WORLD,error)
    WRITE (*,"('Processor ',I0,' second data',100(1X,I0))") myrank,two
    i = 1024
    CALL MPI_Buffer_detach(buffer,i,error)
    CALL MPI_Finalize(error)

CONTAINS

    SUBROUTINE myalltoall (sendbuf, sendcount, sendtype,    &
            recvbuf, recvcount, recvtype, comm, error)
        INTEGER, DIMENSION(*), INTENT(IN) :: sendbuf
        INTEGER, DIMENSION(*), INTENT(OUT) :: recvbuf
        INTEGER, INTENT(IN) :: sendcount, sendtype, recvcount, recvtype, comm
        INTEGER, INTENT(OUT) :: error
        INTEGER :: nprocs, i
        INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status

        CALL MPI_Comm_size(comm,nprocs,error)
        DO i = 0,nprocs-1
            CALL MPI_Bsend(sendbuf(i*sendcount+1),sendcount,sendtype,    &
                i,tag,comm,error)
        END DO
        DO i = 0,nprocs-1
            CALL MPI_Probe(MPI_ANY_SOURCE,tag,comm,status,error)
            CALL MPI_Recv(recvbuf(status(MPI_SOURCE)*recvcount+1),    &
                recvcount,recvtype,MPI_ANY_SOURCE,tag,comm,status,error)
        END DO
        error = MPI_SUCCESS
    END SUBROUTINE myalltoall

END PROGRAM main
