PROGRAM Main
    USE MPI
    IMPLICIT NONE
    INTEGER :: comm, myrank, ranks(8), error
    INTEGER, PARAMETER :: dims(2) = (/ 3, 5 /)
    LOGICAL, PARAMETER :: periodic(2) = .TRUE.
    CHARACTER(LEN=*), PARAMETER :: format =    &
            '("Rank ",I2," has neighbours ",8(I4,:,","))'

    CALL MPI_Init(error)
    CALL MPI_Cart_create(MPI_COMM_WORLD,2,dims,periodic,.TRUE.,comm,error)
    IF (comm /= MPI_COMM_NULL) THEN
        CALL MPI_Comm_rank(comm,myrank,error)
        ranks(1) = Neighbour(comm,(/-1,-1/))
        ranks(2) = Neighbour(comm,(/-1,0/))
        ranks(3) = Neighbour(comm,(/-1,+1/))
        ranks(4) = Neighbour(comm,(/0,-1/))
        ranks(5) = Neighbour(comm,(/0,+1/))
        ranks(6) = Neighbour(comm,(/+1,-1/))
        ranks(7) = Neighbour(comm,(/+1,0/))
        ranks(8) = Neighbour(comm,(/+1,+1/))
        WHERE (ranks == MPI_PROC_NULL) ranks = -123
        PRINT format, myrank, ranks
    END IF
    CALL MPI_Finalize(error)

CONTAINS

    FUNCTION Neighbour (comm, where)
        INTEGER :: Neighbour
        INTEGER, INTENT(IN) :: comm, where(:)
        INTEGER :: topo, ndims, dims(SIZE(where)),    &
            coords(SIZE(where)), error
        LOGICAL :: periodicities(2)

        IF (comm == MPI_COMM_NULL) THEN
            Neighbour = MPI_PROC_NULL
            RETURN
        END IF
        CALL MPI_Topo_test(comm,topo,error)
        IF (topo /= MPI_CART) THEN
            PRINT *, "The topology is not Cartesian"
            CALL MPI_Abort(MPI_COMM_WORLD,1,error)
        END IF
        CALL MPI_Cartdim_get(comm,ndims,error)
        IF (ndims <= 0) THEN
            PRINT *, "Too few dimensions"
            CALL MPI_Abort(MPI_COMM_WORLD,1,error)
        END IF
        IF (SIZE(where) /= ndims .OR. MAXVAL(ABS(where)) /= 1) THEN
            PRINT *, "Invalid neighbour vector"
            CALL MPI_Abort(MPI_COMM_WORLD,1,error)
        END IF
        CALL MPI_Cart_get(comm,ndims,dims,periodicities,coords,error)
        coords = coords+where
        WHERE (periodicities) coords = MOD(coords+dims,dims)
        IF (MINVAL(coords) < 0 .OR. ANY(coords >= dims)) THEN
            Neighbour = MPI_PROC_NULL
        ELSE
            CALL MPI_Cart_rank(comm,coords,Neighbour,error)    ! OK
        END IF
    END FUNCTION Neighbour

END PROGRAM Main
