source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 10 years ago

First attempt to put dynamic allocation on the trunk

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