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 @ 6478

Last change on this file since 6478 was 6478, checked in by mcastril, 8 years ago

Merging of branch dev_r5546_CNRS19_HPC_scalability #1539
  • Property svn:keywords set to Id
File size: 28.5 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) 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 
11   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi 
12   !!----------------------------------------------------------------------
13#if defined key_mpp_mpi
14   !!----------------------------------------------------------------------
15   !!   'key_mpp_mpi'             MPI massively parallel processing library
16   !!----------------------------------------------------------------------
17   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
18   !!   lbc_sum      : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d routines defined in lib_mpp
19   !!   lbc_lnk_e    : generic interface for mpp_lnk_2d_e routine defined in lib_mpp
20   !!   lbc_bdy_lnk  : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp
21   !!----------------------------------------------------------------------
22   USE lib_mpp        ! distributed memory computing library
23
24   INTERFACE lbc_lnk_multi
25      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple
26   END INTERFACE
27   !
28   INTERFACE lbc_lnk
29      MODULE PROCEDURE mpp_lnk_3d_gather, mpp_lnk_3d, mpp_lnk_2d
30   END INTERFACE
31   !
32!JMM interface not defined if not key_mpp_mpi : likely do not compile without this CPP key !!!!
33   INTERFACE lbc_sum
34      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d
35   END INTERFACE
36
37   INTERFACE lbc_bdy_lnk
38      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
39   END INTERFACE
40   !
41   INTERFACE lbc_lnk_e
42      MODULE PROCEDURE mpp_lnk_2d_e
43   END INTERFACE
44   !
45   INTERFACE lbc_lnk_icb
46      MODULE PROCEDURE mpp_lnk_2d_icb
47   END INTERFACE
48
49   PUBLIC   lbc_lnk       ! ocean lateral boundary conditions
50   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions
51   PUBLIC   lbc_sum
52   PUBLIC   lbc_lnk_e     !
53   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
54   PUBLIC   lbc_lnk_icb   !
55
56   !!----------------------------------------------------------------------
57   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
58   !! $Id$
59   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
60   !!----------------------------------------------------------------------
61#else
62   !!----------------------------------------------------------------------
63   !!   Default option                              shared memory computing
64   !!----------------------------------------------------------------------
65   !!   lbc_sum       : generic interface for mpp_lnk_sum_3d and mpp_lnk_sum_2d
66   !!   lbc_lnk_sum_3d: compute sum over the halos on a 3D variable on ocean mesh
67   !!   lbc_lnk_sum_3d: compute sum over the halos on a 2D variable on ocean mesh
68   !!   lbc_lnk       : generic interface for lbc_lnk_3d and lbc_lnk_2d
69   !!   lbc_lnk_3d    : set the lateral boundary condition on a 3D variable on ocean mesh
70   !!   lbc_lnk_2d    : set the lateral boundary condition on a 2D variable on ocean mesh
71   !!   lbc_bdy_lnk   : set the lateral BDY boundary condition
72   !!----------------------------------------------------------------------
73   USE oce             ! ocean dynamics and tracers   
74   USE dom_oce         ! ocean space and time domain
75   USE in_out_manager  ! I/O manager
76   USE lbcnfd          ! north fold
77
78   IMPLICIT NONE
79   PRIVATE
80
81   INTERFACE lbc_lnk
82      MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
83   END INTERFACE
84   !
85   INTERFACE lbc_sum
86      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d
87   END INTERFACE
88
89   INTERFACE lbc_lnk_e
90      MODULE PROCEDURE lbc_lnk_2d_e
91   END INTERFACE
92   !
93   INTERFACE lbc_lnk_multi
94      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple
95   END INTERFACE
96
97   INTERFACE lbc_bdy_lnk
98      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d
99   END INTERFACE
100   !
101   INTERFACE lbc_lnk_icb
102      MODULE PROCEDURE lbc_lnk_2d_e
103   END INTERFACE
104   
105   TYPE arrayptr
106      REAL , DIMENSION (:,:),  POINTER :: pt2d
107   END TYPE arrayptr
108   PUBLIC   arrayptr
109
110   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions
111   PUBLIC   lbc_lnk_e     !
112   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions
113   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
114   PUBLIC   lbc_lnk_icb   !
115   
116   !!----------------------------------------------------------------------
117   !! NEMO/OPA 3.7 , NEMO Consortium (2015)
118   !! $Id$
119   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
120   !!----------------------------------------------------------------------
121CONTAINS
122
123# if defined key_c1d
124   !!----------------------------------------------------------------------
125   !!   'key_c1d'                                          1D configuration
126   !!----------------------------------------------------------------------
127
128   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
129      !!---------------------------------------------------------------------
130      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
131      !!
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
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
211
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
237      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
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
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      !!
261      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case)
262      !!
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.
268      !!----------------------------------------------------------------------
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      !
274      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
275      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
276      !
277   END SUBROUTINE lbc_lnk_3d_gather
278
279
280   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
281      !!---------------------------------------------------------------------
282      !!                  ***  ROUTINE lbc_lnk_3d  ***
283      !!
284      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
285      !!
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)
297      !!
298      REAL(wp) ::   zland
299      !!----------------------------------------------------------------------
300
301      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
302      ELSE                         ;   zland = 0._wp
303      ENDIF
304
305
306      IF( PRESENT( cd_mpp ) ) THEN
307         ! only fill the overlap area and extra allows
308         ! this is in mpp case. In this module, just do nothing
309      ELSE
310         !                                     !  East-West boundaries
311         !                                     ! ======================
312         SELECT CASE ( nperio )
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
319            SELECT CASE ( cd_type )
320            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
321               pt3d( 1 ,:,:) = zland
322               pt3d(jpi,:,:) = zland
323            CASE ( 'F' )                               ! F-point
324               pt3d(jpi,:,:) = zland
325            END SELECT
326            !
327         END SELECT
328         !                                     ! North-South boundaries
329         !                                     ! ======================
330         SELECT CASE ( nperio )
331         !
332         CASE ( 2 )                               !**  South symmetric  --  North closed
333            SELECT CASE ( cd_type )
334            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
335               pt3d(:, 1 ,:) = pt3d(:,3,:)
336               pt3d(:,jpj,:) = zland
337            CASE ( 'V' , 'F' )                         ! V-, F-points
338               pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
339               pt3d(:,jpj,:) = zland
340            END SELECT
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
346            END SELECT
347            !                                          ! North fold
348            CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
349            !
350         CASE DEFAULT                             !**  North closed  --  South closed
351            SELECT CASE ( cd_type )
352            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
353               pt3d(:, 1 ,:) = zland
354               pt3d(:,jpj,:) = zland
355            CASE ( 'F' )                               ! F-point
356               pt3d(:,jpj,:) = zland
357            END SELECT
358            !
359         END SELECT
360         !
361      ENDIF
362      !
363   END SUBROUTINE lbc_lnk_3d
364
365
366   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
367      !!---------------------------------------------------------------------
368      !!                 ***  ROUTINE lbc_lnk_2d  ***
369      !!
370      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
371      !!
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
379      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
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)
383      !!
384      REAL(wp) ::   zland
385      !!----------------------------------------------------------------------
386
387      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
388      ELSE                         ;   zland = 0._wp
389      ENDIF
390
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     
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            !
412         END SELECT
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            !
444         END SELECT
445         !
446      ENDIF
447      !   
448   END SUBROUTINE lbc_lnk_2d
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
466
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
492      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
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
503
504#endif
505
506   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
507      !!---------------------------------------------------------------------
508      !!                  ***  ROUTINE lbc_bdy_lnk  ***
509      !!
510      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
511      !!              to maintain the same interface with regards to the mpp case
512      !!
513      !!----------------------------------------------------------------------
514      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
515      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied
516      REAL(wp)                        , INTENT(in   ) ::   psgn      ! control of the sign
517      INTEGER                         , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
518      !!----------------------------------------------------------------------
519      !
520      CALL lbc_lnk_3d( pt3d, cd_type, psgn)
521      !
522   END SUBROUTINE lbc_bdy_lnk_3d
523
524
525   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
526      !!---------------------------------------------------------------------
527      !!                  ***  ROUTINE lbc_bdy_lnk  ***
528      !!
529      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
530      !!              to maintain the same interface with regards to the mpp case
531      !!
532      !!----------------------------------------------------------------------
533      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
534      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied
535      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
536      INTEGER                     , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
537      !!----------------------------------------------------------------------
538      !
539      CALL lbc_lnk_2d( pt2d, cd_type, psgn)
540      !
541   END SUBROUTINE lbc_bdy_lnk_2d
542
543
544   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
545      !!---------------------------------------------------------------------
546      !!                 ***  ROUTINE lbc_lnk_2d  ***
547      !!
548      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
549      !!                special dummy routine to allow for use of halo indexing in mpp case
550      !!
551      !! ** Method  :   psign = -1 :    change the sign across the north fold
552      !!                      =  1 : no change of the sign across the north fold
553      !!                      =  0 : no change of the sign across the north fold and
554      !!                             strict positivity preserved: use inner row/column
555      !!                             for closed boundaries.
556      !!----------------------------------------------------------------------
557      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
558      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied
559      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
560      INTEGER                     , INTENT(in   ) ::   jpri      ! size of extra halo (not needed in non-mpp)
561      INTEGER                     , INTENT(in   ) ::   jprj      ! size of extra halo (not needed in non-mpp)
562      !!----------------------------------------------------------------------
563      !
564      CALL lbc_lnk_2d( pt2d, cd_type, psgn )
565      !   
566   END SUBROUTINE lbc_lnk_2d_e
567
568#endif
569
570   !!======================================================================
571END MODULE lbclnk
572
Note: See TracBrowser for help on using the repository browser.