SPEED
Functions/Subroutines
SETUP_MPI.f90 File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine setup_mpi (nnode, node_proc, ncs, cs, nsend, node_send, nrecv, node_recv, nproc, proc_send, proc_recv, id, filempi, mpi_comm)
 Routine used to setup the communication buffer structure.
 

Function/Subroutine Documentation

◆ setup_mpi()

subroutine setup_mpi ( integer*4  nnode,
integer*4, dimension(nnode)  node_proc,
integer*4  ncs,
integer*4, dimension(0:ncs)  cs,
integer*4  nsend,
integer*4, dimension(nsend)  node_send,
integer*4  nrecv,
integer*4, dimension(nrecv)  node_recv,
integer*4  nproc,
integer*4, dimension(nproc)  proc_send,
integer*4, dimension(nproc)  proc_recv,
integer*4  id,
character*70  filempi,
integer*4  mpi_comm 
)

Routine used to setup the communication buffer structure.

Note
If run with nsend and nrecv equal to zero gives back the correct values of these to allocate node_send and node_recv, otherwise fills node_send and node_recv with the indices of the nodes to be sent to and received from the other processors, and proc_send and proc_recv with the number of nodes to be sent and received.
Author
Ilario Mazzieri
Date
September, 2013
Version
1.0
Parameters
[in]nnodenumber of nodes
[in]node_procvector containing the processor to which the node is assigned
[in]ncslength of the connectivity vector
[in]csconnectivity vector
[in]idprocessor identifyer
[in]filempifolder where to find file *.mpi
[in]mpi_commmpi common world
[out]nsendnumber of nodes to be sent to other processors
[out]node_sendordered vector of nodes to be sent
[out]nrecvnumber of nodes to be received from other procs
[out]node_recvordered vector of nodes to be received
[out]nprocnumber of processors
[out]proc_sendvector containing the number of the nodes to be sent to each proc.
[out]proc_recvvector containing the number of the nodes to be received from each proc.

Definition at line 43 of file SETUP_MPI.f90.

46
47
48 implicit none
49 include 'SPEED.MPI'
50
51 character*70 :: filename, filempi, filename_new
52
53 integer*4 :: nnode,ncs,nsend,nrecv,nproc,id,mpi_ierr
54 integer*4 :: i,j,k,ie,ip,ic,unitfile,ncs_mpi,nelem_mpi,nelem_loc, mpi_comm
55
56 integer*4, dimension(:), allocatable :: cs_mpi
57 integer*4, dimension(:), allocatable :: i4vec
58 integer*4, dimension(nnode) :: node_proc
59 integer*4, dimension(0:ncs) :: cs
60 integer*4, dimension(nsend) :: node_send
61 integer*4, dimension(nrecv) :: node_recv
62 integer*4, dimension(nproc) :: proc_send, proc_recv
63
64 !real*8 :: start1,start2
65 allocate(i4vec(ncs))
66 nelem_loc = cs(0) - 1
67
68
69 do ip = 1, nproc
70 if ((ip -1).eq.id) then
71 proc_recv(ip) = 0
72 else
73
74 i4vec = 0
75 ic = 0
76 do ie = 1,nelem_loc
77 do i = cs(ie -1) +1, cs(ie) -1
78 if (node_proc(cs(i)).eq.(ip -1)) then
79 ic = ic +1
80 i4vec(ic) = cs(i)
81 endif
82 enddo
83 enddo
84
85 !ordering nodes
86 do i = 1, ic
87 do j = i, ic
88 if (i4vec(j).lt.i4vec(i)) then
89 k = i4vec(i)
90 i4vec(i) = i4vec(j)
91 i4vec(j) = k
92 endif
93 enddo
94 enddo
95
96 !counting nodes to receive
97 j = 1
98 do i = 2, ic
99 if (i4vec(i).ne.i4vec(j)) then
100 j = j +1
101 i4vec(j) = i4vec(i)
102 endif
103 enddo
104
105 if (ic.eq.0) j = 0
106 proc_recv(ip) = j
107
108 !fill node_recv vector
109 if (nrecv.ne.0) then
110 ic = 0
111 do i = 1, ip -1
112 ic = ic +proc_recv(i)
113 enddo
114
115 do i = 1, proc_recv(ip)
116 node_recv(ic +i) = i4vec(i)
117 enddo
118 endif
119
120 endif
121 enddo
122
123 if (nrecv.eq.0) then
124 do i = 1, nproc
125 nrecv = nrecv +proc_recv(i)
126 enddo
127 endif
128
129 deallocate(i4vec)
130
131 do ip = 1, nproc
132
133 ! if(id .eq. 0) then
134
135 ! if(id .eq. ip-1) start1=MPI_WTIME()
136 ! filename = 'cons000000.mpi'
137 ! unitfile = 40
138 ! if (ip-1 .lt. 10) then
139 ! write(filename(10:10),'(i1)') ip-1
140 ! else if (ip-1 .lt. 100) then
141 ! write(filename(9:10),'(i2)') ip-1
142 ! else if (ip-1 .lt. 1000) then
143 ! write(filename(8:10),'(i3)') ip-1
144 ! else if (ip-1 .lt. 10000) then
145 ! write(filename(7:10),'(i4)') ip-1
146 ! else if (ip-1 .lt. 100000) then
147 ! write(filename(6:10),'(i5)') ip-1
148 ! else if (ip-1 .lt. 1000000) then
149 ! write(filename(5:10),'(i6)') ip-1
150 ! endif
151
152 ! if(len_trim(filempi) .ne. 70) then
153 ! filename_new = filempi(1:len_trim(filempi)) // '/' // filename
154 ! else
155 ! filename_new = filename
156 ! endif
157
158 ! open(unitfile,file=filename_new)
159 ! read(unitfile,*) ncs_mpi
160 ! allocate(cs_mpi(0:ncs_mpi))
161
162
163 ! do i = 0, ncs_mpi
164 ! read(unitfile,*) cs_mpi(i)
165 ! enddo
166 ! close(unitfile)
167
168 ! endif
169
170 !call MPI_SCATTER(ncs_mpi, 1, SPEED_INTEGER, ncs_mpi, 1, SPEED_INTEGER, 0, mpi_comm)
171 !call MPI_BCAST(ncs_mpi,1,SPEED_INTEGER,0,MPI_COMM_WORLD,mpi_ierr)
172 if(id .eq. ip-1) ncs_mpi = ncs;
173 call mpi_bcast(ncs_mpi,1,speed_integer,ip-1,mpi_comm_world,mpi_ierr)
174
175 !if(id .ne. 0) allocate(cs_mpi(0:ncs_mpi))
176 allocate(cs_mpi(0:ncs_mpi))
177 if(id .eq. ip-1) cs_mpi = cs;
178
179 call mpi_bcast(cs_mpi,ncs_mpi+1,speed_integer,ip-1,mpi_comm_world,mpi_ierr)
180
181 !call MPI_BCAST(cs_mpi,ncs_mpi+1,SPEED_INTEGER,0,MPI_COMM_WORLD,mpi_ierr)
182 !call MPI_SCATTER(cs_mpi,ncs_mpi+1, SPEED_INTEGER, cs_mpi, ncs_mpi+1, SPEED_INTEGER, 0, mpi_comm)
183
184 ! if(id .eq. ip-1) then
185 ! start2=MPI_WTIME()
186 ! write (*,*) "Time to send all .mpi files to all proc",start2-start1,"sec"
187 ! endif
188
189
190 allocate(i4vec(ncs_mpi))
191 nelem_mpi = cs_mpi(0)-1
192
193
194
195 if ((ip -1).eq.id) then
196 proc_send(ip) = 0
197 else
198 i4vec = 0
199
200 ic = 0
201 do ie = 1,nelem_mpi
202 do i = cs_mpi(ie -1) +1, cs_mpi(ie) -1
203 if (node_proc(cs_mpi(i)).eq.id) then
204 ic = ic +1
205 i4vec(ic) = cs_mpi(i)
206 endif
207 enddo
208 enddo
209
210 do i = 1, ic
211 do j = i, ic
212 if (i4vec(j).lt.i4vec(i)) then
213 k = i4vec(i)
214 i4vec(i) = i4vec(j)
215 i4vec(j) = k
216 endif
217 enddo
218 enddo
219
220 j = 1
221 do i = 2, ic
222 if (i4vec(i).ne.i4vec(j)) then
223 j = j +1
224 i4vec(j) = i4vec(i)
225 endif
226 enddo
227
228 if (ic .eq. 0) j = 0
229 proc_send(ip) = j
230
231 if (nsend.ne.0) then
232 ic = 0
233 do i = 1, ip -1
234 ic = ic +proc_send(i)
235 enddo
236
237 do i = 1, proc_send(ip)
238 node_send(ic +i) = i4vec(i)
239 enddo
240 endif
241 endif
242
243 deallocate(i4vec, cs_mpi)
244
245 enddo
246
247 if (nsend.eq.0) then
248 do i = 1, nproc
249 nsend = nsend +proc_send(i)
250 enddo
251 endif
252
253 return
254

Referenced by make_setup_mpi_conforming().

Here is the caller graph for this function: