source: branches/UKMO/dev_r5518_GO6_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8356

Last change on this file since 8356 was 8356, checked in by davestorkey, 3 years ago

UKMO/dev_r5518_GO6_package branch: merge in changes from rev 6917 to 6959 of the 3.6_stable branch.

File size: 173.6 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
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
1496   SUBROUTINE mppscatter( pio, kp, ptab )
1497      !!----------------------------------------------------------------------
1498      !!                  ***  routine mppscatter  ***
1499      !!
1500      !! ** Purpose :   Transfert between awork array which is distributed
1501      !!      following the vertical level and the local subdomain array.
1502      !!
1503      !!----------------------------------------------------------------------
1504      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1505      INTEGER                             ::   kp        ! Tag (not used with MPI
1506      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1507      !!
1508      INTEGER :: itaille, ierror   ! temporary integer
1509      !!---------------------------------------------------------------------
1510      !
1511      itaille=jpi*jpj
1512      !
1513      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1514         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1515      !
1516   END SUBROUTINE mppscatter
1517
1518
1519   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1520      !!----------------------------------------------------------------------
1521      !!                  ***  routine mppmax_a_int  ***
1522      !!
1523      !! ** Purpose :   Find maximum value in an integer layout array
1524      !!
1525      !!----------------------------------------------------------------------
1526      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1527      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1528      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1529      !!
1530      INTEGER :: ierror, localcomm   ! temporary integer
1531      INTEGER, DIMENSION(kdim) ::   iwork
1532      !!----------------------------------------------------------------------
1533      !
1534      localcomm = mpi_comm_opa
1535      IF( PRESENT(kcom) )   localcomm = kcom
1536      !
1537      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1538      !
1539      ktab(:) = iwork(:)
1540      !
1541   END SUBROUTINE mppmax_a_int
1542
1543
1544   SUBROUTINE mppmax_int( ktab, kcom )
1545      !!----------------------------------------------------------------------
1546      !!                  ***  routine mppmax_int  ***
1547      !!
1548      !! ** Purpose :   Find maximum value in an integer layout array
1549      !!
1550      !!----------------------------------------------------------------------
1551      INTEGER, INTENT(inout)           ::   ktab      ! ???
1552      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1553      !!
1554      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1555      !!----------------------------------------------------------------------
1556      !
1557      localcomm = mpi_comm_opa
1558      IF( PRESENT(kcom) )   localcomm = kcom
1559      !
1560      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1561      !
1562      ktab = iwork
1563      !
1564   END SUBROUTINE mppmax_int
1565
1566
1567   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1568      !!----------------------------------------------------------------------
1569      !!                  ***  routine mppmin_a_int  ***
1570      !!
1571      !! ** Purpose :   Find minimum value in an integer layout array
1572      !!
1573      !!----------------------------------------------------------------------
1574      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1575      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1576      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1577      !!
1578      INTEGER ::   ierror, localcomm   ! temporary integer
1579      INTEGER, DIMENSION(kdim) ::   iwork
1580      !!----------------------------------------------------------------------
1581      !
1582      localcomm = mpi_comm_opa
1583      IF( PRESENT(kcom) )   localcomm = kcom
1584      !
1585      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1586      !
1587      ktab(:) = iwork(:)
1588      !
1589   END SUBROUTINE mppmin_a_int
1590
1591
1592   SUBROUTINE mppmin_int( ktab, kcom )
1593      !!----------------------------------------------------------------------
1594      !!                  ***  routine mppmin_int  ***
1595      !!
1596      !! ** Purpose :   Find minimum value in an integer layout array
1597      !!
1598      !!----------------------------------------------------------------------
1599      INTEGER, INTENT(inout) ::   ktab      ! ???
1600      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1601      !!
1602      INTEGER ::  ierror, iwork, localcomm
1603      !!----------------------------------------------------------------------
1604      !
1605      localcomm = mpi_comm_opa
1606      IF( PRESENT(kcom) )   localcomm = kcom
1607      !
1608     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1609      !
1610      ktab = iwork
1611      !
1612   END SUBROUTINE mppmin_int
1613
1614
1615   SUBROUTINE mppsum_a_int( ktab, kdim )
1616      !!----------------------------------------------------------------------
1617      !!                  ***  routine mppsum_a_int  ***
1618      !!
1619      !! ** Purpose :   Global integer sum, 1D array case
1620      !!
1621      !!----------------------------------------------------------------------
1622      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1623      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1624      !!
1625      INTEGER :: ierror
1626      INTEGER, DIMENSION (kdim) ::  iwork
1627      !!----------------------------------------------------------------------
1628      !
1629      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1630      !
1631      ktab(:) = iwork(:)
1632      !
1633   END SUBROUTINE mppsum_a_int
1634
1635
1636   SUBROUTINE mppsum_int( ktab )
1637      !!----------------------------------------------------------------------
1638      !!                 ***  routine mppsum_int  ***
1639      !!
1640      !! ** Purpose :   Global integer sum
1641      !!
1642      !!----------------------------------------------------------------------
1643      INTEGER, INTENT(inout) ::   ktab
1644      !!
1645      INTEGER :: ierror, iwork
1646      !!----------------------------------------------------------------------
1647      !
1648      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1649      !
1650      ktab = iwork
1651      !
1652   END SUBROUTINE mppsum_int
1653
1654
1655   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1656      !!----------------------------------------------------------------------
1657      !!                 ***  routine mppmax_a_real  ***
1658      !!
1659      !! ** Purpose :   Maximum
1660      !!
1661      !!----------------------------------------------------------------------
1662      INTEGER , INTENT(in   )                  ::   kdim
1663      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1664      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1665      !!
1666      INTEGER :: ierror, localcomm
1667      REAL(wp), DIMENSION(kdim) ::  zwork
1668      !!----------------------------------------------------------------------
1669      !
1670      localcomm = mpi_comm_opa
1671      IF( PRESENT(kcom) ) localcomm = kcom
1672      !
1673      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1674      ptab(:) = zwork(:)
1675      !
1676   END SUBROUTINE mppmax_a_real
1677
1678
1679   SUBROUTINE mppmax_real( ptab, kcom )
1680      !!----------------------------------------------------------------------
1681      !!                  ***  routine mppmax_real  ***
1682      !!
1683      !! ** Purpose :   Maximum
1684      !!
1685      !!----------------------------------------------------------------------
1686      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1687      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1688      !!
1689      INTEGER  ::   ierror, localcomm
1690      REAL(wp) ::   zwork
1691      !!----------------------------------------------------------------------
1692      !
1693      localcomm = mpi_comm_opa
1694      IF( PRESENT(kcom) )   localcomm = kcom
1695      !
1696      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1697      ptab = zwork
1698      !
1699   END SUBROUTINE mppmax_real
1700
1701   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  )
1702      !!----------------------------------------------------------------------
1703      !!                  ***  routine mppmax_real  ***
1704      !!
1705      !! ** Purpose :   Maximum
1706      !!
1707      !!----------------------------------------------------------------------
1708      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ???
1709      INTEGER , INTENT(in   )           ::   NUM
1710      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1711      !!
1712      INTEGER  ::   ierror, localcomm
1713      REAL(wp) , POINTER , DIMENSION(:) ::   zwork
1714      !!----------------------------------------------------------------------
1715      !
1716      CALL wrk_alloc(NUM , zwork)
1717      localcomm = mpi_comm_opa
1718      IF( PRESENT(kcom) )   localcomm = kcom
1719      !
1720      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror )
1721      ptab = zwork
1722      CALL wrk_dealloc(NUM , zwork)
1723      !
1724   END SUBROUTINE mppmax_real_multiple
1725
1726
1727   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1728      !!----------------------------------------------------------------------
1729      !!                 ***  routine mppmin_a_real  ***
1730      !!
1731      !! ** Purpose :   Minimum of REAL, array case
1732      !!
1733      !!-----------------------------------------------------------------------
1734      INTEGER , INTENT(in   )                  ::   kdim
1735      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1736      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1737      !!
1738      INTEGER :: ierror, localcomm
1739      REAL(wp), DIMENSION(kdim) ::   zwork
1740      !!-----------------------------------------------------------------------
1741      !
1742      localcomm = mpi_comm_opa
1743      IF( PRESENT(kcom) ) localcomm = kcom
1744      !
1745      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1746      ptab(:) = zwork(:)
1747      !
1748   END SUBROUTINE mppmin_a_real
1749
1750
1751   SUBROUTINE mppmin_real( ptab, kcom )
1752      !!----------------------------------------------------------------------
1753      !!                  ***  routine mppmin_real  ***
1754      !!
1755      !! ** Purpose :   minimum of REAL, scalar case
1756      !!
1757      !!-----------------------------------------------------------------------
1758      REAL(wp), INTENT(inout)           ::   ptab        !
1759      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1760      !!
1761      INTEGER  ::   ierror
1762      REAL(wp) ::   zwork
1763      INTEGER :: localcomm
1764      !!-----------------------------------------------------------------------
1765      !
1766      localcomm = mpi_comm_opa
1767      IF( PRESENT(kcom) )   localcomm = kcom
1768      !
1769      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1770      ptab = zwork
1771      !
1772   END SUBROUTINE mppmin_real
1773
1774
1775   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1776      !!----------------------------------------------------------------------
1777      !!                  ***  routine mppsum_a_real  ***
1778      !!
1779      !! ** Purpose :   global sum, REAL ARRAY argument case
1780      !!
1781      !!-----------------------------------------------------------------------
1782      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1783      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1784      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1785      !!
1786      INTEGER                   ::   ierror    ! temporary integer
1787      INTEGER                   ::   localcomm
1788      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1789      !!-----------------------------------------------------------------------
1790      !
1791      localcomm = mpi_comm_opa
1792      IF( PRESENT(kcom) )   localcomm = kcom
1793      !
1794      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1795      ptab(:) = zwork(:)
1796      !
1797   END SUBROUTINE mppsum_a_real
1798
1799
1800   SUBROUTINE mppsum_real( ptab, kcom )
1801      !!----------------------------------------------------------------------
1802      !!                  ***  routine mppsum_real  ***
1803      !!
1804      !! ** Purpose :   global sum, SCALAR argument case
1805      !!
1806      !!-----------------------------------------------------------------------
1807      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1808      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1809      !!
1810      INTEGER  ::   ierror, localcomm
1811      REAL(wp) ::   zwork
1812      !!-----------------------------------------------------------------------
1813      !
1814      localcomm = mpi_comm_opa
1815      IF( PRESENT(kcom) ) localcomm = kcom
1816      !
1817      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1818      ptab = zwork
1819      !
1820   END SUBROUTINE mppsum_real
1821
1822   SUBROUTINE mppsum_realdd( ytab, kcom )
1823      !!----------------------------------------------------------------------
1824      !!                  ***  routine mppsum_realdd ***
1825      !!
1826      !! ** Purpose :   global sum in Massively Parallel Processing
1827      !!                SCALAR argument case for double-double precision
1828      !!
1829      !!-----------------------------------------------------------------------
1830      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
1831      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1832
1833      !! * Local variables   (MPI version)
1834      INTEGER  ::    ierror
1835      INTEGER  ::   localcomm
1836      COMPLEX(wp) :: zwork
1837
1838      localcomm = mpi_comm_opa
1839      IF( PRESENT(kcom) ) localcomm = kcom
1840
1841      ! reduce local sums into global sum
1842      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
1843                       MPI_SUMDD,localcomm,ierror)
1844      ytab = zwork
1845
1846   END SUBROUTINE mppsum_realdd
1847
1848
1849   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
1850      !!----------------------------------------------------------------------
1851      !!                  ***  routine mppsum_a_realdd  ***
1852      !!
1853      !! ** Purpose :   global sum in Massively Parallel Processing
1854      !!                COMPLEX ARRAY case for double-double precision
1855      !!
1856      !!-----------------------------------------------------------------------
1857      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
1858      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
1859      INTEGER , INTENT( in  ), OPTIONAL :: kcom
1860
1861      !! * Local variables   (MPI version)
1862      INTEGER                      :: ierror    ! temporary integer
1863      INTEGER                      ::   localcomm
1864      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace
1865
1866      localcomm = mpi_comm_opa
1867      IF( PRESENT(kcom) ) localcomm = kcom
1868
1869      CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
1870                       MPI_SUMDD,localcomm,ierror)
1871      ytab(:) = zwork(:)
1872
1873   END SUBROUTINE mppsum_a_realdd
1874
1875   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1876      !!------------------------------------------------------------------------
1877      !!             ***  routine mpp_minloc  ***
1878      !!
1879      !! ** Purpose :   Compute the global minimum of an array ptab
1880      !!              and also give its global position
1881      !!
1882      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1883      !!
1884      !!--------------------------------------------------------------------------
1885      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1886      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1887      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1888      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1889      !!
1890      INTEGER , DIMENSION(2)   ::   ilocs
1891      INTEGER :: ierror
1892      REAL(wp) ::   zmin   ! local minimum
1893      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1894      !!-----------------------------------------------------------------------
1895      !
1896      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1897      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1898      !
1899      ki = ilocs(1) + nimpp - 1
1900      kj = ilocs(2) + njmpp - 1
1901      !
1902      zain(1,:)=zmin
1903      zain(2,:)=ki+10000.*kj
1904      !
1905      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1906      !
1907      pmin = zaout(1,1)
1908      kj = INT(zaout(2,1)/10000.)
1909      ki = INT(zaout(2,1) - 10000.*kj )
1910      !
1911   END SUBROUTINE mpp_minloc2d
1912
1913
1914   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1915      !!------------------------------------------------------------------------
1916      !!             ***  routine mpp_minloc  ***
1917      !!
1918      !! ** Purpose :   Compute the global minimum of an array ptab
1919      !!              and also give its global position
1920      !!
1921      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1922      !!
1923      !!--------------------------------------------------------------------------
1924      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1925      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1926      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1927      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1928      !!
1929      INTEGER  ::   ierror
1930      REAL(wp) ::   zmin     ! local minimum
1931      INTEGER , DIMENSION(3)   ::   ilocs
1932      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1933      !!-----------------------------------------------------------------------
1934      !
1935      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1936      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1937      !
1938      ki = ilocs(1) + nimpp - 1
1939      kj = ilocs(2) + njmpp - 1
1940      kk = ilocs(3)
1941      !
1942      zain(1,:)=zmin
1943      zain(2,:)=ki+10000.*kj+100000000.*kk
1944      !
1945      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1946      !
1947      pmin = zaout(1,1)
1948      kk   = INT( zaout(2,1) / 100000000. )
1949      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1950      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1951      !
1952   END SUBROUTINE mpp_minloc3d
1953
1954
1955   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1956      !!------------------------------------------------------------------------
1957      !!             ***  routine mpp_maxloc  ***
1958      !!
1959      !! ** Purpose :   Compute the global maximum of an array ptab
1960      !!              and also give its global position
1961      !!
1962      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1963      !!
1964      !!--------------------------------------------------------------------------
1965      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
1966      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
1967      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
1968      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
1969      !!
1970      INTEGER  :: ierror
1971      INTEGER, DIMENSION (2)   ::   ilocs
1972      REAL(wp) :: zmax   ! local maximum
1973      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1974      !!-----------------------------------------------------------------------
1975      !
1976      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1977      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1978      !
1979      ki = ilocs(1) + nimpp - 1
1980      kj = ilocs(2) + njmpp - 1
1981      !
1982      zain(1,:) = zmax
1983      zain(2,:) = ki + 10000. * kj
1984      !
1985      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1986      !
1987      pmax = zaout(1,1)
1988      kj   = INT( zaout(2,1) / 10000.     )
1989      ki   = INT( zaout(2,1) - 10000.* kj )
1990      !
1991   END SUBROUTINE mpp_maxloc2d
1992
1993
1994   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1995      !!------------------------------------------------------------------------
1996      !!             ***  routine mpp_maxloc  ***
1997      !!
1998      !! ** Purpose :  Compute the global maximum of an array ptab
1999      !!              and also give its global position
2000      !!
2001      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2002      !!
2003      !!--------------------------------------------------------------------------
2004      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
2005      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
2006      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
2007      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
2008      !!
2009      REAL(wp) :: zmax   ! local maximum
2010      REAL(wp), DIMENSION(2,1) ::   zain, zaout
2011      INTEGER , DIMENSION(3)   ::   ilocs
2012      INTEGER :: ierror
2013      !!-----------------------------------------------------------------------
2014      !
2015      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2016      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2017      !
2018      ki = ilocs(1) + nimpp - 1
2019      kj = ilocs(2) + njmpp - 1
2020      kk = ilocs(3)
2021      !
2022      zain(1,:)=zmax
2023      zain(2,:)=ki+10000.*kj+100000000.*kk
2024      !
2025      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
2026      !
2027      pmax = zaout(1,1)
2028      kk   = INT( zaout(2,1) / 100000000. )
2029      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
2030      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
2031      !
2032   END SUBROUTINE mpp_maxloc3d
2033
2034
2035   SUBROUTINE mppsync()
2036      !!----------------------------------------------------------------------
2037      !!                  ***  routine mppsync  ***
2038      !!
2039      !! ** Purpose :   Massively parallel processors, synchroneous
2040      !!
2041      !!-----------------------------------------------------------------------
2042      INTEGER :: ierror
2043      !!-----------------------------------------------------------------------
2044      !
2045      CALL mpi_barrier( mpi_comm_opa, ierror )
2046      !
2047   END SUBROUTINE mppsync
2048
2049
2050   SUBROUTINE mppstop
2051   
2052#if defined key_oasis3
2053   USE mod_oasis      ! coupling routines
2054#endif
2055
2056      !!----------------------------------------------------------------------
2057      !!                  ***  routine mppstop  ***
2058      !!
2059      !! ** purpose :   Stop massively parallel processors method
2060      !!
2061      !!----------------------------------------------------------------------
2062      INTEGER ::   info
2063      !!----------------------------------------------------------------------
2064      !
2065     
2066#if defined key_oasis3
2067      ! If we're trying to shut down cleanly then we need to consider the fact
2068      ! that this could be part of an MPMD configuration - we don't want to
2069      ! leave other components deadlocked.
2070
2071      CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
2072
2073
2074#else
2075     
2076      CALL mppsync
2077      CALL mpi_finalize( info )
2078#endif
2079
2080      !
2081   END SUBROUTINE mppstop
2082
2083
2084   SUBROUTINE mpp_comm_free( kcom )
2085      !!----------------------------------------------------------------------
2086      !!----------------------------------------------------------------------
2087      INTEGER, INTENT(in) ::   kcom
2088      !!
2089      INTEGER :: ierr
2090      !!----------------------------------------------------------------------
2091      !
2092      CALL MPI_COMM_FREE(kcom, ierr)
2093      !
2094   END SUBROUTINE mpp_comm_free
2095
2096
2097   SUBROUTINE mpp_ini_ice( pindic, kumout )
2098      !!----------------------------------------------------------------------
2099      !!               ***  routine mpp_ini_ice  ***
2100      !!
2101      !! ** Purpose :   Initialize special communicator for ice areas
2102      !!      condition together with global variables needed in the ddmpp folding
2103      !!
2104      !! ** Method  : - Look for ice processors in ice routines
2105      !!              - Put their number in nrank_ice
2106      !!              - Create groups for the world processors and the ice processors
2107      !!              - Create a communicator for ice processors
2108      !!
2109      !! ** output
2110      !!      njmppmax = njmpp for northern procs
2111      !!      ndim_rank_ice = number of processors with ice
2112      !!      nrank_ice (ndim_rank_ice) = ice processors
2113      !!      ngrp_iworld = group ID for the world processors
2114      !!      ngrp_ice = group ID for the ice processors
2115      !!      ncomm_ice = communicator for the ice procs.
2116      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2117      !!
2118      !!----------------------------------------------------------------------
2119      INTEGER, INTENT(in) ::   pindic
2120      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
2121      !!
2122      INTEGER :: jjproc
2123      INTEGER :: ii, ierr
2124      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2125      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
2126      !!----------------------------------------------------------------------
2127      !
2128      ! Since this is just an init routine and these arrays are of length jpnij
2129      ! then don't use wrk_nemo module - just allocate and deallocate.
2130      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2131      IF( ierr /= 0 ) THEN
2132         WRITE(kumout, cform_err)
2133         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2134         CALL mppstop
2135      ENDIF
2136
2137      ! Look for how many procs with sea-ice
2138      !
2139      kice = 0
2140      DO jjproc = 1, jpnij
2141         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
2142      END DO
2143      !
2144      zwork = 0
2145      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2146      ndim_rank_ice = SUM( zwork )
2147
2148      ! Allocate the right size to nrank_north
2149      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2150      ALLOCATE( nrank_ice(ndim_rank_ice) )
2151      !
2152      ii = 0
2153      nrank_ice = 0
2154      DO jjproc = 1, jpnij
2155         IF( zwork(jjproc) == 1) THEN
2156            ii = ii + 1
2157            nrank_ice(ii) = jjproc -1
2158         ENDIF
2159      END DO
2160
2161      ! Create the world group
2162      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2163
2164      ! Create the ice group from the world group
2165      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2166
2167      ! Create the ice communicator , ie the pool of procs with sea-ice
2168      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2169
2170      ! Find proc number in the world of proc 0 in the north
2171      ! The following line seems to be useless, we just comment & keep it as reminder
2172      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2173      !
2174      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2175      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2176
2177      DEALLOCATE(kice, zwork)
2178      !
2179   END SUBROUTINE mpp_ini_ice
2180
2181
2182   SUBROUTINE mpp_ini_znl( kumout )
2183      !!----------------------------------------------------------------------
2184      !!               ***  routine mpp_ini_znl  ***
2185      !!
2186      !! ** Purpose :   Initialize special communicator for computing zonal sum
2187      !!
2188      !! ** Method  : - Look for processors in the same row
2189      !!              - Put their number in nrank_znl
2190      !!              - Create group for the znl processors
2191      !!              - Create a communicator for znl processors
2192      !!              - Determine if processor should write znl files
2193      !!
2194      !! ** output
2195      !!      ndim_rank_znl = number of processors on the same row
2196      !!      ngrp_znl = group ID for the znl processors
2197      !!      ncomm_znl = communicator for the ice procs.
2198      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2199      !!
2200      !!----------------------------------------------------------------------
2201      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2202      !
2203      INTEGER :: jproc      ! dummy loop integer
2204      INTEGER :: ierr, ii   ! local integer
2205      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2206      !!----------------------------------------------------------------------
2207      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2208      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2209      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2210      !
2211      ALLOCATE( kwork(jpnij), STAT=ierr )
2212      IF( ierr /= 0 ) THEN
2213         WRITE(kumout, cform_err)
2214         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2215         CALL mppstop
2216      ENDIF
2217
2218      IF( jpnj == 1 ) THEN
2219         ngrp_znl  = ngrp_world
2220         ncomm_znl = mpi_comm_opa
2221      ELSE
2222         !
2223         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2224         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2225         !-$$        CALL flush(numout)
2226         !
2227         ! Count number of processors on the same row
2228         ndim_rank_znl = 0
2229         DO jproc=1,jpnij
2230            IF ( kwork(jproc) == njmpp ) THEN
2231               ndim_rank_znl = ndim_rank_znl + 1
2232            ENDIF
2233         END DO
2234         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2235         !-$$        CALL flush(numout)
2236         ! Allocate the right size to nrank_znl
2237         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2238         ALLOCATE(nrank_znl(ndim_rank_znl))
2239         ii = 0
2240         nrank_znl (:) = 0
2241         DO jproc=1,jpnij
2242            IF ( kwork(jproc) == njmpp) THEN
2243               ii = ii + 1
2244               nrank_znl(ii) = jproc -1
2245            ENDIF
2246         END DO
2247         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2248         !-$$        CALL flush(numout)
2249
2250         ! Create the opa group
2251         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2252         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2253         !-$$        CALL flush(numout)
2254
2255         ! Create the znl group from the opa group
2256         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2257         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2258         !-$$        CALL flush(numout)
2259
2260         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2261         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2262         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2263         !-$$        CALL flush(numout)
2264         !
2265      END IF
2266
2267      ! Determines if processor if the first (starting from i=1) on the row
2268      IF ( jpni == 1 ) THEN
2269         l_znl_root = .TRUE.
2270      ELSE
2271         l_znl_root = .FALSE.
2272         kwork (1) = nimpp
2273         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2274         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2275      END IF
2276
2277      DEALLOCATE(kwork)
2278
2279   END SUBROUTINE mpp_ini_znl
2280
2281
2282   SUBROUTINE mpp_ini_north
2283      !!----------------------------------------------------------------------
2284      !!               ***  routine mpp_ini_north  ***
2285      !!
2286      !! ** Purpose :   Initialize special communicator for north folding
2287      !!      condition together with global variables needed in the mpp folding
2288      !!
2289      !! ** Method  : - Look for northern processors
2290      !!              - Put their number in nrank_north
2291      !!              - Create groups for the world processors and the north processors
2292      !!              - Create a communicator for northern processors
2293      !!
2294      !! ** output
2295      !!      njmppmax = njmpp for northern procs
2296      !!      ndim_rank_north = number of processors in the northern line
2297      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2298      !!      ngrp_world = group ID for the world processors
2299      !!      ngrp_north = group ID for the northern processors
2300      !!      ncomm_north = communicator for the northern procs.
2301      !!      north_root = number (in the world) of proc 0 in the northern comm.
2302      !!
2303      !!----------------------------------------------------------------------
2304      INTEGER ::   ierr
2305      INTEGER ::   jjproc
2306      INTEGER ::   ii, ji
2307      !!----------------------------------------------------------------------
2308      !
2309      njmppmax = MAXVAL( njmppt )
2310      !
2311      ! Look for how many procs on the northern boundary
2312      ndim_rank_north = 0
2313      DO jjproc = 1, jpnij
2314         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2315      END DO
2316      !
2317      ! Allocate the right size to nrank_north
2318      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2319      ALLOCATE( nrank_north(ndim_rank_north) )
2320
2321      ! Fill the nrank_north array with proc. number of northern procs.
2322      ! Note : the rank start at 0 in MPI
2323      ii = 0
2324      DO ji = 1, jpnij
2325         IF ( njmppt(ji) == njmppmax   ) THEN
2326            ii=ii+1
2327            nrank_north(ii)=ji-1
2328         END IF
2329      END DO
2330      !
2331      ! create the world group
2332      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2333      !
2334      ! Create the North group from the world group
2335      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2336      !
2337      ! Create the North communicator , ie the pool of procs in the north group
2338      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2339      !
2340   END SUBROUTINE mpp_ini_north
2341
2342
2343   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2344      !!---------------------------------------------------------------------
2345      !!                   ***  routine mpp_lbc_north_3d  ***
2346      !!
2347      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2348      !!              in mpp configuration in case of jpn1 > 1
2349      !!
2350      !! ** Method  :   North fold condition and mpp with more than one proc
2351      !!              in i-direction require a specific treatment. We gather
2352      !!              the 4 northern lines of the global domain on 1 processor
2353      !!              and apply lbc north-fold on this sub array. Then we
2354      !!              scatter the north fold array back to the processors.
2355      !!
2356      !!----------------------------------------------------------------------
2357      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2358      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2359      !                                                              !   = T ,  U , V , F or W  gridpoints
2360      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2361      !!                                                             ! =  1. , the sign is kept
2362      INTEGER ::   ji, jj, jr, jk
2363      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2364      INTEGER ::   ijpj, ijpjm1, ij, iproc
2365      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2366      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2367      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2368      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2369      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2370      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2371      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2372      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2373
2374      INTEGER :: istatus(mpi_status_size)
2375      INTEGER :: iflag
2376      !!----------------------------------------------------------------------
2377      !
2378      ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
2379      ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 
2380
2381      ijpj   = 4
2382      ijpjm1 = 3
2383      !
2384      znorthloc(:,:,:) = 0
2385      DO jk = 1, jpk
2386         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2387            ij = jj - nlcj + ijpj
2388            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2389         END DO
2390      END DO
2391      !
2392      !                                     ! Build in procs of ncomm_north the znorthgloio
2393      itaille = jpi * jpk * ijpj
2394
2395      IF ( l_north_nogather ) THEN
2396         !
2397        ztabr(:,:,:) = 0
2398        ztabl(:,:,:) = 0
2399
2400        DO jk = 1, jpk
2401           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2402              ij = jj - nlcj + ijpj
2403              DO ji = nfsloop, nfeloop
2404                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2405              END DO
2406           END DO
2407        END DO
2408
2409         DO jr = 1,nsndto
2410            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2411              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2412            ENDIF
2413         END DO
2414         DO jr = 1,nsndto
2415            iproc = nfipproc(isendto(jr),jpnj)
2416            IF(iproc .ne. -1) THEN
2417               ilei = nleit (iproc+1)
2418               ildi = nldit (iproc+1)
2419               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2420            ENDIF
2421            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2422              CALL mpprecv(5, zfoldwk, itaille, iproc)
2423              DO jk = 1, jpk
2424                 DO jj = 1, ijpj
2425                    DO ji = ildi, ilei
2426                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2427                    END DO
2428                 END DO
2429              END DO
2430           ELSE IF (iproc .eq. (narea-1)) THEN
2431              DO jk = 1, jpk
2432                 DO jj = 1, ijpj
2433                    DO ji = ildi, ilei
2434                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2435                    END DO
2436                 END DO
2437              END DO
2438           ENDIF
2439         END DO
2440         IF (l_isend) THEN
2441            DO jr = 1,nsndto
2442               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2443                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2444               ENDIF   
2445            END DO
2446         ENDIF
2447         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2448         DO jk = 1, jpk
2449            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2450               ij = jj - nlcj + ijpj
2451               DO ji= 1, nlci
2452                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2453               END DO
2454            END DO
2455         END DO
2456         !
2457
2458      ELSE
2459         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2460            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2461         !
2462         ztab(:,:,:) = 0.e0
2463         DO jr = 1, ndim_rank_north         ! recover the global north array
2464            iproc = nrank_north(jr) + 1
2465            ildi  = nldit (iproc)
2466            ilei  = nleit (iproc)
2467            iilb  = nimppt(iproc)
2468            DO jk = 1, jpk
2469               DO jj = 1, ijpj
2470                  DO ji = ildi, ilei
2471                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2472                  END DO
2473               END DO
2474            END DO
2475         END DO
2476         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2477         !
2478         DO jk = 1, jpk
2479            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2480               ij = jj - nlcj + ijpj
2481               DO ji= 1, nlci
2482                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2483               END DO
2484            END DO
2485         END DO
2486         !
2487      ENDIF
2488      !
2489      ! The ztab array has been either:
2490      !  a. Fully populated by the mpi_allgather operation or
2491      !  b. Had the active points for this domain and northern neighbours populated
2492      !     by peer to peer exchanges
2493      ! Either way the array may be folded by lbc_nfd and the result for the span of
2494      ! this domain will be identical.
2495      !
2496      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2497      DEALLOCATE( ztabl, ztabr ) 
2498      !
2499   END SUBROUTINE mpp_lbc_north_3d
2500
2501
2502   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2503      !!---------------------------------------------------------------------
2504      !!                   ***  routine mpp_lbc_north_2d  ***
2505      !!
2506      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2507      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2508      !!
2509      !! ** Method  :   North fold condition and mpp with more than one proc
2510      !!              in i-direction require a specific treatment. We gather
2511      !!              the 4 northern lines of the global domain on 1 processor
2512      !!              and apply lbc north-fold on this sub array. Then we
2513      !!              scatter the north fold array back to the processors.
2514      !!
2515      !!----------------------------------------------------------------------
2516      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2517      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2518      !                                                          !   = T ,  U , V , F or W  gridpoints
2519      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2520      !!                                                             ! =  1. , the sign is kept
2521      INTEGER ::   ji, jj, jr
2522      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2523      INTEGER ::   ijpj, ijpjm1, ij, iproc
2524      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2525      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2526      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2527      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2528      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2529      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2530      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
2531      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2532      INTEGER :: istatus(mpi_status_size)
2533      INTEGER :: iflag
2534      !!----------------------------------------------------------------------
2535      !
2536      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2537      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
2538      !
2539      ijpj   = 4
2540      ijpjm1 = 3
2541      !
2542      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2543         ij = jj - nlcj + ijpj
2544         znorthloc(:,ij) = pt2d(:,jj)
2545      END DO
2546
2547      !                                     ! Build in procs of ncomm_north the znorthgloio
2548      itaille = jpi * ijpj
2549      IF ( l_north_nogather ) THEN
2550         !
2551         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2552         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2553         !
2554         ztabr(:,:) = 0
2555         ztabl(:,:) = 0
2556
2557         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2558            ij = jj - nlcj + ijpj
2559              DO ji = nfsloop, nfeloop
2560               ztabl(ji,ij) = pt2d(ji,jj)
2561            END DO
2562         END DO
2563
2564         DO jr = 1,nsndto
2565            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2566               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
2567            ENDIF
2568         END DO
2569         DO jr = 1,nsndto
2570            iproc = nfipproc(isendto(jr),jpnj)
2571            IF(iproc .ne. -1) THEN
2572               ilei = nleit (iproc+1)
2573               ildi = nldit (iproc+1)
2574               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2575            ENDIF
2576            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2577              CALL mpprecv(5, zfoldwk, itaille, iproc)
2578              DO jj = 1, ijpj
2579                 DO ji = ildi, ilei
2580                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2581                 END DO
2582              END DO
2583            ELSE IF (iproc .eq. (narea-1)) THEN
2584              DO jj = 1, ijpj
2585                 DO ji = ildi, ilei
2586                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2587                 END DO
2588              END DO
2589            ENDIF
2590         END DO
2591         IF (l_isend) THEN
2592            DO jr = 1,nsndto
2593               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2594                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2595               ENDIF
2596            END DO
2597         ENDIF
2598         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2599         !
2600         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2601            ij = jj - nlcj + ijpj
2602            DO ji = 1, nlci
2603               pt2d(ji,jj) = ztabl(ji,ij)
2604            END DO
2605         END DO
2606         !
2607      ELSE
2608         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2609            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2610         !
2611         ztab(:,:) = 0.e0
2612         DO jr = 1, ndim_rank_north            ! recover the global north array
2613            iproc = nrank_north(jr) + 1
2614            ildi = nldit (iproc)
2615            ilei = nleit (iproc)
2616            iilb = nimppt(iproc)
2617            DO jj = 1, ijpj
2618               DO ji = ildi, ilei
2619                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2620               END DO
2621            END DO
2622         END DO
2623         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2624         !
2625         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2626            ij = jj - nlcj + ijpj
2627            DO ji = 1, nlci
2628               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2629            END DO
2630         END DO
2631         !
2632      ENDIF
2633      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2634      DEALLOCATE( ztabl, ztabr ) 
2635      !
2636   END SUBROUTINE mpp_lbc_north_2d
2637
2638   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields)
2639      !!---------------------------------------------------------------------
2640      !!                   ***  routine mpp_lbc_north_2d  ***
2641      !!
2642      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2643      !!              in mpp configuration in case of jpn1 > 1
2644      !!              (for multiple 2d arrays )
2645      !!
2646      !! ** Method  :   North fold condition and mpp with more than one proc
2647      !!              in i-direction require a specific treatment. We gather
2648      !!              the 4 northern lines of the global domain on 1 processor
2649      !!              and apply lbc north-fold on this sub array. Then we
2650      !!              scatter the north fold array back to the processors.
2651      !!
2652      !!----------------------------------------------------------------------
2653      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d
2654      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array
2655      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2656      !                                                          !   = T ,  U , V , F or W  gridpoints
2657      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2658      !!                                                             ! =  1. , the sign is kept
2659      INTEGER ::   ji, jj, jr, jk
2660      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2661      INTEGER ::   ijpj, ijpjm1, ij, iproc
2662      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2663      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2664      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2665      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2666      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2667      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk
2668      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2669      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2670      INTEGER :: istatus(mpi_status_size)
2671      INTEGER :: iflag
2672      !!----------------------------------------------------------------------
2673      !
2674      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   & 
2675            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions
2676      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) )
2677      !
2678      ijpj   = 4
2679      ijpjm1 = 3
2680      !
2681     
2682      DO jk = 1, num_fields
2683         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable)
2684            ij = jj - nlcj + ijpj
2685            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj)
2686         END DO
2687      END DO
2688      !                                     ! Build in procs of ncomm_north the znorthgloio
2689      itaille = jpi * ijpj
2690                                                                 
2691      IF ( l_north_nogather ) THEN
2692         !
2693         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2694         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2695         !
2696         ztabr(:,:,:) = 0
2697         ztabl(:,:,:) = 0
2698
2699         DO jk = 1, num_fields
2700            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2701               ij = jj - nlcj + ijpj
2702               DO ji = nfsloop, nfeloop
2703                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj)
2704               END DO
2705            END DO
2706         END DO
2707
2708         DO jr = 1,nsndto
2709            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2710               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times
2711            ENDIF
2712         END DO
2713         DO jr = 1,nsndto
2714            iproc = nfipproc(isendto(jr),jpnj)
2715            IF(iproc .ne. -1) THEN
2716               ilei = nleit (iproc+1)
2717               ildi = nldit (iproc+1)
2718               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2719            ENDIF
2720            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2721              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times
2722              DO jk = 1 , num_fields
2723                 DO jj = 1, ijpj
2724                    DO ji = ildi, ilei
2725                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D
2726                    END DO
2727                 END DO
2728              END DO
2729            ELSE IF (iproc .eq. (narea-1)) THEN
2730              DO jk = 1, num_fields
2731                 DO jj = 1, ijpj
2732                    DO ji = ildi, ilei
2733                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D
2734                    END DO
2735                 END DO
2736              END DO
2737            ENDIF
2738         END DO
2739         IF (l_isend) THEN
2740            DO jr = 1,nsndto
2741               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2742                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2743               ENDIF
2744            END DO
2745         ENDIF
2746         !
2747         DO ji = 1, num_fields     ! Loop to manage 3D variables
2748            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition
2749         END DO
2750         !
2751         DO jk = 1, num_fields
2752            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2753               ij = jj - nlcj + ijpj
2754               DO ji = 1, nlci
2755                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D
2756               END DO
2757            END DO
2758         END DO
2759         
2760         !
2761      ELSE
2762         !
2763         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        &
2764            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2765         !
2766         ztab(:,:,:) = 0.e0
2767         DO jk = 1, num_fields
2768            DO jr = 1, ndim_rank_north            ! recover the global north array
2769               iproc = nrank_north(jr) + 1
2770               ildi = nldit (iproc)
2771               ilei = nleit (iproc)
2772               iilb = nimppt(iproc)
2773               DO jj = 1, ijpj
2774                  DO ji = ildi, ilei
2775                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2776                  END DO
2777               END DO
2778            END DO
2779         END DO
2780         
2781         DO ji = 1, num_fields
2782            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition
2783         END DO
2784         !
2785         DO jk = 1, num_fields
2786            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2787               ij = jj - nlcj + ijpj
2788               DO ji = 1, nlci
2789                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk)
2790               END DO
2791            END DO
2792         END DO
2793         !
2794         !
2795      ENDIF
2796      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2797      DEALLOCATE( ztabl, ztabr )
2798      !
2799   END SUBROUTINE mpp_lbc_north_2d_multiple
2800
2801   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2802      !!---------------------------------------------------------------------
2803      !!                   ***  routine mpp_lbc_north_2d  ***
2804      !!
2805      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2806      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2807      !!              array with outer extra halo
2808      !!
2809      !! ** Method  :   North fold condition and mpp with more than one proc
2810      !!              in i-direction require a specific treatment. We gather
2811      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2812      !!              processor and apply lbc north-fold on this sub array.
2813      !!              Then we scatter the north fold array back to the processors.
2814      !!
2815      !!----------------------------------------------------------------------
2816      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2817      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2818      !                                                                                         !   = T ,  U , V , F or W -points
2819      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2820      !!                                                                                        ! north fold, =  1. otherwise
2821      INTEGER ::   ji, jj, jr
2822      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2823      INTEGER ::   ijpj, ij, iproc
2824      !
2825      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
2826      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
2827
2828      !!----------------------------------------------------------------------
2829      !
2830      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
2831
2832      !
2833      ijpj=4
2834      ztab_e(:,:) = 0.e0
2835
2836      ij=0
2837      ! put in znorthloc_e the last 4 jlines of pt2d
2838      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2839         ij = ij + 1
2840         DO ji = 1, jpi
2841            znorthloc_e(ji,ij)=pt2d(ji,jj)
2842         END DO
2843      END DO
2844      !
2845      itaille = jpi * ( ijpj + 2 * jpr2dj )
2846      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2847         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2848      !
2849      DO jr = 1, ndim_rank_north            ! recover the global north array
2850         iproc = nrank_north(jr) + 1
2851         ildi = nldit (iproc)
2852         ilei = nleit (iproc)
2853         iilb = nimppt(iproc)
2854         DO jj = 1, ijpj+2*jpr2dj
2855            DO ji = ildi, ilei
2856               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2857            END DO
2858         END DO
2859      END DO
2860
2861
2862      ! 2. North-Fold boundary conditions
2863      ! ----------------------------------
2864      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2865
2866      ij = jpr2dj
2867      !! Scatter back to pt2d
2868      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2869      ij  = ij +1
2870         DO ji= 1, nlci
2871            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2872         END DO
2873      END DO
2874      !
2875      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
2876      !
2877   END SUBROUTINE mpp_lbc_north_e
2878
2879      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
2880      !!----------------------------------------------------------------------
2881      !!                  ***  routine mpp_lnk_bdy_3d  ***
2882      !!
2883      !! ** Purpose :   Message passing management
2884      !!
2885      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2886      !!      between processors following neighboring subdomains.
2887      !!            domain parameters
2888      !!                    nlci   : first dimension of the local subdomain
2889      !!                    nlcj   : second dimension of the local subdomain
2890      !!                    nbondi_bdy : mark for "east-west local boundary"
2891      !!                    nbondj_bdy : mark for "north-south local boundary"
2892      !!                    noea   : number for local neighboring processors
2893      !!                    nowe   : number for local neighboring processors
2894      !!                    noso   : number for local neighboring processors
2895      !!                    nono   : number for local neighboring processors
2896      !!
2897      !! ** Action  :   ptab with update value at its periphery
2898      !!
2899      !!----------------------------------------------------------------------
2900
2901      USE lbcnfd          ! north fold
2902
2903      INCLUDE 'mpif.h'
2904
2905      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2906      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2907      !                                                             ! = T , U , V , F , W points
2908      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2909      !                                                             ! =  1. , the sign is kept
2910      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2911      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
2912      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2913      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2914      REAL(wp) ::   zland
2915      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2916      !
2917      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
2918      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
2919
2920      !!----------------------------------------------------------------------
2921     
2922      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
2923         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
2924
2925      zland = 0.e0
2926
2927      ! 1. standard boundary treatment
2928      ! ------------------------------
2929     
2930      !                                   ! East-West boundaries
2931      !                                        !* Cyclic east-west
2932
2933      IF( nbondi == 2) THEN
2934        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2935          ptab( 1 ,:,:) = ptab(jpim1,:,:)
2936          ptab(jpi,:,:) = ptab(  2  ,:,:)
2937        ELSE
2938          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2939          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2940        ENDIF
2941      ELSEIF(nbondi == -1) THEN
2942        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2943      ELSEIF(nbondi == 1) THEN
2944        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2945      ENDIF                                     !* closed
2946
2947      IF (nbondj == 2 .OR. nbondj == -1) THEN
2948        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
2949      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2950        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
2951      ENDIF
2952     
2953      !
2954
2955      ! 2. East and west directions exchange
2956      ! ------------------------------------
2957      ! we play with the neigbours AND the row number because of the periodicity
2958      !
2959      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2960      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2961         iihom = nlci-nreci
2962         DO jl = 1, jpreci
2963            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
2964            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
2965         END DO
2966      END SELECT
2967      !
2968      !                           ! Migrations
2969      imigr = jpreci * jpj * jpk
2970      !
2971      SELECT CASE ( nbondi_bdy(ib_bdy) )
2972      CASE ( -1 )
2973         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
2974      CASE ( 0 )
2975         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2976         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
2977      CASE ( 1 )
2978         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2979      END SELECT
2980      !
2981      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2982      CASE ( -1 )
2983         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2984      CASE ( 0 )
2985         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2986         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2987      CASE ( 1 )
2988         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2989      END SELECT
2990      !
2991      SELECT CASE ( nbondi_bdy(ib_bdy) )
2992      CASE ( -1 )
2993         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2994      CASE ( 0 )
2995         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2996         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2997      CASE ( 1 )
2998         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2999      END SELECT
3000      !
3001      !                           ! Write Dirichlet lateral conditions
3002      iihom = nlci-jpreci
3003      !
3004      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3005      CASE ( -1 )
3006         DO jl = 1, jpreci
3007            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3008         END DO
3009      CASE ( 0 )
3010         DO jl = 1, jpreci
3011            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
3012            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
3013         END DO
3014      CASE ( 1 )
3015         DO jl = 1, jpreci
3016            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
3017         END DO
3018      END SELECT
3019
3020
3021      ! 3. North and south directions
3022      ! -----------------------------
3023      ! always closed : we play only with the neigbours
3024      !
3025      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3026         ijhom = nlcj-nrecj
3027         DO jl = 1, jprecj
3028            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
3029            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
3030         END DO
3031      ENDIF
3032      !
3033      !                           ! Migrations
3034      imigr = jprecj * jpi * jpk
3035      !
3036      SELECT CASE ( nbondj_bdy(ib_bdy) )
3037      CASE ( -1 )
3038         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
3039      CASE ( 0 )
3040         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3041         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
3042      CASE ( 1 )
3043         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
3044      END SELECT
3045      !
3046      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3047      CASE ( -1 )
3048         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3049      CASE ( 0 )
3050         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
3051         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3052      CASE ( 1 )
3053         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
3054      END SELECT
3055      !
3056      SELECT CASE ( nbondj_bdy(ib_bdy) )
3057      CASE ( -1 )
3058         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3059      CASE ( 0 )
3060         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3061         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3062      CASE ( 1 )
3063         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3064      END SELECT
3065      !
3066      !                           ! Write Dirichlet lateral conditions
3067      ijhom = nlcj-jprecj
3068      !
3069      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3070      CASE ( -1 )
3071         DO jl = 1, jprecj
3072            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3073         END DO
3074      CASE ( 0 )
3075         DO jl = 1, jprecj
3076            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
3077            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
3078         END DO
3079      CASE ( 1 )
3080         DO jl = 1, jprecj
3081            ptab(:,jl,:) = zt3sn(:,jl,:,2)
3082         END DO
3083      END SELECT
3084
3085
3086      ! 4. north fold treatment
3087      ! -----------------------
3088      !
3089      IF( npolj /= 0) THEN
3090         !
3091         SELECT CASE ( jpni )
3092         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3093         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3094         END SELECT
3095         !
3096      ENDIF
3097      !
3098      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
3099      !
3100   END SUBROUTINE mpp_lnk_bdy_3d
3101
3102      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
3103      !!----------------------------------------------------------------------
3104      !!                  ***  routine mpp_lnk_bdy_2d  ***
3105      !!
3106      !! ** Purpose :   Message passing management
3107      !!
3108      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
3109      !!      between processors following neighboring subdomains.
3110      !!            domain parameters
3111      !!                    nlci   : first dimension of the local subdomain
3112      !!                    nlcj   : second dimension of the local subdomain
3113      !!                    nbondi_bdy : mark for "east-west local boundary"
3114      !!                    nbondj_bdy : mark for "north-south local boundary"
3115      !!                    noea   : number for local neighboring processors
3116      !!                    nowe   : number for local neighboring processors
3117      !!                    noso   : number for local neighboring processors
3118      !!                    nono   : number for local neighboring processors
3119      !!
3120      !! ** Action  :   ptab with update value at its periphery
3121      !!
3122      !!----------------------------------------------------------------------
3123
3124      USE lbcnfd          ! north fold
3125
3126      INCLUDE 'mpif.h'
3127
3128      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
3129      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
3130      !                                                             ! = T , U , V , F , W points
3131      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
3132      !                                                             ! =  1. , the sign is kept
3133      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
3134      INTEGER  ::   ji, jj, jl             ! dummy loop indices
3135      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3136      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3137      REAL(wp) ::   zland
3138      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3139      !
3140      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
3141      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
3142
3143      !!----------------------------------------------------------------------
3144
3145      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
3146         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
3147
3148      zland = 0.e0
3149
3150      ! 1. standard boundary treatment
3151      ! ------------------------------
3152     
3153      !                                   ! East-West boundaries
3154      !                                        !* Cyclic east-west
3155
3156      IF( nbondi == 2) THEN
3157        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
3158          ptab( 1 ,:) = ptab(jpim1,:)
3159          ptab(jpi,:) = ptab(  2  ,:)
3160        ELSE
3161          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3162          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3163        ENDIF
3164      ELSEIF(nbondi == -1) THEN
3165        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
3166      ELSEIF(nbondi == 1) THEN
3167        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
3168      ENDIF                                     !* closed
3169
3170      IF (nbondj == 2 .OR. nbondj == -1) THEN
3171        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point
3172      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
3173        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north
3174      ENDIF
3175     
3176      !
3177
3178      ! 2. East and west directions exchange
3179      ! ------------------------------------
3180      ! we play with the neigbours AND the row number because of the periodicity
3181      !
3182      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
3183      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3184         iihom = nlci-nreci
3185         DO jl = 1, jpreci
3186            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
3187            zt2we(:,jl,1) = ptab(iihom +jl,:)
3188         END DO
3189      END SELECT
3190      !
3191      !                           ! Migrations
3192      imigr = jpreci * jpj
3193      !
3194      SELECT CASE ( nbondi_bdy(ib_bdy) )
3195      CASE ( -1 )
3196         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
3197      CASE ( 0 )
3198         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3199         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
3200      CASE ( 1 )
3201         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
3202      END SELECT
3203      !
3204      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3205      CASE ( -1 )
3206         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3207      CASE ( 0 )
3208         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3209         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3210      CASE ( 1 )
3211         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3212      END SELECT
3213      !
3214      SELECT CASE ( nbondi_bdy(ib_bdy) )
3215      CASE ( -1 )
3216         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3217      CASE ( 0 )
3218         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3219         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3220      CASE ( 1 )
3221         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3222      END SELECT
3223      !
3224      !                           ! Write Dirichlet lateral conditions
3225      iihom = nlci-jpreci
3226      !
3227      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3228      CASE ( -1 )
3229         DO jl = 1, jpreci
3230            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3231         END DO
3232      CASE ( 0 )
3233         DO jl = 1, jpreci
3234            ptab(jl      ,:) = zt2we(:,jl,2)
3235            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3236         END DO
3237      CASE ( 1 )
3238         DO jl = 1, jpreci
3239            ptab(jl      ,:) = zt2we(:,jl,2)
3240         END DO
3241      END SELECT
3242
3243
3244      ! 3. North and south directions
3245      ! -----------------------------
3246      ! always closed : we play only with the neigbours
3247      !
3248      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3249         ijhom = nlcj-nrecj
3250         DO jl = 1, jprecj
3251            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3252            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
3253         END DO
3254      ENDIF
3255      !
3256      !                           ! Migrations
3257      imigr = jprecj * jpi
3258      !
3259      SELECT CASE ( nbondj_bdy(ib_bdy) )
3260      CASE ( -1 )
3261         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
3262      CASE ( 0 )
3263         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3264         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
3265      CASE ( 1 )
3266         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3267      END SELECT
3268      !
3269      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3270      CASE ( -1 )
3271         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3272      CASE ( 0 )
3273         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3274         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3275      CASE ( 1 )
3276         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3277      END SELECT
3278      !
3279      SELECT CASE ( nbondj_bdy(ib_bdy) )
3280      CASE ( -1 )
3281         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3282      CASE ( 0 )
3283         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3284         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3285      CASE ( 1 )
3286         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3287      END SELECT
3288      !
3289      !                           ! Write Dirichlet lateral conditions
3290      ijhom = nlcj-jprecj
3291      !
3292      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3293      CASE ( -1 )
3294         DO jl = 1, jprecj
3295            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3296         END DO
3297      CASE ( 0 )
3298         DO jl = 1, jprecj
3299            ptab(:,jl      ) = zt2sn(:,jl,2)
3300            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3301         END DO
3302      CASE ( 1 )
3303         DO jl = 1, jprecj
3304            ptab(:,jl) = zt2sn(:,jl,2)
3305         END DO
3306      END SELECT
3307
3308
3309      ! 4. north fold treatment
3310      ! -----------------------
3311      !
3312      IF( npolj /= 0) THEN
3313         !
3314         SELECT CASE ( jpni )
3315         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3316         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3317         END SELECT
3318         !
3319      ENDIF
3320      !
3321      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
3322      !
3323   END SUBROUTINE mpp_lnk_bdy_2d
3324
3325   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3326      !!---------------------------------------------------------------------
3327      !!                   ***  routine mpp_init.opa  ***
3328      !!
3329      !! ** Purpose :: export and attach a MPI buffer for bsend
3330      !!
3331      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3332      !!            but classical mpi_init
3333      !!
3334      !! History :: 01/11 :: IDRIS initial version for IBM only
3335      !!            08/04 :: R. Benshila, generalisation
3336      !!---------------------------------------------------------------------
3337      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
3338      INTEGER                      , INTENT(inout) ::   ksft
3339      INTEGER                      , INTENT(  out) ::   code
3340      INTEGER                                      ::   ierr, ji
3341      LOGICAL                                      ::   mpi_was_called
3342      !!---------------------------------------------------------------------
3343      !
3344      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
3345      IF ( code /= MPI_SUCCESS ) THEN
3346         DO ji = 1, SIZE(ldtxt)
3347            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3348         END DO
3349         WRITE(*, cform_err)
3350         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
3351         CALL mpi_abort( mpi_comm_world, code, ierr )
3352      ENDIF
3353      !
3354      IF( .NOT. mpi_was_called ) THEN
3355         CALL mpi_init( code )
3356         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3357         IF ( code /= MPI_SUCCESS ) THEN
3358            DO ji = 1, SIZE(ldtxt)
3359               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3360            END DO
3361            WRITE(*, cform_err)
3362            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
3363            CALL mpi_abort( mpi_comm_world, code, ierr )
3364         ENDIF
3365      ENDIF
3366      !
3367      IF( nn_buffer > 0 ) THEN
3368         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
3369         ! Buffer allocation and attachment
3370         ALLOCATE( tampon(nn_buffer), stat = ierr )
3371         IF( ierr /= 0 ) THEN
3372            DO ji = 1, SIZE(ldtxt)
3373               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3374            END DO
3375            WRITE(*, cform_err)
3376            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3377            CALL mpi_abort( mpi_comm_world, code, ierr )
3378         END IF
3379         CALL mpi_buffer_attach( tampon, nn_buffer, code )
3380      ENDIF
3381      !
3382   END SUBROUTINE mpi_init_opa
3383
3384   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3385      !!---------------------------------------------------------------------
3386      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3387      !!
3388      !!   Modification of original codes written by David H. Bailey
3389      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3390      !!---------------------------------------------------------------------
3391      INTEGER, INTENT(in)                         :: ilen, itype
3392      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
3393      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
3394      !
3395      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3396      INTEGER :: ji, ztmp           ! local scalar
3397
3398      ztmp = itype   ! avoid compilation warning
3399
3400      DO ji=1,ilen
3401      ! Compute ydda + yddb using Knuth's trick.
3402         zt1  = real(ydda(ji)) + real(yddb(ji))
3403         zerr = zt1 - real(ydda(ji))
3404         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3405                + aimag(ydda(ji)) + aimag(yddb(ji))
3406
3407         ! The result is zt1 + zt2, after normalization.
3408         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3409      END DO
3410
3411   END SUBROUTINE DDPDD_MPI
3412
3413   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3414      !!---------------------------------------------------------------------
3415      !!                   ***  routine mpp_lbc_north_icb  ***
3416      !!
3417      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3418      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3419      !!              array with outer extra halo
3420      !!
3421      !! ** Method  :   North fold condition and mpp with more than one proc
3422      !!              in i-direction require a specific treatment. We gather
3423      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3424      !!              processor and apply lbc north-fold on this sub array.
3425      !!              Then we scatter the north fold array back to the processors.
3426      !!              This version accounts for an extra halo with icebergs.
3427      !!
3428      !!----------------------------------------------------------------------
3429      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3430      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3431      !                                                     !   = T ,  U , V , F or W -points
3432      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
3433      !!                                                    ! north fold, =  1. otherwise
3434      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
3435      INTEGER ::   ji, jj, jr
3436      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3437      INTEGER ::   ijpj, ij, iproc, ipr2dj
3438      !
3439      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3440      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3441
3442      !!----------------------------------------------------------------------
3443      !
3444      ijpj=4
3445      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
3446         ipr2dj = pr2dj
3447      ELSE
3448         ipr2dj = 0
3449      ENDIF
3450      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3451
3452      !
3453      ztab_e(:,:) = 0.e0
3454
3455      ij=0
3456      ! put in znorthloc_e the last 4 jlines of pt2d
3457      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3458         ij = ij + 1
3459         DO ji = 1, jpi
3460            znorthloc_e(ji,ij)=pt2d(ji,jj)
3461         END DO
3462      END DO
3463      !
3464      itaille = jpi * ( ijpj + 2 * ipr2dj )
3465      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3466         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3467      !
3468      DO jr = 1, ndim_rank_north            ! recover the global north array
3469         iproc = nrank_north(jr) + 1
3470         ildi = nldit (iproc)
3471         ilei = nleit (iproc)
3472         iilb = nimppt(iproc)
3473         DO jj = 1, ijpj+2*ipr2dj
3474            DO ji = ildi, ilei
3475               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3476            END DO
3477         END DO
3478      END DO
3479
3480
3481      ! 2. North-Fold boundary conditions
3482      ! ----------------------------------
3483      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3484
3485      ij = ipr2dj
3486      !! Scatter back to pt2d
3487      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3488      ij  = ij +1
3489         DO ji= 1, nlci
3490            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3491         END DO
3492      END DO
3493      !
3494      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3495      !
3496   END SUBROUTINE mpp_lbc_north_icb
3497
3498   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3499      !!----------------------------------------------------------------------
3500      !!                  ***  routine mpp_lnk_2d_icb  ***
3501      !!
3502      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
3503      !!
3504      !! ** Method  :   Use mppsend and mpprecv function for passing mask
3505      !!      between processors following neighboring subdomains.
3506      !!            domain parameters
3507      !!                    nlci   : first dimension of the local subdomain
3508      !!                    nlcj   : second dimension of the local subdomain
3509      !!                    jpri   : number of rows for extra outer halo
3510      !!                    jprj   : number of columns for extra outer halo
3511      !!                    nbondi : mark for "east-west local boundary"
3512      !!                    nbondj : mark for "north-south local boundary"
3513      !!                    noea   : number for local neighboring processors
3514      !!                    nowe   : number for local neighboring processors
3515      !!                    noso   : number for local neighboring processors
3516      !!                    nono   : number for local neighboring processors
3517      !!
3518      !!----------------------------------------------------------------------
3519      INTEGER                                             , INTENT(in   ) ::   jpri
3520      INTEGER                                             , INTENT(in   ) ::   jprj
3521      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3522      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3523      !                                                                                 ! = T , U , V , F , W and I points
3524      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
3525      !!                                                                                ! north boundary, =  1. otherwise
3526      INTEGER  ::   jl   ! dummy loop indices
3527      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3528      INTEGER  ::   ipreci, iprecj             ! temporary integers
3529      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3530      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3531      !!
3532      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3533      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3534      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3535      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3536      !!----------------------------------------------------------------------
3537
3538      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3539      iprecj = jprecj + jprj
3540
3541
3542      ! 1. standard boundary treatment
3543      ! ------------------------------
3544      ! Order matters Here !!!!
3545      !
3546      !                                      ! East-West boundaries
3547      !                                           !* Cyclic east-west
3548      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3549         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3550         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3551         !
3552      ELSE                                        !* closed
3553         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
3554                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
3555      ENDIF
3556      !
3557
3558      ! north fold treatment
3559      ! -----------------------
3560      IF( npolj /= 0 ) THEN
3561         !
3562         SELECT CASE ( jpni )
3563         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3564         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3565         END SELECT
3566         !
3567      ENDIF
3568
3569      ! 2. East and west directions exchange
3570      ! ------------------------------------
3571      ! we play with the neigbours AND the row number because of the periodicity
3572      !
3573      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3574      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3575         iihom = nlci-nreci-jpri
3576         DO jl = 1, ipreci
3577            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3578            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3579         END DO
3580      END SELECT
3581      !
3582      !                           ! Migrations
3583      imigr = ipreci * ( jpj + 2*jprj)
3584      !
3585      SELECT CASE ( nbondi )
3586      CASE ( -1 )
3587         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3588         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3589         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3590      CASE ( 0 )
3591         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3592         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3593         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3594         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3595         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3596         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3597      CASE ( 1 )
3598         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3599         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3600         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3601      END SELECT
3602      !
3603      !                           ! Write Dirichlet lateral conditions
3604      iihom = nlci - jpreci
3605      !
3606      SELECT CASE ( nbondi )
3607      CASE ( -1 )
3608         DO jl = 1, ipreci
3609            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3610         END DO
3611      CASE ( 0 )
3612         DO jl = 1, ipreci
3613            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3614            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3615         END DO
3616      CASE ( 1 )
3617         DO jl = 1, ipreci
3618            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3619         END DO
3620      END SELECT
3621
3622
3623      ! 3. North and south directions
3624      ! -----------------------------
3625      ! always closed : we play only with the neigbours
3626      !
3627      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3628         ijhom = nlcj-nrecj-jprj
3629         DO jl = 1, iprecj
3630            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3631            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3632         END DO
3633      ENDIF
3634      !
3635      !                           ! Migrations
3636      imigr = iprecj * ( jpi + 2*jpri )
3637      !
3638      SELECT CASE ( nbondj )
3639      CASE ( -1 )
3640         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3641         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3642         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3643      CASE ( 0 )
3644         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3645         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3646         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3647         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3648         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3649         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3650      CASE ( 1 )
3651         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3652         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3653         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3654      END SELECT
3655      !
3656      !                           ! Write Dirichlet lateral conditions
3657      ijhom = nlcj - jprecj
3658      !
3659      SELECT CASE ( nbondj )
3660      CASE ( -1 )
3661         DO jl = 1, iprecj
3662            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3663         END DO
3664      CASE ( 0 )
3665         DO jl = 1, iprecj
3666            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3667            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3668         END DO
3669      CASE ( 1 )
3670         DO jl = 1, iprecj
3671            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3672         END DO
3673      END SELECT
3674
3675   END SUBROUTINE mpp_lnk_2d_icb
3676#else
3677   !!----------------------------------------------------------------------
3678   !!   Default case:            Dummy module        share memory computing
3679   !!----------------------------------------------------------------------
3680   USE in_out_manager
3681
3682   INTERFACE mpp_sum
3683      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3684   END INTERFACE
3685   INTERFACE mpp_max
3686      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3687   END INTERFACE
3688   INTERFACE mpp_min
3689      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3690   END INTERFACE
3691   INTERFACE mpp_minloc
3692      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3693   END INTERFACE
3694   INTERFACE mpp_maxloc
3695      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3696   END INTERFACE
3697
3698   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
3699   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3700   INTEGER :: ncomm_ice
3701   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator
3702   !!----------------------------------------------------------------------
3703CONTAINS
3704
3705   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
3706      INTEGER, INTENT(in) ::   kumout
3707      lib_mpp_alloc = 0
3708   END FUNCTION lib_mpp_alloc
3709
3710   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
3711      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
3712      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
3713      CHARACTER(len=*) ::   ldname
3714      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
3715      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
3716      function_value = 0
3717      IF( .FALSE. )   ldtxt(:) = 'never done'
3718      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
3719   END FUNCTION mynode
3720
3721   SUBROUTINE mppsync                       ! Dummy routine
3722   END SUBROUTINE mppsync
3723
3724   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
3725      REAL   , DIMENSION(:) :: parr
3726      INTEGER               :: kdim
3727      INTEGER, OPTIONAL     :: kcom
3728      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
3729   END SUBROUTINE mpp_sum_as
3730
3731   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
3732      REAL   , DIMENSION(:,:) :: parr
3733      INTEGER               :: kdim
3734      INTEGER, OPTIONAL     :: kcom
3735      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
3736   END SUBROUTINE mpp_sum_a2s
3737
3738   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
3739      INTEGER, DIMENSION(:) :: karr
3740      INTEGER               :: kdim
3741      INTEGER, OPTIONAL     :: kcom
3742      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
3743   END SUBROUTINE mpp_sum_ai
3744
3745   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
3746      REAL                  :: psca
3747      INTEGER, OPTIONAL     :: kcom
3748      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
3749   END SUBROUTINE mpp_sum_s
3750
3751   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
3752      integer               :: kint
3753      INTEGER, OPTIONAL     :: kcom
3754      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
3755   END SUBROUTINE mpp_sum_i
3756
3757   SUBROUTINE mppsum_realdd( ytab, kcom )
3758      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
3759      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3760      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
3761   END SUBROUTINE mppsum_realdd
3762
3763   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
3764      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
3765      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
3766      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3767      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
3768   END SUBROUTINE mppsum_a_realdd
3769
3770   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
3771      REAL   , DIMENSION(:) :: parr
3772      INTEGER               :: kdim
3773      INTEGER, OPTIONAL     :: kcom
3774      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3775   END SUBROUTINE mppmax_a_real
3776
3777   SUBROUTINE mppmax_real( psca, kcom )
3778      REAL                  :: psca
3779      INTEGER, OPTIONAL     :: kcom
3780      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
3781   END SUBROUTINE mppmax_real
3782
3783   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
3784      REAL   , DIMENSION(:) :: parr
3785      INTEGER               :: kdim
3786      INTEGER, OPTIONAL     :: kcom
3787      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3788   END SUBROUTINE mppmin_a_real
3789
3790   SUBROUTINE mppmin_real( psca, kcom )
3791      REAL                  :: psca
3792      INTEGER, OPTIONAL     :: kcom
3793      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
3794   END SUBROUTINE mppmin_real
3795
3796   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
3797      INTEGER, DIMENSION(:) :: karr
3798      INTEGER               :: kdim
3799      INTEGER, OPTIONAL     :: kcom
3800      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3801   END SUBROUTINE mppmax_a_int
3802
3803   SUBROUTINE mppmax_int( kint, kcom)
3804      INTEGER               :: kint
3805      INTEGER, OPTIONAL     :: kcom
3806      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
3807   END SUBROUTINE mppmax_int
3808
3809   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
3810      INTEGER, DIMENSION(:) :: karr
3811      INTEGER               :: kdim
3812      INTEGER, OPTIONAL     :: kcom
3813      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3814   END SUBROUTINE mppmin_a_int
3815
3816   SUBROUTINE mppmin_int( kint, kcom )
3817      INTEGER               :: kint
3818      INTEGER, OPTIONAL     :: kcom
3819      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
3820   END SUBROUTINE mppmin_int
3821
3822   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
3823      REAL                   :: pmin
3824      REAL , DIMENSION (:,:) :: ptab, pmask
3825      INTEGER :: ki, kj
3826      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
3827   END SUBROUTINE mpp_minloc2d
3828
3829   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
3830      REAL                     :: pmin
3831      REAL , DIMENSION (:,:,:) :: ptab, pmask
3832      INTEGER :: ki, kj, kk
3833      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3834   END SUBROUTINE mpp_minloc3d
3835
3836   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
3837      REAL                   :: pmax
3838      REAL , DIMENSION (:,:) :: ptab, pmask
3839      INTEGER :: ki, kj
3840      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
3841   END SUBROUTINE mpp_maxloc2d
3842
3843   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
3844      REAL                     :: pmax
3845      REAL , DIMENSION (:,:,:) :: ptab, pmask
3846      INTEGER :: ki, kj, kk
3847      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3848   END SUBROUTINE mpp_maxloc3d
3849
3850   SUBROUTINE mppstop
3851      STOP      ! non MPP case, just stop the run
3852   END SUBROUTINE mppstop
3853
3854   SUBROUTINE mpp_ini_ice( kcom, knum )
3855      INTEGER :: kcom, knum
3856      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
3857   END SUBROUTINE mpp_ini_ice
3858
3859   SUBROUTINE mpp_ini_znl( knum )
3860      INTEGER :: knum
3861      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
3862   END SUBROUTINE mpp_ini_znl
3863
3864   SUBROUTINE mpp_comm_free( kcom )
3865      INTEGER :: kcom
3866      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
3867   END SUBROUTINE mpp_comm_free
3868#endif
3869
3870   !!----------------------------------------------------------------------
3871   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
3872   !!----------------------------------------------------------------------
3873
3874   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
3875      &                 cd6, cd7, cd8, cd9, cd10 )
3876      !!----------------------------------------------------------------------
3877      !!                  ***  ROUTINE  stop_opa  ***
3878      !!
3879      !! ** Purpose :   print in ocean.outpput file a error message and
3880      !!                increment the error number (nstop) by one.
3881      !!----------------------------------------------------------------------
3882      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3883      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3884      !!----------------------------------------------------------------------
3885      !
3886      nstop = nstop + 1
3887      IF(lwp) THEN
3888         WRITE(numout,cform_err)
3889         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
3890         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
3891         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
3892         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
3893         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
3894         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
3895         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
3896         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
3897         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
3898         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
3899      ENDIF
3900                               CALL FLUSH(numout    )
3901      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
3902      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
3903      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
3904      !
3905      IF( cd1 == 'MPPSTOP' ) THEN
3906         IF(lwp) WRITE(numout,*)  'E R R O R: Calling mppstop'
3907         CALL mppstop()
3908      ENDIF
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         CALL ctl_stop ('STOP', 'NEMO abort 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=4)                 ::   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, '(I4.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 n