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

source: branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6748

Last change on this file since 6748 was 6748, checked in by mocavero, 8 years ago

GYRE hybrid parallelization

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