source: branches/2011/DEV_r2739_STFC_dCSE/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 3849

Last change on this file since 3849 was 3849, checked in by trackstand2, 8 years ago

Merge branch 'partitioner'

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