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 on Ticket #1568 – Attachment – NEMO

Ticket #1568: lbclnk.F90

File lbclnk.F90, 31.4 KB (added by dupontf, 8 years ago)
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   !!----------------------------------------------------------------------
14#if defined key_mpp_mpi
15   !!----------------------------------------------------------------------
16   !!   'key_mpp_mpi'             MPI massively parallel processing library
17   !!----------------------------------------------------------------------
18   !!   lbc_lnk      : generic interface for mpp_lnk_3d and mpp_lnk_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   !!   lbc_lnk_multi: generic interface for mpp_lnk_2d_9 routine 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
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: lbclnk.F90 5429 2015-06-16 09:57:07Z smasson $
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   !!   lbc_lnk_multi: generic interface for lbc_lnk_2d_9 routine
67   !!----------------------------------------------------------------------
68   USE oce             ! ocean dynamics and tracers   
69   USE dom_oce         ! ocean space and time domain
70   USE in_out_manager  ! I/O manager
71   USE lbcnfd          ! north fold
72
73   IMPLICIT NONE
74   PRIVATE
75
76   INTERFACE lbc_lnk_multi
77      MODULE PROCEDURE lbc_lnk_2d_9
78   END INTERFACE
79
80   INTERFACE lbc_lnk
81      MODULE PROCEDURE lbc_lnk_3d_gather, lbc_lnk_3d, lbc_lnk_2d
82   END INTERFACE
83
84   INTERFACE lbc_lnk_e
85      MODULE PROCEDURE lbc_lnk_2d_e
86   END INTERFACE
87
88   INTERFACE lbc_bdy_lnk
89      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d
90   END INTERFACE
91
92   INTERFACE lbc_lnk_icb
93      MODULE PROCEDURE lbc_lnk_2d_e
94   END INTERFACE
95
96   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions
97   PUBLIC   lbc_lnk_e 
98   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions
99   PUBLIC   lbc_lnk_icb
100   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions
101   
102   TYPE arrayptr
103      REAL , DIMENSION (:,:),  POINTER :: pt2d
104   END TYPE arrayptr
105   
106   !!----------------------------------------------------------------------
107   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
108   !! $Id: lbclnk.F90 5429 2015-06-16 09:57:07Z smasson $
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#else
186   !!----------------------------------------------------------------------
187   !!   Default option                           3D shared memory computing
188   !!----------------------------------------------------------------------
189
190   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
191      !!---------------------------------------------------------------------
192      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
193      !!
194      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case)
195      !!
196      !! ** Method  :   psign = -1 :    change the sign across the north fold
197      !!                      =  1 : no change of the sign across the north fold
198      !!                      =  0 : no change of the sign across the north fold and
199      !!                             strict positivity preserved: use inner row/column
200      !!                             for closed boundaries.
201      !!----------------------------------------------------------------------
202      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points
203      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied
204      REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign
205      !!----------------------------------------------------------------------
206      !
207      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
208      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
209      !
210   END SUBROUTINE lbc_lnk_3d_gather
211
212
213   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
214      !!---------------------------------------------------------------------
215      !!                  ***  ROUTINE lbc_lnk_3d  ***
216      !!
217      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
218      !!
219      !! ** Method  :   psign = -1 :    change the sign across the north fold
220      !!                      =  1 : no change of the sign across the north fold
221      !!                      =  0 : no change of the sign across the north fold and
222      !!                             strict positivity preserved: use inner row/column
223      !!                             for closed boundaries.
224      !!----------------------------------------------------------------------
225      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
226      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
227      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
228      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
229      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
230      !!
231      REAL(wp) ::   zland
232      !!----------------------------------------------------------------------
233
234      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
235      ELSE                         ;   zland = 0._wp
236      ENDIF
237
238
239      IF( PRESENT( cd_mpp ) ) THEN
240         ! only fill the overlap area and extra allows
241         ! this is in mpp case. In this module, just do nothing
242      ELSE
243         !
244         !                                     !  East-West boundaries
245         !                                     ! ======================
246         SELECT CASE ( nperio )
247         !
248         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
249            pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points
250            pt3d(jpi,:,:) = pt3d(  2  ,:,:)
251            !
252         CASE DEFAULT                             !**  East closed  --  West closed
253            SELECT CASE ( cd_type )
254            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
255               pt3d( 1 ,:,:) = zland
256               pt3d(jpi,:,:) = zland
257            CASE ( 'F' )                               ! F-point
258               pt3d(jpi,:,:) = zland
259            END SELECT
260            !
261         END SELECT
262         !
263         !                                     ! North-South boundaries
264         !                                     ! ======================
265         SELECT CASE ( nperio )
266         !
267         CASE ( 2 )                               !**  South symmetric  --  North closed
268            SELECT CASE ( cd_type )
269            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
270               pt3d(:, 1 ,:) = pt3d(:,3,:)
271               pt3d(:,jpj,:) = zland
272            CASE ( 'V' , 'F' )                         ! V-, F-points
273               pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
274               pt3d(:,jpj,:) = zland
275            END SELECT
276            !
277         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
278            SELECT CASE ( cd_type )                    ! South : closed
279            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
280               pt3d(:, 1 ,:) = zland
281            END SELECT
282            !                                          ! North fold
283            CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
284            !
285         CASE DEFAULT                             !**  North closed  --  South closed
286            SELECT CASE ( cd_type )
287            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
288               pt3d(:, 1 ,:) = zland
289               pt3d(:,jpj,:) = zland
290            CASE ( 'F' )                               ! F-point
291               pt3d(:,jpj,:) = zland
292            END SELECT
293            !
294         END SELECT
295         !
296      ENDIF
297      !
298   END SUBROUTINE lbc_lnk_3d
299
300   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
301      !!---------------------------------------------------------------------
302      !!                 ***  ROUTINE lbc_lnk_2d  ***
303      !!
304      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
305      !!
306      !! ** Method  :   psign = -1 :    change the sign across the north fold
307      !!                      =  1 : no change of the sign across the north fold
308      !!                      =  0 : no change of the sign across the north fold and
309      !!                             strict positivity preserved: use inner row/column
310      !!                             for closed boundaries.
311      !!----------------------------------------------------------------------
312      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
313      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
314      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
315      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
316      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
317      !!
318      REAL(wp) ::   zland
319      !!----------------------------------------------------------------------
320
321      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
322      ELSE                         ;   zland = 0._wp
323      ENDIF
324
325      IF (PRESENT(cd_mpp)) THEN
326         ! only fill the overlap area and extra allows
327         ! this is in mpp case. In this module, just do nothing
328      ELSE     
329         !
330         !                                     ! East-West boundaries
331         !                                     ! ====================
332         SELECT CASE ( nperio )
333         !
334         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
335            pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points
336            pt2d(jpi,:) = pt2d(  2  ,:)
337            !
338         CASE DEFAULT                             !** East closed  --  West closed
339            SELECT CASE ( cd_type )
340            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
341               pt2d( 1 ,:) = zland
342               pt2d(jpi,:) = zland
343            CASE ( 'F' )                              ! F-point
344               pt2d(jpi,:) = zland
345            END SELECT
346            !
347         END SELECT
348         !
349         !                                     ! North-South boundaries
350         !                                     ! ======================
351         SELECT CASE ( nperio )
352         !
353         CASE ( 2 )                               !**  South symmetric  --  North closed
354            SELECT CASE ( cd_type )
355            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
356               pt2d(:, 1 ) = pt2d(:,3)
357               pt2d(:,jpj) = zland
358            CASE ( 'V' , 'F' )                         ! V-, F-points
359               pt2d(:, 1 ) = psgn * pt2d(:,2)
360               pt2d(:,jpj) = zland
361            END SELECT
362            !
363         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
364            SELECT CASE ( cd_type )                    ! South : closed
365            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
366               pt2d(:, 1 ) = zland
367            END SELECT
368            !                                          ! North fold
369            CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
370            !
371         CASE DEFAULT                             !**  North closed  --  South closed
372            SELECT CASE ( cd_type )
373            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
374               pt2d(:, 1 ) = zland
375               pt2d(:,jpj) = zland
376            CASE ( 'F' )                               ! F-point
377               pt2d(:,jpj) = zland
378            END SELECT
379            !
380         END SELECT
381         !
382      ENDIF
383      !   
384   END SUBROUTINE lbc_lnk_2d
385
386   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
387      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
388      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
389      !!---------------------------------------------------------------------
390      ! Second 2D array on which the boundary condition is applied
391      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA   
392      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
393      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
394      ! define the nature of ptab array grid-points
395      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
396      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
397      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
398      ! =-1 the sign change across the north fold boundary
399      REAL(wp)                                      , INTENT(in   ) ::   psgnA   
400      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
401      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI   
402      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
403      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
404      !!
405      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array 
406      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
407      !                                                         ! = T , U , V , F , W and I points
408      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
409      INTEGER :: num_fields
410      !!---------------------------------------------------------------------
411
412      num_fields = 0
413
414      !! Load the first array
415      CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields)
416
417      !! Look if more arrays are added
418      IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields)
419      IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields)
420      IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields)
421      IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields)
422      IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields)
423      IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields)
424      IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields)
425      IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields)
426     
427      CALL lbc_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval)
428   END SUBROUTINE lbc_lnk_2d_9
429
430   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval )
431      !!----------------------------------------------------------------------
432      !!                  ***  routine mpp_lnk_2d_multiple  ***
433      !!
434      !! ** Purpose :   Message passing management for multiple 2d arrays
435      !!
436      !! ** Method  :   Use mppsend and mpprecv function for passing mask
437      !!      between processors following neighboring subdomains.
438      !!            domain parameters
439      !!                    nlci   : first dimension of the local subdomain
440      !!                    nlcj   : second dimension of the local subdomain
441      !!                    nbondi : mark for "east-west local boundary"
442      !!                    nbondj : mark for "north-south local boundary"
443      !!                    noea   : number for local neighboring processors
444      !!                    nowe   : number for local neighboring processors
445      !!                    noso   : number for local neighboring processors
446      !!                    nono   : number for local neighboring processors
447      !!
448      !!----------------------------------------------------------------------
449
450      INTEGER :: num_fields
451      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
452      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
453      !                                                               ! = T , U , V , F , W and I points
454      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
455      !                                                               ! =  1. , the sign is kept
456      CHARACTER(len=3), OPTIONAL    , INTENT(in   ) ::   cd_mpp       ! fill the overlap area only
457      REAL(wp)        , OPTIONAL    , INTENT(in   ) ::   pval         ! background value (used at closed boundaries)
458      !!
459      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
460
461      REAL(wp) ::   zland
462
463      !!----------------------------------------------------------------------
464      !
465      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
466      ELSE                         ;   zland = 0.e0      ! zero by default
467      ENDIF
468
469      ! 1. standard boundary treatment
470      ! ------------------------------
471      !
472      !First Array
473      DO ii = 1 , num_fields
474         IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
475            ! only fill the overlap area and extra allows
476            ! this is in mpp case. In this module, just do nothing
477         ELSE                              ! standard close or cyclic treatment
478            !
479            !                                     ! East-West boundaries
480            !                                     ! ====================
481            SELECT CASE ( nperio )
482            !
483            CASE ( 1 , 4 , 6 )                       !** cyclic east-west
484               pt2d_array(ii)%pt2d( 1 ,:) = pt2d_array(ii)%pt2d(jpim1,:)               ! all points
485               pt2d_array(ii)%pt2d(jpi,:) = pt2d_array(ii)%pt2d(  2  ,:)
486               !
487            CASE DEFAULT                             !** East closed  --  West closed
488               SELECT CASE ( type_array(ii) )
489               CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
490                  pt2d_array(ii)%pt2d( 1 ,:) = zland
491                  pt2d_array(ii)%pt2d(jpi,:) = zland
492               CASE ( 'F' )                              ! F-point
493                  pt2d_array(ii)%pt2d(jpi,:) = zland
494               END SELECT
495               !
496            END SELECT
497            !
498            !                                     ! North-South boundaries
499            !                                     ! ======================
500            SELECT CASE ( nperio )
501            !
502            CASE ( 2 )                               !**  South symmetric  --  North closed
503               SELECT CASE ( type_array(ii) )
504               CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
505                  pt2d_array(ii)%pt2d(:, 1 ) = pt2d_array(ii)%pt2d(:,3)
506                  pt2d_array(ii)%pt2d(:,jpj) = zland
507               CASE ( 'V' , 'F' )                         ! V-, F-points
508                  pt2d_array(ii)%pt2d(:, 1 ) = psgn_array(ii) * pt2d_array(ii)%pt2d(:,2)
509                  pt2d_array(ii)%pt2d(:,jpj) = zland
510               END SELECT
511               !
512            CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
513               SELECT CASE ( type_array(ii) )                    ! South : closed
514               CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
515                  pt2d_array(ii)%pt2d(:, 1 ) = zland
516               END SELECT
517               !                                          ! North fold
518               CALL lbc_nfd( pt2d_array(ii)%pt2d(:,:), type_array(ii), psgn_array(ii) )
519               !
520            CASE DEFAULT                             !**  North closed  --  South closed
521               SELECT CASE ( type_array(ii) )
522               CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
523                  pt2d_array(ii)%pt2d(:, 1 ) = zland
524                  pt2d_array(ii)%pt2d(:,jpj) = zland
525               CASE ( 'F' )                               ! F-point
526                  pt2d_array(ii)%pt2d(:,jpj) = zland
527               END SELECT
528              !
529            END SELECT
530            !
531         ENDIF
532      END DO
533      !
534   END SUBROUTINE lbc_lnk_2d_multiple
535   
536   SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields)
537      !!---------------------------------------------------------------------
538      REAL(wp), DIMENSION(jpi,jpj), TARGET   ,   INTENT(inout) ::   pt2d    ! Second 2D array on which the boundary condition is applied
539      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type ! define the nature of ptab array grid-points
540      REAL(wp)                    , INTENT(in   ) ::   psgn    ! =-1 the sign change across the north fold boundary
541      TYPE(arrayptr)   , DIMENSION(9) ::   pt2d_array
542      CHARACTER(len=1) , DIMENSION(9) ::   type_array    ! define the nature of ptab array grid-points
543      REAL(wp)         , DIMENSION(9) ::   psgn_array    ! =-1 the sign change across the north fold boundary
544      INTEGER                      , INTENT (inout):: num_fields 
545      !!---------------------------------------------------------------------
546      num_fields=num_fields+1
547      pt2d_array(num_fields)%pt2d=>pt2d
548      type_array(num_fields)=cd_type
549      psgn_array(num_fields)=psgn
550   END SUBROUTINE load_array
551   
552#endif
553
554
555   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
556      !!---------------------------------------------------------------------
557      !!                  ***  ROUTINE lbc_bdy_lnk  ***
558      !!
559      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
560      !!                to maintain the same interface with regards to the mpp
561      !case
562      !!
563      !!----------------------------------------------------------------------
564      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
565      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
566      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
567      INTEGER                                                   ::   ib_bdy    ! BDY boundary set
568      !!
569      CALL lbc_lnk_3d( pt3d, cd_type, psgn)
570
571   END SUBROUTINE lbc_bdy_lnk_3d
572
573   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
574      !!---------------------------------------------------------------------
575      !!                  ***  ROUTINE lbc_bdy_lnk  ***
576      !!
577      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
578      !!                to maintain the same interface with regards to the mpp
579      !case
580      !!
581      !!----------------------------------------------------------------------
582      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
583      REAL(wp), DIMENSION(jpi,jpj),     INTENT(inout)           ::   pt2d      ! 3D array on which the lbc is applied
584      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
585      INTEGER                                                   ::   ib_bdy    ! BDY boundary set
586      !!
587      CALL lbc_lnk_2d( pt2d, cd_type, psgn)
588
589   END SUBROUTINE lbc_bdy_lnk_2d
590
591
592   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
593      !!---------------------------------------------------------------------
594      !!                 ***  ROUTINE lbc_lnk_2d  ***
595      !!
596      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
597      !!                special dummy routine to allow for use of halo indexing in mpp case
598      !!
599      !! ** Method  :   psign = -1 :    change the sign across the north fold
600      !!                      =  1 : no change of the sign across the north fold
601      !!                      =  0 : no change of the sign across the north fold and
602      !!                             strict positivity preserved: use inner row/column
603      !!                             for closed boundaries.
604      !!----------------------------------------------------------------------
605      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
606      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
607      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
608      INTEGER                     , INTENT(in   )           ::   jpri      ! size of extra halo (not needed in non-mpp)
609      INTEGER                     , INTENT(in   )           ::   jprj      ! size of extra halo (not needed in non-mpp)
610      !!----------------------------------------------------------------------
611
612      CALL lbc_lnk_2d( pt2d, cd_type, psgn )
613      !   
614   END SUBROUTINE lbc_lnk_2d_e
615
616#endif
617
618   !!======================================================================
619END MODULE lbclnk