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

Last change on this file since 7646 was 7646, checked in by timgraham, 4 years ago

Merge of dev_merge_2016 into trunk. UPDATE TO ARCHFILES NEEDED for XIOS2.
LIM_SRC_s/limrhg.F90 to follow in next commit due to change of kind (I'm unable to do it in this commit).
Merged using the following steps:

1) svn merge —reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk .
2) Resolve minor conflicts in sette.sh and namelist_cfg for ORCA2LIM3 (due to a change in trunk after branch was created)
3) svn commit
4) svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
5) svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2016/dev_merge_2016 .
6) At this stage I checked out a clean copy of the branch to compare against what is about to be committed to the trunk.
6) svn commit #Commit code to the trunk

In this commit I have also reverted a change to Fcheck_archfile.sh which was causing problems on the Paris machine.

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