mp_rget_rv Subroutine

private subroutine mp_rget_rv(base, source, win, win_data, myproc, disp, request, origin_datatype, target_datatype)

Single-sided get function for vector data

Arguments

TypeIntentOptionalAttributesName
real(kind=real_4), CONTIGUOUS, DIMENSION(:):: base
integer, intent(in) :: source
integer, intent(in) :: win
real(kind=real_4), CONTIGUOUS, DIMENSION(:):: win_data
integer, intent(in), optional :: myproc
integer, intent(in), optional :: disp
integer, intent(out) :: request
type(mp_type_descriptor_type), intent(in), optional :: origin_datatype
type(mp_type_descriptor_type), intent(in), optional :: target_datatype

Contents

Source Code


Source Code

      SUBROUTINE mp_rget_rv(base, source, win, win_data, myproc, disp, request, &
                                        origin_datatype, target_datatype)
      !! Single-sided get function for vector data
      !! @note
      !! arrays can be pointers or assumed shape, but they must be contiguous!

         REAL(kind=real_4), CONTIGUOUS, DIMENSION(:)                 :: base
         INTEGER, INTENT(IN)                                 :: source, win
         REAL(kind=real_4), CONTIGUOUS, DIMENSION(:)                 :: win_data
         INTEGER, INTENT(IN), OPTIONAL                       :: myproc, disp
         INTEGER, INTENT(OUT)                                :: request
         TYPE(mp_type_descriptor_type), INTENT(IN), OPTIONAL :: origin_datatype, target_datatype

         CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_rget_rv'

         INTEGER                                  :: ierr, handle
#if defined(__parallel) && (__MPI_VERSION > 2)
         INTEGER                                  :: len, &
                                                     handle_origin_datatype, &
                                                     handle_target_datatype, &
                                                     origin_len, target_len
         LOGICAL                                  :: do_local_copy
         INTEGER(kind=mpi_address_kind)           :: disp_aint
#endif

         ierr = 0
         CALL timeset(routineN, handle)

#if defined(__parallel)
#if __MPI_VERSION > 2
         len = SIZE(base)
         disp_aint = 0
         IF (PRESENT(disp)) THEN
            disp_aint = INT(disp, KIND=mpi_address_kind)
         END IF
         handle_origin_datatype = MPI_REAL
         origin_len = len
         IF (PRESENT(origin_datatype)) THEN
            handle_origin_datatype = origin_datatype%type_handle
            origin_len = 1
         END IF
         handle_target_datatype = MPI_REAL
         target_len = len
         IF (PRESENT(target_datatype)) THEN
            handle_target_datatype = target_datatype%type_handle
            target_len = 1
         END IF
         IF (len > 0) THEN
            do_local_copy = .FALSE.
#if !defined(__DBCSR_DISABLE_RMA_LOCAL_COPY)
            IF (PRESENT(myproc) .AND. .NOT. PRESENT(origin_datatype) .AND. .NOT. PRESENT(target_datatype)) THEN
               IF (myproc .EQ. source) do_local_copy = .TRUE.
            END IF
#else
            MARK_USED(myproc)
#endif
            IF (do_local_copy) THEN
#if !defined(__DBCSR_DISABLE_WORKSHARE)
!$OMP           PARALLEL WORKSHARE DEFAULT(none) SHARED(base,win_data,disp_aint,len)
#endif
               base(:) = win_data(disp_aint + 1:disp_aint + len)
#if !defined(__DBCSR_DISABLE_WORKSHARE)
!$OMP           END PARALLEL WORKSHARE
#endif
               request = mp_request_null
               ierr = 0
            ELSE
               CALL mpi_rget(base(1), origin_len, handle_origin_datatype, source, disp_aint, &
                             target_len, handle_target_datatype, win, request, ierr)
            END IF
         ELSE
            request = mp_request_null
            ierr = 0
         END IF
#else
         MARK_USED(source)
         MARK_USED(win)
         MARK_USED(disp)
         MARK_USED(myproc)
         MARK_USED(origin_datatype)
         MARK_USED(target_datatype)
         MARK_USED(win_data)

         request = mp_request_null
         DBCSR_ABORT("mp_rget requires MPI-3 standard")
#endif
         IF (ierr /= 0) CALL mp_stop(ierr, "mpi_rget @ "//routineN)

         CALL add_perf(perf_id=25, msg_size=SIZE(base)*real_4_size)
#else
         MARK_USED(source)
         MARK_USED(win)
         MARK_USED(myproc)
         MARK_USED(origin_datatype)
         MARK_USED(target_datatype)

         request = mp_request_null
         !
         IF (PRESENT(disp)) THEN
            base(:) = win_data(disp + 1:disp + SIZE(base))
         ELSE
            base(:) = win_data(:SIZE(base))
         END IF

#endif
         CALL timestop(handle)
      END SUBROUTINE mp_rget_rv