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_nfd_nogather_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_nfd_nogather_generic.h90 @ 14349

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

dev_r14312_MPI_Interface: further simplifications of lbclk and lbcnfd, #2598
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 13.8 KB
Line 
1
2   SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn )
3      !!----------------------------------------------------------------------
4      !!
5      !! ** Purpose :   lateral boundary condition : North fold treatment
6      !!                without allgather exchanges.
7      !!
8      !!----------------------------------------------------------------------
9      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab        !
10      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab2       !
11      CHARACTER(len=1)                    , INTENT(in   ) ::   cd_nat      ! nature of array grid-points
12      REAL(PRECISION)                     , INTENT(in   ) ::   psgn        ! sign used across the north fold boundary
13      !
14      INTEGER  ::    ji,  jj, jk,  jn,  jl, jh       ! dummy loop indices
15      INTEGER  ::   ipk, ipl, ii, iij, ijj      ! dimension of the input array
16      INTEGER  ::   ijt, iju, ijta, ijua, jia, startloop, endloop
17      LOGICAL  ::   l_fast_exchanges
18      !!----------------------------------------------------------------------
19      ipk = SIZE(ptab,3)
20      ipl = SIZE(ptab,4)
21      !
22      ! 2nd dimension determines exchange speed
23      l_fast_exchanges = SIZE(ptab2,2) == 1
24      !
25      IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot
26         !
27         SELECT CASE ( cd_nat )
28            !
29         CASE ( 'T' , 'W' )                         ! T-, W-point
30            IF ( nimpp /= 1 ) THEN  ;  startloop = 1 
31            ELSE                    ;  startloop = 1 + nn_hls
32            ENDIF
33            !
34            DO jl = 1, ipl; DO jk = 1, ipk
35               DO jj = 1, nn_hls
36                  ijj = jpj -jj +1
37                  DO ji = startloop, jpi
38                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
39                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
40                  END DO
41               END DO
42            END DO; END DO
43            IF( nimpp == 1 ) THEN
44               DO jl = 1, ipl; DO jk = 1, ipk
45                  DO jj = 1, nn_hls
46                     ijj = jpj -jj +1
47                     DO ii = 0, nn_hls-1
48                        ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl)
49                     END DO
50                  END DO
51               END DO; END DO
52            ENDIF
53            !
54            IF ( .NOT. l_fast_exchanges ) THEN
55               IF( nimpp >= Ni0glo/2+2 ) THEN
56                  startloop = 1
57               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
58                  startloop = Ni0glo/2+2 - nimpp + nn_hls
59               ELSE
60                  startloop = jpi + 1
61               ENDIF
62               IF( startloop <= jpi ) THEN
63                  DO jl = 1, ipl; DO jk = 1, ipk
64                     DO ji = startloop, jpi
65                        ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
66                        jia  = ji + nimpp - 1
67                        ijta = jpiglo - jia + 2
68                        IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
69                           ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl)
70                        ELSE
71                           ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl)
72                        ENDIF
73                     END DO
74                  END DO; END DO
75               ENDIF
76            ENDIF
77         CASE ( 'U' )                                     ! U-point
78            IF( nimpp + jpi - 1 /= jpiglo ) THEN
79               endloop = jpi
80            ELSE
81               endloop = jpi - nn_hls
82            ENDIF
83            DO jl = 1, ipl; DO jk = 1, ipk
84               DO jj = 1, nn_hls
85                  ijj = jpj -jj +1
86                  DO ji = 1, endloop
87                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
88                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
89                  END DO
90               END DO
91            END DO; END DO
92            IF (nimpp .eq. 1) THEN
93               DO jj = 1, nn_hls
94                  ijj = jpj -jj +1
95                  DO ii = 0, nn_hls-1
96                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:)
97                  END DO
98               END DO
99            ENDIF
100            IF((nimpp + jpi - 1) .eq. jpiglo) THEN
101               DO jj = 1, nn_hls
102                  ijj = jpj -jj +1
103                  DO ii = 1, nn_hls
104                     ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:)
105                  END DO
106               END DO
107            ENDIF
108            !
109            IF ( .NOT. l_fast_exchanges ) THEN
110               IF( nimpp + jpi - 1 /= jpiglo ) THEN
111                  endloop = jpi
112               ELSE
113                  endloop = jpi - nn_hls
114               ENDIF
115               IF( nimpp >= Ni0glo/2+1 ) THEN
116                  startloop = nn_hls
117               ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN
118                  startloop = Ni0glo/2+1 - nimpp + nn_hls 
119               ELSE
120                  startloop = endloop + 1
121               ENDIF
122               IF( startloop <= endloop ) THEN
123                  DO jl = 1, ipl; DO jk = 1, ipk
124                     DO ji = startloop, endloop
125                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
126                        jia = ji + nimpp - 1 
127                        ijua = jpiglo - jia + 1 
128                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
129                           ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-nn_hls,jk,jl)
130                        ELSE
131                           ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl)
132                        ENDIF
133                     END DO
134                  END DO; END DO
135               ENDIF
136            ENDIF
137            !
138         CASE ( 'V' )                                     ! V-point
139            IF( nimpp /= 1 ) THEN
140               startloop = 1 
141            ELSE
142               startloop = 1 + nn_hls
143            ENDIF
144            IF ( .NOT. l_fast_exchanges ) THEN
145               DO jl = 1, ipl; DO jk = 1, ipk
146                  DO jj = 2, nn_hls+1
147                     ijj = jpj -jj +1
148                     DO ji = startloop, jpi
149                        ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
150                        ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
151                     END DO
152                  END DO
153               END DO; END DO
154            ENDIF
155            DO jl = 1, ipl; DO jk = 1, ipk
156               DO ji = startloop, jpi
157                  ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
158                  ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl)
159               END DO
160            END DO; END DO
161            IF (nimpp .eq. 1) THEN
162               DO jj = 1, nn_hls
163                  ijj = jpj-jj+1
164                  DO ii = 0, nn_hls-1
165                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:)
166                  END DO
167               END DO
168            ENDIF
169         CASE ( 'F' )                                     ! F-point
170            IF( nimpp + jpi - 1 /= jpiglo ) THEN
171               endloop = jpi
172            ELSE
173               endloop = jpi - nn_hls
174            ENDIF
175            IF ( .NOT. l_fast_exchanges ) THEN
176               DO jl = 1, ipl; DO jk = 1, ipk
177                  DO jj = 2, nn_hls+1
178                     ijj = jpj -jj +1
179                     DO ji = 1, endloop
180                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
181                        ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
182                     END DO
183                  END DO
184               END DO; END DO
185            ENDIF
186            DO jl = 1, ipl; DO jk = 1, ipk
187               DO ji = 1, endloop
188                  iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
189                  ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl)
190               END DO
191            END DO; END DO
192            IF (nimpp .eq. 1) THEN               
193               DO ii = 1, nn_hls
194                  ptab(ii,jpj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls-1,:,:)
195               END DO
196               IF ( .NOT. l_fast_exchanges ) THEN
197                  DO jj = 1, nn_hls
198                     ijj = jpj -jj
199                     DO ii = 0, nn_hls-1
200                        ptab(ii+1,ijj,:,:) = psgn * ptab(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:)
201                     END DO
202                  END DO
203               ENDIF
204            ENDIF
205            IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN
206               DO ii = 1, nn_hls
207                  ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:)
208               END DO
209               IF ( .NOT. l_fast_exchanges ) THEN
210                  DO jj = 1, nn_hls
211                     ijj = jpj -jj
212                     DO ii = 1, nn_hls
213                        ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:)
214                     END DO
215                  END DO
216               ENDIF
217            ENDIF
218            !
219         END SELECT
220         !
221      ENDIF   ! c_NFtype == 'T'
222      !
223      IF( c_NFtype == 'F' ) THEN           ! *  North fold  F-point pivot
224         !
225         SELECT CASE ( cd_nat )
226         CASE ( 'T' , 'W' )                               ! T-, W-point
227            DO jl = 1, ipl; DO jk = 1, ipk
228               DO jj = 1, nn_hls
229                  ijj = jpj-jj+1
230                  DO ji = 1, jpi
231                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
232                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
233                  END DO
234               END DO
235            END DO; END DO
236            !
237         CASE ( 'U' )                                     ! U-point
238            IF( nimpp + jpi - 1 /= jpiglo ) THEN
239               endloop = jpi
240            ELSE
241               endloop = jpi - nn_hls
242            ENDIF
243            DO jl = 1, ipl; DO jk = 1, ipk
244               DO jj = 1, nn_hls
245                  ijj = jpj-jj+1
246                  DO ji = 1, endloop
247                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
248                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
249                  END DO
250               END DO
251            END DO; END DO
252            IF(nimpp + jpi - 1 .eq. jpiglo) THEN
253               DO jl = 1, ipl; DO jk = 1, ipk
254                  DO jj = 1, nn_hls
255                     ijj = jpj-jj+1
256                     DO ii = 1, nn_hls
257                        iij = jpi-ii+1
258                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl)
259                     END DO
260                  END DO
261               END DO; END DO
262            ENDIF
263            !
264         CASE ( 'V' )                                     ! V-point
265            DO jl = 1, ipl; DO jk = 1, ipk
266               DO jj = 1, nn_hls
267                  ijj = jpj -jj +1
268                  DO ji = 1, jpi
269                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
270                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
271                  END DO
272               END DO
273            END DO; END DO
274
275            IF ( .NOT. l_fast_exchanges ) THEN
276               IF( nimpp >= Ni0glo/2+2 ) THEN
277                  startloop = 1
278               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
279                  startloop = Ni0glo/2+2 - nimpp + nn_hls
280               ELSE
281                  startloop = jpi + 1
282               ENDIF
283               IF( startloop <= jpi ) THEN
284                  DO jl = 1, ipl; DO jk = 1, ipk
285                     DO ji = startloop, jpi
286                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
287                        ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(ijt,nn_hls+1,jk,jl)
288                     END DO
289                  END DO; END DO
290               ENDIF
291            ENDIF
292            !
293         CASE ( 'F' )                               ! F-point
294            IF( nimpp + jpi - 1 /= jpiglo ) THEN
295               endloop = jpi
296            ELSE
297               endloop = jpi - nn_hls
298            ENDIF
299            DO jl = 1, ipl; DO jk = 1, ipk
300               DO jj = 1, nn_hls
301                  ijj = jpj -jj +1
302                  DO ji = 1, endloop
303                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
304                     ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
305                  END DO
306               END DO
307            END DO; END DO
308            IF((nimpp + jpi - 1) .eq. jpiglo) THEN
309               DO jl = 1, ipl; DO jk = 1, ipk
310                  DO jj = 1, nn_hls
311                     ijj = jpj -jj +1
312                     DO ii = 1, nn_hls
313                        iij = jpi -ii+1
314                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl)
315                     END DO
316                  END DO
317               END DO; END DO
318            ENDIF
319            !
320            IF ( .NOT. l_fast_exchanges ) THEN
321               IF( nimpp + jpi - 1 /= jpiglo ) THEN
322                  endloop = jpi
323               ELSE
324                  endloop = jpi - nn_hls
325               ENDIF
326               IF( nimpp >= Ni0glo/2+2 ) THEN
327                  startloop = 1 
328               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
329                  startloop = Ni0glo/2+2 - nimpp + nn_hls
330               ELSE
331                  startloop = endloop + 1
332               ENDIF
333               IF( startloop <= endloop ) THEN
334                  DO jl = 1, ipl; DO jk = 1, ipk
335                     DO ji = startloop, endloop
336                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
337                        ptab(ji,jpj-nn_hls,jk,jl) = psgn * ptab2(iju,nn_hls+1,jk,jl)
338                     END DO
339                  END DO; END DO
340               ENDIF
341            ENDIF
342            !
343         END SELECT
344         !
345      ENDIF   ! c_NFtype == 'F'
346      !
347   END SUBROUTINE lbc_nfd_nogather_/**/PRECISION
348
Note: See TracBrowser for help on using the repository browser.