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_r1784_mid_year_merge_2010/NEMO/OPA_SRC – NEMO

source: branches/DEV_r1784_mid_year_merge_2010/NEMO/OPA_SRC/lib_mpp.F90 @ 1976

Last change on this file since 1976 was 1976, checked in by acc, 14 years ago

ticket #684 step 6: Add in changes between the head of the DEV_r1879_mpp_rep branch and the trunk@1879.

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