source: NEMO/trunk/src/OCE/LBC/lbclnk.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 7 months ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge —ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The —ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

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