source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4314

Last change on this file since 4314 was 4314, checked in by cetlod, 7 years ago

v3.6_alpha : fix to compile without FPP key key_mpp_mpi, see ticket #1188

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