source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 13266

Last change on this file since 13266 was 13247, checked in by francesca, 5 months ago

dev_r12558_HPC-08_epico_Extra_Halo: merge with trunk@13227, see #2366

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 18.5 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   if defined DIM_2d
6#      if defined SINGLE_PRECISION
7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)
8#      else
9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)
10#      endif 
11#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
12#      define K_SIZE(ptab)             1
13#      define L_SIZE(ptab)             1
14#   endif
15#   if defined DIM_3d
16#      if defined SINGLE_PRECISION
17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)
18#      else
19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)
20#      endif 
21#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
22#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
23#      define L_SIZE(ptab)             1
24#   endif
25#   if defined DIM_4d
26#      if defined SINGLE_PRECISION
27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)
28#      else
29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)
30#      endif 
31#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
32#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
33#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
34#   endif
35#   if defined SINGLE_PRECISION
36#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f)
37#   else
38#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f)
39#   endif
40#   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2)
41#   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l)
42#else
43!                          !==  IN: ptab is an array  ==!
44#   define NAT_IN(k)                cd_nat
45#   define SGN_IN(k)                psgn
46#   define F_SIZE(ptab)             1
47#   if defined DIM_2d
48#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
49#      define K_SIZE(ptab)          1
50#      define L_SIZE(ptab)          1
51#   endif
52#   if defined DIM_3d
53#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
54#      define K_SIZE(ptab)          SIZE(ptab,3)
55#      define L_SIZE(ptab)          1
56#   endif
57#   if defined DIM_4d
58#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
59#      define K_SIZE(ptab)          SIZE(ptab,3)
60#      define L_SIZE(ptab)          SIZE(ptab,4)
61#   endif
62#   define J_SIZE(ptab2)             SIZE(ptab2,2)
63#   define ARRAY2_IN(i,j,k,l,f)   ptab2(i,j,k,l)
64#   if defined SINGLE_PRECISION
65#      define ARRAY_TYPE(i,j,k,l,f)     REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
66#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
67#   else
68#      define ARRAY_TYPE(i,j,k,l,f)     REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
69#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
70#   endif
71#   endif
72#   ifdef SINGLE_PRECISION
73#      define PRECISION sp
74#   else
75#      define PRECISION dp
76#   endif
77   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
78      !!----------------------------------------------------------------------
79      !!
80      !! ** Purpose :   lateral boundary condition : North fold treatment
81      !!                without allgather exchanges.
82      !!
83      !!----------------------------------------------------------------------
84      ARRAY_TYPE(:,:,:,:,:)
85      ARRAY2_TYPE(:,:,:,:,:) 
86      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
87      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
88      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
89      !
90      INTEGER  ::    ji,  jj,   jk, jn, ii,   jl,   jh,  jf   ! dummy loop indices
91      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf, iij, ijj   ! dimension of the input array
92      INTEGER  ::   ijt, iju, ijta, ijua, jia, startloop, endloop
93      LOGICAL  ::   l_fast_exchanges
94      !!----------------------------------------------------------------------
95      ipj = J_SIZE(ptab2)  ! 2nd dimension of input array
96      ipk = K_SIZE(ptab)   ! 3rd dimension of output array
97      ipl = L_SIZE(ptab)   ! 4th    -
98      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
99      !
100      ! Security check for further developments
101      IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' )
102      ! 2nd dimension determines exchange speed
103      IF (ipj == 1 ) THEN
104        l_fast_exchanges = .TRUE.
105      ELSE
106        l_fast_exchanges = .FALSE.
107      ENDIF
108      !
109      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed
110         !
111         SELECT CASE ( npolj )
112         !
113         CASE ( 3, 4 )                       ! *  North fold  T-point pivot
114            !
115            SELECT CASE ( NAT_IN(jf) )
116            !
117            CASE ( 'T' , 'W' )                         ! T-, W-point
118               IF ( nimpp /= 1 ) THEN  ;  startloop = 1 
119               ELSE                    ;  startloop = 1 + nn_hls
120               ENDIF
121               !
122               DO jl = 1, ipl; DO jk = 1, ipk
123                    DO jj = 1, nn_hls
124                       ijj = jpj -jj +1
125                     DO ji = startloop, jpi
126                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
127                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
128                     END DO
129                  END DO
130               END DO; END DO
131               IF( nimpp == 1 ) THEN
132                  DO jl = 1, ipl; DO jk = 1, ipk
133                     DO jj = 1, nn_hls
134                     ijj = jpj -jj +1
135                     DO ii = 0, nn_hls-1
136                        ARRAY_IN(ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,jk,jl,jf)
137                     END DO
138                     END DO
139                  END DO; END DO
140               ENDIF             
141               !
142               IF ( .NOT. l_fast_exchanges ) THEN
143                  IF( nimpp >= Ni0glo/2+2 ) THEN
144                     startloop = 1
145                  ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
146                     startloop = Ni0glo/2+2 - nimpp + nn_hls
147                  ELSE
148                     startloop = jpi + 1
149                  ENDIF
150                  IF( startloop <= jpi ) THEN
151                     DO jl = 1, ipl; DO jk = 1, ipk
152                        DO ji = startloop, jpi
153                           ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
154                           jia  = ji + nimpp - 1
155                           ijta = jpiglo - jia + 2
156                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
157                              ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+nn_hls,jpj-nn_hls,jk,jl,jf)
158                           ELSE
159                              ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)
160                           ENDIF
161                        END DO
162                     END DO; END DO
163                  ENDIF
164               ENDIF
165            CASE ( 'U' )                                     ! U-point
166               IF( nimpp + jpi - 1 /= jpiglo ) THEN
167                  endloop = jpi
168               ELSE
169                  endloop = jpi - nn_hls
170               ENDIF
171               DO jl = 1, ipl; DO jk = 1, ipk
172        DO jj = 1, nn_hls
173              ijj = jpj -jj +1
174                     DO ji = 1, endloop
175                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
176                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
177                     END DO
178                  END DO
179               END DO; END DO
180               IF (nimpp .eq. 1) THEN
181        DO jj = 1, nn_hls
182           ijj = jpj -jj +1
183           DO ii = 0, nn_hls-1
184         ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)
185           END DO
186                  END DO
187               ENDIF
188               IF((nimpp + jpi - 1) .eq. jpiglo) THEN
189                  DO jj = 1, nn_hls
190                       ijj = jpj -jj +1
191         DO ii = 1, nn_hls
192               ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)
193         END DO
194        END DO
195               ENDIF
196               !
197               IF ( .NOT. l_fast_exchanges ) THEN
198                  IF( nimpp + jpi - 1 /= jpiglo ) THEN
199                     endloop = jpi
200                  ELSE
201                     endloop = jpi - nn_hls
202                  ENDIF
203                  IF( nimpp >= Ni0glo/2+1 ) THEN
204                     startloop = nn_hls
205                  ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN
206                     startloop = Ni0glo/2+1 - nimpp + nn_hls 
207                  ELSE
208                     startloop = endloop + 1
209                  ENDIF
210                  IF( startloop <= endloop ) THEN
211                  DO jl = 1, ipl; DO jk = 1, ipk
212                     DO ji = startloop, endloop
213                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
214                        jia = ji + nimpp - 1 
215                        ijua = jpiglo - jia + 1 
216                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
217                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,jpj-nn_hls,jk,jl,jf)
218                        ELSE
219                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)
220                        ENDIF
221                     END DO
222                  END DO; END DO
223                  ENDIF
224               ENDIF
225               !
226            CASE ( 'V' )                                     ! V-point
227               IF( nimpp /= 1 ) THEN
228                 startloop = 1 
229               ELSE
230                 startloop = 1 + nn_hls
231               ENDIF
232               IF ( .NOT. l_fast_exchanges ) THEN
233                  DO jl = 1, ipl; DO jk = 1, ipk
234                       DO jj = 2, nn_hls+1
235                     ijj = jpj -jj +1
236                        DO ji = startloop, jpi
237                           ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
238                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
239                        END DO
240                    END DO
241                  END DO; END DO
242               ENDIF
243               DO jl = 1, ipl; DO jk = 1, ipk
244                  DO ji = startloop, jpi
245                     ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
246                     ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf)
247                  END DO
248               END DO; END DO
249               IF (nimpp .eq. 1) THEN
250        DO jj = 1, nn_hls
251                       ijj = jpj-jj+1
252                       DO ii = 0, nn_hls-1
253                        ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii+1,jpj-2*nn_hls+jj-1,:,:,jf)
254           END DO
255        END DO
256               ENDIF
257            CASE ( 'F' )                                     ! F-point
258               IF( nimpp + jpi - 1 /= jpiglo ) THEN
259                  endloop = jpi
260               ELSE
261                  endloop = jpi - nn_hls
262               ENDIF
263               IF ( .NOT. l_fast_exchanges ) THEN
264                  DO jl = 1, ipl; DO jk = 1, ipk
265                       DO jj = 2, nn_hls+1
266                     ijj = jpj -jj +1
267                        DO ji = 1, endloop
268                           iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
269                           ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
270                        END DO
271                    END DO
272                  END DO; END DO
273               ENDIF
274               DO jl = 1, ipl; DO jk = 1, ipk
275                  DO ji = 1, endloop
276                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
277                     ARRAY_IN(ji,jpj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf)
278                  END DO
279               END DO; END DO
280      IF (nimpp .eq. 1) THEN               
281         DO ii = 1, nn_hls
282                 ARRAY_IN(ii,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls-1,:,:,jf)
283         END DO
284         IF ( .NOT. l_fast_exchanges ) THEN
285            DO jj = 1, nn_hls
286                      ijj = jpj -jj
287                      DO ii = 0, nn_hls-1
288                         ARRAY_IN(ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2*nn_hls-ii,jpj-2*nn_hls+jj-1,:,:,jf)
289                   END DO
290                      END DO
291                     ENDIF
292      ENDIF
293      IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN
294                   DO ii = 1, nn_hls
295                 ARRAY_IN(jpi-ii+1,jpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls-1,:,:,jf)
296         END DO
297         IF ( .NOT. l_fast_exchanges ) THEN
298            DO jj = 1, nn_hls
299                           ijj = jpj -jj
300                      DO ii = 1, nn_hls
301                         ARRAY_IN(jpi-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii,jpj-2*nn_hls+jj-1,:,:,jf)
302                         END DO
303                      END DO
304                     ENDIF
305                  ENDIF
306                  !
307       END SELECT
308            !
309         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
310            !
311            SELECT CASE ( NAT_IN(jf) )
312            CASE ( 'T' , 'W' )                               ! T-, W-point
313               DO jl = 1, ipl; DO jk = 1, ipk
314        DO jj = 1, nn_hls
315           ijj = jpj-jj+1
316           DO ji = 1, jpi
317                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
318                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
319                     END DO
320        END DO
321               END DO; END DO
322               !
323            CASE ( 'U' )                                     ! U-point
324               IF( nimpp + jpi - 1 /= jpiglo ) THEN
325                  endloop = jpi
326               ELSE
327                  endloop = jpi - nn_hls
328               ENDIF
329               DO jl = 1, ipl; DO jk = 1, ipk
330        DO jj = 1, nn_hls
331           ijj = jpj-jj+1
332                     DO ji = 1, endloop
333                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
334                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
335                     END DO
336                  END DO
337               END DO; END DO
338               IF(nimpp + jpi - 1 .eq. jpiglo) THEN
339                  DO jl = 1, ipl; DO jk = 1, ipk
340                     DO jj = 1, nn_hls
341                          ijj = jpj-jj+1
342                        DO ii = 1, nn_hls
343            iij = jpi-ii+1
344                           ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj,jk,jl,jf)
345                        END DO
346                     END DO
347                  END DO; END DO
348               ENDIF
349               !
350            CASE ( 'V' )                                     ! V-point
351               DO jl = 1, ipl; DO jk = 1, ipk
352        DO jj = 1, nn_hls
353           ijj = jpj -jj +1
354                     DO ji = 1, jpi
355                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
356                        ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
357                     END DO
358                  END DO
359               END DO; END DO
360
361               IF ( .NOT. l_fast_exchanges ) THEN
362                  IF( nimpp >= Ni0glo/2+2 ) THEN
363                     startloop = 1
364                  ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
365                     startloop = Ni0glo/2+2 - nimpp + nn_hls
366                  ELSE
367                     startloop = jpi + 1
368                  ENDIF
369                  IF( startloop <= jpi ) THEN
370                  DO jl = 1, ipl; DO jk = 1, ipk
371                        DO ji = startloop, jpi
372                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
373                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,nn_hls+1,jk,jl,jf)
374                        END DO
375                  END DO; END DO
376                  ENDIF
377               ENDIF
378               !
379            CASE ( 'F' )                               ! F-point
380               IF( nimpp + jpi - 1 /= jpiglo ) THEN
381                  endloop = jpi
382               ELSE
383                  endloop = jpi - nn_hls
384               ENDIF
385               DO jl = 1, ipl; DO jk = 1, ipk
386        DO jj = 1, nn_hls
387          ijj = jpj -jj +1
388                    DO ji = 1, endloop
389                       iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
390                       ARRAY_IN(ji,ijj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,jj,jk,jl,jf)
391                     END DO
392                  END DO
393               END DO; END DO
394               IF((nimpp + jpi - 1) .eq. jpiglo) THEN
395                  DO jl = 1, ipl; DO jk = 1, ipk
396                     DO jj = 1, nn_hls
397                        ijj = jpj -jj +1
398                        DO ii = 1, nn_hls
399            iij = jpi -ii+1
400                           ARRAY_IN(iij,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(jpi-2*nn_hls+ii-1,jpj-2*nn_hls+jj-1,jk,jl,jf)
401                        END DO
402                     END DO
403                  END DO; END DO
404               ENDIF
405               !
406               IF ( .NOT. l_fast_exchanges ) THEN
407                  IF( nimpp + jpi - 1 /= jpiglo ) THEN
408                     endloop = jpi
409                  ELSE
410                     endloop = jpi - nn_hls
411                  ENDIF
412                  IF( nimpp >= Ni0glo/2+2 ) THEN
413                     startloop = 1 
414                  ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
415                     startloop = Ni0glo/2+2 - nimpp + nn_hls
416                  ELSE
417                     startloop = endloop + 1
418                  ENDIF
419                  IF( startloop <= endloop ) THEN
420                     DO jl = 1, ipl; DO jk = 1, ipk
421                        DO ji = startloop, endloop
422                           iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
423                           ARRAY_IN(ji,jpj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,nn_hls+1,jk,jl,jf)
424                        END DO
425                     END DO; END DO
426                  ENDIF
427               ENDIF
428               !
429            END SELECT
430            !
431         CASE DEFAULT                           ! *  closed : the code probably never go through
432            !
433            WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj
434            !
435         END SELECT     !  npolj
436         !
437      END DO            ! End jf loop
438   END SUBROUTINE ROUTINE_NFD
439#undef PRECISION
440#undef ARRAY_TYPE
441#undef ARRAY_IN
442#undef NAT_IN
443#undef SGN_IN
444#undef J_SIZE
445#undef K_SIZE
446#undef L_SIZE
447#undef F_SIZE
448#undef ARRAY2_TYPE
449#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.