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

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

source: branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4785

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

dev_r4765_CNRS_agrif: First update of AGRIF for dynamic only (_flt and _ts), see ticket #1380 and associated wiki page

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