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

source: branches/UKMO/dev_r5518_GO6_package_asm_surf_bgc/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 8485

Last change on this file since 8485 was 7993, checked in by frrh, 7 years ago

Merge in missing revisions 6428:2477 inclusive and 6482 from nemo_v3_6_STABLE
branch. In ptic, this includes the fix for restartability of runoff fields in coupled
models. Evolution of coupled models will therefor be affected.

These changes donot affect evolution of the current stand-alone NEMO-CICE GO6
standard configuration.

Work and testing documented in Met Office GMED ticket 320.
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( pt2dA, cd_typeA, psgnA ) 
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( pt2dA, cd_typeA, psgnA ) 
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.