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

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 4291

Last change on this file since 4291 was 4230, checked in by cetlod, 10 years ago

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