program mpi_parcel
  use mpi
  implicit none

  integer,parameter :: dp = kind(1.0d0)

  real(kind=dp) :: parcel,x

  integer :: my_rank,size,nhops,sendnode,hopcount,ierr

  integer,allocatable,dimension(:) :: status

  ! variables required for random number generator
  integer :: rand_size
  integer, allocatable, dimension(:) :: rand_seed
  logical :: fixed_seed = .false. ! for repeatability

  !f90 intrinsic time call
  character(len=10) :: system_time           !length is crucial ...
  real (kind=dp)    :: rtime


  ! fill with random numbers - random number code pinched from simple_md.f90
  call random_seed(size=rand_size)
  allocate(rand_seed(1:rand_size),stat=ierr)
  if (ierr/=0) stop 'Error in allocating rand_seed'
  if (fixed_seed) then
     rand_seed=223257167
  else
     call date_and_time(time=system_time)  !character string hhmmss.xxx
     read (system_time,*) rtime            !convert to real
     rand_seed = int(rtime * 1000.0_dp)    !0<rtime<235959999.0 which fits within huge(1)
  end if
  call random_seed(put=rand_seed)
  deallocate(rand_seed,stat=ierr)
  if (ierr/=0) stop 'Error in deallocating rand_seed'
  !now random number generator is ready to use ...

  !allocate status array
  allocate(status(1:MPI_STATUS_SIZE),stat=ierr)
  if (ierr/=0) stop 'Error allocating status array'

  !initialise MPI world
  call MPI_init(ierr)
  if (ierr/=MPI_success) stop 'Error in MPI_init'

  !get size (total number of processors) within MPI world
  call MPI_comm_size(MPI_comm_world,size,ierr)
  if (ierr/=MPI_success) stop 'Error in MPI_comm_size'

  !get my rank on each different processor within MPI world (0 to num_procs-1)
  call MPI_comm_rank(MPI_comm_world,my_rank,ierr)
  if (ierr/=MPI_success) stop 'Error in MPI_comm_rank'

  ! generate a random number for when the music stops
  if (my_rank==0) then
     call random_number(x)
     nhops = ceiling(x*100.0_dp)
  end if

  !broadcast this to all nodes in MPI_COMM_WORLD
  call MPI_bcast(nhops,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
  if (ierr/=MPI_success) stop 'Error in MPI_bcast'

  ! generate the initial value of parcel on rank 0
  if (my_rank==0) then
     call random_number(x)
     parcel = 2.0_dp*x - 1.0_dp
  end if

  ! initialise hopcount and sendnode
  hopcount = 0
  sendnode = 0
  

  do ! loop until exit

     if (sendnode/=size-1) then  ! normal case

        if (my_rank==sendnode) then
           ! send parcel to next node
           call MPI_send(parcel,1,MPI_DOUBLE_PRECISION,sendnode+1,hopcount,MPI_COMM_WORLD,ierr)
           if (ierr/=MPI_SUCCESS) stop 'Error sending from sendnode'
           write(*,'("Sending from node ",i2," to node ",i2)')sendnode,sendnode+1
        end if

        if (my_rank==sendnode+1) then
           ! receive from previous node
           call MPI_recv(parcel,1,MPI_DOUBLE_PRECISION,sendnode,hopcount,MPI_COMM_WORLD,status,ierr)
           if (ierr/=0) stop 'Error receiving from sendnode'

           ! unwrap a layer of the parcel
           call random_number(x)
           parcel = parcel + 2.0_dp*x-1.0_dp
        end if

     else ! special case for wrap around

        if (my_rank==size-1) then
           ! send parcel to next node
           call MPI_send(parcel,1,MPI_DOUBLE_PRECISION,0,hopcount,MPI_COMM_WORLD,ierr) 
           write(*,'("Sending from node ",i2," to node ",i2)')sendnode,0
        end if

        if (my_rank==0) then
           ! receive from previous node
           call MPI_recv(parcel,1,MPI_DOUBLE_PRECISION,sendnode,hopcount,MPI_COMM_WORLD,status,ierr)

           ! unwrap a layer of the parcel
           call random_number(x)
           parcel = parcel + 2.0_dp*x-1.0_dp
        end if

     end if

     ! increment or wrap round the sendnode
     if (sendnode==size-1) then
        sendnode = 0
     else
        sendnode = sendnode + 1
     end if

     ! synchronise
     call MPI_barrier(MPI_COMM_WORLD,ierr)
     if (ierr/=MPI_SUCCESS) stop 'error in MPI_barrier'

     ! check for music stopping and print final info
     hopcount = hopcount + 1
     if (hopcount == nhops) then
        ! synchronise
        call MPI_barrier(MPI_COMM_WORLD,ierr)
        if (ierr/=MPI_SUCCESS) stop 'error in MPI_barrier'
        if (my_rank==sendnode) then
           write(*,'("Music stopped after nhops = ",I2)')nhops
           write(*,'("Node holding the parcel was ",I2)')my_rank
           write(*,'("Final value of parcel       ",F10.5)')parcel
        end if
        exit
     end if

  end do

  ! finalise MPI
  call MPI_finalize(ierr)
  if (ierr/=MPI_success) stop 'Error in MPI_finalize'

  ! deallocate the status array
  deallocate(status,stat=ierr)
  if (ierr/=0) stop 'Error deallocating status array'

end program mpi_parcel
