source: branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4027

Last change on this file since 4027 was 4027, checked in by epico, 8 years ago

bug fix to support also decompositions without land-only processes

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