New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
lib_mpp.F90 in branches/UKMO/dev_r5107_hadgem3_cplseq/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/UKMO/dev_r5107_hadgem3_cplseq/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5572

Last change on this file since 5572 was 5572, checked in by davestorkey, 9 years ago

Update UKMO/dev_r5107_hadgem3_cplseq branch to trunk revision 5518
(= branching point of NEMO 3.6_stable).

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