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

Last change on this file since 897 was 897, checked in by rblod, 13 years ago

Add nn_buffer in namelist nammpp to control the buffer size for bsend, see ticket #116

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