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

Last change on this file since 389 was 389, checked in by opalod, 15 years ago

RB:nemo_v1_update_038: first integration of Agrif :

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