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

source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lbcnfd.F90 @ 3211

Last change on this file since 3211 was 3211, checked in by spickles2, 12 years ago

Stephen Pickles, 11 Dec 2011

Commit to bring the rest of the DCSE NEMO development branch
in line with the latest development version. This includes
array index re-ordering of all OPA_SRC/.
  • Property svn:keywords set to Id
File size: 14.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   !!----------------------------------------------------------------------
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   !! * Control permutation of array indices
27#  include "dom_oce_ftrans.h90"
28
29   !!----------------------------------------------------------------------
30   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
31   !! $Id$
32   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
33   !!----------------------------------------------------------------------
34CONTAINS
35
36   SUBROUTINE lbc_nfd_3d( pt3d, cd_type, psgn )
37      !!----------------------------------------------------------------------
38      !!                  ***  routine lbc_nfd_3d  ***
39      !!
40      !! ** Purpose :   3D lateral boundary condition : North fold treatment
41      !!              without processor exchanges.
42      !!
43      !! ** Method  :   
44      !!
45      !! ** Action  :   pt3d with updated values along the north fold
46      !!----------------------------------------------------------------------
47      CHARACTER(len=1)          , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points
48      !                                                        !   = T , U , V , F , W points
49      REAL(wp)                  , INTENT(in   ) ::   psgn      ! control of the sign change
50      !                                                        !   = -1. , the sign is changed if north fold boundary
51      !                                                        !   =  1. , the sign is kept  if north fold boundary
52!FTRANS pt3d :I :I :z
53      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied
54      !
55      INTEGER  ::   ji, jk
56      INTEGER  ::   ijt, iju, ijpj, ijpjm1
57      !!----------------------------------------------------------------------
58
59      SELECT CASE ( jpni )
60      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
61      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
62      END SELECT
63      ijpjm1 = ijpj-1
64
65#if !defined key_z_first
66      DO jk = 1, jpk
67#endif
68         !
69         SELECT CASE ( npolj )
70         !
71         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
72            !
73            SELECT CASE ( cd_type )
74            CASE ( 'T' , 'W' )                         ! T-, W-point
75               DO ji = 2, jpiglo
76                  ijt = jpiglo-ji+2
77#if defined key_z_first
78                  DO jk = 1, jpk
79                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
80                  END DO
81#else
82                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
83#endif
84               END DO
85               DO ji = jpiglo/2+1, jpiglo
86                  ijt = jpiglo-ji+2
87#if defined key_z_first
88                  DO jk = 1, jpk
89                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
90                  END DO
91#else
92                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
93#endif
94               END DO
95            CASE ( 'U' )                               ! U-point
96               DO ji = 1, jpiglo-1
97                  iju = jpiglo-ji+1
98#if defined key_z_first
99                  DO jk = 1, jpk
100                     pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
101                  END DO
102#else
103                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
104#endif
105               END DO
106               DO ji = jpiglo/2, jpiglo-1
107                  iju = jpiglo-ji+1
108#if defined key_z_first
109                  DO jk = 1, jpk
110                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
111                  END DO
112#else
113                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
114#endif
115               END DO
116            CASE ( 'V' )                               ! V-point
117               DO ji = 2, jpiglo
118                  ijt = jpiglo-ji+2
119#if defined key_z_first
120                  DO jk = 1, jpk
121                     pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
122                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
123                  END DO
124#else
125                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
126                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
127#endif
128               END DO
129            CASE ( 'F' )                               ! F-point
130               DO ji = 1, jpiglo-1
131                  iju = jpiglo-ji+1
132#if defined key_z_first
133                  DO jk = 1, jpk
134                     pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
135                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk)
136                  END DO
137#else
138                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
139                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk)
140#endif
141               END DO
142            END SELECT
143            !
144         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
145            !
146            SELECT CASE ( cd_type )
147            CASE ( 'T' , 'W' )                         ! T-, W-point
148               DO ji = 1, jpiglo
149                  ijt = jpiglo-ji+1
150#if defined key_z_first
151                  DO jk = 1, jpk
152                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
153                  END DO
154#else
155                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
156#endif
157               END DO
158            CASE ( 'U' )                               ! U-point
159               DO ji = 1, jpiglo-1
160                  iju = jpiglo-ji
161#if defined key_z_first
162                  DO jk = 1, jpk
163                     pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
164                  END DO
165#else
166                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
167#endif
168               END DO
169            CASE ( 'V' )                               ! V-point
170               DO ji = 1, jpiglo
171                  ijt = jpiglo-ji+1
172#if defined key_z_first
173                  DO jk = 1, jpk
174                     pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
175                  END DO
176#else
177                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
178#endif
179               END DO
180               DO ji = jpiglo/2+1, jpiglo
181                  ijt = jpiglo-ji+1
182#if defined key_z_first
183                  DO jk = 1, jpk
184                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
185                  END DO
186#else
187                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
188#endif
189               END DO
190            CASE ( 'F' )                               ! F-point
191               DO ji = 1, jpiglo-1
192                  iju = jpiglo-ji
193#if defined key_z_first
194                  DO jk = 1, jpk
195                     pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk)
196                  END DO
197#else
198                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk)
199#endif
200               END DO
201               DO ji = jpiglo/2+1, jpiglo-1
202                  iju = jpiglo-ji
203#if defined key_z_first
204                  DO jk = 1, jpk
205                     pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
206                  END DO
207#else
208                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
209#endif
210               END DO
211            END SELECT
212            !
213         CASE DEFAULT                           ! *  closed : the code probably never go through
214            !
215            SELECT CASE ( cd_type)
216            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
217#if defined key_z_first
218               pt3d(:, 1  ,:) = 0.e0
219               pt3d(:,ijpj,:) = 0.e0
220#else
221               pt3d(:, 1  ,jk) = 0.e0
222               pt3d(:,ijpj,jk) = 0.e0
223#endif
224            CASE ( 'F' )                               ! F-point
225#if defined key_z_first
226               pt3d(:,ijpj,:) = 0.e0
227#else
228               pt3d(:,ijpj,jk) = 0.e0
229#endif
230            END SELECT
231            !
232         END SELECT     !  npolj
233         !
234#if !defined key_z_first
235      END DO
236#endif
237      !
238   END SUBROUTINE lbc_nfd_3d
239
240
241   SUBROUTINE lbc_nfd_2d( pt2d, cd_type, psgn, pr2dj )
242      !!----------------------------------------------------------------------
243      !!                  ***  routine lbc_nfd_2d  ***
244      !!
245      !! ** Purpose :   2D lateral boundary condition : North fold treatment
246      !!       without processor exchanges.
247      !!
248      !! ** Method  :   
249      !!
250      !! ** Action  :   pt2d with updated values along the north fold
251      !!----------------------------------------------------------------------
252      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type   ! define the nature of ptab array grid-points
253      !                                                      ! = T , U , V , F , W points
254      REAL(wp)                , INTENT(in   ) ::   psgn      ! control of the sign change
255      !                                                      !   = -1. , the sign is changed if north fold boundary
256      !                                                      !   =  1. , the sign is kept  if north fold boundary
257      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d      ! 2D array on which the boundary condition is applied
258      INTEGER , OPTIONAL      , INTENT(in   ) ::   pr2dj     ! number of additional halos
259      !
260      INTEGER  ::   ji, jl, ipr2dj
261      INTEGER  ::   ijt, iju, ijpj, ijpjm1
262      !!----------------------------------------------------------------------
263
264      SELECT CASE ( jpni )
265      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
266      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
267      END SELECT
268      !
269      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
270         ipr2dj = pr2dj
271         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
272      ELSE
273         ipr2dj = 0 
274      ENDIF
275      !
276      ijpjm1 = ijpj-1
277
278
279      SELECT CASE ( npolj )
280      !
281      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
282         !
283         SELECT CASE ( cd_type )
284         !
285         CASE ( 'T' , 'W' )                               ! T- , W-points
286            DO jl = 0, ipr2dj
287               DO ji = 2, jpiglo
288                  ijt=jpiglo-ji+2
289                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
290               END DO
291            END DO
292            DO ji = jpiglo/2+1, jpiglo
293               ijt=jpiglo-ji+2
294               pt2d(ji,ijpj-1) = psgn * pt2d(ijt,ijpj-1)
295            END DO
296         CASE ( 'U' )                                     ! U-point
297            DO jl = 0, ipr2dj
298               DO ji = 1, jpiglo-1
299                  iju = jpiglo-ji+1
300                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
301               END DO
302            END DO
303            DO ji = jpiglo/2, jpiglo-1
304               iju = jpiglo-ji+1
305               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
306            END DO
307         CASE ( 'V' )                                     ! V-point
308            DO jl = -1, ipr2dj
309               DO ji = 2, jpiglo
310                  ijt = jpiglo-ji+2
311                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-3-jl)
312               END DO
313            END DO
314         CASE ( 'F' )                                     ! F-point
315            DO jl = -1, ipr2dj
316               DO ji = 1, jpiglo-1
317                  iju = jpiglo-ji+1
318                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-3-jl)
319               END DO
320            END DO
321         CASE ( 'I' )                                     ! ice U-V point (I-point)
322            DO jl = 0, ipr2dj
323               pt2d(2,ijpj+jl) = psgn * pt2d(3,ijpj-1+jl)
324               DO ji = 3, jpiglo
325                  iju = jpiglo - ji + 3
326                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
327               END DO
328            END DO
329         END SELECT
330         !
331      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
332         !
333         SELECT CASE ( cd_type )
334         CASE ( 'T' , 'W' )                               ! T-, W-point
335            DO jl = 0, ipr2dj
336               DO ji = 1, jpiglo
337                  ijt = jpiglo-ji+1
338                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
339               END DO
340            END DO
341         CASE ( 'U' )                                     ! U-point
342            DO jl = 0, ipr2dj
343               DO ji = 1, jpiglo-1
344                  iju = jpiglo-ji
345                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
346               END DO
347            END DO
348         CASE ( 'V' )                                     ! V-point
349            DO jl = 0, ipr2dj
350               DO ji = 1, jpiglo
351                  ijt = jpiglo-ji+1
352                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
353               END DO
354            END DO
355            DO ji = jpiglo/2+1, jpiglo
356               ijt = jpiglo-ji+1
357               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
358            END DO
359         CASE ( 'F' )                               ! F-point
360            DO jl = 0, ipr2dj
361               DO ji = 1, jpiglo-1
362                  iju = jpiglo-ji
363                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-2-jl)
364               END DO
365            END DO
366            DO ji = jpiglo/2+1, jpiglo-1
367               iju = jpiglo-ji
368               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
369            END DO
370         CASE ( 'I' )                                  ! ice U-V point (I-point)
371            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
372            DO jl = 0, ipr2dj
373               DO ji = 2 , jpiglo-1
374                  ijt = jpiglo - ji + 2
375                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
376               END DO
377            END DO
378         END SELECT
379         !
380      CASE DEFAULT                           ! *  closed : the code probably never go through
381         !
382         SELECT CASE ( cd_type)
383         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
384            pt2d(:, 1:1-ipr2dj     ) = 0.e0
385            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
386         CASE ( 'F' )                                   ! F-point
387            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
388         CASE ( 'I' )                                   ! ice U-V point
389            pt2d(:, 1:1-ipr2dj     ) = 0.e0
390            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
391         END SELECT
392         !
393      END SELECT
394      !
395   END SUBROUTINE lbc_nfd_2d
396
397   !!======================================================================
398END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.