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

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

source: branches/r6232_hadgem3_cplfld/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7462

Last change on this file since 7462 was 7462, checked in by jcastill, 7 years ago

Remove svn keys

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