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 trunk/NEMO/OPA_SRC – NEMO

Context Navigation

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

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

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

Download in other formats: