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

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 5819

Last change on this file since 5819 was 5819, checked in by timgraham, 8 years ago

Deleted fcm keywords

File size: 39.5 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                  IF(nimpp .eq. 1) THEN
426                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-2,jk)
427                  ENDIF
428               END DO
429
430               IF(nimpp .ge. (jpiglo/2+1)) THEN
431                 startloop = 1
432               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
433                 startloop = jpiglo/2+1 - nimpp + 1
434               ELSE
435                 startloop = nlci + 1
436               ENDIF
437               IF(startloop .le. nlci) THEN
438                 DO jk = 1, jpk
439                    DO ji = startloop, nlci
440                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
441                       jia = ji + nimpp - 1
442                       ijta = jpiglo - jia + 2
443                       IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN
444                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijta-nimpp+1,ijpjm1,jk)
445                       ELSE
446                          pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
447                       ENDIF
448                    END DO
449                 END DO
450               ENDIF
451
452
453            CASE ( 'U' )                               ! U-point
454               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
455                  endloop = nlci
456               ELSE
457                  endloop = nlci - 1
458               ENDIF
459               DO jk = 1, jpk
460                  DO ji = 1, endloop
461                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
462                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-2,jk)
463                  END DO
464                  IF(nimpp .eq. 1) THEN
465                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-2,jk)
466                  ENDIF
467                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
468                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-2,jk)
469                  ENDIF
470               END DO
471
472               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
473                  endloop = nlci
474               ELSE
475                  endloop = nlci - 1
476               ENDIF
477               IF(nimpp .ge. (jpiglo/2)) THEN
478                  startloop = 1
479               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN
480                  startloop = jpiglo/2 - nimpp + 1
481               ELSE
482                  startloop = endloop + 1
483               ENDIF
484               IF (startloop .le. endloop) THEN
485                 DO jk = 1, jpk
486                    DO ji = startloop, endloop
487                      iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
488                      jia = ji + nimpp - 1
489                      ijua = jpiglo - jia + 1
490                      IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN
491                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dl(ijua-nimpp+1,ijpjm1,jk)
492                      ELSE
493                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
494                      ENDIF
495                    END DO
496                 END DO
497               ENDIF
498
499            CASE ( 'V' )                               ! V-point
500               IF (nimpp .ne. 1) THEN
501                  startloop = 1
502               ELSE
503                  startloop = 2
504               ENDIF
505               DO jk = 1, jpk
506                  DO ji = startloop, nlci
507                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
508                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
509                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(ijt,ijpj-3,jk)
510                  END DO
511                  IF(nimpp .eq. 1) THEN
512                     pt3dl(1,ijpj,jk) = psgn * pt3dl(3,ijpj-3,jk)
513                  ENDIF
514               END DO
515            CASE ( 'F' )                               ! F-point
516               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
517                  endloop = nlci
518               ELSE
519                  endloop = nlci - 1
520               ENDIF
521               DO jk = 1, jpk
522                  DO ji = 1, endloop
523                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
524                     pt3dl(ji,ijpj-1,jk) = psgn * pt3dr(iju,ijpj-2,jk)
525                     pt3dl(ji,ijpj  ,jk) = psgn * pt3dr(iju,ijpj-3,jk)
526                  END DO
527                  IF(nimpp .eq. 1) THEN
528                     pt3dl(   1  ,ijpj,jk) = psgn * pt3dl(    2   ,ijpj-3,jk)
529                  ENDIF
530                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
531                     pt3dl(nlci,ijpj,jk) = psgn * pt3dl(nlci-1,ijpj-3,jk)
532                  ENDIF
533               END DO
534            END SELECT
535            !
536
537         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
538            !
539            SELECT CASE ( cd_type )
540            CASE ( 'T' , 'W' )                         ! T-, W-point
541               DO jk = 1, jpk
542                  DO ji = 1, nlci
543                     ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
544                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-1,jk)
545                  END DO
546               END DO
547
548            CASE ( 'U' )                               ! U-point
549               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
550                  endloop = nlci
551               ELSE
552                  endloop = nlci - 1
553               ENDIF
554               DO jk = 1, jpk
555                  DO ji = 1, endloop
556                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
557                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(iju,ijpj-1,jk)
558                  END DO
559                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
560                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-1,jk)
561                  ENDIF
562               END DO
563
564            CASE ( 'V' )                               ! V-point
565               DO jk = 1, jpk
566                  DO ji = 1, nlci
567                     ijt = jpiglo - ji- nimpp - nfiimpp(isendto(1),jpnj) + 3
568                     pt3dl(ji,ijpj,jk) = psgn * pt3dr(ijt,ijpj-2,jk)
569                  END DO
570               END DO
571
572               IF(nimpp .ge. (jpiglo/2+1)) THEN
573                  startloop = 1
574               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
575                  startloop = jpiglo/2+1 - nimpp + 1
576               ELSE
577                  startloop = nlci + 1
578               ENDIF
579               IF(startloop .le. nlci) THEN
580                 DO jk = 1, jpk
581                    DO ji = startloop, nlci
582                       ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
583                       pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(ijt,ijpjm1,jk)
584                    END DO
585                 END DO
586               ENDIF
587
588            CASE ( 'F' )                               ! F-point
589               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
590                  endloop = nlci
591               ELSE
592                  endloop = nlci - 1
593               ENDIF
594               DO jk = 1, jpk
595                  DO ji = 1, endloop
596                     iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
597                     pt3dl(ji,ijpj ,jk) = psgn * pt3dr(iju,ijpj-2,jk)
598                  END DO
599                  IF((nimpp + nlci - 1) .eq. jpiglo) THEN
600                     pt3dl(nlci,ijpj,jk) = psgn * pt3dr(1,ijpj-2,jk)
601                  ENDIF
602               END DO
603
604               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
605                  endloop = nlci
606               ELSE
607                  endloop = nlci - 1
608               ENDIF
609               IF(nimpp .ge. (jpiglo/2+1)) THEN
610                  startloop = 1
611               ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
612                  startloop = jpiglo/2+1 - nimpp + 1
613               ELSE
614                  startloop = endloop + 1
615               ENDIF
616               IF (startloop .le. endloop) THEN
617                  DO jk = 1, jpk
618                     DO ji = startloop, endloop
619                        iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
620                        pt3dl(ji,ijpjm1,jk) = psgn * pt3dr(iju,ijpjm1,jk)
621                     END DO
622                  END DO
623               ENDIF
624
625            END SELECT
626
627         CASE DEFAULT                           ! *  closed : the code probably never go through
628            !
629            SELECT CASE ( cd_type)
630            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
631               pt3dl(:, 1  ,jk) = 0.e0
632               pt3dl(:,ijpj,jk) = 0.e0
633            CASE ( 'F' )                               ! F-point
634               pt3dl(:,ijpj,jk) = 0.e0
635            END SELECT
636            !
637         END SELECT     !  npolj
638         !
639      !
640   END SUBROUTINE mpp_lbc_nfd_3d
641
642
643   SUBROUTINE mpp_lbc_nfd_2d( pt2dl, pt2dr, cd_type, psgn )
644      !!----------------------------------------------------------------------
645      !!                  ***  routine mpp_lbc_nfd_2d  ***
646      !!
647      !! ** Purpose :   2D lateral boundary condition : North fold treatment
648      !!       without processor exchanges.
649      !!
650      !! ** Method  :   
651      !!
652      !! ** Action  :   pt2d with updated values along the north fold
653      !!----------------------------------------------------------------------
654      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points
655      !                                                      ! = T , U , V , F , W points
656      REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change
657      !                                                      !   = -1. , the sign is changed if north fold boundary
658      !                                                      !   =  1. , the sign is kept  if north fold boundary
659      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2dl      ! 2D array on which the boundary condition is applied
660      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pt2dr      ! 2D array on which the boundary condition is applied
661      !
662      INTEGER  ::   ji
663      INTEGER  ::   ijt, iju, ijpj, ijpjm1, ijta, ijua, jia, startloop, endloop
664      !!----------------------------------------------------------------------
665
666      SELECT CASE ( jpni )
667      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
668      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
669      END SELECT
670      !
671      ijpjm1 = ijpj-1
672
673
674      SELECT CASE ( npolj )
675      !
676      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
677         !
678         SELECT CASE ( cd_type )
679         !
680         CASE ( 'T' , 'W' )                               ! T- , W-points
681            IF (nimpp .ne. 1) THEN
682              startloop = 1
683            ELSE
684              startloop = 2
685            ENDIF
686            DO ji = startloop, nlci
687              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
688              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
689            END DO
690            IF (nimpp .eq. 1) THEN
691              pt2dl(1,ijpj)   = psgn * pt2dl(3,ijpj-2)
692            ENDIF
693
694            IF(nimpp .ge. (jpiglo/2+1)) THEN
695               startloop = 1
696            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
697               startloop = jpiglo/2+1 - nimpp + 1
698            ELSE
699               startloop = nlci + 1
700            ENDIF
701            DO ji = startloop, nlci
702               ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
703               jia = ji + nimpp - 1
704               ijta = jpiglo - jia + 2
705               IF((ijta .ge. (startloop + nimpp - 1)) .and. (ijta .lt. jia)) THEN
706                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijta-nimpp+1,ijpjm1)
707               ELSE
708                  pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
709               ENDIF
710            END DO
711
712         CASE ( 'U' )                                     ! U-point
713            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
714               endloop = nlci
715            ELSE
716               endloop = nlci - 1
717            ENDIF
718            DO ji = 1, endloop
719               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
720               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
721            END DO
722
723            IF (nimpp .eq. 1) THEN
724              pt2dl(   1  ,ijpj  ) = psgn * pt2dl(    2   ,ijpj-2)
725              pt2dl(1     ,ijpj-1) = psgn * pt2dr(jpiglo - nfiimpp(isendto(1), jpnj) + 1, ijpj-1)
726            ENDIF
727            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
728              pt2dl(nlci,ijpj  ) = psgn * pt2dl(nlci-1,ijpj-2)
729            ENDIF
730
731            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
732               endloop = nlci
733            ELSE
734               endloop = nlci - 1
735            ENDIF
736            IF(nimpp .ge. (jpiglo/2)) THEN
737               startloop = 1
738            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2)) .AND. (nimpp .lt. (jpiglo/2))) THEN
739               startloop = jpiglo/2 - nimpp + 1
740            ELSE
741               startloop = endloop + 1
742            ENDIF
743            DO ji = startloop, endloop
744               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
745               jia = ji + nimpp - 1
746               ijua = jpiglo - jia + 1
747               IF((ijua .ge. (startloop + nimpp - 1)) .and. (ijua .lt. jia)) THEN
748                  pt2dl(ji,ijpjm1) = psgn * pt2dl(ijua-nimpp+1,ijpjm1)
749               ELSE
750                  pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
751               ENDIF
752            END DO
753
754         CASE ( 'V' )                                     ! V-point
755            IF (nimpp .ne. 1) THEN
756              startloop = 1
757            ELSE
758              startloop = 2
759            ENDIF
760            DO ji = startloop, nlci
761              ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
762              pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1-1)
763              pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-2)
764            END DO
765            IF (nimpp .eq. 1) THEN
766              pt2dl( 1 ,ijpj)   = psgn * pt2dl( 3 ,ijpj-3) 
767            ENDIF
768
769         CASE ( 'F' )                                     ! F-point
770            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
771               endloop = nlci
772            ELSE
773               endloop = nlci - 1
774            ENDIF
775            DO ji = 1, endloop
776               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
777               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1-1)
778               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-2)
779            END DO
780            IF (nimpp .eq. 1) THEN
781              pt2dl(   1  ,ijpj)   = psgn * pt2dl(    2   ,ijpj-3)
782              pt2dl(   1  ,ijpj-1) = psgn * pt2dl(    2   ,ijpj-2)
783            ENDIF
784            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
785              pt2dl(nlci,ijpj)   = psgn * pt2dl(nlci-1,ijpj-3)
786              pt2dl(nlci,ijpj-1) = psgn * pt2dl(nlci-1,ijpj-2) 
787            ENDIF
788
789         CASE ( 'I' )                                     ! ice U-V point (I-point)
790            IF (nimpp .ne. 1) THEN
791               startloop = 1
792            ELSE
793               startloop = 3
794               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1)
795            ENDIF
796            DO ji = startloop, nlci
797               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
798               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
799            END DO
800
801         CASE ( 'J' )                                     ! first ice U-V point
802            IF (nimpp .ne. 1) THEN
803               startloop = 1
804            ELSE
805               startloop = 3
806               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1)
807            ENDIF
808            DO ji = startloop, nlci
809               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
810               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
811            END DO
812
813         CASE ( 'K' )                                     ! second ice U-V point
814            IF (nimpp .ne. 1) THEN
815               startloop = 1
816            ELSE
817               startloop = 3
818               pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1)
819            ENDIF
820            DO ji = startloop, nlci
821               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 5
822               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
823            END DO
824
825         END SELECT
826         !
827      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
828         !
829         SELECT CASE ( cd_type )
830         CASE ( 'T' , 'W' )                               ! T-, W-point
831            DO ji = 1, nlci
832               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
833               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1)
834            END DO
835
836         CASE ( 'U' )                                     ! U-point
837            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
838               endloop = nlci
839            ELSE
840               endloop = nlci - 1
841            ENDIF
842            DO ji = 1, endloop
843               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
844               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1)
845            END DO
846            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
847               pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-1)
848            ENDIF
849
850         CASE ( 'V' )                                     ! V-point
851            DO ji = 1, nlci
852               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
853               pt2dl(ji,ijpj) = psgn * pt2dr(ijt,ijpjm1-1)
854            END DO
855            IF(nimpp .ge. (jpiglo/2+1)) THEN
856               startloop = 1
857            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
858               startloop = jpiglo/2+1 - nimpp + 1
859            ELSE
860               startloop = nlci + 1
861            ENDIF
862            DO ji = startloop, nlci
863               ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3
864               pt2dl(ji,ijpjm1) = psgn * pt2dr(ijt,ijpjm1)
865            END DO
866
867         CASE ( 'F' )                               ! F-point
868            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
869               endloop = nlci
870            ELSE
871               endloop = nlci - 1
872            ENDIF
873            DO ji = 1, endloop
874               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
875               pt2dl(ji,ijpj) = psgn * pt2dr(iju,ijpjm1-1)
876            END DO
877            IF((nimpp + nlci - 1) .eq. jpiglo) THEN
878                pt2dl(nlci,ijpj) = psgn * pt2dr(1,ijpj-2)
879            ENDIF
880
881            IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
882               endloop = nlci
883            ELSE
884               endloop = nlci - 1
885            ENDIF
886            IF(nimpp .ge. (jpiglo/2+1)) THEN
887               startloop = 1
888            ELSEIF(((nimpp+nlci-1) .ge. (jpiglo/2+1)) .AND. (nimpp .lt. (jpiglo/2+1))) THEN
889               startloop = jpiglo/2+1 - nimpp + 1
890            ELSE
891               startloop = endloop + 1
892            ENDIF
893
894            DO ji = startloop, endloop
895               iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2
896               pt2dl(ji,ijpjm1) = psgn * pt2dr(iju,ijpjm1)
897            END DO
898
899         CASE ( 'I' )                                  ! ice U-V point (I-point)
900               IF (nimpp .ne. 1) THEN
901                  startloop = 1
902               ELSE
903                  startloop = 2
904               ENDIF
905               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
906                  endloop = nlci
907               ELSE
908                  endloop = nlci - 1
909               ENDIF
910               DO ji = startloop , endloop
911                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
912                  pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1))
913               END DO
914
915         CASE ( 'J' )                                  ! first ice U-V point
916               IF (nimpp .ne. 1) THEN
917                  startloop = 1
918               ELSE
919                  startloop = 2
920               ENDIF
921               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
922                  endloop = nlci
923               ELSE
924                  endloop = nlci - 1
925               ENDIF
926               DO ji = startloop , endloop
927                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
928                  pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1)
929               END DO
930
931         CASE ( 'K' )                                  ! second ice U-V point
932               IF (nimpp .ne. 1) THEN
933                  startloop = 1
934               ELSE
935                  startloop = 2
936               ENDIF
937               IF ((nimpp + nlci - 1) .ne. jpiglo) THEN
938                  endloop = nlci
939               ELSE
940                  endloop = nlci - 1
941               ENDIF
942               DO ji = startloop, endloop
943                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4
944                  pt2dl(ji,ijpj) = pt2dr(ijt,ijpjm1)
945               END DO
946
947         END SELECT
948         !
949      CASE DEFAULT                           ! *  closed : the code probably never go through
950         !
951         SELECT CASE ( cd_type)
952         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
953            pt2dl(:, 1     ) = 0.e0
954            pt2dl(:,ijpj) = 0.e0
955         CASE ( 'F' )                                   ! F-point
956            pt2dl(:,ijpj) = 0.e0
957         CASE ( 'I' )                                   ! ice U-V point
958            pt2dl(:, 1     ) = 0.e0
959            pt2dl(:,ijpj) = 0.e0
960         CASE ( 'J' )                                   ! first ice U-V point
961            pt2dl(:, 1     ) = 0.e0
962            pt2dl(:,ijpj) = 0.e0
963         CASE ( 'K' )                                   ! second ice U-V point
964            pt2dl(:, 1     ) = 0.e0
965            pt2dl(:,ijpj) = 0.e0
966         END SELECT
967         !
968      END SELECT
969      !
970   END SUBROUTINE mpp_lbc_nfd_2d
971
972END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.