New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

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

Last change on this file since 311 was 311, checked in by opalod, 19 years ago

nemo_v1_update_017:RB: added extra outer halo (parameters jpr2di and jpr2dj) and the corresponding lbc_lnk_e for boundary conditions.It will be use for nsolv=4.

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