Context Navigation

lib_mpp.F90 @ 2363

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

Download in other formats: