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 trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 8114

Last change on this file since 8114 was 8114, checked in by lovato, 7 years ago

trunk: bugfix for lbclnk.F90 (#1879)

  • Property svn:keywords set to Id
File size: 34.0 KB
RevLine 
[3]1MODULE lbclnk
2   !!======================================================================
[232]3   !!                       ***  MODULE  lbclnk  ***
[3]4   !! Ocean        : lateral boundary conditions
5   !!=====================================================================
[6140]6   !! History :  OPA  ! 1997-06  (G. Madec)  Original code
7   !!   NEMO     1.0  ! 2002-09  (G. Madec)  F90: Free form and module
[2335]8   !!            3.2  ! 2009-03  (R. Benshila)  External north fold treatment 
[6140]9   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk
10   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case 
[6490]11   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi 
[1344]12   !!----------------------------------------------------------------------
[3764]13#if defined key_mpp_mpi
[3]14   !!----------------------------------------------------------------------
[2335]15   !!   'key_mpp_mpi'             MPI massively parallel processing library
[3]16   !!----------------------------------------------------------------------
[2335]17   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
[6140]18   !!   lbc_sum      : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp
[2335]19   !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp
[3680]20   !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp
[15]21   !!----------------------------------------------------------------------
[6140]22   USE lib_mpp        ! distributed memory computing library
[3]23
[5429]24   INTERFACE lbc_lnk_multi
[6490]25      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple
[5429]26   END INTERFACE
[6140]27   !
[3]28   INTERFACE lbc_lnk
[473]29      MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
[3]30   END INTERFACE
[6140]31   !
32   INTERFACE lbc_sum
33      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d
34   END INTERFACE
[6493]35   !
[3680]36   INTERFACE lbc_bdy_lnk
37      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
38   END INTERFACE
[6140]39   !
[311]40   INTERFACE lbc_lnk_e
41      MODULE PROCEDURE mpp_lnk_2d_e
42   END INTERFACE
[6140]43   !
[4990]44   INTERFACE lbc_lnk_icb
45      MODULE PROCEDURE mpp_lnk_2d_icb
46   END INTERFACE
47
[6140]48   PUBLIC   lbc_lnk       ! ocean lateral boundary conditions
49   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions
50   PUBLIC   lbc_sum
51   PUBLIC   lbc_lnk_e     !
52   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
53   PUBLIC   lbc_lnk_icb   !
[2335]54
[3]55   !!----------------------------------------------------------------------
[2335]56   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
57   !! $Id$
58   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
59   !!----------------------------------------------------------------------
[3]60#else
61   !!----------------------------------------------------------------------
62   !!   Default option                              shared memory computing
63   !!----------------------------------------------------------------------
[6140]64   !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d
65   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh
66   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh
67   !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d
68   !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh
69   !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh
70   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition
[3]71   !!----------------------------------------------------------------------
72   USE oce             ! ocean dynamics and tracers   
73   USE dom_oce         ! ocean space and time domain
74   USE in_out_manager  ! I/O manager
[1344]75   USE lbcnfd          ! north fold
[3]76
77   IMPLICIT NONE
78   PRIVATE
79
80   INTERFACE lbc_lnk
[473]81      MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
[3]82   END INTERFACE
[6140]83   !
84   INTERFACE lbc_sum
[6493]85      MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d
[6140]86   END INTERFACE
[3]87
[311]88   INTERFACE lbc_lnk_e
[3609]89      MODULE PROCEDURE lbc_lnk_2d_e
[311]90   END INTERFACE
[6140]91   !
[6490]92   INTERFACE lbc_lnk_multi
93      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple
94   END INTERFACE
95
[3680]96   INTERFACE lbc_bdy_lnk
97      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d
98   END INTERFACE
[6140]99   !
[4990]100   INTERFACE lbc_lnk_icb
101      MODULE PROCEDURE lbc_lnk_2d_e
102   END INTERFACE
[6490]103   
104   TYPE arrayptr
105      REAL , DIMENSION (:,:),  POINTER :: pt2d
106   END TYPE arrayptr
107   PUBLIC   arrayptr
[4990]108
[2335]109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions
[6493]110   PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region)
[6140]111   PUBLIC   lbc_lnk_e     !
[6490]112   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions
[3680]113   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
[6140]114   PUBLIC   lbc_lnk_icb   !
[2335]115   
[3]116   !!----------------------------------------------------------------------
[6140]117   !! NEMO/OPA 3.7 , NEMO Consortium (2015)
[2335]118   !! $Id$
119   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
120   !!----------------------------------------------------------------------
[3]121CONTAINS
122
[3764]123# if defined key_c1d
124   !!----------------------------------------------------------------------
125   !!   'key_c1d'                                          1D configuration
126   !!----------------------------------------------------------------------
127
[473]128   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
[3]129      !!---------------------------------------------------------------------
[473]130      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
131      !!
[3764]132      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (C1D case)
133      !!
134      !! ** Method  :   call lbc_lnk_3d on pt3d1 and pt3d2
135      !!----------------------------------------------------------------------
136      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points
137      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied
138      REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign
139      !!----------------------------------------------------------------------
140      !
141      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
142      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
143      !
144   END SUBROUTINE lbc_lnk_3d_gather
145
146
147   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
148      !!---------------------------------------------------------------------
149      !!                  ***  ROUTINE lbc_lnk_3d  ***
150      !!
151      !! ** Purpose :   set lateral boundary conditions on a 3D array (C1D case)
152      !!
153      !! ** Method  :   1D case, the central water column is set everywhere
154      !!----------------------------------------------------------------------
155      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
156      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
157      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
158      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
159      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
160      !
161      INTEGER  ::   jk     ! dummy loop index
162      REAL(wp) ::   ztab   ! local scalar
163      !!----------------------------------------------------------------------
164      !
165      DO jk = 1, jpk
166         ztab = pt3d(2,2,jk)
167         pt3d(:,:,jk) = ztab
168      END DO
169      !
170   END SUBROUTINE lbc_lnk_3d
171
172
173   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
174      !!---------------------------------------------------------------------
175      !!                 ***  ROUTINE lbc_lnk_2d  ***
176      !!
177      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
178      !!
179      !! ** Method  :   1D case, the central water column is set everywhere
180      !!----------------------------------------------------------------------
181      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
182      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
183      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
184      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
185      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
186      !
187      REAL(wp) ::   ztab   ! local scalar
188      !!----------------------------------------------------------------------
189      !
190      ztab = pt2d(2,2)
191      pt2d(:,:) = ztab
192      !
193   END SUBROUTINE lbc_lnk_2d
[6490]194   
195   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )
196      !!
197      INTEGER :: num_fields
198      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
199      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
200      !                                                               ! = T , U , V , F , W and I points
201      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
202      !                                                               ! =  1. , the sign is kept
203      !
204      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
205      !
206      DO ii = 1, num_fields
207        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )
208      END DO     
209      !
210   END SUBROUTINE lbc_lnk_2d_multiple
[3764]211
[6490]212   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
213      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
214      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
215      !!---------------------------------------------------------------------
216      ! Second 2D array on which the boundary condition is applied
217      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA
218      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
219      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI
220      ! define the nature of ptab array grid-points
221      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
222      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
223      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
224      ! =-1 the sign change across the north fold boundary
225      REAL(wp)                                      , INTENT(in   ) ::   psgnA
226      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
227      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI
228      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
229      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
230      !!
231      !!---------------------------------------------------------------------
232
233      !!The first array
234      CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
235
236      !! Look if more arrays to process
[8114]237      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB )
[6490]238      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 
239      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 
240      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 
241      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 
242      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 
243      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 
244      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 
245
246   END SUBROUTINE lbc_lnk_2d_9
247
248
249
250
251
[3764]252#else
253   !!----------------------------------------------------------------------
254   !!   Default option                           3D shared memory computing
255   !!----------------------------------------------------------------------
256
257   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
258      !!---------------------------------------------------------------------
259      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
260      !!
[2335]261      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case)
[473]262      !!
[2335]263      !! ** Method  :   psign = -1 :    change the sign across the north fold
264      !!                      =  1 : no change of the sign across the north fold
265      !!                      =  0 : no change of the sign across the north fold and
266      !!                             strict positivity preserved: use inner row/column
267      !!                             for closed boundaries.
[473]268      !!----------------------------------------------------------------------
[2335]269      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points
270      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied
271      REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign
272      !!----------------------------------------------------------------------
273      !
[1344]274      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
275      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
[2335]276      !
[473]277   END SUBROUTINE lbc_lnk_3d_gather
278
279
[888]280   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
[473]281      !!---------------------------------------------------------------------
[3]282      !!                  ***  ROUTINE lbc_lnk_3d  ***
283      !!
[2335]284      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
[3]285      !!
[2335]286      !! ** Method  :   psign = -1 :    change the sign across the north fold
287      !!                      =  1 : no change of the sign across the north fold
288      !!                      =  0 : no change of the sign across the north fold and
289      !!                             strict positivity preserved: use inner row/column
290      !!                             for closed boundaries.
291      !!----------------------------------------------------------------------
292      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
293      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
294      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
295      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
296      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
[3]297      !!
[2335]298      REAL(wp) ::   zland
[3]299      !!----------------------------------------------------------------------
300
[2335]301      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
[3764]302      ELSE                         ;   zland = 0._wp
[888]303      ENDIF
304
305
306      IF( PRESENT( cd_mpp ) ) THEN
[473]307         ! only fill the overlap area and extra allows
308         ! this is in mpp case. In this module, just do nothing
309      ELSE
[1344]310         !                                     !  East-West boundaries
311         !                                     ! ======================
[3]312         SELECT CASE ( nperio )
[1344]313         !
314         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
315            pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points
316            pt3d(jpi,:,:) = pt3d(  2  ,:,:)
317            !
318         CASE DEFAULT                             !**  East closed  --  West closed
[3]319            SELECT CASE ( cd_type )
320            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
[1344]321               pt3d( 1 ,:,:) = zland
322               pt3d(jpi,:,:) = zland
[3]323            CASE ( 'F' )                               ! F-point
[1344]324               pt3d(jpi,:,:) = zland
[3]325            END SELECT
[1344]326            !
[3]327         END SELECT
328         !                                     ! North-South boundaries
329         !                                     ! ======================
330         SELECT CASE ( nperio )
[1344]331         !
332         CASE ( 2 )                               !**  South symmetric  --  North closed
[3]333            SELECT CASE ( cd_type )
334            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
[1344]335               pt3d(:, 1 ,:) = pt3d(:,3,:)
336               pt3d(:,jpj,:) = zland
[3]337            CASE ( 'V' , 'F' )                         ! V-, F-points
[1344]338               pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
339               pt3d(:,jpj,:) = zland
[3]340            END SELECT
[1344]341            !
342         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
343            SELECT CASE ( cd_type )                    ! South : closed
344            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
345               pt3d(:, 1 ,:) = zland
[3]346            END SELECT
[1344]347            !                                          ! North fold
348            CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
349            !
350         CASE DEFAULT                             !**  North closed  --  South closed
[3]351            SELECT CASE ( cd_type )
[1344]352            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
353               pt3d(:, 1 ,:) = zland
354               pt3d(:,jpj,:) = zland
[3]355            CASE ( 'F' )                               ! F-point
[1344]356               pt3d(:,jpj,:) = zland
[3]357            END SELECT
[1344]358            !
359         END SELECT
[2335]360         !
[1344]361      ENDIF
[2335]362      !
[3]363   END SUBROUTINE lbc_lnk_3d
364
[6140]365
[888]366   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[3]367      !!---------------------------------------------------------------------
368      !!                 ***  ROUTINE lbc_lnk_2d  ***
369      !!
[2335]370      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
[3]371      !!
[2335]372      !! ** Method  :   psign = -1 :    change the sign across the north fold
373      !!                      =  1 : no change of the sign across the north fold
374      !!                      =  0 : no change of the sign across the north fold and
375      !!                             strict positivity preserved: use inner row/column
376      !!                             for closed boundaries.
377      !!----------------------------------------------------------------------
378      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
[2339]379      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
[2335]380      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
381      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
382      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
[3]383      !!
[2335]384      REAL(wp) ::   zland
[3]385      !!----------------------------------------------------------------------
386
[2335]387      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
[3764]388      ELSE                         ;   zland = 0._wp
[888]389      ENDIF
390
[473]391      IF (PRESENT(cd_mpp)) THEN
392         ! only fill the overlap area and extra allows
393         ! this is in mpp case. In this module, just do nothing
394      ELSE     
[1344]395         !                                     ! East-West boundaries
396         !                                     ! ====================
397         SELECT CASE ( nperio )
398         !
399         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
400            pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points
401            pt2d(jpi,:) = pt2d(  2  ,:)
402            !
403         CASE DEFAULT                             !** East closed  --  West closed
404            SELECT CASE ( cd_type )
405            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
406               pt2d( 1 ,:) = zland
407               pt2d(jpi,:) = zland
408            CASE ( 'F' )                              ! F-point
409               pt2d(jpi,:) = zland
410            END SELECT
411            !
[3]412         END SELECT
[1344]413         !                                     ! North-South boundaries
414         !                                     ! ======================
415         SELECT CASE ( nperio )
416         !
417         CASE ( 2 )                               !**  South symmetric  --  North closed
418            SELECT CASE ( cd_type )
419            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
420               pt2d(:, 1 ) = pt2d(:,3)
421               pt2d(:,jpj) = zland
422            CASE ( 'V' , 'F' )                         ! V-, F-points
423               pt2d(:, 1 ) = psgn * pt2d(:,2)
424               pt2d(:,jpj) = zland
425            END SELECT
426            !
427         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
428            SELECT CASE ( cd_type )                    ! South : closed
429            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
430               pt2d(:, 1 ) = zland
431            END SELECT
432            !                                          ! North fold
433            CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
434            !
435         CASE DEFAULT                             !**  North closed  --  South closed
436            SELECT CASE ( cd_type )
437            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
438               pt2d(:, 1 ) = zland
439               pt2d(:,jpj) = zland
440            CASE ( 'F' )                               ! F-point
441               pt2d(:,jpj) = zland
442            END SELECT
443            !
[3]444         END SELECT
[2335]445         !
[473]446      ENDIF
[2335]447      !   
[3]448   END SUBROUTINE lbc_lnk_2d
[6490]449   
450   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )
451      !!
452      INTEGER :: num_fields
453      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
454      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
455      !                                                               ! = T , U , V , F , W and I points
456      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
457      !                                                               ! =  1. , the sign is kept
458      !
459      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
460      !
461      DO ii = 1, num_fields
462        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )
463      END DO     
464      !
465   END SUBROUTINE lbc_lnk_2d_multiple
[3]466
[6490]467   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
468      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
469      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
470      !!---------------------------------------------------------------------
471      ! Second 2D array on which the boundary condition is applied
472      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA
473      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
474      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI
475      ! define the nature of ptab array grid-points
476      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
477      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
478      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
479      ! =-1 the sign change across the north fold boundary
480      REAL(wp)                                      , INTENT(in   ) ::   psgnA
481      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
482      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI
483      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
484      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
485      !!
486      !!---------------------------------------------------------------------
487
488      !!The first array
489      CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
490
491      !! Look if more arrays to process
[8114]492      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB )
[6490]493      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 
494      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 
495      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 
496      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 
497      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 
498      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 
499      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 
500
501   END SUBROUTINE lbc_lnk_2d_9
502
[6493]503   SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )
504      !!---------------------------------------------------------------------
505      !!                 ***  ROUTINE lbc_lnk_sum_2d  ***
506      !!
507      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
508      !!
509      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean
510      !!                coupling if conservation option activated. As no ice shelf are present along
511      !!                this line, nothing is done along the north fold.
512      !!----------------------------------------------------------------------
513      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
514      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
515      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
516      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
517      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
518      !!
519      REAL(wp) ::   zland
520      !!----------------------------------------------------------------------
[6490]521
[6493]522      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
523      ELSE                         ;   zland = 0._wp
524      ENDIF
525
526      IF (PRESENT(cd_mpp)) THEN
527         ! only fill the overlap area and extra allows
528         ! this is in mpp case. In this module, just do nothing
529      ELSE
530         !                                     ! East-West boundaries
531         !                                     ! ====================
532         SELECT CASE ( nperio )
533         !
534         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
535            pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:)
536            pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:)
537            pt2d( 1 ,:) = 0.0_wp               ! all points
538            pt2d(jpi,:) = 0.0_wp
539            !
540         CASE DEFAULT                             !** East closed  --  West closed
541            SELECT CASE ( cd_type )
542            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
543               pt2d( 1 ,:) = zland
544               pt2d(jpi,:) = zland
545            CASE ( 'F' )                              ! F-point
546               pt2d(jpi,:) = zland
547            END SELECT
548            !
549         END SELECT
550         !                                     ! North-South boundaries
551         !                                     ! ======================
552         ! Nothing to do for the north fold, there is no ice shelf along this line.
553         !
554      END IF
555
556   END SUBROUTINE
557
558   SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval )
559      !!---------------------------------------------------------------------
560      !!                 ***  ROUTINE lbc_lnk_sum_3d  ***
561      !!
562      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
563      !!
564      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean
565      !!                coupling if conservation option activated. As no ice shelf are present along
566      !!                this line, nothing is done along the north fold.
567      !!----------------------------------------------------------------------
568      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
569      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
570      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
571      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
572      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
573      !!
574      REAL(wp) ::   zland
575      !!----------------------------------------------------------------------
576
577      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
578      ELSE                         ;   zland = 0._wp
579      ENDIF
580
581
582      IF( PRESENT( cd_mpp ) ) THEN
583         ! only fill the overlap area and extra allows
584         ! this is in mpp case. In this module, just do nothing
585      ELSE
586         !                                     !  East-West boundaries
587         !                                     ! ======================
588         SELECT CASE ( nperio )
589         !
590         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
591            pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:)
592            pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:) 
593            pt3d( 1 ,:,:) = 0.0_wp            ! all points
594            pt3d(jpi,:,:) = 0.0_wp
595            !
596         CASE DEFAULT                             !**  East closed  --  West closed
597            SELECT CASE ( cd_type )
598            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
599               pt3d( 1 ,:,:) = zland
600               pt3d(jpi,:,:) = zland
601            CASE ( 'F' )                               ! F-point
602               pt3d(jpi,:,:) = zland
603            END SELECT
604            !
605         END SELECT
606         !                                     ! North-South boundaries
607         !                                     ! ======================
608         ! Nothing to do for the north fold, there is no ice shelf along this line.
609         !
610      END IF
611   END SUBROUTINE
612
613
[4153]614#endif
615
616   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
617      !!---------------------------------------------------------------------
618      !!                  ***  ROUTINE lbc_bdy_lnk  ***
619      !!
620      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
[6140]621      !!              to maintain the same interface with regards to the mpp case
[4153]622      !!
623      !!----------------------------------------------------------------------
[6140]624      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
625      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied
626      REAL(wp)                        , INTENT(in   ) ::   psgn      ! control of the sign
627      INTEGER                         , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
628      !!----------------------------------------------------------------------
629      !
[4153]630      CALL lbc_lnk_3d( pt3d, cd_type, psgn)
[6140]631      !
[4153]632   END SUBROUTINE lbc_bdy_lnk_3d
633
[6140]634
[4153]635   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
636      !!---------------------------------------------------------------------
637      !!                  ***  ROUTINE lbc_bdy_lnk  ***
638      !!
639      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
[6140]640      !!              to maintain the same interface with regards to the mpp case
[4153]641      !!
642      !!----------------------------------------------------------------------
[6140]643      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
644      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied
645      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
646      INTEGER                     , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
647      !!----------------------------------------------------------------------
648      !
[4153]649      CALL lbc_lnk_2d( pt2d, cd_type, psgn)
[6140]650      !
[4153]651   END SUBROUTINE lbc_bdy_lnk_2d
652
653
[3609]654   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
655      !!---------------------------------------------------------------------
656      !!                 ***  ROUTINE lbc_lnk_2d  ***
657      !!
658      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
659      !!                special dummy routine to allow for use of halo indexing in mpp case
660      !!
661      !! ** Method  :   psign = -1 :    change the sign across the north fold
662      !!                      =  1 : no change of the sign across the north fold
663      !!                      =  0 : no change of the sign across the north fold and
664      !!                             strict positivity preserved: use inner row/column
665      !!                             for closed boundaries.
666      !!----------------------------------------------------------------------
[6140]667      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
668      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied
669      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
670      INTEGER                     , INTENT(in   ) ::   jpri      ! size of extra halo (not needed in non-mpp)
671      INTEGER                     , INTENT(in   ) ::   jprj      ! size of extra halo (not needed in non-mpp)
[3609]672      !!----------------------------------------------------------------------
[6140]673      !
[3609]674      CALL lbc_lnk_2d( pt2d, cd_type, psgn )
675      !   
676   END SUBROUTINE lbc_lnk_2d_e
677
[3]678#endif
679
680   !!======================================================================
681END MODULE lbclnk
[6490]682
Note: See TracBrowser for help on using the repository browser.