Line data Source code
1 : module schedule_mod
2 : use metagraph_mod, only: MetaEdge_t
3 : use schedtype_mod, only: Cycle_t, Schedule_t, schedule, pgindex_t, HME_Ordinal,HME_Cardinal
4 : use parallel_mod, only: parallel_t
5 : use cam_logfile, only: iulog
6 :
7 : implicit none
8 : private
9 :
10 : type, public :: GraphStats_t
11 : integer :: offnode
12 : integer :: onnode
13 : integer :: LB
14 : integer :: padding
15 : end type GraphStats_t
16 :
17 : integer,public,parameter :: HME_CYCLE_SEND=1
18 : integer,public,parameter :: HME_CYCLE_RECV=2
19 : integer,public,parameter :: HME_CYCLE_MOVE=3
20 : integer,public,parameter :: HME_CYCLE_ANY =4
21 :
22 :
23 : integer,public,parameter :: BNDRY_EXCHANGE_MESSAGE=10
24 : integer,private,allocatable,target :: Global2Local(:)
25 :
26 : integer :: MinNelemd,MaxNelemd
27 :
28 : public :: genEdgeSched ! Setup the communication schedule for the edge based boundary exchange
29 : public :: PrintSchedule, PrintCycle
30 : public :: PrintIndex
31 : public :: CheckSchedule
32 : public :: FindBufferSlot
33 :
34 : contains
35 :
36 1536 : subroutine genEdgeSched(par,elem, PartNumber,LSchedule,MetaVertex)
37 : use element_mod, only: element_t
38 : use metagraph_mod, only: metavertex_t
39 : use dimensions_mod, only: nelem, max_neigh_edges
40 : use gridgraph_mod, only: gridvertex_t, gridedge_t, assignment ( = )
41 : use cam_abortutils, only: endrun
42 : use spmd_utils, only: mpi_status_size, mpi_info_null, mpi_success
43 : use parallel_mod, only: nComPoints, rrequest, srequest, status, npackpoints
44 :
45 : type(parallel_t), intent(inout) :: par
46 : type(element_t), intent(inout) :: elem(:)
47 : integer, intent(in) :: PartNumber
48 : type (schedule_t), intent(inout) :: LSchedule
49 : type (MetaVertex_t), intent(inout) :: MetaVertex
50 :
51 : integer :: lengthP,lengthS,total_length,lengthp_ghost
52 : integer :: i,j,is,ir,ncycle
53 : integer :: il,ie,ig
54 : integer :: nelemd0
55 : integer :: jmd
56 : integer :: inbr
57 : integer :: nSched
58 1536 : integer,allocatable :: tmpP(:,:)
59 1536 : integer,allocatable :: tmpS(:,:)
60 1536 : integer,allocatable :: tmpP_ghost(:,:)
61 : integer :: nSend,nRecv,nedges
62 : integer :: icycle
63 : integer :: iSched
64 : logical, parameter :: VerbosePrint=.FALSE.
65 : logical, parameter :: Debug=.FALSE.
66 : character(len=*), parameter :: subname = 'genEdgeSched'
67 : integer :: errorcode,errorlen
68 : character*(80) :: errorstring
69 : integer, allocatable :: intracommranks(:)
70 : integer :: numIntra, numInter, rank
71 : logical :: OnNode
72 :
73 :
74 : integer :: ierr
75 : integer :: l1,l2,l1id,l2id
76 : integer :: src,dest,wgt
77 : integer :: icIntra, icInter
78 :
79 1536 : integer, allocatable :: srcFull(:), destFull(:), srcweightFull(:), destweightFull(:)
80 1536 : integer, allocatable :: srcInter(:),destInter(:), srcweightInter(:),destweightInter(:)
81 1536 : integer, allocatable :: srcIntra(:),destIntra(:), srcweightIntra(:),destweightIntra(:)
82 :
83 : logical :: reorder
84 : integer :: sizeGroup, groupFull
85 :
86 1536 : nSched=SIZE(schedule)
87 : ! ================================================
88 : ! allocate some arrays for the call to MPI_gatherv
89 : ! ================================================
90 :
91 1536 : MinNelemd = nelem
92 1536 : MaxNelemd = 0
93 : ! =====================================================
94 : ! It looks like this is only used in this routine...
95 : ! so no need to put it in the schedule data-structure
96 : ! =====================================================
97 4608 : allocate(Global2Local(nelem))
98 : if(Debug) write(iulog,*)'genEdgeSched: point #1'
99 1536 : iSched = PartNumber
100 :
101 1536 : nelemd0 = MetaVertex%nmembers
102 1536 : MaxNelemd = AMAX0(MaxNelemd,nelemd0)
103 1536 : MinNelemd = AMIN0(MinNelemd,nelemd0)
104 : if(Debug) write(iulog,*)'genEdgeSched: point #2'
105 :
106 : if(Debug) write(iulog,*)'genEdgeSched: point #3'
107 1536 : LSchedule%ncycles = MetaVertex%nedges
108 1536 : LSchedule%nelemd = nelemd0
109 : if(Debug) write(iulog,*)'genEdgeSched: point #4'
110 :
111 : ! Note the minus one is for the internal node
112 1536 : nedges = MetaVertex%nedges
113 1536 : if(2*(nedges/2) .eq. nedges) then
114 : nedges = nedges/2
115 : else
116 1536 : nedges = (nedges-1)/2
117 : endif
118 1536 : LSchedule%nSendCycles = nedges
119 1536 : LSchedule%nRecvCycles = nedges
120 : if(Debug) write(iulog,*)'genEdgeSched: point #5'
121 :
122 : ! Temporary array to calculate the Buffer Slot
123 4608 : allocate(tmpP(2,nedges+1))
124 3072 : allocate(tmpS(2,nedges+1))
125 3072 : allocate(tmpP_ghost(2,nedges+1))
126 :
127 :
128 : ! Allocate all the cycle structures
129 4608 : allocate(LSchedule%SendCycle(nedges))
130 3072 : allocate(LSchedule%RecvCycle(nedges))
131 1536 : allocate(LSchedule%MoveCycle(1))
132 :
133 : ! Initialize the schedules...
134 1536 : LSchedule%MoveCycle(1)%ptrP = 0
135 1536 : LSchedule%MoveCycle(1)%ptrS = 0
136 1536 : LSchedule%MoveCycle(1)%lengthP = 0
137 : if(Debug) write(iulog,*)'genEdgeSched: point #6'
138 :
139 : !==================================================================
140 : ! Allocate and initalized the index translation arrays
141 8295936 : Global2Local = -1
142 4608 : allocate(LSchedule%Local2Global(nelemd0))
143 4608 : allocate(LSchedule%pIndx(max_neigh_edges*nelemd0))
144 3072 : allocate(LSchedule%gIndx(max_neigh_edges*nelemd0))
145 :
146 87936 : LSchedule%pIndx(:)%elemId = -1
147 87936 : LSchedule%pIndx(:)%edgeId = -1
148 87936 : LSchedule%pIndx(:)%lenP = -1
149 87936 : LSchedule%pIndx(:)%lenS = -1
150 87936 : LSchedule%pIndx(:)%mesgid = -1
151 87936 : LSchedule%pIndx(:)%edgeType = -1
152 :
153 87936 : LSchedule%gIndx(:)%elemId = -1
154 87936 : LSchedule%gIndx(:)%edgeId = -1
155 87936 : LSchedule%gIndx(:)%lenP = -1
156 87936 : LSchedule%gIndx(:)%lenS = -1
157 87936 : LSchedule%gIndx(:)%mesgid = -1
158 87936 : LSchedule%gIndx(:)%edgeType = -1
159 :
160 1536 : LSchedule%pPtr=1
161 1536 : LSchedule%gPtr=1
162 :
163 : if(Debug) write(iulog,*)'genEdgeSched: point #7'
164 :
165 12336 : do il=1,nelemd0
166 10800 : ig = MetaVertex%members(il)%number
167 10800 : Global2Local(ig)=il
168 10800 : LSchedule%Local2Global(il)=ig
169 97200 : elem(il)%desc%putmapP=-1
170 97200 : elem(il)%desc%getmapP=-1
171 97200 : elem(il)%desc%putmapS=-1
172 97200 : elem(il)%desc%getmapS=-1
173 97200 : elem(il)%desc%putmapP_ghost=-1
174 97200 : elem(il)%desc%getmapP_ghost=-1
175 98736 : elem(il)%desc%reverse = .FALSE.
176 : enddo
177 : !==================================================================
178 : if(Debug) write(iulog,*)'genEdgeSched: point #8'
179 :
180 :
181 :
182 1536 : total_length = 0
183 1536 : ncycle = LSchedule%ncycles
184 : !
185 : ! Send Cycle
186 : !
187 1536 : is=1
188 12964 : tmpP(1,:) = -1
189 12964 : tmpP(2,:) = 0
190 12964 : tmpS(1,:) = -1
191 12964 : tmpS(2,:) = 0
192 12964 : tmpP_ghost(1,:) = -1
193 12964 : tmpP_ghost(2,:) = 0
194 :
195 22856 : do j=1,ncycle
196 21320 : lengthP = MetaVertex%edges(j)%wgtP
197 21320 : lengthS = MetaVertex%edges(j)%wgtS
198 21320 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
199 :
200 21320 : if ((MetaVertex%edges(j)%TailVertex == PartNumber) .AND. &
201 1536 : (MetaVertex%edges(j)%HeadVertex .ne. PartNumber) ) then
202 9892 : inbr = MetaVertex%edges(j)%HeadVertex
203 : if(Debug) write(iulog,*)'genEdgeSched: point #11', par%rank
204 9892 : LSchedule%SendCycle(is)%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
205 9892 : LSchedule%SendCycle(is)%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
206 9892 : LSchedule%SendCycle(is)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
207 9892 : call SetCycle(par, elem, LSchedule,LSchedule%SendCycle(is),MetaVertex%edges(j), HME_CYCLE_SEND)
208 : if(Debug) write(iulog,*)'genEdgeSched: point #12',par%rank
209 9892 : is = is+1
210 : endif
211 : enddo
212 :
213 : !
214 : ! Recv Cycle: Note that by reinitializing the tmpP array we change the structure of the receive buffer
215 : !
216 1536 : ir=1
217 12964 : tmpP(1,:) = -1
218 12964 : tmpP(2,:) = 0
219 12964 : tmpS(1,:) = -1
220 12964 : tmpS(2,:) = 0
221 12964 : tmpP_ghost(1,:) = -1
222 12964 : tmpP_ghost(2,:) = 0
223 :
224 22856 : do j=1,ncycle
225 21320 : lengthP = MetaVertex%edges(j)%wgtP
226 21320 : lengthS = MetaVertex%edges(j)%wgtS
227 21320 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
228 :
229 21320 : if ( (MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
230 1536 : (MetaVertex%edges(j)%TailVertex .ne. PartNumber) ) then
231 9892 : inbr = MetaVertex%edges(j)%TailVertex
232 : if(Debug) write(iulog,*)'genEdgeSched: point #13',par%rank
233 9892 : LSchedule%RecvCycle(ir)%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
234 9892 : LSchedule%RecvCycle(ir)%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
235 9892 : LSchedule%RecvCycle(ir)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
236 9892 : call SetCycle(par, elem, LSchedule,LSchedule%RecvCycle(ir),MetaVertex%edges(j),HME_CYCLE_RECV)
237 : if(Debug) write(iulog,*)'genEdgeSched: point #14',par%rank
238 9892 : ir = ir+1
239 : endif
240 : enddo
241 :
242 : ! Put the move cycle at the end of the buffer.
243 22856 : do j=1,ncycle
244 21320 : lengthP = MetaVertex%edges(j)%wgtP
245 21320 : lengthS = MetaVertex%edges(j)%wgtS
246 21320 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
247 :
248 21320 : if((MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
249 1536 : (MetaVertex%edges(j)%TailVertex == PartNumber)) then
250 1536 : inbr = PartNumber
251 : if(Debug) write(iulog,*)'genEdgeSched: point #9', par%rank
252 3072 : LSchedule%MoveCycle%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
253 3072 : LSchedule%MoveCycle%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
254 3072 : LSchedule%MoveCycle%ptrP_ghost = FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
255 1536 : call SetCycle(par, elem, LSchedule,LSchedule%MoveCycle(1),MetaVertex%edges(j),HME_CYCLE_MOVE)
256 : if(Debug) write(iulog,*)'genEdgeSched: point #10',par%rank
257 : endif
258 : enddo
259 :
260 1536 : deallocate(tmpP)
261 1536 : deallocate(tmpS)
262 1536 : deallocate(tmpP_ghost)
263 :
264 12336 : do ie=1,nelemd0
265 : ! compute number of neighbers for each element
266 10800 : elem(ie)%desc%actual_neigh_edges=0
267 97200 : do i=1,max_neigh_edges
268 97200 : if (elem(ie)%desc%globalID(i)>0) then
269 86352 : elem(ie)%desc%actual_neigh_edges=elem(ie)%desc%actual_neigh_edges+1
270 : endif
271 : enddo
272 :
273 : ! normally, we loop over max_neigh_edges, checking if there is an edge
274 : ! let's create a mapping so that we can loop over actual_neigh_edges
275 : ! sort in REVERSE global id order (so the ones with globalID=0 are last)
276 86400 : do l1 = 1,max_neigh_edges-1
277 388800 : do l2=l1+1,max_neigh_edges
278 302400 : l1id=elem(ie)%desc%loc2buf(l1)
279 302400 : l2id=elem(ie)%desc%loc2buf(l2)
280 378000 : if (elem(ie)%desc%globalID(l2id) > elem(ie)%desc%globalID(l1id)) then
281 : ! swap index:
282 191132 : l1id=elem(ie)%desc%loc2buf(l2)
283 191132 : elem(ie)%desc%loc2buf(l2)=elem(ie)%desc%loc2buf(l1)
284 191132 : elem(ie)%desc%loc2buf(l1)=l1id
285 : endif
286 : enddo
287 : enddo
288 :
289 :
290 :
291 :
292 10800 : elem(ie)%vertex = MetaVertex%members(ie)
293 10800 : ig = MetaVertex%members(ie)%number
294 10800 : elem(ie)%GlobalId = ig
295 23136 : elem(ie)%LocalId = ie
296 : enddo
297 :
298 1536 : deallocate(Global2Local)
299 :
300 : #ifdef SPMD
301 : !================================================================
302 : ! Allocate a couple of structures for bndry_exchange
303 : ! done here to remove it from the critical path
304 : !================================================================
305 1536 : nComPoints = 0
306 :
307 1536 : nSend = nedges
308 1536 : nRecv = nedges
309 4608 : allocate(Rrequest(nRecv))
310 3072 : allocate(Srequest(nSend))
311 4608 : allocate(status(MPI_STATUS_SIZE,nRecv))
312 :
313 : !===============================================================
314 : ! Number of communication points ... to be used later to
315 : ! setup the size of the communication buffer for MPI_Ibsend
316 : !===============================================================
317 11428 : do icycle = 1, nSend
318 11428 : nComPoints = nComPoints + LSchedule%SendCycle(icycle)%lengthP
319 : end do
320 1536 : nPackPoints = nComPoints + LSchedule%MoveCycle(1)%lengthP
321 : #if MPI_VERSION >= 3
322 : ! Create a communicator that only contains the on-node MPI ranks
323 : call MPI_Comm_split_type(par%comm, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, par%intracomm, ierr)
324 :
325 : call MPI_Comm_size(par%intracomm, par%intracommsize, ierr)
326 : call MPI_Comm_rank(par%intracomm, par%intracommrank, ierr)
327 :
328 : allocate(intracommranks(par%intracommsize))
329 : call MPI_Allgather(par%rank,1,MPIinteger_t,intracommranks,1,MPIinteger_t,par%intracomm,ierr)
330 :
331 : numIntra=0
332 : do icycle=1,nSend
333 : rank = LSchedule%SendCycle(icycle)%dest - 1
334 : onNode = isIntraComm(intracommranks,rank)
335 : LSchedule%SendCycle(icycle)%onNode = onNode
336 : if(onNode) then
337 : numIntra=numIntra+1
338 : endif
339 : enddo
340 : do icycle=1,nRecv
341 : rank = LSchedule%RecvCycle(icycle)%source - 1
342 : onNode = isIntraComm(intracommranks,rank)
343 : LSchedule%RecvCycle(icycle)%onNode = onNode
344 : enddo
345 : numInter = nsend-numIntra
346 :
347 :
348 : deallocate(intracommranks)
349 : #else
350 1536 : numIntra = 0
351 1536 : numInter = nSend
352 : ! Mark all communications as off-node by default
353 11428 : do icycle=1,nSend
354 11428 : LSchedule%SendCycle(icycle)%onNode = .False.
355 : enddo
356 11428 : do icycle=1,nRecv
357 11428 : LSchedule%RecvCycle(icycle)%onNode = .False.
358 : enddo
359 : #endif
360 1536 : LSchedule%nInter = numInter
361 1536 : LSchedule%nIntra = numIntra
362 :
363 7680 : allocate(srcFull(nRecv), srcWeightFull(nRecv),destFull(nSend),destWeightFull(nSend))
364 1536 : if(numInter>0) then
365 7680 : allocate(srcInter(numInter),srcWeightInter(numInter),destInter(numInter), destWeightInter(numInter))
366 : endif
367 : if(numIntra>0) then
368 : allocate(srcIntra(numIntra),srcWeightIntra(numIntra),destIntra(numIntra), destWeightIntra(numIntra))
369 : endif
370 :
371 : icIntra=0
372 : icInter=0
373 11428 : do icycle=1,nSend
374 9892 : dest = LSchedule%SendCycle(icycle)%dest - 1
375 9892 : wgt = LSchedule%SendCycle(icycle)%lengthP
376 9892 : destFull(icycle) = dest
377 9892 : destWeightFull(icycle) = wgt
378 11428 : if(LSchedule%SendCycle(icycle)%onNode) then
379 0 : icIntra=icIntra+1
380 0 : destIntra(icIntra) = dest
381 0 : destWeightIntra(icIntra) = wgt
382 : else
383 9892 : icInter=icInter+1
384 9892 : destInter(icInter) = dest
385 9892 : destWeightInter(icInter) = wgt
386 : endif
387 : enddo
388 :
389 1536 : icIntra=0
390 1536 : icInter=0
391 11428 : do icycle=1,nRecv
392 9892 : src = LSchedule%RecvCycle(icycle)%source - 1
393 9892 : wgt = LSchedule%RecvCycle(icycle)%lengthP
394 9892 : srcFull(icycle) = src
395 9892 : srcWeightFUll(icycle) = wgt
396 11428 : if(LSchedule%RecvCycle(icycle)%onNode) then
397 0 : icIntra=icIntra+1
398 0 : srcIntra(icIntra) = src
399 0 : srcWeightIntra(icIntra) = wgt
400 : else
401 9892 : icInter=icInter+1
402 9892 : srcInter(icInter) = src
403 9892 : srcWeightInter(icInter) = wgt
404 : endif
405 : enddo
406 :
407 : ! construct the FULL communication graph
408 1536 : reorder=.FALSE.
409 : call MPI_Dist_graph_create_adjacent(par%comm, nRecv,srcFull,srcWeightFull, &
410 1536 : nSend,destFull,destWeightFull,MPI_INFO_NULL,reorder,par%commGraphFull,ierr)
411 1536 : if(ierr .ne. MPI_SUCCESS) then
412 0 : errorcode=ierr
413 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
414 0 : print *,subname,': Error after call to MPI_dist_graph_create_adjacent(FULL) ',errorstring
415 : endif
416 7680 : allocate(LSchedule%destFull(nSend),LSchedule%srcFull(nRecv))
417 11428 : LSchedule%destFull(:) = destFull(:)
418 11428 : LSchedule%srcFull(:) = srcFull(:)
419 : ! construct the FULL communication -group- (for one-sided operations):
420 1536 : call MPI_Comm_group(par%comm, groupFull, ierr)
421 1536 : call MPI_group_incl(groupFull,nRecv,srcFull,par%groupGraphFull,ierr)
422 1536 : if (ierr .ne. MPI_SUCCESS) then
423 0 : errorcode=ierr
424 0 : call MPI_Error_String(errorcode, errorstring, errorlen, ierr)
425 0 : print *,subname, ': Error after call to MPI_Comm_group (groupGraphFull) ', errorstring
426 : endif
427 1536 : call MPi_Group_size(par%groupGraphFull,sizeGroup,ierr)
428 : if(Debug) write (*,199) par%rank,sizeGroup,nSend,nRecv
429 :
430 : 199 format ('RANK: ',i4,' genEdgeSched: size of groupGraphFUll is: ',i8,' nSend, nRecv: ',2(i4))
431 1536 : deallocate(srcFull,srcWeightFull,destFull,destWeightFull)
432 :
433 : ! construct the INTER communication graph
434 1536 : reorder=.FALSE.
435 1536 : if(numInter>0) then
436 : call MPI_Dist_graph_create_adjacent(par%comm, numInter,srcInter,srcWeightInter, &
437 1536 : numInter,destInter,destWeightInter,MPI_INFO_NULL,reorder,par%commGraphInter,ierr)
438 1536 : if(ierr .ne. MPI_SUCCESS) then
439 0 : errorcode=ierr
440 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
441 0 : print *,subname,': Error after call to MPI_dist_graph_create_adjacent(INTER) ',errorstring
442 : endif
443 1536 : deallocate(srcInter,srcWeightInter,destInter,destWeightInter)
444 : endif
445 :
446 : ! construct the INTRA communication graph
447 1536 : reorder=.FALSE.
448 1536 : if(numIntra>0) then
449 : call MPI_Dist_graph_create_adjacent(par%comm, numIntra,srcIntra,srcWeightIntra, &
450 0 : numIntra,destIntra,destWeightIntra,MPI_INFO_NULL,reorder,par%commGraphIntra,ierr)
451 0 : if(ierr .ne. MPI_SUCCESS) then
452 0 : errorcode=ierr
453 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
454 0 : print *,subname,': Error after call to MPI_dist_graph_create_adjacent(INTRA) ',errorstring
455 : endif
456 0 : deallocate(srcIntra,srcWeightIntra,destIntra,destWeightIntra)
457 : endif
458 :
459 : 200 format ('IAM: ',i4,': ', i2,' of',i2,' comms are interNode')
460 : 201 format ('IAM: ',i4,': ', i2,' of',i2,' comms are intraNode')
461 : #endif
462 :
463 :
464 1536 : end subroutine genEdgeSched
465 :
466 : logical function isIntraComm(commranks,rank)
467 :
468 :
469 : integer, intent(in) :: commranks(:)
470 : integer, intent(in) :: rank
471 :
472 : integer :: i,nranks
473 :
474 : nranks = SIZE(commranks)
475 : isIntraComm = .FALSE.
476 : do i=1,nranks
477 : if(commranks(i) .eq. rank) then
478 : isIntraComm=.TRUE.
479 : endif
480 : enddo
481 :
482 : end function isIntraComm
483 :
484 0 : subroutine CheckSchedule()
485 :
486 : integer :: i, nSched, nbufferwords_1, nbufferwords_2
487 : type (Schedule_t), pointer :: pSchedule
488 :
489 0 : nSched = SIZE(Schedule)
490 :
491 0 : do i = 1, nSched
492 0 : pSchedule => Schedule(i)
493 0 : nbufferwords_1 = SUM(pSchedule%SendCycle(:)%lengthP)
494 0 : nbufferwords_2 = SUM(pSchedule%RecvCycle(:)%lengthP)
495 0 : if(nbufferwords_1 .ne. nbufferwords_2) then
496 0 : write (iulog,100) i,nbufferwords_1, nbufferwords_2
497 : end if
498 : end do
499 : 100 format('CheckSchedule: ERR IAM:',I3,' SIZEOF(SendBuffer):',I10,' != SIZEOF(RecvBuffer) :',I10)
500 :
501 0 : end subroutine CheckSchedule
502 :
503 0 : subroutine PrintSchedule(Schedule)
504 : ! Debug subroutine for the schedule_t data-structure
505 : use gridgraph_mod, only : printgridedge
506 :
507 : type (Schedule_t),intent(in),target :: Schedule(:)
508 : type (Schedule_t), pointer :: pSchedule
509 : type (Cycle_t),pointer :: pCycle
510 :
511 : integer :: i,j,nSched
512 :
513 0 : nSched = SIZE(Schedule)
514 :
515 0 : write(6,*) '------NEW SCHEDULE FORMAT---------------------'
516 0 : do i=1,nSched
517 0 : pSchedule => Schedule(i)
518 0 : write(6,*)
519 0 : write(6,*) '----------------------------------------------'
520 0 : write(6,90) i,pSchedule%ncycles
521 0 : write(6,*) '----------------------------------------------'
522 0 : write(6,*) '-----------SEND-------------------------------'
523 0 : do j=1,pSchedule%nSendCycles
524 0 : pCycle => pSchedule%SendCycle(j)
525 0 : call PrintCycle(pCycle)
526 0 : call PrintGridEdge(pCycle%edge%members)
527 : enddo
528 0 : write(6,*) '-----------RECV-------------------------------'
529 0 : do j=1,pSchedule%nRecvCycles
530 0 : pCycle => pSchedule%RecvCycle(j)
531 0 : call PrintCycle(pCycle)
532 0 : call PrintGridEdge(pCycle%edge%members)
533 : enddo
534 0 : write(6,*) '-----------MOVE-------------------------------'
535 0 : pCycle => pSchedule%MoveCycle(1)
536 0 : call PrintCycle(pCycle)
537 0 : call PrintGridEdge(pCycle%edge%members)
538 : enddo
539 0 : write(6,*) '-----------Put Index--------------------'
540 0 : call PrintIndex(Schedule(1)%pIndx)
541 0 : write(6,*) '-----------Get Index--------------------'
542 : call PrintIndex(Schedule(1)%gIndx)
543 :
544 : 90 format('NODE # ',I2,2x,'NCYCLES ',I2)
545 : 97 format(10x,'EDGE #',I2,2x,'TYPE ',I1,2x,'G.EDGES',I4,2x,'WORDS ',I5,2x, &
546 : 'SRC ',I3,2x,'DEST ',I3,2x,'PTR ',I4)
547 : 100 format(15x,I4,5x,I3,1x,'(',I1,') --',I1,'--> ',I3,1x,'(',I1,')')
548 :
549 0 : end subroutine PrintSchedule
550 :
551 0 : subroutine PrintIndex(Indx)
552 : ! Debugging subroutine for the pgindex_t data-structure
553 :
554 : ! type, public :: pgindex_t
555 : ! integer :: elemid
556 : ! integer :: edgeid
557 : ! integer :: mesgid
558 : ! integer :: lenP,lenS
559 : ! end type pgindex_t
560 :
561 : type (pgindex_t) :: Indx(:)
562 :
563 : integer :: i, len
564 :
565 0 : len = SIZE(Indx)
566 :
567 0 : write(6,*) ' elemID, edgeID, mesgID, lenP, lenS '
568 0 : do i=1,len
569 0 : write(6,1099) Indx(i)%elemid,Indx(i)%edgeid,Indx(i)%mesgid,Indx(i)%lenP,Indx(i)%lenS
570 : enddo
571 :
572 : 1099 format(I4,5X,I4,5X,I4,5X,I2,4X,I2)
573 :
574 0 : end subroutine PrintIndex
575 :
576 0 : subroutine PrintCycle(Cycle)
577 : ! debug subroutine for the cycle_t data-structure
578 : type (Cycle_t),intent(in),target :: Cycle
579 :
580 0 : write(6,97) Cycle%edge%number,Cycle%type,Cycle%edge%nmembers, &
581 0 : Cycle%lengthP,Cycle%source, Cycle%dest,Cycle%ptrP
582 :
583 : 97 format(5x,'METAEDGE #',I2,2x,'TYPE ',I1,2x,'G.EDGES',I4,2x,'WORDS ',I5,2x, &
584 : 'SRC ',I3,2x,'DEST ',I3,2x,'PTR ',I5)
585 :
586 0 : end subroutine PrintCycle
587 :
588 21320 : subroutine SetCycle(par, elem, schedule,Cycle,Edge,ctype)
589 : use element_mod, only: element_t
590 : use dimensions_mod, only: max_corner_elem, max_neigh_edges
591 : use cam_abortutils, only: endrun
592 :
593 : type(parallel_t), intent(in) :: par
594 : type(element_t), intent(inout) :: elem(:)
595 : type (Schedule_t), intent(inout) :: Schedule
596 : type (Cycle_t), intent(inout) :: Cycle
597 : type (MetaEdge_t), intent(in), target :: Edge
598 : integer, intent(in) :: ctype
599 : integer :: i,il,face, loc, dir
600 :
601 155488 : do i = 1, Edge%nmembers
602 : if((ctype == HME_CYCLE_SEND) .or. &
603 134168 : (ctype == HME_CYCLE_MOVE) .or. &
604 : (ctype == HME_CYCLE_ANY)) then
605 : ! Setup send index
606 86352 : il = Global2Local(Edge%members(i)%tail%number)
607 86352 : face = Edge%members(i)%tail_face
608 : !need to convert the location of corner elements for getmap and putmap
609 86352 : if (face.ge.5) then ! if a corner element
610 43152 : dir = Edge%members(i)%tail_dir
611 43152 : loc = MOD(dir,max_corner_elem) !this is the location within that direction
612 43152 : dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
613 43152 : loc = dir + (dir-5)*(max_corner_elem-1)+loc
614 : else
615 : loc = face
616 : end if
617 :
618 86352 : if(il .gt. 0) then
619 86352 : elem(il)%desc%putmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1 ! offset, so start at 0
620 86352 : elem(il)%desc%putmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
621 86352 : elem(il)%desc%putmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost ! index, start at 1
622 86352 : elem(il)%desc%reverse(loc) = Edge%members(i)%reverse
623 86352 : schedule%pIndx(schedule%pPtr)%elemid=il
624 86352 : schedule%pIndx(schedule%pPtr)%edgeid=loc
625 86352 : schedule%pIndx(schedule%pPtr)%mesgid=Edge%HeadVertex-1 ! convert this to 0-based
626 86352 : schedule%pIndx(schedule%pPtr)%lenP =Edge%members(i)%wgtP
627 86352 : schedule%pIndx(schedule%pPtr)%lenS =Edge%members(i)%wgtS
628 86352 : if (face.ge.5) then
629 43152 : schedule%pIndx(schedule%pPtr)%edgeType = HME_Ordinal
630 : else
631 43200 : schedule%pIndx(schedule%pPtr)%edgeType = HME_Cardinal
632 : endif
633 86352 : schedule%pPtr=schedule%pPtr+1
634 : end if
635 : end if
636 :
637 : if((ctype == HME_CYCLE_RECV) .or. &
638 134168 : (ctype == HME_CYCLE_MOVE) .or. &
639 21320 : (ctype == HME_CYCLE_ANY)) then
640 : ! Setup receive index
641 86352 : il = Global2Local(Edge%members(i)%head%number)
642 86352 : face = Edge%members(i)%head_face
643 : !need to convert the location of corner elements for getmap and putmap
644 86352 : if (face.ge.5) then !its a corner
645 43152 : dir = Edge%members(i)%head_dir
646 43152 : loc = MOD(dir,max_corner_elem) !this is the location within that direction
647 43152 : dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
648 43152 : loc = dir + (dir-5)*(max_corner_elem-1)+loc
649 43152 : if(loc > max_neigh_edges) then
650 0 : write(iulog, *) __FILE__,__LINE__,par%rank,face,i,max_corner_elem,max_neigh_edges,edge%members(i)%head_face
651 0 : call endrun('max_neigh_edges set too low.')
652 : end if
653 : else
654 : loc = face
655 : end if
656 :
657 86352 : if(il .gt. 0) then
658 86352 : elem(il)%desc%getmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1
659 86352 : elem(il)%desc%getmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
660 86352 : elem(il)%desc%getmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost
661 86352 : elem(il)%desc%globalID(loc) = Edge%members(i)%tail%number
662 86352 : schedule%gIndx(schedule%gPtr)%elemid=il
663 86352 : schedule%gIndx(schedule%gPtr)%edgeid=loc
664 86352 : schedule%gIndx(schedule%gPtr)%mesgid=Edge%TailVertex-1 ! convert this to 0-based
665 86352 : schedule%gIndx(schedule%gPtr)%lenP =Edge%members(i)%wgtP
666 86352 : schedule%gIndx(schedule%gPtr)%lenS =Edge%members(i)%wgtS
667 86352 : if (face.ge.5) then
668 43152 : schedule%gIndx(schedule%gPtr)%edgeType = HME_Ordinal
669 : else
670 43200 : schedule%gIndx(schedule%gPtr)%edgeType = HME_Cardinal
671 : endif
672 86352 : schedule%gPtr=schedule%gPtr+1
673 : end if
674 : end if
675 : end do
676 21320 : Cycle%edge => Edge
677 21320 : Cycle%type = Edge%type
678 21320 : Cycle%dest = Edge%HeadVertex
679 21320 : Cycle%source = Edge%TailVertex
680 21320 : Cycle%tag = BNDRY_EXCHANGE_MESSAGE
681 21320 : Cycle%lengthP = Edge%wgtP
682 21320 : Cycle%lengthS = Edge%wgtS
683 21320 : Cycle%lengthP_ghost = Edge%wgtP_ghost
684 :
685 21320 : end subroutine SetCycle
686 :
687 63960 : function FindBufferSlot(inbr,length,tmp) result(ptr)
688 :
689 : integer :: ptr
690 : integer, intent(in) :: inbr,length
691 : integer, intent(inout) :: tmp(:,:)
692 :
693 : integer :: i,n
694 :
695 63960 : n = SIZE(tmp,2)
696 :
697 63960 : ptr = 0
698 260772 : do i=1,n
699 260772 : if( tmp(1,i) == inbr) then
700 0 : ptr = tmp(2,i)
701 0 : return
702 : endif
703 260772 : if( tmp(1,i) == -1 ) then
704 63960 : tmp(1,i) = inbr
705 63960 : if(i .eq. 1) tmp(2,i) = 1
706 63960 : ptr = tmp(2,i)
707 63960 : if(i .ne. n) tmp(2,i+1) = ptr +length
708 63960 : return
709 : endif
710 : enddo
711 :
712 : end function FindBufferSlot
713 :
714 0 : end module schedule_mod
|
