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 NEMO/releases/r4.0/r4.0-HEAD/src/OCE/LBC – NEMO

source: NEMO/releases/r4.0/r4.0-HEAD/src/OCE/LBC/lbclnk.F90 @ 13350

Last change on this file since 13350 was 13350, checked in by smueller, 4 years ago

Remedy for the bugs reported in ticket #2492

  • Property svn:keywords set to Id
File size: 20.9 KB
Line 
1MODULE lbclnk
2   !!======================================================================
3   !!                       ***  MODULE  lbclnk  ***
4   !! NEMO        : 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   !!            4.0  ! 2017-03  (G. Madec) automatique allocation of array size (use with any 3rd dim size)
13   !!             -   ! 2017-04  (G. Madec) remove duplicated routines (lbc_lnk_2d_9, lbc_lnk_2d_multiple, lbc_lnk_3d_gather)
14   !!             -   ! 2017-05  (G. Madec) create generic.h90 files to generate all lbc and north fold routines
15   !!----------------------------------------------------------------------
16   !!           define the generic interfaces of lib_mpp routines
17   !!----------------------------------------------------------------------
18   !!   lbc_lnk       : generic interface for mpp_lnk_3d and mpp_lnk_2d routines defined in lib_mpp
19   !!   lbc_bdy_lnk   : generic interface for mpp_lnk_bdy_2d and mpp_lnk_bdy_3d routines defined in lib_mpp
20   !!----------------------------------------------------------------------
21   USE dom_oce        ! ocean space and time domain
22   USE lib_mpp        ! distributed memory computing library
23   USE lbcnfd         ! north fold
24   USE in_out_manager ! I/O manager
25
26   IMPLICIT NONE
27   PRIVATE
28
29   INTERFACE lbc_lnk
30      MODULE PROCEDURE   mpp_lnk_2d      , mpp_lnk_3d      , mpp_lnk_4d
31   END INTERFACE
32   INTERFACE lbc_lnk_ptr
33      MODULE PROCEDURE   mpp_lnk_2d_ptr  , mpp_lnk_3d_ptr  , mpp_lnk_4d_ptr
34   END INTERFACE
35   INTERFACE lbc_lnk_multi
36      MODULE PROCEDURE   lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi
37   END INTERFACE
38   !
39   INTERFACE lbc_lnk_icb
40      MODULE PROCEDURE mpp_lnk_2d_icb
41   END INTERFACE
42
43   INTERFACE mpp_nfd
44      MODULE PROCEDURE   mpp_nfd_2d    , mpp_nfd_3d    , mpp_nfd_4d
45      MODULE PROCEDURE   mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
46   END INTERFACE
47
48   PUBLIC   lbc_lnk       ! ocean/ice lateral boundary conditions
49   PUBLIC   lbc_lnk_multi ! modified ocean/ice lateral boundary conditions
50   PUBLIC   lbc_lnk_icb   ! iceberg lateral boundary conditions
51
52#if   defined key_mpp_mpi
53!$AGRIF_DO_NOT_TREAT
54   INCLUDE 'mpif.h'
55!$AGRIF_END_DO_NOT_TREAT
56#endif
57
58   INTEGER, PUBLIC, PARAMETER ::   jpfillnothing = 1
59   INTEGER, PUBLIC, PARAMETER ::   jpfillcst     = 2
60   INTEGER, PUBLIC, PARAMETER ::   jpfillcopy    = 3
61   INTEGER, PUBLIC, PARAMETER ::   jpfillperio   = 4
62   INTEGER, PUBLIC, PARAMETER ::   jpfillmpi     = 5
63
64   !!----------------------------------------------------------------------
65   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
66   !! $Id$
67   !! Software governed by the CeCILL license (see ./LICENSE)
68   !!----------------------------------------------------------------------
69CONTAINS
70
71   !!----------------------------------------------------------------------
72   !!                   ***   load_ptr_(2,3,4)d   ***
73   !!
74   !!   * Dummy Argument :
75   !!       in    ==>   ptab       ! array to be loaded (2D, 3D or 4D)
76   !!                   cd_nat     ! nature of pt2d array grid-points
77   !!                   psgn       ! sign used across the north fold boundary
78   !!       inout <=>   ptab_ptr   ! array of 2D, 3D or 4D pointers
79   !!                   cdna_ptr   ! nature of ptab array grid-points
80   !!                   psgn_ptr   ! sign used across the north fold boundary
81   !!                   kfld       ! number of elements that has been attributed
82   !!----------------------------------------------------------------------
83
84   !!----------------------------------------------------------------------
85   !!                  ***   lbc_lnk_(2,3,4)d_multi   ***
86   !!                     ***   load_ptr_(2,3,4)d   ***
87   !!
88   !!   * Argument : dummy argument use in lbc_lnk_multi_... routines
89   !!
90   !!----------------------------------------------------------------------
91
92#  define DIM_2d
93#     define ROUTINE_LOAD           load_ptr_2d
94#     define ROUTINE_MULTI          lbc_lnk_2d_multi
95#     include "lbc_lnk_multi_generic.h90"
96#     undef ROUTINE_MULTI
97#     undef ROUTINE_LOAD
98#  undef DIM_2d
99
100#  define DIM_3d
101#     define ROUTINE_LOAD           load_ptr_3d
102#     define ROUTINE_MULTI          lbc_lnk_3d_multi
103#     include "lbc_lnk_multi_generic.h90"
104#     undef ROUTINE_MULTI
105#     undef ROUTINE_LOAD
106#  undef DIM_3d
107
108#  define DIM_4d
109#     define ROUTINE_LOAD           load_ptr_4d
110#     define ROUTINE_MULTI          lbc_lnk_4d_multi
111#     include "lbc_lnk_multi_generic.h90"
112#     undef ROUTINE_MULTI
113#     undef ROUTINE_LOAD
114#  undef DIM_4d
115
116   !!----------------------------------------------------------------------
117   !!                   ***  routine mpp_lnk_(2,3,4)d  ***
118   !!
119   !!   * Argument : dummy argument use in mpp_lnk_... routines
120   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied
121   !!                cd_nat    :   nature of array grid-points
122   !!                psgn      :   sign used across the north fold boundary
123   !!                kfld      :   optional, number of pt3d arrays
124   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables)
125   !!                pfillval  :   optional, background value (used with jpfillcopy)
126   !!----------------------------------------------------------------------
127   !
128   !                       !==  2D array and array of 2D pointer  ==!
129   !
130#  define DIM_2d
131#     define ROUTINE_LNK           mpp_lnk_2d
132#     include "mpp_lnk_generic.h90"
133#     undef ROUTINE_LNK
134#     define MULTI
135#     define ROUTINE_LNK           mpp_lnk_2d_ptr
136#     include "mpp_lnk_generic.h90"
137#     undef ROUTINE_LNK
138#     undef MULTI
139#  undef DIM_2d
140   !
141   !                       !==  3D array and array of 3D pointer  ==!
142   !
143#  define DIM_3d
144#     define ROUTINE_LNK           mpp_lnk_3d
145#     include "mpp_lnk_generic.h90"
146#     undef ROUTINE_LNK
147#     define MULTI
148#     define ROUTINE_LNK           mpp_lnk_3d_ptr
149#     include "mpp_lnk_generic.h90"
150#     undef ROUTINE_LNK
151#     undef MULTI
152#  undef DIM_3d
153   !
154   !                       !==  4D array and array of 4D pointer  ==!
155   !
156#  define DIM_4d
157#     define ROUTINE_LNK           mpp_lnk_4d
158#     include "mpp_lnk_generic.h90"
159#     undef ROUTINE_LNK
160#     define MULTI
161#     define ROUTINE_LNK           mpp_lnk_4d_ptr
162#     include "mpp_lnk_generic.h90"
163#     undef ROUTINE_LNK
164#     undef MULTI
165#  undef DIM_4d
166
167   !!----------------------------------------------------------------------
168   !!                   ***  routine mpp_nfd_(2,3,4)d  ***
169   !!
170   !!   * Argument : dummy argument use in mpp_nfd_... routines
171   !!                ptab      :   array or pointer of arrays on which the boundary condition is applied
172   !!                cd_nat    :   nature of array grid-points
173   !!                psgn      :   sign used across the north fold boundary
174   !!                kfld      :   optional, number of pt3d arrays
175   !!                kfillmode :   optional, method to be use to fill the halos (see jpfill* variables)
176   !!                pfillval  :   optional, background value (used with jpfillcopy)
177   !!----------------------------------------------------------------------
178   !
179   !                       !==  2D array and array of 2D pointer  ==!
180   !
181#  define DIM_2d
182#     define ROUTINE_NFD           mpp_nfd_2d
183#     include "mpp_nfd_generic.h90"
184#     undef ROUTINE_NFD
185#     define MULTI
186#     define ROUTINE_NFD           mpp_nfd_2d_ptr
187#     include "mpp_nfd_generic.h90"
188#     undef ROUTINE_NFD
189#     undef MULTI
190#  undef DIM_2d
191   !
192   !                       !==  3D array and array of 3D pointer  ==!
193   !
194#  define DIM_3d
195#     define ROUTINE_NFD           mpp_nfd_3d
196#     include "mpp_nfd_generic.h90"
197#     undef ROUTINE_NFD
198#     define MULTI
199#     define ROUTINE_NFD           mpp_nfd_3d_ptr
200#     include "mpp_nfd_generic.h90"
201#     undef ROUTINE_NFD
202#     undef MULTI
203#  undef DIM_3d
204   !
205   !                       !==  4D array and array of 4D pointer  ==!
206   !
207#  define DIM_4d
208#     define ROUTINE_NFD           mpp_nfd_4d
209#     include "mpp_nfd_generic.h90"
210#     undef ROUTINE_NFD
211#     define MULTI
212#     define ROUTINE_NFD           mpp_nfd_4d_ptr
213#     include "mpp_nfd_generic.h90"
214#     undef ROUTINE_NFD
215#     undef MULTI
216#  undef DIM_4d
217
218
219   !!======================================================================
220
221
222
223   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)
224      !!---------------------------------------------------------------------
225      !!                   ***  routine mpp_lbc_north_icb  ***
226      !!
227      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
228      !!              in mpp configuration in case of jpn1 > 1 and for 2d
229      !!              array with outer extra halo
230      !!
231      !! ** Method  :   North fold condition and mpp with more than one proc
232      !!              in i-direction require a specific treatment. We gather
233      !!              the 4+kextj northern lines of the global domain on 1
234      !!              processor and apply lbc north-fold on this sub array.
235      !!              Then we scatter the north fold array back to the processors.
236      !!              This routine accounts for an extra halo with icebergs
237      !!              and assumes ghost rows and columns have been suppressed.
238      !!
239      !!----------------------------------------------------------------------
240      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
241      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
242      !                                                     !   = T ,  U , V , F or W -points
243      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
244      !!                                                    ! north fold, =  1. otherwise
245      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold
246      !
247      INTEGER ::   ji, jj, jr
248      INTEGER ::   ierr, itaille, ildi, ilei, iilb
249      INTEGER ::   ipj, ij, iproc
250      !
251      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
252      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
253      !!----------------------------------------------------------------------
254#if defined key_mpp_mpi
255      !
256      ipj=4
257      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       &
258     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       &
259     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni)    )
260      !
261      ztab_e(:,:)      = 0._wp
262      znorthloc_e(:,:) = 0._wp
263      !
264      ij = 1 - kextj
265      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e
266      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
267         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
268         ij = ij + 1
269      END DO
270      !
271      itaille = jpimax * ( ipj + 2*kextj )
272      !
273      IF( ln_timing ) CALL tic_tac(.TRUE.)
274      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_DOUBLE_PRECISION,    &
275         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION,    &
276         &                ncomm_north, ierr )
277      !
278      IF( ln_timing ) CALL tic_tac(.FALSE.)
279      !
280      DO jr = 1, ndim_rank_north            ! recover the global north array
281         iproc = nrank_north(jr) + 1
282         ildi = nldit (iproc)
283         ilei = nleit (iproc)
284         iilb = nimppt(iproc)
285         DO jj = 1-kextj, ipj+kextj
286            DO ji = ildi, ilei
287               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
288            END DO
289         END DO
290      END DO
291
292      ! 2. North-Fold boundary conditions
293      ! ----------------------------------
294      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
295
296      ij = 1 - kextj
297      !! Scatter back to pt2d
298      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
299         DO ji= 1, jpi
300            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
301         END DO
302         ij  = ij +1
303      END DO
304      !
305      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
306      !
307#endif
308   END SUBROUTINE mpp_lbc_north_icb
309
310
311   SUBROUTINE mpp_lnk_2d_icb( cdname, pt2d, cd_type, psgn, kexti, kextj )
312      !!----------------------------------------------------------------------
313      !!                  ***  routine mpp_lnk_2d_icb  ***
314      !!
315      !! ** Purpose :   Message passing management for 2d array (with extra halo for icebergs)
316      !!                This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
317      !!                array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
318      !!
319      !! ** Method  :   Use mppsend and mpprecv function for passing mask
320      !!      between processors following neighboring subdomains.
321      !!            domain parameters
322      !!                    jpi    : first dimension of the local subdomain
323      !!                    jpj    : second dimension of the local subdomain
324      !!                    kexti  : number of columns for extra outer halo
325      !!                    kextj  : number of rows for extra outer halo
326      !!                    nbondi : mark for "east-west local boundary"
327      !!                    nbondj : mark for "north-south local boundary"
328      !!                    noea   : number for local neighboring processors
329      !!                    nowe   : number for local neighboring processors
330      !!                    noso   : number for local neighboring processors
331      !!                    nono   : number for local neighboring processors
332      !!----------------------------------------------------------------------
333      CHARACTER(len=*)                                        , INTENT(in   ) ::   cdname      ! name of the calling subroutine
334      REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
335      CHARACTER(len=1)                                        , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
336      REAL(wp)                                                , INTENT(in   ) ::   psgn     ! sign used across the north fold
337      INTEGER                                                 , INTENT(in   ) ::   kexti    ! extra i-halo width
338      INTEGER                                                 , INTENT(in   ) ::   kextj    ! extra j-halo width
339      !
340      INTEGER  ::   jl   ! dummy loop indices
341      INTEGER  ::   imigr, iihom, ijhom        ! local integers
342      INTEGER  ::   ipreci, iprecj             !   -       -
343      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
344      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
345      !!
346      REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) ::   r2dns, r2dsn
347      REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) ::   r2dwe, r2dew
348      !!----------------------------------------------------------------------
349
350      ipreci = nn_hls + kexti      ! take into account outer extra 2D overlap area
351      iprecj = nn_hls + kextj
352
353      IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, 1, 1, 1, ld_lbc = .TRUE. )
354
355      ! 1. standard boundary treatment
356      ! ------------------------------
357      ! Order matters Here !!!!
358      !
359      !                                      ! East-West boundaries
360      !                                           !* Cyclic east-west
361      IF( l_Iperio ) THEN
362         pt2d(1-kexti:     1   ,:) = pt2d(jpim1-kexti: jpim1 ,:)       ! east
363         pt2d(  jpi  :jpi+kexti,:) = pt2d(     2     :2+kexti,:)       ! west
364         !
365      ELSE                                        !* closed
366         IF( .NOT. cd_type == 'F' )   pt2d(  1-kexti   :nn_hls   ,:) = 0._wp    ! east except at F-point
367                                      pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp    ! west
368      ENDIF
369      !                                      ! North-South boundaries
370      IF( l_Jperio ) THEN                         !* cyclic (only with no mpp j-split)
371         pt2d(:,1-kextj:     1   ) = pt2d(:,jpjm1-kextj:  jpjm1)       ! north
372         pt2d(:,  jpj  :jpj+kextj) = pt2d(:,     2     :2+kextj)       ! south
373      ELSE                                        !* closed
374         IF( .NOT. cd_type == 'F' )   pt2d(:,  1-kextj   :nn_hls   ) = 0._wp    ! north except at F-point
375                                      pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp    ! south
376      ENDIF
377      !
378
379      ! north fold treatment
380      ! -----------------------
381      IF( npolj /= 0 ) THEN
382         !
383         SELECT CASE ( jpni )
384                   CASE ( 1 )     ;   CALL lbc_nfd          ( pt2d(1:jpi,1-kextj:jpj+kextj), cd_type, psgn, kextj )
385                   CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
386         END SELECT
387         !
388      ENDIF
389
390      ! 2. East and west directions exchange
391      ! ------------------------------------
392      ! we play with the neigbours AND the row number because of the periodicity
393      !
394      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
395      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
396         iihom = jpi-nreci-kexti
397         DO jl = 1, ipreci
398            r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
399            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
400         END DO
401      END SELECT
402      !
403      !                           ! Migrations
404      imigr = ipreci * ( jpj + 2*kextj )
405      !
406      IF( ln_timing ) CALL tic_tac(.TRUE.)
407      !
408      SELECT CASE ( nbondi )
409      CASE ( -1 )
410         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
411         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
412         CALL mpi_wait(ml_req1,ml_stat,ml_err)
413      CASE ( 0 )
414         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
415         CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
416         CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
417         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
418         CALL mpi_wait(ml_req1,ml_stat,ml_err)
419         CALL mpi_wait(ml_req2,ml_stat,ml_err)
420      CASE ( 1 )
421         CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
422         CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
423         CALL mpi_wait(ml_req1,ml_stat,ml_err)
424      END SELECT
425      !
426      IF( ln_timing ) CALL tic_tac(.FALSE.)
427      !
428      !                           ! Write Dirichlet lateral conditions
429      iihom = jpi - nn_hls
430      !
431      SELECT CASE ( nbondi )
432      CASE ( -1 )
433         DO jl = 1, ipreci
434            pt2d(iihom+jl,:) = r2dew(:,jl,2)
435         END DO
436      CASE ( 0 )
437         DO jl = 1, ipreci
438            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
439            pt2d(iihom+jl,:) = r2dew(:,jl,2)
440         END DO
441      CASE ( 1 )
442         DO jl = 1, ipreci
443            pt2d(jl-kexti,:) = r2dwe(:,jl,2)
444         END DO
445      END SELECT
446
447
448      ! 3. North and south directions
449      ! -----------------------------
450      ! always closed : we play only with the neigbours
451      !
452      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
453         ijhom = jpj-nrecj-kextj
454         DO jl = 1, iprecj
455            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
456            r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
457         END DO
458      ENDIF
459      !
460      !                           ! Migrations
461      imigr = iprecj * ( jpi + 2*kexti )
462      !
463      IF( ln_timing ) CALL tic_tac(.TRUE.)
464      !
465      SELECT CASE ( nbondj )
466      CASE ( -1 )
467         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
468         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
469         CALL mpi_wait(ml_req1,ml_stat,ml_err)
470      CASE ( 0 )
471         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
472         CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
473         CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
474         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
475         CALL mpi_wait(ml_req1,ml_stat,ml_err)
476         CALL mpi_wait(ml_req2,ml_stat,ml_err)
477      CASE ( 1 )
478         CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
479         CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
480         CALL mpi_wait(ml_req1,ml_stat,ml_err)
481      END SELECT
482      !
483      IF( ln_timing ) CALL tic_tac(.FALSE.)
484      !
485      !                           ! Write Dirichlet lateral conditions
486      ijhom = jpj - nn_hls
487      !
488      SELECT CASE ( nbondj )
489      CASE ( -1 )
490         DO jl = 1, iprecj
491            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
492         END DO
493      CASE ( 0 )
494         DO jl = 1, iprecj
495            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
496            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
497         END DO
498      CASE ( 1 )
499         DO jl = 1, iprecj
500            pt2d(:,jl-kextj) = r2dsn(:,jl,2)
501         END DO
502      END SELECT
503      !
504   END SUBROUTINE mpp_lnk_2d_icb
505   
506END MODULE lbclnk
507
Note: See TracBrowser for help on using the repository browser.