source: utils/tools/SIREN/src/lbc.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 10 months ago

update nemo trunk

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