ROMS
Loading...
Searching...
No Matches
mp_exchange.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE mp_exchange_mod
3#ifdef DISTRIBUTE
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! Distributed-memory tile exchange: !
13! !
14! This routine updates the I,J tile overlap halo of NV variables. !
15! It exchanges the specified number of "ghost-points". In order !
16! to minimize the number send and receive calls, the ghost-points !
17! are included in the buffers. Therefore, the order of the pack, !
18! send, receive, and unpack is crucial. !
19! !
20! On Input: !
21! !
22! ng Nested grid number. !
23! model Calling model identifier. !
24! Nvar Number of variables for aggregated exchanges. !
25! Istr Starting tile index in the I-direction. !
26! Iend Ending tile index in the I-direction. !
27! Jstr Starting tile index in the J-direction. !
28! Jend Ending tile index in the J-direction. !
29! LBi I-dimension Lower bound. !
30! UBi I-dimension Upper bound. !
31! LBj J-dimension Lower bound. !
32! UBj J-dimension Upper bound. !
33! LBk K-dimension Lower bound. !
34! UBk K-dimension Upper bound. !
35! LBt T-dimension Lower bound. !
36! UBt T-dimension Upper bound. !
37! Nghost Number of ghost-points in the halo region. !
38! EW_periodic Switch indicating EW periodicity exchanges. !
39! NS_periodic Switch indicating NS periodicity exchanges. !
40! A 2D tiled array to process. !
41! B 2D tiled array (optional) to process. !
42! C 2D tiled array (optional) to process. !
43! D 2D tiled array (optional) to process. !
44! !
45! On Output: !
46! !
47! A Updated tiled array. !
48! B Updated tiled array (optional). !
49! C Updated tiled array (optional). !
50! D Updated tiled array (optional). !
51! !
52! Routines: !
53! !
54! mp_exchange2d 2D variables tile exchanges !
55! mp_exchange2d_bry 2D boundary variables tile exchanges !
56! mp_exchange3d 3D variables tile exchanges !
57! mp_exchange3d_bry 3D boundary variables tile exchanges !
58! mp_exchange4d 4D variables tile exchanges !
59! !
60! ad_mp_exchange2d 2D variables tile adjoint exchanges !
61! ad_mp_exchange2d_bry 2D boundary variables tile adjoint exchanges !
62! ad_mp_exchange3d 3D variables tile adjoint exchanges !
63! ad_mp_exchange3d_bry 3D boundary variables tile adjoint exchanges !
64! ad_mp_exchange4d 4D variables tile adjoint exchanges !
65! !
66!=======================================================================
67!
68 implicit none
69
70 CONTAINS
71!
72!***********************************************************************
73 SUBROUTINE tile_neighbors (ng, Nghost, EW_periodic, NS_periodic, &
74 & GrecvW, GsendW, Wtile, Wexchange, &
75 & GrecvE, GsendE, Etile, Eexchange, &
76 & GrecvS, GsendS, Stile, Sexchange, &
77 & GrecvN, GsendN, Ntile, Nexchange)
78!***********************************************************************
79!
80 USE mod_param
81 USE mod_parallel
82!
83 implicit none
84!
85! Imported variable declarations.
86!
87 logical, intent(in) :: EW_periodic, NS_periodic
88
89 integer, intent(in) :: ng, Nghost
90
91 logical, intent(out) :: Wexchange, Eexchange
92 logical, intent(out) :: Sexchange, Nexchange
93
94 integer, intent(out) :: GrecvW, GsendW, Wtile
95 integer, intent(out) :: GrecvE, GsendE, Etile
96 integer, intent(out) :: GrecvS, GsendS, Stile
97 integer, intent(out) :: GrecvN, GsendN, Ntile
98!
99! Local variable declarations.
100!
101 integer :: i, j
102 integer :: MyRankI, MyRankJ, Null_Value, rank
103
104 integer, dimension(-1:NtileI(ng),-1:NtileJ(ng)) :: table
105!
106!-----------------------------------------------------------------------
107! Set tile partition table for looking up adjacent processes.
108!-----------------------------------------------------------------------
109!
110! Notice that a null value is used in places that data transmition is
111! not required.
112!
113# if defined MPI
114 null_value=mpi_proc_null
115# else
116 null_value=-1
117# endif
118 DO j=-1,ntilej(ng)
119 DO i=-1,ntilei(ng)
120 table(i,j)=null_value
121 END DO
122 END DO
123 rank=0
124 DO j=0,ntilej(ng)-1
125 DO i=0,ntilei(ng)-1
126 table(i,j)=rank
127 IF (myrank.eq.rank) THEN
128 myranki=i
129 myrankj=j
130 END IF
131 rank=rank+1
132 END DO
133 END DO
134!
135!-----------------------------------------------------------------------
136! Determine the rank of Western and Eastern tiles. Then, determine
137! the number of ghost-points to send and receive in the West- and
138! East-directions.
139!-----------------------------------------------------------------------
140!
141! This logic only works for two and three ghost points. The number of
142! ghost-points changes when periodic boundary condition are activated.
143! The periodicity is as follows:
144!
145! If two ghost-points:
146!
147! Lm-2 Lm-1 Lm Lm+1 Lm+2
148! -2 -1 0 1 2
149!
150! If three ghost-points:
151!
152! Lm-2 Lm-1 Lm Lm+1 Lm+2 Lm+3
153! -2 -1 0 1 2 3
154!
155 IF (ew_periodic) THEN
156 IF ((table(myranki-1,myrankj).eq.null_value).and. &
157 & (ntilei(ng).gt.1)) THEN
158 wtile=table(ntilei(ng)-1,myrankj)
159 etile=table(myranki+1,myrankj)
160 gsendw=nghost
161 gsende=nghost
162 IF (nghostpoints.eq.3) THEN
163 grecvw=nghost
164 ELSE
165 grecvw=nghost+1
166 END IF
167 grecve=nghost
168 ELSE IF ((table(myranki+1,myrankj).eq.null_value).and. &
169 & (ntilei(ng).gt.1)) THEN
170 wtile=table(myranki-1,myrankj)
171 etile=table(0,myrankj)
172 gsendw=nghost
173 IF (nghostpoints.eq.3) THEN
174 gsende=nghost
175 ELSE
176 gsende=nghost+1
177 END IF
178 grecvw=nghost
179 grecve=nghost
180 ELSE
181 wtile=table(myranki-1,myrankj)
182 etile=table(myranki+1,myrankj)
183 gsendw=nghost
184 gsende=nghost
185 grecvw=nghost
186 grecve=nghost
187 END IF
188 ELSE
189 wtile=table(myranki-1,myrankj)
190 etile=table(myranki+1,myrankj)
191 gsendw=nghost
192 gsende=nghost
193 grecvw=nghost
194 grecve=nghost
195 END IF
196!
197! Determine exchange switches.
198!
199 IF (wtile.eq.null_value) THEN
200 wexchange=.false.
201 ELSE
202 wexchange=.true.
203 END IF
204 IF (etile.eq.null_value) THEN
205 eexchange=.false.
206 ELSE
207 eexchange=.true.
208 END IF
209!
210!-----------------------------------------------------------------------
211! Determine the rank of Southern and Northern tiles. Then, determine
212! the number of ghost-points to send and receive in the South- and
213! North-directions.
214!-----------------------------------------------------------------------
215!
216! This logic only works for two and three ghost-points. The number of
217! ghost-points changes when periodic boundary condition are activated.
218! The periodicity is as follows:
219!
220! If two ghost-points:
221!
222! Mm-2 Mm-1 Mm Mm+1 Mm+2
223! -2 -1 0 1 2
224!
225! If three ghost-points:
226!
227! Mm-2 Mm-1 Mm Mm+1 Mm+2 Mm+3
228! -2 -1 0 1 2 3
229!
230 IF (ns_periodic) THEN
231 IF ((table(myranki,myrankj-1).eq.null_value).and. &
232 & (ntilej(ng).gt.1)) THEN
233 stile=table(myranki,ntilej(ng)-1)
234 ntile=table(myranki,myrankj+1)
235 gsends=nghost
236 gsendn=nghost
237 IF (nghostpoints.eq.3) THEN
238 grecvs=nghost
239 ELSE
240 grecvs=nghost+1
241 END IF
242 grecvn=nghost
243 ELSE IF ((table(myranki,myrankj+1).eq.null_value).and. &
244 & (ntilej(ng).gt.1)) then
245 stile=table(myranki,myrankj-1)
246 ntile=table(myranki,0)
247 gsends=nghost
248 IF (nghostpoints.eq.3) THEN
249 gsendn=nghost
250 ELSE
251 gsendn=nghost+1
252 END IF
253 grecvs=nghost
254 grecvn=nghost
255 ELSE
256 stile=table(myranki,myrankj-1)
257 ntile=table(myranki,myrankj+1)
258 gsends=nghost
259 gsendn=nghost
260 grecvs=nghost
261 grecvn=nghost
262 END IF
263 ELSE
264 stile=table(myranki,myrankj-1)
265 ntile=table(myranki,myrankj+1)
266 gsends=nghost
267 gsendn=nghost
268 grecvs=nghost
269 grecvn=nghost
270 END IF
271!
272! Determine exchange switches.
273!
274 IF (stile.eq.null_value) THEN
275 sexchange=.false.
276 ELSE
277 sexchange=.true.
278 END IF
279 IF (ntile.eq.null_value) THEN
280 nexchange=.false.
281 ELSE
282 nexchange=.true.
283 END IF
284
285 RETURN
286 END SUBROUTINE tile_neighbors
287
288!
289!***********************************************************************
290 SUBROUTINE mp_exchange2d (ng, tile, model, Nvar, &
291 & LBi, UBi, LBj, UBj, &
292 & Nghost, EW_periodic, NS_periodic, &
293 & A, B, C, D)
294!***********************************************************************
295!
296 USE mod_param
297 USE mod_parallel
298 USE mod_iounits
299 USE mod_scalars
300!
301 implicit none
302!
303! Imported variable declarations.
304!
305 logical, intent(in) :: EW_periodic, NS_periodic
306!
307 integer, intent(in) :: ng, tile, model, Nvar
308 integer, intent(in) :: LBi, UBi, LBj, UBj
309 integer, intent(in) :: Nghost
310!
311# ifdef ASSUMED_SHAPE
312 real(r8), intent(inout) :: A(LBi:,LBj:)
313
314 real(r8), intent(inout), optional :: B(LBi:,LBj:)
315 real(r8), intent(inout), optional :: C(LBi:,LBj:)
316 real(r8), intent(inout), optional :: D(LBi:,LBj:)
317# else
318 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj)
319
320 real(r8), intent(inout), optional :: B(LBi:UBi,LBj:UBj)
321 real(r8), intent(inout), optional :: C(LBi:UBi,LBj:UBj)
322 real(r8), intent(inout), optional :: D(LBi:UBi,LBj:UBj)
323# endif
324!
325! Local variable declarations.
326!
327 logical :: Wexchange, Sexchange, Eexchange, Nexchange
328!
329 integer :: i, icS, icN, ioff, Imin, Imax, Ilen
330 integer :: j, jcW, jcE, joff, Jmin, Jmax, Jlen
331 integer :: m, mc, Ierror, Lstr, pp
332 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
333 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
334 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
335 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
336 integer :: EWsize, sizeW, sizeE
337 integer :: NSsize, sizeS, sizeN
338
339# ifdef MPI
340 integer, dimension(MPI_STATUS_SIZE,4) :: status
341# endif
342!
343 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: sendW, sendE
344 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: recvW, recvE
345
346 real(r8), dimension(Nvar*HaloSizeI(ng)) :: sendS, sendN
347 real(r8), dimension(Nvar*HaloSizeI(ng)) :: recvS, recvN
348!
349 character (len=MPI_MAX_ERROR_STRING) :: string
350
351 character (len=*), parameter :: MyFile = &
352 & __FILE__//", mp_exchange2d"
353
354# include "set_bounds.h"
355
356# ifdef PROFILE
357!
358!-----------------------------------------------------------------------
359! Turn on time clocks.
360!-----------------------------------------------------------------------
361!
362 CALL wclock_on (ng, model, 60, __line__, myfile)
363# endif
364!
365!-----------------------------------------------------------------------
366! Determine rank of tile neighbors and number of ghost-points to
367! exchange.
368!-----------------------------------------------------------------------
369!
370! Maximum automatic buffer memory size in bytes.
371!
372 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
373 & 4*SIZE(sends))*kind(a),r8))
374!
375 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
376 & grecvw, gsendw, wtile, wexchange, &
377 & grecve, gsende, etile, eexchange, &
378 & grecvs, gsends, stile, sexchange, &
379 & grecvn, gsendn, ntile, nexchange)
380!
381! Set communication tags.
382!
383 wtag=1
384 stag=2
385 etag=3
386 ntag=4
387!
388! Determine range and length of the distributed tile boundary segments.
389!
390 imin=lbi
391 imax=ubi
392 jmin=lbj
393 jmax=ubj
394 ilen=imax-imin+1
395 jlen=jmax-jmin+1
396 IF (ew_periodic.or.ns_periodic) THEN
397 pp=1
398 ELSE
399 pp=0
400 END IF
401 ewsize=nvar*(nghost+pp)*jlen
402 nssize=nvar*(nghost+pp)*ilen
403 IF (SIZE(sende).lt.ewsize) THEN
404 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
405 10 FORMAT (/,' MP_EXCHANGE2D - communication buffer too small, ', &
406 & a, 2i8)
407 END IF
408 IF (SIZE(sendn).lt.nssize) THEN
409 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
410 END IF
411!
412!-----------------------------------------------------------------------
413! Pack Western and Eastern tile boundary data including ghost-points.
414!-----------------------------------------------------------------------
415!
416 IF (wexchange) THEN
417 sizew=0
418 DO m=1,gsendw
419 mc=(m-1)*jlen
420 i=istr+m-1
421 DO j=jmin,jmax
422 sizew=sizew+1
423 jcw=1+(j-jmin)+mc
424 sendw(jcw)=a(i,j)
425 END DO
426 END DO
427 IF (PRESENT(b)) THEN
428 joff=jcw
429 DO m=1,gsendw
430 mc=(m-1)*jlen
431 i=istr+m-1
432 DO j=jmin,jmax
433 sizew=sizew+1
434 jcw=joff+1+(j-jmin)+mc
435 sendw(jcw)=b(i,j)
436 END DO
437 END DO
438 END IF
439 IF (PRESENT(c)) THEN
440 joff=jcw
441 DO m=1,gsendw
442 mc=(m-1)*jlen
443 i=istr+m-1
444 DO j=jmin,jmax
445 sizew=sizew+1
446 jcw=joff+1+(j-jmin)+mc
447 sendw(jcw)=c(i,j)
448 END DO
449 END DO
450 END IF
451 IF (PRESENT(d)) THEN
452 joff=jcw
453 DO m=1,gsendw
454 mc=(m-1)*jlen
455 i=istr+m-1
456 DO j=jmin,jmax
457 sizew=sizew+1
458 jcw=joff+1+(j-jmin)+mc
459 sendw(jcw)=d(i,j)
460 END DO
461 END DO
462 END IF
463 END IF
464!
465 IF (eexchange) THEN
466 sizee=0
467 DO m=1,gsende
468 mc=(m-1)*jlen
469 i=iend-gsende+m
470 DO j=jmin,jmax
471 sizee=sizee+1
472 jce=1+(j-jmin)+mc
473 sende(jce)=a(i,j)
474 END DO
475 END DO
476 IF (PRESENT(b)) THEN
477 joff=jce
478 DO m=1,gsende
479 mc=(m-1)*jlen
480 i=iend-gsende+m
481 DO j=jmin,jmax
482 sizee=sizee+1
483 jce=joff+1+(j-jmin)+mc
484 sende(jce)=b(i,j)
485 END DO
486 END DO
487 END IF
488 IF (PRESENT(c)) THEN
489 joff=jce
490 DO m=1,gsende
491 mc=(m-1)*jlen
492 i=iend-gsende+m
493 DO j=jmin,jmax
494 sizee=sizee+1
495 jce=joff+1+(j-jmin)+mc
496 sende(jce)=c(i,j)
497 END DO
498 END DO
499 END IF
500 IF (PRESENT(d)) THEN
501 joff=jce
502 DO m=1,gsende
503 mc=(m-1)*jlen
504 i=iend-gsende+m
505 DO j=jmin,jmax
506 sizee=sizee+1
507 jce=joff+1+(j-jmin)+mc
508 sende(jce)=d(i,j)
509 END DO
510 END DO
511 END IF
512 END IF
513!
514!-----------------------------------------------------------------------
515! Send and receive Western and Eastern segments.
516!-----------------------------------------------------------------------
517!
518# if defined MPI
519 IF (wexchange) THEN
520 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
521 & ocn_comm_world, wrequest, werror)
522 END IF
523 IF (eexchange) THEN
524 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
525 & ocn_comm_world, erequest, eerror)
526 END IF
527 IF (wexchange) THEN
528 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
529 & ocn_comm_world, werror)
530 END IF
531 IF (eexchange) THEN
532 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
533 & ocn_comm_world, eerror)
534 END IF
535# endif
536!
537!-----------------------------------------------------------------------
538! Unpack Western and Eastern segments.
539!-----------------------------------------------------------------------
540!
541 IF (wexchange) THEN
542# ifdef MPI
543 CALL mpi_wait (wrequest, status(1,1), werror)
544 IF (werror.ne.mpi_success) THEN
545 CALL mpi_error_string (werror, string, lstr, ierror)
546 lstr=len_trim(string)
547 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
548 & myrank, werror, string(1:lstr)
549 20 FORMAT (/,' MP_EXCHANGE2D - error during ',a, &
550 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
551 exit_flag=2
552 RETURN
553 END IF
554# endif
555 DO m=grecvw,1,-1
556 mc=(grecvw-m)*jlen
557 i=istr-m
558 DO j=jmin,jmax
559 jcw=1+(j-jmin)+mc
560 a(i,j)=recvw(jcw)
561 END DO
562 END DO
563 IF (PRESENT(b)) THEN
564 joff=jcw
565 DO m=grecvw,1,-1
566 mc=(grecvw-m)*jlen
567 i=istr-m
568 DO j=jmin,jmax
569 jcw=joff+1+(j-jmin)+mc
570 b(i,j)=recvw(jcw)
571 END DO
572 END DO
573 END IF
574 IF (PRESENT(c)) THEN
575 joff=jcw
576 DO m=grecvw,1,-1
577 mc=(grecvw-m)*jlen
578 i=istr-m
579 DO j=jmin,jmax
580 jcw=joff+1+(j-jmin)+mc
581 c(i,j)=recvw(jcw)
582 END DO
583 END DO
584 END IF
585 IF (PRESENT(d)) THEN
586 joff=jcw
587 DO m=grecvw,1,-1
588 mc=(grecvw-m)*jlen
589 i=istr-m
590 DO j=jmin,jmax
591 jcw=joff+1+(j-jmin)+mc
592 d(i,j)=recvw(jcw)
593 END DO
594 END DO
595 END IF
596 END IF
597!
598 IF (eexchange) THEN
599# ifdef MPI
600 CALL mpi_wait (erequest, status(1,3), eerror)
601 IF (eerror.ne.mpi_success) THEN
602 CALL mpi_error_string (eerror, string, lstr, ierror)
603 lstr=len_trim(string)
604 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
605 & myrank, eerror, string(1:lstr)
606 exit_flag=2
607 RETURN
608 END IF
609# endif
610 DO m=1,grecve
611 mc=(m-1)*jlen
612 i=iend+m
613 DO j=jmin,jmax
614 jce=1+(j-jmin)+mc
615 a(i,j)=recve(jce)
616 ENDDO
617 END DO
618 IF (PRESENT(b)) THEN
619 joff=jce
620 DO m=1,grecve
621 mc=(m-1)*jlen
622 i=iend+m
623 DO j=jmin,jmax
624 jce=joff+1+(j-jmin)+mc
625 b(i,j)=recve(jce)
626 ENDDO
627 END DO
628 END IF
629 IF (PRESENT(c)) THEN
630 joff=jce
631 DO m=1,grecve
632 mc=(m-1)*jlen
633 i=iend+m
634 DO j=jmin,jmax
635 jce=joff+1+(j-jmin)+mc
636 c(i,j)=recve(jce)
637 ENDDO
638 END DO
639 END IF
640 IF (PRESENT(d)) THEN
641 joff=jce
642 DO m=1,grecve
643 mc=(m-1)*jlen
644 i=iend+m
645 DO j=jmin,jmax
646 jce=joff+1+(j-jmin)+mc
647 d(i,j)=recve(jce)
648 ENDDO
649 END DO
650 END IF
651 END IF
652!
653!-----------------------------------------------------------------------
654! Pack Southern and Northern tile boundary data including ghost-points.
655!-----------------------------------------------------------------------
656!
657 IF (sexchange) THEN
658 sizes=0
659 DO m=1,gsends
660 mc=(m-1)*ilen
661 j=jstr+m-1
662 DO i=imin,imax
663 sizes=sizes+1
664 ics=1+(i-imin)+mc
665 sends(ics)=a(i,j)
666 END DO
667 END DO
668 IF (PRESENT(b)) THEN
669 ioff=ics
670 DO m=1,gsends
671 mc=(m-1)*ilen
672 j=jstr+m-1
673 DO i=imin,imax
674 sizes=sizes+1
675 ics=ioff+1+(i-imin)+mc
676 sends(ics)=b(i,j)
677 END DO
678 END DO
679 END IF
680 IF (PRESENT(c)) THEN
681 ioff=ics
682 DO m=1,gsends
683 mc=(m-1)*ilen
684 j=jstr+m-1
685 DO i=imin,imax
686 sizes=sizes+1
687 ics=ioff+1+(i-imin)+mc
688 sends(ics)=c(i,j)
689 END DO
690 END DO
691 END IF
692 IF (PRESENT(d)) THEN
693 ioff=ics
694 DO m=1,gsends
695 mc=(m-1)*ilen
696 j=jstr+m-1
697 DO i=imin,imax
698 sizes=sizes+1
699 ics=ioff+1+(i-imin)+mc
700 sends(ics)=d(i,j)
701 END DO
702 END DO
703 END IF
704 END IF
705!
706 IF (nexchange) THEN
707 sizen=0
708 DO m=1,gsendn
709 mc=(m-1)*ilen
710 j=jend-gsendn+m
711 DO i=imin,imax
712 sizen=sizen+1
713 icn=1+(i-imin)+mc
714 sendn(icn)=a(i,j)
715 END DO
716 END DO
717 IF (PRESENT(b)) THEN
718 ioff=icn
719 DO m=1,gsendn
720 mc=(m-1)*ilen
721 j=jend-gsendn+m
722 DO i=imin,imax
723 sizen=sizen+1
724 icn=ioff+1+(i-imin)+mc
725 sendn(icn)=b(i,j)
726 END DO
727 END DO
728 END IF
729 IF (PRESENT(c)) THEN
730 ioff=icn
731 DO m=1,gsendn
732 mc=(m-1)*ilen
733 j=jend-gsendn+m
734 DO i=imin,imax
735 sizen=sizen+1
736 icn=ioff+1+(i-imin)+mc
737 sendn(icn)=c(i,j)
738 END DO
739 END DO
740 END IF
741 IF (PRESENT(d)) THEN
742 ioff=icn
743 DO m=1,gsendn
744 mc=(m-1)*ilen
745 j=jend-gsendn+m
746 DO i=imin,imax
747 sizen=sizen+1
748 icn=ioff+1+(i-imin)+mc
749 sendn(icn)=d(i,j)
750 END DO
751 END DO
752 END IF
753 END IF
754!
755!-----------------------------------------------------------------------
756! Send and receive Southern and Northern segments.
757!-----------------------------------------------------------------------
758!
759# if defined MPI
760 IF (sexchange) THEN
761 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
762 & ocn_comm_world, srequest, serror)
763 END IF
764 IF (nexchange) THEN
765 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
766 & ocn_comm_world, nrequest, nerror)
767 END IF
768 IF (sexchange) THEN
769 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
770 & ocn_comm_world, serror)
771 END IF
772 IF (nexchange) THEN
773 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
774 & ocn_comm_world, nerror)
775 END IF
776# endif
777!
778!-----------------------------------------------------------------------
779! Unpack Northern and Southern segments.
780!-----------------------------------------------------------------------
781!
782 IF (sexchange) THEN
783# ifdef MPI
784 CALL mpi_wait (srequest, status(1,2), serror)
785 IF (serror.ne.mpi_success) THEN
786 CALL mpi_error_string (serror, string, lstr, ierror)
787 lstr=len_trim(string)
788 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
789 & myrank, serror, string(1:lstr)
790 exit_flag=2
791 RETURN
792 END IF
793# endif
794 DO m=grecvs,1,-1
795 mc=(grecvs-m)*ilen
796 j=jstr-m
797 DO i=imin,imax
798 ics=1+(i-imin)+mc
799 a(i,j)=recvs(ics)
800 END DO
801 END DO
802 IF (PRESENT(b)) THEN
803 ioff=ics
804 DO m=grecvs,1,-1
805 mc=(grecvs-m)*ilen
806 j=jstr-m
807 DO i=imin,imax
808 ics=ioff+1+(i-imin)+mc
809 b(i,j)=recvs(ics)
810 END DO
811 END DO
812 END IF
813 IF (PRESENT(c)) THEN
814 ioff=ics
815 DO m=grecvs,1,-1
816 mc=(grecvs-m)*ilen
817 j=jstr-m
818 DO i=imin,imax
819 ics=ioff+1+(i-imin)+mc
820 c(i,j)=recvs(ics)
821 END DO
822 END DO
823 END IF
824 IF (PRESENT(d)) THEN
825 ioff=ics
826 DO m=grecvs,1,-1
827 mc=(grecvs-m)*ilen
828 j=jstr-m
829 DO i=imin,imax
830 ics=ioff+1+(i-imin)+mc
831 d(i,j)=recvs(ics)
832 END DO
833 END DO
834 END IF
835 END IF
836!
837 IF (nexchange) THEN
838# ifdef MPI
839 CALL mpi_wait (nrequest, status(1,4), nerror)
840 IF (nerror.ne.mpi_success) THEN
841 CALL mpi_error_string (nerror, string, lstr, ierror)
842 lstr=len_trim(string)
843 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
844 & myrank, nerror, string(1:lstr)
845 exit_flag=2
846 RETURN
847 END IF
848# endif
849 DO m=1,grecvn
850 mc=(m-1)*ilen
851 j=jend+m
852 DO i=imin,imax
853 icn=1+(i-imin)+mc
854 a(i,j)=recvn(icn)
855 END DO
856 END DO
857 IF (PRESENT(b)) THEN
858 ioff=icn
859 DO m=1,grecvn
860 mc=(m-1)*ilen
861 j=jend+m
862 DO i=imin,imax
863 icn=ioff+1+(i-imin)+mc
864 b(i,j)=recvn(icn)
865 END DO
866 END DO
867 END IF
868 IF (PRESENT(c)) THEN
869 ioff=icn
870 DO m=1,grecvn
871 mc=(m-1)*ilen
872 j=jend+m
873 DO i=imin,imax
874 icn=ioff+1+(i-imin)+mc
875 c(i,j)=recvn(icn)
876 END DO
877 END DO
878 END IF
879 IF (PRESENT(d)) THEN
880 ioff=icn
881 DO m=1,grecvn
882 mc=(m-1)*ilen
883 j=jend+m
884 DO i=imin,imax
885 icn=ioff+1+(i-imin)+mc
886 d(i,j)=recvn(icn)
887 END DO
888 END DO
889 END IF
890 END IF
891
892# ifdef PROFILE
893!
894!-----------------------------------------------------------------------
895! Turn off time clocks.
896!-----------------------------------------------------------------------
897!
898 CALL wclock_off (ng, model, 60, __line__, myfile)
899# endif
900!
901 RETURN
902 END SUBROUTINE mp_exchange2d
903
904# ifdef GRID_EXTRACT
905
906!
907!***********************************************************************
908 SUBROUTINE mp_exchange2d_xtr (ng, tile, model, Nvar, &
909 & LBi, UBi, LBj, UBj, &
910 & Nghost, EW_periodic, NS_periodic, &
911 & A, B, C, D)
912!***********************************************************************
913!
914 USE mod_param
915 USE mod_parallel
916 USE mod_iounits
917 USE mod_scalars
918!
919 implicit none
920!
921! Imported variable declarations.
922!
923 logical, intent(in) :: EW_periodic, NS_periodic
924!
925 integer, intent(in) :: ng, tile, model, Nvar
926 integer, intent(in) :: LBi, UBi, LBj, UBj
927 integer, intent(in) :: Nghost
928!
929# ifdef ASSUMED_SHAPE
930 real(r8), intent(inout) :: A(LBi:,LBj:)
931
932 real(r8), intent(inout), optional :: B(LBi:,LBj:)
933 real(r8), intent(inout), optional :: C(LBi:,LBj:)
934 real(r8), intent(inout), optional :: D(LBi:,LBj:)
935# else
936 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj)
937
938 real(r8), intent(inout), optional :: B(LBi:UBi,LBj:UBj)
939 real(r8), intent(inout), optional :: C(LBi:UBi,LBj:UBj)
940 real(r8), intent(inout), optional :: D(LBi:UBi,LBj:UBj)
941# endif
942!
943! Local variable declarations.
944!
945 logical :: Wexchange, Sexchange, Eexchange, Nexchange
946!
947 integer :: i, icS, icN, ioff, Imin, Imax, Ilen
948 integer :: j, jcW, jcE, joff, Jmin, Jmax, Jlen
949 integer :: m, mc, Ierror, Lstr, pp
950 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
951 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
952 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
953 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
954 integer :: EWsize, sizeW, sizeE
955 integer :: NSsize, sizeS, sizeN
956
957# ifdef MPI
958 integer, dimension(MPI_STATUS_SIZE,4) :: status
959# endif
960!
961 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: sendW, sendE
962 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: recvW, recvE
963
964 real(r8), dimension(Nvar*HaloSizeI(ng)) :: sendS, sendN
965 real(r8), dimension(Nvar*HaloSizeI(ng)) :: recvS, recvN
966!
967 character (len=MPI_MAX_ERROR_STRING) :: string
968
969 character (len=*), parameter :: MyFile = &
970 & __FILE__//", mp_exchange2d"
971
972# include "set_bounds_xtr.h"
973
974# ifdef PROFILE
975!
976!-----------------------------------------------------------------------
977! Turn on time clocks.
978!-----------------------------------------------------------------------
979!
980 CALL wclock_on (ng, model, 60, __line__, myfile)
981# endif
982!
983!-----------------------------------------------------------------------
984! Determine rank of tile neighbors and number of ghost-points to
985! exchange.
986!-----------------------------------------------------------------------
987!
988! Maximum automatic buffer memory size in bytes.
989!
990 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
991 & 4*SIZE(sends))*kind(a),r8))
992!
993 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
994 & grecvw, gsendw, wtile, wexchange, &
995 & grecve, gsende, etile, eexchange, &
996 & grecvs, gsends, stile, sexchange, &
997 & grecvn, gsendn, ntile, nexchange)
998!
999! Set communication tags.
1000!
1001 wtag=1
1002 stag=2
1003 etag=3
1004 ntag=4
1005!
1006! Determine range and length of the distributed tile boundary segments.
1007!
1008 imin=lbi
1009 imax=ubi
1010 jmin=lbj
1011 jmax=ubj
1012 ilen=imax-imin+1
1013 jlen=jmax-jmin+1
1014 IF (ew_periodic.or.ns_periodic) THEN
1015 pp=1
1016 ELSE
1017 pp=0
1018 END IF
1019 ewsize=nvar*(nghost+pp)*jlen
1020 nssize=nvar*(nghost+pp)*ilen
1021 IF (SIZE(sende).lt.ewsize) THEN
1022 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
1023 10 FORMAT (/,' MP_EXCHANGE2D - communication buffer too small, ', &
1024 & a, 2i8)
1025 END IF
1026 IF (SIZE(sendn).lt.nssize) THEN
1027 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
1028 END IF
1029!
1030!-----------------------------------------------------------------------
1031! Pack Western and Eastern tile boundary data including ghost-points.
1032!-----------------------------------------------------------------------
1033!
1034 IF (wexchange) THEN
1035 sizew=0
1036 DO m=1,gsendw
1037 mc=(m-1)*jlen
1038 i=istr+m-1
1039 DO j=jmin,jmax
1040 sizew=sizew+1
1041 jcw=1+(j-jmin)+mc
1042 sendw(jcw)=a(i,j)
1043 END DO
1044 END DO
1045 IF (PRESENT(b)) THEN
1046 joff=jcw
1047 DO m=1,gsendw
1048 mc=(m-1)*jlen
1049 i=istr+m-1
1050 DO j=jmin,jmax
1051 sizew=sizew+1
1052 jcw=joff+1+(j-jmin)+mc
1053 sendw(jcw)=b(i,j)
1054 END DO
1055 END DO
1056 END IF
1057 IF (PRESENT(c)) THEN
1058 joff=jcw
1059 DO m=1,gsendw
1060 mc=(m-1)*jlen
1061 i=istr+m-1
1062 DO j=jmin,jmax
1063 sizew=sizew+1
1064 jcw=joff+1+(j-jmin)+mc
1065 sendw(jcw)=c(i,j)
1066 END DO
1067 END DO
1068 END IF
1069 IF (PRESENT(d)) THEN
1070 joff=jcw
1071 DO m=1,gsendw
1072 mc=(m-1)*jlen
1073 i=istr+m-1
1074 DO j=jmin,jmax
1075 sizew=sizew+1
1076 jcw=joff+1+(j-jmin)+mc
1077 sendw(jcw)=d(i,j)
1078 END DO
1079 END DO
1080 END IF
1081 END IF
1082!
1083 IF (eexchange) THEN
1084 sizee=0
1085 DO m=1,gsende
1086 mc=(m-1)*jlen
1087 i=iend-gsende+m
1088 DO j=jmin,jmax
1089 sizee=sizee+1
1090 jce=1+(j-jmin)+mc
1091 sende(jce)=a(i,j)
1092 END DO
1093 END DO
1094 IF (PRESENT(b)) THEN
1095 joff=jce
1096 DO m=1,gsende
1097 mc=(m-1)*jlen
1098 i=iend-gsende+m
1099 DO j=jmin,jmax
1100 sizee=sizee+1
1101 jce=joff+1+(j-jmin)+mc
1102 sende(jce)=b(i,j)
1103 END DO
1104 END DO
1105 END IF
1106 IF (PRESENT(c)) THEN
1107 joff=jce
1108 DO m=1,gsende
1109 mc=(m-1)*jlen
1110 i=iend-gsende+m
1111 DO j=jmin,jmax
1112 sizee=sizee+1
1113 jce=joff+1+(j-jmin)+mc
1114 sende(jce)=c(i,j)
1115 END DO
1116 END DO
1117 END IF
1118 IF (PRESENT(d)) THEN
1119 joff=jce
1120 DO m=1,gsende
1121 mc=(m-1)*jlen
1122 i=iend-gsende+m
1123 DO j=jmin,jmax
1124 sizee=sizee+1
1125 jce=joff+1+(j-jmin)+mc
1126 sende(jce)=d(i,j)
1127 END DO
1128 END DO
1129 END IF
1130 END IF
1131!
1132!-----------------------------------------------------------------------
1133! Send and receive Western and Eastern segments.
1134!-----------------------------------------------------------------------
1135!
1136# if defined MPI
1137 IF (wexchange) THEN
1138 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
1139 & ocn_comm_world, wrequest, werror)
1140 END IF
1141 IF (eexchange) THEN
1142 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
1143 & ocn_comm_world, erequest, eerror)
1144 END IF
1145 IF (wexchange) THEN
1146 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
1147 & ocn_comm_world, werror)
1148 END IF
1149 IF (eexchange) THEN
1150 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
1151 & ocn_comm_world, eerror)
1152 END IF
1153# endif
1154!
1155!-----------------------------------------------------------------------
1156! Unpack Western and Eastern segments.
1157!-----------------------------------------------------------------------
1158!
1159 IF (wexchange) THEN
1160# ifdef MPI
1161 CALL mpi_wait (wrequest, status(1,1), werror)
1162 IF (werror.ne.mpi_success) THEN
1163 CALL mpi_error_string (werror, string, lstr, ierror)
1164 lstr=len_trim(string)
1165 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
1166 & myrank, werror, string(1:lstr)
1167 20 FORMAT (/,' MP_EXCHANGE2D - error during ',a, &
1168 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
1169 exit_flag=2
1170 RETURN
1171 END IF
1172# endif
1173 DO m=grecvw,1,-1
1174 mc=(grecvw-m)*jlen
1175 i=istr-m
1176 DO j=jmin,jmax
1177 jcw=1+(j-jmin)+mc
1178 a(i,j)=recvw(jcw)
1179 END DO
1180 END DO
1181 IF (PRESENT(b)) THEN
1182 joff=jcw
1183 DO m=grecvw,1,-1
1184 mc=(grecvw-m)*jlen
1185 i=istr-m
1186 DO j=jmin,jmax
1187 jcw=joff+1+(j-jmin)+mc
1188 b(i,j)=recvw(jcw)
1189 END DO
1190 END DO
1191 END IF
1192 IF (PRESENT(c)) THEN
1193 joff=jcw
1194 DO m=grecvw,1,-1
1195 mc=(grecvw-m)*jlen
1196 i=istr-m
1197 DO j=jmin,jmax
1198 jcw=joff+1+(j-jmin)+mc
1199 c(i,j)=recvw(jcw)
1200 END DO
1201 END DO
1202 END IF
1203 IF (PRESENT(d)) THEN
1204 joff=jcw
1205 DO m=grecvw,1,-1
1206 mc=(grecvw-m)*jlen
1207 i=istr-m
1208 DO j=jmin,jmax
1209 jcw=joff+1+(j-jmin)+mc
1210 d(i,j)=recvw(jcw)
1211 END DO
1212 END DO
1213 END IF
1214 END IF
1215!
1216 IF (eexchange) THEN
1217# ifdef MPI
1218 CALL mpi_wait (erequest, status(1,3), eerror)
1219 IF (eerror.ne.mpi_success) THEN
1220 CALL mpi_error_string (eerror, string, lstr, ierror)
1221 lstr=len_trim(string)
1222 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
1223 & myrank, eerror, string(1:lstr)
1224 exit_flag=2
1225 RETURN
1226 END IF
1227# endif
1228 DO m=1,grecve
1229 mc=(m-1)*jlen
1230 i=iend+m
1231 DO j=jmin,jmax
1232 jce=1+(j-jmin)+mc
1233 a(i,j)=recve(jce)
1234 ENDDO
1235 END DO
1236 IF (PRESENT(b)) THEN
1237 joff=jce
1238 DO m=1,grecve
1239 mc=(m-1)*jlen
1240 i=iend+m
1241 DO j=jmin,jmax
1242 jce=joff+1+(j-jmin)+mc
1243 b(i,j)=recve(jce)
1244 ENDDO
1245 END DO
1246 END IF
1247 IF (PRESENT(c)) THEN
1248 joff=jce
1249 DO m=1,grecve
1250 mc=(m-1)*jlen
1251 i=iend+m
1252 DO j=jmin,jmax
1253 jce=joff+1+(j-jmin)+mc
1254 c(i,j)=recve(jce)
1255 ENDDO
1256 END DO
1257 END IF
1258 IF (PRESENT(d)) THEN
1259 joff=jce
1260 DO m=1,grecve
1261 mc=(m-1)*jlen
1262 i=iend+m
1263 DO j=jmin,jmax
1264 jce=joff+1+(j-jmin)+mc
1265 d(i,j)=recve(jce)
1266 ENDDO
1267 END DO
1268 END IF
1269 END IF
1270!
1271!-----------------------------------------------------------------------
1272! Pack Southern and Northern tile boundary data including ghost-points.
1273!-----------------------------------------------------------------------
1274!
1275 IF (sexchange) THEN
1276 sizes=0
1277 DO m=1,gsends
1278 mc=(m-1)*ilen
1279 j=jstr+m-1
1280 DO i=imin,imax
1281 sizes=sizes+1
1282 ics=1+(i-imin)+mc
1283 sends(ics)=a(i,j)
1284 END DO
1285 END DO
1286 IF (PRESENT(b)) THEN
1287 ioff=ics
1288 DO m=1,gsends
1289 mc=(m-1)*ilen
1290 j=jstr+m-1
1291 DO i=imin,imax
1292 sizes=sizes+1
1293 ics=ioff+1+(i-imin)+mc
1294 sends(ics)=b(i,j)
1295 END DO
1296 END DO
1297 END IF
1298 IF (PRESENT(c)) THEN
1299 ioff=ics
1300 DO m=1,gsends
1301 mc=(m-1)*ilen
1302 j=jstr+m-1
1303 DO i=imin,imax
1304 sizes=sizes+1
1305 ics=ioff+1+(i-imin)+mc
1306 sends(ics)=c(i,j)
1307 END DO
1308 END DO
1309 END IF
1310 IF (PRESENT(d)) THEN
1311 ioff=ics
1312 DO m=1,gsends
1313 mc=(m-1)*ilen
1314 j=jstr+m-1
1315 DO i=imin,imax
1316 sizes=sizes+1
1317 ics=ioff+1+(i-imin)+mc
1318 sends(ics)=d(i,j)
1319 END DO
1320 END DO
1321 END IF
1322 END IF
1323!
1324 IF (nexchange) THEN
1325 sizen=0
1326 DO m=1,gsendn
1327 mc=(m-1)*ilen
1328 j=jend-gsendn+m
1329 DO i=imin,imax
1330 sizen=sizen+1
1331 icn=1+(i-imin)+mc
1332 sendn(icn)=a(i,j)
1333 END DO
1334 END DO
1335 IF (PRESENT(b)) THEN
1336 ioff=icn
1337 DO m=1,gsendn
1338 mc=(m-1)*ilen
1339 j=jend-gsendn+m
1340 DO i=imin,imax
1341 sizen=sizen+1
1342 icn=ioff+1+(i-imin)+mc
1343 sendn(icn)=b(i,j)
1344 END DO
1345 END DO
1346 END IF
1347 IF (PRESENT(c)) THEN
1348 ioff=icn
1349 DO m=1,gsendn
1350 mc=(m-1)*ilen
1351 j=jend-gsendn+m
1352 DO i=imin,imax
1353 sizen=sizen+1
1354 icn=ioff+1+(i-imin)+mc
1355 sendn(icn)=c(i,j)
1356 END DO
1357 END DO
1358 END IF
1359 IF (PRESENT(d)) THEN
1360 ioff=icn
1361 DO m=1,gsendn
1362 mc=(m-1)*ilen
1363 j=jend-gsendn+m
1364 DO i=imin,imax
1365 sizen=sizen+1
1366 icn=ioff+1+(i-imin)+mc
1367 sendn(icn)=d(i,j)
1368 END DO
1369 END DO
1370 END IF
1371 END IF
1372!
1373!-----------------------------------------------------------------------
1374! Send and receive Southern and Northern segments.
1375!-----------------------------------------------------------------------
1376!
1377# if defined MPI
1378 IF (sexchange) THEN
1379 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
1380 & ocn_comm_world, srequest, serror)
1381 END IF
1382 IF (nexchange) THEN
1383 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
1384 & ocn_comm_world, nrequest, nerror)
1385 END IF
1386 IF (sexchange) THEN
1387 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
1388 & ocn_comm_world, serror)
1389 END IF
1390 IF (nexchange) THEN
1391 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
1392 & ocn_comm_world, nerror)
1393 END IF
1394# endif
1395!
1396!-----------------------------------------------------------------------
1397! Unpack Northern and Southern segments.
1398!-----------------------------------------------------------------------
1399!
1400 IF (sexchange) THEN
1401# ifdef MPI
1402 CALL mpi_wait (srequest, status(1,2), serror)
1403 IF (serror.ne.mpi_success) THEN
1404 CALL mpi_error_string (serror, string, lstr, ierror)
1405 lstr=len_trim(string)
1406 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
1407 & myrank, serror, string(1:lstr)
1408 exit_flag=2
1409 RETURN
1410 END IF
1411# endif
1412 DO m=grecvs,1,-1
1413 mc=(grecvs-m)*ilen
1414 j=jstr-m
1415 DO i=imin,imax
1416 ics=1+(i-imin)+mc
1417 a(i,j)=recvs(ics)
1418 END DO
1419 END DO
1420 IF (PRESENT(b)) THEN
1421 ioff=ics
1422 DO m=grecvs,1,-1
1423 mc=(grecvs-m)*ilen
1424 j=jstr-m
1425 DO i=imin,imax
1426 ics=ioff+1+(i-imin)+mc
1427 b(i,j)=recvs(ics)
1428 END DO
1429 END DO
1430 END IF
1431 IF (PRESENT(c)) THEN
1432 ioff=ics
1433 DO m=grecvs,1,-1
1434 mc=(grecvs-m)*ilen
1435 j=jstr-m
1436 DO i=imin,imax
1437 ics=ioff+1+(i-imin)+mc
1438 c(i,j)=recvs(ics)
1439 END DO
1440 END DO
1441 END IF
1442 IF (PRESENT(d)) THEN
1443 ioff=ics
1444 DO m=grecvs,1,-1
1445 mc=(grecvs-m)*ilen
1446 j=jstr-m
1447 DO i=imin,imax
1448 ics=ioff+1+(i-imin)+mc
1449 d(i,j)=recvs(ics)
1450 END DO
1451 END DO
1452 END IF
1453 END IF
1454!
1455 IF (nexchange) THEN
1456# ifdef MPI
1457 CALL mpi_wait (nrequest, status(1,4), nerror)
1458 IF (nerror.ne.mpi_success) THEN
1459 CALL mpi_error_string (nerror, string, lstr, ierror)
1460 lstr=len_trim(string)
1461 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
1462 & myrank, nerror, string(1:lstr)
1463 exit_flag=2
1464 RETURN
1465 END IF
1466# endif
1467 DO m=1,grecvn
1468 mc=(m-1)*ilen
1469 j=jend+m
1470 DO i=imin,imax
1471 icn=1+(i-imin)+mc
1472 a(i,j)=recvn(icn)
1473 END DO
1474 END DO
1475 IF (PRESENT(b)) THEN
1476 ioff=icn
1477 DO m=1,grecvn
1478 mc=(m-1)*ilen
1479 j=jend+m
1480 DO i=imin,imax
1481 icn=ioff+1+(i-imin)+mc
1482 b(i,j)=recvn(icn)
1483 END DO
1484 END DO
1485 END IF
1486 IF (PRESENT(c)) THEN
1487 ioff=icn
1488 DO m=1,grecvn
1489 mc=(m-1)*ilen
1490 j=jend+m
1491 DO i=imin,imax
1492 icn=ioff+1+(i-imin)+mc
1493 c(i,j)=recvn(icn)
1494 END DO
1495 END DO
1496 END IF
1497 IF (PRESENT(d)) THEN
1498 ioff=icn
1499 DO m=1,grecvn
1500 mc=(m-1)*ilen
1501 j=jend+m
1502 DO i=imin,imax
1503 icn=ioff+1+(i-imin)+mc
1504 d(i,j)=recvn(icn)
1505 END DO
1506 END DO
1507 END IF
1508 END IF
1509
1510# ifdef PROFILE
1511!
1512!-----------------------------------------------------------------------
1513! Turn off time clocks.
1514!-----------------------------------------------------------------------
1515!
1516 CALL wclock_off (ng, model, 60, __line__, myfile)
1517# endif
1518!
1519 RETURN
1520 END SUBROUTINE mp_exchange2d_xtr
1521# endif
1522
1523!
1524!***********************************************************************
1525 SUBROUTINE mp_exchange2d_bry (ng, tile, model, Nvar, boundary, &
1526 & LBij, UBij, &
1527 & Nghost, EW_periodic, NS_periodic, &
1528 & A, B, C, D)
1529!***********************************************************************
1530!
1531 USE mod_param
1532 USE mod_parallel
1533 USE mod_iounits
1534 USE mod_scalars
1535!
1536 implicit none
1537!
1538! Imported variable declarations.
1539!
1540 logical, intent(in) :: EW_periodic, NS_periodic
1541!
1542 integer, intent(in) :: ng, tile, model, Nvar, boundary
1543 integer, intent(in) :: LBij, UBij
1544 integer, intent(in) :: Nghost
1545!
1546# ifdef ASSUMED_SHAPE
1547 real(r8), intent(inout) :: A(LBij:)
1548
1549 real(r8), intent(inout), optional :: B(LBij:)
1550 real(r8), intent(inout), optional :: C(LBij:)
1551 real(r8), intent(inout), optional :: D(LBij:)
1552# else
1553 real(r8), intent(inout) :: A(LBij:UBij)
1554
1555 real(r8), intent(inout), optional :: B(LBij:UBij)
1556 real(r8), intent(inout), optional :: C(LBij:UBij)
1557 real(r8), intent(inout), optional :: D(LBij:UBij)
1558# endif
1559!
1560! Local variable declarations.
1561!
1562 logical :: Wexchange, Sexchange, Eexchange, Nexchange
1563!
1564 integer :: i, icS, icN
1565 integer :: j, jcW, jcE
1566 integer :: m, Ierror, Lstr, pp
1567 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
1568 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
1569 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
1570 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
1571 integer :: EWsize, sizeW, sizeE
1572 integer :: NSsize, sizeS, sizeN
1573
1574# ifdef MPI
1575 integer, dimension(MPI_STATUS_SIZE,4) :: status
1576# endif
1577!
1578 real(r8), dimension(Nvar*HaloBry(ng)) :: sendW, sendE
1579 real(r8), dimension(Nvar*HaloBry(ng)) :: recvW, recvE
1580
1581 real(r8), dimension(Nvar*HaloBry(ng)) :: sendS, sendN
1582 real(r8), dimension(Nvar*HaloBry(ng)) :: recvS, recvN
1583!
1584 character (len=MPI_MAX_ERROR_STRING) :: string
1585
1586 character (len=*), parameter :: MyFile = &
1587 & __FILE__//", mp_exchange2d_bry"
1588
1589# include "set_bounds.h"
1590
1591# ifdef PROFILE
1592!
1593!-----------------------------------------------------------------------
1594! Turn on time clocks.
1595!-----------------------------------------------------------------------
1596!
1597 CALL wclock_on (ng, model, 63, __line__, myfile)
1598# endif
1599!
1600!-----------------------------------------------------------------------
1601! Determine rank of tile neighbors and number of ghost-points to
1602! exchange.
1603!-----------------------------------------------------------------------
1604!
1605! Maximum automatic buffer memory size in bytes.
1606!
1607 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
1608 & 4*SIZE(sends))*kind(a),r8))
1609!
1610 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
1611 & grecvw, gsendw, wtile, wexchange, &
1612 & grecve, gsende, etile, eexchange, &
1613 & grecvs, gsends, stile, sexchange, &
1614 & grecvn, gsendn, ntile, nexchange)
1615!
1616! Adjust exchange swiches according to boundary edge to process.
1617!
1618 wexchange=wexchange.and.((boundary.eq.isouth).or. &
1619 & (boundary.eq.inorth))
1620 eexchange=eexchange.and.((boundary.eq.isouth).or. &
1621 & (boundary.eq.inorth))
1622 sexchange=sexchange.and.((boundary.eq.iwest).or. &
1623 & (boundary.eq.ieast))
1624 nexchange=nexchange.and.((boundary.eq.iwest).or. &
1625 & (boundary.eq.ieast))
1626!
1627! Set communication tags.
1628!
1629 wtag=1
1630 stag=2
1631 etag=3
1632 ntag=4
1633!
1634! Determine range and length of the distributed tile boundary segments.
1635!
1636 IF (ew_periodic.or.ns_periodic) THEN
1637 pp=1
1638 ELSE
1639 pp=0
1640 END IF
1641 ewsize=nvar*(nghost+pp)
1642 nssize=nvar*(nghost+pp)
1643 IF (SIZE(sende).lt.ewsize) THEN
1644 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
1645 10 FORMAT (/,' MP_EXCHANGE2D_BRY - communication buffer too ', &
1646 & 'small, ',a, 2i8)
1647 END IF
1648 IF (SIZE(sendn).lt.nssize) THEN
1649 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
1650 END IF
1651!
1652!-----------------------------------------------------------------------
1653! Pack Western and Eastern tile boundary data including ghost-points.
1654!-----------------------------------------------------------------------
1655!
1656 IF (wexchange) THEN
1657 jcw=0
1658 sizew=0
1659 DO m=1,gsendw
1660 i=istr+m-1
1661 sizew=sizew+1
1662 jcw=jcw+1
1663 sendw(jcw)=a(i)
1664 END DO
1665 IF (PRESENT(b)) THEN
1666 DO m=1,gsendw
1667 i=istr+m-1
1668 sizew=sizew+1
1669 jcw=jcw+1
1670 sendw(jcw)=b(i)
1671 END DO
1672 END IF
1673 IF (PRESENT(c)) THEN
1674 DO m=1,gsendw
1675 i=istr+m-1
1676 sizew=sizew+1
1677 jcw=jcw+1
1678 sendw(jcw)=c(i)
1679 END DO
1680 END IF
1681 IF (PRESENT(d)) THEN
1682 DO m=1,gsendw
1683 i=istr+m-1
1684 sizew=sizew+1
1685 jcw=jcw+1
1686 sendw(jcw)=d(i)
1687 END DO
1688 END IF
1689 END IF
1690!
1691 IF (eexchange) THEN
1692 jce=0
1693 sizee=0
1694 DO m=1,gsende
1695 i=iend-gsende+m
1696 sizee=sizee+1
1697 jce=jce+1
1698 sende(jce)=a(i)
1699 END DO
1700 IF (PRESENT(b)) THEN
1701 DO m=1,gsende
1702 i=iend-gsende+m
1703 sizee=sizee+1
1704 jce=jce+1
1705 sende(jce)=b(i)
1706 END DO
1707 END IF
1708 IF (PRESENT(c)) THEN
1709 DO m=1,gsende
1710 i=iend-gsende+m
1711 sizee=sizee+1
1712 jce=jce+1
1713 sende(jce)=c(i)
1714 END DO
1715 END IF
1716 IF (PRESENT(d)) THEN
1717 DO m=1,gsende
1718 i=iend-gsende+m
1719 sizee=sizee+1
1720 jce=jce+1
1721 sende(jce)=d(i)
1722 END DO
1723 END IF
1724 END IF
1725!
1726!-----------------------------------------------------------------------
1727! Send and receive Western and Eastern segments.
1728!-----------------------------------------------------------------------
1729!
1730# if defined MPI
1731 IF (wexchange) THEN
1732 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
1733 & ocn_comm_world, wrequest, werror)
1734 END IF
1735 IF (eexchange) THEN
1736 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
1737 & ocn_comm_world, erequest, eerror)
1738 END IF
1739 IF (wexchange) THEN
1740 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
1741 & ocn_comm_world, werror)
1742 END IF
1743 IF (eexchange) THEN
1744 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
1745 & ocn_comm_world, eerror)
1746 END IF
1747# endif
1748!
1749!-----------------------------------------------------------------------
1750! Unpack Western and Eastern segments.
1751!-----------------------------------------------------------------------
1752!
1753 IF (wexchange) THEN
1754# ifdef MPI
1755 CALL mpi_wait (wrequest, status(1,1), werror)
1756 IF (werror.ne.mpi_success) THEN
1757 CALL mpi_error_string (werror, string, lstr, ierror)
1758 lstr=len_trim(string)
1759 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
1760 & myrank, werror, string(1:lstr)
1761 20 FORMAT (/,' MP_EXCHANGE2D_BRY - error during ',a, &
1762 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
1763 exit_flag=2
1764 RETURN
1765 END IF
1766# endif
1767 jcw=0
1768 DO m=grecvw,1,-1
1769 i=istr-m
1770 jcw=jcw+1
1771 a(i)=recvw(jcw)
1772 END DO
1773 IF (PRESENT(b)) THEN
1774 DO m=grecvw,1,-1
1775 i=istr-m
1776 jcw=jcw+1
1777 b(i)=recvw(jcw)
1778 END DO
1779 END IF
1780 IF (PRESENT(c)) THEN
1781 DO m=grecvw,1,-1
1782 i=istr-m
1783 jcw=jcw+1
1784 c(i)=recvw(jcw)
1785 END DO
1786 END IF
1787 IF (PRESENT(d)) THEN
1788 DO m=grecvw,1,-1
1789 i=istr-m
1790 jcw=jcw+1
1791 d(i)=recvw(jcw)
1792 END DO
1793 END IF
1794 END IF
1795!
1796 IF (eexchange) THEN
1797# ifdef MPI
1798 CALL mpi_wait (erequest, status(1,3), eerror)
1799 IF (eerror.ne.mpi_success) THEN
1800 CALL mpi_error_string (eerror, string, lstr, ierror)
1801 lstr=len_trim(string)
1802 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
1803 & myrank, eerror, string(1:lstr)
1804 exit_flag=2
1805 RETURN
1806 END IF
1807# endif
1808 jce=0
1809 DO m=1,grecve
1810 i=iend+m
1811 jce=jce+1
1812 a(i)=recve(jce)
1813 END DO
1814 IF (PRESENT(b)) THEN
1815 DO m=1,grecve
1816 i=iend+m
1817 jce=jce+1
1818 b(i)=recve(jce)
1819 END DO
1820 END IF
1821 IF (PRESENT(c)) THEN
1822 DO m=1,grecve
1823 i=iend+m
1824 jce=jce+1
1825 c(i)=recve(jce)
1826 END DO
1827 END IF
1828 IF (PRESENT(d)) THEN
1829 DO m=1,grecve
1830 i=iend+m
1831 jce=jce+1
1832 d(i)=recve(jce)
1833 END DO
1834 END IF
1835 END IF
1836!
1837!-----------------------------------------------------------------------
1838! Pack Southern and Northern tile boundary data including ghost-points.
1839!-----------------------------------------------------------------------
1840!
1841 IF (sexchange) THEN
1842 ics=0
1843 sizes=0
1844 DO m=1,gsends
1845 j=jstr+m-1
1846 sizes=sizes+1
1847 ics=ics+1
1848 sends(ics)=a(j)
1849 END DO
1850 IF (PRESENT(b)) THEN
1851 DO m=1,gsends
1852 j=jstr+m-1
1853 sizes=sizes+1
1854 ics=ics+1
1855 sends(ics)=b(j)
1856 END DO
1857 END IF
1858 IF (PRESENT(c)) THEN
1859 DO m=1,gsends
1860 j=jstr+m-1
1861 sizes=sizes+1
1862 ics=ics+1
1863 sends(ics)=c(j)
1864 END DO
1865 END IF
1866 IF (PRESENT(d)) THEN
1867 DO m=1,gsends
1868 j=jstr+m-1
1869 sizes=sizes+1
1870 ics=ics+1
1871 sends(ics)=d(j)
1872 END DO
1873 END IF
1874 END IF
1875!
1876 IF (nexchange) THEN
1877 icn=0
1878 sizen=0
1879 DO m=1,gsendn
1880 j=jend-gsendn+m
1881 sizen=sizen+1
1882 icn=icn+1
1883 sendn(icn)=a(j)
1884 END DO
1885 IF (PRESENT(b)) THEN
1886 DO m=1,gsendn
1887 j=jend-gsendn+m
1888 sizen=sizen+1
1889 icn=icn+1
1890 sendn(icn)=b(j)
1891 END DO
1892 END IF
1893 IF (PRESENT(c)) THEN
1894 DO m=1,gsendn
1895 j=jend-gsendn+m
1896 sizen=sizen+1
1897 icn=icn+1
1898 sendn(icn)=c(j)
1899 END DO
1900 END IF
1901 IF (PRESENT(d)) THEN
1902 DO m=1,gsendn
1903 j=jend-gsendn+m
1904 sizen=sizen+1
1905 icn=icn+1
1906 sendn(icn)=d(j)
1907 END DO
1908 END IF
1909 END IF
1910!
1911!-----------------------------------------------------------------------
1912! Send and receive Southern and Northern segments.
1913!-----------------------------------------------------------------------
1914!
1915# if defined MPI
1916 IF (sexchange) THEN
1917 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
1918 & ocn_comm_world, srequest, serror)
1919 END IF
1920 IF (nexchange) THEN
1921 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
1922 & ocn_comm_world, nrequest, nerror)
1923 END IF
1924 IF (sexchange) THEN
1925 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
1926 & ocn_comm_world, serror)
1927 END IF
1928 IF (nexchange) THEN
1929 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
1930 & ocn_comm_world, nerror)
1931 END IF
1932# endif
1933!
1934!-----------------------------------------------------------------------
1935! Unpack Northern and Southern segments.
1936!-----------------------------------------------------------------------
1937!
1938 IF (sexchange) THEN
1939# ifdef MPI
1940 CALL mpi_wait (srequest, status(1,2), serror)
1941 IF (serror.ne.mpi_success) THEN
1942 CALL mpi_error_string (serror, string, lstr, ierror)
1943 lstr=len_trim(string)
1944 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
1945 & myrank, serror, string(1:lstr)
1946 exit_flag=2
1947 RETURN
1948 END IF
1949# endif
1950 ics=0
1951 DO m=grecvs,1,-1
1952 j=jstr-m
1953 ics=ics+1
1954 a(j)=recvs(ics)
1955 END DO
1956 IF (PRESENT(b)) THEN
1957 DO m=grecvs,1,-1
1958 j=jstr-m
1959 ics=ics+1
1960 b(j)=recvs(ics)
1961 END DO
1962 END IF
1963 IF (PRESENT(c)) THEN
1964 DO m=grecvs,1,-1
1965 j=jstr-m
1966 ics=ics+1
1967 c(j)=recvs(ics)
1968 END DO
1969 END IF
1970 IF (PRESENT(d)) THEN
1971 DO m=grecvs,1,-1
1972 j=jstr-m
1973 ics=ics+1
1974 d(j)=recvs(ics)
1975 END DO
1976 END IF
1977 END IF
1978!
1979 IF (nexchange) THEN
1980# ifdef MPI
1981 CALL mpi_wait (nrequest, status(1,4), nerror)
1982 IF (nerror.ne.mpi_success) THEN
1983 CALL mpi_error_string (nerror, string, lstr, ierror)
1984 lstr=len_trim(string)
1985 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
1986 & myrank, nerror, string(1:lstr)
1987 exit_flag=2
1988 RETURN
1989 END IF
1990# endif
1991 icn=0
1992 DO m=1,grecvn
1993 j=jend+m
1994 icn=icn+1
1995 a(j)=recvn(icn)
1996 END DO
1997 IF (PRESENT(b)) THEN
1998 DO m=1,grecvn
1999 j=jend+m
2000 icn=icn+1
2001 b(j)=recvn(icn)
2002 END DO
2003 END IF
2004 IF (PRESENT(c)) THEN
2005 DO m=1,grecvn
2006 j=jend+m
2007 icn=icn+1
2008 c(j)=recvn(icn)
2009 END DO
2010 END IF
2011 IF (PRESENT(d)) THEN
2012 DO m=1,grecvn
2013 j=jend+m
2014 icn=icn+1
2015 d(j)=recvn(icn)
2016 END DO
2017 END IF
2018 END IF
2019
2020# ifdef PROFILE
2021!
2022!-----------------------------------------------------------------------
2023! Turn off time clocks.
2024!-----------------------------------------------------------------------
2025!
2026 CALL wclock_off (ng, model, 63, __line__, myfile)
2027# endif
2028!
2029 RETURN
2030 END SUBROUTINE mp_exchange2d_bry
2031!
2032!***********************************************************************
2033 SUBROUTINE mp_exchange3d (ng, tile, model, Nvar, &
2034 & LBi, UBi, LBj, UBj, LBk, UBk, &
2035 & Nghost, EW_periodic, NS_periodic, &
2036 & A, B, C, D)
2037!***********************************************************************
2038!
2039 USE mod_param
2040 USE mod_parallel
2041 USE mod_iounits
2042 USE mod_scalars
2043!
2044 implicit none
2045!
2046! Imported variable declarations.
2047!
2048 logical, intent(in) :: EW_periodic, NS_periodic
2049!
2050 integer, intent(in) :: ng, tile, model, Nvar
2051 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
2052 integer, intent(in) :: Nghost
2053
2054# ifdef ASSUMED_SHAPE
2055 real(r8), intent(inout) :: A(LBi:,LBj:,LBk:)
2056
2057 real(r8), intent(inout), optional :: B(LBi:,LBj:,LBk:)
2058 real(r8), intent(inout), optional :: C(LBi:,LBj:,LBk:)
2059 real(r8), intent(inout), optional :: D(LBi:,LBj:,LBk:)
2060# else
2061 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj,LBk:UBk)
2062
2063 real(r8), intent(inout), optional :: B(LBi:UBi,LBj:UBj,LBk:UBk)
2064 real(r8), intent(inout), optional :: C(LBi:UBi,LBj:UBj,LBk:UBk)
2065 real(r8), intent(inout), optional :: D(LBi:UBi,LBj:UBj,LBk:UBk)
2066# endif
2067!
2068! Local variable declarations.
2069!
2070 logical :: Wexchange, Sexchange, Eexchange, Nexchange
2071!
2072 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen
2073 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen
2074 integer :: k, kc, m, mc, Ierror, Klen, Lstr, pp
2075 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
2076 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
2077 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
2078 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
2079 integer :: EWsize, sizeW, sizeE
2080 integer :: NSsize, sizeS, sizeN
2081
2082# ifdef MPI
2083 integer, dimension(MPI_STATUS_SIZE,4) :: status
2084# endif
2085!
2086 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: sendW, sendE
2087 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: recvW, recvE
2088
2089 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: sendS, sendN
2090 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: recvS, recvN
2091!
2092 character (len=MPI_MAX_ERROR_STRING) :: string
2093
2094 character (len=*), parameter :: MyFile = &
2095 & __FILE__//", mp_exchange3d"
2096
2097# include "set_bounds.h"
2098
2099# ifdef PROFILE
2100!
2101!-----------------------------------------------------------------------
2102! Turn on time clocks.
2103!-----------------------------------------------------------------------
2104!
2105 CALL wclock_on (ng, model, 61, __line__, myfile)
2106# endif
2107!
2108!-----------------------------------------------------------------------
2109! Determine rank of tile neighbors and number of ghost-points to
2110! exchange.
2111!-----------------------------------------------------------------------
2112!
2113! Maximum automatic buffer memory size in bytes.
2114!
2115 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
2116 & 4*SIZE(sends))*kind(a),r8))
2117!
2118 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
2119 & grecvw, gsendw, wtile, wexchange, &
2120 & grecve, gsende, etile, eexchange, &
2121 & grecvs, gsends, stile, sexchange, &
2122 & grecvn, gsendn, ntile, nexchange)
2123!
2124! Set communication tags.
2125!
2126 wtag=1
2127 stag=2
2128 etag=3
2129 ntag=4
2130!
2131! Determine range and length of the distributed tile boundary segments.
2132!
2133 imin=lbi
2134 imax=ubi
2135 jmin=lbj
2136 jmax=ubj
2137 ilen=imax-imin+1
2138 jlen=jmax-jmin+1
2139 klen=ubk-lbk+1
2140 iklen=ilen*klen
2141 jklen=jlen*klen
2142 IF (ew_periodic.or.ns_periodic) THEN
2143 pp=1
2144 ELSE
2145 pp=0
2146 END IF
2147 ewsize=nvar*(nghost+pp)*jklen
2148 nssize=nvar*(nghost+pp)*iklen
2149 IF (SIZE(sende).lt.ewsize) THEN
2150 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
2151 10 FORMAT (/,' MP_EXCHANGE3D - communication buffer too small, ', &
2152 & a, 2i8)
2153 END IF
2154 IF (SIZE(sendn).lt.nssize) THEN
2155 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
2156 END IF
2157!
2158!-----------------------------------------------------------------------
2159! Pack Western and Eastern tile boundary data including ghost-points.
2160!-----------------------------------------------------------------------
2161!
2162 IF (wexchange) THEN
2163 sizew=0
2164 DO m=1,gsendw
2165 mc=(m-1)*jklen
2166 i=istr+m-1
2167 DO k=lbk,ubk
2168 kc=(k-lbk)*jlen+mc
2169 DO j=jmin,jmax
2170 sizew=sizew+1
2171 jkw=1+(j-jmin)+kc
2172 sendw(jkw)=a(i,j,k)
2173 END DO
2174 END DO
2175 END DO
2176 IF (PRESENT(b)) THEN
2177 joff=jkw
2178 DO m=1,gsendw
2179 mc=(m-1)*jklen
2180 i=istr+m-1
2181 DO k=lbk,ubk
2182 kc=(k-lbk)*jlen+mc
2183 DO j=jmin,jmax
2184 sizew=sizew+1
2185 jkw=joff+1+(j-jmin)+kc
2186 sendw(jkw)=b(i,j,k)
2187 END DO
2188 END DO
2189 END DO
2190 END IF
2191 IF (PRESENT(c)) THEN
2192 joff=jkw
2193 DO m=1,gsendw
2194 mc=(m-1)*jklen
2195 i=istr+m-1
2196 DO k=lbk,ubk
2197 kc=(k-lbk)*jlen+mc
2198 DO j=jmin,jmax
2199 sizew=sizew+1
2200 jkw=joff+1+(j-jmin)+kc
2201 sendw(jkw)=c(i,j,k)
2202 END DO
2203 END DO
2204 END DO
2205 END IF
2206 IF (PRESENT(d)) THEN
2207 joff=jkw
2208 DO m=1,gsendw
2209 mc=(m-1)*jklen
2210 i=istr+m-1
2211 DO k=lbk,ubk
2212 kc=(k-lbk)*jlen+mc
2213 DO j=jmin,jmax
2214 sizew=sizew+1
2215 jkw=joff+1+(j-jmin)+kc
2216 sendw(jkw)=d(i,j,k)
2217 END DO
2218 END DO
2219 END DO
2220 END IF
2221 END IF
2222!
2223 IF (eexchange) THEN
2224 sizee=0
2225 DO m=1,gsende
2226 mc=(m-1)*jklen
2227 i=iend-gsende+m
2228 DO k=lbk,ubk
2229 kc=(k-lbk)*jlen+mc
2230 DO j=jmin,jmax
2231 sizee=sizee+1
2232 jke=1+(j-jmin)+kc
2233 sende(jke)=a(i,j,k)
2234 END DO
2235 END DO
2236 END DO
2237 IF (PRESENT(b)) THEN
2238 joff=jke
2239 DO m=1,gsende
2240 mc=(m-1)*jklen
2241 i=iend-gsende+m
2242 DO k=lbk,ubk
2243 kc=(k-lbk)*jlen+mc
2244 DO j=jmin,jmax
2245 sizee=sizee+1
2246 jke=joff+1+(j-jmin)+kc
2247 sende(jke)=b(i,j,k)
2248 END DO
2249 END DO
2250 END DO
2251 END IF
2252 IF (PRESENT(c)) THEN
2253 joff=jke
2254 DO m=1,gsende
2255 mc=(m-1)*jklen
2256 i=iend-gsende+m
2257 DO k=lbk,ubk
2258 kc=(k-lbk)*jlen+mc
2259 DO j=jmin,jmax
2260 sizee=sizee+1
2261 jke=joff+1+(j-jmin)+kc
2262 sende(jke)=c(i,j,k)
2263 END DO
2264 END DO
2265 END DO
2266 END IF
2267 IF (PRESENT(d)) THEN
2268 joff=jke
2269 DO m=1,gsende
2270 mc=(m-1)*jklen
2271 i=iend-gsende+m
2272 DO k=lbk,ubk
2273 kc=(k-lbk)*jlen+mc
2274 DO j=jmin,jmax
2275 sizee=sizee+1
2276 jke=joff+1+(j-jmin)+kc
2277 sende(jke)=d(i,j,k)
2278 END DO
2279 END DO
2280 END DO
2281 END IF
2282 END IF
2283!
2284!-----------------------------------------------------------------------
2285! Send and receive Western and Eastern segments.
2286!-----------------------------------------------------------------------
2287!
2288# if defined MPI
2289 IF (wexchange) THEN
2290 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
2291 & ocn_comm_world, wrequest, werror)
2292 END IF
2293 IF (eexchange) THEN
2294 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
2295 & ocn_comm_world, erequest, eerror)
2296 END IF
2297 IF (wexchange) THEN
2298 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
2299 & ocn_comm_world, werror)
2300 END IF
2301 IF (eexchange) THEN
2302 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
2303 & ocn_comm_world, eerror)
2304 END IF
2305# endif
2306!
2307!-----------------------------------------------------------------------
2308! Unpack Eastern and Western segments.
2309!-----------------------------------------------------------------------
2310!
2311 IF (wexchange) THEN
2312# ifdef MPI
2313 CALL mpi_wait (wrequest, status(1,1), werror)
2314 IF (werror.ne.mpi_success) THEN
2315 CALL mpi_error_string (werror, string, lstr, ierror)
2316 lstr=len_trim(string)
2317 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
2318 & myrank, werror, string(1:lstr)
2319 exit_flag=2
2320 RETURN
2321 END IF
2322# endif
2323 DO m=grecvw,1,-1
2324 mc=(grecvw-m)*jklen
2325 i=istr-m
2326 DO k=lbk,ubk
2327 kc=(k-lbk)*jlen+mc
2328 DO j=jmin,jmax
2329 jkw=1+(j-jmin)+kc
2330 a(i,j,k)=recvw(jkw)
2331 END DO
2332 END DO
2333 END DO
2334 IF (PRESENT(b)) THEN
2335 joff=jkw
2336 DO m=grecvw,1,-1
2337 mc=(grecvw-m)*jklen
2338 i=istr-m
2339 DO k=lbk,ubk
2340 kc=(k-lbk)*jlen+mc
2341 DO j=jmin,jmax
2342 jkw=joff+1+(j-jmin)+kc
2343 b(i,j,k)=recvw(jkw)
2344 END DO
2345 END DO
2346 END DO
2347 END IF
2348 IF (PRESENT(c)) THEN
2349 joff=jkw
2350 DO m=grecvw,1,-1
2351 mc=(grecvw-m)*jklen
2352 i=istr-m
2353 DO k=lbk,ubk
2354 kc=(k-lbk)*jlen+mc
2355 DO j=jmin,jmax
2356 jkw=joff+1+(j-jmin)+kc
2357 c(i,j,k)=recvw(jkw)
2358 END DO
2359 END DO
2360 END DO
2361 END IF
2362 IF (PRESENT(d)) THEN
2363 joff=jkw
2364 DO m=grecvw,1,-1
2365 mc=(grecvw-m)*jklen
2366 i=istr-m
2367 DO k=lbk,ubk
2368 kc=(k-lbk)*jlen+mc
2369 DO j=jmin,jmax
2370 jkw=joff+1+(j-jmin)+kc
2371 d(i,j,k)=recvw(jkw)
2372 END DO
2373 END DO
2374 END DO
2375 END IF
2376 END IF
2377!
2378 IF (eexchange) THEN
2379# ifdef MPI
2380 CALL mpi_wait (erequest, status(1,3), eerror)
2381 IF (eerror.ne.mpi_success) THEN
2382 CALL mpi_error_string (eerror, string, lstr, ierror)
2383 lstr=len_trim(string)
2384 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
2385 & myrank, eerror, string(1:lstr)
2386 20 FORMAT (/,' MP_EXCHANGE3D - error during ',a, &
2387 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
2388 exit_flag=2
2389 RETURN
2390 END IF
2391# endif
2392 DO m=1,grecve
2393 mc=(m-1)*jklen
2394 i=iend+m
2395 DO k=lbk,ubk
2396 kc=(k-lbk)*jlen+mc
2397 DO j=jmin,jmax
2398 jke=1+(j-jmin)+kc
2399 a(i,j,k)=recve(jke)
2400 END DO
2401 ENDDO
2402 END DO
2403 IF (PRESENT(b)) THEN
2404 joff=jke
2405 DO m=1,grecve
2406 mc=(m-1)*jklen
2407 i=iend+m
2408 DO k=lbk,ubk
2409 kc=(k-lbk)*jlen+mc
2410 DO j=jmin,jmax
2411 jke=joff+1+(j-jmin)+kc
2412 b(i,j,k)=recve(jke)
2413 END DO
2414 ENDDO
2415 END DO
2416 END IF
2417 IF (PRESENT(c)) THEN
2418 joff=jke
2419 DO m=1,grecve
2420 mc=(m-1)*jklen
2421 i=iend+m
2422 DO k=lbk,ubk
2423 kc=(k-lbk)*jlen+mc
2424 DO j=jmin,jmax
2425 jke=joff+1+(j-jmin)+kc
2426 c(i,j,k)=recve(jke)
2427 END DO
2428 ENDDO
2429 END DO
2430 END IF
2431 IF (PRESENT(d)) THEN
2432 joff=jke
2433 DO m=1,grecve
2434 mc=(m-1)*jklen
2435 i=iend+m
2436 DO k=lbk,ubk
2437 kc=(k-lbk)*jlen+mc
2438 DO j=jmin,jmax
2439 jke=joff+1+(j-jmin)+kc
2440 d(i,j,k)=recve(jke)
2441 END DO
2442 ENDDO
2443 END DO
2444 END IF
2445 END IF
2446!
2447!-----------------------------------------------------------------------
2448! Pack Southern and Northern tile boundary data including ghost-points.
2449!-----------------------------------------------------------------------
2450!
2451 IF (sexchange) THEN
2452 sizes=0
2453 DO m=1,gsends
2454 mc=(m-1)*iklen
2455 j=jstr+m-1
2456 DO k=lbk,ubk
2457 kc=(k-lbk)*ilen+mc
2458 DO i=imin,imax
2459 sizes=sizes+1
2460 iks=1+(i-imin)+kc
2461 sends(iks)=a(i,j,k)
2462 END DO
2463 END DO
2464 END DO
2465 IF (PRESENT(b)) THEN
2466 ioff=iks
2467 DO m=1,gsends
2468 mc=(m-1)*iklen
2469 j=jstr+m-1
2470 DO k=lbk,ubk
2471 kc=(k-lbk)*ilen+mc
2472 DO i=imin,imax
2473 sizes=sizes+1
2474 iks=ioff+1+(i-imin)+kc
2475 sends(iks)=b(i,j,k)
2476 END DO
2477 END DO
2478 END DO
2479 END IF
2480 IF (PRESENT(c)) THEN
2481 ioff=iks
2482 DO m=1,gsends
2483 mc=(m-1)*iklen
2484 j=jstr+m-1
2485 DO k=lbk,ubk
2486 kc=(k-lbk)*ilen+mc
2487 DO i=imin,imax
2488 sizes=sizes+1
2489 iks=ioff+1+(i-imin)+kc
2490 sends(iks)=c(i,j,k)
2491 END DO
2492 END DO
2493 END DO
2494 END IF
2495 IF (PRESENT(d)) THEN
2496 ioff=iks
2497 DO m=1,gsends
2498 mc=(m-1)*iklen
2499 j=jstr+m-1
2500 DO k=lbk,ubk
2501 kc=(k-lbk)*ilen+mc
2502 DO i=imin,imax
2503 sizes=sizes+1
2504 iks=ioff+1+(i-imin)+kc
2505 sends(iks)=d(i,j,k)
2506 END DO
2507 END DO
2508 END DO
2509 END IF
2510 END IF
2511!
2512 IF (nexchange) THEN
2513 sizen=0
2514 DO m=1,gsendn
2515 mc=(m-1)*iklen
2516 j=jend-gsendn+m
2517 DO k=lbk,ubk
2518 kc=(k-lbk)*ilen+mc
2519 DO i=imin,imax
2520 sizen=sizen+1
2521 ikn=1+(i-imin)+kc
2522 sendn(ikn)=a(i,j,k)
2523 END DO
2524 END DO
2525 END DO
2526 IF (PRESENT(b)) THEN
2527 ioff=ikn
2528 DO m=1,gsendn
2529 mc=(m-1)*iklen
2530 j=jend-gsendn+m
2531 DO k=lbk,ubk
2532 kc=(k-lbk)*ilen+mc
2533 DO i=imin,imax
2534 sizen=sizen+1
2535 ikn=ioff+1+(i-imin)+kc
2536 sendn(ikn)=b(i,j,k)
2537 END DO
2538 END DO
2539 END DO
2540 END IF
2541 IF (PRESENT(c)) THEN
2542 ioff=ikn
2543 DO m=1,gsendn
2544 mc=(m-1)*iklen
2545 j=jend-gsendn+m
2546 DO k=lbk,ubk
2547 kc=(k-lbk)*ilen+mc
2548 DO i=imin,imax
2549 sizen=sizen+1
2550 ikn=ioff+1+(i-imin)+kc
2551 sendn(ikn)=c(i,j,k)
2552 END DO
2553 END DO
2554 END DO
2555 END IF
2556 IF (PRESENT(d)) THEN
2557 ioff=ikn
2558 DO m=1,gsendn
2559 mc=(m-1)*iklen
2560 j=jend-gsendn+m
2561 DO k=lbk,ubk
2562 kc=(k-lbk)*ilen+mc
2563 DO i=imin,imax
2564 sizen=sizen+1
2565 ikn=ioff+1+(i-imin)+kc
2566 sendn(ikn)=d(i,j,k)
2567 END DO
2568 END DO
2569 END DO
2570 END IF
2571 END IF
2572!
2573!-----------------------------------------------------------------------
2574! Send and receive Southern and Northern segments.
2575!-----------------------------------------------------------------------
2576!
2577# if defined MPI
2578 IF (sexchange) THEN
2579 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
2580 & ocn_comm_world, srequest, serror)
2581 END IF
2582 IF (nexchange) THEN
2583 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
2584 & ocn_comm_world, nrequest, nerror)
2585 END IF
2586 IF (sexchange) THEN
2587 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
2588 & ocn_comm_world, serror)
2589 END IF
2590 IF (nexchange) THEN
2591 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
2592 & ocn_comm_world, nerror)
2593 END IF
2594# endif
2595!
2596!-----------------------------------------------------------------------
2597! Unpack Northern and Southern segments.
2598!-----------------------------------------------------------------------
2599!
2600 IF (sexchange) THEN
2601# ifdef MPI
2602 CALL mpi_wait (srequest, status(1,2), serror)
2603 IF (serror.ne.mpi_success) THEN
2604 CALL mpi_error_string (serror, string, lstr, ierror)
2605 lstr=len_trim(string)
2606 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
2607 & myrank, serror, string(1:lstr)
2608 exit_flag=2
2609 RETURN
2610 END IF
2611# endif
2612 DO m=grecvs,1,-1
2613 mc=(grecvs-m)*iklen
2614 j=jstr-m
2615 DO k=lbk,ubk
2616 kc=(k-lbk)*ilen+mc
2617 DO i=imin,imax
2618 iks=1+(i-imin)+kc
2619 a(i,j,k)=recvs(iks)
2620 END DO
2621 END DO
2622 END DO
2623 IF (PRESENT(b)) THEN
2624 ioff=iks
2625 DO m=grecvs,1,-1
2626 mc=(grecvs-m)*iklen
2627 j=jstr-m
2628 DO k=lbk,ubk
2629 kc=(k-lbk)*ilen+mc
2630 DO i=imin,imax
2631 iks=ioff+1+(i-imin)+kc
2632 b(i,j,k)=recvs(iks)
2633 END DO
2634 END DO
2635 END DO
2636 END IF
2637 IF (PRESENT(c)) THEN
2638 ioff=iks
2639 DO m=grecvs,1,-1
2640 mc=(grecvs-m)*iklen
2641 j=jstr-m
2642 DO k=lbk,ubk
2643 kc=(k-lbk)*ilen+mc
2644 DO i=imin,imax
2645 iks=ioff+1+(i-imin)+kc
2646 c(i,j,k)=recvs(iks)
2647 END DO
2648 END DO
2649 END DO
2650 END IF
2651 IF (PRESENT(d)) THEN
2652 ioff=iks
2653 DO m=grecvs,1,-1
2654 mc=(grecvs-m)*iklen
2655 j=jstr-m
2656 DO k=lbk,ubk
2657 kc=(k-lbk)*ilen+mc
2658 DO i=imin,imax
2659 iks=ioff+1+(i-imin)+kc
2660 d(i,j,k)=recvs(iks)
2661 END DO
2662 END DO
2663 END DO
2664 END IF
2665 END IF
2666!
2667 IF (nexchange) THEN
2668# ifdef MPI
2669 CALL mpi_wait (nrequest, status(1,4), nerror)
2670 IF (nerror.ne.mpi_success) THEN
2671 CALL mpi_error_string (nerror, string, lstr, ierror)
2672 lstr=len_trim(string)
2673 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
2674 & myrank, nerror, string(1:lstr)
2675 exit_flag=2
2676 RETURN
2677 END IF
2678# endif
2679 DO m=1,grecvn
2680 mc=(m-1)*iklen
2681 j=jend+m
2682 DO k=lbk,ubk
2683 kc=(k-lbk)*ilen+mc
2684 DO i=imin,imax
2685 ikn=1+(i-imin)+kc
2686 a(i,j,k)=recvn(ikn)
2687 END DO
2688 END DO
2689 END DO
2690 IF (PRESENT(b)) THEN
2691 ioff=ikn
2692 DO m=1,grecvn
2693 mc=(m-1)*iklen
2694 j=jend+m
2695 DO k=lbk,ubk
2696 kc=(k-lbk)*ilen+mc
2697 DO i=imin,imax
2698 ikn=ioff+1+(i-imin)+kc
2699 b(i,j,k)=recvn(ikn)
2700 END DO
2701 END DO
2702 END DO
2703 END IF
2704 IF (PRESENT(c)) THEN
2705 ioff=ikn
2706 DO m=1,grecvn
2707 mc=(m-1)*iklen
2708 j=jend+m
2709 DO k=lbk,ubk
2710 kc=(k-lbk)*ilen+mc
2711 DO i=imin,imax
2712 ikn=ioff+1+(i-imin)+kc
2713 c(i,j,k)=recvn(ikn)
2714 END DO
2715 END DO
2716 END DO
2717 END IF
2718 IF (PRESENT(d)) THEN
2719 ioff=ikn
2720 DO m=1,grecvn
2721 mc=(m-1)*iklen
2722 j=jend+m
2723 DO k=lbk,ubk
2724 kc=(k-lbk)*ilen+mc
2725 DO i=imin,imax
2726 ikn=ioff+1+(i-imin)+kc
2727 d(i,j,k)=recvn(ikn)
2728 END DO
2729 END DO
2730 END DO
2731 END IF
2732 END IF
2733
2734# ifdef PROFILE
2735!
2736!-----------------------------------------------------------------------
2737! Turn off time clocks.
2738!-----------------------------------------------------------------------
2739!
2740 CALL wclock_off (ng, model, 61, __line__, myfile)
2741# endif
2742!
2743 RETURN
2744 END SUBROUTINE mp_exchange3d
2745
2746!
2747!***********************************************************************
2748 SUBROUTINE mp_exchange3d_bry (ng, tile, model, Nvar, boundary, &
2749 & LBij, UBij, LBk, UBk, &
2750 & Nghost, EW_periodic, NS_periodic, &
2751 & A, B, C, D)
2752!***********************************************************************
2753!
2754 USE mod_param
2755 USE mod_parallel
2756 USE mod_iounits
2757 USE mod_scalars
2758!
2759 implicit none
2760!
2761! Imported variable declarations.
2762!
2763 logical, intent(in) :: EW_periodic, NS_periodic
2764!
2765 integer, intent(in) :: ng, tile, model, Nvar, boundary
2766 integer, intent(in) :: LBij, UBij, LBk, UBk
2767 integer, intent(in) :: Nghost
2768!
2769# ifdef ASSUMED_SHAPE
2770 real(r8), intent(inout) :: A(LBij:,LBk:)
2771
2772 real(r8), intent(inout), optional :: B(LBij:,LBk:)
2773 real(r8), intent(inout), optional :: C(LBij:,LBk:)
2774 real(r8), intent(inout), optional :: D(LBij:,LBk:)
2775# else
2776 real(r8), intent(inout) :: A(LBij:UBij,LBk:UBk)
2777
2778 real(r8), intent(inout), optional :: B(LBij:UBij,LBk:UBk)
2779 real(r8), intent(inout), optional :: C(LBij:UBij,LBk:UBk)
2780 real(r8), intent(inout), optional :: D(LBij:UBij,LBk:UBk)
2781# endif
2782!
2783! Local variable declarations.
2784!
2785 logical :: Wexchange, Sexchange, Eexchange, Nexchange
2786!
2787 integer :: i, ikS, ikN, ioff
2788 integer :: j, jkW, jkE, joff
2789 integer :: k, m, mc, Ierror, Klen, Lstr, pp
2790 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
2791 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
2792 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
2793 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
2794 integer :: EWsize, sizeW, sizeE
2795 integer :: NSsize, sizeS, sizeN
2796
2797# ifdef MPI
2798 integer, dimension(MPI_STATUS_SIZE,4) :: status
2799# endif
2800!
2801 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendW, sendE
2802 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvW, recvE
2803 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendS, sendN
2804 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvS, recvN
2805!
2806 character (len=MPI_MAX_ERROR_STRING) :: string
2807
2808 character (len=*), parameter :: MyFile = &
2809 & __FILE__//", mp_exchange3d_bry"
2810
2811# include "set_bounds.h"
2812
2813# ifdef PROFILE
2814!
2815!-----------------------------------------------------------------------
2816! Turn on time clocks.
2817!-----------------------------------------------------------------------
2818!
2819 CALL wclock_on (ng, model, 63, __line__, myfile)
2820# endif
2821!
2822!-----------------------------------------------------------------------
2823! Determine rank of tile neighbors and number of ghost-points to
2824! exchange.
2825!-----------------------------------------------------------------------
2826!
2827! Maximum automatic buffer memory size in bytes.
2828!
2829 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
2830 & 4*SIZE(sends))*kind(a),r8))
2831!
2832 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
2833 & grecvw, gsendw, wtile, wexchange, &
2834 & grecve, gsende, etile, eexchange, &
2835 & grecvs, gsends, stile, sexchange, &
2836 & grecvn, gsendn, ntile, nexchange)
2837!
2838! Adjust exchange swiches according to boundary edge to process.
2839!
2840 wexchange=wexchange.and.((boundary.eq.isouth).or. &
2841 & (boundary.eq.inorth))
2842 eexchange=eexchange.and.((boundary.eq.isouth).or. &
2843 & (boundary.eq.inorth))
2844 sexchange=sexchange.and.((boundary.eq.iwest).or. &
2845 & (boundary.eq.ieast))
2846 nexchange=nexchange.and.((boundary.eq.iwest).or. &
2847 & (boundary.eq.ieast))
2848!
2849! Set communication tags.
2850!
2851 wtag=1
2852 stag=2
2853 etag=3
2854 ntag=4
2855!
2856! Determine range and length of the distributed tile boundary segments.
2857!
2858 klen=ubk-lbk+1
2859 IF (ew_periodic.or.ns_periodic) THEN
2860 pp=1
2861 ELSE
2862 pp=0
2863 END IF
2864 ewsize=nvar*(nghost+pp)*klen
2865 nssize=nvar*(nghost+pp)*klen
2866 IF (SIZE(sende).lt.ewsize) THEN
2867 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
2868 10 FORMAT (/,' MP_EXCHANGE3D_BRY - communication buffer too ', &
2869 & 'small, ', a, 2i8)
2870 END IF
2871 IF (SIZE(sendn).lt.nssize) THEN
2872 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
2873 END IF
2874!
2875!-----------------------------------------------------------------------
2876! Pack Western and Eastern tile boundary data including ghost-points.
2877!-----------------------------------------------------------------------
2878!
2879 IF (wexchange) THEN
2880 sizew=0
2881 DO m=1,gsendw
2882 mc=(m-1)*klen
2883 i=istr+m-1
2884 DO k=lbk,ubk
2885 sizew=sizew+1
2886 jkw=1+(k-lbk)+mc
2887 sendw(jkw)=a(i,k)
2888 END DO
2889 END DO
2890 IF (PRESENT(b)) THEN
2891 joff=jkw
2892 DO m=1,gsendw
2893 mc=(m-1)*klen
2894 i=istr+m-1
2895 DO k=lbk,ubk
2896 sizew=sizew+1
2897 jkw=joff+1+(k-lbk)+mc
2898 sendw(jkw)=b(i,k)
2899 END DO
2900 END DO
2901 END IF
2902 IF (PRESENT(c)) THEN
2903 joff=jkw
2904 DO m=1,gsendw
2905 mc=(m-1)*klen
2906 i=istr+m-1
2907 DO k=lbk,ubk
2908 sizew=sizew+1
2909 jkw=joff+1+(k-lbk)+mc
2910 sendw(jkw)=c(i,k)
2911 END DO
2912 END DO
2913 END IF
2914 IF (PRESENT(d)) THEN
2915 joff=jkw
2916 DO m=1,gsendw
2917 mc=(m-1)*klen
2918 i=istr+m-1
2919 DO k=lbk,ubk
2920 sizew=sizew+1
2921 jkw=joff+1+(k-lbk)+mc
2922 sendw(jkw)=d(i,k)
2923 END DO
2924 END DO
2925 END IF
2926 END IF
2927!
2928 IF (eexchange) THEN
2929 sizee=0
2930 DO m=1,gsende
2931 mc=(m-1)*klen
2932 i=iend-gsende+m
2933 DO k=lbk,ubk
2934 sizee=sizee+1
2935 jke=1+(k-lbk)+mc
2936 sende(jke)=a(i,k)
2937 END DO
2938 END DO
2939 IF (PRESENT(b)) THEN
2940 joff=jke
2941 DO m=1,gsende
2942 mc=(m-1)*klen
2943 i=iend-gsende+m
2944 DO k=lbk,ubk
2945 sizee=sizee+1
2946 jke=joff+1+(k-lbk)+mc
2947 sende(jke)=b(i,k)
2948 END DO
2949 END DO
2950 END IF
2951 IF (PRESENT(c)) THEN
2952 joff=jke
2953 DO m=1,gsende
2954 mc=(m-1)*klen
2955 i=iend-gsende+m
2956 DO k=lbk,ubk
2957 sizee=sizee+1
2958 jke=joff+1+(k-lbk)+mc
2959 sende(jke)=c(i,k)
2960 END DO
2961 END DO
2962 END IF
2963 IF (PRESENT(d)) THEN
2964 joff=jke
2965 DO m=1,gsende
2966 mc=(m-1)*klen
2967 i=iend-gsende+m
2968 DO k=lbk,ubk
2969 sizee=sizee+1
2970 jke=joff+1+(k-lbk)+mc
2971 sende(jke)=d(i,k)
2972 END DO
2973 END DO
2974 END IF
2975 END IF
2976!
2977!-----------------------------------------------------------------------
2978! Send and receive Western and Eastern segments.
2979!-----------------------------------------------------------------------
2980!
2981# if defined MPI
2982 IF (wexchange) THEN
2983 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
2984 & ocn_comm_world, wrequest, werror)
2985 END IF
2986 IF (eexchange) THEN
2987 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
2988 & ocn_comm_world, erequest, eerror)
2989 END IF
2990 IF (wexchange) THEN
2991 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
2992 & ocn_comm_world, werror)
2993 END IF
2994 IF (eexchange) THEN
2995 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
2996 & ocn_comm_world, eerror)
2997 END IF
2998# endif
2999!
3000!-----------------------------------------------------------------------
3001! Unpack Eastern and Western segments.
3002!-----------------------------------------------------------------------
3003!
3004 IF (wexchange) THEN
3005# ifdef MPI
3006 CALL mpi_wait (wrequest, status(1,1), werror)
3007 IF (werror.ne.mpi_success) THEN
3008 CALL mpi_error_string (werror, string, lstr, ierror)
3009 lstr=len_trim(string)
3010 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
3011 & myrank, werror, string(1:lstr)
3012 exit_flag=2
3013 RETURN
3014 END IF
3015# endif
3016 DO m=grecvw,1,-1
3017 mc=(grecvw-m)*klen
3018 i=istr-m
3019 DO k=lbk,ubk
3020 jkw=1+(k-lbk)+mc
3021 a(i,k)=recvw(jkw)
3022 END DO
3023 END DO
3024 IF (PRESENT(b)) THEN
3025 joff=jkw
3026 DO m=grecvw,1,-1
3027 mc=(grecvw-m)*klen
3028 i=istr-m
3029 DO k=lbk,ubk
3030 jkw=joff+1+(k-lbk)+mc
3031 b(i,k)=recvw(jkw)
3032 END DO
3033 END DO
3034 END IF
3035 IF (PRESENT(c)) THEN
3036 joff=jkw
3037 DO m=grecvw,1,-1
3038 mc=(grecvw-m)*klen
3039 i=istr-m
3040 DO k=lbk,ubk
3041 jkw=joff+1+(k-lbk)+mc
3042 c(i,k)=recvw(jkw)
3043 END DO
3044 END DO
3045 END IF
3046 IF (PRESENT(d)) THEN
3047 joff=jkw
3048 DO m=grecvw,1,-1
3049 mc=(grecvw-m)*klen
3050 i=istr-m
3051 DO k=lbk,ubk
3052 jkw=joff+1+(k-lbk)+mc
3053 d(i,k)=recvw(jkw)
3054 END DO
3055 END DO
3056 END IF
3057 END IF
3058!
3059 IF (eexchange) THEN
3060# ifdef MPI
3061 CALL mpi_wait (erequest, status(1,3), eerror)
3062 IF (eerror.ne.mpi_success) THEN
3063 CALL mpi_error_string (eerror, string, lstr, ierror)
3064 lstr=len_trim(string)
3065 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
3066 & myrank, eerror, string(1:lstr)
3067 20 FORMAT (/,' MP_EXCHANGE3D_BRY - error during ',a, &
3068 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
3069 exit_flag=2
3070 RETURN
3071 END IF
3072# endif
3073 DO m=1,grecve
3074 mc=(m-1)*klen
3075 i=iend+m
3076 DO k=lbk,ubk
3077 jke=1+(k-lbk)+mc
3078 a(i,k)=recve(jke)
3079 END DO
3080 END DO
3081 IF (PRESENT(b)) THEN
3082 joff=jke
3083 DO m=1,grecve
3084 mc=(m-1)*klen
3085 i=iend+m
3086 DO k=lbk,ubk
3087 jke=joff+1+(k-lbk)+mc
3088 b(i,k)=recve(jke)
3089 END DO
3090 END DO
3091 END IF
3092 IF (PRESENT(c)) THEN
3093 joff=jke
3094 DO m=1,grecve
3095 mc=(m-1)*klen
3096 i=iend+m
3097 DO k=lbk,ubk
3098 jke=joff+1+(k-lbk)+mc
3099 c(i,k)=recve(jke)
3100 END DO
3101 END DO
3102 END IF
3103 IF (PRESENT(d)) THEN
3104 joff=jke
3105 DO m=1,grecve
3106 mc=(m-1)*klen
3107 i=iend+m
3108 DO k=lbk,ubk
3109 jke=joff+1+(k-lbk)+mc
3110 d(i,k)=recve(jke)
3111 END DO
3112 END DO
3113 END IF
3114 END IF
3115!
3116!-----------------------------------------------------------------------
3117! Pack Southern and Northern tile boundary data including ghost-points.
3118!-----------------------------------------------------------------------
3119!
3120 IF (sexchange) THEN
3121 sizes=0
3122 DO m=1,gsends
3123 mc=(m-1)*klen
3124 j=jstr+m-1
3125 DO k=lbk,ubk
3126 sizes=sizes+1
3127 iks=1+(k-lbk)+mc
3128 sends(iks)=a(j,k)
3129 END DO
3130 END DO
3131 IF (PRESENT(b)) THEN
3132 ioff=iks
3133 DO m=1,gsends
3134 mc=(m-1)*klen
3135 j=jstr+m-1
3136 DO k=lbk,ubk
3137 sizes=sizes+1
3138 iks=ioff+1+(k-lbk)+mc
3139 sends(iks)=b(j,k)
3140 END DO
3141 END DO
3142 END IF
3143 IF (PRESENT(c)) THEN
3144 ioff=iks
3145 DO m=1,gsends
3146 mc=(m-1)*klen
3147 j=jstr+m-1
3148 DO k=lbk,ubk
3149 sizes=sizes+1
3150 iks=ioff+1+(k-lbk)+mc
3151 sends(iks)=c(j,k)
3152 END DO
3153 END DO
3154 END IF
3155 IF (PRESENT(d)) THEN
3156 ioff=iks
3157 DO m=1,gsends
3158 mc=(m-1)*klen
3159 j=jstr+m-1
3160 DO k=lbk,ubk
3161 sizes=sizes+1
3162 iks=ioff+1+(k-lbk)+mc
3163 sends(iks)=d(j,k)
3164 END DO
3165 END DO
3166 END IF
3167 END IF
3168!
3169 IF (nexchange) THEN
3170 sizen=0
3171 DO m=1,gsendn
3172 mc=(m-1)*klen
3173 j=jend-gsendn+m
3174 DO k=lbk,ubk
3175 sizen=sizen+1
3176 ikn=1+(k-lbk)+mc
3177 sendn(ikn)=a(j,k)
3178 END DO
3179 END DO
3180 IF (PRESENT(b)) THEN
3181 ioff=ikn
3182 DO m=1,gsendn
3183 mc=(m-1)*klen
3184 j=jend-gsendn+m
3185 DO k=lbk,ubk
3186 sizen=sizen+1
3187 ikn=ioff+1+(k-lbk)+mc
3188 sendn(ikn)=b(j,k)
3189 END DO
3190 END DO
3191 END IF
3192 IF (PRESENT(c)) THEN
3193 ioff=ikn
3194 DO m=1,gsendn
3195 mc=(m-1)*klen
3196 j=jend-gsendn+m
3197 DO k=lbk,ubk
3198 sizen=sizen+1
3199 ikn=ioff+1+(k-lbk)+mc
3200 sendn(ikn)=c(j,k)
3201 END DO
3202 END DO
3203 END IF
3204 IF (PRESENT(d)) THEN
3205 ioff=ikn
3206 DO m=1,gsendn
3207 mc=(m-1)*klen
3208 j=jend-gsendn+m
3209 DO k=lbk,ubk
3210 sizen=sizen+1
3211 ikn=ioff+1+(k-lbk)+mc
3212 sendn(ikn)=d(j,k)
3213 END DO
3214 END DO
3215 END IF
3216 END IF
3217!
3218!-----------------------------------------------------------------------
3219! Send and receive Southern and Northern segments.
3220!-----------------------------------------------------------------------
3221!
3222# if defined MPI
3223 IF (sexchange) THEN
3224 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
3225 & ocn_comm_world, srequest, serror)
3226 END IF
3227 IF (nexchange) THEN
3228 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
3229 & ocn_comm_world, nrequest, nerror)
3230 END IF
3231 IF (sexchange) THEN
3232 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
3233 & ocn_comm_world, serror)
3234 END IF
3235 IF (nexchange) THEN
3236 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
3237 & ocn_comm_world, nerror)
3238 END IF
3239# endif
3240!
3241!-----------------------------------------------------------------------
3242! Unpack Northern and Southern segments.
3243!-----------------------------------------------------------------------
3244!
3245 IF (sexchange) THEN
3246# ifdef MPI
3247 CALL mpi_wait (srequest, status(1,2), serror)
3248 IF (serror.ne.mpi_success) THEN
3249 CALL mpi_error_string (serror, string, lstr, ierror)
3250 lstr=len_trim(string)
3251 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
3252 & myrank, serror, string(1:lstr)
3253 exit_flag=2
3254 RETURN
3255 END IF
3256# endif
3257 DO m=grecvs,1,-1
3258 mc=(grecvs-m)*klen
3259 j=jstr-m
3260 DO k=lbk,ubk
3261 iks=1+(k-lbk)+mc
3262 a(j,k)=recvs(iks)
3263 END DO
3264 END DO
3265 IF (PRESENT(b)) THEN
3266 ioff=iks
3267 DO m=grecvs,1,-1
3268 mc=(grecvs-m)*klen
3269 j=jstr-m
3270 DO k=lbk,ubk
3271 iks=ioff+1+(k-lbk)+mc
3272 b(j,k)=recvs(iks)
3273 END DO
3274 END DO
3275 END IF
3276 IF (PRESENT(c)) THEN
3277 ioff=iks
3278 DO m=grecvs,1,-1
3279 mc=(grecvs-m)*klen
3280 j=jstr-m
3281 DO k=lbk,ubk
3282 iks=ioff+1+(k-lbk)+mc
3283 c(j,k)=recvs(iks)
3284 END DO
3285 END DO
3286 END IF
3287 IF (PRESENT(d)) THEN
3288 ioff=iks
3289 DO m=grecvs,1,-1
3290 mc=(grecvs-m)*klen
3291 j=jstr-m
3292 DO k=lbk,ubk
3293 iks=ioff+1+(k-lbk)+mc
3294 d(j,k)=recvs(iks)
3295 END DO
3296 END DO
3297 END IF
3298 END IF
3299!
3300 IF (nexchange) THEN
3301# ifdef MPI
3302 CALL mpi_wait (nrequest, status(1,4), nerror)
3303 IF (nerror.ne.mpi_success) THEN
3304 CALL mpi_error_string (nerror, string, lstr, ierror)
3305 lstr=len_trim(string)
3306 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
3307 & myrank, nerror, string(1:lstr)
3308 exit_flag=2
3309 RETURN
3310 END IF
3311# endif
3312 DO m=1,grecvn
3313 mc=(m-1)*klen
3314 j=jend+m
3315 DO k=lbk,ubk
3316 ikn=1+(k-lbk)+mc
3317 a(j,k)=recvn(ikn)
3318 END DO
3319 END DO
3320 IF (PRESENT(b)) THEN
3321 ioff=ikn
3322 DO m=1,grecvn
3323 mc=(m-1)*klen
3324 j=jend+m
3325 DO k=lbk,ubk
3326 ikn=ioff+1+(k-lbk)+mc
3327 b(j,k)=recvn(ikn)
3328 END DO
3329 END DO
3330 END IF
3331 IF (PRESENT(c)) THEN
3332 ioff=ikn
3333 DO m=1,grecvn
3334 mc=(m-1)*klen
3335 j=jend+m
3336 DO k=lbk,ubk
3337 ikn=ioff+1+(k-lbk)+mc
3338 c(j,k)=recvn(ikn)
3339 END DO
3340 END DO
3341 END IF
3342 IF (PRESENT(d)) THEN
3343 ioff=ikn
3344 DO m=1,grecvn
3345 mc=(m-1)*klen
3346 j=jend+m
3347 DO k=lbk,ubk
3348 ikn=ioff+1+(k-lbk)+mc
3349 d(j,k)=recvn(ikn)
3350 END DO
3351 END DO
3352 END IF
3353 END IF
3354
3355# ifdef PROFILE
3356!
3357!-----------------------------------------------------------------------
3358! Turn off time clocks.
3359!-----------------------------------------------------------------------
3360!
3361 CALL wclock_off (ng, model, 63, __line__, myfile)
3362# endif
3363!
3364 RETURN
3365 END SUBROUTINE mp_exchange3d_bry
3366
3367!
3368!***********************************************************************
3369 SUBROUTINE mp_exchange4d (ng, tile, model, Nvar, &
3370 & LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt, &
3371 & Nghost, EW_periodic, NS_periodic, &
3372 & A, B, C)
3373!***********************************************************************
3374!
3375 USE mod_param
3376 USE mod_parallel
3377 USE mod_iounits
3378 USE mod_scalars
3379!
3380 implicit none
3381!
3382! Imported variable declarations.
3383!
3384 logical, intent(in) :: EW_periodic, NS_periodic
3385!
3386 integer, intent(in) :: ng, tile, model, Nvar
3387 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
3388 integer, intent(in) :: Nghost
3389!
3390# ifdef ASSUMED_SHAPE
3391 real(r8), intent(inout) :: A(LBi:,LBj:,LBk:,LBt:)
3392
3393 real(r8), intent(inout), optional :: B(LBi:,LBj:,LBk:,LBt:)
3394 real(r8), intent(inout), optional :: C(LBi:,LBj:,LBk:,LBt:)
3395
3396# else
3397 real(r8), intent(inout) :: A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3398
3399 real(r8), intent(inout), optional :: &
3400 & B(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3401 real(r8), intent(inout), optional :: &
3402 & C(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
3403# endif
3404!
3405! Local variable declarations.
3406!
3407 logical :: Wexchange, Sexchange, Eexchange, Nexchange
3408!
3409 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen, IKTlen
3410 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen, JKTlen
3411 integer :: k, kc, m, mc, Ierror, Klen, Lstr, Tlen, pp
3412 integer :: l, lc
3413 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
3414 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
3415 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
3416 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
3417 integer :: EWsize, sizeW, sizeE
3418 integer :: NSsize, sizeS, sizeN
3419
3420# ifdef MPI
3421 integer, dimension(MPI_STATUS_SIZE,4) :: status
3422# endif
3423!
3424 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: sendW, sendE
3425 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: recvW, recvE
3426
3427 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: sendS, sendN
3428 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)*(UBt-LBt+1)) :: recvS, recvN
3429!
3430 character (len=MPI_MAX_ERROR_STRING) :: string
3431
3432 character (len=*), parameter :: MyFile = &
3433 & __FILE__//", mp_exchange4d"
3434
3435# include "set_bounds.h"
3436
3437# ifdef PROFILE
3438!
3439!-----------------------------------------------------------------------
3440! Turn on time clocks.
3441!-----------------------------------------------------------------------
3442!
3443 CALL wclock_on (ng, model, 62, __line__, myfile)
3444# endif
3445!
3446!-----------------------------------------------------------------------
3447! Determine rank of tile neighbors and number of ghost-points to
3448! exchange.
3449!-----------------------------------------------------------------------
3450!
3451! Maximum automatic buffer memory size in bytes.
3452!
3453 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
3454 & 4*SIZE(sends))*kind(a),r8))
3455!
3456 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
3457 & grecvw, gsendw, wtile, wexchange, &
3458 & grecve, gsende, etile, eexchange, &
3459 & grecvs, gsends, stile, sexchange, &
3460 & grecvn, gsendn, ntile, nexchange)
3461!
3462! Set communication tags.
3463!
3464 wtag=1
3465 stag=2
3466 etag=3
3467 ntag=4
3468!
3469! Determine range and length of the distributed tile boundary segments.
3470!
3471 imin=lbi
3472 imax=ubi
3473 jmin=lbj
3474 jmax=ubj
3475 ilen=imax-imin+1
3476 jlen=jmax-jmin+1
3477 klen=ubk-lbk+1
3478 tlen=ubt-lbt+1
3479 iklen=ilen*klen
3480 jklen=jlen*klen
3481 iktlen=iklen*tlen
3482 jktlen=jklen*tlen
3483 IF (ew_periodic.or.ns_periodic) THEN
3484 pp=1
3485 ELSE
3486 pp=0
3487 END IF
3488 ewsize=nvar*(nghost+pp)*jktlen
3489 nssize=nvar*(nghost+pp)*iktlen
3490 IF (SIZE(sende).lt.ewsize) THEN
3491 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
3492 10 FORMAT (/,' MP_EXCHANGE4D - communication buffer too small, ', &
3493 & a, 2i8)
3494 END IF
3495 IF (SIZE(sendn).lt.nssize) THEN
3496 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
3497 END IF
3498!
3499!-----------------------------------------------------------------------
3500! Pack Western and Eastern tile boundary data including ghost-points.
3501!-----------------------------------------------------------------------
3502!
3503 IF (wexchange) THEN
3504 sizew=0
3505 DO m=1,gsendw
3506 mc=(m-1)*jktlen
3507 i=istr+m-1
3508 DO l=lbt,ubt
3509 lc=(l-lbt)*jklen+mc
3510 DO k=lbk,ubk
3511 kc=(k-lbk)*jlen+lc
3512 DO j=jmin,jmax
3513 sizew=sizew+1
3514 jkw=1+(j-jmin)+kc
3515 sendw(jkw)=a(i,j,k,l)
3516 END DO
3517 END DO
3518 END DO
3519 END DO
3520 IF (PRESENT(b)) THEN
3521 joff=jkw
3522 DO m=1,gsendw
3523 mc=(m-1)*jktlen
3524 i=istr+m-1
3525 DO l=lbt,ubt
3526 lc=(l-lbt)*jklen+mc
3527 DO k=lbk,ubk
3528 kc=(k-lbk)*jlen+lc
3529 DO j=jmin,jmax
3530 sizew=sizew+1
3531 jkw=joff+1+(j-jmin)+kc
3532 sendw(jkw)=b(i,j,k,l)
3533 END DO
3534 END DO
3535 END DO
3536 END DO
3537 END IF
3538 IF (PRESENT(c)) THEN
3539 joff=jkw
3540 DO m=1,gsendw
3541 mc=(m-1)*jktlen
3542 i=istr+m-1
3543 DO l=lbt,ubt
3544 lc=(l-lbt)*jklen+mc
3545 DO k=lbk,ubk
3546 kc=(k-lbk)*jlen+lc
3547 DO j=jmin,jmax
3548 sizew=sizew+1
3549 jkw=joff+1+(j-jmin)+kc
3550 sendw(jkw)=c(i,j,k,l)
3551 END DO
3552 END DO
3553 END DO
3554 END DO
3555 END IF
3556 END IF
3557!
3558 IF (eexchange) THEN
3559 sizee=0
3560 DO m=1,gsende
3561 mc=(m-1)*jktlen
3562 i=iend-gsende+m
3563 DO l=lbt,ubt
3564 lc=(l-lbt)*jklen+mc
3565 DO k=lbk,ubk
3566 kc=(k-lbk)*jlen+lc
3567 DO j=jmin,jmax
3568 sizee=sizee+1
3569 jke=1+(j-jmin)+kc
3570 sende(jke)=a(i,j,k,l)
3571 END DO
3572 END DO
3573 END DO
3574 END DO
3575 IF (PRESENT(b)) THEN
3576 joff=jke
3577 DO m=1,gsende
3578 mc=(m-1)*jktlen
3579 i=iend-gsende+m
3580 DO l=lbt,ubt
3581 lc=(l-lbt)*jklen+mc
3582 DO k=lbk,ubk
3583 kc=(k-lbk)*jlen+lc
3584 DO j=jmin,jmax
3585 sizee=sizee+1
3586 jke=joff+1+(j-jmin)+kc
3587 sende(jke)=b(i,j,k,l)
3588 END DO
3589 END DO
3590 END DO
3591 END DO
3592 END IF
3593 IF (PRESENT(c)) THEN
3594 joff=jke
3595 DO m=1,gsende
3596 mc=(m-1)*jktlen
3597 i=iend-gsende+m
3598 DO l=lbt,ubt
3599 lc=(l-lbt)*jklen+mc
3600 DO k=lbk,ubk
3601 kc=(k-lbk)*jlen+lc
3602 DO j=jmin,jmax
3603 sizee=sizee+1
3604 jke=joff+1+(j-jmin)+kc
3605 sende(jke)=c(i,j,k,l)
3606 END DO
3607 END DO
3608 END DO
3609 END DO
3610 END IF
3611 END IF
3612!
3613!-----------------------------------------------------------------------
3614! Send and receive Western and Eastern segments.
3615!-----------------------------------------------------------------------
3616!
3617# if defined MPI
3618 IF (wexchange) THEN
3619 CALL mpi_irecv (recvw, ewsize, mp_float, wtile, etag, &
3620 & ocn_comm_world, wrequest, werror)
3621 END IF
3622 IF (eexchange) THEN
3623 CALL mpi_irecv (recve, ewsize, mp_float, etile, wtag, &
3624 & ocn_comm_world, erequest, eerror)
3625 END IF
3626 IF (wexchange) THEN
3627 CALL mpi_send (sendw, sizew, mp_float, wtile, wtag, &
3628 & ocn_comm_world, werror)
3629 END IF
3630 IF (eexchange) THEN
3631 CALL mpi_send (sende, sizee, mp_float, etile, etag, &
3632 & ocn_comm_world, eerror)
3633 END IF
3634# endif
3635!
3636!-----------------------------------------------------------------------
3637! Unpack Eastern and Western segments.
3638!-----------------------------------------------------------------------
3639!
3640 IF (wexchange) THEN
3641# ifdef MPI
3642 CALL mpi_wait (wrequest, status(1,1), werror)
3643 IF (werror.ne.mpi_success) THEN
3644 CALL mpi_error_string (werror, string, lstr, ierror)
3645 lstr=len_trim(string)
3646 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
3647 & myrank, werror, string(1:lstr)
3648 20 FORMAT (/,' MP_EXCHANGE4D - error during ',a, &
3649 & ' call, Node = ',i3.3,' Error = ',i3,/,15x,a)
3650 exit_flag=2
3651 RETURN
3652 END IF
3653# endif
3654 DO m=grecvw,1,-1
3655 mc=(grecvw-m)*jktlen
3656 i=istr-m
3657 DO l=lbt,ubt
3658 lc=(l-lbt)*jklen+mc
3659 DO k=lbk,ubk
3660 kc=(k-lbk)*jlen+lc
3661 DO j=jmin,jmax
3662 jkw=1+(j-jmin)+kc
3663 a(i,j,k,l)=recvw(jkw)
3664 END DO
3665 END DO
3666 END DO
3667 END DO
3668 IF (PRESENT(b)) THEN
3669 joff=jkw
3670 DO m=grecvw,1,-1
3671 mc=(grecvw-m)*jktlen
3672 i=istr-m
3673 DO l=lbt,ubt
3674 lc=(l-lbt)*jklen+mc
3675 DO k=lbk,ubk
3676 kc=(k-lbk)*jlen+lc
3677 DO j=jmin,jmax
3678 jkw=joff+1+(j-jmin)+kc
3679 b(i,j,k,l)=recvw(jkw)
3680 END DO
3681 END DO
3682 END DO
3683 END DO
3684 END IF
3685 IF (PRESENT(c)) THEN
3686 joff=jkw
3687 DO m=grecvw,1,-1
3688 mc=(grecvw-m)*jktlen
3689 i=istr-m
3690 DO l=lbt,ubt
3691 lc=(l-lbt)*jklen+mc
3692 DO k=lbk,ubk
3693 kc=(k-lbk)*jlen+lc
3694 DO j=jmin,jmax
3695 jkw=joff+1+(j-jmin)+kc
3696 c(i,j,k,l)=recvw(jkw)
3697 END DO
3698 END DO
3699 END DO
3700 END DO
3701 END IF
3702 END IF
3703!
3704 IF (eexchange) THEN
3705# ifdef MPI
3706 CALL mpi_wait (erequest, status(1,3), eerror)
3707 IF (eerror.ne.mpi_success) THEN
3708 CALL mpi_error_string (eerror, string, lstr, ierror)
3709 lstr=len_trim(string)
3710 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
3711 & myrank, eerror, string(1:lstr)
3712 exit_flag=2
3713 RETURN
3714 END IF
3715# endif
3716 DO m=1,grecve
3717 mc=(m-1)*jktlen
3718 i=iend+m
3719 DO l=lbt,ubt
3720 lc=(l-lbt)*jklen+mc
3721 DO k=lbk,ubk
3722 kc=(k-lbk)*jlen+lc
3723 DO j=jmin,jmax
3724 jke=1+(j-jmin)+kc
3725 a(i,j,k,l)=recve(jke)
3726 END DO
3727 END DO
3728 ENDDO
3729 END DO
3730 IF (PRESENT(b)) THEN
3731 joff=jke
3732 DO m=1,grecve
3733 mc=(m-1)*jktlen
3734 i=iend+m
3735 DO l=lbt,ubt
3736 lc=(l-lbt)*jklen+mc
3737 DO k=lbk,ubk
3738 kc=(k-lbk)*jlen+lc
3739 DO j=jmin,jmax
3740 jke=joff+1+(j-jmin)+kc
3741 b(i,j,k,l)=recve(jke)
3742 END DO
3743 END DO
3744 ENDDO
3745 END DO
3746 END IF
3747 IF (PRESENT(c)) THEN
3748 joff=jke
3749 DO m=1,grecve
3750 mc=(m-1)*jktlen
3751 i=iend+m
3752 DO l=lbt,ubt
3753 lc=(l-lbt)*jklen+mc
3754 DO k=lbk,ubk
3755 kc=(k-lbk)*jlen+lc
3756 DO j=jmin,jmax
3757 jke=joff+1+(j-jmin)+kc
3758 c(i,j,k,l)=recve(jke)
3759 END DO
3760 END DO
3761 ENDDO
3762 END DO
3763 END IF
3764 END IF
3765!
3766!-----------------------------------------------------------------------
3767! Pack Southern and Northern tile boundary data including ghost-points.
3768!-----------------------------------------------------------------------
3769!
3770 IF (sexchange) THEN
3771 sizes=0
3772 DO m=1,gsends
3773 mc=(m-1)*iktlen
3774 j=jstr+m-1
3775 DO l=lbt,ubt
3776 lc=(l-lbt)*iklen+mc
3777 DO k=lbk,ubk
3778 kc=(k-lbk)*ilen+lc
3779 DO i=imin,imax
3780 sizes=sizes+1
3781 iks=1+(i-imin)+kc
3782 sends(iks)=a(i,j,k,l)
3783 END DO
3784 END DO
3785 END DO
3786 END DO
3787 IF (PRESENT(b)) THEN
3788 ioff=iks
3789 DO m=1,gsends
3790 mc=(m-1)*iktlen
3791 j=jstr+m-1
3792 DO l=lbt,ubt
3793 lc=(l-lbt)*iklen+mc
3794 DO k=lbk,ubk
3795 kc=(k-lbk)*ilen+lc
3796 DO i=imin,imax
3797 sizes=sizes+1
3798 iks=ioff+1+(i-imin)+kc
3799 sends(iks)=b(i,j,k,l)
3800 END DO
3801 END DO
3802 END DO
3803 END DO
3804 END IF
3805 IF (PRESENT(c)) THEN
3806 ioff=iks
3807 DO m=1,gsends
3808 mc=(m-1)*iktlen
3809 j=jstr+m-1
3810 DO l=lbt,ubt
3811 lc=(l-lbt)*iklen+mc
3812 DO k=lbk,ubk
3813 kc=(k-lbk)*ilen+lc
3814 DO i=imin,imax
3815 sizes=sizes+1
3816 iks=ioff+1+(i-imin)+kc
3817 sends(iks)=c(i,j,k,l)
3818 END DO
3819 END DO
3820 END DO
3821 END DO
3822 END IF
3823 END IF
3824!
3825 IF (nexchange) THEN
3826 sizen=0
3827 DO m=1,gsendn
3828 mc=(m-1)*iktlen
3829 j=jend-gsendn+m
3830 DO l=lbt,ubt
3831 lc=(l-lbt)*iklen+mc
3832 DO k=lbk,ubk
3833 kc=(k-lbk)*ilen+lc
3834 DO i=imin,imax
3835 sizen=sizen+1
3836 ikn=1+(i-imin)+kc
3837 sendn(ikn)=a(i,j,k,l)
3838 END DO
3839 END DO
3840 END DO
3841 END DO
3842 IF (PRESENT(b)) THEN
3843 ioff=ikn
3844 DO m=1,gsendn
3845 mc=(m-1)*iktlen
3846 j=jend-gsendn+m
3847 DO l=lbt,ubt
3848 lc=(l-lbt)*iklen+mc
3849 DO k=lbk,ubk
3850 kc=(k-lbk)*ilen+lc
3851 DO i=imin,imax
3852 sizen=sizen+1
3853 ikn=ioff+1+(i-imin)+kc
3854 sendn(ikn)=b(i,j,k,l)
3855 END DO
3856 END DO
3857 END DO
3858 END DO
3859 END IF
3860 IF (PRESENT(c)) THEN
3861 ioff=ikn
3862 DO m=1,gsendn
3863 mc=(m-1)*iktlen
3864 j=jend-gsendn+m
3865 DO l=lbt,ubt
3866 lc=(l-lbt)*iklen+mc
3867 DO k=lbk,ubk
3868 kc=(k-lbk)*ilen+lc
3869 DO i=imin,imax
3870 sizen=sizen+1
3871 ikn=ioff+1+(i-imin)+kc
3872 sendn(ikn)=c(i,j,k,l)
3873 END DO
3874 END DO
3875 END DO
3876 END DO
3877 END IF
3878 END IF
3879!
3880!-----------------------------------------------------------------------
3881! Send and receive Southern and Northern segments.
3882!-----------------------------------------------------------------------
3883!
3884# if defined MPI
3885 IF (sexchange) THEN
3886 CALL mpi_irecv (recvs, nssize, mp_float, stile, ntag, &
3887 & ocn_comm_world, srequest, serror)
3888 END IF
3889 IF (nexchange) THEN
3890 CALL mpi_irecv (recvn, nssize, mp_float, ntile, stag, &
3891 & ocn_comm_world, nrequest, nerror)
3892 END IF
3893 IF (sexchange) THEN
3894 CALL mpi_send (sends, sizes, mp_float, stile, stag, &
3895 & ocn_comm_world, serror)
3896 END IF
3897 IF (nexchange) THEN
3898 CALL mpi_send (sendn, sizen, mp_float, ntile, ntag, &
3899 & ocn_comm_world, nerror)
3900 END IF
3901# endif
3902!
3903!-----------------------------------------------------------------------
3904! Unpack Northern and Southern segments.
3905!-----------------------------------------------------------------------
3906!
3907 IF (sexchange) THEN
3908# ifdef MPI
3909 CALL mpi_wait (srequest, status(1,2), serror)
3910 IF (serror.ne.mpi_success) THEN
3911 CALL mpi_error_string (serror, string, lstr, ierror)
3912 lstr=len_trim(string)
3913 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
3914 & myrank, serror, string(1:lstr)
3915 exit_flag=2
3916 RETURN
3917 END IF
3918# endif
3919 DO m=grecvs,1,-1
3920 mc=(grecvs-m)*iktlen
3921 j=jstr-m
3922 DO l=lbt,ubt
3923 lc=(l-lbt)*iklen+mc
3924 DO k=lbk,ubk
3925 kc=(k-lbk)*ilen+lc
3926 DO i=imin,imax
3927 iks=1+(i-imin)+kc
3928 a(i,j,k,l)=recvs(iks)
3929 END DO
3930 END DO
3931 END DO
3932 END DO
3933 IF (PRESENT(b)) THEN
3934 ioff=iks
3935 DO m=grecvs,1,-1
3936 mc=(grecvs-m)*iktlen
3937 j=jstr-m
3938 DO l=lbt,ubt
3939 lc=(l-lbt)*iklen+mc
3940 DO k=lbk,ubk
3941 kc=(k-lbk)*ilen+lc
3942 DO i=imin,imax
3943 iks=ioff+1+(i-imin)+kc
3944 b(i,j,k,l)=recvs(iks)
3945 END DO
3946 END DO
3947 END DO
3948 END DO
3949 END IF
3950 IF (PRESENT(c)) THEN
3951 ioff=iks
3952 DO m=grecvs,1,-1
3953 mc=(grecvs-m)*iktlen
3954 j=jstr-m
3955 DO l=lbt,ubt
3956 lc=(l-lbt)*iklen+mc
3957 DO k=lbk,ubk
3958 kc=(k-lbk)*ilen+lc
3959 DO i=imin,imax
3960 iks=ioff+1+(i-imin)+kc
3961 c(i,j,k,l)=recvs(iks)
3962 END DO
3963 END DO
3964 END DO
3965 END DO
3966 END IF
3967 END IF
3968!
3969 IF (nexchange) THEN
3970# ifdef MPI
3971 CALL mpi_wait (nrequest, status(1,4), nerror)
3972 IF (nerror.ne.mpi_success) THEN
3973 CALL mpi_error_string (nerror, string, lstr, ierror)
3974 lstr=len_trim(string)
3975 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
3976 & myrank, nerror, string(1:lstr)
3977 exit_flag=2
3978 RETURN
3979 END IF
3980# endif
3981 DO m=1,grecvn
3982 mc=(m-1)*iktlen
3983 j=jend+m
3984 DO l=lbt,ubt
3985 lc=(l-lbt)*iklen+mc
3986 DO k=lbk,ubk
3987 kc=(k-lbk)*ilen+lc
3988 DO i=imin,imax
3989 ikn=1+(i-imin)+kc
3990 a(i,j,k,l)=recvn(ikn)
3991 END DO
3992 END DO
3993 END DO
3994 END DO
3995 IF (PRESENT(b)) THEN
3996 ioff=ikn
3997 DO m=1,grecvn
3998 mc=(m-1)*iktlen
3999 j=jend+m
4000 DO l=lbt,ubt
4001 lc=(l-lbt)*iklen+mc
4002 DO k=lbk,ubk
4003 kc=(k-lbk)*ilen+lc
4004 DO i=imin,imax
4005 ikn=ioff+1+(i-imin)+kc
4006 b(i,j,k,l)=recvn(ikn)
4007 END DO
4008 END DO
4009 END DO
4010 END DO
4011 END IF
4012 IF (PRESENT(c)) THEN
4013 ioff=ikn
4014 DO m=1,grecvn
4015 mc=(m-1)*iktlen
4016 j=jend+m
4017 DO l=lbt,ubt
4018 lc=(l-lbt)*iklen+mc
4019 DO k=lbk,ubk
4020 kc=(k-lbk)*ilen+lc
4021 DO i=imin,imax
4022 ikn=ioff+1+(i-imin)+kc
4023 c(i,j,k,l)=recvn(ikn)
4024 END DO
4025 END DO
4026 END DO
4027 END DO
4028 END IF
4029 END IF
4030
4031# ifdef PROFILE
4032!
4033!-----------------------------------------------------------------------
4034! Turn off time clocks.
4035!-----------------------------------------------------------------------
4036!
4037 CALL wclock_off (ng, model, 62, __line__, myfile)
4038# endif
4039!
4040 RETURN
4041 END SUBROUTINE mp_exchange4d
4042
4043# ifdef ADJOINT
4044!
4045!***********************************************************************
4046 SUBROUTINE ad_mp_exchange2d (ng, tile, model, Nvar, &
4047 & LBi, UBi, LBj, UBj, &
4048 & Nghost, EW_periodic, NS_periodic, &
4049 & ad_A, ad_B, ad_C, ad_D)
4050!***********************************************************************
4051!
4052 USE mod_param
4053 USE mod_parallel
4054 USE mod_iounits
4055 USE mod_scalars
4056!
4057 implicit none
4058!
4059! Imported variable declarations.
4060!
4061 logical, intent(in) :: EW_periodic, NS_periodic
4062!
4063 integer, intent(in) :: ng, tile, model, Nvar
4064 integer, intent(in) :: LBi, UBi, LBj, UBj
4065 integer, intent(in) :: Nghost
4066!
4067# ifdef ASSUMED_SHAPE
4068 real(r8), intent(inout) :: ad_A(LBi:,LBj:)
4069
4070 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:)
4071 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:)
4072 real(r8), intent(inout), optional :: ad_D(LBi:,LBj:)
4073# else
4074 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj)
4075
4076 real(r8), intent(inout), optional :: ad_B(LBi:UBi,LBj:UBj)
4077 real(r8), intent(inout), optional :: ad_C(LBi:UBi,LBj:UBj)
4078 real(r8), intent(inout), optional :: ad_D(LBi:UBi,LBj:UBj)
4079# endif
4080!
4081! Local variable declarations.
4082!
4083 logical :: Wexchange, Sexchange, Eexchange, Nexchange
4084!
4085 integer :: i, icS, icN, ioff, Imin, Imax, Ilen
4086 integer :: j, jcW, jcE, joff, Jmin, Jmax, Jlen
4087 integer :: m, mc, Ierror, Lstr, pp
4088 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
4089 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
4090 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
4091 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
4092 integer :: BufferSizeEW, EWsize, sizeW, sizeE
4093 integer :: BufferSizeNS, NSsize, sizeS, sizeN
4094
4095# ifdef MPI
4096 integer, dimension(MPI_STATUS_SIZE,4) :: status
4097# endif
4098!
4099 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: sendW, sendE
4100 real(r8), dimension(Nvar*HaloSizeJ(ng)) :: recvW, recvE
4101
4102 real(r8), dimension(Nvar*HaloSizeI(ng)) :: sendS, sendN
4103 real(r8), dimension(Nvar*HaloSizeI(ng)) :: recvS, recvN
4104!
4105 character (len=MPI_MAX_ERROR_STRING) :: string
4106
4107 character (len=*), parameter :: MyFile = &
4108 & __FILE__//", ad_mp_exchange2d"
4109
4110# include "set_bounds.h"
4111
4112# ifdef PROFILE
4113!
4114!-----------------------------------------------------------------------
4115! Turn on time clocks.
4116!-----------------------------------------------------------------------
4117!
4118 CALL wclock_on (ng, model, 60, __line__, myfile)
4119# endif
4120!
4121!-----------------------------------------------------------------------
4122! Determine rank of tile neighbors and number of ghost-points to
4123! exchange.
4124!-----------------------------------------------------------------------
4125!
4126! Maximum automatic buffer memory size in bytes.
4127!
4128 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
4129 & 4*SIZE(sends))*kind(ad_a),r8))
4130!
4131 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
4132 & grecvw, gsendw, wtile, wexchange, &
4133 & grecve, gsende, etile, eexchange, &
4134 & grecvs, gsends, stile, sexchange, &
4135 & grecvn, gsendn, ntile, nexchange)
4136!
4137! Set communication tags.
4138!
4139 wtag=1
4140 stag=2
4141 etag=3
4142 ntag=4
4143!
4144! Determine range and length of the distributed tile boundary segments.
4145!
4146 imin=lbi
4147 imax=ubi
4148 jmin=lbj
4149 jmax=ubj
4150 ilen=imax-imin+1
4151 jlen=jmax-jmin+1
4152 IF (ew_periodic.or.ns_periodic) THEN
4153 pp=1
4154 ELSE
4155 pp=0
4156 END IF
4157 nssize=nvar*(nghost+pp)*ilen
4158 ewsize=nvar*(nghost+pp)*jlen
4159 buffersizens=nvar*halosizei(ng)
4160 buffersizeew=nvar*halosizej(ng)
4161 IF (SIZE(sende).lt.ewsize) THEN
4162 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
4163 10 FORMAT (/,' AD_MP_EXCHANGE2D - communication buffer too', &
4164 & ' small, ',a, 2i8)
4165 END IF
4166 IF (SIZE(sendn).lt.nssize) THEN
4167 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
4168 END IF
4169!
4170!-----------------------------------------------------------------------
4171! Adjoint of unpacking Northern and Southern segments.
4172!-----------------------------------------------------------------------
4173!
4174 IF (nexchange) THEN
4175 DO i=1,buffersizens
4176 recvn(i)=0.0_r8
4177 sendn(i)=0.0_r8
4178 END DO
4179 sizen=0
4180 DO m=1,grecvn
4181 mc=(m-1)*ilen
4182 j=jend+m
4183 DO i=imin,imax
4184 sizen=sizen+1
4185 icn=1+(i-imin)+mc
4186!^ A(i,j)=recvN(icN)
4187!^
4188 recvn(icn)=ad_a(i,j)
4189 ad_a(i,j)=0.0_r8
4190 END DO
4191 END DO
4192 IF (PRESENT(ad_b)) THEN
4193 ioff=icn
4194 DO m=1,grecvn
4195 mc=(m-1)*ilen
4196 j=jend+m
4197 DO i=imin,imax
4198 sizen=sizen+1
4199 icn=ioff+1+(i-imin)+mc
4200!^ B(i,j)=recvN(icN)
4201!^
4202 recvn(icn)=ad_b(i,j)
4203 ad_b(i,j)=0.0_r8
4204 END DO
4205 END DO
4206 END IF
4207 IF (PRESENT(ad_c)) THEN
4208 ioff=icn
4209 DO m=1,grecvn
4210 mc=(m-1)*ilen
4211 j=jend+m
4212 DO i=imin,imax
4213 sizen=sizen+1
4214 icn=ioff+1+(i-imin)+mc
4215!^ C(i,j)=recvN(icN)
4216!^
4217 recvn(icn)=ad_c(i,j)
4218 ad_c(i,j)=0.0_r8
4219 END DO
4220 END DO
4221 END IF
4222 IF (PRESENT(ad_d)) THEN
4223 ioff=icn
4224 DO m=1,grecvn
4225 mc=(m-1)*ilen
4226 j=jend+m
4227 DO i=imin,imax
4228 sizen=sizen+1
4229 icn=ioff+1+(i-imin)+mc
4230!^ D(i,j)=recvN(icN)
4231!^
4232 recvn(icn)=ad_d(i,j)
4233 ad_d(i,j)=0.0_r8
4234 END DO
4235 END DO
4236 END IF
4237 END IF
4238!
4239 IF (sexchange) THEN
4240 DO i=1,buffersizens
4241 recvs(i)=0.0_r8
4242 sends(i)=0.0_r8
4243 END DO
4244 sizes=0
4245 DO m=grecvs,1,-1
4246 mc=(grecvs-m)*ilen
4247 j=jstr-m
4248 DO i=imin,imax
4249 sizes=sizes+1
4250 ics=1+(i-imin)+mc
4251!^ A(i,j)=recvS(icS)
4252!^
4253 recvs(ics)=ad_a(i,j)
4254 ad_a(i,j)=0.0_r8
4255 END DO
4256 END DO
4257 IF (PRESENT(ad_b)) THEN
4258 ioff=ics
4259 DO m=grecvs,1,-1
4260 mc=(grecvs-m)*ilen
4261 j=jstr-m
4262 DO i=imin,imax
4263 sizes=sizes+1
4264 ics=ioff+1+(i-imin)+mc
4265!^ B(i,j)=recvS(icS)
4266!^
4267 recvs(ics)=ad_b(i,j)
4268 ad_b(i,j)=0.0_r8
4269 END DO
4270 END DO
4271 END IF
4272 IF (PRESENT(ad_c)) THEN
4273 ioff=ics
4274 DO m=grecvs,1,-1
4275 mc=(grecvs-m)*ilen
4276 j=jstr-m
4277 DO i=imin,imax
4278 sizes=sizes+1
4279 ics=ioff+1+(i-imin)+mc
4280!^ C(i,j)=recvS(icS)
4281!^
4282 recvs(ics)=ad_c(i,j)
4283 ad_c(i,j)=0.0_r8
4284 END DO
4285 END DO
4286 END IF
4287 IF (PRESENT(ad_d)) THEN
4288 ioff=ics
4289 DO m=grecvs,1,-1
4290 mc=(grecvs-m)*ilen
4291 j=jstr-m
4292 DO i=imin,imax
4293 sizes=sizes+1
4294 ics=ioff+1+(i-imin)+mc
4295!^ D(i,j)=recvS(icS)
4296!^
4297 recvs(ics)=ad_d(i,j)
4298 ad_d(i,j)=0.0_r8
4299 END DO
4300 END DO
4301 END IF
4302 END IF
4303!
4304!-----------------------------------------------------------------------
4305! Adjoint of send and receive Southern and Northern segments.
4306!-----------------------------------------------------------------------
4307!
4308# if defined MPI
4309 IF (sexchange) THEN
4310!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
4311!^ & OCN_COMM_WORLD, Srequest, Serror)
4312!^
4313 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
4314 & ocn_comm_world, srequest, serror)
4315 END IF
4316 IF (nexchange) THEN
4317!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
4318!^ & OCN_COMM_WORLD, Nrequest, Nerror)
4319!^
4320 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
4321 & ocn_comm_world, nrequest, nerror)
4322 END IF
4323 IF (sexchange) THEN
4324!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
4325!^ & OCN_COMM_WORLD, Serror)
4326!^
4327 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
4328 & ocn_comm_world, serror)
4329 END IF
4330 IF (nexchange) THEN
4331!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
4332!^ & OCN_COMM_WORLD, Nerror)
4333!^
4334 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
4335 & ocn_comm_world, nerror)
4336 END IF
4337# endif
4338!
4339! Adjoint of packing tile boundary data including ghost-points.
4340!
4341 IF (sexchange) THEN
4342# ifdef MPI
4343 CALL mpi_wait (srequest, status(1,2), serror)
4344 IF (serror.ne.mpi_success) THEN
4345 CALL mpi_error_string (serror, string, lstr, ierror)
4346 lstr=len_trim(string)
4347 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
4348 & myrank, serror, string(1:lstr)
4349 20 FORMAT (/,' AD_MP_EXCHANGE2D - error during ',a,' call,', &
4350 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
4351 exit_flag=2
4352 RETURN
4353 END IF
4354# endif
4355 DO m=1,gsends
4356 mc=(m-1)*ilen
4357 j=jstr+m-1
4358 DO i=imin,imax
4359 ics=1+(i-imin)+mc
4360!^ sendS(icS)=A(i,j)
4361!^
4362 ad_a(i,j)=ad_a(i,j)+sends(ics)
4363 sends(ics)=0.0_r8
4364 END DO
4365 END DO
4366 IF (PRESENT(ad_b)) THEN
4367 ioff=ics
4368 DO m=1,gsends
4369 mc=(m-1)*ilen
4370 j=jstr+m-1
4371 DO i=imin,imax
4372 ics=ioff+1+(i-imin)+mc
4373!^ sendS(icS)=B(i,j)
4374!^
4375 ad_b(i,j)=ad_b(i,j)+sends(ics)
4376 sends(ics)=0.0_r8
4377 END DO
4378 END DO
4379 END IF
4380 IF (PRESENT(ad_c)) THEN
4381 ioff=ics
4382 DO m=1,gsends
4383 mc=(m-1)*ilen
4384 j=jstr+m-1
4385 DO i=imin,imax
4386 ics=ioff+1+(i-imin)+mc
4387!^ sendS(icS)=C(i,j)
4388!^
4389 ad_c(i,j)=ad_c(i,j)+sends(ics)
4390 sends(ics)=0.0_r8
4391 END DO
4392 END DO
4393 END IF
4394 IF (PRESENT(ad_d)) THEN
4395 ioff=ics
4396 DO m=1,gsends
4397 mc=(m-1)*ilen
4398 j=jstr+m-1
4399 DO i=imin,imax
4400 ics=ioff+1+(i-imin)+mc
4401!^ sendS(icS)=D(i,j)
4402!^
4403 ad_d(i,j)=ad_d(i,j)+sends(ics)
4404 sends(ics)=0.0_r8
4405 END DO
4406 END DO
4407 END IF
4408 END IF
4409!
4410 IF (nexchange) THEN
4411# ifdef MPI
4412 CALL mpi_wait (nrequest, status(1,4), nerror)
4413 IF (nerror.ne.mpi_success) THEN
4414 CALL mpi_error_string (nerror, string, lstr, ierror)
4415 lstr=len_trim(string)
4416 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
4417 & myrank, nerror, string(1:lstr)
4418 exit_flag=2
4419 RETURN
4420 END IF
4421# endif
4422 DO m=1,gsendn
4423 mc=(m-1)*ilen
4424 j=jend-gsendn+m
4425 DO i=imin,imax
4426 icn=1+(i-imin)+mc
4427!^ sendN(icN)=A(i,j)
4428!^
4429 ad_a(i,j)=ad_a(i,j)+sendn(icn)
4430 sendn(icn)=0.0_r8
4431 END DO
4432 END DO
4433 IF (PRESENT(ad_b)) THEN
4434 ioff=icn
4435 DO m=1,gsendn
4436 mc=(m-1)*ilen
4437 j=jend-gsendn+m
4438 DO i=imin,imax
4439 icn=ioff+1+(i-imin)+mc
4440!^ sendN(icN)=B(i,j)
4441!^
4442 ad_b(i,j)=ad_b(i,j)+sendn(icn)
4443 sendn(icn)=0.0_r8
4444 END DO
4445 END DO
4446 END IF
4447 IF (PRESENT(ad_c)) THEN
4448 ioff=icn
4449 DO m=1,gsendn
4450 mc=(m-1)*ilen
4451 j=jend-gsendn+m
4452 DO i=imin,imax
4453 icn=ioff+1+(i-imin)+mc
4454!^ sendN(icN)=C(i,Jend-GsendN+m)
4455!^
4456 ad_c(i,j)=ad_c(i,j)+sendn(icn)
4457 sendn(icn)=0.0_r8
4458 END DO
4459 END DO
4460 END IF
4461 IF (PRESENT(ad_d)) THEN
4462 ioff=icn
4463 DO m=1,gsendn
4464 mc=(m-1)*ilen
4465 j=jend-gsendn+m
4466 DO i=imin,imax
4467 icn=ioff+1+(i-imin)+mc
4468!^ sendN(icN)=D(i,j)
4469!^
4470 ad_d(i,j)=ad_d(i,j)+sendn(icn)
4471 sendn(icn)=0.0_r8
4472 END DO
4473 END DO
4474 END IF
4475 END IF
4476!
4477!-----------------------------------------------------------------------
4478! Adjoint of unpack Eastern and Western segments.
4479!-----------------------------------------------------------------------
4480!
4481 IF (eexchange) THEN
4482 DO i=1,buffersizeew
4483 recve(i)=0.0_r8
4484 sende(i)=0.0_r8
4485 END DO
4486 sizee=0
4487 DO m=1,grecve
4488 mc=(m-1)*jlen
4489 i=iend+m
4490 DO j=jmin,jmax
4491 sizee=sizee+1
4492 jce=1+(j-jmin)+mc
4493!^ A(i,j)=recvE(jcE)
4494!^
4495 recve(jce)=ad_a(i,j)
4496 ad_a(i,j)=0.0_r8
4497 ENDDO
4498 END DO
4499 IF (PRESENT(ad_b)) THEN
4500 joff=jce
4501 DO m=1,grecve
4502 mc=(m-1)*jlen
4503 i=iend+m
4504 DO j=jmin,jmax
4505 sizee=sizee+1
4506 jce=joff+1+(j-jmin)+mc
4507!^ B(i,j)=recvE(jcE)
4508!^
4509 recve(jce)=ad_b(i,j)
4510 ad_b(i,j)=0.0_r8
4511 END DO
4512 END DO
4513 END IF
4514 IF (PRESENT(ad_c)) THEN
4515 joff=jce
4516 DO m=1,grecve
4517 mc=(m-1)*jlen
4518 i=iend+m
4519 DO j=jmin,jmax
4520 sizee=sizee+1
4521 jce=joff+1+(j-jmin)+mc
4522!^ C(i,j)=recvE(jcE)
4523!^
4524 recve(jce)=ad_c(i,j)
4525 ad_c(i,j)=0.0_r8
4526 END DO
4527 END DO
4528 END IF
4529 IF (PRESENT(ad_d)) THEN
4530 joff=jce
4531 DO m=1,grecve
4532 mc=(m-1)*jlen
4533 i=iend+m
4534 DO j=jmin,jmax
4535 sizee=sizee+1
4536 jce=joff+1+(j-jmin)+mc
4537!^ D(i,j)=recvE(jcE)
4538!^
4539 recve(jce)=ad_d(i,j)
4540 ad_d(i,j)=0.0_r8
4541 END DO
4542 END DO
4543 END IF
4544 END IF
4545!
4546 IF (wexchange) THEN
4547 DO i=1,buffersizeew
4548 recvw(i)=0.0_r8
4549 sendw(i)=0.0_r8
4550 END DO
4551 sizew=0
4552 DO m=grecvw,1,-1
4553 mc=(grecvw-m)*jlen
4554 i=istr-m
4555 DO j=jmin,jmax
4556 sizew=sizew+1
4557 jcw=1+(j-jmin)+mc
4558!^ A(i,j)=recvW(jcW)
4559!^
4560 recvw(jcw)=ad_a(i,j)
4561 ad_a(i,j)=0.0_r8
4562 END DO
4563 END DO
4564 IF (PRESENT(ad_b)) THEN
4565 joff=jcw
4566 DO m=grecvw,1,-1
4567 mc=(grecvw-m)*jlen
4568 i=istr-m
4569 DO j=jmin,jmax
4570 sizew=sizew+1
4571 jcw=joff+1+(j-jmin)+mc
4572!^ B(i,j)=recvW(jcW)
4573!^
4574 recvw(jcw)=ad_b(i,j)
4575 ad_b(i,j)=0.0_r8
4576 END DO
4577 END DO
4578 END IF
4579 IF (PRESENT(ad_c)) THEN
4580 joff=jcw
4581 DO m=grecvw,1,-1
4582 mc=(grecvw-m)*jlen
4583 i=istr-m
4584 DO j=jmin,jmax
4585 sizew=sizew+1
4586 jcw=joff+1+(j-jmin)+mc
4587!^ C(i,j)=recvW(jcW)
4588!^
4589 recvw(jcw)=ad_c(i,j)
4590 ad_c(i,j)=0.0_r8
4591 END DO
4592 END DO
4593 END IF
4594 IF (PRESENT(ad_d)) THEN
4595 joff=jcw
4596 DO m=grecvw,1,-1
4597 mc=(grecvw-m)*jlen
4598 i=istr-m
4599 DO j=jmin,jmax
4600 sizew=sizew+1
4601 jcw=joff+1+(j-jmin)+mc
4602!^ D(i,j)=recvW(jcW)
4603!^
4604 recvw(jcw)=ad_d(i,j)
4605 ad_d(i,j)=0.0_r8
4606 END DO
4607 END DO
4608 END IF
4609 END IF
4610!
4611!-----------------------------------------------------------------------
4612! Send and receive Western and Eastern segments.
4613!-----------------------------------------------------------------------
4614!
4615# if defined MPI
4616 IF (wexchange) THEN
4617!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
4618!^ & OCN_COMM_WORLD, Wrequest, Werror)
4619!^
4620 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
4621 & ocn_comm_world, wrequest, werror)
4622 END IF
4623 IF (eexchange) THEN
4624!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
4625!^ & OCN_COMM_WORLD, Erequest, Eerror)
4626!^
4627 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
4628 & ocn_comm_world, erequest, eerror)
4629 END IF
4630 IF (wexchange) THEN
4631!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
4632!^ & OCN_COMM_WORLD, Werror)
4633!^
4634 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
4635 & ocn_comm_world, werror)
4636 END IF
4637 IF (eexchange) THEN
4638!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
4639!^ & OCN_COMM_WORLD, Eerror)
4640!^
4641 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
4642 & ocn_comm_world, eerror)
4643 END IF
4644# endif
4645!
4646! Adjoint of packing tile boundary data including ghost-points.
4647!
4648 IF (wexchange) THEN
4649# ifdef MPI
4650 CALL mpi_wait (wrequest, status(1,1), werror)
4651 IF (werror.ne.mpi_success) THEN
4652 CALL mpi_error_string (werror, string, lstr, ierror)
4653 lstr=len_trim(string)
4654 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
4655 & myrank, werror, string(1:lstr)
4656 exit_flag=2
4657 RETURN
4658 END IF
4659# endif
4660 DO m=1,gsendw
4661 mc=(m-1)*jlen
4662 i=istr+m-1
4663 DO j=jmin,jmax
4664 jcw=1+(j-jmin)+mc
4665!^ sendW(jcW)=A(i,j)
4666!^
4667 ad_a(i,j)=ad_a(i,j)+sendw(jcw)
4668 sendw(jcw)=0.0_r8
4669 END DO
4670 END DO
4671 IF (PRESENT(ad_b)) THEN
4672 joff=jcw
4673 DO m=1,gsendw
4674 mc=(m-1)*jlen
4675 i=istr+m-1
4676 DO j=jmin,jmax
4677 jcw=joff+1+(j-jmin)+mc
4678!^ sendW(jcW)=B(i,j)
4679!^
4680 ad_b(i,j)=ad_b(i,j)+sendw(jcw)
4681 sendw(jcw)=0.0_r8
4682 END DO
4683 END DO
4684 END IF
4685 IF (PRESENT(ad_c)) THEN
4686 joff=jcw
4687 DO m=1,gsendw
4688 mc=(m-1)*jlen
4689 i=istr+m-1
4690 DO j=jmin,jmax
4691 jcw=joff+1+(j-jmin)+mc
4692!^ sendW(jcW)=C(i,j)
4693!^
4694 ad_c(i,j)=ad_c(i,j)+sendw(jcw)
4695 sendw(jcw)=0.0_r8
4696 END DO
4697 END DO
4698 END IF
4699 IF (PRESENT(ad_d)) THEN
4700 joff=jcw
4701 DO m=1,gsendw
4702 mc=(m-1)*jlen
4703 i=istr+m-1
4704 DO j=jmin,jmax
4705 jcw=joff+1+(j-jmin)+mc
4706!^ sendW(jcW)=D(i,j)
4707!^
4708 ad_d(i,j)=ad_d(i,j)+sendw(jcw)
4709 sendw(jcw)=0.0_r8
4710 END DO
4711 END DO
4712 END IF
4713 END IF
4714!
4715 IF (eexchange) THEN
4716# ifdef MPI
4717 CALL mpi_wait (erequest, status(1,3), eerror)
4718 IF (eerror.ne.mpi_success) THEN
4719 CALL mpi_error_string (eerror, string, lstr, ierror)
4720 lstr=len_trim(string)
4721 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
4722 & myrank, eerror, string(1:lstr)
4723 exit_flag=2
4724 RETURN
4725 END IF
4726# endif
4727 DO m=1,gsende
4728 mc=(m-1)*jlen
4729 i=iend-gsende+m
4730 DO j=jmin,jmax
4731 jce=1+(j-jmin)+mc
4732!^ sendE(jcE)=A(i,j)
4733!^
4734 ad_a(i,j)=ad_a(i,j)+sende(jce)
4735 sende(jce)=0.0_r8
4736 END DO
4737 END DO
4738 IF (PRESENT(ad_b)) THEN
4739 joff=jce
4740 DO m=1,gsende
4741 mc=(m-1)*jlen
4742 i=iend-gsende+m
4743 DO j=jmin,jmax
4744 jce=joff+1+(j-jmin)+mc
4745!^ sendE(jcE)=B(i,j)
4746!^
4747 ad_b(i,j)=ad_b(i,j)+sende(jce)
4748 sende(jce)=0.0_r8
4749 END DO
4750 END DO
4751 END IF
4752 IF (PRESENT(ad_c)) THEN
4753 joff=jce
4754 DO m=1,gsende
4755 mc=(m-1)*jlen
4756 i=iend-gsende+m
4757 DO j=jmin,jmax
4758 jce=joff+1+(j-jmin)+mc
4759!^ sendE(jcE)=C(i,j)
4760!^
4761 ad_c(i,j)=ad_c(i,j)+sende(jce)
4762 sende(jce)=0.0_r8
4763 END DO
4764 END DO
4765 END IF
4766 IF (PRESENT(ad_d)) THEN
4767 joff=jce
4768 DO m=1,gsende
4769 mc=(m-1)*jlen
4770 i=iend-gsende+m
4771 DO j=jmin,jmax
4772 jce=joff+1+(j-jmin)+mc
4773!^ sendE(jcE)=D(i,j)
4774!^
4775 ad_d(i,j)=ad_d(i,j)+sende(jce)
4776 sende(jce)=0.0_r8
4777 END DO
4778 END DO
4779 END IF
4780 END IF
4781
4782# ifdef PROFILE
4783!
4784!-----------------------------------------------------------------------
4785! Turn off time clocks.
4786!-----------------------------------------------------------------------
4787!
4788 CALL wclock_off (ng, model, 60, __line__, myfile)
4789# endif
4790!
4791 RETURN
4792 END SUBROUTINE ad_mp_exchange2d
4793
4794!
4795!***********************************************************************
4796 SUBROUTINE ad_mp_exchange2d_bry (ng, tile, model, Nvar, boundary, &
4797 & LBij, UBij, &
4798 & Nghost, EW_periodic, NS_periodic,&
4799 & ad_A, ad_B, ad_C, ad_D)
4800!***********************************************************************
4801!
4802 USE mod_param
4803 USE mod_parallel
4804 USE mod_iounits
4805 USE mod_scalars
4806!
4807 implicit none
4808!
4809! Imported variable declarations.
4810!
4811 logical, intent(in) :: EW_periodic, NS_periodic
4812!
4813 integer, intent(in) :: ng, tile, model, Nvar, boundary
4814 integer, intent(in) :: LBij, UBij
4815 integer, intent(in) :: Nghost
4816!
4817# ifdef ASSUMED_SHAPE
4818 real(r8), intent(inout) :: ad_A(LBij:)
4819
4820 real(r8), intent(inout), optional :: ad_B(LBij:)
4821 real(r8), intent(inout), optional :: ad_C(LBij:)
4822 real(r8), intent(inout), optional :: ad_D(LBij:)
4823# else
4824 real(r8), intent(inout) :: ad_A(LBij:UBij)
4825
4826 real(r8), intent(inout), optional :: ad_B(LBij:UBij)
4827 real(r8), intent(inout), optional :: ad_C(LBij:UBij)
4828 real(r8), intent(inout), optional :: ad_D(LBij:UBij)
4829# endif
4830!
4831! Local variable declarations.
4832!
4833 logical :: Wexchange, Sexchange, Eexchange, Nexchange
4834!
4835 integer :: i, icS, icN
4836 integer :: j, jcW, jcE
4837 integer :: m, Ierror, Lstr, pp
4838 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
4839 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
4840 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
4841 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
4842 integer :: BufferSizeEW, EWsize, sizeW, sizeE
4843 integer :: BufferSizeNS, NSsize, sizeS, sizeN
4844
4845# ifdef MPI
4846 integer, dimension(MPI_STATUS_SIZE,4) :: status
4847# endif
4848!
4849 real(r8), dimension(Nvar*HaloBry(ng)) :: sendW, sendE
4850 real(r8), dimension(Nvar*HaloBry(ng)) :: recvW, recvE
4851
4852 real(r8), dimension(Nvar*HaloBry(ng)) :: sendS, sendN
4853 real(r8), dimension(Nvar*HaloBry(ng)) :: recvS, recvN
4854!
4855 character (len=MPI_MAX_ERROR_STRING) :: string
4856
4857 character (len=*), parameter :: MyFile = &
4858 & __FILE__//", ad_mp_exchange2d_bry"
4859
4860# include "set_bounds.h"
4861
4862# ifdef PROFILE
4863!
4864!-----------------------------------------------------------------------
4865! Turn on time clocks.
4866!-----------------------------------------------------------------------
4867!
4868 CALL wclock_on (ng, model, 63, __line__, myfile)
4869# endif
4870!
4871!-----------------------------------------------------------------------
4872! Determine rank of tile neighbors and number of ghost-points to
4873! exchange.
4874!-----------------------------------------------------------------------
4875!
4876! Maximum automatic buffer memory size in bytes.
4877!
4878 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
4879 & 4*SIZE(sends))*kind(ad_a),r8))
4880!
4881 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
4882 & grecvw, gsendw, wtile, wexchange, &
4883 & grecve, gsende, etile, eexchange, &
4884 & grecvs, gsends, stile, sexchange, &
4885 & grecvn, gsendn, ntile, nexchange)
4886!
4887! Adjust exchange swiches according to boundary edge to process.
4888!
4889 wexchange=wexchange.and.((boundary.eq.isouth).or. &
4890 & (boundary.eq.inorth))
4891 eexchange=eexchange.and.((boundary.eq.isouth).or. &
4892 & (boundary.eq.inorth))
4893 sexchange=sexchange.and.((boundary.eq.iwest).or. &
4894 & (boundary.eq.ieast))
4895 nexchange=nexchange.and.((boundary.eq.iwest).or. &
4896 & (boundary.eq.ieast))
4897!
4898! Set communication tags.
4899!
4900 wtag=1
4901 stag=2
4902 etag=3
4903 ntag=4
4904!
4905! Determine range and length of the distributed tile boundary segments.
4906!
4907 IF (ew_periodic.or.ns_periodic) THEN
4908 pp=1
4909 ELSE
4910 pp=0
4911 END IF
4912 nssize=nvar*(nghost+pp)
4913 ewsize=nvar*(nghost+pp)
4914 buffersizens=nvar*(nghost+pp)
4915 buffersizeew=nvar*(nghost+pp)
4916 IF (SIZE(sende).lt.ewsize) THEN
4917 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
4918 10 FORMAT (/,' AD_MP_EXCHANGE2D_BRY - communication buffer too', &
4919 & ' small, ',a, 2i8)
4920 END IF
4921 IF (SIZE(sendn).lt.nssize) THEN
4922 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
4923 END IF
4924!
4925!-----------------------------------------------------------------------
4926! Adjoint of unpacking Northern and Southern segments.
4927!-----------------------------------------------------------------------
4928!
4929 IF (nexchange) THEN
4930 DO i=1,buffersizens
4931 recvn(i)=0.0_r8
4932 sendn(i)=0.0_r8
4933 END DO
4934 icn=0
4935 sizen=0
4936 DO m=1,grecvn
4937 j=jend+m
4938 sizen=sizen+1
4939 icn=icn+1
4940!^ A(j)=recvN(icN)
4941!^
4942 recvn(icn)=ad_a(j)
4943 ad_a(j)=0.0_r8
4944 END DO
4945 IF (PRESENT(ad_b)) THEN
4946 DO m=1,grecvn
4947 j=jend+m
4948 sizen=sizen+1
4949 icn=icn+1
4950!^ B(j)=recvN(icN)
4951!^
4952 recvn(icn)=ad_b(j)
4953 ad_b(j)=0.0_r8
4954 END DO
4955 END IF
4956 IF (PRESENT(ad_c)) THEN
4957 DO m=1,grecvn
4958 j=jend+m
4959 sizen=sizen+1
4960 icn=icn+1
4961!^ C(j)=recvN(icN)
4962!^
4963 recvn(icn)=ad_c(j)
4964 ad_c(j)=0.0_r8
4965 END DO
4966 END IF
4967 IF (PRESENT(ad_d)) THEN
4968 DO m=1,grecvn
4969 j=jend+m
4970 sizen=sizen+1
4971 icn=icn+1
4972!^ D(j)=recvN(icN)
4973!^
4974 recvn(icn)=ad_d(j)
4975 ad_d(j)=0.0_r8
4976 END DO
4977 END IF
4978 END IF
4979!
4980 IF (sexchange) THEN
4981 DO i=1,buffersizens
4982 recvs(i)=0.0_r8
4983 sends(i)=0.0_r8
4984 END DO
4985 ics=0
4986 sizes=0
4987 DO m=grecvs,1,-1
4988 j=jstr-m
4989 sizes=sizes+1
4990 ics=ics+1
4991!^ A(j)=recvS(icS)
4992!^
4993 recvs(ics)=ad_a(j)
4994 ad_a(j)=0.0_r8
4995 END DO
4996 IF (PRESENT(ad_b)) THEN
4997 DO m=grecvs,1,-1
4998 j=jstr-m
4999 sizes=sizes+1
5000 ics=ics+1
5001!^ B(j)=recvS(icS)
5002!^
5003 recvs(ics)=ad_b(j)
5004 ad_b(j)=0.0_r8
5005 END DO
5006 END IF
5007 IF (PRESENT(ad_c)) THEN
5008 DO m=grecvs,1,-1
5009 j=jstr-m
5010 sizes=sizes+1
5011 ics=ics+1
5012!^ C(j)=recvS(icS)
5013!^
5014 recvs(ics)=ad_c(j)
5015 ad_c(j)=0.0_r8
5016 END DO
5017 END IF
5018 IF (PRESENT(ad_d)) THEN
5019 DO m=grecvs,1,-1
5020 j=jstr-m
5021 sizes=sizes+1
5022 ics=ics+1
5023!^ D(j)=recvS(icS)
5024!^
5025 recvs(ics)=ad_d(j)
5026 ad_d(j)=0.0_r8
5027 END DO
5028 END IF
5029 END IF
5030!
5031!-----------------------------------------------------------------------
5032! Adjoint of send and receive Southern and Northern segments.
5033!-----------------------------------------------------------------------
5034!
5035# if defined MPI
5036 IF (sexchange) THEN
5037!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
5038!^ & OCN_COMM_WORLD, Srequest, Serror)
5039!^
5040 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
5041 & ocn_comm_world, srequest, serror)
5042 END IF
5043 IF (nexchange) THEN
5044!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
5045!^ & OCN_COMM_WORLD, Nrequest, Nerror)
5046!^
5047 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
5048 & ocn_comm_world, nrequest, nerror)
5049 END IF
5050 IF (sexchange) THEN
5051!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
5052!^ & OCN_COMM_WORLD, Serror)
5053!^
5054 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
5055 & ocn_comm_world, serror)
5056 END IF
5057 IF (nexchange) THEN
5058!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
5059!^ & OCN_COMM_WORLD, Nerror)
5060!^
5061 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
5062 & ocn_comm_world, nerror)
5063 END IF
5064# endif
5065!
5066! Adjoint of packing tile boundary data including ghost-points.
5067!
5068 IF (sexchange) THEN
5069# ifdef MPI
5070 CALL mpi_wait (srequest, status(1,2), serror)
5071 IF (serror.ne.mpi_success) THEN
5072 CALL mpi_error_string (serror, string, lstr, ierror)
5073 lstr=len_trim(string)
5074 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
5075 & myrank, serror, string(1:lstr)
5076 20 FORMAT (/,' AD_MP_EXCHANGE2D_BRY - error during ',a,' call,', &
5077 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
5078 exit_flag=2
5079 RETURN
5080 END IF
5081# endif
5082 ics=0
5083 DO m=1,gsends
5084 j=jstr+m-1
5085 ics=ics+1
5086!^ sendS(icS)=A(j)
5087!^
5088 ad_a(j)=ad_a(j)+sends(ics)
5089 sends(ics)=0.0_r8
5090 END DO
5091 IF (PRESENT(ad_b)) THEN
5092 DO m=1,gsends
5093 j=jstr+m-1
5094 ics=ics+1
5095!^ sendS(icS)=B(j)
5096!^
5097 ad_b(j)=ad_b(j)+sends(ics)
5098 sends(ics)=0.0_r8
5099 END DO
5100 END IF
5101 IF (PRESENT(ad_c)) THEN
5102 DO m=1,gsends
5103 j=jstr+m-1
5104 ics=ics+1
5105!^ sendS(icS)=C(j)
5106!^
5107 ad_c(j)=ad_c(j)+sends(ics)
5108 sends(ics)=0.0_r8
5109 END DO
5110 END IF
5111 IF (PRESENT(ad_d)) THEN
5112 DO m=1,gsends
5113 j=jstr+m-1
5114 ics=ics+1
5115!^ sendS(icS)=D(j)
5116!^
5117 ad_d(j)=ad_d(j)+sends(ics)
5118 sends(ics)=0.0_r8
5119 END DO
5120 END IF
5121 END IF
5122!
5123 IF (nexchange) THEN
5124# ifdef MPI
5125 CALL mpi_wait (nrequest, status(1,4), nerror)
5126 IF (nerror.ne.mpi_success) THEN
5127 CALL mpi_error_string (nerror, string, lstr, ierror)
5128 lstr=len_trim(string)
5129 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
5130 & myrank, nerror, string(1:lstr)
5131 exit_flag=2
5132 RETURN
5133 END IF
5134# endif
5135 icn=0
5136 DO m=1,gsendn
5137 j=jend-gsendn+m
5138 icn=icn+1
5139!^ sendN(icN)=A(j)
5140!^
5141 ad_a(j)=ad_a(j)+sendn(icn)
5142 sendn(icn)=0.0_r8
5143 END DO
5144 IF (PRESENT(ad_b)) THEN
5145 DO m=1,gsendn
5146 j=jend-gsendn+m
5147 icn=icn+1
5148!^ sendN(icN)=B(j)
5149!^
5150 ad_b(j)=ad_b(j)+sendn(icn)
5151 sendn(icn)=0.0_r8
5152 END DO
5153 END IF
5154 IF (PRESENT(ad_c)) THEN
5155 DO m=1,gsendn
5156 j=jend-gsendn+m
5157 icn=icn+1
5158!^ sendN(icN)=C(j)
5159!^
5160 ad_c(j)=ad_c(j)+sendn(icn)
5161 sendn(icn)=0.0_r8
5162 END DO
5163 END IF
5164 IF (PRESENT(ad_d)) THEN
5165 DO m=1,gsendn
5166 j=jend-gsendn+m
5167 icn=icn+1
5168!^ sendN(icN)=D(j)
5169!^
5170 ad_d(j)=ad_d(j)+sendn(icn)
5171 sendn(icn)=0.0_r8
5172 END DO
5173 END IF
5174 END IF
5175!
5176!-----------------------------------------------------------------------
5177! Adjoint of unpack Eastern and Western segments.
5178!-----------------------------------------------------------------------
5179!
5180 IF (eexchange) THEN
5181 DO i=1,buffersizeew
5182 recve(i)=0.0_r8
5183 sende(i)=0.0_r8
5184 END DO
5185 jce=0
5186 sizee=0
5187 DO m=1,grecve
5188 i=iend+m
5189 sizee=sizee+1
5190 jce=jce+1
5191!^ A(i)=recvE(jcE)
5192!^
5193 recve(jce)=ad_a(i)
5194 ad_a(i)=0.0_r8
5195 END DO
5196 IF (PRESENT(ad_b)) THEN
5197 DO m=1,grecve
5198 i=iend+m
5199 sizee=sizee+1
5200 jce=jce+1
5201!^ B(i)=recvE(jcE)
5202!^
5203 recve(jce)=ad_b(i)
5204 ad_b(i)=0.0_r8
5205 END DO
5206 END IF
5207 IF (PRESENT(ad_c)) THEN
5208 DO m=1,grecve
5209 i=iend+m
5210 sizee=sizee+1
5211 jce=jce+1
5212!^ C(i)=recvE(jcE)
5213!^
5214 recve(jce)=ad_c(i)
5215 ad_c(i)=0.0_r8
5216 END DO
5217 END IF
5218 IF (PRESENT(ad_d)) THEN
5219 DO m=1,grecve
5220 i=iend+m
5221 sizee=sizee+1
5222 jce=jce+1
5223!^ D(i)=recvE(jcE)
5224!^
5225 recve(jce)=ad_d(i)
5226 ad_d(i)=0.0_r8
5227 END DO
5228 END IF
5229 END IF
5230!
5231 IF (wexchange) THEN
5232 DO i=1,buffersizeew
5233 recvw(i)=0.0_r8
5234 sendw(i)=0.0_r8
5235 END DO
5236 jcw=0
5237 sizew=0
5238 DO m=grecvw,1,-1
5239 i=istr-m
5240 sizew=sizew+1
5241 jcw=jcw+1
5242!^ A(i)=recvW(jcW)
5243!^
5244 recvw(jcw)=ad_a(i)
5245 ad_a(i)=0.0_r8
5246 END DO
5247 IF (PRESENT(ad_b)) THEN
5248 DO m=grecvw,1,-1
5249 i=istr-m
5250 sizew=sizew+1
5251 jcw=jcw+1
5252!^ B(i)=recvW(jcW)
5253!^
5254 recvw(jcw)=ad_b(i)
5255 ad_b(i)=0.0_r8
5256 END DO
5257 END IF
5258 IF (PRESENT(ad_c)) THEN
5259 DO m=grecvw,1,-1
5260 i=istr-m
5261 sizew=sizew+1
5262 jcw=jcw+1
5263!^ C(i)=recvW(jcW)
5264!^
5265 recvw(jcw)=ad_c(i)
5266 ad_c(i)=0.0_r8
5267 END DO
5268 END IF
5269 IF (PRESENT(ad_d)) THEN
5270 DO m=grecvw,1,-1
5271 i=istr-m
5272 sizew=sizew+1
5273 jcw=jcw+1
5274!^ D(i)=recvW(jcW)
5275!^
5276 recvw(jcw)=ad_d(i)
5277 ad_d(i)=0.0_r8
5278 END DO
5279 END IF
5280 END IF
5281!
5282!-----------------------------------------------------------------------
5283! Send and receive Western and Eastern segments.
5284!-----------------------------------------------------------------------
5285!
5286# if defined MPI
5287 IF (wexchange) THEN
5288!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
5289!^ & OCN_COMM_WORLD, Wrequest, Werror)
5290!^
5291 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
5292 & ocn_comm_world, wrequest, werror)
5293 END IF
5294 IF (eexchange) THEN
5295!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
5296!^ & OCN_COMM_WORLD, Erequest, Eerror)
5297!^
5298 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
5299 & ocn_comm_world, erequest, eerror)
5300 END IF
5301 IF (wexchange) THEN
5302!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
5303!^ & OCN_COMM_WORLD, Werror)
5304!^
5305 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
5306 & ocn_comm_world, werror)
5307 END IF
5308 IF (eexchange) THEN
5309!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
5310!^ & OCN_COMM_WORLD, Eerror)
5311!^
5312 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
5313 & ocn_comm_world, eerror)
5314 END IF
5315# endif
5316!
5317! Adjoint of packing tile boundary data including ghost-points.
5318!
5319 IF (wexchange) THEN
5320# ifdef MPI
5321 CALL mpi_wait (wrequest, status(1,1), werror)
5322 IF (werror.ne.mpi_success) THEN
5323 CALL mpi_error_string (werror, string, lstr, ierror)
5324 lstr=len_trim(string)
5325 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
5326 & myrank, werror, string(1:lstr)
5327 exit_flag=2
5328 RETURN
5329 END IF
5330# endif
5331 jcw=0
5332 DO m=1,gsendw
5333 i=istr+m-1
5334 jcw=jcw+1
5335!^ sendW(jcW)=A(i)
5336!^
5337 ad_a(i)=ad_a(i)+sendw(jcw)
5338 sendw(jcw)=0.0_r8
5339 END DO
5340 IF (PRESENT(ad_b)) THEN
5341 DO m=1,gsendw
5342 i=istr+m-1
5343 jcw=jcw+1
5344!^ sendW(jcW)=B(i)
5345!^
5346 ad_b(i)=ad_b(i)+sendw(jcw)
5347 sendw(jcw)=0.0_r8
5348 END DO
5349 END IF
5350 IF (PRESENT(ad_c)) THEN
5351 DO m=1,gsendw
5352 i=istr+m-1
5353 jcw=jcw+1
5354!^ sendW(jcW)=C(i)
5355!^
5356 ad_c(i)=ad_c(i)+sendw(jcw)
5357 sendw(jcw)=0.0_r8
5358 END DO
5359 END IF
5360 IF (PRESENT(ad_d)) THEN
5361 DO m=1,gsendw
5362 i=istr+m-1
5363 jcw=jcw+1
5364!^ sendW(jcW)=D(i)
5365!^
5366 ad_d(i)=ad_d(i)+sendw(jcw)
5367 sendw(jcw)=0.0_r8
5368 END DO
5369 END IF
5370 END IF
5371!
5372 IF (eexchange) THEN
5373# ifdef MPI
5374 CALL mpi_wait (erequest, status(1,3), eerror)
5375 IF (eerror.ne.mpi_success) THEN
5376 CALL mpi_error_string (eerror, string, lstr, ierror)
5377 lstr=len_trim(string)
5378 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
5379 & myrank, eerror, string(1:lstr)
5380 exit_flag=2
5381 RETURN
5382 END IF
5383# endif
5384 jce=0
5385 DO m=1,gsende
5386 i=iend-gsende+m
5387 jce=jce+1
5388!^ sendE(jcE)=A(i)
5389!^
5390 ad_a(i)=ad_a(i)+sende(jce)
5391 sende(jce)=0.0_r8
5392 END DO
5393 IF (PRESENT(ad_b)) THEN
5394 DO m=1,gsende
5395 i=iend-gsende+m
5396 jce=jce+1
5397!^ sendE(jcE)=B(i)
5398!^
5399 ad_b(i)=ad_b(i)+sende(jce)
5400 sende(jce)=0.0_r8
5401 END DO
5402 END IF
5403 IF (PRESENT(ad_c)) THEN
5404 DO m=1,gsende
5405 i=iend-gsende+m
5406 jce=jce+1
5407!^ sendE(jcE)=C(i)
5408!^
5409 ad_c(i)=ad_c(i)+sende(jce)
5410 sende(jce)=0.0_r8
5411 END DO
5412 END IF
5413 IF (PRESENT(ad_d)) THEN
5414 DO m=1,gsende
5415 i=iend-gsende+m
5416 jce=jce+1
5417!^ sendE(jcE)=D(i)
5418!^
5419 ad_d(i)=ad_d(i)+sende(jce)
5420 sende(jce)=0.0_r8
5421 END DO
5422 END IF
5423 END IF
5424
5425# ifdef PROFILE
5426!
5427!-----------------------------------------------------------------------
5428! Turn off time clocks.
5429!-----------------------------------------------------------------------
5430!
5431 CALL wclock_off (ng, model, 63, __line__, myfile)
5432# endif
5433!
5434 RETURN
5435 END SUBROUTINE ad_mp_exchange2d_bry
5436
5437!
5438!***********************************************************************
5439 SUBROUTINE ad_mp_exchange3d (ng, tile, model, Nvar, &
5440 & LBi, UBi, LBj, UBj, LBk, UBk, &
5441 & Nghost, EW_periodic, NS_periodic, &
5442 & ad_A, ad_B, ad_C, ad_D)
5443!***********************************************************************
5444!
5445 USE mod_param
5446 USE mod_parallel
5447 USE mod_iounits
5448 USE mod_scalars
5449!
5450 implicit none
5451!
5452! Imported variable declarations.
5453!
5454 logical, intent(in) :: EW_periodic, NS_periodic
5455!
5456 integer, intent(in) :: ng, tile, model, Nvar
5457 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
5458 integer, intent(in) :: Nghost
5459!
5460# ifdef ASSUMED_SHAPE
5461 real(r8), intent(inout) :: ad_A(LBi:,LBj:,LBk:)
5462
5463 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:,LBk:)
5464 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:,LBk:)
5465 real(r8), intent(inout), optional :: ad_D(LBi:,LBj:,LBk:)
5466# else
5467 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj,LBk:UBk)
5468
5469 real(r8), intent(inout), optional :: ad_B(LBi:UBi,LBj:UBj,LBk:UBk)
5470 real(r8), intent(inout), optional :: ad_C(LBi:UBi,LBj:UBj,LBk:UBk)
5471 real(r8), intent(inout), optional :: ad_D(LBi:UBi,LBj:UBj,LBk:UBk)
5472# endif
5473!
5474! Local variable declarations.
5475!
5476 logical :: Wexchange, Sexchange, Eexchange, Nexchange
5477!
5478 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen
5479 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen
5480 integer :: k, kc, m, mc, Ierror, Klen, Lstr, pp
5481 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
5482 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
5483 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
5484 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
5485 integer :: BufferSizeEW, EWsize, sizeW, sizeE
5486 integer :: BufferSizeNS, NSsize, sizeS, sizeN
5487
5488# ifdef MPI
5489 integer, dimension(MPI_STATUS_SIZE,4) :: status
5490# endif
5491!
5492 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: sendW, sendE
5493 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: sendS, sendN
5494
5495 real(r8), dimension(Nvar*HaloSizeJ(ng)* & & (UBk-LBk+1)) :: recvW, recvE
5496 real(r8), dimension(Nvar*HaloSizeI(ng)* & & (UBk-LBk+1)) :: recvS, recvN
5497!
5498 character (len=MPI_MAX_ERROR_STRING) :: string
5499
5500 character (len=*), parameter :: MyFile = &
5501 & __FILE__//", ad_mp_exchange3d"
5502
5503# include "set_bounds.h"
5504
5505# ifdef PROFILE
5506!
5507!-----------------------------------------------------------------------
5508! Turn on time clocks.
5509!-----------------------------------------------------------------------
5510!
5511 CALL wclock_on (ng, model, 61, __line__, myfile)
5512# endif
5513!
5514!-----------------------------------------------------------------------
5515! Determine rank of tile neighbors and number of ghost-points to
5516! exchange.
5517!-----------------------------------------------------------------------
5518!
5519! Maximum automatic buffer memory size in bytes.
5520!
5521 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
5522 & 4*SIZE(sends))*kind(ad_a),r8))
5523!
5524 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
5525 & grecvw, gsendw, wtile, wexchange, &
5526 & grecve, gsende, etile, eexchange, &
5527 & grecvs, gsends, stile, sexchange, &
5528 & grecvn, gsendn, ntile, nexchange)
5529!
5530! Set communication tags.
5531!
5532 wtag=1
5533 stag=2
5534 etag=3
5535 ntag=4
5536!
5537! Determine range and length of the distributed tile boundary segments.
5538!
5539 imin=lbi
5540 imax=ubi
5541 jmin=lbj
5542 jmax=ubj
5543 ilen=imax-imin+1
5544 jlen=jmax-jmin+1
5545 klen=ubk-lbk+1
5546 iklen=ilen*klen
5547 jklen=jlen*klen
5548 IF (ew_periodic.or.ns_periodic) THEN
5549 pp=1
5550 ELSE
5551 pp=0
5552 END IF
5553 nssize=nvar*(nghost+pp)*iklen
5554 ewsize=nvar*(nghost+pp)*jklen
5555 buffersizens=nvar*halosizei(ng)*klen
5556 buffersizeew=nvar*halosizej(ng)*klen
5557 IF (SIZE(sende).lt.ewsize) THEN
5558 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
5559 10 FORMAT (/,' AD_MP_EXCHANGE3D - communication buffer too', &
5560 & ' small, ',a, 2i8)
5561 END IF
5562 IF (SIZE(sendn).lt.nssize) THEN
5563 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
5564 END IF
5565!
5566!-----------------------------------------------------------------------
5567! Adjoint of unpacking Northern and Southern segments.
5568!-----------------------------------------------------------------------
5569!
5570 IF (nexchange) THEN
5571 DO i=1,buffersizens
5572 recvn(i)=0.0_r8
5573 sendn(i)=0.0_r8
5574 END DO
5575 sizen=0
5576 DO m=1,grecvn
5577 mc=(m-1)*iklen
5578 j=jend+m
5579 DO k=lbk,ubk
5580 kc=(k-lbk)*ilen+mc
5581 DO i=imin,imax
5582 sizen=sizen+1
5583 ikn=1+(i-imin)+kc
5584!^ A(i,j,k)=recvN(ikN)
5585!^
5586 recvn(ikn)=ad_a(i,j,k)
5587 ad_a(i,j,k)=0.0_r8
5588 END DO
5589 END DO
5590 END DO
5591 IF (PRESENT(ad_b)) THEN
5592 ioff=ikn
5593 DO m=1,grecvn
5594 mc=(m-1)*iklen
5595 j=jend+m
5596 DO k=lbk,ubk
5597 kc=(k-lbk)*ilen+mc
5598 DO i=imin,imax
5599 sizen=sizen+1
5600 ikn=ioff+1+(i-imin)+kc
5601!^ B(i,j,k)=recvN(ikN)
5602!^
5603 recvn(ikn)=ad_b(i,j,k)
5604 ad_b(i,j,k)=0.0_r8
5605 END DO
5606 END DO
5607 END DO
5608 END IF
5609 IF (PRESENT(ad_c)) THEN
5610 ioff=ikn
5611 DO m=1,grecvn
5612 mc=(m-1)*iklen
5613 j=jend+m
5614 DO k=lbk,ubk
5615 kc=(k-lbk)*ilen+mc
5616 DO i=imin,imax
5617 sizen=sizen+1
5618 ikn=ioff+1+(i-imin)+kc
5619!^ C(i,j,k)=recvN(ikN)
5620!^
5621 recvn(ikn)=ad_c(i,j,k)
5622 ad_c(i,j,k)=0.0_r8
5623 END DO
5624 END DO
5625 END DO
5626 END IF
5627 IF (PRESENT(ad_d)) THEN
5628 ioff=ikn
5629 DO m=1,grecvn
5630 mc=(m-1)*iklen
5631 j=jend+m
5632 DO k=lbk,ubk
5633 kc=(k-lbk)*ilen+mc
5634 DO i=imin,imax
5635 sizen=sizen+1
5636 ikn=ioff+1+(i-imin)+kc
5637!^ D(i,j,k)=recvN(ikN)
5638!^
5639 recvn(ikn)=ad_d(i,j,k)
5640 ad_d(i,j,k)=0.0_r8
5641 END DO
5642 END DO
5643 END DO
5644 END IF
5645 END IF
5646!
5647 IF (sexchange) THEN
5648 DO i=1,buffersizens
5649 recvs(i)=0.0_r8
5650 sends(i)=0.0_r8
5651 END DO
5652 sizes=0
5653 DO m=grecvs,1,-1
5654 mc=(grecvs-m)*iklen
5655 j=jstr-m
5656 DO k=lbk,ubk
5657 kc=(k-lbk)*ilen+mc
5658 DO i=imin,imax
5659 sizes=sizes+1
5660 iks=1+(i-imin)+kc
5661!^ A(i,j,k)=recvS(ikS)
5662!^
5663 recvs(iks)=ad_a(i,j,k)
5664 ad_a(i,j,k)=0.0_r8
5665 END DO
5666 END DO
5667 END DO
5668 IF (PRESENT(ad_b)) THEN
5669 ioff=iks
5670 DO m=grecvs,1,-1
5671 mc=(grecvs-m)*iklen
5672 j=jstr-m
5673 DO k=lbk,ubk
5674 kc=(k-lbk)*ilen+mc
5675 DO i=imin,imax
5676 sizes=sizes+1
5677 iks=ioff+1+(i-imin)+kc
5678!^ B(i,j,k)=recvS(ikS)
5679!^
5680 recvs(iks)=ad_b(i,j,k)
5681 ad_b(i,j,k)=0.0_r8
5682 END DO
5683 END DO
5684 END DO
5685 END IF
5686 IF (PRESENT(ad_c)) THEN
5687 ioff=iks
5688 DO m=grecvs,1,-1
5689 mc=(grecvs-m)*iklen
5690 j=jstr-m
5691 DO k=lbk,ubk
5692 kc=(k-lbk)*ilen+mc
5693 DO i=imin,imax
5694 sizes=sizes+1
5695 iks=ioff+1+(i-imin)+kc
5696!^ C(i,j,k)=recvS(ikS)
5697!^
5698 recvs(iks)=ad_c(i,j,k)
5699 ad_c(i,j,k)=0.0_r8
5700 END DO
5701 END DO
5702 END DO
5703 END IF
5704 IF (PRESENT(ad_d)) THEN
5705 ioff=iks
5706 DO m=grecvs,1,-1
5707 mc=(grecvs-m)*iklen
5708 j=jstr-m
5709 DO k=lbk,ubk
5710 kc=(k-lbk)*ilen+mc
5711 DO i=imin,imax
5712 sizes=sizes+1
5713 iks=ioff+1+(i-imin)+kc
5714!^ D(i,j,k)=recvS(ikS)
5715!^
5716 recvs(iks)=ad_d(i,j,k)
5717 ad_d(i,j,k)=0.0_r8
5718 END DO
5719 END DO
5720 END DO
5721 END IF
5722 END IF
5723!
5724!-----------------------------------------------------------------------
5725! Adjoint of send and receive Southern and Northern segments.
5726!-----------------------------------------------------------------------
5727!
5728# if defined MPI
5729 IF (sexchange) THEN
5730!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
5731!^ & OCN_COMM_WORLD, Srequest, Serror)
5732!^
5733 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
5734 & ocn_comm_world, srequest, serror)
5735 END IF
5736 IF (nexchange) THEN
5737!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
5738!^ & OCN_COMM_WORLD, Nrequest, Nerror)
5739!^
5740 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
5741 & ocn_comm_world, nrequest, nerror)
5742 END IF
5743 IF (sexchange) THEN
5744!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
5745!^ & OCN_COMM_WORLD, Serror)
5746!^
5747 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
5748 & ocn_comm_world, serror)
5749 END IF
5750 IF (nexchange) THEN
5751!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
5752!^ & OCN_COMM_WORLD, Nerror)
5753!^
5754 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
5755 & ocn_comm_world, nerror)
5756 END IF
5757# endif
5758!
5759! Adjoint of packing tile boundary data including ghost-points.
5760!
5761 IF (sexchange) THEN
5762# ifdef MPI
5763 CALL mpi_wait (srequest, status(1,2), serror)
5764 IF (serror.ne.mpi_success) THEN
5765 CALL mpi_error_string (serror, string, lstr, ierror)
5766 lstr=len_trim(string)
5767 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
5768 & myrank, serror, string(1:lstr)
5769 20 FORMAT (/,' AD_MP_EXCHANGE3D - error during ',a,' call,', &
5770 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
5771 exit_flag=2
5772 RETURN
5773 END IF
5774# endif
5775 DO m=1,gsends
5776 mc=(m-1)*iklen
5777 j=jstr+m-1
5778 DO k=lbk,ubk
5779 kc=(k-lbk)*ilen+mc
5780 DO i=imin,imax
5781 iks=1+(i-imin)+kc
5782!^ sendS(ikS)=A(i,j,k)
5783!^
5784 ad_a(i,j,k)=ad_a(i,j,k)+sends(iks)
5785 sends(iks)=0.0_r8
5786 END DO
5787 END DO
5788 END DO
5789 IF (PRESENT(ad_b)) THEN
5790 ioff=iks
5791 DO m=1,gsends
5792 mc=(m-1)*iklen
5793 j=jstr+m-1
5794 DO k=lbk,ubk
5795 kc=(k-lbk)*ilen+mc
5796 DO i=imin,imax
5797 iks=ioff+1+(i-imin)+kc
5798!^ sendS(ikS)=B(i,j,k)
5799!^
5800 ad_b(i,j,k)=ad_b(i,j,k)+sends(iks)
5801 sends(iks)=0.0_r8
5802 END DO
5803 END DO
5804 END DO
5805 END IF
5806 IF (PRESENT(ad_c)) THEN
5807 ioff=iks
5808 DO m=1,gsends
5809 mc=(m-1)*iklen
5810 j=jstr+m-1
5811 DO k=lbk,ubk
5812 kc=(k-lbk)*ilen+mc
5813 DO i=imin,imax
5814 iks=ioff+1+(i-imin)+kc
5815!^ sendS(ikS)=C(i,j,k)
5816!^
5817 ad_c(i,j,k)=ad_c(i,j,k)+sends(iks)
5818 sends(iks)=0.0_r8
5819 END DO
5820 END DO
5821 END DO
5822 END IF
5823 IF (PRESENT(ad_d)) THEN
5824 ioff=iks
5825 DO m=1,gsends
5826 mc=(m-1)*iklen
5827 j=jstr+m-1
5828 DO k=lbk,ubk
5829 kc=(k-lbk)*ilen+mc
5830 DO i=imin,imax
5831 iks=ioff+1+(i-imin)+kc
5832!^ sendS(ikS)=D(i,j,k)
5833!^
5834 ad_d(i,j,k)=ad_d(i,j,k)+sends(iks)
5835 sends(iks)=0.0_r8
5836 END DO
5837 END DO
5838 END DO
5839 END IF
5840 END IF
5841!
5842 IF (nexchange) THEN
5843# ifdef MPI
5844 CALL mpi_wait (nrequest, status(1,4), nerror)
5845 IF (nerror.ne.mpi_success) THEN
5846 CALL mpi_error_string (nerror, string, lstr, ierror)
5847 lstr=len_trim(string)
5848 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
5849 & myrank, nerror, string(1:lstr)
5850 exit_flag=2
5851 RETURN
5852 END IF
5853# endif
5854 DO m=1,gsendn
5855 mc=(m-1)*iklen
5856 j=jend-gsendn+m
5857 DO k=lbk,ubk
5858 kc=(k-lbk)*ilen+mc
5859 DO i=imin,imax
5860 ikn=1+(i-imin)+kc
5861!^ sendN(ikN)=A(i,j,k)
5862!^
5863 ad_a(i,j,k)=ad_a(i,j,k)+sendn(ikn)
5864 sendn(ikn)=0.0_r8
5865 END DO
5866 END DO
5867 END DO
5868 IF (PRESENT(ad_b)) THEN
5869 ioff=ikn
5870 DO m=1,gsendn
5871 mc=(m-1)*iklen
5872 j=jend-gsendn+m
5873 DO k=lbk,ubk
5874 kc=(k-lbk)*ilen+mc
5875 DO i=imin,imax
5876 ikn=ioff+1+(i-imin)+kc
5877!^ sendN(ikN)=B(i,j,k)
5878!^
5879 ad_b(i,j,k)=ad_b(i,j,k)+sendn(ikn)
5880 sendn(ikn)=0.0_r8
5881 END DO
5882 END DO
5883 END DO
5884 END IF
5885 IF (PRESENT(ad_c)) THEN
5886 ioff=ikn
5887 DO m=1,gsendn
5888 mc=(m-1)*iklen
5889 j=jend-gsendn+m
5890 DO k=lbk,ubk
5891 kc=(k-lbk)*ilen+mc
5892 DO i=imin,imax
5893 ikn=ioff+1+(i-imin)+kc
5894!^ sendN(ikN)=C(i,j,k)
5895!^
5896 ad_c(i,j,k)=ad_c(i,j,k)+sendn(ikn)
5897 sendn(ikn)=0.0_r8
5898 END DO
5899 END DO
5900 END DO
5901 END IF
5902 IF (PRESENT(ad_d)) THEN
5903 ioff=ikn
5904 DO m=1,gsendn
5905 mc=(m-1)*iklen
5906 j=jend-gsendn+m
5907 DO k=lbk,ubk
5908 kc=(k-lbk)*ilen+mc
5909 DO i=imin,imax
5910 ikn=ioff+1+(i-imin)+kc
5911!^ sendN(ikN)=D(i,j,k)
5912!^
5913 ad_d(i,j,k)=ad_d(i,j,k)+sendn(ikn)
5914 sendn(ikn)=0.0_r8
5915 END DO
5916 END DO
5917 END DO
5918 END IF
5919 END IF
5920!
5921!-----------------------------------------------------------------------
5922! Adjoint of unpack Eastern and Western segments.
5923!-----------------------------------------------------------------------
5924!
5925 IF (eexchange) THEN
5926 DO i=1,buffersizeew
5927 recve(i)=0.0_r8
5928 sende(i)=0.0_r8
5929 END DO
5930 sizee=0
5931 DO m=1,grecve
5932 mc=(m-1)*jklen
5933 i=iend+m
5934 DO k=lbk,ubk
5935 kc=(k-lbk)*jlen+mc
5936 DO j=jmin,jmax
5937 sizee=sizee+1
5938 jke=1+(j-jmin)+kc
5939!^ A(i,j,k)=recvE(jkE)
5940!^
5941 recve(jke)=ad_a(i,j,k)
5942 ad_a(i,j,k)=0.0_r8
5943 END DO
5944 ENDDO
5945 END DO
5946 IF (PRESENT(ad_b)) THEN
5947 joff=jke
5948 DO m=1,grecve
5949 mc=(m-1)*jklen
5950 i=iend+m
5951 DO k=lbk,ubk
5952 kc=(k-lbk)*jlen+mc
5953 DO j=jmin,jmax
5954 sizee=sizee+1
5955 jke=joff+1+(j-jmin)+kc
5956!^ B(i,j,k)=recvE(jkE)
5957!^
5958 recve(jke)=ad_b(i,j,k)
5959 ad_b(i,j,k)=0.0_r8
5960 END DO
5961 END DO
5962 END DO
5963 END IF
5964 IF (PRESENT(ad_c)) THEN
5965 joff=jke
5966 DO m=1,grecve
5967 mc=(m-1)*jklen
5968 i=iend+m
5969 DO k=lbk,ubk
5970 kc=(k-lbk)*jlen+mc
5971 DO j=jmin,jmax
5972 sizee=sizee+1
5973 jke=joff+1+(j-jmin)+kc
5974!^ C(i,j,k)=recvE(jkE)
5975!^
5976 recve(jke)=ad_c(i,j,k)
5977 ad_c(i,j,k)=0.0_r8
5978 END DO
5979 END DO
5980 END DO
5981 END IF
5982 IF (PRESENT(ad_d)) THEN
5983 joff=jke
5984 DO m=1,grecve
5985 mc=(m-1)*jklen
5986 i=iend+m
5987 DO k=lbk,ubk
5988 kc=(k-lbk)*jlen+mc
5989 DO j=jmin,jmax
5990 sizee=sizee+1
5991 jke=joff+1+(j-jmin)+kc
5992!^ D(i,j,k)=recvE(jkE)
5993!^
5994 recve(jke)=ad_d(i,j,k)
5995 ad_d(i,j,k)=0.0_r8
5996 END DO
5997 END DO
5998 END DO
5999 END IF
6000 END IF
6001!
6002 IF (wexchange) THEN
6003 DO i=1,buffersizeew
6004 recvw(i)=0.0_r8
6005 sendw(i)=0.0_r8
6006 END DO
6007 sizew=0
6008 DO m=grecvw,1,-1
6009 mc=(grecvw-m)*jklen
6010 i=istr-m
6011 DO k=lbk,ubk
6012 kc=(k-lbk)*jlen+mc
6013 DO j=jmin,jmax
6014 sizew=sizew+1
6015 jkw=1+(j-jmin)+kc
6016!^ A(i,j,k)=recvW(jkW)
6017!^
6018 recvw(jkw)=ad_a(i,j,k)
6019 ad_a(i,j,k)=0.0_r8
6020 END DO
6021 END DO
6022 END DO
6023 IF (PRESENT(ad_b)) THEN
6024 joff=jkw
6025 DO m=grecvw,1,-1
6026 mc=(grecvw-m)*jklen
6027 i=istr-m
6028 DO k=lbk,ubk
6029 kc=(k-lbk)*jlen+mc
6030 DO j=jmin,jmax
6031 sizew=sizew+1
6032 jkw=joff+1+(j-jmin)+kc
6033!^ B(i,j,k)=recvW(jkW)
6034!^
6035 recvw(jkw)=ad_b(i,j,k)
6036 ad_b(i,j,k)=0.0_r8
6037 END DO
6038 END DO
6039 END DO
6040 END IF
6041 IF (PRESENT(ad_c)) THEN
6042 joff=jkw
6043 DO m=grecvw,1,-1
6044 mc=(grecvw-m)*jklen
6045 i=istr-m
6046 DO k=lbk,ubk
6047 kc=(k-lbk)*jlen+mc
6048 DO j=jmin,jmax
6049 sizew=sizew+1
6050 jkw=joff+1+(j-jmin)+kc
6051!^ C(i,j,k)=recvW(jkW)
6052!^
6053 recvw(jkw)=ad_c(i,j,k)
6054 ad_c(i,j,k)=0.0_r8
6055 END DO
6056 END DO
6057 END DO
6058 END IF
6059 IF (PRESENT(ad_d)) THEN
6060 joff=jkw
6061 DO m=grecvw,1,-1
6062 mc=(grecvw-m)*jklen
6063 i=istr-m
6064 DO k=lbk,ubk
6065 kc=(k-lbk)*jlen+mc
6066 DO j=jmin,jmax
6067 sizew=sizew+1
6068 jkw=joff+1+(j-jmin)+kc
6069!^ D(i,j,k)=recvW(jkW)
6070!^
6071 recvw(jkw)=ad_d(i,j,k)
6072 ad_d(i,j,k)=0.0_r8
6073 END DO
6074 END DO
6075 END DO
6076 END IF
6077 END IF
6078!
6079!-----------------------------------------------------------------------
6080! Send and receive Western and Eastern segments.
6081!-----------------------------------------------------------------------
6082!
6083# if defined MPI
6084 IF (wexchange) THEN
6085!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
6086!^ & OCN_COMM_WORLD, Wrequest, Werror)
6087!^
6088 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
6089 & ocn_comm_world, wrequest, werror)
6090 END IF
6091 IF (eexchange) THEN
6092!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
6093!^ & OCN_COMM_WORLD, Erequest, Eerror)
6094!^
6095 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
6096 & ocn_comm_world, erequest, eerror)
6097 END IF
6098 IF (wexchange) THEN
6099!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
6100!^ & OCN_COMM_WORLD, Werror)
6101!^
6102 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
6103 & ocn_comm_world, werror)
6104 END IF
6105 IF (eexchange) THEN
6106!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
6107!^ & OCN_COMM_WORLD, Eerror)
6108!^
6109 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
6110 & ocn_comm_world, eerror)
6111 END IF
6112# endif
6113!
6114! Adjoint of packing tile boundary data including ghost-points.
6115!
6116 IF (wexchange) THEN
6117# ifdef MPI
6118 CALL mpi_wait (wrequest, status(1,1), werror)
6119 IF (werror.ne.mpi_success) THEN
6120 CALL mpi_error_string (werror, string, lstr, ierror)
6121 lstr=len_trim(string)
6122 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
6123 & myrank, werror, string(1:lstr)
6124 exit_flag=2
6125 RETURN
6126 END IF
6127# endif
6128 DO m=1,gsendw
6129 mc=(m-1)*jklen
6130 i=istr+m-1
6131 DO k=lbk,ubk
6132 kc=(k-lbk)*jlen+mc
6133 DO j=jmin,jmax
6134 jkw=1+(j-jmin)+kc
6135!^ sendW(jkW)=A(i,j,k)
6136!^
6137 ad_a(i,j,k)=ad_a(i,j,k)+sendw(jkw)
6138 sendw(jkw)=0.0_r8
6139 END DO
6140 END DO
6141 END DO
6142 IF (PRESENT(ad_b)) THEN
6143 joff=jkw
6144 DO m=1,gsendw
6145 mc=(m-1)*jklen
6146 i=istr+m-1
6147 DO k=lbk,ubk
6148 kc=(k-lbk)*jlen+mc
6149 DO j=jmin,jmax
6150 jkw=joff+1+(j-jmin)+kc
6151!^ sendW(jkW)=B(i,j,k)
6152!^
6153 ad_b(i,j,k)=ad_b(i,j,k)+sendw(jkw)
6154 sendw(jkw)=0.0_r8
6155 END DO
6156 END DO
6157 END DO
6158 END IF
6159 IF (PRESENT(ad_c)) THEN
6160 joff=jkw
6161 DO m=1,gsendw
6162 mc=(m-1)*jklen
6163 i=istr+m-1
6164 DO k=lbk,ubk
6165 kc=(k-lbk)*jlen+mc
6166 DO j=jmin,jmax
6167 jkw=joff+1+(j-jmin)+kc
6168!^ sendW(jkW)=C(i,j,k)
6169!^
6170 ad_c(i,j,k)=ad_c(i,j,k)+sendw(jkw)
6171 sendw(jkw)=0.0_r8
6172 END DO
6173 END DO
6174 END DO
6175 END IF
6176 IF (PRESENT(ad_d)) THEN
6177 joff=jkw
6178 DO m=1,gsendw
6179 mc=(m-1)*jklen
6180 i=istr+m-1
6181 DO k=lbk,ubk
6182 kc=(k-lbk)*jlen+mc
6183 DO j=jmin,jmax
6184 jkw=joff+1+(j-jmin)+kc
6185!^ sendW(jkW)=D(i,j,k)
6186!^
6187 ad_d(i,j,k)=ad_d(i,j,k)+sendw(jkw)
6188 sendw(jkw)=0.0_r8
6189 END DO
6190 END DO
6191 END DO
6192 END IF
6193 END IF
6194!
6195 IF (eexchange) THEN
6196# ifdef MPI
6197 CALL mpi_wait (erequest, status(1,3), eerror)
6198 IF (eerror.ne.mpi_success) THEN
6199 CALL mpi_error_string (eerror, string, lstr, ierror)
6200 lstr=len_trim(string)
6201 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
6202 & myrank, eerror, string(1:lstr)
6203 exit_flag=2
6204 RETURN
6205 END IF
6206# endif
6207 DO m=1,gsende
6208 mc=(m-1)*jklen
6209 i=iend-gsende+m
6210 DO k=lbk,ubk
6211 kc=(k-lbk)*jlen+mc
6212 DO j=jmin,jmax
6213 jke=1+(j-jmin)+kc
6214!^ sendE(jkE)=A(i,j,k)
6215!^
6216 ad_a(i,j,k)=ad_a(i,j,k)+sende(jke)
6217 sende(jke)=0.0_r8
6218 END DO
6219 END DO
6220 END DO
6221 IF (PRESENT(ad_b)) THEN
6222 joff=jke
6223 DO m=1,gsende
6224 mc=(m-1)*jklen
6225 i=iend-gsende+m
6226 DO k=lbk,ubk
6227 kc=(k-lbk)*jlen+mc
6228 DO j=jmin,jmax
6229 jke=joff+1+(j-jmin)+kc
6230!^ sendE(jkE)=B(i,j,k)
6231!^
6232 ad_b(i,j,k)=ad_b(i,j,k)+sende(jke)
6233 sende(jke)=0.0_r8
6234 END DO
6235 END DO
6236 END DO
6237 END IF
6238 IF (PRESENT(ad_c)) THEN
6239 joff=jke
6240 DO m=1,gsende
6241 mc=(m-1)*jklen
6242 i=iend-gsende+m
6243 DO k=lbk,ubk
6244 kc=(k-lbk)*jlen+mc
6245 DO j=jmin,jmax
6246 jke=joff+1+(j-jmin)+kc
6247!^ sendE(jkE)=C(i,j,k)
6248!^
6249 ad_c(i,j,k)=ad_c(i,j,k)+sende(jke)
6250 sende(jke)=0.0_r8
6251 END DO
6252 END DO
6253 END DO
6254 END IF
6255 IF (PRESENT(ad_d)) THEN
6256 joff=jke
6257 DO m=1,gsende
6258 mc=(m-1)*jklen
6259 i=iend-gsende+m
6260 DO k=lbk,ubk
6261 kc=(k-lbk)*jlen+mc
6262 DO j=jmin,jmax
6263 jke=joff+1+(j-jmin)+kc
6264!^ sendE(jkE)=D(i,j,k)
6265!^
6266 ad_d(i,j,k)=ad_d(i,j,k)+sende(jke)
6267 sende(jke)=0.0_r8
6268 END DO
6269 END DO
6270 END DO
6271 END IF
6272 END IF
6273
6274# ifdef PROFILE
6275!
6276!-----------------------------------------------------------------------
6277! Turn off time clocks.
6278!-----------------------------------------------------------------------
6279!
6280 CALL wclock_off (ng, model, 61, __line__, myfile)
6281# endif
6282!
6283 RETURN
6284 END SUBROUTINE ad_mp_exchange3d
6285!
6286!***********************************************************************
6287 SUBROUTINE ad_mp_exchange3d_bry (ng, tile, model, Nvar, boundary, &
6288 & LBij, UBij, LBk, UBk, &
6289 & Nghost, EW_periodic, NS_periodic,&
6290 & ad_A, ad_B, ad_C, ad_D)
6291!***********************************************************************
6292!
6293 USE mod_param
6294 USE mod_parallel
6295 USE mod_iounits
6296 USE mod_scalars
6297!
6298 implicit none
6299!
6300! Imported variable declarations.
6301!
6302 logical, intent(in) :: EW_periodic, NS_periodic
6303!
6304 integer, intent(in) :: ng, tile, model, Nvar, boundary
6305 integer, intent(in) :: LBij, UBij, LBk, UBk
6306 integer, intent(in) :: Nghost
6307!
6308# ifdef ASSUMED_SHAPE
6309 real(r8), intent(inout) :: ad_A(LBij:,LBk:)
6310
6311 real(r8), intent(inout), optional :: ad_B(LBij:,LBk:)
6312 real(r8), intent(inout), optional :: ad_C(LBij:,LBk:)
6313 real(r8), intent(inout), optional :: ad_D(LBij:,LBk:)
6314# else
6315 real(r8), intent(inout) :: ad_A(LBij:UBij,LBk:UBk)
6316
6317 real(r8), intent(inout), optional :: ad_B(LBij:UBij,LBk:UBk)
6318 real(r8), intent(inout), optional :: ad_C(LBij:UBij,LBk:UBk)
6319 real(r8), intent(inout), optional :: ad_D(LBij:UBij,LBk:UBk)
6320# endif
6321!
6322! Local variable declarations.
6323!
6324 logical :: Wexchange, Sexchange, Eexchange, Nexchange
6325!
6326 integer :: i, ikS, ikN, ioff
6327 integer :: j, jkW, jkE, joff
6328 integer :: k, m, mc, Ierror, Klen, Lstr, pp
6329 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
6330 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
6331 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
6332 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
6333 integer :: BufferSizeEW, EWsize, sizeW, sizeE
6334 integer :: BufferSizeNS, NSsize, sizeS, sizeN
6335
6336# ifdef MPI
6337 integer, dimension(MPI_STATUS_SIZE,4) :: status
6338# endif
6339!
6340 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendW, sendE
6341 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvW, recvE
6342 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: sendS, sendN
6343 real(r8), dimension(Nvar*HaloBry(ng)*(UBk-LBk+1)) :: recvS, recvN
6344!
6345 character (len=MPI_MAX_ERROR_STRING) :: string
6346
6347 character (len=*), parameter :: MyFile = &
6348 & __FILE__//", ad_mp_exchange3d_bry"
6349
6350# include "set_bounds.h"
6351
6352# ifdef PROFILE
6353!
6354!-----------------------------------------------------------------------
6355! Turn on time clocks.
6356!-----------------------------------------------------------------------
6357!
6358 CALL wclock_on (ng, model, 63, __line__, myfile)
6359# endif
6360!
6361!-----------------------------------------------------------------------
6362! Determine rank of tile neighbors and number of ghost-points to
6363! exchange.
6364!-----------------------------------------------------------------------
6365!
6366! Maximum automatic buffer memory size in bytes.
6367!
6368 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
6369 & 4*SIZE(sends))*kind(ad_a),r8))
6370!
6371 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
6372 & grecvw, gsendw, wtile, wexchange, &
6373 & grecve, gsende, etile, eexchange, &
6374 & grecvs, gsends, stile, sexchange, &
6375 & grecvn, gsendn, ntile, nexchange)
6376!
6377! Adjust exchange swiches according to boundary edge to process.
6378!
6379 wexchange=wexchange.and.((boundary.eq.isouth).or. &
6380 & (boundary.eq.inorth))
6381 eexchange=eexchange.and.((boundary.eq.isouth).or. &
6382 & (boundary.eq.inorth))
6383 sexchange=sexchange.and.((boundary.eq.iwest).or. &
6384 & (boundary.eq.ieast))
6385 nexchange=nexchange.and.((boundary.eq.iwest).or. &
6386 & (boundary.eq.ieast))
6387!
6388! Set communication tags.
6389!
6390 wtag=1
6391 stag=2
6392 etag=3
6393 ntag=4
6394!
6395! Determine range and length of the distributed tile boundary segments.
6396!
6397 klen=ubk-lbk+1
6398 IF (ew_periodic.or.ns_periodic) THEN
6399 pp=1
6400 ELSE
6401 pp=0
6402 END IF
6403 nssize=nvar*(nghost+pp)*klen
6404 ewsize=nvar*(nghost+pp)*klen
6405 buffersizens=nvar*(nghost+pp)*klen
6406 buffersizeew=nvar*(nghost+pp)*klen
6407 IF (SIZE(sende).lt.ewsize) THEN
6408 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
6409 10 FORMAT (/,' AD_MP_EXCHANGE3D_BRY - communication buffer too', &
6410 & ' small, ',a, 2i8)
6411 END IF
6412 IF (SIZE(sendn).lt.nssize) THEN
6413 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
6414 END IF
6415!
6416!-----------------------------------------------------------------------
6417! Adjoint of unpacking Northern and Southern segments.
6418!-----------------------------------------------------------------------
6419!
6420 IF (nexchange) THEN
6421 DO i=1,buffersizens
6422 recvn(i)=0.0_r8
6423 sendn(i)=0.0_r8
6424 END DO
6425 sizen=0
6426 DO m=1,grecvn
6427 mc=(m-1)*klen
6428 j=jend+m
6429 DO k=lbk,ubk
6430 sizen=sizen+1
6431 ikn=1+(k-lbk)+mc
6432!^ A(j,k)=recvN(ikN)
6433!^
6434 recvn(ikn)=ad_a(j,k)
6435 ad_a(j,k)=0.0_r8
6436 END DO
6437 END DO
6438 IF (PRESENT(ad_b)) THEN
6439 ioff=ikn
6440 DO m=1,grecvn
6441 mc=(m-1)*klen
6442 j=jend+m
6443 DO k=lbk,ubk
6444 sizen=sizen+1
6445 ikn=ioff+1+(k-lbk)+mc
6446!^ B(j,k)=recvN(ikN)
6447!^
6448 recvn(ikn)=ad_b(j,k)
6449 ad_b(j,k)=0.0_r8
6450 END DO
6451 END DO
6452 END IF
6453 IF (PRESENT(ad_c)) THEN
6454 ioff=ikn
6455 DO m=1,grecvn
6456 mc=(m-1)*klen
6457 j=jend+m
6458 DO k=lbk,ubk
6459 sizen=sizen+1
6460 ikn=ioff+1+(k-lbk)+mc
6461!^ C(j,k)=recvN(ikN)
6462!^
6463 recvn(ikn)=ad_c(j,k)
6464 ad_c(j,k)=0.0_r8
6465 END DO
6466 END DO
6467 END IF
6468 IF (PRESENT(ad_d)) THEN
6469 ioff=ikn
6470 DO m=1,grecvn
6471 mc=(m-1)*klen
6472 j=jend+m
6473 DO k=lbk,ubk
6474 sizen=sizen+1
6475 ikn=ioff+1+(k-lbk)+mc
6476!^ D(j,k)=recvN(ikN)
6477!^
6478 recvn(ikn)=ad_d(j,k)
6479 ad_d(j,k)=0.0_r8
6480 END DO
6481 END DO
6482 END IF
6483 END IF
6484!
6485 IF (sexchange) THEN
6486 DO i=1,buffersizens
6487 recvs(i)=0.0_r8
6488 sends(i)=0.0_r8
6489 END DO
6490 sizes=0
6491 DO m=grecvs,1,-1
6492 mc=(grecvs-m)*klen
6493 j=jstr-m
6494 DO k=lbk,ubk
6495 sizes=sizes+1
6496 iks=1+(k-lbk)+mc
6497!^ A(j,k)=recvS(ikS)
6498!^
6499 recvs(iks)=ad_a(j,k)
6500 ad_a(j,k)=0.0_r8
6501 END DO
6502 END DO
6503 IF (PRESENT(ad_b)) THEN
6504 ioff=iks
6505 DO m=grecvs,1,-1
6506 mc=(grecvs-m)*klen
6507 j=jstr-m
6508 DO k=lbk,ubk
6509 sizes=sizes+1
6510 iks=ioff+1+(k-lbk)+mc
6511!^ B(j,k)=recvS(ikS)
6512!^
6513 recvs(iks)=ad_b(j,k)
6514 ad_b(j,k)=0.0_r8
6515 END DO
6516 END DO
6517 END IF
6518 IF (PRESENT(ad_c)) THEN
6519 ioff=iks
6520 DO m=grecvs,1,-1
6521 mc=(grecvs-m)*klen
6522 j=jstr-m
6523 DO k=lbk,ubk
6524 sizes=sizes+1
6525 iks=ioff+1+(k-lbk)+mc
6526!^ C(j,k)=recvS(ikS)
6527!^
6528 recvs(iks)=ad_c(j,k)
6529 ad_c(j,k)=0.0_r8
6530 END DO
6531 END DO
6532 END IF
6533 IF (PRESENT(ad_d)) THEN
6534 ioff=iks
6535 DO m=grecvs,1,-1
6536 mc=(grecvs-m)*klen
6537 j=jstr-m
6538 DO k=lbk,ubk
6539 sizes=sizes+1
6540 iks=ioff+1+(k-lbk)+mc
6541!^ D(j,k)=recvS(ikS)
6542!^
6543 recvs(iks)=ad_d(j,k)
6544 ad_d(j,k)=0.0_r8
6545 END DO
6546 END DO
6547 END IF
6548 END IF
6549!
6550!-----------------------------------------------------------------------
6551! Adjoint of send and receive Southern and Northern segments.
6552!-----------------------------------------------------------------------
6553!
6554# if defined MPI
6555 IF (sexchange) THEN
6556!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
6557!^ & OCN_COMM_WORLD, Srequest, Serror)
6558!^
6559 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
6560 & ocn_comm_world, srequest, serror)
6561 END IF
6562 IF (nexchange) THEN
6563!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
6564!^ & OCN_COMM_WORLD, Nrequest, Nerror)
6565!^
6566 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
6567 & ocn_comm_world, nrequest, nerror)
6568 END IF
6569 IF (sexchange) THEN
6570!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
6571!^ & OCN_COMM_WORLD, Serror)
6572!^
6573 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
6574 & ocn_comm_world, serror)
6575 END IF
6576 IF (nexchange) THEN
6577!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
6578!^ & OCN_COMM_WORLD, Nerror)
6579!^
6580 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
6581 & ocn_comm_world, nerror)
6582 END IF
6583# endif
6584!
6585! Adjoint of packing tile boundary data including ghost-points.
6586!
6587 IF (sexchange) THEN
6588# ifdef MPI
6589 CALL mpi_wait (srequest, status(1,2), serror)
6590 IF (serror.ne.mpi_success) THEN
6591 CALL mpi_error_string (serror, string, lstr, ierror)
6592 lstr=len_trim(string)
6593 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
6594 & myrank, serror, string(1:lstr)
6595 20 FORMAT (/,' AD_MP_EXCHANGE3D_BRY - error during ',a,' call,', &
6596 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
6597 exit_flag=2
6598 RETURN
6599 END IF
6600# endif
6601 DO m=1,gsends
6602 mc=(m-1)*klen
6603 j=jstr+m-1
6604 DO k=lbk,ubk
6605 iks=1+(k-lbk)+mc
6606!^ sendS(ikS)=A(j,k)
6607!^
6608 ad_a(j,k)=ad_a(j,k)+sends(iks)
6609 sends(iks)=0.0_r8
6610 END DO
6611 END DO
6612 IF (PRESENT(ad_b)) THEN
6613 ioff=iks
6614 DO m=1,gsends
6615 mc=(m-1)*klen
6616 j=jstr+m-1
6617 DO k=lbk,ubk
6618 iks=ioff+1+(k-lbk)+mc
6619!^ sendS(ikS)=B(j,k)
6620!^
6621 ad_b(j,k)=ad_b(j,k)+sends(iks)
6622 sends(iks)=0.0_r8
6623 END DO
6624 END DO
6625 END IF
6626 IF (PRESENT(ad_c)) THEN
6627 ioff=iks
6628 DO m=1,gsends
6629 mc=(m-1)*klen
6630 j=jstr+m-1
6631 DO k=lbk,ubk
6632 iks=ioff+1+(k-lbk)+mc
6633!^ sendS(ikS)=C(j,k)
6634!^
6635 ad_c(j,k)=ad_c(j,k)+sends(iks)
6636 sends(iks)=0.0_r8
6637 END DO
6638 END DO
6639 END IF
6640 IF (PRESENT(ad_d)) THEN
6641 ioff=iks
6642 DO m=1,gsends
6643 mc=(m-1)*klen
6644 j=jstr+m-1
6645 DO k=lbk,ubk
6646 iks=ioff+1+(k-lbk)+mc
6647!^ sendS(ikS)=D(j,k)
6648!^
6649 ad_d(j,k)=ad_d(j,k)+sends(iks)
6650 sends(iks)=0.0_r8
6651 END DO
6652 END DO
6653 END IF
6654 END IF
6655!
6656 IF (nexchange) THEN
6657# ifdef MPI
6658 CALL mpi_wait (nrequest, status(1,4), nerror)
6659 IF (nerror.ne.mpi_success) THEN
6660 CALL mpi_error_string (nerror, string, lstr, ierror)
6661 lstr=len_trim(string)
6662 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
6663 & myrank, nerror, string(1:lstr)
6664 exit_flag=2
6665 RETURN
6666 END IF
6667# endif
6668 DO m=1,gsendn
6669 mc=(m-1)*klen
6670 j=jend-gsendn+m
6671 DO k=lbk,ubk
6672 ikn=1+(k-lbk)+mc
6673!^ sendN(ikN)=A(j,k)
6674!^
6675 ad_a(j,k)=ad_a(j,k)+sendn(ikn)
6676 sendn(ikn)=0.0_r8
6677 END DO
6678 END DO
6679 IF (PRESENT(ad_b)) THEN
6680 ioff=ikn
6681 DO m=1,gsendn
6682 mc=(m-1)*klen
6683 j=jend-gsendn+m
6684 DO k=lbk,ubk
6685 ikn=ioff+1+(k-lbk)+mc
6686!^ sendN(ikN)=B(j,k)
6687!^
6688 ad_b(j,k)=ad_b(j,k)+sendn(ikn)
6689 sendn(ikn)=0.0_r8
6690 END DO
6691 END DO
6692 END IF
6693 IF (PRESENT(ad_c)) THEN
6694 ioff=ikn
6695 DO m=1,gsendn
6696 mc=(m-1)*klen
6697 j=jend-gsendn+m
6698 DO k=lbk,ubk
6699 ikn=ioff+1+(k-lbk)+mc
6700!^ sendN(ikN)=C(j,k)
6701!^
6702 ad_c(j,k)=ad_c(j,k)+sendn(ikn)
6703 sendn(ikn)=0.0_r8
6704 END DO
6705 END DO
6706 END IF
6707 IF (PRESENT(ad_d)) THEN
6708 ioff=ikn
6709 DO m=1,gsendn
6710 mc=(m-1)*klen
6711 j=jend-gsendn+m
6712 DO k=lbk,ubk
6713 ikn=ioff+1+(k-lbk)+mc
6714!^ sendN(ikN)=D(j,k)
6715!^
6716 ad_d(j,k)=ad_d(j,k)+sendn(ikn)
6717 sendn(ikn)=0.0_r8
6718 END DO
6719 END DO
6720 END IF
6721 END IF
6722!
6723!-----------------------------------------------------------------------
6724! Adjoint of unpack Eastern and Western segments.
6725!-----------------------------------------------------------------------
6726!
6727 IF (eexchange) THEN
6728 DO i=1,buffersizeew
6729 recve(i)=0.0_r8
6730 sende(i)=0.0_r8
6731 END DO
6732 sizee=0
6733 DO m=1,grecve
6734 mc=(m-1)*klen
6735 i=iend+m
6736 DO k=lbk,ubk
6737 sizee=sizee+1
6738 jke=1+(k-lbk)+mc
6739!^ A(i,k)=recvE(jkE)
6740!^
6741 recve(jke)=ad_a(i,k)
6742 ad_a(i,k)=0.0_r8
6743 ENDDO
6744 END DO
6745 IF (PRESENT(ad_b)) THEN
6746 joff=jke
6747 DO m=1,grecve
6748 mc=(m-1)*klen
6749 i=iend+m
6750 DO k=lbk,ubk
6751 sizee=sizee+1
6752 jke=joff+1+(k-lbk)+mc
6753!^ B(i,k)=recvE(jkE)
6754!^
6755 recve(jke)=ad_b(i,k)
6756 ad_b(i,k)=0.0_r8
6757 END DO
6758 END DO
6759 END IF
6760 IF (PRESENT(ad_c)) THEN
6761 joff=jke
6762 DO m=1,grecve
6763 mc=(m-1)*klen
6764 i=iend+m
6765 DO k=lbk,ubk
6766 sizee=sizee+1
6767 jke=joff+1+(k-lbk)+mc
6768!^ C(i,k)=recvE(jkE)
6769!^
6770 recve(jke)=ad_c(i,k)
6771 ad_c(i,k)=0.0_r8
6772 END DO
6773 END DO
6774 END IF
6775 IF (PRESENT(ad_d)) THEN
6776 joff=jke
6777 DO m=1,grecve
6778 mc=(m-1)*klen
6779 i=iend+m
6780 DO k=lbk,ubk
6781 sizee=sizee+1
6782 jke=joff+1+(k-lbk)+mc
6783!^ D(i,k)=recvE(jkE)
6784!^
6785 recve(jke)=ad_d(i,k)
6786 ad_d(i,k)=0.0_r8
6787 END DO
6788 END DO
6789 END IF
6790 END IF
6791!
6792 IF (wexchange) THEN
6793 DO i=1,buffersizeew
6794 recvw(i)=0.0_r8
6795 sendw(i)=0.0_r8
6796 END DO
6797 sizew=0
6798 DO m=grecvw,1,-1
6799 mc=(grecvw-m)*klen
6800 i=istr-m
6801 DO k=lbk,ubk
6802 sizew=sizew+1
6803 jkw=1+(k-lbk)+mc
6804!^ A(i,k)=recvW(jkW)
6805!^
6806 recvw(jkw)=ad_a(i,k)
6807 ad_a(i,k)=0.0_r8
6808 END DO
6809 END DO
6810 IF (PRESENT(ad_b)) THEN
6811 joff=jkw
6812 DO m=grecvw,1,-1
6813 mc=(grecvw-m)*klen
6814 i=istr-m
6815 DO k=lbk,ubk
6816 sizew=sizew+1
6817 jkw=joff+1+(k-lbk)+mc
6818!^ B(i,k)=recvW(jkW)
6819!^
6820 recvw(jkw)=ad_b(i,k)
6821 ad_b(i,k)=0.0_r8
6822 END DO
6823 END DO
6824 END IF
6825 IF (PRESENT(ad_c)) THEN
6826 joff=jkw
6827 DO m=grecvw,1,-1
6828 mc=(grecvw-m)*klen
6829 i=istr-m
6830 DO k=lbk,ubk
6831 sizew=sizew+1
6832 jkw=joff+1+(k-lbk)+mc
6833!^ C(i,k)=recvW(jkW)
6834!^
6835 recvw(jkw)=ad_c(i,k)
6836 ad_c(i,k)=0.0_r8
6837 END DO
6838 END DO
6839 END IF
6840 IF (PRESENT(ad_d)) THEN
6841 joff=jkw
6842 DO m=grecvw,1,-1
6843 mc=(grecvw-m)*klen
6844 i=istr-m
6845 DO k=lbk,ubk
6846 sizew=sizew+1
6847 jkw=joff+1+(k-lbk)+mc
6848!^ D(i,k)=recvW(jkW)
6849!^
6850 recvw(jkw)=ad_d(i,k)
6851 ad_d(i,k)=0.0_r8
6852 END DO
6853 END DO
6854 END IF
6855 END IF
6856!
6857!-----------------------------------------------------------------------
6858! Send and receive Western and Eastern segments.
6859!-----------------------------------------------------------------------
6860!
6861# if defined MPI
6862 IF (wexchange) THEN
6863!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
6864!^ & OCN_COMM_WORLD, Wrequest, Werror)
6865!^
6866 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
6867 & ocn_comm_world, wrequest, werror)
6868 END IF
6869 IF (eexchange) THEN
6870!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
6871!^ & OCN_COMM_WORLD, Erequest, Eerror)
6872!^
6873 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
6874 & ocn_comm_world, erequest, eerror)
6875 END IF
6876 IF (wexchange) THEN
6877!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
6878!^ & OCN_COMM_WORLD, Werror)
6879!^
6880 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
6881 & ocn_comm_world, werror)
6882 END IF
6883 IF (eexchange) THEN
6884!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
6885!^ & OCN_COMM_WORLD, Eerror)
6886!^
6887 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
6888 & ocn_comm_world, eerror)
6889 END IF
6890# endif
6891!
6892! Adjoint of packing tile boundary data including ghost-points.
6893!
6894 IF (wexchange) THEN
6895# ifdef MPI
6896 CALL mpi_wait (wrequest, status(1,1), werror)
6897 IF (werror.ne.mpi_success) THEN
6898 CALL mpi_error_string (werror, string, lstr, ierror)
6899 lstr=len_trim(string)
6900 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
6901 & myrank, werror, string(1:lstr)
6902 exit_flag=2
6903 RETURN
6904 END IF
6905# endif
6906 DO m=1,gsendw
6907 mc=(m-1)*klen
6908 i=istr+m-1
6909 DO k=lbk,ubk
6910 jkw=1+(k-lbk)+mc
6911!^ sendW(jkW)=A(i,k)
6912!^
6913 ad_a(i,k)=ad_a(i,k)+sendw(jkw)
6914 sendw(jkw)=0.0_r8
6915 END DO
6916 END DO
6917 IF (PRESENT(ad_b)) THEN
6918 joff=jkw
6919 DO m=1,gsendw
6920 mc=(m-1)*klen
6921 i=istr+m-1
6922 DO k=lbk,ubk
6923 jkw=joff+1+(k-lbk)+mc
6924!^ sendW(jkW)=B(i,k)
6925!^
6926 ad_b(i,k)=ad_b(i,k)+sendw(jkw)
6927 sendw(jkw)=0.0_r8
6928 END DO
6929 END DO
6930 END IF
6931 IF (PRESENT(ad_c)) THEN
6932 joff=jkw
6933 DO m=1,gsendw
6934 mc=(m-1)*klen
6935 i=istr+m-1
6936 DO k=lbk,ubk
6937 jkw=joff+1+(k-lbk)+mc
6938!^ sendW(jkW)=C(i,k)
6939!^
6940 ad_c(i,k)=ad_c(i,k)+sendw(jkw)
6941 sendw(jkw)=0.0_r8
6942 END DO
6943 END DO
6944 END IF
6945 IF (PRESENT(ad_d)) THEN
6946 joff=jkw
6947 DO m=1,gsendw
6948 mc=(m-1)*klen
6949 i=istr+m-1
6950 DO k=lbk,ubk
6951 jkw=joff+1+(k-lbk)+mc
6952!^ sendW(jkW)=D(i,k)
6953!^
6954 ad_d(i,k)=ad_d(i,k)+sendw(jkw)
6955 sendw(jkw)=0.0_r8
6956 END DO
6957 END DO
6958 END IF
6959 END IF
6960!
6961 IF (eexchange) THEN
6962# ifdef MPI
6963 CALL mpi_wait (erequest, status(1,3), eerror)
6964 IF (eerror.ne.mpi_success) THEN
6965 CALL mpi_error_string (eerror, string, lstr, ierror)
6966 lstr=len_trim(string)
6967 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
6968 & myrank, eerror, string(1:lstr)
6969 exit_flag=2
6970 RETURN
6971 END IF
6972# endif
6973 DO m=1,gsende
6974 mc=(m-1)*klen
6975 i=iend-gsende+m
6976 DO k=lbk,ubk
6977 jke=1+(k-lbk)+mc
6978!^ sendE(jkE)=A(i,k)
6979!^
6980 ad_a(i,k)=ad_a(i,k)+sende(jke)
6981 sende(jke)=0.0_r8
6982 END DO
6983 END DO
6984 IF (PRESENT(ad_b)) THEN
6985 joff=jke
6986 DO m=1,gsende
6987 mc=(m-1)*klen
6988 i=iend-gsende+m
6989 DO k=lbk,ubk
6990 jke=joff+1+(k-lbk)+mc
6991!^ sendE(jkE)=B(i,k)
6992!^
6993 ad_b(i,k)=ad_b(i,k)+sende(jke)
6994 sende(jke)=0.0_r8
6995 END DO
6996 END DO
6997 END IF
6998 IF (PRESENT(ad_c)) THEN
6999 joff=jke
7000 DO m=1,gsende
7001 mc=(m-1)*klen
7002 i=iend-gsende+m
7003 DO k=lbk,ubk
7004 jke=joff+1+(k-lbk)+mc
7005!^ sendE(jkE)=C(i,k)
7006!^
7007 ad_c(i,k)=ad_c(i,k)+sende(jke)
7008 sende(jke)=0.0_r8
7009 END DO
7010 END DO
7011 END IF
7012 IF (PRESENT(ad_d)) THEN
7013 joff=jke
7014 DO m=1,gsende
7015 mc=(m-1)*klen
7016 i=iend-gsende+m
7017 DO k=lbk,ubk
7018 jke=joff+1+(k-lbk)+mc
7019!^ sendE(jkE)=D(i,k)
7020!^
7021 ad_d(i,k)=ad_d(i,k)+sende(jke)
7022 sende(jke)=0.0_r8
7023 END DO
7024 END DO
7025 END IF
7026 END IF
7027
7028# ifdef PROFILE
7029!
7030!-----------------------------------------------------------------------
7031! Turn off time clocks.
7032!-----------------------------------------------------------------------
7033!
7034 CALL wclock_off (ng, model, 63, __line__, myfile)
7035# endif
7036!
7037 RETURN
7038 END SUBROUTINE ad_mp_exchange3d_bry
7039!
7040!***********************************************************************
7041 SUBROUTINE ad_mp_exchange4d (ng, tile, model, Nvar, &
7042 & LBi, UBi, LBj, UBj, LBk, UBk, &
7043 & LBt, UBt, &
7044 & Nghost, EW_periodic, NS_periodic, &
7045 & ad_A, ad_B, ad_C)
7046!***********************************************************************
7047!
7048 USE mod_param
7049 USE mod_parallel
7050 USE mod_iounits
7051 USE mod_scalars
7052!
7053 implicit none
7054!
7055! Imported variable declarations.
7056!
7057 logical, intent(in) :: EW_periodic, NS_periodic
7058!
7059 integer, intent(in) :: ng, tile, model, Nvar
7060 integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk, LBt, UBt
7061 integer, intent(in) :: Nghost
7062!
7063# ifdef ASSUMED_SHAPE
7064 real(r8), intent(inout) :: ad_A(LBi:,LBj:,LBk:,LBt:)
7065
7066 real(r8), intent(inout), optional :: ad_B(LBi:,LBj:,LBk:,LBt:)
7067 real(r8), intent(inout), optional :: ad_C(LBi:,LBj:,LBk:,LBt:)
7068# else
7069 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7070
7071 real(r8), intent(inout), optional :: &
7072 & ad_B(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7073 real(r8), intent(inout), optional :: &
7074 & ad_C(LBi:UBi,LBj:UBj,LBk:UBk,LBt:UBt)
7075# endif
7076!
7077! Local variable declarations.
7078!
7079 logical :: Wexchange, Sexchange, Eexchange, Nexchange
7080!
7081 integer :: i, ikS, ikN, ioff, Imin, Imax, Ilen, IKlen, IKTlen
7082 integer :: j, jkW, jkE, joff, Jmin, Jmax, Jlen, JKlen, JKTlen
7083 integer :: k, kc, m, mc, Ierror, Klen, Lstr, Tlen, pp
7084 integer :: l, lc
7085 integer :: Wtile, GsendW, GrecvW, Wtag, Werror, Wrequest
7086 integer :: Stile, GsendS, GrecvS, Stag, Serror, Srequest
7087 integer :: Etile, GsendE, GrecvE, Etag, Eerror, Erequest
7088 integer :: Ntile, GsendN, GrecvN, Ntag, Nerror, Nrequest
7089 integer :: BufferSizeEW, EWsize, sizeW, sizeE
7090 integer :: BufferSizeNS, NSsize, sizeS, sizeN
7091
7092# ifdef MPI
7093 integer, dimension(MPI_STATUS_SIZE,4) :: status
7094# endif
7095!
7096 real(r8), dimension(Nvar*HaloSizeJ(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: sendW, sendE
7097 real(r8), dimension(Nvar*HaloSizeI(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: sendS, sendN
7098
7099 real(r8), dimension(Nvar*HaloSizeJ(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: recvW, recvE
7100 real(r8), dimension(Nvar*HaloSizeI(ng)*(UBk-LBk+1)* & & (UBt-LBt+1)) :: recvS, recvN
7101!
7102 character (len=MPI_MAX_ERROR_STRING) :: string
7103
7104 character (len=*), parameter :: MyFile = &
7105 & __FILE__//", ad_mp_exchange4d"
7106
7107# include "set_bounds.h"
7108
7109# ifdef PROFILE
7110!
7111!-----------------------------------------------------------------------
7112! Turn on time clocks.
7113!-----------------------------------------------------------------------
7114!
7115 CALL wclock_on (ng, model, 62, __line__, myfile)
7116# endif
7117!
7118!-----------------------------------------------------------------------
7119! Determine rank of tile neighbors and number of ghost-points to
7120! exchange.
7121!-----------------------------------------------------------------------
7122!
7123! Maximum automatic buffer memory size in bytes.
7124!
7125 bmemmax(ng)=max(bmemmax(ng), real((4*SIZE(sendw)+ &
7126 & 4*SIZE(sends))*kind(ad_a),r8))
7127!
7128 CALL tile_neighbors (ng, nghost, ew_periodic, ns_periodic, &
7129 & grecvw, gsendw, wtile, wexchange, &
7130 & grecve, gsende, etile, eexchange, &
7131 & grecvs, gsends, stile, sexchange, &
7132 & grecvn, gsendn, ntile, nexchange)
7133!
7134! Set communication tags.
7135!
7136 wtag=1
7137 stag=2
7138 etag=3
7139 ntag=4
7140!
7141! Determine range and length of the distributed tile boundary segments.
7142!
7143 imin=lbi
7144 imax=ubi
7145 jmin=lbj
7146 jmax=ubj
7147 ilen=imax-imin+1
7148 jlen=jmax-jmin+1
7149 klen=ubk-lbk+1
7150 tlen=ubt-lbt+1
7151 iklen=ilen*klen
7152 jklen=jlen*klen
7153 iktlen=iklen*tlen
7154 jktlen=jklen*tlen
7155 IF (ew_periodic.or.ns_periodic) THEN
7156 pp=1
7157 ELSE
7158 pp=0
7159 END IF
7160 nssize=nvar*(nghost+pp)*iktlen
7161 ewsize=nvar*(nghost+pp)*jktlen
7162 buffersizens=nvar*halosizei(ng)*klen*tlen
7163 buffersizeew=nvar*halosizej(ng)*klen*tlen
7164 IF (SIZE(sende).lt.ewsize) THEN
7165 WRITE (stdout,10) 'EWsize = ', ewsize, SIZE(sende)
7166 10 FORMAT (/,' AD_MP_EXCHANGE4D - communication buffer too', &
7167 & ' small, ',a, 2i8)
7168 END IF
7169 IF (SIZE(sendn).lt.nssize) THEN
7170 WRITE (stdout,10) 'NSsize = ', nssize, SIZE(sendn)
7171 END IF
7172!
7173!-----------------------------------------------------------------------
7174! Adjoint of unpacking Northern and Southern segments.
7175!-----------------------------------------------------------------------
7176!
7177 IF (nexchange) THEN
7178 DO i=1,buffersizens
7179 recvn(i)=0.0_r8
7180 sendn(i)=0.0_r8
7181 END DO
7182 sizen=0
7183 DO m=1,grecvn
7184 mc=(m-1)*iktlen
7185 j=jend+m
7186 DO l=lbt,ubt
7187 lc=(l-lbt)*iklen+mc
7188 DO k=lbk,ubk
7189 kc=(k-lbk)*ilen+lc
7190 DO i=imin,imax
7191 sizen=sizen+1
7192 ikn=1+(i-imin)+kc
7193!^ A(i,j,k,l)=recvN(ikN)
7194!^
7195 recvn(ikn)=ad_a(i,j,k,l)
7196 ad_a(i,j,k,l)=0.0_r8
7197 END DO
7198 END DO
7199 END DO
7200 END DO
7201 IF (PRESENT(ad_b)) THEN
7202 ioff=ikn
7203 DO m=1,grecvn
7204 mc=(m-1)*iktlen
7205 j=jend+m
7206 DO l=lbt,ubt
7207 lc=(l-lbt)*iklen+mc
7208 DO k=lbk,ubk
7209 kc=(k-lbk)*ilen+lc
7210 DO i=imin,imax
7211 sizen=sizen+1
7212 ikn=ioff+1+(i-imin)+kc
7213!^ B(i,j,k,l)=recvN(ikN)
7214!^
7215 recvn(ikn)=ad_b(i,j,k,l)
7216 ad_b(i,j,k,l)=0.0_r8
7217 END DO
7218 END DO
7219 END DO
7220 END DO
7221 END IF
7222 IF (PRESENT(ad_c)) THEN
7223 ioff=ikn
7224 DO m=1,grecvn
7225 mc=(m-1)*iktlen
7226 j=jend+m
7227 DO l=lbt,ubt
7228 lc=(l-lbt)*iklen+mc
7229 DO k=lbk,ubk
7230 kc=(k-lbk)*ilen+lc
7231 DO i=imin,imax
7232 sizen=sizen+1
7233 ikn=ioff+1+(i-imin)+kc
7234!^ C(i,j,k,l)=recvN(ikN)
7235!^
7236 recvn(ikn)=ad_c(i,j,k,l)
7237 ad_c(i,j,k,l)=0.0_r8
7238 END DO
7239 END DO
7240 END DO
7241 END DO
7242 END IF
7243 END IF
7244!
7245 IF (sexchange) THEN
7246 DO i=1,buffersizens
7247 recvs(i)=0.0_r8
7248 sends(i)=0.0_r8
7249 END DO
7250 sizes=0
7251 DO m=grecvs,1,-1
7252 mc=(grecvs-m)*iktlen
7253 j=jstr-m
7254 DO l=lbt,ubt
7255 lc=(l-lbt)*iklen+mc
7256 DO k=lbk,ubk
7257 kc=(k-lbk)*ilen+lc
7258 DO i=imin,imax
7259 sizes=sizes+1
7260 iks=1+(i-imin)+kc
7261!^ A(i,j,k,l)=recvS(ikS)
7262!^
7263 recvs(iks)=ad_a(i,j,k,l)
7264 ad_a(i,j,k,l)=0.0_r8
7265 END DO
7266 END DO
7267 END DO
7268 END DO
7269 IF (PRESENT(ad_b)) THEN
7270 ioff=iks
7271 DO m=grecvs,1,-1
7272 mc=(grecvs-m)*iktlen
7273 j=jstr-m
7274 DO l=lbt,ubt
7275 lc=(l-lbt)*iklen+mc
7276 DO k=lbk,ubk
7277 kc=(k-lbk)*ilen+lc
7278 DO i=imin,imax
7279 sizes=sizes+1
7280 iks=ioff+1+(i-imin)+kc
7281!^ B(i,Jstr-m,k,l)=recvS(ikS)
7282!^
7283 recvs(iks)=ad_b(i,j,k,l)
7284 ad_b(i,j,k,l)=0.0_r8
7285 END DO
7286 END DO
7287 END DO
7288 END DO
7289 END IF
7290 IF (PRESENT(ad_c)) THEN
7291 ioff=iks
7292 DO m=grecvs,1,-1
7293 mc=(grecvs-m)*iktlen
7294 j=jstr-m
7295 DO l=lbt,ubt
7296 lc=(l-lbt)*iklen+mc
7297 DO k=lbk,ubk
7298 kc=(k-lbk)*ilen+lc
7299 DO i=imin,imax
7300 sizes=sizes+1
7301 iks=ioff+1+(i-imin)+kc
7302!^ C(i,Jstr-m,k,l)=recvS(ikS)
7303!^
7304 recvs(iks)=ad_c(i,j,k,l)
7305 ad_c(i,j,k,l)=0.0_r8
7306 END DO
7307 END DO
7308 END DO
7309 END DO
7310 END IF
7311 END IF
7312!
7313!-----------------------------------------------------------------------
7314! Adjoint of send and receive Southern and Northern segments.
7315!-----------------------------------------------------------------------
7316!
7317# if defined MPI
7318 IF (sexchange) THEN
7319!^ CALL mpi_irecv (recvS, NSsize, MP_FLOAT, Stile, Ntag, &
7320!^ & OCN_COMM_WORLD, Srequest, Serror)
7321!^
7322 CALL mpi_irecv (sends, nssize, mp_float, stile, ntag, &
7323 & ocn_comm_world, srequest, serror)
7324 END IF
7325 IF (nexchange) THEN
7326!^ CALL mpi_irecv (recvN, NSsize, MP_FLOAT, Ntile, Stag, &
7327!^ & OCN_COMM_WORLD, Nrequest, Nerror)
7328!^
7329 CALL mpi_irecv (sendn, nssize, mp_float, ntile, stag, &
7330 & ocn_comm_world, nrequest, nerror)
7331 END IF
7332 IF (sexchange) THEN
7333!^ CALL mpi_send (sendS, sizeS, MP_FLOAT, Stile, Stag, &
7334!^ & OCN_COMM_WORLD, Serror)
7335!^
7336 CALL mpi_send (recvs, sizes, mp_float, stile, stag, &
7337 & ocn_comm_world, serror)
7338 END IF
7339 IF (nexchange) THEN
7340!^ CALL mpi_send (sendN, sizeN, MP_FLOAT, Ntile, Ntag, &
7341!^ & OCN_COMM_WORLD, Nerror)
7342!^
7343 CALL mpi_send (recvn, sizen, mp_float, ntile, ntag, &
7344 & ocn_comm_world, nerror)
7345 END IF
7346# endif
7347!
7348! Adjoint of packing tile boundary data including ghost-points.
7349!
7350 IF (sexchange) THEN
7351# ifdef MPI
7352 CALL mpi_wait (srequest, status(1,2), serror)
7353 IF (serror.ne.mpi_success) THEN
7354 CALL mpi_error_string (serror, string, lstr, ierror)
7355 lstr=len_trim(string)
7356 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Southern Edge)', &
7357 & myrank, serror, string(1:lstr)
7358 20 FORMAT (/,' AD_MP_EXCHANGE4D - error during ',a,' call,', &
7359 & ' Node = ', i3.3,' Error = ',i3,/,18x,a)
7360 exit_flag=2
7361 RETURN
7362 END IF
7363# endif
7364 DO m=1,gsends
7365 mc=(m-1)*iktlen
7366 j=jstr+m-1
7367 DO l=lbt,ubt
7368 lc=(l-lbt)*iklen+mc
7369 DO k=lbk,ubk
7370 kc=(k-lbk)*ilen+lc
7371 DO i=imin,imax
7372 iks=1+(i-imin)+kc
7373!^ sendS(ikS)=A(i,j,k,l)
7374!^
7375 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sends(iks)
7376 sends(iks)=0.0_r8
7377 END DO
7378 END DO
7379 END DO
7380 END DO
7381 IF (PRESENT(ad_b)) THEN
7382 ioff=iks
7383 DO m=1,gsends
7384 mc=(m-1)*iktlen
7385 j=jstr+m-1
7386 DO l=lbt,ubt
7387 lc=(l-lbt)*iklen+mc
7388 DO k=lbk,ubk
7389 kc=(k-lbk)*ilen+lc
7390 DO i=imin,imax
7391 iks=ioff+1+(i-imin)+kc
7392!^ sendS(ikS)=B(i,j,k,l)
7393!^
7394 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sends(iks)
7395 sends(iks)=0.0_r8
7396 END DO
7397 END DO
7398 END DO
7399 END DO
7400 END IF
7401 IF (PRESENT(ad_c)) THEN
7402 ioff=iks
7403 DO m=1,gsends
7404 mc=(m-1)*iktlen
7405 j=jstr+m-1
7406 DO l=lbt,ubt
7407 lc=(l-lbt)*iklen+mc
7408 DO k=lbk,ubk
7409 kc=(k-lbk)*ilen+lc
7410 DO i=imin,imax
7411 iks=ioff+1+(i-imin)+kc
7412!^ sendS(ikS)=C(i,j,k,l)
7413!^
7414 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sends(iks)
7415 sends(iks)=0.0_r8
7416 END DO
7417 END DO
7418 END DO
7419 END DO
7420 END IF
7421 END IF
7422!
7423 IF (nexchange) THEN
7424# ifdef MPI
7425 CALL mpi_wait (nrequest, status(1,4), nerror)
7426 IF (nerror.ne.mpi_success) THEN
7427 CALL mpi_error_string (nerror, string, lstr, ierror)
7428 lstr=len_trim(string)
7429 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Northern Edge)', &
7430 & myrank, nerror, string(1:lstr)
7431 exit_flag=2
7432 RETURN
7433 END IF
7434# endif
7435 DO m=1,gsendn
7436 mc=(m-1)*iktlen
7437 j=jend-gsendn+m
7438 DO l=lbt,ubt
7439 lc=(l-lbt)*iklen+mc
7440 DO k=lbk,ubk
7441 kc=(k-lbk)*ilen+lc
7442 DO i=imin,imax
7443 ikn=1+(i-imin)+kc
7444!^ sendN(ikN)=A(i,j,k,l)
7445!^
7446 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sendn(ikn)
7447 sendn(ikn)=0.0_r8
7448 END DO
7449 END DO
7450 END DO
7451 END DO
7452 IF (PRESENT(ad_b)) THEN
7453 ioff=ikn
7454 DO m=1,gsendn
7455 mc=(m-1)*iklen
7456 j=jend-gsendn+m
7457 DO l=lbt,ubt
7458 lc=(l-lbt)*iklen+mc
7459 DO k=lbk,ubk
7460 kc=(k-lbk)*ilen+lc
7461 DO i=imin,imax
7462 ikn=ioff+1+(i-imin)+kc
7463!^ sendN(ikN)=B(i,j,k,l)
7464!^
7465 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sendn(ikn)
7466 sendn(ikn)=0.0_r8
7467 END DO
7468 END DO
7469 END DO
7470 END DO
7471 END IF
7472 IF (PRESENT(ad_c)) THEN
7473 ioff=ikn
7474 DO m=1,gsendn
7475 mc=(m-1)*iklen
7476 j=jend-gsendn+m
7477 DO l=lbt,ubt
7478 lc=(l-lbt)*iklen+mc
7479 DO k=lbk,ubk
7480 kc=(k-lbk)*ilen+lc
7481 DO i=imin,imax
7482 ikn=ioff+1+(i-imin)+kc
7483!^ sendN(ikN)=C(i,j,k,l)
7484!^
7485 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sendn(ikn)
7486 sendn(ikn)=0.0_r8
7487 END DO
7488 END DO
7489 END DO
7490 END DO
7491 END IF
7492 END IF
7493!
7494!-----------------------------------------------------------------------
7495! Adjoint of unpack Eastern and Western segments.
7496!-----------------------------------------------------------------------
7497!
7498 IF (eexchange) THEN
7499 DO i=1,buffersizeew
7500 recve(i)=0.0_r8
7501 sende(i)=0.0_r8
7502 END DO
7503 sizee=0
7504 DO m=1,grecve
7505 mc=(m-1)*jktlen
7506 i=iend+m
7507 DO l=lbt,ubt
7508 lc=(l-lbt)*jklen+mc
7509 DO k=lbk,ubk
7510 kc=(k-lbk)*jlen+lc
7511 DO j=jmin,jmax
7512 sizee=sizee+1
7513 jke=1+(j-jmin)+kc
7514!^ A(i,j,k,l)=recvE(jkE)
7515!^
7516 recve(jke)=ad_a(i,j,k,l)
7517 ad_a(i,j,k,l)=0.0_r8
7518 END DO
7519 END DO
7520 ENDDO
7521 END DO
7522 IF (PRESENT(ad_b)) THEN
7523 joff=jke
7524 DO m=1,grecve
7525 mc=(m-1)*jktlen
7526 i=iend+m
7527 DO l=lbt,ubt
7528 lc=(l-lbt)*jklen+mc
7529 DO k=lbk,ubk
7530 kc=(k-lbk)*jlen+lc
7531 DO j=jmin,jmax
7532 sizee=sizee+1
7533 jke=joff+1+(j-jmin)+kc
7534!^ B(i,j,k,l)=recvE(jkE)
7535!^
7536 recve(jke)=ad_b(i,j,k,l)
7537 ad_b(i,j,k,l)=0.0_r8
7538 END DO
7539 END DO
7540 END DO
7541 END DO
7542 END IF
7543 IF (PRESENT(ad_c)) THEN
7544 joff=jke
7545 DO m=1,grecve
7546 mc=(m-1)*jktlen
7547 i=iend+m
7548 DO l=lbt,ubt
7549 lc=(l-lbt)*jklen+mc
7550 DO k=lbk,ubk
7551 kc=(k-lbk)*jlen+lc
7552 DO j=jmin,jmax
7553 sizee=sizee+1
7554 jke=joff+1+(j-jmin)+kc
7555!^ C(i,j,k,l)=recvE(jkE)
7556!^
7557 recve(jke)=ad_c(i,j,k,l)
7558 ad_c(i,j,k,l)=0.0_r8
7559 END DO
7560 END DO
7561 END DO
7562 END DO
7563 END IF
7564 END IF
7565!
7566 IF (wexchange) THEN
7567 DO i=1,buffersizeew
7568 recvw(i)=0.0_r8
7569 sendw(i)=0.0_r8
7570 END DO
7571 sizew=0
7572 DO m=grecvw,1,-1
7573 mc=(grecvw-m)*jktlen
7574 i=istr-m
7575 DO l=lbt,ubt
7576 lc=(l-lbt)*jklen+mc
7577 DO k=lbk,ubk
7578 kc=(k-lbk)*jlen+lc
7579 DO j=jmin,jmax
7580 sizew=sizew+1
7581 jkw=1+(j-jmin)+kc
7582!^ A(i,j,k,l)=recvW(jkW)
7583!^
7584 recvw(jkw)=ad_a(i,j,k,l)
7585 ad_a(i,j,k,l)=0.0_r8
7586 END DO
7587 END DO
7588 END DO
7589 END DO
7590 IF (PRESENT(ad_b)) THEN
7591 joff=jkw
7592 DO m=grecvw,1,-1
7593 mc=(grecvw-m)*jktlen
7594 i=istr-m
7595 DO l=lbt,ubt
7596 lc=(l-lbt)*jklen+mc
7597 DO k=lbk,ubk
7598 kc=(k-lbk)*jlen+lc
7599 DO j=jmin,jmax
7600 sizew=sizew+1
7601 jkw=joff+1+(j-jmin)+kc
7602!^ B(i,j,k,l)=recvW(jkW)
7603!^
7604 recvw(jkw)=ad_b(i,j,k,l)
7605 ad_b(i,j,k,l)=0.0_r8
7606 END DO
7607 END DO
7608 END DO
7609 END DO
7610 END IF
7611 IF (PRESENT(ad_c)) THEN
7612 joff=jkw
7613 DO m=grecvw,1,-1
7614 mc=(grecvw-m)*jktlen
7615 i=istr-m
7616 DO l=lbt,ubt
7617 lc=(l-lbt)*jklen+mc
7618 DO k=lbk,ubk
7619 kc=(k-lbk)*jlen+lc
7620 DO j=jmin,jmax
7621 sizew=sizew+1
7622 jkw=joff+1+(j-jmin)+kc
7623!^ C(i,j,k,l)=recvW(jkW)
7624!^
7625 recvw(jkw)=ad_c(i,j,k,l)
7626 ad_c(i,j,k,l)=0.0_r8
7627 END DO
7628 END DO
7629 END DO
7630 END DO
7631 END IF
7632 END IF
7633!
7634!-----------------------------------------------------------------------
7635! Send and receive Western and Eastern segments.
7636!-----------------------------------------------------------------------
7637!
7638# if defined MPI
7639 IF (wexchange) THEN
7640!^ CALL mpi_irecv (recvW, EWsize, MP_FLOAT, Wtile, Etag, &
7641!^ & OCN_COMM_WORLD, Wrequest, Werror)
7642!^
7643 CALL mpi_irecv (sendw, ewsize, mp_float, wtile, etag, &
7644 & ocn_comm_world, wrequest, werror)
7645 END IF
7646 IF (eexchange) THEN
7647!^ CALL mpi_irecv (recvE, EWsize, MP_FLOAT, Etile, Wtag, &
7648!^ & OCN_COMM_WORLD, Erequest, Eerror)
7649!^
7650 CALL mpi_irecv (sende, ewsize, mp_float, etile, wtag, &
7651 & ocn_comm_world, erequest, eerror)
7652 END IF
7653 IF (wexchange) THEN
7654!^ CALL mpi_send (sendW, sizeW, MP_FLOAT, Wtile, Wtag, &
7655!^ & OCN_COMM_WORLD, Werror)
7656!^
7657 CALL mpi_send (recvw, sizew, mp_float, wtile, wtag, &
7658 & ocn_comm_world, werror)
7659 END IF
7660 IF (eexchange) THEN
7661!^ CALL mpi_send (sendE, sizeE, MP_FLOAT, Etile, Etag, &
7662!^ & OCN_COMM_WORLD, Eerror)
7663!^
7664 CALL mpi_send (recve, sizee, mp_float, etile, etag, &
7665 & ocn_comm_world, eerror)
7666 END IF
7667# endif
7668!
7669! Adjoint of packing tile boundary data including ghost-points.
7670!
7671 IF (wexchange) THEN
7672# ifdef MPI
7673 CALL mpi_wait (wrequest, status(1,1), werror)
7674 IF (werror.ne.mpi_success) THEN
7675 CALL mpi_error_string (werror, string, lstr, ierror)
7676 lstr=len_trim(string)
7677 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Western Edge)', &
7678 & myrank, werror, string(1:lstr)
7679 exit_flag=2
7680 RETURN
7681 END IF
7682# endif
7683 DO m=1,gsendw
7684 mc=(m-1)*jktlen
7685 i=istr+m-1
7686 DO l=lbt,ubt
7687 lc=(l-lbt)*jklen+mc
7688 DO k=lbk,ubk
7689 kc=(k-lbk)*jlen+lc
7690 DO j=jmin,jmax
7691 jkw=1+(j-jmin)+kc
7692!^ sendW(jkW)=A(i,j,k,l)
7693!^
7694 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sendw(jkw)
7695 sendw(jkw)=0.0_r8
7696 END DO
7697 END DO
7698 END DO
7699 END DO
7700 IF (PRESENT(ad_b)) THEN
7701 joff=jkw
7702 DO m=1,gsendw
7703 mc=(m-1)*jktlen
7704 i=istr+m-1
7705 DO l=lbt,ubt
7706 lc=(l-lbt)*jklen+mc
7707 DO k=lbk,ubk
7708 kc=(k-lbk)*jlen+lc
7709 DO j=jmin,jmax
7710 jkw=joff+1+(j-jmin)+kc
7711!^ sendW(jkW)=B(i,j,k,l)
7712!^
7713 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sendw(jkw)
7714 sendw(jkw)=0.0_r8
7715 END DO
7716 END DO
7717 END DO
7718 END DO
7719 END IF
7720 IF (PRESENT(ad_c)) THEN
7721 joff=jkw
7722 DO m=1,gsendw
7723 mc=(m-1)*jktlen
7724 i=istr+m-1
7725 DO l=lbt,ubt
7726 lc=(l-lbt)*jklen+mc
7727 DO k=lbk,ubk
7728 kc=(k-lbk)*jlen+lc
7729 DO j=jmin,jmax
7730 jkw=joff+1+(j-jmin)+kc
7731!^ sendW(jkW)=C(i,j,k,l)
7732!^
7733 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sendw(jkw)
7734 sendw(jkw)=0.0_r8
7735 END DO
7736 END DO
7737 END DO
7738 END DO
7739 END IF
7740 END IF
7741!
7742 IF (eexchange) THEN
7743# ifdef MPI
7744 CALL mpi_wait (erequest, status(1,3), eerror)
7745 IF (eerror.ne.mpi_success) THEN
7746 CALL mpi_error_string (eerror, string, lstr, ierror)
7747 lstr=len_trim(string)
7748 WRITE (stdout,20) 'MPI_SEND/MPI_IRECV (Eastern Edge)', &
7749 & myrank, eerror, string(1:lstr)
7750 exit_flag=2
7751 RETURN
7752 END IF
7753# endif
7754 DO m=1,gsende
7755 mc=(m-1)*jktlen
7756 i=iend-gsende+m
7757 DO l=lbt,ubt
7758 lc=(l-lbt)*jklen+mc
7759 DO k=lbk,ubk
7760 kc=(k-lbk)*jlen+lc
7761 DO j=jmin,jmax
7762 jke=1+(j-jmin)+kc
7763!^ sendE(jkE)=A(i,j,k,l)
7764!^
7765 ad_a(i,j,k,l)=ad_a(i,j,k,l)+sende(jke)
7766 sende(jke)=0.0_r8
7767 END DO
7768 END DO
7769 END DO
7770 END DO
7771 IF (PRESENT(ad_b)) THEN
7772 joff=jke
7773 DO m=1,gsende
7774 mc=(m-1)*jktlen
7775 i=iend-gsende+m
7776 DO l=lbt,ubt
7777 lc=(l-lbt)*jklen+mc
7778 DO k=lbk,ubk
7779 kc=(k-lbk)*jlen+lc
7780 DO j=jmin,jmax
7781 jke=joff+1+(j-jmin)+kc
7782!^ sendE(jkE)=B(i,j,k,l)
7783!^
7784 ad_b(i,j,k,l)=ad_b(i,j,k,l)+sende(jke)
7785 sende(jke)=0.0_r8
7786 END DO
7787 END DO
7788 END DO
7789 END DO
7790 END IF
7791 IF (PRESENT(ad_c)) THEN
7792 joff=jke
7793 DO m=1,gsende
7794 mc=(m-1)*jktlen
7795 i=iend-gsende+m
7796 DO l=lbt,ubt
7797 lc=(l-lbt)*jklen+mc
7798 DO k=lbk,ubk
7799 kc=(k-lbk)*jlen+lc
7800 DO j=jmin,jmax
7801 jke=joff+1+(j-jmin)+kc
7802!^ sendE(jkE)=C(i,j,k,l)
7803!^
7804 ad_c(i,j,k,l)=ad_c(i,j,k,l)+sende(jke)
7805 sende(jke)=0.0_r8
7806 END DO
7807 END DO
7808 END DO
7809 END DO
7810 END IF
7811 END IF
7812# ifdef PROFILE
7813!
7814!-----------------------------------------------------------------------
7815! Turn off time clocks.
7816!-----------------------------------------------------------------------
7817!
7818 CALL wclock_off (ng, model, 62, __line__, myfile)
7819# endif
7820!
7821 RETURN
7822 END SUBROUTINE ad_mp_exchange4d
7823# endif
7824#endif
7825 END MODULE mp_exchange_mod
7826
mod_iounits
Definition mod_iounits.F:2
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_parallel
Definition mod_parallel.F:2
mod_parallel::mp_float
integer, parameter mp_float
Definition mod_parallel.F:189
mod_parallel::myrank
integer myrank
Definition mod_parallel.F:157
mod_parallel::ocn_comm_world
integer ocn_comm_world
Definition mod_parallel.F:178
mod_param
Definition mod_param.F:2
mod_param::halosizei
integer, dimension(:), allocatable halosizei
Definition mod_param.F:696
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::halosizej
integer, dimension(:), allocatable halosizej
Definition mod_param.F:697
mod_param::bmemmax
real(r8), dimension(:), allocatable bmemmax
Definition mod_param.F:132
mod_param::ntilei
integer, dimension(:), allocatable ntilei
Definition mod_param.F:677
mod_param::ntilej
integer, dimension(:), allocatable ntilej
Definition mod_param.F:678
mod_scalars
Definition mod_scalars.F:2
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::mp_exchange2d_bry
subroutine mp_exchange2d_bry(ng, tile, model, nvar, boundary, lbij, ubij, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:1529
mp_exchange_mod::ad_mp_exchange3d
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:5451
mp_exchange_mod::ad_mp_exchange4d
subroutine ad_mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
Definition mp_exchange.F:7058
mp_exchange_mod::mp_exchange4d
subroutine mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, a, b, c)
Definition mp_exchange.F:3377
mp_exchange_mod::ad_mp_exchange2d
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4058
mp_exchange_mod::mp_exchange2d
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:294
mp_exchange_mod::mp_exchange3d
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2037
mp_exchange_mod::mp_exchange3d_bry
subroutine mp_exchange3d_bry(ng, tile, model, nvar, boundary, lbij, ubij, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2756
mp_exchange_mod::ad_mp_exchange3d_bry
subroutine ad_mp_exchange3d_bry(ng, tile, model, nvar, boundary, lbij, ubij, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:6303
mp_exchange_mod::ad_mp_exchange2d_bry
subroutine ad_mp_exchange2d_bry(ng, tile, model, nvar, boundary, lbij, ubij, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4808
mp_exchange_mod::tile_neighbors
subroutine tile_neighbors(ng, nghost, ew_periodic, ns_periodic, grecvw, gsendw, wtile, wexchange, grecve, gsende, etile, eexchange, grecvs, gsends, stile, sexchange, grecvn, gsendn, ntile, nexchange)
Definition mp_exchange.F:78
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3