New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_mpp.F90 in branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8165

Last change on this file since 8165 was 7753, checked in by mocavero, 7 years ago

Reverting trunk to remove OpenMP

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