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.
lbcnfd.F90 in branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LBC – NEMO

source: branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/RK3_SRC/LBC/lbcnfd.F90 @ 8367

Last change on this file since 8367 was 8367, checked in by gm, 7 years ago

#1918 (ENHANCE-17): PART 1.1 - create NEMO/RK3_SRC as a copy of NEMO/OPA_SRC + SETTE changes associated with HPC09
  • Property svn:keywords set to Id
File size: 34.7 KB
Line 
1MODULE lbcnfd
2   !!======================================================================
3   !!                       ***  MODULE  lbcnfd  ***
4   !! Ocean        : north fold  boundary conditions
5   !!======================================================================
6   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code
7   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization
8   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   lbc_nfd       : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
13   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd)
14   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd)
15   !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP
16   !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP
17   !!----------------------------------------------------------------------
18   USE dom_oce        ! ocean space and time domain
19   USE in_out_manager ! I/O manager
20
21   IMPLICIT NONE
22   PRIVATE
23
24   INTERFACE lbc_nfd
25      MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d
26   END INTERFACE
27   !
28   INTERFACE mpp_lbc_nfd
29      MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d
30   END INTERFACE
31
32   PUBLIC   lbc_nfd       ! north fold conditions
33   PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case)
34
35   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !:
36   INTEGER, PUBLIC                       ::   nsndto, nfsloop, nfeloop   !:
37   INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate
38
39   !!----------------------------------------------------------------------
40   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
41   !! $Id$
42   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
43   !!----------------------------------------------------------------------
44CONTAINS
45
46   SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
47      !!----------------------------------------------------------------------
48      !!                  ***  routine lbc_nfd_3d  ***
49      !!
50      !! ** Purpose :   3D lateral boundary condition : North fold treatment
51      !!              without processor exchanges.
52      !!
53      !! ** Method  :   
54      !!
55      !! ** Action  :   pt3d with updated values along the north fold
56      !!----------------------------------------------------------------------
57      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied
58      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-point
59      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold
60      !
61      INTEGER  ::   ji, jk
62      INTEGER  ::   ijt, iju, ijpj, ijpjm1
63      !!----------------------------------------------------------------------
64      !
65      SELECT CASE ( jpni )
66      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
67      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
68      END SELECT
69      ijpjm1 = ijpj-1
70
71      DO jk = 1, SIZE( pt3d, 3 )
72         !
73         SELECT CASE ( npolj )
74         !
75         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
76            !
77            SELECT CASE ( cd_type )
78            CASE ( 'T' , 'W' )                         ! T-, W-point
79               DO ji = 2, jpiglo
80                  ijt = jpiglo-ji+2
81                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
82               END DO
83               pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-2,jk)
84               DO ji = jpiglo/2+1, jpiglo
85                  ijt = jpiglo-ji+2
86                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
87               END DO
88            CASE ( 'U' )                               ! U-point
89               DO ji = 1, jpiglo-1
90                  iju = jpiglo-ji+1
91                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
92               END DO
93               pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-2,jk)
94               pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-2,jk) 
95               DO ji = jpiglo/2, jpiglo-1
96                  iju = jpiglo-ji+1
97                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
98               END DO
99            CASE ( 'V' )                               ! V-point
100               DO ji = 2, jpiglo
101                  ijt = jpiglo-ji+2
102                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
103                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
104               END DO
105               pt3d(1,ijpj,jk) = psgn * pt3d(3,ijpj-3,jk) 
106            CASE ( 'F' )                               ! F-point
107               DO ji = 1, jpiglo-1
108                  iju = jpiglo-ji+1
109                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
110                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk)
111               END DO
112               pt3d(   1  ,ijpj,jk) = psgn * pt3d(    2   ,ijpj-3,jk)
113               pt3d(jpiglo,ijpj,jk) = psgn * pt3d(jpiglo-1,ijpj-3,jk) 
114            END SELECT
115            !
116         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
117            !
118            SELECT CASE ( cd_type )
119            CASE ( 'T' , 'W' )                         ! T-, W-point
120               DO ji = 1, jpiglo
121                  ijt = jpiglo-ji+1
122                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
123               END DO
124            CASE ( 'U' )                               ! U-point
125               DO ji = 1, jpiglo-1
126                  iju = jpiglo-ji
127                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
128               END DO
129               pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-1,jk)
130            CASE ( 'V' )                               ! V-point
131               DO ji = 1, jpiglo
132                  ijt = jpiglo-ji+1
133                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
134               END DO
135               DO ji = jpiglo/2+1, jpiglo
136                  ijt = jpiglo-ji+1
137                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
138               END DO
139            CASE ( 'F' )                               ! F-point
140               DO ji = 1, jpiglo-1
141                  iju = jpiglo-ji
142                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk)
143               END DO
144               pt3d(jpiglo,ijpj,jk) = psgn * pt3d(1,ijpj-2,jk)
145               DO ji = jpiglo/2+1, jpiglo-1
146                  iju = jpiglo-ji
147                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
148               END DO
149            END SELECT
150            !
151         CASE DEFAULT                           ! *  closed : the code probably never go through
152            !
153            SELECT CASE ( cd_type)
154            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
155               pt3d(:, 1  ,jk) = 0._wp
156               pt3d(:,ijpj,jk) = 0._wp
157            CASE ( 'F' )                               ! F-point
158               pt3d(:,ijpj,jk) = 0._wp
159            END SELECT
160            !
161         END SELECT     !  npolj
162         !
163      END DO
164      !
165   END SUBROUTINE lbc_nfd_3d
166
167
168   SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
169      !!----------------------------------------------------------------------
170      !!                  ***  routine lbc_nfd_2d  ***
171      !!
172      !! ** Purpose :   2D lateral boundary condition : North fold treatment
173      !!       without processor exchanges.
174      !!
175      !! ** Method  :   
176      !!
177      !! ** Action  :   pt2d with updated values along the north fold
178      !!----------------------------------------------------------------------
179      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied
180      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-point
181      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold
182      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos
183      !
184      INTEGER  ::   ji, jl, ipr2dj
185      INTEGER  ::   ijt, iju, ijpj, ijpjm1
186      !!----------------------------------------------------------------------
187
188      SELECT CASE ( jpni )
189      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
190      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
191      END SELECT
192      !
193      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
194         ipr2dj = pr2dj
195         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
196      ELSE
197         ipr2dj = 0 
198      ENDIF
199      !
200      ijpjm1 = ijpj-1
201
202
203      SELECT CASE ( npolj )
204      !
205      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
206         !
207         SELECT CASE ( cd_type )
208         !
209         CASE ( 'T' , 'W' )                               ! T- , W-points
210            DO jl = 0, ipr2dj
211               DO ji = 2, jpiglo
212                  ijt=jpiglo-ji+2
213                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
214               END DO
215            END DO
216            pt2d(1,ijpj)   = psgn * pt2d(3,ijpj-2)
217            DO ji = jpiglo/2+1, jpiglo
218               ijt=jpiglo-ji+2
219               pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
220            END DO
221         CASE ( 'U' )                                     ! U-point
222            DO jl = 0, ipr2dj
223               DO ji = 1, jpiglo-1
224                  iju = jpiglo-ji+1
225                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
226               END DO
227            END DO
228            pt2d(   1  ,ijpj  ) = psgn * pt2d(    2   ,ijpj-2)
229            pt2d(jpiglo,ijpj  ) = psgn * pt2d(jpiglo-1,ijpj-2)
230            pt2d(1     ,ijpj-1) = psgn * pt2d(jpiglo  ,ijpj-1)   
231            DO ji = jpiglo/2, jpiglo-1
232               iju = jpiglo-ji+1
233               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
234            END DO
235         CASE ( 'V' )                                     ! V-point
236            DO jl = -1, ipr2dj
237               DO ji = 2, jpiglo
238                  ijt = jpiglo-ji+2
239                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
240               END DO
241            END DO
242            pt2d( 1 ,ijpj)   = psgn * pt2d( 3 ,ijpj-3) 
243         CASE ( 'F' )                                     ! F-point
244            DO jl = -1, ipr2dj
245               DO ji = 1, jpiglo-1
246                  iju = jpiglo-ji+1
247                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
248               END DO
249            END DO
250            pt2d(   1  ,ijpj)   = psgn * pt2d(    2   ,ijpj-3)
251            pt2d(jpiglo,ijpj)   = psgn * pt2d(jpiglo-1,ijpj-3)
252            pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)     
253            pt2d(   1  ,ijpj-1) = psgn * pt2d(    2   ,ijpj-2)     
254         CASE ( 'I' )                                     ! ice U-V point (I-point)
255            DO jl = 0, ipr2dj
256               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
257               DO ji = 3, jpiglo
258                  iju = jpiglo - ji + 3
259                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
260               END DO
261            END DO
262         END SELECT
263         !
264      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
265         !
266         SELECT CASE ( cd_type )
267         CASE ( 'T' , 'W' )                               ! T-, W-point
268            DO jl = 0, ipr2dj
269               DO ji = 1, jpiglo
270                  ijt = jpiglo-ji+1
271                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
272               END DO
273            END DO
274         CASE ( 'U' )                                     ! U-point
275            DO jl = 0, ipr2dj
276               DO ji = 1, jpiglo-1
277                  iju = jpiglo-ji
278                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
279               END DO
280            END DO
281            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1)
282         CASE ( 'V' )                                     ! V-point
283            DO jl = 0, ipr2dj
284               DO ji = 1, jpiglo
285                  ijt = jpiglo-ji+1
286                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
287               END DO
288            END DO
289            DO ji = jpiglo/2+1, jpiglo
290               ijt = jpiglo-ji+1
291               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
292            END DO
293         CASE ( 'F' )                               ! F-point
294            DO jl = 0, ipr2dj
295               DO ji = 1, jpiglo-1
296                  iju = jpiglo-ji
297                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
298               END DO
299            END DO
300            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2)
301            DO ji = jpiglo/2+1, jpiglo-1
302               iju = jpiglo-ji
303               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
304            END DO
305         CASE ( 'I' )                                  ! ice U-V point (I-point)
306            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp
307            DO jl = 0, ipr2dj
308               DO ji = 2 , jpiglo-1
309                  ijt = jpiglo - ji + 2
310                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
311               END DO
312            END DO
313         END SELECT
314         !
315      CASE DEFAULT                           ! *  closed : the code probably never go through
316         !
317         SELECT CASE ( cd_type)
318         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
319            pt2d(:, 1:1-ipr2dj     ) = 0._wp
320            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
321         CASE ( 'F' )                                   ! F-point
322            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
323         CASE ( 'I' )                                   ! ice U-V point
324            pt2d(:, 1:1-ipr2dj     ) = 0._wp
325            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
326         END SELECT
327         !
328      END SELECT
329      !
330   END SUBROUTINE lbc_nfd_2d
331
332
333   SUBROUTINE mpp_lbc_nfd_3d( pt3dl, pt3dr, cd_type, psgn )
334      !!----------------------------------------------------------------------
335      !!                  ***  routine mpp_lbc_nfd_3d  ***
336      !!
337      !! ** Purpose :   3D lateral boundary condition : North fold treatment
338      !!              without processor exchanges.
339      !!
340      !! ** Method  :   
341      !!
342      !! ** Action  :   pt3d with updated values along the north fold
343      !!----------------------------------------------------------------------
344      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3dl     ! 3D array on which the boundary condition is applied
345      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pt3dr     ! 3D array on which the boundary condition is applied
346      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point
347      REAL(wp)                  , INTENT(in   ) ::   psgn      ! sign used across north fold
348      !
349      INTEGER  ::   ji, jk      ! dummy loop indices
350      INTEGER  ::   ipk         ! 3rd dimension of the input array
351      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
352      !!----------------------------------------------------------------------
353      !
354      ipk = SIZE( pt3dl, 3 )
355      !
356      SELECT CASE ( jpni )
357      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
358      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
359      END SELECT
360      ijpjm1 = ijpj-1
361      !
362      !
363      SELECT CASE ( npolj )
364      !
365      CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
366         !
367         SELECT CASE ( cd_type )
368            CASE ( 'T' , 'W' )                         ! T-, W-point
369               IF ( nimpp /= 1 ) THEN   ;   startloop = 1
370               ELSE                     ;   startloop = 2
371               ENDIF
372               !
373               DO jk = 1, ipk
374                  DO ji = startloop, nlci
375                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
376                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
377                  END DO
378                  IF(nimpp .eq. 1) THEN
379                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk)
380                  ENDIF
381               END DO
382
383               IF( nimpp >= jpiglo/2+1 ) THEN
384                 startloop = 1
385               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
386                 startloop = jpiglo/2+1 - nimpp + 1
387               ELSE
388                 startloop = nlci + 1
389               ENDIF
390               IF(startloop <= nlci) THEN
391                 DO jk = 1, ipk
392                    DO ji = startloop, nlci
393                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
394                       jia = ji + nimpp - 1
395                       ijta = jpiglo - jia + 2
396                       IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
397                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk)
398                       ELSE
399                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
400                       ENDIF
401                    END DO
402                 END DO
403               ENDIF
404               !
405            CASE ( 'U' )                               ! U-point
406               IF( nimpp + nlci - 1 /= jpiglo ) THEN
407                  endloop = nlci
408               ELSE
409                  endloop = nlci - 1
410               ENDIF
411               DO jk = 1, ipk
412                  DO ji = 1, endloop
413                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
414                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk)
415                  END DO
416                  IF(nimpp .eq. 1) THEN
417                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk)
418                  ENDIF
419                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
420                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk)
421                  ENDIF
422               END DO
423               !
424               IF( nimpp + nlci - 1 /= jpiglo ) THEN
425                  endloop = nlci
426               ELSE
427                  endloop = nlci - 1
428               ENDIF
429               IF( nimpp >= jpiglo/2 ) THEN
430                  startloop = 1
431               ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN
432                  startloop = jpiglo/2 - nimpp + 1
433               ELSE
434                  startloop = endloop + 1
435               ENDIF
436               IF( startloop <= endloop ) THEN
437                 DO jk = 1, ipk
438                    DO ji = startloop, endloop
439                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
440                      jia = ji + nimpp - 1
441                      ijua = jpiglo - jia + 1
442                      IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
443                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk)
444                      ELSE
445                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
446                      ENDIF
447                    END DO
448                 END DO
449               ENDIF
450               !
451            CASE ( 'V' )                               ! V-point
452               IF( nimpp /= 1 ) THEN
453                  startloop = 1
454               ELSE
455                  startloop = 2
456               ENDIF
457               DO jk = 1, ipk
458                  DO ji = startloop, nlci
459                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
460                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
461                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk)
462                  END DO
463                  IF(nimpp .eq. 1) THEN
464                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk)
465                  ENDIF
466               END DO
467            CASE ( 'F' )                               ! F-point
468               IF( nimpp + nlci - 1 /= jpiglo ) THEN
469                  endloop = nlci
470               ELSE
471                  endloop = nlci - 1
472               ENDIF
473               DO jk = 1, ipk
474                  DO ji = 1, endloop
475                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
476                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk)
477                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk)
478                  END DO
479                  IF(nimpp .eq. 1) THEN
480                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk)
481                  ENDIF
482                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
483                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk)
484                  ENDIF
485               END DO
486         END SELECT
487         !
488      CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
489         !
490         SELECT CASE ( cd_type )
491            CASE ( 'T' , 'W' )                         ! T-, W-point
492               DO jk = 1, ipk
493                  DO ji = 1, nlci
494                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
495                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk)
496                  END DO
497               END DO
498               !
499            CASE ( 'U' )                               ! U-point
500               IF( nimpp + nlci - 1 /= jpiglo ) THEN
501                  endloop = nlci
502               ELSE
503                  endloop = nlci - 1
504               ENDIF
505               DO jk = 1, ipk
506                  DO ji = 1, endloop
507                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
508                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk)
509                  END DO
510                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
511                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk)
512                  ENDIF
513               END DO
514               !
515            CASE ( 'V' )                               ! V-point
516               DO jk = 1, ipk
517                  DO ji = 1, nlci
518                     ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3
519                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
520                  END DO
521               END DO
522               !
523               IF( nimpp >= jpiglo/2+1 ) THEN
524                  startloop = 1
525               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
526                  startloop = jpiglo/2+1 - nimpp + 1
527               ELSE
528                  startloop = nlci + 1
529               ENDIF
530               IF( startloop <= nlci ) THEN
531                 DO jk = 1, ipk
532                    DO ji = startloop, nlci
533                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
534                       pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
535                    END DO
536                 END DO
537               ENDIF
538               !
539            CASE ( 'F' )                               ! F-point
540               IF( nimpp + nlci - 1 /= jpiglo ) THEN
541                  endloop = nlci
542               ELSE
543                  endloop = nlci - 1
544               ENDIF
545               DO jk = 1, ipk
546                  DO ji = 1, endloop
547                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
548                     pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk)
549                  END DO
550                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
551                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk)
552                  ENDIF
553               END DO
554               !
555               IF( nimpp + nlci - 1 /= jpiglo ) THEN
556                  endloop = nlci
557               ELSE
558                  endloop = nlci - 1
559               ENDIF
560               IF( nimpp >= jpiglo/2+1 ) THEN
561                  startloop = 1
562               ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
563                  startloop = jpiglo/2+1 - nimpp + 1
564               ELSE
565                  startloop = endloop + 1
566               ENDIF
567               IF( startloop <= endloop ) THEN
568                  DO jk = 1, ipk
569                     DO ji = startloop, endloop
570                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
571                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
572                     END DO
573                  END DO
574               ENDIF
575               !
576         END SELECT
577         !
578      CASE DEFAULT                           ! *  closed : the code probably never go through
579         !
580         SELECT CASE ( cd_type)
581            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
582               pt3dl(:, 1  ,jk) = 0._wp
583               pt3dl(:,ijpj,jk) = 0._wp
584            CASE ( 'F' )                               ! F-point
585               pt3dl(:,ijpj,jk) = 0._wp
586         END SELECT
587         !
588      END SELECT     !  npolj
589      !
590   END SUBROUTINE mpp_lbc_nfd_3d
591
592
593   SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn )
594      !!----------------------------------------------------------------------
595      !!                  ***  routine mpp_lbc_nfd_2d  ***
596      !!
597      !! ** Purpose :   2D lateral boundary condition : North fold treatment
598      !!              without processor exchanges.
599      !!
600      !! ** Method  :   
601      !!
602      !! ** Action  :   pt2dl with updated values along the north fold
603      !!----------------------------------------------------------------------
604      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl     ! 2D array on which the boundary condition is applied
605      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   pt2dr     ! 2D array on which the boundary condition is applied
606      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! nature of pt3d(l/r) grid-point
607      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold
608      !
609      INTEGER  ::   ji
610      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
611      !!----------------------------------------------------------------------
612
613      SELECT CASE ( jpni )
614      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
615      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
616      END SELECT
617      !
618      ijpjm1 = ijpj-1
619      !
620      !
621      SELECT CASE ( npolj )
622      !
623      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
624         !
625         SELECT CASE ( cd_type )
626         !
627         CASE ( 'T' , 'W' )                               ! T- , W-points
628            IF( nimpp /= 1 ) THEN
629              startloop = 1
630            ELSE
631              startloop = 2
632            ENDIF
633            DO ji = startloop, nlci
634              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
635              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
636            END DO
637            IF( nimpp == 1 ) THEN
638              pt2dl(1,ijpj) = psgn * pt2dl(3,ijpj-2)
639            ENDIF
640            !
641            IF( nimpp >= jpiglo/2+1 ) THEN
642               startloop = 1
643            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
644               startloop = jpiglo/2+1 - nimpp + 1
645            ELSE
646               startloop = nlci + 1
647            ENDIF
648            DO ji = startloop, nlci
649               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
650               jia = ji + nimpp - 1
651               ijta = jpiglo - jia + 2
652               IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN
653                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1)
654               ELSE
655                  pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
656               ENDIF
657            END DO
658            !
659         CASE ( 'U' )                                     ! U-point
660            IF( nimpp + nlci - 1 /= jpiglo ) THEN
661               endloop = nlci
662            ELSE
663               endloop = nlci - 1
664            ENDIF
665            DO ji = 1, endloop
666               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
667               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
668            END DO
669            !
670            IF (nimpp .eq. 1) THEN
671              pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2)
672              pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1)
673            ENDIF
674            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
675              pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2)
676            ENDIF
677            !
678            IF( nimpp + nlci - 1 /= jpiglo ) THEN
679               endloop = nlci
680            ELSE
681               endloop = nlci - 1
682            ENDIF
683            IF( nimpp >= jpiglo/2 ) THEN
684               startloop = 1
685            ELSEIF( nimpp+nlci-1 >= jpiglo/2 .AND. nimpp < jpiglo/2 ) THEN
686               startloop = jpiglo/2 - nimpp + 1
687            ELSE
688               startloop = endloop + 1
689            ENDIF
690            DO ji = startloop, endloop
691               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
692               jia = ji + nimpp - 1
693               ijua = jpiglo - jia + 1
694               IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN
695                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1)
696               ELSE
697                  pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
698               ENDIF
699            END DO
700            !
701         CASE ( 'V' )                                     ! V-point
702            IF( nimpp /= 1 ) THEN
703              startloop = 1
704            ELSE
705              startloop = 2
706            ENDIF
707            DO ji = startloop, nlci
708              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
709              pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1)
710              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2)
711            END DO
712            IF (nimpp .eq. 1) THEN
713              pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3) 
714            ENDIF
715            !
716         CASE ( 'F' )                                     ! F-point
717            IF( nimpp + nlci - 1 /= jpiglo ) THEN
718               endloop = nlci
719            ELSE
720               endloop = nlci - 1
721            ENDIF
722            DO ji = 1, endloop
723               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
724               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1)
725               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2)
726            END DO
727            IF (nimpp .eq. 1) THEN
728              pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3)
729              pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2)
730            ENDIF
731            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
732              pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3)
733              pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 
734            ENDIF
735            !
736         CASE ( 'I' )                                     ! ice U-V point (I-point)
737            IF( nimpp /= 1 ) THEN
738               startloop = 1
739            ELSE
740               startloop = 3
741               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1)
742            ENDIF
743            DO ji = startloop, nlci
744               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
745               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
746            END DO
747            !
748         END SELECT
749         !
750      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
751         !
752         SELECT CASE ( cd_type )
753         CASE ( 'T' , 'W' )                               ! T-, W-point
754            DO ji = 1, nlci
755               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
756               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1)
757            END DO
758            !
759         CASE ( 'U' )                                     ! U-point
760            IF( nimpp + nlci - 1 /= jpiglo ) THEN
761               endloop = nlci
762            ELSE
763               endloop = nlci - 1
764            ENDIF
765            DO ji = 1, endloop
766               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
767               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
768            END DO
769            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
770               pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1)
771            ENDIF
772            !
773         CASE ( 'V' )                                     ! V-point
774            DO ji = 1, nlci
775               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
776               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
777            END DO
778            IF( nimpp >= jpiglo/2+1 ) THEN
779               startloop = 1
780            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
781               startloop = jpiglo/2+1 - nimpp + 1
782            ELSE
783               startloop = nlci + 1
784            ENDIF
785            DO ji = startloop, nlci
786               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
787               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
788            END DO
789            !
790         CASE ( 'F' )                               ! F-point
791            IF( nimpp + nlci - 1 /= jpiglo ) THEN
792               endloop = nlci
793            ELSE
794               endloop = nlci - 1
795            ENDIF
796            DO ji = 1, endloop
797               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
798               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
799            END DO
800            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
801                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2)
802            ENDIF
803            !
804            IF( nimpp + nlci - 1 /= jpiglo ) THEN
805               endloop = nlci
806            ELSE
807               endloop = nlci - 1
808            ENDIF
809            IF( nimpp >= jpiglo/2+1 ) THEN
810               startloop = 1
811            ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN
812               startloop = jpiglo/2+1 - nimpp + 1
813            ELSE
814               startloop = endloop + 1
815            ENDIF
816            !
817            DO ji = startloop, endloop
818               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
819               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
820            END DO
821            !
822         CASE ( 'I' )                                  ! ice U-V point (I-point)
823               IF( nimpp /= 1 ) THEN
824                  startloop = 1
825               ELSE
826                  startloop = 2
827               ENDIF
828               IF( nimpp + nlci - 1 /= jpiglo ) THEN
829                  endloop = nlci
830               ELSE
831                  endloop = nlci - 1
832               ENDIF
833               DO ji = startloop , endloop
834                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
835                  pt2dl(ji,ijpj) = 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1))
836               END DO
837               !
838         END SELECT
839         !
840      CASE DEFAULT                           ! *  closed : the code probably never go through
841         !
842         SELECT CASE ( cd_type)
843         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
844            pt2dl(:, 1  ) = 0._wp
845            pt2dl(:,ijpj) = 0._wp
846         CASE ( 'F' )                                   ! F-point
847            pt2dl(:,ijpj) = 0._wp
848         CASE ( 'I' )                                   ! ice U-V point
849            pt2dl(:, 1  ) = 0._wp
850            pt2dl(:,ijpj) = 0._wp
851         END SELECT
852         !
853      END SELECT
854      !
855   END SUBROUTINE mpp_lbc_nfd_2d
856
857   !!======================================================================
858END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.