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 @ 1550

Last change on this file since 1550 was 1528, checked in by rblod, 15 years ago
Suppress rigid-lid option, see ticket #486
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 103.7 KB

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

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

Download in other formats: