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

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

lib_mpp.F90 in branches/dev_1784_OBS/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/dev_1784_OBS/NEMO/OPA_SRC/lib_mpp.F90 @ 2001

Last change on this file since 2001 was 2001, checked in by djlea, 14 years ago
Adding observation operator code
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 105.1 KB

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

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

Download in other formats: