!
! Proposed MPI Interfaces;
!
!     Subroutine MPI_Isend(buf, count, datatype, dest, tag, comm,    &
!                          request, ierror)
!        VOID                  :: buf
!        ASYNCHRONOUS_EXT      :: buf
!        Integer, Intent (In)  :: count, datatype, dest, tag, comm
!        Integer, Intent (Out) :: request, ierror
!     End Subroutine MPI_Isend
!
!     Subroutine MPI_Irecv(buf, count, datatype, source, tag,        &
!                          comm, request, ierror)
!        VOID                  :: buf
!        ASYNCHRONOUS_EXT      :: buf
!        Intent (InOut)        :: buf
!        Integer, Intent (In)  :: count, datatype, source, tag, comm
!        Integer, Intent (Out) :: request, ierror
!     End Subroutine MPI_Irecv
!
! The ASYNCHRONOUS_EXT is an extension of the ASYNCHRONOUS attribute.
!
! The ASYNCHRONOUS_EXT attribute species the variables that might be associated
! with a pending sequence (the actual memory locations
! on which (asynchronous, non-blocking) communication is being performed)
! while the scoping unit is in execution. This information could be used
! by the compiler to disable certain code motion optimizations.
!
! The constraints on actual arguments that correspond to a dummy argument
! with ASYNCHRONOUS_EXT attribute are designed to avoid forcing a processor
! to use the so-called copy-in/copy-out argument passing mechanism.
! Making a copy of actual arguments whose values are likely to change due
! to a (non-blocking, asynchronous) communication operation completing or
! in some unpredictable manner will cause those new values to be lost
! when a called procedure returns and the copy-out overwrites the
! actual argument or the application program aborts.
!
! The ASYNCHRONOUS_EXT attribute is similar to the VOLATILE and ASYNCHRONOUS
! attribute. It is intended to facilitate traditional code motion
! optimizations in the presence of (asynchronous, non-blocking) communication.
!
      program isend
      use mpi

      implicit none
!     include 'mpif.h'

      Integer :: ierror, len, nprocs, rank
      Integer, Allocatable :: len_sent (:)

      call MPI_Init(ierror)

      call MPI_Comm_size (MPI_COMM_WORLD, nprocs, ierror)
      call MPI_Comm_rank (MPI_COMM_WORLD, rank,   ierror)

      Allocate (len_sent(nprocs), stat = ierror)
      if (ierror > 0) then
         print *, 'Error: could not allocate vector len_sent'
         call MPI_Abort (MPI_COMM_WORLD, 1, ierror)
      endif

      len = 10000
      if (rank == 0) then
         print *, 'Length per process:', len, ' reals'
#ifdef AVOID_COPY
         print *, 'Copy-in/Copy-out avoided'
#endif
      endif

      len_sent (:) = len

      call test_isend (len_sent, nprocs, rank) 

      call MPI_Finalize(ierror)

      end

      subroutine test_isend (len_sent, nprocs, rank)
      use mpi

      implicit none
!     include 'mpif.h'

      Integer, Intent (In) :: rank, nprocs
      Integer, Intent (In) :: len_sent (nprocs)

      Real, Pointer     :: send_vector (:), recv_vector (:)
      Integer           :: i, ierror, ip, j, len_tot, n_errors
      Integer           :: recv_req (nprocs)
      Integer           :: send_req (nprocs)

      len_tot = sum (len_sent)

!     Allocate vectors

      Allocate (send_vector(len_tot), stat = ierror)
      if (ierror > 0) then
         print *, 'Error: could not allocate send vector'
         call MPI_Abort (MPI_COMM_WORLD, 1, ierror)
      endif

      Allocate (recv_vector(len_tot), stat = ierror)
      if (ierror > 0) then
         print *, 'Error: could not allocate recv vector'
         call MPI_Abort (MPI_COMM_WORLD, 1, ierror)
      endif

!     Initialize vectors

      send_vector (:) = rank+1
      recv_vector (:) = -1

!     Non-blocking receive

      ip = 0
         do i = 1, nprocs
#ifdef AVOID_COPY
!        In this case, the program worked since 
!        copy-in/copy-out is not performed.
!
         call MPI_Irecv (recv_vector(ip+1), len_sent(i),                &
                         MPI_REAL, i-1, 1, MPI_COMM_WORLD, recv_req(i), &
                         ierror)
#else
!        A Fortran 90 compiler performed copy/in copy out at
!        this location and passed the temporary array to MPI_Irecv.
!        This caused incorrect results or segmentation violations.
!        
         call MPI_Irecv (recv_vector(ip+1:ip+len_sent(i)), len_sent(i), &
                         MPI_REAL, i-1, 1, MPI_COMM_WORLD, recv_req(i), &
                         ierror)
#endif
         ip = ip + len_sent (i)
         end do

!
      call MPI_Barrier (MPI_COMM_WORLD, ierror)

!     Non-Blocking send

      ip = 0
         do i = 1, nprocs
#ifdef AVOID_COPY
!        This avoids copy-in and incorrect results.
!
         call MPI_Isend (send_vector(ip+1), len_sent(i),                &
                         MPI_REAL, i-1, 1, MPI_COMM_WORLD, send_req(i), &
                         ierror)
#else
!        A Fortran 90 compiler may perform copy-in at this location and
!        may pass the temporary array to MPI_Isend.
!        This may cause incorrect results.
!
         call MPI_Isend (send_vector(ip+1:ip+len_sent(i)), len_sent(i), &
                         MPI_REAL, i-1, 1, MPI_COMM_WORLD, send_req(i), &
                         ierror)
#endif
         ip = ip + len_sent (i)
         end do
!
      call MPI_Barrier (MPI_COMM_WORLD, ierror)

!     Wait for completion of non-blocking requests

      call MPI_Waitall (nprocs, send_req, MPI_STATUSES_IGNORE, ierror)
      call MPI_Waitall (nprocs, recv_req, MPI_STATUSES_IGNORE, ierror)

!     Control

      n_errors = 0
      ip = 0
         do i = 1, nprocs
            do j = 1, len_sent(i)
            if (recv_vector (ip+j) /= i) then
               print *, rank, 'error in element ', ip+j, ', expected:', i, &
                        ' got', recv_vector (ip+j)
               n_errors = n_errors + 1
            endif
            end do

            ip = ip + len_sent (i)
         end do
!
      call MPI_Allreduce (MPI_IN_PLACE, n_errors, 1, MPI_INTEGER, MPI_SUM, &
                          MPI_COMM_WORLD, ierror)

      if (n_errors == 0 .and. rank == 0) then
         print *, "No errors detected"
      endif

!     Free memory

      Deallocate (send_vector, recv_vector)

      return
      end