Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

MPI_Type, MPI_Alltoallw, mpp_global_field update #5

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

MPI_Type, MPI_Alltoallw, mpp_global_field update #5

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
52 changes: 45 additions & 7 deletions mpp/include/mpp_alltoall_mpi.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,20 +18,17 @@
!***********************************************************************

subroutine MPP_ALLTOALL_(sbuf, scount, rbuf, rcount, pelist)

MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)
integer, intent(in) :: scount, rcount


integer, intent(in), optional :: pelist(0:)
integer :: n

if (.NOT. module_is_initialized) &
call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.')

n = get_peset(pelist)
! if (peset(n)%count .eq. 1) return

if (current_clock .NE. 0) call SYSTEM_CLOCK(start_tick)

Expand All @@ -48,7 +45,6 @@ end subroutine MPP_ALLTOALL_


subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)

MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

Expand All @@ -60,14 +56,13 @@ subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)
integer :: n

if (.NOT. module_is_initialized) &
call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.')
call mpp_error(FATAL, 'MPP_ALLTOALLV_: You must first call mpp_init.')

n = get_peset(pelist)
! if (peset(n)%count .eq. 1) return

if (current_clock .NE. 0) call SYSTEM_CLOCK(start_tick)

if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALL_: using MPI_Alltoallv...')
if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLV_: using MPI_Alltoallv...')

call MPI_Alltoallv(sbuf, ssize, sdispl, MPI_TYPE_, &
rbuf, rsize, rdispl, MPI_TYPE_, &
Expand All @@ -77,3 +72,46 @@ subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)
call increment_current_clock(EVENT_ALLTOALL, MPP_TYPE_BYTELEN_)

end subroutine MPP_ALLTOALLV_


subroutine MPP_ALLTOALLW_(sbuf, ssize, sdispl, stype, &
rbuf, rsize, rdispl, rtype, pelist)
MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

integer, intent(in) :: ssize(:), rsize(:)
integer, intent(in) :: sdispl(:), rdispl(:)
type(mpp_type), intent(in) :: stype(:), rtype(:)
integer, intent(in), optional :: pelist(0:)
integer :: i, n

integer, allocatable :: sendtypes(:), recvtypes(:)

if (.NOT. module_is_initialized) &
call mpp_error(FATAL, 'MPP_ALLTOALLW_: You must first call mpp_init.')

n = get_peset(pelist)

if (current_clock .NE. 0) call SYSTEM_CLOCK(start_tick)

if (verbose) call mpp_error(NOTE, 'MPP_ALLTOALLW_: using MPI_Alltoallw...')

! Convert mpp_types to MPI datatype IDs
! NOTE: sendtypes and recvtypes must be the same size
allocate(sendtypes(size(stype)))
allocate(recvtypes(size(rtype)))
do i = 1, size(stype)
sendtypes(i) = stype(i)%id
recvtypes(i) = rtype(i)%id
end do

call MPI_Alltoallw(sbuf, ssize, sdispl, sendtypes, &
rbuf, rsize, rdispl, recvtypes, &
peset(n)%id, error)

deallocate(sendtypes, recvtypes)

if (current_clock .NE. 0) &
call increment_current_clock(EVENT_ALLTOALL, MPP_TYPE_BYTELEN_)

end subroutine MPP_ALLTOALLW_
26 changes: 24 additions & 2 deletions mpp/include/mpp_alltoall_nocomm.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,6 @@
!***********************************************************************

subroutine MPP_ALLTOALL_(sbuf, scount, rbuf, rcount, pelist)

MPP_TYPE_, dimension(:), intent(in) :: sbuf
MPP_TYPE_, dimension(:), intent(inout) :: rbuf
integer, intent(in) :: scount, rcount
Expand All @@ -39,7 +38,6 @@ end subroutine MPP_ALLTOALL_


subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)

MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

Expand All @@ -59,3 +57,27 @@ subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)
call increment_current_clock(EVENT_ALLTOALL, MPP_TYPE_BYTELEN_)

end subroutine MPP_ALLTOALLV_


subroutine MPP_ALLTOALLW_(sbuf, ssize, sdispl, stype, &
rbuf, rsize, rdispl, rtype, pelist)
MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

integer, intent(in) :: ssize(:), rsize(:)
integer, intent(in) :: sdispl(:), rdispl(:)
type(mpp_type), intent(in) :: stype(:), rtype(:)

integer, intent(in), optional :: pelist(0:)

if (.NOT. module_is_initialized) &
call mpp_error(FATAL, 'MPP_ALLTOALL: You must first call mpp_init.')

if (current_clock .NE. 0) call SYSTEM_CLOCK(start_tick)

rbuf(:) = sbuf(:)

if (current_clock .NE. 0) &
call increment_current_clock(EVENT_ALLTOALL, MPP_TYPE_BYTELEN_)

end subroutine MPP_ALLTOALLW_
18 changes: 16 additions & 2 deletions mpp/include/mpp_alltoall_sma.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,6 @@
!***********************************************************************

subroutine MPP_ALLTOALL_(sbuf, scount, rbuf, rcount, pelist)

MPP_TYPE_, dimension(:), intent(in) :: sbuf
MPP_TYPE_, dimension(:), intent(inout) :: rbuf
integer, intent(in) :: scount, rcount
Expand All @@ -31,7 +30,6 @@ end subroutine MPP_ALLTOALL_


subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)

MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

Expand All @@ -43,3 +41,19 @@ subroutine MPP_ALLTOALLV_(sbuf, ssize, sdispl, rbuf, rsize, rdispl, pelist)
call mpp_error(FATAL, 'MPP_ALLTOALLV: No SHMEM implementation.')

end subroutine MPP_ALLTOALLV_


subroutine MPP_ALLTOALLW_(sbuf, ssize, sdispl, stype, &
rbuf, rsize, rdispl, rtype, pelist)
MPP_TYPE_, intent(in) :: sbuf(:)
MPP_TYPE_, intent(inout) :: rbuf(:)

integer, intent(in) :: ssize(:), rsize(:)
integer, intent(in) :: sdispl(:), rdispl(:)
type(mpp_type), intent(in) :: stype(:), rtype(:)

integer, intent(in), optional :: pelist(0:)

call mpp_error(FATAL, 'MPP_ALLTOALLW: No SHMEM implementation.')

end subroutine MPP_ALLTOALLW_
143 changes: 141 additions & 2 deletions mpp/include/mpp_comm_mpi.inc
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@
logical :: opened, existed
integer :: unit_begin, unit_end, unit_nml, io_status
character(len=5) :: this_pe
type(mpp_type), pointer :: dtype

if( module_is_initialized )return

Expand Down Expand Up @@ -79,6 +80,23 @@
tick_rate = 1./ticks_per_sec
clock0 = mpp_clock_id( 'Total runtime', flags=MPP_CLOCK_SYNC )

! Create the bytestream (default) mpp_datatype
mpp_byte%counter = 1
mpp_byte%ndims = 0
allocate(mpp_byte%sizes(0))
allocate(mpp_byte%subsizes(0))
allocate(mpp_byte%starts(0))
mpp_byte%etype = MPI_BYTE
mpp_byte%id = MPI_BYTE

mpp_byte%prev => null()
mpp_byte%next => null()

! Initialize datatype list with mpp_byte
datatypes%head => mpp_byte
datatypes%tail => mpp_byte
datatypes%length = 0

if( PRESENT(flags) )then
debug = flags.EQ.MPP_DEBUG
verbose = flags.EQ.MPP_VERBOSE .OR. debug
Expand Down Expand Up @@ -204,6 +222,7 @@ subroutine mpp_exit()
real :: t, tmin, tmax, tavg, tstd
real :: m, mmin, mmax, mavg, mstd, t_total
logical :: opened
type(mpp_type), pointer :: dtype

if( .NOT.module_is_initialized )return
call mpp_set_current_pelist()
Expand Down Expand Up @@ -291,14 +310,20 @@ subroutine mpp_exit()
close(etc_unit)
endif

! Clear derived data types (skipping list head, mpp_byte)
dtype => datatypes%head
do while (.not. associated(dtype))
dtype => dtype%next
dtype%counter = 1 ! Force deallocation
call mpp_type_free(dtype)
end do

call mpp_set_current_pelist()
call mpp_sync()
call mpp_max(mpp_stack_hwm)
if( pe.EQ.root_pe )write( out_unit,* )'MPP_STACK high water mark=', mpp_stack_hwm
if(mpp_comm_private == MPI_COMM_WORLD ) call MPI_FINALIZE(error)



return
end subroutine mpp_exit

Expand Down Expand Up @@ -1141,48 +1166,162 @@ end subroutine mpp_gsm_free

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_int4
#define MPP_ALLTOALLV_ mpp_alltoall_int4_v
#define MPP_ALLTOALLW_ mpp_alltoall_int4_w
#define MPP_TYPE_ integer(INT_KIND)
#define MPP_TYPE_BYTELEN_ 4
#define MPI_TYPE_ MPI_INTEGER4
#include <mpp_alltoall_mpi.h>

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_int8
#define MPP_ALLTOALLV_ mpp_alltoall_int8_v
#define MPP_ALLTOALLW_ mpp_alltoall_int8_w
#define MPP_TYPE_ integer(LONG_KIND)
#define MPP_TYPE_BYTELEN_ 8
#define MPI_TYPE_ MPI_INTEGER8
#include <mpp_alltoall_mpi.h>

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_real4
#define MPP_ALLTOALLV_ mpp_alltoall_real4_v
#define MPP_ALLTOALLW_ mpp_alltoall_real4_w
#define MPP_TYPE_ real(FLOAT_KIND)
#define MPP_TYPE_BYTELEN_ 4
#define MPI_TYPE_ MPI_REAL4
#include <mpp_alltoall_mpi.h>

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_real8
#define MPP_ALLTOALLV_ mpp_alltoall_real8_v
#define MPP_ALLTOALLW_ mpp_alltoall_real8_w
#define MPP_TYPE_ real(DOUBLE_KIND)
#define MPP_TYPE_BYTELEN_ 8
#define MPI_TYPE_ MPI_REAL8
#include <mpp_alltoall_mpi.h>

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_logical4
#define MPP_ALLTOALLV_ mpp_alltoall_logical4_v
#define MPP_ALLTOALLW_ mpp_alltoall_logical4_w
#define MPP_TYPE_ logical(INT_KIND)
#define MPP_TYPE_BYTELEN_ 4
#define MPI_TYPE_ MPI_INTEGER4
#include <mpp_alltoall_mpi.h>

#undef MPP_ALLTOALL_
#undef MPP_ALLTOALLV_
#undef MPP_ALLTOALLW_
#undef MPP_TYPE_
#undef MPP_TYPE_BYTELEN_
#undef MPI_TYPE_
#define MPP_ALLTOALL_ mpp_alltoall_logical8
#define MPP_ALLTOALLV_ mpp_alltoall_logical8_v
#define MPP_ALLTOALLW_ mpp_alltoall_logical8_w
#define MPP_TYPE_ logical(LONG_KIND)
#define MPP_TYPE_BYTELEN_ 8
#define MPI_TYPE_ MPI_INTEGER8
#include <mpp_alltoall_mpi.h>

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !
! DATA TRANSFER TYPES: mpp_type_create, mpp_type_free !
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

#define MPP_TYPE_CREATE_ mpp_type_create_int4
#define MPP_TYPE_ integer(INT_KIND)
#define MPI_TYPE_ MPI_INTEGER4
#include <mpp_type_mpi.h>

#define MPP_TYPE_CREATE_ mpp_type_create_int8
#define MPP_TYPE_ integer(LONG_KIND)
#define MPI_TYPE_ MPI_INTEGER8
#include <mpp_type_mpi.h>

#define MPP_TYPE_CREATE_ mpp_type_create_real4
#define MPP_TYPE_ real(FLOAT_KIND)
#define MPI_TYPE_ MPI_REAL4
#include <mpp_type_mpi.h>

#define MPP_TYPE_CREATE_ mpp_type_create_real8
#define MPP_TYPE_ real(DOUBLE_KIND)
#define MPI_TYPE_ MPI_REAL8
#include <mpp_type_mpi.h>

#define MPP_TYPE_CREATE_ mpp_type_create_logical4
#define MPP_TYPE_ logical(INT_KIND)
#define MPI_TYPE_ MPI_INTEGER4
#include <mpp_type_mpi.h>

#define MPP_TYPE_CREATE_ mpp_type_create_logical8
#define MPP_TYPE_ logical(LONG_KIND)
#define MPI_TYPE_ MPI_INTEGER8
#include <mpp_type_mpi.h>

! Clear preprocessor flags
#undef MPI_TYPE_
#undef MPP_TYPE_
#undef MPP_TYPE_CREATE_

! NOTE: This should probably not take a pointer, but for now we do this.
subroutine mpp_type_free(dtype)
type(mpp_type), pointer, intent(inout) :: dtype

if (.NOT. module_is_initialized) &
call mpp_error(FATAL, 'MPP_TYPE_FREE: You must first call mpp_init.')

if (current_clock .NE. 0) &
call SYSTEM_CLOCK(start_tick)

if (verbose) &
call mpp_error(NOTE, 'MPP_TYPE_FREE: using MPI_Type_free...')

! Decrement the reference counter
dtype%counter = dtype%counter - 1

if (dtype%counter < 1) then
! De-register the datatype in MPI runtime
call MPI_Type_free(dtype%id, error)

! Remove from list
dtype%prev => dtype%next

! Remove from memory
if (allocated(dtype%sizes)) deallocate(dtype%sizes)
if (allocated(dtype%subsizes)) deallocate(dtype%subsizes)
if (allocated(dtype%starts)) deallocate(dtype%starts)
deallocate(dtype)

datatypes%length = datatypes%length - 1
end if

if (current_clock .NE. 0) &
call increment_current_clock(EVENT_TYPE_FREE, MPP_TYPE_BYTELEN_)

end subroutine mpp_type_free
Loading