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/2016/dev_r6711_SIMPLIF_6_aerobulk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2016/dev_r6711_SIMPLIF_6_aerobulk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7163

Last change on this file since 7163 was 7163, checked in by gm, 7 years ago

#1751 - branch SIMPLIF_6_aerobulk: update option control in sbcmod + uniformization of print in ocean_output (many module involved)

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