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/2012/dev_r3365_CMCC1_BDYOBCopt/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2012/dev_r3365_CMCC1_BDYOBCopt/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3592

Last change on this file since 3592 was 3592, checked in by vichi, 10 years ago

OBC and BDY optimization by CMCC

Also Added ARCH/CMCC folder with PW6_calypso archfiles.

The CMCC achitecture files for calypso are :

  • PW6_calypso fro compiling NEMO release configuration
  • PW6_calypso_debug for debugging NEMO
  • PW6_calypso_tools to compile toolswith xlf90 for serial job
  • Property svn:keywords set to Id
File size: 161.1 KB
Line 
1MODULE lib_mpp
2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
4   !! Ocean numerics:  massively parallel processing library
5   !!=====================================================================
6   !! History :  OPA  !  1994  (M. Guyon, J. Escobar, M. Imbard)  Original code
7   !!            7.0  !  1997  (A.M. Treguier)  SHMEM additions
8   !!            8.0  !  1998  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
9   !!                 !  1998  (J.M. Molines) Open boundary conditions
10   !!   NEMO     1.0  !  2003  (J.-M. Molines, G. Madec)  F90, free form
11   !!                 !  2003  (J.M. Molines) add mpp_ini_north(_3d,_2d)
12   !!             -   !  2004  (R. Bourdalle Badie)  isend option in mpi
13   !!                 !  2004  (J.M. Molines) minloc, maxloc
14   !!             -   !  2005  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
15   !!             -   !  2005  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
16   !!             -   !  2005  (R. Benshila, G. Madec)  add extra halo case
17   !!             -   !  2008  (R. Benshila) add mpp_ini_ice
18   !!            3.2  !  2009  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
21   !!            3.5  !  2012  (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
22   !!                          'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
23   !!                          the mppobc routine to optimize the BDY and OBC communications
24   !!----------------------------------------------------------------------
25
26   !!----------------------------------------------------------------------
27   !!   ctl_stop   : update momentum and tracer Kz from a tke scheme
28   !!   ctl_warn   : initialization, namelist read, and parameters control
29   !!   ctl_opn    : Open file and check if required file is available.
30   !!   get_unit    : give the index of an unused logical unit
31   !!----------------------------------------------------------------------
32#if   defined key_mpp_mpi 
33   !!----------------------------------------------------------------------
34   !!   'key_mpp_mpi'             MPI massively parallel processing library
35   !!----------------------------------------------------------------------
36   !!   lib_mpp_alloc : allocate mpp arrays
37   !!   mynode        : indentify the processor unit
38   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
39   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
40   !!   mpp_lnk_e     : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
41   !!   mpprecv         :
42   !!   mppsend       :   SUBROUTINE mpp_ini_znl
43   !!   mppscatter    :
44   !!   mppgather     :
45   !!   mpp_min       : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
46   !!   mpp_max       : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
47   !!   mpp_sum       : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
48   !!   mpp_minloc    :
49   !!   mpp_maxloc    :
50   !!   mppsync       :
51   !!   mppstop       :
52   !!   mppobc        : variant of mpp_lnk for open boundary condition
53   !!   mpp_ini_north : initialisation of north fold
54   !!   mpp_lbc_north : north fold processors gathering
55   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
56   !!----------------------------------------------------------------------
57   USE dom_oce        ! ocean space and time domain
58   USE lbcnfd         ! north fold treatment
59   USE in_out_manager ! I/O manager
60
61   IMPLICIT NONE
62   PRIVATE
63   
64   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn
65   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
66   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
67   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
68   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
69   PUBLIC   mppscatter, mppgather
70   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl
71   PUBLIC   mppsize
72   PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90
73   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
74   PUBLIC   mpp_lnk_obc_2d, mpp_lnk_obc_3d
75
76   !! * Interfaces
77   !! define generic interface for these routine as they are called sometimes
78   !! with scalar arguments instead of array arguments, which causes problems
79   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
80   INTERFACE mpp_min
81      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
82   END INTERFACE
83   INTERFACE mpp_max
84      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
85   END INTERFACE
86   INTERFACE mpp_sum
87# if defined key_mpp_rep
88      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
89                       mppsum_realdd, mppsum_a_realdd
90# else
91      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
92# endif
93   END INTERFACE
94   INTERFACE mpp_lbc_north
95      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
96   END INTERFACE
97   INTERFACE mpp_minloc
98      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
99   END INTERFACE
100   INTERFACE mpp_maxloc
101      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
102   END INTERFACE
103   
104   !! ========================= !!
105   !!  MPI  variable definition !!
106   !! ========================= !!
107!$AGRIF_DO_NOT_TREAT
108   INCLUDE 'mpif.h'
109!$AGRIF_END_DO_NOT_TREAT
110   
111   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
112
113   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
114   
115   INTEGER ::   mppsize        ! number of process
116   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
117!$AGRIF_DO_NOT_TREAT
118   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
119!$AGRIF_END_DO_NOT_TREAT
120
121# if defined key_mpp_rep
122   INTEGER :: MPI_SUMDD
123# endif
124
125   ! variables used in case of sea-ice
126   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice
127   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
128   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
129   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
130   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
131
132   ! variables used for zonal integration
133   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
134   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
135   INTEGER ::   ngrp_znl        ! group ID for the znl processors
136   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
137   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
138   
139   ! North fold condition in mpp_mpi with jpni > 1
140   INTEGER ::   ngrp_world        ! group ID for the world processors
141   INTEGER ::   ngrp_opa          ! group ID for the opa processors
142   INTEGER ::   ngrp_north        ! group ID for the northern processors (to be fold)
143   INTEGER ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
144   INTEGER ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
145   INTEGER ::   njmppmax          ! value of njmpp for the processors of the northern line
146   INTEGER ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
147   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   ! dimension ndim_rank_north
148
149   ! Type of send : standard, buffered, immediate
150   CHARACTER(len=1) ::   cn_mpi_send = 'S'    ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
151   LOGICAL          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
152   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend
153     
154   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend
155
156   ! message passing arrays
157   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4ns, t4sn   ! 2 x 3d for north-south & south-north
158   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4ew, t4we   ! 2 x 3d for east-west & west-east
159   REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE ::   t4p1, t4p2   ! 2 x 3d for north fold
160   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3ns, t3sn   ! 3d for north-south & south-north
161   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3ew, t3we   ! 3d for east-west & west-east
162   REAL(wp), DIMENSION(:,:,:,:)  , ALLOCATABLE, SAVE ::   t3p1, t3p2   ! 3d for north fold
163   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2ns, t2sn   ! 2d for north-south & south-north
164   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2ew, t2we   ! 2d for east-west & west-east
165   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   t2p1, t2p2   ! 2d for north fold
166   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo
167   REAL(wp), DIMENSION(:,:,:)    , ALLOCATABLE, SAVE ::   tr2ew, tr2we ! 2d for east-west   & west-east   + extra outer halo
168
169   ! Arrays used in mpp_lbc_north_3d()
170   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   ztab, znorthloc
171   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE   ::   znorthgloio
172   REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE, SAVE   ::   zfoldwk      ! Workspace for message transfers avoiding mpi_allgather
173
174   ! Arrays used in mpp_lbc_north_2d()
175   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_2d, znorthloc_2d
176   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_2d
177   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   zfoldwk_2d    ! Workspace for message transfers avoiding mpi_allgather
178
179   ! Arrays used in mpp_lbc_north_e()
180   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, SAVE    ::   ztab_e, znorthloc_e
181   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE    ::   znorthgloio_e
182
183   ! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public
184   INTEGER, PUBLIC,  PARAMETER :: jpmaxngh = 8                 ! Assumed maximum number of active neighbours
185   INTEGER, PUBLIC,  PARAMETER :: jptyps   = 5                 ! Number of different neighbour lists to be used for northfold exchanges
186   INTEGER, PUBLIC,  DIMENSION (jpmaxngh,jptyps)    ::   isendto
187   INTEGER, PUBLIC,  DIMENSION (jptyps)             ::   nsndto
188   LOGICAL, PUBLIC                                  ::   ln_nnogather     = .FALSE.  ! namelist control of northfold comms
189   LOGICAL, PUBLIC                                  ::   l_north_nogather = .FALSE.  ! internal control of northfold comms
190   INTEGER, PUBLIC                                  ::   ityp
191   !!----------------------------------------------------------------------
192   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
193   !! $Id: lib_mpp.F90 3294 2012-01-28 16:44:18Z rblod $
194   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
195   !!----------------------------------------------------------------------
196CONTAINS
197
198   INTEGER FUNCTION lib_mpp_alloc( kumout )
199      !!----------------------------------------------------------------------
200      !!              ***  routine lib_mpp_alloc  ***
201      !!----------------------------------------------------------------------
202      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
203      !!----------------------------------------------------------------------
204      !
205      ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) ,                                            &
206         &      t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) ,                                            &
207         &      t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) ,                                            &
208         &      t3ns(jpi,jprecj,jpk,2)   , t3sn(jpi,jprecj,jpk,2)   ,                                            &
209         &      t3ew(jpj,jpreci,jpk,2)   , t3we(jpj,jpreci,jpk,2)   ,                                            &
210         &      t3p1(jpi,jprecj,jpk,2)   , t3p2(jpi,jprecj,jpk,2)   ,                                            &
211         &      t2ns(jpi,jprecj    ,2)   , t2sn(jpi,jprecj    ,2)   ,                                            &
212         &      t2ew(jpj,jpreci    ,2)   , t2we(jpj,jpreci    ,2)   ,                                            &
213         &      t2p1(jpi,jprecj    ,2)   , t2p2(jpi,jprecj    ,2)   ,                                            &
214         !
215         &      tr2ns(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     &
216         &      tr2sn(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ,                                                     &
217         &      tr2ew(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     &
218         &      tr2we(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ,                                                     &
219         !
220         &      ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk) , znorthgloio(jpi,4,jpk,jpni) ,                        &
221         &      zfoldwk(jpi,4,jpk) ,                                                                             &
222         !
223         &      ztab_2d(jpiglo,4)  , znorthloc_2d(jpi,4)  , znorthgloio_2d(jpi,4,jpni)  ,                        &
224         &      zfoldwk_2d(jpi,4)  ,                                                                             &
225         !
226         &      ztab_e(jpiglo,4+2*jpr2dj) , znorthloc_e(jpi,4+2*jpr2dj) , znorthgloio_e(jpi,4+2*jpr2dj,jpni) ,   &
227         !
228         &      STAT=lib_mpp_alloc )
229         !
230      IF( lib_mpp_alloc /= 0 ) THEN
231         WRITE(kumout,cform_war)
232         WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays'
233      ENDIF
234      !
235   END FUNCTION lib_mpp_alloc
236
237
238   FUNCTION mynode( ldtxt, kumnam, kstop, localComm )
239      !!----------------------------------------------------------------------
240      !!                  ***  routine mynode  ***
241      !!                   
242      !! ** Purpose :   Find processor unit
243      !!----------------------------------------------------------------------
244      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
245      INTEGER                      , INTENT(in   ) ::   kumnam       ! namelist logical unit
246      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
247      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
248      !
249      INTEGER ::   mynode, ierr, code, ji, ii
250      LOGICAL ::   mpi_was_called
251      !
252      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
253      !!----------------------------------------------------------------------
254      !
255      ii = 1
256      WRITE(ldtxt(ii),*)                                                                          ;   ii = ii + 1
257      WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                            ;   ii = ii + 1
258      WRITE(ldtxt(ii),*) '~~~~~~ '                                                                ;   ii = ii + 1
259      !
260      jpni = -1; jpnj = -1; jpnij = -1
261      REWIND( kumnam )               ! Namelist namrun : parameters of the run
262      READ  ( kumnam, nammpp )
263      !                              ! control print
264      WRITE(ldtxt(ii),*) '   Namelist nammpp'                                                     ;   ii = ii + 1
265      WRITE(ldtxt(ii),*) '      mpi send type                      cn_mpi_send = ', cn_mpi_send   ;   ii = ii + 1
266      WRITE(ldtxt(ii),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer     ;   ii = ii + 1
267
268#if defined key_agrif
269      IF( .NOT. Agrif_Root() ) THEN
270         jpni  = Agrif_Parent(jpni ) 
271         jpnj  = Agrif_Parent(jpnj )
272         jpnij = Agrif_Parent(jpnij)
273      ENDIF
274#endif
275
276      IF(jpnij < 1)THEN
277         ! If jpnij is not specified in namelist then we calculate it - this
278         ! means there will be no land cutting out.
279         jpnij = jpni * jpnj
280      END IF
281
282      IF( (jpni < 1) .OR. (jpnj < 1) )THEN
283         WRITE(ldtxt(ii),*) '      jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
284      ELSE
285         WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni; ii = ii + 1
286         WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj; ii = ii + 1
287         WRITE(ldtxt(ii),*) '      number of local domains           jpnij = ',jpnij; ii = ii +1
288      END IF
289
290      WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1
291
292      CALL mpi_initialized ( mpi_was_called, code )
293      IF( code /= MPI_SUCCESS ) THEN
294         DO ji = 1, SIZE(ldtxt) 
295            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
296         END DO         
297         WRITE(*, cform_err)
298         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
299         CALL mpi_abort( mpi_comm_world, code, ierr )
300      ENDIF
301
302      IF( mpi_was_called ) THEN
303         !
304         SELECT CASE ( cn_mpi_send )
305         CASE ( 'S' )                ! Standard mpi send (blocking)
306            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
307         CASE ( 'B' )                ! Buffer mpi send (blocking)
308            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
309            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr ) 
310         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
311            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
312            l_isend = .TRUE.
313         CASE DEFAULT
314            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
315            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
316            kstop = kstop + 1
317         END SELECT
318      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
319         WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '                  ;   ii = ii + 1
320         WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                        ;   ii = ii + 1
321         kstop = kstop + 1
322      ELSE
323         SELECT CASE ( cn_mpi_send )
324         CASE ( 'S' )                ! Standard mpi send (blocking)
325            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
326            CALL mpi_init( ierr )
327         CASE ( 'B' )                ! Buffer mpi send (blocking)
328            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
329            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
330         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
331            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
332            l_isend = .TRUE.
333            CALL mpi_init( ierr )
334         CASE DEFAULT
335            WRITE(ldtxt(ii),cform_err)                                                            ;   ii = ii + 1
336            WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send             ;   ii = ii + 1
337            kstop = kstop + 1
338         END SELECT
339         !
340      ENDIF
341
342      IF( PRESENT(localComm) ) THEN
343         IF( Agrif_Root() ) THEN
344            mpi_comm_opa = localComm
345         ENDIF
346      ELSE
347         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
348         IF( code /= MPI_SUCCESS ) THEN
349            DO ji = 1, SIZE(ldtxt) 
350               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
351            END DO
352            WRITE(*, cform_err)
353            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
354            CALL mpi_abort( mpi_comm_world, code, ierr )
355         ENDIF
356      ENDIF
357
358      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
359      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
360      mynode = mpprank
361      !
362#if defined key_mpp_rep
363      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
364#endif
365      !
366   END FUNCTION mynode
367
368   SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn )
369      !!----------------------------------------------------------------------
370      !!                  ***  routine mpp_lnk_obc_3d  ***
371      !!
372      !! ** Purpose :   Message passing manadgement
373      !!
374      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries
375      !!      between processors following neighboring subdomains.
376      !!            domain parameters
377      !!                    nlci   : first dimension of the local subdomain
378      !!                    nlcj   : second dimension of the local subdomain
379      !!                    nbondi : mark for "east-west local boundary"
380      !!                    nbondj : mark for "north-south local boundary"
381      !!                    noea   : number for local neighboring processors
382      !!                    nowe   : number for local neighboring processors
383      !!                    noso   : number for local neighboring processors
384      !!                    nono   : number for local neighboring processors
385      !!
386      !! ** Action  :   ptab with update value at its periphery
387      !!
388      !!----------------------------------------------------------------------
389      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
390      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
391      !                                                             ! = T , U , V , F , W points
392      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
393      !                                                             ! =  1. , the sign is kept
394      !!
395      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
396      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
397      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
398      REAL(wp) ::   zland
399      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
400      !!----------------------------------------------------------------------
401
402      zland = 0.e0      ! zero by default
403
404      ! 1. standard boundary treatment
405      ! ------------------------------
406      IF( nbondi == 2) THEN
407        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
408          ptab( 1 ,:,:) = ptab(jpim1,:,:)
409          ptab(jpi,:,:) = ptab(  2  ,:,:)
410        ELSE
411          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
412          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
413        ENDIF
414      ELSEIF(nbondi == -1) THEN
415        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
416      ELSEIF(nbondi == 1) THEN
417        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
418      ENDIF                                     !* closed
419
420      IF (nbondj == 2 .OR. nbondj == -1) THEN
421        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
422      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
423        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
424      ENDIF
425
426      ! 2. East and west directions exchange
427      ! ------------------------------------
428      ! we play with the neigbours AND the row number because of the periodicity
429      !
430      IF(nbondj .ne. 0) THEN
431      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
432      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
433         iihom = nlci-nreci
434         DO jl = 1, jpreci
435            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
436            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
437         END DO
438      END SELECT 
439      !
440      !                           ! Migrations
441      imigr = jpreci * jpj * jpk
442      !
443      SELECT CASE ( nbondi ) 
444      CASE ( -1 )
445         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
446         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
447         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
448      CASE ( 0 )
449         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
450         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
451         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
452         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
453         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
454         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
455      CASE ( 1 )
456         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
457         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
458         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
459      END SELECT
460      !
461      !                           ! Write Dirichlet lateral conditions
462      iihom = nlci-jpreci
463      !
464      SELECT CASE ( nbondi )
465      CASE ( -1 )
466         DO jl = 1, jpreci
467            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
468         END DO
469      CASE ( 0 )
470         DO jl = 1, jpreci
471            ptab(jl      ,:,:) = t3we(:,jl,:,2)
472            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
473         END DO
474      CASE ( 1 )
475         DO jl = 1, jpreci
476            ptab(jl      ,:,:) = t3we(:,jl,:,2)
477         END DO
478      END SELECT
479      ENDIF
480
481
482      ! 3. North and south directions
483      ! -----------------------------
484      ! always closed : we play only with the neigbours
485      !
486      IF(nbondi .ne. 0) THEN
487      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
488         ijhom = nlcj-nrecj
489         DO jl = 1, jprecj
490            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
491            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
492         END DO
493      ENDIF
494      !
495      !                           ! Migrations
496      imigr = jprecj * jpi * jpk
497      !
498      SELECT CASE ( nbondj )     
499      CASE ( -1 )
500         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
501         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
502         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
503      CASE ( 0 )
504         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
505         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
506         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
507         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
508         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
509         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
510      CASE ( 1 ) 
511         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
512         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
513         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
514      END SELECT
515      !
516      !                           ! Write Dirichlet lateral conditions
517      ijhom = nlcj-jprecj
518      !
519      SELECT CASE ( nbondj )
520      CASE ( -1 )
521         DO jl = 1, jprecj
522            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
523         END DO
524      CASE ( 0 )
525         DO jl = 1, jprecj
526            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
527            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
528         END DO
529      CASE ( 1 )
530         DO jl = 1, jprecj
531            ptab(:,jl,:) = t3sn(:,jl,:,2)
532         END DO
533      END SELECT
534      ENDIF
535
536
537      ! 4. north fold treatment
538      ! -----------------------
539      !
540      IF( npolj /= 0 ) THEN
541         !
542         SELECT CASE ( jpni )
543         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
544         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
545         END SELECT
546         !
547      ENDIF
548      !
549   END SUBROUTINE mpp_lnk_obc_3d
550
551
552   SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn )
553      !!----------------------------------------------------------------------
554      !!                  ***  routine mpp_lnk_obc_2d  ***
555      !!                 
556      !! ** Purpose :   Message passing manadgement for 2d array
557      !!
558      !! ** Method  :   Use mppsend and mpprecv function for passing OBC boundaries
559      !!      between processors following neighboring subdomains.
560      !!            domain parameters
561      !!                    nlci   : first dimension of the local subdomain
562      !!                    nlcj   : second dimension of the local subdomain
563      !!                    nbondi : mark for "east-west local boundary"
564      !!                    nbondj : mark for "north-south local boundary"
565      !!                    noea   : number for local neighboring processors
566      !!                    nowe   : number for local neighboring processors
567      !!                    noso   : number for local neighboring processors
568      !!                    nono   : number for local neighboring processors
569      !!
570      !!----------------------------------------------------------------------
571      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
572      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
573      !                                                         ! = T , U , V , F , W and I points
574      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
575      !                                                         ! =  1. , the sign is kept
576      !!
577      INTEGER  ::   ji, jj, jl   ! dummy loop indices
578      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
579      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
580      REAL(wp) ::   zland
581      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
582      !!----------------------------------------------------------------------
583
584      zland = 0.e0      ! zero by default
585
586      ! 1. standard boundary treatment
587      ! ------------------------------
588      !
589      IF( nbondi == 2) THEN
590        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
591          pt2d( 1 ,:) = pt2d(jpim1,:)
592          pt2d(jpi,:) = pt2d(  2  ,:)
593        ELSE
594          IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
595          pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
596        ENDIF
597      ELSEIF(nbondi == -1) THEN
598        IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
599      ELSEIF(nbondi == 1) THEN
600        pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
601      ENDIF                                     !* closed
602
603      IF (nbondj == 2 .OR. nbondj == -1) THEN
604        IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland       ! south except F-point
605      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
606        pt2d(:,nlcj-jprecj+1:jpj) = zland       ! north
607      ENDIF
608
609      ! 2. East and west directions exchange
610      ! ------------------------------------
611      ! we play with the neigbours AND the row number because of the periodicity
612      !
613      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
614      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
615         iihom = nlci-nreci
616         DO jl = 1, jpreci
617            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
618            t2we(:,jl,1) = pt2d(iihom +jl,:)
619         END DO
620      END SELECT
621      !
622      !                           ! Migrations
623      imigr = jpreci * jpj
624      !
625      SELECT CASE ( nbondi )
626      CASE ( -1 )
627         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
628         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
629         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
630      CASE ( 0 )
631         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
632         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
633         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
634         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
635         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
636         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
637      CASE ( 1 )
638         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
639         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
640         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
641      END SELECT
642      !
643      !                           ! Write Dirichlet lateral conditions
644      iihom = nlci - jpreci
645      !
646      SELECT CASE ( nbondi )
647      CASE ( -1 )
648         DO jl = 1, jpreci
649            pt2d(iihom+jl,:) = t2ew(:,jl,2)
650         END DO
651      CASE ( 0 )
652         DO jl = 1, jpreci
653            pt2d(jl      ,:) = t2we(:,jl,2)
654            pt2d(iihom+jl,:) = t2ew(:,jl,2)
655         END DO
656      CASE ( 1 )
657         DO jl = 1, jpreci
658            pt2d(jl      ,:) = t2we(:,jl,2)
659         END DO
660      END SELECT
661
662
663      ! 3. North and south directions
664      ! -----------------------------
665      ! always closed : we play only with the neigbours
666      !
667      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
668         ijhom = nlcj-nrecj
669         DO jl = 1, jprecj
670            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
671            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
672         END DO
673      ENDIF
674      !
675      !                           ! Migrations
676      imigr = jprecj * jpi
677      !
678      SELECT CASE ( nbondj )
679      CASE ( -1 )
680         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
681         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
682         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
683      CASE ( 0 )
684         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
685         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
686         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
687         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
688         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
689         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
690      CASE ( 1 )
691         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
692         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
693         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
694      END SELECT
695      !
696      !                           ! Write Dirichlet lateral conditions
697      ijhom = nlcj - jprecj
698      !
699      SELECT CASE ( nbondj )
700      CASE ( -1 )
701         DO jl = 1, jprecj
702            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
703         END DO
704      CASE ( 0 )
705         DO jl = 1, jprecj
706            pt2d(:,jl      ) = t2sn(:,jl,2)
707            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
708         END DO
709      CASE ( 1 ) 
710         DO jl = 1, jprecj
711            pt2d(:,jl      ) = t2sn(:,jl,2)
712         END DO
713      END SELECT
714
715
716      ! 4. north fold treatment
717      ! -----------------------
718      !
719      IF( npolj /= 0 ) THEN
720         !
721         SELECT CASE ( jpni )
722         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
723         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
724         END SELECT
725         !
726      ENDIF
727      !
728   END SUBROUTINE mpp_lnk_obc_2d
729
730   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
731      !!----------------------------------------------------------------------
732      !!                  ***  routine mpp_lnk_3d  ***
733      !!
734      !! ** Purpose :   Message passing manadgement
735      !!
736      !! ** Method  :   Use mppsend and mpprecv function for passing mask
737      !!      between processors following neighboring subdomains.
738      !!            domain parameters
739      !!                    nlci   : first dimension of the local subdomain
740      !!                    nlcj   : second dimension of the local subdomain
741      !!                    nbondi : mark for "east-west local boundary"
742      !!                    nbondj : mark for "north-south local boundary"
743      !!                    noea   : number for local neighboring processors
744      !!                    nowe   : number for local neighboring processors
745      !!                    noso   : number for local neighboring processors
746      !!                    nono   : number for local neighboring processors
747      !!
748      !! ** Action  :   ptab with update value at its periphery
749      !!
750      !!----------------------------------------------------------------------
751      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
752      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
753      !                                                             ! = T , U , V , F , W points
754      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
755      !                                                             ! =  1. , the sign is kept
756      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
757      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
758      !!
759      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
760      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
761      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
762      REAL(wp) ::   zland
763      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
764      !!----------------------------------------------------------------------
765
766      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
767      ELSE                         ;   zland = 0.e0      ! zero by default
768      ENDIF
769
770      ! 1. standard boundary treatment
771      ! ------------------------------
772      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
773         !
774         ! WARNING ptab is defined only between nld and nle
775         DO jk = 1, jpk
776            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
777               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)   
778               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
779               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
780            END DO
781            DO ji = nlci+1, jpi                 ! added column(s) (full)
782               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
783               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
784               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
785            END DO
786         END DO
787         !
788      ELSE                              ! standard close or cyclic treatment
789         !
790         !                                   ! East-West boundaries
791         !                                        !* Cyclic east-west
792         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
793            ptab( 1 ,:,:) = ptab(jpim1,:,:)
794            ptab(jpi,:,:) = ptab(  2  ,:,:)
795         ELSE                                     !* closed
796            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
797                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
798         ENDIF
799         !                                   ! North-South boundaries (always closed)
800         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
801                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
802         !
803      ENDIF
804
805      ! 2. East and west directions exchange
806      ! ------------------------------------
807      ! we play with the neigbours AND the row number because of the periodicity
808      !
809      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
810      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
811         iihom = nlci-nreci
812         DO jl = 1, jpreci
813            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
814            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
815         END DO
816      END SELECT 
817      !
818      !                           ! Migrations
819      imigr = jpreci * jpj * jpk
820      !
821      SELECT CASE ( nbondi ) 
822      CASE ( -1 )
823         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
824         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
825         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
826      CASE ( 0 )
827         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
828         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
829         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
830         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
831         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
832         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
833      CASE ( 1 )
834         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
835         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
836         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
837      END SELECT
838      !
839      !                           ! Write Dirichlet lateral conditions
840      iihom = nlci-jpreci
841      !
842      SELECT CASE ( nbondi )
843      CASE ( -1 )
844         DO jl = 1, jpreci
845            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
846         END DO
847      CASE ( 0 ) 
848         DO jl = 1, jpreci
849            ptab(jl      ,:,:) = t3we(:,jl,:,2)
850            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
851         END DO
852      CASE ( 1 )
853         DO jl = 1, jpreci
854            ptab(jl      ,:,:) = t3we(:,jl,:,2)
855         END DO
856      END SELECT
857
858
859      ! 3. North and south directions
860      ! -----------------------------
861      ! always closed : we play only with the neigbours
862      !
863      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
864         ijhom = nlcj-nrecj
865         DO jl = 1, jprecj
866            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
867            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
868         END DO
869      ENDIF
870      !
871      !                           ! Migrations
872      imigr = jprecj * jpi * jpk
873      !
874      SELECT CASE ( nbondj )     
875      CASE ( -1 )
876         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
877         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
878         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
879      CASE ( 0 )
880         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
881         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
882         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
883         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
884         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
885         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
886      CASE ( 1 ) 
887         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
888         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
889         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
890      END SELECT
891      !
892      !                           ! Write Dirichlet lateral conditions
893      ijhom = nlcj-jprecj
894      !
895      SELECT CASE ( nbondj )
896      CASE ( -1 )
897         DO jl = 1, jprecj
898            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
899         END DO
900      CASE ( 0 ) 
901         DO jl = 1, jprecj
902            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
903            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
904         END DO
905      CASE ( 1 )
906         DO jl = 1, jprecj
907            ptab(:,jl,:) = t3sn(:,jl,:,2)
908         END DO
909      END SELECT
910
911
912      ! 4. north fold treatment
913      ! -----------------------
914      !
915      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
916         !
917         SELECT CASE ( jpni )
918         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
919         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
920         END SELECT
921         !
922      ENDIF
923      !
924   END SUBROUTINE mpp_lnk_3d
925
926
927   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
928      !!----------------------------------------------------------------------
929      !!                  ***  routine mpp_lnk_2d  ***
930      !!                 
931      !! ** Purpose :   Message passing manadgement for 2d array
932      !!
933      !! ** Method  :   Use mppsend and mpprecv function for passing mask
934      !!      between processors following neighboring subdomains.
935      !!            domain parameters
936      !!                    nlci   : first dimension of the local subdomain
937      !!                    nlcj   : second dimension of the local subdomain
938      !!                    nbondi : mark for "east-west local boundary"
939      !!                    nbondj : mark for "north-south local boundary"
940      !!                    noea   : number for local neighboring processors
941      !!                    nowe   : number for local neighboring processors
942      !!                    noso   : number for local neighboring processors
943      !!                    nono   : number for local neighboring processors
944      !!
945      !!----------------------------------------------------------------------
946      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
947      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
948      !                                                         ! = T , U , V , F , W and I points
949      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
950      !                                                         ! =  1. , the sign is kept
951      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
952      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
953      !!
954      INTEGER  ::   ji, jj, jl   ! dummy loop indices
955      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
956      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
957      REAL(wp) ::   zland
958      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
959      !!----------------------------------------------------------------------
960
961      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
962      ELSE                         ;   zland = 0.e0      ! zero by default
963      ENDIF
964
965      ! 1. standard boundary treatment
966      ! ------------------------------
967      !
968      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
969         !
970         ! WARNING pt2d is defined only between nld and nle
971         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
972            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)   
973            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
974            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
975         END DO
976         DO ji = nlci+1, jpi                 ! added column(s) (full)
977            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
978            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
979            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
980         END DO
981         !
982      ELSE                              ! standard close or cyclic treatment
983         !
984         !                                   ! East-West boundaries
985         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
986            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
987            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
988            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
989         ELSE                                     ! closed
990            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
991                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
992         ENDIF
993         !                                   ! North-South boundaries (always closed)
994            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
995                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
996         !
997      ENDIF
998
999      ! 2. East and west directions exchange
1000      ! ------------------------------------
1001      ! we play with the neigbours AND the row number because of the periodicity
1002      !
1003      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1004      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1005         iihom = nlci-nreci
1006         DO jl = 1, jpreci
1007            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1008            t2we(:,jl,1) = pt2d(iihom +jl,:)
1009         END DO
1010      END SELECT
1011      !
1012      !                           ! Migrations
1013      imigr = jpreci * jpj
1014      !
1015      SELECT CASE ( nbondi )
1016      CASE ( -1 )
1017         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1018         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
1019         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1020      CASE ( 0 )
1021         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1022         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1023         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
1024         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
1025         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1026         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1027      CASE ( 1 )
1028         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1029         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
1030         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1031      END SELECT
1032      !
1033      !                           ! Write Dirichlet lateral conditions
1034      iihom = nlci - jpreci
1035      !
1036      SELECT CASE ( nbondi )
1037      CASE ( -1 )
1038         DO jl = 1, jpreci
1039            pt2d(iihom+jl,:) = t2ew(:,jl,2)
1040         END DO
1041      CASE ( 0 )
1042         DO jl = 1, jpreci
1043            pt2d(jl      ,:) = t2we(:,jl,2)
1044            pt2d(iihom+jl,:) = t2ew(:,jl,2)
1045         END DO
1046      CASE ( 1 )
1047         DO jl = 1, jpreci
1048            pt2d(jl      ,:) = t2we(:,jl,2)
1049         END DO
1050      END SELECT
1051
1052
1053      ! 3. North and south directions
1054      ! -----------------------------
1055      ! always closed : we play only with the neigbours
1056      !
1057      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1058         ijhom = nlcj-nrecj
1059         DO jl = 1, jprecj
1060            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1061            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1062         END DO
1063      ENDIF
1064      !
1065      !                           ! Migrations
1066      imigr = jprecj * jpi
1067      !
1068      SELECT CASE ( nbondj )
1069      CASE ( -1 )
1070         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1071         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
1072         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1073      CASE ( 0 )
1074         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1075         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1076         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
1077         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
1078         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1079         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1080      CASE ( 1 )
1081         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1082         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
1083         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1084      END SELECT
1085      !
1086      !                           ! Write Dirichlet lateral conditions
1087      ijhom = nlcj - jprecj
1088      !
1089      SELECT CASE ( nbondj )
1090      CASE ( -1 )
1091         DO jl = 1, jprecj
1092            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1093         END DO
1094      CASE ( 0 )
1095         DO jl = 1, jprecj
1096            pt2d(:,jl      ) = t2sn(:,jl,2)
1097            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1098         END DO
1099      CASE ( 1 ) 
1100         DO jl = 1, jprecj
1101            pt2d(:,jl      ) = t2sn(:,jl,2)
1102         END DO
1103      END SELECT
1104
1105
1106      ! 4. north fold treatment
1107      ! -----------------------
1108      !
1109      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
1110         !
1111         SELECT CASE ( jpni )
1112         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
1113         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
1114         END SELECT
1115         !
1116      ENDIF
1117      !
1118   END SUBROUTINE mpp_lnk_2d
1119
1120
1121   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1122      !!----------------------------------------------------------------------
1123      !!                  ***  routine mpp_lnk_3d_gather  ***
1124      !!
1125      !! ** Purpose :   Message passing manadgement for two 3D arrays
1126      !!
1127      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1128      !!      between processors following neighboring subdomains.
1129      !!            domain parameters
1130      !!                    nlci   : first dimension of the local subdomain
1131      !!                    nlcj   : second dimension of the local subdomain
1132      !!                    nbondi : mark for "east-west local boundary"
1133      !!                    nbondj : mark for "north-south local boundary"
1134      !!                    noea   : number for local neighboring processors
1135      !!                    nowe   : number for local neighboring processors
1136      !!                    noso   : number for local neighboring processors
1137      !!                    nono   : number for local neighboring processors
1138      !!
1139      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
1140      !!
1141      !!----------------------------------------------------------------------
1142      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
1143      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
1144      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
1145      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
1146      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
1147      !!                                                             ! =  1. , the sign is kept
1148      INTEGER  ::   jl   ! dummy loop indices
1149      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1150      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1151      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1152      !!----------------------------------------------------------------------
1153
1154      ! 1. standard boundary treatment
1155      ! ------------------------------
1156      !                                      ! East-West boundaries
1157      !                                           !* Cyclic east-west
1158      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1159         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1160         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
1161         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1162         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
1163      ELSE                                        !* closed
1164         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
1165         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
1166                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
1167                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
1168      ENDIF
1169
1170     
1171      !                                      ! North-South boundaries
1172      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
1173      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
1174                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
1175                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
1176
1177
1178      ! 2. East and west directions exchange
1179      ! ------------------------------------
1180      ! we play with the neigbours AND the row number because of the periodicity
1181      !
1182      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1183      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1184         iihom = nlci-nreci
1185         DO jl = 1, jpreci
1186            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1187            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1188            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1189            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1190         END DO
1191      END SELECT
1192      !
1193      !                           ! Migrations
1194      imigr = jpreci * jpj * jpk *2
1195      !
1196      SELECT CASE ( nbondi ) 
1197      CASE ( -1 )
1198         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
1199         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
1200         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1201      CASE ( 0 )
1202         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1203         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
1204         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
1205         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
1206         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1207         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1208      CASE ( 1 )
1209         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1210         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
1211         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1212      END SELECT
1213      !
1214      !                           ! Write Dirichlet lateral conditions
1215      iihom = nlci - jpreci
1216      !
1217      SELECT CASE ( nbondi )
1218      CASE ( -1 )
1219         DO jl = 1, jpreci
1220            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1221            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1222         END DO
1223      CASE ( 0 ) 
1224         DO jl = 1, jpreci
1225            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
1226            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1227            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
1228            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1229         END DO
1230      CASE ( 1 )
1231         DO jl = 1, jpreci
1232            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
1233            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
1234         END DO
1235      END SELECT
1236
1237
1238      ! 3. North and south directions
1239      ! -----------------------------
1240      ! always closed : we play only with the neigbours
1241      !
1242      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1243         ijhom = nlcj - nrecj
1244         DO jl = 1, jprecj
1245            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1246            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1247            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1248            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1249         END DO
1250      ENDIF
1251      !
1252      !                           ! Migrations
1253      imigr = jprecj * jpi * jpk * 2
1254      !
1255      SELECT CASE ( nbondj )     
1256      CASE ( -1 )
1257         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1258         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
1259         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1260      CASE ( 0 )
1261         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1262         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1263         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
1264         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
1265         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1266         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1267      CASE ( 1 ) 
1268         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1269         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
1270         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1271      END SELECT
1272      !
1273      !                           ! Write Dirichlet lateral conditions
1274      ijhom = nlcj - jprecj
1275      !
1276      SELECT CASE ( nbondj )
1277      CASE ( -1 )
1278         DO jl = 1, jprecj
1279            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1280            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1281         END DO
1282      CASE ( 0 ) 
1283         DO jl = 1, jprecj
1284            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2)
1285            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1286            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2)
1287            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1288         END DO
1289      CASE ( 1 )
1290         DO jl = 1, jprecj
1291            ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
1292            ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
1293         END DO
1294      END SELECT
1295
1296
1297      ! 4. north fold treatment
1298      ! -----------------------
1299      IF( npolj /= 0 ) THEN
1300         !
1301         SELECT CASE ( jpni )
1302         CASE ( 1 )                                           
1303            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
1304            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
1305         CASE DEFAULT
1306            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
1307            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
1308         END SELECT 
1309         !
1310      ENDIF
1311      !
1312   END SUBROUTINE mpp_lnk_3d_gather
1313
1314
1315   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
1316      !!----------------------------------------------------------------------
1317      !!                  ***  routine mpp_lnk_2d_e  ***
1318      !!                 
1319      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
1320      !!
1321      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1322      !!      between processors following neighboring subdomains.
1323      !!            domain parameters
1324      !!                    nlci   : first dimension of the local subdomain
1325      !!                    nlcj   : second dimension of the local subdomain
1326      !!                    jpr2di : number of rows for extra outer halo
1327      !!                    jpr2dj : number of columns for extra outer halo
1328      !!                    nbondi : mark for "east-west local boundary"
1329      !!                    nbondj : mark for "north-south local boundary"
1330      !!                    noea   : number for local neighboring processors
1331      !!                    nowe   : number for local neighboring processors
1332      !!                    noso   : number for local neighboring processors
1333      !!                    nono   : number for local neighboring processors
1334      !!
1335      !!----------------------------------------------------------------------
1336      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
1337      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
1338      !                                                                                         ! = T , U , V , F , W and I points
1339      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
1340      !!                                                                                        ! north boundary, =  1. otherwise
1341      INTEGER  ::   jl   ! dummy loop indices
1342      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
1343      INTEGER  ::   ipreci, iprecj             ! temporary integers
1344      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
1345      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
1346      !!----------------------------------------------------------------------
1347
1348      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area
1349      iprecj = jprecj + jpr2dj
1350
1351
1352      ! 1. standard boundary treatment
1353      ! ------------------------------
1354      ! Order matters Here !!!!
1355      !
1356      !                                      !* North-South boundaries (always colsed)
1357      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0    ! south except at F-point
1358                                   pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0    ! north
1359                               
1360      !                                      ! East-West boundaries
1361      !                                           !* Cyclic east-west
1362      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1363         pt2d(1-jpr2di:     1    ,:) = pt2d(jpim1-jpr2di:  jpim1 ,:)       ! east
1364         pt2d(   jpi  :jpi+jpr2di,:) = pt2d(     2      :2+jpr2di,:)       ! west
1365         !
1366      ELSE                                        !* closed
1367         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpr2di   :jpreci    ,:) = 0.e0    ! south except at F-point
1368                                      pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0    ! north
1369      ENDIF
1370      !
1371
1372      ! north fold treatment
1373      ! -----------------------
1374      IF( npolj /= 0 ) THEN
1375         !
1376         SELECT CASE ( jpni )
1377         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
1378         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
1379         END SELECT 
1380         !
1381      ENDIF
1382
1383      ! 2. East and west directions exchange
1384      ! ------------------------------------
1385      ! we play with the neigbours AND the row number because of the periodicity
1386      !
1387      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
1388      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
1389         iihom = nlci-nreci-jpr2di
1390         DO jl = 1, ipreci
1391            tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
1392            tr2we(:,jl,1) = pt2d(iihom +jl,:)
1393         END DO
1394      END SELECT
1395      !
1396      !                           ! Migrations
1397      imigr = ipreci * ( jpj + 2*jpr2dj)
1398      !
1399      SELECT CASE ( nbondi )
1400      CASE ( -1 )
1401         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
1402         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
1403         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1404      CASE ( 0 )
1405         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1406         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
1407         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr, noea )
1408         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
1409         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1410         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1411      CASE ( 1 )
1412         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
1413         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr, nowe )
1414         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1415      END SELECT
1416      !
1417      !                           ! Write Dirichlet lateral conditions
1418      iihom = nlci - jpreci
1419      !
1420      SELECT CASE ( nbondi )
1421      CASE ( -1 )
1422         DO jl = 1, ipreci
1423            pt2d(iihom+jl,:) = tr2ew(:,jl,2)
1424         END DO
1425      CASE ( 0 )
1426         DO jl = 1, ipreci
1427            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1428            pt2d( iihom+jl,:) = tr2ew(:,jl,2)
1429         END DO
1430      CASE ( 1 )
1431         DO jl = 1, ipreci
1432            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
1433         END DO
1434      END SELECT
1435
1436
1437      ! 3. North and south directions
1438      ! -----------------------------
1439      ! always closed : we play only with the neigbours
1440      !
1441      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
1442         ijhom = nlcj-nrecj-jpr2dj
1443         DO jl = 1, iprecj
1444            tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
1445            tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
1446         END DO
1447      ENDIF
1448      !
1449      !                           ! Migrations
1450      imigr = iprecj * ( jpi + 2*jpr2di )
1451      !
1452      SELECT CASE ( nbondj )
1453      CASE ( -1 )
1454         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
1455         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
1456         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1457      CASE ( 0 )
1458         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1459         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
1460         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr, nono )
1461         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
1462         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1463         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1464      CASE ( 1 )
1465         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
1466         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr, noso )
1467         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1468      END SELECT
1469      !
1470      !                           ! Write Dirichlet lateral conditions
1471      ijhom = nlcj - jprecj 
1472      !
1473      SELECT CASE ( nbondj )
1474      CASE ( -1 )
1475         DO jl = 1, iprecj
1476            pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1477         END DO
1478      CASE ( 0 )
1479         DO jl = 1, iprecj
1480            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1481            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1482         END DO
1483      CASE ( 1 ) 
1484         DO jl = 1, iprecj
1485            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1486         END DO
1487      END SELECT
1488
1489   END SUBROUTINE mpp_lnk_2d_e
1490
1491
1492   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1493      !!----------------------------------------------------------------------
1494      !!                  ***  routine mppsend  ***
1495      !!                   
1496      !! ** Purpose :   Send messag passing array
1497      !!
1498      !!----------------------------------------------------------------------
1499      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1500      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1501      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1502      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1503      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1504      !!
1505      INTEGER ::   iflag
1506      !!----------------------------------------------------------------------
1507      !
1508      SELECT CASE ( cn_mpi_send )
1509      CASE ( 'S' )                ! Standard mpi send (blocking)
1510         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1511      CASE ( 'B' )                ! Buffer mpi send (blocking)
1512         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1513      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
1514         ! be carefull, one more argument here : the mpi request identifier..
1515         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1516      END SELECT
1517      !
1518   END SUBROUTINE mppsend
1519
1520
1521   SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
1522      !!----------------------------------------------------------------------
1523      !!                  ***  routine mpprecv  ***
1524      !!
1525      !! ** Purpose :   Receive messag passing array
1526      !!
1527      !!----------------------------------------------------------------------
1528      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1529      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1530      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
1531      INTEGER, OPTIONAL, INTENT(in) :: ksource    ! source process number
1532      !!
1533      INTEGER :: istatus(mpi_status_size)
1534      INTEGER :: iflag
1535      INTEGER :: use_source
1536      !!----------------------------------------------------------------------
1537      !
1538
1539      ! If a specific process number has been passed to the receive call,
1540      ! use that one. Default is to use mpi_any_source
1541      use_source=mpi_any_source
1542      if(present(ksource)) then
1543         use_source=ksource
1544      end if
1545
1546      CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
1547      !
1548   END SUBROUTINE mpprecv
1549
1550
1551   SUBROUTINE mppgather( ptab, kp, pio )
1552      !!----------------------------------------------------------------------
1553      !!                   ***  routine mppgather  ***
1554      !!                   
1555      !! ** Purpose :   Transfert between a local subdomain array and a work
1556      !!     array which is distributed following the vertical level.
1557      !!
1558      !!----------------------------------------------------------------------
1559      REAL(wp), DIMENSION(jpi,jpj),       INTENT(in   ) ::   ptab   ! subdomain input array
1560      INTEGER ,                           INTENT(in   ) ::   kp     ! record length
1561      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
1562      !!
1563      INTEGER :: itaille, ierror   ! temporary integer
1564      !!---------------------------------------------------------------------
1565      !
1566      itaille = jpi * jpj
1567      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
1568         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
1569      !
1570   END SUBROUTINE mppgather
1571
1572
1573   SUBROUTINE mppscatter( pio, kp, ptab )
1574      !!----------------------------------------------------------------------
1575      !!                  ***  routine mppscatter  ***
1576      !!
1577      !! ** Purpose :   Transfert between awork array which is distributed
1578      !!      following the vertical level and the local subdomain array.
1579      !!
1580      !!----------------------------------------------------------------------
1581      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1582      INTEGER                             ::   kp        ! Tag (not used with MPI
1583      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1584      !!
1585      INTEGER :: itaille, ierror   ! temporary integer
1586      !!---------------------------------------------------------------------
1587      !
1588      itaille=jpi*jpj
1589      !
1590      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1591         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1592      !
1593   END SUBROUTINE mppscatter
1594
1595
1596   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1597      !!----------------------------------------------------------------------
1598      !!                  ***  routine mppmax_a_int  ***
1599      !!
1600      !! ** Purpose :   Find maximum value in an integer layout array
1601      !!
1602      !!----------------------------------------------------------------------
1603      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1604      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1605      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1606      !!
1607      INTEGER :: ierror, localcomm   ! temporary integer
1608      INTEGER, DIMENSION(kdim) ::   iwork
1609      !!----------------------------------------------------------------------
1610      !
1611      localcomm = mpi_comm_opa
1612      IF( PRESENT(kcom) )   localcomm = kcom
1613      !
1614      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1615      !
1616      ktab(:) = iwork(:)
1617      !
1618   END SUBROUTINE mppmax_a_int
1619
1620
1621   SUBROUTINE mppmax_int( ktab, kcom )
1622      !!----------------------------------------------------------------------
1623      !!                  ***  routine mppmax_int  ***
1624      !!
1625      !! ** Purpose :   Find maximum value in an integer layout array
1626      !!
1627      !!----------------------------------------------------------------------
1628      INTEGER, INTENT(inout)           ::   ktab      ! ???
1629      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1630      !!
1631      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1632      !!----------------------------------------------------------------------
1633      !
1634      localcomm = mpi_comm_opa 
1635      IF( PRESENT(kcom) )   localcomm = kcom
1636      !
1637      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1638      !
1639      ktab = iwork
1640      !
1641   END SUBROUTINE mppmax_int
1642
1643
1644   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1645      !!----------------------------------------------------------------------
1646      !!                  ***  routine mppmin_a_int  ***
1647      !!
1648      !! ** Purpose :   Find minimum value in an integer layout array
1649      !!
1650      !!----------------------------------------------------------------------
1651      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1652      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1653      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1654      !!
1655      INTEGER ::   ierror, localcomm   ! temporary integer
1656      INTEGER, DIMENSION(kdim) ::   iwork
1657      !!----------------------------------------------------------------------
1658      !
1659      localcomm = mpi_comm_opa
1660      IF( PRESENT(kcom) )   localcomm = kcom
1661      !
1662      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1663      !
1664      ktab(:) = iwork(:)
1665      !
1666   END SUBROUTINE mppmin_a_int
1667
1668
1669   SUBROUTINE mppmin_int( ktab, kcom )
1670      !!----------------------------------------------------------------------
1671      !!                  ***  routine mppmin_int  ***
1672      !!
1673      !! ** Purpose :   Find minimum value in an integer layout array
1674      !!
1675      !!----------------------------------------------------------------------
1676      INTEGER, INTENT(inout) ::   ktab      ! ???
1677      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1678      !!
1679      INTEGER ::  ierror, iwork, localcomm
1680      !!----------------------------------------------------------------------
1681      !
1682      localcomm = mpi_comm_opa
1683      IF( PRESENT(kcom) )   localcomm = kcom
1684      !
1685     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1686      !
1687      ktab = iwork
1688      !
1689   END SUBROUTINE mppmin_int
1690
1691
1692   SUBROUTINE mppsum_a_int( ktab, kdim )
1693      !!----------------------------------------------------------------------
1694      !!                  ***  routine mppsum_a_int  ***
1695      !!                   
1696      !! ** Purpose :   Global integer sum, 1D array case
1697      !!
1698      !!----------------------------------------------------------------------
1699      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1700      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1701      !!
1702      INTEGER :: ierror
1703      INTEGER, DIMENSION (kdim) ::  iwork
1704      !!----------------------------------------------------------------------
1705      !
1706      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1707      !
1708      ktab(:) = iwork(:)
1709      !
1710   END SUBROUTINE mppsum_a_int
1711
1712
1713   SUBROUTINE mppsum_int( ktab )
1714      !!----------------------------------------------------------------------
1715      !!                 ***  routine mppsum_int  ***
1716      !!                 
1717      !! ** Purpose :   Global integer sum
1718      !!
1719      !!----------------------------------------------------------------------
1720      INTEGER, INTENT(inout) ::   ktab
1721      !!
1722      INTEGER :: ierror, iwork
1723      !!----------------------------------------------------------------------
1724      !
1725      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1726      !
1727      ktab = iwork
1728      !
1729   END SUBROUTINE mppsum_int
1730
1731
1732   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1733      !!----------------------------------------------------------------------
1734      !!                 ***  routine mppmax_a_real  ***
1735      !!                 
1736      !! ** Purpose :   Maximum
1737      !!
1738      !!----------------------------------------------------------------------
1739      INTEGER , INTENT(in   )                  ::   kdim
1740      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1741      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1742      !!
1743      INTEGER :: ierror, localcomm
1744      REAL(wp), DIMENSION(kdim) ::  zwork
1745      !!----------------------------------------------------------------------
1746      !
1747      localcomm = mpi_comm_opa
1748      IF( PRESENT(kcom) ) localcomm = kcom
1749      !
1750      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1751      ptab(:) = zwork(:)
1752      !
1753   END SUBROUTINE mppmax_a_real
1754
1755
1756   SUBROUTINE mppmax_real( ptab, kcom )
1757      !!----------------------------------------------------------------------
1758      !!                  ***  routine mppmax_real  ***
1759      !!                   
1760      !! ** Purpose :   Maximum
1761      !!
1762      !!----------------------------------------------------------------------
1763      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1764      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1765      !!
1766      INTEGER  ::   ierror, localcomm
1767      REAL(wp) ::   zwork
1768      !!----------------------------------------------------------------------
1769      !
1770      localcomm = mpi_comm_opa 
1771      IF( PRESENT(kcom) )   localcomm = kcom
1772      !
1773      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1774      ptab = zwork
1775      !
1776   END SUBROUTINE mppmax_real
1777
1778
1779   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1780      !!----------------------------------------------------------------------
1781      !!                 ***  routine mppmin_a_real  ***
1782      !!                 
1783      !! ** Purpose :   Minimum of REAL, array case
1784      !!
1785      !!-----------------------------------------------------------------------
1786      INTEGER , INTENT(in   )                  ::   kdim
1787      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1788      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1789      !!
1790      INTEGER :: ierror, localcomm
1791      REAL(wp), DIMENSION(kdim) ::   zwork
1792      !!-----------------------------------------------------------------------
1793      !
1794      localcomm = mpi_comm_opa 
1795      IF( PRESENT(kcom) ) localcomm = kcom
1796      !
1797      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1798      ptab(:) = zwork(:)
1799      !
1800   END SUBROUTINE mppmin_a_real
1801
1802
1803   SUBROUTINE mppmin_real( ptab, kcom )
1804      !!----------------------------------------------------------------------
1805      !!                  ***  routine mppmin_real  ***
1806      !!
1807      !! ** Purpose :   minimum of REAL, scalar case
1808      !!
1809      !!-----------------------------------------------------------------------
1810      REAL(wp), INTENT(inout)           ::   ptab        !
1811      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1812      !!
1813      INTEGER  ::   ierror
1814      REAL(wp) ::   zwork
1815      INTEGER :: localcomm
1816      !!-----------------------------------------------------------------------
1817      !
1818      localcomm = mpi_comm_opa 
1819      IF( PRESENT(kcom) )   localcomm = kcom
1820      !
1821      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1822      ptab = zwork
1823      !
1824   END SUBROUTINE mppmin_real
1825
1826
1827   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1828      !!----------------------------------------------------------------------
1829      !!                  ***  routine mppsum_a_real  ***
1830      !!
1831      !! ** Purpose :   global sum, REAL ARRAY argument case
1832      !!
1833      !!-----------------------------------------------------------------------
1834      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1835      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1836      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1837      !!
1838      INTEGER                   ::   ierror    ! temporary integer
1839      INTEGER                   ::   localcomm 
1840      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1841      !!-----------------------------------------------------------------------
1842      !
1843      localcomm = mpi_comm_opa 
1844      IF( PRESENT(kcom) )   localcomm = kcom
1845      !
1846      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1847      ptab(:) = zwork(:)
1848      !
1849   END SUBROUTINE mppsum_a_real
1850
1851
1852   SUBROUTINE mppsum_real( ptab, kcom )
1853      !!----------------------------------------------------------------------
1854      !!                  ***  routine mppsum_real  ***
1855      !!             
1856      !! ** Purpose :   global sum, SCALAR argument case
1857      !!
1858      !!-----------------------------------------------------------------------
1859      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1860      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1861      !!
1862      INTEGER  ::   ierror, localcomm 
1863      REAL(wp) ::   zwork
1864      !!-----------------------------------------------------------------------
1865      !
1866      localcomm = mpi_comm_opa 
1867      IF( PRESENT(kcom) ) localcomm = kcom
1868      !
1869      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1870      ptab = zwork
1871      !
1872   END SUBROUTINE mppsum_real
1873
1874# if defined key_mpp_rep
1875   SUBROUTINE mppsum_realdd( ytab, kcom )
1876      !!----------------------------------------------------------------------
1877      !!                  ***  routine mppsum_realdd ***
1878      !!
1879      !! ** Purpose :   global sum in Massively Parallel Processing
1880      !!                SCALAR argument case for double-double precision
1881      !!
1882      !!-----------------------------------------------------------------------
1883      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
1884      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1885
1886      !! * Local variables   (MPI version)
1887      INTEGER  ::    ierror
1888      INTEGER  ::   localcomm
1889      COMPLEX(wp) :: zwork
1890
1891      localcomm = mpi_comm_opa
1892      IF( PRESENT(kcom) ) localcomm = kcom
1893
1894      ! reduce local sums into global sum
1895      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1896                       MPI_SUMDD,localcomm,ierror)
1897      ytab = zwork
1898
1899   END SUBROUTINE mppsum_realdd
1900 
1901 
1902   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1903      !!----------------------------------------------------------------------
1904      !!                  ***  routine mppsum_a_realdd  ***
1905      !!
1906      !! ** Purpose :   global sum in Massively Parallel Processing
1907      !!                COMPLEX ARRAY case for double-double precision
1908      !!
1909      !!-----------------------------------------------------------------------
1910      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
1911      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
1912      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1913
1914      !! * Local variables   (MPI version)
1915      INTEGER                      :: ierror    ! temporary integer
1916      INTEGER                      ::   localcomm
1917      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
1918
1919      localcomm = mpi_comm_opa
1920      IF( PRESENT(kcom) ) localcomm = kcom
1921
1922      CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1923                       MPI_SUMDD,localcomm,ierror)
1924      ytab(:) = zwork(:)
1925
1926   END SUBROUTINE mppsum_a_realdd
1927# endif   
1928   
1929   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1930      !!------------------------------------------------------------------------
1931      !!             ***  routine mpp_minloc  ***
1932      !!
1933      !! ** Purpose :   Compute the global minimum of an array ptab
1934      !!              and also give its global position
1935      !!
1936      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1937      !!
1938      !!--------------------------------------------------------------------------
1939      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1940      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1941      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1942      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1943      !!
1944      INTEGER , DIMENSION(2)   ::   ilocs
1945      INTEGER :: ierror
1946      REAL(wp) ::   zmin   ! local minimum
1947      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1948      !!-----------------------------------------------------------------------
1949      !
1950      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1951      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1952      !
1953      ki = ilocs(1) + nimpp - 1
1954      kj = ilocs(2) + njmpp - 1
1955      !
1956      zain(1,:)=zmin
1957      zain(2,:)=ki+10000.*kj
1958      !
1959      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1960      !
1961      pmin = zaout(1,1)
1962      kj = INT(zaout(2,1)/10000.)
1963      ki = INT(zaout(2,1) - 10000.*kj )
1964      !
1965   END SUBROUTINE mpp_minloc2d
1966
1967
1968   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1969      !!------------------------------------------------------------------------
1970      !!             ***  routine mpp_minloc  ***
1971      !!
1972      !! ** Purpose :   Compute the global minimum of an array ptab
1973      !!              and also give its global position
1974      !!
1975      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1976      !!
1977      !!--------------------------------------------------------------------------
1978      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1979      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1980      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1981      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1982      !!
1983      INTEGER  ::   ierror
1984      REAL(wp) ::   zmin     ! local minimum
1985      INTEGER , DIMENSION(3)   ::   ilocs
1986      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1987      !!-----------------------------------------------------------------------
1988      !
1989      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1990      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1991      !
1992      ki = ilocs(1) + nimpp - 1
1993      kj = ilocs(2) + njmpp - 1
1994      kk = ilocs(3)
1995      !
1996      zain(1,:)=zmin
1997      zain(2,:)=ki+10000.*kj+100000000.*kk
1998      !
1999      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
2000      !
2001      pmin = zaout(1,1)
2002      kk   = INT( zaout(2,1) / 100000000. )
2003      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2004      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2005      !
2006   END SUBROUTINE mpp_minloc3d
2007
2008
2009   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2010      !!------------------------------------------------------------------------
2011      !!             ***  routine mpp_maxloc  ***
2012      !!
2013      !! ** Purpose :   Compute the global maximum of an array ptab
2014      !!              and also give its global position
2015      !!
2016      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
2017      !!
2018      !!--------------------------------------------------------------------------
2019      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
2020      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
2021      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
2022      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
2023      !! 
2024      INTEGER  :: ierror
2025      INTEGER, DIMENSION (2)   ::   ilocs
2026      REAL(wp) :: zmax   ! local maximum
2027      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2028      !!-----------------------------------------------------------------------
2029      !
2030      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
2031      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
2032      !
2033      ki = ilocs(1) + nimpp - 1
2034      kj = ilocs(2) + njmpp - 1
2035      !
2036      zain(1,:) = zmax
2037      zain(2,:) = ki + 10000. * kj
2038      !
2039      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2040      !
2041      pmax = zaout(1,1)
2042      kj   = INT( zaout(2,1) / 10000.     )
2043      ki   = INT( zaout(2,1) - 10000.* kj )
2044      !
2045   END SUBROUTINE mpp_maxloc2d
2046
2047
2048   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2049      !!------------------------------------------------------------------------
2050      !!             ***  routine mpp_maxloc  ***
2051      !!
2052      !! ** Purpose :  Compute the global maximum of an array ptab
2053      !!              and also give its global position
2054      !!
2055      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2056      !!
2057      !!--------------------------------------------------------------------------
2058      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
2059      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
2060      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
2061      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
2062      !!   
2063      REAL(wp) :: zmax   ! local maximum
2064      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2065      INTEGER , DIMENSION(3)   ::   ilocs
2066      INTEGER :: ierror
2067      !!-----------------------------------------------------------------------
2068      !
2069      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2070      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2071      !
2072      ki = ilocs(1) + nimpp - 1
2073      kj = ilocs(2) + njmpp - 1
2074      kk = ilocs(3)
2075      !
2076      zain(1,:)=zmax
2077      zain(2,:)=ki+10000.*kj+100000000.*kk
2078      !
2079      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2080      !
2081      pmax = zaout(1,1)
2082      kk   = INT( zaout(2,1) / 100000000. )
2083      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2084      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2085      !
2086   END SUBROUTINE mpp_maxloc3d
2087
2088
2089   SUBROUTINE mppsync()
2090      !!----------------------------------------------------------------------
2091      !!                  ***  routine mppsync  ***
2092      !!                   
2093      !! ** Purpose :   Massively parallel processors, synchroneous
2094      !!
2095      !!-----------------------------------------------------------------------
2096      INTEGER :: ierror
2097      !!-----------------------------------------------------------------------
2098      !
2099      CALL mpi_barrier( mpi_comm_opa, ierror )
2100      !
2101   END SUBROUTINE mppsync
2102
2103
2104   SUBROUTINE mppstop
2105      !!----------------------------------------------------------------------
2106      !!                  ***  routine mppstop  ***
2107      !!                   
2108      !! ** purpose :   Stop massively parallel processors method
2109      !!
2110      !!----------------------------------------------------------------------
2111      INTEGER ::   info
2112      !!----------------------------------------------------------------------
2113      !
2114      CALL mppsync
2115      CALL mpi_finalize( info )
2116      !
2117   END SUBROUTINE mppstop
2118
2119
2120   SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
2121      !!----------------------------------------------------------------------
2122      !!                  ***  routine mppobc  ***
2123      !!
2124      !! ** Purpose :   Message passing manadgement for open boundary
2125      !!     conditions array
2126      !!
2127      !! ** Method  :   Use mppsend and mpprecv function for passing mask
2128      !!       between processors following neighboring subdomains.
2129      !!       domain parameters
2130      !!                    nlci   : first dimension of the local subdomain
2131      !!                    nlcj   : second dimension of the local subdomain
2132      !!                    nbondi : mark for "east-west local boundary"
2133      !!                    nbondj : mark for "north-south local boundary"
2134      !!                    noea   : number for local neighboring processors
2135      !!                    nowe   : number for local neighboring processors
2136      !!                    noso   : number for local neighboring processors
2137      !!                    nono   : number for local neighboring processors
2138      !!
2139      !!----------------------------------------------------------------------
2140      USE wrk_nemo        ! Memory allocation
2141      !
2142      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices
2143      INTEGER , INTENT(in   )                     ::   kl         ! index of open boundary
2144      INTEGER , INTENT(in   )                     ::   kk         ! vertical dimension
2145      INTEGER , INTENT(in   )                     ::   ktype      ! define north/south or east/west cdt
2146      !                                                           !  = 1  north/south  ;  = 2  east/west
2147      INTEGER , INTENT(in   )                     ::   kij        ! horizontal dimension
2148      INTEGER , INTENT(in   )                     ::   kumout     ! ocean.output logical unit
2149      REAL(wp), INTENT(inout), DIMENSION(kij,kk)  ::   ptab       ! variable array
2150      !
2151      INTEGER ::   ji, jj, jk, jl        ! dummy loop indices
2152      INTEGER ::   iipt0, iipt1, ilpt1   ! local integers
2153      INTEGER ::   ijpt0, ijpt1          !   -       -
2154      INTEGER ::   imigr, iihom, ijhom   !   -       -
2155      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend
2156      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend
2157      REAL(wp), POINTER, DIMENSION(:,:) ::   ztab   ! temporary workspace
2158      LOGICAL :: lmigr ! is true for those processors that have to migrate the OB
2159      !!----------------------------------------------------------------------
2160
2161      CALL wrk_alloc( jpi,jpj, ztab )
2162
2163      ! boundary condition initialization
2164      ! ---------------------------------
2165      ztab(:,:) = 0.e0
2166      !
2167      IF( ktype==1 ) THEN                                  ! north/south boundaries
2168         iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci     ) )
2169         iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
2170         ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci     ) )
2171         ijpt0 = MAX( 1, MIN(kl  - njmpp+1, nlcj     ) )
2172         ijpt1 = MAX( 0, MIN(kl  - njmpp+1, nlcj - 1 ) )
2173      ELSEIF( ktype==2 ) THEN                              ! east/west boundaries
2174         iipt0 = MAX( 1, MIN(kl  - nimpp+1, nlci     ) )
2175         iipt1 = MAX( 0, MIN(kl  - nimpp+1, nlci - 1 ) )
2176         ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj     ) )
2177         ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
2178         ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) )
2179      ELSE
2180         WRITE(kumout, cform_err)
2181         WRITE(kumout,*) 'mppobc : bad ktype'
2182         CALL mppstop
2183      ENDIF
2184
2185      ! Communication level by level
2186      ! ----------------------------
2187!!gm Remark : this is very time consumming!!!
2188      !                                         ! ------------------------ !
2189            IF( ijpt0 > ijpt1 .OR. iipt0 > iipt1 ) THEN
2190            ! there is nothing to be migrated
2191               lmigr = .FALSE.
2192            ELSE
2193              lmigr = .TRUE.
2194            ENDIF
2195
2196      IF( lmigr ) THEN
2197
2198      DO jk = 1, kk                             !   Loop over the levels   !
2199         !                                      ! ------------------------ !
2200         !
2201         IF( ktype == 1 ) THEN                               ! north/south boundaries
2202            DO jj = ijpt0, ijpt1
2203               DO ji = iipt0, iipt1
2204                  ztab(ji,jj) = ptab(ji,jk)
2205               END DO
2206            END DO
2207         ELSEIF( ktype == 2 ) THEN                           ! east/west boundaries
2208            DO jj = ijpt0, ijpt1
2209               DO ji = iipt0, iipt1
2210                  ztab(ji,jj) = ptab(jj,jk)
2211               END DO
2212            END DO
2213         ENDIF
2214
2215
2216         ! 1. East and west directions
2217         ! ---------------------------
2218         !
2219       IF( ktype == 1 ) THEN
2220
2221         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions
2222            iihom = nlci-nreci
2223            t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0)
2224            t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0)
2225         ENDIF
2226         !
2227         !                              ! Migrations
2228         imigr = jpreci
2229         !
2230         IF( nbondi == -1 ) THEN
2231            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
2232            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
2233            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
2234         ELSEIF( nbondi == 0 ) THEN
2235            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
2236            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
2237            CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
2238            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
2239            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
2240            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err )
2241         ELSEIF( nbondi == 1 ) THEN
2242            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
2243            CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
2244            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
2245         ENDIF
2246         !
2247         !                              ! Write Dirichlet lateral conditions
2248         iihom = nlci-jpreci
2249         !
2250         IF( nbondi == 0 .OR. nbondi == 1 ) THEN
2251            ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2)
2252         ENDIF
2253         IF( nbondi == -1 .OR. nbondi == 0 ) THEN
2254            ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2)
2255         ENDIF
2256       ENDIF  ! (ktype == 1)
2257
2258         ! 2. North and south directions
2259         ! -----------------------------
2260         !
2261       IF(ktype == 2 ) THEN
2262         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions
2263            ijhom = nlcj-nrecj
2264            t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj)
2265            t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj)
2266         ENDIF
2267         !
2268         !                              ! Migrations
2269         imigr = jprecj
2270         !
2271         IF( nbondj == -1 ) THEN
2272            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
2273            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
2274            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
2275         ELSEIF( nbondj == 0 ) THEN
2276            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
2277            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
2278            CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
2279            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
2280            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
2281            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err )
2282         ELSEIF( nbondj == 1 ) THEN
2283            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
2284            CALL mpprecv( 4, t2sn(1,1,2), imigr, noso)
2285            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
2286         ENDIF
2287         !
2288         !                              ! Write Dirichlet lateral conditions
2289         ijhom = nlcj - jprecj
2290         IF( nbondj == 0 .OR. nbondj == 1 ) THEN
2291            ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2)
2292         ENDIF
2293         IF( nbondj == 0 .OR. nbondj == -1 ) THEN
2294            ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2)
2295         ENDIF
2296         ENDIF    ! (ktype == 2)
2297         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
2298            DO jj = ijpt0, ijpt1            ! north/south boundaries
2299               DO ji = iipt0,ilpt1
2300                  ptab(ji,jk) = ztab(ji,jj)
2301               END DO
2302            END DO
2303         ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
2304            DO jj = ijpt0, ilpt1            ! east/west boundaries
2305               DO ji = iipt0,iipt1
2306                  ptab(jj,jk) = ztab(ji,jj)
2307               END DO
2308            END DO
2309         ENDIF
2310         !
2311      END DO
2312      !
2313      ENDIF ! ( lmigr )
2314      CALL wrk_dealloc( jpi,jpj, ztab )
2315      !
2316   END SUBROUTINE mppobc
2317   
2318
2319   SUBROUTINE mpp_comm_free( kcom )
2320      !!----------------------------------------------------------------------
2321      !!----------------------------------------------------------------------
2322      INTEGER, INTENT(in) ::   kcom
2323      !!
2324      INTEGER :: ierr
2325      !!----------------------------------------------------------------------
2326      !
2327      CALL MPI_COMM_FREE(kcom, ierr)
2328      !
2329   END SUBROUTINE mpp_comm_free
2330
2331
2332   SUBROUTINE mpp_ini_ice( pindic, kumout )
2333      !!----------------------------------------------------------------------
2334      !!               ***  routine mpp_ini_ice  ***
2335      !!
2336      !! ** Purpose :   Initialize special communicator for ice areas
2337      !!      condition together with global variables needed in the ddmpp folding
2338      !!
2339      !! ** Method  : - Look for ice processors in ice routines
2340      !!              - Put their number in nrank_ice
2341      !!              - Create groups for the world processors and the ice processors
2342      !!              - Create a communicator for ice processors
2343      !!
2344      !! ** output
2345      !!      njmppmax = njmpp for northern procs
2346      !!      ndim_rank_ice = number of processors with ice
2347      !!      nrank_ice (ndim_rank_ice) = ice processors
2348      !!      ngrp_world = group ID for the world processors
2349      !!      ngrp_ice = group ID for the ice processors
2350      !!      ncomm_ice = communicator for the ice procs.
2351      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2352      !!
2353      !!----------------------------------------------------------------------
2354      INTEGER, INTENT(in) ::   pindic
2355      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
2356      !!
2357      INTEGER :: jjproc
2358      INTEGER :: ii, ierr
2359      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2360      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
2361      !!----------------------------------------------------------------------
2362      !
2363      ! Since this is just an init routine and these arrays are of length jpnij
2364      ! then don't use wrk_nemo module - just allocate and deallocate.
2365      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2366      IF( ierr /= 0 ) THEN
2367         WRITE(kumout, cform_err)
2368         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2369         CALL mppstop
2370      ENDIF
2371
2372      ! Look for how many procs with sea-ice
2373      !
2374      kice = 0
2375      DO jjproc = 1, jpnij
2376         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1   
2377      END DO
2378      !
2379      zwork = 0
2380      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2381      ndim_rank_ice = SUM( zwork )         
2382
2383      ! Allocate the right size to nrank_north
2384      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2385      ALLOCATE( nrank_ice(ndim_rank_ice) )
2386      !
2387      ii = 0     
2388      nrank_ice = 0
2389      DO jjproc = 1, jpnij
2390         IF( zwork(jjproc) == 1) THEN
2391            ii = ii + 1
2392            nrank_ice(ii) = jjproc -1 
2393         ENDIF
2394      END DO
2395
2396      ! Create the world group
2397      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2398
2399      ! Create the ice group from the world group
2400      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2401
2402      ! Create the ice communicator , ie the pool of procs with sea-ice
2403      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2404
2405      ! Find proc number in the world of proc 0 in the north
2406      ! The following line seems to be useless, we just comment & keep it as reminder
2407      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
2408      !
2409      DEALLOCATE(kice, zwork)
2410      !
2411   END SUBROUTINE mpp_ini_ice
2412
2413
2414   SUBROUTINE mpp_ini_znl( kumout )
2415      !!----------------------------------------------------------------------
2416      !!               ***  routine mpp_ini_znl  ***
2417      !!
2418      !! ** Purpose :   Initialize special communicator for computing zonal sum
2419      !!
2420      !! ** Method  : - Look for processors in the same row
2421      !!              - Put their number in nrank_znl
2422      !!              - Create group for the znl processors
2423      !!              - Create a communicator for znl processors
2424      !!              - Determine if processor should write znl files
2425      !!
2426      !! ** output
2427      !!      ndim_rank_znl = number of processors on the same row
2428      !!      ngrp_znl = group ID for the znl processors
2429      !!      ncomm_znl = communicator for the ice procs.
2430      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2431      !!
2432      !!----------------------------------------------------------------------
2433      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2434      !
2435      INTEGER :: jproc      ! dummy loop integer
2436      INTEGER :: ierr, ii   ! local integer
2437      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2438      !!----------------------------------------------------------------------
2439      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2440      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2441      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2442      !
2443      ALLOCATE( kwork(jpnij), STAT=ierr )
2444      IF( ierr /= 0 ) THEN
2445         WRITE(kumout, cform_err)
2446         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2447         CALL mppstop
2448      ENDIF
2449
2450      IF( jpnj == 1 ) THEN
2451         ngrp_znl  = ngrp_world
2452         ncomm_znl = mpi_comm_opa
2453      ELSE
2454         !
2455         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2456         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2457         !-$$        CALL flush(numout)
2458         !
2459         ! Count number of processors on the same row
2460         ndim_rank_znl = 0
2461         DO jproc=1,jpnij
2462            IF ( kwork(jproc) == njmpp ) THEN
2463               ndim_rank_znl = ndim_rank_znl + 1
2464            ENDIF
2465         END DO
2466         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2467         !-$$        CALL flush(numout)
2468         ! Allocate the right size to nrank_znl
2469         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2470         ALLOCATE(nrank_znl(ndim_rank_znl))
2471         ii = 0     
2472         nrank_znl (:) = 0
2473         DO jproc=1,jpnij
2474            IF ( kwork(jproc) == njmpp) THEN
2475               ii = ii + 1
2476               nrank_znl(ii) = jproc -1 
2477            ENDIF
2478         END DO
2479         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2480         !-$$        CALL flush(numout)
2481
2482         ! Create the opa group
2483         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2484         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2485         !-$$        CALL flush(numout)
2486
2487         ! Create the znl group from the opa group
2488         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2489         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2490         !-$$        CALL flush(numout)
2491
2492         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2493         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2494         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2495         !-$$        CALL flush(numout)
2496         !
2497      END IF
2498
2499      ! Determines if processor if the first (starting from i=1) on the row
2500      IF ( jpni == 1 ) THEN
2501         l_znl_root = .TRUE.
2502      ELSE
2503         l_znl_root = .FALSE.
2504         kwork (1) = nimpp
2505         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2506         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2507      END IF
2508
2509      DEALLOCATE(kwork)
2510
2511   END SUBROUTINE mpp_ini_znl
2512
2513
2514   SUBROUTINE mpp_ini_north
2515      !!----------------------------------------------------------------------
2516      !!               ***  routine mpp_ini_north  ***
2517      !!
2518      !! ** Purpose :   Initialize special communicator for north folding
2519      !!      condition together with global variables needed in the mpp folding
2520      !!
2521      !! ** Method  : - Look for northern processors
2522      !!              - Put their number in nrank_north
2523      !!              - Create groups for the world processors and the north processors
2524      !!              - Create a communicator for northern processors
2525      !!
2526      !! ** output
2527      !!      njmppmax = njmpp for northern procs
2528      !!      ndim_rank_north = number of processors in the northern line
2529      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2530      !!      ngrp_world = group ID for the world processors
2531      !!      ngrp_north = group ID for the northern processors
2532      !!      ncomm_north = communicator for the northern procs.
2533      !!      north_root = number (in the world) of proc 0 in the northern comm.
2534      !!
2535      !!----------------------------------------------------------------------
2536      INTEGER ::   ierr
2537      INTEGER ::   jjproc
2538      INTEGER ::   ii, ji
2539      !!----------------------------------------------------------------------
2540      !
2541      njmppmax = MAXVAL( njmppt )
2542      !
2543      ! Look for how many procs on the northern boundary
2544      ndim_rank_north = 0
2545      DO jjproc = 1, jpnij
2546         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2547      END DO
2548      !
2549      ! Allocate the right size to nrank_north
2550      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2551      ALLOCATE( nrank_north(ndim_rank_north) )
2552
2553      ! Fill the nrank_north array with proc. number of northern procs.
2554      ! Note : the rank start at 0 in MPI
2555      ii = 0
2556      DO ji = 1, jpnij
2557         IF ( njmppt(ji) == njmppmax   ) THEN
2558            ii=ii+1
2559            nrank_north(ii)=ji-1
2560         END IF
2561      END DO
2562      !
2563      ! create the world group
2564      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2565      !
2566      ! Create the North group from the world group
2567      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2568      !
2569      ! Create the North communicator , ie the pool of procs in the north group
2570      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2571      !
2572   END SUBROUTINE mpp_ini_north
2573
2574
2575   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2576      !!---------------------------------------------------------------------
2577      !!                   ***  routine mpp_lbc_north_3d  ***
2578      !!
2579      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2580      !!              in mpp configuration in case of jpn1 > 1
2581      !!
2582      !! ** Method  :   North fold condition and mpp with more than one proc
2583      !!              in i-direction require a specific treatment. We gather
2584      !!              the 4 northern lines of the global domain on 1 processor
2585      !!              and apply lbc north-fold on this sub array. Then we
2586      !!              scatter the north fold array back to the processors.
2587      !!
2588      !!----------------------------------------------------------------------
2589      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2590      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2591      !                                                              !   = T ,  U , V , F or W  gridpoints
2592      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2593      !!                                                             ! =  1. , the sign is kept
2594      INTEGER ::   ji, jj, jr
2595      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2596      INTEGER ::   ijpj, ijpjm1, ij, iproc
2597      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather
2598      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2599      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2600      !!----------------------------------------------------------------------
2601      !   
2602      ijpj   = 4
2603      ityp = -1
2604      ijpjm1 = 3
2605      ztab(:,:,:) = 0.e0
2606      !
2607      DO jj = nlcj - ijpj +1, nlcj          ! put in znorthloc the last 4 jlines of pt3d
2608         ij = jj - nlcj + ijpj
2609         znorthloc(:,ij,:) = pt3d(:,jj,:)
2610      END DO
2611      !
2612      !                                     ! Build in procs of ncomm_north the znorthgloio
2613      itaille = jpi * jpk * ijpj
2614      IF ( l_north_nogather ) THEN
2615         !
2616         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2617         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2618         !
2619         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2620            ij = jj - nlcj + ijpj
2621            DO ji = 1, nlci
2622               ztab(ji+nimpp-1,ij,:) = pt3d(ji,jj,:)
2623            END DO
2624         END DO
2625
2626         !
2627         ! Set the exchange type in order to access the correct list of active neighbours
2628         !
2629         SELECT CASE ( cd_type )
2630            CASE ( 'T' , 'W' )
2631               ityp = 1
2632            CASE ( 'U' )
2633               ityp = 2
2634            CASE ( 'V' )
2635               ityp = 3
2636            CASE ( 'F' )
2637               ityp = 4
2638            CASE ( 'I' )
2639               ityp = 5
2640            CASE DEFAULT
2641               ityp = -1                    ! Set a default value for unsupported types which
2642                                            ! will cause a fallback to the mpi_allgather method
2643         END SELECT
2644         IF ( ityp .gt. 0 ) THEN
2645
2646            DO jr = 1,nsndto(ityp)
2647               CALL mppsend(5, znorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) )
2648            END DO
2649            DO jr = 1,nsndto(ityp)
2650               CALL mpprecv(5, zfoldwk, itaille, isendto(jr,ityp))
2651               iproc = isendto(jr,ityp) + 1
2652               ildi = nldit (iproc)
2653               ilei = nleit (iproc)
2654               iilb = nimppt(iproc)
2655               DO jj = 1, ijpj
2656                  DO ji = ildi, ilei
2657                     ztab(ji+iilb-1,jj,:) = zfoldwk(ji,jj,:)
2658                  END DO
2659               END DO
2660            END DO
2661            IF (l_isend) THEN
2662               DO jr = 1,nsndto(ityp)
2663                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2664               END DO
2665            ENDIF
2666
2667         ENDIF
2668
2669      ENDIF
2670
2671      IF ( ityp .lt. 0 ) THEN
2672         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2673            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2674         !
2675         DO jr = 1, ndim_rank_north         ! recover the global north array
2676            iproc = nrank_north(jr) + 1
2677            ildi  = nldit (iproc)
2678            ilei  = nleit (iproc)
2679            iilb  = nimppt(iproc)
2680            DO jj = 1, ijpj
2681               DO ji = ildi, ilei
2682                  ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2683               END DO
2684            END DO
2685         END DO
2686      ENDIF
2687      !
2688      ! The ztab array has been either:
2689      !  a. Fully populated by the mpi_allgather operation or
2690      !  b. Had the active points for this domain and northern neighbours populated
2691      !     by peer to peer exchanges
2692      ! Either way the array may be folded by lbc_nfd and the result for the span of
2693      ! this domain will be identical.
2694      !
2695      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2696      !
2697      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2698         ij = jj - nlcj + ijpj
2699         DO ji= 1, nlci
2700            pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2701         END DO
2702      END DO
2703      !
2704   END SUBROUTINE mpp_lbc_north_3d
2705
2706
2707   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2708      !!---------------------------------------------------------------------
2709      !!                   ***  routine mpp_lbc_north_2d  ***
2710      !!
2711      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2712      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2713      !!
2714      !! ** Method  :   North fold condition and mpp with more than one proc
2715      !!              in i-direction require a specific treatment. We gather
2716      !!              the 4 northern lines of the global domain on 1 processor
2717      !!              and apply lbc north-fold on this sub array. Then we
2718      !!              scatter the north fold array back to the processors.
2719      !!
2720      !!----------------------------------------------------------------------
2721      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the b.c. is applied
2722      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2723      !                                                          !   = T ,  U , V , F or W  gridpoints
2724      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2725      !!                                                             ! =  1. , the sign is kept
2726      INTEGER ::   ji, jj, jr
2727      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2728      INTEGER ::   ijpj, ijpjm1, ij, iproc
2729      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          ! for mpi_isend when avoiding mpi_allgather
2730      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2731      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2732      !!----------------------------------------------------------------------
2733      !
2734      ijpj   = 4
2735      ityp = -1
2736      ijpjm1 = 3
2737      ztab_2d(:,:) = 0.e0
2738      !
2739      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc_2d the last 4 jlines of pt2d
2740         ij = jj - nlcj + ijpj
2741         znorthloc_2d(:,ij) = pt2d(:,jj)
2742      END DO
2743
2744      !                                     ! Build in procs of ncomm_north the znorthgloio_2d
2745      itaille = jpi * ijpj
2746      IF ( l_north_nogather ) THEN
2747         !
2748         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2749         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2750         !
2751         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2752            ij = jj - nlcj + ijpj
2753            DO ji = 1, nlci
2754               ztab_2d(ji+nimpp-1,ij) = pt2d(ji,jj)
2755            END DO
2756         END DO
2757
2758         !
2759         ! Set the exchange type in order to access the correct list of active neighbours
2760         !
2761         SELECT CASE ( cd_type )
2762            CASE ( 'T' , 'W' )
2763               ityp = 1
2764            CASE ( 'U' )
2765               ityp = 2
2766            CASE ( 'V' )
2767               ityp = 3
2768            CASE ( 'F' )
2769               ityp = 4
2770            CASE ( 'I' )
2771               ityp = 5
2772            CASE DEFAULT
2773               ityp = -1                    ! Set a default value for unsupported types which
2774                                            ! will cause a fallback to the mpi_allgather method
2775         END SELECT
2776
2777         IF ( ityp .gt. 0 ) THEN
2778
2779            DO jr = 1,nsndto(ityp)
2780               CALL mppsend(5, znorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) )
2781            END DO
2782            DO jr = 1,nsndto(ityp)
2783               CALL mpprecv(5, zfoldwk_2d, itaille, isendto(jr,ityp))
2784               iproc = isendto(jr,ityp) + 1
2785               ildi = nldit (iproc)
2786               ilei = nleit (iproc)
2787               iilb = nimppt(iproc)
2788               DO jj = 1, ijpj
2789                  DO ji = ildi, ilei
2790                     ztab_2d(ji+iilb-1,jj) = zfoldwk_2d(ji,jj)
2791                  END DO
2792               END DO
2793            END DO
2794            IF (l_isend) THEN
2795               DO jr = 1,nsndto(ityp)
2796                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2797               END DO
2798            ENDIF
2799
2800         ENDIF
2801
2802      ENDIF
2803
2804      IF ( ityp .lt. 0 ) THEN
2805         CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        &
2806            &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2807         !
2808         DO jr = 1, ndim_rank_north            ! recover the global north array
2809            iproc = nrank_north(jr) + 1
2810            ildi = nldit (iproc)
2811            ilei = nleit (iproc)
2812            iilb = nimppt(iproc)
2813            DO jj = 1, ijpj
2814               DO ji = ildi, ilei
2815                  ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)
2816               END DO
2817            END DO
2818         END DO
2819      ENDIF
2820      !
2821      ! The ztab array has been either:
2822      !  a. Fully populated by the mpi_allgather operation or
2823      !  b. Had the active points for this domain and northern neighbours populated
2824      !     by peer to peer exchanges
2825      ! Either way the array may be folded by lbc_nfd and the result for the span of
2826      ! this domain will be identical.
2827      !
2828      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition
2829      !
2830      !
2831      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2832         ij = jj - nlcj + ijpj
2833         DO ji = 1, nlci
2834            pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)
2835         END DO
2836      END DO
2837      !
2838   END SUBROUTINE mpp_lbc_north_2d
2839
2840
2841   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2842      !!---------------------------------------------------------------------
2843      !!                   ***  routine mpp_lbc_north_2d  ***
2844      !!
2845      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2846      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2847      !!              array with outer extra halo
2848      !!
2849      !! ** Method  :   North fold condition and mpp with more than one proc
2850      !!              in i-direction require a specific treatment. We gather
2851      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2852      !!              processor and apply lbc north-fold on this sub array.
2853      !!              Then we scatter the north fold array back to the processors.
2854      !!
2855      !!----------------------------------------------------------------------
2856      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2857      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2858      !                                                                                         !   = T ,  U , V , F or W -points
2859      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
2860      !!                                                                                        ! north fold, =  1. otherwise
2861      INTEGER ::   ji, jj, jr
2862      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2863      INTEGER ::   ijpj, ij, iproc
2864      !!----------------------------------------------------------------------
2865      !
2866      ijpj=4
2867      ztab_e(:,:) = 0.e0
2868
2869      ij=0
2870      ! put in znorthloc_e the last 4 jlines of pt2d
2871      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2872         ij = ij + 1
2873         DO ji = 1, jpi
2874            znorthloc_e(ji,ij)=pt2d(ji,jj)
2875         END DO
2876      END DO
2877      !
2878      itaille = jpi * ( ijpj + 2 * jpr2dj )
2879      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2880         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2881      !
2882      DO jr = 1, ndim_rank_north            ! recover the global north array
2883         iproc = nrank_north(jr) + 1
2884         ildi = nldit (iproc)
2885         ilei = nleit (iproc)
2886         iilb = nimppt(iproc)
2887         DO jj = 1, ijpj+2*jpr2dj
2888            DO ji = ildi, ilei
2889               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2890            END DO
2891         END DO
2892      END DO
2893
2894
2895      ! 2. North-Fold boundary conditions
2896      ! ----------------------------------
2897      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2898
2899      ij = jpr2dj
2900      !! Scatter back to pt2d
2901      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2902      ij  = ij +1 
2903         DO ji= 1, nlci
2904            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2905         END DO
2906      END DO
2907      !
2908   END SUBROUTINE mpp_lbc_north_e
2909
2910      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
2911      !!----------------------------------------------------------------------
2912      !!                  ***  routine mpp_lnk_bdy_3d  ***
2913      !!
2914      !! ** Purpose :   Message passing management
2915      !!
2916      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2917      !!      between processors following neighboring subdomains.
2918      !!            domain parameters
2919      !!                    nlci   : first dimension of the local subdomain
2920      !!                    nlcj   : second dimension of the local subdomain
2921      !!                    nbondi_bdy : mark for "east-west local boundary"
2922      !!                    nbondj_bdy : mark for "north-south local boundary"
2923      !!                    noea   : number for local neighboring processors
2924      !!                    nowe   : number for local neighboring processors
2925      !!                    noso   : number for local neighboring processors
2926      !!                    nono   : number for local neighboring processors
2927      !!
2928      !! ** Action  :   ptab with update value at its periphery
2929      !!
2930      !!----------------------------------------------------------------------
2931
2932      USE lbcnfd          ! north fold
2933
2934      INCLUDE 'mpif.h'
2935
2936      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2937      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2938      !                                                             ! = T , U , V , F , W points
2939      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2940      !                                                             ! =  1. , the sign is kept
2941      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2942      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
2943      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2944      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2945      REAL(wp) ::   zland
2946      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2947      !!----------------------------------------------------------------------
2948
2949      zland = 0.e0
2950
2951      ! 1. standard boundary treatment
2952      ! ------------------------------
2953     
2954      !                                   ! East-West boundaries
2955      !                                        !* Cyclic east-west
2956
2957      IF( nbondi == 2) THEN
2958        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2959          ptab( 1 ,:,:) = ptab(jpim1,:,:)
2960          ptab(jpi,:,:) = ptab(  2  ,:,:)
2961        ELSE
2962          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2963          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2964        ENDIF
2965      ELSEIF(nbondi == -1) THEN
2966        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2967      ELSEIF(nbondi == 1) THEN
2968        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2969      ENDIF                                     !* closed
2970
2971      IF (nbondj == 2 .OR. nbondj == -1) THEN
2972        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
2973      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2974        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
2975      ENDIF
2976     
2977      !
2978
2979      ! 2. East and west directions exchange
2980      ! ------------------------------------
2981      ! we play with the neigbours AND the row number because of the periodicity
2982      !
2983      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2984      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2985         iihom = nlci-nreci
2986         DO jl = 1, jpreci
2987            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
2988            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
2989         END DO
2990      END SELECT
2991      !
2992      !                           ! Migrations
2993      imigr = jpreci * jpj * jpk
2994      !
2995      SELECT CASE ( nbondi_bdy(ib_bdy) )
2996      CASE ( -1 )
2997         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
2998      CASE ( 0 )
2999         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
3000         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
3001      CASE ( 1 )
3002         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
3003      END SELECT
3004      !
3005      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3006      CASE ( -1 )
3007         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
3008      CASE ( 0 )
3009         CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
3010         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
3011      CASE ( 1 )
3012         CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
3013      END SELECT
3014      !
3015      SELECT CASE ( nbondi_bdy(ib_bdy) )
3016      CASE ( -1 )
3017         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3018      CASE ( 0 )
3019         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3020         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3021      CASE ( 1 )
3022         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3023      END SELECT
3024      !
3025      !                           ! Write Dirichlet lateral conditions
3026      iihom = nlci-jpreci
3027      !
3028      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3029      CASE ( -1 )
3030         DO jl = 1, jpreci
3031            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
3032         END DO
3033      CASE ( 0 )
3034         DO jl = 1, jpreci
3035            ptab(jl      ,:,:) = t3we(:,jl,:,2)
3036            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
3037         END DO
3038      CASE ( 1 )
3039         DO jl = 1, jpreci
3040            ptab(jl      ,:,:) = t3we(:,jl,:,2)
3041         END DO
3042      END SELECT
3043
3044
3045      ! 3. North and south directions
3046      ! -----------------------------
3047      ! always closed : we play only with the neigbours
3048      !
3049      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3050         ijhom = nlcj-nrecj
3051         DO jl = 1, jprecj
3052            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3053            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
3054         END DO
3055      ENDIF
3056      !
3057      !                           ! Migrations
3058      imigr = jprecj * jpi * jpk
3059      !
3060      SELECT CASE ( nbondj_bdy(ib_bdy) )
3061      CASE ( -1 )
3062         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
3063      CASE ( 0 )
3064         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
3065         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
3066      CASE ( 1 )
3067         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
3068      END SELECT
3069      !
3070      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3071      CASE ( -1 )
3072         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
3073      CASE ( 0 )
3074         CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
3075         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
3076      CASE ( 1 )
3077         CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
3078      END SELECT
3079      !
3080      SELECT CASE ( nbondj_bdy(ib_bdy) )
3081      CASE ( -1 )
3082         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3083      CASE ( 0 )
3084         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3085         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3086      CASE ( 1 )
3087         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3088      END SELECT
3089      !
3090      !                           ! Write Dirichlet lateral conditions
3091      ijhom = nlcj-jprecj
3092      !
3093      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3094      CASE ( -1 )
3095         DO jl = 1, jprecj
3096            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
3097         END DO
3098      CASE ( 0 )
3099         DO jl = 1, jprecj
3100            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
3101            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
3102         END DO
3103      CASE ( 1 )
3104         DO jl = 1, jprecj
3105            ptab(:,jl,:) = t3sn(:,jl,:,2)
3106         END DO
3107      END SELECT
3108
3109
3110      ! 4. north fold treatment
3111      ! -----------------------
3112      !
3113      IF( npolj /= 0) THEN
3114         !
3115         SELECT CASE ( jpni )
3116         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3117         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3118         END SELECT
3119         !
3120      ENDIF
3121      !
3122   END SUBROUTINE mpp_lnk_bdy_3d
3123
3124      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
3125      !!----------------------------------------------------------------------
3126      !!                  ***  routine mpp_lnk_bdy_2d  ***
3127      !!
3128      !! ** Purpose :   Message passing management
3129      !!
3130      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3131      !!      between processors following neighboring subdomains.
3132      !!            domain parameters
3133      !!                    nlci   : first dimension of the local subdomain
3134      !!                    nlcj   : second dimension of the local subdomain
3135      !!                    nbondi_bdy : mark for "east-west local boundary"
3136      !!                    nbondj_bdy : mark for "north-south local boundary"
3137      !!                    noea   : number for local neighboring processors
3138      !!                    nowe   : number for local neighboring processors
3139      !!                    noso   : number for local neighboring processors
3140      !!                    nono   : number for local neighboring processors
3141      !!
3142      !! ** Action  :   ptab with update value at its periphery
3143      !!
3144      !!----------------------------------------------------------------------
3145
3146      USE lbcnfd          ! north fold
3147
3148      INCLUDE 'mpif.h'
3149
3150      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3151      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
3152      !                                                             ! = T , U , V , F , W points
3153      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
3154      !                                                             ! =  1. , the sign is kept
3155      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3156      INTEGER  ::   ji, jj, jl             ! dummy loop indices
3157      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3158      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3159      REAL(wp) ::   zland
3160      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3161      !!----------------------------------------------------------------------
3162
3163      zland = 0.e0
3164
3165      ! 1. standard boundary treatment
3166      ! ------------------------------
3167     
3168      !                                   ! East-West boundaries
3169      !                                        !* Cyclic east-west
3170
3171      IF( nbondi == 2) THEN
3172        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
3173          ptab( 1 ,:) = ptab(jpim1,:)
3174          ptab(jpi,:) = ptab(  2  ,:)
3175        ELSE
3176          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3177          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3178        ENDIF
3179      ELSEIF(nbondi == -1) THEN
3180        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3181      ELSEIF(nbondi == 1) THEN
3182        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3183      ENDIF                                     !* closed
3184
3185      IF (nbondj == 2 .OR. nbondj == -1) THEN
3186        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point
3187      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3188        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north
3189      ENDIF
3190     
3191      !
3192
3193      ! 2. East and west directions exchange
3194      ! ------------------------------------
3195      ! we play with the neigbours AND the row number because of the periodicity
3196      !
3197      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3198      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3199         iihom = nlci-nreci
3200         DO jl = 1, jpreci
3201            t2ew(:,jl,1) = ptab(jpreci+jl,:)
3202            t2we(:,jl,1) = ptab(iihom +jl,:)
3203         END DO
3204      END SELECT
3205      !
3206      !                           ! Migrations
3207      imigr = jpreci * jpj
3208      !
3209      SELECT CASE ( nbondi_bdy(ib_bdy) )
3210      CASE ( -1 )
3211         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
3212      CASE ( 0 )
3213         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
3214         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
3215      CASE ( 1 )
3216         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
3217      END SELECT
3218      !
3219      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3220      CASE ( -1 )
3221         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
3222      CASE ( 0 )
3223         CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
3224         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
3225      CASE ( 1 )
3226         CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
3227      END SELECT
3228      !
3229      SELECT CASE ( nbondi_bdy(ib_bdy) )
3230      CASE ( -1 )
3231         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3232      CASE ( 0 )
3233         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3234         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3235      CASE ( 1 )
3236         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3237      END SELECT
3238      !
3239      !                           ! Write Dirichlet lateral conditions
3240      iihom = nlci-jpreci
3241      !
3242      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3243      CASE ( -1 )
3244         DO jl = 1, jpreci
3245            ptab(iihom+jl,:) = t2ew(:,jl,2)
3246         END DO
3247      CASE ( 0 )
3248         DO jl = 1, jpreci
3249            ptab(jl      ,:) = t2we(:,jl,2)
3250            ptab(iihom+jl,:) = t2ew(:,jl,2)
3251         END DO
3252      CASE ( 1 )
3253         DO jl = 1, jpreci
3254            ptab(jl      ,:) = t2we(:,jl,2)
3255         END DO
3256      END SELECT
3257
3258
3259      ! 3. North and south directions
3260      ! -----------------------------
3261      ! always closed : we play only with the neigbours
3262      !
3263      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3264         ijhom = nlcj-nrecj
3265         DO jl = 1, jprecj
3266            t2sn(:,jl,1) = ptab(:,ijhom +jl)
3267            t2ns(:,jl,1) = ptab(:,jprecj+jl)
3268         END DO
3269      ENDIF
3270      !
3271      !                           ! Migrations
3272      imigr = jprecj * jpi
3273      !
3274      SELECT CASE ( nbondj_bdy(ib_bdy) )
3275      CASE ( -1 )
3276         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
3277      CASE ( 0 )
3278         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
3279         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
3280      CASE ( 1 )
3281         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
3282      END SELECT
3283      !
3284      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3285      CASE ( -1 )
3286         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
3287      CASE ( 0 )
3288         CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
3289         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
3290      CASE ( 1 )
3291         CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
3292      END SELECT
3293      !
3294      SELECT CASE ( nbondj_bdy(ib_bdy) )
3295      CASE ( -1 )
3296         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3297      CASE ( 0 )
3298         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3299         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3300      CASE ( 1 )
3301         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3302      END SELECT
3303      !
3304      !                           ! Write Dirichlet lateral conditions
3305      ijhom = nlcj-jprecj
3306      !
3307      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3308      CASE ( -1 )
3309         DO jl = 1, jprecj
3310            ptab(:,ijhom+jl) = t2ns(:,jl,2)
3311         END DO
3312      CASE ( 0 )
3313         DO jl = 1, jprecj
3314            ptab(:,jl      ) = t2sn(:,jl,2)
3315            ptab(:,ijhom+jl) = t2ns(:,jl,2)
3316         END DO
3317      CASE ( 1 )
3318         DO jl = 1, jprecj
3319            ptab(:,jl) = t2sn(:,jl,2)
3320         END DO
3321      END SELECT
3322
3323
3324      ! 4. north fold treatment
3325      ! -----------------------
3326      !
3327      IF( npolj /= 0) THEN
3328         !
3329         SELECT CASE ( jpni )
3330         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3331         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3332         END SELECT
3333         !
3334      ENDIF
3335      !
3336   END SUBROUTINE mpp_lnk_bdy_2d
3337
3338   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3339      !!---------------------------------------------------------------------
3340      !!                   ***  routine mpp_init.opa  ***
3341      !!
3342      !! ** Purpose :: export and attach a MPI buffer for bsend
3343      !!
3344      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3345      !!            but classical mpi_init
3346      !!
3347      !! History :: 01/11 :: IDRIS initial version for IBM only 
3348      !!            08/04 :: R. Benshila, generalisation
3349      !!---------------------------------------------------------------------
3350      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
3351      INTEGER                      , INTENT(inout) ::   ksft
3352      INTEGER                      , INTENT(  out) ::   code
3353      INTEGER                                      ::   ierr, ji
3354      LOGICAL                                      ::   mpi_was_called
3355      !!---------------------------------------------------------------------
3356      !
3357      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
3358      IF ( code /= MPI_SUCCESS ) THEN
3359         DO ji = 1, SIZE(ldtxt) 
3360            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3361         END DO         
3362         WRITE(*, cform_err)
3363         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
3364         CALL mpi_abort( mpi_comm_world, code, ierr )
3365      ENDIF
3366      !
3367      IF( .NOT. mpi_was_called ) THEN
3368         CALL mpi_init( code )
3369         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3370         IF ( code /= MPI_SUCCESS ) THEN
3371            DO ji = 1, SIZE(ldtxt) 
3372               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3373            END DO
3374            WRITE(*, cform_err)
3375            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
3376            CALL mpi_abort( mpi_comm_world, code, ierr )
3377         ENDIF
3378      ENDIF
3379      !
3380      IF( nn_buffer > 0 ) THEN
3381         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
3382         ! Buffer allocation and attachment
3383         ALLOCATE( tampon(nn_buffer), stat = ierr )
3384         IF( ierr /= 0 ) THEN
3385            DO ji = 1, SIZE(ldtxt) 
3386               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3387            END DO
3388            WRITE(*, cform_err)
3389            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3390            CALL mpi_abort( mpi_comm_world, code, ierr )
3391         END IF
3392         CALL mpi_buffer_attach( tampon, nn_buffer, code )
3393      ENDIF
3394      !
3395   END SUBROUTINE mpi_init_opa
3396
3397#if defined key_mpp_rep
3398   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3399      !!---------------------------------------------------------------------
3400      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3401      !!
3402      !!   Modification of original codes written by David H. Bailey
3403      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3404      !!---------------------------------------------------------------------
3405      INTEGER, INTENT(in)                         :: ilen, itype
3406      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
3407      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
3408      !
3409      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3410      INTEGER :: ji, ztmp           ! local scalar
3411
3412      ztmp = itype   ! avoid compilation warning
3413
3414      DO ji=1,ilen
3415      ! Compute ydda + yddb using Knuth's trick.
3416         zt1  = real(ydda(ji)) + real(yddb(ji))
3417         zerr = zt1 - real(ydda(ji))
3418         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3419                + aimag(ydda(ji)) + aimag(yddb(ji))
3420
3421         ! The result is zt1 + zt2, after normalization.
3422         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3423      END DO
3424
3425   END SUBROUTINE DDPDD_MPI
3426#endif
3427
3428#else
3429   !!----------------------------------------------------------------------
3430   !!   Default case:            Dummy module        share memory computing
3431   !!----------------------------------------------------------------------
3432   USE in_out_manager
3433
3434   INTERFACE mpp_sum
3435      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3436   END INTERFACE
3437   INTERFACE mpp_max
3438      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3439   END INTERFACE
3440   INTERFACE mpp_min
3441      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3442   END INTERFACE
3443   INTERFACE mppobc
3444      MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
3445   END INTERFACE
3446   INTERFACE mpp_minloc
3447      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3448   END INTERFACE
3449   INTERFACE mpp_maxloc
3450      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3451   END INTERFACE
3452
3453   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
3454   LOGICAL, PUBLIC            ::   ln_nnogather  = .FALSE.  !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3455   INTEGER :: ncomm_ice
3456   !!----------------------------------------------------------------------
3457CONTAINS
3458
3459   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
3460      INTEGER, INTENT(in) ::   kumout
3461      lib_mpp_alloc = 0
3462   END FUNCTION lib_mpp_alloc
3463
3464   FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value)
3465      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
3466      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
3467      INTEGER ::   kumnam, kstop
3468      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
3469      IF( .FALSE. )   ldtxt(:) = 'never done'
3470   END FUNCTION mynode
3471
3472   SUBROUTINE mppsync                       ! Dummy routine
3473   END SUBROUTINE mppsync
3474
3475   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
3476      REAL   , DIMENSION(:) :: parr
3477      INTEGER               :: kdim
3478      INTEGER, OPTIONAL     :: kcom 
3479      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
3480   END SUBROUTINE mpp_sum_as
3481
3482   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
3483      REAL   , DIMENSION(:,:) :: parr
3484      INTEGER               :: kdim
3485      INTEGER, OPTIONAL     :: kcom 
3486      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
3487   END SUBROUTINE mpp_sum_a2s
3488
3489   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
3490      INTEGER, DIMENSION(:) :: karr
3491      INTEGER               :: kdim
3492      INTEGER, OPTIONAL     :: kcom 
3493      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
3494   END SUBROUTINE mpp_sum_ai
3495
3496   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
3497      REAL                  :: psca
3498      INTEGER, OPTIONAL     :: kcom 
3499      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
3500   END SUBROUTINE mpp_sum_s
3501
3502   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
3503      integer               :: kint
3504      INTEGER, OPTIONAL     :: kcom 
3505      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
3506   END SUBROUTINE mpp_sum_i
3507
3508   SUBROUTINE mppsum_realdd( ytab, kcom )
3509      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
3510      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3511      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
3512   END SUBROUTINE mppsum_realdd
3513 
3514   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
3515      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
3516      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
3517      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3518      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
3519   END SUBROUTINE mppsum_a_realdd
3520
3521   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
3522      REAL   , DIMENSION(:) :: parr
3523      INTEGER               :: kdim
3524      INTEGER, OPTIONAL     :: kcom 
3525      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3526   END SUBROUTINE mppmax_a_real
3527
3528   SUBROUTINE mppmax_real( psca, kcom )
3529      REAL                  :: psca
3530      INTEGER, OPTIONAL     :: kcom 
3531      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
3532   END SUBROUTINE mppmax_real
3533
3534   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
3535      REAL   , DIMENSION(:) :: parr
3536      INTEGER               :: kdim
3537      INTEGER, OPTIONAL     :: kcom 
3538      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3539   END SUBROUTINE mppmin_a_real
3540
3541   SUBROUTINE mppmin_real( psca, kcom )
3542      REAL                  :: psca
3543      INTEGER, OPTIONAL     :: kcom 
3544      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
3545   END SUBROUTINE mppmin_real
3546
3547   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
3548      INTEGER, DIMENSION(:) :: karr
3549      INTEGER               :: kdim
3550      INTEGER, OPTIONAL     :: kcom 
3551      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3552   END SUBROUTINE mppmax_a_int
3553
3554   SUBROUTINE mppmax_int( kint, kcom)
3555      INTEGER               :: kint
3556      INTEGER, OPTIONAL     :: kcom 
3557      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
3558   END SUBROUTINE mppmax_int
3559
3560   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
3561      INTEGER, DIMENSION(:) :: karr
3562      INTEGER               :: kdim
3563      INTEGER, OPTIONAL     :: kcom 
3564      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3565   END SUBROUTINE mppmin_a_int
3566
3567   SUBROUTINE mppmin_int( kint, kcom )
3568      INTEGER               :: kint
3569      INTEGER, OPTIONAL     :: kcom 
3570      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
3571   END SUBROUTINE mppmin_int
3572
3573   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
3574      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
3575      REAL, DIMENSION(:) ::   parr           ! variable array
3576      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
3577   END SUBROUTINE mppobc_1d
3578
3579   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
3580      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
3581      REAL, DIMENSION(:,:) ::   parr           ! variable array
3582      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
3583   END SUBROUTINE mppobc_2d
3584
3585   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
3586      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
3587      REAL, DIMENSION(:,:,:) ::   parr           ! variable array
3588      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
3589   END SUBROUTINE mppobc_3d
3590
3591   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
3592      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
3593      REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array
3594      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
3595   END SUBROUTINE mppobc_4d
3596
3597   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
3598      REAL                   :: pmin
3599      REAL , DIMENSION (:,:) :: ptab, pmask
3600      INTEGER :: ki, kj
3601      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
3602   END SUBROUTINE mpp_minloc2d
3603
3604   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
3605      REAL                     :: pmin
3606      REAL , DIMENSION (:,:,:) :: ptab, pmask
3607      INTEGER :: ki, kj, kk
3608      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3609   END SUBROUTINE mpp_minloc3d
3610
3611   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
3612      REAL                   :: pmax
3613      REAL , DIMENSION (:,:) :: ptab, pmask
3614      INTEGER :: ki, kj
3615      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
3616   END SUBROUTINE mpp_maxloc2d
3617
3618   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
3619      REAL                     :: pmax
3620      REAL , DIMENSION (:,:,:) :: ptab, pmask
3621      INTEGER :: ki, kj, kk
3622      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3623   END SUBROUTINE mpp_maxloc3d
3624
3625   SUBROUTINE mppstop
3626      WRITE(*,*) 'mppstop: You should not have seen this print if running in mpp mode! error?...'
3627      WRITE(*,*) 'mppstop: ..otherwise this is a stop condition raised by ctl_stop in single processor mode'
3628      STOP
3629   END SUBROUTINE mppstop
3630
3631   SUBROUTINE mpp_ini_ice( kcom, knum )
3632      INTEGER :: kcom, knum
3633      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
3634   END SUBROUTINE mpp_ini_ice
3635
3636   SUBROUTINE mpp_ini_znl( knum )
3637      INTEGER :: knum
3638      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
3639   END SUBROUTINE mpp_ini_znl
3640
3641   SUBROUTINE mpp_comm_free( kcom )
3642      INTEGER :: kcom
3643      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
3644   END SUBROUTINE mpp_comm_free
3645#endif
3646
3647   !!----------------------------------------------------------------------
3648   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn   routines
3649   !!----------------------------------------------------------------------
3650
3651   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
3652      &                 cd6, cd7, cd8, cd9, cd10 )
3653      !!----------------------------------------------------------------------
3654      !!                  ***  ROUTINE  stop_opa  ***
3655      !!
3656      !! ** Purpose :   print in ocean.outpput file a error message and
3657      !!                increment the error number (nstop) by one.
3658      !!----------------------------------------------------------------------
3659      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3660      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3661      !!----------------------------------------------------------------------
3662      !
3663      nstop = nstop + 1 
3664      IF(lwp) THEN
3665         WRITE(numout,cform_err)
3666         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
3667         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
3668         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
3669         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
3670         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
3671         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
3672         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
3673         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
3674         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
3675         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
3676      ENDIF
3677                               CALL FLUSH(numout    )
3678      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
3679      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
3680      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
3681      !
3682      IF( cd1 == 'STOP' ) THEN
3683         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
3684         CALL mppstop()
3685      ENDIF
3686      !
3687   END SUBROUTINE ctl_stop
3688
3689
3690   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
3691      &                 cd6, cd7, cd8, cd9, cd10 )
3692      !!----------------------------------------------------------------------
3693      !!                  ***  ROUTINE  stop_warn  ***
3694      !!
3695      !! ** Purpose :   print in ocean.outpput file a error message and
3696      !!                increment the warning number (nwarn) by one.
3697      !!----------------------------------------------------------------------
3698      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3699      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3700      !!----------------------------------------------------------------------
3701      !
3702      nwarn = nwarn + 1 
3703      IF(lwp) THEN
3704         WRITE(numout,cform_war)
3705         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
3706         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
3707         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
3708         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
3709         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
3710         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
3711         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
3712         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
3713         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
3714         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
3715      ENDIF
3716      CALL FLUSH(numout)
3717      !
3718   END SUBROUTINE ctl_warn
3719
3720
3721   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
3722      !!----------------------------------------------------------------------
3723      !!                  ***  ROUTINE ctl_opn  ***
3724      !!
3725      !! ** Purpose :   Open file and check if required file is available.
3726      !!
3727      !! ** Method  :   Fortan open
3728      !!----------------------------------------------------------------------
3729      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
3730      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
3731      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
3732      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
3733      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
3734      INTEGER          , INTENT(in   ) ::   klengh    ! record length
3735      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
3736      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3737      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
3738      !!
3739      CHARACTER(len=80) ::   clfile
3740      INTEGER           ::   iost
3741      !!----------------------------------------------------------------------
3742
3743      ! adapt filename
3744      ! ----------------
3745      clfile = TRIM(cdfile)
3746      IF( PRESENT( karea ) ) THEN
3747         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
3748      ENDIF
3749#if defined key_agrif
3750      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
3751      knum=Agrif_Get_Unit()
3752#else
3753      knum=get_unit()
3754#endif
3755
3756      iost=0
3757      IF( cdacce(1:6) == 'DIRECT' )  THEN
3758         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
3759      ELSE
3760         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
3761      ENDIF
3762      IF( iost == 0 ) THEN
3763         IF(ldwp) THEN
3764            WRITE(kout,*) '     file   : ', clfile,' open ok'
3765            WRITE(kout,*) '     unit   = ', knum
3766            WRITE(kout,*) '     status = ', cdstat
3767            WRITE(kout,*) '     form   = ', cdform
3768            WRITE(kout,*) '     access = ', cdacce
3769            WRITE(kout,*)
3770         ENDIF
3771      ENDIF
3772100   CONTINUE
3773      IF( iost /= 0 ) THEN
3774         IF(ldwp) THEN
3775            WRITE(kout,*)
3776            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
3777            WRITE(kout,*) ' =======   ===  '
3778            WRITE(kout,*) '           unit   = ', knum
3779            WRITE(kout,*) '           status = ', cdstat
3780            WRITE(kout,*) '           form   = ', cdform
3781            WRITE(kout,*) '           access = ', cdacce
3782            WRITE(kout,*) '           iostat = ', iost
3783            WRITE(kout,*) '           we stop. verify the file '
3784            WRITE(kout,*)
3785         ENDIF
3786         STOP 'ctl_opn bad opening'
3787      ENDIF
3788     
3789   END SUBROUTINE ctl_opn
3790
3791
3792   INTEGER FUNCTION get_unit()
3793      !!----------------------------------------------------------------------
3794      !!                  ***  FUNCTION  get_unit  ***
3795      !!
3796      !! ** Purpose :   return the index of an unused logical unit
3797      !!----------------------------------------------------------------------
3798      LOGICAL :: llopn 
3799      !!----------------------------------------------------------------------
3800      !
3801      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
3802      llopn = .TRUE.
3803      DO WHILE( (get_unit < 998) .AND. llopn )
3804         get_unit = get_unit + 1
3805         INQUIRE( unit = get_unit, opened = llopn )
3806      END DO
3807      IF( (get_unit == 999) .AND. llopn ) THEN
3808         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
3809         get_unit = -1
3810      ENDIF
3811      !
3812   END FUNCTION get_unit
3813
3814   !!----------------------------------------------------------------------
3815END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.