Line data Source code
1 : module bndry_mod
2 : use shr_kind_mod, only: r8=>shr_kind_r8, i8=>shr_kind_i8
3 : use parallel_mod, only: HME_BNDRY_A2A, HME_BNDRY_A2AO
4 : use thread_mod, only: omp_in_parallel, omp_get_thread_num
5 : use gbarrier_mod, only: gbarrier
6 : use cam_abortutils, only: endrun
7 : use cam_logfile, only: iulog
8 :
9 :
10 : implicit none
11 : private
12 :
13 : interface bndry_exchange
14 : module procedure bndry_exchange_threaded
15 : module procedure bndry_exchange_nonthreaded
16 : module procedure long_bndry_exchange_nonth
17 : end interface
18 : public :: bndry_exchange
19 :
20 : interface ghost_exchange
21 : module procedure ghost_exchange_threaded
22 : module procedure ghost_exchange_nonthreaded
23 : end interface
24 : public :: ghost_exchange
25 :
26 : interface bndry_exchange_start
27 : module procedure bndry_exchange_threaded_start
28 : module procedure bndry_exchange_nonthreaded_start
29 : end interface
30 : public :: bndry_exchange_start
31 :
32 : interface bndry_exchange_finish
33 : module procedure bndry_exchange_threaded_finish
34 : module procedure bndry_exchange_nonthreaded_finish
35 : end interface
36 : public :: bndry_exchange_finish
37 :
38 :
39 : public :: compute_ghost_corner_orientation
40 : public :: ghost_exchangeVfull
41 : public :: copyBuffer
42 :
43 : contains
44 :
45 0 : subroutine bndry_exchange_a2a(par,nthreads,ithr,buffer,location)
46 : use edgetype_mod, only: Edgebuffer_t
47 : use schedtype_mod, only: schedule_t, cycle_t, schedule
48 : use thread_mod, only: omp_in_parallel, omp_get_thread_num
49 : use perf_mod, only: t_startf, t_stopf
50 : use spmd_utils, only: mpi_real8, mpi_success
51 : use parallel_mod, only: parallel_t
52 : use perf_mod, only: t_startf, t_stopf
53 :
54 : type (parallel_t) :: par
55 : integer, intent(in) :: nthreads
56 : integer :: ithr ! The OpenMP thread ID
57 : type (EdgeBuffer_t) :: buffer
58 : character(len=*), optional :: location
59 :
60 : type (Schedule_t), pointer :: pSchedule
61 : type (Cycle_t), pointer :: pCycle
62 : integer :: icycle,ierr
63 : integer :: length
64 : integer :: iptr,source,nlyr
65 : integer :: nSendCycles,nRecvCycles
66 : integer :: errorcode,errorlen
67 : character*(80) :: errorstring
68 : character(len=*), parameter :: subname = 'bndry_exchange_a2a'
69 : character(len=80) :: locstring
70 : logical :: ompthreadMissmatch
71 :
72 : integer :: i,j
73 : integer :: request
74 :
75 : ! Neighborhood collectives are only in MPI3 and up
76 : #ifdef SPMD
77 : #if MPI_VERSION >= 3
78 :
79 : if(ithr == 0) then
80 :
81 : call MPI_Ineighbor_Alltoallv(buffer%buf,buffer%scountsFull,buffer%sdisplsFull,Mpi_real8, &
82 : buffer%receive,buffer%rcountsFull,buffer%rdisplsFull,Mpi_real8,par%commGraphFull,request,ierr)
83 : if(ierr .ne. MPI_SUCCESS) then
84 : errorcode=ierr
85 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
86 : write(iulog,*) subname,': Error after call to MPI_Ineighbor_alltoallv: ',errorstring
87 : endif
88 :
89 : if(present(location)) then
90 : locstring = TRIM(subname) // ': ' // TRIM(location)
91 : else
92 : locstring = TRIM(subname)
93 : endif
94 : ! location 1 for copyBuffer
95 : call copyBuffer(nthreads,ithr,buffer,locstring)
96 :
97 : call MPI_wait(request,lstatus,ierr)
98 : call t_stopf('bndry_a2a')
99 : else
100 :
101 : if(present(location)) then
102 : locstring = TRIM(subname) // ': ' // TRIM(location)
103 : else
104 : locstring = TRIM(subname)
105 : endif
106 : call copyBuffer(nthreads,ithr,buffer,locstring)
107 :
108 : endif
109 : #else
110 0 : call endrun('bndry_exchange_a2a requires MPI-3 feature support')
111 : #endif
112 : #endif
113 :
114 0 : end subroutine bndry_exchange_a2a
115 :
116 37704960 : subroutine copyBuffer(nthreads,ithr,buffer,location)
117 0 : use edgetype_mod, only : Edgebuffer_t
118 : integer :: nthreads
119 : integer :: ithr
120 : type (EdgeBuffer_t) :: buffer
121 : character(len=80) :: location
122 : logical :: ompThreadMissmatch
123 : integer lenMovePtr, iptr,length,i,j
124 :
125 37704960 : ompThreadMissmatch = .false.
126 37704960 : lenMovePtr = size(buffer%moveptr)
127 37704960 : if ( lenMOveptr .ne. nthreads) then
128 0 : ompthreadMissmatch = .true.
129 0 : write(*,30) TRIM(location), lenMoveptr, nthreads
130 : endif
131 :
132 : if (.not. ompthreadMissmatch) then
133 37704960 : iptr = buffer%moveptr(ithr+1)
134 37704960 : length = buffer%moveLength(ithr+1)
135 37704960 : if(length>0) then
136 >10527*10^8 : do i=0,length-1
137 >10527*10^8 : buffer%receive(iptr+i) = buffer%buf(iptr+i)
138 : enddo
139 : endif
140 0 : else if(ompthreadMissmatch .and. ithr == 0) then
141 0 : do j=1,lenMovePtr
142 0 : iptr = buffer%moveptr(j)
143 0 : length = buffer%moveLength(j)
144 0 : if(length>0) then
145 0 : do i=0,length-1
146 0 : buffer%receive(iptr+i) = buffer%buf(iptr+i)
147 : enddo
148 : endif
149 : enddo
150 : endif
151 : 30 format(a,'Potential perf issue: ',a,'LenMoveptr,nthreads: ',2(i3))
152 37704960 : end subroutine copyBuffer
153 :
154 0 : subroutine bndry_exchange_a2ao(par,nthreads,ithr,buffer,location)
155 : use edgetype_mod, only : Edgebuffer_t
156 : use schedtype_mod, only : schedule_t, cycle_t, schedule
157 : use thread_mod, only : omp_in_parallel, omp_get_thread_num
158 : use perf_mod, only : t_startf, t_stopf
159 : use spmd_utils, only: mpi_real8, mpi_success, mpi_status_size
160 : use parallel_mod, only: parallel_t
161 : use perf_mod, only : t_startf, t_stopf
162 :
163 : type (parallel_t) :: par
164 : integer, intent(in) :: nthreads
165 : integer :: ithr ! The OpenMP thread ID
166 : type (EdgeBuffer_t) :: buffer
167 : character(len=*), optional :: location
168 :
169 : integer :: ierr
170 : integer :: errorcode,errorlen
171 : character(len=80) :: errorstring
172 : character(len=*), parameter :: subname = 'bndry_exchange_a2ao'
173 : character(len=80) :: locstring
174 :
175 : integer :: requestIntra,requestInter
176 : integer :: lstatus(MPI_status_size)
177 :
178 : ! Neighborhood collectives are only in MPI3 and up
179 : #ifdef SPMD
180 : #if MPI_VERSION >= 3
181 :
182 : if(ithr == 0) then
183 :
184 : call t_startf('bndry_a2ao')
185 : ! Start Inter-node communication
186 : call MPI_Ineighbor_Alltoallv(buffer%buf,buffer%scountsInter,buffer%sdisplsInter,MPI_real8, &
187 : buffer%receive,buffer%rcountsInter,buffer%rdisplsInter,MPI_real8,par%commGraphInter,requestInter,ierr)
188 : if(ierr .ne. MPI_SUCCESS) then
189 : errorcode=ierr
190 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
191 : write(iulog,*) subname,': Error after call to MPI_Ineighbor_alltoallv: ',errorstring
192 : endif
193 : ! Start Intra-node communication
194 : call MPI_Ineighbor_Alltoallv(buffer%buf,buffer%scountsIntra,buffer%sdisplsIntra,MPI_real8, &
195 : buffer%receive,buffer%rcountsIntra,buffer%rdisplsIntra,MPI_real8,par%commGraphIntra,requestIntra,ierr)
196 : if(ierr .ne. MPI_SUCCESS) then
197 : errorcode=ierr
198 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
199 : write(iulog,*) subname,': Error after call to MPI_Ineighbor_alltoallv: ',errorstring
200 : endif
201 :
202 : if(present(location)) then
203 : locstring = TRIM(subname) // ': ' // TRIM(location)
204 : else
205 : locstring = TRIM(subname)
206 : endif
207 : ! Finish the Intra-node communication
208 : call MPI_wait(requestIntra,lstatus,ierr)
209 :
210 : ! location 3 for copyBuffer
211 : call copyBuffer(nthreads,ithr,buffer,locstring)
212 :
213 : ! Finish the Inter-node communication
214 : call MPI_wait(requestInter,lstatus,ierr)
215 : call t_stopf('bndry_a2ao')
216 :
217 : else
218 :
219 : if(present(location)) then
220 : locstring = TRIM(subname) // ': ' // TRIM(location)
221 : else
222 : locstring = TRIM(subname)
223 : endif
224 : !Copy buffer for ithr!=0
225 : call copyBuffer(nthreads,ithr,buffer,locstring)
226 :
227 : endif
228 : #else
229 0 : call endrun('bndry_exchange_a2ao requires MPI-3 feature support')
230 : #endif
231 : #endif
232 :
233 0 : end subroutine bndry_exchange_a2ao
234 :
235 37704960 : subroutine bndry_exchange_p2p(par,nthreads,ithr,buffer,location)
236 0 : use edgetype_mod, only: Edgebuffer_t
237 : use schedtype_mod, only: schedule_t, cycle_t, schedule
238 : use thread_mod, only: omp_in_parallel, omp_get_thread_num
239 : use spmd_utils, only: mpi_real8, mpi_success
240 : use parallel_mod, only: parallel_t
241 : use perf_mod, only: t_startf, t_stopf
242 :
243 : type (parallel_t) :: par
244 : integer, intent(in) :: nthreads
245 : integer :: ithr
246 : type (EdgeBuffer_t) :: buffer
247 : character(len=*), optional :: location
248 :
249 : type (Schedule_t),pointer :: pSchedule
250 : type (Cycle_t),pointer :: pCycle
251 : integer :: dest,length,tag
252 : integer :: icycle,ierr
253 : integer :: iptr,source,nlyr
254 : integer :: nSendCycles,nRecvCycles
255 : integer :: errorcode,errorlen
256 : character*(80) :: errorstring
257 : character(len=*), parameter :: subname = 'bndry_exchange_p2p'
258 : character(len=80) :: locstring
259 : logical, parameter :: Debug=.FALSE.
260 :
261 : integer :: i,j
262 : logical :: ompthreadMissmatch
263 : integer :: lenMovePtr
264 :
265 37704960 : pSchedule => Schedule(1)
266 37704960 : nlyr = buffer%nlyr
267 37704960 : ompthreadMissmatch = .FALSE.
268 :
269 37704960 : lenMovePtr = size(buffer%moveptr)
270 :
271 37704960 : if(ithr == 0) then
272 37704960 : nSendCycles = pSchedule%nSendCycles
273 37704960 : nRecvCycles = pSchedule%nRecvCycles
274 :
275 :
276 : !==================================================
277 : ! Fire off the sends
278 : !==================================================
279 :
280 280528830 : do icycle=1,nSendCycles
281 242823870 : pCycle => pSchedule%SendCycle(icycle)
282 242823870 : dest = pCycle%dest - 1
283 242823870 : length = buffer%scountsFull(icycle)
284 242823870 : tag = buffer%tag
285 242823870 : iptr = buffer%sdisplsFull(icycle) + 1
286 : if(Debug) write(iulog,*) subname,': MPI_Isend: DEST:',dest,'LENGTH:',length,'TAG: ',tag
287 242823870 : call MPI_Isend(buffer%buf(iptr),length,Mpi_real8,dest,tag,par%comm,buffer%Srequest(icycle),ierr)
288 280528830 : if(ierr .ne. MPI_SUCCESS) then
289 0 : errorcode=ierr
290 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
291 0 : write(iulog,*) subname,': Error after call to MPI_Isend: ',errorstring
292 : endif
293 : end do ! icycle
294 :
295 : !==================================================
296 : ! Post the Receives
297 : !==================================================
298 280528830 : do icycle=1,nRecvCycles
299 242823870 : pCycle => pSchedule%RecvCycle(icycle)
300 242823870 : source = pCycle%source - 1
301 242823870 : length = buffer%rcountsFull(icycle)
302 242823870 : tag = buffer%tag
303 242823870 : iptr = buffer%rdisplsFull(icycle) + 1
304 : if(Debug) write(iulog,*) subname,': MPI_Irecv: SRC:',source,'LENGTH:',length,'TAG: ',tag
305 0 : call MPI_Irecv(buffer%receive(iptr),length,Mpi_real8, &
306 242823870 : source,tag,par%comm,buffer%Rrequest(icycle),ierr)
307 280528830 : if(ierr .ne. MPI_SUCCESS) then
308 0 : errorcode=ierr
309 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
310 0 : write(iulog,*) subname,': Error after call to MPI_Irecv: ',errorstring
311 : endif
312 : end do ! icycle
313 37704960 : if(present(location)) then
314 37704960 : locstring = TRIM(subname) // ': ' // TRIM(location)
315 : else
316 0 : locstring = TRIM(subname)
317 : endif
318 37704960 : call copyBuffer(nthreads,ithr,buffer,locstring)
319 37704960 : if (nSendCycles>0) call MPI_Waitall(nSendCycles,buffer%Srequest,buffer%status,ierr)
320 37704960 : if (nRecvCycles>0) call MPI_Waitall(nRecvCycles,buffer%Rrequest,buffer%status,ierr)
321 : else
322 0 : if(present(location)) then
323 0 : locstring = TRIM(subname) // ': ' // TRIM(location)
324 : else
325 0 : locstring = TRIM(subname)
326 : endif
327 0 : call copyBuffer(nthreads,ithr,buffer,locstring)
328 : endif
329 :
330 37704960 : end subroutine bndry_exchange_p2p
331 :
332 0 : subroutine bndry_exchange_p2p_start(par,nthreads,ithr,buffer,location)
333 :
334 37704960 : use edgetype_mod, only: Edgebuffer_t
335 : use schedtype_mod, only: schedule_t, cycle_t, schedule
336 : use thread_mod, only: omp_in_parallel, omp_get_thread_num
337 : use spmd_utils, only: mpi_real8, mpi_success
338 : use parallel_mod, only: parallel_t
339 :
340 : type (parallel_t) :: par
341 : integer, intent(in) :: nthreads
342 : integer :: ithr
343 : type (EdgeBuffer_t) :: buffer
344 : character (len=*), optional :: location
345 :
346 : type (Schedule_t),pointer :: pSchedule
347 : type (Cycle_t),pointer :: pCycle
348 : integer :: dest,length,tag
349 : integer :: icycle,ierr
350 : integer :: iptr,source,nlyr
351 : integer :: nSendCycles,nRecvCycles
352 : integer :: errorcode,errorlen
353 : character*(80) :: errorstring
354 : character(len=*), parameter :: subname = 'bndry_exchange_p2p_start'
355 : logical, parameter :: Debug=.FALSE.
356 :
357 : integer :: i,j, lenMovePtr
358 : logical :: ompthreadMissmatch
359 :
360 0 : pSchedule => Schedule(1)
361 0 : nlyr = buffer%nlyr
362 0 : ompthreadMissmatch = .FALSE.
363 :
364 0 : lenMovePtr = size(buffer%moveptr)
365 :
366 0 : if(ithr == 0) then
367 0 : nSendCycles = pSchedule%nSendCycles
368 0 : nRecvCycles = pSchedule%nRecvCycles
369 :
370 : !==================================================
371 : ! Fire off the sends
372 : !==================================================
373 :
374 0 : do icycle=1,nSendCycles
375 0 : pCycle => pSchedule%SendCycle(icycle)
376 0 : dest = pCycle%dest - 1
377 0 : length = buffer%scountsFull(icycle)
378 0 : tag = buffer%tag
379 0 : iptr = buffer%sdisplsFull(icycle) + 1
380 : if(Debug) write(iulog,*) subname,': MPI_Isend: DEST:',dest,'LENGTH:',length,'TAG: ',tag
381 0 : call MPI_Isend(buffer%buf(iptr),length,Mpi_real8,dest,tag,par%comm,buffer%Srequest(icycle),ierr)
382 0 : if(ierr .ne. MPI_SUCCESS) then
383 0 : errorcode=ierr
384 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
385 0 : write(iulog,*) subname,': Error after call to MPI_Isend: ',errorstring
386 : endif
387 : end do ! icycle
388 :
389 : !==================================================
390 : ! Post the Receives
391 : !==================================================
392 0 : do icycle=1,nRecvCycles
393 0 : pCycle => pSchedule%RecvCycle(icycle)
394 0 : source = pCycle%source - 1
395 0 : length = buffer%rcountsFull(icycle)
396 0 : tag = buffer%tag
397 0 : iptr = buffer%rdisplsFull(icycle) + 1
398 : if(Debug) write(iulog,*) subname,': MPI_Irecv: SRC:',source,'LENGTH:',length,'TAG: ',tag
399 0 : call MPI_Irecv(buffer%receive(iptr),length,Mpi_real8, &
400 0 : source,tag,par%comm,buffer%Rrequest(icycle),ierr)
401 0 : if(ierr .ne. MPI_SUCCESS) then
402 0 : errorcode=ierr
403 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
404 0 : write(iulog,*) subname,': Error after call to MPI_Irecv: ',errorstring
405 : endif
406 : end do ! icycle
407 : endif
408 :
409 0 : end subroutine bndry_exchange_p2p_start
410 :
411 0 : subroutine bndry_exchange_p2p_finish(par,nthreads,ithr,buffer,location)
412 : use edgetype_mod, only: Edgebuffer_t
413 : use schedtype_mod, only: schedule_t, cycle_t, schedule
414 : use thread_mod, only: omp_in_parallel, omp_get_thread_num
415 : use parallel_mod, only: parallel_t
416 : use perf_mod, only: t_startf, t_stopf
417 :
418 :
419 : type (parallel_t) :: par
420 : integer, intent(in) :: nthreads
421 : integer :: ithr
422 : type (EdgeBuffer_t) :: buffer
423 : character(len=*), optional :: location
424 :
425 : type (Schedule_t), pointer :: pSchedule
426 : type (Cycle_t), pointer :: pCycle
427 : integer :: dest,length,tag
428 : integer :: icycle,ierr
429 : integer :: iptr,source,nlyr
430 : integer :: nSendCycles,nRecvCycles
431 : integer :: errorcode,errorlen
432 : character*(80) :: errorstring
433 : character(len=*), parameter :: subname = 'bndry_exchange_p2p_finish'
434 : character(len=80) :: locstring
435 :
436 : integer :: i,j
437 : logical :: ompthreadMissmatch
438 : integer :: lenMovePtr
439 :
440 :
441 0 : pSchedule => Schedule(1)
442 0 : if(present(location)) then
443 0 : locstring = TRIM(subname) // ': ' // TRIM(location)
444 : else
445 0 : locstring = TRIM(subname)
446 : endif
447 0 : call copyBuffer(nthreads,ithr,buffer,locstring)
448 :
449 0 : if(ithr == 0) then
450 :
451 0 : nSendCycles = pSchedule%nSendCycles
452 0 : nRecvCycles = pSchedule%nRecvCycles
453 :
454 0 : if (nSendCycles>0) call MPI_Waitall(nSendCycles,buffer%Srequest,buffer%status,ierr)
455 0 : if (nRecvCycles>0) call MPI_Waitall(nRecvCycles,buffer%Rrequest,buffer%status,ierr)
456 :
457 : endif
458 :
459 0 : end subroutine bndry_exchange_p2p_finish
460 :
461 1536 : subroutine long_bndry_exchange_nonth(par,buffer)
462 0 : use edgetype_mod, only: LongEdgebuffer_t
463 : use schedtype_mod, only: schedule_t, cycle_t, schedule
464 : use thread_mod, only: omp_in_parallel
465 : use parallel_mod, only: parallel_t, status, srequest, rrequest
466 : use spmd_utils, only: mpi_integer, mpi_success
467 :
468 : type (parallel_t) :: par
469 : type (LongEdgeBuffer_t) :: buffer
470 :
471 : type (Schedule_t), pointer :: pSchedule
472 : type (Cycle_t), pointer :: pCycle
473 : integer :: dest,length,tag
474 : integer :: icycle,ierr
475 : integer :: iptr,source,nlyr
476 : integer :: nSendCycles,nRecvCycles
477 : integer :: errorcode,errorlen
478 : character*(80) :: errorstring
479 : character(len=*), parameter :: subname = 'long_bndry_exchange_nonth'
480 :
481 : integer :: i
482 :
483 : #ifdef SPMD
484 1536 : if(omp_in_parallel()) then
485 0 : print *,subname,': Warning you are calling a non-thread safe'
486 0 : print *,' routine inside a threaded region.... '
487 0 : print *,' Results are not predictable!! '
488 : endif
489 :
490 :
491 : ! Setup the pointer to proper Schedule
492 1536 : pSchedule => Schedule(1)
493 1536 : nlyr = buffer%nlyr
494 :
495 1536 : nSendCycles = pSchedule%nSendCycles
496 1536 : nRecvCycles = pSchedule%nRecvCycles
497 :
498 :
499 : !==================================================
500 : ! Fire off the sends
501 : !==================================================
502 :
503 11428 : do icycle=1,nSendCycles
504 9892 : pCycle => pSchedule%SendCycle(icycle)
505 9892 : dest = pCycle%dest - 1
506 9892 : length = nlyr * pCycle%lengthP
507 9892 : tag = pCycle%tag
508 9892 : iptr = pCycle%ptrP
509 :
510 9892 : call MPI_Isend(buffer%buf(1,iptr),length,Mpi_integer,dest,tag,par%comm,Srequest(icycle),ierr)
511 11428 : if(ierr .ne. MPI_SUCCESS) then
512 0 : errorcode=ierr
513 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
514 0 : write(iulog,*) subname,': Error after call to MPI_Isend: ',errorstring
515 : endif
516 : end do ! icycle
517 :
518 : !==================================================
519 : ! Post the Receives
520 : !==================================================
521 11428 : do icycle=1,nRecvCycles
522 9892 : pCycle => pSchedule%RecvCycle(icycle)
523 9892 : source = pCycle%source - 1
524 9892 : length = nlyr * pCycle%lengthP
525 9892 : tag = pCycle%tag
526 9892 : iptr = pCycle%ptrP
527 :
528 0 : call MPI_Irecv(buffer%receive(1,iptr),length,Mpi_integer, &
529 9892 : source,tag,par%comm,Rrequest(icycle),ierr)
530 11428 : if(ierr .ne. MPI_SUCCESS) then
531 0 : errorcode=ierr
532 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
533 0 : write(iulog,*) subname,': Error after call to MPI_Irecv: ',errorstring
534 : endif
535 : end do ! icycle
536 :
537 :
538 : !==================================================
539 : ! Wait for all the receives to complete
540 : !==================================================
541 :
542 1536 : if (nSendCycles>0) call MPI_Waitall(nSendCycles,Srequest,status,ierr)
543 1536 : if (nRecvCycles>0) call MPI_Waitall(nRecvCycles,Rrequest,status,ierr)
544 11428 : do icycle=1,nRecvCycles
545 9892 : pCycle => pSchedule%RecvCycle(icycle)
546 9892 : length = pCycle%lengthP
547 9892 : iptr = pCycle%ptrP
548 117504 : do i=0,length-1
549 222044 : buffer%buf(1:nlyr,iptr+i) = buffer%receive(1:nlyr,iptr+i)
550 : enddo
551 : end do ! icycle
552 :
553 : #endif
554 :
555 1536 : end subroutine long_bndry_exchange_nonth
556 : !********************************************************************************
557 : !
558 : !********************************************************************************
559 :
560 :
561 3329280 : subroutine ghost_exchange_threaded(hybrid,buffer,location)
562 : use hybrid_mod, only : hybrid_t
563 : use edgetype_mod, only : Edgebuffer_t
564 :
565 : implicit none
566 :
567 : type (hybrid_t) :: hybrid
568 : type (EdgeBuffer_t) :: buffer
569 : character(len=*), optional :: location
570 :
571 3329280 : call bndry_exchange_threaded(hybrid,buffer,location)
572 3329280 : end subroutine ghost_exchange_threaded
573 :
574 37327104 : subroutine bndry_exchange_threaded(hybrid,buffer,location)
575 : use hybrid_mod, only : hybrid_t
576 : use edgetype_mod, only : Edgebuffer_t
577 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
578 : implicit none
579 :
580 : type (hybrid_t) :: hybrid
581 : type (EdgeBuffer_t) :: buffer
582 : character(len=*), optional :: location
583 :
584 : character(len=*), parameter :: subname = 'bndry_exchange_threaded'
585 : !VERBOSE
586 : ! if(present(location)) then
587 : ! print *,subname,' ',location
588 : ! else
589 : ! print *,subname,' somewhere'
590 : ! endif
591 :
592 37327104 : call gbarrier(buffer%gbarrier, hybrid%ithr)
593 37327104 : if(buffer%bndry_type == HME_BNDRY_A2A) then
594 0 : call bndry_exchange_a2a(hybrid%par,hybrid%nthreads,hybrid%ithr,buffer,location)
595 37327104 : else if (buffer%bndry_type == HME_BNDRY_A2AO) then
596 0 : call bndry_exchange_a2ao(hybrid%par,hybrid%nthreads,hybrid%ithr,buffer,location)
597 : else
598 37327104 : call bndry_exchange_p2p(hybrid%par,hybrid%nthreads,hybrid%ithr,buffer,location)
599 : endif
600 37327104 : call gbarrier(buffer%gbarrier, hybrid%ithr)
601 :
602 37327104 : end subroutine bndry_exchange_threaded
603 :
604 0 : subroutine bndry_exchange_threaded_start(hybrid,buffer,location)
605 37327104 : use hybrid_mod, only : hybrid_t
606 : use edgetype_mod, only : Edgebuffer_t
607 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
608 : implicit none
609 :
610 : type (hybrid_t) :: hybrid
611 : type (EdgeBuffer_t) :: buffer
612 : character(len=*), optional :: location
613 :
614 : character(len=*), parameter :: subname = 'bndry_exchange_threaded_start'
615 :
616 0 : call gbarrier(buffer%gbarrier, hybrid%ithr)
617 0 : call bndry_exchange_p2p_start(hybrid%par,hybrid%nthreads,hybrid%ithr,buffer,location)
618 :
619 0 : end subroutine bndry_exchange_threaded_start
620 :
621 0 : subroutine bndry_exchange_threaded_finish(hybrid,buffer,location)
622 0 : use hybrid_mod, only : hybrid_t
623 : use edgetype_mod, only : Edgebuffer_t
624 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
625 : implicit none
626 :
627 : type (hybrid_t) :: hybrid
628 : type (EdgeBuffer_t) :: buffer
629 : character(len=*), optional :: location
630 :
631 : character(len=*), parameter :: subname = 'bndry_exchange_threaded_finish'
632 :
633 0 : call bndry_exchange_p2p_finish(hybrid%par,hybrid%nthreads,hybrid%ithr,buffer,location)
634 0 : call gbarrier(buffer%gbarrier, hybrid%ithr)
635 :
636 0 : end subroutine bndry_exchange_threaded_finish
637 :
638 0 : subroutine ghost_exchange_nonthreaded(par,buffer,location)
639 0 : use parallel_mod, only : parallel_t
640 : use edgetype_mod, only : Edgebuffer_t
641 : type (parallel_t) :: par
642 : type (EdgeBUffer_t) :: buffer
643 : character(len=*), optional :: location
644 0 : call bndry_exchange_nonthreaded(par,buffer,location)
645 0 : end subroutine ghost_exchange_nonthreaded
646 :
647 377856 : subroutine bndry_exchange_nonthreaded(par,buffer,location)
648 : use parallel_mod, only : parallel_t
649 : use edgetype_mod, only : Edgebuffer_t
650 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
651 : implicit none
652 :
653 : type (parallel_t) :: par
654 : type (EdgeBuffer_t) :: buffer
655 : character(len=*), optional :: location
656 :
657 : integer :: ithr
658 : integer :: nthreads
659 : character(len=*), parameter :: subname = 'bndry_exchange_nonthreaded'
660 :
661 : !$OMP BARRIER
662 377856 : ithr=0
663 377856 : nthreads = 1
664 377856 : if(buffer%bndry_type == HME_BNDRY_A2A) then
665 0 : call bndry_exchange_a2a(par,nthreads,ithr,buffer,location)
666 377856 : else if (buffer%bndry_type == HME_BNDRY_A2AO) then
667 0 : call bndry_exchange_a2ao(par,nthreads,ithr,buffer,location)
668 : else
669 377856 : call bndry_exchange_p2p(par,nthreads,ithr,buffer,location)
670 : endif
671 : !$OMP BARRIER
672 :
673 377856 : end subroutine bndry_exchange_nonthreaded
674 :
675 0 : subroutine bndry_exchange_nonthreaded_start(par,buffer,location)
676 377856 : use parallel_mod, only : parallel_t
677 : use edgetype_mod, only : Edgebuffer_t
678 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
679 : implicit none
680 :
681 : type (parallel_t) :: par
682 : type (EdgeBuffer_t) :: buffer
683 : character (len=*), optional :: location
684 :
685 : integer :: ithr
686 : integer :: nthreads
687 : character(len=*), parameter :: subname = 'bndry_exchange_nonthreaded_start'
688 :
689 : !$OMP BARRIER
690 0 : ithr=0
691 0 : nthreads=1
692 0 : call bndry_exchange_p2p_start(par,nthreads,ithr,buffer,location)
693 :
694 0 : end subroutine bndry_exchange_nonthreaded_start
695 :
696 0 : subroutine bndry_exchange_nonthreaded_finish(par,buffer,location)
697 0 : use parallel_mod, only : parallel_t
698 : use edgetype_mod, only : Edgebuffer_t
699 : use perf_mod, only: t_startf, t_stopf, t_adj_detailf
700 : implicit none
701 :
702 : type (parallel_t) :: par
703 : integer :: ithr
704 : type (EdgeBuffer_t) :: buffer
705 : character (len=*), optional :: location
706 : integer :: nthreads
707 :
708 : character(len=*), parameter :: subname = 'bndry_exchange_nonthreaded_finish'
709 :
710 0 : ithr=0
711 0 : nthreads=1
712 0 : call bndry_exchange_p2p_finish(par,nthreads,ithr,buffer,location)
713 : !$OMP BARRIER
714 :
715 0 : end subroutine bndry_exchange_nonthreaded_finish
716 :
717 1536 : subroutine compute_ghost_corner_orientation(hybrid,elem,nets,nete)
718 : !
719 : ! this routine can NOT be called in a threaded region because then each thread
720 : ! will have its on ghostbuffer. initghostbufer3D() should detect this and abort.
721 : !
722 0 : use dimensions_mod, only: nelemd, np
723 : use parallel_mod, only : syncmp
724 : use hybrid_mod, only : hybrid_t
725 : use element_mod, only : element_t
726 : use edgetype_mod, only : edgebuffer_t
727 : use edge_mod, only : ghostpack, ghostunpack, &
728 : initghostbuffer,freeghostbuffer
729 :
730 : use control_mod, only : north,south,east,west,neast, nwest, seast, swest
731 :
732 : type (hybrid_t) , intent(in) :: hybrid
733 : type (element_t) , intent(inout), target :: elem(:)
734 : integer :: nets,nete
735 1536 : type (edgeBuffer_t) :: ghostbuf_cv
736 :
737 3072 : real (kind=r8) :: cin(-1:4,-1:4,1,nets:nete) !CE: fvm tracer
738 3072 : real (kind=r8) :: cout(-1:4,-1:4,1,nets:nete) !CE: fvm tracer
739 : integer :: i,j,ie,kptr,np1,np2,nc,nc1,nc2,k,nlev
740 : logical :: fail,fail1,fail2
741 : real (kind=r8) :: tol = 0.1_r8
742 1536 : call syncmp(hybrid%par)
743 :
744 :
745 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
746 : ! first test on the Gauss Grid with same number of ghost cells:
747 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
748 1536 : nc=2 ! test using GLL interior points
749 1536 : nc1=-1
750 1536 : nc2=4
751 :
752 1536 : nlev=1
753 :
754 1536 : if (hybrid%nthreads > 1) then
755 0 : call endrun('ERROR: compute_ghost_corner_orientation must be called before threaded region')
756 : endif
757 1536 : call initghostbuffer(hybrid%par,ghostbuf_cv,elem,nlev,nc,nc,nthreads=1)
758 :
759 :
760 476736 : cin = 0._r8
761 12336 : do ie=nets,nete
762 10800 : cin(1,1,1,ie)= elem(ie)%gdofp(1,1)
763 10800 : cin(nc,nc,1,ie)= elem(ie)%gdofp(np,np)
764 10800 : cin(1,nc,1,ie)= elem(ie)%gdofp(1,np)
765 12336 : cin(nc,1,1,ie)= elem(ie)%gdofp(np,1)
766 : enddo
767 476736 : cout=0
768 :
769 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
770 : ! run ghost exchange on c array to get corner orientation
771 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
772 12336 : do ie=nets,nete
773 10800 : kptr=0
774 12336 : call ghostpack(ghostbuf_cv, cin(:,:,:,ie),nlev,kptr,ie)
775 : end do
776 1536 : call ghost_exchange(hybrid,ghostbuf_cv,location='compute_ghost_corner_orientation')
777 12336 : do ie=nets,nete
778 10800 : kptr=0
779 12336 : call ghostunpack(ghostbuf_cv, cout(:,:,:,ie),nlev,kptr,ie)
780 : enddo
781 :
782 : ! nc +--------+
783 : ! ^ | nw ne |
784 : ! j | | |
785 : ! 1 | sw se |
786 : ! +--------+
787 : ! 1 --> nc
788 : ! i
789 :
790 : ! check SW corner
791 12336 : do ie=nets,nete
792 10800 : fail1=.false.
793 10800 : fail2=.false.
794 10800 : if ( elem(ie)%desc%putmapP_ghost(swest) /= -1) then
795 10788 : if (abs(cout(nc1,1,1,ie)-cout(nc1,0,1,ie)) .gt. tol ) fail1=.true.
796 10788 : if (abs(cout(1,nc1,1,ie)-cout(0,nc1,1,ie)).gt.tol) fail2=.true.
797 : endif
798 10788 : if (fail1 .neqv. fail2 ) call endrun( 'ghost exchange SW orientation failure')
799 12336 : if (fail1) then
800 232 : elem(ie)%desc%reverse(swest)=.true.
801 : endif
802 : enddo
803 : ! check SE corner
804 12336 : do ie=nets,nete
805 10800 : fail1=.false.
806 10800 : fail2=.false.
807 10800 : if ( elem(ie)%desc%putmapP_ghost(seast) /= -1) then
808 10788 : if (abs(cout(nc2,1,1,ie)-cout(nc2,0,1,ie)) .gt. tol ) fail1=.true.
809 10788 : if (abs(cout(nc+1,nc1,1,ie)-cout(nc,nc1,1,ie)).gt.tol) fail2=.true.
810 : endif
811 10788 : if (fail1 .neqv. fail2 ) call endrun('ghost exchange SE orientation failure')
812 12336 : if (fail1) then
813 232 : elem(ie)%desc%reverse(seast)=.true.
814 : endif
815 : enddo
816 : ! check NW corner
817 12336 : do ie=nets,nete
818 10800 : fail1=.false.
819 10800 : fail2=.false.
820 10800 : if ( elem(ie)%desc%putmapP_ghost(nwest) /= -1) then
821 10788 : if (abs(cout(nc1,nc+1,1,ie)-cout(nc1,nc,1,ie)) .gt. tol ) fail1=.true.
822 10788 : if (abs(cout(1,nc2,1,ie)-cout(0,nc2,1,ie)).gt.tol) fail2=.true.
823 : endif
824 10788 : if (fail1 .neqv. fail2 ) call endrun( 'ghost exchange NW orientation failure')
825 12336 : if (fail1) then
826 232 : elem(ie)%desc%reverse(nwest)=.true.
827 : endif
828 : enddo
829 : ! check NE corner
830 12336 : do ie=nets,nete
831 10800 : fail1=.false.
832 10800 : fail2=.false.
833 10800 : if ( elem(ie)%desc%putmapP_ghost(neast) /= -1) then
834 10788 : if (abs(cout(nc2,nc+1,1,ie)-cout(nc2,nc,1,ie)) .gt. tol ) fail1=.true.
835 10788 : if (abs(cout(nc+1,nc2,1,ie)-cout(nc,nc2,1,ie)).gt.tol) fail2=.true.
836 : endif
837 10788 : if (fail1 .neqv. fail2 ) call endrun( 'ghost exchange NE orientation failure')
838 12336 : if (fail1) then
839 232 : elem(ie)%desc%reverse(neast)=.true.
840 : endif
841 : enddo
842 1536 : call freeghostbuffer(ghostbuf_cv)
843 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
844 : ! end ghost exchange corner orientation
845 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
846 1536 : end subroutine
847 0 : subroutine ghost_exchangeVfull(par,ithr,buffer)
848 : !
849 : ! MT 2011: derived from bndry_exchange, but copies an entire
850 : ! element of ghost cell information, including corner
851 : ! elements. Requres cubed-sphere grid
852 : !
853 1536 : use hybrid_mod, only : hybrid_t
854 : use edgetype_mod, only: Ghostbuffer3D_t
855 : use schedtype_mod, only : schedule_t, cycle_t, schedule
856 : use dimensions_mod, only: nelemd
857 : use parallel_mod, only : status, srequest, rrequest, parallel_t
858 : use spmd_utils, only: mpi_integer, mpi_success,mpi_real8
859 :
860 : implicit none
861 : type (parallel_t) :: par
862 : integer :: ithr ! hybrid%ithr 0 if called outside threaded region
863 :
864 : type (GhostBuffer3D_t) :: buffer
865 :
866 : type (Schedule_t),pointer :: pSchedule
867 : type (Cycle_t),pointer :: pCycle
868 : integer :: dest,length,tag
869 : integer :: icycle,ierr
870 : integer :: iptr,source,nlyr
871 : integer :: nSendCycles,nRecvCycles
872 : integer :: errorcode,errorlen
873 : character(len=*), parameter :: subname = 'ghost_exchangeVfull'
874 : character*(80) errorstring
875 :
876 : integer :: i,i1,i2
877 :
878 : !$OMP BARRIER
879 0 : if(ithr == 0) then
880 :
881 :
882 : #ifdef SPMD
883 : ! Setup the pointer to proper Schedule
884 0 : pSchedule => Schedule(1)
885 0 : nlyr = buffer%nlyr
886 :
887 0 : nSendCycles = pSchedule%nSendCycles
888 0 : nRecvCycles = pSchedule%nRecvCycles
889 :
890 : !==================================================
891 : ! Fire off the sends
892 : !==================================================
893 0 : do icycle=1,nSendCycles
894 0 : pCycle => pSchedule%SendCycle(icycle)
895 0 : dest = pCycle%dest - 1
896 0 : length = nlyr * pCycle%lengthP_ghost * buffer%elem_size
897 0 : tag = pCycle%tag
898 0 : iptr = pCycle%ptrP_ghost
899 :
900 0 : call MPI_Isend(buffer%buf(1,1,1,iptr),length,MPI_real8,dest,tag,par%comm,Srequest(icycle),ierr)
901 0 : if(ierr .ne. MPI_SUCCESS) then
902 0 : errorcode=ierr
903 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
904 0 : print *,subname,': Error after call to MPI_Isend: ',errorstring
905 : endif
906 : end do ! icycle
907 :
908 : !==================================================
909 : ! Post the Receives
910 : !==================================================
911 0 : do icycle=1,nRecvCycles
912 0 : pCycle => pSchedule%RecvCycle(icycle)
913 0 : source = pCycle%source - 1
914 0 : length = nlyr * pCycle%lengthP_ghost * buffer%elem_size
915 0 : tag = pCycle%tag
916 0 : iptr = pCycle%ptrP_ghost
917 :
918 0 : call MPI_Irecv(buffer%receive(1,1,1,iptr),length,MPI_real8, &
919 0 : source,tag,par%comm,Rrequest(icycle),ierr)
920 0 : if(ierr .ne. MPI_SUCCESS) then
921 0 : errorcode=ierr
922 0 : call MPI_Error_String(errorcode,errorstring,errorlen,ierr)
923 0 : print *,subname,': Error after call to MPI_Irecv: ',errorstring
924 : endif
925 : end do ! icycle
926 :
927 :
928 : !==================================================
929 : ! Wait for all the receives to complete
930 : !==================================================
931 :
932 0 : call MPI_Waitall(nSendCycles,Srequest,status,ierr)
933 0 : call MPI_Waitall(nRecvCycles,Rrequest,status,ierr)
934 :
935 0 : do icycle=1,nRecvCycles
936 0 : pCycle => pSchedule%RecvCycle(icycle)
937 0 : length = pCycle%lengthP_ghost
938 0 : iptr = pCycle%ptrP_ghost
939 0 : do i=0,length-1
940 0 : buffer%buf(:,:,1:nlyr,iptr+i) = buffer%receive(:,:,1:nlyr,iptr+i)
941 : enddo
942 : end do ! icycle
943 :
944 :
945 : #endif
946 : endif ! if (hybrid%ithr == 0)
947 : !$OMP BARRIER
948 :
949 0 : end subroutine ghost_exchangeVfull
950 :
951 :
952 : end module bndry_mod
|
