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

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

Changes for Agrif in MPI

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