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
RevLine 
[1344]1MODULE lbcnfd
2   !!======================================================================
3   !!                       ***  MODULE  lbcnfd  ***
4   !! Ocean        : north fold  boundary conditions
5   !!======================================================================
[2413]6   !! History :  3.2  ! 2009-03  (R. Benshila)  Original code
[1344]7   !!----------------------------------------------------------------------
8
[2413]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
[1344]17   IMPLICIT NONE
18   PRIVATE
19
20   INTERFACE lbc_nfd
[2413]21      MODULE PROCEDURE   lbc_nfd_3d, lbc_nfd_2d
[1344]22   END INTERFACE
23
[2413]24   PUBLIC   lbc_nfd   ! north fold conditions
[2287]25
[3211]26   !! * Control permutation of array indices
27#  include "dom_oce_ftrans.h90"
28
[1344]29   !!----------------------------------------------------------------------
[2287]30   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
31   !! $Id$
[2413]32   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[2287]33   !!----------------------------------------------------------------------
[1344]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
[2413]41      !!              without processor exchanges.
[1344]42      !!
43      !! ** Method  :   
44      !!
[2413]45      !! ** Action  :   pt3d with updated values along the north fold
[1344]46      !!----------------------------------------------------------------------
[2413]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
[3211]52!FTRANS pt3d :I :I :z
[2413]53      REAL(wp), DIMENSION(:,:,:), INTENT(inout) ::   pt3d      ! 3D array on which the boundary condition is applied
54      !
[1344]55      INTEGER  ::   ji, jk
56      INTEGER  ::   ijt, iju, ijpj, ijpjm1
[2413]57      !!----------------------------------------------------------------------
[1344]58
59      SELECT CASE ( jpni )
[2413]60      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
61      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
[1344]62      END SELECT
63      ijpjm1 = ijpj-1
64
[3211]65#if !defined key_z_first
[1344]66      DO jk = 1, jpk
[3211]67#endif
[2413]68         !
[1344]69         SELECT CASE ( npolj )
[2413]70         !
[1344]71         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
[2413]72            !
[1344]73            SELECT CASE ( cd_type )
74            CASE ( 'T' , 'W' )                         ! T-, W-point
75               DO ji = 2, jpiglo
76                  ijt = jpiglo-ji+2
[3211]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
[1344]82                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
[3211]83#endif
[1344]84               END DO
85               DO ji = jpiglo/2+1, jpiglo
86                  ijt = jpiglo-ji+2
[3211]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
[1344]92                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
[3211]93#endif
[1344]94               END DO
95            CASE ( 'U' )                               ! U-point
96               DO ji = 1, jpiglo-1
97                  iju = jpiglo-ji+1
[3211]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
[1344]103                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-2,jk)
[3211]104#endif
[1344]105               END DO
106               DO ji = jpiglo/2, jpiglo-1
107                  iju = jpiglo-ji+1
[3211]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
[1344]113                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
[3211]114#endif
[1344]115               END DO
116            CASE ( 'V' )                               ! V-point
117               DO ji = 2, jpiglo
118                  ijt = jpiglo-ji+2
[3211]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
[1344]125                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(ijt,ijpj-2,jk)
126                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(ijt,ijpj-3,jk)
[3211]127#endif
[1344]128               END DO
129            CASE ( 'F' )                               ! F-point
130               DO ji = 1, jpiglo-1
131                  iju = jpiglo-ji+1
[3211]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
[1344]138                  pt3d(ji,ijpj-1,jk) = psgn * pt3d(iju,ijpj-2,jk)
139                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-3,jk)
[3211]140#endif
[1344]141               END DO
142            END SELECT
[2413]143            !
[1344]144         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
[2413]145            !
[1344]146            SELECT CASE ( cd_type )
147            CASE ( 'T' , 'W' )                         ! T-, W-point
148               DO ji = 1, jpiglo
149                  ijt = jpiglo-ji+1
[3211]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
[1344]155                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-1,jk)
[3211]156#endif
[1344]157               END DO
158            CASE ( 'U' )                               ! U-point
159               DO ji = 1, jpiglo-1
160                  iju = jpiglo-ji
[3211]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
[1344]166                  pt3d(ji,ijpj,jk) = psgn * pt3d(iju,ijpj-1,jk)
[3211]167#endif
[1344]168               END DO
169            CASE ( 'V' )                               ! V-point
170               DO ji = 1, jpiglo
171                  ijt = jpiglo-ji+1
[3211]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
[1344]177                  pt3d(ji,ijpj,jk) = psgn * pt3d(ijt,ijpj-2,jk)
[3211]178#endif
[1344]179               END DO
180               DO ji = jpiglo/2+1, jpiglo
181                  ijt = jpiglo-ji+1
[3211]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
[1344]187                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(ijt,ijpjm1,jk)
[3211]188#endif
[1344]189               END DO
190            CASE ( 'F' )                               ! F-point
191               DO ji = 1, jpiglo-1
192                  iju = jpiglo-ji
[3211]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
[1344]198                  pt3d(ji,ijpj  ,jk) = psgn * pt3d(iju,ijpj-2,jk)
[3211]199#endif
[1344]200               END DO
201               DO ji = jpiglo/2+1, jpiglo-1
202                  iju = jpiglo-ji
[3211]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
[1344]208                  pt3d(ji,ijpjm1,jk) = psgn * pt3d(iju,ijpjm1,jk)
[3211]209#endif
[1344]210               END DO
211            END SELECT
[2413]212            !
[1344]213         CASE DEFAULT                           ! *  closed : the code probably never go through
[2413]214            !
[1344]215            SELECT CASE ( cd_type)
216            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
[3211]217#if defined key_z_first
218               pt3d(:, 1  ,:) = 0.e0
219               pt3d(:,ijpj,:) = 0.e0
220#else
[1344]221               pt3d(:, 1  ,jk) = 0.e0
222               pt3d(:,ijpj,jk) = 0.e0
[3211]223#endif
[1344]224            CASE ( 'F' )                               ! F-point
[3211]225#if defined key_z_first
226               pt3d(:,ijpj,:) = 0.e0
227#else
[1344]228               pt3d(:,ijpj,jk) = 0.e0
[3211]229#endif
[1344]230            END SELECT
[2413]231            !
[1344]232         END SELECT     !  npolj
[2413]233         !
[3211]234#if !defined key_z_first
[1344]235      END DO
[3211]236#endif
[2413]237      !
[1344]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      !!
[2413]250      !! ** Action  :   pt2d with updated values along the north fold
[1344]251      !!----------------------------------------------------------------------
[2413]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      !
[1344]260      INTEGER  ::   ji, jl, ipr2dj
261      INTEGER  ::   ijt, iju, ijpj, ijpjm1
[2413]262      !!----------------------------------------------------------------------
[1344]263
264      SELECT CASE ( jpni )
[2413]265      CASE ( 1 )     ;   ijpj = nlcj      ! 1 proc only  along the i-direction
266      CASE DEFAULT   ;   ijpj = 4         ! several proc along the i-direction
[1344]267      END SELECT
[2413]268      !
269      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
[1344]270         ipr2dj = pr2dj
[2413]271         IF( jpni > 1 )   ijpj = ijpj + ipr2dj
[1344]272      ELSE
273         ipr2dj = 0 
274      ENDIF
[2413]275      !
[1344]276      ijpjm1 = ijpj-1
277
278
279      SELECT CASE ( npolj )
[2413]280      !
[1344]281      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
[2413]282         !
[1344]283         SELECT CASE ( cd_type )
[2413]284         !
285         CASE ( 'T' , 'W' )                               ! T- , W-points
[1344]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
[2413]297            DO jl = 0, ipr2dj
[1344]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
[2413]308            DO jl = -1, ipr2dj
[1344]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
[2413]314         CASE ( 'F' )                                     ! F-point
315            DO jl = -1, ipr2dj
[1344]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
[2413]321         CASE ( 'I' )                                     ! ice U-V point (I-point)
322            DO jl = 0, ipr2dj
[1344]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
[2413]330         !
[1344]331      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
[2413]332         !
[1344]333         SELECT CASE ( cd_type )
[2413]334         CASE ( 'T' , 'W' )                               ! T-, W-point
[1344]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
[2413]359         CASE ( 'F' )                               ! F-point
[1344]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
[2413]370         CASE ( 'I' )                                  ! ice U-V point (I-point)
[1344]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
[2413]379         !
[1344]380      CASE DEFAULT                           ! *  closed : the code probably never go through
[2413]381         !
[1344]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
[2413]392         !
[1344]393      END SELECT
[2413]394      !
[1344]395   END SUBROUTINE lbc_nfd_2d
396
397   !!======================================================================
398END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.