New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lbc_lnk_pt2pt_generic.h90 in NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC – NEMO

source: NEMO/branches/2021/dev_r14312_MPI_Interface/src/OCE/LBC/lbc_lnk_pt2pt_generic.h90 @ 14363

Last change on this file since 14363 was 14363, checked in by smasson, 4 years ago

dev_r14312_MPI_Interface: suppress communications involving only land points, #2598
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 15.1 KB
Line 
1
2   SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv )
3      CHARACTER(len=*)              , INTENT(in   ) ::   cdname      ! name of the calling subroutine
4      TYPE(PTR_4d_/**/PRECISION),  DIMENSION(:), INTENT(inout) ::   ptab        ! pointer of arrays on which apply the b.c.
5      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_nat      ! nature of array grid-points
6      REAL(PRECISION),  DIMENSION(:), INTENT(in   ) ::   psgn        ! sign used across the north fold boundary
7      INTEGER                       , INTENT(in   ) ::   kfld        ! number of pt3d arrays
8      INTEGER ,             OPTIONAL, INTENT(in   ) ::   kfillmode   ! filling method for halo over land (default = constant)
9      REAL(PRECISION),      OPTIONAL, INTENT(in   ) ::   pfillval    ! background value (used at closed boundaries)
10      INTEGER ,             OPTIONAL, INTENT(in   ) ::   khls        ! halo size, default = nn_hls
11      LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in   ) ::   lsend, lrecv  ! communication with other 4 proc
12      !
13      INTEGER  ::     ji,   jj,  jk,  jl,  jf, jn     ! dummy loop indices
14      INTEGER  ::    ipi,  ipj, ipk, ipl, ipf         ! dimension of the input array
15      INTEGER  ::   ip0i, ip1i, im0i, im1i
16      INTEGER  ::   ip0j, ip1j, im0j, im1j
17      INTEGER  ::   ishti, ishtj, ishti2, ishtj2
18      INTEGER  ::   ifill_nfd, icomm, ierr
19      INTEGER  ::   ihls, idxs, idxr
20      INTEGER, DIMENSION(4)  ::   isizei, ishtSi, ishtRi, ishtPi
21      INTEGER, DIMENSION(4)  ::   isizej, ishtSj, ishtRj, ishtPj
22      INTEGER, DIMENSION(4)  ::   ifill, iszall, ishtS, ishtR
23      INTEGER, DIMENSION(4)  ::   ireq  ! mpi_request id
24      REAL(PRECISION) ::   zland
25      REAL(PRECISION), DIMENSION(:), ALLOCATABLE  ::   zsnd, zrcv          ! halos arrays
26      LOGICAL, DIMENSION(4)  ::   llsend, llrecv
27      LOGICAL  ::   ll_IdoNFold
28      !!----------------------------------------------------------------------
29      !
30      ! ----------------------------------------- !
31      !     1. local variables initialization     !
32      ! ----------------------------------------- !
33      !
34      ipi = SIZE(ptab(1)%pt4d,1)
35      ipj = SIZE(ptab(1)%pt4d,2)
36      ipk = SIZE(ptab(1)%pt4d,3)
37      ipl = SIZE(ptab(1)%pt4d,4)
38      ipf = kfld
39      !
40      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
41      !
42      ! take care of optional parameters
43      !
44      ihls = nn_hls   ! default definition
45      IF( PRESENT( khls ) )   ihls = khls
46      IF( ihls > n_hlsmax ) THEN
47         WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
48         CALL ctl_stop( 'STOP', ctmp1 )
49      ENDIF
50      IF( ipi /= Ni_0+2*ihls ) THEN
51         WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
52         CALL ctl_stop( 'STOP', ctmp1 )
53      ENDIF
54      IF( ipj /= Nj_0+2*ihls ) THEN
55         WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
56         CALL ctl_stop( 'STOP', ctmp1 )
57      ENDIF
58      !
59      zland = 0._wp                                     ! land filling value: zero by default
60      IF( PRESENT( pfillval ) )   zland = pfillval      ! set land value
61      !
62      ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
63      IF     ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN   ! localy defined neighbourgs
64         llsend(1:4) = lsend(1:4)   ;   llrecv(1:4) = lrecv(1:4)
65      ELSE IF( PRESENT(lsend) .OR.  PRESENT(lrecv) ) THEN
66         WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
67         CALL ctl_stop( 'STOP', ctmp1 )
68      ELSE                                                  ! default neighbours
69         llsend(:) = mpiSnei(ihls,1:4) >= 0
70         llrecv(:) = mpiRnei(ihls,1:4) >= 0
71      END IF
72      !
73      ! define ifill: which method should be used to fill each parts (sides+corners) of the halos
74      ! default definition
75      DO jn = 1, 4
76         IF(             llrecv(jn) ) THEN   ;   ifill(jn) = jpfillmpi    ! with an mpi communication
77         ELSEIF(    l_SelfPerio(jn) ) THEN   ;   ifill(jn) = jpfillperio  ! with self-periodicity
78         ELSEIF( PRESENT(kfillmode) ) THEN   ;   ifill(jn) = kfillmode    ! localy defined
79         ELSE                                ;   ifill(jn) = jpfillcst    ! constant value (zland)
80         END IF
81      END DO
82      ! north fold treatment
83      ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing
84      IF( ll_IdoNFold ) THEN
85         ifill_nfd = ifill(jpno)             ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
86         ifill( (/jpno/) ) = jpfillnothing   ! we do north fold -> do nothing for northern halo
87      ENDIF
88     
89      ! We first define the localization and size of the parts of the array that will be sent (s), received (r)
90      ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
91      ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
92      !
93      ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
94      !                   !                       ________________________
95      ip0i =          0   !          im0j = inner |__|__|__________|__|__|
96      ip1i =       ihls   !   im1j = inner - halo |__|__|__________|__|__|
97      im1i = ipi-2*ihls   !                       |  |  |          |  |  |
98      im0i = ipi - ihls   !                       |  |  |          |  |  |
99      ip0j =          0   !                       |  |  |          |  |  |
100      ip1j =       ihls   !                       |__|__|__________|__|__|
101      im1j = ipj-2*ihls   !           ip1j = halo |__|__|__________|__|__|
102      im0j = ipj - ihls   !              ip0j = 0 |__|__|__________|__|__|
103      !                   !                    ip0i ip1i        im1i im0i
104      !
105      !     sides:     west  east south north
106      isizei(1:4) = (/ ihls, ihls,  ipi,  ipi /)   ! i- count
107      isizej(1:4) = (/  ipj,  ipj, ihls, ihls /)   ! j- count
108      ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /)   ! i- shift send data
109      ishtSj(1:4) = (/ ip0j, ip0j, ip1j, im1j /)   ! j- shift send data
110      ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /)   ! i- shift received data location
111      ishtRj(1:4) = (/ ip0j, ip0j, ip0j, im0j /)   ! j- shift received data location
112      ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /)   ! i- shift data used for periodicity
113      ishtPj(1:4) = (/ ip0j, ip0j, im1j, ip1j /)   ! j- shift data used for periodicity
114      !
115      ! -------------------------------- !
116      !     2. Prepare MPI exchanges     !
117      ! -------------------------------- !
118      !
119      ireq(:) = MPI_REQUEST_NULL
120      iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
121      ishtS(1) = 0
122      DO jn = 2,4
123         ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )   ! with _alltoallv: in units of sendtype
124      END DO
125      ishtR(1) = 0
126      DO jn = 2,4
127         ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )   ! with _alltoallv: in units of sendtype
128      END DO
129
130      ! Allocate local temporary arrays to be sent/received.
131      ALLOCATE( zsnd( SUM(iszall, mask = llsend) ), zrcv( SUM(iszall, mask = llrecv) ) )
132      !
133      ! -------------------------------------------------- !
134      !     3. Do east and west MPI exchange if needed     !
135      ! -------------------------------------------------- !
136      !
137      ! fill sending buffer with ARRAY_IN
138      idxs = 1
139      DO jn = 1, 2
140         IF( llsend(jn) ) THEN
141            ishti = ishtSi(jn)
142            ishtj = ishtSj(jn)
143            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
144               zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
145               idxs = idxs + 1
146            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
147         END IF
148      END DO
149      !
150#if ! defined key_mpi_off
151      IF( ln_timing ) CALL tic_tac(.TRUE.)
152      !
153      icomm = mpi_comm_oce        ! shorter name
154      ! non-blocking send of the western/eastern side using local temporary arrays
155      jn = jpwe
156      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 1, icomm, ireq(jn), ierr )
157      jn = jpea
158      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 2, icomm, ireq(jn), ierr )
159      ! blocking receive of the western/eastern halo in local temporary arrays
160      jn = jpwe
161      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 2, icomm, MPI_STATUS_IGNORE, ierr )
162      jn = jpea
163      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 1, icomm, MPI_STATUS_IGNORE, ierr )
164      !
165      IF( ln_timing ) CALL tic_tac(.FALSE.)
166#endif
167      !
168      ! ----------------------------------- !
169      !     4. Fill east and west halos     !
170      ! ----------------------------------- !
171      !
172      idxr = 1
173      DO jn = 1, 2
174         ishti = ishtRi(jn)
175         ishtj = ishtRj(jn)
176         SELECT CASE ( ifill(jn) )
177         CASE ( jpfillnothing )               ! no filling
178         CASE ( jpfillmpi   )                 ! fill with data received by MPI
179            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
180               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr)
181               idxr = idxr + 1
182            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
183         CASE ( jpfillperio )                 ! use periodicity
184            ishti2 = ishtPi(jn)
185            ishtj2 = ishtPj(jn)
186            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
187               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
188            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
189         CASE ( jpfillcopy  )                 ! filling with inner domain values
190            ishti2 = ishtSi(jn)
191            ishtj2 = ishtSj(jn)
192            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
193               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
194            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
195         CASE ( jpfillcst   )                 ! filling with constant value
196            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
197               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
198            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
199         END SELECT
200      END DO
201      !
202      ! ------------------------------- !
203      !     5. north fold treatment     !
204      ! ------------------------------- !
205      !
206      ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor
207      !
208      IF( ll_IdoNFold ) THEN
209         IF( jpni == 1 )  THEN   ;   CALL lbc_nfd( ptab, cd_nat, psgn                  , ihls, ipf )   ! self NFold
210         ELSE                    ;   CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf )   ! mpi  NFold
211         ENDIF
212      ENDIF
213      !
214      ! ---------------------------------------------------- !
215      !     6. Do north and south MPI exchange if needed     !
216      ! ---------------------------------------------------- !
217      !
218      DO jn = 3, 4
219         IF( llsend(jn) ) THEN
220            ishti = ishtSi(jn)
221            ishtj = ishtSj(jn)
222            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
223               zsnd(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
224               idxs = idxs + 1
225            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
226         END IF
227      END DO
228      !
229#if ! defined key_mpi_off
230      IF( ln_timing ) CALL tic_tac(.TRUE.)
231      !
232      ! non-blocking send of the western/eastern side using local temporary arrays
233      jn = jpso
234      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 3, icomm, ireq(jn), ierr )
235      jn = jpno
236      IF( llsend(jn) )   CALL MPI_ISEND( zsnd(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), 4, icomm, ireq(jn), ierr )
237      ! blocking receive of the western/eastern halo in local temporary arrays
238      jn = jpso
239      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 4, icomm, MPI_STATUS_IGNORE, ierr )
240      jn = jpno
241      IF( llrecv(jn) )   CALL MPI_RECV(  zrcv(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), 3, icomm, MPI_STATUS_IGNORE, ierr )
242      !
243      IF( ln_timing ) CALL tic_tac(.FALSE.)
244#endif
245      !
246      ! ------------------------------------- !
247      !     7. Fill south and north halos     !
248      ! ------------------------------------- !
249      !
250      DO jn = 3, 4
251         ishti = ishtRi(jn)
252         ishtj = ishtRj(jn)
253         SELECT CASE ( ifill(jn) )
254         CASE ( jpfillnothing )               ! no filling
255         CASE ( jpfillmpi   )                 ! fill with data received by MPI
256            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
257               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zrcv(idxr)
258               idxr = idxr + 1
259            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
260         CASE ( jpfillperio )                 ! use periodicity
261            ishti2 = ishtPi(jn)
262            ishtj2 = ishtPj(jn)
263            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
264               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
265            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
266         CASE ( jpfillcopy  )                 ! filling with inner domain values
267            ishti2 = ishtSi(jn)
268            ishtj2 = ishtSj(jn)
269            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
270               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
271            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
272         CASE ( jpfillcst   )                 ! filling with constant value
273            DO jf = 1, ipf  ;  DO jl = 1, ipl  ;  DO jk = 1, ipk  ;  DO jj = 1,isizej(jn)  ;  DO ji = 1,isizei(jn)
274               ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
275            END DO   ;   END DO   ;   END DO   ;   END DO   ;   END DO
276         END SELECT
277      END DO
278      !
279      ! -------------------------------------------- !
280      !     8. deallocate local temporary arrays     !
281      ! -------------------------------------------- !
282      !
283      CALL mpi_waitall(4, ireq, MPI_STATUSES_IGNORE, ierr)
284      DEALLOCATE( zsnd, zrcv )
285      !
286   END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION
287
Note: See TracBrowser for help on using the repository browser.