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 2304 : 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 2304 : integer,allocatable :: tmpP(:,:)
59 2304 : integer,allocatable :: tmpS(:,:)
60 2304 : 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 2304 : integer, allocatable :: srcFull(:), destFull(:), srcweightFull(:), destweightFull(:)
80 2304 : integer, allocatable :: srcInter(:),destInter(:), srcweightInter(:),destweightInter(:)
81 2304 : integer, allocatable :: srcIntra(:),destIntra(:), srcweightIntra(:),destweightIntra(:)
82 :
83 : logical :: reorder
84 : integer :: sizeGroup, groupFull
85 :
86 2304 : nSched=SIZE(schedule)
87 : ! ================================================
88 : ! allocate some arrays for the call to MPI_gatherv
89 : ! ================================================
90 :
91 2304 : MinNelemd = nelem
92 2304 : 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 6912 : allocate(Global2Local(nelem))
98 : if(Debug) write(iulog,*)'genEdgeSched: point #1'
99 2304 : iSched = PartNumber
100 :
101 2304 : nelemd0 = MetaVertex%nmembers
102 2304 : MaxNelemd = AMAX0(MaxNelemd,nelemd0)
103 2304 : MinNelemd = AMIN0(MinNelemd,nelemd0)
104 : if(Debug) write(iulog,*)'genEdgeSched: point #2'
105 :
106 : if(Debug) write(iulog,*)'genEdgeSched: point #3'
107 2304 : LSchedule%ncycles = MetaVertex%nedges
108 2304 : LSchedule%nelemd = nelemd0
109 : if(Debug) write(iulog,*)'genEdgeSched: point #4'
110 :
111 : ! Note the minus one is for the internal node
112 2304 : nedges = MetaVertex%nedges
113 2304 : if(2*(nedges/2) .eq. nedges) then
114 : nedges = nedges/2
115 : else
116 2304 : nedges = (nedges-1)/2
117 : endif
118 2304 : LSchedule%nSendCycles = nedges
119 2304 : LSchedule%nRecvCycles = nedges
120 : if(Debug) write(iulog,*)'genEdgeSched: point #5'
121 :
122 : ! Temporary array to calculate the Buffer Slot
123 6912 : allocate(tmpP(2,nedges+1))
124 4608 : allocate(tmpS(2,nedges+1))
125 4608 : allocate(tmpP_ghost(2,nedges+1))
126 :
127 :
128 : ! Allocate all the cycle structures
129 6912 : allocate(LSchedule%SendCycle(nedges))
130 4608 : allocate(LSchedule%RecvCycle(nedges))
131 2304 : allocate(LSchedule%MoveCycle(1))
132 :
133 : ! Initialize the schedules...
134 2304 : LSchedule%MoveCycle(1)%ptrP = 0
135 2304 : LSchedule%MoveCycle(1)%ptrS = 0
136 2304 : LSchedule%MoveCycle(1)%lengthP = 0
137 : if(Debug) write(iulog,*)'genEdgeSched: point #6'
138 :
139 : !==================================================================
140 : ! Allocate and initalized the index translation arrays
141 12443904 : Global2Local = -1
142 6912 : allocate(LSchedule%Local2Global(nelemd0))
143 6912 : allocate(LSchedule%pIndx(max_neigh_edges*nelemd0))
144 4608 : allocate(LSchedule%gIndx(max_neigh_edges*nelemd0))
145 :
146 131904 : LSchedule%pIndx(:)%elemId = -1
147 131904 : LSchedule%pIndx(:)%edgeId = -1
148 131904 : LSchedule%pIndx(:)%lenP = -1
149 131904 : LSchedule%pIndx(:)%lenS = -1
150 131904 : LSchedule%pIndx(:)%mesgid = -1
151 131904 : LSchedule%pIndx(:)%edgeType = -1
152 :
153 131904 : LSchedule%gIndx(:)%elemId = -1
154 131904 : LSchedule%gIndx(:)%edgeId = -1
155 131904 : LSchedule%gIndx(:)%lenP = -1
156 131904 : LSchedule%gIndx(:)%lenS = -1
157 131904 : LSchedule%gIndx(:)%mesgid = -1
158 131904 : LSchedule%gIndx(:)%edgeType = -1
159 :
160 2304 : LSchedule%pPtr=1
161 2304 : LSchedule%gPtr=1
162 :
163 : if(Debug) write(iulog,*)'genEdgeSched: point #7'
164 :
165 18504 : do il=1,nelemd0
166 16200 : ig = MetaVertex%members(il)%number
167 16200 : Global2Local(ig)=il
168 16200 : LSchedule%Local2Global(il)=ig
169 145800 : elem(il)%desc%putmapP=-1
170 145800 : elem(il)%desc%getmapP=-1
171 145800 : elem(il)%desc%putmapS=-1
172 145800 : elem(il)%desc%getmapS=-1
173 145800 : elem(il)%desc%putmapP_ghost=-1
174 145800 : elem(il)%desc%getmapP_ghost=-1
175 148104 : elem(il)%desc%reverse = .FALSE.
176 : enddo
177 : !==================================================================
178 : if(Debug) write(iulog,*)'genEdgeSched: point #8'
179 :
180 :
181 :
182 2304 : total_length = 0
183 2304 : ncycle = LSchedule%ncycles
184 : !
185 : ! Send Cycle
186 : !
187 2304 : is=1
188 19446 : tmpP(1,:) = -1
189 19446 : tmpP(2,:) = 0
190 19446 : tmpS(1,:) = -1
191 19446 : tmpS(2,:) = 0
192 19446 : tmpP_ghost(1,:) = -1
193 19446 : tmpP_ghost(2,:) = 0
194 :
195 34284 : do j=1,ncycle
196 31980 : lengthP = MetaVertex%edges(j)%wgtP
197 31980 : lengthS = MetaVertex%edges(j)%wgtS
198 31980 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
199 :
200 31980 : if ((MetaVertex%edges(j)%TailVertex == PartNumber) .AND. &
201 2304 : (MetaVertex%edges(j)%HeadVertex .ne. PartNumber) ) then
202 14838 : inbr = MetaVertex%edges(j)%HeadVertex
203 : if(Debug) write(iulog,*)'genEdgeSched: point #11', par%rank
204 14838 : LSchedule%SendCycle(is)%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
205 14838 : LSchedule%SendCycle(is)%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
206 14838 : LSchedule%SendCycle(is)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
207 14838 : 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 14838 : 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 2304 : ir=1
217 19446 : tmpP(1,:) = -1
218 19446 : tmpP(2,:) = 0
219 19446 : tmpS(1,:) = -1
220 19446 : tmpS(2,:) = 0
221 19446 : tmpP_ghost(1,:) = -1
222 19446 : tmpP_ghost(2,:) = 0
223 :
224 34284 : do j=1,ncycle
225 31980 : lengthP = MetaVertex%edges(j)%wgtP
226 31980 : lengthS = MetaVertex%edges(j)%wgtS
227 31980 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
228 :
229 31980 : if ( (MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
230 2304 : (MetaVertex%edges(j)%TailVertex .ne. PartNumber) ) then
231 14838 : inbr = MetaVertex%edges(j)%TailVertex
232 : if(Debug) write(iulog,*)'genEdgeSched: point #13',par%rank
233 14838 : LSchedule%RecvCycle(ir)%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
234 14838 : LSchedule%RecvCycle(ir)%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
235 14838 : LSchedule%RecvCycle(ir)%ptrP_ghost= FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
236 14838 : 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 14838 : ir = ir+1
239 : endif
240 : enddo
241 :
242 : ! Put the move cycle at the end of the buffer.
243 34284 : do j=1,ncycle
244 31980 : lengthP = MetaVertex%edges(j)%wgtP
245 31980 : lengthS = MetaVertex%edges(j)%wgtS
246 31980 : lengthP_ghost = MetaVertex%edges(j)%wgtP_ghost
247 :
248 31980 : if((MetaVertex%edges(j)%HeadVertex == PartNumber) .AND. &
249 2304 : (MetaVertex%edges(j)%TailVertex == PartNumber)) then
250 2304 : inbr = PartNumber
251 : if(Debug) write(iulog,*)'genEdgeSched: point #9', par%rank
252 4608 : LSchedule%MoveCycle%ptrP = FindBufferSlot(inbr,lengthP,tmpP)
253 4608 : LSchedule%MoveCycle%ptrS = FindBufferSlot(inbr,lengthS,tmpS)
254 4608 : LSchedule%MoveCycle%ptrP_ghost = FindBufferSlot(inbr,lengthP_ghost,tmpP_ghost)
255 2304 : 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 2304 : deallocate(tmpP)
261 2304 : deallocate(tmpS)
262 2304 : deallocate(tmpP_ghost)
263 :
264 18504 : do ie=1,nelemd0
265 : ! compute number of neighbers for each element
266 16200 : elem(ie)%desc%actual_neigh_edges=0
267 145800 : do i=1,max_neigh_edges
268 145800 : if (elem(ie)%desc%globalID(i)>0) then
269 129528 : 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 129600 : do l1 = 1,max_neigh_edges-1
277 583200 : do l2=l1+1,max_neigh_edges
278 453600 : l1id=elem(ie)%desc%loc2buf(l1)
279 453600 : l2id=elem(ie)%desc%loc2buf(l2)
280 567000 : if (elem(ie)%desc%globalID(l2id) > elem(ie)%desc%globalID(l1id)) then
281 : ! swap index:
282 286698 : l1id=elem(ie)%desc%loc2buf(l2)
283 286698 : elem(ie)%desc%loc2buf(l2)=elem(ie)%desc%loc2buf(l1)
284 286698 : elem(ie)%desc%loc2buf(l1)=l1id
285 : endif
286 : enddo
287 : enddo
288 :
289 :
290 :
291 :
292 16200 : elem(ie)%vertex = MetaVertex%members(ie)
293 16200 : ig = MetaVertex%members(ie)%number
294 16200 : elem(ie)%GlobalId = ig
295 34704 : elem(ie)%LocalId = ie
296 : enddo
297 :
298 2304 : 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 2304 : nComPoints = 0
306 :
307 2304 : nSend = nedges
308 2304 : nRecv = nedges
309 6912 : allocate(Rrequest(nRecv))
310 4608 : allocate(Srequest(nSend))
311 6912 : 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 17142 : do icycle = 1, nSend
318 17142 : nComPoints = nComPoints + LSchedule%SendCycle(icycle)%lengthP
319 : end do
320 2304 : 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 2304 : numIntra = 0
351 2304 : numInter = nSend
352 : ! Mark all communications as off-node by default
353 17142 : do icycle=1,nSend
354 17142 : LSchedule%SendCycle(icycle)%onNode = .False.
355 : enddo
356 17142 : do icycle=1,nRecv
357 17142 : LSchedule%RecvCycle(icycle)%onNode = .False.
358 : enddo
359 : #endif
360 2304 : LSchedule%nInter = numInter
361 2304 : LSchedule%nIntra = numIntra
362 :
363 11520 : allocate(srcFull(nRecv), srcWeightFull(nRecv),destFull(nSend),destWeightFull(nSend))
364 2304 : if(numInter>0) then
365 11520 : 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 17142 : do icycle=1,nSend
374 14838 : dest = LSchedule%SendCycle(icycle)%dest - 1
375 14838 : wgt = LSchedule%SendCycle(icycle)%lengthP
376 14838 : destFull(icycle) = dest
377 14838 : destWeightFull(icycle) = wgt
378 17142 : if(LSchedule%SendCycle(icycle)%onNode) then
379 0 : icIntra=icIntra+1
380 0 : destIntra(icIntra) = dest
381 0 : destWeightIntra(icIntra) = wgt
382 : else
383 14838 : icInter=icInter+1
384 14838 : destInter(icInter) = dest
385 14838 : destWeightInter(icInter) = wgt
386 : endif
387 : enddo
388 :
389 2304 : icIntra=0
390 2304 : icInter=0
391 17142 : do icycle=1,nRecv
392 14838 : src = LSchedule%RecvCycle(icycle)%source - 1
393 14838 : wgt = LSchedule%RecvCycle(icycle)%lengthP
394 14838 : srcFull(icycle) = src
395 14838 : srcWeightFUll(icycle) = wgt
396 17142 : if(LSchedule%RecvCycle(icycle)%onNode) then
397 0 : icIntra=icIntra+1
398 0 : srcIntra(icIntra) = src
399 0 : srcWeightIntra(icIntra) = wgt
400 : else
401 14838 : icInter=icInter+1
402 14838 : srcInter(icInter) = src
403 14838 : srcWeightInter(icInter) = wgt
404 : endif
405 : enddo
406 :
407 : ! construct the FULL communication graph
408 2304 : reorder=.FALSE.
409 : call MPI_Dist_graph_create_adjacent(par%comm, nRecv,srcFull,srcWeightFull, &
410 2304 : nSend,destFull,destWeightFull,MPI_INFO_NULL,reorder,par%commGraphFull,ierr)
411 2304 : 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 11520 : allocate(LSchedule%destFull(nSend),LSchedule%srcFull(nRecv))
417 17142 : LSchedule%destFull(:) = destFull(:)
418 17142 : LSchedule%srcFull(:) = srcFull(:)
419 : ! construct the FULL communication -group- (for one-sided operations):
420 2304 : call MPI_Comm_group(par%comm, groupFull, ierr)
421 2304 : call MPI_group_incl(groupFull,nRecv,srcFull,par%groupGraphFull,ierr)
422 2304 : 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 2304 : 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 2304 : deallocate(srcFull,srcWeightFull,destFull,destWeightFull)
432 :
433 : ! construct the INTER communication graph
434 2304 : reorder=.FALSE.
435 2304 : if(numInter>0) then
436 : call MPI_Dist_graph_create_adjacent(par%comm, numInter,srcInter,srcWeightInter, &
437 2304 : numInter,destInter,destWeightInter,MPI_INFO_NULL,reorder,par%commGraphInter,ierr)
438 2304 : 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 2304 : deallocate(srcInter,srcWeightInter,destInter,destWeightInter)
444 : endif
445 :
446 : ! construct the INTRA communication graph
447 2304 : reorder=.FALSE.
448 2304 : 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 2304 : 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 31980 : 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 233232 : do i = 1, Edge%nmembers
602 : if((ctype == HME_CYCLE_SEND) .or. &
603 201252 : (ctype == HME_CYCLE_MOVE) .or. &
604 : (ctype == HME_CYCLE_ANY)) then
605 : ! Setup send index
606 129528 : il = Global2Local(Edge%members(i)%tail%number)
607 129528 : face = Edge%members(i)%tail_face
608 : !need to convert the location of corner elements for getmap and putmap
609 129528 : if (face.ge.5) then ! if a corner element
610 64728 : dir = Edge%members(i)%tail_dir
611 64728 : loc = MOD(dir,max_corner_elem) !this is the location within that direction
612 64728 : dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
613 64728 : loc = dir + (dir-5)*(max_corner_elem-1)+loc
614 : else
615 : loc = face
616 : end if
617 :
618 129528 : if(il .gt. 0) then
619 129528 : elem(il)%desc%putmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1 ! offset, so start at 0
620 129528 : elem(il)%desc%putmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
621 129528 : elem(il)%desc%putmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost ! index, start at 1
622 129528 : elem(il)%desc%reverse(loc) = Edge%members(i)%reverse
623 129528 : schedule%pIndx(schedule%pPtr)%elemid=il
624 129528 : schedule%pIndx(schedule%pPtr)%edgeid=loc
625 129528 : schedule%pIndx(schedule%pPtr)%mesgid=Edge%HeadVertex-1 ! convert this to 0-based
626 129528 : schedule%pIndx(schedule%pPtr)%lenP =Edge%members(i)%wgtP
627 129528 : schedule%pIndx(schedule%pPtr)%lenS =Edge%members(i)%wgtS
628 129528 : if (face.ge.5) then
629 64728 : schedule%pIndx(schedule%pPtr)%edgeType = HME_Ordinal
630 : else
631 64800 : schedule%pIndx(schedule%pPtr)%edgeType = HME_Cardinal
632 : endif
633 129528 : schedule%pPtr=schedule%pPtr+1
634 : end if
635 : end if
636 :
637 : if((ctype == HME_CYCLE_RECV) .or. &
638 201252 : (ctype == HME_CYCLE_MOVE) .or. &
639 31980 : (ctype == HME_CYCLE_ANY)) then
640 : ! Setup receive index
641 129528 : il = Global2Local(Edge%members(i)%head%number)
642 129528 : face = Edge%members(i)%head_face
643 : !need to convert the location of corner elements for getmap and putmap
644 129528 : if (face.ge.5) then !its a corner
645 64728 : dir = Edge%members(i)%head_dir
646 64728 : loc = MOD(dir,max_corner_elem) !this is the location within that direction
647 64728 : dir = (dir - loc)/max_corner_elem !this is the direction (1-8)
648 64728 : loc = dir + (dir-5)*(max_corner_elem-1)+loc
649 64728 : 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 129528 : if(il .gt. 0) then
658 129528 : elem(il)%desc%getmapP(loc) = Edge%edgeptrP(i) + Cycle%ptrP - 1
659 129528 : elem(il)%desc%getmapS(loc) = Edge%edgeptrS(i) + Cycle%ptrS - 1
660 129528 : elem(il)%desc%getmapP_ghost(loc) = Edge%edgeptrP_ghost(i) + Cycle%ptrP_ghost
661 129528 : elem(il)%desc%globalID(loc) = Edge%members(i)%tail%number
662 129528 : schedule%gIndx(schedule%gPtr)%elemid=il
663 129528 : schedule%gIndx(schedule%gPtr)%edgeid=loc
664 129528 : schedule%gIndx(schedule%gPtr)%mesgid=Edge%TailVertex-1 ! convert this to 0-based
665 129528 : schedule%gIndx(schedule%gPtr)%lenP =Edge%members(i)%wgtP
666 129528 : schedule%gIndx(schedule%gPtr)%lenS =Edge%members(i)%wgtS
667 129528 : if (face.ge.5) then
668 64728 : schedule%gIndx(schedule%gPtr)%edgeType = HME_Ordinal
669 : else
670 64800 : schedule%gIndx(schedule%gPtr)%edgeType = HME_Cardinal
671 : endif
672 129528 : schedule%gPtr=schedule%gPtr+1
673 : end if
674 : end if
675 : end do
676 31980 : Cycle%edge => Edge
677 31980 : Cycle%type = Edge%type
678 31980 : Cycle%dest = Edge%HeadVertex
679 31980 : Cycle%source = Edge%TailVertex
680 31980 : Cycle%tag = BNDRY_EXCHANGE_MESSAGE
681 31980 : Cycle%lengthP = Edge%wgtP
682 31980 : Cycle%lengthS = Edge%wgtS
683 31980 : Cycle%lengthP_ghost = Edge%wgtP_ghost
684 :
685 31980 : end subroutine SetCycle
686 :
687 95940 : 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 95940 : n = SIZE(tmp,2)
696 :
697 95940 : ptr = 0
698 391158 : do i=1,n
699 391158 : if( tmp(1,i) == inbr) then
700 0 : ptr = tmp(2,i)
701 0 : return
702 : endif
703 391158 : if( tmp(1,i) == -1 ) then
704 95940 : tmp(1,i) = inbr
705 95940 : if(i .eq. 1) tmp(2,i) = 1
706 95940 : ptr = tmp(2,i)
707 95940 : if(i .ne. n) tmp(2,i+1) = ptr +length
708 95940 : return
709 : endif
710 : enddo
711 :
712 : end function FindBufferSlot
713 :
714 0 : end module schedule_mod
|