source: NEMO/trunk/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 9596

Last change on this file since 9596 was 9190, checked in by gm, 3 years ago

dev_merge_2017: OPA_SRC: style only, results unchanged

File size: 14.8 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#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_2D),INTENT(inout)::ptab2(f)
11#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt2d(i,j)
12#   endif
13#   if defined DIM_3d
14#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D),INTENT(inout)::ptab(f)
15#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
16#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
17#      define L_SIZE(ptab)             1
18#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_3D),INTENT(inout)::ptab2(f)
19#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt3d(i,j,k)
20#   endif
21#   if defined DIM_4d
22#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D),INTENT(inout)::ptab(f)
23#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
24#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
25#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
26#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D),INTENT(inout)::ptab2(f)
27#      define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l)
28#   endif
29#else
30!                          !==  IN: ptab is an array  ==!
31#   define NAT_IN(k)                cd_nat
32#   define SGN_IN(k)                psgn
33#   define F_SIZE(ptab)             1
34#   if defined DIM_2d
35#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
36#      define K_SIZE(ptab)          1
37#      define L_SIZE(ptab)          1
38#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j)
39#   endif
40#   if defined DIM_3d
41#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
42#      define K_SIZE(ptab)          SIZE(ptab,3)
43#      define L_SIZE(ptab)          1
44#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k)
45#   endif
46#   if defined DIM_4d
47#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
48#      define K_SIZE(ptab)          SIZE(ptab,3)
49#      define L_SIZE(ptab)          SIZE(ptab,4)
50#      define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l)
51#   endif
52#   define ARRAY_TYPE(i,j,k,l,f)     REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
53#   define ARRAY2_TYPE(i,j,k,l,f)    REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
54#endif
55
56   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
57      !!----------------------------------------------------------------------
58      !!
59      !! ** Purpose :   lateral boundary condition : North fold treatment
60      !!                without allgather exchanges.
61      !!
62      !!----------------------------------------------------------------------
63      ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied
64      ARRAY2_TYPE(:,:,:,:,:)                            ! array or pointer of arrays on which the boundary condition is applied
65      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
66      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
67      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
68      !
69      INTEGER  ::    ji,  jj,   jk,     jl,   jh,  jf   ! dummy loop indices
70      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array
71      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
72      !!----------------------------------------------------------------------
73      ipk = K_SIZE(ptab)   ! 3rd dimension
74      ipl = L_SIZE(ptab)   ! 4th    -
75      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
76      !
77      !
78      SELECT CASE ( jpni )
79      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
80      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
81      END SELECT
82      ijpjm1 = ijpj-1
83      !
84      !
85      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed
86         !
87         SELECT CASE ( npolj )
88         !
89         CASE ( 3, 4 )                       ! *  North fold  T-point pivot
90            !
91            SELECT CASE ( NAT_IN(jf) )
92            !
93            CASE ( 'T' , 'W' )                         ! T-, W-point
94               IF ( nimpp /= 1 ) THEN   ;   startloop = 1
95               ELSE                     ;   startloop = 2
96               ENDIF
97               !
98               DO ji = startloop, nlci
99                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
100                  ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
101               END DO
102               IF( nimpp == 1 ) THEN
103                  ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-2,:,:,jf)
104               ENDIF
105               !
106               IF( nimpp >= jpiglo/2+1 ) THEN
107                  startloop = 1
108               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
109                  startloop = jpiglo/2+1 - nimpp + 1
110               ELSE
111                  startloop = nlci + 1
112               ENDIF
113               IF( startloop <= nlci ) THEN
114                  DO ji = startloop, nlci
115                     ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
116                     jia  = ji + nimpp - 1
117                     ijta = jpiglo - jia + 2
118                     IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
119                        ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,ijpjm1,:,:,jf)
120                     ELSE
121                        ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
122                     ENDIF
123                  END DO
124               ENDIF
125               !
126            CASE ( 'U' )                                     ! U-point
127               IF( nimpp + nlci - 1 /= jpiglo ) THEN
128                  endloop = nlci
129               ELSE
130                  endloop = nlci - 1
131               ENDIF
132               DO ji = 1, endloop
133                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
134                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
135               END DO
136               IF (nimpp .eq. 1) THEN
137                        ARRAY_IN(   1  ,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf)
138               ENDIF
139               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
140                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)
141               ENDIF
142               !
143               IF( nimpp + nlci - 1 /= jpiglo ) THEN
144                  endloop = nlci
145               ELSE
146                  endloop = nlci - 1
147               ENDIF
148               IF( nimpp >= jpiglo/2 ) THEN
149                  startloop = 1
150                  ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
151                  startloop = jpiglo/2 - nimpp + 1
152               ELSE
153                  startloop = endloop + 1
154               ENDIF
155               IF( startloop <= endloop ) THEN
156               DO ji = startloop, endloop
157                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
158                  jia = ji + nimpp - 1
159                  ijua = jpiglo - jia + 1
160                  IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
161                           ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,ijpjm1,:,:,jf)
162                  ELSE
163                           ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
164                  ENDIF
165               END DO
166               ENDIF
167               !
168            CASE ( 'V' )                                     ! V-point
169               IF( nimpp /= 1 ) THEN
170                 startloop = 1
171               ELSE
172                 startloop = 2
173               ENDIF
174               DO ji = startloop, nlci
175                 ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
176                        ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
177                        ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-3,:,:,jf)
178               END DO
179               IF (nimpp .eq. 1) THEN
180                        ARRAY_IN(1,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ijpj-3,:,:,jf)
181               ENDIF
182            CASE ( 'F' )                                     ! F-point
183               IF( nimpp + nlci - 1 /= jpiglo ) THEN
184                  endloop = nlci
185               ELSE
186                  endloop = nlci - 1
187               ENDIF
188               DO ji = 1, endloop
189                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
190                        ARRAY_IN(ji,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
191                        ARRAY_IN(ji,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-3,:,:,jf)
192               END DO
193               IF (nimpp .eq. 1) THEN
194                        ARRAY_IN(   1  ,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-3,:,:,jf)
195                        ARRAY_IN(   1  ,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(    2   ,ijpj-2,:,:,jf)
196               ENDIF
197               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
198                        ARRAY_IN(nlci,ijpj  ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-3,:,:,jf)
199                        ARRAY_IN(nlci,ijpj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,ijpj-2,:,:,jf)
200               ENDIF
201               !
202            CASE ( 'I' )                                     ! ice U-V point (I-point)
203               IF( nimpp /= 1 ) THEN
204                  startloop = 1
205               ELSE
206                  startloop = 3
207                  ARRAY_IN(2,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(3,ijpjm1,:,:,jf)
208               ENDIF
209               DO ji = startloop, nlci
210                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
211                  ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
212               END DO
213            END SELECT
214            !
215         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
216            !
217            SELECT CASE ( NAT_IN(jf) )
218            CASE ( 'T' , 'W' )                               ! T-, W-point
219               DO ji = 1, nlci
220                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
221                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf)
222               END DO
223               !
224            CASE ( 'U' )                                     ! U-point
225               IF( nimpp + nlci - 1 /= jpiglo ) THEN
226                  endloop = nlci
227               ELSE
228                  endloop = nlci - 1
229               ENDIF
230               DO ji = 1, endloop
231                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
232                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf)
233               END DO
234               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
235                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-1,:,:,jf)
236               ENDIF
237               !
238            CASE ( 'V' )                                     ! V-point
239               DO ji = 1, nlci
240                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
241                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
242               END DO
243                  !
244               IF( nimpp >= jpiglo/2+1 ) THEN
245                  startloop = 1
246               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
247                  startloop = jpiglo/2+1 - nimpp + 1
248               ELSE
249                  startloop = nlci + 1
250               ENDIF
251               IF( startloop <= nlci ) THEN
252               DO ji = startloop, nlci
253                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
254                          ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
255               END DO
256               ENDIF
257               !
258            CASE ( 'F' )                               ! F-point
259               IF( nimpp + nlci - 1 /= jpiglo ) THEN
260                  endloop = nlci
261               ELSE
262                  endloop = nlci - 1
263               ENDIF
264               DO ji = 1, endloop
265                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
266                        ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
267               END DO
268               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
269                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(1,ijpj-2,:,:,jf)
270               ENDIF
271               !
272               IF( nimpp + nlci - 1 /= jpiglo ) THEN
273                  endloop = nlci
274               ELSE
275                  endloop = nlci - 1
276               ENDIF
277               IF( nimpp >= jpiglo/2+1 ) THEN
278                  startloop = 1
279               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
280                  startloop = jpiglo/2+1 - nimpp + 1
281               ELSE
282                  startloop = endloop + 1
283               ENDIF
284               IF( startloop <= endloop ) THEN
285                  DO ji = startloop, endloop
286                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
287                      ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
288                  END DO
289               ENDIF
290               !
291            CASE ( 'I' )                                  ! ice U-V point (I-point)
292               IF( nimpp /= 1 ) THEN
293                  startloop = 1
294               ELSE
295                  startloop = 2
296               ENDIF
297               IF( nimpp + nlci - 1 /= jpiglo ) THEN
298                  endloop = nlci
299               ELSE
300                  endloop = nlci - 1
301               ENDIF
302               DO ji = startloop , endloop
303                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
304                  ARRAY_IN(ji,ijpj,:,:,jf) = 0.5 * (ARRAY_IN(ji,ijpjm1,:,:,jf) + SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf))
305               END DO
306               !
307            END SELECT
308            !
309         CASE DEFAULT                           ! *  closed : the code probably never go through
310            !
311            SELECT CASE ( NAT_IN(jf))
312            CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
313               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
314               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
315            CASE ( 'F' )                                   ! F-point
316               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
317            CASE ( 'I' )                                   ! ice U-V point
318               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
319               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
320            END SELECT
321            !
322         END SELECT     !  npolj
323         !
324      END DO            ! End jf loop
325   END SUBROUTINE ROUTINE_NFD
326#undef ARRAY_TYPE
327#undef ARRAY_IN
328#undef NAT_IN
329#undef SGN_IN
330#undef K_SIZE
331#undef L_SIZE
332#undef F_SIZE
333#undef ARRAY2_TYPE
334#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.