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

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

First attempt to put dynamic allocation on the trunk
  • Property svn:keywords set to Id
File size: 12.6 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         END SELECT
239         !
240      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
241         !
242         SELECT CASE ( cd_type )
243         CASE ( 'T' , 'W' )                               ! T-, W-point
244            DO jl = 0, ipr2dj
245               DO ji = 1, jpiglo
246                  ijt = jpiglo-ji+1
247                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-1-jl)
248               END DO
249            END DO
250         CASE ( 'U' )                                     ! U-point
251            DO jl = 0, ipr2dj
252               DO ji = 1, jpiglo-1
253                  iju = jpiglo-ji
254                  pt2d(ji,ijpj+jl) = psgn * pt2d(iju,ijpj-1-jl)
255               END DO
256            END DO
257         CASE ( 'V' )                                     ! V-point
258            DO jl = 0, ipr2dj
259               DO ji = 1, jpiglo
260                  ijt = jpiglo-ji+1
261                  pt2d(ji,ijpj+jl) = psgn * pt2d(ijt,ijpj-2-jl)
262               END DO
263            END DO
264            DO ji = jpiglo/2+1, jpiglo
265               ijt = jpiglo-ji+1
266               pt2d(ji,ijpjm1) = psgn * pt2d(ijt,ijpjm1)
267            END DO
268         CASE ( 'F' )                               ! F-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-2-jl)
273               END DO
274            END DO
275            DO ji = jpiglo/2+1, jpiglo-1
276               iju = jpiglo-ji
277               pt2d(ji,ijpjm1) = psgn * pt2d(iju,ijpjm1)
278            END DO
279         CASE ( 'I' )                                  ! ice U-V point (I-point)
280            pt2d( 2 ,ijpj:ijpj+ipr2dj) = 0.e0
281            DO jl = 0, ipr2dj
282               DO ji = 2 , jpiglo-1
283                  ijt = jpiglo - ji + 2
284                  pt2d(ji,ijpj+jl)= 0.5 * ( pt2d(ji,ijpj-1-jl) + psgn * pt2d(ijt,ijpj-1-jl) )
285               END DO
286            END DO
287         END SELECT
288         !
289      CASE DEFAULT                           ! *  closed : the code probably never go through
290         !
291         SELECT CASE ( cd_type)
292         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
293            pt2d(:, 1:1-ipr2dj     ) = 0.e0
294            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
295         CASE ( 'F' )                                   ! F-point
296            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
297         CASE ( 'I' )                                   ! ice U-V point
298            pt2d(:, 1:1-ipr2dj     ) = 0.e0
299            pt2d(:,ijpj:ijpj+ipr2dj) = 0.e0
300         END SELECT
301         !
302      END SELECT
303      !
304   END SUBROUTINE lbc_nfd_2d
305
306   !!======================================================================
307END MODULE lbcnfd
Note: See TracBrowser for help on using the repository browser.