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

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

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

Last change on this file since 4990 was 4990, checked in by timgraham, 10 years ago

Merged branches/2014/dev_MERGE_2014 back onto the trunk as follows:

In the working copy of branch ran:
svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk@HEAD
1 conflict in LIM_SRC_3/limdiahsb.F90
Resolved by keeping the version from dev_MERGE_2014 branch
and commited at r4989

In working copy run:
svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
to switch working copy

Run:
svn merge --reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2014/dev_MERGE_2014
to merge the branch into the trunk - no conflicts at this stage.

  • Property svn:keywords set to Id
File size: 149.2 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      !!                  ***  routine mppstop  ***
1718      !!
1719      !! ** purpose :   Stop massively parallel processors method
1720      !!
1721      !!----------------------------------------------------------------------
1722      INTEGER ::   info
1723      !!----------------------------------------------------------------------
1724      !
1725      CALL mppsync
1726      CALL mpi_finalize( info )
1727      !
1728   END SUBROUTINE mppstop
1729
1730
1731   SUBROUTINE mpp_comm_free( kcom )
1732      !!----------------------------------------------------------------------
1733      !!----------------------------------------------------------------------
1734      INTEGER, INTENT(in) ::   kcom
1735      !!
1736      INTEGER :: ierr
1737      !!----------------------------------------------------------------------
1738      !
1739      CALL MPI_COMM_FREE(kcom, ierr)
1740      !
1741   END SUBROUTINE mpp_comm_free
1742
1743
1744   SUBROUTINE mpp_ini_ice( pindic, kumout )
1745      !!----------------------------------------------------------------------
1746      !!               ***  routine mpp_ini_ice  ***
1747      !!
1748      !! ** Purpose :   Initialize special communicator for ice areas
1749      !!      condition together with global variables needed in the ddmpp folding
1750      !!
1751      !! ** Method  : - Look for ice processors in ice routines
1752      !!              - Put their number in nrank_ice
1753      !!              - Create groups for the world processors and the ice processors
1754      !!              - Create a communicator for ice processors
1755      !!
1756      !! ** output
1757      !!      njmppmax = njmpp for northern procs
1758      !!      ndim_rank_ice = number of processors with ice
1759      !!      nrank_ice (ndim_rank_ice) = ice processors
1760      !!      ngrp_iworld = group ID for the world processors
1761      !!      ngrp_ice = group ID for the ice processors
1762      !!      ncomm_ice = communicator for the ice procs.
1763      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
1764      !!
1765      !!----------------------------------------------------------------------
1766      INTEGER, INTENT(in) ::   pindic
1767      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
1768      !!
1769      INTEGER :: jjproc
1770      INTEGER :: ii, ierr
1771      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
1772      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
1773      !!----------------------------------------------------------------------
1774      !
1775      ! Since this is just an init routine and these arrays are of length jpnij
1776      ! then don't use wrk_nemo module - just allocate and deallocate.
1777      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
1778      IF( ierr /= 0 ) THEN
1779         WRITE(kumout, cform_err)
1780         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
1781         CALL mppstop
1782      ENDIF
1783
1784      ! Look for how many procs with sea-ice
1785      !
1786      kice = 0
1787      DO jjproc = 1, jpnij
1788         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
1789      END DO
1790      !
1791      zwork = 0
1792      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
1793      ndim_rank_ice = SUM( zwork )
1794
1795      ! Allocate the right size to nrank_north
1796      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
1797      ALLOCATE( nrank_ice(ndim_rank_ice) )
1798      !
1799      ii = 0
1800      nrank_ice = 0
1801      DO jjproc = 1, jpnij
1802         IF( zwork(jjproc) == 1) THEN
1803            ii = ii + 1
1804            nrank_ice(ii) = jjproc -1
1805         ENDIF
1806      END DO
1807
1808      ! Create the world group
1809      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
1810
1811      ! Create the ice group from the world group
1812      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
1813
1814      ! Create the ice communicator , ie the pool of procs with sea-ice
1815      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
1816
1817      ! Find proc number in the world of proc 0 in the north
1818      ! The following line seems to be useless, we just comment & keep it as reminder
1819      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
1820      !
1821      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
1822      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
1823
1824      DEALLOCATE(kice, zwork)
1825      !
1826   END SUBROUTINE mpp_ini_ice
1827
1828
1829   SUBROUTINE mpp_ini_znl( kumout )
1830      !!----------------------------------------------------------------------
1831      !!               ***  routine mpp_ini_znl  ***
1832      !!
1833      !! ** Purpose :   Initialize special communicator for computing zonal sum
1834      !!
1835      !! ** Method  : - Look for processors in the same row
1836      !!              - Put their number in nrank_znl
1837      !!              - Create group for the znl processors
1838      !!              - Create a communicator for znl processors
1839      !!              - Determine if processor should write znl files
1840      !!
1841      !! ** output
1842      !!      ndim_rank_znl = number of processors on the same row
1843      !!      ngrp_znl = group ID for the znl processors
1844      !!      ncomm_znl = communicator for the ice procs.
1845      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
1846      !!
1847      !!----------------------------------------------------------------------
1848      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
1849      !
1850      INTEGER :: jproc      ! dummy loop integer
1851      INTEGER :: ierr, ii   ! local integer
1852      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
1853      !!----------------------------------------------------------------------
1854      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
1855      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
1856      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
1857      !
1858      ALLOCATE( kwork(jpnij), STAT=ierr )
1859      IF( ierr /= 0 ) THEN
1860         WRITE(kumout, cform_err)
1861         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
1862         CALL mppstop
1863      ENDIF
1864
1865      IF( jpnj == 1 ) THEN
1866         ngrp_znl  = ngrp_world
1867         ncomm_znl = mpi_comm_opa
1868      ELSE
1869         !
1870         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
1871         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
1872         !-$$        CALL flush(numout)
1873         !
1874         ! Count number of processors on the same row
1875         ndim_rank_znl = 0
1876         DO jproc=1,jpnij
1877            IF ( kwork(jproc) == njmpp ) THEN
1878               ndim_rank_znl = ndim_rank_znl + 1
1879            ENDIF
1880         END DO
1881         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
1882         !-$$        CALL flush(numout)
1883         ! Allocate the right size to nrank_znl
1884         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
1885         ALLOCATE(nrank_znl(ndim_rank_znl))
1886         ii = 0
1887         nrank_znl (:) = 0
1888         DO jproc=1,jpnij
1889            IF ( kwork(jproc) == njmpp) THEN
1890               ii = ii + 1
1891               nrank_znl(ii) = jproc -1
1892            ENDIF
1893         END DO
1894         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
1895         !-$$        CALL flush(numout)
1896
1897         ! Create the opa group
1898         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
1899         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
1900         !-$$        CALL flush(numout)
1901
1902         ! Create the znl group from the opa group
1903         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
1904         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
1905         !-$$        CALL flush(numout)
1906
1907         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
1908         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
1909         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
1910         !-$$        CALL flush(numout)
1911         !
1912      END IF
1913
1914      ! Determines if processor if the first (starting from i=1) on the row
1915      IF ( jpni == 1 ) THEN
1916         l_znl_root = .TRUE.
1917      ELSE
1918         l_znl_root = .FALSE.
1919         kwork (1) = nimpp
1920         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
1921         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
1922      END IF
1923
1924      DEALLOCATE(kwork)
1925
1926   END SUBROUTINE mpp_ini_znl
1927
1928
1929   SUBROUTINE mpp_ini_north
1930      !!----------------------------------------------------------------------
1931      !!               ***  routine mpp_ini_north  ***
1932      !!
1933      !! ** Purpose :   Initialize special communicator for north folding
1934      !!      condition together with global variables needed in the mpp folding
1935      !!
1936      !! ** Method  : - Look for northern processors
1937      !!              - Put their number in nrank_north
1938      !!              - Create groups for the world processors and the north processors
1939      !!              - Create a communicator for northern processors
1940      !!
1941      !! ** output
1942      !!      njmppmax = njmpp for northern procs
1943      !!      ndim_rank_north = number of processors in the northern line
1944      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
1945      !!      ngrp_world = group ID for the world processors
1946      !!      ngrp_north = group ID for the northern processors
1947      !!      ncomm_north = communicator for the northern procs.
1948      !!      north_root = number (in the world) of proc 0 in the northern comm.
1949      !!
1950      !!----------------------------------------------------------------------
1951      INTEGER ::   ierr
1952      INTEGER ::   jjproc
1953      INTEGER ::   ii, ji
1954      !!----------------------------------------------------------------------
1955      !
1956      njmppmax = MAXVAL( njmppt )
1957      !
1958      ! Look for how many procs on the northern boundary
1959      ndim_rank_north = 0
1960      DO jjproc = 1, jpnij
1961         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
1962      END DO
1963      !
1964      ! Allocate the right size to nrank_north
1965      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
1966      ALLOCATE( nrank_north(ndim_rank_north) )
1967
1968      ! Fill the nrank_north array with proc. number of northern procs.
1969      ! Note : the rank start at 0 in MPI
1970      ii = 0
1971      DO ji = 1, jpnij
1972         IF ( njmppt(ji) == njmppmax   ) THEN
1973            ii=ii+1
1974            nrank_north(ii)=ji-1
1975         END IF
1976      END DO
1977      !
1978      ! create the world group
1979      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
1980      !
1981      ! Create the North group from the world group
1982      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
1983      !
1984      ! Create the North communicator , ie the pool of procs in the north group
1985      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
1986      !
1987   END SUBROUTINE mpp_ini_north
1988
1989
1990   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
1991      !!---------------------------------------------------------------------
1992      !!                   ***  routine mpp_lbc_north_3d  ***
1993      !!
1994      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
1995      !!              in mpp configuration in case of jpn1 > 1
1996      !!
1997      !! ** Method  :   North fold condition and mpp with more than one proc
1998      !!              in i-direction require a specific treatment. We gather
1999      !!              the 4 northern lines of the global domain on 1 processor
2000      !!              and apply lbc north-fold on this sub array. Then we
2001      !!              scatter the north fold array back to the processors.
2002      !!
2003      !!----------------------------------------------------------------------
2004      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2005      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2006      !                                                              !   = T ,  U , V , F or W  gridpoints
2007      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2008      !!                                                             ! =  1. , the sign is kept
2009      INTEGER ::   ji, jj, jr, jk
2010      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2011      INTEGER ::   ijpj, ijpjm1, ij, iproc
2012      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2013      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2014      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2015      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2016      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2017      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2018      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2019      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2020
2021      INTEGER :: istatus(mpi_status_size)
2022      INTEGER :: iflag
2023      !!----------------------------------------------------------------------
2024      !
2025      ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
2026      ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 
2027
2028      ijpj   = 4
2029      ijpjm1 = 3
2030      !
2031      znorthloc(:,:,:) = 0
2032      DO jk = 1, jpk
2033         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2034            ij = jj - nlcj + ijpj
2035            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2036         END DO
2037      END DO
2038      !
2039      !                                     ! Build in procs of ncomm_north the znorthgloio
2040      itaille = jpi * jpk * ijpj
2041
2042      IF ( l_north_nogather ) THEN
2043         !
2044        ztabr(:,:,:) = 0
2045        ztabl(:,:,:) = 0
2046
2047        DO jk = 1, jpk
2048           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2049              ij = jj - nlcj + ijpj
2050              DO ji = nfsloop, nfeloop
2051                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2052              END DO
2053           END DO
2054        END DO
2055
2056         DO jr = 1,nsndto
2057            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2058              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2059            ENDIF
2060         END DO
2061         DO jr = 1,nsndto
2062            iproc = nfipproc(isendto(jr),jpnj)
2063            IF(iproc .ne. -1) THEN
2064               ilei = nleit (iproc+1)
2065               ildi = nldit (iproc+1)
2066               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2067            ENDIF
2068            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2069              CALL mpprecv(5, zfoldwk, itaille, iproc)
2070              DO jk = 1, jpk
2071                 DO jj = 1, ijpj
2072                    DO ji = ildi, ilei
2073                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2074                    END DO
2075                 END DO
2076              END DO
2077           ELSE IF (iproc .eq. (narea-1)) THEN
2078              DO jk = 1, jpk
2079                 DO jj = 1, ijpj
2080                    DO ji = ildi, ilei
2081                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2082                    END DO
2083                 END DO
2084              END DO
2085           ENDIF
2086         END DO
2087         IF (l_isend) THEN
2088            DO jr = 1,nsndto
2089               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2090                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2091               ENDIF   
2092            END DO
2093         ENDIF
2094         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2095         DO jk = 1, jpk
2096            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2097               ij = jj - nlcj + ijpj
2098               DO ji= 1, nlci
2099                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2100               END DO
2101            END DO
2102         END DO
2103         !
2104
2105      ELSE
2106         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2107            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2108         !
2109         ztab(:,:,:) = 0.e0
2110         DO jr = 1, ndim_rank_north         ! recover the global north array
2111            iproc = nrank_north(jr) + 1
2112            ildi  = nldit (iproc)
2113            ilei  = nleit (iproc)
2114            iilb  = nimppt(iproc)
2115            DO jk = 1, jpk
2116               DO jj = 1, ijpj
2117                  DO ji = ildi, ilei
2118                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2119                  END DO
2120               END DO
2121            END DO
2122         END DO
2123         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2124         !
2125         DO jk = 1, jpk
2126            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2127               ij = jj - nlcj + ijpj
2128               DO ji= 1, nlci
2129                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2130               END DO
2131            END DO
2132         END DO
2133         !
2134      ENDIF
2135      !
2136      ! The ztab array has been either:
2137      !  a. Fully populated by the mpi_allgather operation or
2138      !  b. Had the active points for this domain and northern neighbours populated
2139      !     by peer to peer exchanges
2140      ! Either way the array may be folded by lbc_nfd and the result for the span of
2141      ! this domain will be identical.
2142      !
2143      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2144      DEALLOCATE( ztabl, ztabr ) 
2145      !
2146   END SUBROUTINE mpp_lbc_north_3d
2147
2148
2149   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2150      !!---------------------------------------------------------------------
2151      !!                   ***  routine mpp_lbc_north_2d  ***
2152      !!
2153      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2154      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2155      !!
2156      !! ** Method  :   North fold condition and mpp with more than one proc
2157      !!              in i-direction require a specific treatment. We gather
2158      !!              the 4 northern lines of the global domain on 1 processor
2159      !!              and apply lbc north-fold on this sub array. Then we
2160      !!              scatter the north fold array back to the processors.
2161      !!
2162      !!----------------------------------------------------------------------
2163      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2164      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2165      !                                                          !   = T ,  U , V , F or W  gridpoints
2166      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2167      !!                                                             ! =  1. , the sign is kept
2168      INTEGER ::   ji, jj, jr
2169      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2170      INTEGER ::   ijpj, ijpjm1, ij, iproc
2171      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2172      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2173      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2174      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2175      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2176      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2177      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
2178      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2179      INTEGER :: istatus(mpi_status_size)
2180      INTEGER :: iflag
2181      !!----------------------------------------------------------------------
2182      !
2183      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2184      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
2185      !
2186      ijpj   = 4
2187      ijpjm1 = 3
2188      !
2189      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2190         ij = jj - nlcj + ijpj
2191         znorthloc(:,ij) = pt2d(:,jj)
2192      END DO
2193
2194      !                                     ! Build in procs of ncomm_north the znorthgloio
2195      itaille = jpi * ijpj
2196      IF ( l_north_nogather ) THEN
2197         !
2198         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2199         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2200         !
2201         ztabr(:,:) = 0
2202         ztabl(:,:) = 0
2203
2204         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2205            ij = jj - nlcj + ijpj
2206              DO ji = nfsloop, nfeloop
2207               ztabl(ji,ij) = pt2d(ji,jj)
2208            END DO
2209         END DO
2210
2211         DO jr = 1,nsndto
2212            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2213               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
2214            ENDIF
2215         END DO
2216         DO jr = 1,nsndto
2217            iproc = nfipproc(isendto(jr),jpnj)
2218            IF(iproc .ne. -1) THEN
2219               ilei = nleit (iproc+1)
2220               ildi = nldit (iproc+1)
2221               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2222            ENDIF
2223            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2224              CALL mpprecv(5, zfoldwk, itaille, iproc)
2225              DO jj = 1, ijpj
2226                 DO ji = ildi, ilei
2227                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2228                 END DO
2229              END DO
2230            ELSE IF (iproc .eq. (narea-1)) THEN
2231              DO jj = 1, ijpj
2232                 DO ji = ildi, ilei
2233                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2234                 END DO
2235              END DO
2236            ENDIF
2237         END DO
2238         IF (l_isend) THEN
2239            DO jr = 1,nsndto
2240               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2241                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2242               ENDIF
2243            END DO
2244         ENDIF
2245         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2246         !
2247         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2248            ij = jj - nlcj + ijpj
2249            DO ji = 1, nlci
2250               pt2d(ji,jj) = ztabl(ji,ij)
2251            END DO
2252         END DO
2253         !
2254      ELSE
2255         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2256            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2257         !
2258         ztab(:,:) = 0.e0
2259         DO jr = 1, ndim_rank_north            ! recover the global north array
2260            iproc = nrank_north(jr) + 1
2261            ildi = nldit (iproc)
2262            ilei = nleit (iproc)
2263            iilb = nimppt(iproc)
2264            DO jj = 1, ijpj
2265               DO ji = ildi, ilei
2266                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2267               END DO
2268            END DO
2269         END DO
2270         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2271         !
2272         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2273            ij = jj - nlcj + ijpj
2274            DO ji = 1, nlci
2275               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2276            END DO
2277         END DO
2278         !
2279      ENDIF
2280      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2281      DEALLOCATE( ztabl, ztabr ) 
2282      !
2283   END SUBROUTINE mpp_lbc_north_2d
2284
2285
2286   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2287      !!---------------------------------------------------------------------
2288      !!                   ***  routine mpp_lbc_north_2d  ***
2289      !!
2290      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2291      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2292      !!              array with outer extra halo
2293      !!
2294      !! ** Method  :   North fold condition and mpp with more than one proc
2295      !!              in i-direction require a specific treatment. We gather
2296      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2297      !!              processor and apply lbc north-fold on this sub array.
2298      !!              Then we scatter the north fold array back to the processors.
2299      !!
2300      !!----------------------------------------------------------------------
2301      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2302      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2303      !                                                                                         !   = T ,  U , V , F or W -points
2304      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2305      !!                                                                                        ! north fold, =  1. otherwise
2306      INTEGER ::   ji, jj, jr
2307      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2308      INTEGER ::   ijpj, ij, iproc
2309      !
2310      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
2311      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
2312
2313      !!----------------------------------------------------------------------
2314      !
2315      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
2316
2317      !
2318      ijpj=4
2319      ztab_e(:,:) = 0.e0
2320
2321      ij=0
2322      ! put in znorthloc_e the last 4 jlines of pt2d
2323      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2324         ij = ij + 1
2325         DO ji = 1, jpi
2326            znorthloc_e(ji,ij)=pt2d(ji,jj)
2327         END DO
2328      END DO
2329      !
2330      itaille = jpi * ( ijpj + 2 * jpr2dj )
2331      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2332         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2333      !
2334      DO jr = 1, ndim_rank_north            ! recover the global north array
2335         iproc = nrank_north(jr) + 1
2336         ildi = nldit (iproc)
2337         ilei = nleit (iproc)
2338         iilb = nimppt(iproc)
2339         DO jj = 1, ijpj+2*jpr2dj
2340            DO ji = ildi, ilei
2341               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2342            END DO
2343         END DO
2344      END DO
2345
2346
2347      ! 2. North-Fold boundary conditions
2348      ! ----------------------------------
2349      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2350
2351      ij = jpr2dj
2352      !! Scatter back to pt2d
2353      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2354      ij  = ij +1
2355         DO ji= 1, nlci
2356            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2357         END DO
2358      END DO
2359      !
2360      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
2361      !
2362   END SUBROUTINE mpp_lbc_north_e
2363
2364      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
2365      !!----------------------------------------------------------------------
2366      !!                  ***  routine mpp_lnk_bdy_3d  ***
2367      !!
2368      !! ** Purpose :   Message passing management
2369      !!
2370      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2371      !!      between processors following neighboring subdomains.
2372      !!            domain parameters
2373      !!                    nlci   : first dimension of the local subdomain
2374      !!                    nlcj   : second dimension of the local subdomain
2375      !!                    nbondi_bdy : mark for "east-west local boundary"
2376      !!                    nbondj_bdy : mark for "north-south local boundary"
2377      !!                    noea   : number for local neighboring processors
2378      !!                    nowe   : number for local neighboring processors
2379      !!                    noso   : number for local neighboring processors
2380      !!                    nono   : number for local neighboring processors
2381      !!
2382      !! ** Action  :   ptab with update value at its periphery
2383      !!
2384      !!----------------------------------------------------------------------
2385
2386      USE lbcnfd          ! north fold
2387
2388      INCLUDE 'mpif.h'
2389
2390      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2391      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2392      !                                                             ! = T , U , V , F , W points
2393      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2394      !                                                             ! =  1. , the sign is kept
2395      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2396      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
2397      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2398      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2399      REAL(wp) ::   zland
2400      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2401      !
2402      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
2403      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
2404
2405      !!----------------------------------------------------------------------
2406     
2407      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
2408         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
2409
2410      zland = 0.e0
2411
2412      ! 1. standard boundary treatment
2413      ! ------------------------------
2414     
2415      !                                   ! East-West boundaries
2416      !                                        !* Cyclic east-west
2417
2418      IF( nbondi == 2) THEN
2419        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2420          ptab( 1 ,:,:) = ptab(jpim1,:,:)
2421          ptab(jpi,:,:) = ptab(  2  ,:,:)
2422        ELSE
2423          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2424          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2425        ENDIF
2426      ELSEIF(nbondi == -1) THEN
2427        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2428      ELSEIF(nbondi == 1) THEN
2429        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2430      ENDIF                                     !* closed
2431
2432      IF (nbondj == 2 .OR. nbondj == -1) THEN
2433        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
2434      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2435        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
2436      ENDIF
2437     
2438      !
2439
2440      ! 2. East and west directions exchange
2441      ! ------------------------------------
2442      ! we play with the neigbours AND the row number because of the periodicity
2443      !
2444      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2445      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2446         iihom = nlci-nreci
2447         DO jl = 1, jpreci
2448            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
2449            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
2450         END DO
2451      END SELECT
2452      !
2453      !                           ! Migrations
2454      imigr = jpreci * jpj * jpk
2455      !
2456      SELECT CASE ( nbondi_bdy(ib_bdy) )
2457      CASE ( -1 )
2458         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
2459      CASE ( 0 )
2460         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2461         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
2462      CASE ( 1 )
2463         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2464      END SELECT
2465      !
2466      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2467      CASE ( -1 )
2468         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2469      CASE ( 0 )
2470         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2471         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2472      CASE ( 1 )
2473         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2474      END SELECT
2475      !
2476      SELECT CASE ( nbondi_bdy(ib_bdy) )
2477      CASE ( -1 )
2478         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2479      CASE ( 0 )
2480         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2481         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2482      CASE ( 1 )
2483         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2484      END SELECT
2485      !
2486      !                           ! Write Dirichlet lateral conditions
2487      iihom = nlci-jpreci
2488      !
2489      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2490      CASE ( -1 )
2491         DO jl = 1, jpreci
2492            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2493         END DO
2494      CASE ( 0 )
2495         DO jl = 1, jpreci
2496            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2497            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2498         END DO
2499      CASE ( 1 )
2500         DO jl = 1, jpreci
2501            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2502         END DO
2503      END SELECT
2504
2505
2506      ! 3. North and south directions
2507      ! -----------------------------
2508      ! always closed : we play only with the neigbours
2509      !
2510      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
2511         ijhom = nlcj-nrecj
2512         DO jl = 1, jprecj
2513            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
2514            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
2515         END DO
2516      ENDIF
2517      !
2518      !                           ! Migrations
2519      imigr = jprecj * jpi * jpk
2520      !
2521      SELECT CASE ( nbondj_bdy(ib_bdy) )
2522      CASE ( -1 )
2523         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
2524      CASE ( 0 )
2525         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
2526         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
2527      CASE ( 1 )
2528         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
2529      END SELECT
2530      !
2531      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2532      CASE ( -1 )
2533         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
2534      CASE ( 0 )
2535         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
2536         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
2537      CASE ( 1 )
2538         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
2539      END SELECT
2540      !
2541      SELECT CASE ( nbondj_bdy(ib_bdy) )
2542      CASE ( -1 )
2543         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2544      CASE ( 0 )
2545         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2546         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2547      CASE ( 1 )
2548         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2549      END SELECT
2550      !
2551      !                           ! Write Dirichlet lateral conditions
2552      ijhom = nlcj-jprecj
2553      !
2554      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2555      CASE ( -1 )
2556         DO jl = 1, jprecj
2557            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
2558         END DO
2559      CASE ( 0 )
2560         DO jl = 1, jprecj
2561            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
2562            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
2563         END DO
2564      CASE ( 1 )
2565         DO jl = 1, jprecj
2566            ptab(:,jl,:) = zt3sn(:,jl,:,2)
2567         END DO
2568      END SELECT
2569
2570
2571      ! 4. north fold treatment
2572      ! -----------------------
2573      !
2574      IF( npolj /= 0) THEN
2575         !
2576         SELECT CASE ( jpni )
2577         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
2578         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
2579         END SELECT
2580         !
2581      ENDIF
2582      !
2583      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
2584      !
2585   END SUBROUTINE mpp_lnk_bdy_3d
2586
2587      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
2588      !!----------------------------------------------------------------------
2589      !!                  ***  routine mpp_lnk_bdy_2d  ***
2590      !!
2591      !! ** Purpose :   Message passing management
2592      !!
2593      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2594      !!      between processors following neighboring subdomains.
2595      !!            domain parameters
2596      !!                    nlci   : first dimension of the local subdomain
2597      !!                    nlcj   : second dimension of the local subdomain
2598      !!                    nbondi_bdy : mark for "east-west local boundary"
2599      !!                    nbondj_bdy : mark for "north-south local boundary"
2600      !!                    noea   : number for local neighboring processors
2601      !!                    nowe   : number for local neighboring processors
2602      !!                    noso   : number for local neighboring processors
2603      !!                    nono   : number for local neighboring processors
2604      !!
2605      !! ** Action  :   ptab with update value at its periphery
2606      !!
2607      !!----------------------------------------------------------------------
2608
2609      USE lbcnfd          ! north fold
2610
2611      INCLUDE 'mpif.h'
2612
2613      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2614      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2615      !                                                             ! = T , U , V , F , W points
2616      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2617      !                                                             ! =  1. , the sign is kept
2618      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2619      INTEGER  ::   ji, jj, jl             ! dummy loop indices
2620      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2621      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2622      REAL(wp) ::   zland
2623      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2624      !
2625      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
2626      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
2627
2628      !!----------------------------------------------------------------------
2629
2630      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
2631         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
2632
2633      zland = 0.e0
2634
2635      ! 1. standard boundary treatment
2636      ! ------------------------------
2637     
2638      !                                   ! East-West boundaries
2639      !                                        !* Cyclic east-west
2640
2641      IF( nbondi == 2) THEN
2642        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2643          ptab( 1 ,:) = ptab(jpim1,:)
2644          ptab(jpi,:) = ptab(  2  ,:)
2645        ELSE
2646          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
2647          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
2648        ENDIF
2649      ELSEIF(nbondi == -1) THEN
2650        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
2651      ELSEIF(nbondi == 1) THEN
2652        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
2653      ENDIF                                     !* closed
2654
2655      IF (nbondj == 2 .OR. nbondj == -1) THEN
2656        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point
2657      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2658        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north
2659      ENDIF
2660     
2661      !
2662
2663      ! 2. East and west directions exchange
2664      ! ------------------------------------
2665      ! we play with the neigbours AND the row number because of the periodicity
2666      !
2667      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2668      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2669         iihom = nlci-nreci
2670         DO jl = 1, jpreci
2671            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
2672            zt2we(:,jl,1) = ptab(iihom +jl,:)
2673         END DO
2674      END SELECT
2675      !
2676      !                           ! Migrations
2677      imigr = jpreci * jpj
2678      !
2679      SELECT CASE ( nbondi_bdy(ib_bdy) )
2680      CASE ( -1 )
2681         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
2682      CASE ( 0 )
2683         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
2684         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
2685      CASE ( 1 )
2686         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
2687      END SELECT
2688      !
2689      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2690      CASE ( -1 )
2691         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
2692      CASE ( 0 )
2693         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
2694         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
2695      CASE ( 1 )
2696         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
2697      END SELECT
2698      !
2699      SELECT CASE ( nbondi_bdy(ib_bdy) )
2700      CASE ( -1 )
2701         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2702      CASE ( 0 )
2703         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2704         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2705      CASE ( 1 )
2706         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2707      END SELECT
2708      !
2709      !                           ! Write Dirichlet lateral conditions
2710      iihom = nlci-jpreci
2711      !
2712      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2713      CASE ( -1 )
2714         DO jl = 1, jpreci
2715            ptab(iihom+jl,:) = zt2ew(:,jl,2)
2716         END DO
2717      CASE ( 0 )
2718         DO jl = 1, jpreci
2719            ptab(jl      ,:) = zt2we(:,jl,2)
2720            ptab(iihom+jl,:) = zt2ew(:,jl,2)
2721         END DO
2722      CASE ( 1 )
2723         DO jl = 1, jpreci
2724            ptab(jl      ,:) = zt2we(:,jl,2)
2725         END DO
2726      END SELECT
2727
2728
2729      ! 3. North and south directions
2730      ! -----------------------------
2731      ! always closed : we play only with the neigbours
2732      !
2733      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
2734         ijhom = nlcj-nrecj
2735         DO jl = 1, jprecj
2736            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
2737            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
2738         END DO
2739      ENDIF
2740      !
2741      !                           ! Migrations
2742      imigr = jprecj * jpi
2743      !
2744      SELECT CASE ( nbondj_bdy(ib_bdy) )
2745      CASE ( -1 )
2746         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
2747      CASE ( 0 )
2748         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
2749         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
2750      CASE ( 1 )
2751         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
2752      END SELECT
2753      !
2754      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2755      CASE ( -1 )
2756         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
2757      CASE ( 0 )
2758         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
2759         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
2760      CASE ( 1 )
2761         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
2762      END SELECT
2763      !
2764      SELECT CASE ( nbondj_bdy(ib_bdy) )
2765      CASE ( -1 )
2766         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2767      CASE ( 0 )
2768         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2769         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2770      CASE ( 1 )
2771         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2772      END SELECT
2773      !
2774      !                           ! Write Dirichlet lateral conditions
2775      ijhom = nlcj-jprecj
2776      !
2777      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2778      CASE ( -1 )
2779         DO jl = 1, jprecj
2780            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
2781         END DO
2782      CASE ( 0 )
2783         DO jl = 1, jprecj
2784            ptab(:,jl      ) = zt2sn(:,jl,2)
2785            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
2786         END DO
2787      CASE ( 1 )
2788         DO jl = 1, jprecj
2789            ptab(:,jl) = zt2sn(:,jl,2)
2790         END DO
2791      END SELECT
2792
2793
2794      ! 4. north fold treatment
2795      ! -----------------------
2796      !
2797      IF( npolj /= 0) THEN
2798         !
2799         SELECT CASE ( jpni )
2800         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
2801         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
2802         END SELECT
2803         !
2804      ENDIF
2805      !
2806      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
2807      !
2808   END SUBROUTINE mpp_lnk_bdy_2d
2809
2810   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
2811      !!---------------------------------------------------------------------
2812      !!                   ***  routine mpp_init.opa  ***
2813      !!
2814      !! ** Purpose :: export and attach a MPI buffer for bsend
2815      !!
2816      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
2817      !!            but classical mpi_init
2818      !!
2819      !! History :: 01/11 :: IDRIS initial version for IBM only
2820      !!            08/04 :: R. Benshila, generalisation
2821      !!---------------------------------------------------------------------
2822      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
2823      INTEGER                      , INTENT(inout) ::   ksft
2824      INTEGER                      , INTENT(  out) ::   code
2825      INTEGER                                      ::   ierr, ji
2826      LOGICAL                                      ::   mpi_was_called
2827      !!---------------------------------------------------------------------
2828      !
2829      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
2830      IF ( code /= MPI_SUCCESS ) THEN
2831         DO ji = 1, SIZE(ldtxt)
2832            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2833         END DO
2834         WRITE(*, cform_err)
2835         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
2836         CALL mpi_abort( mpi_comm_world, code, ierr )
2837      ENDIF
2838      !
2839      IF( .NOT. mpi_was_called ) THEN
2840         CALL mpi_init( code )
2841         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2842         IF ( code /= MPI_SUCCESS ) THEN
2843            DO ji = 1, SIZE(ldtxt)
2844               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2845            END DO
2846            WRITE(*, cform_err)
2847            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
2848            CALL mpi_abort( mpi_comm_world, code, ierr )
2849         ENDIF
2850      ENDIF
2851      !
2852      IF( nn_buffer > 0 ) THEN
2853         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
2854         ! Buffer allocation and attachment
2855         ALLOCATE( tampon(nn_buffer), stat = ierr )
2856         IF( ierr /= 0 ) THEN
2857            DO ji = 1, SIZE(ldtxt)
2858               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
2859            END DO
2860            WRITE(*, cform_err)
2861            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
2862            CALL mpi_abort( mpi_comm_world, code, ierr )
2863         END IF
2864         CALL mpi_buffer_attach( tampon, nn_buffer, code )
2865      ENDIF
2866      !
2867   END SUBROUTINE mpi_init_opa
2868
2869   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
2870      !!---------------------------------------------------------------------
2871      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
2872      !!
2873      !!   Modification of original codes written by David H. Bailey
2874      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
2875      !!---------------------------------------------------------------------
2876      INTEGER, INTENT(in)                         :: ilen, itype
2877      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
2878      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
2879      !
2880      REAL(wp) :: zerr, zt1, zt2    ! local work variables
2881      INTEGER :: ji, ztmp           ! local scalar
2882
2883      ztmp = itype   ! avoid compilation warning
2884
2885      DO ji=1,ilen
2886      ! Compute ydda + yddb using Knuth's trick.
2887         zt1  = real(ydda(ji)) + real(yddb(ji))
2888         zerr = zt1 - real(ydda(ji))
2889         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
2890                + aimag(ydda(ji)) + aimag(yddb(ji))
2891
2892         ! The result is zt1 + zt2, after normalization.
2893         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
2894      END DO
2895
2896   END SUBROUTINE DDPDD_MPI
2897
2898   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
2899      !!---------------------------------------------------------------------
2900      !!                   ***  routine mpp_lbc_north_icb  ***
2901      !!
2902      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2903      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2904      !!              array with outer extra halo
2905      !!
2906      !! ** Method  :   North fold condition and mpp with more than one proc
2907      !!              in i-direction require a specific treatment. We gather
2908      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2909      !!              processor and apply lbc north-fold on this sub array.
2910      !!              Then we scatter the north fold array back to the processors.
2911      !!              This version accounts for an extra halo with icebergs.
2912      !!
2913      !!----------------------------------------------------------------------
2914      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2915      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2916      !                                                     !   = T ,  U , V , F or W -points
2917      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2918      !!                                                    ! north fold, =  1. otherwise
2919      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
2920      INTEGER ::   ji, jj, jr
2921      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2922      INTEGER ::   ijpj, ij, iproc, ipr2dj
2923      !
2924      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
2925      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
2926
2927      !!----------------------------------------------------------------------
2928      !
2929      ijpj=4
2930      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
2931         ipr2dj = pr2dj
2932      ELSE
2933         ipr2dj = 0
2934      ENDIF
2935      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
2936
2937      !
2938      ztab_e(:,:) = 0.e0
2939
2940      ij=0
2941      ! put in znorthloc_e the last 4 jlines of pt2d
2942      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
2943         ij = ij + 1
2944         DO ji = 1, jpi
2945            znorthloc_e(ji,ij)=pt2d(ji,jj)
2946         END DO
2947      END DO
2948      !
2949      itaille = jpi * ( ijpj + 2 * ipr2dj )
2950      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2951         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2952      !
2953      DO jr = 1, ndim_rank_north            ! recover the global north array
2954         iproc = nrank_north(jr) + 1
2955         ildi = nldit (iproc)
2956         ilei = nleit (iproc)
2957         iilb = nimppt(iproc)
2958         DO jj = 1, ijpj+2*ipr2dj
2959            DO ji = ildi, ilei
2960               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2961            END DO
2962         END DO
2963      END DO
2964
2965
2966      ! 2. North-Fold boundary conditions
2967      ! ----------------------------------
2968      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
2969
2970      ij = ipr2dj
2971      !! Scatter back to pt2d
2972      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
2973      ij  = ij +1
2974         DO ji= 1, nlci
2975            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2976         END DO
2977      END DO
2978      !
2979      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
2980      !
2981   END SUBROUTINE mpp_lbc_north_icb
2982
2983   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
2984      !!----------------------------------------------------------------------
2985      !!                  ***  routine mpp_lnk_2d_icb  ***
2986      !!
2987      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
2988      !!
2989      !! ** Method  :   Use mppsend and mpprecv function for passing mask
2990      !!      between processors following neighboring subdomains.
2991      !!            domain parameters
2992      !!                    nlci   : first dimension of the local subdomain
2993      !!                    nlcj   : second dimension of the local subdomain
2994      !!                    jpri   : number of rows for extra outer halo
2995      !!                    jprj   : number of columns for extra outer halo
2996      !!                    nbondi : mark for "east-west local boundary"
2997      !!                    nbondj : mark for "north-south local boundary"
2998      !!                    noea   : number for local neighboring processors
2999      !!                    nowe   : number for local neighboring processors
3000      !!                    noso   : number for local neighboring processors
3001      !!                    nono   : number for local neighboring processors
3002      !!
3003      !!----------------------------------------------------------------------
3004      INTEGER                                             , INTENT(in   ) ::   jpri
3005      INTEGER                                             , INTENT(in   ) ::   jprj
3006      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3007      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3008      !                                                                                 ! = T , U , V , F , W and I points
3009      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
3010      !!                                                                                ! north boundary, =  1. otherwise
3011      INTEGER  ::   jl   ! dummy loop indices
3012      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3013      INTEGER  ::   ipreci, iprecj             ! temporary integers
3014      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3015      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3016      !!
3017      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3018      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3019      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3020      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3021      !!----------------------------------------------------------------------
3022
3023      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3024      iprecj = jprecj + jprj
3025
3026
3027      ! 1. standard boundary treatment
3028      ! ------------------------------
3029      ! Order matters Here !!!!
3030      !
3031      !                                      ! East-West boundaries
3032      !                                           !* Cyclic east-west
3033      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3034         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3035         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3036         !
3037      ELSE                                        !* closed
3038         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
3039                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
3040      ENDIF
3041      !
3042
3043      ! north fold treatment
3044      ! -----------------------
3045      IF( npolj /= 0 ) THEN
3046         !
3047         SELECT CASE ( jpni )
3048         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3049         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3050         END SELECT
3051         !
3052      ENDIF
3053
3054      ! 2. East and west directions exchange
3055      ! ------------------------------------
3056      ! we play with the neigbours AND the row number because of the periodicity
3057      !
3058      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3059      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3060         iihom = nlci-nreci-jpri
3061         DO jl = 1, ipreci
3062            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3063            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3064         END DO
3065      END SELECT
3066      !
3067      !                           ! Migrations
3068      imigr = ipreci * ( jpj + 2*jprj)
3069      !
3070      SELECT CASE ( nbondi )
3071      CASE ( -1 )
3072         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3073         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3074         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3075      CASE ( 0 )
3076         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3077         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3078         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3079         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3080         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3081         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3082      CASE ( 1 )
3083         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3084         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3085         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3086      END SELECT
3087      !
3088      !                           ! Write Dirichlet lateral conditions
3089      iihom = nlci - jpreci
3090      !
3091      SELECT CASE ( nbondi )
3092      CASE ( -1 )
3093         DO jl = 1, ipreci
3094            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3095         END DO
3096      CASE ( 0 )
3097         DO jl = 1, ipreci
3098            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3099            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3100         END DO
3101      CASE ( 1 )
3102         DO jl = 1, ipreci
3103            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3104         END DO
3105      END SELECT
3106
3107
3108      ! 3. North and south directions
3109      ! -----------------------------
3110      ! always closed : we play only with the neigbours
3111      !
3112      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3113         ijhom = nlcj-nrecj-jprj
3114         DO jl = 1, iprecj
3115            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3116            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3117         END DO
3118      ENDIF
3119      !
3120      !                           ! Migrations
3121      imigr = iprecj * ( jpi + 2*jpri )
3122      !
3123      SELECT CASE ( nbondj )
3124      CASE ( -1 )
3125         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3126         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3127         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3128      CASE ( 0 )
3129         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3130         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3131         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3132         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3133         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3134         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3135      CASE ( 1 )
3136         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3137         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3138         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3139      END SELECT
3140      !
3141      !                           ! Write Dirichlet lateral conditions
3142      ijhom = nlcj - jprecj
3143      !
3144      SELECT CASE ( nbondj )
3145      CASE ( -1 )
3146         DO jl = 1, iprecj
3147            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3148         END DO
3149      CASE ( 0 )
3150         DO jl = 1, iprecj
3151            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3152            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3153         END DO
3154      CASE ( 1 )
3155         DO jl = 1, iprecj
3156            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3157         END DO
3158      END SELECT
3159
3160   END SUBROUTINE mpp_lnk_2d_icb
3161#else
3162   !!----------------------------------------------------------------------
3163   !!   Default case:            Dummy module        share memory computing
3164   !!----------------------------------------------------------------------
3165   USE in_out_manager
3166
3167   INTERFACE mpp_sum
3168      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3169   END INTERFACE
3170   INTERFACE mpp_max
3171      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3172   END INTERFACE
3173   INTERFACE mpp_min
3174      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3175   END INTERFACE
3176   INTERFACE mpp_minloc
3177      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3178   END INTERFACE
3179   INTERFACE mpp_maxloc
3180      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3181   END INTERFACE
3182
3183   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
3184   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3185   INTEGER :: ncomm_ice
3186   !!----------------------------------------------------------------------
3187CONTAINS
3188
3189   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
3190      INTEGER, INTENT(in) ::   kumout
3191      lib_mpp_alloc = 0
3192   END FUNCTION lib_mpp_alloc
3193
3194   FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
3195      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
3196      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
3197      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
3198      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
3199      IF( .FALSE. )   ldtxt(:) = 'never done'
3200      CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
3201   END FUNCTION mynode
3202
3203   SUBROUTINE mppsync                       ! Dummy routine
3204   END SUBROUTINE mppsync
3205
3206   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
3207      REAL   , DIMENSION(:) :: parr
3208      INTEGER               :: kdim
3209      INTEGER, OPTIONAL     :: kcom
3210      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
3211   END SUBROUTINE mpp_sum_as
3212
3213   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
3214      REAL   , DIMENSION(:,:) :: parr
3215      INTEGER               :: kdim
3216      INTEGER, OPTIONAL     :: kcom
3217      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
3218   END SUBROUTINE mpp_sum_a2s
3219
3220   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
3221      INTEGER, DIMENSION(:) :: karr
3222      INTEGER               :: kdim
3223      INTEGER, OPTIONAL     :: kcom
3224      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
3225   END SUBROUTINE mpp_sum_ai
3226
3227   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
3228      REAL                  :: psca
3229      INTEGER, OPTIONAL     :: kcom
3230      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
3231   END SUBROUTINE mpp_sum_s
3232
3233   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
3234      integer               :: kint
3235      INTEGER, OPTIONAL     :: kcom
3236      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
3237   END SUBROUTINE mpp_sum_i
3238
3239   SUBROUTINE mppsum_realdd( ytab, kcom )
3240      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
3241      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3242      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
3243   END SUBROUTINE mppsum_realdd
3244
3245   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
3246      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
3247      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
3248      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3249      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
3250   END SUBROUTINE mppsum_a_realdd
3251
3252   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
3253      REAL   , DIMENSION(:) :: parr
3254      INTEGER               :: kdim
3255      INTEGER, OPTIONAL     :: kcom
3256      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3257   END SUBROUTINE mppmax_a_real
3258
3259   SUBROUTINE mppmax_real( psca, kcom )
3260      REAL                  :: psca
3261      INTEGER, OPTIONAL     :: kcom
3262      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
3263   END SUBROUTINE mppmax_real
3264
3265   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
3266      REAL   , DIMENSION(:) :: parr
3267      INTEGER               :: kdim
3268      INTEGER, OPTIONAL     :: kcom
3269      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3270   END SUBROUTINE mppmin_a_real
3271
3272   SUBROUTINE mppmin_real( psca, kcom )
3273      REAL                  :: psca
3274      INTEGER, OPTIONAL     :: kcom
3275      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
3276   END SUBROUTINE mppmin_real
3277
3278   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
3279      INTEGER, DIMENSION(:) :: karr
3280      INTEGER               :: kdim
3281      INTEGER, OPTIONAL     :: kcom
3282      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3283   END SUBROUTINE mppmax_a_int
3284
3285   SUBROUTINE mppmax_int( kint, kcom)
3286      INTEGER               :: kint
3287      INTEGER, OPTIONAL     :: kcom
3288      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
3289   END SUBROUTINE mppmax_int
3290
3291   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
3292      INTEGER, DIMENSION(:) :: karr
3293      INTEGER               :: kdim
3294      INTEGER, OPTIONAL     :: kcom
3295      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3296   END SUBROUTINE mppmin_a_int
3297
3298   SUBROUTINE mppmin_int( kint, kcom )
3299      INTEGER               :: kint
3300      INTEGER, OPTIONAL     :: kcom
3301      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
3302   END SUBROUTINE mppmin_int
3303
3304   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
3305      REAL                   :: pmin
3306      REAL , DIMENSION (:,:) :: ptab, pmask
3307      INTEGER :: ki, kj
3308      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
3309   END SUBROUTINE mpp_minloc2d
3310
3311   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
3312      REAL                     :: pmin
3313      REAL , DIMENSION (:,:,:) :: ptab, pmask
3314      INTEGER :: ki, kj, kk
3315      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3316   END SUBROUTINE mpp_minloc3d
3317
3318   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
3319      REAL                   :: pmax
3320      REAL , DIMENSION (:,:) :: ptab, pmask
3321      INTEGER :: ki, kj
3322      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
3323   END SUBROUTINE mpp_maxloc2d
3324
3325   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
3326      REAL                     :: pmax
3327      REAL , DIMENSION (:,:,:) :: ptab, pmask
3328      INTEGER :: ki, kj, kk
3329      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3330   END SUBROUTINE mpp_maxloc3d
3331
3332   SUBROUTINE mppstop
3333      STOP      ! non MPP case, just stop the run
3334   END SUBROUTINE mppstop
3335
3336   SUBROUTINE mpp_ini_ice( kcom, knum )
3337      INTEGER :: kcom, knum
3338      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
3339   END SUBROUTINE mpp_ini_ice
3340
3341   SUBROUTINE mpp_ini_znl( knum )
3342      INTEGER :: knum
3343      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
3344   END SUBROUTINE mpp_ini_znl
3345
3346   SUBROUTINE mpp_comm_free( kcom )
3347      INTEGER :: kcom
3348      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
3349   END SUBROUTINE mpp_comm_free
3350#endif
3351
3352   !!----------------------------------------------------------------------
3353   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
3354   !!----------------------------------------------------------------------
3355
3356   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
3357      &                 cd6, cd7, cd8, cd9, cd10 )
3358      !!----------------------------------------------------------------------
3359      !!                  ***  ROUTINE  stop_opa  ***
3360      !!
3361      !! ** Purpose :   print in ocean.outpput file a error message and
3362      !!                increment the error number (nstop) by one.
3363      !!----------------------------------------------------------------------
3364      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3365      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3366      !!----------------------------------------------------------------------
3367      !
3368      nstop = nstop + 1
3369      IF(lwp) THEN
3370         WRITE(numout,cform_err)
3371         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
3372         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
3373         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
3374         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
3375         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
3376         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
3377         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
3378         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
3379         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
3380         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
3381      ENDIF
3382                               CALL FLUSH(numout    )
3383      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
3384      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
3385      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
3386      !
3387      IF( cd1 == 'STOP' ) THEN
3388         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
3389         CALL mppstop()
3390      ENDIF
3391      !
3392   END SUBROUTINE ctl_stop
3393
3394
3395   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
3396      &                 cd6, cd7, cd8, cd9, cd10 )
3397      !!----------------------------------------------------------------------
3398      !!                  ***  ROUTINE  stop_warn  ***
3399      !!
3400      !! ** Purpose :   print in ocean.outpput file a error message and
3401      !!                increment the warning number (nwarn) by one.
3402      !!----------------------------------------------------------------------
3403      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3404      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3405      !!----------------------------------------------------------------------
3406      !
3407      nwarn = nwarn + 1
3408      IF(lwp) THEN
3409         WRITE(numout,cform_war)
3410         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
3411         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
3412         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
3413         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
3414         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
3415         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
3416         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
3417         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
3418         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
3419         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
3420      ENDIF
3421      CALL FLUSH(numout)
3422      !
3423   END SUBROUTINE ctl_warn
3424
3425
3426   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
3427      !!----------------------------------------------------------------------
3428      !!                  ***  ROUTINE ctl_opn  ***
3429      !!
3430      !! ** Purpose :   Open file and check if required file is available.
3431      !!
3432      !! ** Method  :   Fortan open
3433      !!----------------------------------------------------------------------
3434      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
3435      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
3436      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
3437      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
3438      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
3439      INTEGER          , INTENT(in   ) ::   klengh    ! record length
3440      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
3441      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3442      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
3443      !!
3444      CHARACTER(len=80) ::   clfile
3445      INTEGER           ::   iost
3446      !!----------------------------------------------------------------------
3447
3448      ! adapt filename
3449      ! ----------------
3450      clfile = TRIM(cdfile)
3451      IF( PRESENT( karea ) ) THEN
3452         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
3453      ENDIF
3454#if defined key_agrif
3455      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
3456      knum=Agrif_Get_Unit()
3457#else
3458      knum=get_unit()
3459#endif
3460
3461      iost=0
3462      IF( cdacce(1:6) == 'DIRECT' )  THEN
3463         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
3464      ELSE
3465         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
3466      ENDIF
3467      IF( iost == 0 ) THEN
3468         IF(ldwp) THEN
3469            WRITE(kout,*) '     file   : ', clfile,' open ok'
3470            WRITE(kout,*) '     unit   = ', knum
3471            WRITE(kout,*) '     status = ', cdstat
3472            WRITE(kout,*) '     form   = ', cdform
3473            WRITE(kout,*) '     access = ', cdacce
3474            WRITE(kout,*)
3475         ENDIF
3476      ENDIF
3477100   CONTINUE
3478      IF( iost /= 0 ) THEN
3479         IF(ldwp) THEN
3480            WRITE(kout,*)
3481            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
3482            WRITE(kout,*) ' =======   ===  '
3483            WRITE(kout,*) '           unit   = ', knum
3484            WRITE(kout,*) '           status = ', cdstat
3485            WRITE(kout,*) '           form   = ', cdform
3486            WRITE(kout,*) '           access = ', cdacce
3487            WRITE(kout,*) '           iostat = ', iost
3488            WRITE(kout,*) '           we stop. verify the file '
3489            WRITE(kout,*)
3490         ENDIF
3491         STOP 'ctl_opn bad opening'
3492      ENDIF
3493
3494   END SUBROUTINE ctl_opn
3495
3496   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
3497      !!----------------------------------------------------------------------
3498      !!                  ***  ROUTINE ctl_nam  ***
3499      !!
3500      !! ** Purpose :   Informations when error while reading a namelist
3501      !!
3502      !! ** Method  :   Fortan open
3503      !!----------------------------------------------------------------------
3504      INTEGER          , INTENT(inout) ::   kios      ! IO status after reading the namelist
3505      CHARACTER(len=*) , INTENT(in   ) ::   cdnam     ! group name of namelist for which error occurs
3506      CHARACTER(len=4)                 ::   clios     ! string to convert iostat in character for print
3507      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3508      !!----------------------------------------------------------------------
3509
3510      !
3511      ! ----------------
3512      WRITE (clios, '(I4.0)') kios
3513      IF( kios < 0 ) THEN         
3514         CALL ctl_warn( 'W A R N I N G:  end of record or file while reading namelist ' &
3515 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
3516      ENDIF
3517
3518      IF( kios > 0 ) THEN
3519         CALL ctl_stop( 'E R R O R :   misspelled variable in namelist ' &
3520 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
3521      ENDIF
3522      kios = 0
3523      RETURN
3524     
3525   END SUBROUTINE ctl_nam
3526
3527   INTEGER FUNCTION get_unit()
3528      !!----------------------------------------------------------------------
3529      !!                  ***  FUNCTION  get_unit  ***
3530      !!
3531      !! ** Purpose :   return the index of an unused logical unit
3532      !!----------------------------------------------------------------------
3533      LOGICAL :: llopn
3534      !!----------------------------------------------------------------------
3535      !
3536      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
3537      llopn = .TRUE.
3538      DO WHILE( (get_unit < 998) .AND. llopn )
3539         get_unit = get_unit + 1
3540         INQUIRE( unit = get_unit, opened = llopn )
3541      END DO
3542      IF( (get_unit == 999) .AND. llopn ) THEN
3543         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
3544         get_unit = -1
3545      ENDIF
3546      !
3547   END FUNCTION get_unit
3548
3549   !!----------------------------------------------------------------------
3550END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.