New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lbclnk.F90 in branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 7037

Last change on this file since 7037 was 7037, checked in by mocavero, 8 years ago

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