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 trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 4671

Last change on this file since 4671 was 4671, checked in by epico, 10 years ago

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