source: trunk/NEMO/OPA_SRC/lib_mpp.F90 @ 888

Last change on this file since 888 was 888, checked in by ctlod, 13 years ago

merge dev_001_SBC branche with the trunk to include the New Surface Module package, see ticket: #113

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 186.9 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing librairy
5   !!=====================================================================
6#if   defined key_mpp_mpi   ||   defined key_mpp_shmem
7   !!----------------------------------------------------------------------
8   !!   'key_mpp_mpi'     OR      MPI massively parallel processing library
9   !!   'key_mpp_shmem'         SHMEM massively parallel processing library
10   !!----------------------------------------------------------------------
11   !!   mynode
12   !!   mpparent
13   !!   mppshmem
14   !!   mpp_lnk     : generic interface (defined in lbclnk) for :
15   !!                 mpp_lnk_2d, mpp_lnk_3d
16   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
17   !!   mpp_lnk_e   : interface defined in lbclnk
18   !!   mpplnks
19   !!   mpprecv
20   !!   mppsend
21   !!   mppscatter
22   !!   mppgather
23   !!   mpp_isl    : generic inteface  for :
24   !!                mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real
25   !!   mpp_min    : generic interface for :
26   !!                mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
27   !!   mpp_max    : generic interface for :
28   !!                mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
29   !!   mpp_sum    : generic interface for :
30   !!                mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
31   !!   mpp_minloc
32   !!   mpp_maxloc
33   !!   mppsync
34   !!   mppstop
35   !!   mppobc     : variant of mpp_lnk for open boundaries
36   !!   mpp_ini_north
37   !!   mpp_lbc_north
38   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo (nsolv=4)
39   !!----------------------------------------------------------------------
40   !! History :
41   !!        !  94 (M. Guyon, J. Escobar, M. Imbard)  Original code
42   !!        !  97  (A.M. Treguier)  SHMEM additions
43   !!        !  98  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
44   !!   9.0  !  03  (J.-M. Molines, G. Madec)  F90, free form
45   !!        !  04  (R. Bourdalle Badie)  isend option in mpi
46   !!        !  05  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
47   !!        !  05  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
48   !!----------------------------------------------------------------------
49   !!  OPA 9.0 , LOCEAN-IPSL (2005)
50   !! $Id$
51   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
52   !!---------------------------------------------------------------------
53   !! * Modules used
54   USE dom_oce                    ! ocean space and time domain
55   USE in_out_manager             ! I/O manager
56
57   IMPLICIT NONE
58
59   PRIVATE
60   PUBLIC  mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum,  mpp_lbc_north
61   PUBLIC  mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks
62   PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free
63#if defined key_oasis3 || defined key_oasis4
64   PUBLIC  mppsize, mpprank
65#endif
66
67   !! * Interfaces
68   !! define generic interface for these routine as they are called sometimes
69   !!        with scalar arguments instead of array arguments, which causes problems
70   !!        for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
71
72   INTERFACE mpp_isl
73      MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
74   END INTERFACE
75   INTERFACE mpp_min
76      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
77   END INTERFACE
78   INTERFACE mpp_max
79      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
80   END INTERFACE
81   INTERFACE mpp_sum
82      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
83   END INTERFACE
84   INTERFACE mpp_lbc_north
85      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
86   END INTERFACE
87  INTERFACE mpp_minloc
88     MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
89  END INTERFACE
90  INTERFACE mpp_maxloc
91     MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
92  END INTERFACE
93
94
95   !! * Share module variables
96   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.       !: mpp flag
97
98   !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
99   INTEGER, PARAMETER ::   &
100      nprocmax = 2**10     ! maximun dimension
101
102#if defined key_mpp_mpi
103   !! ========================= !!
104   !!  MPI  variable definition !!
105   !! ========================= !!
106!$AGRIF_DO_NOT_TREAT
107#  include <mpif.h>
108!$AGRIF_END_DO_NOT_TREAT
109
110   INTEGER ::   &
111      mppsize,  &  ! number of process
112      mpprank,  &  ! process number  [ 0 - size-1 ]
113      mpi_comm_opa ! opa local communicator
114
115   ! variables used in case of sea-ice
116   INTEGER, PUBLIC ::  &       !
117      ngrp_ice,        &       ! group ID for the ice processors (to compute rheology)
118      ncomm_ice,       &       ! communicator made by the processors with sea-ice
119      ndim_rank_ice,   &       ! number of 'ice' processors
120      n_ice_root               ! number (in the comm_ice) of proc 0 in the ice comm
121   INTEGER, DIMENSION(:), ALLOCATABLE ::   &
122      nrank_ice            ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
123   ! variables used in case of north fold condition in mpp_mpi with jpni > 1
124   INTEGER ::      &       !
125      ngrp_world,  &       ! group ID for the world processors
126      ngrp_north,  &       ! group ID for the northern processors (to be fold)
127      ncomm_north, &       ! communicator made by the processors belonging to ngrp_north
128      ndim_rank_north, &   ! number of 'sea' processor in the northern line (can be /= jpni !)
129      njmppmax             ! value of njmpp for the processors of the northern line
130   INTEGER ::      &       !
131      north_root           ! number (in the comm_opa) of proc 0 in the northern comm
132   INTEGER, DIMENSION(:), ALLOCATABLE ::   &
133      nrank_north          ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
134   CHARACTER (len=1) ::  &
135      c_mpi_send = 'S'     ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
136   LOGICAL  ::           &
137      l_isend = .FALSE.    ! isend use indicator (T if c_mpi_send='I')
138
139
140#elif defined key_mpp_shmem
141   !! ========================= !!
142   !! SHMEM variable definition !!
143   !! ========================= !!
144#  include  <fpvm3.h>
145#  include <mpp/shmem.fh>
146
147   CHARACTER (len=80), PARAMETER ::   simfile    = 'pvm3_ndim'   ! file name
148   CHARACTER (len=47), PARAMETER ::   executable = 'opa'         ! executable name
149   CHARACTER, PARAMETER ::            opaall     = ""            ! group name (old def opaall*(*))
150
151   INTEGER, PARAMETER ::   & !! SHMEM control print
152      mynode_print   = 0,  &  ! flag for print, mynode   routine
153      mpprecv_print  = 0,  &  ! flag for print, mpprecv  routine
154      mppsend_print  = 0,  &  ! flag for print, mppsend  routine
155      mppsync_print  = 0,  &  ! flag for print, mppsync  routine
156      mppsum_print   = 0,  &  ! flag for print, mpp_sum  routine
157      mppisl_print   = 0,  &  ! flag for print, mpp_isl  routine
158      mppmin_print   = 0,  &  ! flag for print, mpp_min  routine
159      mppmax_print   = 0,  &  ! flag for print, mpp_max  routine
160      mpparent_print = 0      ! flag for print, mpparent routine
161
162   INTEGER, PARAMETER ::   & !! Variable definition
163      jpvmint = 21            ! ???
164
165   INTEGER, PARAMETER ::   & !! Maximum  dimension of array to sum on the processors
166      jpmsec   = 50000,    &  ! ???
167      jpmpplat =    30,    &  ! ???
168      jpmppsum = MAX( jpisl*jpisl, jpmpplat*jpk, jpmsec )   ! ???
169
170   INTEGER ::   &
171      npvm_ipas ,  &  ! pvm initialization flag
172      npvm_mytid,  &  ! pvm tid
173      npvm_me   ,  &  ! node number [ 0 - nproc-1 ]
174      npvm_nproc,  &  ! real number of nodes
175      npvm_inum       ! ???
176   INTEGER, DIMENSION(0:nprocmax-1) ::   &
177      npvm_tids       ! tids array [ 0 - nproc-1 ]
178
179   INTEGER ::   &
180      nt3d_ipas ,  &  ! pvm initialization flag
181      nt3d_mytid,  &  ! pvm tid
182      nt3d_me   ,  &  ! node number [ 0 - nproc-1 ]
183      nt3d_nproc      ! real number of nodes
184   INTEGER, DIMENSION(0:nprocmax-1) ::   &
185      nt3d_tids       ! tids array [ 0 - nproc-1 ]
186
187   !! real sum reduction
188   INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) ::   &
189       nrs1sync_shmem,   &  !
190       nrs2sync_shmem
191   REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
192       wrs1wrk_shmem,    &  !
193       wrs2wrk_shmem        !
194   REAL(wp), DIMENSION(jpmppsum) ::   &
195       wrstab_shmem         !
196
197   !! minimum and maximum reduction
198   INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) ::   &
199       ni1sync_shmem,    &  !
200       ni2sync_shmem        !
201   REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
202       wi1wrk_shmem,     &  !
203       wi2wrk_shmem
204   REAL(wp), DIMENSION(jpmppsum) ::   &
205       wintab_shmem,     &  !
206       wi1tab_shmem,     &  !
207       wi2tab_shmem         !
208       
209       !! value not equal zero for barotropic stream function around islands
210   INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) ::   &
211       ni11sync_shmem,   &  !
212       ni12sync_shmem,   &  !
213       ni21sync_shmem,   &  !
214       ni22sync_shmem       !
215   REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
216       wi11wrk_shmem,    &  !
217       wi12wrk_shmem,    &  !
218       wi21wrk_shmem,    &  !
219       wi22wrk_shmem        !
220   REAL(wp), DIMENSION(jpmppsum) ::   &
221       wiltab_shmem ,    &  !
222       wi11tab_shmem,    &  !
223       wi12tab_shmem,    &  !
224       wi21tab_shmem,    &  !
225       wi22tab_shmem
226
227   INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
228       ni11wrk_shmem,    &  !
229       ni12wrk_shmem,    &  !
230       ni21wrk_shmem,    &  !
231       ni22wrk_shmem        !
232   INTEGER, DIMENSION(jpmppsum) ::   &
233       niitab_shmem ,    &  !
234       ni11tab_shmem,    &  !
235       ni12tab_shmem        !
236   INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) ::   &
237       nis1sync_shmem,   &  !
238       nis2sync_shmem       !
239   INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
240       nis1wrk_shmem,    &  !
241       nis2wrk_shmem        !
242   INTEGER, DIMENSION(jpmppsum) ::   &
243       nistab_shmem
244
245   !! integer sum reduction
246   INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) ::   &
247       nil1sync_shmem,   &  !
248       nil2sync_shmem       !
249   INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) ::   &
250       nil1wrk_shmem,    &  !
251       nil2wrk_shmem        !
252   INTEGER, DIMENSION(jpmppsum) ::   &
253       niltab_shmem
254#endif
255
256   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   &
257       t4ns, t4sn  ! 3d message passing arrays north-south & south-north
258   REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) ::   &
259       t4ew, t4we  ! 3d message passing arrays east-west & west-east
260   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   &
261       t4p1, t4p2  ! 3d message passing arrays north fold
262   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   &
263       t3ns, t3sn  ! 3d message passing arrays north-south & south-north
264   REAL(wp), DIMENSION(jpj,jpreci,jpk,2) ::   &
265       t3ew, t3we  ! 3d message passing arrays east-west & west-east
266   REAL(wp), DIMENSION(jpi,jprecj,jpk,2) ::   &
267       t3p1, t3p2  ! 3d message passing arrays north fold
268   REAL(wp), DIMENSION(jpi,jprecj,2) ::   &
269       t2ns, t2sn  ! 2d message passing arrays north-south & south-north
270   REAL(wp), DIMENSION(jpj,jpreci,2) ::   &
271       t2ew, t2we  ! 2d message passing arrays east-west & west-east
272   REAL(wp), DIMENSION(jpi,jprecj,2) ::   &
273       t2p1, t2p2  ! 2d message passing arrays north fold
274   REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   &
275       tr2ns, tr2sn  ! 2d message passing arrays north-south & south-north including extra outer halo
276   REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   &
277       tr2ew, tr2we  ! 2d message passing arrays east-west & west-east including extra outer halo
278   !!----------------------------------------------------------------------
279   !!  OPA 9.0 , LOCEAN-IPSL (2005)
280   !! $Id$
281   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
282   !!---------------------------------------------------------------------
283
284CONTAINS
285
286   FUNCTION mynode(localComm)
287      !!----------------------------------------------------------------------
288      !!                  ***  routine mynode  ***
289      !!                   
290      !! ** Purpose :   Find processor unit
291      !!
292      !!----------------------------------------------------------------------
293#if defined key_mpp_mpi
294      !! * Local variables   (MPI version)
295      INTEGER ::   mynode, ierr, code
296      LOGICAL ::   mpi_was_called
297      INTEGER,OPTIONAL ::   localComm
298      NAMELIST/nam_mpp/ c_mpi_send
299      !!----------------------------------------------------------------------
300
301      WRITE(numout,*)
302      WRITE(numout,*) 'mynode : mpi initialisation'
303      WRITE(numout,*) '~~~~~~ '
304      WRITE(numout,*)
305
306      ! Namelist namrun : parameters of the run
307      REWIND( numnam )
308      READ  ( numnam, nam_mpp )
309
310      WRITE(numout,*) '        Namelist nam_mpp'
311      WRITE(numout,*) '           mpi send type            c_mpi_send = ', c_mpi_send
312
313#if defined key_agrif
314      IF( Agrif_Root() ) THEN
315#endif
316!!bug RB : should be clean to use Agrif in coupled mode
317#if ! defined key_agrif
318         CALL mpi_initialized ( mpi_was_called, code )
319         IF( code /= MPI_SUCCESS ) THEN
320            CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
321            CALL mpi_abort( mpi_comm_world, code, ierr )
322         ENDIF
323
324         IF( PRESENT(localComm) .and. mpi_was_called ) THEN
325            mpi_comm_opa = localComm
326            SELECT CASE ( c_mpi_send )
327            CASE ( 'S' )                ! Standard mpi send (blocking)
328               WRITE(numout,*) '           Standard blocking mpi send (send)'
329            CASE ( 'B' )                ! Buffer mpi send (blocking)
330               WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
331               CALL mpi_init_opa( ierr )
332            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
333               WRITE(numout,*) '           Immediate non-blocking send (isend)'
334               l_isend = .TRUE.
335            CASE DEFAULT
336               WRITE(numout,cform_err)
337               WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send
338               nstop = nstop + 1
339            END SELECT
340         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
341            WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator '
342            WRITE(numout,*) '          without calling MPI_Init before ! '
343         ELSE
344#endif
345            SELECT CASE ( c_mpi_send )
346            CASE ( 'S' )                ! Standard mpi send (blocking)
347               WRITE(numout,*) '           Standard blocking mpi send (send)'
348               CALL mpi_init( ierr )
349            CASE ( 'B' )                ! Buffer mpi send (blocking)
350               WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
351               CALL mpi_init_opa( ierr )
352            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
353               WRITE(numout,*) '           Immediate non-blocking send (isend)'
354               l_isend = .TRUE.
355               CALL mpi_init( ierr )
356            CASE DEFAULT
357               WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send
358               CALL ctl_stop( ctmp1 )
359            END SELECT
360
361#if ! defined key_agrif
362            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
363            IF( code /= MPI_SUCCESS ) THEN
364               CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
365               CALL mpi_abort( mpi_comm_world, code, ierr )
366            ENDIF
367            !
368         ENDIF
369#endif
370#if defined key_agrif
371      ELSE
372         SELECT CASE ( c_mpi_send )
373         CASE ( 'S' )                ! Standard mpi send (blocking)
374            WRITE(numout,*) '           Standard blocking mpi send (send)'
375         CASE ( 'B' )                ! Buffer mpi send (blocking)
376            WRITE(numout,*) '           Buffer blocking mpi send (bsend)'
377         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
378            WRITE(numout,*) '           Immediate non-blocking send (isend)'
379            l_isend = .TRUE.
380         CASE DEFAULT
381            WRITE(numout,cform_err)
382            WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send
383            nstop = nstop + 1
384         END SELECT
385      ENDIF
386
387      mpi_comm_opa = mpi_comm_world
388#endif
389        CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
390        CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
391      mynode = mpprank
392#else
393      !! * Local variables   (SHMEM version)
394      INTEGER ::   mynode
395      INTEGER ::   &
396           imypid, imyhost, ji, info, iparent_tid
397      !!----------------------------------------------------------------------
398
399      IF( npvm_ipas /= nprocmax ) THEN
400         !         ---   first passage in mynode
401         !         -------------
402         !         enroll in pvm
403         !         -------------
404         CALL pvmfmytid( npvm_mytid )
405         IF( mynode_print /= 0 ) THEN
406            WRITE(numout,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
407            WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
408         ENDIF
409
410         !         ---------------------------------------------------------------
411         !         find out IF i am parent or child spawned processes have parents
412         !         ---------------------------------------------------------------
413         CALL mpparent( iparent_tid )
414         IF( mynode_print /= 0 ) THEN
415            WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid,   &
416               &            ' after mpparent, npvm_tids(0) = ',   &
417               &            npvm_tids(0), ' iparent_tid=', iparent_tid
418         ENDIF
419         IF( iparent_tid < 0 )  THEN
420            WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid,   &
421               &            ' after mpparent, npvm_tids(0) = ',   &
422               &            npvm_tids(0), ' iparent_tid=', iparent_tid
423            npvm_tids(0) = npvm_mytid
424            npvm_me = 0
425            IF( jpnij > nprocmax ) THEN
426               WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great'
427               CALL ctl_stop( ctmp1 )
428
429            ELSE
430               npvm_nproc = jpnij
431            ENDIF
432
433            ! -------------------------
434            ! start up copies of myself
435            ! -------------------------
436            IF( npvm_nproc > 1 ) THEN
437               DO ji = 1, npvm_nproc-1
438                  npvm_tids(ji) = nt3d_tids(ji)
439               END DO
440               info=npvm_nproc-1
441 
442               IF( mynode_print /= 0 ) THEN
443                  WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid,   &
444                     &            ' maitre=',executable,' info=', info   &
445                     &            ,' npvm_nproc=',npvm_nproc
446                  WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid,   &
447                     &            ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
448               ENDIF
449
450               ! ---------------------------
451               ! multicast tids array to children
452               ! ---------------------------
453               CALL pvmfinitsend( pvmdefault, info )
454               CALL pvmfpack ( jpvmint, npvm_nproc, 1         , 1, info )
455               CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
456               CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
457            ENDIF
458         ELSE
459
460            ! ---------------------------------
461            ! receive the tids array and set me
462            ! ---------------------------------
463            IF( mynode_print /= 0 )   WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
464            CALL pvmfrecv( iparent_tid, 10, info )
465            IF( mynode_print /= 0 )   WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
466            CALL pvmfunpack( jpvmint, npvm_nproc, 1         , 1, info )
467            CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
468            IF( mynode_print /= 0 ) THEN
469               WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid,   &
470                  &            ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
471               WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid,   &
472                  &            'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
473            ENDIF
474            DO ji = 0, npvm_nproc-1
475               IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
476            END DO
477         ENDIF
478
479         ! ------------------------------------------------------------
480         ! all nproc tasks are equal now
481         ! and can address each other by tids(0) thru tids(nproc-1)
482         ! for each process me => process number [0-(nproc-1)]
483         ! ------------------------------------------------------------
484         CALL pvmfjoingroup ( "bidon", info )
485         CALL pvmfbarrier   ( "bidon", npvm_nproc, info )
486         DO ji = 0, npvm_nproc-1
487            IF( ji == npvm_me ) THEN
488               CALL pvmfjoingroup ( opaall, npvm_inum )
489               IF( npvm_inum /= npvm_me )   WRITE(numout,*) 'mynode not arrived in the good order for opaall'
490            ENDIF
491            CALL pvmfbarrier( "bidon", npvm_nproc, info )
492         END DO
493         CALL pvmfbarrier( opaall, npvm_nproc, info )
494 
495      ELSE
496         ! ---   other passage in mynode
497      ENDIF
498 
499      npvm_ipas = nprocmax
500      mynode    = npvm_me
501      imypid    = npvm_mytid
502      imyhost   = npvm_tids(0)
503      IF( mynode_print /= 0 ) THEN
504         WRITE(numout,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me,   &
505            &           ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
506      ENDIF
507#endif
508   END FUNCTION mynode
509
510
511   SUBROUTINE mpparent( kparent_tid )
512      !!----------------------------------------------------------------------
513      !!                  ***  routine mpparent  ***
514      !!
515      !! ** Purpose :   use an pvmfparent routine for T3E (key_mpp_shmem)
516      !!              or  only return -1 (key_mpp_mpi)
517      !!----------------------------------------------------------------------
518      !! * Arguments
519      INTEGER, INTENT(inout) ::   kparent_tid      ! ???
520 
521#if defined key_mpp_mpi
522      ! MPI version : retour -1
523
524      kparent_tid = -1
525
526#else
527      !! * Local variables   (SHMEN onto T3E version)
528      INTEGER ::   &
529           it3d_my_pe, LEADZ, ji, info
530 
531      CALL pvmfmytid( nt3d_mytid )
532      CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
533      IF( mpparent_print /= 0 ) THEN
534         WRITE(numout,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
535      ENDIF
536      IF( it3d_my_pe == 0 ) THEN
537         !-----------------------------------------------------------------!
538         !     process = 0 => receive other tids                           !
539         !-----------------------------------------------------------------!
540         kparent_tid = -1
541         IF(mpparent_print /= 0 ) THEN
542            WRITE(numout,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
543         ENDIF
544         !          --- END receive dimension ---
545         IF( jpnij > nprocmax ) THEN
546            WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great'
547            CALL ctl_stop( ctmp1 )
548         ELSE
549            nt3d_nproc =  jpnij
550         ENDIF
551         IF( mpparent_print /= 0 ) THEN
552            WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
553         ENDIF
554         !-------- receive tids from others process --------
555         DO ji = 1, nt3d_nproc-1
556            CALL pvmfrecv( ji , 100, info )
557            CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
558            IF( mpparent_print /= 0 ) THEN
559               WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
560            ENDIF
561         END DO
562         nt3d_tids(0) = nt3d_mytid
563         IF( mpparent_print /= 0 ) THEN
564            WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji),   &
565                 ji = 0, nt3d_nproc-1 )
566            WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
567         ENDIF
568
569      ELSE
570         !!----------------------------------------------------------------!
571         !     process <> 0 => send  other tids                            !
572         !!----------------------------------------------------------------!
573         kparent_tid = 0
574         CALL pvmfinitsend( pvmdataraw, info )
575         CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
576         CALL pvmfsend( kparent_tid, 100, info )
577      ENDIF
578#endif
579
580   END SUBROUTINE mpparent
581
582#if defined key_mpp_shmem
583
584   SUBROUTINE mppshmem
585      !!----------------------------------------------------------------------
586      !!                  ***  routine mppshmem  ***
587      !!
588      !! ** Purpose :   SHMEM ROUTINE
589      !!
590      !!----------------------------------------------------------------------
591      nrs1sync_shmem = SHMEM_SYNC_VALUE
592      nrs2sync_shmem = SHMEM_SYNC_VALUE
593      nis1sync_shmem = SHMEM_SYNC_VALUE
594      nis2sync_shmem = SHMEM_SYNC_VALUE
595      nil1sync_shmem = SHMEM_SYNC_VALUE
596      nil2sync_shmem = SHMEM_SYNC_VALUE
597      ni11sync_shmem = SHMEM_SYNC_VALUE
598      ni12sync_shmem = SHMEM_SYNC_VALUE
599      ni21sync_shmem = SHMEM_SYNC_VALUE
600      ni22sync_shmem = SHMEM_SYNC_VALUE
601      CALL barrier()
602 
603   END SUBROUTINE mppshmem
604
605#endif
606
607   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
608      !!----------------------------------------------------------------------
609      !!                  ***  routine mpp_lnk_3d  ***
610      !!
611      !! ** Purpose :   Message passing manadgement
612      !!
613      !! ** Method  :   Use mppsend and mpprecv function for passing mask
614      !!      between processors following neighboring subdomains.
615      !!            domain parameters
616      !!                    nlci   : first dimension of the local subdomain
617      !!                    nlcj   : second dimension of the local subdomain
618      !!                    nbondi : mark for "east-west local boundary"
619      !!                    nbondj : mark for "north-south local boundary"
620      !!                    noea   : number for local neighboring processors
621      !!                    nowe   : number for local neighboring processors
622      !!                    noso   : number for local neighboring processors
623      !!                    nono   : number for local neighboring processors
624      !!
625      !! ** Action  :   ptab with update value at its periphery
626      !!
627      !!----------------------------------------------------------------------
628      !! * Arguments
629      CHARACTER(len=1) , INTENT( in ) ::   &
630         cd_type       ! define the nature of ptab array grid-points
631         !             ! = T , U , V , F , W points
632         !             ! = S : T-point, north fold treatment ???
633         !             ! = G : F-point, north fold treatment ???
634      REAL(wp), INTENT( in ) ::   &
635         psgn          ! control of the sign change
636         !             !   = -1. , the sign is changed if north fold boundary
637         !             !   =  1. , the sign is kept  if north fold boundary
638      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
639         ptab          ! 3D array on which the boundary condition is applied
640      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    &
641         cd_mpp        ! fill the overlap area only
642      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries)
643
644      !! * Local variables
645      INTEGER ::   ji, jj, jk, jl                        ! dummy loop indices
646      INTEGER ::   imigr, iihom, ijhom, iloc, ijt, iju   ! temporary integers
647      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
648      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
649      REAL(wp) ::   zland
650      !!----------------------------------------------------------------------
651
652      ! 1. standard boundary treatment
653      ! ------------------------------
654
655      IF( PRESENT( pval ) ) THEN      ! set land value (zero by default)
656         zland = pval
657      ELSE
658         zland = 0.e0
659      ENDIF
660
661      IF( PRESENT( cd_mpp ) ) THEN
662         DO jj = nlcj+1, jpj   ! only fill extra allows last line
663            ptab(1:nlci, jj, :) = ptab(1:nlci, nlej, :)
664         END DO
665         DO ji = nlci+1, jpi   ! only fill extra allows last column
666            ptab(ji    , : , :) = ptab(nlei  , :   , :)
667         END DO
668      ELSE     
669
670         !                                        ! East-West boundaries
671         !                                        ! ====================
672         IF( nbondi == 2 .AND.   &      ! Cyclic east-west
673            &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
674            ptab( 1 ,:,:) = ptab(jpim1,:,:)
675            ptab(jpi,:,:) = ptab(  2  ,:,:)
676
677         ELSE                           ! closed
678            SELECT CASE ( cd_type )
679            CASE ( 'T', 'U', 'V', 'W' )
680               ptab(     1       :jpreci,:,:) = zland
681               ptab(nlci-jpreci+1:jpi   ,:,:) = zland
682            CASE ( 'F' )
683               ptab(nlci-jpreci+1:jpi   ,:,:) = zland
684            END SELECT
685         ENDIF
686
687         !                                        ! North-South boundaries
688         !                                        ! ======================
689         SELECT CASE ( cd_type )
690         CASE ( 'T', 'U', 'V', 'W' )
691            ptab(:,     1       :jprecj,:) = zland
692            ptab(:,nlcj-jprecj+1:jpj   ,:) = zland
693         CASE ( 'F' )
694            ptab(:,nlcj-jprecj+1:jpj   ,:) = zland
695         END SELECT
696     
697      ENDIF
698
699      ! 2. East and west directions exchange
700      ! ------------------------------------
701
702      ! 2.1 Read Dirichlet lateral conditions
703
704      SELECT CASE ( nbondi )
705      CASE ( -1, 0, 1 )    ! all exept 2
706         iihom = nlci-nreci
707         DO jl = 1, jpreci
708            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
709            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
710         END DO
711      END SELECT
712
713      ! 2.2 Migrations
714
715#if defined key_mpp_shmem
716      !! * SHMEM version
717
718      imigr = jpreci * jpj * jpk
719
720      SELECT CASE ( nbondi )
721      CASE ( -1 )
722         CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
723      CASE ( 0 )
724         CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
725         CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
726      CASE ( 1 )
727         CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
728      END SELECT
729
730      CALL barrier()
731      CALL shmem_udcflush()
732
733#elif defined key_mpp_mpi
734      !! * Local variables   (MPI version)
735
736      imigr = jpreci * jpj * jpk
737
738      SELECT CASE ( nbondi ) 
739      CASE ( -1 )
740         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
741         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
742         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
743      CASE ( 0 )
744         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
745         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
746         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
747         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
748         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
749         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
750      CASE ( 1 )
751         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
752         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
753         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
754      END SELECT
755#endif
756
757      ! 2.3 Write Dirichlet lateral conditions
758
759      iihom = nlci-jpreci
760
761      SELECT CASE ( nbondi )
762      CASE ( -1 )
763         DO jl = 1, jpreci
764            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
765         END DO
766      CASE ( 0 ) 
767         DO jl = 1, jpreci
768            ptab(jl      ,:,:) = t3we(:,jl,:,2)
769            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
770         END DO
771      CASE ( 1 )
772         DO jl = 1, jpreci
773            ptab(jl      ,:,:) = t3we(:,jl,:,2)
774         END DO
775      END SELECT
776
777
778      ! 3. North and south directions
779      ! -----------------------------
780
781      ! 3.1 Read Dirichlet lateral conditions
782
783      IF( nbondj /= 2 ) THEN
784         ijhom = nlcj-nrecj
785         DO jl = 1, jprecj
786            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
787            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
788         END DO
789      ENDIF
790
791      ! 3.2 Migrations
792
793#if defined key_mpp_shmem
794      !! * SHMEM version
795
796      imigr = jprecj * jpi * jpk
797
798      SELECT CASE ( nbondj )
799      CASE ( -1 )
800         CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
801      CASE ( 0 )
802         CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
803         CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
804      CASE ( 1 )
805         CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
806      END SELECT
807
808      CALL barrier()
809      CALL shmem_udcflush()
810
811#elif defined key_mpp_mpi
812      !! * Local variables   (MPI version)
813 
814      imigr=jprecj*jpi*jpk
815
816      SELECT CASE ( nbondj )     
817      CASE ( -1 )
818         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
819         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
820         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
821      CASE ( 0 )
822         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
823         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
824         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
825         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
826         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
827         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
828      CASE ( 1 ) 
829         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
830         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
831         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
832      END SELECT
833
834#endif
835
836      ! 3.3 Write Dirichlet lateral conditions
837
838      ijhom = nlcj-jprecj
839
840      SELECT CASE ( nbondj )
841      CASE ( -1 )
842         DO jl = 1, jprecj
843            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
844         END DO
845      CASE ( 0 ) 
846         DO jl = 1, jprecj
847            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
848            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
849         END DO
850      CASE ( 1 )
851         DO jl = 1, jprecj
852            ptab(:,jl,:) = t3sn(:,jl,:,2)
853         END DO
854      END SELECT
855
856
857      ! 4. north fold treatment
858      ! -----------------------
859
860      IF (PRESENT(cd_mpp)) THEN
861         ! No north fold treatment (it is assumed to be already OK)
862     
863      ELSE     
864
865      ! 4.1 treatment without exchange (jpni odd)
866      !     T-point pivot 
867
868      SELECT CASE ( jpni )
869
870      CASE ( 1 )  ! only one proc along I, no mpp exchange
871       
872         SELECT CASE ( npolj )
873 
874         CASE ( 3 , 4 )    ! T pivot
875            iloc = jpiglo - 2 * ( nimpp - 1 )
876
877            SELECT CASE ( cd_type )
878
879            CASE ( 'T' , 'S', 'W' )
880               DO jk = 1, jpk
881                  DO ji = 2, nlci
882                     ijt=iloc-ji+2
883                     ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
884                  END DO
885                  DO ji = nlci/2+1, nlci
886                     ijt=iloc-ji+2
887                     ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
888                  END DO
889               END DO
890
891            CASE ( 'U' )
892               DO jk = 1, jpk
893                  DO ji = 1, nlci-1
894                     iju=iloc-ji+1
895                     ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
896                  END DO
897                  DO ji = nlci/2, nlci-1
898                     iju=iloc-ji+1
899                     ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
900                  END DO
901               END DO
902
903            CASE ( 'V' )
904               DO jk = 1, jpk
905                  DO ji = 2, nlci
906                     ijt=iloc-ji+2
907                     ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
908                     ptab(ji,nlcj  ,jk) = psgn * ptab(ijt,nlcj-3,jk)
909                  END DO
910               END DO
911
912            CASE ( 'F', 'G' )
913               DO jk = 1, jpk
914                  DO ji = 1, nlci-1
915                     iju=iloc-ji+1
916                     ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-2,jk)
917                     ptab(ji,nlcj  ,jk) = psgn * ptab(iju,nlcj-3,jk)
918                  END DO
919               END DO
920 
921          END SELECT
922       
923         CASE ( 5 , 6 ) ! F pivot
924            iloc=jpiglo-2*(nimpp-1)
925 
926            SELECT CASE ( cd_type )
927
928            CASE ( 'T' , 'S', 'W' )
929               DO jk = 1, jpk
930                  DO ji = 1, nlci
931                     ijt=iloc-ji+1
932                     ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
933                  END DO
934               END DO
935
936            CASE ( 'U' )
937               DO jk = 1, jpk
938                  DO ji = 1, nlci-1
939                     iju=iloc-ji
940                     ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
941                  END DO
942               END DO
943
944            CASE ( 'V' )
945               DO jk = 1, jpk
946                  DO ji = 1, nlci
947                     ijt=iloc-ji+1
948                     ptab(ji,nlcj  ,jk) = psgn * ptab(ijt,nlcj-2,jk)
949                  END DO
950                  DO ji = nlci/2+1, nlci
951                     ijt=iloc-ji+1
952                     ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
953                  END DO
954               END DO
955
956            CASE ( 'F', 'G' )
957               DO jk = 1, jpk
958                  DO ji = 1, nlci-1
959                     iju=iloc-ji
960                     ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
961                  END DO
962                  DO ji = nlci/2+1, nlci-1
963                     iju=iloc-ji
964                     ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
965                  END DO
966               END DO
967            END SELECT  ! cd_type
968
969         END SELECT     !  npolj
970 
971      CASE DEFAULT ! more than 1 proc along I
972         IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn)  ! only for northern procs.
973
974      END SELECT ! jpni
975
976      ENDIF
977     
978
979      ! 5. East and west directions exchange
980      ! ------------------------------------
981
982      SELECT CASE ( npolj )
983
984      CASE ( 3, 4, 5, 6 )
985
986         ! 5.1 Read Dirichlet lateral conditions
987
988         SELECT CASE ( nbondi )
989
990         CASE ( -1, 0, 1 )
991            iihom = nlci-nreci
992            DO jl = 1, jpreci
993               t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
994               t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
995            END DO
996
997         END SELECT
998
999         ! 5.2 Migrations
1000
1001#if defined key_mpp_shmem
1002         !! SHMEM version
1003
1004         imigr = jpreci * jpj * jpk
1005
1006         SELECT CASE ( nbondi )
1007         CASE ( -1 )
1008            CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1009         CASE ( 0 )
1010            CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1011            CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1012         CASE ( 1 )
1013            CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1014         END SELECT
1015
1016         CALL barrier()
1017         CALL shmem_udcflush()
1018
1019#elif defined key_mpp_mpi
1020         !! MPI version
1021
1022         imigr=jpreci*jpj*jpk
1023 
1024         SELECT CASE ( nbondi )
1025         CASE ( -1 )
1026            CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
1027            CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1028            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1029         CASE ( 0 )
1030            CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1031            CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
1032            CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1033            CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1034            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1035            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1036         CASE ( 1 )
1037            CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1038            CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1039            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1040         END SELECT
1041#endif
1042
1043         ! 5.3 Write Dirichlet lateral conditions
1044
1045         iihom = nlci-jpreci
1046
1047         SELECT CASE ( nbondi)
1048         CASE ( -1 )
1049            DO jl = 1, jpreci
1050               ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1051            END DO
1052         CASE ( 0 ) 
1053            DO jl = 1, jpreci
1054               ptab(jl      ,:,:) = t3we(:,jl,:,2)
1055               ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1056            END DO
1057         CASE ( 1 )
1058            DO jl = 1, jpreci
1059               ptab(jl      ,:,:) = t3we(:,jl,:,2)
1060            END DO
1061         END SELECT
1062
1063      END SELECT    ! npolj
1064
1065   END SUBROUTINE mpp_lnk_3d
1066
1067
1068   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
1069      !!----------------------------------------------------------------------
1070      !!                  ***  routine mpp_lnk_2d  ***
1071      !!                 
1072      !! ** Purpose :   Message passing manadgement for 2d array
1073      !!
1074      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1075      !!      between processors following neighboring subdomains.
1076      !!            domain parameters
1077      !!                    nlci   : first dimension of the local subdomain
1078      !!                    nlcj   : second dimension of the local subdomain
1079      !!                    nbondi : mark for "east-west local boundary"
1080      !!                    nbondj : mark for "north-south local boundary"
1081      !!                    noea   : number for local neighboring processors
1082      !!                    nowe   : number for local neighboring processors
1083      !!                    noso   : number for local neighboring processors
1084      !!                    nono   : number for local neighboring processors
1085      !!
1086      !!----------------------------------------------------------------------
1087      !! * Arguments
1088      CHARACTER(len=1) , INTENT( in ) ::   &
1089         cd_type       ! define the nature of pt2d array grid-points
1090         !             !  = T , U , V , F , W
1091         !             !  = S : T-point, north fold treatment
1092         !             !  = G : F-point, north fold treatment
1093         !             !  = I : sea-ice velocity at F-point with index shift
1094      REAL(wp), INTENT( in ) ::   &
1095         psgn          ! control of the sign change
1096         !             !   = -1. , the sign is changed if north fold boundary
1097         !             !   =  1. , the sign is kept  if north fold boundary
1098      REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) ::   &
1099         pt2d          ! 2D array on which the boundary condition is applied
1100      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    &
1101         cd_mpp        ! fill the overlap area only
1102      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries)
1103
1104      !! * Local variables
1105      INTEGER  ::   ji, jj, jl      ! dummy loop indices
1106      INTEGER  ::   &
1107         imigr, iihom, ijhom,    &  ! temporary integers
1108         iloc, ijt, iju             !    "          "
1109      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
1110      INTEGER  ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
1111      REAL(wp) ::   zland
1112      !!----------------------------------------------------------------------
1113
1114      IF( PRESENT( pval ) ) THEN      ! set land value (zero by default)
1115         zland = pval
1116      ELSE
1117         zland = 0.e0
1118      ENDIF
1119
1120      ! 1. standard boundary treatment
1121      ! ------------------------------
1122      IF (PRESENT(cd_mpp)) THEN
1123         DO jj = nlcj+1, jpj   ! only fill extra allows last line
1124            pt2d(1:nlci, jj) = pt2d(1:nlci, nlej)
1125         END DO
1126         DO ji = nlci+1, jpi   ! only fill extra allows last column
1127            pt2d(ji    , : ) = pt2d(nlei  , :   )
1128         END DO     
1129      ELSE     
1130
1131         !                                        ! East-West boundaries
1132         !                                        ! ====================
1133         IF( nbondi == 2 .AND.   &      ! Cyclic east-west
1134            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1135            pt2d( 1 ,:) = pt2d(jpim1,:)
1136            pt2d(jpi,:) = pt2d(  2  ,:)
1137
1138         ELSE                           ! ... closed
1139            SELECT CASE ( cd_type )
1140            CASE ( 'T', 'U', 'V', 'W' , 'I' )
1141               pt2d(     1       :jpreci,:) = zland
1142               pt2d(nlci-jpreci+1:jpi   ,:) = zland
1143            CASE ( 'F' )
1144               pt2d(nlci-jpreci+1:jpi   ,:) = zland
1145            END SELECT
1146         ENDIF
1147
1148         !                                        ! North-South boundaries
1149         !                                        ! ======================
1150         SELECT CASE ( cd_type )
1151         CASE ( 'T', 'U', 'V', 'W' , 'I' )
1152            pt2d(:,     1       :jprecj) = zland
1153            pt2d(:,nlcj-jprecj+1:jpj   ) = zland
1154         CASE ( 'F' )
1155            pt2d(:,nlcj-jprecj+1:jpj   ) = zland
1156         END SELECT
1157
1158      ENDIF
1159
1160
1161      ! 2. East and west directions
1162      ! ---------------------------
1163
1164      ! 2.1 Read Dirichlet lateral conditions
1165
1166      SELECT CASE ( nbondi )
1167      CASE ( -1, 0, 1 )    ! all except 2
1168         iihom = nlci-nreci
1169         DO jl = 1, jpreci
1170            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1171            t2we(:,jl,1) = pt2d(iihom +jl,:)
1172         END DO
1173      END SELECT
1174
1175      ! 2.2 Migrations
1176
1177#if defined key_mpp_shmem
1178      !! * SHMEM version
1179
1180      imigr = jpreci * jpj
1181
1182      SELECT CASE ( nbondi )
1183      CASE ( -1 )
1184         CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1185      CASE ( 0 )
1186         CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1187         CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1188      CASE ( 1 )
1189         CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1190      END SELECT
1191
1192      CALL barrier()
1193      CALL shmem_udcflush()
1194
1195#elif defined key_mpp_mpi
1196      !! * MPI version
1197
1198      imigr = jpreci * jpj
1199
1200      SELECT CASE ( nbondi )
1201      CASE ( -1 )
1202         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1203         CALL mpprecv( 1, t2ew(1,1,2), imigr )
1204         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1205      CASE ( 0 )
1206         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1207         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1208         CALL mpprecv( 1, t2ew(1,1,2), imigr )
1209         CALL mpprecv( 2, t2we(1,1,2), imigr )
1210         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1211         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1212      CASE ( 1 )
1213         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1214         CALL mpprecv( 2, t2we(1,1,2), imigr )
1215         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1216      END SELECT
1217
1218#endif
1219
1220      ! 2.3 Write Dirichlet lateral conditions
1221
1222      iihom = nlci - jpreci
1223      SELECT CASE ( nbondi )
1224      CASE ( -1 )
1225         DO jl = 1, jpreci
1226            pt2d(iihom+jl,:) = t2ew(:,jl,2)
1227         END DO
1228      CASE ( 0 )
1229         DO jl = 1, jpreci
1230            pt2d(jl      ,:) = t2we(:,jl,2)
1231            pt2d(iihom+jl,:) = t2ew(:,jl,2)
1232         END DO
1233      CASE ( 1 )
1234         DO jl = 1, jpreci
1235            pt2d(jl      ,:) = t2we(:,jl,2)
1236         END DO
1237      END SELECT
1238
1239
1240      ! 3. North and south directions
1241      ! -----------------------------
1242
1243      ! 3.1 Read Dirichlet lateral conditions
1244
1245      IF( nbondj /= 2 ) THEN
1246         ijhom = nlcj-nrecj
1247         DO jl = 1, jprecj
1248            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1249            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1250         END DO
1251      ENDIF
1252
1253      ! 3.2 Migrations
1254
1255#if defined key_mpp_shmem
1256      !! * SHMEM version
1257
1258      imigr = jprecj * jpi
1259
1260      SELECT CASE ( nbondj )
1261      CASE ( -1 )
1262         CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1263      CASE ( 0 )
1264         CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1265         CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1266      CASE ( 1 )
1267         CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1268      END SELECT
1269      CALL barrier()
1270      CALL shmem_udcflush()
1271
1272#elif defined key_mpp_mpi
1273      !! * MPI version
1274
1275      imigr = jprecj * jpi
1276
1277      SELECT CASE ( nbondj )
1278      CASE ( -1 )
1279         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1280         CALL mpprecv( 3, t2ns(1,1,2), imigr )
1281         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1282      CASE ( 0 )
1283         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1284         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1285         CALL mpprecv( 3, t2ns(1,1,2), imigr )
1286         CALL mpprecv( 4, t2sn(1,1,2), imigr )
1287         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1288         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1289      CASE ( 1 )
1290         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1291         CALL mpprecv( 4, t2sn(1,1,2), imigr )
1292         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1293      END SELECT
1294 
1295#endif
1296
1297      ! 3.3 Write Dirichlet lateral conditions
1298
1299      ijhom = nlcj - jprecj
1300
1301      SELECT CASE ( nbondj )
1302      CASE ( -1 )
1303         DO jl = 1, jprecj
1304            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1305         END DO
1306      CASE ( 0 )
1307         DO jl = 1, jprecj
1308            pt2d(:,jl      ) = t2sn(:,jl,2)
1309            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1310         END DO
1311      CASE ( 1 ) 
1312         DO jl = 1, jprecj
1313            pt2d(:,jl      ) = t2sn(:,jl,2)
1314         END DO
1315      END SELECT 
1316 
1317
1318      ! 4. north fold treatment
1319      ! -----------------------
1320 
1321      IF (PRESENT(cd_mpp)) THEN
1322         ! No north fold treatment (it is assumed to be already OK)
1323     
1324      ELSE     
1325
1326      ! 4.1 treatment without exchange (jpni odd)
1327     
1328      SELECT CASE ( jpni )
1329 
1330      CASE ( 1 ) ! only one proc along I, no mpp exchange
1331 
1332         SELECT CASE ( npolj )
1333 
1334         CASE ( 3 , 4 )   !  T pivot
1335            iloc = jpiglo - 2 * ( nimpp - 1 )
1336 
1337            SELECT CASE ( cd_type )
1338 
1339            CASE ( 'T' , 'S', 'W' )
1340               DO ji = 2, nlci
1341                  ijt=iloc-ji+2
1342                  pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1343               END DO
1344               DO ji = nlci/2+1, nlci
1345                  ijt=iloc-ji+2
1346                  pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1347               END DO
1348 
1349            CASE ( 'U' )
1350               DO ji = 1, nlci-1
1351                  iju=iloc-ji+1
1352                  pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1353               END DO
1354               DO ji = nlci/2, nlci-1
1355                  iju=iloc-ji+1
1356                  pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1357               END DO
1358 
1359            CASE ( 'V' )
1360               DO ji = 2, nlci
1361                  ijt=iloc-ji+2
1362                  pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1363                  pt2d(ji,nlcj  ) = psgn * pt2d(ijt,nlcj-3)
1364               END DO
1365 
1366            CASE ( 'F', 'G' )
1367               DO ji = 1, nlci-1
1368                  iju=iloc-ji+1
1369                  pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-2)
1370                  pt2d(ji,nlcj  ) = psgn * pt2d(iju,nlcj-3)
1371               END DO
1372 
1373            CASE ( 'I' )                                  ! ice U-V point
1374               pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1375               DO ji = 3, nlci
1376                  iju = iloc - ji + 3
1377                  pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1378               END DO
1379 
1380            END SELECT
1381 
1382         CASE ( 5 , 6 )                 ! F pivot
1383            iloc=jpiglo-2*(nimpp-1)
1384 
1385            SELECT CASE (cd_type )
1386 
1387            CASE ( 'T', 'S', 'W' )
1388               DO ji = 1, nlci
1389                  ijt=iloc-ji+1
1390                  pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1391               END DO
1392 
1393            CASE ( 'U' )
1394               DO ji = 1, nlci-1
1395                  iju=iloc-ji
1396                  pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1397               END DO
1398
1399            CASE ( 'V' )
1400               DO ji = 1, nlci
1401                  ijt=iloc-ji+1
1402                  pt2d(ji,nlcj  ) = psgn * pt2d(ijt,nlcj-2)
1403               END DO
1404               DO ji = nlci/2+1, nlci
1405                  ijt=iloc-ji+1
1406                  pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1407               END DO
1408 
1409            CASE ( 'F', 'G' )
1410               DO ji = 1, nlci-1
1411                  iju=iloc-ji
1412                  pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1413               END DO
1414               DO ji = nlci/2+1, nlci-1
1415                  iju=iloc-ji
1416                  pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1417               END DO
1418 
1419            CASE ( 'I' )                                  ! ice U-V point
1420               pt2d( 2 ,nlcj) = zland
1421               DO ji = 2 , nlci-1
1422                  ijt = iloc - ji + 2
1423                  pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) )
1424               END DO
1425 
1426            END SELECT   ! cd_type
1427 
1428         END SELECT   ! npolj
1429
1430      CASE DEFAULT   ! more than 1 proc along I
1431         IF( npolj /= 0 )   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! only for northern procs.
1432
1433      END SELECT   ! jpni
1434
1435      ENDIF
1436
1437      ! 5. East and west directions
1438      ! ---------------------------
1439
1440      SELECT CASE ( npolj )
1441
1442      CASE ( 3, 4, 5, 6 )
1443
1444         ! 5.1 Read Dirichlet lateral conditions
1445
1446         SELECT CASE ( nbondi )
1447         CASE ( -1, 0, 1 )
1448            iihom = nlci-nreci
1449            DO jl = 1, jpreci
1450               DO jj = 1, jpj
1451                  t2ew(jj,jl,1) = pt2d(jpreci+jl,jj)
1452                  t2we(jj,jl,1) = pt2d(iihom +jl,jj)
1453               END DO
1454            END DO
1455         END SELECT
1456
1457         ! 5.2 Migrations
1458
1459#if defined key_mpp_shmem
1460         !! * SHMEM version
1461
1462         imigr=jpreci*jpj
1463
1464         SELECT CASE ( nbondi )
1465         CASE ( -1 )
1466            CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1467         CASE ( 0 )
1468            CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1469            CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1470         CASE ( 1 )
1471            CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1472         END SELECT
1473
1474         CALL barrier()
1475         CALL shmem_udcflush()
1476 
1477#elif defined key_mpp_mpi
1478         !! * MPI version
1479 
1480         imigr=jpreci*jpj
1481 
1482         SELECT CASE ( nbondi )
1483         CASE ( -1 )
1484            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1485            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1486            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1487         CASE ( 0 )
1488            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1489            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1490            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1491            CALL mpprecv( 2, t2we(1,1,2), imigr )
1492            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1493            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1494         CASE ( 1 )
1495            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1496            CALL mpprecv( 2, t2we(1,1,2), imigr )
1497            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1498         END SELECT 
1499#endif
1500
1501         ! 5.3 Write Dirichlet lateral conditions
1502 
1503         iihom = nlci - jpreci
1504 
1505         SELECT CASE ( nbondi )
1506         CASE ( -1 )
1507            DO jl = 1, jpreci
1508               pt2d(iihom+jl,:) = t2ew(:,jl,2)
1509            END DO
1510         CASE ( 0 )
1511            DO jl = 1, jpreci
1512               pt2d(jl      ,:) = t2we(:,jl,2)
1513               pt2d(iihom+jl,:) = t2ew(:,jl,2)
1514            END DO
1515         CASE ( 1 )
1516            DO jl = 1, jpreci
1517               pt2d(jl,:) = t2we(:,jl,2)
1518            END DO
1519         END SELECT
1520 
1521      END SELECT   ! npolj
1522 
1523   END SUBROUTINE mpp_lnk_2d
1524
1525
1526   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1527      !!----------------------------------------------------------------------
1528      !!                  ***  routine mpp_lnk_3d_gather  ***
1529      !!
1530      !! ** Purpose :   Message passing manadgement for two 3D arrays
1531      !!
1532      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1533      !!      between processors following neighboring subdomains.
1534      !!            domain parameters
1535      !!                    nlci   : first dimension of the local subdomain
1536      !!                    nlcj   : second dimension of the local subdomain
1537      !!                    nbondi : mark for "east-west local boundary"
1538      !!                    nbondj : mark for "north-south local boundary"
1539      !!                    noea   : number for local neighboring processors
1540      !!                    nowe   : number for local neighboring processors
1541      !!                    noso   : number for local neighboring processors
1542      !!                    nono   : number for local neighboring processors
1543      !!
1544      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
1545      !!
1546      !!----------------------------------------------------------------------
1547      !! * Arguments
1548      CHARACTER(len=1) , INTENT( in ) ::   &
1549         cd_type1, cd_type2       ! define the nature of ptab array grid-points
1550         !                        ! = T , U , V , F , W points
1551         !                        ! = S : T-point, north fold treatment ???
1552         !                        ! = G : F-point, north fold treatment ???
1553      REAL(wp), INTENT( in ) ::   &
1554         psgn          ! control of the sign change
1555         !             !   = -1. , the sign is changed if north fold boundary
1556         !             !   =  1. , the sign is kept  if north fold boundary
1557      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
1558         ptab1, ptab2             ! 3D array on which the boundary condition is applied
1559
1560      !! * Local variables
1561      INTEGER ::   ji, jk, jl   ! dummy loop indices
1562      INTEGER ::   imigr, iihom, ijhom, iloc, ijt, iju   ! temporary integers
1563      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
1564      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
1565      !!----------------------------------------------------------------------
1566
1567      ! 1. standard boundary treatment
1568      ! ------------------------------
1569      !                                        ! East-West boundaries
1570      !                                        ! ====================
1571      IF( nbondi == 2 .AND.   &      ! Cyclic east-west
1572         &   (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1573         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1574         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
1575         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1576         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
1577
1578      ELSE                           ! closed
1579         SELECT CASE ( cd_type1 )
1580         CASE ( 'T', 'U', 'V', 'W' )
1581            ptab1(     1       :jpreci,:,:) = 0.e0
1582            ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1583         CASE ( 'F' )
1584            ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1585         END SELECT
1586         SELECT CASE ( cd_type2 )
1587         CASE ( 'T', 'U', 'V', 'W' )
1588            ptab2(     1       :jpreci,:,:) = 0.e0
1589            ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1590         CASE ( 'F' )
1591            ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1592         END SELECT
1593      ENDIF
1594
1595      !                                        ! North-South boundaries
1596      !                                        ! ======================
1597      SELECT CASE ( cd_type1 )
1598      CASE ( 'T', 'U', 'V', 'W' )
1599         ptab1(:,     1       :jprecj,:) = 0.e0
1600         ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1601      CASE ( 'F' )
1602         ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1603      END SELECT
1604
1605      SELECT CASE ( cd_type2 )
1606      CASE ( 'T', 'U', 'V', 'W' )
1607         ptab2(:,     1       :jprecj,:) = 0.e0
1608         ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1609      CASE ( 'F' )
1610         ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1611      END SELECT
1612
1613
1614      ! 2. East and west directions exchange
1615      ! ------------------------------------
1616
1617      ! 2.1 Read Dirichlet lateral conditions
1618
1619      SELECT CASE ( nbondi )
1620      CASE ( -1, 0, 1 )    ! all exept 2
1621         iihom = nlci-nreci
1622         DO jl = 1, jpreci
1623            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1624            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1625            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1626            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1627         END DO
1628      END SELECT
1629
1630      ! 2.2 Migrations
1631
1632#if defined key_mpp_shmem
1633      !! * SHMEM version
1634
1635      imigr = jpreci * jpj * jpk *2
1636
1637      SELECT CASE ( nbondi )
1638      CASE ( -1 )
1639         CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1640      CASE ( 0 )
1641         CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1642         CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1643      CASE ( 1 )
1644         CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1645      END SELECT
1646
1647      CALL barrier()
1648      CALL shmem_udcflush()
1649
1650#elif defined key_mpp_mpi
1651      !! * Local variables   (MPI version)
1652
1653      imigr = jpreci * jpj * jpk *2
1654
1655      SELECT CASE ( nbondi ) 
1656      CASE ( -1 )
1657         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
1658         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1659         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1660      CASE ( 0 )
1661         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1662         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
1663         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1664         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1665         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1666         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1667      CASE ( 1 )
1668         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1669         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1670         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1671      END SELECT
1672#endif
1673
1674      ! 2.3 Write Dirichlet lateral conditions
1675
1676      iihom = nlci-jpreci
1677
1678      SELECT CASE ( nbondi )
1679      CASE ( -1 )
1680         DO jl = 1, jpreci
1681            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1682            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1683         END DO
1684      CASE ( 0 ) 
1685         DO jl = 1, jpreci
1686            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
1687            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1688            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
1689            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1690         END DO
1691      CASE ( 1 )
1692         DO jl = 1, jpreci
1693            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
1694            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
1695         END DO
1696      END SELECT
1697
1698
1699      ! 3. North and south directions
1700      ! -----------------------------
1701
1702      ! 3.1 Read Dirichlet lateral conditions
1703
1704      IF( nbondj /= 2 ) THEN
1705         ijhom = nlcj-nrecj
1706         DO jl = 1, jprecj
1707            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1708            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1709            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1710            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1711         END DO
1712      ENDIF
1713
1714      ! 3.2 Migrations
1715
1716#if defined key_mpp_shmem
1717      !! * SHMEM version
1718
1719      imigr = jprecj * jpi * jpk * 2
1720
1721      SELECT CASE ( nbondj )
1722      CASE ( -1 )
1723         CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1724      CASE ( 0 )
1725         CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1,1), imigr, noso )
1726         CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1727      CASE ( 1 )
1728         CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1;,1), imigr, noso )
1729      END SELECT
1730
1731      CALL barrier()
1732      CALL shmem_udcflush()
1733
1734#elif defined key_mpp_mpi
1735      !! * Local variables   (MPI version)
1736 
1737      imigr=jprecj * jpi * jpk * 2
1738
1739      SELECT CASE ( nbondj )     
1740      CASE ( -1 )
1741         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1742         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1743         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1744      CASE ( 0 )
1745         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1746         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1747         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1748         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1749         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1750         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1751      CASE ( 1 ) 
1752         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1753         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1754         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1755      END SELECT
1756
1757#endif
1758
1759      ! 3.3 Write Dirichlet lateral conditions
1760
1761      ijhom = nlcj-jprecj
1762
1763      SELECT CASE ( nbondj )
1764      CASE ( -1 )
1765         DO jl = 1, jprecj
1766            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1767            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1768         END DO
1769      CASE ( 0 ) 
1770         DO jl = 1, jprecj
1771            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2)
1772            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1773            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2)
1774            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1775         END DO
1776      CASE ( 1 )
1777         DO jl = 1, jprecj
1778            ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
1779            ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
1780         END DO
1781      END SELECT
1782
1783
1784      ! 4. north fold treatment
1785      ! -----------------------
1786
1787      ! 4.1 treatment without exchange (jpni odd)
1788      !     T-point pivot 
1789
1790      SELECT CASE ( jpni )
1791
1792      CASE ( 1 )  ! only one proc along I, no mpp exchange
1793
1794      SELECT CASE ( npolj )
1795 
1796         CASE ( 3 , 4 )    ! T pivot
1797            iloc = jpiglo - 2 * ( nimpp - 1 )
1798
1799            SELECT CASE ( cd_type1 )
1800
1801            CASE ( 'T' , 'S', 'W' )
1802               DO jk = 1, jpk
1803                  DO ji = 2, nlci
1804                     ijt=iloc-ji+2
1805                     ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1806                  END DO
1807                  DO ji = nlci/2+1, nlci
1808                     ijt=iloc-ji+2
1809                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1810                  END DO
1811               END DO
1812         
1813            CASE ( 'U' )
1814               DO jk = 1, jpk
1815                  DO ji = 1, nlci-1
1816                     iju=iloc-ji+1
1817                     ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1818                  END DO
1819                  DO ji = nlci/2, nlci-1
1820                     iju=iloc-ji+1
1821                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1822                  END DO
1823               END DO
1824
1825            CASE ( 'V' )
1826               DO jk = 1, jpk
1827                  DO ji = 2, nlci
1828                     ijt=iloc-ji+2
1829                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1830                     ptab1(ji,nlcj  ,jk) = psgn * ptab1(ijt,nlcj-3,jk)
1831                  END DO
1832               END DO
1833
1834            CASE ( 'F', 'G' )
1835               DO jk = 1, jpk
1836                  DO ji = 1, nlci-1
1837                     iju=iloc-ji+1
1838                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-2,jk)
1839                     ptab1(ji,nlcj  ,jk) = psgn * ptab1(iju,nlcj-3,jk)
1840                  END DO
1841               END DO
1842 
1843            END SELECT
1844           
1845            SELECT CASE ( cd_type2 )
1846
1847            CASE ( 'T' , 'S', 'W' )
1848               DO jk = 1, jpk
1849                  DO ji = 2, nlci
1850                     ijt=iloc-ji+2
1851                     ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1852                  END DO
1853                  DO ji = nlci/2+1, nlci
1854                     ijt=iloc-ji+2
1855                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1856                  END DO
1857               END DO
1858         
1859            CASE ( 'U' )
1860               DO jk = 1, jpk
1861                  DO ji = 1, nlci-1
1862                     iju=iloc-ji+1
1863                     ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1864                  END DO
1865                  DO ji = nlci/2, nlci-1
1866                     iju=iloc-ji+1
1867                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1868                  END DO
1869               END DO
1870
1871            CASE ( 'V' )
1872               DO jk = 1, jpk
1873                  DO ji = 2, nlci
1874                     ijt=iloc-ji+2
1875                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1876                     ptab2(ji,nlcj  ,jk) = psgn * ptab2(ijt,nlcj-3,jk)
1877                  END DO
1878               END DO
1879
1880            CASE ( 'F', 'G' )
1881               DO jk = 1, jpk
1882                  DO ji = 1, nlci-1
1883                     iju=iloc-ji+1
1884                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-2,jk)
1885                     ptab2(ji,nlcj  ,jk) = psgn * ptab2(iju,nlcj-3,jk)
1886                  END DO
1887               END DO
1888 
1889          END SELECT
1890       
1891         CASE ( 5 , 6 ) ! F pivot
1892            iloc=jpiglo-2*(nimpp-1)
1893 
1894            SELECT CASE ( cd_type1 )
1895
1896            CASE ( 'T' , 'S', 'W' )
1897               DO jk = 1, jpk
1898                  DO ji = 1, nlci
1899                     ijt=iloc-ji+1
1900                     ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1901                  END DO
1902               END DO
1903
1904            CASE ( 'U' )
1905               DO jk = 1, jpk
1906                  DO ji = 1, nlci-1
1907                     iju=iloc-ji
1908                     ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-1,jk)
1909                  END DO
1910               END DO
1911
1912            CASE ( 'V' )
1913               DO jk = 1, jpk
1914                  DO ji = 1, nlci
1915                     ijt=iloc-ji+1
1916                     ptab1(ji,nlcj  ,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1917                  END DO
1918                  DO ji = nlci/2+1, nlci
1919                     ijt=iloc-ji+1
1920                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1921                  END DO
1922               END DO
1923
1924            CASE ( 'F', 'G' )
1925               DO jk = 1, jpk
1926                  DO ji = 1, nlci-1
1927                     iju=iloc-ji
1928                     ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1929                  END DO
1930                  DO ji = nlci/2+1, nlci-1
1931                     iju=iloc-ji
1932                     ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1933                  END DO
1934               END DO
1935            END SELECT  ! cd_type1
1936
1937            SELECT CASE ( cd_type2 )
1938
1939            CASE ( 'T' , 'S', 'W' )
1940               DO jk = 1, jpk
1941                  DO ji = 1, nlci
1942                     ijt=iloc-ji+1
1943                     ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1944                  END DO
1945               END DO
1946
1947            CASE ( 'U' )
1948               DO jk = 1, jpk
1949                  DO ji = 1, nlci-1
1950                     iju=iloc-ji
1951                     ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-1,jk)
1952                  END DO
1953               END DO
1954
1955            CASE ( 'V' )
1956               DO jk = 1, jpk
1957                  DO ji = 1, nlci
1958                     ijt=iloc-ji+1
1959                     ptab2(ji,nlcj  ,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1960                  END DO
1961                  DO ji = nlci/2+1, nlci
1962                     ijt=iloc-ji+1
1963                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1964                  END DO
1965               END DO
1966
1967            CASE ( 'F', 'G' )
1968               DO jk = 1, jpk
1969                  DO ji = 1, nlci-1
1970                     iju=iloc-ji
1971                     ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1972                  END DO
1973                  DO ji = nlci/2+1, nlci-1
1974                     iju=iloc-ji
1975                     ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1976                  END DO
1977               END DO
1978
1979            END SELECT  ! cd_type2
1980
1981         END SELECT     !  npolj
1982 
1983      CASE DEFAULT ! more than 1 proc along I
1984         IF ( npolj /= 0 ) THEN
1985            CALL mpp_lbc_north (ptab1, cd_type1, psgn)  ! only for northern procs.
1986            CALL mpp_lbc_north (ptab2, cd_type2, psgn)  ! only for northern procs.
1987         ENDIF
1988
1989      END SELECT ! jpni
1990
1991
1992      ! 5. East and west directions exchange
1993      ! ------------------------------------
1994
1995      SELECT CASE ( npolj )
1996
1997      CASE ( 3, 4, 5, 6 )
1998
1999         ! 5.1 Read Dirichlet lateral conditions
2000
2001         SELECT CASE ( nbondi )
2002
2003         CASE ( -1, 0, 1 )
2004            iihom = nlci-nreci
2005            DO jl = 1, jpreci
2006               t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
2007               t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
2008               t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
2009               t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
2010            END DO
2011
2012         END SELECT
2013
2014         ! 5.2 Migrations
2015
2016#if defined key_mpp_shmem
2017         !! SHMEM version
2018
2019         imigr = jpreci * jpj * jpk * 2
2020
2021         SELECT CASE ( nbondi )
2022         CASE ( -1 )
2023            CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2024         CASE ( 0 )
2025            CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2026            CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2027         CASE ( 1 )
2028            CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2029         END SELECT
2030
2031         CALL barrier()
2032         CALL shmem_udcflush()
2033
2034#elif defined key_mpp_mpi
2035         !! MPI version
2036
2037         imigr = jpreci * jpj * jpk * 2
2038 
2039         SELECT CASE ( nbondi )
2040         CASE ( -1 )
2041            CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
2042            CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2043            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2044         CASE ( 0 )
2045            CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2046            CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
2047            CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2048            CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2049            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2050            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2051         CASE ( 1 )
2052            CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2053            CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2054            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2055         END SELECT
2056#endif
2057
2058         ! 5.3 Write Dirichlet lateral conditions
2059
2060         iihom = nlci-jpreci
2061
2062         SELECT CASE ( nbondi)
2063         CASE ( -1 )
2064            DO jl = 1, jpreci
2065               ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2066               ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2067            END DO
2068         CASE ( 0 ) 
2069            DO jl = 1, jpreci
2070               ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
2071               ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2072               ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
2073               ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2074            END DO
2075         CASE ( 1 )
2076            DO jl = 1, jpreci
2077               ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
2078               ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
2079            END DO
2080         END SELECT
2081
2082      END SELECT    ! npolj
2083
2084   END SUBROUTINE mpp_lnk_3d_gather
2085
2086
2087   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
2088      !!----------------------------------------------------------------------
2089      !!                  ***  routine mpp_lnk_2d_e  ***
2090      !!                 
2091      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
2092      !!
2093      !! ** Method  :   Use mppsend and mpprecv function for passing mask
2094      !!      between processors following neighboring subdomains.
2095      !!            domain parameters
2096      !!                    nlci   : first dimension of the local subdomain
2097      !!                    nlcj   : second dimension of the local subdomain
2098      !!                    jpr2di : number of rows for extra outer halo
2099      !!                    jpr2dj : number of columns for extra outer halo
2100      !!                    nbondi : mark for "east-west local boundary"
2101      !!                    nbondj : mark for "north-south local boundary"
2102      !!                    noea   : number for local neighboring processors
2103      !!                    nowe   : number for local neighboring processors
2104      !!                    noso   : number for local neighboring processors
2105      !!                    nono   : number for local neighboring processors
2106      !!   
2107      !! History :
2108      !!       
2109      !!   9.0  !  05-09  (R. Benshila, G. Madec)  original code
2110      !!
2111      !!----------------------------------------------------------------------
2112      !! * Arguments
2113      CHARACTER(len=1) , INTENT( in ) ::   &
2114         cd_type       ! define the nature of pt2d array grid-points
2115         !             !  = T , U , V , F , W
2116         !             !  = S : T-point, north fold treatment
2117         !             !  = G : F-point, north fold treatment
2118         !             !  = I : sea-ice velocity at F-point with index shift
2119      REAL(wp), INTENT( in ) ::   &
2120         psgn          ! control of the sign change
2121         !             !   = -1. , the sign is changed if north fold boundary
2122         !             !   =  1. , the sign is kept  if north fold boundary
2123      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) ::   &
2124         pt2d          ! 2D array on which the boundary condition is applied
2125
2126      !! * Local variables
2127      INTEGER  ::   ji, jl      ! dummy loop indices
2128      INTEGER  ::   &
2129         imigr, iihom, ijhom,    &  ! temporary integers
2130         iloc, ijt, iju             !    "          "
2131      INTEGER  ::   &
2132         ipreci, iprecj             ! temporary integers
2133      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for isend
2134      INTEGER  ::   ml_stat(MPI_STATUS_SIZE)     ! for isend
2135     !!---------------------------------------------------------------------
2136
2137      ! take into account outer extra 2D overlap area
2138      ipreci = jpreci + jpr2di
2139      iprecj = jprecj + jpr2dj
2140
2141
2142      ! 1. standard boundary treatment
2143      ! ------------------------------
2144
2145      !                                        ! East-West boundaries
2146      !                                        ! ====================
2147      IF( nbondi == 2 .AND.   &      ! Cyclic east-west
2148         &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
2149         pt2d(1-jpr2di:     1    ,:) = pt2d(jpim1-jpr2di:  jpim1 ,:)
2150         pt2d(   jpi  :jpi+jpr2di,:) = pt2d(     2      :2+jpr2di,:)
2151
2152      ELSE                           ! ... closed
2153         SELECT CASE ( cd_type )
2154         CASE ( 'T', 'U', 'V', 'W' , 'I' )
2155            pt2d(  1-jpr2di   :jpreci    ,:) = 0.e0
2156            pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2157         CASE ( 'F' )
2158            pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2159         END SELECT
2160      ENDIF
2161
2162      !                                        ! North-South boundaries
2163      !                                        ! ======================
2164      SELECT CASE ( cd_type )
2165      CASE ( 'T', 'U', 'V', 'W' , 'I' )
2166         pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0
2167         pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2168      CASE ( 'F' )
2169         pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2170      END SELECT
2171
2172
2173      ! 2. East and west directions
2174      ! ---------------------------
2175
2176      ! 2.1 Read Dirichlet lateral conditions
2177
2178      SELECT CASE ( nbondi )
2179      CASE ( -1, 0, 1 )    ! all except 2
2180         iihom = nlci-nreci-jpr2di
2181         DO jl = 1, ipreci
2182            tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2183            tr2we(:,jl,1) = pt2d(iihom +jl,:)
2184         END DO
2185      END SELECT
2186
2187      ! 2.2 Migrations
2188
2189#if defined key_mpp_shmem
2190      !! * SHMEM version
2191
2192      imigr = ipreci * ( jpj + 2*jpr2dj)
2193
2194      SELECT CASE ( nbondi )
2195      CASE ( -1 )
2196         CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2197      CASE ( 0 )
2198         CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2199         CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2200      CASE ( 1 )
2201         CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2202      END SELECT
2203
2204      CALL barrier()
2205      CALL shmem_udcflush()
2206
2207#elif defined key_mpp_mpi
2208      !! * MPI version
2209
2210      imigr = ipreci * ( jpj + 2*jpr2dj)
2211
2212      SELECT CASE ( nbondi )
2213      CASE ( -1 )
2214         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2215         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2216         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2217      CASE ( 0 )
2218         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2219         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2220         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2221         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2222         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2223         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2224      CASE ( 1 )
2225         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2226         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2227         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2228      END SELECT
2229
2230#endif
2231
2232      ! 2.3 Write Dirichlet lateral conditions
2233
2234      iihom = nlci - jpreci
2235
2236      SELECT CASE ( nbondi )
2237      CASE ( -1 )
2238         DO jl = 1, ipreci
2239            pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2240         END DO
2241      CASE ( 0 )
2242         DO jl = 1, ipreci
2243            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2244            pt2d( iihom+jl,:) = tr2ew(:,jl,2)
2245         END DO
2246      CASE ( 1 )
2247         DO jl = 1, ipreci
2248            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2249         END DO
2250      END SELECT
2251
2252
2253      ! 3. North and south directions
2254      ! -----------------------------
2255
2256      ! 3.1 Read Dirichlet lateral conditions
2257
2258      IF( nbondj /= 2 ) THEN
2259         ijhom = nlcj-nrecj-jpr2dj
2260         DO jl = 1, iprecj
2261            tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
2262            tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
2263         END DO
2264      ENDIF
2265
2266      ! 3.2 Migrations
2267
2268#if defined key_mpp_shmem
2269      !! * SHMEM version
2270
2271      imigr = iprecj * ( jpi + 2*jpr2di )
2272
2273      SELECT CASE ( nbondj )
2274      CASE ( -1 )
2275         CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2276      CASE ( 0 )
2277         CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2278         CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2279      CASE ( 1 )
2280         CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2281      END SELECT
2282      CALL barrier()
2283      CALL shmem_udcflush()
2284
2285#elif defined key_mpp_mpi
2286      !! * MPI version
2287
2288      imigr = iprecj * ( jpi + 2*jpr2di )
2289
2290      SELECT CASE ( nbondj )
2291      CASE ( -1 )
2292         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
2293         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2294         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2295      CASE ( 0 )
2296         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2297         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
2298         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2299         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2300         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2301         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2302      CASE ( 1 )
2303         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2304         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2305         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2306      END SELECT
2307 
2308#endif
2309
2310      ! 3.3 Write Dirichlet lateral conditions
2311
2312      ijhom = nlcj - jprecj 
2313
2314      SELECT CASE ( nbondj )
2315      CASE ( -1 )
2316         DO jl = 1, iprecj
2317            pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
2318         END DO
2319      CASE ( 0 )
2320         DO jl = 1, iprecj
2321            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2322            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
2323         END DO
2324      CASE ( 1 ) 
2325         DO jl = 1, iprecj
2326            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2327         END DO
2328      END SELECT 
2329 
2330
2331      ! 4. north fold treatment
2332      ! -----------------------
2333 
2334      ! 4.1 treatment without exchange (jpni odd)
2335     
2336      SELECT CASE ( jpni )
2337 
2338      CASE ( 1 ) ! only one proc along I, no mpp exchange
2339 
2340         SELECT CASE ( npolj )
2341 
2342         CASE ( 3 , 4 )   !  T pivot
2343            iloc = jpiglo - 2 * ( nimpp - 1 )
2344 
2345            SELECT CASE ( cd_type )
2346 
2347            CASE ( 'T', 'S', 'W' )
2348               DO jl = 0, iprecj-1
2349                  DO ji = 2-jpr2di, nlci+jpr2di
2350                     ijt=iloc-ji+2
2351                     pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2352                  END DO
2353               END DO
2354               DO ji = nlci/2+1, nlci+jpr2di
2355                  ijt=iloc-ji+2
2356                  pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2357               END DO
2358 
2359            CASE ( 'U' )
2360               DO jl =0, iprecj-1
2361                  DO ji = 1-jpr2di, nlci-1-jpr2di
2362                     iju=iloc-ji+1
2363                     pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2364                  END DO
2365               END DO
2366               DO ji = nlci/2, nlci-1+jpr2di
2367                  iju=iloc-ji+1
2368                  pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2369               END DO
2370 
2371            CASE ( 'V' )
2372               DO jl = -1, iprecj-1
2373                  DO ji = 2-jpr2di, nlci+jpr2di
2374                     ijt=iloc-ji+2
2375                     pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-3-jl)
2376                  END DO
2377               END DO
2378 
2379            CASE ( 'F', 'G' )
2380               DO jl = -1, iprecj-1
2381                  DO ji = 1-jpr2di, nlci-1+jpr2di
2382                     iju=iloc-ji+1
2383                     pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-3-jl)
2384                  END DO
2385               END DO
2386 
2387            CASE ( 'I' )                                  ! ice U-V point
2388               DO jl = 0, iprecj-1
2389                  pt2d(2,nlcj+jl) = psgn * pt2d(3,nlcj-1-jl)
2390                  DO ji = 3, nlci+jpr2di
2391                     iju = iloc - ji + 3
2392                     pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2393                  END DO
2394               END DO
2395 
2396            END SELECT
2397 
2398         CASE ( 5 , 6 )                 ! F pivot
2399            iloc=jpiglo-2*(nimpp-1)
2400 
2401            SELECT CASE (cd_type )
2402 
2403            CASE ( 'T', 'S', 'W' )
2404               DO jl = 0, iprecj-1
2405                  DO ji = 1-jpr2di, nlci+jpr2di
2406                     ijt=iloc-ji+1
2407                     pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-1-jl)
2408                  END DO
2409               END DO
2410 
2411            CASE ( 'U' )
2412               DO jl = 0, iprecj-1
2413                  DO ji = 1-jpr2di, nlci-1+jpr2di
2414                     iju=iloc-ji
2415                     pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2416                  END DO
2417               END DO
2418 
2419            CASE ( 'V' )
2420               DO jl = 0, iprecj-1
2421                  DO ji = 1-jpr2di, nlci+jpr2di
2422                     ijt=iloc-ji+1
2423                     pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2424                  END DO
2425               END DO
2426               DO ji = nlci/2+1, nlci+jpr2di
2427                  ijt=iloc-ji+1
2428                  pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2429               END DO
2430 
2431            CASE ( 'F', 'G' )
2432               DO jl = 0, iprecj-1
2433                  DO ji = 1-jpr2di, nlci-1+jpr2di
2434                     iju=iloc-ji
2435                     pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2436                  END DO
2437               END DO
2438               DO ji = nlci/2+1, nlci-1+jpr2di
2439                  iju=iloc-ji
2440                  pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2441               END DO
2442 
2443            CASE ( 'I' )                                  ! ice U-V point
2444               pt2d( 2 ,nlcj) = 0.e0
2445               DO jl = 0, iprecj-1
2446                  DO ji = 2 , nlci-1+jpr2di
2447                     ijt = iloc - ji + 2
2448                     pt2d(ji,nlcj+jl)= 0.5 * ( pt2d(ji,nlcj-1-jl) + psgn * pt2d(ijt,nlcj-1-jl) )
2449                  END DO
2450               END DO
2451 
2452            END SELECT   ! cd_type
2453 
2454         END SELECT   ! npolj
2455
2456      CASE DEFAULT   ! more than 1 proc along I
2457         IF( npolj /= 0 )   CALL mpp_lbc_north_e( pt2d, cd_type, psgn )   ! only for northern procs
2458         
2459      END SELECT   ! jpni
2460
2461
2462      ! 5. East and west directions
2463      ! ---------------------------
2464
2465      SELECT CASE ( npolj )
2466
2467      CASE ( 3, 4, 5, 6 )
2468
2469         ! 5.1 Read Dirichlet lateral conditions
2470
2471         SELECT CASE ( nbondi )
2472         CASE ( -1, 0, 1 )
2473            iihom = nlci-nreci-jpr2di
2474            DO jl = 1, ipreci
2475               tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2476               tr2we(:,jl,1) = pt2d(iihom +jl,:)
2477            END DO
2478         END SELECT
2479
2480         ! 5.2 Migrations
2481
2482#if defined key_mpp_shmem
2483         !! * SHMEM version
2484
2485         imigr = ipreci * ( jpj + 2*jpr2dj )
2486
2487         SELECT CASE ( nbondi )
2488         CASE ( -1 )
2489            CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2490         CASE ( 0 )
2491            CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2492            CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2493         CASE ( 1 )
2494            CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2495         END SELECT
2496
2497         CALL barrier()
2498         CALL shmem_udcflush()
2499 
2500#elif defined key_mpp_mpi
2501         !! * MPI version
2502 
2503         imigr=ipreci* ( jpj + 2*jpr2dj )
2504 
2505         SELECT CASE ( nbondi )
2506         CASE ( -1 )
2507            CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2508            CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2509            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2510         CASE ( 0 )
2511            CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2512            CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2513            CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2514            CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2515            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2516            IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2517         CASE ( 1 )
2518            CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2519            CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2520            IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2521         END SELECT 
2522#endif
2523
2524         ! 5.3 Write Dirichlet lateral conditions
2525 
2526         iihom = nlci - jpreci
2527 
2528         SELECT CASE ( nbondi )
2529         CASE ( -1 )
2530            DO jl = 1, ipreci
2531               pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2532            END DO
2533         CASE ( 0 )
2534            DO jl = 1, ipreci
2535               pt2d(jl- jpr2di,:) = tr2we(:,jl,2)
2536               pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2537            END DO
2538         CASE ( 1 )
2539            DO jl = 1, ipreci
2540               pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2541            END DO
2542         END SELECT
2543 
2544      END SELECT   ! npolj
2545 
2546   END SUBROUTINE mpp_lnk_2d_e
2547
2548
2549   SUBROUTINE mpplnks( ptab )
2550      !!----------------------------------------------------------------------
2551      !!                  ***  routine mpplnks  ***
2552      !!
2553      !! ** Purpose :   Message passing manadgement for add 2d array local boundary
2554      !!
2555      !! ** Method  :   Use mppsend and mpprecv function for passing mask between
2556      !!       processors following neighboring subdomains.
2557      !!            domain parameters
2558      !!                    nlci   : first dimension of the local subdomain
2559      !!                    nlcj   : second dimension of the local subdomain
2560      !!                    nbondi : mark for "east-west local boundary"
2561      !!                    nbondj : mark for "north-south local boundary"
2562      !!                    noea   : number for local neighboring processors
2563      !!                    nowe   : number for local neighboring processors
2564      !!                    noso   : number for local neighboring processors
2565      !!                    nono   : number for local neighboring processors
2566      !!
2567      !!----------------------------------------------------------------------
2568      !! * Arguments
2569      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   &
2570         ptab                     ! 2D array
2571 
2572      !! * Local variables
2573      INTEGER ::   ji, jl         ! dummy loop indices
2574      INTEGER ::   &
2575         imigr, iihom, ijhom      ! temporary integers
2576      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
2577      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
2578      !!----------------------------------------------------------------------
2579
2580
2581      ! 1. north fold treatment
2582      ! -----------------------
2583
2584      ! 1.1 treatment without exchange (jpni odd)
2585 
2586      SELECT CASE ( npolj )
2587      CASE ( 4 )
2588         DO ji = 1, nlci
2589            ptab(ji,nlcj-2) = ptab(ji,nlcj-2) + t2p1(ji,1,1)
2590         END DO
2591      CASE ( 6 )
2592         DO ji = 1, nlci
2593            ptab(ji,nlcj-1) = ptab(ji,nlcj-1) + t2p1(ji,1,1)
2594         END DO
2595
2596      ! 1.2 treatment with exchange (jpni greater than 1)
2597      !
2598      CASE ( 3 )
2599#if defined key_mpp_shmem
2600 
2601         !! * SHMEN version
2602 
2603         imigr=jprecj*jpi
2604 
2605         CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2606         CALL barrier()
2607         CALL shmem_udcflush()
2608
2609#  elif defined key_mpp_mpi
2610       !! * MPI version
2611
2612       imigr=jprecj*jpi
2613
2614       CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2615       CALL mpprecv(3,t2p1(1,1,2),imigr)
2616       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2617
2618#endif     
2619
2620       ! Write north fold conditions
2621
2622       DO ji = 1, nlci
2623          ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2)
2624       END DO
2625
2626    CASE ( 5 )
2627
2628#if defined key_mpp_shmem
2629
2630       !! * SHMEN version
2631
2632       imigr=jprecj*jpi
2633
2634       CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2635       CALL barrier()
2636       CALL shmem_udcflush()
2637
2638#  elif defined key_mpp_mpi
2639       !! * Local variables   (MPI version)
2640
2641       imigr=jprecj*jpi
2642
2643       CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2644       CALL mpprecv(3,t2p1(1,1,2),imigr)
2645       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2646
2647#endif     
2648
2649       ! Write north fold conditions
2650
2651       DO ji = 1, nlci
2652          ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,2)
2653       END DO
2654
2655    END SELECT
2656
2657
2658    ! 2. East and west directions
2659    ! ---------------------------
2660
2661    ! 2.1 Read Dirichlet lateral conditions
2662
2663    iihom = nlci-jpreci
2664
2665    SELECT CASE ( nbondi )
2666
2667    CASE ( -1, 0, 1 )  ! all except 2
2668       DO jl = 1, jpreci
2669             t2ew(:,jl,1) = ptab(  jl    ,:)
2670             t2we(:,jl,1) = ptab(iihom+jl,:)
2671       END DO
2672    END SELECT
2673
2674    ! 2.2 Migrations
2675
2676#if defined key_mpp_shmem
2677
2678    !! * SHMEN version
2679
2680    imigr=jpreci*jpj
2681
2682    SELECT CASE ( nbondi )
2683
2684    CASE ( -1 )
2685       CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2686
2687    CASE ( 0 )
2688       CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2689       CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2690
2691    CASE ( 1 )
2692       CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2693
2694    END SELECT
2695    CALL  barrier()
2696    CALL  shmem_udcflush()
2697
2698#  elif defined key_mpp_mpi
2699    !! * Local variables   (MPI version)
2700
2701    imigr=jpreci*jpj
2702
2703    SELECT CASE ( nbondi )
2704
2705    CASE ( -1 )
2706       CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
2707       CALL mpprecv(1,t2ew(1,1,2),imigr)
2708       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2709    CASE ( 0 )
2710       CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2711       CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
2712       CALL mpprecv(1,t2ew(1,1,2),imigr)
2713       CALL mpprecv(2,t2we(1,1,2),imigr)
2714       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2715       IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2716
2717    CASE ( 1 )
2718       CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2719       CALL mpprecv(2,t2we(1,1,2),imigr)
2720       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2721
2722    END SELECT
2723
2724#endif
2725
2726    ! 2.3 Write Dirichlet lateral conditions
2727
2728       iihom = nlci-nreci
2729
2730    SELECT CASE ( nbondi )
2731
2732    CASE ( -1 )
2733       DO jl = 1, jpreci
2734             ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2735       END DO
2736
2737    CASE ( 0 )
2738       DO jl = 1, jpreci
2739             ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2740             ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2741       END DO
2742
2743    CASE ( 1 )
2744       DO jl = 1, jpreci
2745             ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2746       END DO
2747    END SELECT
2748
2749
2750    ! 3. North and south directions
2751    ! -----------------------------
2752
2753    ! 3.1 Read Dirichlet lateral conditions
2754
2755    ijhom = nlcj-jprecj
2756
2757    SELECT CASE ( nbondj )
2758
2759    CASE ( -1, 0, 1 )
2760       DO jl = 1, jprecj
2761             t2sn(:,jl,1) = ptab(:,ijhom+jl)
2762             t2ns(:,jl,1) = ptab(:,   jl   )
2763       END DO
2764
2765    END SELECT 
2766
2767    ! 3.2 Migrations
2768
2769#if defined key_mpp_shmem
2770
2771    !! * SHMEN version
2772
2773    imigr=jprecj*jpi
2774
2775    SELECT CASE ( nbondj )
2776
2777    CASE ( -1 )
2778       CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2779
2780    CASE ( 0 )
2781       CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2782       CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2783
2784    CASE ( 1 )
2785       CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2786
2787    END SELECT
2788    CALL  barrier()
2789    CALL  shmem_udcflush()
2790
2791#  elif defined key_mpp_mpi
2792    !! * Local variables   (MPI version)
2793
2794    imigr=jprecj*jpi
2795
2796    SELECT CASE ( nbondj )
2797
2798    CASE ( -1 )
2799       CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
2800       CALL mpprecv(3,t2ns(1,1,2),imigr)
2801       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2802
2803    CASE ( 0 )
2804       CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2805       CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
2806       CALL mpprecv(3,t2ns(1,1,2),imigr)
2807       CALL mpprecv(4,t2sn(1,1,2),imigr)
2808       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2809       IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2810
2811    CASE ( 1 )
2812       CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2813       CALL mpprecv(4,t2sn(1,1,2),imigr)
2814       IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2815    END SELECT
2816
2817#endif
2818
2819    ! 3.3 Write Dirichlet lateral conditions
2820
2821       ijhom = nlcj-nrecj
2822
2823    SELECT CASE ( nbondj )
2824
2825    CASE ( -1 )
2826       DO jl = 1, jprecj
2827             ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2828       END DO
2829
2830    CASE ( 0 )
2831       DO jl = 1, jprecj
2832             ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2833             ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2834       END DO
2835
2836    CASE ( 1 ) 
2837       DO jl = 1, jprecj
2838             ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2839       END DO
2840
2841    END SELECT
2842
2843  END SUBROUTINE mpplnks
2844
2845
2846   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req)
2847      !!----------------------------------------------------------------------
2848      !!                  ***  routine mppsend  ***
2849      !!                   
2850      !! ** Purpose :   Send messag passing array
2851      !!
2852      !!----------------------------------------------------------------------
2853      !! * Arguments
2854      REAL(wp), INTENT(inout) ::   pmess(*)       ! array of real
2855      INTEGER , INTENT( in  ) ::   kbytes,     &  ! size of the array pmess
2856         &                         kdest ,     &  ! receive process number
2857         &                         ktyp,       &  ! Tag of the message
2858         &                         md_req         ! Argument for isend
2859      !!----------------------------------------------------------------------
2860#if defined key_mpp_shmem
2861      !! * SHMEM version  :    routine not used
2862
2863#elif defined key_mpp_mpi
2864      !! * MPI version
2865      INTEGER ::   iflag
2866
2867      SELECT CASE ( c_mpi_send )
2868      CASE ( 'S' )                ! Standard mpi send (blocking)
2869         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp,   &
2870            &                          mpi_comm_opa, iflag )
2871      CASE ( 'B' )                ! Buffer mpi send (blocking)
2872         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   &
2873            &                          mpi_comm_opa, iflag )
2874      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
2875         ! Be carefull, one more argument here : the mpi request identifier..
2876         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   &
2877            &                          mpi_comm_opa, md_req, iflag )
2878      END SELECT
2879#endif
2880
2881   END SUBROUTINE mppsend
2882
2883
2884   SUBROUTINE mpprecv( ktyp, pmess, kbytes )
2885      !!----------------------------------------------------------------------
2886      !!                  ***  routine mpprecv  ***
2887      !!
2888      !! ** Purpose :   Receive messag passing array
2889      !!
2890      !!----------------------------------------------------------------------
2891      !! * Arguments
2892      REAL(wp), INTENT(inout) ::   pmess(*)       ! array of real
2893      INTEGER , INTENT( in  ) ::   kbytes,     &  ! suze of the array pmess
2894         &                         ktyp           ! Tag of the recevied message
2895      !!----------------------------------------------------------------------
2896#if defined key_mpp_shmem
2897      !! * SHMEM version  :    routine not used
2898
2899#  elif defined key_mpp_mpi
2900      !! * MPI version
2901      INTEGER :: istatus(mpi_status_size)
2902      INTEGER :: iflag
2903
2904      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp,   &
2905         &                          mpi_comm_opa, istatus, iflag )
2906#endif
2907
2908   END SUBROUTINE mpprecv
2909
2910
2911   SUBROUTINE mppgather( ptab, kp, pio )
2912      !!----------------------------------------------------------------------
2913      !!                   ***  routine mppgather  ***
2914      !!                   
2915      !! ** Purpose :   Transfert between a local subdomain array and a work
2916      !!     array which is distributed following the vertical level.
2917      !!
2918      !! ** Method  :
2919      !!
2920      !!----------------------------------------------------------------------
2921      !! * Arguments
2922      REAL(wp), DIMENSION(jpi,jpj),       INTENT( in  ) ::   ptab   ! subdomain input array
2923      INTEGER ,                           INTENT( in  ) ::   kp     ! record length
2924      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) ::   pio    ! subdomain input array
2925      !!---------------------------------------------------------------------
2926#if defined key_mpp_shmem
2927      !! * SHMEM version
2928
2929      CALL barrier()
2930      CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp )
2931      CALL barrier()
2932
2933#elif defined key_mpp_mpi
2934      !! * Local variables   (MPI version)
2935      INTEGER :: itaille,ierror
2936 
2937      itaille=jpi*jpj
2938      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille,   &
2939         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
2940#endif
2941
2942   END SUBROUTINE mppgather
2943
2944
2945   SUBROUTINE mppscatter( pio, kp, ptab )
2946      !!----------------------------------------------------------------------
2947      !!                  ***  routine mppscatter  ***
2948      !!
2949      !! ** Purpose :   Transfert between awork array which is distributed
2950      !!      following the vertical level and the local subdomain array.
2951      !!
2952      !! ** Method :
2953      !!
2954      !!----------------------------------------------------------------------
2955      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
2956      INTEGER                             ::   kp        ! Tag (not used with MPI
2957      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
2958      !!---------------------------------------------------------------------
2959#if defined key_mpp_shmem
2960      !! * SHMEM version
2961
2962      CALL barrier()
2963      CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp )
2964      CALL barrier()
2965
2966#  elif defined key_mpp_mpi
2967      !! * Local variables   (MPI version)
2968      INTEGER :: itaille, ierror
2969 
2970      itaille=jpi*jpj
2971
2972      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille,   &
2973         &                            mpi_double_precision, kp, mpi_comm_opa, ierror )
2974#endif
2975
2976   END SUBROUTINE mppscatter
2977
2978
2979   SUBROUTINE mppisl_a_int( ktab, kdim )
2980      !!----------------------------------------------------------------------
2981      !!                  ***  routine mppisl_a_int  ***
2982      !!                   
2983      !! ** Purpose :   Massively parallel processors
2984      !!                Find the  non zero value
2985      !!
2986      !!----------------------------------------------------------------------
2987      !! * Arguments
2988      INTEGER, INTENT( in  )                  ::   kdim       ! ???
2989      INTEGER, INTENT(inout), DIMENSION(kdim) ::   ktab       ! ???
2990 
2991#if defined key_mpp_shmem
2992      !! * Local variables   (SHMEM version)
2993      INTEGER :: ji
2994      INTEGER, SAVE :: ibool=0
2995
2996      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', &
2997           &                               'change jpmppsum dimension in mpp.h' )
2998
2999      DO ji = 1, kdim
3000         niitab_shmem(ji) = ktab(ji)
3001      END DO
3002      CALL  barrier()
3003      IF(ibool == 0 ) THEN
3004         CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0   &
3005              ,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3006         CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0   &
3007              ,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3008      ELSE
3009         CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0   &
3010              ,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3011         CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0   &
3012              ,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3013      ENDIF
3014      CALL  barrier()
3015      ibool=ibool+1
3016      ibool=MOD( ibool,2)
3017      DO ji = 1, kdim
3018         IF( ni11tab_shmem(ji) /= 0. ) THEN
3019            ktab(ji) = ni11tab_shmem(ji)
3020         ELSE
3021            ktab(ji) = ni12tab_shmem(ji)
3022         ENDIF
3023      END DO
3024 
3025#  elif defined key_mpp_mpi
3026      !! * Local variables   (MPI version)
3027      LOGICAL  :: lcommute
3028      INTEGER, DIMENSION(kdim) ::   iwork
3029      INTEGER  :: mpi_isl,ierror
3030 
3031      lcommute = .TRUE.
3032      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3033      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer   &
3034           , mpi_isl, mpi_comm_opa, ierror )
3035      ktab(:) = iwork(:)
3036#endif
3037
3038   END SUBROUTINE mppisl_a_int
3039
3040
3041   SUBROUTINE mppisl_int( ktab )
3042      !!----------------------------------------------------------------------
3043      !!                  ***  routine mppisl_int  ***
3044      !!                   
3045      !! ** Purpose :   Massively parallel processors
3046      !!                Find the non zero value
3047      !!
3048      !!----------------------------------------------------------------------
3049      !! * Arguments
3050      INTEGER , INTENT( inout ) ::   ktab        !
3051
3052#if defined key_mpp_shmem
3053      !! * Local variables   (SHMEM version)
3054      INTEGER, SAVE :: ibool=0
3055
3056      niitab_shmem(1) = ktab
3057      CALL  barrier()
3058      IF(ibool == 0 ) THEN
3059         CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0   &
3060              ,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3061         CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0   &
3062              ,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3063      ELSE
3064         CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0   &
3065              ,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3066         CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0   &
3067              ,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3068      ENDIF
3069      CALL  barrier()
3070      ibool=ibool+1
3071      ibool=MOD( ibool,2)
3072      IF( ni11tab_shmem(1) /= 0. ) THEN
3073         ktab = ni11tab_shmem(1)
3074      ELSE
3075         ktab = ni12tab_shmem(1)
3076      ENDIF
3077 
3078#  elif defined key_mpp_mpi
3079 
3080      !! * Local variables   (MPI version)
3081      LOGICAL :: lcommute
3082      INTEGER :: mpi_isl,ierror
3083      INTEGER ::   iwork
3084 
3085      lcommute = .TRUE.
3086      CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3087      CALL mpi_allreduce(ktab, iwork, 1,mpi_integer   &
3088           ,mpi_isl,mpi_comm_opa,ierror)
3089      ktab = iwork
3090#endif
3091
3092   END SUBROUTINE mppisl_int
3093
3094
3095   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
3096      !!----------------------------------------------------------------------
3097      !!                  ***  routine mppmax_a_int  ***
3098      !!
3099      !! ** Purpose :   Find maximum value in an integer layout array
3100      !!
3101      !!----------------------------------------------------------------------
3102      !! * Arguments
3103      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
3104      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
3105      INTEGER , INTENT(in)   , OPTIONAL        ::   kcom 
3106 
3107#if defined key_mpp_shmem
3108      !! * Local declarations    (SHMEM version)
3109      INTEGER :: ji
3110      INTEGER, SAVE :: ibool=0
3111 
3112      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_int routine : kdim is too big', &
3113           &                               'change jpmppsum dimension in mpp.h' )
3114 
3115      DO ji = 1, kdim
3116         niltab_shmem(ji) = ktab(ji)
3117      END DO
3118      CALL  barrier()
3119      IF(ibool == 0 ) THEN
3120         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0   &
3121              ,N$PES,nil1wrk_shmem,nil1sync_shmem )
3122      ELSE
3123         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0   &
3124              ,N$PES,nil2wrk_shmem,nil2sync_shmem )
3125      ENDIF
3126      CALL  barrier()
3127      ibool=ibool+1
3128      ibool=MOD( ibool,2)
3129      DO ji = 1, kdim
3130         ktab(ji) = niltab_shmem(ji)
3131      END DO
3132 
3133#  elif defined key_mpp_mpi
3134 
3135      !! * Local variables   (MPI version)
3136      INTEGER :: ierror
3137      INTEGER :: localcomm
3138      INTEGER, DIMENSION(kdim) ::   iwork
3139
3140      localcomm = mpi_comm_opa
3141      IF( PRESENT(kcom) ) localcomm = kcom
3142 
3143      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   &
3144           &                mpi_max, localcomm, ierror )
3145 
3146      ktab(:) = iwork(:)
3147#endif
3148
3149   END SUBROUTINE mppmax_a_int
3150
3151
3152   SUBROUTINE mppmax_int( ktab, kcom )
3153      !!----------------------------------------------------------------------
3154      !!                  ***  routine mppmax_int  ***
3155      !!
3156      !! ** Purpose :
3157      !!     Massively parallel processors
3158      !!     Find maximum value in an integer layout array
3159      !!
3160      !!----------------------------------------------------------------------
3161      !! * Arguments
3162      INTEGER, INTENT(inout) ::   ktab      ! ???
3163      INTEGER, INTENT(in), OPTIONAL ::   kcom      ! ???
3164 
3165      !! * Local declarations
3166
3167#if defined key_mpp_shmem
3168
3169      !! * Local variables   (SHMEM version)
3170      INTEGER :: ji
3171      INTEGER, SAVE :: ibool=0
3172 
3173      niltab_shmem(1) = ktab
3174      CALL  barrier()
3175      IF(ibool == 0 ) THEN
3176         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0   &
3177              ,N$PES,nil1wrk_shmem,nil1sync_shmem )
3178      ELSE
3179         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0   &
3180              ,N$PES,nil2wrk_shmem,nil2sync_shmem )
3181      ENDIF
3182      CALL  barrier()
3183      ibool=ibool+1
3184      ibool=MOD( ibool,2)
3185      ktab = niltab_shmem(1)
3186 
3187#  elif defined key_mpp_mpi
3188
3189      !! * Local variables   (MPI version)
3190      INTEGER ::  ierror, iwork
3191      INTEGER :: localcomm
3192
3193      localcomm = mpi_comm_opa 
3194      IF( PRESENT(kcom) ) localcomm = kcom
3195
3196      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   &
3197           &              ,mpi_max,localcomm,ierror)
3198 
3199      ktab = iwork
3200#endif
3201
3202   END SUBROUTINE mppmax_int
3203
3204
3205   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
3206      !!----------------------------------------------------------------------
3207      !!                  ***  routine mppmin_a_int  ***
3208      !!
3209      !! ** Purpose :   Find minimum value in an integer layout array
3210      !!
3211      !!----------------------------------------------------------------------
3212      !! * Arguments
3213      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
3214      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
3215      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
3216 
3217#if defined key_mpp_shmem
3218      !! * Local declarations    (SHMEM version)
3219      INTEGER :: ji
3220      INTEGER, SAVE :: ibool=0
3221 
3222      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', &
3223           &                               'change jpmppsum dimension in mpp.h' )
3224 
3225      DO ji = 1, kdim
3226         niltab_shmem(ji) = ktab(ji)
3227      END DO
3228      CALL  barrier()
3229      IF(ibool == 0 ) THEN
3230         CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0   &
3231              ,N$PES,nil1wrk_shmem,nil1sync_shmem )
3232      ELSE
3233         CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0   &
3234              ,N$PES,nil2wrk_shmem,nil2sync_shmem )
3235      ENDIF
3236      CALL  barrier()
3237      ibool=ibool+1
3238      ibool=MOD( ibool,2)
3239      DO ji = 1, kdim
3240         ktab(ji) = niltab_shmem(ji)
3241      END DO
3242 
3243#  elif defined key_mpp_mpi
3244 
3245      !! * Local variables   (MPI version)
3246      INTEGER :: ierror
3247      INTEGER :: localcomm
3248      INTEGER, DIMENSION(kdim) ::   iwork
3249 
3250      localcomm = mpi_comm_opa
3251      IF( PRESENT(kcom) ) localcomm = kcom
3252
3253      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   &
3254           &                mpi_min, localcomm, ierror )
3255 
3256      ktab(:) = iwork(:)
3257#endif
3258
3259   END SUBROUTINE mppmin_a_int
3260
3261
3262   SUBROUTINE mppmin_int( ktab )
3263      !!----------------------------------------------------------------------
3264      !!                  ***  routine mppmin_int  ***
3265      !!
3266      !! ** Purpose :
3267      !!     Massively parallel processors
3268      !!     Find minimum value in an integer layout array
3269      !!
3270      !!----------------------------------------------------------------------
3271      !! * Arguments
3272      INTEGER, INTENT(inout) ::   ktab      ! ???
3273 
3274      !! * Local declarations
3275
3276#if defined key_mpp_shmem
3277
3278      !! * Local variables   (SHMEM version)
3279      INTEGER :: ji
3280      INTEGER, SAVE :: ibool=0
3281 
3282      niltab_shmem(1) = ktab
3283      CALL  barrier()
3284      IF(ibool == 0 ) THEN
3285         CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0   &
3286              ,N$PES,nil1wrk_shmem,nil1sync_shmem )
3287      ELSE
3288         CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0   &
3289              ,N$PES,nil2wrk_shmem,nil2sync_shmem )
3290      ENDIF
3291      CALL  barrier()
3292      ibool=ibool+1
3293      ibool=MOD( ibool,2)
3294      ktab = niltab_shmem(1)
3295 
3296#  elif defined key_mpp_mpi
3297
3298      !! * Local variables   (MPI version)
3299      INTEGER ::  ierror, iwork
3300 
3301      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   &
3302           &              ,mpi_min,mpi_comm_opa,ierror)
3303 
3304      ktab = iwork
3305#endif
3306
3307   END SUBROUTINE mppmin_int
3308
3309
3310   SUBROUTINE mppsum_a_int( ktab, kdim )
3311      !!----------------------------------------------------------------------
3312      !!                  ***  routine mppsum_a_int  ***
3313      !!                   
3314      !! ** Purpose :   Massively parallel processors
3315      !!                Global integer sum
3316      !!
3317      !!----------------------------------------------------------------------
3318      !! * Arguments
3319      INTEGER, INTENT( in  )                   ::   kdim      ! ???
3320      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
3321 
3322#if defined key_mpp_shmem
3323
3324      !! * Local variables   (SHMEM version)
3325      INTEGER :: ji
3326      INTEGER, SAVE :: ibool=0
3327
3328      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', &
3329           &                               'change jpmppsum dimension in mpp.h' )
3330
3331      DO ji = 1, kdim
3332         nistab_shmem(ji) = ktab(ji)
3333      END DO
3334      CALL  barrier()
3335      IF(ibool == 0 ) THEN
3336         CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0,   &
3337              N$PES,nis1wrk_shmem,nis1sync_shmem)
3338      ELSE
3339         CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0,   &
3340              N$PES,nis2wrk_shmem,nis2sync_shmem)
3341      ENDIF
3342      CALL  barrier()
3343      ibool = ibool + 1
3344      ibool = MOD( ibool, 2 )
3345      DO ji = 1, kdim
3346         ktab(ji) = nistab_shmem(ji)
3347      END DO
3348 
3349#  elif defined key_mpp_mpi
3350
3351      !! * Local variables   (MPI version)
3352      INTEGER :: ierror
3353      INTEGER, DIMENSION (kdim) ::  iwork
3354 
3355      CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer   &
3356           ,mpi_sum,mpi_comm_opa,ierror)
3357 
3358      ktab(:) = iwork(:)
3359#endif
3360
3361   END SUBROUTINE mppsum_a_int
3362
3363
3364  SUBROUTINE mppsum_int( ktab )
3365    !!----------------------------------------------------------------------
3366    !!                 ***  routine mppsum_int  ***
3367    !!                 
3368    !! ** Purpose :   Global integer sum
3369    !!
3370    !!----------------------------------------------------------------------
3371    !! * Arguments
3372    INTEGER, INTENT(inout) ::   ktab
3373
3374#if defined key_mpp_shmem
3375
3376    !! * Local variables   (SHMEM version)
3377    INTEGER, SAVE :: ibool=0
3378
3379    nistab_shmem(1) = ktab
3380    CALL  barrier()
3381    IF(ibool == 0 ) THEN
3382       CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0,   &
3383            N$PES,nis1wrk_shmem,nis1sync_shmem)
3384    ELSE
3385       CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0,   &
3386            N$PES,nis2wrk_shmem,nis2sync_shmem)
3387    ENDIF
3388    CALL  barrier()
3389    ibool=ibool+1
3390    ibool=MOD( ibool,2)
3391    ktab = nistab_shmem(1)
3392
3393#  elif defined key_mpp_mpi
3394
3395    !! * Local variables   (MPI version)
3396    INTEGER :: ierror, iwork
3397
3398    CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   &
3399         ,mpi_sum,mpi_comm_opa,ierror)
3400
3401    ktab = iwork
3402
3403#endif
3404
3405  END SUBROUTINE mppsum_int
3406
3407
3408  SUBROUTINE mppisl_a_real( ptab, kdim )
3409    !!----------------------------------------------------------------------
3410    !!                 ***  routine mppisl_a_real  ***
3411    !!         
3412    !! ** Purpose :   Massively parallel processors
3413    !!           Find the non zero island barotropic stream function value
3414    !!
3415    !!   Modifications:
3416    !!        !  93-09 (M. Imbard)
3417    !!        !  96-05 (j. Escobar)
3418    !!        !  98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3419    !!----------------------------------------------------------------------
3420    INTEGER , INTENT( in  )                  ::   kdim      ! ???
3421    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab      ! ???
3422
3423#if defined key_mpp_shmem
3424
3425    !! * Local variables   (SHMEM version)
3426    INTEGER :: ji
3427    INTEGER, SAVE :: ibool=0
3428
3429    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', &
3430         &                               'change jpmppsum dimension in mpp.h' )
3431
3432    DO ji = 1, kdim
3433       wiltab_shmem(ji) = ptab(ji)
3434    END DO
3435    CALL  barrier()
3436    IF(ibool == 0 ) THEN
3437       CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0   &
3438            ,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3439       CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0   &
3440            ,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3441    ELSE
3442       CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0   &
3443            ,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3444       CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0   &
3445            ,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3446    ENDIF
3447    CALL  barrier()
3448    ibool=ibool+1
3449    ibool=MOD( ibool,2)
3450    DO ji = 1, kdim
3451       IF(wi1tab_shmem(ji) /= 0. ) THEN
3452          ptab(ji) = wi1tab_shmem(ji)
3453       ELSE
3454          ptab(ji) = wi2tab_shmem(ji)
3455       ENDIF
3456    END DO
3457
3458#  elif defined key_mpp_mpi
3459
3460    !! * Local variables   (MPI version)
3461    LOGICAL ::   lcommute = .TRUE.
3462    INTEGER ::   mpi_isl, ierror
3463    REAL(wp), DIMENSION(kdim) ::  zwork
3464
3465    CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3466    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   &
3467         ,mpi_isl,mpi_comm_opa,ierror)
3468    ptab(:) = zwork(:)
3469
3470#endif
3471
3472  END SUBROUTINE mppisl_a_real
3473
3474
3475   SUBROUTINE mppisl_real( ptab )
3476      !!----------------------------------------------------------------------
3477      !!                  ***  routine mppisl_real  ***
3478      !!                 
3479      !! ** Purpose :   Massively parallel processors
3480      !!       Find the  non zero island barotropic stream function value
3481      !!
3482      !!     Modifications:
3483      !!        !  93-09 (M. Imbard)
3484      !!        !  96-05 (j. Escobar)
3485      !!        !  98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3486      !!----------------------------------------------------------------------
3487      REAL(wp), INTENT(inout) ::   ptab
3488
3489#if defined key_mpp_shmem
3490
3491      !! * Local variables   (SHMEM version)
3492      INTEGER, SAVE :: ibool=0
3493
3494      wiltab_shmem(1) = ptab
3495      CALL  barrier()
3496      IF(ibool == 0 ) THEN
3497         CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   &
3498            ,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3499         CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   &
3500            ,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3501      ELSE
3502         CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   &
3503            ,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3504         CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   &
3505            ,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3506      ENDIF
3507      CALL barrier()
3508      ibool = ibool + 1
3509      ibool = MOD( ibool, 2 )
3510      IF( wi1tab_shmem(1) /= 0. ) THEN
3511         ptab = wi1tab_shmem(1)
3512      ELSE
3513         ptab = wi2tab_shmem(1)
3514      ENDIF
3515
3516#  elif defined key_mpp_mpi
3517
3518      !! * Local variables   (MPI version)
3519      LOGICAL  ::   lcommute = .TRUE.
3520      INTEGER  ::   mpi_isl, ierror
3521      REAL(wp) ::   zwork
3522
3523      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3524      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision,   &
3525         &                                mpi_isl  , mpi_comm_opa, ierror )
3526      ptab = zwork
3527
3528#endif
3529
3530   END SUBROUTINE mppisl_real
3531
3532
3533  FUNCTION lc_isl( py, px, kdim, kdtatyp )
3534    INTEGER :: kdim
3535    REAL(wp), DIMENSION(kdim) ::  px, py
3536    INTEGER :: kdtatyp, ji
3537    INTEGER :: lc_isl
3538    DO ji = 1, kdim
3539       IF( py(ji) /= 0. )   px(ji) = py(ji)
3540    END DO
3541    lc_isl=0
3542
3543  END FUNCTION lc_isl
3544
3545
3546  SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
3547    !!----------------------------------------------------------------------
3548    !!                 ***  routine mppmax_a_real  ***
3549    !!                 
3550    !! ** Purpose :   Maximum
3551    !!
3552    !!----------------------------------------------------------------------
3553    !! * Arguments
3554    INTEGER , INTENT( in  )                  ::   kdim
3555    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
3556    INTEGER , INTENT( in  ), OPTIONAL        ::   kcom
3557
3558#if defined key_mpp_shmem
3559
3560    !! * Local variables   (SHMEM version)
3561    INTEGER :: ji
3562    INTEGER, SAVE :: ibool=0
3563
3564    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', &
3565         &                               'change jpmppsum dimension in mpp.h' )
3566
3567    DO ji = 1, kdim
3568       wintab_shmem(ji) = ptab(ji)
3569    END DO
3570    CALL  barrier()
3571    IF(ibool == 0 ) THEN
3572       CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0   &
3573            ,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3574    ELSE
3575       CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0   &
3576            ,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3577    ENDIF
3578    CALL  barrier()
3579    ibool=ibool+1
3580    ibool=MOD( ibool,2)
3581    DO ji = 1, kdim
3582       ptab(ji) = wintab_shmem(ji)
3583    END DO
3584
3585#  elif defined key_mpp_mpi
3586
3587    !! * Local variables   (MPI version)
3588    INTEGER :: ierror
3589    INTEGER :: localcomm
3590    REAL(wp), DIMENSION(kdim) ::  zwork
3591
3592    localcomm = mpi_comm_opa
3593    IF( PRESENT(kcom) ) localcomm = kcom
3594
3595    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   &
3596         ,mpi_max,localcomm,ierror)
3597    ptab(:) = zwork(:)
3598
3599#endif
3600
3601  END SUBROUTINE mppmax_a_real
3602
3603
3604  SUBROUTINE mppmax_real( ptab, kcom )
3605    !!----------------------------------------------------------------------
3606    !!                  ***  routine mppmax_real  ***
3607    !!                   
3608    !! ** Purpose :   Maximum
3609    !!
3610    !!----------------------------------------------------------------------
3611    !! * Arguments
3612    REAL(wp), INTENT(inout) ::   ptab      ! ???
3613    INTEGER , INTENT( in  ), OPTIONAL ::   kcom      ! ???
3614
3615#if defined key_mpp_shmem
3616
3617    !! * Local variables   (SHMEM version)
3618    INTEGER, SAVE :: ibool=0
3619
3620    wintab_shmem(1) = ptab
3621    CALL  barrier()
3622    IF(ibool == 0 ) THEN
3623       CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0   &
3624            ,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3625    ELSE
3626       CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0   &
3627            ,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3628    ENDIF
3629    CALL  barrier()
3630    ibool=ibool+1
3631    ibool=MOD( ibool,2)
3632    ptab = wintab_shmem(1)
3633
3634#  elif defined key_mpp_mpi
3635
3636    !! * Local variables   (MPI version)
3637    INTEGER  ::   ierror
3638    INTEGER  ::   localcomm
3639    REAL(wp) ::   zwork
3640
3641    localcomm = mpi_comm_opa 
3642    IF( PRESENT(kcom) ) localcomm = kcom
3643
3644    CALL mpi_allreduce( ptab, zwork  , 1             , mpi_double_precision,   &
3645       &                      mpi_max, localcomm, ierror     )
3646    ptab = zwork
3647
3648#endif
3649
3650  END SUBROUTINE mppmax_real
3651
3652
3653  SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
3654    !!----------------------------------------------------------------------
3655    !!                 ***  routine mppmin_a_real  ***
3656    !!                 
3657    !! ** Purpose :   Minimum
3658    !!
3659    !!-----------------------------------------------------------------------
3660    !! * Arguments
3661    INTEGER , INTENT( in  )                  ::   kdim
3662    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
3663    INTEGER , INTENT( in  ), OPTIONAL        ::   kcom
3664
3665#if defined key_mpp_shmem
3666
3667    !! * Local variables   (SHMEM version)
3668    INTEGER :: ji
3669    INTEGER, SAVE :: ibool=0
3670
3671    IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', &
3672         &                               'change jpmppsum dimension in mpp.h' )
3673
3674    DO ji = 1, kdim
3675       wintab_shmem(ji) = ptab(ji)
3676    END DO
3677    CALL  barrier()
3678    IF(ibool == 0 ) THEN
3679       CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0   &
3680            ,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3681    ELSE
3682       CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0   &
3683            ,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3684    ENDIF
3685    CALL  barrier()
3686    ibool=ibool+1
3687    ibool=MOD( ibool,2)
3688    DO ji = 1, kdim
3689       ptab(ji) = wintab_shmem(ji)
3690    END DO
3691
3692#  elif defined key_mpp_mpi
3693
3694    !! * Local variables   (MPI version)
3695    INTEGER :: ierror
3696    INTEGER :: localcomm 
3697    REAL(wp), DIMENSION(kdim) ::   zwork
3698
3699    localcomm = mpi_comm_opa 
3700    IF( PRESENT(kcom) ) localcomm = kcom
3701
3702    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   &
3703         ,mpi_min,localcomm,ierror)
3704    ptab(:) = zwork(:)
3705
3706#endif
3707
3708  END SUBROUTINE mppmin_a_real
3709
3710
3711  SUBROUTINE mppmin_real( ptab, kcom )
3712    !!----------------------------------------------------------------------
3713    !!                  ***  routine mppmin_real  ***
3714    !!
3715    !! ** Purpose :   minimum in Massively Parallel Processing
3716    !!                REAL scalar case
3717    !!
3718    !!-----------------------------------------------------------------------
3719    !! * Arguments
3720    REAL(wp), INTENT( inout ) ::   ptab        !
3721    INTEGER , INTENT(  in   ), OPTIONAL :: kcom
3722
3723#if defined key_mpp_shmem
3724
3725    !! * Local variables   (SHMEM version)
3726    INTEGER, SAVE :: ibool=0
3727
3728    wintab_shmem(1) = ptab
3729    CALL  barrier()
3730    IF(ibool == 0 ) THEN
3731       CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0   &
3732            ,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3733    ELSE
3734       CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0   &
3735            ,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3736    ENDIF
3737    CALL  barrier()
3738    ibool=ibool+1
3739    ibool=MOD( ibool,2)
3740    ptab = wintab_shmem(1)
3741
3742#  elif defined key_mpp_mpi
3743
3744    !! * Local variables   (MPI version)
3745    INTEGER  ::   ierror
3746    REAL(wp) ::   zwork
3747    INTEGER :: localcomm
3748
3749    localcomm = mpi_comm_opa 
3750    IF( PRESENT(kcom) ) localcomm = kcom
3751
3752    CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision   &
3753         &               ,mpi_min,localcomm,ierror)
3754    ptab = zwork
3755
3756#endif
3757
3758  END SUBROUTINE mppmin_real
3759
3760
3761  SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
3762    !!----------------------------------------------------------------------
3763    !!                  ***  routine mppsum_a_real  ***
3764    !!
3765    !! ** Purpose :   global sum in Massively Parallel Processing
3766    !!                REAL ARRAY argument case
3767    !!
3768    !!-----------------------------------------------------------------------
3769    INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
3770    REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
3771    INTEGER , INTENT( in ), OPTIONAL           :: kcom
3772
3773#if defined key_mpp_shmem
3774
3775    !! * Local variables   (SHMEM version)
3776    INTEGER :: ji
3777    INTEGER, SAVE :: ibool=0
3778
3779    IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', &
3780         &                               'change jpmppsum dimension in mpp.h' )
3781
3782    DO ji = 1, kdim
3783       wrstab_shmem(ji) = ptab(ji)
3784    END DO
3785    CALL  barrier()
3786    IF(ibool == 0 ) THEN
3787       CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0   &
3788            ,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3789    ELSE
3790       CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0   &
3791            ,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3792    ENDIF
3793    CALL  barrier()
3794    ibool=ibool+1
3795    ibool=MOD( ibool,2)
3796    DO ji = 1, kdim
3797       ptab(ji) = wrstab_shmem(ji)
3798    END DO
3799
3800#  elif defined key_mpp_mpi
3801
3802    !! * Local variables   (MPI version)
3803    INTEGER                   ::   ierror    ! temporary integer
3804    INTEGER                   ::   localcomm 
3805    REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
3806   
3807
3808    localcomm = mpi_comm_opa 
3809    IF( PRESENT(kcom) ) localcomm = kcom
3810
3811    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   &
3812         &              ,mpi_sum,localcomm,ierror)
3813    ptab(:) = zwork(:)
3814
3815#endif
3816
3817  END SUBROUTINE mppsum_a_real
3818
3819
3820  SUBROUTINE mppsum_real( ptab, kcom )
3821    !!----------------------------------------------------------------------
3822    !!                  ***  routine mppsum_real  ***
3823    !!             
3824    !! ** Purpose :   global sum in Massively Parallel Processing
3825    !!                SCALAR argument case
3826    !!
3827    !!-----------------------------------------------------------------------
3828    REAL(wp), INTENT(inout) ::   ptab        ! input scalar
3829    INTEGER , INTENT( in  ), OPTIONAL :: kcom
3830
3831#if defined key_mpp_shmem
3832
3833    !! * Local variables   (SHMEM version)
3834    INTEGER, SAVE :: ibool=0
3835
3836    wrstab_shmem(1) = ptab
3837    CALL  barrier()
3838    IF(ibool == 0 ) THEN
3839       CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0   &
3840            ,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3841    ELSE
3842       CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0   &
3843            ,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3844    ENDIF
3845    CALL  barrier()
3846    ibool = ibool + 1
3847    ibool = MOD( ibool, 2 )
3848    ptab = wrstab_shmem(1)
3849
3850#  elif defined key_mpp_mpi
3851
3852    !! * Local variables   (MPI version)
3853    INTEGER  ::   ierror
3854    INTEGER  ::   localcomm 
3855    REAL(wp) ::   zwork
3856
3857   localcomm = mpi_comm_opa 
3858   IF( PRESENT(kcom) ) localcomm = kcom
3859 
3860   CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   &
3861         &              ,mpi_sum,localcomm,ierror)
3862    ptab = zwork
3863
3864#endif
3865
3866  END SUBROUTINE mppsum_real
3867
3868  SUBROUTINE mpp_minloc2d(ptab, pmask, pmin, ki,kj )
3869    !!------------------------------------------------------------------------
3870    !!             ***  routine mpp_minloc  ***
3871    !!
3872    !! ** Purpose :  Compute the global minimum of an array ptab
3873    !!              and also give its global position
3874    !!
3875    !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3876    !!
3877    !! ** Arguments : I : ptab =local 2D array
3878    !!                O : pmin = global minimum
3879    !!                O : ki,kj = global position of minimum
3880    !!
3881    !! ** Author : J.M. Molines 10/10/2004
3882    !!--------------------------------------------------------------------------
3883#ifdef key_mpp_shmem
3884    CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3885# elif key_mpp_mpi
3886    !! * Arguments
3887    REAL(wp), DIMENSION (jpi,jpj), INTENT (in)  :: ptab ,& ! Local 2D array
3888         &                                         pmask   ! Local mask
3889    REAL(wp)                     , INTENT (out) :: pmin    ! Global minimum of ptab
3890    INTEGER                      , INTENT (out) :: ki,kj   ! index of minimum in global frame
3891
3892    !! * Local variables
3893    REAL(wp) :: zmin   ! local minimum
3894    REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3895    INTEGER, DIMENSION (2)  :: ilocs
3896    INTEGER :: ierror
3897
3898
3899    zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
3900    ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
3901
3902    ki = ilocs(1) + nimpp - 1
3903    kj = ilocs(2) + njmpp - 1
3904
3905    zain(1,:)=zmin
3906    zain(2,:)=ki+10000.*kj
3907
3908    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3909
3910    pmin=zaout(1,1)
3911    kj= INT(zaout(2,1)/10000.)
3912    ki= INT(zaout(2,1) - 10000.*kj )
3913#endif
3914
3915  END SUBROUTINE mpp_minloc2d
3916
3917
3918  SUBROUTINE mpp_minloc3d(ptab, pmask, pmin, ki,kj ,kk)
3919    !!------------------------------------------------------------------------
3920    !!             ***  routine mpp_minloc  ***
3921    !!
3922    !! ** Purpose :  Compute the global minimum of an array ptab
3923    !!              and also give its global position
3924    !!
3925    !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3926    !!
3927    !! ** Arguments : I : ptab =local 2D array
3928    !!                O : pmin = global minimum
3929    !!                O : ki,kj = global position of minimum
3930    !!
3931    !! ** Author : J.M. Molines 10/10/2004
3932    !!--------------------------------------------------------------------------
3933#ifdef key_mpp_shmem
3934    CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3935# elif key_mpp_mpi
3936    !! * Arguments
3937    REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in)  :: ptab ,& ! Local 2D array
3938         &                                         pmask   ! Local mask
3939    REAL(wp)                     , INTENT (out) :: pmin    ! Global minimum of ptab
3940    INTEGER                      , INTENT (out) :: ki,kj,kk ! index of minimum in global frame
3941
3942    !! * Local variables
3943    REAL(wp) :: zmin   ! local minimum
3944    REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3945    INTEGER, DIMENSION (3)  :: ilocs
3946    INTEGER :: ierror
3947
3948
3949    zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
3950    ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
3951
3952    ki = ilocs(1) + nimpp - 1
3953    kj = ilocs(2) + njmpp - 1
3954    kk = ilocs(3)
3955
3956    zain(1,:)=zmin
3957    zain(2,:)=ki+10000.*kj+100000000.*kk
3958
3959    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3960
3961    pmin=zaout(1,1)
3962    kk= INT(zaout(2,1)/100000000.)
3963    kj= INT(zaout(2,1) - kk * 100000000. )/10000
3964    ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
3965#endif
3966
3967  END SUBROUTINE mpp_minloc3d
3968
3969
3970  SUBROUTINE mpp_maxloc2d(ptab, pmask, pmax, ki,kj )
3971    !!------------------------------------------------------------------------
3972    !!             ***  routine mpp_maxloc  ***
3973    !!
3974    !! ** Purpose :  Compute the global maximum of an array ptab
3975    !!              and also give its global position
3976    !!
3977    !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3978    !!
3979    !! ** Arguments : I : ptab =local 2D array
3980    !!                O : pmax = global maximum
3981    !!                O : ki,kj = global position of maximum
3982    !!
3983    !! ** Author : J.M. Molines 10/10/2004
3984    !!--------------------------------------------------------------------------
3985#ifdef key_mpp_shmem
3986    CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
3987# elif key_mpp_mpi
3988    !! * Arguments
3989    REAL(wp), DIMENSION (jpi,jpj), INTENT (in)  :: ptab ,& ! Local 2D array
3990         &                                         pmask   ! Local mask
3991    REAL(wp)                     , INTENT (out) :: pmax    ! Global maximum of ptab
3992    INTEGER                      , INTENT (out) :: ki,kj   ! index of maximum in global frame
3993
3994    !! * Local variables
3995    REAL(wp) :: zmax   ! local maximum
3996    REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3997    INTEGER, DIMENSION (2)  :: ilocs
3998    INTEGER :: ierror
3999
4000
4001    zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
4002    ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
4003
4004    ki = ilocs(1) + nimpp - 1
4005    kj = ilocs(2) + njmpp - 1
4006
4007    zain(1,:)=zmax
4008    zain(2,:)=ki+10000.*kj
4009
4010    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4011
4012    pmax=zaout(1,1)
4013    kj= INT(zaout(2,1)/10000.)
4014    ki= INT(zaout(2,1) - 10000.*kj )
4015#endif
4016
4017  END SUBROUTINE mpp_maxloc2d
4018
4019  SUBROUTINE mpp_maxloc3d(ptab, pmask, pmax, ki,kj,kk )
4020    !!------------------------------------------------------------------------
4021    !!             ***  routine mpp_maxloc  ***
4022    !!
4023    !! ** Purpose :  Compute the global maximum of an array ptab
4024    !!              and also give its global position
4025    !!
4026    !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
4027    !!
4028    !! ** Arguments : I : ptab =local 2D array
4029    !!                O : pmax = global maximum
4030    !!                O : ki,kj = global position of maximum
4031    !!
4032    !! ** Author : J.M. Molines 10/10/2004
4033    !!--------------------------------------------------------------------------
4034#ifdef key_mpp_shmem
4035    CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
4036# elif key_mpp_mpi
4037    !! * Arguments
4038    REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in)  :: ptab ,& ! Local 2D array
4039         &                                         pmask   ! Local mask
4040    REAL(wp)                     , INTENT (out) :: pmax    ! Global maximum of ptab
4041    INTEGER                      , INTENT (out) :: ki,kj,kk   ! index of maximum in global frame
4042
4043    !! * Local variables
4044    REAL(wp) :: zmax   ! local maximum
4045    REAL(wp) ,DIMENSION(2,1) :: zain, zaout
4046    INTEGER, DIMENSION (3)  :: ilocs
4047    INTEGER :: ierror
4048
4049
4050    zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
4051    ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
4052
4053    ki = ilocs(1) + nimpp - 1
4054    kj = ilocs(2) + njmpp - 1
4055    kk = ilocs(3)
4056
4057    zain(1,:)=zmax
4058    zain(2,:)=ki+10000.*kj+100000000.*kk
4059
4060    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4061
4062    pmax=zaout(1,1)
4063    kk= INT(zaout(2,1)/100000000.)
4064    kj= INT(zaout(2,1) - kk * 100000000. )/10000
4065    ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
4066#endif
4067
4068  END SUBROUTINE mpp_maxloc3d
4069
4070  SUBROUTINE mppsync()
4071    !!----------------------------------------------------------------------
4072    !!                  ***  routine mppsync  ***
4073    !!                   
4074    !! ** Purpose :   Massively parallel processors, synchroneous
4075    !!
4076    !!-----------------------------------------------------------------------
4077
4078#if defined key_mpp_shmem
4079
4080    !! * Local variables   (SHMEM version)
4081    CALL barrier()
4082
4083#  elif defined key_mpp_mpi
4084
4085    !! * Local variables   (MPI version)
4086    INTEGER :: ierror
4087
4088    CALL mpi_barrier(mpi_comm_opa,ierror)
4089
4090#endif
4091
4092  END SUBROUTINE mppsync
4093
4094
4095  SUBROUTINE mppstop
4096    !!----------------------------------------------------------------------
4097    !!                  ***  routine mppstop  ***
4098    !!                   
4099    !! ** purpose :   Stop massilively parallel processors method
4100    !!
4101    !!----------------------------------------------------------------------
4102    !! * Local declarations
4103    INTEGER ::   info
4104    !!----------------------------------------------------------------------
4105
4106    ! 1. Mpp synchroneus
4107    ! ------------------
4108
4109    CALL mppsync
4110#if defined key_mpp_mpi
4111    CALL mpi_finalize( info )
4112#endif
4113
4114  END SUBROUTINE mppstop
4115
4116
4117  SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
4118    !!----------------------------------------------------------------------
4119    !!                  ***  routine mppobc  ***
4120    !!
4121    !! ** Purpose :   Message passing manadgement for open boundary
4122    !!     conditions array
4123    !!
4124    !! ** Method  :   Use mppsend and mpprecv function for passing mask
4125    !!       between processors following neighboring subdomains.
4126    !!       domain parameters
4127    !!                    nlci   : first dimension of the local subdomain
4128    !!                    nlcj   : second dimension of the local subdomain
4129    !!                    nbondi : mark for "east-west local boundary"
4130    !!                    nbondj : mark for "north-south local boundary"
4131    !!                    noea   : number for local neighboring processors
4132    !!                    nowe   : number for local neighboring processors
4133    !!                    noso   : number for local neighboring processors
4134    !!                    nono   : number for local neighboring processors
4135    !!
4136    !! History :
4137    !!        !  98-07 (J.M. Molines) Open boundary conditions
4138    !!----------------------------------------------------------------------
4139    !! * Arguments
4140    INTEGER , INTENT( in ) ::   &
4141         kd1, kd2,   &  ! starting and ending indices
4142         kl ,        &  ! index of open boundary
4143         kk,         &  ! vertical dimension
4144         ktype,      &  ! define north/south or east/west cdt
4145         !              !  = 1  north/south  ;  = 2  east/west
4146         kij            ! horizontal dimension
4147    REAL(wp), DIMENSION(kij,kk), INTENT( inout )  ::   &
4148         ptab           ! variable array
4149
4150    !! * Local variables
4151    INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
4152    INTEGER  ::   &
4153         iipt0, iipt1, ilpt1,     &  ! temporary integers
4154         ijpt0, ijpt1,            &  !    "          "
4155         imigr, iihom, ijhom         !    "          "
4156    INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend
4157    INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend
4158    REAL(wp), DIMENSION(jpi,jpj) ::   &
4159         ztab                        ! temporary workspace
4160    !!----------------------------------------------------------------------
4161
4162
4163    ! boundary condition initialization
4164    ! ---------------------------------
4165
4166    ztab(:,:) = 0.e0
4167
4168    IF( ktype==1 ) THEN                                  ! north/south boundaries
4169       iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci     ) )
4170       iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
4171       ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci     ) )
4172       ijpt0 = MAX( 1, MIN(kl  - njmpp+1, nlcj     ) )
4173       ijpt1 = MAX( 0, MIN(kl  - njmpp+1, nlcj - 1 ) )
4174    ELSEIF( ktype==2 ) THEN                              ! east/west boundaries
4175       iipt0 = MAX( 1, MIN(kl  - nimpp+1, nlci     ) )
4176       iipt1 = MAX( 0, MIN(kl  - nimpp+1, nlci - 1 ) )
4177       ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj     ) )
4178       ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
4179       ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) )
4180    ELSE
4181       CALL ctl_stop( 'mppobc: bad ktype' )
4182    ENDIF
4183
4184    DO jk = 1, kk
4185       IF( ktype==1 ) THEN                               ! north/south boundaries
4186          DO jj = ijpt0, ijpt1
4187             DO ji = iipt0, iipt1
4188                ztab(ji,jj) = ptab(ji,jk)
4189             END DO
4190          END DO
4191       ELSEIF( ktype==2 ) THEN                           ! east/west boundaries
4192          DO jj = ijpt0, ijpt1
4193             DO ji = iipt0, iipt1
4194                ztab(ji,jj) = ptab(jj,jk)
4195             END DO
4196          END DO
4197       ENDIF
4198
4199
4200       ! 1. East and west directions
4201       ! ---------------------------
4202
4203       ! 1.1 Read Dirichlet lateral conditions
4204
4205       IF( nbondi /= 2 ) THEN
4206          iihom = nlci-nreci
4207
4208          DO jl = 1, jpreci
4209             t2ew(:,jl,1) = ztab(jpreci+jl,:)
4210             t2we(:,jl,1) = ztab(iihom +jl,:)
4211          END DO
4212       ENDIF
4213
4214       ! 1.2 Migrations
4215
4216#if defined key_mpp_shmem
4217       !! *  (SHMEM version)
4218       imigr=jpreci*jpj*jpbyt
4219
4220       IF( nbondi == -1 ) THEN
4221          CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4222       ELSEIF( nbondi == 0 ) THEN
4223          CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4224          CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4225       ELSEIF( nbondi == 1 ) THEN
4226          CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4227       ENDIF
4228       CALL barrier()
4229       CALL shmem_udcflush()
4230
4231#  elif key_mpp_mpi
4232       !! * (MPI version)
4233
4234       imigr=jpreci*jpj
4235
4236       IF( nbondi == -1 ) THEN
4237          CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
4238          CALL mpprecv(1,t2ew(1,1,2),imigr)
4239          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4240       ELSEIF( nbondi == 0 ) THEN
4241          CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4242          CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
4243          CALL mpprecv(1,t2ew(1,1,2),imigr)
4244          CALL mpprecv(2,t2we(1,1,2),imigr)
4245          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4246          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4247       ELSEIF( nbondi == 1 ) THEN
4248          CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4249          CALL mpprecv(2,t2we(1,1,2),imigr)
4250          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4251       ENDIF
4252#endif
4253
4254
4255       ! 1.3 Write Dirichlet lateral conditions
4256
4257       iihom = nlci-jpreci
4258       IF( nbondi == 0 .OR. nbondi == 1 ) THEN
4259          DO jl = 1, jpreci
4260             ztab(jl,:) = t2we(:,jl,2)
4261          END DO
4262       ENDIF
4263
4264       IF( nbondi == -1 .OR. nbondi == 0 ) THEN
4265          DO jl = 1, jpreci
4266             ztab(iihom+jl,:) = t2ew(:,jl,2)
4267          END DO
4268       ENDIF
4269
4270
4271       ! 2. North and south directions
4272       ! -----------------------------
4273
4274       ! 2.1 Read Dirichlet lateral conditions
4275
4276       IF( nbondj /= 2 ) THEN
4277          ijhom = nlcj-nrecj
4278          DO jl = 1, jprecj
4279             t2sn(:,jl,1) = ztab(:,ijhom +jl)
4280             t2ns(:,jl,1) = ztab(:,jprecj+jl)
4281          END DO
4282       ENDIF
4283
4284       ! 2.2 Migrations
4285
4286#if defined key_mpp_shmem
4287       !! * SHMEM version
4288
4289       imigr=jprecj*jpi*jpbyt
4290
4291       IF( nbondj == -1 ) THEN
4292          CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4293       ELSEIF( nbondj == 0 ) THEN
4294          CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4295          CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4296       ELSEIF( nbondj == 1 ) THEN
4297          CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4298       ENDIF
4299       CALL barrier()
4300       CALL shmem_udcflush()
4301
4302#  elif key_mpp_mpi
4303       !! * Local variables   (MPI version)
4304
4305       imigr=jprecj*jpi
4306
4307       IF( nbondj == -1 ) THEN
4308          CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
4309          CALL mpprecv(3,t2ns(1,1,2),imigr)
4310          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4311       ELSEIF( nbondj == 0 ) THEN
4312          CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4313          CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
4314          CALL mpprecv(3,t2ns(1,1,2),imigr)
4315          CALL mpprecv(4,t2sn(1,1,2),imigr)
4316          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4317          IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4318       ELSEIF( nbondj == 1 ) THEN
4319          CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4320          CALL mpprecv(4,t2sn(1,1,2),imigr)
4321          IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4322       ENDIF
4323
4324#endif
4325
4326       ! 2.3 Write Dirichlet lateral conditions
4327
4328       ijhom = nlcj - jprecj
4329       IF( nbondj == 0 .OR. nbondj == 1 ) THEN
4330          DO jl = 1, jprecj
4331             ztab(:,jl) = t2sn(:,jl,2)
4332          END DO
4333       ENDIF
4334
4335       IF( nbondj == 0 .OR. nbondj == -1 ) THEN
4336          DO jl = 1, jprecj
4337             ztab(:,ijhom+jl) = t2ns(:,jl,2)
4338          END DO
4339       ENDIF
4340
4341       IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
4342          ! north/south boundaries
4343          DO jj = ijpt0,ijpt1
4344             DO ji = iipt0,ilpt1
4345                ptab(ji,jk) = ztab(ji,jj) 
4346             END DO
4347          END DO
4348       ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
4349          ! east/west boundaries
4350          DO jj = ijpt0,ilpt1
4351             DO ji = iipt0,iipt1
4352                ptab(jj,jk) = ztab(ji,jj) 
4353             END DO
4354          END DO
4355       ENDIF
4356
4357    END DO
4358
4359  END SUBROUTINE mppobc
4360
4361  SUBROUTINE mpp_comm_free( kcom)
4362
4363     INTEGER, INTENT(in) :: kcom
4364     INTEGER :: ierr
4365
4366     CALL MPI_COMM_FREE(kcom, ierr)
4367
4368  END SUBROUTINE mpp_comm_free
4369
4370
4371  SUBROUTINE mpp_ini_ice(pindic)
4372    !!----------------------------------------------------------------------
4373    !!               ***  routine mpp_ini_ice  ***
4374    !!
4375    !! ** Purpose :   Initialize special communicator for ice areas
4376    !!      condition together with global variables needed in the ddmpp folding
4377    !!
4378    !! ** Method  : - Look for ice processors in ice routines
4379    !!              - Put their number in nrank_ice
4380    !!              - Create groups for the world processors and the ice processors
4381    !!              - Create a communicator for ice processors
4382    !!
4383    !! ** output
4384    !!      njmppmax = njmpp for northern procs
4385    !!      ndim_rank_ice = number of processors in the northern line
4386    !!      nrank_north (ndim_rank_north) = number  of the northern procs.
4387    !!      ngrp_world = group ID for the world processors
4388    !!      ngrp_ice = group ID for the ice processors
4389    !!      ncomm_ice = communicator for the ice procs.
4390    !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
4391    !!
4392    !! History :
4393    !!        !  03-09 (J.M. Molines, MPI only )
4394    !!----------------------------------------------------------------------
4395#ifdef key_mpp_shmem
4396    CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' )
4397# elif key_mpp_mpi
4398    INTEGER, INTENT(in) :: pindic
4399    INTEGER :: ierr
4400    INTEGER :: jproc
4401    INTEGER :: ii,ji
4402    INTEGER, DIMENSION(jpnij) :: kice
4403    INTEGER, DIMENSION(jpnij) :: zwork
4404    INTEGER :: zrank
4405    !!----------------------------------------------------------------------
4406
4407    ! Look for how many procs with sea-ice
4408    !
4409    kice = 0
4410    DO jproc=1,jpnij
4411       IF(jproc == narea .AND. pindic .GT. 0) THEN
4412          kice(jproc) = 1   
4413       ENDIF       
4414    END DO
4415
4416    zwork = 0
4417    CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer,   &
4418                       mpi_sum, mpi_comm_opa, ierr )
4419    ndim_rank_ice = sum(zwork)         
4420
4421    ! Allocate the right size to nrank_north
4422    IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice)
4423    ALLOCATE(nrank_ice(ndim_rank_ice))
4424
4425    ii = 0     
4426    nrank_ice = 0
4427    DO jproc=1,jpnij
4428       IF(zwork(jproc) == 1) THEN
4429          ii = ii + 1
4430          nrank_ice(ii) = jproc -1 
4431       ENDIF       
4432    END DO
4433
4434    ! Create the world group
4435    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4436
4437    ! Create the ice group from the world group
4438    CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr)
4439
4440    ! Create the ice communicator , ie the pool of procs with sea-ice
4441    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr)
4442
4443    ! Find proc number in the world of proc 0 in the north
4444    CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
4445#endif
4446
4447  END SUBROUTINE mpp_ini_ice
4448
4449
4450  SUBROUTINE mpp_ini_north
4451    !!----------------------------------------------------------------------
4452    !!               ***  routine mpp_ini_north  ***
4453    !!
4454    !! ** Purpose :   Initialize special communicator for north folding
4455    !!      condition together with global variables needed in the mpp folding
4456    !!
4457    !! ** Method  : - Look for northern processors
4458    !!              - Put their number in nrank_north
4459    !!              - Create groups for the world processors and the north processors
4460    !!              - Create a communicator for northern processors
4461    !!
4462    !! ** output
4463    !!      njmppmax = njmpp for northern procs
4464    !!      ndim_rank_north = number of processors in the northern line
4465    !!      nrank_north (ndim_rank_north) = number  of the northern procs.
4466    !!      ngrp_world = group ID for the world processors
4467    !!      ngrp_north = group ID for the northern processors
4468    !!      ncomm_north = communicator for the northern procs.
4469    !!      north_root = number (in the world) of proc 0 in the northern comm.
4470    !!
4471    !! History :
4472    !!        !  03-09 (J.M. Molines, MPI only )
4473    !!----------------------------------------------------------------------
4474#ifdef key_mpp_shmem
4475    CALL ctl_stop( ' mpp_ini_north not available in SHMEM' )
4476# elif key_mpp_mpi
4477    INTEGER :: ierr
4478    INTEGER :: jproc
4479    INTEGER :: ii,ji
4480    !!----------------------------------------------------------------------
4481
4482    njmppmax=MAXVAL(njmppt)
4483
4484    ! Look for how many procs on the northern boundary
4485    !
4486    ndim_rank_north=0
4487    DO jproc=1,jpnij
4488       IF ( njmppt(jproc) == njmppmax ) THEN
4489          ndim_rank_north = ndim_rank_north + 1
4490       END IF
4491    END DO
4492
4493
4494    ! Allocate the right size to nrank_north
4495    !
4496    ALLOCATE(nrank_north(ndim_rank_north))
4497
4498    ! Fill the nrank_north array with proc. number of northern procs.
4499    ! Note : the rank start at 0 in MPI
4500    !
4501    ii=0
4502    DO ji = 1, jpnij
4503       IF ( njmppt(ji) == njmppmax   ) THEN
4504          ii=ii+1
4505          nrank_north(ii)=ji-1
4506       END IF
4507    END DO
4508    ! create the world group
4509    !
4510    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4511    !
4512    ! Create the North group from the world group
4513    CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr)
4514
4515    ! Create the North communicator , ie the pool of procs in the north group
4516    !
4517    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr)
4518
4519
4520    ! find proc number in the world of proc 0 in the north
4521    CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr)
4522#endif
4523
4524  END SUBROUTINE mpp_ini_north
4525
4526
4527   SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
4528      !!---------------------------------------------------------------------
4529      !!                   ***  routine mpp_lbc_north_3d  ***
4530      !!
4531      !! ** Purpose :
4532      !!      Ensure proper north fold horizontal bondary condition in mpp configuration
4533      !!      in case of jpn1 > 1
4534      !!
4535      !! ** Method :
4536      !!      Gather the 4 northern lines of the global domain on 1 processor and
4537      !!      apply lbc north-fold on this sub array. Then scatter the fold array
4538      !!      back to the processors.
4539      !!
4540      !! History :
4541      !!   8.5  !  03-09  (J.M. Molines ) For mpp folding condition at north
4542      !!                                  from lbc routine
4543      !!   9.0  !  03-12  (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
4544      !!----------------------------------------------------------------------
4545      !! * Arguments
4546      CHARACTER(len=1), INTENT( in ) ::   &
4547         cd_type       ! nature of pt3d grid-points
4548         !             !   = T ,  U , V , F or W  gridpoints
4549      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) ::   &
4550         pt3d          ! 3D array on which the boundary condition is applied
4551      REAL(wp),