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

Last change on this file since 12807 was 12807, checked in by smasson, 10 months ago

Extra_Halo: input file only over inner domain + new variables names, see #2366

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