Context Navigation

lib_mpp.F90 @ 2004

Last change on this file since 2004 was 2004, checked in by acc, 14 years ago
ticket #684 step 8: Add in changes from the trunk between revisions 1879 and the 3.2.1 tag (rev 1986)
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 115.5 KB

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

Note: See TracBrowser for help on using the repository browser.

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

Context Navigation

source: branches/DEV_r1784_mid_year_merge_2010/NEMO/OPA_SRC/lib_mpp.F90 @ 2004

Download in other formats: