!
! --------- trmpi_setup_barrier_tag ---------
! set trmpi_barrier_tag in trmpi module
!
subroutine trmpi_setup_barrier_tag
#ifdef __MPI
  use trmpi

  implicit none

  integer :: imxtag  ! stupid compiler

  if (trmpi_barrier_tag<=0) then
     imxtag = max(0, MPI_TAG_UB)
     trmpi_barrier_tag = 84826578  ! 'T' 'R' 'A' 'N'
     if (imxtag>1) then
        trmpi_barrier_tag = mod(max(0,trmpi_barrier_tag-10),imxtag)+10
     end if
  end if
#endif
end subroutine trmpi_setup_barrier_tag

!
! ------------- trmpi_parse_barrier_arg -----------
! fetch the number of sleep seconds from the BARRIER service argument
!
subroutine trmpi_parse_barrier_arg(arg,isleep)
  use trmpi

  implicit none

  character*(*), intent(in) :: arg   ! service argument, convert to integer to wait this number of seconds
                                     ! between checking for reception of message or 0 for barrier only
  integer, intent(out) :: isleep     ! sleep for this number of seconds
  integer :: iertmp
  character(len=len(arg)) :: aarg    ! left adjusted

  isleep = 0
  if (len_trim(arg)>0) then
     aarg = adjustl(arg)
     read(aarg,'(i9)',iostat=iertmp) isleep
     if (iertmp/=0) then
        write(trmpi_lunmsg,'(a)') '?trmpi_***_barrier: error converting string to integer "' &
             &         //trim(adjustl(arg))//'"'
        call bad_exit
     end if
     if (isleep<0) then
        write(trmpi_lunmsg,'(a,i9)') '?trmpi_***_barrier: bad sleep size = ',isleep
        call bad_exit
     end if
  end if
end subroutine trmpi_parse_barrier_arg

!
! --------- trmpi_listener_barrier --------
! called by rank>0 listeners to sleep until a signal has been sent
!
subroutine trmpi_listener_barrier(arg)
#ifdef __MPI
  use trmpi
#endif

  implicit none

  character*(*), intent(in) :: arg   ! service argument, convert to integer to wait this number of seconds
                                     ! between checking for reception of message or 0 for barrier only

#ifdef __MPI
  logical :: fbarrier      ! flag for test of completion
  integer :: iertmp        ! error flag
  integer :: ibarrier      ! send/receive a single integer
  integer :: rbarrier      ! result handle
  integer :: isleep        ! sleep for this number of seconds

  integer :: sbarrier(MPI_STATUS_SIZE) ! status

  call trmpi_setup_barrier_tag

  call trmpi_parse_barrier_arg(arg,isleep)

  if (isleep>0) then   ! expect a message from rank 0
     ibarrier=0

     call MPI_IRECV(ibarrier, 1, MPI_INTEGER, 0, trmpi_barrier_tag, trmpi_comm, rbarrier, iertmp)
     if (iertmp/=0) then
        write(trmpi_lunmsg,*) 'trmpi_listener_barrier: bad call to MPI_IRECV'
        call bad_exit
     end if
     
100  continue       
     call gosleep(isleep)
     call MPI_TEST(rbarrier, fbarrier, sbarrier, iertmp)
     if (iertmp/=0) then
        write(trmpi_lunmsg,*) 'trmpi_listener_barrier: bad call to MPI_TEST'
        call bad_exit
     end if
     
     if (.not. fbarrier) goto 100
  end if

  call MPI_BARRIER(trmpi_comm,iertmp)
#endif

end subroutine trmpi_listener_barrier

!
! --------- trmpi_end_barrier --------
! call by rank=0 requestor to wake up listeners and proceed past the barrier
!
subroutine trmpi_end_barrier(arg)
#ifdef __MPI
  use trmpi
#endif

  implicit none

  character*(*), intent(in) :: arg   ! service argument, convert to integer to wait this number of seconds
                                     ! between checking for reception of message or 0 for barrier only

#ifdef __MPI
  integer :: iertmp        ! error flag
  integer :: ibarrier      ! send/receive a single integer
  integer :: isleep        ! sleep for this number of seconds
  integer :: isize         ! number of ranks in communicator
  integer :: irank         ! rank number

  integer,allocatable :: rbarrier(:)      ! result handle
  integer,allocatable :: sbarrier(:,:)    ! status

  call trmpi_setup_barrier_tag

  call trmpi_parse_barrier_arg(arg,isleep)

  if (isleep>0) then   ! send a message to the other ranks
     ibarrier=0
     
     call MPI_COMM_SIZE(trmpi_comm, isize, iertmp)
     if (iertmp/=0) then
        write(trmpi_lunmsg,*) 'trmpi_end_barrier: bad call to MPI_COMM_SIZE'
        call bad_exit
     end if
        
     call MPI_COMM_RANK(trmpi_comm, irank, iertmp)
     if (iertmp/=0) then
        write(trmpi_lunmsg,*) 'trmpi_end_barrier: bad call to MPI_COMM_RANK'
        call bad_exit
     else if (irank/=0) then
        write(trmpi_lunmsg,*) 'trmpi_end_barrier: this should only be called by rank 0, this rank = ',irank
        call bad_exit
     end if
        
     allocate(rbarrier(isize-1), sbarrier(MPI_STATUS_SIZE,isize-1))

     do irank=1, isize-1
        call MPI_ISEND(ibarrier, 1, MPI_INTEGER, irank, trmpi_barrier_tag, trmpi_comm, rbarrier(irank), iertmp)
        if (iertmp/=0) then
           write(trmpi_lunmsg,*) 'trmpi_end_barrier: bad call to MPI_ISEND'
           call bad_exit
        end if
     end do
     
     call MPI_WAITALL(isize-1, rbarrier, sbarrier, iertmp)
     if (iertmp/=0) then
        write(trmpi_lunmsg,*) 'trmpi_end_barrier: bad call to MPI_WAITALL'
        call bad_exit
     end if
     deallocate(rbarrier,sbarrier)
  end if

  call MPI_BARRIER(trmpi_comm,iertmp)
#endif

end subroutine trmpi_end_barrier
