-
Notifications
You must be signed in to change notification settings - Fork 1
/
ddt_bw.f90
100 lines (90 loc) · 2.95 KB
/
ddt_bw.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
subroutine pingpong_usempi(buf, rank)
use mpi
implicit none
integer :: buf(0:1048577)
integer, intent(in) :: rank
double precision :: t0, t1
integer i, ierr
if (rank.eq.0) then
do i=0,1048577
buf(i) = i
enddo
call mpi_send(buf(1:1048576:2), 524288, MPI_INTEGER, 1, 0, MPI_COMM_WORLD, ierr)
call mpi_recv(buf(1:1048576:2), 524288, MPI_INTEGER, 1, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
t0 = MPI_Wtime()
do i=1,1024
call mpi_send(buf(1:1048576:2), 524288, MPI_INTEGER, 1, 0, MPI_COMM_WORLD, ierr)
call mpi_recv(buf(1:1048576:2), 524288, MPI_INTEGER, 1, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
end do
t1 = MPI_Wtime()
write (*,*) 'BW fortran = ', 1/(t1-t0), ' GW/s'
elseif (rank.eq.1) then
buf = -1
call mpi_recv(buf(1:1048576:2), 524288, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
call mpi_send(buf(1:1048576:2), 524288, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, ierr)
do i=1,1024
call mpi_recv(buf(1:1048576:2), 524288, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
call mpi_send(buf(1:1048576:2), 524288, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, ierr)
end do
do i=0,1048577,2
if (buf(i).ne.-1) write (*,*) 'buf(', i, ') = ', i, ' != -1'
enddo
do i=1,1048576,2
if (buf(i).ne.i) write (*,*) 'buf(', i, ') = ', i, ' != ', i
enddo
endif
end subroutine
subroutine pingpong_ddt(buf, rank)
use mpi
implicit none
integer :: buf(0:1048577)
integer, intent(in) :: rank
double precision :: t0, t1
integer :: datatype
integer i, ierr
call mpi_type_vector(524288, 1, 2, MPI_INT, datatype, ierr)
call mpi_type_commit(datatype, ierr)
if (rank.eq.0) then
do i=0,1048577
buf(i) = i
enddo
call mpi_send(buf(1), 1, datatype, 1, 0, MPI_COMM_WORLD, ierr)
call mpi_recv(buf(1), 1, datatype, 1, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
t0 = MPI_Wtime()
do i=1,1024
call mpi_send(buf(1), 1, datatype, 1, 0, MPI_COMM_WORLD, ierr)
call mpi_recv(buf(1), 1, datatype, 1, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
end do
t1 = MPI_Wtime()
write (*,*) 'BW ddt = ', 1/(t1-t0), ' GW/s'
elseif (rank.eq.1) then
buf = -1
call mpi_recv(buf(1), 1, datatype, 0, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
call mpi_send(buf(1), 1, datatype, 0, 0, MPI_COMM_WORLD, ierr)
do i=1,1024
call mpi_recv(buf(1), 1, datatype, 0, 0, MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
call mpi_send(buf(1), 1, datatype, 0, 0, MPI_COMM_WORLD, ierr)
end do
do i=0,1048577,2
if (buf(i).ne.-1) write (*,*) 'buf(', i, ') = ', i, ' != -1'
enddo
do i=1,1048576,2
if (buf(i).ne.i) write (*,*) 'buf(', i, ') = ', i, ' != ', i
enddo
endif
end subroutine
program pingpong
use mpi
implicit none
integer :: buf(0:1048577)
integer :: datatype, ierr
integer type_size
integer rank
call mpi_init(ierr)
call mpi_comm_rank(mpi_comm_world, rank, ierr)
call pingpong_usempi(buf, rank)
call mpi_barrier(MPI_COMM_WORLD, ierr)
call pingpong_ddt(buf, rank)
call mpi_barrier(MPI_COMM_WORLD, ierr)
call mpi_finalize(ierr)
end program