Blob Blame History Raw
! -*- Mode: Fortran; -*-
!
!  (C) 2013 by Argonne National Laboratory.
!      See COPYRIGHT in top-level directory.
!
       program main
       use mpi_f08
       integer ierr
       integer smsg(3), rmsg(3), toterrs, wsize, wrank
       common /myinfo/ calls, amount, rcalls, ramount
       integer calls, amount, rcalls, ramount

       toterrs = 0
       call mpi_init( ierr )
       call init_counts()
       call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
       call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )

       if (wrank .eq. 0) then
           smsg(1) = 3
           call mpi_send( smsg, 1, MPI_INT, 1, 0, MPI_COMM_WORLD, ierr )
       else if (wrank .eq. 1) then
          call mpi_recv( rmsg, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &
      &         MPI_STATUS_IGNORE, ierr )
          if (rmsg(1) .ne. 3) then
             toterrs = toterrs + 1
             print *, "Unexpected received value ", rmsg(1)
          endif
       endif
!
!     check that we used the profiling versions of the routines
       toterrs = 0
       if (wrank .eq. 0) then
          if (calls.ne.1) then
             toterrs = toterrs + 1
             print *, "Sender calls is ", calls
          endif
          if (amount.ne.1) then
             toterrs = toterrs + 1
             print *, "Sender amount is ", amount
          endif
       else if (wrank .eq. 1) then
          if (rcalls.ne.1) then
             toterrs = toterrs + 1
             print *, "Receiver calls is ", rcalls
          endif
          if (ramount.ne.1) then
             toterrs = toterrs + 1
             print *, "Receiver amount is ", ramount
          endif
       endif

       call mtest_finalize( toterrs )
!
       end
!
       subroutine mpi_send_f08ts( smsg, count, dtype, dest, tag, comm, ierr )
       use :: mpi_f08, my_noname => mpi_send_f08ts
       type(*), dimension(..), intent(in) :: smsg
       integer, intent(in) :: count, dest, tag
       type(MPI_Datatype), intent(in) :: dtype
       type(MPI_Comm), intent(in) :: comm
       integer, optional, intent(out) :: ierr

       common /myinfo/ calls, amount, rcalls, ramount
       integer calls, amount, rcalls, ramount
!
       calls = calls + 1
       amount = amount + count
       if (present(ierr)) then
         call pmpi_send(smsg, count, dtype, dest, tag, comm, ierr)
       else
         call pmpi_send(smsg, count, dtype, dest, tag, comm)
       end if
       end
!
      subroutine mpi_recv_f08ts( rmsg, count, dtype, src, tag, comm, status, ierr )
       use :: mpi_f08, my_noname => mpi_recv_f08ts
       type(*), dimension(..), intent(in) :: rmsg
       integer, intent(in) :: count, src, tag
       type(MPI_Datatype), intent(in) :: dtype
       type(MPI_Comm), intent(in) :: comm
       type(MPI_Status) :: status
       integer, optional, intent(out) :: ierr

       common /myinfo/ calls, amount, rcalls, ramount
       integer calls, amount, rcalls, ramount
       rcalls = rcalls + 1
       ramount = ramount + 1
       if (present(ierr)) then
         call pmpi_recv(rmsg, count, dtype, src, tag, comm, status, ierr)
       else
         call pmpi_recv(rmsg, count, dtype, src, tag, comm, status)
       end if
       end
!
       subroutine init_counts()
       common /myinfo/ calls, amount, rcalls, ramount
       integer calls, amount, rcalls, ramount
       calls = 0
       amount = 0
       rcalls = 0
       ramount = 0
       end
!
       subroutine mpi_pcontrol( ierr )
       integer ierr
       return
       end