source: branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6052

Last change on this file since 6052 was 6052, checked in by mcastril, 5 years ago

Added routines in lbclnk to run in serial mode

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