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.
lbc.f90 in branches/2016/dev_merge_2016/NEMOGCM/TOOLS/SIREN/src – NEMO

source: branches/2016/dev_merge_2016/NEMOGCM/TOOLS/SIREN/src/lbc.f90 @ 7421

Last change on this file since 7421 was 7421, checked in by flavoni, 7 years ago

#1811 merge dev_CNRS_MERATOR_2016 with dev_merge_2016 branch
File size: 32.1 KB
Line 
1!----------------------------------------------------------------------
2! NEMO system team, System and Interface for oceanic RElocable Nesting
3!----------------------------------------------------------------------
4!
5! MODULE: math
6!
7! DESCRIPTION:
8!> @brief
9!> This module groups lateral boundary conditions subroutine.
10!>
11!> @details
12!>
13!> @warning keep only non mpp case
14!>
15!> @author
16!> G. Madec
17! REVISION HISTORY:
18!>  @date June, 1997 - Original code
19!> @date September, 2002
20!> - F90: Free form and module
21!>  @date Marsh, 2009
22!> - R. Benshila : External north fold treatment 
23!>  @date December, 2012
24!> - S.Mocavero, I. Epicoco : Add 'lbc_bdy_lnk' and lbc_obc_lnk' routine to optimize the BDY/OBC communications
25!> @date December, 2012
26!> - R. Bourdalle-Badie and G. Reffray : add a C1D case
27!> @date January, 2015
28!> - J.Paul : rewrite with SIREN coding rules
29!> @date Marsh, 2015
30!> - J.Paul : add hide subroutine
31!
32!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
33!----------------------------------------------------------------------
34MODULE lbc
35   USE kind                            ! F90 kind parameter
36   ! NOTE_avoid_public_variables_if_possible
37
38   ! function and subroutine
39   PUBLIC :: lbc_lnk 
40   PUBLIC :: lbc_nfd 
41   PUBLIC :: lbc_hide 
42
43   PRIVATE :: lbc__lnk_3d
44   PRIVATE :: lbc__lnk_2d
45   PRIVATE :: lbc__nfd_3d
46   PRIVATE :: lbc__nfd_2d
47   PRIVATE :: lbc__hide_lnk_2d
48   PRIVATE :: lbc__hide_nfd
49   PRIVATE :: lbc__hide_nfd_2d
50
51   INTERFACE lbc_lnk
52      MODULE PROCEDURE   lbc__lnk_3d
53      MODULE PROCEDURE   lbc__lnk_2d
54   END INTERFACE
55
56   INTERFACE lbc_nfd
57      MODULE PROCEDURE   lbc__nfd_3d
58      MODULE PROCEDURE   lbc__nfd_2d
59   END INTERFACE
60
61   INTERFACE lbc_hide
62      MODULE PROCEDURE   lbc__hide_lnk_2d
63   END INTERFACE
64
65   INTERFACE lbc__hide_nfd
66      MODULE PROCEDURE   lbc__hide_nfd_2d
67   END INTERFACE
68   
69CONTAINS
70   !-------------------------------------------------------------------
71   !> @brief This subroutine set lateral boundary conditions on a 3D array (non mpp case)
72   !>
73   !> @details
74   !>             dd_psign = -1 :    change the sign across the north fold
75   !>                      =  1 : no change of the sign across the north fold
76   !>                      =  0 : no change of the sign across the north fold and
77   !>                             strict positivity preserved: use inner row/column
78   !>                             for closed boundaries.
79   !> @author J.Paul
80   !> - January, 2015- rewrite with SIREN coding rules
81   !
82   !> @param[inout] dd_array  3D array
83   !> @param[in] cd_type point grid
84   !> @param[in] id_perio NEMO periodicity of the grid
85   !> @param[in] dd_psgn
86   !> @param[in] dd_fill   fillValue
87   !-------------------------------------------------------------------
88   SUBROUTINE lbc__lnk_3d( dd_array, cd_type, id_perio, dd_psgn, dd_fill )
89      IMPLICIT NONE
90      ! Argument
91      REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) :: dd_array
92      CHARACTER(LEN=*)          , INTENT(IN   ) :: cd_type
93      INTEGER(i4)               , INTENT(IN   ) :: id_perio
94      REAL(dp),                   INTENT(IN   ) :: dd_psgn
95      REAL(dp),                   INTENT(IN   ), OPTIONAL :: dd_fill
96
97      ! local variable
98      REAL(dp)    :: dl_fill
99
100      INTEGER(i4) :: il_jpi
101      INTEGER(i4) :: il_jpj
102      INTEGER(i4) :: il_jpim1
103      !----------------------------------------------------------------
104      IF( PRESENT( dd_fill ) ) THEN   ;   dl_fill = dd_fill      ! set FillValue (zero by default)
105      ELSE                            ;   dl_fill = 0._dp
106      ENDIF
107
108      il_jpi=SIZE(dd_array(:,:,:),DIM=1)
109      il_jpj=SIZE(dd_array(:,:,:),DIM=2)
110
111      il_jpim1=il_jpi-1
112      !
113      !                                     ! East-West boundaries
114      !                                     ! ====================
115      SELECT CASE ( id_perio )
116      !
117      CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
118         dd_array(    1 ,:,:) = dd_array(il_jpim1,:,:)            ! all points
119         dd_array(il_jpi,:,:) = dd_array(     2  ,:,:)
120         !
121      CASE DEFAULT                             !**  East closed  --  West closed
122         SELECT CASE ( TRIM(cd_type) )
123         CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
124            dd_array(    1 ,:,:) = dl_fill
125            dd_array(il_jpi,:,:) = dl_fill
126         CASE ( 'F' )                               ! F-point
127            dd_array(il_jpi,:,:) = dl_fill
128         END SELECT
129         !
130      END SELECT
131      !
132      !                                     ! North-South boundaries
133      !                                     ! ======================
134      SELECT CASE ( id_perio )
135      !
136      CASE ( 2 )                               !**  South symmetric  --  North closed
137         SELECT CASE ( TRIM(cd_type) )
138         CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
139            dd_array(:,    1 ,:) = dd_array(:,3,:)
140            dd_array(:,il_jpj,:) = dl_fill
141         CASE ( 'V' , 'F' )                         ! V-, F-points
142            dd_array(:,    1 ,:) = dd_psgn * dd_array(:,2,:)
143            dd_array(:,il_jpj,:) = dl_fill
144         END SELECT
145         !
146      CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
147         SELECT CASE ( TRIM(cd_type) )                    ! South : closed
148         CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
149            dd_array(:, 1 ,:) = dl_fill
150         END SELECT
151         !                                          ! North fold
152         CALL lbc_nfd( dd_array(:,:,:), cd_type, id_perio, dd_psgn )
153         !
154      CASE DEFAULT                             !**  North closed  --  South closed
155         SELECT CASE ( cd_type )
156         CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
157            dd_array(:,    1 ,:) = dl_fill
158            dd_array(:,il_jpj,:) = dl_fill
159         CASE ( 'F' )                               ! F-point
160            dd_array(:,il_jpj,:) = dl_fill
161         END SELECT
162         !
163      END SELECT
164
165   END SUBROUTINE lbc__lnk_3d
166   !-------------------------------------------------------------------
167   !> @brief This subroutine set lateral boundary conditions on a 2D array (non mpp case)
168   !>
169   !> @details
170   !>             dd_psign = -1 :    change the sign across the north fold
171   !>                      =  1 : no change of the sign across the north fold
172   !>                      =  0 : no change of the sign across the north fold and
173   !>                             strict positivity preserved: use inner row/column
174   !>                             for closed boundaries.
175   !> @author J.Paul
176   !> - January, 2015- rewrite with SIREN coding rules
177   !
178   !> @param[inout] dd_array  2D array
179   !> @param[in] cd_type point grid
180   !> @param[in] id_perio NEMO periodicity of the grid
181   !> @param[in] dd_psgn
182   !> @param[in] dd_fill   fillValue
183   !-------------------------------------------------------------------
184   SUBROUTINE lbc__lnk_2d( dd_array, cd_type, id_perio, dd_psgn, dd_fill )
185      IMPLICIT NONE
186      ! Argument
187      REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array
188      CHARACTER(LEN=*)        , INTENT(IN   ) :: cd_type
189      INTEGER(i4)             , INTENT(IN   ) :: id_perio
190      REAL(dp)                , INTENT(IN   ) :: dd_psgn
191      REAL(dp)                , INTENT(IN   ), OPTIONAL :: dd_fill
192
193      ! local variable
194      REAL(dp)    :: dl_fill
195
196      INTEGER(i4) :: il_jpi
197      INTEGER(i4) :: il_jpj
198      INTEGER(i4) :: il_jpim1
199      !----------------------------------------------------------------
200      IF( PRESENT( dd_fill ) ) THEN   ;   dl_fill = dd_fill      ! set FillValue (zero by default)
201      ELSE                            ;   dl_fill = 0._dp
202      ENDIF
203
204      il_jpi=SIZE(dd_array(:,:),DIM=1)
205      il_jpj=SIZE(dd_array(:,:),DIM=2)
206
207      il_jpim1=il_jpi-1
208
209      !
210      !                                     ! East-West boundaries
211      !                                     ! ====================
212      SELECT CASE ( id_perio )
213      !
214      CASE ( 1 , 4 , 6 )                       !** cyclic east-west
215         dd_array(    1 ,:) = dd_array(il_jpim1,:)               ! all points
216         dd_array(il_jpi,:) = dd_array(     2  ,:)
217         !
218      CASE DEFAULT                             !** East closed  --  West closed
219         SELECT CASE ( TRIM(cd_type) )
220         CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
221            dd_array(    1 ,:) = dl_fill
222            dd_array(il_jpi,:) = dl_fill
223         CASE ( 'F' )                              ! F-point
224            dd_array(il_jpi,:) = dl_fill
225         END SELECT
226         !
227      END SELECT
228      !
229      !                                     ! North-South boundaries
230      !                                     ! ======================
231      SELECT CASE ( id_perio )
232      !
233      CASE ( 2 )                               !**  South symmetric  --  North closed
234         SELECT CASE ( TRIM(cd_type) )
235         CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
236            dd_array(:,   1  ) = dd_array(:,3)
237            dd_array(:,il_jpj) = dl_fill
238         CASE ( 'V' , 'F' )                         ! V-, F-points
239            dd_array(:,   1  ) = dd_psgn * dd_array(:,2)
240            dd_array(:,il_jpj) = dl_fill
241         END SELECT
242         !
243      CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
244         SELECT CASE ( TRIM(cd_type) )                    ! South : closed
245         CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
246            dd_array(:, 1 ) = dl_fill
247         END SELECT
248         !                                          ! North fold
249         CALL lbc_nfd( dd_array(:,:), cd_type, id_perio, dd_psgn )
250         !
251      CASE DEFAULT                             !**  North closed  --  South closed
252         SELECT CASE ( TRIM(cd_type) )
253         CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
254            dd_array(:,   1  ) = dl_fill
255            dd_array(:,il_jpj) = dl_fill
256         CASE ( 'F' )                               ! F-point
257            dd_array(:,il_jpj) = dl_fill
258         END SELECT
259         !
260      END SELECT
261
262   END SUBROUTINE lbc__lnk_2d
263   !-------------------------------------------------------------------
264   !> @brief This subroutine manage 3D lateral boundary condition :
265   !> North fold treatment without processor exchanges.
266   !>
267   !> @warning keep only non mpp case
268   !>
269   !> @author J.Paul
270   !> - January, 2015- rewrite with SIREN coding rules
271   !
272   !> @param[inout] dd_array  3D array
273   !> @param[in] cd_type point grid
274   !> @param[in] id_perio NEMO periodicity of the grid
275   !> @param[in] dd_psgn
276   !-------------------------------------------------------------------
277   SUBROUTINE lbc__nfd_3d( dd_array, cd_type, id_perio, dd_psgn )
278      IMPLICIT NONE
279      ! Argument
280      REAL(dp), DIMENSION(:,:,:), INTENT(INOUT) :: dd_array
281      CHARACTER(LEN=*)          , INTENT(IN   ) :: cd_type
282      INTEGER(i4)               , INTENT(IN   ) :: id_perio
283      REAL(dp)                  , INTENT(IN   ) :: dd_psgn
284
285      ! local variable
286      INTEGER(i4) :: il_jpi
287      INTEGER(i4) :: il_jpj
288      INTEGER(i4) :: il_jpk
289      INTEGER(i4) :: il_jpim1
290      INTEGER(i4) :: il_jpjm1
291
292      INTEGER(i4) :: ijt
293      INTEGER(i4) :: iju
294
295      ! loop indices
296      INTEGER(i4) :: ji
297      INTEGER(i4) :: jk
298      !----------------------------------------------------------------
299     
300      il_jpi=SIZE(dd_array(:,:,:),DIM=1)
301      il_jpj=SIZE(dd_array(:,:,:),DIM=2)
302      il_jpk=SIZE(dd_array(:,:,:),DIM=3)
303
304      il_jpim1=il_jpi-1
305      il_jpjm1=il_jpj-1
306
307      DO jk = 1, il_jpk
308         !
309         SELECT CASE ( id_perio )
310         !
311         CASE ( 3 , 4 )                        ! *  North fold  T-point pivot
312            !
313            SELECT CASE ( TRIM(cd_type) )
314            CASE ( 'T' , 'W' )                         ! T-, W-point
315               DO ji = 2, il_jpi
316                  ijt = il_jpi-ji+2
317                  dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk)
318               END DO
319               dd_array(1,il_jpj,jk) = dd_psgn * dd_array(3,il_jpj-2,jk)
320               DO ji = il_jpi/2+1, il_jpi
321                  ijt = il_jpi-ji+2
322                  dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(ijt,il_jpjm1,jk)
323               END DO
324            CASE ( 'U' )                               ! U-point
325               DO ji = 1, il_jpi-1
326                  iju = il_jpi-ji+1
327                  dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk)
328               END DO
329               dd_array(   1  ,il_jpj,jk) = dd_psgn * dd_array(    2   ,il_jpj-2,jk)
330               dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(il_jpi-1,il_jpj-2,jk) 
331               DO ji = il_jpi/2, il_jpi-1
332                  iju = il_jpi-ji+1
333                  dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(iju,il_jpjm1,jk)
334               END DO
335            CASE ( 'V' )                               ! V-point
336               DO ji = 2, il_jpi
337                  ijt = il_jpi-ji+2
338                  dd_array(ji,il_jpj-1,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk)
339                  dd_array(ji,il_jpj  ,jk) = dd_psgn * dd_array(ijt,il_jpj-3,jk)
340               END DO
341               dd_array(1,il_jpj,jk) = dd_psgn * dd_array(3,il_jpj-3,jk) 
342            CASE ( 'F' )                               ! F-point
343               DO ji = 1, il_jpi-1
344                  iju = il_jpi-ji+1
345                  dd_array(ji,il_jpj-1,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk)
346                  dd_array(ji,il_jpj  ,jk) = dd_psgn * dd_array(iju,il_jpj-3,jk)
347               END DO
348               dd_array(   1  ,il_jpj,jk) = dd_psgn * dd_array(    2   ,il_jpj-3,jk)
349               dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(il_jpi-1,il_jpj-3,jk) 
350            END SELECT
351            !
352         CASE ( 5 , 6 )                        ! *  North fold  F-point pivot
353            !
354            SELECT CASE ( TRIM(cd_type) )
355            CASE ( 'T' , 'W' )                         ! T-, W-point
356               DO ji = 1, il_jpi
357                  ijt = il_jpi-ji+1
358                  dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-1,jk)
359               END DO
360            CASE ( 'U' )                               ! U-point
361               DO ji = 1, il_jpi-1
362                  iju = il_jpi-ji
363                  dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(iju,il_jpj-1,jk)
364               END DO
365               dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(1,il_jpj-1,jk)
366            CASE ( 'V' )                               ! V-point
367               DO ji = 1, il_jpi
368                  ijt = il_jpi-ji+1
369                  dd_array(ji,il_jpj,jk) = dd_psgn * dd_array(ijt,il_jpj-2,jk)
370               END DO
371               DO ji = il_jpi/2+1, il_jpi
372                  ijt = il_jpi-ji+1
373                  dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(ijt,il_jpjm1,jk)
374               END DO
375            CASE ( 'F' )                               ! F-point
376               DO ji = 1, il_jpi-1
377                  iju = il_jpi-ji
378                  dd_array(ji,il_jpj  ,jk) = dd_psgn * dd_array(iju,il_jpj-2,jk)
379               END DO
380               dd_array(il_jpi,il_jpj,jk) = dd_psgn * dd_array(1,il_jpj-2,jk)
381               DO ji = il_jpi/2+1, il_jpi-1
382                  iju = il_jpi-ji
383                  dd_array(ji,il_jpjm1,jk) = dd_psgn * dd_array(iju,il_jpjm1,jk)
384               END DO
385            END SELECT
386            !
387         CASE DEFAULT                           ! *  closed : the code probably never go through
388            !
389            SELECT CASE ( TRIM(cd_type))
390            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
391               dd_array(:, 1  ,jk) = 0.e0
392               dd_array(:,il_jpj,jk) = 0.e0
393            CASE ( 'F' )                               ! F-point
394               dd_array(:,il_jpj,jk) = 0.e0
395            END SELECT
396            !
397         END SELECT     !  id_perio
398         !
399      END DO
400   END SUBROUTINE lbc__nfd_3d
401   !-------------------------------------------------------------------
402   !> @brief This subroutine manage 2D lateral boundary condition :
403   !> North fold treatment without processor exchanges.
404   !>
405   !> @warning keep only non mpp case
406   !> @warning do not use additional halos
407   !>
408   !> @author J.Paul
409   !> - January, 2015- rewrite with SIREN coding rules
410   !
411   !> @param[inout] dd_array  2D array
412   !> @param[in] cd_type point grid
413   !> @param[in] id_perio NEMO periodicity of the grid
414   !> @param[in] dd_psgn
415   !-------------------------------------------------------------------
416   SUBROUTINE lbc__nfd_2d( dd_array, cd_type, id_perio, dd_psgn )
417      IMPLICIT NONE
418      ! Argument
419      REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array
420      CHARACTER(LEN=*)        , INTENT(IN   ) :: cd_type
421      INTEGER(i4)             , INTENT(IN   ) :: id_perio
422      REAL(dp)                , INTENT(IN   ) :: dd_psgn
423
424      ! local variable
425      INTEGER(i4) :: il_jpi
426      INTEGER(i4) :: il_jpj
427      INTEGER(i4) :: il_jpim1
428      INTEGER(i4) :: il_jpjm1
429
430      INTEGER(i4) :: ijt
431      INTEGER(i4) :: iju
432
433      ! loop indices
434      INTEGER(i4) :: ji
435      !----------------------------------------------------------------
436      il_jpi=SIZE(dd_array(:,:),DIM=1)
437      il_jpj=SIZE(dd_array(:,:),DIM=2)
438
439      il_jpim1=il_jpi-1
440      il_jpjm1=il_jpj-1
441
442      SELECT CASE ( id_perio )
443      !
444      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
445         !
446         SELECT CASE ( TRIM(cd_type) )
447         !
448         CASE ( 'T' , 'W' )                               ! T- , W-points
449            DO ji = 2, il_jpi
450               ijt=il_jpi-ji+2
451               dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-2)
452            END DO
453            dd_array(1,il_jpj)   = dd_psgn * dd_array(3,il_jpj-2)
454            dd_array(1,il_jpj-1) = dd_psgn * dd_array(3,il_jpj-1)
455            DO ji = il_jpi/2+1, il_jpi
456               ijt=il_jpi-ji+2
457               dd_array(ji,il_jpj-1) = dd_psgn * dd_array(ijt,il_jpj-1)
458            END DO
459         CASE ( 'U' )                                     ! U-point
460            DO ji = 1, il_jpi-1
461               iju = il_jpi-ji+1
462               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-2)
463            END DO
464            dd_array(   1  ,il_jpj  ) = dd_psgn * dd_array(    2   ,il_jpj-2)
465            dd_array(il_jpi,il_jpj  ) = dd_psgn * dd_array(il_jpi-1,il_jpj-2)
466            dd_array(1     ,il_jpj-1) = dd_psgn * dd_array(il_jpi  ,il_jpj-1)   
467            DO ji = il_jpi/2, il_jpi-1
468               iju = il_jpi-ji+1
469               dd_array(ji,il_jpjm1) = dd_psgn * dd_array(iju,il_jpjm1)
470            END DO
471         CASE ( 'V' )                                     ! V-point
472            DO ji = 2, il_jpi
473               ijt = il_jpi-ji+2
474               dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-3)
475            END DO
476            dd_array( 1 ,il_jpj)   = dd_psgn * dd_array( 3 ,il_jpj-3) 
477         CASE ( 'F' )                                     ! F-point
478            DO ji = 1, il_jpi-1
479               iju = il_jpi-ji+1
480               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-3)
481            END DO
482            dd_array(   1  ,il_jpj)   = dd_psgn * dd_array(    2   ,il_jpj-3)
483            dd_array(il_jpi,il_jpj)   = dd_psgn * dd_array(il_jpi-1,il_jpj-3)
484            dd_array(il_jpi,il_jpj-1) = dd_psgn * dd_array(il_jpi-1,il_jpj-2)     
485            dd_array(   1  ,il_jpj-1) = dd_psgn * dd_array(    2   ,il_jpj-2)     
486         CASE ( 'I' )                                     ! ice U-V point (I-point)
487            dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1)
488            DO ji = 3, il_jpi
489               iju = il_jpi - ji + 3
490               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1)
491            END DO
492         CASE ( 'J' )                                     ! first ice U-V point
493            dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1)
494            DO ji = 3, il_jpi
495               iju = il_jpi - ji + 3
496               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1)
497            END DO
498         CASE ( 'K' )                                     ! second ice U-V point
499            dd_array(2,il_jpj) = dd_psgn * dd_array(3,il_jpj-1)
500            DO ji = 3, il_jpi
501               iju = il_jpi - ji + 3
502               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1)
503            END DO
504         END SELECT
505         !
506      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
507         !
508         SELECT CASE ( TRIM(cd_type) )
509         CASE ( 'T' , 'W' )                               ! T-, W-point
510            DO ji = 1, il_jpi
511               ijt = il_jpi-ji+1
512               dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-1)
513            END DO
514         CASE ( 'U' )                                     ! U-point
515            DO ji = 1, il_jpi-1
516               iju = il_jpi-ji
517               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-1)
518            END DO
519            dd_array(il_jpi,il_jpj) = dd_psgn * dd_array(1,il_jpj-1)
520         CASE ( 'V' )                                     ! V-point
521            DO ji = 1, il_jpi
522               ijt = il_jpi-ji+1
523               dd_array(ji,il_jpj) = dd_psgn * dd_array(ijt,il_jpj-2)
524            END DO
525            DO ji = il_jpi/2+1, il_jpi
526               ijt = il_jpi-ji+1
527               dd_array(ji,il_jpjm1) = dd_psgn * dd_array(ijt,il_jpjm1)
528            END DO
529         CASE ( 'F' )                               ! F-point
530            DO ji = 1, il_jpi-1
531               iju = il_jpi-ji
532               dd_array(ji,il_jpj) = dd_psgn * dd_array(iju,il_jpj-2)
533            END DO
534            dd_array(il_jpi,il_jpj) = dd_psgn * dd_array(1,il_jpj-2)
535            DO ji = il_jpi/2+1, il_jpi-1
536               iju = il_jpi-ji
537               dd_array(ji,il_jpjm1) = dd_psgn * dd_array(iju,il_jpjm1)
538            END DO
539         CASE ( 'I' )                                  ! ice U-V point (I-point)
540            dd_array( 2 ,il_jpj) = 0.e0
541            DO ji = 2 , il_jpi-1
542               ijt = il_jpi - ji + 2
543               dd_array(ji,il_jpj)= 0.5 * ( dd_array(ji,il_jpj-1) + dd_psgn * dd_array(ijt,il_jpj-1) )
544            END DO
545         CASE ( 'J' )                                  ! first ice U-V point
546            dd_array( 2 ,il_jpj) = 0.e0
547            DO ji = 2 , il_jpi-1
548               ijt = il_jpi - ji + 2
549               dd_array(ji,il_jpj)= dd_array(ji,il_jpj-1)
550            END DO
551         CASE ( 'K' )                                  ! second ice U-V point
552            dd_array( 2 ,il_jpj) = 0.e0
553            DO ji = 2 , il_jpi-1
554               ijt = il_jpi - ji + 2
555               dd_array(ji,il_jpj)= dd_array(ijt,il_jpj-1)
556            END DO
557         END SELECT
558         !
559      CASE DEFAULT                           ! *  closed : the code probably never go through
560         !
561         SELECT CASE ( TRIM(cd_type) )
562         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
563            dd_array(:, 1    ) = 0.e0
564            dd_array(:,il_jpj) = 0.e0
565         CASE ( 'F' )                                   ! F-point
566            dd_array(:,il_jpj) = 0.e0
567         CASE ( 'I' )                                   ! ice U-V point
568            dd_array(:, 1    ) = 0.e0
569            dd_array(:,il_jpj) = 0.e0
570         CASE ( 'J' )                                   ! first ice U-V point
571            dd_array(:, 1    ) = 0.e0
572            dd_array(:,il_jpj) = 0.e0
573         CASE ( 'K' )                                   ! second ice U-V point
574            dd_array(:, 1    ) = 0.e0
575            dd_array(:,il_jpj) = 0.e0
576         END SELECT
577         !
578      END SELECT
579   END SUBROUTINE lbc__nfd_2d
580   !-------------------------------------------------------------------
581   !> @brief This subroutine hide lateral boundary conditions on a 2D array (non mpp case)
582   !>
583   !> @details
584   !>             dd_psign = -1 :    change the sign across the north fold
585   !>                      =  1 : no change of the sign across the north fold
586   !>                      =  0 : no change of the sign across the north fold and
587   !>                             strict positivity preserved: use inner row/column
588   !>                             for closed boundaries.
589   !> @author J.Paul
590   !> - Marsh, 2015- initial version
591   !
592   !> @param[inout] dd_array  2D array
593   !> @param[in] cd_type point grid
594   !> @param[in] id_perio NEMO periodicity of the grid
595   !> @param[in] dd_psgn
596   !> @param[in] dd_fill   fillValue
597   !-------------------------------------------------------------------
598   SUBROUTINE lbc__hide_lnk_2d( dd_array, cd_type, id_perio, dd_psgn, dd_fill )
599      IMPLICIT NONE
600      ! Argument
601      REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array
602      CHARACTER(LEN=*)        , INTENT(IN   ) :: cd_type
603      INTEGER(i4)             , INTENT(IN   ) :: id_perio
604      REAL(dp)                , INTENT(IN   ) :: dd_psgn
605      REAL(dp)                , INTENT(IN   ), OPTIONAL :: dd_fill
606
607      ! local variable
608      REAL(dp)    :: dl_fill
609
610      INTEGER(i4) :: il_jpi
611      INTEGER(i4) :: il_jpj
612      INTEGER(i4) :: il_jpim1
613      !----------------------------------------------------------------
614      IF( PRESENT( dd_fill ) ) THEN   ;   dl_fill = dd_fill      ! set FillValue (zero by default)
615      ELSE                            ;   dl_fill = 0._dp
616      ENDIF
617
618      il_jpi=SIZE(dd_array(:,:),DIM=1)
619      il_jpj=SIZE(dd_array(:,:),DIM=2)
620
621      il_jpim1=il_jpi-1
622
623      !
624      !                                     ! East-West boundaries
625      !                                     ! ====================
626      SELECT CASE ( id_perio )
627      !
628      CASE ( 1 , 4 , 6 )                       !** cyclic east-west
629         dd_array(    1 ,:) = dl_fill               ! all points
630         dd_array(il_jpi,:) = dl_fill
631         !
632      CASE DEFAULT                             !** East closed  --  West closed
633         SELECT CASE ( TRIM(cd_type) )
634         CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
635            dd_array(    1 ,:) = dl_fill
636            dd_array(il_jpi,:) = dl_fill
637         CASE ( 'F' )                              ! F-point
638            dd_array(il_jpi,:) = dl_fill
639         END SELECT
640         !
641      END SELECT
642      !
643      !                                     ! North-South boundaries
644      !                                     ! ======================
645      SELECT CASE ( id_perio )
646      !
647      CASE ( 2 )                               !**  South symmetric  --  North closed
648         SELECT CASE ( TRIM(cd_type) )
649         CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
650            dd_array(:,   1  ) = dl_fill
651            dd_array(:,il_jpj) = dl_fill
652         CASE ( 'V' , 'F' )                         ! V-, F-points
653            dd_array(:,   1  ) = dl_fill
654            dd_array(:,il_jpj) = dl_fill
655         END SELECT
656         !
657      CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
658         SELECT CASE ( TRIM(cd_type) )                    ! South : closed
659         CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
660            dd_array(:, 1 ) = dl_fill
661         END SELECT
662         !                                          ! North fold
663         CALL lbc__hide_nfd( dd_array(:,:), cd_type, id_perio, dd_psgn, &
664         &                   dd_fill=dl_fill )
665         !
666      CASE DEFAULT                             !**  North closed  --  South closed
667         SELECT CASE ( TRIM(cd_type) )
668         CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
669            dd_array(:,   1  ) = dl_fill
670            dd_array(:,il_jpj) = dl_fill
671         CASE ( 'F' )                               ! F-point
672            dd_array(:,il_jpj) = dl_fill
673         END SELECT
674         !
675      END SELECT
676
677   END SUBROUTINE lbc__hide_lnk_2d
678   !-------------------------------------------------------------------
679   !> @brief This subroutine manage 2D lateral boundary condition :
680   !> hide North fold treatment without processor exchanges.
681   !>
682   !> @warning keep only non mpp case
683   !> @warning do not use additional halos
684   !>
685   !> @author J.Paul
686   !> - Marsh, 2015- initial version
687   !
688   !> @param[inout] dd_array  2D array
689   !> @param[in] cd_type point grid
690   !> @param[in] id_perio NEMO periodicity of the grid
691   !> @param[in] dd_psgn
692   !> @param[in] dd_fill
693   !-------------------------------------------------------------------
694   SUBROUTINE lbc__hide_nfd_2d( dd_array, cd_type, id_perio, dd_psgn, dd_fill )
695      IMPLICIT NONE
696      ! Argument
697      REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: dd_array
698      CHARACTER(LEN=*)        , INTENT(IN   ) :: cd_type
699      INTEGER(i4)             , INTENT(IN   ) :: id_perio
700      REAL(dp)                , INTENT(IN   ) :: dd_psgn
701      REAL(dp)                , INTENT(IN   ), OPTIONAL :: dd_fill
702
703      ! local variable
704      REAL(dp)    :: dl_fill
705
706      INTEGER(i4) :: il_jpi
707      INTEGER(i4) :: il_jpj
708      INTEGER(i4) :: il_jpim1
709      INTEGER(i4) :: il_jpjm1
710
711      ! loop indices
712      INTEGER(i4) :: ji
713      !----------------------------------------------------------------
714      IF( PRESENT( dd_fill ) ) THEN   ;   dl_fill = dd_fill      ! set FillValue (zero by default)
715      ELSE                            ;   dl_fill = 0._dp
716      ENDIF
717
718      il_jpi=SIZE(dd_array(:,:),DIM=1)
719      il_jpj=SIZE(dd_array(:,:),DIM=2)
720
721      il_jpim1=il_jpi-1
722      il_jpjm1=il_jpj-1
723
724      SELECT CASE ( id_perio )
725      !
726      CASE ( 3, 4 )                       ! *  North fold  T-point pivot
727         !
728         SELECT CASE ( TRIM(cd_type) )
729         !
730         CASE ( 'T' , 'W' )                               ! T- , W-points
731            DO ji = 2, il_jpi
732               dd_array(ji,il_jpj) = dl_fill
733            END DO
734            dd_array(1,il_jpj)   = dl_fill
735            DO ji = il_jpi/2+2, il_jpi
736               dd_array(ji,il_jpj-1) = dl_fill
737            END DO
738         CASE ( 'U' )                                     ! U-point
739            DO ji = 1, il_jpi-1
740               dd_array(ji,il_jpj) = dl_fill
741            END DO
742            dd_array(   1  ,il_jpj  ) = dl_fill 
743            dd_array(il_jpi,il_jpj  ) = dl_fill
744            dd_array(1     ,il_jpj-1) = dl_fill
745            DO ji = il_jpi/2+1, il_jpi-1
746               dd_array(ji,il_jpjm1) = dl_fill
747            END DO
748         CASE ( 'V' )                                     ! V-point
749            DO ji = 2, il_jpi
750               dd_array(ji,il_jpj) = dl_fill
751            END DO
752            dd_array( 1 ,il_jpj)   = dl_fill 
753         CASE ( 'F' )                                     ! F-point
754            DO ji = 1, il_jpi-1
755               dd_array(ji,il_jpj) = dl_fill
756            END DO
757            dd_array(   1  ,il_jpj)   = dl_fill
758            dd_array(il_jpi,il_jpj)   = dl_fill
759            dd_array(il_jpi,il_jpj-1) = dl_fill 
760            dd_array(   1  ,il_jpj-1) = dl_fill
761         END SELECT
762         !
763      CASE ( 5, 6 )                        ! *  North fold  F-point pivot
764         !
765         SELECT CASE ( TRIM(cd_type) )
766         CASE ( 'T' , 'W' )                               ! T-, W-point
767            DO ji = 1, il_jpi
768               dd_array(ji,il_jpj) = dl_fill
769            END DO
770         CASE ( 'U' )                                     ! U-point
771            DO ji = 1, il_jpi-1
772               dd_array(ji,il_jpj) = dl_fill
773            END DO
774            dd_array(il_jpi,il_jpj) = dl_fill
775         CASE ( 'V' )                                     ! V-point
776            DO ji = 1, il_jpi
777               dd_array(ji,il_jpj) = dl_fill
778            END DO
779            DO ji = il_jpi/2+2, il_jpi
780               dd_array(ji,il_jpjm1) = dl_fill
781            END DO
782         CASE ( 'F' )                               ! F-point
783            DO ji = 1, il_jpi-1
784               dd_array(ji,il_jpj) = dl_fill
785            END DO
786            dd_array(il_jpi,il_jpj) = dl_fill
787            DO ji = il_jpi/2+2, il_jpi-1
788               dd_array(ji,il_jpjm1) = dl_fill
789            END DO
790         END SELECT
791         !
792      CASE DEFAULT                           ! *  closed : the code probably never go through
793         !
794         SELECT CASE ( TRIM(cd_type) )
795         CASE ( 'T' , 'U' , 'V' , 'W' )                 ! T-, U-, V-, W-points
796            dd_array(:, 1    ) = dl_fill
797            dd_array(:,il_jpj) = dl_fill
798         CASE ( 'F' )                                   ! F-point
799            dd_array(:,il_jpj) = dl_fill
800         END SELECT
801         !
802      END SELECT
803   END SUBROUTINE lbc__hide_nfd_2d
804END MODULE lbc
Note: See TracBrowser for help on using the repository browser.