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

source: branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7806

Last change on this file since 7806 was 7806, checked in by cbricaud, 7 years ago

phaze dev_r5003_MERCATOR6_CRS branch with rev7805 of 3.6_stable branch

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