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

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

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 2636

Last change on this file since 2636 was 2636, checked in by gm, 12 years ago

dynamic mem: #785 ; move ctl_stop & warn in lib_mpp to avoid a circular dependency + ctl_stop improvment

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