source: NEMO/branches/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 11692

Last change on this file since 11692 was 11692, checked in by francesca, 12 months ago

Update branch to integrate the development starting from the current v4.01 ready trunk

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 15.7 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 ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l)
47#   define J_SIZE(ptab2)             SIZE(ptab2,2)
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(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied
60      ARRAY2_TYPE(:,:,:,:,:)                            ! array or pointer of arrays on which the boundary condition is applied
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,     jl,   jh,  jf   ! dummy loop indices
66      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array
67      INTEGER  ::   ijt, iju, ijpj, ijpjp1, 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      !
78      ijpj   = 1    ! index of first modified line
79      ijpjp1 = 2    ! index + 1
80     
81      ! 2nd dimension determines exchange speed
82      IF (ipj == 1 ) THEN
83        l_fast_exchanges = .TRUE.
84      ELSE
85        l_fast_exchanges = .FALSE.
86      ENDIF
87      !
88      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed
89         !
90         SELECT CASE ( npolj )
91         !
92         CASE ( 3, 4 )                       ! *  North fold  T-point pivot
93            !
94            SELECT CASE ( NAT_IN(jf) )
95            !
96            CASE ( 'T' , 'W' )                         ! T-, W-point
97               IF ( nimpp /= 1 ) THEN   ;   startloop = 1
98               ELSE                     ;   startloop = 2
99               ENDIF
100               !
101               DO jl = 1, ipl; DO jk = 1, ipk
102                  DO ji = startloop, nlci
103                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
104                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
105                  END DO
106               END DO; END DO
107               IF( nimpp == 1 ) THEN
108                  DO jl = 1, ipl; DO jk = 1, ipk
109                     ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf)
110                  END DO; END DO
111               ENDIF
112               !
113               IF ( .NOT. l_fast_exchanges ) THEN
114                  IF( nimpp >= jpiglo/2+1 ) THEN
115                     startloop = 1
116                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
117                     startloop = jpiglo/2+1 - nimpp + 1
118                  ELSE
119                     startloop = nlci + 1
120                  ENDIF
121                  IF( startloop <= nlci ) THEN
122                     DO jl = 1, ipl; DO jk = 1, ipk
123                        DO ji = startloop, nlci
124                           ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
125                           jia  = ji + nimpp - 1
126                           ijta = jpiglo - jia + 2
127                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
128                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)
129                           ELSE
130                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
131                           ENDIF
132                        END DO
133                     END DO; END DO
134                  ENDIF
135               ENDIF
136
137            CASE ( 'U' )                                     ! U-point
138               IF( nimpp + nlci - 1 /= jpiglo ) THEN
139                  endloop = nlci
140               ELSE
141                  endloop = nlci - 1
142               ENDIF
143               DO jl = 1, ipl; DO jk = 1, ipk
144                  DO ji = 1, endloop
145                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
146                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
147                  END DO
148               END DO; END DO
149               IF (nimpp .eq. 1) THEN
150                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
151               ENDIF
152               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
153                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
154               ENDIF
155               !
156               IF ( .NOT. l_fast_exchanges ) THEN
157                  IF( nimpp + nlci - 1 /= jpiglo ) THEN
158                     endloop = nlci
159                  ELSE
160                     endloop = nlci - 1
161                  ENDIF
162                  IF( nimpp >= jpiglo/2 ) THEN
163                     startloop = 1
164                     ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
165                     startloop = jpiglo/2 - nimpp + 1
166                  ELSE
167                     startloop = endloop + 1
168                  ENDIF
169                  IF( startloop <= endloop ) THEN
170                  DO jl = 1, ipl; DO jk = 1, ipk
171                     DO ji = startloop, endloop
172                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
173                        jia = ji + nimpp - 1
174                        ijua = jpiglo - jia + 1
175                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
176                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)
177                        ELSE
178                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
179                        ENDIF
180                     END DO
181                  END DO; END DO
182                  ENDIF
183               ENDIF
184               !
185            CASE ( 'V' )                                     ! V-point
186               IF( nimpp /= 1 ) THEN
187                 startloop = 1
188               ELSE
189                 startloop = 2
190               ENDIF
191               IF ( .NOT. l_fast_exchanges ) THEN
192                  DO jl = 1, ipl; DO jk = 1, ipk
193                     DO ji = startloop, nlci
194                        ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
195                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
196                     END DO
197                  END DO; END DO
198               ENDIF
199               DO jl = 1, ipl; DO jk = 1, ipk
200                  DO ji = startloop, nlci
201                     ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
202                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
203                  END DO
204               END DO; END DO
205               IF (nimpp .eq. 1) THEN
206                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf)
207               ENDIF
208            CASE ( 'F' )                                     ! F-point
209               IF( nimpp + nlci - 1 /= jpiglo ) THEN
210                  endloop = nlci
211               ELSE
212                  endloop = nlci - 1
213               ENDIF
214               IF ( .NOT. l_fast_exchanges ) THEN
215                  DO jl = 1, ipl; DO jk = 1, ipk
216                     DO ji = 1, endloop
217                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
218                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
219                     END DO
220                  END DO; END DO
221               ENDIF
222               DO jl = 1, ipl; DO jk = 1, ipk
223                  DO ji = 1, endloop
224                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
225                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
226                  END DO
227               END DO; END DO
228               IF (nimpp .eq. 1) THEN
229                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf)
230                  IF ( .NOT. l_fast_exchanges ) &
231                     ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
232               ENDIF
233               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
234                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf)
235                  IF ( .NOT. l_fast_exchanges ) &
236                     ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
237               ENDIF
238               !
239            END SELECT
240            !
241         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
242            !
243            SELECT CASE ( NAT_IN(jf) )
244            CASE ( 'T' , 'W' )                               ! T-, W-point
245               DO jl = 1, ipl; DO jk = 1, ipk
246                  DO ji = 1, nlci
247                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
248                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
249                  END DO
250               END DO; END DO
251               !
252            CASE ( 'U' )                                     ! U-point
253               IF( nimpp + nlci - 1 /= jpiglo ) THEN
254                  endloop = nlci
255               ELSE
256                  endloop = nlci - 1
257               ENDIF
258               DO jl = 1, ipl; DO jk = 1, ipk
259                  DO ji = 1, endloop
260                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
261                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
262                  END DO
263               END DO; END DO
264               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
265                  DO jl = 1, ipl; DO jk = 1, ipk
266                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf)
267                  END DO; END DO
268               ENDIF
269               !
270            CASE ( 'V' )                                     ! V-point
271               DO jl = 1, ipl; DO jk = 1, ipk
272                  DO ji = 1, nlci
273                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
274                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
275                  END DO
276               END DO; END DO
277
278               IF ( .NOT. l_fast_exchanges ) THEN
279                  IF( nimpp >= jpiglo/2+1 ) THEN
280                     startloop = 1
281                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
282                     startloop = jpiglo/2+1 - nimpp + 1
283                  ELSE
284                     startloop = nlci + 1
285                  ENDIF
286                  IF( startloop <= nlci ) THEN
287                  DO jl = 1, ipl; DO jk = 1, ipk
288                     DO ji = startloop, nlci
289                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
290                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
291                     END DO
292                  END DO; END DO
293                  ENDIF
294               ENDIF
295               !
296            CASE ( 'F' )                               ! F-point
297               IF( nimpp + nlci - 1 /= jpiglo ) THEN
298                  endloop = nlci
299               ELSE
300                  endloop = nlci - 1
301               ENDIF
302               DO jl = 1, ipl; DO jk = 1, ipk
303                  DO ji = 1, endloop
304                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
305                     ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
306                  END DO
307               END DO; END DO
308               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
309                  DO jl = 1, ipl; DO jk = 1, ipk
310                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf)
311                  END DO; END DO
312               ENDIF
313               !
314               IF ( .NOT. l_fast_exchanges ) THEN
315                  IF( nimpp + nlci - 1 /= jpiglo ) THEN
316                     endloop = nlci
317                  ELSE
318                     endloop = nlci - 1
319                  ENDIF
320                  IF( nimpp >= jpiglo/2+1 ) THEN
321                     startloop = 1
322                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
323                     startloop = jpiglo/2+1 - nimpp + 1
324                  ELSE
325                     startloop = endloop + 1
326                  ENDIF
327                  IF( startloop <= endloop ) THEN
328                     DO jl = 1, ipl; DO jk = 1, ipk
329                        DO ji = startloop, endloop
330                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
331                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
332                        END DO
333                     END DO; END DO
334                  ENDIF
335               ENDIF
336               !
337            END SELECT
338            !
339         CASE DEFAULT                           ! *  closed : the code probably never go through
340            !
341            WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj
342            !
343         END SELECT     !  npolj
344         !
345      END DO            ! End jf loop
346   END SUBROUTINE ROUTINE_NFD
347#undef ARRAY_TYPE
348#undef ARRAY_IN
349#undef NAT_IN
350#undef SGN_IN
351#undef J_SIZE
352#undef K_SIZE
353#undef L_SIZE
354#undef F_SIZE
355#undef ARRAY2_TYPE
356#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.