New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lbcnfd.F90 in branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 8196

Last change on this file since 8196 was 8196, checked in by acc, 8 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Add generic routine for the north fold operation without global width arrays or MPI_ALLGATHER operations (lbc_nfd_nogather_generic.h90). Actually the generic form is not strictly neccessary since only the 4d array version is used. Other possibilities are currently commented out. This commit includes fixes to mpp_nfd_generic.h90 which ensure only necessary arrays are allocated depending on ln_nnogather setting. Tested with ORCA2LIMPIS_LONG SETTE test and produces identical results with ln_nnogather true or false.
  • Property svn:keywords set to Id
File size: 12.7 KB
Line 
1MODULE lbcnfd
2   !!======================================================================
3   !!                       ***  MODULE  lbcnfd  ***
4   !! Ocean        : north fold  boundary conditions
5   !!======================================================================
6   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code
7   !!            3.5  ! 2013-07  (I. Epicoco, S. Mocavero - CMCC) MPP optimization
8   !!            4.0  ! 2017-04  (G. Madec) automatique allocation of array argument (use any 3rd dimension)
9   !!----------------------------------------------------------------------
10
11   !!----------------------------------------------------------------------
12   !!   lbc_nfd       : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
13   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd)
14   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd)
15   !!   lbc_nfd_nogather       : generic interface for lbc_nfd_nogather_3d and
16   !!                            lbc_nfd_nogather_2d routines (designed for use
17   !!                            with ln_nnogather to avoid global width arrays
18   !!                            mpi all gather operations)
19   !!----------------------------------------------------------------------
20   USE dom_oce        ! ocean space and time domain
21   USE in_out_manager ! I/O manager
22
23   IMPLICIT NONE
24   PRIVATE
25
26   INTERFACE lbc_nfd
27      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d
28      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr
29   END INTERFACE
30   !
31   INTERFACE lbc_nfd_nogather
32!                        ! Currently only 4d array version is needed
33!     MODULE PROCEDURE   lbc_nfd_nogather_2d    , lbc_nfd_nogather_3d
34      MODULE PROCEDURE   lbc_nfd_nogather_4d
35!     MODULE PROCEDURE   lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr
36!     MODULE PROCEDURE   lbc_nfd_nogather_4d_ptr
37   END INTERFACE
38
39   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp)
40      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d
41   END TYPE PTR_2D
42   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp)
43      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d
44   END TYPE PTR_3D
45   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp)
46      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d
47   END TYPE PTR_4D
48
49   PUBLIC   lbc_nfd            ! north fold conditions
50   PUBLIC   lbc_nfd_nogather   ! north fold conditions (no allgather case)
51
52   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !:
53   INTEGER, PUBLIC                       ::   nsndto, nfsloop, nfeloop   !:
54   INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate
55
56   !!----------------------------------------------------------------------
57   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
58   !! $Id$
59   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
60   !!----------------------------------------------------------------------
61CONTAINS
62
63   !!----------------------------------------------------------------------
64   !!                   ***  routine lbc_nfd_(2,3,4)d  ***
65   !!----------------------------------------------------------------------
66   !!
67   !! ** Purpose :   lateral boundary condition
68   !!                North fold treatment without processor exchanges.
69   !!
70   !! ** Method  :   
71   !!
72   !! ** Action  :   ptab with updated values along the north fold
73   !!----------------------------------------------------------------------
74   !
75   !                       !==  2D array and array of 2D pointer  ==!
76   !
77#  define DIM_2d
78#     define ROUTINE_NFD           lbc_nfd_2d
79#     include "lbc_nfd_generic.h90"
80#     undef ROUTINE_NFD
81#     define MULTI
82#     define ROUTINE_NFD           lbc_nfd_2d_ptr
83#     include "lbc_nfd_generic.h90"
84#     undef ROUTINE_NFD
85#     undef MULTI
86#  undef DIM_2d
87   !
88   !                       !==  3D array and array of 3D pointer  ==!
89   !
90#  define DIM_3d
91#     define ROUTINE_NFD           lbc_nfd_3d
92#     include "lbc_nfd_generic.h90"
93#     undef ROUTINE_NFD
94#     define MULTI
95#     define ROUTINE_NFD           lbc_nfd_3d_ptr
96#     include "lbc_nfd_generic.h90"
97#     undef ROUTINE_NFD
98#     undef MULTI
99#  undef DIM_3d
100   !
101   !                       !==  4D array and array of 4D pointer  ==!
102   !
103#  define DIM_4d
104#     define ROUTINE_NFD           lbc_nfd_4d
105#     include "lbc_nfd_generic.h90"
106#     undef ROUTINE_NFD
107#     define MULTI
108#     define ROUTINE_NFD           lbc_nfd_4d_ptr
109#     include "lbc_nfd_generic.h90"
110#     undef ROUTINE_NFD
111#     undef MULTI
112#  undef DIM_4d
113   !
114   !  lbc_nfd_nogather routines
115   !
116   !                       !==  2D array and array of 2D pointer  ==!
117   !
118!#  define DIM_2d
119!#     define ROUTINE_NFD           lbc_nfd_nogather_2d
120!#     include "lbc_nfd_nogather_generic.h90"
121!#     undef ROUTINE_NFD
122!#     define MULTI
123!#     define ROUTINE_NFD           lbc_nfd_nogather_2d_ptr
124!#     include "lbc_nfd_nogather_generic.h90"
125!#     undef ROUTINE_NFD
126!#     undef MULTI
127!#  undef DIM_2d
128   !
129   !                       !==  3D array and array of 3D pointer  ==!
130   !
131!#  define DIM_3d
132!#     define ROUTINE_NFD           lbc_nfd_nogather_3d
133!#     include "lbc_nfd_nogather_generic.h90"
134!#     undef ROUTINE_NFD
135!#     define MULTI
136!#     define ROUTINE_NFD           lbc_nfd_nogather_3d_ptr
137!#     include "lbc_nfd_nogather_generic.h90"
138!#     undef ROUTINE_NFD
139!#     undef MULTI
140!#  undef DIM_3d
141   !
142   !                       !==  4D array and array of 4D pointer  ==!
143   !
144#  define DIM_4d
145#     define ROUTINE_NFD           lbc_nfd_nogather_4d
146#     include "lbc_nfd_nogather_generic.h90"
147#     undef ROUTINE_NFD
148!#     define MULTI
149!#     define ROUTINE_NFD           lbc_nfd_nogather_4d_ptr
150!#     include "lbc_nfd_nogather_generic.h90"
151!#     undef ROUTINE_NFD
152!#     undef MULTI
153#  undef DIM_4d
154
155   !!----------------------------------------------------------------------
156
157
158!!gm   CAUTION HERE  optional pr2dj  not implemented in generic case
159!!gm                 furthermore, in the _org routine it is OK only for T-point pivot !!
160
161
162   SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj )
163      !!----------------------------------------------------------------------
164      !!                  ***  routine lbc_nfd_2d  ***
165      !!
166      !! ** Purpose :   2D lateral boundary condition : North fold treatment
167      !!       without processor exchanges.
168      !!
169      !! ** Method  :   
170      !!
171      !! ** Action  :   pt2d with updated values along the north fold
172      !!----------------------------------------------------------------------
173      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied
174      CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point
175      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold
176      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos
177      !
178      INTEGER  ::   ji, jl, ipr2dj
179      INTEGER  ::   ijt, iju, ijpj, ijpjm1
180      !!----------------------------------------------------------------------
181
182      SELECT CASE ( jpni )
183      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
184      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
185      END SELECT
186      !
187      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
188         ipr2dj = pr2dj
189         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
190      ELSE
191         ipr2dj = 0 
192      ENDIF
193      !
194      ijpjm1 = ijpj-1
195
196
197      SELECT CASE ( npolj )
198      !
199      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
200         !
201         SELECT CASE ( cd_nat )
202         !
203         CASE ( 'T' , 'W' )                               ! T- , W-points
204            DO jl = 0, ipr2dj
205               DO ji = 2, jpiglo
206                  ijt=jpiglo-ji+2
207                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
208               END DO
209            END DO
210            pt2d(1,ijpj)   = psgn * pt2d(3,ijpj-2)
211            DO ji = jpiglo/2+1, jpiglo
212               ijt=jpiglo-ji+2
213               pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
214            END DO
215         CASE ( 'U' )                                     ! U-point
216            DO jl = 0, ipr2dj
217               DO ji = 1, jpiglo-1
218                  iju = jpiglo-ji+1
219                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
220               END DO
221            END DO
222            pt2d(   1  ,ijpj  ) = psgn * pt2d(    2   ,ijpj-2)
223            pt2d(jpiglo,ijpj  ) = psgn * pt2d(jpiglo-1,ijpj-2)
224            pt2d(1     ,ijpj-1) = psgn * pt2d(jpiglo  ,ijpj-1)   
225            DO ji = jpiglo/2, jpiglo-1
226               iju = jpiglo-ji+1
227               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
228            END DO
229         CASE ( 'V' )                                     ! V-point
230            DO jl = -1, ipr2dj
231               DO ji = 2, jpiglo
232                  ijt = jpiglo-ji+2
233                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
234               END DO
235            END DO
236            pt2d( 1 ,ijpj)   = psgn * pt2d( 3 ,ijpj-3) 
237         CASE ( 'F' )                                     ! F-point
238            DO jl = -1, ipr2dj
239               DO ji = 1, jpiglo-1
240                  iju = jpiglo-ji+1
241                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
242               END DO
243            END DO
244            pt2d(   1  ,ijpj)   = psgn * pt2d(    2   ,ijpj-3)
245            pt2d(jpiglo,ijpj)   = psgn * pt2d(jpiglo-1,ijpj-3)
246            pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)     
247            pt2d(   1  ,ijpj-1) = psgn * pt2d(    2   ,ijpj-2)     
248         CASE ( 'I' )                                     ! ice U-V point (I-point)
249            DO jl = 0, ipr2dj
250               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
251               DO ji = 3, jpiglo
252                  iju = jpiglo - ji + 3
253                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
254               END DO
255            END DO
256         END SELECT
257         !
258      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
259         !
260         SELECT CASE ( cd_nat )
261         CASE ( 'T' , 'W' )                               ! T-, W-point
262            DO jl = 0, ipr2dj
263               DO ji = 1, jpiglo
264                  ijt = jpiglo-ji+1
265                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
266               END DO
267            END DO
268         CASE ( 'U' )                                     ! U-point
269            DO jl = 0, ipr2dj
270               DO ji = 1, jpiglo-1
271                  iju = jpiglo-ji
272                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
273               END DO
274            END DO
275            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1)
276         CASE ( 'V' )                                     ! V-point
277            DO jl = 0, ipr2dj
278               DO ji = 1, jpiglo
279                  ijt = jpiglo-ji+1
280                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
281               END DO
282            END DO
283            DO ji = jpiglo/2+1, jpiglo
284               ijt = jpiglo-ji+1
285               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
286            END DO
287         CASE ( 'F' )                               ! F-point
288            DO jl = 0, ipr2dj
289               DO ji = 1, jpiglo-1
290                  iju = jpiglo-ji
291                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
292               END DO
293            END DO
294            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2)
295            DO ji = jpiglo/2+1, jpiglo-1
296               iju = jpiglo-ji
297               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
298            END DO
299         CASE ( 'I' )                                  ! ice U-V point (I-point)
300            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp
301            DO jl = 0, ipr2dj
302               DO ji = 2 , jpiglo-1
303                  ijt = jpiglo - ji + 2
304                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
305               END DO
306            END DO
307         END SELECT
308         !
309      CASE DEFAULT                           ! *  closed : the code probably never go through
310         !
311         SELECT CASE ( cd_nat)
312         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
313            pt2d(:, 1:1-ipr2dj     ) = 0._wp
314            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
315         CASE ( 'F' )                                   ! F-point
316            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
317         CASE ( 'I' )                                   ! ice U-V point
318            pt2d(:, 1:1-ipr2dj     ) = 0._wp
319            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
320         END SELECT
321         !
322      END SELECT
323      !
324   END SUBROUTINE lbc_nfd_2d_org
325
326   !!======================================================================
327END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.