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/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/UKMO/dev_r5518_GO6_under_ice_relax_dr_hook/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90 @ 11738

Last change on this file since 11738 was 11738, checked in by marc, 4 years ago

The Dr Hook changes from my perl code.

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