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

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

source: branches/DEV_r2106_LOCEAN2010/NEMO/OPA_SRC/lib_mpp.F90 @ 2236

Last change on this file since 2236 was 2236, checked in by cetlod, 13 years ago

First guess of NEMO_v3.3

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