! Unnecessary use of a temporary included to bypass a bug in gfortran's
! generic resolution (fixed in recent releases).

PROGRAM main
    USE double
    USE mpi
    IMPLICIT NONE
    INTEGER, PARAMETER :: procs = 4, size = 3, root = 1
    INTEGER :: nprocs, myrank, error, world
    REAL(KIND=DP), DIMENSION(size,procs) :: source
    REAL(KIND=DP), DIMENSION(size) :: result, summary

    world = MPI_COMM_WORLD    ! Heaven alone knows why this is needed or works!

    source = 0.0_DP
    result = 0.0_DP
    summary = 0.0_DP
    CALL MPI_Init(error)
    IF (error /= MPI_SUCCESS) CALL diagnose(error)
    CALL MPI_Comm_set_errhandler(world,MPI_ERRORS_RETURN,error)
    IF (error /= MPI_SUCCESS) CALL diagnose(error)
    CALL MPI_Comm_size(MPI_COMM_WORLD,nprocs,error)
    IF (error /= MPI_SUCCESS) CALL diagnose(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 (error /= MPI_SUCCESS) CALL diagnose(error)
    IF (myrank == root) THEN
        OPEN (11,FILE="Programs/reals.input",ACTION="READ")
        READ (11,*) source
        CLOSE(11)
    END IF

    CALL MPI_Scatter(source,size,MPI_DOUBLE_PRECISION,    &
        result,size,MPI_DOUBLE_PRECISION,root,MPI_COMM_WORLD,error)
    IF (error /= MPI_SUCCESS) CALL diagnose(error)
    result = exp(result)
    WRITE (*,"('Processor ',I0,' now has data',100(1X,F0.3))") myrank,result
    CALL MPI_Reduce(result,summary,size,MPI_DOUBLE_PRECISION,    &
        MPI_LAND,root,MPI_COMM_WORLD,error)
    IF (error /= MPI_SUCCESS) CALL diagnose(error)
    WRITE (*,"('Processor ',I0,' summary data',100(1X,F0.3))") myrank,summary
    CALL MPI_Finalize(error)
    IF (error /= MPI_SUCCESS) CALL diagnose(error)

CONTAINS

    SUBROUTINE diagnose (error)
        INTEGER, INTENT(IN) :: error
        INTEGER :: junk, length
        CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: buffer

        CALL MPI_Error_string(error,buffer,length,junk)
        IF (junk /= MPI_SUCCESS) THEN
            PRINT *, "How on earth did MPI_Error_string fail?"
            CALL MPI_Abort(MPI_COMM_WORLD,1,junk)
        END IF
        WRITE (*,"('Processor ',I0,' failed with code  ',I0,': ',A)")    &
            myrank,error,buffer
        CALL MPI_Abort(MPI_COMM_WORLD,1,junk)
    END SUBROUTINE diagnose

END PROGRAM main
