source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 8114

Last change on this file since 8114 was 8114, checked in by lovato, 4 years ago

trunk: bugfix for lbclnk.F90 (#1879)

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