program main

    include 'mpif.h'
    integer wrank, wsize, place
    integer ::   coord(2)
    integer north, south, east, west
    integer cart, ierr
    logical commit
! A two-dimensional grid of 12 processes in a 4 row x 3 col grid */
    integer ::    dims(2) = (/4,3/)
    logical :: periods(2) = .false.
    logical :: reorder    = .false. 

    call MPI_Init(ierr)
    call MPI_Comm_rank(MPI_COMM_WORLD, wrank, ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, wsize, ierr)

    call MPI_Cart_create(MPI_COMM_WORLD, 2, dims, periods, reorder, cart, ierr)
    call MPI_Cart_coords(cart, wrank, 2, coord, ierr)
    print*,'Rank ',wrank,' coord are ', coord(1), coord(2)

! The documentation for MPI_Cart_shift is really confusing
    call MPI_Cart_shift(cart, 0, 1, north, south, ierr)
    call MPI_Cart_shift(cart, 1, 1, west , east , ierr)
    print*,'Rank ',wrank,' neighbors are ', north, south, west, east
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call allgather(wrank)
    call MPI_Barrier(MPI_COMM_WORLD, ierr)
    if (wrank==0) print *,'  '
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call allgatherv(wrank)
    call MPI_Barrier(MPI_COMM_WORLD, ierr)
    if (wrank==0) print *,'  '
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    place=10*wrank
    call alltoall(wrank, place)
    call MPI_Barrier(MPI_COMM_WORLD, ierr)
    if (wrank==0) print *,'  '
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call alltoallv(wrank, place)
    call MPI_Barrier(MPI_COMM_WORLD, ierr)
    if (wrank==0) print *,'  '
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call alltoallw(wrank, place)
    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call MPI_Comm_free(cart)
    call MPI_Finalize(ierr)

contains

    subroutine allgather(wrank)
       logical commit
       integer wrank
       integer :: sendbuf(1)
       integer :: recvbuf(4) = (/Z'deadbeef', Z'deadbeef', Z'deadbeef', Z'deadbeef'/)

       sendbuf(1) = wrank
       call MPI_Neighbor_allgather(sendbuf, 1, MPI_INT, recvbuf, 1, MPI_INT, cart, ierr)
       write(6,"(a,i4,a,i,i,i,i)") 'allgather: Rank ', wrank, ' coord are ', recvbuf(1), recvbuf(2), recvbuf(3), recvbuf(4)
       return
    end subroutine allgather 


    subroutine allgatherv(wrank)
       logical commit
       integer wrank
       integer :: sendbuf(1)
       integer :: recvbuf(4)    = (/Z'deadbeef', Z'deadbeef', Z'deadbeef', Z'deadbeef'/)
       integer :: recvcounts(4) =  (/1, 1, 1, 1/)
       integer :: displs(4)     =  (/0, 1, 2, 3/)

       sendbuf(1)    = wrank 
       call MPI_Neighbor_allgatherv(sendbuf, 1, MPI_INT, recvbuf, recvcounts, displs, MPI_INT, cart, ierr)
       write(6,"(a,i4,a,i,i,i,i)") 'allgatherv: Rank ', wrank, ' coord are ', recvbuf(1), recvbuf(2), recvbuf(3), recvbuf(4)
       return
    end subroutine allgatherv
    

    subroutine alltoall(wrank, place)
       logical commit
       integer wrank, place
       integer :: sendbuf(4)
       integer :: recvbuf(4) = (/Z'deadbeef', Z'deadbeef', Z'deadbeef', Z'deadbeef'/)

       sendbuf(1:4) = (/place, place+1, place+2, place+3/)
       call MPI_Neighbor_alltoall(sendbuf, 1, MPI_INT, recvbuf, 1, MPI_INT, cart, ierr)
       write(6,"(a,i4,a,i,i,i,i)") 'alltoall: Rank ', wrank, ' coord are ', recvbuf(1), recvbuf(2), recvbuf(3), recvbuf(4)
       return
    end subroutine alltoall

    subroutine alltoallv(wrank, place)
       logical commit
       integer wrank, place
       integer :: sendbuf(4)
       integer :: recvbuf(4)    = (/Z'deadbeef', Z'deadbeef', Z'deadbeef', Z'deadbeef'/)
       integer :: sendcounts(4) = (/1, 1, 1, 1/)
       integer :: recvcounts(4) = (/1, 1, 1, 1/)
       integer :: sdispls(4)    = (/0, 1, 2, 3/)
       integer :: rdispls(4)    = (/0, 1, 2, 3/)

       sendbuf(1:4) = (/place, place+1, place+2, place+3/)
       call MPI_Neighbor_alltoallv(sendbuf, sendcounts, sdispls, MPI_INT,             &
                                   recvbuf, recvcounts, rdispls, MPI_INT, cart, ierr)
       write(6,"(a,i4,a,i,i,i,i)") 'alltoallv: Rank ', wrank, ' coord are ', recvbuf(1), recvbuf(2), recvbuf(3), recvbuf(4)
       return
    end subroutine alltoallv

    subroutine alltoallw(wrank, place)
       logical commit
       integer wrank, place
       integer :: sendbuf(4)
       integer :: recvbuf(4)    = (/Z'deadbeef', Z'deadbeef', Z'deadbeef', Z'deadbeef'/)
!       integer :: recvbuf(4)    = (/-999, -999, -999, -999/)
       integer :: sendcounts(4) = (/1, 1, 1, 1/)
       integer :: recvcounts(4) = (/1, 1, 1, 1/)
!       integer :: sdispls(4)    = (/0, 1, 2, 3/)
!       integer :: rdispls(4)    = (/0, 1, 2, 3/)
       integer :: sdispls(4)    = (/0, 4, 8, 12/)
       integer :: rdispls(4)    = (/0, 4, 8, 12/)
       integer :: sendtypes(4) = (/MPI_INT, MPI_INT, MPI_INT, MPI_INT/)
       integer :: recvtypes(4) = (/MPI_INT, MPI_INT, MPI_INT, MPI_INT/)

       sendbuf(1:4) = (/place, place+1, place+2, place+3/)
       call MPI_Neighbor_alltoallw(sendbuf, sendcounts, sdispls, sendtypes,             &
                                   recvbuf, recvcounts, rdispls, recvtypes, cart, ierr)
       print*,'Return code from MPI_Neighbor_alltoallw ', ierr
       write(6,"(a,i4,a,i,i,i,i)") 'alltoallw: Rank ', wrank, ' coord are ', recvbuf(1), recvbuf(2), recvbuf(3), recvbuf(4)
       return
    end subroutine alltoallw

end program main