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 @ 8186

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

Branch 2017/dev_r8126_ROBUST08_no_ghost. Incorporation of re-written lbc routines. This introduces generic routines for: lbc_lnk, lbc_lnk_multi, lbc_nfd, mpp_bdy, mpp_lnk and mpp_nfd in .h90 files which are pre-processor included multiple times (with different arguments) to recreate equivalences to all the original variants from a much smaller code base (more than 2000 lines shorter). These changes have been SETTE tested and shown to reproduce identical results to the branch base revision. There are a few caveats: the ice cavity routine: iscplhsb.F90, needs to be rewritten to avoid sums over the overlap regions; this will be done elsewhere and has merely been disabled on this branch. The work is not yet complete for the nogather option for the north-fold. The default MPI ALLGATHER option is working but do not activate ln_nogather until further notice.
  • Property svn:keywords set to Id
File size: 11.1 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!   !!   mpp_lbc_nfd_3d: North fold treatment for a 3D arrays optimized for MPP
16!   !!   mpp_lbc_nfd_2d: North fold treatment for a 2D arrays optimized for MPP
17   !!----------------------------------------------------------------------
18   USE dom_oce        ! ocean space and time domain
19   USE in_out_manager ! I/O manager
20
21   IMPLICIT NONE
22   PRIVATE
23
24   INTERFACE lbc_nfd
25      MODULE PROCEDURE   lbc_nfd_2d    , lbc_nfd_3d    , lbc_nfd_4d
26      MODULE PROCEDURE   lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr
27   END INTERFACE
28   !
29!!gm   INTERFACE mpp_lbc_nfd
30!!gm      MODULE PROCEDURE   mpp_lbc_nfd_3d, mpp_lbc_nfd_2d
31!!gm   END INTERFACE
32
33   TYPE, PUBLIC ::   PTR_2D   !: array of 2D pointers (also used in lib_mpp)
34      REAL(wp), DIMENSION (:,:)    , POINTER ::   pt2d
35   END TYPE PTR_2D
36   TYPE, PUBLIC ::   PTR_3D   !: array of 3D pointers (also used in lib_mpp)
37      REAL(wp), DIMENSION (:,:,:)  , POINTER ::   pt3d
38   END TYPE PTR_3D
39   TYPE, PUBLIC ::   PTR_4D   !: array of 4D pointers (also used in lib_mpp)
40      REAL(wp), DIMENSION (:,:,:,:), POINTER ::   pt4d
41   END TYPE PTR_4D
42
43   PUBLIC   lbc_nfd       ! north fold conditions
44!!gm   PUBLIC   mpp_lbc_nfd   ! north fold conditions (parallel case)
45
46   INTEGER, PUBLIC, PARAMETER            ::   jpmaxngh = 3               !:
47   INTEGER, PUBLIC                       ::   nsndto, nfsloop, nfeloop   !:
48   INTEGER, PUBLIC, DIMENSION (jpmaxngh) ::   isendto                    !: processes to which communicate
49
50   !!----------------------------------------------------------------------
51   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
52   !! $Id$
53   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
54   !!----------------------------------------------------------------------
55CONTAINS
56
57   !!----------------------------------------------------------------------
58   !!                   ***  routine lbc_nfd_(2,3,4)d  ***
59   !!----------------------------------------------------------------------
60   !!
61   !! ** Purpose :   lateral boundary condition
62   !!                North fold treatment without processor exchanges.
63   !!
64   !! ** Method  :   
65   !!
66   !! ** Action  :   ptab with updated values along the north fold
67   !!----------------------------------------------------------------------
68   !
69   !                       !==  2D array and array of 2D pointer  ==!
70   !
71#  define DIM_2d
72#     define ROUTINE_NFD           lbc_nfd_2d
73#     include "lbc_nfd_generic.h90"
74#     undef ROUTINE_NFD
75#     define MULTI
76#     define ROUTINE_NFD           lbc_nfd_2d_ptr
77#     include "lbc_nfd_generic.h90"
78#     undef ROUTINE_NFD
79#     undef MULTI
80#  undef DIM_2d
81   !
82   !                       !==  3D array and array of 3D pointer  ==!
83   !
84#  define DIM_3d
85#     define ROUTINE_NFD           lbc_nfd_3d
86#     include "lbc_nfd_generic.h90"
87#     undef ROUTINE_NFD
88#     define MULTI
89#     define ROUTINE_NFD           lbc_nfd_3d_ptr
90#     include "lbc_nfd_generic.h90"
91#     undef ROUTINE_NFD
92#     undef MULTI
93#  undef DIM_3d
94   !
95   !                       !==  4D array and array of 4D pointer  ==!
96   !
97#  define DIM_4d
98#     define ROUTINE_NFD           lbc_nfd_4d
99#     include "lbc_nfd_generic.h90"
100#     undef ROUTINE_NFD
101#     define MULTI
102#     define ROUTINE_NFD           lbc_nfd_4d_ptr
103#     include "lbc_nfd_generic.h90"
104#     undef ROUTINE_NFD
105#     undef MULTI
106#  undef DIM_4d
107
108   !!----------------------------------------------------------------------
109
110
111!!gm   CAUTION HERE  optional pr2dj  not implemented in generic case
112!!gm                 furthermore, in the _org routine it is OK only for T-point pivot !!
113
114
115   SUBROUTINE lbc_nfd_2d_org( pt2d, cd_nat, psgn, pr2dj )
116      !!----------------------------------------------------------------------
117      !!                  ***  routine lbc_nfd_2d  ***
118      !!
119      !! ** Purpose :   2D lateral boundary condition : North fold treatment
120      !!       without processor exchanges.
121      !!
122      !! ** Method  :   
123      !!
124      !! ** Action  :   pt2d with updated values along the north fold
125      !!----------------------------------------------------------------------
126      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied
127      CHARACTER(len=1)        , INTENT(in   ) ::   cd_nat   ! nature of pt2d grid-point
128      REAL(wp)                , INTENT(in   ) ::   psgn      ! sign used across north fold
129      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos
130      !
131      INTEGER  ::   ji, jl, ipr2dj
132      INTEGER  ::   ijt, iju, ijpj, ijpjm1
133      !!----------------------------------------------------------------------
134
135      SELECT CASE ( jpni )
136      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
137      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
138      END SELECT
139      !
140      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
141         ipr2dj = pr2dj
142         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
143      ELSE
144         ipr2dj = 0 
145      ENDIF
146      !
147      ijpjm1 = ijpj-1
148
149
150      SELECT CASE ( npolj )
151      !
152      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
153         !
154         SELECT CASE ( cd_nat )
155         !
156         CASE ( 'T' , 'W' )                               ! T- , W-points
157            DO jl = 0, ipr2dj
158               DO ji = 2, jpiglo
159                  ijt=jpiglo-ji+2
160                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
161               END DO
162            END DO
163            pt2d(1,ijpj)   = psgn * pt2d(3,ijpj-2)
164            DO ji = jpiglo/2+1, jpiglo
165               ijt=jpiglo-ji+2
166               pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
167            END DO
168         CASE ( 'U' )                                     ! U-point
169            DO jl = 0, ipr2dj
170               DO ji = 1, jpiglo-1
171                  iju = jpiglo-ji+1
172                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
173               END DO
174            END DO
175            pt2d(   1  ,ijpj  ) = psgn * pt2d(    2   ,ijpj-2)
176            pt2d(jpiglo,ijpj  ) = psgn * pt2d(jpiglo-1,ijpj-2)
177            pt2d(1     ,ijpj-1) = psgn * pt2d(jpiglo  ,ijpj-1)   
178            DO ji = jpiglo/2, jpiglo-1
179               iju = jpiglo-ji+1
180               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
181            END DO
182         CASE ( 'V' )                                     ! V-point
183            DO jl = -1, ipr2dj
184               DO ji = 2, jpiglo
185                  ijt = jpiglo-ji+2
186                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
187               END DO
188            END DO
189            pt2d( 1 ,ijpj)   = psgn * pt2d( 3 ,ijpj-3) 
190         CASE ( 'F' )                                     ! F-point
191            DO jl = -1, ipr2dj
192               DO ji = 1, jpiglo-1
193                  iju = jpiglo-ji+1
194                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
195               END DO
196            END DO
197            pt2d(   1  ,ijpj)   = psgn * pt2d(    2   ,ijpj-3)
198            pt2d(jpiglo,ijpj)   = psgn * pt2d(jpiglo-1,ijpj-3)
199            pt2d(jpiglo,ijpj-1) = psgn * pt2d(jpiglo-1,ijpj-2)     
200            pt2d(   1  ,ijpj-1) = psgn * pt2d(    2   ,ijpj-2)     
201         CASE ( 'I' )                                     ! ice U-V point (I-point)
202            DO jl = 0, ipr2dj
203               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
204               DO ji = 3, jpiglo
205                  iju = jpiglo - ji + 3
206                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
207               END DO
208            END DO
209         END SELECT
210         !
211      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
212         !
213         SELECT CASE ( cd_nat )
214         CASE ( 'T' , 'W' )                               ! T-, W-point
215            DO jl = 0, ipr2dj
216               DO ji = 1, jpiglo
217                  ijt = jpiglo-ji+1
218                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
219               END DO
220            END DO
221         CASE ( 'U' )                                     ! U-point
222            DO jl = 0, ipr2dj
223               DO ji = 1, jpiglo-1
224                  iju = jpiglo-ji
225                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
226               END DO
227            END DO
228            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-1)
229         CASE ( 'V' )                                     ! V-point
230            DO jl = 0, ipr2dj
231               DO ji = 1, jpiglo
232                  ijt = jpiglo-ji+1
233                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
234               END DO
235            END DO
236            DO ji = jpiglo/2+1, jpiglo
237               ijt = jpiglo-ji+1
238               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
239            END DO
240         CASE ( 'F' )                               ! F-point
241            DO jl = 0, ipr2dj
242               DO ji = 1, jpiglo-1
243                  iju = jpiglo-ji
244                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
245               END DO
246            END DO
247            pt2d(jpiglo,ijpj) = psgn * pt2d(1,ijpj-2)
248            DO ji = jpiglo/2+1, jpiglo-1
249               iju = jpiglo-ji
250               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
251            END DO
252         CASE ( 'I' )                                  ! ice U-V point (I-point)
253            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0._wp
254            DO jl = 0, ipr2dj
255               DO ji = 2 , jpiglo-1
256                  ijt = jpiglo - ji + 2
257                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
258               END DO
259            END DO
260         END SELECT
261         !
262      CASE DEFAULT                           ! *  closed : the code probably never go through
263         !
264         SELECT CASE ( cd_nat)
265         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
266            pt2d(:, 1:1-ipr2dj     ) = 0._wp
267            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
268         CASE ( 'F' )                                   ! F-point
269            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
270         CASE ( 'I' )                                   ! ice U-V point
271            pt2d(:, 1:1-ipr2dj     ) = 0._wp
272            pt2d(:,ijpj:ijpj+ipr2dj) = 0._wp
273         END SELECT
274         !
275      END SELECT
276      !
277   END SUBROUTINE lbc_nfd_2d_org
278
279   !!======================================================================
280END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.