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_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC – NEMO

source: NEMO/branches/2020/dev_r12512_HPC-04_mcastril_Mixed_Precision_implementation/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @ 12603

Last change on this file since 12603 was 12603, checked in by orioltp, 4 years ago

Adding several interfaces to work with both single and double precision
  • Property svn:keywords set to Id
  • Property svn:mime-type set to text/x-fortran
File size: 16.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#      if defined SINGLE_PRECISION
7#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_sp),INTENT(inout)::ptab(f)
8#      else
9#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D_dp),INTENT(inout)::ptab(f)
10#      endif 
11#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
12#      define K_SIZE(ptab)             1
13#      define L_SIZE(ptab)             1
14#   endif
15#   if defined DIM_3d
16#      if defined SINGLE_PRECISION
17#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_sp),INTENT(inout)::ptab(f)
18#      else
19#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D_dp),INTENT(inout)::ptab(f)
20#      endif 
21#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
22#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
23#      define L_SIZE(ptab)             1
24#   endif
25#   if defined DIM_4d
26#      if defined SINGLE_PRECISION
27#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_sp),INTENT(inout)::ptab(f)
28#      else
29#         define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D_dp),INTENT(inout)::ptab(f)
30#      endif 
31#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
32#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
33#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
34#   endif
35#   if defined SINGLE_PRECISION
36#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_sp),INTENT(inout)::ptab2(f)
37#   else
38#      define ARRAY2_TYPE(i,j,k,l,f)   TYPE(PTR_4D_dp),INTENT(inout)::ptab2(f)
39#   endif
40#   define J_SIZE(ptab2)            SIZE(ptab2(1)%pt4d,2)
41#   define ARRAY2_IN(i,j,k,l,f)     ptab2(f)%pt4d(i,j,k,l)
42#else
43!                          !==  IN: ptab is an array  ==!
44#   define NAT_IN(k)                cd_nat
45#   define SGN_IN(k)                psgn
46#   define F_SIZE(ptab)             1
47#   if defined DIM_2d
48#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
49#      define K_SIZE(ptab)          1
50#      define L_SIZE(ptab)          1
51#   endif
52#   if defined DIM_3d
53#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
54#      define K_SIZE(ptab)          SIZE(ptab,3)
55#      define L_SIZE(ptab)          1
56#   endif
57#   if defined DIM_4d
58#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
59#      define K_SIZE(ptab)          SIZE(ptab,3)
60#      define L_SIZE(ptab)          SIZE(ptab,4)
61#   endif
62#   define ARRAY2_IN(i,j,k,l,f)  ptab2(i,j,k,l)
63#   define J_SIZE(ptab2)             SIZE(ptab2,2)
64#   if defined SINGLE_PRECISION
65#      define ARRAY_TYPE(i,j,k,l,f)     REAL(sp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
66#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(sp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
67#   else
68#      define ARRAY_TYPE(i,j,k,l,f)     REAL(dp),INTENT(inout)::ARRAY_IN(i,j,k,l,f)
69#      define ARRAY2_TYPE(i,j,k,l,f)    REAL(dp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f)
70#   endif
71#   endif
72#   ifdef SINGLE_PRECISION
73#      define PRECISION sp
74#   else
75#      define PRECISION dp
76#   endif
77   SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld )
78      !!----------------------------------------------------------------------
79      !!
80      !! ** Purpose :   lateral boundary condition : North fold treatment
81      !!                without allgather exchanges.
82      !!
83      !!----------------------------------------------------------------------
84      ARRAY_TYPE(:,:,:,:,:)                             ! array or pointer of arrays on which the boundary condition is applied
85      ARRAY2_TYPE(:,:,:,:,:)                            ! array or pointer of arrays on which the boundary condition is applied
86      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
87      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
88      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
89      !
90      INTEGER  ::    ji,  jj,   jk,     jl,   jh,  jf   ! dummy loop indices
91      INTEGER  ::   ipi, ipj,  ipk,    ipl,  ipf        ! dimension of the input array
92      INTEGER  ::   ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop
93      LOGICAL  ::   l_fast_exchanges
94      !!----------------------------------------------------------------------
95      ipj = J_SIZE(ptab2)  ! 2nd dimension of input array
96      ipk = K_SIZE(ptab)   ! 3rd dimension of output array
97      ipl = L_SIZE(ptab)   ! 4th    -
98      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
99      !
100      ! Security check for further developments
101      IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' )
102      !
103      ijpj   = 1    ! index of first modified line
104      ijpjp1 = 2    ! index + 1
105     
106      ! 2nd dimension determines exchange speed
107      IF (ipj == 1 ) THEN
108        l_fast_exchanges = .TRUE.
109      ELSE
110        l_fast_exchanges = .FALSE.
111      ENDIF
112      !
113      DO jf = 1, ipf                      ! Loop over the number of arrays to be processed
114         !
115         SELECT CASE ( npolj )
116         !
117         CASE ( 3, 4 )                       ! *  North fold  T-point pivot
118            !
119            SELECT CASE ( NAT_IN(jf) )
120            !
121            CASE ( 'T' , 'W' )                         ! T-, W-point
122               IF ( nimpp /= 1 ) THEN   ;   startloop = 1
123               ELSE                     ;   startloop = 2
124               ENDIF
125               !
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                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
130                  END DO
131               END DO; END DO
132               IF( nimpp == 1 ) THEN
133                  DO jl = 1, ipl; DO jk = 1, ipk
134                     ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf)
135                  END DO; END DO
136               ENDIF
137               !
138               IF ( .NOT. l_fast_exchanges ) THEN
139                  IF( nimpp >= jpiglo/2+1 ) THEN
140                     startloop = 1
141                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
142                     startloop = jpiglo/2+1 - nimpp + 1
143                  ELSE
144                     startloop = nlci + 1
145                  ENDIF
146                  IF( startloop <= nlci ) THEN
147                     DO jl = 1, ipl; DO jk = 1, ipk
148                        DO ji = startloop, nlci
149                           ijt  = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
150                           jia  = ji + nimpp - 1
151                           ijta = jpiglo - jia + 2
152                           IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
153                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf)
154                           ELSE
155                              ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
156                           ENDIF
157                        END DO
158                     END DO; END DO
159                  ENDIF
160               ENDIF
161
162            CASE ( 'U' )                                     ! U-point
163               IF( nimpp + nlci - 1 /= jpiglo ) THEN
164                  endloop = nlci
165               ELSE
166                  endloop = nlci - 1
167               ENDIF
168               DO jl = 1, ipl; DO jk = 1, ipk
169                  DO ji = 1, endloop
170                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
171                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
172                  END DO
173               END DO; END DO
174               IF (nimpp .eq. 1) THEN
175                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
176               ENDIF
177               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
178                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
179               ENDIF
180               !
181               IF ( .NOT. l_fast_exchanges ) THEN
182                  IF( nimpp + nlci - 1 /= jpiglo ) THEN
183                     endloop = nlci
184                  ELSE
185                     endloop = nlci - 1
186                  ENDIF
187                  IF( nimpp >= jpiglo/2 ) THEN
188                     startloop = 1
189                     ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
190                     startloop = jpiglo/2 - nimpp + 1
191                  ELSE
192                     startloop = endloop + 1
193                  ENDIF
194                  IF( startloop <= endloop ) THEN
195                  DO jl = 1, ipl; DO jk = 1, ipk
196                     DO ji = startloop, endloop
197                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
198                        jia = ji + nimpp - 1
199                        ijua = jpiglo - jia + 1
200                        IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
201                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf)
202                        ELSE
203                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
204                        ENDIF
205                     END DO
206                  END DO; END DO
207                  ENDIF
208               ENDIF
209               !
210            CASE ( 'V' )                                     ! V-point
211               IF( nimpp /= 1 ) THEN
212                 startloop = 1
213               ELSE
214                 startloop = 2
215               ENDIF
216               IF ( .NOT. l_fast_exchanges ) THEN
217                  DO jl = 1, ipl; DO jk = 1, ipk
218                     DO ji = startloop, nlci
219                        ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
220                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
221                     END DO
222                  END DO; END DO
223               ENDIF
224               DO jl = 1, ipl; DO jk = 1, ipk
225                  DO ji = startloop, nlci
226                     ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
227                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
228                  END DO
229               END DO; END DO
230               IF (nimpp .eq. 1) THEN
231                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf)
232               ENDIF
233            CASE ( 'F' )                                     ! F-point
234               IF( nimpp + nlci - 1 /= jpiglo ) THEN
235                  endloop = nlci
236               ELSE
237                  endloop = nlci - 1
238               ENDIF
239               IF ( .NOT. l_fast_exchanges ) THEN
240                  DO jl = 1, ipl; DO jk = 1, ipk
241                     DO ji = 1, endloop
242                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
243                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
244                     END DO
245                  END DO; END DO
246               ENDIF
247               DO jl = 1, ipl; DO jk = 1, ipk
248                  DO ji = 1, endloop
249                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
250                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
251                  END DO
252               END DO; END DO
253               IF (nimpp .eq. 1) THEN
254                  ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf)
255                  IF ( .NOT. l_fast_exchanges ) &
256                     ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf)
257               ENDIF
258               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
259                  ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf)
260                  IF ( .NOT. l_fast_exchanges ) &
261                     ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf)
262               ENDIF
263               !
264            END SELECT
265            !
266         CASE ( 5, 6 )                        ! *  North fold  F-point pivot
267            !
268            SELECT CASE ( NAT_IN(jf) )
269            CASE ( 'T' , 'W' )                               ! T-, W-point
270               DO jl = 1, ipl; DO jk = 1, ipk
271                  DO ji = 1, nlci
272                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
273                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
274                  END DO
275               END DO; END DO
276               !
277            CASE ( 'U' )                                     ! U-point
278               IF( nimpp + nlci - 1 /= jpiglo ) THEN
279                  endloop = nlci
280               ELSE
281                  endloop = nlci - 1
282               ENDIF
283               DO jl = 1, ipl; DO jk = 1, ipk
284                  DO ji = 1, endloop
285                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
286                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
287                  END DO
288               END DO; END DO
289               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
290                  DO jl = 1, ipl; DO jk = 1, ipk
291                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf)
292                  END DO; END DO
293               ENDIF
294               !
295            CASE ( 'V' )                                     ! V-point
296               DO jl = 1, ipl; DO jk = 1, ipk
297                  DO ji = 1, nlci
298                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
299                     ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf)
300                  END DO
301               END DO; END DO
302
303               IF ( .NOT. l_fast_exchanges ) THEN
304                  IF( nimpp >= jpiglo/2+1 ) THEN
305                     startloop = 1
306                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
307                     startloop = jpiglo/2+1 - nimpp + 1
308                  ELSE
309                     startloop = nlci + 1
310                  ENDIF
311                  IF( startloop <= nlci ) THEN
312                  DO jl = 1, ipl; DO jk = 1, ipk
313                     DO ji = startloop, nlci
314                        ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
315                        ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf)
316                     END DO
317                  END DO; END DO
318                  ENDIF
319               ENDIF
320               !
321            CASE ( 'F' )                               ! F-point
322               IF( nimpp + nlci - 1 /= jpiglo ) THEN
323                  endloop = nlci
324               ELSE
325                  endloop = nlci - 1
326               ENDIF
327               DO jl = 1, ipl; DO jk = 1, ipk
328                  DO ji = 1, endloop
329                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
330                     ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf)
331                  END DO
332               END DO; END DO
333               IF((nimpp + nlci - 1) .eq. jpiglo) THEN
334                  DO jl = 1, ipl; DO jk = 1, ipk
335                     ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf)
336                  END DO; END DO
337               ENDIF
338               !
339               IF ( .NOT. l_fast_exchanges ) THEN
340                  IF( nimpp + nlci - 1 /= jpiglo ) THEN
341                     endloop = nlci
342                  ELSE
343                     endloop = nlci - 1
344                  ENDIF
345                  IF( nimpp >= jpiglo/2+1 ) THEN
346                     startloop = 1
347                  ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
348                     startloop = jpiglo/2+1 - nimpp + 1
349                  ELSE
350                     startloop = endloop + 1
351                  ENDIF
352                  IF( startloop <= endloop ) THEN
353                     DO jl = 1, ipl; DO jk = 1, ipk
354                        DO ji = startloop, endloop
355                           iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
356                           ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf)
357                        END DO
358                     END DO; END DO
359                  ENDIF
360               ENDIF
361               !
362            END SELECT
363            !
364         CASE DEFAULT                           ! *  closed : the code probably never go through
365            !
366            WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj
367            !
368         END SELECT     !  npolj
369         !
370      END DO            ! End jf loop
371   END SUBROUTINE ROUTINE_NFD
372#undef PRECISION
373#undef ARRAY_TYPE
374#undef ARRAY_IN
375#undef NAT_IN
376#undef SGN_IN
377#undef J_SIZE
378#undef K_SIZE
379#undef L_SIZE
380#undef F_SIZE
381#undef ARRAY2_TYPE
382#undef ARRAY2_IN
Note: See TracBrowser for help on using the repository browser.