source: branches/UKMO/dev_r5107_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5284

Last change on this file since 5284 was 5284, checked in by dancopsey, 6 years ago

First attempt to convert OASIS3-MCT branch from NEMO3.5 to NEMO3.6. Original branch was dev/frrh/vn3.5_beta_hadgem3_mct

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