1 | |
---|
2 | #if ! defined BLOCK_ISEND && ! defined BLOCK_FILL |
---|
3 | SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only ) |
---|
4 | CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine |
---|
5 | TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c. |
---|
6 | CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points |
---|
7 | REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary |
---|
8 | INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays |
---|
9 | INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant) |
---|
10 | REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries) |
---|
11 | INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls |
---|
12 | LOGICAL, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc |
---|
13 | LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners) |
---|
14 | ! |
---|
15 | INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices |
---|
16 | INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array |
---|
17 | INTEGER :: ip0i, ip1i, im0i, im1i |
---|
18 | INTEGER :: ip0j, ip1j, im0j, im1j |
---|
19 | INTEGER :: ishti, ishtj, ishti2, ishtj2 |
---|
20 | INTEGER :: ifill_nfd, icomm, ierr |
---|
21 | INTEGER :: ihls, idxs, idxr, iszS, iszR |
---|
22 | INTEGER, DIMENSION(4) :: iwewe, issnn |
---|
23 | INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi |
---|
24 | INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj |
---|
25 | INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR |
---|
26 | INTEGER, DIMENSION(8) :: ireq ! mpi_request id |
---|
27 | INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id |
---|
28 | REAL(PRECISION) :: zland |
---|
29 | LOGICAL, DIMENSION(8) :: llsend, llrecv |
---|
30 | LOGICAL :: ll4only ! default: 8 neighbourgs |
---|
31 | LOGICAL :: ll_IdoNFold |
---|
32 | !!---------------------------------------------------------------------- |
---|
33 | ! |
---|
34 | ! ----------------------------------------- ! |
---|
35 | ! 1. local variables initialization ! |
---|
36 | ! ----------------------------------------- ! |
---|
37 | ! |
---|
38 | ipi = SIZE(ptab(1)%pt4d,1) |
---|
39 | ipj = SIZE(ptab(1)%pt4d,2) |
---|
40 | ipk = SIZE(ptab(1)%pt4d,3) |
---|
41 | ipl = SIZE(ptab(1)%pt4d,4) |
---|
42 | ipf = kfld |
---|
43 | ! |
---|
44 | IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) |
---|
45 | ! |
---|
46 | idxs = 1 ! initalize index for send buffer |
---|
47 | idxr = 1 ! initalize index for recv buffer |
---|
48 | icomm = mpi_comm_oce ! shorter name |
---|
49 | ! |
---|
50 | ! take care of optional parameters |
---|
51 | ! |
---|
52 | ihls = nn_hls ! default definition |
---|
53 | IF( PRESENT( khls ) ) ihls = khls |
---|
54 | IF( ihls > n_hlsmax ) THEN |
---|
55 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax |
---|
56 | CALL ctl_stop( 'STOP', ctmp1 ) |
---|
57 | ENDIF |
---|
58 | IF( ipi /= Ni_0+2*ihls ) THEN |
---|
59 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0 |
---|
60 | CALL ctl_stop( 'STOP', ctmp1 ) |
---|
61 | ENDIF |
---|
62 | IF( ipj /= Nj_0+2*ihls ) THEN |
---|
63 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0 |
---|
64 | CALL ctl_stop( 'STOP', ctmp1 ) |
---|
65 | ENDIF |
---|
66 | ! |
---|
67 | ll4only = .FALSE. ! default definition |
---|
68 | IF( PRESENT(ld4only) ) ll4only = ld4only |
---|
69 | ! |
---|
70 | zland = 0._wp ! land filling value: zero by default |
---|
71 | IF( PRESENT( pfillval ) ) zland = pfillval ! set land value |
---|
72 | ! |
---|
73 | ! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not. |
---|
74 | IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs |
---|
75 | llsend(1:4) = lsend(1:4) ; llrecv(1:4) = lrecv(1:4) |
---|
76 | ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN |
---|
77 | WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' |
---|
78 | CALL ctl_stop( 'STOP', ctmp1 ) |
---|
79 | ELSE ! default neighbours |
---|
80 | llsend(:) = mpiSnei(ihls,:) >= 0 |
---|
81 | IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners |
---|
82 | llrecv(:) = mpiRnei(ihls,:) >= 0 |
---|
83 | IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners |
---|
84 | ENDIF |
---|
85 | ! |
---|
86 | ! define ifill: which method should be used to fill each parts (sides+corners) of the halos |
---|
87 | ! default definition |
---|
88 | DO jn = 1, 4 |
---|
89 | IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication |
---|
90 | ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity |
---|
91 | ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined |
---|
92 | ELSE ; ifill(jn) = jpfillcst ! constant value (zland) |
---|
93 | ENDIF |
---|
94 | END DO |
---|
95 | DO jn = 5, 8 |
---|
96 | IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication |
---|
97 | ELSE ; ifill(jn) = jpfillnothing! do nothing |
---|
98 | ENDIF |
---|
99 | END DO |
---|
100 | ! |
---|
101 | ! north fold treatment |
---|
102 | ll_IdoNFold = l_IdoNFold .AND. ifill(jpno) /= jpfillnothing |
---|
103 | IF( ll_IdoNFold ) THEN |
---|
104 | ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false. |
---|
105 | ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo |
---|
106 | ENDIF |
---|
107 | |
---|
108 | ! We first define the localization and size of the parts of the array that will be sent (s), received (r) |
---|
109 | ! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions. |
---|
110 | ! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array |
---|
111 | ! |
---|
112 | ! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls |
---|
113 | ! ! ________________________ |
---|
114 | ip0i = 0 ! im0j = inner |__|__|__________|__|__| |
---|
115 | ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__| |
---|
116 | im1i = ipi-2*ihls ! | | | | | | |
---|
117 | im0i = ipi - ihls ! | | | | | | |
---|
118 | ip0j = 0 ! | | | | | | |
---|
119 | ip1j = ihls ! |__|__|__________|__|__| |
---|
120 | im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__| |
---|
121 | im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__| |
---|
122 | ! ! ip0i ip1i im1i im0i |
---|
123 | ! |
---|
124 | iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /) |
---|
125 | !cd sides: west east south north ; corners: so-we, so-ea, no-we, no-ea |
---|
126 | isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count |
---|
127 | isizej(1:4) = (/ ipj, ipj, ihls, ihls /) ; isizej(5:8) = ihls ! j- count |
---|
128 | ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data |
---|
129 | ishtSj(1:4) = (/ ip0j, ip0j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data |
---|
130 | ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location |
---|
131 | ishtRj(1:4) = (/ ip0j, ip0j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location |
---|
132 | ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity |
---|
133 | ishtPj(1:4) = (/ ip0j, ip0j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity |
---|
134 | ! |
---|
135 | ! -------------------------------- ! |
---|
136 | ! 2. Prepare MPI exchanges ! |
---|
137 | ! -------------------------------- ! |
---|
138 | ! |
---|
139 | iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different |
---|
140 | ! define iRtag with the corresponding iStag, e.g. data received at west where sent at east. |
---|
141 | iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso) |
---|
142 | iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw) |
---|
143 | ! |
---|
144 | iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf |
---|
145 | ishtS(1) = 0 |
---|
146 | DO jn = 2, 8 |
---|
147 | ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) ) |
---|
148 | END DO |
---|
149 | ishtR(1) = 0 |
---|
150 | DO jn = 2, 8 |
---|
151 | ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) ) |
---|
152 | END DO |
---|
153 | |
---|
154 | ! Allocate buffer arrays to be sent/received if needed |
---|
155 | iszS = SUM(iszall, mask = llsend) ! send buffer size |
---|
156 | IF( ALLOCATED(BUFFSND) ) THEN |
---|
157 | CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call |
---|
158 | IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small |
---|
159 | ENDIF |
---|
160 | IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) ) |
---|
161 | iszR = SUM(iszall, mask = llrecv) ! recv buffer size |
---|
162 | IF( ALLOCATED(BUFFRCV) ) THEN |
---|
163 | IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small |
---|
164 | ENDIF |
---|
165 | IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) ) |
---|
166 | ! |
---|
167 | ! default definition when no communication is done. understood by mpi_waitall |
---|
168 | nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above |
---|
169 | ! |
---|
170 | ! ----------------------------------------------- ! |
---|
171 | ! 3. Do east and west MPI_Isend if needed ! |
---|
172 | ! ----------------------------------------------- ! |
---|
173 | ! |
---|
174 | DO jn = 1, 2 |
---|
175 | #define BLOCK_ISEND |
---|
176 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
177 | #undef BLOCK_ISEND |
---|
178 | END DO |
---|
179 | ! |
---|
180 | ! ----------------------------------- ! |
---|
181 | ! 4. Fill east and west halos ! |
---|
182 | ! ----------------------------------- ! |
---|
183 | ! |
---|
184 | DO jn = 1, 2 |
---|
185 | #define BLOCK_FILL |
---|
186 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
187 | #undef BLOCK_FILL |
---|
188 | END DO |
---|
189 | ! |
---|
190 | ! ------------------------------------------------- ! |
---|
191 | ! 5. Do north and south MPI_Isend if needed ! |
---|
192 | ! ------------------------------------------------- ! |
---|
193 | ! |
---|
194 | DO jn = 3, 4 |
---|
195 | #define BLOCK_ISEND |
---|
196 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
197 | #undef BLOCK_ISEND |
---|
198 | END DO |
---|
199 | ! |
---|
200 | ! ------------------------------- ! |
---|
201 | ! 6. north fold treatment ! |
---|
202 | ! ------------------------------- ! |
---|
203 | ! |
---|
204 | ! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...) |
---|
205 | ! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data |
---|
206 | ! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data |
---|
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 | ! 7. Fill south and north halos ! |
---|
216 | ! ------------------------------------- ! |
---|
217 | ! |
---|
218 | DO jn = 3, 4 |
---|
219 | #define BLOCK_FILL |
---|
220 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
221 | #undef BLOCK_FILL |
---|
222 | END DO |
---|
223 | ! |
---|
224 | ! ----------------------------------------------- ! |
---|
225 | ! 8. Specific problem in corner treatment ! |
---|
226 | ! ( very rate case... ) ! |
---|
227 | ! ----------------------------------------------- ! |
---|
228 | ! |
---|
229 | DO jn = 5, 8 |
---|
230 | #define BLOCK_ISEND |
---|
231 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
232 | #undef BLOCK_ISEND |
---|
233 | END DO |
---|
234 | DO jn = 5, 8 |
---|
235 | #define BLOCK_FILL |
---|
236 | # include "lbc_lnk_pt2pt_generic.h90" |
---|
237 | #undef BLOCK_FILL |
---|
238 | END DO |
---|
239 | ! |
---|
240 | ! -------------------------------------------- ! |
---|
241 | ! 9. deallocate local temporary arrays ! |
---|
242 | ! if they areg larger than jpi*jpj ! <- arbitrary max size... |
---|
243 | ! -------------------------------------------- ! |
---|
244 | ! |
---|
245 | IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking receive -> can directly deallocate |
---|
246 | IF( iszS > jpi*jpj ) THEN |
---|
247 | CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! must wait before deallocate send buffer |
---|
248 | DEALLOCATE(BUFFSND) |
---|
249 | ENDIF |
---|
250 | ! |
---|
251 | END SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION |
---|
252 | #endif |
---|
253 | |
---|
254 | #if defined BLOCK_ISEND |
---|
255 | IF( llsend(jn) ) THEN |
---|
256 | ishti = ishtSi(jn) |
---|
257 | ishtj = ishtSj(jn) |
---|
258 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
---|
259 | BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) |
---|
260 | idxs = idxs + 1 |
---|
261 | END DO ; END DO ; END DO ; END DO ; END DO |
---|
262 | #if ! defined key_mpi_off |
---|
263 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
---|
264 | ! non-blocking send of the west/east side using local buffer |
---|
265 | CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr ) |
---|
266 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
---|
267 | #endif |
---|
268 | ENDIF |
---|
269 | #endif |
---|
270 | |
---|
271 | #if defined BLOCK_FILL |
---|
272 | ishti = ishtRi(jn) |
---|
273 | ishtj = ishtRj(jn) |
---|
274 | SELECT CASE ( ifill(jn) ) |
---|
275 | CASE ( jpfillnothing ) ! no filling |
---|
276 | CASE ( jpfillmpi ) ! fill with data received by MPI |
---|
277 | #if ! defined key_mpi_off |
---|
278 | IF( ln_timing ) CALL tic_tac(.TRUE.) |
---|
279 | ! ! blocking receive of the west/east halo in local temporary arrays |
---|
280 | CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr ) |
---|
281 | IF( ln_timing ) CALL tic_tac(.FALSE.) |
---|
282 | #endif |
---|
283 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
---|
284 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr) |
---|
285 | idxr = idxr + 1 |
---|
286 | END DO ; END DO ; END DO ; END DO ; END DO |
---|
287 | CASE ( jpfillperio ) ! use periodicity |
---|
288 | ishti2 = ishtPi(jn) |
---|
289 | ishtj2 = ishtPj(jn) |
---|
290 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
---|
291 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
---|
292 | END DO ; END DO ; END DO ; END DO ; END DO |
---|
293 | CASE ( jpfillcopy ) ! filling with inner domain values |
---|
294 | ishti2 = ishtSi(jn) |
---|
295 | ishtj2 = ishtSj(jn) |
---|
296 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
---|
297 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl) |
---|
298 | END DO ; END DO ; END DO ; END DO ; END DO |
---|
299 | CASE ( jpfillcst ) ! filling with constant value |
---|
300 | DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn) |
---|
301 | ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland |
---|
302 | END DO ; END DO ; END DO ; END DO ; END DO |
---|
303 | END SELECT |
---|
304 | #endif |
---|