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 #1628 – Attachment – NEMO

Ticket #1628: lbclnk.F90

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