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/2019/dev_r11514_HPC-02_single-core-extrahalo/src/OCE/LBC – NEMO

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

Last change on this file since 11719 was 11719, checked in by francesca, 4 years ago

add extra halo support- ticket #2009

  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 17.2 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(1-nn_hls+1:,1-nn_hls+1:,:,:,:)
60      ARRAY2_TYPE(1-nn_hls+1:,:,:,:,:) 
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, 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 - nn_hls+1 /= 1 ) THEN  ;  startloop = 1 - nn_hls + 1
94               ELSE                     ;   startloop = 2
95               ENDIF
96               !
97               DO jl = 1, ipl; DO jk = 1, ipk
98                    DO jj = 1, nn_hls
99                     ijj = nlcj -jj +1
100                     DO ji = startloop, nlci
101                     ijt = jpiglo - ji - nimpp - 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 - nn_hls+1 == 1 ) THEN
107                  DO jl = 1, ipl; DO jk = 1, ipk
108                     DO jj = 1, nn_hls
109                        ijj = nlcj -jj +1
110                        DO ii = 1, nn_hls
111                           ARRAY_IN(1-ii+1,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ii+2,nlcj-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 - nn_hls +1 >= jpiglo/2+1 ) THEN
119                     startloop = 1 - nn_hls +1
120                ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp - nn_hls +1 < jpiglo/2+1 ) THEN
121                     startloop = jpiglo/2+1 - nimpp + nn_hls
122                  ELSE
123                     startloop = nlci + 1
124                  ENDIF
125                  IF( startloop <= nlci ) THEN
126                     DO jl = 1, ipl; DO jk = 1, ipk
127                        DO ji = startloop, nlci
128                           ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
129                           jia  = ji + nimpp - 1
130                           ijta = jpiglo - jia + 2
131                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
132                              ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-nn_hls,jk,jl,jf)
133                           ELSE
134                              ARRAY_IN(ji,nlcj-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 + nlci - nn_hls /= jpiglo ) THEN
142                  endloop = nlci
143               ELSE
144                  endloop = nlci - nn_hls
145               ENDIF
146               DO jl = 1, ipl; DO jk = 1, ipk
147              DO jj = 1, nn_hls
148                     ijj = nlcj -jj +1
149                     DO ji = 1-nn_hls+1, endloop
150                     iju = jpiglo - ji - nimpp - 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 - nn_hls+1 .eq. 1) THEN
156               DO jj = 1, nn_hls
157                  ijj = nlcj -jj +1
158                  DO ii = 1, nn_hls
159                     ARRAY_IN(2-ii,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls+jj-1,:,:,jf)
160                  END DO
161                     END DO
162               ENDIF
163               IF((nimpp + nlci - nn_hls) .eq. jpiglo) THEN
164                     DO jj = 1, nn_hls
165                        ijj = nlcj -jj +1
166                  DO ii = 1, nn_hls
167                     ARRAY_IN(nlci-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-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 + nlci - nn_hls /= jpiglo ) THEN
174                     endloop = nlci
175                  ELSE
176                     endloop = nlci - nn_hls
177                  ENDIF
178                  IF( nimpp - nn_hls+1 >= jpiglo/2 ) THEN
179                     startloop = 1- nn_hls + 1
180                     ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp - nn_hls+1 < jpiglo/2 ) ) THEN
181                     startloop = jpiglo/2 - nimpp + nn_hls
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 - nfiimpp(isendto(1),jpnj) + 3
189                        jia = ji + nimpp - 1
190                        ijua = jpiglo - jia + 1
191                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
192                           ARRAY_IN(ji,nlcj-nn_hls,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-nn_hls,jk,jl,jf)
193                        ELSE
194                           ARRAY_IN(ji,nlcj-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 - nn_hls+1 /= 1 ) THEN
203                 startloop = 1 - nn_hls + 1
204               ELSE
205                 startloop = 2
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 = nlcj -jj +1
211                        DO ji = startloop, nlci
212                           ijt=jpiglo - ji - nimpp - 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, nlci
220                     ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
221                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,1,jk,jl,jf)
222                  END DO
223               END DO; END DO
224               IF (nimpp - nn_hls+1.eq. 1) THEN
225               DO jj = 1, nn_hls
226                        ijj = nlcj-jj+1
227                        DO ii = 1, nn_hls
228                        ARRAY_IN(1-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+2,nlcj-2*nn_hls+jj-1,:,:,jf)
229                  END DO
230               END DO
231               ENDIF
232            CASE ( 'F' )                                     ! F-point
233               IF( nimpp + nlci - nn_hls /= jpiglo ) THEN
234                  endloop = nlci
235               ELSE
236                  endloop = nlci - 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 = nlcj -jj +1
242                        DO ji = 1 - nn_hls +1, endloop
243                           iju = jpiglo - ji - nimpp - 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- nn_hls +1, endloop
251                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
252                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,1,jk,jl,jf)
253                  END DO
254               END DO; END DO
255      IF (nimpp - nn_hls+1.eq. 1) THEN               
256         DO ii = 1, nn_hls
257                     ARRAY_IN(2-ii,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls-1,:,:,jf)
258         END DO
259         IF ( .NOT. l_fast_exchanges ) THEN
260            DO jj = 1, nn_hls
261                           ijj = nlcj -jj
262                           DO ii = 1, nn_hls
263                           ARRAY_IN(2-ii,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ii+1,nlcj-2*nn_hls+jj-1,:,:,jf)
264                              END DO
265                        END DO
266                     ENDIF
267      ENDIF
268      IF((nimpp + nlci - nn_hls ) .eq. jpiglo) THEN
269                     DO ii = 1, nn_hls
270                     ARRAY_IN(nlci-ii+1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-2*nn_hls-1,:,:,jf)
271         END DO
272         IF ( .NOT. l_fast_exchanges ) THEN
273            DO jj = 1, nn_hls
274                           ijj = nlcj -jj
275                           DO ii = 1, nn_hls
276                           ARRAY_IN(nlci-ii+1,ijj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2*nn_hls+ii,nlcj-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            WRITE(*,*) 'extrahalo not handled in this case', __FILE__, __LINE__
287            SELECT CASE ( NAT_IN(jf) )
288            CASE ( 'T' , 'W' )                               ! T-, W-point
289               DO jl = 1, ipl; DO jk = 1, ipk
290              DO jj = 1, nn_hls
291                      ijj = nlcj -jj+1
292                  DO ji = 1, nlci
293                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
294                     ARRAY_IN(ji,ijj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,jj,jk,jl,jf)
295                  END DO
296              END DO
297               END DO; END DO
298               !
299            CASE ( 'U' )                                     ! U-point
300               IF( nimpp + nlci - 1 /= jpiglo ) THEN
301                  endloop = nlci
302               ELSE
303                  endloop = nlci - 1
304               ENDIF
305               DO jl = 1, ipl; DO jk = 1, ipk
306                  DO ji = 1, endloop
307                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
308                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,jk,jl,jf)
309                  END DO
310               END DO; END DO
311               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
312                  DO jl = 1, ipl; DO jk = 1, ipk
313                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf)
314                  END DO; END DO
315               ENDIF
316               !
317            CASE ( 'V' )                                     ! V-point
318               DO jl = 1, ipl; DO jk = 1, ipk
319                  DO ji = 1, nlci
320                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
321                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,jk,jl,jf)
322                  END DO
323               END DO; END DO
324
325               IF ( .NOT. l_fast_exchanges ) THEN
326                  IF( nimpp >= jpiglo/2+1 ) THEN
327                     startloop = 1
328                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
329                     startloop = jpiglo/2+1 - nimpp + 1
330                  ELSE
331                     startloop = nlci + 1
332                  ENDIF
333                  IF( startloop <= nlci ) THEN
334                  DO jl = 1, ipl; DO jk = 1, ipk
335                     DO ji = startloop, nlci
336                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
337                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
338                     END DO
339                  END DO; END DO
340                  ENDIF
341               ENDIF
342               !
343            CASE ( 'F' )                               ! F-point
344               IF( nimpp + nlci - 1 /= jpiglo ) THEN
345                  endloop = nlci
346               ELSE
347                  endloop = nlci - 1
348               ENDIF
349               DO jl = 1, ipl; DO jk = 1, ipk
350                  DO ji = 1, endloop
351                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
352                     ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,jk,jl,jf)
353                  END DO
354               END DO; END DO
355               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
356                  DO jl = 1, ipl; DO jk = 1, ipk
357                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf)
358                  END DO; END DO
359               ENDIF
360               !
361               IF ( .NOT. l_fast_exchanges ) THEN
362                  IF( nimpp + nlci - 1 /= jpiglo ) THEN
363                     endloop = nlci
364                  ELSE
365                     endloop = nlci - 1
366                  ENDIF
367                  IF( nimpp >= jpiglo/2+1 ) THEN
368                     startloop = 1
369                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
370                     startloop = jpiglo/2+1 - nimpp + 1
371                  ELSE
372                     startloop = endloop + 1
373                  ENDIF
374                  IF( startloop <= endloop ) THEN
375                     DO jl = 1, ipl; DO jk = 1, ipk
376                        DO ji = startloop, endloop
377                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
378                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
379                        END DO
380                     END DO; END DO
381                  ENDIF
382               ENDIF
383               !
384            END SELECT
385            !
386         CASE DEFAULT                           ! *  closed : the code probably never go through
387            !
388            WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj
389            !
390         END SELECT     !  npolj
391         !
392      END DO            ! End jf loop
393   END SUBROUTINE ROUTINE_NFD
394#undef ARRAY_TYPE
395#undef ARRAY_IN
396#undef NAT_IN
397#undef SGN_IN
398#undef J_SIZE
399#undef K_SIZE
400#undef L_SIZE
401#undef F_SIZE
402#undef ARRAY2_TYPE
403#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.