source: branches/UKMO/dev_r5518_MO_couple_package/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6546

Last change on this file since 6546 was 6546, checked in by frrh, 6 years ago

Commit final changes relating to manual addition of relevant code
from fcm:NEMO.xm/branches/UKMO/dev_r5107_hadgem3_mct@6355.

Note this is a subset of the total changnes… I have ecluded those which
have become or appear redundant or unnecessary.

This version bit compares with the original.

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