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

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

source: branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6808

Last change on this file since 6808 was 6808, checked in by jamesharle, 8 years ago

merge with trunk@6232 for consistency with SSB code

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