source: branches/UKMO/AMM15_v3_6_STABLE_package_collate_coupling/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 10392

Last change on this file since 10392 was 10392, checked in by jcastill, 23 months ago

Merge branch r6232_hadgem3_mct@7457

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