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

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

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, 11 years ago

Merge branch 'partitioner'

  • Property svn:keywords set to Id
File size: 129.0 KB
RevLine 
[3]1MODULE lib_mpp
[13]2   !!======================================================================
3   !!                       ***  MODULE  lib_mpp  ***
[1344]4   !! Ocean numerics:  massively parallel processing library
[13]5   !!=====================================================================
[1344]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
[1345]19   !!            3.2  !  2009  (O. Marti)    add mpp_ini_znl
[2715]20   !!            4.0  !  2011  (G. Madec)  move ctl_ routines from in_out_manager
[13]21   !!----------------------------------------------------------------------
[2715]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   !!----------------------------------------------------------------------
[1344]29#if   defined key_mpp_mpi 
[13]30   !!----------------------------------------------------------------------
[1344]31   !!   'key_mpp_mpi'             MPI massively parallel processing library
32   !!----------------------------------------------------------------------
[2715]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)
[473]36   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
[2715]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
[1344]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
[13]53   !!----------------------------------------------------------------------
[2715]54   USE dom_oce        ! ocean space and time domain
55   USE lbcnfd         ! north fold treatment
56   USE in_out_manager ! I/O manager
[3]57
[13]58   IMPLICIT NONE
[415]59   PRIVATE
[1344]60   
[2715]61   PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn
[1344]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
[1528]66   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl
[3432]67   PUBLIC   mppsize, MAX_FACTORS, nxfactors, xfactors, nyfactors, yfactors
[2715]68   PUBLIC   lib_mpp_alloc   ! Called in nemogcm.F90
[415]69
[13]70   !! * Interfaces
71   !! define generic interface for these routine as they are called sometimes
[1344]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
[13]74   INTERFACE mpp_min
75      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
76   END INTERFACE
77   INTERFACE mpp_max
[681]78      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]79   END INTERFACE
80   INTERFACE mpp_sum
[2304]81# if defined key_mpp_rep
[1976]82      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
83                       mppsum_realdd, mppsum_a_realdd
84# else
[13]85      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
[1976]86# endif
[13]87   END INTERFACE
88   INTERFACE mpp_lbc_north
89      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
90   END INTERFACE
[1344]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
[1976]97   
[51]98   !! ========================= !!
99   !!  MPI  variable definition !!
100   !! ========================= !!
[1629]101!$AGRIF_DO_NOT_TREAT
[2004]102   INCLUDE 'mpif.h'
[1629]103!$AGRIF_END_DO_NOT_TREAT
[1344]104   
105   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
[3]106
[1344]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 ]
[2363]111!$AGRIF_DO_NOT_TREAT
[2249]112   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
[2363]113!$AGRIF_END_DO_NOT_TREAT
[3]114
[2480]115# if defined key_mpp_rep
116   INTEGER :: MPI_SUMDD
117# endif
[1976]118
[869]119   ! variables used in case of sea-ice
[1344]120   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice
[1345]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
[2715]124   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_ice     ! dimension ndim_rank_ice
[1345]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
[3211]131   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_znl  ! dimension ndim_rank_znl,
132   !                                                        ! number of the procs into the same znl domain
[1344]133   
134   ! North fold condition in mpp_mpi with jpni > 1
135   INTEGER ::   ngrp_world        ! group ID for the world processors
[1345]136   INTEGER ::   ngrp_opa          ! group ID for the opa processors
[1344]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
[2715]142   INTEGER, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   ! dimension ndim_rank_north
[3]143
[1344]144   ! Type of send : standard, buffered, immediate
[1601]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')
[1344]147   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend
[3432]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
[3849]159   LOGICAL, SAVE, PUBLIC                 :: nn_readpart = .FALSE. ! Whether to read partition from
160                                                            ! file (1) or not (0)
[2715]161   REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon  ! buffer in case of bsend
[3]162
[1344]163   ! message passing arrays
[2715]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
[3211]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
[51]203   !!----------------------------------------------------------------------
[2287]204   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
[888]205   !! $Id$
[2715]206   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
[1344]207   !!----------------------------------------------------------------------
[3]208CONTAINS
209
[2715]210   INTEGER FUNCTION lib_mpp_alloc( kumout )
[51]211      !!----------------------------------------------------------------------
[2715]212      !!              ***  routine lib_mpp_alloc  ***
213      !!----------------------------------------------------------------------
214      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
215      !!----------------------------------------------------------------------
216      !
[3432]217      ALLOCATE( &
218#if !defined key_mpp_rkpart
219                t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) ,                                            &
[2715]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)   ,                                            &
[3432]228#endif
[2715]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      !!----------------------------------------------------------------------
[51]253      !!                  ***  routine mynode  ***
254      !!                   
255      !! ** Purpose :   Find processor unit
256      !!----------------------------------------------------------------------
[1579]257      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
[2715]258      INTEGER                      , INTENT(in   ) ::   kumnam       ! namelist logical unit
259      INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator
[1579]260      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
[2715]261      !
[2481]262      INTEGER ::   mynode, ierr, code, ji, ii
[532]263      LOGICAL ::   mpi_was_called
[2715]264      !
[3432]265      NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, &
[3849]266                       nn_readpart, nn_xfactors, nn_yfactors,     &
267                       nn_pttrim, nn_cpnode
[51]268      !!----------------------------------------------------------------------
[1344]269      !
[2481]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
[1344]274      !
[2715]275      jpni = -1; jpnj = -1; jpnij = -1
276      REWIND( kumnam )               ! Namelist namrun : parameters of the run
277      READ  ( kumnam, nammpp )
[1344]278      !                              ! control print
[2481]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
[3432]282      WRITE(ldtxt(ii),*) '      whether to trim dry points         nn_pttrim   = ', nn_pttrim     ;   ii = ii + 1
[3837]283      WRITE(ldtxt(ii),*) '      number of cores per compute node   nn_cpnode   = ', nn_cpnode     ;   ii = ii + 1
[2731]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
[2715]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
[3432]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
[2480]350      CALL mpi_initialized ( mpi_was_called, code )
351      IF( code /= MPI_SUCCESS ) THEN
[2481]352         DO ji = 1, SIZE(ldtxt) 
353            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
354         END DO         
[2480]355         WRITE(*, cform_err)
356         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
357         CALL mpi_abort( mpi_comm_world, code, ierr )
358      ENDIF
[415]359
[2480]360      IF( mpi_was_called ) THEN
361         !
362         SELECT CASE ( cn_mpi_send )
363         CASE ( 'S' )                ! Standard mpi send (blocking)
[2481]364            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
[2480]365         CASE ( 'B' )                ! Buffer mpi send (blocking)
[2481]366            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
367            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr ) 
[2480]368         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[2481]369            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
[2480]370            l_isend = .TRUE.
371         CASE DEFAULT
[2481]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
[2715]374            kstop = kstop + 1
[2480]375         END SELECT
376      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
[2481]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
[2715]379         kstop = kstop + 1
[532]380      ELSE
[1601]381         SELECT CASE ( cn_mpi_send )
[524]382         CASE ( 'S' )                ! Standard mpi send (blocking)
[2481]383            WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'                     ;   ii = ii + 1
[2480]384            CALL mpi_init( ierr )
[524]385         CASE ( 'B' )                ! Buffer mpi send (blocking)
[2481]386            WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'                      ;   ii = ii + 1
387            IF( Agrif_Root() )   CALL mpi_init_opa( ldtxt, ii, ierr )
[524]388         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[2481]389            WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'                   ;   ii = ii + 1
[524]390            l_isend = .TRUE.
[2480]391            CALL mpi_init( ierr )
[524]392         CASE DEFAULT
[2481]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
[2715]395            kstop = kstop + 1
[524]396         END SELECT
[2480]397         !
[415]398      ENDIF
[570]399
[2480]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
[2481]407            DO ji = 1, SIZE(ldtxt) 
408               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
409            END DO
[2480]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
[1344]416      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
417      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
[629]418      mynode = mpprank
[2480]419      !
[3432]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
[2304]424#if defined key_mpp_rep
[1976]425      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
426#endif
427      !
[51]428   END FUNCTION mynode
[3]429
430
[3432]431   SUBROUTINE mpp_lnk_3d( ptab3d, cd_type, psgn, cd_mpp, pval, lzero )
[51]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      !!----------------------------------------------------------------------
[3211]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)
[1344]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)
[3432]462      LOGICAL         , OPTIONAL      , INTENT(in   ) ::   lzero    ! Whether to zero field at closed boundaries
[1344]463      !!
[1718]464      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
[1344]465      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
466      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
[888]467      REAL(wp) ::   zland
[1344]468      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
[3432]469      LOGICAL  ::   lzeroarg
[51]470      !!----------------------------------------------------------------------
[3]471
[3432]472#if defined key_mpp_rkpart
[3837]473      CALL ctl_stop('STOP', &
474                    'mpp_lnk_3d: should not have been called when key_mpp_rkpart defined!')
[3432]475      RETURN
476#endif
477      ! Deal with optional routine arguments
478      lzeroarg = .TRUE.
479      IF( PRESENT(lzero) ) lzeroarg = lzero
480
[1344]481      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
482      ELSE                         ;   zland = 0.e0      ! zero by default
483      ENDIF
484
[51]485      ! 1. standard boundary treatment
486      ! ------------------------------
[1718]487      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
[1344]488         !
[3211]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
[1718]494         DO jk = 1, jpk
495            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
[3211]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)
[1718]500            END DO
[3211]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
[1718]506            DO ji = nlci+1, jpi                 ! added column(s) (full)
[3211]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)
[1718]511            END DO
[610]512         END DO
[1344]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
[3211]519            ptab3d( 1 ,:,:) = ptab3d(jpim1,:,:)
520            ptab3d(jpi,:,:) = ptab3d(  2  ,:,:)
[1344]521         ELSE                                     !* closed
[3432]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
[473]526         ENDIF
[1344]527         !                                   ! North-South boundaries (always closed)
[3432]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
[1344]532         !
[51]533      ENDIF
[3]534
[51]535      ! 2. East and west directions exchange
536      ! ------------------------------------
[1344]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)
[51]541         iihom = nlci-nreci
542         DO jl = 1, jpreci
[3211]543            t3ew(:,jl,:,1) = ptab3d(jpreci+jl,:,:)
544            t3we(:,jl,:,1) = ptab3d(iihom +jl,:,:)
[51]545         END DO
[1345]546      END SELECT 
[1344]547      !
548      !                           ! Migrations
[51]549      imigr = jpreci * jpj * jpk
[1344]550      !
[51]551      SELECT CASE ( nbondi ) 
552      CASE ( -1 )
[181]553         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
[51]554         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
[300]555         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]556      CASE ( 0 )
[181]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 )
[51]559         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
560         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
[300]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)
[51]563      CASE ( 1 )
[181]564         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
[51]565         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
[300]566         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]567      END SELECT
[1344]568      !
569      !                           ! Write Dirichlet lateral conditions
[51]570      iihom = nlci-jpreci
[1344]571      !
[51]572      SELECT CASE ( nbondi )
573      CASE ( -1 )
574         DO jl = 1, jpreci
[3211]575            ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2)
[51]576         END DO
577      CASE ( 0 ) 
578         DO jl = 1, jpreci
[3211]579            ptab3d(jl      ,:,:) = t3we(:,jl,:,2)
580            ptab3d(iihom+jl,:,:) = t3ew(:,jl,:,2)
[51]581         END DO
582      CASE ( 1 )
583         DO jl = 1, jpreci
[3211]584            ptab3d(jl      ,:,:) = t3we(:,jl,:,2)
[51]585         END DO
586      END SELECT
[3]587
588
[51]589      ! 3. North and south directions
590      ! -----------------------------
[1344]591      ! always closed : we play only with the neigbours
592      !
593      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[51]594         ijhom = nlcj-nrecj
595         DO jl = 1, jprecj
[3211]596            t3sn(:,jl,:,1) = ptab3d(:,ijhom +jl,:)
597            t3ns(:,jl,:,1) = ptab3d(:,jprecj+jl,:)
[51]598         END DO
599      ENDIF
[1344]600      !
601      !                           ! Migrations
[51]602      imigr = jprecj * jpi * jpk
[1344]603      !
[51]604      SELECT CASE ( nbondj )     
605      CASE ( -1 )
[181]606         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
[51]607         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
[300]608         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]609      CASE ( 0 )
[181]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 )
[51]612         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
613         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
[300]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)
[51]616      CASE ( 1 ) 
[181]617         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
[51]618         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
[300]619         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]620      END SELECT
[1344]621      !
622      !                           ! Write Dirichlet lateral conditions
[51]623      ijhom = nlcj-jprecj
[1344]624      !
[51]625      SELECT CASE ( nbondj )
626      CASE ( -1 )
627         DO jl = 1, jprecj
[3211]628            ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2)
[51]629         END DO
630      CASE ( 0 ) 
631         DO jl = 1, jprecj
[3211]632            ptab3d(:,jl      ,:) = t3sn(:,jl,:,2)
633            ptab3d(:,ijhom+jl,:) = t3ns(:,jl,:,2)
[51]634         END DO
635      CASE ( 1 )
636         DO jl = 1, jprecj
[3211]637            ptab3d(:,jl,:) = t3sn(:,jl,:,2)
[51]638         END DO
639      END SELECT
[3]640
641
[51]642      ! 4. north fold treatment
643      ! -----------------------
[1344]644      !
645      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
646         !
647         SELECT CASE ( jpni )
[3211]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.
[1344]650         END SELECT
651         !
[473]652      ENDIF
[1344]653      !
[51]654   END SUBROUTINE mpp_lnk_3d
[3]655
656
[3432]657   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval, lzero )
[51]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      !!----------------------------------------------------------------------
[1344]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)
[3432]683      LOGICAL         , OPTIONAL  , INTENT(in   ) ::   lzero    ! Whether to zero field at closed boundaries
[1344]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
[888]688      REAL(wp) ::   zland
[1344]689      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
[3432]690      LOGICAL  ::   lzeroarg
[51]691      !!----------------------------------------------------------------------
[3]692
[3432]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
[1344]702      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
703      ELSE                         ;   zland = 0.e0      ! zero by default
[888]704      ENDIF
705
[51]706      ! 1. standard boundary treatment
707      ! ------------------------------
[1344]708      !
[1718]709      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
[1344]710         !
[1718]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)
[610]716         END DO
[1718]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)
[1344]721         END DO
722         !
723      ELSE                              ! standard close or cyclic treatment
724         !
725         !                                   ! East-West boundaries
726         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
[473]727            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[1344]728            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
729            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
730         ELSE                                     ! closed
[3432]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
[473]735         ENDIF
[1344]736         !                                   ! North-South boundaries (always closed)
[3432]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
[1344]741         !
[51]742      ENDIF
[3]743
[1344]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)
[51]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
[1344]756      !
757      !                           ! Migrations
[51]758      imigr = jpreci * jpj
[1344]759      !
[51]760      SELECT CASE ( nbondi )
761      CASE ( -1 )
[181]762         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
[51]763         CALL mpprecv( 1, t2ew(1,1,2), imigr )
[300]764         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]765      CASE ( 0 )
[181]766         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
767         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
[51]768         CALL mpprecv( 1, t2ew(1,1,2), imigr )
769         CALL mpprecv( 2, t2we(1,1,2), imigr )
[300]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)
[51]772      CASE ( 1 )
[181]773         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
[51]774         CALL mpprecv( 2, t2we(1,1,2), imigr )
[300]775         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]776      END SELECT
[1344]777      !
778      !                           ! Write Dirichlet lateral conditions
[51]779      iihom = nlci - jpreci
[1344]780      !
[51]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
[3]796
797
[51]798      ! 3. North and south directions
799      ! -----------------------------
[1344]800      ! always closed : we play only with the neigbours
801      !
802      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[51]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
[1344]809      !
810      !                           ! Migrations
[51]811      imigr = jprecj * jpi
[1344]812      !
[51]813      SELECT CASE ( nbondj )
814      CASE ( -1 )
[181]815         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
[51]816         CALL mpprecv( 3, t2ns(1,1,2), imigr )
[300]817         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]818      CASE ( 0 )
[181]819         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
820         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
[51]821         CALL mpprecv( 3, t2ns(1,1,2), imigr )
822         CALL mpprecv( 4, t2sn(1,1,2), imigr )
[300]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)
[51]825      CASE ( 1 )
[181]826         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
[51]827         CALL mpprecv( 4, t2sn(1,1,2), imigr )
[300]828         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]829      END SELECT
[1344]830      !
831      !                           ! Write Dirichlet lateral conditions
[51]832      ijhom = nlcj - jprecj
[1344]833      !
[51]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
[1344]848      END SELECT
[3]849
[1344]850
[51]851      ! 4. north fold treatment
852      ! -----------------------
[1344]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         !
[473]861      ENDIF
[1344]862      !
[51]863   END SUBROUTINE mpp_lnk_2d
[3]864
865
[473]866   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
867      !!----------------------------------------------------------------------
868      !!                  ***  routine mpp_lnk_3d_gather  ***
869      !!
[3211]870      !! ** Purpose :   Message passing management for two 3D arrays
[473]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      !!----------------------------------------------------------------------
[3211]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)
[1344]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
[473]902      !!----------------------------------------------------------------------
903
904      ! 1. standard boundary treatment
905      ! ------------------------------
[1344]906      !                                      ! East-West boundaries
907      !                                           !* Cyclic east-west
908      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]909         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
910         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
911         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
912         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
[1344]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
[473]918      ENDIF
919
[1344]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
[473]926
927
928      ! 2. East and west directions exchange
929      ! ------------------------------------
[1344]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)
[473]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
[1344]942      !
943      !                           ! Migrations
[473]944      imigr = jpreci * jpj * jpk *2
[1344]945      !
[473]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
[1344]963      !
964      !                           ! Write Dirichlet lateral conditions
965      iihom = nlci - jpreci
966      !
[473]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      ! -----------------------------
[1344]990      ! always closed : we play only with the neigbours
991      !
992      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
993         ijhom = nlcj - nrecj
[473]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
[1344]1001      !
1002      !                           ! Migrations
[473]1003      imigr = jprecj * jpi * jpk * 2
[1344]1004      !
[473]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
[1344]1022      !
1023      !                           ! Write Dirichlet lateral conditions
1024      ijhom = nlcj - jprecj
1025      !
[473]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      ! -----------------------
[1344]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      !
[473]1062   END SUBROUTINE mpp_lnk_3d_gather
1063
1064
[311]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      !!----------------------------------------------------------------------
[1344]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      !!----------------------------------------------------------------------
[311]1097
[1344]1098      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area
[311]1099      iprecj = jprecj + jpr2dj
1100
1101
1102      ! 1. standard boundary treatment
1103      ! ------------------------------
[1344]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      !
[311]1121
[1344]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         !
[311]1131      ENDIF
1132
[1344]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)
[311]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
[1344]1145      !
1146      !                           ! Migrations
[311]1147      imigr = ipreci * ( jpj + 2*jpr2dj)
[1344]1148      !
[311]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
[1344]1166      !
1167      !                           ! Write Dirichlet lateral conditions
[311]1168      iihom = nlci - jpreci
[1344]1169      !
[311]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      ! -----------------------------
[1344]1189      ! always closed : we play only with the neigbours
1190      !
1191      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
[311]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
[1344]1198      !
1199      !                           ! Migrations
[311]1200      imigr = iprecj * ( jpi + 2*jpr2di )
[1344]1201      !
[311]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
[1344]1219      !
1220      !                           ! Write Dirichlet lateral conditions
[311]1221      ijhom = nlcj - jprecj 
[1344]1222      !
[311]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
[1344]1237      END SELECT
[311]1238
1239   END SUBROUTINE mpp_lnk_2d_e
1240
1241
[1344]1242   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
[51]1243      !!----------------------------------------------------------------------
1244      !!                  ***  routine mppsend  ***
1245      !!                   
[3211]1246      !! ** Purpose :   Send message passing array
[51]1247      !!
1248      !!----------------------------------------------------------------------
[1344]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
[51]1256      !!----------------------------------------------------------------------
[1344]1257      !
[1601]1258      SELECT CASE ( cn_mpi_send )
[300]1259      CASE ( 'S' )                ! Standard mpi send (blocking)
[1344]1260         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
[300]1261      CASE ( 'B' )                ! Buffer mpi send (blocking)
[1344]1262         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
[300]1263      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
[1344]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 )
[300]1266      END SELECT
[1344]1267      !
[51]1268   END SUBROUTINE mppsend
[3]1269
1270
[51]1271   SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1272      !!----------------------------------------------------------------------
1273      !!                  ***  routine mpprecv  ***
1274      !!
1275      !! ** Purpose :   Receive messag passing array
1276      !!
1277      !!----------------------------------------------------------------------
[1344]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      !!
[51]1282      INTEGER :: istatus(mpi_status_size)
1283      INTEGER :: iflag
[1344]1284      !!----------------------------------------------------------------------
1285      !
1286      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1287      !
[51]1288   END SUBROUTINE mpprecv
[3]1289
1290
[51]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      !!
[1344]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
[51]1302      !!
[1344]1303      INTEGER :: itaille, ierror   ! temporary integer
[51]1304      !!---------------------------------------------------------------------
[1344]1305      !
1306      itaille = jpi * jpj
1307      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
[532]1308         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
[1344]1309      !
[51]1310   END SUBROUTINE mppgather
[3]1311
1312
[51]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
[1344]1324      !!
1325      INTEGER :: itaille, ierror   ! temporary integer
[51]1326      !!---------------------------------------------------------------------
[1344]1327      !
[51]1328      itaille=jpi*jpj
[1344]1329      !
1330      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1331         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1332      !
[51]1333   END SUBROUTINE mppscatter
[3]1334
1335
[869]1336   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
[681]1337      !!----------------------------------------------------------------------
1338      !!                  ***  routine mppmax_a_int  ***
1339      !!
1340      !! ** Purpose :   Find maximum value in an integer layout array
1341      !!
1342      !!----------------------------------------------------------------------
[1344]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
[681]1348      INTEGER, DIMENSION(kdim) ::   iwork
[1344]1349      !!----------------------------------------------------------------------
1350      !
[869]1351      localcomm = mpi_comm_opa
[1344]1352      IF( PRESENT(kcom) )   localcomm = kcom
1353      !
1354      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1355      !
[681]1356      ktab(:) = iwork(:)
[1344]1357      !
[681]1358   END SUBROUTINE mppmax_a_int
1359
1360
[869]1361   SUBROUTINE mppmax_int( ktab, kcom )
[681]1362      !!----------------------------------------------------------------------
1363      !!                  ***  routine mppmax_int  ***
1364      !!
[1344]1365      !! ** Purpose :   Find maximum value in an integer layout array
[681]1366      !!
1367      !!----------------------------------------------------------------------
[1344]1368      INTEGER, INTENT(inout)           ::   ktab      ! ???
1369      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1370      !!
1371      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1372      !!----------------------------------------------------------------------
1373      !
[869]1374      localcomm = mpi_comm_opa 
[1344]1375      IF( PRESENT(kcom) )   localcomm = kcom
1376      !
1377      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1378      !
[681]1379      ktab = iwork
[1344]1380      !
[681]1381   END SUBROUTINE mppmax_int
1382
1383
[869]1384   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
[51]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
[888]1393      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
[1344]1394      !!
1395      INTEGER ::   ierror, localcomm   ! temporary integer
[51]1396      INTEGER, DIMENSION(kdim) ::   iwork
[1344]1397      !!----------------------------------------------------------------------
1398      !
[869]1399      localcomm = mpi_comm_opa
[1344]1400      IF( PRESENT(kcom) )   localcomm = kcom
1401      !
1402      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1403      !
[51]1404      ktab(:) = iwork(:)
[1344]1405      !
[51]1406   END SUBROUTINE mppmin_a_int
[3]1407
[13]1408
[1345]1409   SUBROUTINE mppmin_int( ktab, kcom )
[51]1410      !!----------------------------------------------------------------------
1411      !!                  ***  routine mppmin_int  ***
1412      !!
[1344]1413      !! ** Purpose :   Find minimum value in an integer layout array
[51]1414      !!
1415      !!----------------------------------------------------------------------
1416      INTEGER, INTENT(inout) ::   ktab      ! ???
[1345]1417      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
[1344]1418      !!
[1345]1419      INTEGER ::  ierror, iwork, localcomm
[1344]1420      !!----------------------------------------------------------------------
1421      !
[1345]1422      localcomm = mpi_comm_opa
1423      IF( PRESENT(kcom) )   localcomm = kcom
[1344]1424      !
[1345]1425     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1426      !
[51]1427      ktab = iwork
[1344]1428      !
[51]1429   END SUBROUTINE mppmin_int
[3]1430
[13]1431
[51]1432   SUBROUTINE mppsum_a_int( ktab, kdim )
1433      !!----------------------------------------------------------------------
1434      !!                  ***  routine mppsum_a_int  ***
1435      !!                   
[1344]1436      !! ** Purpose :   Global integer sum, 1D array case
[51]1437      !!
1438      !!----------------------------------------------------------------------
[1344]1439      INTEGER, INTENT(in   )                   ::   kdim      ! ???
[51]1440      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
[1344]1441      !!
[51]1442      INTEGER :: ierror
1443      INTEGER, DIMENSION (kdim) ::  iwork
[1344]1444      !!----------------------------------------------------------------------
1445      !
1446      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1447      !
[51]1448      ktab(:) = iwork(:)
[1344]1449      !
[51]1450   END SUBROUTINE mppsum_a_int
[3]1451
[13]1452
[1344]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
[3]1470
[13]1471
[1344]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
[3]1494
1495
[1344]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
[13]1517
[3]1518
[1344]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
[3]1541
1542
[1344]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
[13]1565
[3]1566
[1344]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
[869]1590
[3]1591
[1344]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
[3]1613
[2304]1614# if defined key_mpp_rep
[1976]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
[3]1625
[1976]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   
[1344]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
[13]1706
[3]1707
[3211]1708   SUBROUTINE mpp_minloc3d( ptab3d, pmask3d, pmin, ki, kj ,kk)
[1344]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      !!--------------------------------------------------------------------------
[3211]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)
[1344]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      !
[3211]1734      zmin  = MINVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1735      ilocs = MINLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
[1344]1736      !
[3211]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
[1344]1743      ki = ilocs(1) + nimpp - 1
1744      kj = ilocs(2) + njmpp - 1
1745      kk = ilocs(3)
[3211]1746#endif
[1344]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
[13]1759
[3]1760
[1344]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
[3]1798
[13]1799
[3211]1800   SUBROUTINE mpp_maxloc3d( ptab3d, pmask3d, pmax, ki, kj, kk )
[1344]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      !!--------------------------------------------------------------------------
[3211]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
[1344]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      !
[3211]1826      zmax  = MAXVAL( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
1827      ilocs = MAXLOC( ptab3d(:,:,:) , mask= pmask3d == 1.e0 )
[1344]1828      !
[3211]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
[1344]1835      ki = ilocs(1) + nimpp - 1
1836      kj = ilocs(2) + njmpp - 1
1837      kk = ilocs(3)
[3211]1838#endif
[1344]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
[3]1851
[869]1852
[1344]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
[3]1866
1867
[1344]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 )
[3432]1880      STOP
[1344]1881      !
1882   END SUBROUTINE mppstop
[3]1883
1884
[2715]1885   SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
[1344]1886      !!----------------------------------------------------------------------
1887      !!                  ***  routine mppobc  ***
1888      !!
[3211]1889      !! ** Purpose :   Message passing management for open boundary
[1344]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      !!----------------------------------------------------------------------
[2715]1905      USE wrk_nemo, ONLY:   wrk_in_use, wrk_not_released
[3211]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
[2715]1909      !
[1344]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
[2715]1916      INTEGER , INTENT(in   )                     ::   kumout     ! ocean.output logical unit
[1344]1917      REAL(wp), INTENT(inout), DIMENSION(kij,kk)  ::   ptab       ! variable array
[2715]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   !   -       -
[1344]1923      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend
1924      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend
1925      !!----------------------------------------------------------------------
[3]1926
[2715]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
[1344]1933      ! boundary condition initialization
1934      ! ---------------------------------
[3211]1935      ztab2d(:,:) = 0.e0
[1344]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
[2715]1950         WRITE(kumout, cform_err)
1951         WRITE(kumout,*) 'mppobc : bad ktype'
1952         CALL mppstop
[1344]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
[3211]1965                  ztab2d(ji,jj) = ptab(ji,jk)
[1344]1966               END DO
1967            END DO
1968         ELSEIF( ktype == 2 ) THEN                           ! east/west boundaries
1969            DO jj = ijpt0, ijpt1
1970               DO ji = iipt0, iipt1
[3211]1971                  ztab2d(ji,jj) = ptab(jj,jk)
[1344]1972               END DO
1973            END DO
1974         ENDIF
[13]1975
[3]1976
[1344]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
[3211]1983               t2ew(:,jl,1) = ztab2d(jpreci+jl,:)
1984               t2we(:,jl,1) = ztab2d(iihom +jl,:)
[1344]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
[3211]2013               ztab2d(jl,:) = t2we(:,jl,2)
[1344]2014            END DO
2015         ENDIF
2016         IF( nbondi == -1 .OR. nbondi == 0 ) THEN
2017            DO jl = 1, jpreci
[3211]2018               ztab2d(iihom+jl,:) = t2ew(:,jl,2)
[1344]2019            END DO
2020         ENDIF
[3]2021
2022
[1344]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
[3211]2029               t2sn(:,jl,1) = ztab2d(:,ijhom +jl)
2030               t2ns(:,jl,1) = ztab2d(:,jprecj+jl)
[1344]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
[3211]2058               ztab2d(:,jl) = t2sn(:,jl,2)
[1344]2059            END DO
2060         ENDIF
2061         IF( nbondj == 0 .OR. nbondj == -1 ) THEN
2062            DO jl = 1, jprecj
[3211]2063               ztab2d(:,ijhom+jl) = t2ns(:,jl,2)
[1344]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
[3211]2069                  ptab(ji,jk) = ztab2d(ji,jj) 
[1344]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
[3211]2075                  ptab(jj,jk) = ztab2d(ji,jj) 
[1344]2076               END DO
2077            END DO
2078         ENDIF
2079         !
2080      END DO
2081      !
[2715]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      !
[1344]2088   END SUBROUTINE mppobc
2089   
[13]2090
[1344]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
[3]2102
[869]2103
[2715]2104   SUBROUTINE mpp_ini_ice( pindic, kumout )
[1344]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      !!----------------------------------------------------------------------
[2715]2126      INTEGER, INTENT(in) ::   pindic
2127      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
[1344]2128      !!
2129      INTEGER :: jjproc
[2715]2130      INTEGER :: ii, ierr
2131      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2132      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
[1344]2133      !!----------------------------------------------------------------------
2134      !
[2715]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
[1344]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 )         
[3]2154
[1344]2155      ! Allocate the right size to nrank_north
[1441]2156      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
[1344]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
[1208]2167
[1344]2168      ! Create the world group
2169      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
[869]2170
[1344]2171      ! Create the ice group from the world group
2172      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
[869]2173
[1344]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 )
[869]2176
[1344]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      !
[2715]2181      DEALLOCATE(kice, zwork)
2182      !
[1344]2183   END SUBROUTINE mpp_ini_ice
[869]2184
2185
[2715]2186   SUBROUTINE mpp_ini_znl( kumout )
[1345]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      !!----------------------------------------------------------------------
[2715]2205      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
[1345]2206      !
[2715]2207      INTEGER :: jproc      ! dummy loop integer
2208      INTEGER :: ierr, ii   ! local integer
2209      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2210      !!----------------------------------------------------------------------
[1345]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      !
[2715]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
[1345]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
[1441]2241         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]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
[2715]2281      DEALLOCATE(kwork)
2282
[1345]2283   END SUBROUTINE mpp_ini_znl
2284
2285
[1344]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      !
[3837]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
[1344]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
[1441]2328      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
[1344]2329      ALLOCATE( nrank_north(ndim_rank_north) )
[869]2330
[1344]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
[869]2351
2352
[1344]2353   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
[51]2354      !!---------------------------------------------------------------------
2355      !!                   ***  routine mpp_lbc_north_3d  ***
2356      !!
[1344]2357      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2358      !!              in mpp configuration in case of jpn1 > 1
[51]2359      !!
[1344]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.
[51]2365      !!
2366      !!----------------------------------------------------------------------
[3211]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)
[1344]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
[51]2378      !!----------------------------------------------------------------------
[1344]2379      !   
2380      ijpj   = 4
2381      ijpjm1 = 3
[2480]2382      ztab(:,:,:) = 0.e0
[1344]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
[3]2417
2418
[1344]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
[2715]2445      ztab_2d(:,:) = 0.e0
[1344]2446      !
[2715]2447      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc_2d the last 4 jlines of pt2d
[1344]2448         ij = jj - nlcj + ijpj
[2715]2449         znorthloc_2d(:,ij) = pt2d(:,jj)
[1344]2450      END DO
[3]2451
[2715]2452      !                                     ! Build in procs of ncomm_north the znorthgloio_2d
[1344]2453      itaille = jpi * ijpj
[2715]2454      CALL MPI_ALLGATHER( znorthloc_2d  , itaille, MPI_DOUBLE_PRECISION,        &
2455         &                znorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[1344]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
[2715]2464               ztab_2d(ji+iilb-1,jj) = znorthgloio_2d(ji,jj,jr)
[13]2465            END DO
2466         END DO
[1344]2467      END DO
2468      !
[2715]2469      CALL lbc_nfd( ztab_2d, cd_type, psgn )   ! North fold boundary condition
[1344]2470      !
2471      !
2472      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
[13]2473         ij = jj - nlcj + ijpj
[1344]2474         DO ji = 1, nlci
[2715]2475            pt2d(ji,jj) = ztab_2d(ji+nimpp-1,ij)
[1344]2476         END DO
[13]2477      END DO
[1344]2478      !
[13]2479   END SUBROUTINE mpp_lbc_north_2d
[3]2480
2481
[1344]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
[2715]2508      ztab_e(:,:) = 0.e0
[311]2509
[1344]2510      ij=0
[2715]2511      ! put in znorthloc_e the last 4 jlines of pt2d
[1344]2512      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2513         ij = ij + 1
2514         DO ji = 1, jpi
[2715]2515            znorthloc_e(ji,ij)=pt2d(ji,jj)
[1344]2516         END DO
2517      END DO
2518      !
2519      itaille = jpi * ( ijpj + 2 * jpr2dj )
[2715]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 )
[1344]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
[2715]2530               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
[311]2531            END DO
[1344]2532         END DO
2533      END DO
[311]2534
2535
[1344]2536      ! 2. North-Fold boundary conditions
2537      ! ----------------------------------
[2715]2538      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
[311]2539
[1344]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
[2715]2545            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
[311]2546         END DO
2547      END DO
[1344]2548      !
[311]2549   END SUBROUTINE mpp_lbc_north_e
2550
[389]2551
[2481]2552   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
[1344]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      !!---------------------------------------------------------------------
[2481]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
[1344]2569      !!---------------------------------------------------------------------
2570      !
2571      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
[532]2572      IF ( code /= MPI_SUCCESS ) THEN
[2481]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'
[1344]2578         CALL mpi_abort( mpi_comm_world, code, ierr )
[532]2579      ENDIF
[1344]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 )
[532]2584         IF ( code /= MPI_SUCCESS ) THEN
[2481]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'
[532]2590            CALL mpi_abort( mpi_comm_world, code, ierr )
2591         ENDIF
2592      ENDIF
[1344]2593      !
[897]2594      IF( nn_buffer > 0 ) THEN
[2481]2595         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
[897]2596         ! Buffer allocation and attachment
[2481]2597         ALLOCATE( tampon(nn_buffer), stat = ierr )
[2715]2598         IF( ierr /= 0 ) THEN
[2481]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 )
[897]2607      ENDIF
[1344]2608      !
[13]2609   END SUBROUTINE mpi_init_opa
[3]2610
[2304]2611#if defined key_mpp_rep
[1976]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
[13]2642#else
2643   !!----------------------------------------------------------------------
2644   !!   Default case:            Dummy module        share memory computing
2645   !!----------------------------------------------------------------------
[2715]2646   USE in_out_manager
[1976]2647
[13]2648   INTERFACE mpp_sum
[2480]2649      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
[13]2650   END INTERFACE
2651   INTERFACE mpp_max
[681]2652      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]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
[1344]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
[3]2666
[13]2667   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
[869]2668   INTEGER :: ncomm_ice
[2715]2669   !!----------------------------------------------------------------------
[13]2670CONTAINS
[3]2671
[2715]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)
[1579]2678      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
[2715]2679      CHARACTER(len=*),DIMENSION(:) ::   ldtxt 
2680      INTEGER ::   kumnam, kstop
[1559]2681      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
[1579]2682      IF( .FALSE. )   ldtxt(:) = 'never done'
[13]2683   END FUNCTION mynode
[3]2684
[13]2685   SUBROUTINE mppsync                       ! Dummy routine
2686   END SUBROUTINE mppsync
[3]2687
[869]2688   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
[13]2689      REAL   , DIMENSION(:) :: parr
2690      INTEGER               :: kdim
[869]2691      INTEGER, OPTIONAL     :: kcom 
2692      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]2693   END SUBROUTINE mpp_sum_as
[3]2694
[869]2695   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
[13]2696      REAL   , DIMENSION(:,:) :: parr
2697      INTEGER               :: kdim
[869]2698      INTEGER, OPTIONAL     :: kcom 
2699      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]2700   END SUBROUTINE mpp_sum_a2s
[3]2701
[869]2702   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
[13]2703      INTEGER, DIMENSION(:) :: karr
2704      INTEGER               :: kdim
[869]2705      INTEGER, OPTIONAL     :: kcom 
2706      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]2707   END SUBROUTINE mpp_sum_ai
[3]2708
[869]2709   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
[13]2710      REAL                  :: psca
[869]2711      INTEGER, OPTIONAL     :: kcom 
2712      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]2713   END SUBROUTINE mpp_sum_s
[2480]2714
[869]2715   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
[13]2716      integer               :: kint
[2480]2717      INTEGER, OPTIONAL     :: kcom 
[869]2718      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]2719   END SUBROUTINE mpp_sum_i
2720
[869]2721   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]2722      REAL   , DIMENSION(:) :: parr
2723      INTEGER               :: kdim
[869]2724      INTEGER, OPTIONAL     :: kcom 
2725      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]2726   END SUBROUTINE mppmax_a_real
2727
[869]2728   SUBROUTINE mppmax_real( psca, kcom )
[13]2729      REAL                  :: psca
[869]2730      INTEGER, OPTIONAL     :: kcom 
2731      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]2732   END SUBROUTINE mppmax_real
2733
[869]2734   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]2735      REAL   , DIMENSION(:) :: parr
2736      INTEGER               :: kdim
[869]2737      INTEGER, OPTIONAL     :: kcom 
2738      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]2739   END SUBROUTINE mppmin_a_real
2740
[869]2741   SUBROUTINE mppmin_real( psca, kcom )
[13]2742      REAL                  :: psca
[869]2743      INTEGER, OPTIONAL     :: kcom 
2744      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]2745   END SUBROUTINE mppmin_real
2746
[869]2747   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]2748      INTEGER, DIMENSION(:) :: karr
2749      INTEGER               :: kdim
[869]2750      INTEGER, OPTIONAL     :: kcom 
[888]2751      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]2752   END SUBROUTINE mppmax_a_int
2753
[869]2754   SUBROUTINE mppmax_int( kint, kcom)
[681]2755      INTEGER               :: kint
[869]2756      INTEGER, OPTIONAL     :: kcom 
2757      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]2758   END SUBROUTINE mppmax_int
2759
[869]2760   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]2761      INTEGER, DIMENSION(:) :: karr
2762      INTEGER               :: kdim
[869]2763      INTEGER, OPTIONAL     :: kcom 
2764      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]2765   END SUBROUTINE mppmin_a_int
2766
[869]2767   SUBROUTINE mppmin_int( kint, kcom )
[13]2768      INTEGER               :: kint
[869]2769      INTEGER, OPTIONAL     :: kcom 
2770      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]2771   END SUBROUTINE mppmin_int
2772
[2715]2773   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2774      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
[1344]2775      REAL, DIMENSION(:) ::   parr           ! variable array
[2715]2776      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
[13]2777   END SUBROUTINE mppobc_1d
2778
[2715]2779   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2780      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
[1344]2781      REAL, DIMENSION(:,:) ::   parr           ! variable array
[2715]2782      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]2783   END SUBROUTINE mppobc_2d
2784
[2715]2785   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2786      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
[1344]2787      REAL, DIMENSION(:,:,:) ::   parr           ! variable array
[2715]2788      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]2789   END SUBROUTINE mppobc_3d
2790
[2715]2791   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
2792      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij, knum
[1344]2793      REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array
[2715]2794      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]2795   END SUBROUTINE mppobc_4d
2796
[1344]2797   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]2798      REAL                   :: pmin
2799      REAL , DIMENSION (:,:) :: ptab, pmask
2800      INTEGER :: ki, kj
[1528]2801      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]2802   END SUBROUTINE mpp_minloc2d
2803
[1344]2804   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]2805      REAL                     :: pmin
2806      REAL , DIMENSION (:,:,:) :: ptab, pmask
2807      INTEGER :: ki, kj, kk
[1528]2808      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]2809   END SUBROUTINE mpp_minloc3d
2810
[1344]2811   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]2812      REAL                   :: pmax
2813      REAL , DIMENSION (:,:) :: ptab, pmask
2814      INTEGER :: ki, kj
[1528]2815      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]2816   END SUBROUTINE mpp_maxloc2d
2817
[1344]2818   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]2819      REAL                     :: pmax
2820      REAL , DIMENSION (:,:,:) :: ptab, pmask
2821      INTEGER :: ki, kj, kk
[1528]2822      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]2823   END SUBROUTINE mpp_maxloc3d
2824
[51]2825   SUBROUTINE mppstop
2826      WRITE(*,*) 'mppstop: You should not have seen this print! error?'
2827   END SUBROUTINE mppstop
2828
[2715]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
[888]2832   END SUBROUTINE mpp_ini_ice
[869]2833
[2715]2834   SUBROUTINE mpp_ini_znl( knum )
2835      INTEGER :: knum
2836      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
[1345]2837   END SUBROUTINE mpp_ini_znl
2838
[1344]2839   SUBROUTINE mpp_comm_free( kcom )
[869]2840      INTEGER :: kcom
[1344]2841      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]2842   END SUBROUTINE mpp_comm_free
[3]2843#endif
[2715]2844
[13]2845   !!----------------------------------------------------------------------
[2715]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   !!----------------------------------------------------------------------
[3]3013END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.