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

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