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

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

Last change on this file since 3294 was 3294, checked in by rblod, 12 years ago

Merge of 3.4beta into the trunk
  • Property svn:keywords set to Id
File size: 14.2 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   !!----------------------------------------------------------------------
8
9   !!----------------------------------------------------------------------
10   !!   lbc_nfd       : generic interface for lbc_nfd_3d and lbc_nfd_2d routines
11   !!   lbc_nfd_3d    : lateral boundary condition: North fold treatment for a 3D arrays   (lbc_nfd)
12   !!   lbc_nfd_2d    : lateral boundary condition: North fold treatment for a 2D arrays   (lbc_nfd)
13   !!----------------------------------------------------------------------
14   USE dom_oce        ! ocean space and time domain
15   USE in_out_manager ! I/O manager
16
17   IMPLICIT NONE
18   PRIVATE
19
20   INTERFACE lbc_nfd
21      MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d
22   END INTERFACE
23
24   PUBLIC   lbc_nfd   ! north fold conditions
25
26   !!----------------------------------------------------------------------
27   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
28   !! $Id$
29   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
30   !!----------------------------------------------------------------------
31CONTAINS
32
33   SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
34      !!----------------------------------------------------------------------
35      !!                  ***  routine lbc_nfd_3d  ***
36      !!
37      !! ** Purpose :   3D lateral boundary condition : North fold treatment
38      !!              without processor exchanges.
39      !!
40      !! ** Method  :   
41      !!
42      !! ** Action  :   pt3d with updated values along the north fold
43      !!----------------------------------------------------------------------
44      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points
45      !                                                        !   = T , U , V , F , W points
46      REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change
47      !                                                        !   = -1. , the sign is changed if north fold boundary
48      !                                                        !   =  1. , the sign is kept  if north fold boundary
49      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied
50      !
51      INTEGER  ::   ji, jk
52      INTEGER  ::   ijt, iju, ijpj, ijpjm1
53      !!----------------------------------------------------------------------
54
55      SELECT CASE ( jpni )
56      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
57      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
58      END SELECT
59      ijpjm1 = ijpj-1
60
61      DO jk = 1, jpk
62         !
63         SELECT CASE ( npolj )
64         !
65         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
66            !
67            SELECT CASE ( cd_type )
68            CASE ( 'T' , 'W' )                         ! T-, W-point
69               DO ji = 2, jpiglo
70                  ijt = jpiglo-ji+2
71                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
72               END DO
73               DO ji = jpiglo/2+1, jpiglo
74                  ijt = jpiglo-ji+2
75                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
76               END DO
77            CASE ( 'U' )                               ! U-point
78               DO ji = 1, jpiglo-1
79                  iju = jpiglo-ji+1
80                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
81               END DO
82               DO ji = jpiglo/2, jpiglo-1
83                  iju = jpiglo-ji+1
84                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
85               END DO
86            CASE ( 'V' )                               ! V-point
87               DO ji = 2, jpiglo
88                  ijt = jpiglo-ji+2
89                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
90                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
91               END DO
92            CASE ( 'F' )                               ! F-point
93               DO ji = 1, jpiglo-1
94                  iju = jpiglo-ji+1
95                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
96                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk)
97               END DO
98            END SELECT
99            !
100         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
101            !
102            SELECT CASE ( cd_type )
103            CASE ( 'T' , 'W' )                         ! T-, W-point
104               DO ji = 1, jpiglo
105                  ijt = jpiglo-ji+1
106                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
107               END DO
108            CASE ( 'U' )                               ! U-point
109               DO ji = 1, jpiglo-1
110                  iju = jpiglo-ji
111                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
112               END DO
113            CASE ( 'V' )                               ! V-point
114               DO ji = 1, jpiglo
115                  ijt = jpiglo-ji+1
116                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
117               END DO
118               DO ji = jpiglo/2+1, jpiglo
119                  ijt = jpiglo-ji+1
120                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
121               END DO
122            CASE ( 'F' )                               ! F-point
123               DO ji = 1, jpiglo-1
124                  iju = jpiglo-ji
125                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk)
126               END DO
127               DO ji = jpiglo/2+1, jpiglo-1
128                  iju = jpiglo-ji
129                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
130               END DO
131            END SELECT
132            !
133         CASE DEFAULT                           ! *  closed : the code probably never go through
134            !
135            SELECT CASE ( cd_type)
136            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
137               pt3d(:, 1  ,jk) = 0.e0
138               pt3d(:,ijpj,jk) = 0.e0
139            CASE ( 'F' )                               ! F-point
140               pt3d(:,ijpj,jk) = 0.e0
141            END SELECT
142            !
143         END SELECT     !  npolj
144         !
145      END DO
146      !
147   END SUBROUTINE lbc_nfd_3d
148
149
150   SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
151      !!----------------------------------------------------------------------
152      !!                  ***  routine lbc_nfd_2d  ***
153      !!
154      !! ** Purpose :   2D lateral boundary condition : North fold treatment
155      !!       without processor exchanges.
156      !!
157      !! ** Method  :   
158      !!
159      !! ** Action  :   pt2d with updated values along the north fold
160      !!----------------------------------------------------------------------
161      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points
162      !                                                      ! = T , U , V , F , W points
163      REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change
164      !                                                      !   = -1. , the sign is changed if north fold boundary
165      !                                                      !   =  1. , the sign is kept  if north fold boundary
166      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied
167      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos
168      !
169      INTEGER  ::   ji, jl, ipr2dj
170      INTEGER  ::   ijt, iju, ijpj, ijpjm1
171      !!----------------------------------------------------------------------
172
173      SELECT CASE ( jpni )
174      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
175      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
176      END SELECT
177      !
178      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
179         ipr2dj = pr2dj
180         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
181      ELSE
182         ipr2dj = 0 
183      ENDIF
184      !
185      ijpjm1 = ijpj-1
186
187
188      SELECT CASE ( npolj )
189      !
190      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
191         !
192         SELECT CASE ( cd_type )
193         !
194         CASE ( 'T' , 'W' )                               ! T- , W-points
195            DO jl = 0, ipr2dj
196               DO ji = 2, jpiglo
197                  ijt=jpiglo-ji+2
198                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
199               END DO
200            END DO
201            DO ji = jpiglo/2+1, jpiglo
202               ijt=jpiglo-ji+2
203               pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
204            END DO
205         CASE ( 'U' )                                     ! U-point
206            DO jl = 0, ipr2dj
207               DO ji = 1, jpiglo-1
208                  iju = jpiglo-ji+1
209                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
210               END DO
211            END DO
212            DO ji = jpiglo/2, jpiglo-1
213               iju = jpiglo-ji+1
214               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
215            END DO
216         CASE ( 'V' )                                     ! V-point
217            DO jl = -1, ipr2dj
218               DO ji = 2, jpiglo
219                  ijt = jpiglo-ji+2
220                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
221               END DO
222            END DO
223         CASE ( 'F' )                                     ! F-point
224            DO jl = -1, ipr2dj
225               DO ji = 1, jpiglo-1
226                  iju = jpiglo-ji+1
227                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
228               END DO
229            END DO
230         CASE ( 'I' )                                     ! ice U-V point (I-point)
231            DO jl = 0, ipr2dj
232               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
233               DO ji = 3, jpiglo
234                  iju = jpiglo - ji + 3
235                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
236               END DO
237            END DO
238         CASE ( 'J' )                                     ! first ice U-V point
239            DO jl =0, ipr2dj
240               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
241               DO ji = 3, jpiglo
242                  iju = jpiglo - ji + 3
243                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
244               END DO
245            END DO
246         CASE ( 'K' )                                     ! second ice U-V point
247            DO jl =0, ipr2dj
248               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
249               DO ji = 3, jpiglo
250                  iju = jpiglo - ji + 3
251                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
252               END DO
253            END DO
254         END SELECT
255         !
256      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
257         !
258         SELECT CASE ( cd_type )
259         CASE ( 'T' , 'W' )                               ! T-, W-point
260            DO jl = 0, ipr2dj
261               DO ji = 1, jpiglo
262                  ijt = jpiglo-ji+1
263                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
264               END DO
265            END DO
266         CASE ( 'U' )                                     ! U-point
267            DO jl = 0, ipr2dj
268               DO ji = 1, jpiglo-1
269                  iju = jpiglo-ji
270                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
271               END DO
272            END DO
273         CASE ( 'V' )                                     ! V-point
274            DO jl = 0, ipr2dj
275               DO ji = 1, jpiglo
276                  ijt = jpiglo-ji+1
277                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
278               END DO
279            END DO
280            DO ji = jpiglo/2+1, jpiglo
281               ijt = jpiglo-ji+1
282               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
283            END DO
284         CASE ( 'F' )                               ! F-point
285            DO jl = 0, ipr2dj
286               DO ji = 1, jpiglo-1
287                  iju = jpiglo-ji
288                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
289               END DO
290            END DO
291            DO ji = jpiglo/2+1, jpiglo-1
292               iju = jpiglo-ji
293               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
294            END DO
295         CASE ( 'I' )                                  ! ice U-V point (I-point)
296            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
297            DO jl = 0, ipr2dj
298               DO ji = 2 , jpiglo-1
299                  ijt = jpiglo - ji + 2
300                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
301               END DO
302            END DO
303         CASE ( 'J' )                                  ! first ice U-V point
304            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
305            DO jl = 0, ipr2dj
306               DO ji = 2 , jpiglo-1
307                  ijt = jpiglo - ji + 2
308                  pt2d(ji,ijpj+jl)= pt2d(ji,ijpj-1-jl)
309               END DO
310            END DO
311         CASE ( 'K' )                                  ! second ice U-V point
312            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
313            DO jl = 0, ipr2dj
314               DO ji = 2 , jpiglo-1
315                  ijt = jpiglo - ji + 2
316                  pt2d(ji,ijpj+jl)= pt2d(ijt,ijpj-1-jl)
317               END DO
318            END DO
319         END SELECT
320         !
321      CASE DEFAULT                           ! *  closed : the code probably never go through
322         !
323         SELECT CASE ( cd_type)
324         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
325            pt2d(:, 1:1-ipr2dj     ) = 0.e0
326            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
327         CASE ( 'F' )                                   ! F-point
328            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
329         CASE ( 'I' )                                   ! ice U-V point
330            pt2d(:, 1:1-ipr2dj     ) = 0.e0
331            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
332         CASE ( 'J' )                                   ! first ice U-V point
333            pt2d(:, 1:1-ipr2dj     ) = 0.e0
334            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
335         CASE ( 'K' )                                   ! second ice U-V point
336            pt2d(:, 1:1-ipr2dj     ) = 0.e0
337            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
338         END SELECT
339         !
340      END SELECT
341      !
342   END SUBROUTINE lbc_nfd_2d
343
344   !!======================================================================
345END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.