source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4328

Last change on this file since 4328 was 4328, checked in by davestorkey, 7 years ago

Remove OBC module at NEMO 3.6. See ticket #1189.

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