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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in tags/nemo_v3_2/nemo_v3_2/NEMO/OPA_SRC – NEMO

Context Navigation

source: tags/nemo_v3_2/nemo_v3_2/NEMO/OPA_SRC/lib_mpp.F90 @ 1878

Last change on this file since 1878 was 1878, checked in by flavoni, 14 years ago
initial test for nemogcm
File size: 105.2 KB

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

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

Download in other formats: