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/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/NEMO_4.0_GO8_package_text_diagnostics/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 10948

Last change on this file since 10948 was 10888, checked in by davestorkey, 5 years ago

branches/UKMO/NEMO_4.0_mirror : clear SVN keywords

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