program cart_ring 
! An MPI program using Cartesian ring topology with PBCs
! MIJP 05/03/97

  use mpi
  implicit none

  integer, parameter :: dp=selected_real_kind(15,300)
  integer, parameter :: reps=10000
  integer, parameter :: max_size=4
  integer, parameter :: ndims=1     !ndims=1 => dim 0 only.

  integer, dimension(1:ndims) :: dims
  logical, dimension(1:ndims) :: periods
  logical :: reorder
  integer :: comm_ring, direction,disp

  integer, dimension(1:MPI_STATUS_SIZE) :: send_status,recv_status
  integer :: send_request,recv_request
  integer :: send_rank,recv_rank,my_rank,size

  integer :: errcode,i,j
  integer :: left,right,send_tag,recv_tag
  integer :: tot

  real (kind=dp) :: start_time,stop_time,time

  errcode=0

  ! Initialize MPI
  call MPI_INIT(errcode)
  !call error_test(errcode,'MPI_INIT')

  ! get # PE's in group	  
  call MPI_COMM_SIZE(MPI_COMM_WORLD,size,errcode)
  !call error_test(errcode,'MPI_COMM_SIZE')
  if (size>max_size) then
     print *,'Need to run on a',max_size,' PE queue'
     stop
  end if

  ! create Cartesian ring topolgy in 1D with PBCs
  if (ndims==1) then
     dims(1)=size
     periods(1)=.TRUE.
     reorder=.TRUE.
  else
     print *,'only set up to do 1D ring at the moment!'
     stop
  end if
  call MPI_CART_CREATE(MPI_COMM_WORLD,ndims,dims,periods,reorder,comm_ring,errcode)
  ! call error_test(errcode,'MPI_CART_CREATE')

  ! now get ranks for shifting one PE to the left for dim 0
  direction=0
  disp=1
  call MPI_CART_SHIFT(comm_ring,direction,disp,left,right,errcode)
  ! call error_test(errcode,'MPI_CART_SHIFT')

  !... and get own rank as need this as the data to send!
  call MPI_COMM_RANK(comm_ring,my_rank,errcode)
  ! call error_test(errcode,'MPI_COMM_SIZE')

  ! Now send rank number to PE on left and receive from PE on right
  ! and monitor time taken to send & receive, and
  ! print out all results from PE 0.

  start_time=MPI_WTIME()
  tot=0
  do i=1,reps
     recv_rank=my_rank
     ! recv_tag=my_rank
     ! send_tag=left
     send_tag=1		!Dont actually need distinct tags
     recv_tag=1		!as only get 1 message/PE before WAIT

     rank_loop: do
     send_rank=recv_rank

     call MPI_ISSEND(send_rank,1,MPI_INTEGER,left,send_tag,comm_ring,send_request,errcode)
     ! call error_test(errcode,'MPI_ISSEND')

     call MPI_IRECV(recv_rank,1,MPI_INTEGER,right,recv_tag,comm_ring,recv_request,errcode)
     ! call error_test(errcode,'MPI_IRECV')

     call MPI_WAIT(send_request,send_status,errcode)
     ! call error_test(errcode,'MPI_WAIT')

     call MPI_WAIT(recv_request,recv_status,errcode)
     ! call error_test(errcode,'MPI_WAIT')

     tot=tot+recv_rank
     if (recv_rank==my_rank) exit rank_loop
  end do rank_loop
  end do
  stop_time=MPI_WTIME()
  time=(stop_time-start_time)*1000.0_dp

  if (my_rank==0) then      
     print *,'Using MPI_ISSEND/IRECV for ',reps,'ints takes',time,'ms.'
     print *,'On root, tot=',tot
  end if

  ! if (my_rank.eq.0) then
  !     print *,'Finished all ISENDs: tot=',tot 
  ! end if

  ! Terminate MPI
  call MPI_FINALIZE(errcode)
  ! call error_test(errcode,'MPI_FINALIZE')
contains

subroutine error_test(errcode,routine)
  integer :: errcode
  character*20 :: routine

  if (errcode/=0) then
     print *,'Error ',errcode,' in routine',routine
     errcode=0
     call MPI_FINALIZE(errcode)
     stop
  else
     ! print *,routine,' OK'
  end if

  return
end subroutine error_test

end program cart_ring
