-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathmatrixMultiply.f90
150 lines (138 loc) · 4.89 KB
/
matrixMultiply.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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
program main
implicit none
include "mpif.h"
integer myid, master, numprocs, ierr
integer, dimension(MPI_STATUS_SIZE) :: stat
call MPI_INIT( ierr)
call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr)
master = 0
if ( myid == master ) then
call master_func(myid, master, numprocs, ierr, stat)
else
continue
! call slave_func(myid, master, numprocs, ierr, stat)
end if
call MPI_FINALIZE ( ierr )
stop
end program
subroutine master_func(myid, master, numprocs, ierr, stat)
implicit none
include "mpif.h"
integer i,j
integer myid, master, numprocs, ierr
integer rows1, cols1, rows2, cols2, rows3, cols3
integer, dimension(MPI_STATUS_SIZE) :: stat
real, allocatable, dimension(:,:) :: A
real, allocatable, dimension(:,:) :: B
real, allocatable, dimension(:,:) :: C
do while (.true.)
print *, "Enter rows1 cols1 rows2 cols2, zero or negative for exit"
read (*,*) rows1, cols1, rows2, cols2
if (cols1 <= 0 .or. rows1 <= 0 .or. &
cols2 <= 0 .or. rows2 <= 0) then
print *, "Exiting"
return
else if (cols1 /= rows2) then
print *, "cols1 must equal rows2."
cycle
end if
rows3 = rows1
cols3 = cols2
allocate(A(1:rows1, 1:cols1), B(1:rows2, 1:cols2), C(1:rows3,1:cols3))
do i = 1,rows1
do j = 1,cols1
if (i == j) then
A(i,j) = 1
else
A(i,j) = 0
end if
end do
end do
do i = 1,rows2
do j = 1,cols2
B(i,j) = i + j
end do
end do
call multiply(rows1, cols1, A, rows2, cols2, B, rows3, cols3, C, &
myid, master, numprocs, ierr, stat)
call print_matrix(rows3, cols3, C)
deallocate(A, B, C)
end do
end subroutine
subroutine multiply(rowsA, colsA, A, rowsB, colsB, B, rowsC, colsC, C, &
myid, master, numprocs, ierr, stat)
implicit none
include "mpif.h"
integer :: myid, master, numprocs, ierr
integer :: colsA, rowsA, colsB, rowsB, rowsC, colsC
integer :: num_sent, num_received, tag
integer :: i, j, k
integer, dimension(MPI_STATUS_SIZE) :: stat
real, dimension(rowsA, colsA) :: A
real, dimension(rowsB, colsB) :: B
real, dimension(rowsC, colsC) :: C
real, dimension(colsC) :: buffer
! First distribute the requisite parameter
call MPI_BCAST(rowsA, 1, MPI_REAL, master, MPI_COMM_WORLD, ierr)
call MPI_BCAST(colsA, 1, MPI_REAL, master, MPI_COMM_WORLD, ierr)
call MPI_BCAST(rowsB, 1, MPI_REAL, master, MPI_COMM_WORLD, ierr)
call MPI_BCAST(colsB, 1, MPI_REAL, master, MPI_COMM_WORLD, ierr)
! Distibute B to all slaves
call MPI_BCAST(B, rowsB*colsB, MPI_REAL, master, MPI_COMM_WORLD, ierr)
! For each row, distribute a row of A to a supplicant slave
num_sent = 0
num_received = 0
do i = 1,min(numprocs - 1, rowsC)
call MPI_SEND(A(i,:), colsA, i, i, MPI_COMM_WORLD, ierr)
num_sent = num_sent + 1
end do
! Now, while there are remaining rows, grab incoming messages and pass rows out
do while (num_sent < rowsC)
call MPI_RECV(buffer, colsC, MPI_ANY_SOURCE, MPI_ANY_TAG, stat, ierr)
num_received = num_received + 1
C(:, stat(MPI_TAG)) = buffer(:)
call MPI_SEND(A(num_sent+1,:), colsA, MPI_REAL, stat(MPI_SOURCE), num_sent+1, &
MPI_COMM_WORLD, ierr)
num_sent = num_sent + 1
end do
! Now receive the remaining messages, terminating processes as we go
do while (num_received < rowsC)
call MPI_RECV(buffer, colsC, MPI_ANY_SOURCE, MPI_ANY_TAG, stat, ierr)
num_received = num_received + 1
C(:, stat(MPI_TAG)) = buffer(:)
end do
do i = 1:numprocs - 1
call MPI_SEND(1.0, 0, MPI_REAL, stat(MPI_SOURCE), 0, MPI_COMM_WORLD, ierr)
end do
end subroutine
subroutine slave_func(myid, master, numprocs, ierr, stat)
implicit none
include "mpif.h"
integer :: myid, master, numprocs, ierr
integer :: colsA, rowsA, colsB, rowsB, rowsC, colsC
integer :: i, j, k
integer, dimension(MPI_STATUS_SIZE) :: stat
real, allocatable, dimension(:,:) :: B
real, allocatable, dimension(:) :: data_buffer
real, allocatable, dimension(:) :: answer_buffer
do while (.true.)
call MPI_RECV(rowsA, 1, MPI_INTEGER, master, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
call MPI_RECV(colsA, 1, MPI_INTEGER, master, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
call MPI_RECV(rowsB, 1, MPI_INTEGER, master, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
call MPI_RECV(colsB, 1, MPI_INTEGER, master, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
allocate(B(1:rowsB, 1:colsB), data_buffer(colsA), answer_buffer(colsB)
call MPI_RECV(B, rowsB*colsB, MPI_REAL, master, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
end do
end subroutine
subroutine print_matrix(rows, cols, matrix)
implicit none
integer :: rows, cols, i, j
real, dimension(rows, cols) :: matrix
do i = 1,rows
do j = 1,cols
write (*, "(f10.2)", advance="no") matrix(i,j)
end do
print *, ""
end do
end subroutine