source: trunk/NEMO/OPA_SRC/lib_mpp.F90 @ 1793

Last change on this file since 1793 was 1793, checked in by rblod, 11 years ago

Adaptation to use iomput with AGRIF, see ticket #630

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 104.2 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   !!----------------------------------------------------------------------
21#if   defined key_mpp_mpi 
22   !!----------------------------------------------------------------------
23   !!   'key_mpp_mpi'             MPI massively parallel processing library
24   !!----------------------------------------------------------------------
25   !!   mynode      : indentify the processor unit
26   !!   mpp_lnk     : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
27   !!   mpp_lnk_3d_gather :  Message passing manadgement for two 3D arrays
28   !!   mpp_lnk_e   : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
29   !!   mpprecv     :
30   !!   mppsend     :   SUBROUTINE mpp_ini_znl
31   !!   mppscatter  :
32   !!   mppgather   :
33   !!   mpp_min     : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
34   !!   mpp_max     : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
35   !!   mpp_sum     : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
36   !!   mpp_minloc  :
37   !!   mpp_maxloc  :
38   !!   mppsync     :
39   !!   mppstop     :
40   !!   mppobc      : variant of mpp_lnk for open boundary condition
41   !!   mpp_ini_north : initialisation of north fold
42   !!   mpp_lbc_north : north fold processors gathering
43   !!   mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
44   !!----------------------------------------------------------------------
45   !! History :
46   !!        !  94 (M. Guyon, J. Escobar, M. Imbard)  Original code
47   !!        !  97  (A.M. Treguier)  SHMEM additions
48   !!        !  98  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
49   !!   9.0  !  03  (J.-M. Molines, G. Madec)  F90, free form
50   !!        !  04  (R. Bourdalle Badie)  isend option in mpi
51   !!        !  05  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases
52   !!        !  05  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
53   !!        !  09  (R. Benshila) SHMEM suppression, north fold in lbc_nfd
54   !!----------------------------------------------------------------------
55   !!  OPA 9.0 , LOCEAN-IPSL (2005)
56   !! $Id$
57   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
58   !!---------------------------------------------------------------------
59   !! * Modules used
60   USE dom_oce                    ! ocean space and time domain
61   USE in_out_manager             ! I/O manager
62   USE lbcnfd                     ! north fold treatment
63
64   IMPLICIT NONE
65   PRIVATE
66   
67   PUBLIC   mynode, mppstop, mppsync, mpp_comm_free
68   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
69   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
70   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
71   PUBLIC   mpprecv, mppsend, mppscatter, mppgather
72   PUBLIC   mppobc, mpp_ini_ice, mpp_ini_znl
73#if defined key_oasis3 || defined key_oasis4
74   PUBLIC   mppsize, mpprank
75#endif
76
77   !! * Interfaces
78   !! define generic interface for these routine as they are called sometimes
79   !! with scalar arguments instead of array arguments, which causes problems
80   !! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
81   INTERFACE mpp_min
82      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
83   END INTERFACE
84   INTERFACE mpp_max
85      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
86   END INTERFACE
87   INTERFACE mpp_sum
88      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
89   END INTERFACE
90   INTERFACE mpp_lbc_north
91      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d 
92   END INTERFACE
93   INTERFACE mpp_minloc
94      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
95   END INTERFACE
96   INTERFACE mpp_maxloc
97      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
98   END INTERFACE
99
100
101   !! ========================= !!
102   !!  MPI  variable definition !!
103   !! ========================= !!
104!$AGRIF_DO_NOT_TREAT
105#  include <mpif.h>
106!$AGRIF_END_DO_NOT_TREAT
107   
108   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.    !: mpp flag
109
110   INTEGER, PARAMETER         ::   nprocmax = 2**10   ! maximun dimension (required to be a power of 2)
111   
112   INTEGER ::   mppsize        ! number of process
113   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ]
114!$AGRIF_DO_NOT_TREAT
115   INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator
116!$AGRIF_END_DO_NOT_TREAT
117
118   ! variables used in case of sea-ice
119   INTEGER, PUBLIC ::   ncomm_ice       !: communicator made by the processors with sea-ice
120   INTEGER ::   ngrp_ice        !  group ID for the ice processors (for rheology)
121   INTEGER ::   ndim_rank_ice   !  number of 'ice' processors
122   INTEGER ::   n_ice_root      !  number (in the comm_ice) of proc 0 in the ice comm
123   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_ice     ! dimension ndim_rank_ice
124
125   ! variables used for zonal integration
126   INTEGER, PUBLIC ::   ncomm_znl       !: communicator made by the processors on the same zonal average
127   LOGICAL, PUBLIC ::   l_znl_root      ! True on the 'left'most processor on the same row
128   INTEGER ::   ngrp_znl        ! group ID for the znl processors
129   INTEGER ::   ndim_rank_znl   ! number of processors on the same zonal average
130   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_znl  ! dimension ndim_rank_znl, number of the procs into the same znl domain
131   
132   ! North fold condition in mpp_mpi with jpni > 1
133   INTEGER ::   ngrp_world        ! group ID for the world processors
134   INTEGER ::   ngrp_opa          ! group ID for the opa processors
135   INTEGER ::   ngrp_north        ! group ID for the northern processors (to be fold)
136   INTEGER ::   ncomm_north       ! communicator made by the processors belonging to ngrp_north
137   INTEGER ::   ndim_rank_north   ! number of 'sea' processor in the northern line (can be /= jpni !)
138   INTEGER ::   njmppmax          ! value of njmpp for the processors of the northern line
139   INTEGER ::   north_root        ! number (in the comm_opa) of proc 0 in the northern comm
140   INTEGER, DIMENSION(:), ALLOCATABLE ::   nrank_north   ! dimension ndim_rank_north
141
142   ! Type of send : standard, buffered, immediate
143   CHARACTER(len=1) ::   cn_mpi_send = 'S'    ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
144   LOGICAL          ::   l_isend = .FALSE.   ! isend use indicator (T if cn_mpi_send='I')
145   INTEGER          ::   nn_buffer = 0       ! size of the buffer in case of mpi_bsend
146     
147   REAL(wp), ALLOCATABLE, DIMENSION(:) :: tampon  ! buffer in case of bsend
148
149   ! message passing arrays
150   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   t4ns, t4sn   ! 2 x 3d for north-south & south-north
151   REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) ::   t4ew, t4we   ! 2 x 3d for east-west & west-east
152   REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) ::   t4p1, t4p2   ! 2 x 3d for north fold
153   REAL(wp), DIMENSION(jpi,jprecj,jpk,2)   ::   t3ns, t3sn   ! 3d for north-south & south-north
154   REAL(wp), DIMENSION(jpj,jpreci,jpk,2)   ::   t3ew, t3we   ! 3d for east-west & west-east
155   REAL(wp), DIMENSION(jpi,jprecj,jpk,2)   ::   t3p1, t3p2   ! 3d for north fold
156   REAL(wp), DIMENSION(jpi,jprecj,2)       ::   t2ns, t2sn   ! 2d for north-south & south-north
157   REAL(wp), DIMENSION(jpj,jpreci,2)       ::   t2ew, t2we   ! 2d for east-west & west-east
158   REAL(wp), DIMENSION(jpi,jprecj,2)       ::   t2p1, t2p2   ! 2d for north fold
159   REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) ::   tr2ns, tr2sn  ! 2d for north-south & south-north + extra outer halo
160   REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) ::   tr2ew, tr2we  ! 2d for east-west   & west-east   + extra outer halo
161   !!----------------------------------------------------------------------
162   !! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)
163   !! $Id$
164   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
165   !!----------------------------------------------------------------------
166
167CONTAINS
168
169   FUNCTION mynode(ldtxt, localComm)
170      !!----------------------------------------------------------------------
171      !!                  ***  routine mynode  ***
172      !!                   
173      !! ** Purpose :   Find processor unit
174      !!
175      !!----------------------------------------------------------------------
176      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
177      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
178      INTEGER ::   mynode, ierr, code
179      LOGICAL ::   mpi_was_called
180     
181      NAMELIST/nammpp/ cn_mpi_send, nn_buffer
182      !!----------------------------------------------------------------------
183      !
184      WRITE(ldtxt(1),*)
185      WRITE(ldtxt(2),*) 'mynode : mpi initialisation'
186      WRITE(ldtxt(3),*) '~~~~~~ '
187      !
188      REWIND( numnam )               ! Namelist namrun : parameters of the run
189      READ  ( numnam, nammpp )
190      !                              ! control print
191      WRITE(ldtxt(4),*) '   Namelist nammpp'
192      WRITE(ldtxt(5),*) '      mpi send type                      cn_mpi_send = ', cn_mpi_send
193      WRITE(ldtxt(6),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer
194
195      CALL mpi_initialized ( mpi_was_called, code )
196      IF( code /= MPI_SUCCESS ) THEN
197         WRITE(*, cform_err)
198         WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized'
199         CALL mpi_abort( mpi_comm_world, code, ierr )
200      ENDIF
201
202      IF( mpi_was_called ) THEN
203         !
204         SELECT CASE ( cn_mpi_send )
205         CASE ( 'S' )                ! Standard mpi send (blocking)
206            WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
207         CASE ( 'B' )                ! Buffer mpi send (blocking)
208            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
209            CALL mpi_init_opa( ierr ) 
210         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
211            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
212            l_isend = .TRUE.
213         CASE DEFAULT
214            WRITE(ldtxt(7),cform_err)
215            WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
216            nstop = nstop + 1
217         END SELECT
218      ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
219         WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '
220         WRITE(ldtxt(8),*) '          without calling MPI_Init before ! '
221         nstop = nstop + 1
222      ELSE
223         SELECT CASE ( cn_mpi_send )
224         CASE ( 'S' )                ! Standard mpi send (blocking)
225            WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)'
226            CALL mpi_init( ierr )
227         CASE ( 'B' )                ! Buffer mpi send (blocking)
228            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)'
229            CALL mpi_init_opa( ierr )
230         CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
231            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)'
232            l_isend = .TRUE.
233            CALL mpi_init( ierr )
234         CASE DEFAULT
235            WRITE(ldtxt(7),cform_err)
236            WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send
237            nstop = nstop + 1
238         END SELECT
239         !
240      ENDIF
241
242      IF( PRESENT(localComm) ) THEN
243         IF( Agrif_Root() ) THEN
244            mpi_comm_opa = localComm
245         ENDIF
246      ELSE
247         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
248         IF( code /= MPI_SUCCESS ) THEN
249            WRITE(*, cform_err)
250            WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'
251            CALL mpi_abort( mpi_comm_world, code, ierr )
252         ENDIF
253      ENDIF
254
255      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
256      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
257      mynode = mpprank
258      !
259   END FUNCTION mynode
260
261
262   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
263      !!----------------------------------------------------------------------
264      !!                  ***  routine mpp_lnk_3d  ***
265      !!
266      !! ** Purpose :   Message passing manadgement
267      !!
268      !! ** Method  :   Use mppsend and mpprecv function for passing mask
269      !!      between processors following neighboring subdomains.
270      !!            domain parameters
271      !!                    nlci   : first dimension of the local subdomain
272      !!                    nlcj   : second dimension of the local subdomain
273      !!                    nbondi : mark for "east-west local boundary"
274      !!                    nbondj : mark for "north-south local boundary"
275      !!                    noea   : number for local neighboring processors
276      !!                    nowe   : number for local neighboring processors
277      !!                    noso   : number for local neighboring processors
278      !!                    nono   : number for local neighboring processors
279      !!
280      !! ** Action  :   ptab with update value at its periphery
281      !!
282      !!----------------------------------------------------------------------
283      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied
284      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
285      !                                                             ! = T , U , V , F , W points
286      REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
287      !                                                             ! =  1. , the sign is kept
288      CHARACTER(len=3), OPTIONAL      , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
289      REAL(wp)        , OPTIONAL      , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
290      !!
291      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices
292      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
293      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
294      REAL(wp) ::   zland
295      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
296      !!----------------------------------------------------------------------
297
298      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
299      ELSE                         ;   zland = 0.e0      ! zero by default
300      ENDIF
301
302      ! 1. standard boundary treatment
303      ! ------------------------------
304      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
305         !
306         ! WARNING ptab is defined only between nld and nle
307         DO jk = 1, jpk
308            DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
309               ptab(nldi  :nlei  , jj          ,jk) = ptab(nldi:nlei,     nlej,jk)   
310               ptab(1     :nldi-1, jj          ,jk) = ptab(nldi     ,     nlej,jk)
311               ptab(nlei+1:nlci  , jj          ,jk) = ptab(     nlei,     nlej,jk)
312            END DO
313            DO ji = nlci+1, jpi                 ! added column(s) (full)
314               ptab(ji           ,nldj  :nlej  ,jk) = ptab(     nlei,nldj:nlej,jk)
315               ptab(ji           ,1     :nldj-1,jk) = ptab(     nlei,nldj     ,jk)
316               ptab(ji           ,nlej+1:jpj   ,jk) = ptab(     nlei,     nlej,jk)
317            END DO
318         END DO
319         !
320      ELSE                              ! standard close or cyclic treatment
321         !
322         !                                   ! East-West boundaries
323         !                                        !* Cyclic east-west
324         IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
325            ptab( 1 ,:,:) = ptab(jpim1,:,:)
326            ptab(jpi,:,:) = ptab(  2  ,:,:)
327         ELSE                                     !* closed
328            IF( .NOT. cd_type == 'F' )   ptab(     1       :jpreci,:,:) = zland    ! south except F-point
329                                         ptab(nlci-jpreci+1:jpi   ,:,:) = zland    ! north
330         ENDIF
331         !                                   ! North-South boundaries (always closed)
332         IF( .NOT. cd_type == 'F' )   ptab(:,     1       :jprecj,:) = zland       ! south except F-point
333                                      ptab(:,nlcj-jprecj+1:jpj   ,:) = zland       ! north
334         !
335      ENDIF
336
337      ! 2. East and west directions exchange
338      ! ------------------------------------
339      ! we play with the neigbours AND the row number because of the periodicity
340      !
341      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
342      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
343         iihom = nlci-nreci
344         DO jl = 1, jpreci
345            t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
346            t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
347         END DO
348      END SELECT 
349      !
350      !                           ! Migrations
351      imigr = jpreci * jpj * jpk
352      !
353      SELECT CASE ( nbondi ) 
354      CASE ( -1 )
355         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
356         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
357         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
358      CASE ( 0 )
359         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
360         CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
361         CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
362         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
363         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
364         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
365      CASE ( 1 )
366         CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
367         CALL mpprecv( 2, t3we(1,1,1,2), imigr )
368         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
369      END SELECT
370      !
371      !                           ! Write Dirichlet lateral conditions
372      iihom = nlci-jpreci
373      !
374      SELECT CASE ( nbondi )
375      CASE ( -1 )
376         DO jl = 1, jpreci
377            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
378         END DO
379      CASE ( 0 ) 
380         DO jl = 1, jpreci
381            ptab(jl      ,:,:) = t3we(:,jl,:,2)
382            ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
383         END DO
384      CASE ( 1 )
385         DO jl = 1, jpreci
386            ptab(jl      ,:,:) = t3we(:,jl,:,2)
387         END DO
388      END SELECT
389
390
391      ! 3. North and south directions
392      ! -----------------------------
393      ! always closed : we play only with the neigbours
394      !
395      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
396         ijhom = nlcj-nrecj
397         DO jl = 1, jprecj
398            t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
399            t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
400         END DO
401      ENDIF
402      !
403      !                           ! Migrations
404      imigr = jprecj * jpi * jpk
405      !
406      SELECT CASE ( nbondj )     
407      CASE ( -1 )
408         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
409         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
410         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
411      CASE ( 0 )
412         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
413         CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
414         CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
415         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
416         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
417         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
418      CASE ( 1 ) 
419         CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
420         CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
421         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
422      END SELECT
423      !
424      !                           ! Write Dirichlet lateral conditions
425      ijhom = nlcj-jprecj
426      !
427      SELECT CASE ( nbondj )
428      CASE ( -1 )
429         DO jl = 1, jprecj
430            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
431         END DO
432      CASE ( 0 ) 
433         DO jl = 1, jprecj
434            ptab(:,jl      ,:) = t3sn(:,jl,:,2)
435            ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
436         END DO
437      CASE ( 1 )
438         DO jl = 1, jprecj
439            ptab(:,jl,:) = t3sn(:,jl,:,2)
440         END DO
441      END SELECT
442
443
444      ! 4. north fold treatment
445      ! -----------------------
446      !
447      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
448         !
449         SELECT CASE ( jpni )
450         CASE ( 1 )     ;   CALL lbc_nfd      ( ptab, cd_type, psgn )   ! only 1 northern proc, no mpp
451         CASE DEFAULT   ;   CALL mpp_lbc_north( ptab, cd_type, psgn )   ! for all northern procs.
452         END SELECT
453         !
454      ENDIF
455      !
456   END SUBROUTINE mpp_lnk_3d
457
458
459   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
460      !!----------------------------------------------------------------------
461      !!                  ***  routine mpp_lnk_2d  ***
462      !!                 
463      !! ** Purpose :   Message passing manadgement for 2d array
464      !!
465      !! ** Method  :   Use mppsend and mpprecv function for passing mask
466      !!      between processors following neighboring subdomains.
467      !!            domain parameters
468      !!                    nlci   : first dimension of the local subdomain
469      !!                    nlcj   : second dimension of the local subdomain
470      !!                    nbondi : mark for "east-west local boundary"
471      !!                    nbondj : mark for "north-south local boundary"
472      !!                    noea   : number for local neighboring processors
473      !!                    nowe   : number for local neighboring processors
474      !!                    noso   : number for local neighboring processors
475      !!                    nono   : number for local neighboring processors
476      !!
477      !!----------------------------------------------------------------------
478      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d     ! 2D array on which the boundary condition is applied
479      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points
480      !                                                         ! = T , U , V , F , W and I points
481      REAL(wp)                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary
482      !                                                         ! =  1. , the sign is kept
483      CHARACTER(len=3), OPTIONAL  , INTENT(in   ) ::   cd_mpp   ! fill the overlap area only
484      REAL(wp)        , OPTIONAL  , INTENT(in   ) ::   pval     ! background value (used at closed boundaries)
485      !!
486      INTEGER  ::   ji, jj, jl   ! dummy loop indices
487      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
488      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
489      REAL(wp) ::   zland
490      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
491      !!----------------------------------------------------------------------
492
493      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value
494      ELSE                         ;   zland = 0.e0      ! zero by default
495      ENDIF
496
497      ! 1. standard boundary treatment
498      ! ------------------------------
499      !
500      IF( PRESENT( cd_mpp ) ) THEN      ! only fill added line/raw with existing values
501         !
502         ! WARNING pt2d is defined only between nld and nle
503         DO jj = nlcj+1, jpj                 ! added line(s)   (inner only)
504            pt2d(nldi  :nlei  , jj          ) = pt2d(nldi:nlei,     nlej)   
505            pt2d(1     :nldi-1, jj          ) = pt2d(nldi     ,     nlej)
506            pt2d(nlei+1:nlci  , jj          ) = pt2d(     nlei,     nlej)
507         END DO
508         DO ji = nlci+1, jpi                 ! added column(s) (full)
509            pt2d(ji           ,nldj  :nlej  ) = pt2d(     nlei,nldj:nlej)
510            pt2d(ji           ,1     :nldj-1) = pt2d(     nlei,nldj     )
511            pt2d(ji           ,nlej+1:jpj   ) = pt2d(     nlei,     nlej)
512         END DO
513         !
514      ELSE                              ! standard close or cyclic treatment
515         !
516         !                                   ! East-West boundaries
517         IF( nbondi == 2 .AND.   &                ! Cyclic east-west
518            &    (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
519            pt2d( 1 ,:) = pt2d(jpim1,:)                                    ! west
520            pt2d(jpi,:) = pt2d(  2  ,:)                                    ! east
521         ELSE                                     ! closed
522            IF( .NOT. cd_type == 'F' )   pt2d(     1       :jpreci,:) = zland    ! south except F-point
523                                         pt2d(nlci-jpreci+1:jpi   ,:) = zland    ! north
524         ENDIF
525         !                                   ! North-South boundaries (always closed)
526            IF( .NOT. cd_type == 'F' )   pt2d(:,     1       :jprecj) = zland    !south except F-point
527                                         pt2d(:,nlcj-jprecj+1:jpj   ) = zland    ! north
528         !
529      ENDIF
530
531      ! 2. East and west directions exchange
532      ! ------------------------------------
533      ! we play with the neigbours AND the row number because of the periodicity
534      !
535      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
536      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
537         iihom = nlci-nreci
538         DO jl = 1, jpreci
539            t2ew(:,jl,1) = pt2d(jpreci+jl,:)
540            t2we(:,jl,1) = pt2d(iihom +jl,:)
541         END DO
542      END SELECT
543      !
544      !                           ! Migrations
545      imigr = jpreci * jpj
546      !
547      SELECT CASE ( nbondi )
548      CASE ( -1 )
549         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
550         CALL mpprecv( 1, t2ew(1,1,2), imigr )
551         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
552      CASE ( 0 )
553         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
554         CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
555         CALL mpprecv( 1, t2ew(1,1,2), imigr )
556         CALL mpprecv( 2, t2we(1,1,2), imigr )
557         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
558         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
559      CASE ( 1 )
560         CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
561         CALL mpprecv( 2, t2we(1,1,2), imigr )
562         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
563      END SELECT
564      !
565      !                           ! Write Dirichlet lateral conditions
566      iihom = nlci - jpreci
567      !
568      SELECT CASE ( nbondi )
569      CASE ( -1 )
570         DO jl = 1, jpreci
571            pt2d(iihom+jl,:) = t2ew(:,jl,2)
572         END DO
573      CASE ( 0 )
574         DO jl = 1, jpreci
575            pt2d(jl      ,:) = t2we(:,jl,2)
576            pt2d(iihom+jl,:) = t2ew(:,jl,2)
577         END DO
578      CASE ( 1 )
579         DO jl = 1, jpreci
580            pt2d(jl      ,:) = t2we(:,jl,2)
581         END DO
582      END SELECT
583
584
585      ! 3. North and south directions
586      ! -----------------------------
587      ! always closed : we play only with the neigbours
588      !
589      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
590         ijhom = nlcj-nrecj
591         DO jl = 1, jprecj
592            t2sn(:,jl,1) = pt2d(:,ijhom +jl)
593            t2ns(:,jl,1) = pt2d(:,jprecj+jl)
594         END DO
595      ENDIF
596      !
597      !                           ! Migrations
598      imigr = jprecj * jpi
599      !
600      SELECT CASE ( nbondj )
601      CASE ( -1 )
602         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
603         CALL mpprecv( 3, t2ns(1,1,2), imigr )
604         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
605      CASE ( 0 )
606         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
607         CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
608         CALL mpprecv( 3, t2ns(1,1,2), imigr )
609         CALL mpprecv( 4, t2sn(1,1,2), imigr )
610         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
611         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
612      CASE ( 1 )
613         CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
614         CALL mpprecv( 4, t2sn(1,1,2), imigr )
615         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
616      END SELECT
617      !
618      !                           ! Write Dirichlet lateral conditions
619      ijhom = nlcj - jprecj
620      !
621      SELECT CASE ( nbondj )
622      CASE ( -1 )
623         DO jl = 1, jprecj
624            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
625         END DO
626      CASE ( 0 )
627         DO jl = 1, jprecj
628            pt2d(:,jl      ) = t2sn(:,jl,2)
629            pt2d(:,ijhom+jl) = t2ns(:,jl,2)
630         END DO
631      CASE ( 1 ) 
632         DO jl = 1, jprecj
633            pt2d(:,jl      ) = t2sn(:,jl,2)
634         END DO
635      END SELECT
636
637
638      ! 4. north fold treatment
639      ! -----------------------
640      !
641      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
642         !
643         SELECT CASE ( jpni )
644         CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d, cd_type, psgn )   ! only 1 northern proc, no mpp
645         CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d, cd_type, psgn )   ! for all northern procs.
646         END SELECT
647         !
648      ENDIF
649      !
650   END SUBROUTINE mpp_lnk_2d
651
652
653   SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
654      !!----------------------------------------------------------------------
655      !!                  ***  routine mpp_lnk_3d_gather  ***
656      !!
657      !! ** Purpose :   Message passing manadgement for two 3D arrays
658      !!
659      !! ** Method  :   Use mppsend and mpprecv function for passing mask
660      !!      between processors following neighboring subdomains.
661      !!            domain parameters
662      !!                    nlci   : first dimension of the local subdomain
663      !!                    nlcj   : second dimension of the local subdomain
664      !!                    nbondi : mark for "east-west local boundary"
665      !!                    nbondj : mark for "north-south local boundary"
666      !!                    noea   : number for local neighboring processors
667      !!                    nowe   : number for local neighboring processors
668      !!                    noso   : number for local neighboring processors
669      !!                    nono   : number for local neighboring processors
670      !!
671      !! ** Action  :   ptab1 and ptab2  with update value at its periphery
672      !!
673      !!----------------------------------------------------------------------
674      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab1     ! first and second 3D array on which
675      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab2     ! the boundary condition is applied
676      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type1  ! nature of ptab1 and ptab2 arrays
677      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type2  ! i.e. grid-points = T , U , V , F or W points
678      REAL(wp)                        , INTENT(in   ) ::   psgn      ! =-1 the sign change across the north fold boundary
679      !!                                                             ! =  1. , the sign is kept
680      INTEGER  ::   jl   ! dummy loop indices
681      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
682      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
683      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
684      !!----------------------------------------------------------------------
685
686      ! 1. standard boundary treatment
687      ! ------------------------------
688      !                                      ! East-West boundaries
689      !                                           !* Cyclic east-west
690      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
691         ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
692         ptab1(jpi,:,:) = ptab1(  2  ,:,:)
693         ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
694         ptab2(jpi,:,:) = ptab2(  2  ,:,:)
695      ELSE                                        !* closed
696         IF( .NOT. cd_type1 == 'F' )   ptab1(     1       :jpreci,:,:) = 0.e0    ! south except at F-point
697         IF( .NOT. cd_type2 == 'F' )   ptab2(     1       :jpreci,:,:) = 0.e0
698                                       ptab1(nlci-jpreci+1:jpi   ,:,:) = 0.e0    ! north
699                                       ptab2(nlci-jpreci+1:jpi   ,:,:) = 0.e0
700      ENDIF
701
702     
703      !                                      ! North-South boundaries
704      IF( .NOT. cd_type1 == 'F' )   ptab1(:,     1       :jprecj,:) = 0.e0    ! south except at F-point
705      IF( .NOT. cd_type2 == 'F' )   ptab2(:,     1       :jprecj,:) = 0.e0
706                                    ptab1(:,nlcj-jprecj+1:jpj   ,:) = 0.e0    ! north
707                                    ptab2(:,nlcj-jprecj+1:jpj   ,:) = 0.e0
708
709
710      ! 2. East and west directions exchange
711      ! ------------------------------------
712      ! we play with the neigbours AND the row number because of the periodicity
713      !
714      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
715      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
716         iihom = nlci-nreci
717         DO jl = 1, jpreci
718            t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
719            t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
720            t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
721            t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
722         END DO
723      END SELECT
724      !
725      !                           ! Migrations
726      imigr = jpreci * jpj * jpk *2
727      !
728      SELECT CASE ( nbondi ) 
729      CASE ( -1 )
730         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
731         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
732         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
733      CASE ( 0 )
734         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
735         CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
736         CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
737         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
738         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
739         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
740      CASE ( 1 )
741         CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
742         CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
743         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
744      END SELECT
745      !
746      !                           ! Write Dirichlet lateral conditions
747      iihom = nlci - jpreci
748      !
749      SELECT CASE ( nbondi )
750      CASE ( -1 )
751         DO jl = 1, jpreci
752            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
753            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
754         END DO
755      CASE ( 0 ) 
756         DO jl = 1, jpreci
757            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
758            ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
759            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
760            ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
761         END DO
762      CASE ( 1 )
763         DO jl = 1, jpreci
764            ptab1(jl      ,:,:) = t4we(:,jl,:,1,2)
765            ptab2(jl      ,:,:) = t4we(:,jl,:,2,2)
766         END DO
767      END SELECT
768
769
770      ! 3. North and south directions
771      ! -----------------------------
772      ! always closed : we play only with the neigbours
773      !
774      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
775         ijhom = nlcj - nrecj
776         DO jl = 1, jprecj
777            t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
778            t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
779            t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
780            t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
781         END DO
782      ENDIF
783      !
784      !                           ! Migrations
785      imigr = jprecj * jpi * jpk * 2
786      !
787      SELECT CASE ( nbondj )     
788      CASE ( -1 )
789         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
790         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
791         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
792      CASE ( 0 )
793         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
794         CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
795         CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
796         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
797         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
798         IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
799      CASE ( 1 ) 
800         CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
801         CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
802         IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
803      END SELECT
804      !
805      !                           ! Write Dirichlet lateral conditions
806      ijhom = nlcj - jprecj
807      !
808      SELECT CASE ( nbondj )
809      CASE ( -1 )
810         DO jl = 1, jprecj
811            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
812            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
813         END DO
814      CASE ( 0 ) 
815         DO jl = 1, jprecj
816            ptab1(:,jl      ,:) = t4sn(:,jl,:,1,2)
817            ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
818            ptab2(:,jl      ,:) = t4sn(:,jl,:,2,2)
819            ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
820         END DO
821      CASE ( 1 )
822         DO jl = 1, jprecj
823            ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
824            ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
825         END DO
826      END SELECT
827
828
829      ! 4. north fold treatment
830      ! -----------------------
831      IF( npolj /= 0 ) THEN
832         !
833         SELECT CASE ( jpni )
834         CASE ( 1 )                                           
835            CALL lbc_nfd      ( ptab1, cd_type1, psgn )   ! only for northern procs.
836            CALL lbc_nfd      ( ptab2, cd_type2, psgn )
837         CASE DEFAULT
838            CALL mpp_lbc_north( ptab1, cd_type1, psgn )   ! for all northern procs.
839            CALL mpp_lbc_north (ptab2, cd_type2, psgn)
840         END SELECT 
841         !
842      ENDIF
843      !
844   END SUBROUTINE mpp_lnk_3d_gather
845
846
847   SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
848      !!----------------------------------------------------------------------
849      !!                  ***  routine mpp_lnk_2d_e  ***
850      !!                 
851      !! ** Purpose :   Message passing manadgement for 2d array (with halo)
852      !!
853      !! ** Method  :   Use mppsend and mpprecv function for passing mask
854      !!      between processors following neighboring subdomains.
855      !!            domain parameters
856      !!                    nlci   : first dimension of the local subdomain
857      !!                    nlcj   : second dimension of the local subdomain
858      !!                    jpr2di : number of rows for extra outer halo
859      !!                    jpr2dj : number of columns for extra outer halo
860      !!                    nbondi : mark for "east-west local boundary"
861      !!                    nbondj : mark for "north-south local boundary"
862      !!                    noea   : number for local neighboring processors
863      !!                    nowe   : number for local neighboring processors
864      !!                    noso   : number for local neighboring processors
865      !!                    nono   : number for local neighboring processors
866      !!
867      !!----------------------------------------------------------------------
868      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
869      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of ptab array grid-points
870      !                                                                                         ! = T , U , V , F , W and I points
871      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! =-1 the sign change across the
872      !!                                                                                        ! north boundary, =  1. otherwise
873      INTEGER  ::   jl   ! dummy loop indices
874      INTEGER  ::   imigr, iihom, ijhom        ! temporary integers
875      INTEGER  ::   ipreci, iprecj             ! temporary integers
876      INTEGER  ::   ml_req1, ml_req2, ml_err   ! for key_mpi_isend
877      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat   ! for key_mpi_isend
878      !!----------------------------------------------------------------------
879
880      ipreci = jpreci + jpr2di      ! take into account outer extra 2D overlap area
881      iprecj = jprecj + jpr2dj
882
883
884      ! 1. standard boundary treatment
885      ! ------------------------------
886      ! Order matters Here !!!!
887      !
888      !                                      !* North-South boundaries (always colsed)
889      IF( .NOT. cd_type == 'F' )   pt2d(:,  1-jpr2dj   :  jprecj  ) = 0.e0    ! south except at F-point
890                                   pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0    ! north
891                               
892      !                                      ! East-West boundaries
893      !                                           !* Cyclic east-west
894      IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
895         pt2d(1-jpr2di:     1    ,:) = pt2d(jpim1-jpr2di:  jpim1 ,:)       ! east
896         pt2d(   jpi  :jpi+jpr2di,:) = pt2d(     2      :2+jpr2di,:)       ! west
897         !
898      ELSE                                        !* closed
899         IF( .NOT. cd_type == 'F' )   pt2d(  1-jpr2di   :jpreci    ,:) = 0.e0    ! south except at F-point
900                                      pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0    ! north
901      ENDIF
902      !
903
904      ! north fold treatment
905      ! -----------------------
906      IF( npolj /= 0 ) THEN
907         !
908         SELECT CASE ( jpni )
909         CASE ( 1 )     ;   CALL lbc_nfd        ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
910         CASE DEFAULT   ;   CALL mpp_lbc_north_e( pt2d                    , cd_type, psgn               )
911         END SELECT 
912         !
913      ENDIF
914
915      ! 2. East and west directions exchange
916      ! ------------------------------------
917      ! we play with the neigbours AND the row number because of the periodicity
918      !
919      SELECT CASE ( nbondi )      ! Read Dirichlet lateral conditions
920      CASE ( -1, 0, 1 )                ! all exept 2 (i.e. close case)
921         iihom = nlci-nreci-jpr2di
922         DO jl = 1, ipreci
923            tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
924            tr2we(:,jl,1) = pt2d(iihom +jl,:)
925         END DO
926      END SELECT
927      !
928      !                           ! Migrations
929      imigr = ipreci * ( jpj + 2*jpr2dj)
930      !
931      SELECT CASE ( nbondi )
932      CASE ( -1 )
933         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
934         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
935         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
936      CASE ( 0 )
937         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
938         CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
939         CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
940         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
941         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
942         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
943      CASE ( 1 )
944         CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
945         CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
946         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
947      END SELECT
948      !
949      !                           ! Write Dirichlet lateral conditions
950      iihom = nlci - jpreci
951      !
952      SELECT CASE ( nbondi )
953      CASE ( -1 )
954         DO jl = 1, ipreci
955            pt2d(iihom+jl,:) = tr2ew(:,jl,2)
956         END DO
957      CASE ( 0 )
958         DO jl = 1, ipreci
959            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
960            pt2d( iihom+jl,:) = tr2ew(:,jl,2)
961         END DO
962      CASE ( 1 )
963         DO jl = 1, ipreci
964            pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
965         END DO
966      END SELECT
967
968
969      ! 3. North and south directions
970      ! -----------------------------
971      ! always closed : we play only with the neigbours
972      !
973      IF( nbondj /= 2 ) THEN      ! Read Dirichlet lateral conditions
974         ijhom = nlcj-nrecj-jpr2dj
975         DO jl = 1, iprecj
976            tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
977            tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
978         END DO
979      ENDIF
980      !
981      !                           ! Migrations
982      imigr = iprecj * ( jpi + 2*jpr2di )
983      !
984      SELECT CASE ( nbondj )
985      CASE ( -1 )
986         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
987         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
988         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
989      CASE ( 0 )
990         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
991         CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
992         CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
993         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
994         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
995         IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
996      CASE ( 1 )
997         CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
998         CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
999         IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1000      END SELECT
1001      !
1002      !                           ! Write Dirichlet lateral conditions
1003      ijhom = nlcj - jprecj 
1004      !
1005      SELECT CASE ( nbondj )
1006      CASE ( -1 )
1007         DO jl = 1, iprecj
1008            pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
1009         END DO
1010      CASE ( 0 )
1011         DO jl = 1, iprecj
1012            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1013            pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
1014         END DO
1015      CASE ( 1 ) 
1016         DO jl = 1, iprecj
1017            pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
1018         END DO
1019      END SELECT
1020
1021   END SUBROUTINE mpp_lnk_2d_e
1022
1023
1024   SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
1025      !!----------------------------------------------------------------------
1026      !!                  ***  routine mppsend  ***
1027      !!                   
1028      !! ** Purpose :   Send messag passing array
1029      !!
1030      !!----------------------------------------------------------------------
1031      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1032      INTEGER , INTENT(in   ) ::   kbytes     ! size of the array pmess
1033      INTEGER , INTENT(in   ) ::   kdest      ! receive process number
1034      INTEGER , INTENT(in   ) ::   ktyp       ! tag of the message
1035      INTEGER , INTENT(in   ) ::   md_req     ! argument for isend
1036      !!
1037      INTEGER ::   iflag
1038      !!----------------------------------------------------------------------
1039      !
1040      SELECT CASE ( cn_mpi_send )
1041      CASE ( 'S' )                ! Standard mpi send (blocking)
1042         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1043      CASE ( 'B' )                ! Buffer mpi send (blocking)
1044         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa        , iflag )
1045      CASE ( 'I' )                ! Immediate mpi send (non-blocking send)
1046         ! be carefull, one more argument here : the mpi request identifier..
1047         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
1048      END SELECT
1049      !
1050   END SUBROUTINE mppsend
1051
1052
1053   SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1054      !!----------------------------------------------------------------------
1055      !!                  ***  routine mpprecv  ***
1056      !!
1057      !! ** Purpose :   Receive messag passing array
1058      !!
1059      !!----------------------------------------------------------------------
1060      REAL(wp), INTENT(inout) ::   pmess(*)   ! array of real
1061      INTEGER , INTENT(in   ) ::   kbytes     ! suze of the array pmess
1062      INTEGER , INTENT(in   ) ::   ktyp       ! Tag of the recevied message
1063      !!
1064      INTEGER :: istatus(mpi_status_size)
1065      INTEGER :: iflag
1066      !!----------------------------------------------------------------------
1067      !
1068      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
1069      !
1070   END SUBROUTINE mpprecv
1071
1072
1073   SUBROUTINE mppgather( ptab, kp, pio )
1074      !!----------------------------------------------------------------------
1075      !!                   ***  routine mppgather  ***
1076      !!                   
1077      !! ** Purpose :   Transfert between a local subdomain array and a work
1078      !!     array which is distributed following the vertical level.
1079      !!
1080      !!----------------------------------------------------------------------
1081      REAL(wp), DIMENSION(jpi,jpj),       INTENT(in   ) ::   ptab   ! subdomain input array
1082      INTEGER ,                           INTENT(in   ) ::   kp     ! record length
1083      REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT(  out) ::   pio    ! subdomain input array
1084      !!
1085      INTEGER :: itaille, ierror   ! temporary integer
1086      !!---------------------------------------------------------------------
1087      !
1088      itaille = jpi * jpj
1089      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille     ,   &
1090         &                            mpi_double_precision, kp , mpi_comm_opa, ierror ) 
1091      !
1092   END SUBROUTINE mppgather
1093
1094
1095   SUBROUTINE mppscatter( pio, kp, ptab )
1096      !!----------------------------------------------------------------------
1097      !!                  ***  routine mppscatter  ***
1098      !!
1099      !! ** Purpose :   Transfert between awork array which is distributed
1100      !!      following the vertical level and the local subdomain array.
1101      !!
1102      !!----------------------------------------------------------------------
1103      REAL(wp), DIMENSION(jpi,jpj,jpnij)  ::  pio        ! output array
1104      INTEGER                             ::   kp        ! Tag (not used with MPI
1105      REAL(wp), DIMENSION(jpi,jpj)        ::  ptab       ! subdomain array input
1106      !!
1107      INTEGER :: itaille, ierror   ! temporary integer
1108      !!---------------------------------------------------------------------
1109      !
1110      itaille=jpi*jpj
1111      !
1112      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille     ,   &
1113         &                            mpi_double_precision, kp  , mpi_comm_opa, ierror )
1114      !
1115   END SUBROUTINE mppscatter
1116
1117
1118   SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
1119      !!----------------------------------------------------------------------
1120      !!                  ***  routine mppmax_a_int  ***
1121      !!
1122      !! ** Purpose :   Find maximum value in an integer layout array
1123      !!
1124      !!----------------------------------------------------------------------
1125      INTEGER , INTENT(in   )                  ::   kdim   ! size of array
1126      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab   ! input array
1127      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom   !
1128      !!
1129      INTEGER :: ierror, localcomm   ! temporary integer
1130      INTEGER, DIMENSION(kdim) ::   iwork
1131      !!----------------------------------------------------------------------
1132      !
1133      localcomm = mpi_comm_opa
1134      IF( PRESENT(kcom) )   localcomm = kcom
1135      !
1136      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
1137      !
1138      ktab(:) = iwork(:)
1139      !
1140   END SUBROUTINE mppmax_a_int
1141
1142
1143   SUBROUTINE mppmax_int( ktab, kcom )
1144      !!----------------------------------------------------------------------
1145      !!                  ***  routine mppmax_int  ***
1146      !!
1147      !! ** Purpose :   Find maximum value in an integer layout array
1148      !!
1149      !!----------------------------------------------------------------------
1150      INTEGER, INTENT(inout)           ::   ktab      ! ???
1151      INTEGER, INTENT(in   ), OPTIONAL ::   kcom      ! ???
1152      !!
1153      INTEGER ::   ierror, iwork, localcomm   ! temporary integer
1154      !!----------------------------------------------------------------------
1155      !
1156      localcomm = mpi_comm_opa 
1157      IF( PRESENT(kcom) )   localcomm = kcom
1158      !
1159      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
1160      !
1161      ktab = iwork
1162      !
1163   END SUBROUTINE mppmax_int
1164
1165
1166   SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
1167      !!----------------------------------------------------------------------
1168      !!                  ***  routine mppmin_a_int  ***
1169      !!
1170      !! ** Purpose :   Find minimum value in an integer layout array
1171      !!
1172      !!----------------------------------------------------------------------
1173      INTEGER , INTENT( in  )                  ::   kdim        ! size of array
1174      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array
1175      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1176      !!
1177      INTEGER ::   ierror, localcomm   ! temporary integer
1178      INTEGER, DIMENSION(kdim) ::   iwork
1179      !!----------------------------------------------------------------------
1180      !
1181      localcomm = mpi_comm_opa
1182      IF( PRESENT(kcom) )   localcomm = kcom
1183      !
1184      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
1185      !
1186      ktab(:) = iwork(:)
1187      !
1188   END SUBROUTINE mppmin_a_int
1189
1190
1191   SUBROUTINE mppmin_int( ktab, kcom )
1192      !!----------------------------------------------------------------------
1193      !!                  ***  routine mppmin_int  ***
1194      !!
1195      !! ** Purpose :   Find minimum value in an integer layout array
1196      !!
1197      !!----------------------------------------------------------------------
1198      INTEGER, INTENT(inout) ::   ktab      ! ???
1199      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array
1200      !!
1201      INTEGER ::  ierror, iwork, localcomm
1202      !!----------------------------------------------------------------------
1203      !
1204      localcomm = mpi_comm_opa
1205      IF( PRESENT(kcom) )   localcomm = kcom
1206      !
1207     CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
1208      !
1209      ktab = iwork
1210      !
1211   END SUBROUTINE mppmin_int
1212
1213
1214   SUBROUTINE mppsum_a_int( ktab, kdim )
1215      !!----------------------------------------------------------------------
1216      !!                  ***  routine mppsum_a_int  ***
1217      !!                   
1218      !! ** Purpose :   Global integer sum, 1D array case
1219      !!
1220      !!----------------------------------------------------------------------
1221      INTEGER, INTENT(in   )                   ::   kdim      ! ???
1222      INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ???
1223      !!
1224      INTEGER :: ierror
1225      INTEGER, DIMENSION (kdim) ::  iwork
1226      !!----------------------------------------------------------------------
1227      !
1228      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1229      !
1230      ktab(:) = iwork(:)
1231      !
1232   END SUBROUTINE mppsum_a_int
1233
1234
1235   SUBROUTINE mppsum_int( ktab )
1236      !!----------------------------------------------------------------------
1237      !!                 ***  routine mppsum_int  ***
1238      !!                 
1239      !! ** Purpose :   Global integer sum
1240      !!
1241      !!----------------------------------------------------------------------
1242      INTEGER, INTENT(inout) ::   ktab
1243      !!
1244      INTEGER :: ierror, iwork
1245      !!----------------------------------------------------------------------
1246      !
1247      CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
1248      !
1249      ktab = iwork
1250      !
1251   END SUBROUTINE mppsum_int
1252
1253
1254   SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
1255      !!----------------------------------------------------------------------
1256      !!                 ***  routine mppmax_a_real  ***
1257      !!                 
1258      !! ** Purpose :   Maximum
1259      !!
1260      !!----------------------------------------------------------------------
1261      INTEGER , INTENT(in   )                  ::   kdim
1262      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1263      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1264      !!
1265      INTEGER :: ierror, localcomm
1266      REAL(wp), DIMENSION(kdim) ::  zwork
1267      !!----------------------------------------------------------------------
1268      !
1269      localcomm = mpi_comm_opa
1270      IF( PRESENT(kcom) ) localcomm = kcom
1271      !
1272      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
1273      ptab(:) = zwork(:)
1274      !
1275   END SUBROUTINE mppmax_a_real
1276
1277
1278   SUBROUTINE mppmax_real( ptab, kcom )
1279      !!----------------------------------------------------------------------
1280      !!                  ***  routine mppmax_real  ***
1281      !!                   
1282      !! ** Purpose :   Maximum
1283      !!
1284      !!----------------------------------------------------------------------
1285      REAL(wp), INTENT(inout)           ::   ptab   ! ???
1286      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ???
1287      !!
1288      INTEGER  ::   ierror, localcomm
1289      REAL(wp) ::   zwork
1290      !!----------------------------------------------------------------------
1291      !
1292      localcomm = mpi_comm_opa 
1293      IF( PRESENT(kcom) )   localcomm = kcom
1294      !
1295      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
1296      ptab = zwork
1297      !
1298   END SUBROUTINE mppmax_real
1299
1300
1301   SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
1302      !!----------------------------------------------------------------------
1303      !!                 ***  routine mppmin_a_real  ***
1304      !!                 
1305      !! ** Purpose :   Minimum of REAL, array case
1306      !!
1307      !!-----------------------------------------------------------------------
1308      INTEGER , INTENT(in   )                  ::   kdim
1309      REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab
1310      INTEGER , INTENT(in   ), OPTIONAL        ::   kcom
1311      !!
1312      INTEGER :: ierror, localcomm
1313      REAL(wp), DIMENSION(kdim) ::   zwork
1314      !!-----------------------------------------------------------------------
1315      !
1316      localcomm = mpi_comm_opa 
1317      IF( PRESENT(kcom) ) localcomm = kcom
1318      !
1319      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
1320      ptab(:) = zwork(:)
1321      !
1322   END SUBROUTINE mppmin_a_real
1323
1324
1325   SUBROUTINE mppmin_real( ptab, kcom )
1326      !!----------------------------------------------------------------------
1327      !!                  ***  routine mppmin_real  ***
1328      !!
1329      !! ** Purpose :   minimum of REAL, scalar case
1330      !!
1331      !!-----------------------------------------------------------------------
1332      REAL(wp), INTENT(inout)           ::   ptab        !
1333      INTEGER , INTENT(in   ), OPTIONAL :: kcom
1334      !!
1335      INTEGER  ::   ierror
1336      REAL(wp) ::   zwork
1337      INTEGER :: localcomm
1338      !!-----------------------------------------------------------------------
1339      !
1340      localcomm = mpi_comm_opa 
1341      IF( PRESENT(kcom) )   localcomm = kcom
1342      !
1343      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
1344      ptab = zwork
1345      !
1346   END SUBROUTINE mppmin_real
1347
1348
1349   SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
1350      !!----------------------------------------------------------------------
1351      !!                  ***  routine mppsum_a_real  ***
1352      !!
1353      !! ** Purpose :   global sum, REAL ARRAY argument case
1354      !!
1355      !!-----------------------------------------------------------------------
1356      INTEGER , INTENT( in )                     ::   kdim      ! size of ptab
1357      REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array
1358      INTEGER , INTENT( in ), OPTIONAL           :: kcom
1359      !!
1360      INTEGER                   ::   ierror    ! temporary integer
1361      INTEGER                   ::   localcomm 
1362      REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace
1363      !!-----------------------------------------------------------------------
1364      !
1365      localcomm = mpi_comm_opa 
1366      IF( PRESENT(kcom) )   localcomm = kcom
1367      !
1368      CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
1369      ptab(:) = zwork(:)
1370      !
1371   END SUBROUTINE mppsum_a_real
1372
1373
1374   SUBROUTINE mppsum_real( ptab, kcom )
1375      !!----------------------------------------------------------------------
1376      !!                  ***  routine mppsum_real  ***
1377      !!             
1378      !! ** Purpose :   global sum, SCALAR argument case
1379      !!
1380      !!-----------------------------------------------------------------------
1381      REAL(wp), INTENT(inout)           ::   ptab   ! input scalar
1382      INTEGER , INTENT(in   ), OPTIONAL ::   kcom
1383      !!
1384      INTEGER  ::   ierror, localcomm 
1385      REAL(wp) ::   zwork
1386      !!-----------------------------------------------------------------------
1387      !
1388      localcomm = mpi_comm_opa 
1389      IF( PRESENT(kcom) ) localcomm = kcom
1390      !
1391      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
1392      ptab = zwork
1393      !
1394   END SUBROUTINE mppsum_real
1395
1396
1397   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
1398      !!------------------------------------------------------------------------
1399      !!             ***  routine mpp_minloc  ***
1400      !!
1401      !! ** Purpose :   Compute the global minimum of an array ptab
1402      !!              and also give its global position
1403      !!
1404      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1405      !!
1406      !!--------------------------------------------------------------------------
1407      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab    ! Local 2D array
1408      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask   ! Local mask
1409      REAL(wp)                     , INTENT(  out) ::   pmin    ! Global minimum of ptab
1410      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of minimum in global frame
1411      !!
1412      INTEGER , DIMENSION(2)   ::   ilocs
1413      INTEGER :: ierror
1414      REAL(wp) ::   zmin   ! local minimum
1415      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1416      !!-----------------------------------------------------------------------
1417      !
1418      zmin  = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
1419      ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
1420      !
1421      ki = ilocs(1) + nimpp - 1
1422      kj = ilocs(2) + njmpp - 1
1423      !
1424      zain(1,:)=zmin
1425      zain(2,:)=ki+10000.*kj
1426      !
1427      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1428      !
1429      pmin = zaout(1,1)
1430      kj = INT(zaout(2,1)/10000.)
1431      ki = INT(zaout(2,1) - 10000.*kj )
1432      !
1433   END SUBROUTINE mpp_minloc2d
1434
1435
1436   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
1437      !!------------------------------------------------------------------------
1438      !!             ***  routine mpp_minloc  ***
1439      !!
1440      !! ** Purpose :   Compute the global minimum of an array ptab
1441      !!              and also give its global position
1442      !!
1443      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1444      !!
1445      !!--------------------------------------------------------------------------
1446      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1447      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1448      REAL(wp)                         , INTENT(  out) ::   pmin         ! Global minimum of ptab
1449      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of minimum in global frame
1450      !!
1451      INTEGER  ::   ierror
1452      REAL(wp) ::   zmin     ! local minimum
1453      INTEGER , DIMENSION(3)   ::   ilocs
1454      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1455      !!-----------------------------------------------------------------------
1456      !
1457      zmin  = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1458      ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1459      !
1460      ki = ilocs(1) + nimpp - 1
1461      kj = ilocs(2) + njmpp - 1
1462      kk = ilocs(3)
1463      !
1464      zain(1,:)=zmin
1465      zain(2,:)=ki+10000.*kj+100000000.*kk
1466      !
1467      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
1468      !
1469      pmin = zaout(1,1)
1470      kk   = INT( zaout(2,1) / 100000000. )
1471      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1472      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1473      !
1474   END SUBROUTINE mpp_minloc3d
1475
1476
1477   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
1478      !!------------------------------------------------------------------------
1479      !!             ***  routine mpp_maxloc  ***
1480      !!
1481      !! ** Purpose :   Compute the global maximum of an array ptab
1482      !!              and also give its global position
1483      !!
1484      !! ** Method  :   Use MPI_ALLREDUCE with MPI_MINLOC
1485      !!
1486      !!--------------------------------------------------------------------------
1487      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   ptab     ! Local 2D array
1488      REAL(wp), DIMENSION (jpi,jpj), INTENT(in   ) ::   pmask    ! Local mask
1489      REAL(wp)                     , INTENT(  out) ::   pmax     ! Global maximum of ptab
1490      INTEGER                      , INTENT(  out) ::   ki, kj   ! index of maximum in global frame
1491      !! 
1492      INTEGER  :: ierror
1493      INTEGER, DIMENSION (2)   ::   ilocs
1494      REAL(wp) :: zmax   ! local maximum
1495      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1496      !!-----------------------------------------------------------------------
1497      !
1498      zmax  = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
1499      ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
1500      !
1501      ki = ilocs(1) + nimpp - 1
1502      kj = ilocs(2) + njmpp - 1
1503      !
1504      zain(1,:) = zmax
1505      zain(2,:) = ki + 10000. * kj
1506      !
1507      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1508      !
1509      pmax = zaout(1,1)
1510      kj   = INT( zaout(2,1) / 10000.     )
1511      ki   = INT( zaout(2,1) - 10000.* kj )
1512      !
1513   END SUBROUTINE mpp_maxloc2d
1514
1515
1516   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
1517      !!------------------------------------------------------------------------
1518      !!             ***  routine mpp_maxloc  ***
1519      !!
1520      !! ** Purpose :  Compute the global maximum of an array ptab
1521      !!              and also give its global position
1522      !!
1523      !! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
1524      !!
1525      !!--------------------------------------------------------------------------
1526      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   ptab         ! Local 2D array
1527      REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in   ) ::   pmask        ! Local mask
1528      REAL(wp)                         , INTENT(  out) ::   pmax         ! Global maximum of ptab
1529      INTEGER                          , INTENT(  out) ::   ki, kj, kk   ! index of maximum in global frame
1530      !!   
1531      REAL(wp) :: zmax   ! local maximum
1532      REAL(wp), DIMENSION(2,1) ::   zain, zaout
1533      INTEGER , DIMENSION(3)   ::   ilocs
1534      INTEGER :: ierror
1535      !!-----------------------------------------------------------------------
1536      !
1537      zmax  = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
1538      ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
1539      !
1540      ki = ilocs(1) + nimpp - 1
1541      kj = ilocs(2) + njmpp - 1
1542      kk = ilocs(3)
1543      !
1544      zain(1,:)=zmax
1545      zain(2,:)=ki+10000.*kj+100000000.*kk
1546      !
1547      CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
1548      !
1549      pmax = zaout(1,1)
1550      kk   = INT( zaout(2,1) / 100000000. )
1551      kj   = INT( zaout(2,1) - kk * 100000000. ) / 10000
1552      ki   = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
1553      !
1554   END SUBROUTINE mpp_maxloc3d
1555
1556
1557   SUBROUTINE mppsync()
1558      !!----------------------------------------------------------------------
1559      !!                  ***  routine mppsync  ***
1560      !!                   
1561      !! ** Purpose :   Massively parallel processors, synchroneous
1562      !!
1563      !!-----------------------------------------------------------------------
1564      INTEGER :: ierror
1565      !!-----------------------------------------------------------------------
1566      !
1567      CALL mpi_barrier( mpi_comm_opa, ierror )
1568      !
1569   END SUBROUTINE mppsync
1570
1571
1572   SUBROUTINE mppstop
1573      !!----------------------------------------------------------------------
1574      !!                  ***  routine mppstop  ***
1575      !!                   
1576      !! ** purpose :   Stop massilively parallel processors method
1577      !!
1578      !!----------------------------------------------------------------------
1579      INTEGER ::   info
1580      !!----------------------------------------------------------------------
1581      !
1582      CALL mppsync
1583      CALL mpi_finalize( info )
1584      !
1585   END SUBROUTINE mppstop
1586
1587
1588   SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
1589      !!----------------------------------------------------------------------
1590      !!                  ***  routine mppobc  ***
1591      !!
1592      !! ** Purpose :   Message passing manadgement for open boundary
1593      !!     conditions array
1594      !!
1595      !! ** Method  :   Use mppsend and mpprecv function for passing mask
1596      !!       between processors following neighboring subdomains.
1597      !!       domain parameters
1598      !!                    nlci   : first dimension of the local subdomain
1599      !!                    nlcj   : second dimension of the local subdomain
1600      !!                    nbondi : mark for "east-west local boundary"
1601      !!                    nbondj : mark for "north-south local boundary"
1602      !!                    noea   : number for local neighboring processors
1603      !!                    nowe   : number for local neighboring processors
1604      !!                    noso   : number for local neighboring processors
1605      !!                    nono   : number for local neighboring processors
1606      !!
1607      !!----------------------------------------------------------------------
1608      INTEGER , INTENT(in   )                     ::   kd1, kd2   ! starting and ending indices
1609      INTEGER , INTENT(in   )                     ::   kl         ! index of open boundary
1610      INTEGER , INTENT(in   )                     ::   kk         ! vertical dimension
1611      INTEGER , INTENT(in   )                     ::   ktype      ! define north/south or east/west cdt
1612      !                                                           !  = 1  north/south  ;  = 2  east/west
1613      INTEGER , INTENT(in   )                     ::   kij        ! horizontal dimension
1614      REAL(wp), INTENT(inout), DIMENSION(kij,kk)  ::   ptab       ! variable array
1615      !!
1616      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices
1617      INTEGER  ::   iipt0, iipt1, ilpt1   ! temporary integers
1618      INTEGER  ::   ijpt0, ijpt1          !    -          -
1619      INTEGER  ::   imigr, iihom, ijhom   !    -          -
1620      INTEGER ::   ml_req1, ml_req2, ml_err    ! for key_mpi_isend
1621      INTEGER ::   ml_stat(MPI_STATUS_SIZE)    ! for key_mpi_isend
1622      REAL(wp), DIMENSION(jpi,jpj) ::   ztab   ! temporary workspace
1623      !!----------------------------------------------------------------------
1624
1625      ! boundary condition initialization
1626      ! ---------------------------------
1627      ztab(:,:) = 0.e0
1628      !
1629      IF( ktype==1 ) THEN                                  ! north/south boundaries
1630         iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci     ) )
1631         iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
1632         ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci     ) )
1633         ijpt0 = MAX( 1, MIN(kl  - njmpp+1, nlcj     ) )
1634         ijpt1 = MAX( 0, MIN(kl  - njmpp+1, nlcj - 1 ) )
1635      ELSEIF( ktype==2 ) THEN                              ! east/west boundaries
1636         iipt0 = MAX( 1, MIN(kl  - nimpp+1, nlci     ) )
1637         iipt1 = MAX( 0, MIN(kl  - nimpp+1, nlci - 1 ) )
1638         ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj     ) )
1639         ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
1640         ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj     ) )
1641      ELSE
1642         CALL ctl_stop( 'mppobc: bad ktype' )
1643      ENDIF
1644     
1645      ! Communication level by level
1646      ! ----------------------------
1647!!gm Remark : this is very time consumming!!!
1648      !                                         ! ------------------------ !
1649      DO jk = 1, kk                             !   Loop over the levels   !
1650         !                                      ! ------------------------ !
1651         !
1652         IF( ktype == 1 ) THEN                               ! north/south boundaries
1653            DO jj = ijpt0, ijpt1
1654               DO ji = iipt0, iipt1
1655                  ztab(ji,jj) = ptab(ji,jk)
1656               END DO
1657            END DO
1658         ELSEIF( ktype == 2 ) THEN                           ! east/west boundaries
1659            DO jj = ijpt0, ijpt1
1660               DO ji = iipt0, iipt1
1661                  ztab(ji,jj) = ptab(jj,jk)
1662               END DO
1663            END DO
1664         ENDIF
1665
1666
1667         ! 1. East and west directions
1668         ! ---------------------------
1669         !
1670         IF( nbondi /= 2 ) THEN         ! Read Dirichlet lateral conditions
1671            iihom = nlci-nreci
1672            DO jl = 1, jpreci
1673               t2ew(:,jl,1) = ztab(jpreci+jl,:)
1674               t2we(:,jl,1) = ztab(iihom +jl,:)
1675            END DO
1676         ENDIF
1677         !
1678         !                              ! Migrations
1679         imigr=jpreci*jpj
1680         !
1681         IF( nbondi == -1 ) THEN
1682            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1683            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1684            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1685         ELSEIF( nbondi == 0 ) THEN
1686            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1687            CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1688            CALL mpprecv( 1, t2ew(1,1,2), imigr )
1689            CALL mpprecv( 2, t2we(1,1,2), imigr )
1690            IF(l_isend)   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1691            IF(l_isend)   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1692         ELSEIF( nbondi == 1 ) THEN
1693            CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1694            CALL mpprecv( 2, t2we(1,1,2), imigr )
1695            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1696         ENDIF
1697         !
1698         !                              ! Write Dirichlet lateral conditions
1699         iihom = nlci-jpreci
1700         !
1701         IF( nbondi == 0 .OR. nbondi == 1 ) THEN
1702            DO jl = 1, jpreci
1703               ztab(jl,:) = t2we(:,jl,2)
1704            END DO
1705         ENDIF
1706         IF( nbondi == -1 .OR. nbondi == 0 ) THEN
1707            DO jl = 1, jpreci
1708               ztab(iihom+jl,:) = t2ew(:,jl,2)
1709            END DO
1710         ENDIF
1711
1712
1713         ! 2. North and south directions
1714         ! -----------------------------
1715         !
1716         IF( nbondj /= 2 ) THEN         ! Read Dirichlet lateral conditions
1717            ijhom = nlcj-nrecj
1718            DO jl = 1, jprecj
1719               t2sn(:,jl,1) = ztab(:,ijhom +jl)
1720               t2ns(:,jl,1) = ztab(:,jprecj+jl)
1721            END DO
1722         ENDIF
1723         !
1724         !                              ! Migrations
1725         imigr = jprecj * jpi
1726         !
1727         IF( nbondj == -1 ) THEN
1728            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1729            CALL mpprecv( 3, t2ns(1,1,2), imigr )
1730            IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
1731         ELSEIF( nbondj == 0 ) THEN
1732            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1733            CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1734            CALL mpprecv( 3, t2ns(1,1,2), imigr )
1735            CALL mpprecv( 4, t2sn(1,1,2), imigr )
1736            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1737            IF( l_isend )   CALL mpi_wait( ml_req2, ml_stat, ml_err )
1738         ELSEIF( nbondj == 1 ) THEN
1739            CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1740            CALL mpprecv( 4, t2sn(1,1,2), imigr)
1741            IF( l_isend )   CALL mpi_wait( ml_req1, ml_stat, ml_err )
1742         ENDIF
1743         !
1744         !                              ! Write Dirichlet lateral conditions
1745         ijhom = nlcj - jprecj
1746         IF( nbondj == 0 .OR. nbondj == 1 ) THEN
1747            DO jl = 1, jprecj
1748               ztab(:,jl) = t2sn(:,jl,2)
1749            END DO
1750         ENDIF
1751         IF( nbondj == 0 .OR. nbondj == -1 ) THEN
1752            DO jl = 1, jprecj
1753               ztab(:,ijhom+jl) = t2ns(:,jl,2)
1754            END DO
1755         ENDIF
1756         IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
1757            DO jj = ijpt0, ijpt1            ! north/south boundaries
1758               DO ji = iipt0,ilpt1
1759                  ptab(ji,jk) = ztab(ji,jj) 
1760               END DO
1761            END DO
1762         ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
1763            DO jj = ijpt0, ilpt1            ! east/west boundaries
1764               DO ji = iipt0,iipt1
1765                  ptab(jj,jk) = ztab(ji,jj) 
1766               END DO
1767            END DO
1768         ENDIF
1769         !
1770      END DO
1771      !
1772   END SUBROUTINE mppobc
1773   
1774
1775   SUBROUTINE mpp_comm_free( kcom )
1776      !!----------------------------------------------------------------------
1777      !!----------------------------------------------------------------------
1778      INTEGER, INTENT(in) ::   kcom
1779      !!
1780      INTEGER :: ierr
1781      !!----------------------------------------------------------------------
1782      !
1783      CALL MPI_COMM_FREE(kcom, ierr)
1784      !
1785   END SUBROUTINE mpp_comm_free
1786
1787
1788   SUBROUTINE mpp_ini_ice( pindic )
1789      !!----------------------------------------------------------------------
1790      !!               ***  routine mpp_ini_ice  ***
1791      !!
1792      !! ** Purpose :   Initialize special communicator for ice areas
1793      !!      condition together with global variables needed in the ddmpp folding
1794      !!
1795      !! ** Method  : - Look for ice processors in ice routines
1796      !!              - Put their number in nrank_ice
1797      !!              - Create groups for the world processors and the ice processors
1798      !!              - Create a communicator for ice processors
1799      !!
1800      !! ** output
1801      !!      njmppmax = njmpp for northern procs
1802      !!      ndim_rank_ice = number of processors with ice
1803      !!      nrank_ice (ndim_rank_ice) = ice processors
1804      !!      ngrp_world = group ID for the world processors
1805      !!      ngrp_ice = group ID for the ice processors
1806      !!      ncomm_ice = communicator for the ice procs.
1807      !!      n_ice_root = number (in the world) of proc 0 in the ice comm.
1808      !!
1809      !!----------------------------------------------------------------------
1810      INTEGER, INTENT(in) :: pindic
1811      !!
1812      INTEGER :: ierr
1813      INTEGER :: jjproc
1814      INTEGER :: ii
1815      INTEGER, DIMENSION(jpnij) :: kice
1816      INTEGER, DIMENSION(jpnij) :: zwork
1817      !!----------------------------------------------------------------------
1818      !
1819      ! Look for how many procs with sea-ice
1820      !
1821      kice = 0
1822      DO jjproc = 1, jpnij
1823         IF( jjproc == narea .AND. pindic .GT. 0 )   kice(jjproc) = 1   
1824      END DO
1825      !
1826      zwork = 0
1827      CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
1828      ndim_rank_ice = SUM( zwork )         
1829
1830      ! Allocate the right size to nrank_north
1831#if ! defined key_agrif
1832      IF( ALLOCATED ( nrank_ice ) )   DEALLOCATE( nrank_ice )
1833#else
1834      IF( ASSOCIATED( nrank_ice ) )   DEALLOCATE( nrank_ice )
1835#endif
1836      ALLOCATE( nrank_ice(ndim_rank_ice) )
1837      !
1838      ii = 0     
1839      nrank_ice = 0
1840      DO jjproc = 1, jpnij
1841         IF( zwork(jjproc) == 1) THEN
1842            ii = ii + 1
1843            nrank_ice(ii) = jjproc -1 
1844         ENDIF
1845      END DO
1846
1847      ! Create the world group
1848      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
1849
1850      ! Create the ice group from the world group
1851      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
1852
1853      ! Create the ice communicator , ie the pool of procs with sea-ice
1854      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
1855
1856      ! Find proc number in the world of proc 0 in the north
1857      ! The following line seems to be useless, we just comment & keep it as reminder
1858      ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
1859      !
1860   END SUBROUTINE mpp_ini_ice
1861
1862
1863   SUBROUTINE mpp_ini_znl
1864      !!----------------------------------------------------------------------
1865      !!               ***  routine mpp_ini_znl  ***
1866      !!
1867      !! ** Purpose :   Initialize special communicator for computing zonal sum
1868      !!
1869      !! ** Method  : - Look for processors in the same row
1870      !!              - Put their number in nrank_znl
1871      !!              - Create group for the znl processors
1872      !!              - Create a communicator for znl processors
1873      !!              - Determine if processor should write znl files
1874      !!
1875      !! ** output
1876      !!      ndim_rank_znl = number of processors on the same row
1877      !!      ngrp_znl = group ID for the znl processors
1878      !!      ncomm_znl = communicator for the ice procs.
1879      !!      n_znl_root = number (in the world) of proc 0 in the ice comm.
1880      !!
1881      !!----------------------------------------------------------------------
1882      INTEGER :: ierr
1883      INTEGER :: jproc
1884      INTEGER :: ii
1885      INTEGER, DIMENSION(jpnij) :: kwork
1886      !
1887      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world     : ', ngrp_world
1888      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
1889      !-$$     WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa   : ', mpi_comm_opa
1890      !
1891      IF ( jpnj == 1 ) THEN
1892         ngrp_znl  = ngrp_world
1893         ncomm_znl = mpi_comm_opa
1894      ELSE
1895         !
1896         CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
1897         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
1898         !-$$        CALL flush(numout)
1899         !
1900         ! Count number of processors on the same row
1901         ndim_rank_znl = 0
1902         DO jproc=1,jpnij
1903            IF ( kwork(jproc) == njmpp ) THEN
1904               ndim_rank_znl = ndim_rank_znl + 1
1905            ENDIF
1906         END DO
1907         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
1908         !-$$        CALL flush(numout)
1909         ! Allocate the right size to nrank_znl
1910#if ! defined key_agrif
1911         IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
1912#else
1913         IF (ASSOCIATED(nrank_znl)) DEALLOCATE(nrank_znl)
1914#endif
1915         ALLOCATE(nrank_znl(ndim_rank_znl))
1916         ii = 0     
1917         nrank_znl (:) = 0
1918         DO jproc=1,jpnij
1919            IF ( kwork(jproc) == njmpp) THEN
1920               ii = ii + 1
1921               nrank_znl(ii) = jproc -1 
1922            ENDIF
1923         END DO
1924         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
1925         !-$$        CALL flush(numout)
1926
1927         ! Create the opa group
1928         CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
1929         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
1930         !-$$        CALL flush(numout)
1931
1932         ! Create the znl group from the opa group
1933         CALL MPI_GROUP_INCL  ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
1934         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
1935         !-$$        CALL flush(numout)
1936
1937         ! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
1938         CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
1939         !-$$        WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
1940         !-$$        CALL flush(numout)
1941         !
1942      END IF
1943
1944      ! Determines if processor if the first (starting from i=1) on the row
1945      IF ( jpni == 1 ) THEN
1946         l_znl_root = .TRUE.
1947      ELSE
1948         l_znl_root = .FALSE.
1949         kwork (1) = nimpp
1950         CALL mpp_min ( kwork(1), kcom = ncomm_znl)
1951         IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
1952      END IF
1953
1954   END SUBROUTINE mpp_ini_znl
1955
1956
1957   SUBROUTINE mpp_ini_north
1958      !!----------------------------------------------------------------------
1959      !!               ***  routine mpp_ini_north  ***
1960      !!
1961      !! ** Purpose :   Initialize special communicator for north folding
1962      !!      condition together with global variables needed in the mpp folding
1963      !!
1964      !! ** Method  : - Look for northern processors
1965      !!              - Put their number in nrank_north
1966      !!              - Create groups for the world processors and the north processors
1967      !!              - Create a communicator for northern processors
1968      !!
1969      !! ** output
1970      !!      njmppmax = njmpp for northern procs
1971      !!      ndim_rank_north = number of processors in the northern line
1972      !!      nrank_north (ndim_rank_north) = number  of the northern procs.
1973      !!      ngrp_world = group ID for the world processors
1974      !!      ngrp_north = group ID for the northern processors
1975      !!      ncomm_north = communicator for the northern procs.
1976      !!      north_root = number (in the world) of proc 0 in the northern comm.
1977      !!
1978      !!----------------------------------------------------------------------
1979      INTEGER ::   ierr
1980      INTEGER ::   jjproc
1981      INTEGER ::   ii, ji
1982      !!----------------------------------------------------------------------
1983      !
1984      njmppmax = MAXVAL( njmppt )
1985      !
1986      ! Look for how many procs on the northern boundary
1987      ndim_rank_north = 0
1988      DO jjproc = 1, jpnij
1989         IF( njmppt(jjproc) == njmppmax )   ndim_rank_north = ndim_rank_north + 1
1990      END DO
1991      !
1992      ! Allocate the right size to nrank_north
1993#if ! defined key_agrif
1994      IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
1995#else
1996      IF (ASSOCIATED(nrank_north)) DEALLOCATE(nrank_north)
1997#endif
1998      ALLOCATE( nrank_north(ndim_rank_north) )
1999
2000      ! Fill the nrank_north array with proc. number of northern procs.
2001      ! Note : the rank start at 0 in MPI
2002      ii = 0
2003      DO ji = 1, jpnij
2004         IF ( njmppt(ji) == njmppmax   ) THEN
2005            ii=ii+1
2006            nrank_north(ii)=ji-1
2007         END IF
2008      END DO
2009      !
2010      ! create the world group
2011      CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
2012      !
2013      ! Create the North group from the world group
2014      CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
2015      !
2016      ! Create the North communicator , ie the pool of procs in the north group
2017      CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
2018      !
2019   END SUBROUTINE mpp_ini_north
2020
2021
2022   SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
2023      !!---------------------------------------------------------------------
2024      !!                   ***  routine mpp_lbc_north_3d  ***
2025      !!
2026      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2027      !!              in mpp configuration in case of jpn1 > 1
2028      !!
2029      !! ** Method  :   North fold condition and mpp with more than one proc
2030      !!              in i-direction require a specific treatment. We gather
2031      !!              the 4 northern lines of the global domain on 1 processor
2032      !!              and apply lbc north-fold on this sub array. Then we
2033      !!              scatter the north fold array back to the processors.
2034      !!
2035      !!----------------------------------------------------------------------
2036      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   pt3d      ! 3D array on which the b.c. is applied
2037      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2038      !                                                              !   = T ,  U , V , F or W  gridpoints
2039      REAL(wp)                        , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2040      !!                                                             ! =  1. , the sign is kept
2041      INTEGER ::   ji, jj, jr
2042      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2043      INTEGER ::   ijpj, ijpjm1, ij, iproc
2044      REAL(wp), DIMENSION(jpiglo,4,jpk)      ::   ztab
2045      REAL(wp), DIMENSION(jpi   ,4,jpk)      ::   znorthloc
2046      REAL(wp), DIMENSION(jpi   ,4,jpk,jpni) ::   znorthgloio
2047      !!----------------------------------------------------------------------
2048      !   
2049      ijpj   = 4
2050      ijpjm1 = 3
2051      !
2052      DO jj = nlcj - ijpj +1, nlcj          ! put in znorthloc the last 4 jlines of pt3d
2053         ij = jj - nlcj + ijpj
2054         znorthloc(:,ij,:) = pt3d(:,jj,:)
2055      END DO
2056      !
2057      !                                     ! Build in procs of ncomm_north the znorthgloio
2058      itaille = jpi * jpk * ijpj
2059      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
2060         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2061      !
2062      !                                     ! recover the global north array
2063      DO jr = 1, ndim_rank_north
2064         iproc = nrank_north(jr) + 1
2065         ildi  = nldit (iproc)
2066         ilei  = nleit (iproc)
2067         iilb  = nimppt(iproc)
2068         DO jj = 1, 4
2069            DO ji = ildi, ilei
2070               ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
2071            END DO
2072         END DO
2073      END DO
2074      !
2075      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2076      !
2077      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt3d
2078         ij = jj - nlcj + ijpj
2079         DO ji= 1, nlci
2080            pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
2081         END DO
2082      END DO
2083      !
2084   END SUBROUTINE mpp_lbc_north_3d
2085
2086
2087   SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
2088      !!---------------------------------------------------------------------
2089      !!                   ***  routine mpp_lbc_north_2d  ***
2090      !!
2091      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2092      !!              in mpp configuration in case of jpn1 > 1 (for 2d array )
2093      !!
2094      !! ** Method  :   North fold condition and mpp with more than one proc
2095      !!              in i-direction require a specific treatment. We gather
2096      !!              the 4 northern lines of the global domain on 1 processor
2097      !!              and apply lbc north-fold on this sub array. Then we
2098      !!              scatter the north fold array back to the processors.
2099      !!
2100      !!----------------------------------------------------------------------
2101      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   pt2d      ! 3D array on which the b.c. is applied
2102      CHARACTER(len=1)            , INTENT(in   ) ::   cd_type   ! nature of pt3d grid-points
2103      !                                                          !   = T ,  U , V , F or W  gridpoints
2104      REAL(wp)                    , INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold
2105      !!                                                             ! =  1. , the sign is kept
2106      INTEGER ::   ji, jj, jr
2107      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2108      INTEGER ::   ijpj, ijpjm1, ij, iproc
2109      REAL(wp), DIMENSION(jpiglo,4)      ::   ztab
2110      REAL(wp), DIMENSION(jpi   ,4)      ::   znorthloc
2111      REAL(wp), DIMENSION(jpi   ,4,jpni) ::   znorthgloio
2112      !!----------------------------------------------------------------------
2113      !
2114      ijpj   = 4
2115      ijpjm1 = 3
2116      !
2117      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d
2118         ij = jj - nlcj + ijpj
2119         znorthloc(:,ij) = pt2d(:,jj)
2120      END DO
2121
2122      !                                     ! Build in procs of ncomm_north the znorthgloio
2123      itaille = jpi * ijpj
2124      CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,        &
2125         &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2126      !
2127      DO jr = 1, ndim_rank_north            ! recover the global north array
2128         iproc = nrank_north(jr) + 1
2129         ildi=nldit (iproc)
2130         ilei=nleit (iproc)
2131         iilb=nimppt(iproc)
2132         DO jj = 1, 4
2133            DO ji = ildi, ilei
2134               ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2135            END DO
2136         END DO
2137      END DO
2138      !
2139      CALL lbc_nfd( ztab, cd_type, psgn )   ! North fold boundary condition
2140      !
2141      !
2142      DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d
2143         ij = jj - nlcj + ijpj
2144         DO ji = 1, nlci
2145            pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2146         END DO
2147      END DO
2148      !
2149   END SUBROUTINE mpp_lbc_north_2d
2150
2151
2152   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
2153      !!---------------------------------------------------------------------
2154      !!                   ***  routine mpp_lbc_north_2d  ***
2155      !!
2156      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
2157      !!              in mpp configuration in case of jpn1 > 1 and for 2d
2158      !!              array with outer extra halo
2159      !!
2160      !! ** Method  :   North fold condition and mpp with more than one proc
2161      !!              in i-direction require a specific treatment. We gather
2162      !!              the 4+2*jpr2dj northern lines of the global domain on 1
2163      !!              processor and apply lbc north-fold on this sub array.
2164      !!              Then we scatter the north fold array back to the processors.
2165      !!
2166      !!----------------------------------------------------------------------
2167      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo
2168      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
2169      !                                                                                         !   = T ,  U , V , F or W -points
2170      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
2171      !!                                                                                        ! north fold, =  1. otherwise
2172      INTEGER ::   ji, jj, jr
2173      INTEGER ::   ierr, itaille, ildi, ilei, iilb
2174      INTEGER ::   ijpj, ij, iproc
2175      REAL(wp), DIMENSION(jpiglo,4+2*jpr2dj)      ::   ztab
2176      REAL(wp), DIMENSION(jpi   ,4+2*jpr2dj)      ::   znorthloc
2177      REAL(wp), DIMENSION(jpi   ,4+2*jpr2dj,jpni) ::   znorthgloio
2178      !!----------------------------------------------------------------------
2179      !
2180      ijpj=4
2181
2182      ij=0
2183      ! put in znorthloc the last 4 jlines of pt2d
2184      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
2185         ij = ij + 1
2186         DO ji = 1, jpi
2187            znorthloc(ji,ij)=pt2d(ji,jj)
2188         END DO
2189      END DO
2190      !
2191      itaille = jpi * ( ijpj + 2 * jpr2dj )
2192      CALL MPI_ALLGATHER( znorthloc(1,1)    , itaille, MPI_DOUBLE_PRECISION,    &
2193         &                znorthgloio(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
2194      !
2195      DO jr = 1, ndim_rank_north            ! recover the global north array
2196         iproc = nrank_north(jr) + 1
2197         ildi = nldit (iproc)
2198         ilei = nleit (iproc)
2199         iilb = nimppt(iproc)
2200         DO jj = 1, ijpj+2*jpr2dj
2201            DO ji = ildi, ilei
2202               ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
2203            END DO
2204         END DO
2205      END DO
2206
2207
2208      ! 2. North-Fold boundary conditions
2209      ! ----------------------------------
2210      CALL lbc_nfd( ztab(:,:), cd_type, psgn, pr2dj = jpr2dj )
2211
2212      ij = jpr2dj
2213      !! Scatter back to pt2d
2214      DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
2215      ij  = ij +1 
2216         DO ji= 1, nlci
2217            pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
2218         END DO
2219      END DO
2220      !
2221   END SUBROUTINE mpp_lbc_north_e
2222
2223
2224   SUBROUTINE mpi_init_opa( code )
2225      !!---------------------------------------------------------------------
2226      !!                   ***  routine mpp_init.opa  ***
2227      !!
2228      !! ** Purpose :: export and attach a MPI buffer for bsend
2229      !!
2230      !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment
2231      !!            but classical mpi_init
2232      !!
2233      !! History :: 01/11 :: IDRIS initial version for IBM only 
2234      !!            08/04 :: R. Benshila, generalisation
2235      !!---------------------------------------------------------------------
2236      INTEGER                                 :: code, ierr
2237      LOGICAL                                 :: mpi_was_called
2238      !!---------------------------------------------------------------------
2239      !
2240      CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization
2241      IF ( code /= MPI_SUCCESS ) THEN
2242         CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
2243         CALL mpi_abort( mpi_comm_world, code, ierr )
2244      ENDIF
2245      !
2246      IF( .NOT. mpi_was_called ) THEN
2247         CALL mpi_init( code )
2248         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
2249         IF ( code /= MPI_SUCCESS ) THEN
2250            CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
2251            CALL mpi_abort( mpi_comm_world, code, ierr )
2252         ENDIF
2253      ENDIF
2254      !
2255      IF( nn_buffer > 0 ) THEN
2256         IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of  : ', nn_buffer
2257         ! Buffer allocation and attachment
2258         ALLOCATE( tampon(nn_buffer) )
2259         CALL mpi_buffer_attach( tampon, nn_buffer,code )
2260      ENDIF
2261      !
2262   END SUBROUTINE mpi_init_opa
2263
2264#else
2265   !!----------------------------------------------------------------------
2266   !!   Default case:            Dummy module        share memory computing
2267   !!----------------------------------------------------------------------
2268   INTERFACE mpp_sum
2269      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
2270   END INTERFACE
2271   INTERFACE mpp_max
2272      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
2273   END INTERFACE
2274   INTERFACE mpp_min
2275      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
2276   END INTERFACE
2277   INTERFACE mppobc
2278      MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
2279   END INTERFACE
2280   INTERFACE mpp_minloc
2281      MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
2282   END INTERFACE
2283   INTERFACE mpp_maxloc
2284      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
2285   END INTERFACE
2286
2287
2288   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag
2289   INTEGER :: ncomm_ice
2290
2291CONTAINS
2292
2293   FUNCTION mynode( ldtxt, localComm ) RESULT (function_value)
2294      CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
2295      INTEGER, OPTIONAL            , INTENT(in   ) ::   localComm
2296      IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) )   function_value = 0
2297      IF( .FALSE. )   ldtxt(:) = 'never done'
2298   END FUNCTION mynode
2299
2300   SUBROUTINE mppsync                       ! Dummy routine
2301   END SUBROUTINE mppsync
2302
2303   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine
2304      REAL   , DIMENSION(:) :: parr
2305      INTEGER               :: kdim
2306      INTEGER, OPTIONAL     :: kcom 
2307      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
2308   END SUBROUTINE mpp_sum_as
2309
2310   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine
2311      REAL   , DIMENSION(:,:) :: parr
2312      INTEGER               :: kdim
2313      INTEGER, OPTIONAL     :: kcom 
2314      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
2315   END SUBROUTINE mpp_sum_a2s
2316
2317   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine
2318      INTEGER, DIMENSION(:) :: karr
2319      INTEGER               :: kdim
2320      INTEGER, OPTIONAL     :: kcom 
2321      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
2322   END SUBROUTINE mpp_sum_ai
2323
2324   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine
2325      REAL                  :: psca
2326      INTEGER, OPTIONAL     :: kcom 
2327      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
2328   END SUBROUTINE mpp_sum_s
2329
2330   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine
2331      integer               :: kint
2332      INTEGER, OPTIONAL     :: kcom 
2333      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
2334   END SUBROUTINE mpp_sum_i
2335
2336   SUBROUTINE mppmax_a_real( parr, kdim, kcom )
2337      REAL   , DIMENSION(:) :: parr
2338      INTEGER               :: kdim
2339      INTEGER, OPTIONAL     :: kcom 
2340      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2341   END SUBROUTINE mppmax_a_real
2342
2343   SUBROUTINE mppmax_real( psca, kcom )
2344      REAL                  :: psca
2345      INTEGER, OPTIONAL     :: kcom 
2346      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom
2347   END SUBROUTINE mppmax_real
2348
2349   SUBROUTINE mppmin_a_real( parr, kdim, kcom )
2350      REAL   , DIMENSION(:) :: parr
2351      INTEGER               :: kdim
2352      INTEGER, OPTIONAL     :: kcom 
2353      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
2354   END SUBROUTINE mppmin_a_real
2355
2356   SUBROUTINE mppmin_real( psca, kcom )
2357      REAL                  :: psca
2358      INTEGER, OPTIONAL     :: kcom 
2359      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom
2360   END SUBROUTINE mppmin_real
2361
2362   SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
2363      INTEGER, DIMENSION(:) :: karr
2364      INTEGER               :: kdim
2365      INTEGER, OPTIONAL     :: kcom 
2366      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2367   END SUBROUTINE mppmax_a_int
2368
2369   SUBROUTINE mppmax_int( kint, kcom)
2370      INTEGER               :: kint
2371      INTEGER, OPTIONAL     :: kcom 
2372      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom
2373   END SUBROUTINE mppmax_int
2374
2375   SUBROUTINE mppmin_a_int( karr, kdim, kcom )
2376      INTEGER, DIMENSION(:) :: karr
2377      INTEGER               :: kdim
2378      INTEGER, OPTIONAL     :: kcom 
2379      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
2380   END SUBROUTINE mppmin_a_int
2381
2382   SUBROUTINE mppmin_int( kint, kcom )
2383      INTEGER               :: kint
2384      INTEGER, OPTIONAL     :: kcom 
2385      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom
2386   END SUBROUTINE mppmin_int
2387
2388   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
2389      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2390      REAL, DIMENSION(:) ::   parr           ! variable array
2391      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij
2392   END SUBROUTINE mppobc_1d
2393
2394   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
2395      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2396      REAL, DIMENSION(:,:) ::   parr           ! variable array
2397      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij
2398   END SUBROUTINE mppobc_2d
2399
2400   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
2401      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2402      REAL, DIMENSION(:,:,:) ::   parr           ! variable array
2403      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
2404   END SUBROUTINE mppobc_3d
2405
2406   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
2407      INTEGER  ::   kd1, kd2, kl , kk, ktype, kij
2408      REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array
2409      WRITE(*,*) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
2410   END SUBROUTINE mppobc_4d
2411
2412   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
2413      REAL                   :: pmin
2414      REAL , DIMENSION (:,:) :: ptab, pmask
2415      INTEGER :: ki, kj
2416      WRITE(*,*) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
2417   END SUBROUTINE mpp_minloc2d
2418
2419   SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
2420      REAL                     :: pmin
2421      REAL , DIMENSION (:,:,:) :: ptab, pmask
2422      INTEGER :: ki, kj, kk
2423      WRITE(*,*) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2424   END SUBROUTINE mpp_minloc3d
2425
2426   SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
2427      REAL                   :: pmax
2428      REAL , DIMENSION (:,:) :: ptab, pmask
2429      INTEGER :: ki, kj
2430      WRITE(*,*) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
2431   END SUBROUTINE mpp_maxloc2d
2432
2433   SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
2434      REAL                     :: pmax
2435      REAL , DIMENSION (:,:,:) :: ptab, pmask
2436      INTEGER :: ki, kj, kk
2437      WRITE(*,*) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
2438   END SUBROUTINE mpp_maxloc3d
2439
2440   SUBROUTINE mppstop
2441      WRITE(*,*) 'mppstop: You should not have seen this print! error?'
2442   END SUBROUTINE mppstop
2443
2444   SUBROUTINE mpp_ini_ice( kcom )
2445      INTEGER :: kcom
2446      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?', kcom
2447   END SUBROUTINE mpp_ini_ice
2448
2449   SUBROUTINE mpp_ini_znl
2450      WRITE(*,*) 'mpp_ini_znl: You should not have seen this print! error?'
2451   END SUBROUTINE mpp_ini_znl
2452
2453   SUBROUTINE mpp_comm_free( kcom )
2454      INTEGER :: kcom
2455      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?', kcom
2456   END SUBROUTINE mpp_comm_free
2457
2458#endif
2459   !!----------------------------------------------------------------------
2460END MODULE lib_mpp
Note: See TracBrowser for help on using the repository browser.