source: branches/2013/dev_r3948_CMCC_NorthFold_Opt/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4021

Last change on this file since 4021 was 4021, checked in by epico, 8 years ago

performance optimization in the north fold routines. See Ticket #1150 for details

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