PROGRAM main
    USE double
    USE mpi
    IMPLICIT NONE
    INTEGER, PARAMETER :: total = 12, size = 3, root = 1, tag = 456
    INTEGER :: nprocs, myrank, error
    REAL(KIND=DP), DIMENSION(total) :: source
    REAL(KIND=DP), DIMENSION(size) :: result, result_2

    source = 0.0_DP
    result = 0.0_DP
    CALL MPI_Init(error)
    CALL MPI_Comm_size(MPI_COMM_WORLD,nprocs,error)
    IF (size*nprocs /= total) 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/reals.input",ACTION="READ")
        READ (11,*) source
        CLOSE(11)
    END IF

    WRITE (*,"('Processor ',I0,' initial data',100(1X,F0.3))") myrank,source
    CALL MPI_Scatter(source,size,MPI_DOUBLE_PRECISION,    &
        result,size,MPI_DOUBLE_PRECISION,root,MPI_COMM_WORLD,error)
    WRITE (*,"('Processor ',I0,' now has data',100(1X,F0.3))") myrank,result
    result_2 = result
    CALL Rotate(result(2),1,MPI_DOUBLE_PRECISION,   &
        result_2(2),1,MPI_DOUBLE_PRECISION,MPI_COMM_WORLD,error)
    WRITE (*,"('Processor ',I0,' finally has data',100(1X,F0.3))")    &
        myrank,result_2
    CALL MPI_Finalize(error)

CONTAINS

    SUBROUTINE Rotate (sendbuf, sendcount, sendtype,    &
            recvbuf, recvcount, recvtype, comm, error)
        REAL(KIND=DP), DIMENSION(*), INTENT(IN) :: sendbuf
        REAL(KIND=DP), DIMENSION(*), INTENT(OUT) :: recvbuf
        INTEGER, INTENT(IN) :: sendcount, sendtype, recvcount, recvtype, comm
        INTEGER, INTENT(OUT) :: error
        INTEGER :: nprocs, myrank
        INTEGER, DIMENSION(MPI_STATUS_SIZE) :: status

        CALL MPI_Comm_size(comm,nprocs,error)
        IF (error /= 0) RETURN
        CALL MPI_Comm_rank(comm,myrank,error)
        IF (error /= 0) RETURN
        IF (myrank == 0) THEN
            CALL MPI_Ssend(sendbuf,sendcount,sendtype,1,tag,comm,error)
            IF (error /= 0) RETURN
            CALL MPI_Recv(recvbuf,recvcount,recvtype,nprocs-1,tag,comm,    &
                status,error)
            IF (error /= 0) RETURN
        ELSE
            CALL MPI_Recv(recvbuf,recvcount,recvtype,myrank-1,tag,comm,    &
                status,error)
            IF (error /= 0) RETURN
            CALL MPI_Ssend(sendbuf,sendcount,sendtype,    &
                MOD(myrank+1,nprocs),tag,comm,error)
            IF (error /= 0) RETURN
        END IF
        error = MPI_SUCCESS
    END SUBROUTINE Rotate

END PROGRAM main
