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/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC – NEMO

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 10173

Last change on this file since 10173 was 10173, checked in by smasson, 6 years ago

dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 3a: north fold bugfix for U and F upper-right corner with jperio=6, see #2133
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 13.6 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            END SELECT
203            !
204         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
205            !
206            SELECT CASE ( NAT_IN(jf) )
207            CASE ( 'T' , 'W' )                               ! T-, W-point
208               DO ji = 1, nlci
209                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
210                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-1,:,:,jf)
211               END DO
212               !
213            CASE ( 'U' )                                     ! U-point
214               IF( nimpp + nlci - 1 /= jpiglo ) THEN
215                  endloop = nlci
216               ELSE
217                  endloop = nlci - 1
218               ENDIF
219               DO ji = 1, endloop
220                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
221                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-1,:,:,jf)
222               END DO
223               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
224                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-1,:,:,jf)
225               ENDIF
226               !
227            CASE ( 'V' )                                     ! V-point
228               DO ji = 1, nlci
229                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
230                        ARRAY_IN(ji,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj-2,:,:,jf)
231               END DO
232                  !
233               IF( nimpp >= jpiglo/2+1 ) THEN
234                  startloop = 1
235               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
236                  startloop = jpiglo/2+1 - nimpp + 1
237               ELSE
238                  startloop = nlci + 1
239               ENDIF
240               IF( startloop <= nlci ) THEN
241               DO ji = startloop, nlci
242                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
243                          ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjm1,:,:,jf)
244               END DO
245               ENDIF
246               !
247            CASE ( 'F' )                               ! F-point
248               IF( nimpp + nlci - 1 /= jpiglo ) THEN
249                  endloop = nlci
250               ELSE
251                  endloop = nlci - 1
252               ENDIF
253               DO ji = 1, endloop
254                  iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
255                        ARRAY_IN(ji,ijpj ,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj-2,:,:,jf)
256               END DO
257               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
258                        ARRAY_IN(nlci,ijpj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,ijpj-2,:,:,jf)
259               ENDIF
260               !
261               IF( nimpp + nlci - 1 /= jpiglo ) THEN
262                  endloop = nlci
263               ELSE
264                  endloop = nlci - 1
265               ENDIF
266               IF( nimpp >= jpiglo/2+1 ) THEN
267                  startloop = 1
268               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
269                  startloop = jpiglo/2+1 - nimpp + 1
270               ELSE
271                  startloop = endloop + 1
272               ENDIF
273               IF( startloop <= endloop ) THEN
274                  DO ji = startloop, endloop
275                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
276                      ARRAY_IN(ji,ijpjm1,:,:,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjm1,:,:,jf)
277                  END DO
278               ENDIF
279               !
280            END SELECT
281            !
282         CASE DEFAULT                           ! *  closed : the code probably never go through
283            !
284            SELECT CASE ( NAT_IN(jf))
285            CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
286               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
287               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
288            CASE ( 'F' )                                   ! F-point
289               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
290            CASE ( 'I' )                                   ! ice U-V point
291               ARRAY_IN(:, 1  ,:,:,jf) = 0._wp
292               ARRAY_IN(:,ijpj,:,:,jf) = 0._wp
293            END SELECT
294            !
295         END SELECT     !  npolj
296         !
297      END DO            ! End jf loop
298   END SUBROUTINE ROUTINE_NFD
299#undef ARRAY_TYPE
300#undef ARRAY_IN
301#undef NAT_IN
302#undef SGN_IN
303#undef K_SIZE
304#undef L_SIZE
305#undef F_SIZE
306#undef ARRAY2_TYPE
307#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.