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/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4162

Last change on this file since 4162 was 4162, checked in by cetlod, 10 years ago

dev_LOCEAN_2013 : merge in trunk changes between r4028 and r4119, see ticket #1169

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