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

source: branches/2017/dev_rev8689_LIM3_RST/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 8708

Last change on this file since 8708 was 8708, checked in by andmirek, 6 years ago

#1976 improvements in LIM3 restart. Working version

  • Property svn:keywords set to Id
File size: 34.1 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(:,:,:)      , 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(:,:,:)      , 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, ilev     ! dummy loop index
162      REAL(wp) ::   ztab         ! local scalar
163      !!----------------------------------------------------------------------
164      !
165      ilev = SIZE(pt3d, 3)
166      DO jk = 1, ilev
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      pt2d(:,:) = ztab
193      !
194   END SUBROUTINE lbc_lnk_2d
195   
196   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )
197      !!
198      INTEGER :: num_fields
199      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
200      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
201      !                                                               ! = T , U , V , F , W and I points
202      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
203      !                                                               ! =  1. , the sign is kept
204      !
205      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
206      !
207      DO ii = 1, num_fields
208        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )
209      END DO     
210      !
211   END SUBROUTINE lbc_lnk_2d_multiple
212
213   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
214      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
215      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
216      !!---------------------------------------------------------------------
217      ! Second 2D array on which the boundary condition is applied
218      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA
219      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
220      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI
221      ! define the nature of ptab array grid-points
222      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
223      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
224      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
225      ! =-1 the sign change across the north fold boundary
226      REAL(wp)                                      , INTENT(in   ) ::   psgnA
227      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
228      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI
229      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
230      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
231      !!
232      !!---------------------------------------------------------------------
233
234      !!The first array
235      CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
236
237      !! Look if more arrays to process
238      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB )
239      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 
240      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 
241      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 
242      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 
243      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 
244      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 
245      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 
246
247   END SUBROUTINE lbc_lnk_2d_9
248
249
250
251
252
253#else
254   !!----------------------------------------------------------------------
255   !!   Default option                           3D shared memory computing
256   !!----------------------------------------------------------------------
257
258   SUBROUTINE lbc_lnk_3d_gather( pt3d1, cd_type1, pt3d2, cd_type2, psgn )
259      !!---------------------------------------------------------------------
260      !!                  ***  ROUTINE lbc_lnk_3d_gather  ***
261      !!
262      !! ** Purpose :   set lateral boundary conditions on two 3D arrays (non mpp case)
263      !!
264      !! ** Method  :   psign = -1 :    change the sign across the north fold
265      !!                      =  1 : no change of the sign across the north fold
266      !!                      =  0 : no change of the sign across the north fold and
267      !!                             strict positivity preserved: use inner row/column
268      !!                             for closed boundaries.
269      !!----------------------------------------------------------------------
270      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1, cd_type2   ! nature of pt3d grid-points
271      REAL(wp), DIMENSION(:,:,:)      , INTENT(inout) ::   pt3d1   , pt3d2      ! 3D array on which the lbc is applied
272      REAL(wp)                        , INTENT(in   ) ::   psgn                 ! control of the sign
273      !!----------------------------------------------------------------------
274      !
275      CALL lbc_lnk_3d( pt3d1, cd_type1, psgn)
276      CALL lbc_lnk_3d( pt3d2, cd_type2, psgn)
277      !
278   END SUBROUTINE lbc_lnk_3d_gather
279
280
281   SUBROUTINE lbc_lnk_3d( pt3d, cd_type, psgn, cd_mpp, pval )
282      !!---------------------------------------------------------------------
283      !!                  ***  ROUTINE lbc_lnk_3d  ***
284      !!
285      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
286      !!
287      !! ** Method  :   psign = -1 :    change the sign across the north fold
288      !!                      =  1 : no change of the sign across the north fold
289      !!                      =  0 : no change of the sign across the north fold and
290      !!                             strict positivity preserved: use inner row/column
291      !!                             for closed boundaries.
292      !!----------------------------------------------------------------------
293      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
294      REAL(wp), DIMENSION(:,:,:)      , INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
295      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
296      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
297      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
298      !!
299      REAL(wp) ::   zland
300      !!----------------------------------------------------------------------
301
302      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
303      ELSE                         ;   zland = 0._wp
304      ENDIF
305
306
307      IF( PRESENT( cd_mpp ) ) THEN
308         ! only fill the overlap area and extra allows
309         ! this is in mpp case. In this module, just do nothing
310      ELSE
311         !                                     !  East-West boundaries
312         !                                     ! ======================
313         SELECT CASE ( nperio )
314         !
315         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
316            pt3d( 1 ,:,:) = pt3d(jpim1,:,:)            ! all points
317            pt3d(jpi,:,:) = pt3d(  2  ,:,:)
318            !
319         CASE DEFAULT                             !**  East closed  --  West closed
320            SELECT CASE ( cd_type )
321            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
322               pt3d( 1 ,:,:) = zland
323               pt3d(jpi,:,:) = zland
324            CASE ( 'F' )                               ! F-point
325               pt3d(jpi,:,:) = zland
326            END SELECT
327            !
328         END SELECT
329         !                                     ! North-South boundaries
330         !                                     ! ======================
331         SELECT CASE ( nperio )
332         !
333         CASE ( 2 )                               !**  South symmetric  --  North closed
334            SELECT CASE ( cd_type )
335            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
336               pt3d(:, 1 ,:) = pt3d(:,3,:)
337               pt3d(:,jpj,:) = zland
338            CASE ( 'V' , 'F' )                         ! V-, F-points
339               pt3d(:, 1 ,:) = psgn * pt3d(:,2,:)
340               pt3d(:,jpj,:) = zland
341            END SELECT
342            !
343         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
344            SELECT CASE ( cd_type )                    ! South : closed
345            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
346               pt3d(:, 1 ,:) = zland
347            END SELECT
348            !                                          ! North fold
349            CALL lbc_nfd( pt3d(:,:,:), cd_type, psgn )
350            !
351         CASE DEFAULT                             !**  North closed  --  South closed
352            SELECT CASE ( cd_type )
353            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
354               pt3d(:, 1 ,:) = zland
355               pt3d(:,jpj,:) = zland
356            CASE ( 'F' )                               ! F-point
357               pt3d(:,jpj,:) = zland
358            END SELECT
359            !
360         END SELECT
361         !
362      ENDIF
363      !
364   END SUBROUTINE lbc_lnk_3d
365
366
367   SUBROUTINE lbc_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
368      !!---------------------------------------------------------------------
369      !!                 ***  ROUTINE lbc_lnk_2d  ***
370      !!
371      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
372      !!
373      !! ** Method  :   psign = -1 :    change the sign across the north fold
374      !!                      =  1 : no change of the sign across the north fold
375      !!                      =  0 : no change of the sign across the north fold and
376      !!                             strict positivity preserved: use inner row/column
377      !!                             for closed boundaries.
378      !!----------------------------------------------------------------------
379      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
380      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
381      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
382      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
383      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
384      !!
385      REAL(wp) ::   zland
386      !!----------------------------------------------------------------------
387
388      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
389      ELSE                         ;   zland = 0._wp
390      ENDIF
391
392      IF (PRESENT(cd_mpp)) THEN
393         ! only fill the overlap area and extra allows
394         ! this is in mpp case. In this module, just do nothing
395      ELSE     
396         !                                     ! East-West boundaries
397         !                                     ! ====================
398         SELECT CASE ( nperio )
399         !
400         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
401            pt2d( 1 ,:) = pt2d(jpim1,:)               ! all points
402            pt2d(jpi,:) = pt2d(  2  ,:)
403            !
404         CASE DEFAULT                             !** East closed  --  West closed
405            SELECT CASE ( cd_type )
406            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
407               pt2d( 1 ,:) = zland
408               pt2d(jpi,:) = zland
409            CASE ( 'F' )                              ! F-point
410               pt2d(jpi,:) = zland
411            END SELECT
412            !
413         END SELECT
414         !                                     ! North-South boundaries
415         !                                     ! ======================
416         SELECT CASE ( nperio )
417         !
418         CASE ( 2 )                               !**  South symmetric  --  North closed
419            SELECT CASE ( cd_type )
420            CASE ( 'T' , 'U' , 'W' )                   ! T-, U-, W-points
421               pt2d(:, 1 ) = pt2d(:,3)
422               pt2d(:,jpj) = zland
423            CASE ( 'V' , 'F' )                         ! V-, F-points
424               pt2d(:, 1 ) = psgn * pt2d(:,2)
425               pt2d(:,jpj) = zland
426            END SELECT
427            !
428         CASE ( 3 , 4 , 5 , 6 )                   !**  North fold  T or F-point pivot  --  South closed
429            SELECT CASE ( cd_type )                    ! South : closed
430            CASE ( 'T' , 'U' , 'V' , 'W' , 'I' )             ! all points except F-point
431               pt2d(:, 1 ) = zland
432            END SELECT
433            !                                          ! North fold
434            CALL lbc_nfd( pt2d(:,:), cd_type, psgn )
435            !
436         CASE DEFAULT                             !**  North closed  --  South closed
437            SELECT CASE ( cd_type )
438            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
439               pt2d(:, 1 ) = zland
440               pt2d(:,jpj) = zland
441            CASE ( 'F' )                               ! F-point
442               pt2d(:,jpj) = zland
443            END SELECT
444            !
445         END SELECT
446         !
447      ENDIF
448      !   
449   END SUBROUTINE lbc_lnk_2d
450   
451   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields )
452      !!
453      INTEGER :: num_fields
454      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
455      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points
456      !                                                               ! = T , U , V , F , W and I points
457      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary
458      !                                                               ! =  1. , the sign is kept
459      !
460      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES
461      !
462      DO ii = 1, num_fields
463        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) )
464      END DO     
465      !
466   END SUBROUTINE lbc_lnk_2d_multiple
467
468   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   &
469      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   &
470      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval)
471      !!---------------------------------------------------------------------
472      ! Second 2D array on which the boundary condition is applied
473      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA
474      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE
475      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI
476      ! define the nature of ptab array grid-points
477      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA
478      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE
479      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI
480      ! =-1 the sign change across the north fold boundary
481      REAL(wp)                                      , INTENT(in   ) ::   psgnA
482      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE
483      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI
484      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
485      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
486      !!
487      !!---------------------------------------------------------------------
488
489      !!The first array
490      CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 
491
492      !! Look if more arrays to process
493      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dB, cd_typeB, psgnB )
494      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 
495      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 
496      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 
497      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 
498      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 
499      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 
500      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 
501
502   END SUBROUTINE lbc_lnk_2d_9
503
504   SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval )
505      !!---------------------------------------------------------------------
506      !!                 ***  ROUTINE lbc_lnk_sum_2d  ***
507      !!
508      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
509      !!
510      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean
511      !!                coupling if conservation option activated. As no ice shelf are present along
512      !!                this line, nothing is done along the north fold.
513      !!----------------------------------------------------------------------
514      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
515      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied
516      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign
517      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
518      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
519      !!
520      REAL(wp) ::   zland
521      !!----------------------------------------------------------------------
522
523      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
524      ELSE                         ;   zland = 0._wp
525      ENDIF
526
527      IF (PRESENT(cd_mpp)) THEN
528         ! only fill the overlap area and extra allows
529         ! this is in mpp case. In this module, just do nothing
530      ELSE
531         !                                     ! East-West boundaries
532         !                                     ! ====================
533         SELECT CASE ( nperio )
534         !
535         CASE ( 1 , 4 , 6 )                       !** cyclic east-west
536            pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:)
537            pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:)
538            pt2d( 1 ,:) = 0.0_wp               ! all points
539            pt2d(jpi,:) = 0.0_wp
540            !
541         CASE DEFAULT                             !** East closed  --  West closed
542            SELECT CASE ( cd_type )
543            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points
544               pt2d( 1 ,:) = zland
545               pt2d(jpi,:) = zland
546            CASE ( 'F' )                              ! F-point
547               pt2d(jpi,:) = zland
548            END SELECT
549            !
550         END SELECT
551         !                                     ! North-South boundaries
552         !                                     ! ======================
553         ! Nothing to do for the north fold, there is no ice shelf along this line.
554         !
555      END IF
556
557   END SUBROUTINE
558
559   SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval )
560      !!---------------------------------------------------------------------
561      !!                 ***  ROUTINE lbc_lnk_sum_3d  ***
562      !!
563      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case)
564      !!
565      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean
566      !!                coupling if conservation option activated. As no ice shelf are present along
567      !!                this line, nothing is done along the north fold.
568      !!----------------------------------------------------------------------
569      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points
570      REAL(wp), DIMENSION(:,:,:)      , INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied
571      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign
572      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing)
573      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries)
574      !!
575      REAL(wp) ::   zland
576      !!----------------------------------------------------------------------
577
578      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default)
579      ELSE                         ;   zland = 0._wp
580      ENDIF
581
582
583      IF( PRESENT( cd_mpp ) ) THEN
584         ! only fill the overlap area and extra allows
585         ! this is in mpp case. In this module, just do nothing
586      ELSE
587         !                                     !  East-West boundaries
588         !                                     ! ======================
589         SELECT CASE ( nperio )
590         !
591         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west
592            pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:)
593            pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:) 
594            pt3d( 1 ,:,:) = 0.0_wp            ! all points
595            pt3d(jpi,:,:) = 0.0_wp
596            !
597         CASE DEFAULT                             !**  East closed  --  West closed
598            SELECT CASE ( cd_type )
599            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points
600               pt3d( 1 ,:,:) = zland
601               pt3d(jpi,:,:) = zland
602            CASE ( 'F' )                               ! F-point
603               pt3d(jpi,:,:) = zland
604            END SELECT
605            !
606         END SELECT
607         !                                     ! North-South boundaries
608         !                                     ! ======================
609         ! Nothing to do for the north fold, there is no ice shelf along this line.
610         !
611      END IF
612   END SUBROUTINE
613
614
615#endif
616
617   SUBROUTINE lbc_bdy_lnk_3d( pt3d, cd_type, psgn, ib_bdy )
618      !!---------------------------------------------------------------------
619      !!                  ***  ROUTINE lbc_bdy_lnk  ***
620      !!
621      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
622      !!              to maintain the same interface with regards to the mpp case
623      !!
624      !!----------------------------------------------------------------------
625      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
626      REAL(wp), DIMENSION(:,:,:)      , INTENT(inout) ::   pt3d      ! 3D array on which the lbc is applied
627      REAL(wp)                        , INTENT(in   ) ::   psgn      ! control of the sign
628      INTEGER                         , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
629      !!----------------------------------------------------------------------
630      !
631      CALL lbc_lnk_3d( pt3d, cd_type, psgn)
632      !
633   END SUBROUTINE lbc_bdy_lnk_3d
634
635
636   SUBROUTINE lbc_bdy_lnk_2d( pt2d, cd_type, psgn, ib_bdy )
637      !!---------------------------------------------------------------------
638      !!                  ***  ROUTINE lbc_bdy_lnk  ***
639      !!
640      !! ** Purpose :   wrapper rountine to 'lbc_lnk_3d'. This wrapper is used
641      !!              to maintain the same interface with regards to the mpp case
642      !!
643      !!----------------------------------------------------------------------
644      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
645      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the lbc is applied
646      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
647      INTEGER                     , INTENT(in   ) ::   ib_bdy    ! BDY boundary set
648      !!----------------------------------------------------------------------
649      !
650      CALL lbc_lnk_2d( pt2d, cd_type, psgn)
651      !
652   END SUBROUTINE lbc_bdy_lnk_2d
653
654
655   SUBROUTINE lbc_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
656      !!---------------------------------------------------------------------
657      !!                 ***  ROUTINE lbc_lnk_2d  ***
658      !!
659      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case)
660      !!                special dummy routine to allow for use of halo indexing in mpp case
661      !!
662      !! ** Method  :   psign = -1 :    change the sign across the north fold
663      !!                      =  1 : no change of the sign across the north fold
664      !!                      =  0 : no change of the sign across the north fold and
665      !!                             strict positivity preserved: use inner row/column
666      !!                             for closed boundaries.
667      !!----------------------------------------------------------------------
668      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
669      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the lbc is applied
670      REAL(wp)                    , INTENT(in   ) ::   psgn      ! control of the sign
671      INTEGER                     , INTENT(in   ) ::   jpri      ! size of extra halo (not needed in non-mpp)
672      INTEGER                     , INTENT(in   ) ::   jprj      ! size of extra halo (not needed in non-mpp)
673      !!----------------------------------------------------------------------
674      !
675      CALL lbc_lnk_2d( pt2d, cd_type, psgn )
676      !   
677   END SUBROUTINE lbc_lnk_2d_e
678
679#endif
680
681   !!======================================================================
682END MODULE lbclnk
683
Note: See TracBrowser for help on using the repository browser.