source: branches/UKMO/dev_r5518_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6558

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

Add changes as per dev_r5107_hadgem3_mct@6355

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
2011      !!----------------------------------------------------------------------
2012      !!                  ***  routine mppstop  ***
2013      !!
2014      !! ** purpose :   Stop massively parallel processors method
2015      !!
2016      !!----------------------------------------------------------------------
2017      INTEGER ::   info
2018      !!----------------------------------------------------------------------
2019      !
2020     
2021#if defined key_oasis3 || defined key_oasis3mct
2022      ! If we're trying to shut down cleanly then we need to consider the fact
2023      ! that this could be part of an MPMD configuration - we don't want to
2024      ! leave other components deadlocked.
2025
2026      CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
2027
2028
2029#else
2030     
2031      CALL mppsync
2032      CALL mpi_finalize( info )
2033#endif
2034
2035      !
2036   END SUBROUTINE mppstop
2037
2038
2039   SUBROUTINE mpp_comm_free( kcom )
2040      !!----------------------------------------------------------------------
2041      !!----------------------------------------------------------------------
2042      INTEGER, INTENT(in) ::   kcom
2043      !!
2044      INTEGER :: ierr
2045      !!----------------------------------------------------------------------
2046      !
2047      CALL MPI_COMM_FREE(kcom, ierr)
2048      !
2049   END SUBROUTINE mpp_comm_free
2050
2051
2052   SUBROUTINE mpp_ini_ice( pindic, kumout )
2053      !!----------------------------------------------------------------------
2054      !!               ***  routine mpp_ini_ice  ***
2055      !!
2056      !! ** Purpose :   Initialize special communicator for ice areas
2057      !!      condition together with global variables needed in the ddmpp folding
2058      !!
2059      !! ** Method  : - Look for ice processors in ice routines
2060      !!              - Put their number in nrank_ice
2061      !!              - Create groups for the world processors and the ice processors
2062      !!              - Create a communicator for ice processors
2063      !!
2064      !! ** output
2065      !!      njmppmax = njmpp for northern procs
2066      !!      ndim_rank_ice = number of processors with ice
2067      !!      nrank_ice (ndim_rank_ice) = ice processors
2068      !!      ngrp_iworld = group ID for the world processors
2069      !!      ngrp_ice = group ID for the ice processors
2070      !!      ncomm_ice = communicator for the ice procs.
2071      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
2072      !!
2073      !!----------------------------------------------------------------------
2074      INTEGER, INTENT(in) ::   pindic
2075      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical unit
2076      !!
2077      INTEGER :: jjproc
2078      INTEGER :: ii, ierr
2079      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kice
2080      INTEGER, ALLOCATABLE, DIMENSION(:) ::   zwork
2081      !!----------------------------------------------------------------------
2082      !
2083      ! Since this is just an init routine and these arrays are of length jpnij
2084      ! then don't use wrk_nemo module - just allocate and deallocate.
2085      ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
2086      IF( ierr /= 0 ) THEN
2087         WRITE(kumout, cform_err)
2088         WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
2089         CALL mppstop
2090      ENDIF
2091
2092      ! Look for how many procs with sea-ice
2093      !
2094      kice = 0
2095      DO jjproc = 1, jpnij
2096         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1
2097      END DO
2098      !
2099      zwork = 0
2100      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
2101      ndim_rank_ice = SUM( zwork )
2102
2103      ! Allocate the right size to nrank_north
2104      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
2105      ALLOCATE( nrank_ice(ndim_rank_ice) )
2106      !
2107      ii = 0
2108      nrank_ice = 0
2109      DO jjproc = 1, jpnij
2110         IF( zwork(jjproc) == 1) THEN
2111            ii = ii + 1
2112            nrank_ice(ii) = jjproc -1
2113         ENDIF
2114      END DO
2115
2116      ! Create the world group
2117      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
2118
2119      ! Create the ice group from the world group
2120      CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
2121
2122      ! Create the ice communicator , ie the pool of procs with sea-ice
2123      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
2124
2125      ! Find proc number in the world of proc 0 in the north
2126      ! The following line seems to be useless, we just comment & keep it as reminder
2127      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
2128      !
2129      CALL MPI_GROUP_FREE(ngrp_ice, ierr)
2130      CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
2131
2132      DEALLOCATE(kice, zwork)
2133      !
2134   END SUBROUTINE mpp_ini_ice
2135
2136
2137   SUBROUTINE mpp_ini_znl( kumout )
2138      !!----------------------------------------------------------------------
2139      !!               ***  routine mpp_ini_znl  ***
2140      !!
2141      !! ** Purpose :   Initialize special communicator for computing zonal sum
2142      !!
2143      !! ** Method  : - Look for processors in the same row
2144      !!              - Put their number in nrank_znl
2145      !!              - Create group for the znl processors
2146      !!              - Create a communicator for znl processors
2147      !!              - Determine if processor should write znl files
2148      !!
2149      !! ** output
2150      !!      ndim_rank_znl = number of processors on the same row
2151      !!      ngrp_znl = group ID for the znl processors
2152      !!      ncomm_znl = communicator for the ice procs.
2153      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
2154      !!
2155      !!----------------------------------------------------------------------
2156      INTEGER, INTENT(in) ::   kumout   ! ocean.output logical units
2157      !
2158      INTEGER :: jproc      ! dummy loop integer
2159      INTEGER :: ierr, ii   ! local integer
2160      INTEGER, ALLOCATABLE, DIMENSION(:) ::   kwork
2161      !!----------------------------------------------------------------------
2162      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
2163      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
2164      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
2165      !
2166      ALLOCATE( kwork(jpnij), STAT=ierr )
2167      IF( ierr /= 0 ) THEN
2168         WRITE(kumout, cform_err)
2169         WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
2170         CALL mppstop
2171      ENDIF
2172
2173      IF( jpnj == 1 ) THEN
2174         ngrp_znl  = ngrp_world
2175         ncomm_znl = mpi_comm_opa
2176      ELSE
2177         !
2178         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
2179         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
2180         !-$$        CALL flush(numout)
2181         !
2182         ! Count number of processors on the same row
2183         ndim_rank_znl = 0
2184         DO jproc=1,jpnij
2185            IF ( kwork(jproc) == njmpp ) THEN
2186               ndim_rank_znl = ndim_rank_znl + 1
2187            ENDIF
2188         END DO
2189         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
2190         !-$$        CALL flush(numout)
2191         ! Allocate the right size to nrank_znl
2192         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
2193         ALLOCATE(nrank_znl(ndim_rank_znl))
2194         ii = 0
2195         nrank_znl (:) = 0
2196         DO jproc=1,jpnij
2197            IF ( kwork(jproc) == njmpp) THEN
2198               ii = ii + 1
2199               nrank_znl(ii) = jproc -1
2200            ENDIF
2201         END DO
2202         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
2203         !-$$        CALL flush(numout)
2204
2205         ! Create the opa group
2206         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
2207         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
2208         !-$$        CALL flush(numout)
2209
2210         ! Create the znl group from the opa group
2211         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
2212         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
2213         !-$$        CALL flush(numout)
2214
2215         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
2216         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
2217         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
2218         !-$$        CALL flush(numout)
2219         !
2220      END IF
2221
2222      ! Determines if processor if the first (starting from i=1) on the row
2223      IF ( jpni == 1 ) THEN
2224         l_znl_root = .TRUE.
2225      ELSE
2226         l_znl_root = .FALSE.
2227         kwork (1) = nimpp
2228         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
2229         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
2230      END IF
2231
2232      DEALLOCATE(kwork)
2233
2234   END SUBROUTINE mpp_ini_znl
2235
2236
2237   SUBROUTINE mpp_ini_north
2238      !!----------------------------------------------------------------------
2239      !!               ***  routine mpp_ini_north  ***
2240      !!
2241      !! ** Purpose :   Initialize special communicator for north folding
2242      !!      condition together with global variables needed in the mpp folding
2243      !!
2244      !! ** Method  : - Look for northern processors
2245      !!              - Put their number in nrank_north
2246      !!              - Create groups for the world processors and the north processors
2247      !!              - Create a communicator for northern processors
2248      !!
2249      !! ** output
2250      !!      njmppmax = njmpp for northern procs
2251      !!      ndim_rank_north = number of processors in the northern line
2252      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
2253      !!      ngrp_world = group ID for the world processors
2254      !!      ngrp_north = group ID for the northern processors
2255      !!      ncomm_north = communicator for the northern procs.
2256      !!      north_root = number (in the world) of proc 0 in the northern comm.
2257      !!
2258      !!----------------------------------------------------------------------
2259      INTEGER ::   ierr
2260      INTEGER ::   jjproc
2261      INTEGER ::   ii, ji
2262      !!----------------------------------------------------------------------
2263      !
2264      njmppmax = MAXVAL( njmppt )
2265      !
2266      ! Look for how many procs on the northern boundary
2267      ndim_rank_north = 0
2268      DO jjproc = 1, jpnij
2269         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
2270      END DO
2271      !
2272      ! Allocate the right size to nrank_north
2273      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
2274      ALLOCATE( nrank_north(ndim_rank_north) )
2275
2276      ! Fill the nrank_north array with proc. number of northern procs.
2277      ! Note : the rank start at 0 in MPI
2278      ii = 0
2279      DO ji = 1, jpnij
2280         IF ( njmppt(ji) == njmppmax   ) THEN
2281            ii=ii+1
2282            nrank_north(ii)=ji-1
2283         END IF
2284      END DO
2285      !
2286      ! create the world group
2287      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2288      !
2289      ! Create the North group from the world group
2290      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2291      !
2292      ! Create the North communicator , ie the pool of procs in the north group
2293      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2294      !
2295   END SUBROUTINE mpp_ini_north
2296
2297
2298   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2299      !!---------------------------------------------------------------------
2300      !!                   ***  routine mpp_lbc_north_3d  ***
2301      !!
2302      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2303      !!              in mpp configuration in case of jpn1 > 1
2304      !!
2305      !! ** Method  :   North fold condition and mpp with more than one proc
2306      !!              in i-direction require a specific treatment. We gather
2307      !!              the 4 northern lines of the global domain on 1 processor
2308      !!              and apply lbc north-fold on this sub array. Then we
2309      !!              scatter the north fold array back to the processors.
2310      !!
2311      !!----------------------------------------------------------------------
2312      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2313      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2314      !                                                              !   = T ,  U , V , F or W  gridpoints
2315      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2316      !!                                                             ! =  1. , the sign is kept
2317      INTEGER ::   ji, jj, jr, jk
2318      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2319      INTEGER ::   ijpj, ijpjm1, ij, iproc
2320      INTEGER, DIMENSION (jpmaxngh)          ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2321      INTEGER                                ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2322      INTEGER, DIMENSION(MPI_STATUS_SIZE)    ::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2323      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2324      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab
2325      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2326      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio
2327      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr
2328
2329      INTEGER :: istatus(mpi_status_size)
2330      INTEGER :: iflag
2331      !!----------------------------------------------------------------------
2332      !
2333      ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
2334      ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) ) 
2335
2336      ijpj   = 4
2337      ijpjm1 = 3
2338      !
2339      znorthloc(:,:,:) = 0
2340      DO jk = 1, jpk
2341         DO jj = nlcj - ijpj +1, nlcj          ! put in xnorthloc the last 4 jlines of pt3d
2342            ij = jj - nlcj + ijpj
2343            znorthloc(:,ij,jk) = pt3d(:,jj,jk)
2344         END DO
2345      END DO
2346      !
2347      !                                     ! Build in procs of ncomm_north the znorthgloio
2348      itaille = jpi * jpk * ijpj
2349
2350      IF ( l_north_nogather ) THEN
2351         !
2352        ztabr(:,:,:) = 0
2353        ztabl(:,:,:) = 0
2354
2355        DO jk = 1, jpk
2356           DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2357              ij = jj - nlcj + ijpj
2358              DO ji = nfsloop, nfeloop
2359                 ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
2360              END DO
2361           END DO
2362        END DO
2363
2364         DO jr = 1,nsndto
2365            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2366              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
2367            ENDIF
2368         END DO
2369         DO jr = 1,nsndto
2370            iproc = nfipproc(isendto(jr),jpnj)
2371            IF(iproc .ne. -1) THEN
2372               ilei = nleit (iproc+1)
2373               ildi = nldit (iproc+1)
2374               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2375            ENDIF
2376            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2377              CALL mpprecv(5, zfoldwk, itaille, iproc)
2378              DO jk = 1, jpk
2379                 DO jj = 1, ijpj
2380                    DO ji = ildi, ilei
2381                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
2382                    END DO
2383                 END DO
2384              END DO
2385           ELSE IF (iproc .eq. (narea-1)) THEN
2386              DO jk = 1, jpk
2387                 DO jj = 1, ijpj
2388                    DO ji = ildi, ilei
2389                       ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
2390                    END DO
2391                 END DO
2392              END DO
2393           ENDIF
2394         END DO
2395         IF (l_isend) THEN
2396            DO jr = 1,nsndto
2397               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2398                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2399               ENDIF   
2400            END DO
2401         ENDIF
2402         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2403         DO jk = 1, jpk
2404            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2405               ij = jj - nlcj + ijpj
2406               DO ji= 1, nlci
2407                  pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
2408               END DO
2409            END DO
2410         END DO
2411         !
2412
2413      ELSE
2414         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2415            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2416         !
2417         ztab(:,:,:) = 0.e0
2418         DO jr = 1, ndim_rank_north         ! recover the global north array
2419            iproc = nrank_north(jr) + 1
2420            ildi  = nldit (iproc)
2421            ilei  = nleit (iproc)
2422            iilb  = nimppt(iproc)
2423            DO jk = 1, jpk
2424               DO jj = 1, ijpj
2425                  DO ji = ildi, ilei
2426                    ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
2427                  END DO
2428               END DO
2429            END DO
2430         END DO
2431         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2432         !
2433         DO jk = 1, jpk
2434            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2435               ij = jj - nlcj + ijpj
2436               DO ji= 1, nlci
2437                  pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
2438               END DO
2439            END DO
2440         END DO
2441         !
2442      ENDIF
2443      !
2444      ! The ztab array has been either:
2445      !  a. Fully populated by the mpi_allgather operation or
2446      !  b. Had the active points for this domain and northern neighbours populated
2447      !     by peer to peer exchanges
2448      ! Either way the array may be folded by lbc_nfd and the result for the span of
2449      ! this domain will be identical.
2450      !
2451      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2452      DEALLOCATE( ztabl, ztabr ) 
2453      !
2454   END SUBROUTINE mpp_lbc_north_3d
2455
2456
2457   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2458      !!---------------------------------------------------------------------
2459      !!                   ***  routine mpp_lbc_north_2d  ***
2460      !!
2461      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2462      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2463      !!
2464      !! ** Method  :   North fold condition and mpp with more than one proc
2465      !!              in i-direction require a specific treatment. We gather
2466      !!              the 4 northern lines of the global domain on 1 processor
2467      !!              and apply lbc north-fold on this sub array. Then we
2468      !!              scatter the north fold array back to the processors.
2469      !!
2470      !!----------------------------------------------------------------------
2471      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 2D array on which the b.c. is applied
2472      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points
2473      !                                                          !   = T ,  U , V , F or W  gridpoints
2474      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2475      !!                                                             ! =  1. , the sign is kept
2476      INTEGER ::   ji, jj, jr
2477      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2478      INTEGER ::   ijpj, ijpjm1, ij, iproc
2479      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather
2480      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather
2481      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather
2482      !                                                              ! Workspace for message transfers avoiding mpi_allgather
2483      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztab
2484      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk     
2485      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE   :: znorthgloio
2486      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE   :: ztabl, ztabr
2487      INTEGER :: istatus(mpi_status_size)
2488      INTEGER :: iflag
2489      !!----------------------------------------------------------------------
2490      !
2491      ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
2492      ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) ) 
2493      !
2494      ijpj   = 4
2495      ijpjm1 = 3
2496      !
2497      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2498         ij = jj - nlcj + ijpj
2499         znorthloc(:,ij) = pt2d(:,jj)
2500      END DO
2501
2502      !                                     ! Build in procs of ncomm_north the znorthgloio
2503      itaille = jpi * ijpj
2504      IF ( l_north_nogather ) THEN
2505         !
2506         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified
2507         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange
2508         !
2509         ztabr(:,:) = 0
2510         ztabl(:,:) = 0
2511
2512         DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array
2513            ij = jj - nlcj + ijpj
2514              DO ji = nfsloop, nfeloop
2515               ztabl(ji,ij) = pt2d(ji,jj)
2516            END DO
2517         END DO
2518
2519         DO jr = 1,nsndto
2520            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2521               CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
2522            ENDIF
2523         END DO
2524         DO jr = 1,nsndto
2525            iproc = nfipproc(isendto(jr),jpnj)
2526            IF(iproc .ne. -1) THEN
2527               ilei = nleit (iproc+1)
2528               ildi = nldit (iproc+1)
2529               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
2530            ENDIF
2531            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
2532              CALL mpprecv(5, zfoldwk, itaille, iproc)
2533              DO jj = 1, ijpj
2534                 DO ji = ildi, ilei
2535                    ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
2536                 END DO
2537              END DO
2538            ELSE IF (iproc .eq. (narea-1)) THEN
2539              DO jj = 1, ijpj
2540                 DO ji = ildi, ilei
2541                    ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
2542                 END DO
2543              END DO
2544            ENDIF
2545         END DO
2546         IF (l_isend) THEN
2547            DO jr = 1,nsndto
2548               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
2549                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
2550               ENDIF
2551            END DO
2552         ENDIF
2553         CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn )   ! North fold boundary condition
2554         !
2555         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2556            ij = jj - nlcj + ijpj
2557            DO ji = 1, nlci
2558               pt2d(ji,jj) = ztabl(ji,ij)
2559            END DO
2560         END DO
2561         !
2562      ELSE
2563         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2564            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2565         !
2566         ztab(:,:) = 0.e0
2567         DO jr = 1, ndim_rank_north            ! recover the global north array
2568            iproc = nrank_north(jr) + 1
2569            ildi = nldit (iproc)
2570            ilei = nleit (iproc)
2571            iilb = nimppt(iproc)
2572            DO jj = 1, ijpj
2573               DO ji = ildi, ilei
2574                  ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2575               END DO
2576            END DO
2577         END DO
2578         CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2579         !
2580         DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2581            ij = jj - nlcj + ijpj
2582            DO ji = 1, nlci
2583               pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2584            END DO
2585         END DO
2586         !
2587      ENDIF
2588      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
2589      DEALLOCATE( ztabl, ztabr ) 
2590      !
2591   END SUBROUTINE mpp_lbc_north_2d
2592
2593
2594   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2595      !!---------------------------------------------------------------------
2596      !!                   ***  routine mpp_lbc_north_2d  ***
2597      !!
2598      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2599      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2600      !!              array with outer extra halo
2601      !!
2602      !! ** Method  :   North fold condition and mpp with more than one proc
2603      !!              in i-direction require a specific treatment. We gather
2604      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2605      !!              processor and apply lbc north-fold on this sub array.
2606      !!              Then we scatter the north fold array back to the processors.
2607      !!
2608      !!----------------------------------------------------------------------
2609      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2610      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2611      !                                                                                         !   = T ,  U , V , F or W -points
2612      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
2613      !!                                                                                        ! north fold, =  1. otherwise
2614      INTEGER ::   ji, jj, jr
2615      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2616      INTEGER ::   ijpj, ij, iproc
2617      !
2618      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
2619      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
2620
2621      !!----------------------------------------------------------------------
2622      !
2623      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
2624
2625      !
2626      ijpj=4
2627      ztab_e(:,:) = 0.e0
2628
2629      ij=0
2630      ! put in znorthloc_e the last 4 jlines of pt2d
2631      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2632         ij = ij + 1
2633         DO ji = 1, jpi
2634            znorthloc_e(ji,ij)=pt2d(ji,jj)
2635         END DO
2636      END DO
2637      !
2638      itaille = jpi * ( ijpj + 2 * jpr2dj )
2639      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
2640         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2641      !
2642      DO jr = 1, ndim_rank_north            ! recover the global north array
2643         iproc = nrank_north(jr) + 1
2644         ildi = nldit (iproc)
2645         ilei = nleit (iproc)
2646         iilb = nimppt(iproc)
2647         DO jj = 1, ijpj+2*jpr2dj
2648            DO ji = ildi, ilei
2649               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
2650            END DO
2651         END DO
2652      END DO
2653
2654
2655      ! 2. North-Fold boundary conditions
2656      ! ----------------------------------
2657      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
2658
2659      ij = jpr2dj
2660      !! Scatter back to pt2d
2661      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2662      ij  = ij +1
2663         DO ji= 1, nlci
2664            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
2665         END DO
2666      END DO
2667      !
2668      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
2669      !
2670   END SUBROUTINE mpp_lbc_north_e
2671
2672      SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
2673      !!----------------------------------------------------------------------
2674      !!                  ***  routine mpp_lnk_bdy_3d  ***
2675      !!
2676      !! ** Purpose :   Message passing management
2677      !!
2678      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2679      !!      between processors following neighboring subdomains.
2680      !!            domain parameters
2681      !!                    nlci   : first dimension of the local subdomain
2682      !!                    nlcj   : second dimension of the local subdomain
2683      !!                    nbondi_bdy : mark for "east-west local boundary"
2684      !!                    nbondj_bdy : mark for "north-south local boundary"
2685      !!                    noea   : number for local neighboring processors
2686      !!                    nowe   : number for local neighboring processors
2687      !!                    noso   : number for local neighboring processors
2688      !!                    nono   : number for local neighboring processors
2689      !!
2690      !! ** Action  :   ptab with update value at its periphery
2691      !!
2692      !!----------------------------------------------------------------------
2693
2694      USE lbcnfd          ! north fold
2695
2696      INCLUDE 'mpif.h'
2697
2698      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2699      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2700      !                                                             ! = T , U , V , F , W points
2701      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2702      !                                                             ! =  1. , the sign is kept
2703      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2704      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
2705      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2706      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2707      REAL(wp) ::   zland
2708      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2709      !
2710      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ns, zt3sn   ! 3d for north-south & south-north
2711      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE ::   zt3ew, zt3we   ! 3d for east-west & west-east
2712
2713      !!----------------------------------------------------------------------
2714     
2715      ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2),   &
2716         &      zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2)  )
2717
2718      zland = 0.e0
2719
2720      ! 1. standard boundary treatment
2721      ! ------------------------------
2722     
2723      !                                   ! East-West boundaries
2724      !                                        !* Cyclic east-west
2725
2726      IF( nbondi == 2) THEN
2727        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2728          ptab( 1 ,:,:) = ptab(jpim1,:,:)
2729          ptab(jpi,:,:) = ptab(  2  ,:,:)
2730        ELSE
2731          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2732          ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2733        ENDIF
2734      ELSEIF(nbondi == -1) THEN
2735        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
2736      ELSEIF(nbondi == 1) THEN
2737        ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
2738      ENDIF                                     !* closed
2739
2740      IF (nbondj == 2 .OR. nbondj == -1) THEN
2741        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
2742      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2743        ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
2744      ENDIF
2745     
2746      !
2747
2748      ! 2. East and west directions exchange
2749      ! ------------------------------------
2750      ! we play with the neigbours AND the row number because of the periodicity
2751      !
2752      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2753      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2754         iihom = nlci-nreci
2755         DO jl = 1, jpreci
2756            zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
2757            zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
2758         END DO
2759      END SELECT
2760      !
2761      !                           ! Migrations
2762      imigr = jpreci * jpj * jpk
2763      !
2764      SELECT CASE ( nbondi_bdy(ib_bdy) )
2765      CASE ( -1 )
2766         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
2767      CASE ( 0 )
2768         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2769         CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
2770      CASE ( 1 )
2771         CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
2772      END SELECT
2773      !
2774      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2775      CASE ( -1 )
2776         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2777      CASE ( 0 )
2778         CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
2779         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2780      CASE ( 1 )
2781         CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
2782      END SELECT
2783      !
2784      SELECT CASE ( nbondi_bdy(ib_bdy) )
2785      CASE ( -1 )
2786         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2787      CASE ( 0 )
2788         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2789         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2790      CASE ( 1 )
2791         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2792      END SELECT
2793      !
2794      !                           ! Write Dirichlet lateral conditions
2795      iihom = nlci-jpreci
2796      !
2797      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2798      CASE ( -1 )
2799         DO jl = 1, jpreci
2800            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2801         END DO
2802      CASE ( 0 )
2803         DO jl = 1, jpreci
2804            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2805            ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
2806         END DO
2807      CASE ( 1 )
2808         DO jl = 1, jpreci
2809            ptab(jl      ,:,:) = zt3we(:,jl,:,2)
2810         END DO
2811      END SELECT
2812
2813
2814      ! 3. North and south directions
2815      ! -----------------------------
2816      ! always closed : we play only with the neigbours
2817      !
2818      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
2819         ijhom = nlcj-nrecj
2820         DO jl = 1, jprecj
2821            zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
2822            zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
2823         END DO
2824      ENDIF
2825      !
2826      !                           ! Migrations
2827      imigr = jprecj * jpi * jpk
2828      !
2829      SELECT CASE ( nbondj_bdy(ib_bdy) )
2830      CASE ( -1 )
2831         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
2832      CASE ( 0 )
2833         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
2834         CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
2835      CASE ( 1 )
2836         CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
2837      END SELECT
2838      !
2839      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2840      CASE ( -1 )
2841         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
2842      CASE ( 0 )
2843         CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
2844         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
2845      CASE ( 1 )
2846         CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
2847      END SELECT
2848      !
2849      SELECT CASE ( nbondj_bdy(ib_bdy) )
2850      CASE ( -1 )
2851         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2852      CASE ( 0 )
2853         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2854         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
2855      CASE ( 1 )
2856         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
2857      END SELECT
2858      !
2859      !                           ! Write Dirichlet lateral conditions
2860      ijhom = nlcj-jprecj
2861      !
2862      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
2863      CASE ( -1 )
2864         DO jl = 1, jprecj
2865            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
2866         END DO
2867      CASE ( 0 )
2868         DO jl = 1, jprecj
2869            ptab(:,jl      ,:) = zt3sn(:,jl,:,2)
2870            ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
2871         END DO
2872      CASE ( 1 )
2873         DO jl = 1, jprecj
2874            ptab(:,jl,:) = zt3sn(:,jl,:,2)
2875         END DO
2876      END SELECT
2877
2878
2879      ! 4. north fold treatment
2880      ! -----------------------
2881      !
2882      IF( npolj /= 0) THEN
2883         !
2884         SELECT CASE ( jpni )
2885         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
2886         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
2887         END SELECT
2888         !
2889      ENDIF
2890      !
2891      DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we  )
2892      !
2893   END SUBROUTINE mpp_lnk_bdy_3d
2894
2895      SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
2896      !!----------------------------------------------------------------------
2897      !!                  ***  routine mpp_lnk_bdy_2d  ***
2898      !!
2899      !! ** Purpose :   Message passing management
2900      !!
2901      !! ** Method  :   Use mppsend and mpprecv function for passing BDY boundaries
2902      !!      between processors following neighboring subdomains.
2903      !!            domain parameters
2904      !!                    nlci   : first dimension of the local subdomain
2905      !!                    nlcj   : second dimension of the local subdomain
2906      !!                    nbondi_bdy : mark for "east-west local boundary"
2907      !!                    nbondj_bdy : mark for "north-south local boundary"
2908      !!                    noea   : number for local neighboring processors
2909      !!                    nowe   : number for local neighboring processors
2910      !!                    noso   : number for local neighboring processors
2911      !!                    nono   : number for local neighboring processors
2912      !!
2913      !! ** Action  :   ptab with update value at its periphery
2914      !!
2915      !!----------------------------------------------------------------------
2916
2917      USE lbcnfd          ! north fold
2918
2919      INCLUDE 'mpif.h'
2920
2921      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
2922      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
2923      !                                                             ! = T , U , V , F , W points
2924      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
2925      !                                                             ! =  1. , the sign is kept
2926      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set
2927      INTEGER  ::   ji, jj, jl             ! dummy loop indices
2928      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
2929      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
2930      REAL(wp) ::   zland
2931      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
2932      !
2933      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ns, zt2sn   ! 2d for north-south & south-north
2934      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  zt2ew, zt2we   ! 2d for east-west & west-east
2935
2936      !!----------------------------------------------------------------------
2937
2938      ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2),  &
2939         &      zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2)   )
2940
2941      zland = 0.e0
2942
2943      ! 1. standard boundary treatment
2944      ! ------------------------------
2945     
2946      !                                   ! East-West boundaries
2947      !                                        !* Cyclic east-west
2948
2949      IF( nbondi == 2) THEN
2950        IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
2951          ptab( 1 ,:) = ptab(jpim1,:)
2952          ptab(jpi,:) = ptab(  2  ,:)
2953        ELSE
2954          IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
2955          ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
2956        ENDIF
2957      ELSEIF(nbondi == -1) THEN
2958        IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:) = zland    ! south except F-point
2959      ELSEIF(nbondi == 1) THEN
2960        ptab(nlci-jpreci+1:jpi   ,:) = zland    ! north
2961      ENDIF                                     !* closed
2962
2963      IF (nbondj == 2 .OR. nbondj == -1) THEN
2964        IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj) = zland       ! south except F-point
2965      ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
2966        ptab(:,nlcj-jprecj+1:jpj) = zland       ! north
2967      ENDIF
2968     
2969      !
2970
2971      ! 2. East and west directions exchange
2972      ! ------------------------------------
2973      ! we play with the neigbours AND the row number because of the periodicity
2974      !
2975      SELECT CASE ( nbondi_bdy(ib_bdy) )      ! Read Dirichlet lateral conditions
2976      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
2977         iihom = nlci-nreci
2978         DO jl = 1, jpreci
2979            zt2ew(:,jl,1) = ptab(jpreci+jl,:)
2980            zt2we(:,jl,1) = ptab(iihom +jl,:)
2981         END DO
2982      END SELECT
2983      !
2984      !                           ! Migrations
2985      imigr = jpreci * jpj
2986      !
2987      SELECT CASE ( nbondi_bdy(ib_bdy) )
2988      CASE ( -1 )
2989         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
2990      CASE ( 0 )
2991         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
2992         CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
2993      CASE ( 1 )
2994         CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
2995      END SELECT
2996      !
2997      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
2998      CASE ( -1 )
2999         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3000      CASE ( 0 )
3001         CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
3002         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3003      CASE ( 1 )
3004         CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
3005      END SELECT
3006      !
3007      SELECT CASE ( nbondi_bdy(ib_bdy) )
3008      CASE ( -1 )
3009         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3010      CASE ( 0 )
3011         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3012         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3013      CASE ( 1 )
3014         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3015      END SELECT
3016      !
3017      !                           ! Write Dirichlet lateral conditions
3018      iihom = nlci-jpreci
3019      !
3020      SELECT CASE ( nbondi_bdy_b(ib_bdy) )
3021      CASE ( -1 )
3022         DO jl = 1, jpreci
3023            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3024         END DO
3025      CASE ( 0 )
3026         DO jl = 1, jpreci
3027            ptab(jl      ,:) = zt2we(:,jl,2)
3028            ptab(iihom+jl,:) = zt2ew(:,jl,2)
3029         END DO
3030      CASE ( 1 )
3031         DO jl = 1, jpreci
3032            ptab(jl      ,:) = zt2we(:,jl,2)
3033         END DO
3034      END SELECT
3035
3036
3037      ! 3. North and south directions
3038      ! -----------------------------
3039      ! always closed : we play only with the neigbours
3040      !
3041      IF( nbondj_bdy(ib_bdy) /= 2 ) THEN      ! Read Dirichlet lateral conditions
3042         ijhom = nlcj-nrecj
3043         DO jl = 1, jprecj
3044            zt2sn(:,jl,1) = ptab(:,ijhom +jl)
3045            zt2ns(:,jl,1) = ptab(:,jprecj+jl)
3046         END DO
3047      ENDIF
3048      !
3049      !                           ! Migrations
3050      imigr = jprecj * jpi
3051      !
3052      SELECT CASE ( nbondj_bdy(ib_bdy) )
3053      CASE ( -1 )
3054         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
3055      CASE ( 0 )
3056         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3057         CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
3058      CASE ( 1 )
3059         CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
3060      END SELECT
3061      !
3062      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3063      CASE ( -1 )
3064         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3065      CASE ( 0 )
3066         CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
3067         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3068      CASE ( 1 )
3069         CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
3070      END SELECT
3071      !
3072      SELECT CASE ( nbondj_bdy(ib_bdy) )
3073      CASE ( -1 )
3074         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3075      CASE ( 0 )
3076         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3077         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
3078      CASE ( 1 )
3079         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
3080      END SELECT
3081      !
3082      !                           ! Write Dirichlet lateral conditions
3083      ijhom = nlcj-jprecj
3084      !
3085      SELECT CASE ( nbondj_bdy_b(ib_bdy) )
3086      CASE ( -1 )
3087         DO jl = 1, jprecj
3088            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3089         END DO
3090      CASE ( 0 )
3091         DO jl = 1, jprecj
3092            ptab(:,jl      ) = zt2sn(:,jl,2)
3093            ptab(:,ijhom+jl) = zt2ns(:,jl,2)
3094         END DO
3095      CASE ( 1 )
3096         DO jl = 1, jprecj
3097            ptab(:,jl) = zt2sn(:,jl,2)
3098         END DO
3099      END SELECT
3100
3101
3102      ! 4. north fold treatment
3103      ! -----------------------
3104      !
3105      IF( npolj /= 0) THEN
3106         !
3107         SELECT CASE ( jpni )
3108         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
3109         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
3110         END SELECT
3111         !
3112      ENDIF
3113      !
3114      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we  )
3115      !
3116   END SUBROUTINE mpp_lnk_bdy_2d
3117
3118   SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
3119      !!---------------------------------------------------------------------
3120      !!                   ***  routine mpp_init.opa  ***
3121      !!
3122      !! ** Purpose :: export and attach a MPI buffer for bsend
3123      !!
3124      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
3125      !!            but classical mpi_init
3126      !!
3127      !! History :: 01/11 :: IDRIS initial version for IBM only
3128      !!            08/04 :: R. Benshila, generalisation
3129      !!---------------------------------------------------------------------
3130      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt
3131      INTEGER                      , INTENT(inout) ::   ksft
3132      INTEGER                      , INTENT(  out) ::   code
3133      INTEGER                                      ::   ierr, ji
3134      LOGICAL                                      ::   mpi_was_called
3135      !!---------------------------------------------------------------------
3136      !
3137      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
3138      IF ( code /= MPI_SUCCESS ) THEN
3139         DO ji = 1, SIZE(ldtxt)
3140            IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3141         END DO
3142         WRITE(*, cform_err)
3143         WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'
3144         CALL mpi_abort( mpi_comm_world, code, ierr )
3145      ENDIF
3146      !
3147      IF( .NOT. mpi_was_called ) THEN
3148         CALL mpi_init( code )
3149         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
3150         IF ( code /= MPI_SUCCESS ) THEN
3151            DO ji = 1, SIZE(ldtxt)
3152               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3153            END DO
3154            WRITE(*, cform_err)
3155            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
3156            CALL mpi_abort( mpi_comm_world, code, ierr )
3157         ENDIF
3158      ENDIF
3159      !
3160      IF( nn_buffer > 0 ) THEN
3161         WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1
3162         ! Buffer allocation and attachment
3163         ALLOCATE( tampon(nn_buffer), stat = ierr )
3164         IF( ierr /= 0 ) THEN
3165            DO ji = 1, SIZE(ldtxt)
3166               IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode
3167            END DO
3168            WRITE(*, cform_err)
3169            WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr
3170            CALL mpi_abort( mpi_comm_world, code, ierr )
3171         END IF
3172         CALL mpi_buffer_attach( tampon, nn_buffer, code )
3173      ENDIF
3174      !
3175   END SUBROUTINE mpi_init_opa
3176
3177   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
3178      !!---------------------------------------------------------------------
3179      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
3180      !!
3181      !!   Modification of original codes written by David H. Bailey
3182      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i)
3183      !!---------------------------------------------------------------------
3184      INTEGER, INTENT(in)                         :: ilen, itype
3185      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda
3186      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb
3187      !
3188      REAL(wp) :: zerr, zt1, zt2    ! local work variables
3189      INTEGER :: ji, ztmp           ! local scalar
3190
3191      ztmp = itype   ! avoid compilation warning
3192
3193      DO ji=1,ilen
3194      ! Compute ydda + yddb using Knuth's trick.
3195         zt1  = real(ydda(ji)) + real(yddb(ji))
3196         zerr = zt1 - real(ydda(ji))
3197         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
3198                + aimag(ydda(ji)) + aimag(yddb(ji))
3199
3200         ! The result is zt1 + zt2, after normalization.
3201         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
3202      END DO
3203
3204   END SUBROUTINE DDPDD_MPI
3205
3206   SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
3207      !!---------------------------------------------------------------------
3208      !!                   ***  routine mpp_lbc_north_icb  ***
3209      !!
3210      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
3211      !!              in mpp configuration in case of jpn1 > 1 and for 2d
3212      !!              array with outer extra halo
3213      !!
3214      !! ** Method  :   North fold condition and mpp with more than one proc
3215      !!              in i-direction require a specific treatment. We gather
3216      !!              the 4+2*jpr2dj northern lines of the global domain on 1
3217      !!              processor and apply lbc north-fold on this sub array.
3218      !!              Then we scatter the north fold array back to the processors.
3219      !!              This version accounts for an extra halo with icebergs.
3220      !!
3221      !!----------------------------------------------------------------------
3222      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3223      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
3224      !                                                     !   = T ,  U , V , F or W -points
3225      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
3226      !!                                                    ! north fold, =  1. otherwise
3227      INTEGER, OPTIONAL       , INTENT(in   ) ::   pr2dj
3228      INTEGER ::   ji, jj, jr
3229      INTEGER ::   ierr, itaille, ildi, ilei, iilb
3230      INTEGER ::   ijpj, ij, iproc, ipr2dj
3231      !
3232      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
3233      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
3234
3235      !!----------------------------------------------------------------------
3236      !
3237      ijpj=4
3238      IF( PRESENT(pr2dj) ) THEN           ! use of additional halos
3239         ipr2dj = pr2dj
3240      ELSE
3241         ipr2dj = 0
3242      ENDIF
3243      ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
3244
3245      !
3246      ztab_e(:,:) = 0.e0
3247
3248      ij=0
3249      ! put in znorthloc_e the last 4 jlines of pt2d
3250      DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
3251         ij = ij + 1
3252         DO ji = 1, jpi
3253            znorthloc_e(ji,ij)=pt2d(ji,jj)
3254         END DO
3255      END DO
3256      !
3257      itaille = jpi * ( ijpj + 2 * ipr2dj )
3258      CALL MPI_ALLGATHER( znorthloc_e(1,1)  , itaille, MPI_DOUBLE_PRECISION,    &
3259         &                znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
3260      !
3261      DO jr = 1, ndim_rank_north            ! recover the global north array
3262         iproc = nrank_north(jr) + 1
3263         ildi = nldit (iproc)
3264         ilei = nleit (iproc)
3265         iilb = nimppt(iproc)
3266         DO jj = 1, ijpj+2*ipr2dj
3267            DO ji = ildi, ilei
3268               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
3269            END DO
3270         END DO
3271      END DO
3272
3273
3274      ! 2. North-Fold boundary conditions
3275      ! ----------------------------------
3276      CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
3277
3278      ij = ipr2dj
3279      !! Scatter back to pt2d
3280      DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
3281      ij  = ij +1
3282         DO ji= 1, nlci
3283            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
3284         END DO
3285      END DO
3286      !
3287      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
3288      !
3289   END SUBROUTINE mpp_lbc_north_icb
3290
3291   SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
3292      !!----------------------------------------------------------------------
3293      !!                  ***  routine mpp_lnk_2d_icb  ***
3294      !!
3295      !! ** Purpose :   Message passing manadgement for 2d array (with extra halo and icebergs)
3296      !!
3297      !! ** Method  :   Use mppsend and mpprecv function for passing mask
3298      !!      between processors following neighboring subdomains.
3299      !!            domain parameters
3300      !!                    nlci   : first dimension of the local subdomain
3301      !!                    nlcj   : second dimension of the local subdomain
3302      !!                    jpri   : number of rows for extra outer halo
3303      !!                    jprj   : number of columns for extra outer halo
3304      !!                    nbondi : mark for "east-west local boundary"
3305      !!                    nbondj : mark for "north-south local boundary"
3306      !!                    noea   : number for local neighboring processors
3307      !!                    nowe   : number for local neighboring processors
3308      !!                    noso   : number for local neighboring processors
3309      !!                    nono   : number for local neighboring processors
3310      !!
3311      !!----------------------------------------------------------------------
3312      INTEGER                                             , INTENT(in   ) ::   jpri
3313      INTEGER                                             , INTENT(in   ) ::   jprj
3314      REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
3315      CHARACTER(len=1)                                    , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
3316      !                                                                                 ! = T , U , V , F , W and I points
3317      REAL(wp)                                            , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
3318      !!                                                                                ! north boundary, =  1. otherwise
3319      INTEGER  ::   jl   ! dummy loop indices
3320      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
3321      INTEGER  ::   ipreci, iprecj             ! temporary integers
3322      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
3323      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
3324      !!
3325      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
3326      REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
3327      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
3328      REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
3329      !!----------------------------------------------------------------------
3330
3331      ipreci = jpreci + jpri      ! take into account outer extra 2D overlap area
3332      iprecj = jprecj + jprj
3333
3334
3335      ! 1. standard boundary treatment
3336      ! ------------------------------
3337      ! Order matters Here !!!!
3338      !
3339      !                                      ! East-West boundaries
3340      !                                           !* Cyclic east-west
3341      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
3342         pt2d(1-jpri:     1    ,:) = pt2d(jpim1-jpri:  jpim1 ,:)       ! east
3343         pt2d(   jpi  :jpi+jpri,:) = pt2d(     2      :2+jpri,:)       ! west
3344         !
3345      ELSE                                        !* closed
3346         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpri   :jpreci    ,:) = 0.e0    ! south except at F-point
3347                                      pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0    ! north
3348      ENDIF
3349      !
3350
3351      ! north fold treatment
3352      ! -----------------------
3353      IF( npolj /= 0 ) THEN
3354         !
3355         SELECT CASE ( jpni )
3356         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
3357         CASE DEFAULT   ;   CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj)  , cd_type, psgn , pr2dj=jprj  )
3358         END SELECT
3359         !
3360      ENDIF
3361
3362      ! 2. East and west directions exchange
3363      ! ------------------------------------
3364      ! we play with the neigbours AND the row number because of the periodicity
3365      !
3366      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
3367      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
3368         iihom = nlci-nreci-jpri
3369         DO jl = 1, ipreci
3370            r2dew(:,jl,1) = pt2d(jpreci+jl,:)
3371            r2dwe(:,jl,1) = pt2d(iihom +jl,:)
3372         END DO
3373      END SELECT
3374      !
3375      !                           ! Migrations
3376      imigr = ipreci * ( jpj + 2*jprj)
3377      !
3378      SELECT CASE ( nbondi )
3379      CASE ( -1 )
3380         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
3381         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3382         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3383      CASE ( 0 )
3384         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3385         CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
3386         CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
3387         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3388         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3389         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3390      CASE ( 1 )
3391         CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
3392         CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
3393         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3394      END SELECT
3395      !
3396      !                           ! Write Dirichlet lateral conditions
3397      iihom = nlci - jpreci
3398      !
3399      SELECT CASE ( nbondi )
3400      CASE ( -1 )
3401         DO jl = 1, ipreci
3402            pt2d(iihom+jl,:) = r2dew(:,jl,2)
3403         END DO
3404      CASE ( 0 )
3405         DO jl = 1, ipreci
3406            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3407            pt2d( iihom+jl,:) = r2dew(:,jl,2)
3408         END DO
3409      CASE ( 1 )
3410         DO jl = 1, ipreci
3411            pt2d(jl-jpri,:) = r2dwe(:,jl,2)
3412         END DO
3413      END SELECT
3414
3415
3416      ! 3. North and south directions
3417      ! -----------------------------
3418      ! always closed : we play only with the neigbours
3419      !
3420      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
3421         ijhom = nlcj-nrecj-jprj
3422         DO jl = 1, iprecj
3423            r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
3424            r2dns(:,jl,1) = pt2d(:,jprecj+jl)
3425         END DO
3426      ENDIF
3427      !
3428      !                           ! Migrations
3429      imigr = iprecj * ( jpi + 2*jpri )
3430      !
3431      SELECT CASE ( nbondj )
3432      CASE ( -1 )
3433         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
3434         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3435         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3436      CASE ( 0 )
3437         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3438         CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
3439         CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
3440         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3441         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3442         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3443      CASE ( 1 )
3444         CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
3445         CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
3446         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3447      END SELECT
3448      !
3449      !                           ! Write Dirichlet lateral conditions
3450      ijhom = nlcj - jprecj
3451      !
3452      SELECT CASE ( nbondj )
3453      CASE ( -1 )
3454         DO jl = 1, iprecj
3455            pt2d(:,ijhom+jl) = r2dns(:,jl,2)
3456         END DO
3457      CASE ( 0 )
3458         DO jl = 1, iprecj
3459            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3460            pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
3461         END DO
3462      CASE ( 1 )
3463         DO jl = 1, iprecj
3464            pt2d(:,jl-jprj) = r2dsn(:,jl,2)
3465         END DO
3466      END SELECT
3467
3468   END SUBROUTINE mpp_lnk_2d_icb
3469#else
3470   !!----------------------------------------------------------------------
3471   !!   Default case:            Dummy module        share memory computing
3472   !!----------------------------------------------------------------------
3473   USE in_out_manager
3474
3475   INTERFACE mpp_sum
3476      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
3477   END INTERFACE
3478   INTERFACE mpp_max
3479      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
3480   END INTERFACE
3481   INTERFACE mpp_min
3482      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3483   END INTERFACE
3484   INTERFACE mpp_minloc
3485      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3486   END INTERFACE
3487   INTERFACE mpp_maxloc
3488      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3489   END INTERFACE
3490
3491   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
3492   LOGICAL, PUBLIC            ::   ln_nnogather          !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
3493   INTEGER :: ncomm_ice
3494   INTEGER, PUBLIC            ::   mpi_comm_opa          ! opa local communicator
3495   !!----------------------------------------------------------------------
3496CONTAINS
3497
3498   INTEGER FUNCTION lib_mpp_alloc(kumout)          ! Dummy function
3499      INTEGER, INTENT(in) ::   kumout
3500      lib_mpp_alloc = 0
3501   END FUNCTION lib_mpp_alloc
3502
3503   FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg,  kumond , kstop, localComm ) RESULT (function_value)
3504      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
3505      CHARACTER(len=*),DIMENSION(:) ::   ldtxt
3506      CHARACTER(len=*) ::   ldname
3507      INTEGER ::   kumnam_ref, knumnam_cfg , kumond , kstop
3508      IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
3509      function_value = 0
3510      IF( .FALSE. )   ldtxt(:) = 'never done'
3511      CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
3512   END FUNCTION mynode
3513
3514   SUBROUTINE mppsync                       ! Dummy routine
3515   END SUBROUTINE mppsync
3516
3517   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
3518      REAL   , DIMENSION(:) :: parr
3519      INTEGER               :: kdim
3520      INTEGER, OPTIONAL     :: kcom
3521      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
3522   END SUBROUTINE mpp_sum_as
3523
3524   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
3525      REAL   , DIMENSION(:,:) :: parr
3526      INTEGER               :: kdim
3527      INTEGER, OPTIONAL     :: kcom
3528      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
3529   END SUBROUTINE mpp_sum_a2s
3530
3531   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
3532      INTEGER, DIMENSION(:) :: karr
3533      INTEGER               :: kdim
3534      INTEGER, OPTIONAL     :: kcom
3535      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
3536   END SUBROUTINE mpp_sum_ai
3537
3538   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
3539      REAL                  :: psca
3540      INTEGER, OPTIONAL     :: kcom
3541      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
3542   END SUBROUTINE mpp_sum_s
3543
3544   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
3545      integer               :: kint
3546      INTEGER, OPTIONAL     :: kcom
3547      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
3548   END SUBROUTINE mpp_sum_i
3549
3550   SUBROUTINE mppsum_realdd( ytab, kcom )
3551      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar
3552      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3553      WRITE(*,*) 'mppsum_realdd: You should not have seen this print! error?', ytab
3554   END SUBROUTINE mppsum_realdd
3555
3556   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
3557      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab
3558      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array
3559      INTEGER , INTENT( in  ), OPTIONAL :: kcom
3560      WRITE(*,*) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
3561   END SUBROUTINE mppsum_a_realdd
3562
3563   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
3564      REAL   , DIMENSION(:) :: parr
3565      INTEGER               :: kdim
3566      INTEGER, OPTIONAL     :: kcom
3567      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3568   END SUBROUTINE mppmax_a_real
3569
3570   SUBROUTINE mppmax_real( psca, kcom )
3571      REAL                  :: psca
3572      INTEGER, OPTIONAL     :: kcom
3573      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
3574   END SUBROUTINE mppmax_real
3575
3576   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
3577      REAL   , DIMENSION(:) :: parr
3578      INTEGER               :: kdim
3579      INTEGER, OPTIONAL     :: kcom
3580      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
3581   END SUBROUTINE mppmin_a_real
3582
3583   SUBROUTINE mppmin_real( psca, kcom )
3584      REAL                  :: psca
3585      INTEGER, OPTIONAL     :: kcom
3586      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
3587   END SUBROUTINE mppmin_real
3588
3589   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
3590      INTEGER, DIMENSION(:) :: karr
3591      INTEGER               :: kdim
3592      INTEGER, OPTIONAL     :: kcom
3593      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3594   END SUBROUTINE mppmax_a_int
3595
3596   SUBROUTINE mppmax_int( kint, kcom)
3597      INTEGER               :: kint
3598      INTEGER, OPTIONAL     :: kcom
3599      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
3600   END SUBROUTINE mppmax_int
3601
3602   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
3603      INTEGER, DIMENSION(:) :: karr
3604      INTEGER               :: kdim
3605      INTEGER, OPTIONAL     :: kcom
3606      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
3607   END SUBROUTINE mppmin_a_int
3608
3609   SUBROUTINE mppmin_int( kint, kcom )
3610      INTEGER               :: kint
3611      INTEGER, OPTIONAL     :: kcom
3612      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
3613   END SUBROUTINE mppmin_int
3614
3615   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
3616      REAL                   :: pmin
3617      REAL , DIMENSION (:,:) :: ptab, pmask
3618      INTEGER :: ki, kj
3619      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
3620   END SUBROUTINE mpp_minloc2d
3621
3622   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
3623      REAL                     :: pmin
3624      REAL , DIMENSION (:,:,:) :: ptab, pmask
3625      INTEGER :: ki, kj, kk
3626      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3627   END SUBROUTINE mpp_minloc3d
3628
3629   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
3630      REAL                   :: pmax
3631      REAL , DIMENSION (:,:) :: ptab, pmask
3632      INTEGER :: ki, kj
3633      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
3634   END SUBROUTINE mpp_maxloc2d
3635
3636   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
3637      REAL                     :: pmax
3638      REAL , DIMENSION (:,:,:) :: ptab, pmask
3639      INTEGER :: ki, kj, kk
3640      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
3641   END SUBROUTINE mpp_maxloc3d
3642
3643   SUBROUTINE mppstop
3644      STOP      ! non MPP case, just stop the run
3645   END SUBROUTINE mppstop
3646
3647   SUBROUTINE mpp_ini_ice( kcom, knum )
3648      INTEGER :: kcom, knum
3649      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
3650   END SUBROUTINE mpp_ini_ice
3651
3652   SUBROUTINE mpp_ini_znl( knum )
3653      INTEGER :: knum
3654      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?', knum
3655   END SUBROUTINE mpp_ini_znl
3656
3657   SUBROUTINE mpp_comm_free( kcom )
3658      INTEGER :: kcom
3659      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
3660   END SUBROUTINE mpp_comm_free
3661#endif
3662
3663   !!----------------------------------------------------------------------
3664   !!   All cases:         ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam   routines
3665   !!----------------------------------------------------------------------
3666
3667   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 ,   &
3668      &                 cd6, cd7, cd8, cd9, cd10 )
3669      !!----------------------------------------------------------------------
3670      !!                  ***  ROUTINE  stop_opa  ***
3671      !!
3672      !! ** Purpose :   print in ocean.outpput file a error message and
3673      !!                increment the error number (nstop) by one.
3674      !!----------------------------------------------------------------------
3675      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3676      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3677      !!----------------------------------------------------------------------
3678      !
3679      nstop = nstop + 1
3680      IF(lwp) THEN
3681         WRITE(numout,cform_err)
3682         IF( PRESENT(cd1 ) )   WRITE(numout,*) cd1
3683         IF( PRESENT(cd2 ) )   WRITE(numout,*) cd2
3684         IF( PRESENT(cd3 ) )   WRITE(numout,*) cd3
3685         IF( PRESENT(cd4 ) )   WRITE(numout,*) cd4
3686         IF( PRESENT(cd5 ) )   WRITE(numout,*) cd5
3687         IF( PRESENT(cd6 ) )   WRITE(numout,*) cd6
3688         IF( PRESENT(cd7 ) )   WRITE(numout,*) cd7
3689         IF( PRESENT(cd8 ) )   WRITE(numout,*) cd8
3690         IF( PRESENT(cd9 ) )   WRITE(numout,*) cd9
3691         IF( PRESENT(cd10) )   WRITE(numout,*) cd10
3692      ENDIF
3693                               CALL FLUSH(numout    )
3694      IF( numstp     /= -1 )   CALL FLUSH(numstp    )
3695      IF( numsol     /= -1 )   CALL FLUSH(numsol    )
3696      IF( numevo_ice /= -1 )   CALL FLUSH(numevo_ice)
3697      !
3698      IF( cd1 == 'STOP' ) THEN
3699         IF(lwp) WRITE(numout,*)  'huge E-R-R-O-R : immediate stop'
3700         CALL mppstop()
3701      ENDIF
3702      !
3703   END SUBROUTINE ctl_stop
3704
3705
3706   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   &
3707      &                 cd6, cd7, cd8, cd9, cd10 )
3708      !!----------------------------------------------------------------------
3709      !!                  ***  ROUTINE  stop_warn  ***
3710      !!
3711      !! ** Purpose :   print in ocean.outpput file a error message and
3712      !!                increment the warning number (nwarn) by one.
3713      !!----------------------------------------------------------------------
3714      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5
3715      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10
3716      !!----------------------------------------------------------------------
3717      !
3718      nwarn = nwarn + 1
3719      IF(lwp) THEN
3720         WRITE(numout,cform_war)
3721         IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
3722         IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
3723         IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
3724         IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
3725         IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
3726         IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
3727         IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
3728         IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
3729         IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
3730         IF( PRESENT(cd10) ) WRITE(numout,*) cd10
3731      ENDIF
3732      CALL FLUSH(numout)
3733      !
3734   END SUBROUTINE ctl_warn
3735
3736
3737   SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
3738      !!----------------------------------------------------------------------
3739      !!                  ***  ROUTINE ctl_opn  ***
3740      !!
3741      !! ** Purpose :   Open file and check if required file is available.
3742      !!
3743      !! ** Method  :   Fortan open
3744      !!----------------------------------------------------------------------
3745      INTEGER          , INTENT(  out) ::   knum      ! logical unit to open
3746      CHARACTER(len=*) , INTENT(in   ) ::   cdfile    ! file name to open
3747      CHARACTER(len=*) , INTENT(in   ) ::   cdstat    ! disposition specifier
3748      CHARACTER(len=*) , INTENT(in   ) ::   cdform    ! formatting specifier
3749      CHARACTER(len=*) , INTENT(in   ) ::   cdacce    ! access specifier
3750      INTEGER          , INTENT(in   ) ::   klengh    ! record length
3751      INTEGER          , INTENT(in   ) ::   kout      ! number of logical units for write
3752      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3753      INTEGER, OPTIONAL, INTENT(in   ) ::   karea     ! proc number
3754      !!
3755      CHARACTER(len=80) ::   clfile
3756      INTEGER           ::   iost
3757      !!----------------------------------------------------------------------
3758
3759      ! adapt filename
3760      ! ----------------
3761      clfile = TRIM(cdfile)
3762      IF( PRESENT( karea ) ) THEN
3763         IF( karea > 1 )   WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
3764      ENDIF
3765#if defined key_agrif
3766      IF( .NOT. Agrif_Root() )   clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
3767      knum=Agrif_Get_Unit()
3768#else
3769      knum=get_unit()
3770#endif
3771
3772      iost=0
3773      IF( cdacce(1:6) == 'DIRECT' )  THEN
3774         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
3775      ELSE
3776         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat             , ERR=100, IOSTAT=iost )
3777      ENDIF
3778      IF( iost == 0 ) THEN
3779         IF(ldwp) THEN
3780            WRITE(kout,*) '     file   : ', clfile,' open ok'
3781            WRITE(kout,*) '     unit   = ', knum
3782            WRITE(kout,*) '     status = ', cdstat
3783            WRITE(kout,*) '     form   = ', cdform
3784            WRITE(kout,*) '     access = ', cdacce
3785            WRITE(kout,*)
3786         ENDIF
3787      ENDIF
3788100   CONTINUE
3789      IF( iost /= 0 ) THEN
3790         IF(ldwp) THEN
3791            WRITE(kout,*)
3792            WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
3793            WRITE(kout,*) ' =======   ===  '
3794            WRITE(kout,*) '           unit   = ', knum
3795            WRITE(kout,*) '           status = ', cdstat
3796            WRITE(kout,*) '           form   = ', cdform
3797            WRITE(kout,*) '           access = ', cdacce
3798            WRITE(kout,*) '           iostat = ', iost
3799            WRITE(kout,*) '           we stop. verify the file '
3800            WRITE(kout,*)
3801         ENDIF
3802         CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening')
3803      ENDIF
3804
3805   END SUBROUTINE ctl_opn
3806
3807   SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
3808      !!----------------------------------------------------------------------
3809      !!                  ***  ROUTINE ctl_nam  ***
3810      !!
3811      !! ** Purpose :   Informations when error while reading a namelist
3812      !!
3813      !! ** Method  :   Fortan open
3814      !!----------------------------------------------------------------------
3815      INTEGER          , INTENT(inout) ::   kios      ! IO status after reading the namelist
3816      CHARACTER(len=*) , INTENT(in   ) ::   cdnam     ! group name of namelist for which error occurs
3817      CHARACTER(len=4)                 ::   clios     ! string to convert iostat in character for print
3818      LOGICAL          , INTENT(in   ) ::   ldwp      ! boolean term for print
3819      !!----------------------------------------------------------------------
3820
3821      !
3822      ! ----------------
3823      WRITE (clios, '(I4.0)') kios
3824      IF( kios < 0 ) THEN         
3825         CALL ctl_warn( 'W A R N I N G:  end of record or file while reading namelist ' &
3826 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
3827      ENDIF
3828
3829      IF( kios > 0 ) THEN
3830         CALL ctl_stop( 'E R R O R :   misspelled variable in namelist ' &
3831 &           // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
3832      ENDIF
3833      kios = 0
3834      RETURN
3835     
3836   END SUBROUTINE ctl_nam
3837
3838   INTEGER FUNCTION get_unit()
3839      !!----------------------------------------------------------------------
3840      !!                  ***  FUNCTION  get_unit  ***
3841      !!
3842      !! ** Purpose :   return the index of an unused logical unit
3843      !!----------------------------------------------------------------------
3844      LOGICAL :: llopn
3845      !!----------------------------------------------------------------------
3846      !
3847      get_unit = 15   ! choose a unit that is big enough then it is not already used in NEMO
3848      llopn = .TRUE.
3849      DO WHILE( (get_unit < 998) .AND. llopn )
3850         get_unit = get_unit + 1
3851         INQUIRE( unit = get_unit, opened = llopn )
3852      END DO
3853      IF( (get_unit == 999) .AND. llopn ) THEN
3854         CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
3855         get_unit = -1
3856      ENDIF
3857      !
3858   END FUNCTION get_unit
3859
3860   !!----------------------------------------------------------------------
3861END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.