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

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6918

Last change on this file since 6918 was 6918, checked in by flavoni, 8 years ago

#1763, commit in trunk, same of 3_6_STABLE, line over 132 chars

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