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/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r14116_HPC-04_mcastril_Mixed_Precision_implementation_final/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 14644

Last change on this file since 14644 was 14644, checked in by sparonuz, 3 years ago

Merge trunk -r14642:HEAD
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 13.8 KB
Line 
1
2   SUBROUTINE lbc_nfd_nogather_/**/PRECISION( ptab, ptab2, cd_nat, psgn, khls )
3      !!----------------------------------------------------------------------
4      !!
5      !! ** Purpose :   lateral boundary condition : North fold treatment
6      !!                without allgather exchanges.
7      !!
8      !!----------------------------------------------------------------------
9      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab        !
10      REAL(PRECISION),  DIMENSION(:,:,:,:), INTENT(inout) ::   ptab2       !
11      CHARACTER(len=1)                    , INTENT(in   ) ::   cd_nat      ! nature of array grid-points
12      REAL(PRECISION)                     , INTENT(in   ) ::   psgn        ! sign used across the north fold boundary
13      INTEGER                             , INTENT(in   ) ::   khls        ! halo size, default = nn_hls
14      !
15      INTEGER  ::    ji,  jj, jk,  jn,  jl, jh       ! dummy loop indices
16      INTEGER  ::   ipk, ipl, ii, iij, ijj      ! dimension of the input array
17      INTEGER  ::   ijt, iju, ijta, ijua, jia, startloop, endloop
18      LOGICAL  ::   l_fast_exchanges
19      !!----------------------------------------------------------------------
20      ipk = SIZE(ptab,3)
21      ipl = SIZE(ptab,4)
22      !
23      ! 2nd dimension determines exchange speed
24      l_fast_exchanges = SIZE(ptab2,2) == 1
25      !
26      IF( c_NFtype == 'T' ) THEN          ! *  North fold  T-point pivot
27         !
28         SELECT CASE ( cd_nat )
29            !
30         CASE ( 'T' , 'W' )                         ! T-, W-point
31            IF ( nimpp /= 1 ) THEN  ;  startloop = 1 
32            ELSE                    ;  startloop = 1 + khls
33            ENDIF
34            !
35            DO jl = 1, ipl; DO jk = 1, ipk
36               DO jj = 1, khls
37                  ijj = jpj -jj +1
38                  DO ji = startloop, jpi
39                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
40                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
41                  END DO
42               END DO
43            END DO; END DO
44            IF( nimpp == 1 ) THEN
45               DO jl = 1, ipl; DO jk = 1, ipk
46                  DO jj = 1, khls
47                     ijj = jpj -jj +1
48                     DO ii = 0, khls-1
49                        ptab(ii+1,ijj,jk,jl) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,jk,jl)
50                     END DO
51                  END DO
52               END DO; END DO
53            ENDIF
54            !
55            IF ( .NOT. l_fast_exchanges ) THEN
56               IF( nimpp >= Ni0glo/2+2 ) THEN
57                  startloop = 1
58               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
59                  startloop = Ni0glo/2+2 - nimpp + khls
60               ELSE
61                  startloop = jpi + 1
62               ENDIF
63               IF( startloop <= jpi ) THEN
64                  DO jl = 1, ipl; DO jk = 1, ipk
65                     DO ji = startloop, jpi
66                        ijt  = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
67                        jia  = ji + nimpp - 1
68                        ijta = jpiglo - jia + 2
69                        IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
70                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijta-nimpp+khls,jpj-khls,jk,jl)
71                        ELSE
72                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl)
73                        ENDIF
74                     END DO
75                  END DO; END DO
76               ENDIF
77            ENDIF
78         CASE ( 'U' )                                     ! U-point
79            IF( nimpp + jpi - 1 /= jpiglo ) THEN
80               endloop = jpi
81            ELSE
82               endloop = jpi - khls
83            ENDIF
84            DO jl = 1, ipl; DO jk = 1, ipk
85               DO jj = 1, khls
86                  ijj = jpj -jj +1
87                  DO ji = 1, endloop
88                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
89                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
90                  END DO
91               END DO
92            END DO; END DO
93            IF (nimpp .eq. 1) THEN
94               DO jj = 1, khls
95                  ijj = jpj -jj +1
96                  DO ii = 0, khls-1
97                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:)
98                  END DO
99               END DO
100            ENDIF
101            IF((nimpp + jpi - 1) .eq. jpiglo) THEN
102               DO jj = 1, khls
103                  ijj = jpj -jj +1
104                  DO ii = 1, khls
105                     ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:)
106                  END DO
107               END DO
108            ENDIF
109            !
110            IF ( .NOT. l_fast_exchanges ) THEN
111               IF( nimpp + jpi - 1 /= jpiglo ) THEN
112                  endloop = jpi
113               ELSE
114                  endloop = jpi - khls
115               ENDIF
116               IF( nimpp >= Ni0glo/2+1 ) THEN
117                  startloop = khls
118               ELSEIF( ( nimpp + jpi - 1 >= Ni0glo/2+1 ) .AND. ( nimpp < Ni0glo/2+1 ) ) THEN
119                  startloop = Ni0glo/2+1 - nimpp + khls 
120               ELSE
121                  startloop = endloop + 1
122               ENDIF
123               IF( startloop <= endloop ) THEN
124                  DO jl = 1, ipl; DO jk = 1, ipk
125                     DO ji = startloop, endloop
126                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
127                        jia = ji + nimpp - 1 
128                        ijua = jpiglo - jia + 1 
129                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
130                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab(ijua-nimpp+1,jpj-khls,jk,jl)
131                        ELSE
132                           ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl)
133                        ENDIF
134                     END DO
135                  END DO; END DO
136               ENDIF
137            ENDIF
138            !
139         CASE ( 'V' )                                     ! V-point
140            IF( nimpp /= 1 ) THEN
141               startloop = 1 
142            ELSE
143               startloop = 1 + khls
144            ENDIF
145            IF ( .NOT. l_fast_exchanges ) THEN
146               DO jl = 1, ipl; DO jk = 1, ipk
147                  DO jj = 2, khls+1
148                     ijj = jpj -jj +1
149                     DO ji = startloop, jpi
150                        ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
151                        ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
152                     END DO
153                  END DO
154               END DO; END DO
155            ENDIF
156            DO jl = 1, ipl; DO jk = 1, ipk
157               DO ji = startloop, jpi
158                  ijt=jpiglo - ji - nimpp - nfimpp(isendto(1)) + 4
159                  ptab(ji,jpj,jk,jl) = psgn * ptab2(ijt,1,jk,jl)
160               END DO
161            END DO; END DO
162            IF (nimpp .eq. 1) THEN
163               DO jj = 1, khls
164                  ijj = jpj-jj+1
165                  DO ii = 0, khls-1
166                     ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii+1,jpj-2*khls+jj-1,:,:)
167                  END DO
168               END DO
169            ENDIF
170         CASE ( 'F' )                                     ! F-point
171            IF( nimpp + jpi - 1 /= jpiglo ) THEN
172               endloop = jpi
173            ELSE
174               endloop = jpi - khls
175            ENDIF
176            IF ( .NOT. l_fast_exchanges ) THEN
177               DO jl = 1, ipl; DO jk = 1, ipk
178                  DO jj = 2, khls+1
179                     ijj = jpj -jj +1
180                     DO ji = 1, endloop
181                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
182                        ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
183                     END DO
184                  END DO
185               END DO; END DO
186            ENDIF
187            DO jl = 1, ipl; DO jk = 1, ipk
188               DO ji = 1, endloop
189                  iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
190                  ptab(ji,jpj,jk,jl) = psgn * ptab2(iju,1,jk,jl)
191               END DO
192            END DO; END DO
193            IF (nimpp .eq. 1) THEN               
194               DO ii = 1, khls
195                  ptab(ii,jpj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls-1,:,:)
196               END DO
197               IF ( .NOT. l_fast_exchanges ) THEN
198                  DO jj = 1, khls
199                     ijj = jpj -jj
200                     DO ii = 0, khls-1
201                        ptab(ii+1,ijj,:,:) = psgn * ptab(2*khls-ii,jpj-2*khls+jj-1,:,:)
202                     END DO
203                  END DO
204               ENDIF
205            ENDIF
206            IF((nimpp + jpi - 1 ) .eq. jpiglo) THEN
207               DO ii = 1, khls
208                  ptab(jpi-ii+1,jpj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls-1,:,:)
209               END DO
210               IF ( .NOT. l_fast_exchanges ) THEN
211                  DO jj = 1, khls
212                     ijj = jpj -jj
213                     DO ii = 1, khls
214                        ptab(jpi-ii+1,ijj,:,:) = psgn * ptab(jpi-2*khls+ii,jpj-2*khls+jj-1,:,:)
215                     END DO
216                  END DO
217               ENDIF
218            ENDIF
219            !
220         END SELECT
221         !
222      ENDIF   ! c_NFtype == 'T'
223      !
224      IF( c_NFtype == 'F' ) THEN           ! *  North fold  F-point pivot
225         !
226         SELECT CASE ( cd_nat )
227         CASE ( 'T' , 'W' )                               ! T-, W-point
228            DO jl = 1, ipl; DO jk = 1, ipk
229               DO jj = 1, khls
230                  ijj = jpj-jj+1
231                  DO ji = 1, jpi
232                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
233                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
234                  END DO
235               END DO
236            END DO; END DO
237            !
238         CASE ( 'U' )                                     ! U-point
239            IF( nimpp + jpi - 1 /= jpiglo ) THEN
240               endloop = jpi
241            ELSE
242               endloop = jpi - khls
243            ENDIF
244            DO jl = 1, ipl; DO jk = 1, ipk
245               DO jj = 1, khls
246                  ijj = jpj-jj+1
247                  DO ji = 1, endloop
248                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
249                     ptab(ji,ijj,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
250                  END DO
251               END DO
252            END DO; END DO
253            IF(nimpp + jpi - 1 .eq. jpiglo) THEN
254               DO jl = 1, ipl; DO jk = 1, ipk
255                  DO jj = 1, khls
256                     ijj = jpj-jj+1
257                     DO ii = 1, khls
258                        iij = jpi-ii+1
259                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj,jk,jl)
260                     END DO
261                  END DO
262               END DO; END DO
263            ENDIF
264            !
265         CASE ( 'V' )                                     ! V-point
266            DO jl = 1, ipl; DO jk = 1, ipk
267               DO jj = 1, khls
268                  ijj = jpj -jj +1
269                  DO ji = 1, jpi
270                     ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
271                     ptab(ji,ijj,jk,jl) = psgn * ptab2(ijt,jj,jk,jl)
272                  END DO
273               END DO
274            END DO; END DO
275
276            IF ( .NOT. l_fast_exchanges ) THEN
277               IF( nimpp >= Ni0glo/2+2 ) THEN
278                  startloop = 1
279               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
280                  startloop = Ni0glo/2+2 - nimpp + khls
281               ELSE
282                  startloop = jpi + 1
283               ENDIF
284               IF( startloop <= jpi ) THEN
285                  DO jl = 1, ipl; DO jk = 1, ipk
286                     DO ji = startloop, jpi
287                        ijt = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 3
288                        ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(ijt,khls+1,jk,jl)
289                     END DO
290                  END DO; END DO
291               ENDIF
292            ENDIF
293            !
294         CASE ( 'F' )                               ! F-point
295            IF( nimpp + jpi - 1 /= jpiglo ) THEN
296               endloop = jpi
297            ELSE
298               endloop = jpi - khls
299            ENDIF
300            DO jl = 1, ipl; DO jk = 1, ipk
301               DO jj = 1, khls
302                  ijj = jpj -jj +1
303                  DO ji = 1, endloop
304                     iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
305                     ptab(ji,ijj ,jk,jl) = psgn * ptab2(iju,jj,jk,jl)
306                  END DO
307               END DO
308            END DO; END DO
309            IF((nimpp + jpi - 1) .eq. jpiglo) THEN
310               DO jl = 1, ipl; DO jk = 1, ipk
311                  DO jj = 1, khls
312                     ijj = jpj -jj +1
313                     DO ii = 1, khls
314                        iij = jpi -ii+1
315                        ptab(iij,ijj,jk,jl) = psgn * ptab(jpi-2*khls+ii-1,jpj-2*khls+jj-1,jk,jl)
316                     END DO
317                  END DO
318               END DO; END DO
319            ENDIF
320            !
321            IF ( .NOT. l_fast_exchanges ) THEN
322               IF( nimpp + jpi - 1 /= jpiglo ) THEN
323                  endloop = jpi
324               ELSE
325                  endloop = jpi - khls
326               ENDIF
327               IF( nimpp >= Ni0glo/2+2 ) THEN
328                  startloop = 1 
329               ELSEIF( nimpp+jpi-1 >= Ni0glo/2+2 .AND. nimpp < Ni0glo/2+2 ) THEN
330                  startloop = Ni0glo/2+2 - nimpp + khls
331               ELSE
332                  startloop = endloop + 1
333               ENDIF
334               IF( startloop <= endloop ) THEN
335                  DO jl = 1, ipl; DO jk = 1, ipk
336                     DO ji = startloop, endloop
337                        iju = jpiglo - ji - nimpp - nfimpp(isendto(1)) + 2
338                        ptab(ji,jpj-khls,jk,jl) = psgn * ptab2(iju,khls+1,jk,jl)
339                     END DO
340                  END DO; END DO
341               ENDIF
342            ENDIF
343            !
344         END SELECT
345         !
346      ENDIF   ! c_NFtype == 'F'
347      !
348   END SUBROUTINE lbc_nfd_nogather_/**/PRECISION
349
Note: See TracBrowser for help on using the repository browser.