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

source: branches/UKMO/dev_r10171_test_crs_AMM7/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 10207

Last change on this file since 10207 was 10207, checked in by cmao, 6 years ago

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