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.
lbclnk.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/lbclnk.F90 @ 3837

Last change on this file since 3837 was 3837, checked in by trackstand2, 11 years ago

Merge of finiss

  • Property svn:keywords set to Id
File size: 13.9 KB
RevLine 
[3]1MODULE lbclnk
2   !!======================================================================
[232]3   !!                       ***  MODULE  lbclnk  ***
[3]4   !! Ocean        : lateral boundary conditions
5   !!=====================================================================
[2335]6   !! History :  OPA  ! 1997-06  (G. Madec)     Original code
7   !!   NEMO     1.0  ! 2002-09  (G. Madec)     F90: Free form and module
8   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment 
[1344]9   !!----------------------------------------------------------------------
[2335]10#if   defined key_mpp_mpi
[3]11   !!----------------------------------------------------------------------
[2335]12   !!   'key_mpp_mpi'             MPI massively parallel processing library
[3]13   !!----------------------------------------------------------------------
[2335]14   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
15   !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp
[15]16   !!----------------------------------------------------------------------
[3]17   USE lib_mpp          ! distributed memory computing library
[3432]18   USE exchmod          ! Comms for irregular domain decomposition
[3]19
[3837]20   ! This is important - it determines which set of comms routines are
21   ! called when lbc_lnk() is invoked.
[3]22   INTERFACE lbc_lnk
[3432]23#if  defined key_mpp_rkpart
24      MODULE PROCEDURE lbc_exch2, lbc_exch3 !, lbc_exch2i, lbc_exch3i
25#else
[473]26      MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
[3432]27#endif
[3]28   END INTERFACE
29
[311]30   INTERFACE lbc_lnk_e
31      MODULE PROCEDURE mpp_lnk_2d_e
32   END INTERFACE
33
[3]34   PUBLIC lbc_lnk       ! ocean lateral boundary conditions
[311]35   PUBLIC lbc_lnk_e
[2335]36
[3]37   !!----------------------------------------------------------------------
[2335]38   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
39   !! $Id$
40   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
41   !!----------------------------------------------------------------------
[3]42
43#else
44   !!----------------------------------------------------------------------
45   !!   Default option                              shared memory computing
46   !!----------------------------------------------------------------------
47   !!   lbc_lnk      : generic interface for lbc_lnk_3d and lbc_lnk_2d
[2335]48   !!   lbc_lnk_3d   : set the lateral boundary condition on a 3D variable on ocean mesh
49   !!   lbc_lnk_2d   : set the lateral boundary condition on a 2D variable on ocean mesh
[3]50   !!----------------------------------------------------------------------
51   USE oce             ! ocean dynamics and tracers   
52   USE dom_oce         ! ocean space and time domain
53   USE in_out_manager  ! I/O manager
[1344]54   USE lbcnfd          ! north fold
[3]55
56   IMPLICIT NONE
57   PRIVATE
58
59   INTERFACE lbc_lnk
[473]60      MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
[3]61   END INTERFACE
62
[311]63   INTERFACE lbc_lnk_e
64      MODULE PROCEDURE lbc_lnk_2d
65   END INTERFACE
66
[2335]67   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions
68   PUBLIC   lbc_lnk_e 
[3211]69
70   !! * Control permutation of array indices
71#  include "oce_ftrans.h90"
72#  include "dom_oce_ftrans.h90"
73
[3]74   !!----------------------------------------------------------------------
[2335]75   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
76   !! $Id$
77   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
78   !!----------------------------------------------------------------------
[3]79CONTAINS
80
[473]81   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
[3]82      !!---------------------------------------------------------------------
[473]83      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
84      !!
[2335]85      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case)
[473]86      !!
[2335]87      !! ** Method  :   psign = -1 :    change the sign across the north fold
88      !!                      =  1 : no change of the sign across the north fold
89      !!                      =  0 : no change of the sign across the north fold and
90      !!                             strict positivity preserved: use inner row/column
91      !!                             for closed boundaries.
[473]92      !!----------------------------------------------------------------------
[2335]93      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points
[3211]94!FTRANS pt3d1 :I :I :z
95!FTRANS pt3d2 :I :I :z
96! DCSE_NEMO: work around a deficiency in ftrans
97!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied
98      REAL(wp), INTENT(inout)   ::   pt3d1(jpi,jpj,jpk)   , pt3d2(jpi,jpj,jpk)
99      REAL(wp), INTENT(in   )   ::   psgn                 ! control of the sign
[2335]100      !!----------------------------------------------------------------------
101      !
[1344]102      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
103      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
[2335]104      !
[473]105   END SUBROUTINE lbc_lnk_3d_gather
106
107
[3837]108   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval, lzero )
109      USE lib_mpp, ONLY: ctl_stop
[473]110      !!---------------------------------------------------------------------
[3]111      !!                  ***  ROUTINE lbc_lnk_3d  ***
112      !!
[2335]113      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
[3]114      !!
[2335]115      !! ** Method  :   psign = -1 :    change the sign across the north fold
116      !!                      =  1 : no change of the sign across the north fold
117      !!                      =  0 : no change of the sign across the north fold and
118      !!                             strict positivity preserved: use inner row/column
119      !!                             for closed boundaries.
120      !!----------------------------------------------------------------------
121      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
[3211]122!FTRANS pt3d :I :I :z
123!! DCSE_NEMO: work around a deficiency in ftrans
124!     REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
125      REAL(wp), INTENT(inout)                                   ::   pt3d(jpi,jpj,jpk)
[2335]126      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
127      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
128      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
[3837]129      LOGICAL                         , INTENT(in   ), OPTIONAL ::   lzero     ! Whether to zero halos on closed boundaries
130
[3]131      !!
[2335]132      REAL(wp) ::   zland
[3]133      !!----------------------------------------------------------------------
134
[2335]135      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
136      ELSE                         ;   zland = 0.e0
[888]137      ENDIF
138
[3837]139      IF( PRESENT( lzero ) )THEN
140         CALL ctl_stop('STOP','lbc_lnk_3d: IMPLEMENT lzero option!')
141      ENDIF
[888]142
143      IF( PRESENT( cd_mpp ) ) THEN
[473]144         ! only fill the overlap area and extra allows
145         ! this is in mpp case. In this module, just do nothing
146      ELSE
[2335]147         !
[1344]148         !                                     !  East-West boundaries
149         !                                     ! ======================
[3]150         SELECT CASE ( nperio )
[1344]151         !
152         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
153            pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points
154            pt3d(jpi,:,:) = pt3d(  2  ,:,:)
155            !
156         CASE DEFAULT                             !**  East closed  --  West closed
[3]157            SELECT CASE ( cd_type )
158            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
[1344]159               pt3d( 1 ,:,:) = zland
160               pt3d(jpi,:,:) = zland
[3]161            CASE ( 'F' )                               ! F-point
[1344]162               pt3d(jpi,:,:) = zland
[3]163            END SELECT
[1344]164            !
[3]165         END SELECT
[2335]166         !
[3]167         !                                     ! North-South boundaries
168         !                                     ! ======================
169         SELECT CASE ( nperio )
[1344]170         !
171         CASE ( 2 )                               !**  South symmetric  --  North closed
[3]172            SELECT CASE ( cd_type )
173            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
[1344]174               pt3d(:, 1 ,:) = pt3d(:,3,:)
175               pt3d(:,jpj,:) = zland
[3]176            CASE ( 'V' , 'F' )                         ! V-, F-points
[1344]177               pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
178               pt3d(:,jpj,:) = zland
[3]179            END SELECT
[1344]180            !
181         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
182            SELECT CASE ( cd_type )                    ! South : closed
183            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
184               pt3d(:, 1 ,:) = zland
[3]185            END SELECT
[1344]186            !                                          ! North fold
187            pt3d( 1 ,jpj,:) = zland
188            pt3d(jpi,jpj,:) = zland
189            CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
190            !
191         CASE DEFAULT                             !**  North closed  --  South closed
[3]192            SELECT CASE ( cd_type )
[1344]193            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
194               pt3d(:, 1 ,:) = zland
195               pt3d(:,jpj,:) = zland
[3]196            CASE ( 'F' )                               ! F-point
[1344]197               pt3d(:,jpj,:) = zland
[3]198            END SELECT
[1344]199            !
200         END SELECT
[2335]201         !
[1344]202      ENDIF
[2335]203      !
[3]204   END SUBROUTINE lbc_lnk_3d
205
206
[3837]207   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval, lzero )
208      USE lib_mpp, ONLY: ctl_stop
[3]209      !!---------------------------------------------------------------------
210      !!                 ***  ROUTINE lbc_lnk_2d  ***
211      !!
[2335]212      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
[3]213      !!
[2335]214      !! ** Method  :   psign = -1 :    change the sign across the north fold
215      !!                      =  1 : no change of the sign across the north fold
216      !!                      =  0 : no change of the sign across the north fold and
217      !!                             strict positivity preserved: use inner row/column
218      !!                             for closed boundaries.
219      !!----------------------------------------------------------------------
220      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
[2339]221      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
[2335]222      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
223      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
224      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
[3837]225      LOGICAL                     , INTENT(in   ), OPTIONAL ::   lzero    ! Whether to zero halos on closed boundaries
[3]226      !!
[2335]227      REAL(wp) ::   zland
[3]228      !!----------------------------------------------------------------------
229
[2335]230      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
231      ELSE                         ;   zland = 0.e0
[888]232      ENDIF
233
[3837]234      IF( PRESENT( lzero ) )THEN
235         CALL ctl_stop('STOP','lbc_lnk_2d: IMPLEMENT lzero option!')
236      ENDIF
237
[473]238      IF (PRESENT(cd_mpp)) THEN
239         ! only fill the overlap area and extra allows
240         ! this is in mpp case. In this module, just do nothing
241      ELSE     
[2335]242         !
[1344]243         !                                     ! East-West boundaries
244         !                                     ! ====================
245         SELECT CASE ( nperio )
246         !
247         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
248            pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points
249            pt2d(jpi,:) = pt2d(  2  ,:)
250            !
251         CASE DEFAULT                             !** East closed  --  West closed
252            SELECT CASE ( cd_type )
253            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
254               pt2d( 1 ,:) = zland
255               pt2d(jpi,:) = zland
256            CASE ( 'F' )                              ! F-point
257               pt2d(jpi,:) = zland
258            END SELECT
259            !
[3]260         END SELECT
[2335]261         !
[1344]262         !                                     ! North-South boundaries
263         !                                     ! ======================
264         SELECT CASE ( nperio )
265         !
266         CASE ( 2 )                               !**  South symmetric  --  North closed
267            SELECT CASE ( cd_type )
268            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
269               pt2d(:, 1 ) = pt2d(:,3)
270               pt2d(:,jpj) = zland
271            CASE ( 'V' , 'F' )                         ! V-, F-points
272               pt2d(:, 1 ) = psgn * pt2d(:,2)
273               pt2d(:,jpj) = zland
274            END SELECT
275            !
276         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
277            SELECT CASE ( cd_type )                    ! South : closed
278            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
279               pt2d(:, 1 ) = zland
280            END SELECT
281            !                                          ! North fold
282            pt2d( 1 ,1  ) = zland 
283            pt2d( 1 ,jpj) = zland 
284            pt2d(jpi,jpj) = zland
285            CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
286            !
287         CASE DEFAULT                             !**  North closed  --  South closed
288            SELECT CASE ( cd_type )
289            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
290               pt2d(:, 1 ) = zland
291               pt2d(:,jpj) = zland
292            CASE ( 'F' )                               ! F-point
293               pt2d(:,jpj) = zland
294            END SELECT
295            !
[3]296         END SELECT
[2335]297         !
[473]298      ENDIF
[2335]299      !   
[3]300   END SUBROUTINE lbc_lnk_2d
301
302#endif
303
304   !!======================================================================
305END MODULE lbclnk
Note: See TracBrowser for help on using the repository browser.