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

Last change on this file since 1718 was 1718, checked in by smasson, 11 years ago

fill extra-halo in mpp_lnk_2/3d with defined values, see ticket:591

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 105.1 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
20   !!----------------------------------------------------------------------
21#if   defined key_mpp_mpi 
22   !!----------------------------------------------------------------------
23   !!   'key_mpp_mpi'             MPI massively parallel processing library
24   !!----------------------------------------------------------------------
25   !!   mynode      : indentify the processor unit
26   !!   mpp_lnk     : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
27   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
28   !!   mpp_lnk_e   : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
29   !!   mpprecv     :
30   !!   mppsend     :   SUBROUTINE mpp_ini_znl
31   !!   mppscatter  :
32   !!   mppgather   :
33   !!   mpp_min     : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
34   !!   mpp_max     : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
35   !!   mpp_sum     : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
36   !!   mpp_minloc  :
37   !!   mpp_maxloc  :
38   !!   mppsync     :
39   !!   mppstop     :
40   !!   mppobc      : variant of mpp_lnk for open boundary condition
41   !!   mpp_ini_north : initialisation of north fold
42   !!   mpp_lbc_north : north fold processors gathering
43   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
44   !!----------------------------------------------------------------------
45   !! History :
46   !!        !  94 (M. Guyon, J. Escobar, M. Imbard)  Original code
47   !!        !  97  (A.M. Treguier)  SHMEM additions
48   !!        !  98  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
49   !!   9.0  !  03  (J.-M. Molines, G. Madec)  F90, free form
50   !!        !  04  (R. Bourdalle Badie)  isend option in mpi
51   !!        !  05  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
52   !!        !  05  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
53   !!        !  09  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
54   !!----------------------------------------------------------------------
55   !!  OPA 9.0 , LOCEAN-IPSL (2005)
56   !! $Id$
57   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
58   !!---------------------------------------------------------------------
59   !! * Modules used
60   USE dom_oce                    ! ocean space and time domain
61   USE in_out_manager             ! I/O manager
62   USE lbcnfd                     ! north fold treatment
63
64   IMPLICIT NONE
65   PRIVATE
66   
67   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
68   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
69   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
70   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
71   PUBLIC   mpprecv, mppsend, mppscatter, mppgather
72   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl
73#if defined key_oasis3 || defined key_oasis4
74   PUBLIC   mppsize, mpprank
75#endif
76
77   !! * Interfaces
78   !! define generic interface for these routine as they are called sometimes
79   !! with scalar arguments instead of array arguments, which causes problems
80   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
81   INTERFACE mpp_min
82      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
83   END INTERFACE
84   INTERFACE mpp_max
85      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
86   END INTERFACE
87   INTERFACE mpp_sum
88      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
89   END INTERFACE
90   INTERFACE mpp_lbc_north
91      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
92   END INTERFACE
93   INTERFACE mpp_minloc
94      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
95   END INTERFACE
96   INTERFACE mpp_maxloc
97      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
98   END INTERFACE
99
100
101   !! ========================= !!
102   !!  MPI  variable definition !!
103   !! ========================= !!
104!$AGRIF_DO_NOT_TREAT
105#  include <mpif.h>
106!$AGRIF_END_DO_NOT_TREAT
107   
108   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
109
110   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
111   
112   INTEGER ::   mppsize        ! number of process
113   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
114   INTEGER ::   mpi_comm_opa   ! opa local communicator
115
116   ! variables used in case of sea-ice
117   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice
118   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
119   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
120   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
121   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_ice     ! dimension ndim_rank_ice
122
123   ! variables used for zonal integration
124   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
125   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
126   INTEGER ::   ngrp_znl        ! group ID for the znl processors
127   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
128   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
129   
130   ! North fold condition in mpp_mpi with jpni > 1
131   INTEGER ::   ngrp_world        ! group ID for the world processors
132   INTEGER ::   ngrp_opa          ! group ID for the opa processors
133   INTEGER ::   ngrp_north        ! group ID for the northern processors (to be fold)
134   INTEGER ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
135   INTEGER ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
136   INTEGER ::   njmppmax          ! value of njmpp for the processors of the northern line
137   INTEGER ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
138   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_north   ! dimension ndim_rank_north
139
140   ! Type of send : standard, buffered, immediate
141   CHARACTER(len=1) ::   cn_mpi_send = 'S'    ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
142   LOGICAL          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
143   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend
144     
145   REAL(wp), ALLOCATABLE, DIMENSION(:) :: tampon  ! buffer in case of bsend
146
147   ! message passing arrays
148   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   t4ns, t4sn   ! 2 x 3d for north-south & south-north
149   REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) ::   t4ew, t4we   ! 2 x 3d for east-west & west-east
150   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   t4p1, t4p2   ! 2 x 3d for north fold
151   REAL(wp), DIMENSION(jpi,jprecj,jpk,2)   ::   t3ns, t3sn   ! 3d for north-south & south-north
152   REAL(wp), DIMENSION(jpj,jpreci,jpk,2)   ::   t3ew, t3we   ! 3d for east-west & west-east
153   REAL(wp), DIMENSION(jpi,jprecj,jpk,2)   ::   t3p1, t3p2   ! 3d for north fold
154   REAL(wp), DIMENSION(jpi,jprecj,2)       ::   t2ns, t2sn   ! 2d for north-south & south-north
155   REAL(wp), DIMENSION(jpj,jpreci,2)       ::   t2ew, t2we   ! 2d for east-west & west-east
156   REAL(wp), DIMENSION(jpi,jprecj,2)       ::   t2p1, t2p2   ! 2d for north fold
157   REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   tr2ns, tr2sn  ! 2d for north-south & south-north + extra outer halo
158   REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   tr2ew, tr2we  ! 2d for east-west   & west-east   + extra outer halo
159   !!----------------------------------------------------------------------
160   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)
161   !! $Id$
162   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
163   !!----------------------------------------------------------------------
164
165CONTAINS
166
167   FUNCTION mynode(ldtxt, localComm)
168      !!----------------------------------------------------------------------
169      !!                  ***  routine mynode  ***
170      !!                   
171      !! ** Purpose :   Find processor unit
172      !!
173      !!----------------------------------------------------------------------
174      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
175      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
176      INTEGER ::   mynode, ierr, code
177      LOGICAL ::   mpi_was_called
178     
179      NAMELIST/nammpp/ cn_mpi_send, nn_buffer
180      !!----------------------------------------------------------------------
181      !
182      WRITE(ldtxt(1),*)
183      WRITE(ldtxt(2),*) 'mynode : mpi initialisation'
184      WRITE(ldtxt(3),*) '~~~~~~ '
185      !
186      REWIND( numnam )               ! Namelist namrun : parameters of the run
187      READ  ( numnam, nammpp )
188      !                              ! control print
189      WRITE(ldtxt(4),*) '   Namelist nammpp'
190      WRITE(ldtxt(5),*) '      mpi send type                      cn_mpi_send = ', cn_mpi_send
191      WRITE(ldtxt(6),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer
192
193#if defined key_agrif
194      IF( Agrif_Root() ) THEN
195#endif
196         !!bug RB : should be clean to use Agrif in coupled mode
197#if ! defined key_agrif
198         CALL mpi_initialized ( mpi_was_called, code )
199         IF( code /= MPI_SUCCESS ) THEN
200            WRITE(*, cform_err)
201            WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
202            CALL mpi_abort( mpi_comm_world, code, ierr )
203         ENDIF
204
205         IF( PRESENT(localComm) .and. mpi_was_called ) THEN
206            mpi_comm_opa = localComm
207            SELECT CASE ( cn_mpi_send )
208            CASE ( 'S' )                ! Standard mpi send (blocking)
209               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
210            CASE ( 'B' )                ! Buffer mpi send (blocking)
211               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
212               CALL mpi_init_opa( ierr ) 
213            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
214               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
215               l_isend = .TRUE.
216            CASE DEFAULT
217               WRITE(ldtxt(7),cform_err)
218               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
219               nstop = nstop + 1
220            END SELECT
221         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
222            WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '
223            WRITE(ldtxt(8),*) '          without calling MPI_Init before ! '
224            nstop = nstop + 1
225         ELSE
226#endif
227            SELECT CASE ( cn_mpi_send )
228            CASE ( 'S' )                ! Standard mpi send (blocking)
229               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
230               CALL mpi_init( ierr )
231            CASE ( 'B' )                ! Buffer mpi send (blocking)
232               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
233               CALL mpi_init_opa( ierr )
234            CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
235               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
236               l_isend = .TRUE.
237               CALL mpi_init( ierr )
238            CASE DEFAULT
239               WRITE(ldtxt(7),cform_err)
240               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
241               nstop = nstop + 1
242            END SELECT
243
244#if ! defined key_agrif
245            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
246            IF( code /= MPI_SUCCESS ) THEN
247               WRITE(*, cform_err)
248               WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
249               CALL mpi_abort( mpi_comm_world, code, ierr )
250            ENDIF
251            !
252         ENDIF
253#endif
254#if defined key_agrif
255      ELSE
256         SELECT CASE ( cn_mpi_send )
257         CASE ( 'S' )                ! Standard mpi send (blocking)
258            WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
259         CASE ( 'B' )                ! Buffer mpi send (blocking)
260            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
261         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
262            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
263            l_isend = .TRUE.
264         CASE DEFAULT
265            WRITE(ldtxt(7),cform_err)
266            WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
267            nstop = nstop + 1
268         END SELECT
269      ENDIF
270
271      mpi_comm_opa = mpi_comm_world
272#endif
273      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
274      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
275      mynode = mpprank
276      !
277   END FUNCTION mynode
278
279
280   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
281      !!----------------------------------------------------------------------
282      !!                  ***  routine mpp_lnk_3d  ***
283      !!
284      !! ** Purpose :   Message passing manadgement
285      !!
286      !! ** Method  :   Use mppsend and mpprecv function for passing mask
287      !!      between processors following neighboring subdomains.
288      !!            domain parameters
289      !!                    nlci   : first dimension of the local subdomain
290      !!                    nlcj   : second dimension of the local subdomain
291      !!                    nbondi : mark for "east-west local boundary"
292      !!                    nbondj : mark for "north-south local boundary"
293      !!                    noea   : number for local neighboring processors
294      !!                    nowe   : number for local neighboring processors
295      !!                    noso   : number for local neighboring processors
296      !!                    nono   : number for local neighboring processors
297      !!
298      !! ** Action  :   ptab with update value at its periphery
299      !!
300      !!----------------------------------------------------------------------
301      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
302      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
303      !                                                             ! = T , U , V , F , W points
304      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
305      !                                                             ! =  1. , the sign is kept
306      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
307      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
308      !!
309      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
310      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
311      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
312      REAL(wp) ::   zland
313      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
314      !!----------------------------------------------------------------------
315
316      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
317      ELSE                         ;   zland = 0.e0      ! zero by default
318      ENDIF
319
320      ! 1. standard boundary treatment
321      ! ------------------------------
322      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
323         !
324         ! WARNING ptab is defined only between nld and nle
325         DO jk = 1, jpk
326            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
327               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)   
328               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
329               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
330            END DO
331            DO ji = nlci+1, jpi                 ! added column(s) (full)
332               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
333               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
334               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
335            END DO
336         END DO
337         !
338      ELSE                              ! standard close or cyclic treatment
339         !
340         !                                   ! East-West boundaries
341         !                                        !* Cyclic east-west
342         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
343            ptab( 1 ,:,:) = ptab(jpim1,:,:)
344            ptab(jpi,:,:) = ptab(  2  ,:,:)
345         ELSE                                     !* closed
346            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
347                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
348         ENDIF
349         !                                   ! North-South boundaries (always closed)
350         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
351                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
352         !
353      ENDIF
354
355      ! 2. East and west directions exchange
356      ! ------------------------------------
357      ! we play with the neigbours AND the row number because of the periodicity
358      !
359      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
360      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
361         iihom = nlci-nreci
362         DO jl = 1, jpreci
363            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
364            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
365         END DO
366      END SELECT 
367      !
368      !                           ! Migrations
369      imigr = jpreci * jpj * jpk
370      !
371      SELECT CASE ( nbondi ) 
372      CASE ( -1 )
373         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
374         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
375         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
376      CASE ( 0 )
377         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
378         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
379         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
380         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
381         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
382         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
383      CASE ( 1 )
384         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
385         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
386         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
387      END SELECT
388      !
389      !                           ! Write Dirichlet lateral conditions
390      iihom = nlci-jpreci
391      !
392      SELECT CASE ( nbondi )
393      CASE ( -1 )
394         DO jl = 1, jpreci
395            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
396         END DO
397      CASE ( 0 ) 
398         DO jl = 1, jpreci
399            ptab(jl      ,:,:) = t3we(:,jl,:,2)
400            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
401         END DO
402      CASE ( 1 )
403         DO jl = 1, jpreci
404            ptab(jl      ,:,:) = t3we(:,jl,:,2)
405         END DO
406      END SELECT
407
408
409      ! 3. North and south directions
410      ! -----------------------------
411      ! always closed : we play only with the neigbours
412      !
413      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
414         ijhom = nlcj-nrecj
415         DO jl = 1, jprecj
416            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
417            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
418         END DO
419      ENDIF
420      !
421      !                           ! Migrations
422      imigr = jprecj * jpi * jpk
423      !
424      SELECT CASE ( nbondj )     
425      CASE ( -1 )
426         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
427         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
428         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
429      CASE ( 0 )
430         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
431         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
432         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
433         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
434         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
435         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
436      CASE ( 1 ) 
437         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
438         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
439         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
440      END SELECT
441      !
442      !                           ! Write Dirichlet lateral conditions
443      ijhom = nlcj-jprecj
444      !
445      SELECT CASE ( nbondj )
446      CASE ( -1 )
447         DO jl = 1, jprecj
448            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
449         END DO
450      CASE ( 0 ) 
451         DO jl = 1, jprecj
452            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
453            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
454         END DO
455      CASE ( 1 )
456         DO jl = 1, jprecj
457            ptab(:,jl,:) = t3sn(:,jl,:,2)
458         END DO
459      END SELECT
460
461
462      ! 4. north fold treatment
463      ! -----------------------
464      !
465      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
466         !
467         SELECT CASE ( jpni )
468         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
469         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
470         END SELECT
471         !
472      ENDIF
473      !
474   END SUBROUTINE mpp_lnk_3d
475
476
477   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
478      !!----------------------------------------------------------------------
479      !!                  ***  routine mpp_lnk_2d  ***
480      !!                 
481      !! ** Purpose :   Message passing manadgement for 2d array
482      !!
483      !! ** Method  :   Use mppsend and mpprecv function for passing mask
484      !!      between processors following neighboring subdomains.
485      !!            domain parameters
486      !!                    nlci   : first dimension of the local subdomain
487      !!                    nlcj   : second dimension of the local subdomain
488      !!                    nbondi : mark for "east-west local boundary"
489      !!                    nbondj : mark for "north-south local boundary"
490      !!                    noea   : number for local neighboring processors
491      !!                    nowe   : number for local neighboring processors
492      !!                    noso   : number for local neighboring processors
493      !!                    nono   : number for local neighboring processors
494      !!
495      !!----------------------------------------------------------------------
496      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
497      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
498      !                                                         ! = T , U , V , F , W and I points
499      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
500      !                                                         ! =  1. , the sign is kept
501      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
502      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
503      !!
504      INTEGER  ::   ji, jj, jl   ! dummy loop indices
505      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
506      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
507      REAL(wp) ::   zland
508      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
509      !!----------------------------------------------------------------------
510
511      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
512      ELSE                         ;   zland = 0.e0      ! zero by default
513      ENDIF
514
515      ! 1. standard boundary treatment
516      ! ------------------------------
517      !
518      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
519         !
520         ! WARNING pt2d is defined only between nld and nle
521         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
522            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)   
523            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
524            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
525         END DO
526         DO ji = nlci+1, jpi                 ! added column(s) (full)
527            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
528            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
529            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
530         END DO
531         !
532      ELSE                              ! standard close or cyclic treatment
533         !
534         !                                   ! East-West boundaries
535         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
536            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
537            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
538            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
539         ELSE                                     ! closed
540            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
541                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
542         ENDIF
543         !                                   ! North-South boundaries (always closed)
544            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
545                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
546         !
547      ENDIF
548
549      ! 2. East and west directions exchange
550      ! ------------------------------------
551      ! we play with the neigbours AND the row number because of the periodicity
552      !
553      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
554      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
555         iihom = nlci-nreci
556         DO jl = 1, jpreci
557            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
558            t2we(:,jl,1) = pt2d(iihom +jl,:)
559         END DO
560      END SELECT
561      !
562      !                           ! Migrations
563      imigr = jpreci * jpj
564      !
565      SELECT CASE ( nbondi )
566      CASE ( -1 )
567         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
568         CALL mpprecv( 1, t2ew(1,1,2), imigr )
569         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
570      CASE ( 0 )
571         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
572         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
573         CALL mpprecv( 1, t2ew(1,1,2), imigr )
574         CALL mpprecv( 2, t2we(1,1,2), imigr )
575         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
576         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
577      CASE ( 1 )
578         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
579         CALL mpprecv( 2, t2we(1,1,2), imigr )
580         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
581      END SELECT
582      !
583      !                           ! Write Dirichlet lateral conditions
584      iihom = nlci - jpreci
585      !
586      SELECT CASE ( nbondi )
587      CASE ( -1 )
588         DO jl = 1, jpreci
589            pt2d(iihom+jl,:) = t2ew(:,jl,2)
590         END DO
591      CASE ( 0 )
592         DO jl = 1, jpreci
593            pt2d(jl      ,:) = t2we(:,jl,2)
594            pt2d(iihom+jl,:) = t2ew(:,jl,2)
595         END DO
596      CASE ( 1 )
597         DO jl = 1, jpreci
598            pt2d(jl      ,:) = t2we(:,jl,2)
599         END DO
600      END SELECT
601
602
603      ! 3. North and south directions
604      ! -----------------------------
605      ! always closed : we play only with the neigbours
606      !
607      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
608         ijhom = nlcj-nrecj
609         DO jl = 1, jprecj
610            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
611            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
612         END DO
613      ENDIF
614      !
615      !                           ! Migrations
616      imigr = jprecj * jpi
617      !
618      SELECT CASE ( nbondj )
619      CASE ( -1 )
620         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
621         CALL mpprecv( 3, t2ns(1,1,2), imigr )
622         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
623      CASE ( 0 )
624         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
625         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
626         CALL mpprecv( 3, t2ns(1,1,2), imigr )
627         CALL mpprecv( 4, t2sn(1,1,2), imigr )
628         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
629         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
630      CASE ( 1 )
631         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
632         CALL mpprecv( 4, t2sn(1,1,2), imigr )
633         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
634      END SELECT
635      !
636      !                           ! Write Dirichlet lateral conditions
637      ijhom = nlcj - jprecj
638      !
639      SELECT CASE ( nbondj )
640      CASE ( -1 )
641         DO jl = 1, jprecj
642            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
643         END DO
644      CASE ( 0 )
645         DO jl = 1, jprecj
646            pt2d(:,jl      ) = t2sn(:,jl,2)
647            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
648         END DO
649      CASE ( 1 ) 
650         DO jl = 1, jprecj
651            pt2d(:,jl      ) = t2sn(:,jl,2)
652         END DO
653      END SELECT
654
655
656      ! 4. north fold treatment
657      ! -----------------------
658      !
659      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
660         !
661         SELECT CASE ( jpni )
662         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
663         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
664         END SELECT
665         !
666      ENDIF
667      !
668   END SUBROUTINE mpp_lnk_2d
669
670
671   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
672      !!----------------------------------------------------------------------
673      !!                  ***  routine mpp_lnk_3d_gather  ***
674      !!
675      !! ** Purpose :   Message passing manadgement for two 3D arrays
676      !!
677      !! ** Method  :   Use mppsend and mpprecv function for passing mask
678      !!      between processors following neighboring subdomains.
679      !!            domain parameters
680      !!                    nlci   : first dimension of the local subdomain
681      !!                    nlcj   : second dimension of the local subdomain
682      !!                    nbondi : mark for "east-west local boundary"
683      !!                    nbondj : mark for "north-south local boundary"
684      !!                    noea   : number for local neighboring processors
685      !!                    nowe   : number for local neighboring processors
686      !!                    noso   : number for local neighboring processors
687      !!                    nono   : number for local neighboring processors
688      !!
689      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
690      !!
691      !!----------------------------------------------------------------------
692      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
693      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
694      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
695      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
696      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
697      !!                                                             ! =  1. , the sign is kept
698      INTEGER  ::   jl   ! dummy loop indices
699      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
700      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
701      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
702      !!----------------------------------------------------------------------
703
704      ! 1. standard boundary treatment
705      ! ------------------------------
706      !                                      ! East-West boundaries
707      !                                           !* Cyclic east-west
708      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
709         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
710         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
711         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
712         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
713      ELSE                                        !* closed
714         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
715         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
716                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
717                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
718      ENDIF
719
720     
721      !                                      ! North-South boundaries
722      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
723      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
724                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
725                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
726
727
728      ! 2. East and west directions exchange
729      ! ------------------------------------
730      ! we play with the neigbours AND the row number because of the periodicity
731      !
732      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
733      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
734         iihom = nlci-nreci
735         DO jl = 1, jpreci
736            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
737            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
738            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
739            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
740         END DO
741      END SELECT
742      !
743      !                           ! Migrations
744      imigr = jpreci * jpj * jpk *2
745      !
746      SELECT CASE ( nbondi ) 
747      CASE ( -1 )
748         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
749         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
750         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
751      CASE ( 0 )
752         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
753         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
754         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
755         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
756         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
757         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
758      CASE ( 1 )
759         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
760         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
761         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
762      END SELECT
763      !
764      !                           ! Write Dirichlet lateral conditions
765      iihom = nlci - jpreci
766      !
767      SELECT CASE ( nbondi )
768      CASE ( -1 )
769         DO jl = 1, jpreci
770            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
771            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
772         END DO
773      CASE ( 0 ) 
774         DO jl = 1, jpreci
775            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
776            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
777            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
778            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
779         END DO
780      CASE ( 1 )
781         DO jl = 1, jpreci
782            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
783            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
784         END DO
785      END SELECT
786
787
788      ! 3. North and south directions
789      ! -----------------------------
790      ! always closed : we play only with the neigbours
791      !
792      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
793         ijhom = nlcj - nrecj
794         DO jl = 1, jprecj
795            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
796            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
797            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
798            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
799         END DO
800      ENDIF
801      !
802      !                           ! Migrations
803      imigr = jprecj * jpi * jpk * 2
804      !
805      SELECT CASE ( nbondj )     
806      CASE ( -1 )
807         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
808         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
809         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
810      CASE ( 0 )
811         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
812         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
813         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
814         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
815         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
816         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
817      CASE ( 1 ) 
818         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
819         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
820         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
821      END SELECT
822      !
823      !                           ! Write Dirichlet lateral conditions
824      ijhom = nlcj - jprecj
825      !
826      SELECT CASE ( nbondj )
827      CASE ( -1 )
828         DO jl = 1, jprecj
829            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
830            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
831         END DO
832      CASE ( 0 ) 
833         DO jl = 1, jprecj
834            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2)
835            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
836            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2)
837            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
838         END DO
839      CASE ( 1 )
840         DO jl = 1, jprecj
841            ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
842            ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
843         END DO
844      END SELECT
845
846
847      ! 4. north fold treatment
848      ! -----------------------
849      IF( npolj /= 0 ) THEN
850         !
851         SELECT CASE ( jpni )
852         CASE ( 1 )                                           
853            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
854            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
855         CASE DEFAULT
856            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
857            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
858         END SELECT 
859         !
860      ENDIF
861      !
862   END SUBROUTINE mpp_lnk_3d_gather
863
864
865   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
866      !!----------------------------------------------------------------------
867      !!                  ***  routine mpp_lnk_2d_e  ***
868      !!                 
869      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
870      !!
871      !! ** Method  :   Use mppsend and mpprecv function for passing mask
872      !!      between processors following neighboring subdomains.
873      !!            domain parameters
874      !!                    nlci   : first dimension of the local subdomain
875      !!                    nlcj   : second dimension of the local subdomain
876      !!                    jpr2di : number of rows for extra outer halo
877      !!                    jpr2dj : number of columns for extra outer halo
878      !!                    nbondi : mark for "east-west local boundary"
879      !!                    nbondj : mark for "north-south local boundary"
880      !!                    noea   : number for local neighboring processors
881      !!                    nowe   : number for local neighboring processors
882      !!                    noso   : number for local neighboring processors
883      !!                    nono   : number for local neighboring processors
884      !!
885      !!----------------------------------------------------------------------
886      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
887      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
888      !                                                                                         ! = T , U , V , F , W and I points
889      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
890      !!                                                                                        ! north boundary, =  1. otherwise
891      INTEGER  ::   jl   ! dummy loop indices
892      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
893      INTEGER  ::   ipreci, iprecj             ! temporary integers
894      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
895      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
896      !!----------------------------------------------------------------------
897
898      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area
899      iprecj = jprecj + jpr2dj
900
901
902      ! 1. standard boundary treatment
903      ! ------------------------------
904      ! Order matters Here !!!!
905      !
906      !                                      !* North-South boundaries (always colsed)
907      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0    ! south except at F-point
908                                   pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0    ! north
909                               
910      !                                      ! East-West boundaries
911      !                                           !* Cyclic east-west
912      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
913         pt2d(1-jpr2di:     1    ,:) = pt2d(jpim1-jpr2di:  jpim1 ,:)       ! east
914         pt2d(   jpi  :jpi+jpr2di,:) = pt2d(     2      :2+jpr2di,:)       ! west
915         !
916      ELSE                                        !* closed
917         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpr2di   :jpreci    ,:) = 0.e0    ! south except at F-point
918                                      pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0    ! north
919      ENDIF
920      !
921
922      ! north fold treatment
923      ! -----------------------
924      IF( npolj /= 0 ) THEN
925         !
926         SELECT CASE ( jpni )
927         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
928         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
929         END SELECT 
930         !
931      ENDIF
932
933      ! 2. East and west directions exchange
934      ! ------------------------------------
935      ! we play with the neigbours AND the row number because of the periodicity
936      !
937      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
938      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
939         iihom = nlci-nreci-jpr2di
940         DO jl = 1, ipreci
941            tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
942            tr2we(:,jl,1) = pt2d(iihom +jl,:)
943         END DO
944      END SELECT
945      !
946      !                           ! Migrations
947      imigr = ipreci * ( jpj + 2*jpr2dj)
948      !
949      SELECT CASE ( nbondi )
950      CASE ( -1 )
951         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
952         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
953         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
954      CASE ( 0 )
955         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
956         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
957         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
958         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
959         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
960         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
961      CASE ( 1 )
962         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
963         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
964         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
965      END SELECT
966      !
967      !                           ! Write Dirichlet lateral conditions
968      iihom = nlci - jpreci
969      !
970      SELECT CASE ( nbondi )
971      CASE ( -1 )
972         DO jl = 1, ipreci
973            pt2d(iihom+jl,:) = tr2ew(:,jl,2)
974         END DO
975      CASE ( 0 )
976         DO jl = 1, ipreci
977            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
978            pt2d( iihom+jl,:) = tr2ew(:,jl,2)
979         END DO
980      CASE ( 1 )
981         DO jl = 1, ipreci
982            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
983         END DO
984      END SELECT
985
986
987      ! 3. North and south directions
988      ! -----------------------------
989      ! always closed : we play only with the neigbours
990      !
991      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
992         ijhom = nlcj-nrecj-jpr2dj
993         DO jl = 1, iprecj
994            tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
995            tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
996         END DO
997      ENDIF
998      !
999      !                           ! Migrations
1000      imigr = iprecj * ( jpi + 2*jpr2di )
1001      !
1002      SELECT CASE ( nbondj )
1003      CASE ( -1 )
1004         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1005         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1006         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1007      CASE ( 0 )
1008         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1009         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1010         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
1011         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1012         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1013         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1014      CASE ( 1 )
1015         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1016         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
1017         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1018      END SELECT
1019      !
1020      !                           ! Write Dirichlet lateral conditions
1021      ijhom = nlcj - jprecj 
1022      !
1023      SELECT CASE ( nbondj )
1024      CASE ( -1 )
1025         DO jl = 1, iprecj
1026            pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1027         END DO
1028      CASE ( 0 )
1029         DO jl = 1, iprecj
1030            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1031            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1032         END DO
1033      CASE ( 1 ) 
1034         DO jl = 1, iprecj
1035            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1036         END DO
1037      END SELECT
1038
1039   END SUBROUTINE mpp_lnk_2d_e
1040
1041
1042   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1043      !!----------------------------------------------------------------------
1044      !!                  ***  routine mppsend  ***
1045      !!                   
1046      !! ** Purpose :   Send messag passing array
1047      !!
1048      !!----------------------------------------------------------------------
1049      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1050      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1051      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1052      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1053      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1054      !!
1055      INTEGER ::   iflag
1056      !!----------------------------------------------------------------------
1057      !
1058      SELECT CASE ( cn_mpi_send )
1059      CASE ( 'S' )                ! Standard mpi send (blocking)
1060         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1061      CASE ( 'B' )                ! Buffer mpi send (blocking)
1062         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1063      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
1064         ! be carefull, one more argument here : the mpi request identifier..
1065         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1066      END SELECT
1067      !
1068   END SUBROUTINE mppsend
1069
1070
1071   SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1072      !!----------------------------------------------------------------------
1073      !!                  ***  routine mpprecv  ***
1074      !!
1075      !! ** Purpose :   Receive messag passing array
1076      !!
1077      !!----------------------------------------------------------------------
1078      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1079      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1080      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
1081      !!
1082      INTEGER :: istatus(mpi_status_size)
1083      INTEGER :: iflag
1084      !!----------------------------------------------------------------------
1085      !
1086      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1087      !
1088   END SUBROUTINE mpprecv
1089
1090
1091   SUBROUTINE mppgather( ptab, kp, pio )
1092      !!----------------------------------------------------------------------
1093      !!                   ***  routine mppgather  ***
1094      !!                   
1095      !! ** Purpose :   Transfert between a local subdomain array and a work
1096      !!     array which is distributed following the vertical level.
1097      !!
1098      !!----------------------------------------------------------------------
1099      REAL(wp), DIMENSION(jpi,jpj),       INTENT(in   ) ::   ptab   ! subdomain input array
1100      INTEGER ,                           INTENT(in   ) ::   kp     ! record length
1101      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
1102      !!
1103      INTEGER :: itaille, ierror   ! temporary integer
1104      !!---------------------------------------------------------------------
1105      !
1106      itaille = jpi * jpj
1107      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
1108         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
1109      !
1110   END SUBROUTINE mppgather
1111
1112
1113   SUBROUTINE mppscatter( pio, kp, ptab )
1114      !!----------------------------------------------------------------------
1115      !!                  ***  routine mppscatter  ***
1116      !!
1117      !! ** Purpose :   Transfert between awork array which is distributed
1118      !!      following the vertical level and the local subdomain array.
1119      !!
1120      !!----------------------------------------------------------------------
1121      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1122      INTEGER                             ::   kp        ! Tag (not used with MPI
1123      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1124      !!
1125      INTEGER :: itaille, ierror   ! temporary integer
1126      !!---------------------------------------------------------------------
1127      !
1128      itaille=jpi*jpj
1129      !
1130      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1131         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1132      !
1133   END SUBROUTINE mppscatter
1134
1135
1136   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1137      !!----------------------------------------------------------------------
1138      !!                  ***  routine mppmax_a_int  ***
1139      !!
1140      !! ** Purpose :   Find maximum value in an integer layout array
1141      !!
1142      !!----------------------------------------------------------------------
1143      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1144      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1145      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1146      !!
1147      INTEGER :: ierror, localcomm   ! temporary integer
1148      INTEGER, DIMENSION(kdim) ::   iwork
1149      !!----------------------------------------------------------------------
1150      !
1151      localcomm = mpi_comm_opa
1152      IF( PRESENT(kcom) )   localcomm = kcom
1153      !
1154      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1155      !
1156      ktab(:) = iwork(:)
1157      !
1158   END SUBROUTINE mppmax_a_int
1159
1160
1161   SUBROUTINE mppmax_int( ktab, kcom )
1162      !!----------------------------------------------------------------------
1163      !!                  ***  routine mppmax_int  ***
1164      !!
1165      !! ** Purpose :   Find maximum value in an integer layout array
1166      !!
1167      !!----------------------------------------------------------------------
1168      INTEGER, INTENT(inout)           ::   ktab      ! ???
1169      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1170      !!
1171      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1172      !!----------------------------------------------------------------------
1173      !
1174      localcomm = mpi_comm_opa 
1175      IF( PRESENT(kcom) )   localcomm = kcom
1176      !
1177      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1178      !
1179      ktab = iwork
1180      !
1181   END SUBROUTINE mppmax_int
1182
1183
1184   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1185      !!----------------------------------------------------------------------
1186      !!                  ***  routine mppmin_a_int  ***
1187      !!
1188      !! ** Purpose :   Find minimum value in an integer layout array
1189      !!
1190      !!----------------------------------------------------------------------
1191      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1192      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1193      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1194      !!
1195      INTEGER ::   ierror, localcomm   ! temporary integer
1196      INTEGER, DIMENSION(kdim) ::   iwork
1197      !!----------------------------------------------------------------------
1198      !
1199      localcomm = mpi_comm_opa
1200      IF( PRESENT(kcom) )   localcomm = kcom
1201      !
1202      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1203      !
1204      ktab(:) = iwork(:)
1205      !
1206   END SUBROUTINE mppmin_a_int
1207
1208
1209   SUBROUTINE mppmin_int( ktab, kcom )
1210      !!----------------------------------------------------------------------
1211      !!                  ***  routine mppmin_int  ***
1212      !!
1213      !! ** Purpose :   Find minimum value in an integer layout array
1214      !!
1215      !!----------------------------------------------------------------------
1216      INTEGER, INTENT(inout) ::   ktab      ! ???
1217      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1218      !!
1219      INTEGER ::  ierror, iwork, localcomm
1220      !!----------------------------------------------------------------------
1221      !
1222      localcomm = mpi_comm_opa
1223      IF( PRESENT(kcom) )   localcomm = kcom
1224      !
1225     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1226      !
1227      ktab = iwork
1228      !
1229   END SUBROUTINE mppmin_int
1230
1231
1232   SUBROUTINE mppsum_a_int( ktab, kdim )
1233      !!----------------------------------------------------------------------
1234      !!                  ***  routine mppsum_a_int  ***
1235      !!                   
1236      !! ** Purpose :   Global integer sum, 1D array case
1237      !!
1238      !!----------------------------------------------------------------------
1239      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1240      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1241      !!
1242      INTEGER :: ierror
1243      INTEGER, DIMENSION (kdim) ::  iwork
1244      !!----------------------------------------------------------------------
1245      !
1246      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1247      !
1248      ktab(:) = iwork(:)
1249      !
1250   END SUBROUTINE mppsum_a_int
1251
1252
1253   SUBROUTINE mppsum_int( ktab )
1254      !!----------------------------------------------------------------------
1255      !!                 ***  routine mppsum_int  ***
1256      !!                 
1257      !! ** Purpose :   Global integer sum
1258      !!
1259      !!----------------------------------------------------------------------
1260      INTEGER, INTENT(inout) ::   ktab
1261      !!
1262      INTEGER :: ierror, iwork
1263      !!----------------------------------------------------------------------
1264      !
1265      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1266      !
1267      ktab = iwork
1268      !
1269   END SUBROUTINE mppsum_int
1270
1271
1272   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1273      !!----------------------------------------------------------------------
1274      !!                 ***  routine mppmax_a_real  ***
1275      !!                 
1276      !! ** Purpose :   Maximum
1277      !!
1278      !!----------------------------------------------------------------------
1279      INTEGER , INTENT(in   )                  ::   kdim
1280      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1281      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1282      !!
1283      INTEGER :: ierror, localcomm
1284      REAL(wp), DIMENSION(kdim) ::  zwork
1285      !!----------------------------------------------------------------------
1286      !
1287      localcomm = mpi_comm_opa
1288      IF( PRESENT(kcom) ) localcomm = kcom
1289      !
1290      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1291      ptab(:) = zwork(:)
1292      !
1293   END SUBROUTINE mppmax_a_real
1294
1295
1296   SUBROUTINE mppmax_real( ptab, kcom )
1297      !!----------------------------------------------------------------------
1298      !!                  ***  routine mppmax_real  ***
1299      !!                   
1300      !! ** Purpose :   Maximum
1301      !!
1302      !!----------------------------------------------------------------------
1303      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1304      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1305      !!
1306      INTEGER  ::   ierror, localcomm
1307      REAL(wp) ::   zwork
1308      !!----------------------------------------------------------------------
1309      !
1310      localcomm = mpi_comm_opa 
1311      IF( PRESENT(kcom) )   localcomm = kcom
1312      !
1313      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1314      ptab = zwork
1315      !
1316   END SUBROUTINE mppmax_real
1317
1318
1319   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1320      !!----------------------------------------------------------------------
1321      !!                 ***  routine mppmin_a_real  ***
1322      !!                 
1323      !! ** Purpose :   Minimum of REAL, array case
1324      !!
1325      !!-----------------------------------------------------------------------
1326      INTEGER , INTENT(in   )                  ::   kdim
1327      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1328      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1329      !!
1330      INTEGER :: ierror, localcomm
1331      REAL(wp), DIMENSION(kdim) ::   zwork
1332      !!-----------------------------------------------------------------------
1333      !
1334      localcomm = mpi_comm_opa 
1335      IF( PRESENT(kcom) ) localcomm = kcom
1336      !
1337      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1338      ptab(:) = zwork(:)
1339      !
1340   END SUBROUTINE mppmin_a_real
1341
1342
1343   SUBROUTINE mppmin_real( ptab, kcom )
1344      !!----------------------------------------------------------------------
1345      !!                  ***  routine mppmin_real  ***
1346      !!
1347      !! ** Purpose :   minimum of REAL, scalar case
1348      !!
1349      !!-----------------------------------------------------------------------
1350      REAL(wp), INTENT(inout)           ::   ptab        !
1351      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1352      !!
1353      INTEGER  ::   ierror
1354      REAL(wp) ::   zwork
1355      INTEGER :: localcomm
1356      !!-----------------------------------------------------------------------
1357      !
1358      localcomm = mpi_comm_opa 
1359      IF( PRESENT(kcom) )   localcomm = kcom
1360      !
1361      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1362      ptab = zwork
1363      !
1364   END SUBROUTINE mppmin_real
1365
1366
1367   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1368      !!----------------------------------------------------------------------
1369      !!                  ***  routine mppsum_a_real  ***
1370      !!
1371      !! ** Purpose :   global sum, REAL ARRAY argument case
1372      !!
1373      !!-----------------------------------------------------------------------
1374      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1375      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1376      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1377      !!
1378      INTEGER                   ::   ierror    ! temporary integer
1379      INTEGER                   ::   localcomm 
1380      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1381      !!-----------------------------------------------------------------------
1382      !
1383      localcomm = mpi_comm_opa 
1384      IF( PRESENT(kcom) )   localcomm = kcom
1385      !
1386      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1387      ptab(:) = zwork(:)
1388      !
1389   END SUBROUTINE mppsum_a_real
1390
1391
1392   SUBROUTINE mppsum_real( ptab, kcom )
1393      !!----------------------------------------------------------------------
1394      !!                  ***  routine mppsum_real  ***
1395      !!             
1396      !! ** Purpose :   global sum, SCALAR argument case
1397      !!
1398      !!-----------------------------------------------------------------------
1399      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1400      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1401      !!
1402      INTEGER  ::   ierror, localcomm 
1403      REAL(wp) ::   zwork
1404      !!-----------------------------------------------------------------------
1405      !
1406      localcomm = mpi_comm_opa 
1407      IF( PRESENT(kcom) ) localcomm = kcom
1408      !
1409      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1410      ptab = zwork
1411      !
1412   END SUBROUTINE mppsum_real
1413
1414
1415   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1416      !!------------------------------------------------------------------------
1417      !!             ***  routine mpp_minloc  ***
1418      !!
1419      !! ** Purpose :   Compute the global minimum of an array ptab
1420      !!              and also give its global position
1421      !!
1422      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1423      !!
1424      !!--------------------------------------------------------------------------
1425      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1426      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1427      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1428      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1429      !!
1430      INTEGER , DIMENSION(2)   ::   ilocs
1431      INTEGER :: ierror
1432      REAL(wp) ::   zmin   ! local minimum
1433      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1434      !!-----------------------------------------------------------------------
1435      !
1436      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1437      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1438      !
1439      ki = ilocs(1) + nimpp - 1
1440      kj = ilocs(2) + njmpp - 1
1441      !
1442      zain(1,:)=zmin
1443      zain(2,:)=ki+10000.*kj
1444      !
1445      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1446      !
1447      pmin = zaout(1,1)
1448      kj = INT(zaout(2,1)/10000.)
1449      ki = INT(zaout(2,1) - 10000.*kj )
1450      !
1451   END SUBROUTINE mpp_minloc2d
1452
1453
1454   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1455      !!------------------------------------------------------------------------
1456      !!             ***  routine mpp_minloc  ***
1457      !!
1458      !! ** Purpose :   Compute the global minimum of an array ptab
1459      !!              and also give its global position
1460      !!
1461      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1462      !!
1463      !!--------------------------------------------------------------------------
1464      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1465      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1466      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1467      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1468      !!
1469      INTEGER  ::   ierror
1470      REAL(wp) ::   zmin     ! local minimum
1471      INTEGER , DIMENSION(3)   ::   ilocs
1472      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1473      !!-----------------------------------------------------------------------
1474      !
1475      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1476      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1477      !
1478      ki = ilocs(1) + nimpp - 1
1479      kj = ilocs(2) + njmpp - 1
1480      kk = ilocs(3)
1481      !
1482      zain(1,:)=zmin
1483      zain(2,:)=ki+10000.*kj+100000000.*kk
1484      !
1485      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1486      !
1487      pmin = zaout(1,1)
1488      kk   = INT( zaout(2,1) / 100000000. )
1489      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1490      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1491      !
1492   END SUBROUTINE mpp_minloc3d
1493
1494
1495   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1496      !!------------------------------------------------------------------------
1497      !!             ***  routine mpp_maxloc  ***
1498      !!
1499      !! ** Purpose :   Compute the global maximum of an array ptab
1500      !!              and also give its global position
1501      !!
1502      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1503      !!
1504      !!--------------------------------------------------------------------------
1505      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
1506      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
1507      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
1508      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
1509      !! 
1510      INTEGER  :: ierror
1511      INTEGER, DIMENSION (2)   ::   ilocs
1512      REAL(wp) :: zmax   ! local maximum
1513      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1514      !!-----------------------------------------------------------------------
1515      !
1516      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1517      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1518      !
1519      ki = ilocs(1) + nimpp - 1
1520      kj = ilocs(2) + njmpp - 1
1521      !
1522      zain(1,:) = zmax
1523      zain(2,:) = ki + 10000. * kj
1524      !
1525      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1526      !
1527      pmax = zaout(1,1)
1528      kj   = INT( zaout(2,1) / 10000.     )
1529      ki   = INT( zaout(2,1) - 10000.* kj )
1530      !
1531   END SUBROUTINE mpp_maxloc2d
1532
1533
1534   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1535      !!------------------------------------------------------------------------
1536      !!             ***  routine mpp_maxloc  ***
1537      !!
1538      !! ** Purpose :  Compute the global maximum of an array ptab
1539      !!              and also give its global position
1540      !!
1541      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1542      !!
1543      !!--------------------------------------------------------------------------
1544      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1545      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1546      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
1547      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
1548      !!   
1549      REAL(wp) :: zmax   ! local maximum
1550      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1551      INTEGER , DIMENSION(3)   ::   ilocs
1552      INTEGER :: ierror
1553      !!-----------------------------------------------------------------------
1554      !
1555      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1556      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1557      !
1558      ki = ilocs(1) + nimpp - 1
1559      kj = ilocs(2) + njmpp - 1
1560      kk = ilocs(3)
1561      !
1562      zain(1,:)=zmax
1563      zain(2,:)=ki+10000.*kj+100000000.*kk
1564      !
1565      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1566      !
1567      pmax = zaout(1,1)
1568      kk   = INT( zaout(2,1) / 100000000. )
1569      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1570      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1571      !
1572   END SUBROUTINE mpp_maxloc3d
1573
1574
1575   SUBROUTINE mppsync()
1576      !!----------------------------------------------------------------------
1577      !!                  ***  routine mppsync  ***
1578      !!                   
1579      !! ** Purpose :   Massively parallel processors, synchroneous
1580      !!
1581      !!-----------------------------------------------------------------------
1582      INTEGER :: ierror
1583      !!-----------------------------------------------------------------------
1584      !
1585      CALL mpi_barrier( mpi_comm_opa, ierror )
1586      !
1587   END SUBROUTINE mppsync
1588
1589
1590   SUBROUTINE mppstop
1591      !!----------------------------------------------------------------------
1592      !!                  ***  routine mppstop  ***
1593      !!                   
1594      !! ** purpose :   Stop massilively parallel processors method
1595      !!
1596      !!----------------------------------------------------------------------
1597      INTEGER ::   info
1598      !!----------------------------------------------------------------------
1599      !
1600      CALL mppsync
1601      CALL mpi_finalize( info )
1602      !
1603   END SUBROUTINE mppstop
1604
1605
1606   SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
1607      !!----------------------------------------------------------------------
1608      !!                  ***  routine mppobc  ***
1609      !!
1610      !! ** Purpose :   Message passing manadgement for open boundary
1611      !!     conditions array
1612      !!
1613      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1614      !!       between processors following neighboring subdomains.
1615      !!       domain parameters
1616      !!                    nlci   : first dimension of the local subdomain
1617      !!                    nlcj   : second dimension of the local subdomain
1618      !!                    nbondi : mark for "east-west local boundary"
1619      !!                    nbondj : mark for "north-south local boundary"
1620      !!                    noea   : number for local neighboring processors
1621      !!                    nowe   : number for local neighboring processors
1622      !!                    noso   : number for local neighboring processors
1623      !!                    nono   : number for local neighboring processors
1624      !!
1625      !!----------------------------------------------------------------------
1626      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices
1627      INTEGER , INTENT(in   )                     ::   kl         ! index of open boundary
1628      INTEGER , INTENT(in   )                     ::   kk         ! vertical dimension
1629      INTEGER , INTENT(in   )                     ::   ktype      ! define north/south or east/west cdt
1630      !                                                           !  = 1  north/south  ;  = 2  east/west
1631      INTEGER , INTENT(in   )                     ::   kij        ! horizontal dimension
1632      REAL(wp), INTENT(inout), DIMENSION(kij,kk)  ::   ptab       ! variable array
1633      !!
1634      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
1635      INTEGER  ::   iipt0, iipt1, ilpt1   ! temporary integers
1636      INTEGER  ::   ijpt0, ijpt1          !    -          -
1637      INTEGER  ::   imigr, iihom, ijhom   !    -          -
1638      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend
1639      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend
1640      REAL(wp), DIMENSION(jpi,jpj) ::   ztab   ! temporary workspace
1641      !!----------------------------------------------------------------------
1642
1643      ! boundary condition initialization
1644      ! ---------------------------------
1645      ztab(:,:) = 0.e0
1646      !
1647      IF( ktype==1 ) THEN                                  ! north/south boundaries
1648         iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci     ) )
1649         iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
1650         ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci     ) )
1651         ijpt0 = MAX( 1, MIN(kl  - njmpp+1, nlcj     ) )
1652         ijpt1 = MAX( 0, MIN(kl  - njmpp+1, nlcj - 1 ) )
1653      ELSEIF( ktype==2 ) THEN                              ! east/west boundaries
1654         iipt0 = MAX( 1, MIN(kl  - nimpp+1, nlci     ) )
1655         iipt1 = MAX( 0, MIN(kl  - nimpp+1, nlci - 1 ) )
1656         ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj     ) )
1657         ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
1658         ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) )
1659      ELSE
1660         CALL ctl_stop( 'mppobc: bad ktype' )
1661      ENDIF
1662     
1663      ! Communication level by level
1664      ! ----------------------------
1665!!gm Remark : this is very time consumming!!!
1666      !                                         ! ------------------------ !
1667      DO jk = 1, kk                             !   Loop over the levels   !
1668         !                                      ! ------------------------ !
1669         !
1670         IF( ktype == 1 ) THEN                               ! north/south boundaries
1671            DO jj = ijpt0, ijpt1
1672               DO ji = iipt0, iipt1
1673                  ztab(ji,jj) = ptab(ji,jk)
1674               END DO
1675            END DO
1676         ELSEIF( ktype == 2 ) THEN                           ! east/west boundaries
1677            DO jj = ijpt0, ijpt1
1678               DO ji = iipt0, iipt1
1679                  ztab(ji,jj) = ptab(jj,jk)
1680               END DO
1681            END DO
1682         ENDIF
1683
1684
1685         ! 1. East and west directions
1686         ! ---------------------------
1687         !
1688         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions
1689            iihom = nlci-nreci
1690            DO jl = 1, jpreci
1691               t2ew(:,jl,1) = ztab(jpreci+jl,:)
1692               t2we(:,jl,1) = ztab(iihom +jl,:)
1693            END DO
1694         ENDIF
1695         !
1696         !                              ! Migrations
1697         imigr=jpreci*jpj
1698         !
1699         IF( nbondi == -1 ) THEN
1700            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1701            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1702            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1703         ELSEIF( nbondi == 0 ) THEN
1704            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1705            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1706            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1707            CALL mpprecv( 2, t2we(1,1,2), imigr )
1708            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1709            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1710         ELSEIF( nbondi == 1 ) THEN
1711            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1712            CALL mpprecv( 2, t2we(1,1,2), imigr )
1713            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1714         ENDIF
1715         !
1716         !                              ! Write Dirichlet lateral conditions
1717         iihom = nlci-jpreci
1718         !
1719         IF( nbondi == 0 .OR. nbondi == 1 ) THEN
1720            DO jl = 1, jpreci
1721               ztab(jl,:) = t2we(:,jl,2)
1722            END DO
1723         ENDIF
1724         IF( nbondi == -1 .OR. nbondi == 0 ) THEN
1725            DO jl = 1, jpreci
1726               ztab(iihom+jl,:) = t2ew(:,jl,2)
1727            END DO
1728         ENDIF
1729
1730
1731         ! 2. North and south directions
1732         ! -----------------------------
1733         !
1734         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions
1735            ijhom = nlcj-nrecj
1736            DO jl = 1, jprecj
1737               t2sn(:,jl,1) = ztab(:,ijhom +jl)
1738               t2ns(:,jl,1) = ztab(:,jprecj+jl)
1739            END DO
1740         ENDIF
1741         !
1742         !                              ! Migrations
1743         imigr = jprecj * jpi
1744         !
1745         IF( nbondj == -1 ) THEN
1746            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1747            CALL mpprecv( 3, t2ns(1,1,2), imigr )
1748            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1749         ELSEIF( nbondj == 0 ) THEN
1750            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1751            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1752            CALL mpprecv( 3, t2ns(1,1,2), imigr )
1753            CALL mpprecv( 4, t2sn(1,1,2), imigr )
1754            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1755            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1756         ELSEIF( nbondj == 1 ) THEN
1757            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1758            CALL mpprecv( 4, t2sn(1,1,2), imigr)
1759            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1760         ENDIF
1761         !
1762         !                              ! Write Dirichlet lateral conditions
1763         ijhom = nlcj - jprecj
1764         IF( nbondj == 0 .OR. nbondj == 1 ) THEN
1765            DO jl = 1, jprecj
1766               ztab(:,jl) = t2sn(:,jl,2)
1767            END DO
1768         ENDIF
1769         IF( nbondj == 0 .OR. nbondj == -1 ) THEN
1770            DO jl = 1, jprecj
1771               ztab(:,ijhom+jl) = t2ns(:,jl,2)
1772            END DO
1773         ENDIF
1774         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
1775            DO jj = ijpt0, ijpt1            ! north/south boundaries
1776               DO ji = iipt0,ilpt1
1777                  ptab(ji,jk) = ztab(ji,jj) 
1778               END DO
1779            END DO
1780         ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
1781            DO jj = ijpt0, ilpt1            ! east/west boundaries
1782               DO ji = iipt0,iipt1
1783                  ptab(jj,jk) = ztab(ji,jj) 
1784               END DO
1785            END DO
1786         ENDIF
1787         !
1788      END DO
1789      !
1790   END SUBROUTINE mppobc
1791   
1792
1793   SUBROUTINE mpp_comm_free( kcom )
1794      !!----------------------------------------------------------------------
1795      !!----------------------------------------------------------------------
1796      INTEGER, INTENT(in) ::   kcom
1797      !!
1798      INTEGER :: ierr
1799      !!----------------------------------------------------------------------
1800      !
1801      CALL MPI_COMM_FREE(kcom, ierr)
1802      !
1803   END SUBROUTINE mpp_comm_free
1804
1805
1806   SUBROUTINE mpp_ini_ice( pindic )
1807      !!----------------------------------------------------------------------
1808      !!               ***  routine mpp_ini_ice  ***
1809      !!
1810      !! ** Purpose :   Initialize special communicator for ice areas
1811      !!      condition together with global variables needed in the ddmpp folding
1812      !!
1813      !! ** Method  : - Look for ice processors in ice routines
1814      !!              - Put their number in nrank_ice
1815      !!              - Create groups for the world processors and the ice processors
1816      !!              - Create a communicator for ice processors
1817      !!
1818      !! ** output
1819      !!      njmppmax = njmpp for northern procs
1820      !!      ndim_rank_ice = number of processors with ice
1821      !!      nrank_ice (ndim_rank_ice) = ice processors
1822      !!      ngrp_world = group ID for the world processors
1823      !!      ngrp_ice = group ID for the ice processors
1824      !!      ncomm_ice = communicator for the ice procs.
1825      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
1826      !!
1827      !!----------------------------------------------------------------------
1828      INTEGER, INTENT(in) :: pindic
1829      !!
1830      INTEGER :: ierr
1831      INTEGER :: jjproc
1832      INTEGER :: ii
1833      INTEGER, DIMENSION(jpnij) :: kice
1834      INTEGER, DIMENSION(jpnij) :: zwork
1835      !!----------------------------------------------------------------------
1836      !
1837      ! Look for how many procs with sea-ice
1838      !
1839      kice = 0
1840      DO jjproc = 1, jpnij
1841         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1   
1842      END DO
1843      !
1844      zwork = 0
1845      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
1846      ndim_rank_ice = SUM( zwork )         
1847
1848      ! Allocate the right size to nrank_north
1849#if ! defined key_agrif
1850      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
1851#else
1852      IF( ASSOCIATED( nrank_ice ) )   DEALLOCATE( nrank_ice )
1853#endif
1854      ALLOCATE( nrank_ice(ndim_rank_ice) )
1855      !
1856      ii = 0     
1857      nrank_ice = 0
1858      DO jjproc = 1, jpnij
1859         IF( zwork(jjproc) == 1) THEN
1860            ii = ii + 1
1861            nrank_ice(ii) = jjproc -1 
1862         ENDIF
1863      END DO
1864
1865      ! Create the world group
1866      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
1867
1868      ! Create the ice group from the world group
1869      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
1870
1871      ! Create the ice communicator , ie the pool of procs with sea-ice
1872      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
1873
1874      ! Find proc number in the world of proc 0 in the north
1875      ! The following line seems to be useless, we just comment & keep it as reminder
1876      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
1877      !
1878   END SUBROUTINE mpp_ini_ice
1879
1880
1881   SUBROUTINE mpp_ini_znl
1882      !!----------------------------------------------------------------------
1883      !!               ***  routine mpp_ini_znl  ***
1884      !!
1885      !! ** Purpose :   Initialize special communicator for computing zonal sum
1886      !!
1887      !! ** Method  : - Look for processors in the same row
1888      !!              - Put their number in nrank_znl
1889      !!              - Create group for the znl processors
1890      !!              - Create a communicator for znl processors
1891      !!              - Determine if processor should write znl files
1892      !!
1893      !! ** output
1894      !!      ndim_rank_znl = number of processors on the same row
1895      !!      ngrp_znl = group ID for the znl processors
1896      !!      ncomm_znl = communicator for the ice procs.
1897      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
1898      !!
1899      !!----------------------------------------------------------------------
1900      INTEGER :: ierr
1901      INTEGER :: jproc
1902      INTEGER :: ii
1903      INTEGER, DIMENSION(jpnij) :: kwork
1904      !
1905      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
1906      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
1907      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
1908      !
1909      IF ( jpnj == 1 ) THEN
1910         ngrp_znl  = ngrp_world
1911         ncomm_znl = mpi_comm_opa
1912      ELSE
1913         !
1914         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
1915         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
1916         !-$$        CALL flush(numout)
1917         !
1918         ! Count number of processors on the same row
1919         ndim_rank_znl = 0
1920         DO jproc=1,jpnij
1921            IF ( kwork(jproc) == njmpp ) THEN
1922               ndim_rank_znl = ndim_rank_znl + 1
1923            ENDIF
1924         END DO
1925         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
1926         !-$$        CALL flush(numout)
1927         ! Allocate the right size to nrank_znl
1928#if ! defined key_agrif
1929         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
1930#else
1931         IF (ASSOCIATED(nrank_znl)) DEALLOCATE(nrank_znl)
1932#endif
1933         ALLOCATE(nrank_znl(ndim_rank_znl))
1934         ii = 0     
1935         nrank_znl (:) = 0
1936         DO jproc=1,jpnij
1937            IF ( kwork(jproc) == njmpp) THEN
1938               ii = ii + 1
1939               nrank_znl(ii) = jproc -1 
1940            ENDIF
1941         END DO
1942         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
1943         !-$$        CALL flush(numout)
1944
1945         ! Create the opa group
1946         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
1947         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
1948         !-$$        CALL flush(numout)
1949
1950         ! Create the znl group from the opa group
1951         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
1952         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
1953         !-$$        CALL flush(numout)
1954
1955         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
1956         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
1957         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
1958         !-$$        CALL flush(numout)
1959         !
1960      END IF
1961
1962      ! Determines if processor if the first (starting from i=1) on the row
1963      IF ( jpni == 1 ) THEN
1964         l_znl_root = .TRUE.
1965      ELSE
1966         l_znl_root = .FALSE.
1967         kwork (1) = nimpp
1968         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
1969         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
1970      END IF
1971
1972   END SUBROUTINE mpp_ini_znl
1973
1974
1975   SUBROUTINE mpp_ini_north
1976      !!----------------------------------------------------------------------
1977      !!               ***  routine mpp_ini_north  ***
1978      !!
1979      !! ** Purpose :   Initialize special communicator for north folding
1980      !!      condition together with global variables needed in the mpp folding
1981      !!
1982      !! ** Method  : - Look for northern processors
1983      !!              - Put their number in nrank_north
1984      !!              - Create groups for the world processors and the north processors
1985      !!              - Create a communicator for northern processors
1986      !!
1987      !! ** output
1988      !!      njmppmax = njmpp for northern procs
1989      !!      ndim_rank_north = number of processors in the northern line
1990      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
1991      !!      ngrp_world = group ID for the world processors
1992      !!      ngrp_north = group ID for the northern processors
1993      !!      ncomm_north = communicator for the northern procs.
1994      !!      north_root = number (in the world) of proc 0 in the northern comm.
1995      !!
1996      !!----------------------------------------------------------------------
1997      INTEGER ::   ierr
1998      INTEGER ::   jjproc
1999      INTEGER ::   ii, ji
2000      !!----------------------------------------------------------------------
2001      !
2002      njmppmax = MAXVAL( njmppt )
2003      !
2004      ! Look for how many procs on the northern boundary
2005      ndim_rank_north = 0
2006      DO jjproc = 1, jpnij
2007         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2008      END DO
2009      !
2010      ! Allocate the right size to nrank_north
2011#if ! defined key_agrif
2012      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2013#else
2014      IF (ASSOCIATED(nrank_north)) DEALLOCATE(nrank_north)
2015#endif
2016      ALLOCATE( nrank_north(ndim_rank_north) )
2017
2018      ! Fill the nrank_north array with proc. number of northern procs.
2019      ! Note : the rank start at 0 in MPI
2020      ii = 0
2021      DO ji = 1, jpnij
2022         IF ( njmppt(ji) == njmppmax   ) THEN
2023            ii=ii+1
2024            nrank_north(ii)=ji-1
2025         END IF
2026      END DO
2027      !
2028      ! create the world group
2029      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2030      !
2031      ! Create the North group from the world group
2032      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2033      !
2034      ! Create the North communicator , ie the pool of procs in the north group
2035      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2036      !
2037   END SUBROUTINE mpp_ini_north
2038
2039
2040   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2041      !!---------------------------------------------------------------------
2042      !!                   ***  routine mpp_lbc_north_3d  ***
2043      !!
2044      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2045      !!              in mpp configuration in case of jpn1 > 1
2046      !!
2047      !! ** Method  :   North fold condition and mpp with more than one proc
2048      !!              in i-direction require a specific treatment. We gather
2049      !!              the 4 northern lines of the global domain on 1 processor
2050      !!              and apply lbc north-fold on this sub array. Then we
2051      !!              scatter the north fold array back to the processors.
2052      !!
2053      !!----------------------------------------------------------------------
2054      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2055      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2056      !                                                              !   = T ,  U , V , F or W  gridpoints
2057      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2058      !!                                                             ! =  1. , the sign is kept
2059      INTEGER ::   ji, jj, jr
2060      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2061      INTEGER ::   ijpj, ijpjm1, ij, iproc
2062      REAL(wp), DIMENSION(jpiglo,4,jpk)      ::   ztab
2063      REAL(wp), DIMENSION(jpi   ,4,jpk)      ::   znorthloc
2064      REAL(wp), DIMENSION(jpi   ,4,jpk,jpni) ::   znorthgloio
2065      !!----------------------------------------------------------------------
2066      !   
2067      ijpj   = 4
2068      ijpjm1 = 3
2069      !
2070      DO jj = nlcj - ijpj +1, nlcj          ! put in znorthloc the last 4 jlines of pt3d
2071         ij = jj - nlcj + ijpj
2072         znorthloc(:,ij,:) = pt3d(:,jj,:)
2073      END DO
2074      !
2075      !                                     ! Build in procs of ncomm_north the znorthgloio
2076      itaille = jpi * jpk * ijpj
2077      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2078         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2079      !
2080      !                                     ! recover the global north array
2081      DO jr = 1, ndim_rank_north
2082         iproc = nrank_north(jr) + 1
2083         ildi  = nldit (iproc)
2084         ilei  = nleit (iproc)
2085         iilb  = nimppt(iproc)
2086         DO jj = 1, 4
2087            DO ji = ildi, ilei
2088               ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2089            END DO
2090         END DO
2091      END DO
2092      !
2093      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2094      !
2095      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2096         ij = jj - nlcj + ijpj
2097         DO ji= 1, nlci
2098            pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2099         END DO
2100      END DO
2101      !
2102   END SUBROUTINE mpp_lbc_north_3d
2103
2104
2105   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2106      !!---------------------------------------------------------------------
2107      !!                   ***  routine mpp_lbc_north_2d  ***
2108      !!
2109      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2110      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2111      !!
2112      !! ** Method  :   North fold condition and mpp with more than one proc
2113      !!              in i-direction require a specific treatment. We gather
2114      !!              the 4 northern lines of the global domain on 1 processor
2115      !!              and apply lbc north-fold on this sub array. Then we
2116      !!              scatter the north fold array back to the processors.
2117      !!
2118      !!----------------------------------------------------------------------
2119      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the b.c. is applied
2120      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2121      !                                                          !   = T ,  U , V , F or W  gridpoints
2122      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2123      !!                                                             ! =  1. , the sign is kept
2124      INTEGER ::   ji, jj, jr
2125      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2126      INTEGER ::   ijpj, ijpjm1, ij, iproc
2127      REAL(wp), DIMENSION(jpiglo,4)      ::   ztab
2128      REAL(wp), DIMENSION(jpi   ,4)      ::   znorthloc
2129      REAL(wp), DIMENSION(jpi   ,4,jpni) ::   znorthgloio
2130      !!----------------------------------------------------------------------
2131      !
2132      ijpj   = 4
2133      ijpjm1 = 3
2134      !
2135      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2136         ij = jj - nlcj + ijpj
2137         znorthloc(:,ij) = pt2d(:,jj)
2138      END DO
2139
2140      !                                     ! Build in procs of ncomm_north the znorthgloio
2141      itaille = jpi * ijpj
2142      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2143         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2144      !
2145      DO jr = 1, ndim_rank_north            ! recover the global north array
2146         iproc = nrank_north(jr) + 1
2147         ildi=nldit (iproc)
2148         ilei=nleit (iproc)
2149         iilb=nimppt(iproc)
2150         DO jj = 1, 4
2151            DO ji = ildi, ilei
2152               ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2153            END DO
2154         END DO
2155      END DO
2156      !
2157      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2158      !
2159      !
2160      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2161         ij = jj - nlcj + ijpj
2162         DO ji = 1, nlci
2163            pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2164         END DO
2165      END DO
2166      !
2167   END SUBROUTINE mpp_lbc_north_2d
2168
2169
2170   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2171      !!---------------------------------------------------------------------
2172      !!                   ***  routine mpp_lbc_north_2d  ***
2173      !!
2174      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2175      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2176      !!              array with outer extra halo
2177      !!
2178      !! ** Method  :   North fold condition and mpp with more than one proc
2179      !!              in i-direction require a specific treatment. We gather
2180      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2181      !!              processor and apply lbc north-fold on this sub array.
2182      !!              Then we scatter the north fold array back to the processors.
2183      !!
2184      !!----------------------------------------------------------------------
2185      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2186      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2187      !                                                                                         !   = T ,  U , V , F or W -points
2188      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
2189      !!                                                                                        ! north fold, =  1. otherwise
2190      INTEGER ::   ji, jj, jr
2191      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2192      INTEGER ::   ijpj, ij, iproc
2193      REAL(wp), DIMENSION(jpiglo,4+2*jpr2dj)      ::   ztab
2194      REAL(wp), DIMENSION(jpi   ,4+2*jpr2dj)      ::   znorthloc
2195      REAL(wp), DIMENSION(jpi   ,4+2*jpr2dj,jpni) ::   znorthgloio
2196      !!----------------------------------------------------------------------
2197      !
2198      ijpj=4
2199
2200      ij=0
2201      ! put in znorthloc the last 4 jlines of pt2d
2202      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2203         ij = ij + 1
2204         DO ji = 1, jpi
2205            znorthloc(ji,ij)=pt2d(ji,jj)
2206         END DO
2207      END DO
2208      !
2209      itaille = jpi * ( ijpj + 2 * jpr2dj )
2210      CALL MPI_ALLGATHER( znorthloc(1,1)    , itaille, MPI_DOUBLE_PRECISION,    &
2211         &                znorthgloio(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2212      !
2213      DO jr = 1, ndim_rank_north            ! recover the global north array
2214         iproc = nrank_north(jr) + 1
2215         ildi = nldit (iproc)
2216         ilei = nleit (iproc)
2217         iilb = nimppt(iproc)
2218         DO jj = 1, ijpj+2*jpr2dj
2219            DO ji = ildi, ilei
2220               ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2221            END DO
2222         END DO
2223      END DO
2224
2225
2226      ! 2. North-Fold boundary conditions
2227      ! ----------------------------------
2228      CALL lbc_nfd( ztab(:,:), cd_type, psgn, pr2dj = jpr2dj )
2229
2230      ij = jpr2dj
2231      !! Scatter back to pt2d
2232      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2233      ij  = ij +1 
2234         DO ji= 1, nlci
2235            pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2236         END DO
2237      END DO
2238      !
2239   END SUBROUTINE mpp_lbc_north_e
2240
2241
2242   SUBROUTINE mpi_init_opa( code )
2243      !!---------------------------------------------------------------------
2244      !!                   ***  routine mpp_init.opa  ***
2245      !!
2246      !! ** Purpose :: export and attach a MPI buffer for bsend
2247      !!
2248      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
2249      !!            but classical mpi_init
2250      !!
2251      !! History :: 01/11 :: IDRIS initial version for IBM only 
2252      !!            08/04 :: R. Benshila, generalisation
2253      !!---------------------------------------------------------------------
2254      INTEGER                                 :: code, ierr
2255      LOGICAL                                 :: mpi_was_called
2256      !!---------------------------------------------------------------------
2257      !
2258      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
2259      IF ( code /= MPI_SUCCESS ) THEN
2260         CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
2261         CALL mpi_abort( mpi_comm_world, code, ierr )
2262      ENDIF
2263      !
2264      IF( .NOT. mpi_was_called ) THEN
2265         CALL mpi_init( code )
2266         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2267         IF ( code /= MPI_SUCCESS ) THEN
2268            CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
2269            CALL mpi_abort( mpi_comm_world, code, ierr )
2270         ENDIF
2271      ENDIF
2272      !
2273      IF( nn_buffer > 0 ) THEN
2274         IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of  : ', nn_buffer
2275         ! Buffer allocation and attachment
2276         ALLOCATE( tampon(nn_buffer) )
2277         CALL mpi_buffer_attach( tampon, nn_buffer,code )
2278      ENDIF
2279      !
2280   END SUBROUTINE mpi_init_opa
2281
2282#else
2283   !!----------------------------------------------------------------------
2284   !!   Default case:            Dummy module        share memory computing
2285   !!----------------------------------------------------------------------
2286   INTERFACE mpp_sum
2287      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
2288   END INTERFACE
2289   INTERFACE mpp_max
2290      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
2291   END INTERFACE
2292   INTERFACE mpp_min
2293      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
2294   END INTERFACE
2295   INTERFACE mppobc
2296      MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
2297   END INTERFACE
2298   INTERFACE mpp_minloc
2299      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
2300   END INTERFACE
2301   INTERFACE mpp_maxloc
2302      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
2303   END INTERFACE
2304
2305
2306   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
2307   INTEGER :: ncomm_ice
2308
2309CONTAINS
2310
2311   FUNCTION mynode( ldtxt, localComm ) RESULT (function_value)
2312      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
2313      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
2314      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
2315      IF( .FALSE. )   ldtxt(:) = 'never done'
2316   END FUNCTION mynode
2317
2318   SUBROUTINE mppsync                       ! Dummy routine
2319   END SUBROUTINE mppsync
2320
2321   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
2322      REAL   , DIMENSION(:) :: parr
2323      INTEGER               :: kdim
2324      INTEGER, OPTIONAL     :: kcom 
2325      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
2326   END SUBROUTINE mpp_sum_as
2327
2328   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
2329      REAL   , DIMENSION(:,:) :: parr
2330      INTEGER               :: kdim
2331      INTEGER, OPTIONAL     :: kcom 
2332      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
2333   END SUBROUTINE mpp_sum_a2s
2334
2335   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
2336      INTEGER, DIMENSION(:) :: karr
2337      INTEGER               :: kdim
2338      INTEGER, OPTIONAL     :: kcom 
2339      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
2340   END SUBROUTINE mpp_sum_ai
2341
2342   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
2343      REAL                  :: psca
2344      INTEGER, OPTIONAL     :: kcom 
2345      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
2346   END SUBROUTINE mpp_sum_s
2347
2348   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
2349      integer               :: kint
2350      INTEGER, OPTIONAL     :: kcom 
2351      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
2352   END SUBROUTINE mpp_sum_i
2353
2354   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
2355      REAL   , DIMENSION(:) :: parr
2356      INTEGER               :: kdim
2357      INTEGER, OPTIONAL     :: kcom 
2358      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2359   END SUBROUTINE mppmax_a_real
2360
2361   SUBROUTINE mppmax_real( psca, kcom )
2362      REAL                  :: psca
2363      INTEGER, OPTIONAL     :: kcom 
2364      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2365   END SUBROUTINE mppmax_real
2366
2367   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2368      REAL   , DIMENSION(:) :: parr
2369      INTEGER               :: kdim
2370      INTEGER, OPTIONAL     :: kcom 
2371      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2372   END SUBROUTINE mppmin_a_real
2373
2374   SUBROUTINE mppmin_real( psca, kcom )
2375      REAL                  :: psca
2376      INTEGER, OPTIONAL     :: kcom 
2377      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2378   END SUBROUTINE mppmin_real
2379
2380   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2381      INTEGER, DIMENSION(:) :: karr
2382      INTEGER               :: kdim
2383      INTEGER, OPTIONAL     :: kcom 
2384      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2385   END SUBROUTINE mppmax_a_int
2386
2387   SUBROUTINE mppmax_int( kint, kcom)
2388      INTEGER               :: kint
2389      INTEGER, OPTIONAL     :: kcom 
2390      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2391   END SUBROUTINE mppmax_int
2392
2393   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2394      INTEGER, DIMENSION(:) :: karr
2395      INTEGER               :: kdim
2396      INTEGER, OPTIONAL     :: kcom 
2397      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2398   END SUBROUTINE mppmin_a_int
2399
2400   SUBROUTINE mppmin_int( kint, kcom )
2401      INTEGER               :: kint
2402      INTEGER, OPTIONAL     :: kcom 
2403      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2404   END SUBROUTINE mppmin_int
2405
2406   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
2407      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2408      REAL, DIMENSION(:) ::   parr           ! variable array
2409      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij
2410   END SUBROUTINE mppobc_1d
2411
2412   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
2413      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2414      REAL, DIMENSION(:,:) ::   parr           ! variable array
2415      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij
2416   END SUBROUTINE mppobc_2d
2417
2418   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
2419      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2420      REAL, DIMENSION(:,:,:) ::   parr           ! variable array
2421      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
2422   END SUBROUTINE mppobc_3d
2423
2424   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
2425      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2426      REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array
2427      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
2428   END SUBROUTINE mppobc_4d
2429
2430   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2431      REAL                   :: pmin
2432      REAL , DIMENSION (:,:) :: ptab, pmask
2433      INTEGER :: ki, kj
2434      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2435   END SUBROUTINE mpp_minloc2d
2436
2437   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2438      REAL                     :: pmin
2439      REAL , DIMENSION (:,:,:) :: ptab, pmask
2440      INTEGER :: ki, kj, kk
2441      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2442   END SUBROUTINE mpp_minloc3d
2443
2444   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2445      REAL                   :: pmax
2446      REAL , DIMENSION (:,:) :: ptab, pmask
2447      INTEGER :: ki, kj
2448      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2449   END SUBROUTINE mpp_maxloc2d
2450
2451   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2452      REAL                     :: pmax
2453      REAL , DIMENSION (:,:,:) :: ptab, pmask
2454      INTEGER :: ki, kj, kk
2455      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2456   END SUBROUTINE mpp_maxloc3d
2457
2458   SUBROUTINE mppstop
2459      WRITE(*,*) 'mppstop: You should not have seen this print! error?'
2460   END SUBROUTINE mppstop
2461
2462   SUBROUTINE mpp_ini_ice( kcom )
2463      INTEGER :: kcom
2464      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom
2465   END SUBROUTINE mpp_ini_ice
2466
2467   SUBROUTINE mpp_ini_znl
2468      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?'
2469   END SUBROUTINE mpp_ini_znl
2470
2471   SUBROUTINE mpp_comm_free( kcom )
2472      INTEGER :: kcom
2473      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
2474   END SUBROUTINE mpp_comm_free
2475
2476#endif
2477   !!----------------------------------------------------------------------
2478END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.