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

Last change on this file since 888 was 888, checked in by ctlod, 16 years ago
merge dev_001_SBC branche with the trunk to include the New Surface Module package, see ticket: #113
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 186.9 KB

Line
1	MODULE lib_mpp
2	!!======================================================================
3	!! * MODULE lib_mpp *
4	!! Ocean numerics: massively parallel processing librairy
5	!!=====================================================================
6	#if defined key_mpp_mpi \|\| defined key_mpp_shmem
7	!!----------------------------------------------------------------------
8	!! 'key_mpp_mpi' OR MPI massively parallel processing library
9	!! 'key_mpp_shmem' SHMEM massively parallel processing library
10	!!----------------------------------------------------------------------
11	!! mynode
12	!! mpparent
13	!! mppshmem
14	!! mpp_lnk : generic interface (defined in lbclnk) for :
15	!! mpp_lnk_2d, mpp_lnk_3d
16	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
17	!! mpp_lnk_e : interface defined in lbclnk
18	!! mpplnks
19	!! mpprecv
20	!! mppsend
21	!! mppscatter
22	!! mppgather
23	!! mpp_isl : generic inteface for :
24	!! mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real
25	!! mpp_min : generic interface for :
26	!! mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
27	!! mpp_max : generic interface for :
28	!! mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
29	!! mpp_sum : generic interface for :
30	!! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
31	!! mpp_minloc
32	!! mpp_maxloc
33	!! mppsync
34	!! mppstop
35	!! mppobc : variant of mpp_lnk for open boundaries
36	!! mpp_ini_north
37	!! mpp_lbc_north
38	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo (nsolv=4)
39	!!----------------------------------------------------------------------
40	!! History :
41	!! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code
42	!! ! 97 (A.M. Treguier) SHMEM additions
43	!! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
44	!! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form
45	!! ! 04 (R. Bourdalle Badie) isend option in mpi
46	!! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
47	!! ! 05 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
48	!!----------------------------------------------------------------------
49	!! OPA 9.0 , LOCEAN-IPSL (2005)
50	!! $Id$
51	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
52	!!---------------------------------------------------------------------
53	!! * Modules used
54	USE dom_oce ! ocean space and time domain
55	USE in_out_manager ! I/O manager
56
57	IMPLICIT NONE
58
59	PRIVATE
60	PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north
61	PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks
62	PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free
63	#if defined key_oasis3 \|\| defined key_oasis4
64	PUBLIC mppsize, mpprank
65	#endif
66
67	!! * Interfaces
68	!! define generic interface for these routine as they are called sometimes
69	!! with scalar arguments instead of array arguments, which causes problems
70	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
71
72	INTERFACE mpp_isl
73	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
74	END INTERFACE
75	INTERFACE mpp_min
76	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
77	END INTERFACE
78	INTERFACE mpp_max
79	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
80	END INTERFACE
81	INTERFACE mpp_sum
82	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
83	END INTERFACE
84	INTERFACE mpp_lbc_north
85	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
86	END INTERFACE
87	INTERFACE mpp_minloc
88	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
89	END INTERFACE
90	INTERFACE mpp_maxloc
91	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
92	END INTERFACE
93
94
95	!! * Share module variables
96	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
97
98	!! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
99	INTEGER, PARAMETER :: &
100	nprocmax = 2**10 ! maximun dimension
101
102	#if defined key_mpp_mpi
103	!! ========================= !!
104	!! MPI variable definition !!
105	!! ========================= !!
106	!$AGRIF_DO_NOT_TREAT
107	# include <mpif.h>
108	!$AGRIF_END_DO_NOT_TREAT
109
110	INTEGER :: &
111	mppsize, & ! number of process
112	mpprank, & ! process number [ 0 - size-1 ]
113	mpi_comm_opa ! opa local communicator
114
115	! variables used in case of sea-ice
116	INTEGER, PUBLIC :: & !
117	ngrp_ice, & ! group ID for the ice processors (to compute rheology)
118	ncomm_ice, & ! communicator made by the processors with sea-ice
119	ndim_rank_ice, & ! number of 'ice' processors
120	n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
121	INTEGER, DIMENSION(:), ALLOCATABLE :: &
122	nrank_ice ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
123	! variables used in case of north fold condition in mpp_mpi with jpni > 1
124	INTEGER :: & !
125	ngrp_world, & ! group ID for the world processors
126	ngrp_north, & ! group ID for the northern processors (to be fold)
127	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
128	ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !)
129	njmppmax ! value of njmpp for the processors of the northern line
130	INTEGER :: & !
131	north_root ! number (in the comm_opa) of proc 0 in the northern comm
132	INTEGER, DIMENSION(:), ALLOCATABLE :: &
133	nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
134	CHARACTER (len=1) :: &
135	c_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
136	LOGICAL :: &
137	l_isend = .FALSE. ! isend use indicator (T if c_mpi_send='I')
138
139
140	#elif defined key_mpp_shmem
141	!! ========================= !!
142	!! SHMEM variable definition !!
143	!! ========================= !!
144	# include <fpvm3.h>
145	# include <mpp/shmem.fh>
146
147	CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name
148	CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name
149	CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall())
150
151	INTEGER, PARAMETER :: & !! SHMEM control print
152	mynode_print = 0, & ! flag for print, mynode routine
153	mpprecv_print = 0, & ! flag for print, mpprecv routine
154	mppsend_print = 0, & ! flag for print, mppsend routine
155	mppsync_print = 0, & ! flag for print, mppsync routine
156	mppsum_print = 0, & ! flag for print, mpp_sum routine
157	mppisl_print = 0, & ! flag for print, mpp_isl routine
158	mppmin_print = 0, & ! flag for print, mpp_min routine
159	mppmax_print = 0, & ! flag for print, mpp_max routine
160	mpparent_print = 0 ! flag for print, mpparent routine
161
162	INTEGER, PARAMETER :: & !! Variable definition
163	jpvmint = 21 ! ???
164
165	INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors
166	jpmsec = 50000, & ! ???
167	jpmpplat = 30, & ! ???
168	jpmppsum = MAX( jpisljpisl, jpmpplatjpk, jpmsec ) ! ???
169
170	INTEGER :: &
171	npvm_ipas , & ! pvm initialization flag
172	npvm_mytid, & ! pvm tid
173	npvm_me , & ! node number [ 0 - nproc-1 ]
174	npvm_nproc, & ! real number of nodes
175	npvm_inum ! ???
176	INTEGER, DIMENSION(0:nprocmax-1) :: &
177	npvm_tids ! tids array [ 0 - nproc-1 ]
178
179	INTEGER :: &
180	nt3d_ipas , & ! pvm initialization flag
181	nt3d_mytid, & ! pvm tid
182	nt3d_me , & ! node number [ 0 - nproc-1 ]
183	nt3d_nproc ! real number of nodes
184	INTEGER, DIMENSION(0:nprocmax-1) :: &
185	nt3d_tids ! tids array [ 0 - nproc-1 ]
186
187	!! real sum reduction
188	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
189	nrs1sync_shmem, & !
190	nrs2sync_shmem
191	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
192	wrs1wrk_shmem, & !
193	wrs2wrk_shmem !
194	REAL(wp), DIMENSION(jpmppsum) :: &
195	wrstab_shmem !
196
197	!! minimum and maximum reduction
198	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
199	ni1sync_shmem, & !
200	ni2sync_shmem !
201	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
202	wi1wrk_shmem, & !
203	wi2wrk_shmem
204	REAL(wp), DIMENSION(jpmppsum) :: &
205	wintab_shmem, & !
206	wi1tab_shmem, & !
207	wi2tab_shmem !
208
209	!! value not equal zero for barotropic stream function around islands
210	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
211	ni11sync_shmem, & !
212	ni12sync_shmem, & !
213	ni21sync_shmem, & !
214	ni22sync_shmem !
215	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
216	wi11wrk_shmem, & !
217	wi12wrk_shmem, & !
218	wi21wrk_shmem, & !
219	wi22wrk_shmem !
220	REAL(wp), DIMENSION(jpmppsum) :: &
221	wiltab_shmem , & !
222	wi11tab_shmem, & !
223	wi12tab_shmem, & !
224	wi21tab_shmem, & !
225	wi22tab_shmem
226
227	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
228	ni11wrk_shmem, & !
229	ni12wrk_shmem, & !
230	ni21wrk_shmem, & !
231	ni22wrk_shmem !
232	INTEGER, DIMENSION(jpmppsum) :: &
233	niitab_shmem , & !
234	ni11tab_shmem, & !
235	ni12tab_shmem !
236	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
237	nis1sync_shmem, & !
238	nis2sync_shmem !
239	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
240	nis1wrk_shmem, & !
241	nis2wrk_shmem !
242	INTEGER, DIMENSION(jpmppsum) :: &
243	nistab_shmem
244
245	!! integer sum reduction
246	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
247	nil1sync_shmem, & !
248	nil2sync_shmem !
249	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
250	nil1wrk_shmem, & !
251	nil2wrk_shmem !
252	INTEGER, DIMENSION(jpmppsum) :: &
253	niltab_shmem
254	#endif
255
256	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: &
257	t4ns, t4sn ! 3d message passing arrays north-south & south-north
258	REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: &
259	t4ew, t4we ! 3d message passing arrays east-west & west-east
260	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: &
261	t4p1, t4p2 ! 3d message passing arrays north fold
262	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
263	t3ns, t3sn ! 3d message passing arrays north-south & south-north
264	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &
265	t3ew, t3we ! 3d message passing arrays east-west & west-east
266	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
267	t3p1, t3p2 ! 3d message passing arrays north fold
268	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
269	t2ns, t2sn ! 2d message passing arrays north-south & south-north
270	REAL(wp), DIMENSION(jpj,jpreci,2) :: &
271	t2ew, t2we ! 2d message passing arrays east-west & west-east
272	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
273	t2p1, t2p2 ! 2d message passing arrays north fold
274	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) :: &
275	tr2ns, tr2sn ! 2d message passing arrays north-south & south-north including extra outer halo
276	REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) :: &
277	tr2ew, tr2we ! 2d message passing arrays east-west & west-east including extra outer halo
278	!!----------------------------------------------------------------------
279	!! OPA 9.0 , LOCEAN-IPSL (2005)
280	!! $Id$
281	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
282	!!---------------------------------------------------------------------
283
284	CONTAINS
285
286	FUNCTION mynode(localComm)
287	!!----------------------------------------------------------------------
288	!! * routine mynode *
289	!!
290	!! ** Purpose : Find processor unit
291	!!
292	!!----------------------------------------------------------------------
293	#if defined key_mpp_mpi
294	!! * Local variables (MPI version)
295	INTEGER :: mynode, ierr, code
296	LOGICAL :: mpi_was_called
297	INTEGER,OPTIONAL :: localComm
298	NAMELIST/nam_mpp/ c_mpi_send
299	!!----------------------------------------------------------------------
300
301	WRITE(numout,*)
302	WRITE(numout,*) 'mynode : mpi initialisation'
303	WRITE(numout,*) '~~~~~~ '
304	WRITE(numout,*)
305
306	! Namelist namrun : parameters of the run
307	REWIND( numnam )
308	READ ( numnam, nam_mpp )
309
310	WRITE(numout,*) ' Namelist nam_mpp'
311	WRITE(numout,*) ' mpi send type c_mpi_send = ', c_mpi_send
312
313	#if defined key_agrif
314	IF( Agrif_Root() ) THEN
315	#endif
316	!!bug RB : should be clean to use Agrif in coupled mode
317	#if ! defined key_agrif
318	CALL mpi_initialized ( mpi_was_called, code )
319	IF( code /= MPI_SUCCESS ) THEN
320	CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
321	CALL mpi_abort( mpi_comm_world, code, ierr )
322	ENDIF
323
324	IF( PRESENT(localComm) .and. mpi_was_called ) THEN
325	mpi_comm_opa = localComm
326	SELECT CASE ( c_mpi_send )
327	CASE ( 'S' ) ! Standard mpi send (blocking)
328	WRITE(numout,*) ' Standard blocking mpi send (send)'
329	CASE ( 'B' ) ! Buffer mpi send (blocking)
330	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
331	CALL mpi_init_opa( ierr )
332	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
333	WRITE(numout,*) ' Immediate non-blocking send (isend)'
334	l_isend = .TRUE.
335	CASE DEFAULT
336	WRITE(numout,cform_err)
337	WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send
338	nstop = nstop + 1
339	END SELECT
340	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
341	WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator '
342	WRITE(numout,*) ' without calling MPI_Init before ! '
343	ELSE
344	#endif
345	SELECT CASE ( c_mpi_send )
346	CASE ( 'S' ) ! Standard mpi send (blocking)
347	WRITE(numout,*) ' Standard blocking mpi send (send)'
348	CALL mpi_init( ierr )
349	CASE ( 'B' ) ! Buffer mpi send (blocking)
350	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
351	CALL mpi_init_opa( ierr )
352	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
353	WRITE(numout,*) ' Immediate non-blocking send (isend)'
354	l_isend = .TRUE.
355	CALL mpi_init( ierr )
356	CASE DEFAULT
357	WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send
358	CALL ctl_stop( ctmp1 )
359	END SELECT
360
361	#if ! defined key_agrif
362	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
363	IF( code /= MPI_SUCCESS ) THEN
364	CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
365	CALL mpi_abort( mpi_comm_world, code, ierr )
366	ENDIF
367	!
368	ENDIF
369	#endif
370	#if defined key_agrif
371	ELSE
372	SELECT CASE ( c_mpi_send )
373	CASE ( 'S' ) ! Standard mpi send (blocking)
374	WRITE(numout,*) ' Standard blocking mpi send (send)'
375	CASE ( 'B' ) ! Buffer mpi send (blocking)
376	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
377	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
378	WRITE(numout,*) ' Immediate non-blocking send (isend)'
379	l_isend = .TRUE.
380	CASE DEFAULT
381	WRITE(numout,cform_err)
382	WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send
383	nstop = nstop + 1
384	END SELECT
385	ENDIF
386
387	mpi_comm_opa = mpi_comm_world
388	#endif
389	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
390	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
391	mynode = mpprank
392	#else
393	!! * Local variables (SHMEM version)
394	INTEGER :: mynode
395	INTEGER :: &
396	imypid, imyhost, ji, info, iparent_tid
397	!!----------------------------------------------------------------------
398
399	IF( npvm_ipas /= nprocmax ) THEN
400	! --- first passage in mynode
401	! -------------
402	! enroll in pvm
403	! -------------
404	CALL pvmfmytid( npvm_mytid )
405	IF( mynode_print /= 0 ) THEN
406	WRITE(numout,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
407	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
408	ENDIF
409
410	! ---------------------------------------------------------------
411	! find out IF i am parent or child spawned processes have parents
412	! ---------------------------------------------------------------
413	CALL mpparent( iparent_tid )
414	IF( mynode_print /= 0 ) THEN
415	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
416	& ' after mpparent, npvm_tids(0) = ', &
417	& npvm_tids(0), ' iparent_tid=', iparent_tid
418	ENDIF
419	IF( iparent_tid < 0 ) THEN
420	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
421	& ' after mpparent, npvm_tids(0) = ', &
422	& npvm_tids(0), ' iparent_tid=', iparent_tid
423	npvm_tids(0) = npvm_mytid
424	npvm_me = 0
425	IF( jpnij > nprocmax ) THEN
426	WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great'
427	CALL ctl_stop( ctmp1 )
428
429	ELSE
430	npvm_nproc = jpnij
431	ENDIF
432
433	! -------------------------
434	! start up copies of myself
435	! -------------------------
436	IF( npvm_nproc > 1 ) THEN
437	DO ji = 1, npvm_nproc-1
438	npvm_tids(ji) = nt3d_tids(ji)
439	END DO
440	info=npvm_nproc-1
441
442	IF( mynode_print /= 0 ) THEN
443	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
444	& ' maitre=',executable,' info=', info &
445	& ,' npvm_nproc=',npvm_nproc
446	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
447	& ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
448	ENDIF
449
450	! ---------------------------
451	! multicast tids array to children
452	! ---------------------------
453	CALL pvmfinitsend( pvmdefault, info )
454	CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info )
455	CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
456	CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
457	ENDIF
458	ELSE
459
460	! ---------------------------------
461	! receive the tids array and set me
462	! ---------------------------------
463	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
464	CALL pvmfrecv( iparent_tid, 10, info )
465	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
466	CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info )
467	CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
468	IF( mynode_print /= 0 ) THEN
469	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
470	& ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
471	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
472	& 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
473	ENDIF
474	DO ji = 0, npvm_nproc-1
475	IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
476	END DO
477	ENDIF
478
479	! ------------------------------------------------------------
480	! all nproc tasks are equal now
481	! and can address each other by tids(0) thru tids(nproc-1)
482	! for each process me => process number [0-(nproc-1)]
483	! ------------------------------------------------------------
484	CALL pvmfjoingroup ( "bidon", info )
485	CALL pvmfbarrier ( "bidon", npvm_nproc, info )
486	DO ji = 0, npvm_nproc-1
487	IF( ji == npvm_me ) THEN
488	CALL pvmfjoingroup ( opaall, npvm_inum )
489	IF( npvm_inum /= npvm_me ) WRITE(numout,*) 'mynode not arrived in the good order for opaall'
490	ENDIF
491	CALL pvmfbarrier( "bidon", npvm_nproc, info )
492	END DO
493	CALL pvmfbarrier( opaall, npvm_nproc, info )
494
495	ELSE
496	! --- other passage in mynode
497	ENDIF
498
499	npvm_ipas = nprocmax
500	mynode = npvm_me
501	imypid = npvm_mytid
502	imyhost = npvm_tids(0)
503	IF( mynode_print /= 0 ) THEN
504	WRITE(numout,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, &
505	& ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
506	ENDIF
507	#endif
508	END FUNCTION mynode
509
510
511	SUBROUTINE mpparent( kparent_tid )
512	!!----------------------------------------------------------------------
513	!! * routine mpparent *
514	!!
515	!! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem)
516	!! or only return -1 (key_mpp_mpi)
517	!!----------------------------------------------------------------------
518	!! * Arguments
519	INTEGER, INTENT(inout) :: kparent_tid ! ???
520
521	#if defined key_mpp_mpi
522	! MPI version : retour -1
523
524	kparent_tid = -1
525
526	#else
527	!! * Local variables (SHMEN onto T3E version)
528	INTEGER :: &
529	it3d_my_pe, LEADZ, ji, info
530
531	CALL pvmfmytid( nt3d_mytid )
532	CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
533	IF( mpparent_print /= 0 ) THEN
534	WRITE(numout,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
535	ENDIF
536	IF( it3d_my_pe == 0 ) THEN
537	!-----------------------------------------------------------------!
538	! process = 0 => receive other tids !
539	!-----------------------------------------------------------------!
540	kparent_tid = -1
541	IF(mpparent_print /= 0 ) THEN
542	WRITE(numout,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
543	ENDIF
544	! --- END receive dimension ---
545	IF( jpnij > nprocmax ) THEN
546	WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great'
547	CALL ctl_stop( ctmp1 )
548	ELSE
549	nt3d_nproc = jpnij
550	ENDIF
551	IF( mpparent_print /= 0 ) THEN
552	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
553	ENDIF
554	!-------- receive tids from others process --------
555	DO ji = 1, nt3d_nproc-1
556	CALL pvmfrecv( ji , 100, info )
557	CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
558	IF( mpparent_print /= 0 ) THEN
559	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
560	ENDIF
561	END DO
562	nt3d_tids(0) = nt3d_mytid
563	IF( mpparent_print /= 0 ) THEN
564	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), &
565	ji = 0, nt3d_nproc-1 )
566	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
567	ENDIF
568
569	ELSE
570	!!----------------------------------------------------------------!
571	! process <> 0 => send other tids !
572	!!----------------------------------------------------------------!
573	kparent_tid = 0
574	CALL pvmfinitsend( pvmdataraw, info )
575	CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
576	CALL pvmfsend( kparent_tid, 100, info )
577	ENDIF
578	#endif
579
580	END SUBROUTINE mpparent
581
582	#if defined key_mpp_shmem
583
584	SUBROUTINE mppshmem
585	!!----------------------------------------------------------------------
586	!! * routine mppshmem *
587	!!
588	!! ** Purpose : SHMEM ROUTINE
589	!!
590	!!----------------------------------------------------------------------
591	nrs1sync_shmem = SHMEM_SYNC_VALUE
592	nrs2sync_shmem = SHMEM_SYNC_VALUE
593	nis1sync_shmem = SHMEM_SYNC_VALUE
594	nis2sync_shmem = SHMEM_SYNC_VALUE
595	nil1sync_shmem = SHMEM_SYNC_VALUE
596	nil2sync_shmem = SHMEM_SYNC_VALUE
597	ni11sync_shmem = SHMEM_SYNC_VALUE
598	ni12sync_shmem = SHMEM_SYNC_VALUE
599	ni21sync_shmem = SHMEM_SYNC_VALUE
600	ni22sync_shmem = SHMEM_SYNC_VALUE
601	CALL barrier()
602
603	END SUBROUTINE mppshmem
604
605	#endif
606
607	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
608	!!----------------------------------------------------------------------
609	!! * routine mpp_lnk_3d *
610	!!
611	!! ** Purpose : Message passing manadgement
612	!!
613	!! ** Method : Use mppsend and mpprecv function for passing mask
614	!! between processors following neighboring subdomains.
615	!! domain parameters
616	!! nlci : first dimension of the local subdomain
617	!! nlcj : second dimension of the local subdomain
618	!! nbondi : mark for "east-west local boundary"
619	!! nbondj : mark for "north-south local boundary"
620	!! noea : number for local neighboring processors
621	!! nowe : number for local neighboring processors
622	!! noso : number for local neighboring processors
623	!! nono : number for local neighboring processors
624	!!
625	!! ** Action : ptab with update value at its periphery
626	!!
627	!!----------------------------------------------------------------------
628	!! * Arguments
629	CHARACTER(len=1) , INTENT( in ) :: &
630	cd_type ! define the nature of ptab array grid-points
631	! ! = T , U , V , F , W points
632	! ! = S : T-point, north fold treatment ???
633	! ! = G : F-point, north fold treatment ???
634	REAL(wp), INTENT( in ) :: &
635	psgn ! control of the sign change
636	! ! = -1. , the sign is changed if north fold boundary
637	! ! = 1. , the sign is kept if north fold boundary
638	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
639	ptab ! 3D array on which the boundary condition is applied
640	CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
641	cd_mpp ! fill the overlap area only
642	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
643
644	!! * Local variables
645	INTEGER :: ji, jj, jk, jl ! dummy loop indices
646	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
647	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
648	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
649	REAL(wp) :: zland
650	!!----------------------------------------------------------------------
651
652	! 1. standard boundary treatment
653	! ------------------------------
654
655	IF( PRESENT( pval ) ) THEN ! set land value (zero by default)
656	zland = pval
657	ELSE
658	zland = 0.e0
659	ENDIF
660
661	IF( PRESENT( cd_mpp ) ) THEN
662	DO jj = nlcj+1, jpj ! only fill extra allows last line
663	ptab(1:nlci, jj, :) = ptab(1:nlci, nlej, :)
664	END DO
665	DO ji = nlci+1, jpi ! only fill extra allows last column
666	ptab(ji , : , :) = ptab(nlei , : , :)
667	END DO
668	ELSE
669
670	! ! East-West boundaries
671	! ! ====================
672	IF( nbondi == 2 .AND. & ! Cyclic east-west
673	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
674	ptab( 1 ,:,:) = ptab(jpim1,:,:)
675	ptab(jpi,:,:) = ptab( 2 ,:,:)
676
677	ELSE ! closed
678	SELECT CASE ( cd_type )
679	CASE ( 'T', 'U', 'V', 'W' )
680	ptab( 1 :jpreci,:,:) = zland
681	ptab(nlci-jpreci+1:jpi ,:,:) = zland
682	CASE ( 'F' )
683	ptab(nlci-jpreci+1:jpi ,:,:) = zland
684	END SELECT
685	ENDIF
686
687	! ! North-South boundaries
688	! ! ======================
689	SELECT CASE ( cd_type )
690	CASE ( 'T', 'U', 'V', 'W' )
691	ptab(:, 1 :jprecj,:) = zland
692	ptab(:,nlcj-jprecj+1:jpj ,:) = zland
693	CASE ( 'F' )
694	ptab(:,nlcj-jprecj+1:jpj ,:) = zland
695	END SELECT
696
697	ENDIF
698
699	! 2. East and west directions exchange
700	! ------------------------------------
701
702	! 2.1 Read Dirichlet lateral conditions
703
704	SELECT CASE ( nbondi )
705	CASE ( -1, 0, 1 ) ! all exept 2
706	iihom = nlci-nreci
707	DO jl = 1, jpreci
708	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
709	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
710	END DO
711	END SELECT
712
713	! 2.2 Migrations
714
715	#if defined key_mpp_shmem
716	!! * SHMEM version
717
718	imigr = jpreci * jpj * jpk
719
720	SELECT CASE ( nbondi )
721	CASE ( -1 )
722	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
723	CASE ( 0 )
724	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
725	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
726	CASE ( 1 )
727	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
728	END SELECT
729
730	CALL barrier()
731	CALL shmem_udcflush()
732
733	#elif defined key_mpp_mpi
734	!! * Local variables (MPI version)
735
736	imigr = jpreci * jpj * jpk
737
738	SELECT CASE ( nbondi )
739	CASE ( -1 )
740	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
741	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
742	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
743	CASE ( 0 )
744	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
745	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
746	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
747	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
748	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
749	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
750	CASE ( 1 )
751	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
752	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
753	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
754	END SELECT
755	#endif
756
757	! 2.3 Write Dirichlet lateral conditions
758
759	iihom = nlci-jpreci
760
761	SELECT CASE ( nbondi )
762	CASE ( -1 )
763	DO jl = 1, jpreci
764	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
765	END DO
766	CASE ( 0 )
767	DO jl = 1, jpreci
768	ptab(jl ,:,:) = t3we(:,jl,:,2)
769	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
770	END DO
771	CASE ( 1 )
772	DO jl = 1, jpreci
773	ptab(jl ,:,:) = t3we(:,jl,:,2)
774	END DO
775	END SELECT
776
777
778	! 3. North and south directions
779	! -----------------------------
780
781	! 3.1 Read Dirichlet lateral conditions
782
783	IF( nbondj /= 2 ) THEN
784	ijhom = nlcj-nrecj
785	DO jl = 1, jprecj
786	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
787	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
788	END DO
789	ENDIF
790
791	! 3.2 Migrations
792
793	#if defined key_mpp_shmem
794	!! * SHMEM version
795
796	imigr = jprecj * jpi * jpk
797
798	SELECT CASE ( nbondj )
799	CASE ( -1 )
800	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
801	CASE ( 0 )
802	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
803	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
804	CASE ( 1 )
805	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
806	END SELECT
807
808	CALL barrier()
809	CALL shmem_udcflush()
810
811	#elif defined key_mpp_mpi
812	!! * Local variables (MPI version)
813
814	imigr=jprecjjpijpk
815
816	SELECT CASE ( nbondj )
817	CASE ( -1 )
818	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
819	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
820	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
821	CASE ( 0 )
822	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
823	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
824	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
825	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
826	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
827	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
828	CASE ( 1 )
829	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
830	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
831	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
832	END SELECT
833
834	#endif
835
836	! 3.3 Write Dirichlet lateral conditions
837
838	ijhom = nlcj-jprecj
839
840	SELECT CASE ( nbondj )
841	CASE ( -1 )
842	DO jl = 1, jprecj
843	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
844	END DO
845	CASE ( 0 )
846	DO jl = 1, jprecj
847	ptab(:,jl ,:) = t3sn(:,jl,:,2)
848	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
849	END DO
850	CASE ( 1 )
851	DO jl = 1, jprecj
852	ptab(:,jl,:) = t3sn(:,jl,:,2)
853	END DO
854	END SELECT
855
856
857	! 4. north fold treatment
858	! -----------------------
859
860	IF (PRESENT(cd_mpp)) THEN
861	! No north fold treatment (it is assumed to be already OK)
862
863	ELSE
864
865	! 4.1 treatment without exchange (jpni odd)
866	! T-point pivot
867
868	SELECT CASE ( jpni )
869
870	CASE ( 1 ) ! only one proc along I, no mpp exchange
871
872	SELECT CASE ( npolj )
873
874	CASE ( 3 , 4 ) ! T pivot
875	iloc = jpiglo - 2 * ( nimpp - 1 )
876
877	SELECT CASE ( cd_type )
878
879	CASE ( 'T' , 'S', 'W' )
880	DO jk = 1, jpk
881	DO ji = 2, nlci
882	ijt=iloc-ji+2
883	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
884	END DO
885	DO ji = nlci/2+1, nlci
886	ijt=iloc-ji+2
887	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
888	END DO
889	END DO
890
891	CASE ( 'U' )
892	DO jk = 1, jpk
893	DO ji = 1, nlci-1
894	iju=iloc-ji+1
895	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
896	END DO
897	DO ji = nlci/2, nlci-1
898	iju=iloc-ji+1
899	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
900	END DO
901	END DO
902
903	CASE ( 'V' )
904	DO jk = 1, jpk
905	DO ji = 2, nlci
906	ijt=iloc-ji+2
907	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
908	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)
909	END DO
910	END DO
911
912	CASE ( 'F', 'G' )
913	DO jk = 1, jpk
914	DO ji = 1, nlci-1
915	iju=iloc-ji+1
916	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-2,jk)
917	ptab(ji,nlcj ,jk) = psgn * ptab(iju,nlcj-3,jk)
918	END DO
919	END DO
920
921	END SELECT
922
923	CASE ( 5 , 6 ) ! F pivot
924	iloc=jpiglo-2*(nimpp-1)
925
926	SELECT CASE ( cd_type )
927
928	CASE ( 'T' , 'S', 'W' )
929	DO jk = 1, jpk
930	DO ji = 1, nlci
931	ijt=iloc-ji+1
932	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
933	END DO
934	END DO
935
936	CASE ( 'U' )
937	DO jk = 1, jpk
938	DO ji = 1, nlci-1
939	iju=iloc-ji
940	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
941	END DO
942	END DO
943
944	CASE ( 'V' )
945	DO jk = 1, jpk
946	DO ji = 1, nlci
947	ijt=iloc-ji+1
948	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)
949	END DO
950	DO ji = nlci/2+1, nlci
951	ijt=iloc-ji+1
952	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
953	END DO
954	END DO
955
956	CASE ( 'F', 'G' )
957	DO jk = 1, jpk
958	DO ji = 1, nlci-1
959	iju=iloc-ji
960	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
961	END DO
962	DO ji = nlci/2+1, nlci-1
963	iju=iloc-ji
964	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
965	END DO
966	END DO
967	END SELECT ! cd_type
968
969	END SELECT ! npolj
970
971	CASE DEFAULT ! more than 1 proc along I
972	IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.
973
974	END SELECT ! jpni
975
976	ENDIF
977
978
979	! 5. East and west directions exchange
980	! ------------------------------------
981
982	SELECT CASE ( npolj )
983
984	CASE ( 3, 4, 5, 6 )
985
986	! 5.1 Read Dirichlet lateral conditions
987
988	SELECT CASE ( nbondi )
989
990	CASE ( -1, 0, 1 )
991	iihom = nlci-nreci
992	DO jl = 1, jpreci
993	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
994	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
995	END DO
996
997	END SELECT
998
999	! 5.2 Migrations
1000
1001	#if defined key_mpp_shmem
1002	!! SHMEM version
1003
1004	imigr = jpreci * jpj * jpk
1005
1006	SELECT CASE ( nbondi )
1007	CASE ( -1 )
1008	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1009	CASE ( 0 )
1010	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1011	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1012	CASE ( 1 )
1013	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1014	END SELECT
1015
1016	CALL barrier()
1017	CALL shmem_udcflush()
1018
1019	#elif defined key_mpp_mpi
1020	!! MPI version
1021
1022	imigr=jprecijpjjpk
1023
1024	SELECT CASE ( nbondi )
1025	CASE ( -1 )
1026	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
1027	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1028	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1029	CASE ( 0 )
1030	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1031	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
1032	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1033	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1034	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1035	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1036	CASE ( 1 )
1037	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1038	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1039	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1040	END SELECT
1041	#endif
1042
1043	! 5.3 Write Dirichlet lateral conditions
1044
1045	iihom = nlci-jpreci
1046
1047	SELECT CASE ( nbondi)
1048	CASE ( -1 )
1049	DO jl = 1, jpreci
1050	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1051	END DO
1052	CASE ( 0 )
1053	DO jl = 1, jpreci
1054	ptab(jl ,:,:) = t3we(:,jl,:,2)
1055	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1056	END DO
1057	CASE ( 1 )
1058	DO jl = 1, jpreci
1059	ptab(jl ,:,:) = t3we(:,jl,:,2)
1060	END DO
1061	END SELECT
1062
1063	END SELECT ! npolj
1064
1065	END SUBROUTINE mpp_lnk_3d
1066
1067
1068	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
1069	!!----------------------------------------------------------------------
1070	!! * routine mpp_lnk_2d *
1071	!!
1072	!! ** Purpose : Message passing manadgement for 2d array
1073	!!
1074	!! ** Method : Use mppsend and mpprecv function for passing mask
1075	!! between processors following neighboring subdomains.
1076	!! domain parameters
1077	!! nlci : first dimension of the local subdomain
1078	!! nlcj : second dimension of the local subdomain
1079	!! nbondi : mark for "east-west local boundary"
1080	!! nbondj : mark for "north-south local boundary"
1081	!! noea : number for local neighboring processors
1082	!! nowe : number for local neighboring processors
1083	!! noso : number for local neighboring processors
1084	!! nono : number for local neighboring processors
1085	!!
1086	!!----------------------------------------------------------------------
1087	!! * Arguments
1088	CHARACTER(len=1) , INTENT( in ) :: &
1089	cd_type ! define the nature of pt2d array grid-points
1090	! ! = T , U , V , F , W
1091	! ! = S : T-point, north fold treatment
1092	! ! = G : F-point, north fold treatment
1093	! ! = I : sea-ice velocity at F-point with index shift
1094	REAL(wp), INTENT( in ) :: &
1095	psgn ! control of the sign change
1096	! ! = -1. , the sign is changed if north fold boundary
1097	! ! = 1. , the sign is kept if north fold boundary
1098	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
1099	pt2d ! 2D array on which the boundary condition is applied
1100	CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
1101	cd_mpp ! fill the overlap area only
1102	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
1103
1104	!! * Local variables
1105	INTEGER :: ji, jj, jl ! dummy loop indices
1106	INTEGER :: &
1107	imigr, iihom, ijhom, & ! temporary integers
1108	iloc, ijt, iju ! " "
1109	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1110	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1111	REAL(wp) :: zland
1112	!!----------------------------------------------------------------------
1113
1114	IF( PRESENT( pval ) ) THEN ! set land value (zero by default)
1115	zland = pval
1116	ELSE
1117	zland = 0.e0
1118	ENDIF
1119
1120	! 1. standard boundary treatment
1121	! ------------------------------
1122	IF (PRESENT(cd_mpp)) THEN
1123	DO jj = nlcj+1, jpj ! only fill extra allows last line
1124	pt2d(1:nlci, jj) = pt2d(1:nlci, nlej)
1125	END DO
1126	DO ji = nlci+1, jpi ! only fill extra allows last column
1127	pt2d(ji , : ) = pt2d(nlei , : )
1128	END DO
1129	ELSE
1130
1131	! ! East-West boundaries
1132	! ! ====================
1133	IF( nbondi == 2 .AND. & ! Cyclic east-west
1134	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1135	pt2d( 1 ,:) = pt2d(jpim1,:)
1136	pt2d(jpi,:) = pt2d( 2 ,:)
1137
1138	ELSE ! ... closed
1139	SELECT CASE ( cd_type )
1140	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1141	pt2d( 1 :jpreci,:) = zland
1142	pt2d(nlci-jpreci+1:jpi ,:) = zland
1143	CASE ( 'F' )
1144	pt2d(nlci-jpreci+1:jpi ,:) = zland
1145	END SELECT
1146	ENDIF
1147
1148	! ! North-South boundaries
1149	! ! ======================
1150	SELECT CASE ( cd_type )
1151	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1152	pt2d(:, 1 :jprecj) = zland
1153	pt2d(:,nlcj-jprecj+1:jpj ) = zland
1154	CASE ( 'F' )
1155	pt2d(:,nlcj-jprecj+1:jpj ) = zland
1156	END SELECT
1157
1158	ENDIF
1159
1160
1161	! 2. East and west directions
1162	! ---------------------------
1163
1164	! 2.1 Read Dirichlet lateral conditions
1165
1166	SELECT CASE ( nbondi )
1167	CASE ( -1, 0, 1 ) ! all except 2
1168	iihom = nlci-nreci
1169	DO jl = 1, jpreci
1170	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1171	t2we(:,jl,1) = pt2d(iihom +jl,:)
1172	END DO
1173	END SELECT
1174
1175	! 2.2 Migrations
1176
1177	#if defined key_mpp_shmem
1178	!! * SHMEM version
1179
1180	imigr = jpreci * jpj
1181
1182	SELECT CASE ( nbondi )
1183	CASE ( -1 )
1184	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1185	CASE ( 0 )
1186	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1187	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1188	CASE ( 1 )
1189	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1190	END SELECT
1191
1192	CALL barrier()
1193	CALL shmem_udcflush()
1194
1195	#elif defined key_mpp_mpi
1196	!! * MPI version
1197
1198	imigr = jpreci * jpj
1199
1200	SELECT CASE ( nbondi )
1201	CASE ( -1 )
1202	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1203	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1204	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1205	CASE ( 0 )
1206	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1207	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1208	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1209	CALL mpprecv( 2, t2we(1,1,2), imigr )
1210	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1211	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1212	CASE ( 1 )
1213	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1214	CALL mpprecv( 2, t2we(1,1,2), imigr )
1215	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1216	END SELECT
1217
1218	#endif
1219
1220	! 2.3 Write Dirichlet lateral conditions
1221
1222	iihom = nlci - jpreci
1223	SELECT CASE ( nbondi )
1224	CASE ( -1 )
1225	DO jl = 1, jpreci
1226	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1227	END DO
1228	CASE ( 0 )
1229	DO jl = 1, jpreci
1230	pt2d(jl ,:) = t2we(:,jl,2)
1231	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1232	END DO
1233	CASE ( 1 )
1234	DO jl = 1, jpreci
1235	pt2d(jl ,:) = t2we(:,jl,2)
1236	END DO
1237	END SELECT
1238
1239
1240	! 3. North and south directions
1241	! -----------------------------
1242
1243	! 3.1 Read Dirichlet lateral conditions
1244
1245	IF( nbondj /= 2 ) THEN
1246	ijhom = nlcj-nrecj
1247	DO jl = 1, jprecj
1248	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1249	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1250	END DO
1251	ENDIF
1252
1253	! 3.2 Migrations
1254
1255	#if defined key_mpp_shmem
1256	!! * SHMEM version
1257
1258	imigr = jprecj * jpi
1259
1260	SELECT CASE ( nbondj )
1261	CASE ( -1 )
1262	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1263	CASE ( 0 )
1264	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1265	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1266	CASE ( 1 )
1267	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1268	END SELECT
1269	CALL barrier()
1270	CALL shmem_udcflush()
1271
1272	#elif defined key_mpp_mpi
1273	!! * MPI version
1274
1275	imigr = jprecj * jpi
1276
1277	SELECT CASE ( nbondj )
1278	CASE ( -1 )
1279	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1280	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1281	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1282	CASE ( 0 )
1283	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1284	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1285	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1286	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1287	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1288	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1289	CASE ( 1 )
1290	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1291	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1292	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1293	END SELECT
1294
1295	#endif
1296
1297	! 3.3 Write Dirichlet lateral conditions
1298
1299	ijhom = nlcj - jprecj
1300
1301	SELECT CASE ( nbondj )
1302	CASE ( -1 )
1303	DO jl = 1, jprecj
1304	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1305	END DO
1306	CASE ( 0 )
1307	DO jl = 1, jprecj
1308	pt2d(:,jl ) = t2sn(:,jl,2)
1309	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1310	END DO
1311	CASE ( 1 )
1312	DO jl = 1, jprecj
1313	pt2d(:,jl ) = t2sn(:,jl,2)
1314	END DO
1315	END SELECT
1316
1317
1318	! 4. north fold treatment
1319	! -----------------------
1320
1321	IF (PRESENT(cd_mpp)) THEN
1322	! No north fold treatment (it is assumed to be already OK)
1323
1324	ELSE
1325
1326	! 4.1 treatment without exchange (jpni odd)
1327
1328	SELECT CASE ( jpni )
1329
1330	CASE ( 1 ) ! only one proc along I, no mpp exchange
1331
1332	SELECT CASE ( npolj )
1333
1334	CASE ( 3 , 4 ) ! T pivot
1335	iloc = jpiglo - 2 * ( nimpp - 1 )
1336
1337	SELECT CASE ( cd_type )
1338
1339	CASE ( 'T' , 'S', 'W' )
1340	DO ji = 2, nlci
1341	ijt=iloc-ji+2
1342	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1343	END DO
1344	DO ji = nlci/2+1, nlci
1345	ijt=iloc-ji+2
1346	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1347	END DO
1348
1349	CASE ( 'U' )
1350	DO ji = 1, nlci-1
1351	iju=iloc-ji+1
1352	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1353	END DO
1354	DO ji = nlci/2, nlci-1
1355	iju=iloc-ji+1
1356	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1357	END DO
1358
1359	CASE ( 'V' )
1360	DO ji = 2, nlci
1361	ijt=iloc-ji+2
1362	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1363	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3)
1364	END DO
1365
1366	CASE ( 'F', 'G' )
1367	DO ji = 1, nlci-1
1368	iju=iloc-ji+1
1369	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-2)
1370	pt2d(ji,nlcj ) = psgn * pt2d(iju,nlcj-3)
1371	END DO
1372
1373	CASE ( 'I' ) ! ice U-V point
1374	pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1375	DO ji = 3, nlci
1376	iju = iloc - ji + 3
1377	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1378	END DO
1379
1380	END SELECT
1381
1382	CASE ( 5 , 6 ) ! F pivot
1383	iloc=jpiglo-2*(nimpp-1)
1384
1385	SELECT CASE (cd_type )
1386
1387	CASE ( 'T', 'S', 'W' )
1388	DO ji = 1, nlci
1389	ijt=iloc-ji+1
1390	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1391	END DO
1392
1393	CASE ( 'U' )
1394	DO ji = 1, nlci-1
1395	iju=iloc-ji
1396	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1397	END DO
1398
1399	CASE ( 'V' )
1400	DO ji = 1, nlci
1401	ijt=iloc-ji+1
1402	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2)
1403	END DO
1404	DO ji = nlci/2+1, nlci
1405	ijt=iloc-ji+1
1406	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1407	END DO
1408
1409	CASE ( 'F', 'G' )
1410	DO ji = 1, nlci-1
1411	iju=iloc-ji
1412	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1413	END DO
1414	DO ji = nlci/2+1, nlci-1
1415	iju=iloc-ji
1416	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1417	END DO
1418
1419	CASE ( 'I' ) ! ice U-V point
1420	pt2d( 2 ,nlcj) = zland
1421	DO ji = 2 , nlci-1
1422	ijt = iloc - ji + 2
1423	pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) )
1424	END DO
1425
1426	END SELECT ! cd_type
1427
1428	END SELECT ! npolj
1429
1430	CASE DEFAULT ! more than 1 proc along I
1431	IF( npolj /= 0 ) CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! only for northern procs.
1432
1433	END SELECT ! jpni
1434
1435	ENDIF
1436
1437	! 5. East and west directions
1438	! ---------------------------
1439
1440	SELECT CASE ( npolj )
1441
1442	CASE ( 3, 4, 5, 6 )
1443
1444	! 5.1 Read Dirichlet lateral conditions
1445
1446	SELECT CASE ( nbondi )
1447	CASE ( -1, 0, 1 )
1448	iihom = nlci-nreci
1449	DO jl = 1, jpreci
1450	DO jj = 1, jpj
1451	t2ew(jj,jl,1) = pt2d(jpreci+jl,jj)
1452	t2we(jj,jl,1) = pt2d(iihom +jl,jj)
1453	END DO
1454	END DO
1455	END SELECT
1456
1457	! 5.2 Migrations
1458
1459	#if defined key_mpp_shmem
1460	!! * SHMEM version
1461
1462	imigr=jpreci*jpj
1463
1464	SELECT CASE ( nbondi )
1465	CASE ( -1 )
1466	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1467	CASE ( 0 )
1468	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1469	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1470	CASE ( 1 )
1471	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1472	END SELECT
1473
1474	CALL barrier()
1475	CALL shmem_udcflush()
1476
1477	#elif defined key_mpp_mpi
1478	!! * MPI version
1479
1480	imigr=jpreci*jpj
1481
1482	SELECT CASE ( nbondi )
1483	CASE ( -1 )
1484	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1485	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1486	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1487	CASE ( 0 )
1488	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1489	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1490	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1491	CALL mpprecv( 2, t2we(1,1,2), imigr )
1492	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1493	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1494	CASE ( 1 )
1495	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1496	CALL mpprecv( 2, t2we(1,1,2), imigr )
1497	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1498	END SELECT
1499	#endif
1500
1501	! 5.3 Write Dirichlet lateral conditions
1502
1503	iihom = nlci - jpreci
1504
1505	SELECT CASE ( nbondi )
1506	CASE ( -1 )
1507	DO jl = 1, jpreci
1508	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1509	END DO
1510	CASE ( 0 )
1511	DO jl = 1, jpreci
1512	pt2d(jl ,:) = t2we(:,jl,2)
1513	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1514	END DO
1515	CASE ( 1 )
1516	DO jl = 1, jpreci
1517	pt2d(jl,:) = t2we(:,jl,2)
1518	END DO
1519	END SELECT
1520
1521	END SELECT ! npolj
1522
1523	END SUBROUTINE mpp_lnk_2d
1524
1525
1526	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1527	!!----------------------------------------------------------------------
1528	!! * routine mpp_lnk_3d_gather *
1529	!!
1530	!! ** Purpose : Message passing manadgement for two 3D arrays
1531	!!
1532	!! ** Method : Use mppsend and mpprecv function for passing mask
1533	!! between processors following neighboring subdomains.
1534	!! domain parameters
1535	!! nlci : first dimension of the local subdomain
1536	!! nlcj : second dimension of the local subdomain
1537	!! nbondi : mark for "east-west local boundary"
1538	!! nbondj : mark for "north-south local boundary"
1539	!! noea : number for local neighboring processors
1540	!! nowe : number for local neighboring processors
1541	!! noso : number for local neighboring processors
1542	!! nono : number for local neighboring processors
1543	!!
1544	!! ** Action : ptab1 and ptab2 with update value at its periphery
1545	!!
1546	!!----------------------------------------------------------------------
1547	!! * Arguments
1548	CHARACTER(len=1) , INTENT( in ) :: &
1549	cd_type1, cd_type2 ! define the nature of ptab array grid-points
1550	! ! = T , U , V , F , W points
1551	! ! = S : T-point, north fold treatment ???
1552	! ! = G : F-point, north fold treatment ???
1553	REAL(wp), INTENT( in ) :: &
1554	psgn ! control of the sign change
1555	! ! = -1. , the sign is changed if north fold boundary
1556	! ! = 1. , the sign is kept if north fold boundary
1557	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
1558	ptab1, ptab2 ! 3D array on which the boundary condition is applied
1559
1560	!! * Local variables
1561	INTEGER :: ji, jk, jl ! dummy loop indices
1562	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
1563	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1564	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1565	!!----------------------------------------------------------------------
1566
1567	! 1. standard boundary treatment
1568	! ------------------------------
1569	! ! East-West boundaries
1570	! ! ====================
1571	IF( nbondi == 2 .AND. & ! Cyclic east-west
1572	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1573	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1574	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
1575	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1576	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
1577
1578	ELSE ! closed
1579	SELECT CASE ( cd_type1 )
1580	CASE ( 'T', 'U', 'V', 'W' )
1581	ptab1( 1 :jpreci,:,:) = 0.e0
1582	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0
1583	CASE ( 'F' )
1584	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0
1585	END SELECT
1586	SELECT CASE ( cd_type2 )
1587	CASE ( 'T', 'U', 'V', 'W' )
1588	ptab2( 1 :jpreci,:,:) = 0.e0
1589	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
1590	CASE ( 'F' )
1591	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
1592	END SELECT
1593	ENDIF
1594
1595	! ! North-South boundaries
1596	! ! ======================
1597	SELECT CASE ( cd_type1 )
1598	CASE ( 'T', 'U', 'V', 'W' )
1599	ptab1(:, 1 :jprecj,:) = 0.e0
1600	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1601	CASE ( 'F' )
1602	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1603	END SELECT
1604
1605	SELECT CASE ( cd_type2 )
1606	CASE ( 'T', 'U', 'V', 'W' )
1607	ptab2(:, 1 :jprecj,:) = 0.e0
1608	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1609	CASE ( 'F' )
1610	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1611	END SELECT
1612
1613
1614	! 2. East and west directions exchange
1615	! ------------------------------------
1616
1617	! 2.1 Read Dirichlet lateral conditions
1618
1619	SELECT CASE ( nbondi )
1620	CASE ( -1, 0, 1 ) ! all exept 2
1621	iihom = nlci-nreci
1622	DO jl = 1, jpreci
1623	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1624	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1625	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1626	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1627	END DO
1628	END SELECT
1629
1630	! 2.2 Migrations
1631
1632	#if defined key_mpp_shmem
1633	!! * SHMEM version
1634
1635	imigr = jpreci * jpj * jpk *2
1636
1637	SELECT CASE ( nbondi )
1638	CASE ( -1 )
1639	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1640	CASE ( 0 )
1641	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1642	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1643	CASE ( 1 )
1644	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1645	END SELECT
1646
1647	CALL barrier()
1648	CALL shmem_udcflush()
1649
1650	#elif defined key_mpp_mpi
1651	!! * Local variables (MPI version)
1652
1653	imigr = jpreci * jpj * jpk *2
1654
1655	SELECT CASE ( nbondi )
1656	CASE ( -1 )
1657	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
1658	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1659	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1660	CASE ( 0 )
1661	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1662	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
1663	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1664	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1665	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1666	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1667	CASE ( 1 )
1668	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1669	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1670	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1671	END SELECT
1672	#endif
1673
1674	! 2.3 Write Dirichlet lateral conditions
1675
1676	iihom = nlci-jpreci
1677
1678	SELECT CASE ( nbondi )
1679	CASE ( -1 )
1680	DO jl = 1, jpreci
1681	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1682	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1683	END DO
1684	CASE ( 0 )
1685	DO jl = 1, jpreci
1686	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
1687	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1688	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
1689	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1690	END DO
1691	CASE ( 1 )
1692	DO jl = 1, jpreci
1693	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
1694	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
1695	END DO
1696	END SELECT
1697
1698
1699	! 3. North and south directions
1700	! -----------------------------
1701
1702	! 3.1 Read Dirichlet lateral conditions
1703
1704	IF( nbondj /= 2 ) THEN
1705	ijhom = nlcj-nrecj
1706	DO jl = 1, jprecj
1707	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1708	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1709	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1710	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1711	END DO
1712	ENDIF
1713
1714	! 3.2 Migrations
1715
1716	#if defined key_mpp_shmem
1717	!! * SHMEM version
1718
1719	imigr = jprecj * jpi * jpk * 2
1720
1721	SELECT CASE ( nbondj )
1722	CASE ( -1 )
1723	CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1724	CASE ( 0 )
1725	CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1,1), imigr, noso )
1726	CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1727	CASE ( 1 )
1728	CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1;,1), imigr, noso )
1729	END SELECT
1730
1731	CALL barrier()
1732	CALL shmem_udcflush()
1733
1734	#elif defined key_mpp_mpi
1735	!! * Local variables (MPI version)
1736
1737	imigr=jprecj * jpi * jpk * 2
1738
1739	SELECT CASE ( nbondj )
1740	CASE ( -1 )
1741	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1742	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1743	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1744	CASE ( 0 )
1745	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1746	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1747	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1748	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1749	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1750	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1751	CASE ( 1 )
1752	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1753	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1754	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1755	END SELECT
1756
1757	#endif
1758
1759	! 3.3 Write Dirichlet lateral conditions
1760
1761	ijhom = nlcj-jprecj
1762
1763	SELECT CASE ( nbondj )
1764	CASE ( -1 )
1765	DO jl = 1, jprecj
1766	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1767	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1768	END DO
1769	CASE ( 0 )
1770	DO jl = 1, jprecj
1771	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
1772	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1773	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
1774	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1775	END DO
1776	CASE ( 1 )
1777	DO jl = 1, jprecj
1778	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
1779	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
1780	END DO
1781	END SELECT
1782
1783
1784	! 4. north fold treatment
1785	! -----------------------
1786
1787	! 4.1 treatment without exchange (jpni odd)
1788	! T-point pivot
1789
1790	SELECT CASE ( jpni )
1791
1792	CASE ( 1 ) ! only one proc along I, no mpp exchange
1793
1794	SELECT CASE ( npolj )
1795
1796	CASE ( 3 , 4 ) ! T pivot
1797	iloc = jpiglo - 2 * ( nimpp - 1 )
1798
1799	SELECT CASE ( cd_type1 )
1800
1801	CASE ( 'T' , 'S', 'W' )
1802	DO jk = 1, jpk
1803	DO ji = 2, nlci
1804	ijt=iloc-ji+2
1805	ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1806	END DO
1807	DO ji = nlci/2+1, nlci
1808	ijt=iloc-ji+2
1809	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1810	END DO
1811	END DO
1812
1813	CASE ( 'U' )
1814	DO jk = 1, jpk
1815	DO ji = 1, nlci-1
1816	iju=iloc-ji+1
1817	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1818	END DO
1819	DO ji = nlci/2, nlci-1
1820	iju=iloc-ji+1
1821	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1822	END DO
1823	END DO
1824
1825	CASE ( 'V' )
1826	DO jk = 1, jpk
1827	DO ji = 2, nlci
1828	ijt=iloc-ji+2
1829	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1830	ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-3,jk)
1831	END DO
1832	END DO
1833
1834	CASE ( 'F', 'G' )
1835	DO jk = 1, jpk
1836	DO ji = 1, nlci-1
1837	iju=iloc-ji+1
1838	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-2,jk)
1839	ptab1(ji,nlcj ,jk) = psgn * ptab1(iju,nlcj-3,jk)
1840	END DO
1841	END DO
1842
1843	END SELECT
1844
1845	SELECT CASE ( cd_type2 )
1846
1847	CASE ( 'T' , 'S', 'W' )
1848	DO jk = 1, jpk
1849	DO ji = 2, nlci
1850	ijt=iloc-ji+2
1851	ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1852	END DO
1853	DO ji = nlci/2+1, nlci
1854	ijt=iloc-ji+2
1855	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1856	END DO
1857	END DO
1858
1859	CASE ( 'U' )
1860	DO jk = 1, jpk
1861	DO ji = 1, nlci-1
1862	iju=iloc-ji+1
1863	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1864	END DO
1865	DO ji = nlci/2, nlci-1
1866	iju=iloc-ji+1
1867	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1868	END DO
1869	END DO
1870
1871	CASE ( 'V' )
1872	DO jk = 1, jpk
1873	DO ji = 2, nlci
1874	ijt=iloc-ji+2
1875	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1876	ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-3,jk)
1877	END DO
1878	END DO
1879
1880	CASE ( 'F', 'G' )
1881	DO jk = 1, jpk
1882	DO ji = 1, nlci-1
1883	iju=iloc-ji+1
1884	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-2,jk)
1885	ptab2(ji,nlcj ,jk) = psgn * ptab2(iju,nlcj-3,jk)
1886	END DO
1887	END DO
1888
1889	END SELECT
1890
1891	CASE ( 5 , 6 ) ! F pivot
1892	iloc=jpiglo-2*(nimpp-1)
1893
1894	SELECT CASE ( cd_type1 )
1895
1896	CASE ( 'T' , 'S', 'W' )
1897	DO jk = 1, jpk
1898	DO ji = 1, nlci
1899	ijt=iloc-ji+1
1900	ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1901	END DO
1902	END DO
1903
1904	CASE ( 'U' )
1905	DO jk = 1, jpk
1906	DO ji = 1, nlci-1
1907	iju=iloc-ji
1908	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-1,jk)
1909	END DO
1910	END DO
1911
1912	CASE ( 'V' )
1913	DO jk = 1, jpk
1914	DO ji = 1, nlci
1915	ijt=iloc-ji+1
1916	ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1917	END DO
1918	DO ji = nlci/2+1, nlci
1919	ijt=iloc-ji+1
1920	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1921	END DO
1922	END DO
1923
1924	CASE ( 'F', 'G' )
1925	DO jk = 1, jpk
1926	DO ji = 1, nlci-1
1927	iju=iloc-ji
1928	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1929	END DO
1930	DO ji = nlci/2+1, nlci-1
1931	iju=iloc-ji
1932	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1933	END DO
1934	END DO
1935	END SELECT ! cd_type1
1936
1937	SELECT CASE ( cd_type2 )
1938
1939	CASE ( 'T' , 'S', 'W' )
1940	DO jk = 1, jpk
1941	DO ji = 1, nlci
1942	ijt=iloc-ji+1
1943	ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1944	END DO
1945	END DO
1946
1947	CASE ( 'U' )
1948	DO jk = 1, jpk
1949	DO ji = 1, nlci-1
1950	iju=iloc-ji
1951	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-1,jk)
1952	END DO
1953	END DO
1954
1955	CASE ( 'V' )
1956	DO jk = 1, jpk
1957	DO ji = 1, nlci
1958	ijt=iloc-ji+1
1959	ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1960	END DO
1961	DO ji = nlci/2+1, nlci
1962	ijt=iloc-ji+1
1963	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1964	END DO
1965	END DO
1966
1967	CASE ( 'F', 'G' )
1968	DO jk = 1, jpk
1969	DO ji = 1, nlci-1
1970	iju=iloc-ji
1971	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1972	END DO
1973	DO ji = nlci/2+1, nlci-1
1974	iju=iloc-ji
1975	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1976	END DO
1977	END DO
1978
1979	END SELECT ! cd_type2
1980
1981	END SELECT ! npolj
1982
1983	CASE DEFAULT ! more than 1 proc along I
1984	IF ( npolj /= 0 ) THEN
1985	CALL mpp_lbc_north (ptab1, cd_type1, psgn) ! only for northern procs.
1986	CALL mpp_lbc_north (ptab2, cd_type2, psgn) ! only for northern procs.
1987	ENDIF
1988
1989	END SELECT ! jpni
1990
1991
1992	! 5. East and west directions exchange
1993	! ------------------------------------
1994
1995	SELECT CASE ( npolj )
1996
1997	CASE ( 3, 4, 5, 6 )
1998
1999	! 5.1 Read Dirichlet lateral conditions
2000
2001	SELECT CASE ( nbondi )
2002
2003	CASE ( -1, 0, 1 )
2004	iihom = nlci-nreci
2005	DO jl = 1, jpreci
2006	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
2007	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
2008	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
2009	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
2010	END DO
2011
2012	END SELECT
2013
2014	! 5.2 Migrations
2015
2016	#if defined key_mpp_shmem
2017	!! SHMEM version
2018
2019	imigr = jpreci * jpj * jpk * 2
2020
2021	SELECT CASE ( nbondi )
2022	CASE ( -1 )
2023	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2024	CASE ( 0 )
2025	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2026	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2027	CASE ( 1 )
2028	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2029	END SELECT
2030
2031	CALL barrier()
2032	CALL shmem_udcflush()
2033
2034	#elif defined key_mpp_mpi
2035	!! MPI version
2036
2037	imigr = jpreci * jpj * jpk * 2
2038
2039	SELECT CASE ( nbondi )
2040	CASE ( -1 )
2041	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
2042	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2043	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2044	CASE ( 0 )
2045	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2046	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
2047	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2048	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2049	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2050	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2051	CASE ( 1 )
2052	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2053	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2054	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2055	END SELECT
2056	#endif
2057
2058	! 5.3 Write Dirichlet lateral conditions
2059
2060	iihom = nlci-jpreci
2061
2062	SELECT CASE ( nbondi)
2063	CASE ( -1 )
2064	DO jl = 1, jpreci
2065	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2066	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2067	END DO
2068	CASE ( 0 )
2069	DO jl = 1, jpreci
2070	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
2071	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2072	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
2073	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2074	END DO
2075	CASE ( 1 )
2076	DO jl = 1, jpreci
2077	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
2078	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
2079	END DO
2080	END SELECT
2081
2082	END SELECT ! npolj
2083
2084	END SUBROUTINE mpp_lnk_3d_gather
2085
2086
2087	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
2088	!!----------------------------------------------------------------------
2089	!! * routine mpp_lnk_2d_e *
2090	!!
2091	!! ** Purpose : Message passing manadgement for 2d array (with halo)
2092	!!
2093	!! ** Method : Use mppsend and mpprecv function for passing mask
2094	!! between processors following neighboring subdomains.
2095	!! domain parameters
2096	!! nlci : first dimension of the local subdomain
2097	!! nlcj : second dimension of the local subdomain
2098	!! jpr2di : number of rows for extra outer halo
2099	!! jpr2dj : number of columns for extra outer halo
2100	!! nbondi : mark for "east-west local boundary"
2101	!! nbondj : mark for "north-south local boundary"
2102	!! noea : number for local neighboring processors
2103	!! nowe : number for local neighboring processors
2104	!! noso : number for local neighboring processors
2105	!! nono : number for local neighboring processors
2106	!!
2107	!! History :
2108	!!
2109	!! 9.0 ! 05-09 (R. Benshila, G. Madec) original code
2110	!!
2111	!!----------------------------------------------------------------------
2112	!! * Arguments
2113	CHARACTER(len=1) , INTENT( in ) :: &
2114	cd_type ! define the nature of pt2d array grid-points
2115	! ! = T , U , V , F , W
2116	! ! = S : T-point, north fold treatment
2117	! ! = G : F-point, north fold treatment
2118	! ! = I : sea-ice velocity at F-point with index shift
2119	REAL(wp), INTENT( in ) :: &
2120	psgn ! control of the sign change
2121	! ! = -1. , the sign is changed if north fold boundary
2122	! ! = 1. , the sign is kept if north fold boundary
2123	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: &
2124	pt2d ! 2D array on which the boundary condition is applied
2125
2126	!! * Local variables
2127	INTEGER :: ji, jl ! dummy loop indices
2128	INTEGER :: &
2129	imigr, iihom, ijhom, & ! temporary integers
2130	iloc, ijt, iju ! " "
2131	INTEGER :: &
2132	ipreci, iprecj ! temporary integers
2133	INTEGER :: ml_req1, ml_req2, ml_err ! for isend
2134	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for isend
2135	!!---------------------------------------------------------------------
2136
2137	! take into account outer extra 2D overlap area
2138	ipreci = jpreci + jpr2di
2139	iprecj = jprecj + jpr2dj
2140
2141
2142	! 1. standard boundary treatment
2143	! ------------------------------
2144
2145	! ! East-West boundaries
2146	! ! ====================
2147	IF( nbondi == 2 .AND. & ! Cyclic east-west
2148	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
2149	pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:)
2150	pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:)
2151
2152	ELSE ! ... closed
2153	SELECT CASE ( cd_type )
2154	CASE ( 'T', 'U', 'V', 'W' , 'I' )
2155	pt2d( 1-jpr2di :jpreci ,:) = 0.e0
2156	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2157	CASE ( 'F' )
2158	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2159	END SELECT
2160	ENDIF
2161
2162	! ! North-South boundaries
2163	! ! ======================
2164	SELECT CASE ( cd_type )
2165	CASE ( 'T', 'U', 'V', 'W' , 'I' )
2166	pt2d(:, 1-jpr2dj : jprecj ) = 0.e0
2167	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2168	CASE ( 'F' )
2169	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2170	END SELECT
2171
2172
2173	! 2. East and west directions
2174	! ---------------------------
2175
2176	! 2.1 Read Dirichlet lateral conditions
2177
2178	SELECT CASE ( nbondi )
2179	CASE ( -1, 0, 1 ) ! all except 2
2180	iihom = nlci-nreci-jpr2di
2181	DO jl = 1, ipreci
2182	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2183	tr2we(:,jl,1) = pt2d(iihom +jl,:)
2184	END DO
2185	END SELECT
2186
2187	! 2.2 Migrations
2188
2189	#if defined key_mpp_shmem
2190	!! * SHMEM version
2191
2192	imigr = ipreci * ( jpj + 2*jpr2dj)
2193
2194	SELECT CASE ( nbondi )
2195	CASE ( -1 )
2196	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2197	CASE ( 0 )
2198	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2199	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2200	CASE ( 1 )
2201	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2202	END SELECT
2203
2204	CALL barrier()
2205	CALL shmem_udcflush()
2206
2207	#elif defined key_mpp_mpi
2208	!! * MPI version
2209
2210	imigr = ipreci * ( jpj + 2*jpr2dj)
2211
2212	SELECT CASE ( nbondi )
2213	CASE ( -1 )
2214	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2215	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2216	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2217	CASE ( 0 )
2218	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2219	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2220	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2221	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2222	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2223	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2224	CASE ( 1 )
2225	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2226	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2227	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2228	END SELECT
2229
2230	#endif
2231
2232	! 2.3 Write Dirichlet lateral conditions
2233
2234	iihom = nlci - jpreci
2235
2236	SELECT CASE ( nbondi )
2237	CASE ( -1 )
2238	DO jl = 1, ipreci
2239	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2240	END DO
2241	CASE ( 0 )
2242	DO jl = 1, ipreci
2243	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2244	pt2d( iihom+jl,:) = tr2ew(:,jl,2)
2245	END DO
2246	CASE ( 1 )
2247	DO jl = 1, ipreci
2248	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2249	END DO
2250	END SELECT
2251
2252
2253	! 3. North and south directions
2254	! -----------------------------
2255
2256	! 3.1 Read Dirichlet lateral conditions
2257
2258	IF( nbondj /= 2 ) THEN
2259	ijhom = nlcj-nrecj-jpr2dj
2260	DO jl = 1, iprecj
2261	tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
2262	tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
2263	END DO
2264	ENDIF
2265
2266	! 3.2 Migrations
2267
2268	#if defined key_mpp_shmem
2269	!! * SHMEM version
2270
2271	imigr = iprecj * ( jpi + 2*jpr2di )
2272
2273	SELECT CASE ( nbondj )
2274	CASE ( -1 )
2275	CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2276	CASE ( 0 )
2277	CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2278	CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2279	CASE ( 1 )
2280	CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2281	END SELECT
2282	CALL barrier()
2283	CALL shmem_udcflush()
2284
2285	#elif defined key_mpp_mpi
2286	!! * MPI version
2287
2288	imigr = iprecj * ( jpi + 2*jpr2di )
2289
2290	SELECT CASE ( nbondj )
2291	CASE ( -1 )
2292	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
2293	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2294	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2295	CASE ( 0 )
2296	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2297	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
2298	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2299	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2300	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2301	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2302	CASE ( 1 )
2303	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2304	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2305	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2306	END SELECT
2307
2308	#endif
2309
2310	! 3.3 Write Dirichlet lateral conditions
2311
2312	ijhom = nlcj - jprecj
2313
2314	SELECT CASE ( nbondj )
2315	CASE ( -1 )
2316	DO jl = 1, iprecj
2317	pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
2318	END DO
2319	CASE ( 0 )
2320	DO jl = 1, iprecj
2321	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2322	pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
2323	END DO
2324	CASE ( 1 )
2325	DO jl = 1, iprecj
2326	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2327	END DO
2328	END SELECT
2329
2330
2331	! 4. north fold treatment
2332	! -----------------------
2333
2334	! 4.1 treatment without exchange (jpni odd)
2335
2336	SELECT CASE ( jpni )
2337
2338	CASE ( 1 ) ! only one proc along I, no mpp exchange
2339
2340	SELECT CASE ( npolj )
2341
2342	CASE ( 3 , 4 ) ! T pivot
2343	iloc = jpiglo - 2 * ( nimpp - 1 )
2344
2345	SELECT CASE ( cd_type )
2346
2347	CASE ( 'T', 'S', 'W' )
2348	DO jl = 0, iprecj-1
2349	DO ji = 2-jpr2di, nlci+jpr2di
2350	ijt=iloc-ji+2
2351	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2352	END DO
2353	END DO
2354	DO ji = nlci/2+1, nlci+jpr2di
2355	ijt=iloc-ji+2
2356	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2357	END DO
2358
2359	CASE ( 'U' )
2360	DO jl =0, iprecj-1
2361	DO ji = 1-jpr2di, nlci-1-jpr2di
2362	iju=iloc-ji+1
2363	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2364	END DO
2365	END DO
2366	DO ji = nlci/2, nlci-1+jpr2di
2367	iju=iloc-ji+1
2368	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2369	END DO
2370
2371	CASE ( 'V' )
2372	DO jl = -1, iprecj-1
2373	DO ji = 2-jpr2di, nlci+jpr2di
2374	ijt=iloc-ji+2
2375	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-3-jl)
2376	END DO
2377	END DO
2378
2379	CASE ( 'F', 'G' )
2380	DO jl = -1, iprecj-1
2381	DO ji = 1-jpr2di, nlci-1+jpr2di
2382	iju=iloc-ji+1
2383	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-3-jl)
2384	END DO
2385	END DO
2386
2387	CASE ( 'I' ) ! ice U-V point
2388	DO jl = 0, iprecj-1
2389	pt2d(2,nlcj+jl) = psgn * pt2d(3,nlcj-1-jl)
2390	DO ji = 3, nlci+jpr2di
2391	iju = iloc - ji + 3
2392	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2393	END DO
2394	END DO
2395
2396	END SELECT
2397
2398	CASE ( 5 , 6 ) ! F pivot
2399	iloc=jpiglo-2*(nimpp-1)
2400
2401	SELECT CASE (cd_type )
2402
2403	CASE ( 'T', 'S', 'W' )
2404	DO jl = 0, iprecj-1
2405	DO ji = 1-jpr2di, nlci+jpr2di
2406	ijt=iloc-ji+1
2407	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-1-jl)
2408	END DO
2409	END DO
2410
2411	CASE ( 'U' )
2412	DO jl = 0, iprecj-1
2413	DO ji = 1-jpr2di, nlci-1+jpr2di
2414	iju=iloc-ji
2415	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2416	END DO
2417	END DO
2418
2419	CASE ( 'V' )
2420	DO jl = 0, iprecj-1
2421	DO ji = 1-jpr2di, nlci+jpr2di
2422	ijt=iloc-ji+1
2423	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2424	END DO
2425	END DO
2426	DO ji = nlci/2+1, nlci+jpr2di
2427	ijt=iloc-ji+1
2428	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2429	END DO
2430
2431	CASE ( 'F', 'G' )
2432	DO jl = 0, iprecj-1
2433	DO ji = 1-jpr2di, nlci-1+jpr2di
2434	iju=iloc-ji
2435	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2436	END DO
2437	END DO
2438	DO ji = nlci/2+1, nlci-1+jpr2di
2439	iju=iloc-ji
2440	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2441	END DO
2442
2443	CASE ( 'I' ) ! ice U-V point
2444	pt2d( 2 ,nlcj) = 0.e0
2445	DO jl = 0, iprecj-1
2446	DO ji = 2 , nlci-1+jpr2di
2447	ijt = iloc - ji + 2
2448	pt2d(ji,nlcj+jl)= 0.5 * ( pt2d(ji,nlcj-1-jl) + psgn * pt2d(ijt,nlcj-1-jl) )
2449	END DO
2450	END DO
2451
2452	END SELECT ! cd_type
2453
2454	END SELECT ! npolj
2455
2456	CASE DEFAULT ! more than 1 proc along I
2457	IF( npolj /= 0 ) CALL mpp_lbc_north_e( pt2d, cd_type, psgn ) ! only for northern procs
2458
2459	END SELECT ! jpni
2460
2461
2462	! 5. East and west directions
2463	! ---------------------------
2464
2465	SELECT CASE ( npolj )
2466
2467	CASE ( 3, 4, 5, 6 )
2468
2469	! 5.1 Read Dirichlet lateral conditions
2470
2471	SELECT CASE ( nbondi )
2472	CASE ( -1, 0, 1 )
2473	iihom = nlci-nreci-jpr2di
2474	DO jl = 1, ipreci
2475	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2476	tr2we(:,jl,1) = pt2d(iihom +jl,:)
2477	END DO
2478	END SELECT
2479
2480	! 5.2 Migrations
2481
2482	#if defined key_mpp_shmem
2483	!! * SHMEM version
2484
2485	imigr = ipreci * ( jpj + 2*jpr2dj )
2486
2487	SELECT CASE ( nbondi )
2488	CASE ( -1 )
2489	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2490	CASE ( 0 )
2491	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2492	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2493	CASE ( 1 )
2494	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2495	END SELECT
2496
2497	CALL barrier()
2498	CALL shmem_udcflush()
2499
2500	#elif defined key_mpp_mpi
2501	!! * MPI version
2502
2503	imigr=ipreci* ( jpj + 2*jpr2dj )
2504
2505	SELECT CASE ( nbondi )
2506	CASE ( -1 )
2507	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2508	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2509	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2510	CASE ( 0 )
2511	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2512	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2513	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2514	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2515	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2516	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2517	CASE ( 1 )
2518	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2519	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2520	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2521	END SELECT
2522	#endif
2523
2524	! 5.3 Write Dirichlet lateral conditions
2525
2526	iihom = nlci - jpreci
2527
2528	SELECT CASE ( nbondi )
2529	CASE ( -1 )
2530	DO jl = 1, ipreci
2531	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2532	END DO
2533	CASE ( 0 )
2534	DO jl = 1, ipreci
2535	pt2d(jl- jpr2di,:) = tr2we(:,jl,2)
2536	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2537	END DO
2538	CASE ( 1 )
2539	DO jl = 1, ipreci
2540	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2541	END DO
2542	END SELECT
2543
2544	END SELECT ! npolj
2545
2546	END SUBROUTINE mpp_lnk_2d_e
2547
2548
2549	SUBROUTINE mpplnks( ptab )
2550	!!----------------------------------------------------------------------
2551	!! * routine mpplnks *
2552	!!
2553	!! ** Purpose : Message passing manadgement for add 2d array local boundary
2554	!!
2555	!! ** Method : Use mppsend and mpprecv function for passing mask between
2556	!! processors following neighboring subdomains.
2557	!! domain parameters
2558	!! nlci : first dimension of the local subdomain
2559	!! nlcj : second dimension of the local subdomain
2560	!! nbondi : mark for "east-west local boundary"
2561	!! nbondj : mark for "north-south local boundary"
2562	!! noea : number for local neighboring processors
2563	!! nowe : number for local neighboring processors
2564	!! noso : number for local neighboring processors
2565	!! nono : number for local neighboring processors
2566	!!
2567	!!----------------------------------------------------------------------
2568	!! * Arguments
2569	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: &
2570	ptab ! 2D array
2571
2572	!! * Local variables
2573	INTEGER :: ji, jl ! dummy loop indices
2574	INTEGER :: &
2575	imigr, iihom, ijhom ! temporary integers
2576	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
2577	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
2578	!!----------------------------------------------------------------------
2579
2580
2581	! 1. north fold treatment
2582	! -----------------------
2583
2584	! 1.1 treatment without exchange (jpni odd)
2585
2586	SELECT CASE ( npolj )
2587	CASE ( 4 )
2588	DO ji = 1, nlci
2589	ptab(ji,nlcj-2) = ptab(ji,nlcj-2) + t2p1(ji,1,1)
2590	END DO
2591	CASE ( 6 )
2592	DO ji = 1, nlci
2593	ptab(ji,nlcj-1) = ptab(ji,nlcj-1) + t2p1(ji,1,1)
2594	END DO
2595
2596	! 1.2 treatment with exchange (jpni greater than 1)
2597	!
2598	CASE ( 3 )
2599	#if defined key_mpp_shmem
2600
2601	!! * SHMEN version
2602
2603	imigr=jprecj*jpi
2604
2605	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2606	CALL barrier()
2607	CALL shmem_udcflush()
2608
2609	# elif defined key_mpp_mpi
2610	!! * MPI version
2611
2612	imigr=jprecj*jpi
2613
2614	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2615	CALL mpprecv(3,t2p1(1,1,2),imigr)
2616	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2617
2618	#endif
2619
2620	! Write north fold conditions
2621
2622	DO ji = 1, nlci
2623	ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2)
2624	END DO
2625
2626	CASE ( 5 )
2627
2628	#if defined key_mpp_shmem
2629
2630	!! * SHMEN version
2631
2632	imigr=jprecj*jpi
2633
2634	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2635	CALL barrier()
2636	CALL shmem_udcflush()
2637
2638	# elif defined key_mpp_mpi
2639	!! * Local variables (MPI version)
2640
2641	imigr=jprecj*jpi
2642
2643	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2644	CALL mpprecv(3,t2p1(1,1,2),imigr)
2645	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2646
2647	#endif
2648
2649	! Write north fold conditions
2650
2651	DO ji = 1, nlci
2652	ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,2)
2653	END DO
2654
2655	END SELECT
2656
2657
2658	! 2. East and west directions
2659	! ---------------------------
2660
2661	! 2.1 Read Dirichlet lateral conditions
2662
2663	iihom = nlci-jpreci
2664
2665	SELECT CASE ( nbondi )
2666
2667	CASE ( -1, 0, 1 ) ! all except 2
2668	DO jl = 1, jpreci
2669	t2ew(:,jl,1) = ptab( jl ,:)
2670	t2we(:,jl,1) = ptab(iihom+jl,:)
2671	END DO
2672	END SELECT
2673
2674	! 2.2 Migrations
2675
2676	#if defined key_mpp_shmem
2677
2678	!! * SHMEN version
2679
2680	imigr=jpreci*jpj
2681
2682	SELECT CASE ( nbondi )
2683
2684	CASE ( -1 )
2685	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2686
2687	CASE ( 0 )
2688	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2689	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2690
2691	CASE ( 1 )
2692	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2693
2694	END SELECT
2695	CALL barrier()
2696	CALL shmem_udcflush()
2697
2698	# elif defined key_mpp_mpi
2699	!! * Local variables (MPI version)
2700
2701	imigr=jpreci*jpj
2702
2703	SELECT CASE ( nbondi )
2704
2705	CASE ( -1 )
2706	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
2707	CALL mpprecv(1,t2ew(1,1,2),imigr)
2708	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2709	CASE ( 0 )
2710	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2711	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
2712	CALL mpprecv(1,t2ew(1,1,2),imigr)
2713	CALL mpprecv(2,t2we(1,1,2),imigr)
2714	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2715	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2716
2717	CASE ( 1 )
2718	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2719	CALL mpprecv(2,t2we(1,1,2),imigr)
2720	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2721
2722	END SELECT
2723
2724	#endif
2725
2726	! 2.3 Write Dirichlet lateral conditions
2727
2728	iihom = nlci-nreci
2729
2730	SELECT CASE ( nbondi )
2731
2732	CASE ( -1 )
2733	DO jl = 1, jpreci
2734	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2735	END DO
2736
2737	CASE ( 0 )
2738	DO jl = 1, jpreci
2739	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2740	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2741	END DO
2742
2743	CASE ( 1 )
2744	DO jl = 1, jpreci
2745	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2746	END DO
2747	END SELECT
2748
2749
2750	! 3. North and south directions
2751	! -----------------------------
2752
2753	! 3.1 Read Dirichlet lateral conditions
2754
2755	ijhom = nlcj-jprecj
2756
2757	SELECT CASE ( nbondj )
2758
2759	CASE ( -1, 0, 1 )
2760	DO jl = 1, jprecj
2761	t2sn(:,jl,1) = ptab(:,ijhom+jl)
2762	t2ns(:,jl,1) = ptab(:, jl )
2763	END DO
2764
2765	END SELECT
2766
2767	! 3.2 Migrations
2768
2769	#if defined key_mpp_shmem
2770
2771	!! * SHMEN version
2772
2773	imigr=jprecj*jpi
2774
2775	SELECT CASE ( nbondj )
2776
2777	CASE ( -1 )
2778	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2779
2780	CASE ( 0 )
2781	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2782	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2783
2784	CASE ( 1 )
2785	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2786
2787	END SELECT
2788	CALL barrier()
2789	CALL shmem_udcflush()
2790
2791	# elif defined key_mpp_mpi
2792	!! * Local variables (MPI version)
2793
2794	imigr=jprecj*jpi
2795
2796	SELECT CASE ( nbondj )
2797
2798	CASE ( -1 )
2799	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
2800	CALL mpprecv(3,t2ns(1,1,2),imigr)
2801	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2802
2803	CASE ( 0 )
2804	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2805	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
2806	CALL mpprecv(3,t2ns(1,1,2),imigr)
2807	CALL mpprecv(4,t2sn(1,1,2),imigr)
2808	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2809	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2810
2811	CASE ( 1 )
2812	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2813	CALL mpprecv(4,t2sn(1,1,2),imigr)
2814	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2815	END SELECT
2816
2817	#endif
2818
2819	! 3.3 Write Dirichlet lateral conditions
2820
2821	ijhom = nlcj-nrecj
2822
2823	SELECT CASE ( nbondj )
2824
2825	CASE ( -1 )
2826	DO jl = 1, jprecj
2827	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2828	END DO
2829
2830	CASE ( 0 )
2831	DO jl = 1, jprecj
2832	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2833	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2834	END DO
2835
2836	CASE ( 1 )
2837	DO jl = 1, jprecj
2838	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2839	END DO
2840
2841	END SELECT
2842
2843	END SUBROUTINE mpplnks
2844
2845
2846	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req)
2847	!!----------------------------------------------------------------------
2848	!! * routine mppsend *
2849	!!
2850	!! ** Purpose : Send messag passing array
2851	!!
2852	!!----------------------------------------------------------------------
2853	!! * Arguments
2854	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
2855	INTEGER , INTENT( in ) :: kbytes, & ! size of the array pmess
2856	& kdest , & ! receive process number
2857	& ktyp, & ! Tag of the message
2858	& md_req ! Argument for isend
2859	!!----------------------------------------------------------------------
2860	#if defined key_mpp_shmem
2861	!! * SHMEM version : routine not used
2862
2863	#elif defined key_mpp_mpi
2864	!! * MPI version
2865	INTEGER :: iflag
2866
2867	SELECT CASE ( c_mpi_send )
2868	CASE ( 'S' ) ! Standard mpi send (blocking)
2869	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2870	& mpi_comm_opa, iflag )
2871	CASE ( 'B' ) ! Buffer mpi send (blocking)
2872	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2873	& mpi_comm_opa, iflag )
2874	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
2875	! Be carefull, one more argument here : the mpi request identifier..
2876	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2877	& mpi_comm_opa, md_req, iflag )
2878	END SELECT
2879	#endif
2880
2881	END SUBROUTINE mppsend
2882
2883
2884	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
2885	!!----------------------------------------------------------------------
2886	!! * routine mpprecv *
2887	!!
2888	!! ** Purpose : Receive messag passing array
2889	!!
2890	!!----------------------------------------------------------------------
2891	!! * Arguments
2892	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
2893	INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess
2894	& ktyp ! Tag of the recevied message
2895	!!----------------------------------------------------------------------
2896	#if defined key_mpp_shmem
2897	!! * SHMEM version : routine not used
2898
2899	# elif defined key_mpp_mpi
2900	!! * MPI version
2901	INTEGER :: istatus(mpi_status_size)
2902	INTEGER :: iflag
2903
2904	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, &
2905	& mpi_comm_opa, istatus, iflag )
2906	#endif
2907
2908	END SUBROUTINE mpprecv
2909
2910
2911	SUBROUTINE mppgather( ptab, kp, pio )
2912	!!----------------------------------------------------------------------
2913	!! * routine mppgather *
2914	!!
2915	!! ** Purpose : Transfert between a local subdomain array and a work
2916	!! array which is distributed following the vertical level.
2917	!!
2918	!! ** Method :
2919	!!
2920	!!----------------------------------------------------------------------
2921	!! * Arguments
2922	REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ptab ! subdomain input array
2923	INTEGER , INTENT( in ) :: kp ! record length
2924	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: pio ! subdomain input array
2925	!!---------------------------------------------------------------------
2926	#if defined key_mpp_shmem
2927	!! * SHMEM version
2928
2929	CALL barrier()
2930	CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp )
2931	CALL barrier()
2932
2933	#elif defined key_mpp_mpi
2934	!! * Local variables (MPI version)
2935	INTEGER :: itaille,ierror
2936
2937	itaille=jpi*jpj
2938	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille, &
2939	& mpi_double_precision, kp , mpi_comm_opa, ierror )
2940	#endif
2941
2942	END SUBROUTINE mppgather
2943
2944
2945	SUBROUTINE mppscatter( pio, kp, ptab )
2946	!!----------------------------------------------------------------------
2947	!! * routine mppscatter *
2948	!!
2949	!! ** Purpose : Transfert between awork array which is distributed
2950	!! following the vertical level and the local subdomain array.
2951	!!
2952	!! ** Method :
2953	!!
2954	!!----------------------------------------------------------------------
2955	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
2956	INTEGER :: kp ! Tag (not used with MPI
2957	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
2958	!!---------------------------------------------------------------------
2959	#if defined key_mpp_shmem
2960	!! * SHMEM version
2961
2962	CALL barrier()
2963	CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp )
2964	CALL barrier()
2965
2966	# elif defined key_mpp_mpi
2967	!! * Local variables (MPI version)
2968	INTEGER :: itaille, ierror
2969
2970	itaille=jpi*jpj
2971
2972	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille, &
2973	& mpi_double_precision, kp, mpi_comm_opa, ierror )
2974	#endif
2975
2976	END SUBROUTINE mppscatter
2977
2978
2979	SUBROUTINE mppisl_a_int( ktab, kdim )
2980	!!----------------------------------------------------------------------
2981	!! * routine mppisl_a_int *
2982	!!
2983	!! ** Purpose : Massively parallel processors
2984	!! Find the non zero value
2985	!!
2986	!!----------------------------------------------------------------------
2987	!! * Arguments
2988	INTEGER, INTENT( in ) :: kdim ! ???
2989	INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ???
2990
2991	#if defined key_mpp_shmem
2992	!! * Local variables (SHMEM version)
2993	INTEGER :: ji
2994	INTEGER, SAVE :: ibool=0
2995
2996	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', &
2997	& 'change jpmppsum dimension in mpp.h' )
2998
2999	DO ji = 1, kdim
3000	niitab_shmem(ji) = ktab(ji)
3001	END DO
3002	CALL barrier()
3003	IF(ibool == 0 ) THEN
3004	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
3005	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3006	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
3007	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3008	ELSE
3009	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
3010	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3011	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
3012	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3013	ENDIF
3014	CALL barrier()
3015	ibool=ibool+1
3016	ibool=MOD( ibool,2)
3017	DO ji = 1, kdim
3018	IF( ni11tab_shmem(ji) /= 0. ) THEN
3019	ktab(ji) = ni11tab_shmem(ji)
3020	ELSE
3021	ktab(ji) = ni12tab_shmem(ji)
3022	ENDIF
3023	END DO
3024
3025	# elif defined key_mpp_mpi
3026	!! * Local variables (MPI version)
3027	LOGICAL :: lcommute
3028	INTEGER, DIMENSION(kdim) :: iwork
3029	INTEGER :: mpi_isl,ierror
3030
3031	lcommute = .TRUE.
3032	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3033	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer &
3034	, mpi_isl, mpi_comm_opa, ierror )
3035	ktab(:) = iwork(:)
3036	#endif
3037
3038	END SUBROUTINE mppisl_a_int
3039
3040
3041	SUBROUTINE mppisl_int( ktab )
3042	!!----------------------------------------------------------------------
3043	!! * routine mppisl_int *
3044	!!
3045	!! ** Purpose : Massively parallel processors
3046	!! Find the non zero value
3047	!!
3048	!!----------------------------------------------------------------------
3049	!! * Arguments
3050	INTEGER , INTENT( inout ) :: ktab !
3051
3052	#if defined key_mpp_shmem
3053	!! * Local variables (SHMEM version)
3054	INTEGER, SAVE :: ibool=0
3055
3056	niitab_shmem(1) = ktab
3057	CALL barrier()
3058	IF(ibool == 0 ) THEN
3059	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
3060	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3061	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
3062	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3063	ELSE
3064	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
3065	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3066	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
3067	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3068	ENDIF
3069	CALL barrier()
3070	ibool=ibool+1
3071	ibool=MOD( ibool,2)
3072	IF( ni11tab_shmem(1) /= 0. ) THEN
3073	ktab = ni11tab_shmem(1)
3074	ELSE
3075	ktab = ni12tab_shmem(1)
3076	ENDIF
3077
3078	# elif defined key_mpp_mpi
3079
3080	!! * Local variables (MPI version)
3081	LOGICAL :: lcommute
3082	INTEGER :: mpi_isl,ierror
3083	INTEGER :: iwork
3084
3085	lcommute = .TRUE.
3086	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3087	CALL mpi_allreduce(ktab, iwork, 1,mpi_integer &
3088	,mpi_isl,mpi_comm_opa,ierror)
3089	ktab = iwork
3090	#endif
3091
3092	END SUBROUTINE mppisl_int
3093
3094
3095	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
3096	!!----------------------------------------------------------------------
3097	!! * routine mppmax_a_int *
3098	!!
3099	!! ** Purpose : Find maximum value in an integer layout array
3100	!!
3101	!!----------------------------------------------------------------------
3102	!! * Arguments
3103	INTEGER , INTENT( in ) :: kdim ! size of array
3104	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
3105	INTEGER , INTENT(in) , OPTIONAL :: kcom
3106
3107	#if defined key_mpp_shmem
3108	!! * Local declarations (SHMEM version)
3109	INTEGER :: ji
3110	INTEGER, SAVE :: ibool=0
3111
3112	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_int routine : kdim is too big', &
3113	& 'change jpmppsum dimension in mpp.h' )
3114
3115	DO ji = 1, kdim
3116	niltab_shmem(ji) = ktab(ji)
3117	END DO
3118	CALL barrier()
3119	IF(ibool == 0 ) THEN
3120	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3121	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3122	ELSE
3123	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3124	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3125	ENDIF
3126	CALL barrier()
3127	ibool=ibool+1
3128	ibool=MOD( ibool,2)
3129	DO ji = 1, kdim
3130	ktab(ji) = niltab_shmem(ji)
3131	END DO
3132
3133	# elif defined key_mpp_mpi
3134
3135	!! * Local variables (MPI version)
3136	INTEGER :: ierror
3137	INTEGER :: localcomm
3138	INTEGER, DIMENSION(kdim) :: iwork
3139
3140	localcomm = mpi_comm_opa
3141	IF( PRESENT(kcom) ) localcomm = kcom
3142
3143	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
3144	& mpi_max, localcomm, ierror )
3145
3146	ktab(:) = iwork(:)
3147	#endif
3148
3149	END SUBROUTINE mppmax_a_int
3150
3151
3152	SUBROUTINE mppmax_int( ktab, kcom )
3153	!!----------------------------------------------------------------------
3154	!! * routine mppmax_int *
3155	!!
3156	!! ** Purpose :
3157	!! Massively parallel processors
3158	!! Find maximum value in an integer layout array
3159	!!
3160	!!----------------------------------------------------------------------
3161	!! * Arguments
3162	INTEGER, INTENT(inout) :: ktab ! ???
3163	INTEGER, INTENT(in), OPTIONAL :: kcom ! ???
3164
3165	!! * Local declarations
3166
3167	#if defined key_mpp_shmem
3168
3169	!! * Local variables (SHMEM version)
3170	INTEGER :: ji
3171	INTEGER, SAVE :: ibool=0
3172
3173	niltab_shmem(1) = ktab
3174	CALL barrier()
3175	IF(ibool == 0 ) THEN
3176	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3177	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3178	ELSE
3179	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3180	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3181	ENDIF
3182	CALL barrier()
3183	ibool=ibool+1
3184	ibool=MOD( ibool,2)
3185	ktab = niltab_shmem(1)
3186
3187	# elif defined key_mpp_mpi
3188
3189	!! * Local variables (MPI version)
3190	INTEGER :: ierror, iwork
3191	INTEGER :: localcomm
3192
3193	localcomm = mpi_comm_opa
3194	IF( PRESENT(kcom) ) localcomm = kcom
3195
3196	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3197	& ,mpi_max,localcomm,ierror)
3198
3199	ktab = iwork
3200	#endif
3201
3202	END SUBROUTINE mppmax_int
3203
3204
3205	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
3206	!!----------------------------------------------------------------------
3207	!! * routine mppmin_a_int *
3208	!!
3209	!! ** Purpose : Find minimum value in an integer layout array
3210	!!
3211	!!----------------------------------------------------------------------
3212	!! * Arguments
3213	INTEGER , INTENT( in ) :: kdim ! size of array
3214	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
3215	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
3216
3217	#if defined key_mpp_shmem
3218	!! * Local declarations (SHMEM version)
3219	INTEGER :: ji
3220	INTEGER, SAVE :: ibool=0
3221
3222	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', &
3223	& 'change jpmppsum dimension in mpp.h' )
3224
3225	DO ji = 1, kdim
3226	niltab_shmem(ji) = ktab(ji)
3227	END DO
3228	CALL barrier()
3229	IF(ibool == 0 ) THEN
3230	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3231	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3232	ELSE
3233	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3234	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3235	ENDIF
3236	CALL barrier()
3237	ibool=ibool+1
3238	ibool=MOD( ibool,2)
3239	DO ji = 1, kdim
3240	ktab(ji) = niltab_shmem(ji)
3241	END DO
3242
3243	# elif defined key_mpp_mpi
3244
3245	!! * Local variables (MPI version)
3246	INTEGER :: ierror
3247	INTEGER :: localcomm
3248	INTEGER, DIMENSION(kdim) :: iwork
3249
3250	localcomm = mpi_comm_opa
3251	IF( PRESENT(kcom) ) localcomm = kcom
3252
3253	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
3254	& mpi_min, localcomm, ierror )
3255
3256	ktab(:) = iwork(:)
3257	#endif
3258
3259	END SUBROUTINE mppmin_a_int
3260
3261
3262	SUBROUTINE mppmin_int( ktab )
3263	!!----------------------------------------------------------------------
3264	!! * routine mppmin_int *
3265	!!
3266	!! ** Purpose :
3267	!! Massively parallel processors
3268	!! Find minimum value in an integer layout array
3269	!!
3270	!!----------------------------------------------------------------------
3271	!! * Arguments
3272	INTEGER, INTENT(inout) :: ktab ! ???
3273
3274	!! * Local declarations
3275
3276	#if defined key_mpp_shmem
3277
3278	!! * Local variables (SHMEM version)
3279	INTEGER :: ji
3280	INTEGER, SAVE :: ibool=0
3281
3282	niltab_shmem(1) = ktab
3283	CALL barrier()
3284	IF(ibool == 0 ) THEN
3285	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3286	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3287	ELSE
3288	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3289	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3290	ENDIF
3291	CALL barrier()
3292	ibool=ibool+1
3293	ibool=MOD( ibool,2)
3294	ktab = niltab_shmem(1)
3295
3296	# elif defined key_mpp_mpi
3297
3298	!! * Local variables (MPI version)
3299	INTEGER :: ierror, iwork
3300
3301	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3302	& ,mpi_min,mpi_comm_opa,ierror)
3303
3304	ktab = iwork
3305	#endif
3306
3307	END SUBROUTINE mppmin_int
3308
3309
3310	SUBROUTINE mppsum_a_int( ktab, kdim )
3311	!!----------------------------------------------------------------------
3312	!! * routine mppsum_a_int *
3313	!!
3314	!! ** Purpose : Massively parallel processors
3315	!! Global integer sum
3316	!!
3317	!!----------------------------------------------------------------------
3318	!! * Arguments
3319	INTEGER, INTENT( in ) :: kdim ! ???
3320	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
3321
3322	#if defined key_mpp_shmem
3323
3324	!! * Local variables (SHMEM version)
3325	INTEGER :: ji
3326	INTEGER, SAVE :: ibool=0
3327
3328	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', &
3329	& 'change jpmppsum dimension in mpp.h' )
3330
3331	DO ji = 1, kdim
3332	nistab_shmem(ji) = ktab(ji)
3333	END DO
3334	CALL barrier()
3335	IF(ibool == 0 ) THEN
3336	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
3337	N$PES,nis1wrk_shmem,nis1sync_shmem)
3338	ELSE
3339	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
3340	N$PES,nis2wrk_shmem,nis2sync_shmem)
3341	ENDIF
3342	CALL barrier()
3343	ibool = ibool + 1
3344	ibool = MOD( ibool, 2 )
3345	DO ji = 1, kdim
3346	ktab(ji) = nistab_shmem(ji)
3347	END DO
3348
3349	# elif defined key_mpp_mpi
3350
3351	!! * Local variables (MPI version)
3352	INTEGER :: ierror
3353	INTEGER, DIMENSION (kdim) :: iwork
3354
3355	CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer &
3356	,mpi_sum,mpi_comm_opa,ierror)
3357
3358	ktab(:) = iwork(:)
3359	#endif
3360
3361	END SUBROUTINE mppsum_a_int
3362
3363
3364	SUBROUTINE mppsum_int( ktab )
3365	!!----------------------------------------------------------------------
3366	!! * routine mppsum_int *
3367	!!
3368	!! ** Purpose : Global integer sum
3369	!!
3370	!!----------------------------------------------------------------------
3371	!! * Arguments
3372	INTEGER, INTENT(inout) :: ktab
3373
3374	#if defined key_mpp_shmem
3375
3376	!! * Local variables (SHMEM version)
3377	INTEGER, SAVE :: ibool=0
3378
3379	nistab_shmem(1) = ktab
3380	CALL barrier()
3381	IF(ibool == 0 ) THEN
3382	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
3383	N$PES,nis1wrk_shmem,nis1sync_shmem)
3384	ELSE
3385	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
3386	N$PES,nis2wrk_shmem,nis2sync_shmem)
3387	ENDIF
3388	CALL barrier()
3389	ibool=ibool+1
3390	ibool=MOD( ibool,2)
3391	ktab = nistab_shmem(1)
3392
3393	# elif defined key_mpp_mpi
3394
3395	!! * Local variables (MPI version)
3396	INTEGER :: ierror, iwork
3397
3398	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3399	,mpi_sum,mpi_comm_opa,ierror)
3400
3401	ktab = iwork
3402
3403	#endif
3404
3405	END SUBROUTINE mppsum_int
3406
3407
3408	SUBROUTINE mppisl_a_real( ptab, kdim )
3409	!!----------------------------------------------------------------------
3410	!! * routine mppisl_a_real *
3411	!!
3412	!! ** Purpose : Massively parallel processors
3413	!! Find the non zero island barotropic stream function value
3414	!!
3415	!! Modifications:
3416	!! ! 93-09 (M. Imbard)
3417	!! ! 96-05 (j. Escobar)
3418	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3419	!!----------------------------------------------------------------------
3420	INTEGER , INTENT( in ) :: kdim ! ???
3421	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab ! ???
3422
3423	#if defined key_mpp_shmem
3424
3425	!! * Local variables (SHMEM version)
3426	INTEGER :: ji
3427	INTEGER, SAVE :: ibool=0
3428
3429	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', &
3430	& 'change jpmppsum dimension in mpp.h' )
3431
3432	DO ji = 1, kdim
3433	wiltab_shmem(ji) = ptab(ji)
3434	END DO
3435	CALL barrier()
3436	IF(ibool == 0 ) THEN
3437	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
3438	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3439	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
3440	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3441	ELSE
3442	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
3443	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3444	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
3445	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3446	ENDIF
3447	CALL barrier()
3448	ibool=ibool+1
3449	ibool=MOD( ibool,2)
3450	DO ji = 1, kdim
3451	IF(wi1tab_shmem(ji) /= 0. ) THEN
3452	ptab(ji) = wi1tab_shmem(ji)
3453	ELSE
3454	ptab(ji) = wi2tab_shmem(ji)
3455	ENDIF
3456	END DO
3457
3458	# elif defined key_mpp_mpi
3459
3460	!! * Local variables (MPI version)
3461	LOGICAL :: lcommute = .TRUE.
3462	INTEGER :: mpi_isl, ierror
3463	REAL(wp), DIMENSION(kdim) :: zwork
3464
3465	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3466	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3467	,mpi_isl,mpi_comm_opa,ierror)
3468	ptab(:) = zwork(:)
3469
3470	#endif
3471
3472	END SUBROUTINE mppisl_a_real
3473
3474
3475	SUBROUTINE mppisl_real( ptab )
3476	!!----------------------------------------------------------------------
3477	!! * routine mppisl_real *
3478	!!
3479	!! ** Purpose : Massively parallel processors
3480	!! Find the non zero island barotropic stream function value
3481	!!
3482	!! Modifications:
3483	!! ! 93-09 (M. Imbard)
3484	!! ! 96-05 (j. Escobar)
3485	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3486	!!----------------------------------------------------------------------
3487	REAL(wp), INTENT(inout) :: ptab
3488
3489	#if defined key_mpp_shmem
3490
3491	!! * Local variables (SHMEM version)
3492	INTEGER, SAVE :: ibool=0
3493
3494	wiltab_shmem(1) = ptab
3495	CALL barrier()
3496	IF(ibool == 0 ) THEN
3497	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
3498	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3499	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
3500	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3501	ELSE
3502	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
3503	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3504	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
3505	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3506	ENDIF
3507	CALL barrier()
3508	ibool = ibool + 1
3509	ibool = MOD( ibool, 2 )
3510	IF( wi1tab_shmem(1) /= 0. ) THEN
3511	ptab = wi1tab_shmem(1)
3512	ELSE
3513	ptab = wi2tab_shmem(1)
3514	ENDIF
3515
3516	# elif defined key_mpp_mpi
3517
3518	!! * Local variables (MPI version)
3519	LOGICAL :: lcommute = .TRUE.
3520	INTEGER :: mpi_isl, ierror
3521	REAL(wp) :: zwork
3522
3523	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3524	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, &
3525	& mpi_isl , mpi_comm_opa, ierror )
3526	ptab = zwork
3527
3528	#endif
3529
3530	END SUBROUTINE mppisl_real
3531
3532
3533	FUNCTION lc_isl( py, px, kdim, kdtatyp )
3534	INTEGER :: kdim
3535	REAL(wp), DIMENSION(kdim) :: px, py
3536	INTEGER :: kdtatyp, ji
3537	INTEGER :: lc_isl
3538	DO ji = 1, kdim
3539	IF( py(ji) /= 0. ) px(ji) = py(ji)
3540	END DO
3541	lc_isl=0
3542
3543	END FUNCTION lc_isl
3544
3545
3546	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
3547	!!----------------------------------------------------------------------
3548	!! * routine mppmax_a_real *
3549	!!
3550	!! ** Purpose : Maximum
3551	!!
3552	!!----------------------------------------------------------------------
3553	!! * Arguments
3554	INTEGER , INTENT( in ) :: kdim
3555	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
3556	INTEGER , INTENT( in ), OPTIONAL :: kcom
3557
3558	#if defined key_mpp_shmem
3559
3560	!! * Local variables (SHMEM version)
3561	INTEGER :: ji
3562	INTEGER, SAVE :: ibool=0
3563
3564	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', &
3565	& 'change jpmppsum dimension in mpp.h' )
3566
3567	DO ji = 1, kdim
3568	wintab_shmem(ji) = ptab(ji)
3569	END DO
3570	CALL barrier()
3571	IF(ibool == 0 ) THEN
3572	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3573	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3574	ELSE
3575	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3576	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3577	ENDIF
3578	CALL barrier()
3579	ibool=ibool+1
3580	ibool=MOD( ibool,2)
3581	DO ji = 1, kdim
3582	ptab(ji) = wintab_shmem(ji)
3583	END DO
3584
3585	# elif defined key_mpp_mpi
3586
3587	!! * Local variables (MPI version)
3588	INTEGER :: ierror
3589	INTEGER :: localcomm
3590	REAL(wp), DIMENSION(kdim) :: zwork
3591
3592	localcomm = mpi_comm_opa
3593	IF( PRESENT(kcom) ) localcomm = kcom
3594
3595	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3596	,mpi_max,localcomm,ierror)
3597	ptab(:) = zwork(:)
3598
3599	#endif
3600
3601	END SUBROUTINE mppmax_a_real
3602
3603
3604	SUBROUTINE mppmax_real( ptab, kcom )
3605	!!----------------------------------------------------------------------
3606	!! * routine mppmax_real *
3607	!!
3608	!! ** Purpose : Maximum
3609	!!
3610	!!----------------------------------------------------------------------
3611	!! * Arguments
3612	REAL(wp), INTENT(inout) :: ptab ! ???
3613	INTEGER , INTENT( in ), OPTIONAL :: kcom ! ???
3614
3615	#if defined key_mpp_shmem
3616
3617	!! * Local variables (SHMEM version)
3618	INTEGER, SAVE :: ibool=0
3619
3620	wintab_shmem(1) = ptab
3621	CALL barrier()
3622	IF(ibool == 0 ) THEN
3623	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
3624	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3625	ELSE
3626	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
3627	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3628	ENDIF
3629	CALL barrier()
3630	ibool=ibool+1
3631	ibool=MOD( ibool,2)
3632	ptab = wintab_shmem(1)
3633
3634	# elif defined key_mpp_mpi
3635
3636	!! * Local variables (MPI version)
3637	INTEGER :: ierror
3638	INTEGER :: localcomm
3639	REAL(wp) :: zwork
3640
3641	localcomm = mpi_comm_opa
3642	IF( PRESENT(kcom) ) localcomm = kcom
3643
3644	CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, &
3645	& mpi_max, localcomm, ierror )
3646	ptab = zwork
3647
3648	#endif
3649
3650	END SUBROUTINE mppmax_real
3651
3652
3653	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
3654	!!----------------------------------------------------------------------
3655	!! * routine mppmin_a_real *
3656	!!
3657	!! ** Purpose : Minimum
3658	!!
3659	!!-----------------------------------------------------------------------
3660	!! * Arguments
3661	INTEGER , INTENT( in ) :: kdim
3662	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
3663	INTEGER , INTENT( in ), OPTIONAL :: kcom
3664
3665	#if defined key_mpp_shmem
3666
3667	!! * Local variables (SHMEM version)
3668	INTEGER :: ji
3669	INTEGER, SAVE :: ibool=0
3670
3671	IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', &
3672	& 'change jpmppsum dimension in mpp.h' )
3673
3674	DO ji = 1, kdim
3675	wintab_shmem(ji) = ptab(ji)
3676	END DO
3677	CALL barrier()
3678	IF(ibool == 0 ) THEN
3679	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3680	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3681	ELSE
3682	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3683	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3684	ENDIF
3685	CALL barrier()
3686	ibool=ibool+1
3687	ibool=MOD( ibool,2)
3688	DO ji = 1, kdim
3689	ptab(ji) = wintab_shmem(ji)
3690	END DO
3691
3692	# elif defined key_mpp_mpi
3693
3694	!! * Local variables (MPI version)
3695	INTEGER :: ierror
3696	INTEGER :: localcomm
3697	REAL(wp), DIMENSION(kdim) :: zwork
3698
3699	localcomm = mpi_comm_opa
3700	IF( PRESENT(kcom) ) localcomm = kcom
3701
3702	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3703	,mpi_min,localcomm,ierror)
3704	ptab(:) = zwork(:)
3705
3706	#endif
3707
3708	END SUBROUTINE mppmin_a_real
3709
3710
3711	SUBROUTINE mppmin_real( ptab, kcom )
3712	!!----------------------------------------------------------------------
3713	!! * routine mppmin_real *
3714	!!
3715	!! ** Purpose : minimum in Massively Parallel Processing
3716	!! REAL scalar case
3717	!!
3718	!!-----------------------------------------------------------------------
3719	!! * Arguments
3720	REAL(wp), INTENT( inout ) :: ptab !
3721	INTEGER , INTENT( in ), OPTIONAL :: kcom
3722
3723	#if defined key_mpp_shmem
3724
3725	!! * Local variables (SHMEM version)
3726	INTEGER, SAVE :: ibool=0
3727
3728	wintab_shmem(1) = ptab
3729	CALL barrier()
3730	IF(ibool == 0 ) THEN
3731	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
3732	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3733	ELSE
3734	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
3735	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3736	ENDIF
3737	CALL barrier()
3738	ibool=ibool+1
3739	ibool=MOD( ibool,2)
3740	ptab = wintab_shmem(1)
3741
3742	# elif defined key_mpp_mpi
3743
3744	!! * Local variables (MPI version)
3745	INTEGER :: ierror
3746	REAL(wp) :: zwork
3747	INTEGER :: localcomm
3748
3749	localcomm = mpi_comm_opa
3750	IF( PRESENT(kcom) ) localcomm = kcom
3751
3752	CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision &
3753	& ,mpi_min,localcomm,ierror)
3754	ptab = zwork
3755
3756	#endif
3757
3758	END SUBROUTINE mppmin_real
3759
3760
3761	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
3762	!!----------------------------------------------------------------------
3763	!! * routine mppsum_a_real *
3764	!!
3765	!! ** Purpose : global sum in Massively Parallel Processing
3766	!! REAL ARRAY argument case
3767	!!
3768	!!-----------------------------------------------------------------------
3769	INTEGER , INTENT( in ) :: kdim ! size of ptab
3770	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
3771	INTEGER , INTENT( in ), OPTIONAL :: kcom
3772
3773	#if defined key_mpp_shmem
3774
3775	!! * Local variables (SHMEM version)
3776	INTEGER :: ji
3777	INTEGER, SAVE :: ibool=0
3778
3779	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', &
3780	& 'change jpmppsum dimension in mpp.h' )
3781
3782	DO ji = 1, kdim
3783	wrstab_shmem(ji) = ptab(ji)
3784	END DO
3785	CALL barrier()
3786	IF(ibool == 0 ) THEN
3787	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
3788	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3789	ELSE
3790	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
3791	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3792	ENDIF
3793	CALL barrier()
3794	ibool=ibool+1
3795	ibool=MOD( ibool,2)
3796	DO ji = 1, kdim
3797	ptab(ji) = wrstab_shmem(ji)
3798	END DO
3799
3800	# elif defined key_mpp_mpi
3801
3802	!! * Local variables (MPI version)
3803	INTEGER :: ierror ! temporary integer
3804	INTEGER :: localcomm
3805	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
3806
3807
3808	localcomm = mpi_comm_opa
3809	IF( PRESENT(kcom) ) localcomm = kcom
3810
3811	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3812	& ,mpi_sum,localcomm,ierror)
3813	ptab(:) = zwork(:)
3814
3815	#endif
3816
3817	END SUBROUTINE mppsum_a_real
3818
3819
3820	SUBROUTINE mppsum_real( ptab, kcom )
3821	!!----------------------------------------------------------------------
3822	!! * routine mppsum_real *
3823	!!
3824	!! ** Purpose : global sum in Massively Parallel Processing
3825	!! SCALAR argument case
3826	!!
3827	!!-----------------------------------------------------------------------
3828	REAL(wp), INTENT(inout) :: ptab ! input scalar
3829	INTEGER , INTENT( in ), OPTIONAL :: kcom
3830
3831	#if defined key_mpp_shmem
3832
3833	!! * Local variables (SHMEM version)
3834	INTEGER, SAVE :: ibool=0
3835
3836	wrstab_shmem(1) = ptab
3837	CALL barrier()
3838	IF(ibool == 0 ) THEN
3839	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
3840	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3841	ELSE
3842	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
3843	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3844	ENDIF
3845	CALL barrier()
3846	ibool = ibool + 1
3847	ibool = MOD( ibool, 2 )
3848	ptab = wrstab_shmem(1)
3849
3850	# elif defined key_mpp_mpi
3851
3852	!! * Local variables (MPI version)
3853	INTEGER :: ierror
3854	INTEGER :: localcomm
3855	REAL(wp) :: zwork
3856
3857	localcomm = mpi_comm_opa
3858	IF( PRESENT(kcom) ) localcomm = kcom
3859
3860	CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision &
3861	& ,mpi_sum,localcomm,ierror)
3862	ptab = zwork
3863
3864	#endif
3865
3866	END SUBROUTINE mppsum_real
3867
3868	SUBROUTINE mpp_minloc2d(ptab, pmask, pmin, ki,kj )
3869	!!------------------------------------------------------------------------
3870	!! * routine mpp_minloc *
3871	!!
3872	!! ** Purpose : Compute the global minimum of an array ptab
3873	!! and also give its global position
3874	!!
3875	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3876	!!
3877	!! ** Arguments : I : ptab =local 2D array
3878	!! O : pmin = global minimum
3879	!! O : ki,kj = global position of minimum
3880	!!
3881	!! ** Author : J.M. Molines 10/10/2004
3882	!!--------------------------------------------------------------------------
3883	#ifdef key_mpp_shmem
3884	CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3885	# elif key_mpp_mpi
3886	!! * Arguments
3887	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
3888	& pmask ! Local mask
3889	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
3890	INTEGER , INTENT (out) :: ki,kj ! index of minimum in global frame
3891
3892	!! * Local variables
3893	REAL(wp) :: zmin ! local minimum
3894	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3895	INTEGER, DIMENSION (2) :: ilocs
3896	INTEGER :: ierror
3897
3898
3899	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
3900	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
3901
3902	ki = ilocs(1) + nimpp - 1
3903	kj = ilocs(2) + njmpp - 1
3904
3905	zain(1,:)=zmin
3906	zain(2,:)=ki+10000.*kj
3907
3908	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3909
3910	pmin=zaout(1,1)
3911	kj= INT(zaout(2,1)/10000.)
3912	ki= INT(zaout(2,1) - 10000.*kj )
3913	#endif
3914
3915	END SUBROUTINE mpp_minloc2d
3916
3917
3918	SUBROUTINE mpp_minloc3d(ptab, pmask, pmin, ki,kj ,kk)
3919	!!------------------------------------------------------------------------
3920	!! * routine mpp_minloc *
3921	!!
3922	!! ** Purpose : Compute the global minimum of an array ptab
3923	!! and also give its global position
3924	!!
3925	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3926	!!
3927	!! ** Arguments : I : ptab =local 2D array
3928	!! O : pmin = global minimum
3929	!! O : ki,kj = global position of minimum
3930	!!
3931	!! ** Author : J.M. Molines 10/10/2004
3932	!!--------------------------------------------------------------------------
3933	#ifdef key_mpp_shmem
3934	CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3935	# elif key_mpp_mpi
3936	!! * Arguments
3937	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
3938	& pmask ! Local mask
3939	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
3940	INTEGER , INTENT (out) :: ki,kj,kk ! index of minimum in global frame
3941
3942	!! * Local variables
3943	REAL(wp) :: zmin ! local minimum
3944	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3945	INTEGER, DIMENSION (3) :: ilocs
3946	INTEGER :: ierror
3947
3948
3949	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
3950	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
3951
3952	ki = ilocs(1) + nimpp - 1
3953	kj = ilocs(2) + njmpp - 1
3954	kk = ilocs(3)
3955
3956	zain(1,:)=zmin
3957	zain(2,:)=ki+10000.kj+100000000.kk
3958
3959	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3960
3961	pmin=zaout(1,1)
3962	kk= INT(zaout(2,1)/100000000.)
3963	kj= INT(zaout(2,1) - kk * 100000000. )/10000
3964	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
3965	#endif
3966
3967	END SUBROUTINE mpp_minloc3d
3968
3969
3970	SUBROUTINE mpp_maxloc2d(ptab, pmask, pmax, ki,kj )
3971	!!------------------------------------------------------------------------
3972	!! * routine mpp_maxloc *
3973	!!
3974	!! ** Purpose : Compute the global maximum of an array ptab
3975	!! and also give its global position
3976	!!
3977	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3978	!!
3979	!! ** Arguments : I : ptab =local 2D array
3980	!! O : pmax = global maximum
3981	!! O : ki,kj = global position of maximum
3982	!!
3983	!! ** Author : J.M. Molines 10/10/2004
3984	!!--------------------------------------------------------------------------
3985	#ifdef key_mpp_shmem
3986	CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
3987	# elif key_mpp_mpi
3988	!! * Arguments
3989	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
3990	& pmask ! Local mask
3991	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
3992	INTEGER , INTENT (out) :: ki,kj ! index of maximum in global frame
3993
3994	!! * Local variables
3995	REAL(wp) :: zmax ! local maximum
3996	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3997	INTEGER, DIMENSION (2) :: ilocs
3998	INTEGER :: ierror
3999
4000
4001	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
4002	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
4003
4004	ki = ilocs(1) + nimpp - 1
4005	kj = ilocs(2) + njmpp - 1
4006
4007	zain(1,:)=zmax
4008	zain(2,:)=ki+10000.*kj
4009
4010	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4011
4012	pmax=zaout(1,1)
4013	kj= INT(zaout(2,1)/10000.)
4014	ki= INT(zaout(2,1) - 10000.*kj )
4015	#endif
4016
4017	END SUBROUTINE mpp_maxloc2d
4018
4019	SUBROUTINE mpp_maxloc3d(ptab, pmask, pmax, ki,kj,kk )
4020	!!------------------------------------------------------------------------
4021	!! * routine mpp_maxloc *
4022	!!
4023	!! ** Purpose : Compute the global maximum of an array ptab
4024	!! and also give its global position
4025	!!
4026	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
4027	!!
4028	!! ** Arguments : I : ptab =local 2D array
4029	!! O : pmax = global maximum
4030	!! O : ki,kj = global position of maximum
4031	!!
4032	!! ** Author : J.M. Molines 10/10/2004
4033	!!--------------------------------------------------------------------------
4034	#ifdef key_mpp_shmem
4035	CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
4036	# elif key_mpp_mpi
4037	!! * Arguments
4038	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
4039	& pmask ! Local mask
4040	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
4041	INTEGER , INTENT (out) :: ki,kj,kk ! index of maximum in global frame
4042
4043	!! * Local variables
4044	REAL(wp) :: zmax ! local maximum
4045	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
4046	INTEGER, DIMENSION (3) :: ilocs
4047	INTEGER :: ierror
4048
4049
4050	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
4051	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
4052
4053	ki = ilocs(1) + nimpp - 1
4054	kj = ilocs(2) + njmpp - 1
4055	kk = ilocs(3)
4056
4057	zain(1,:)=zmax
4058	zain(2,:)=ki+10000.kj+100000000.kk
4059
4060	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4061
4062	pmax=zaout(1,1)
4063	kk= INT(zaout(2,1)/100000000.)
4064	kj= INT(zaout(2,1) - kk * 100000000. )/10000
4065	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
4066	#endif
4067
4068	END SUBROUTINE mpp_maxloc3d
4069
4070	SUBROUTINE mppsync()
4071	!!----------------------------------------------------------------------
4072	!! * routine mppsync *
4073	!!
4074	!! ** Purpose : Massively parallel processors, synchroneous
4075	!!
4076	!!-----------------------------------------------------------------------
4077
4078	#if defined key_mpp_shmem
4079
4080	!! * Local variables (SHMEM version)
4081	CALL barrier()
4082
4083	# elif defined key_mpp_mpi
4084
4085	!! * Local variables (MPI version)
4086	INTEGER :: ierror
4087
4088	CALL mpi_barrier(mpi_comm_opa,ierror)
4089
4090	#endif
4091
4092	END SUBROUTINE mppsync
4093
4094
4095	SUBROUTINE mppstop
4096	!!----------------------------------------------------------------------
4097	!! * routine mppstop *
4098	!!
4099	!! ** purpose : Stop massilively parallel processors method
4100	!!
4101	!!----------------------------------------------------------------------
4102	!! * Local declarations
4103	INTEGER :: info
4104	!!----------------------------------------------------------------------
4105
4106	! 1. Mpp synchroneus
4107	! ------------------
4108
4109	CALL mppsync
4110	#if defined key_mpp_mpi
4111	CALL mpi_finalize( info )
4112	#endif
4113
4114	END SUBROUTINE mppstop
4115
4116
4117	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
4118	!!----------------------------------------------------------------------
4119	!! * routine mppobc *
4120	!!
4121	!! ** Purpose : Message passing manadgement for open boundary
4122	!! conditions array
4123	!!
4124	!! ** Method : Use mppsend and mpprecv function for passing mask
4125	!! between processors following neighboring subdomains.
4126	!! domain parameters
4127	!! nlci : first dimension of the local subdomain
4128	!! nlcj : second dimension of the local subdomain
4129	!! nbondi : mark for "east-west local boundary"
4130	!! nbondj : mark for "north-south local boundary"
4131	!! noea : number for local neighboring processors
4132	!! nowe : number for local neighboring processors
4133	!! noso : number for local neighboring processors
4134	!! nono : number for local neighboring processors
4135	!!
4136	!! History :
4137	!! ! 98-07 (J.M. Molines) Open boundary conditions
4138	!!----------------------------------------------------------------------
4139	!! * Arguments
4140	INTEGER , INTENT( in ) :: &
4141	kd1, kd2, & ! starting and ending indices
4142	kl , & ! index of open boundary
4143	kk, & ! vertical dimension
4144	ktype, & ! define north/south or east/west cdt
4145	! ! = 1 north/south ; = 2 east/west
4146	kij ! horizontal dimension
4147	REAL(wp), DIMENSION(kij,kk), INTENT( inout ) :: &
4148	ptab ! variable array
4149
4150	!! * Local variables
4151	INTEGER :: ji, jj, jk, jl ! dummy loop indices
4152	INTEGER :: &
4153	iipt0, iipt1, ilpt1, & ! temporary integers
4154	ijpt0, ijpt1, & ! " "
4155	imigr, iihom, ijhom ! " "
4156	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
4157	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
4158	REAL(wp), DIMENSION(jpi,jpj) :: &
4159	ztab ! temporary workspace
4160	!!----------------------------------------------------------------------
4161
4162
4163	! boundary condition initialization
4164	! ---------------------------------
4165
4166	ztab(:,:) = 0.e0
4167
4168	IF( ktype==1 ) THEN ! north/south boundaries
4169	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
4170	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
4171	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
4172	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
4173	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
4174	ELSEIF( ktype==2 ) THEN ! east/west boundaries
4175	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
4176	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
4177	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
4178	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
4179	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
4180	ELSE
4181	CALL ctl_stop( 'mppobc: bad ktype' )
4182	ENDIF
4183
4184	DO jk = 1, kk
4185	IF( ktype==1 ) THEN ! north/south boundaries
4186	DO jj = ijpt0, ijpt1
4187	DO ji = iipt0, iipt1
4188	ztab(ji,jj) = ptab(ji,jk)
4189	END DO
4190	END DO
4191	ELSEIF( ktype==2 ) THEN ! east/west boundaries
4192	DO jj = ijpt0, ijpt1
4193	DO ji = iipt0, iipt1
4194	ztab(ji,jj) = ptab(jj,jk)
4195	END DO
4196	END DO
4197	ENDIF
4198
4199
4200	! 1. East and west directions
4201	! ---------------------------
4202
4203	! 1.1 Read Dirichlet lateral conditions
4204
4205	IF( nbondi /= 2 ) THEN
4206	iihom = nlci-nreci
4207
4208	DO jl = 1, jpreci
4209	t2ew(:,jl,1) = ztab(jpreci+jl,:)
4210	t2we(:,jl,1) = ztab(iihom +jl,:)
4211	END DO
4212	ENDIF
4213
4214	! 1.2 Migrations
4215
4216	#if defined key_mpp_shmem
4217	!! * (SHMEM version)
4218	imigr=jprecijpjjpbyt
4219
4220	IF( nbondi == -1 ) THEN
4221	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4222	ELSEIF( nbondi == 0 ) THEN
4223	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4224	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4225	ELSEIF( nbondi == 1 ) THEN
4226	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4227	ENDIF
4228	CALL barrier()
4229	CALL shmem_udcflush()
4230
4231	# elif key_mpp_mpi
4232	!! * (MPI version)
4233
4234	imigr=jpreci*jpj
4235
4236	IF( nbondi == -1 ) THEN
4237	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
4238	CALL mpprecv(1,t2ew(1,1,2),imigr)
4239	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4240	ELSEIF( nbondi == 0 ) THEN
4241	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4242	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
4243	CALL mpprecv(1,t2ew(1,1,2),imigr)
4244	CALL mpprecv(2,t2we(1,1,2),imigr)
4245	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4246	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4247	ELSEIF( nbondi == 1 ) THEN
4248	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4249	CALL mpprecv(2,t2we(1,1,2),imigr)
4250	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4251	ENDIF
4252	#endif
4253
4254
4255	! 1.3 Write Dirichlet lateral conditions
4256
4257	iihom = nlci-jpreci
4258	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
4259	DO jl = 1, jpreci
4260	ztab(jl,:) = t2we(:,jl,2)
4261	END DO
4262	ENDIF
4263
4264	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
4265	DO jl = 1, jpreci
4266	ztab(iihom+jl,:) = t2ew(:,jl,2)
4267	END DO
4268	ENDIF
4269
4270
4271	! 2. North and south directions
4272	! -----------------------------
4273
4274	! 2.1 Read Dirichlet lateral conditions
4275
4276	IF( nbondj /= 2 ) THEN
4277	ijhom = nlcj-nrecj
4278	DO jl = 1, jprecj
4279	t2sn(:,jl,1) = ztab(:,ijhom +jl)
4280	t2ns(:,jl,1) = ztab(:,jprecj+jl)
4281	END DO
4282	ENDIF
4283
4284	! 2.2 Migrations
4285
4286	#if defined key_mpp_shmem
4287	!! * SHMEM version
4288
4289	imigr=jprecjjpijpbyt
4290
4291	IF( nbondj == -1 ) THEN
4292	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4293	ELSEIF( nbondj == 0 ) THEN
4294	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4295	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4296	ELSEIF( nbondj == 1 ) THEN
4297	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4298	ENDIF
4299	CALL barrier()
4300	CALL shmem_udcflush()
4301
4302	# elif key_mpp_mpi
4303	!! * Local variables (MPI version)
4304
4305	imigr=jprecj*jpi
4306
4307	IF( nbondj == -1 ) THEN
4308	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
4309	CALL mpprecv(3,t2ns(1,1,2),imigr)
4310	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4311	ELSEIF( nbondj == 0 ) THEN
4312	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4313	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
4314	CALL mpprecv(3,t2ns(1,1,2),imigr)
4315	CALL mpprecv(4,t2sn(1,1,2),imigr)
4316	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4317	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4318	ELSEIF( nbondj == 1 ) THEN
4319	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4320	CALL mpprecv(4,t2sn(1,1,2),imigr)
4321	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4322	ENDIF
4323
4324	#endif
4325
4326	! 2.3 Write Dirichlet lateral conditions
4327
4328	ijhom = nlcj - jprecj
4329	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
4330	DO jl = 1, jprecj
4331	ztab(:,jl) = t2sn(:,jl,2)
4332	END DO
4333	ENDIF
4334
4335	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
4336	DO jl = 1, jprecj
4337	ztab(:,ijhom+jl) = t2ns(:,jl,2)
4338	END DO
4339	ENDIF
4340
4341	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
4342	! north/south boundaries
4343	DO jj = ijpt0,ijpt1
4344	DO ji = iipt0,ilpt1
4345	ptab(ji,jk) = ztab(ji,jj)
4346	END DO
4347	END DO
4348	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
4349	! east/west boundaries
4350	DO jj = ijpt0,ilpt1
4351	DO ji = iipt0,iipt1
4352	ptab(jj,jk) = ztab(ji,jj)
4353	END DO
4354	END DO
4355	ENDIF
4356
4357	END DO
4358
4359	END SUBROUTINE mppobc
4360
4361	SUBROUTINE mpp_comm_free( kcom)
4362
4363	INTEGER, INTENT(in) :: kcom
4364	INTEGER :: ierr
4365
4366	CALL MPI_COMM_FREE(kcom, ierr)
4367
4368	END SUBROUTINE mpp_comm_free
4369
4370
4371	SUBROUTINE mpp_ini_ice(pindic)
4372	!!----------------------------------------------------------------------
4373	!! * routine mpp_ini_ice *
4374	!!
4375	!! ** Purpose : Initialize special communicator for ice areas
4376	!! condition together with global variables needed in the ddmpp folding
4377	!!
4378	!! ** Method : - Look for ice processors in ice routines
4379	!! - Put their number in nrank_ice
4380	!! - Create groups for the world processors and the ice processors
4381	!! - Create a communicator for ice processors
4382	!!
4383	!! ** output
4384	!! njmppmax = njmpp for northern procs
4385	!! ndim_rank_ice = number of processors in the northern line
4386	!! nrank_north (ndim_rank_north) = number of the northern procs.
4387	!! ngrp_world = group ID for the world processors
4388	!! ngrp_ice = group ID for the ice processors
4389	!! ncomm_ice = communicator for the ice procs.
4390	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
4391	!!
4392	!! History :
4393	!! ! 03-09 (J.M. Molines, MPI only )
4394	!!----------------------------------------------------------------------
4395	#ifdef key_mpp_shmem
4396	CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' )
4397	# elif key_mpp_mpi
4398	INTEGER, INTENT(in) :: pindic
4399	INTEGER :: ierr
4400	INTEGER :: jproc
4401	INTEGER :: ii,ji
4402	INTEGER, DIMENSION(jpnij) :: kice
4403	INTEGER, DIMENSION(jpnij) :: zwork
4404	INTEGER :: zrank
4405	!!----------------------------------------------------------------------
4406
4407	! Look for how many procs with sea-ice
4408	!
4409	kice = 0
4410	DO jproc=1,jpnij
4411	IF(jproc == narea .AND. pindic .GT. 0) THEN
4412	kice(jproc) = 1
4413	ENDIF
4414	END DO
4415
4416	zwork = 0
4417	CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer, &
4418	mpi_sum, mpi_comm_opa, ierr )
4419	ndim_rank_ice = sum(zwork)
4420
4421	! Allocate the right size to nrank_north
4422	IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice)
4423	ALLOCATE(nrank_ice(ndim_rank_ice))
4424
4425	ii = 0
4426	nrank_ice = 0
4427	DO jproc=1,jpnij
4428	IF(zwork(jproc) == 1) THEN
4429	ii = ii + 1
4430	nrank_ice(ii) = jproc -1
4431	ENDIF
4432	END DO
4433
4434	! Create the world group
4435	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4436
4437	! Create the ice group from the world group
4438	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr)
4439
4440	! Create the ice communicator , ie the pool of procs with sea-ice
4441	CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr)
4442
4443	! Find proc number in the world of proc 0 in the north
4444	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
4445	#endif
4446
4447	END SUBROUTINE mpp_ini_ice
4448
4449
4450	SUBROUTINE mpp_ini_north
4451	!!----------------------------------------------------------------------
4452	!! * routine mpp_ini_north *
4453	!!
4454	!! ** Purpose : Initialize special communicator for north folding
4455	!! condition together with global variables needed in the mpp folding
4456	!!
4457	!! ** Method : - Look for northern processors
4458	!! - Put their number in nrank_north
4459	!! - Create groups for the world processors and the north processors
4460	!! - Create a communicator for northern processors
4461	!!
4462	!! ** output
4463	!! njmppmax = njmpp for northern procs
4464	!! ndim_rank_north = number of processors in the northern line
4465	!! nrank_north (ndim_rank_north) = number of the northern procs.
4466	!! ngrp_world = group ID for the world processors
4467	!! ngrp_north = group ID for the northern processors
4468	!! ncomm_north = communicator for the northern procs.
4469	!! north_root = number (in the world) of proc 0 in the northern comm.
4470	!!
4471	!! History :
4472	!! ! 03-09 (J.M. Molines, MPI only )
4473	!!----------------------------------------------------------------------
4474	#ifdef key_mpp_shmem
4475	CALL ctl_stop( ' mpp_ini_north not available in SHMEM' )
4476	# elif key_mpp_mpi
4477	INTEGER :: ierr
4478	INTEGER :: jproc
4479	INTEGER :: ii,ji
4480	!!----------------------------------------------------------------------
4481
4482	njmppmax=MAXVAL(njmppt)
4483
4484	! Look for how many procs on the northern boundary
4485	!
4486	ndim_rank_north=0
4487	DO jproc=1,jpnij
4488	IF ( njmppt(jproc) == njmppmax ) THEN
4489	ndim_rank_north = ndim_rank_north + 1
4490	END IF
4491	END DO
4492
4493
4494	! Allocate the right size to nrank_north
4495	!
4496	ALLOCATE(nrank_north(ndim_rank_north))
4497
4498	! Fill the nrank_north array with proc. number of northern procs.
4499	! Note : the rank start at 0 in MPI
4500	!
4501	ii=0
4502	DO ji = 1, jpnij
4503	IF ( njmppt(ji) == njmppmax ) THEN
4504	ii=ii+1
4505	nrank_north(ii)=ji-1
4506	END IF
4507	END DO
4508	! create the world group
4509	!
4510	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4511	!
4512	! Create the North group from the world group
4513	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr)
4514
4515	! Create the North communicator , ie the pool of procs in the north group
4516	!
4517	CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr)
4518
4519
4520	! find proc number in the world of proc 0 in the north
4521	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr)
4522	#endif
4523
4524	END SUBROUTINE mpp_ini_north
4525
4526
4527	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
4528	!!---------------------------------------------------------------------
4529	!! * routine mpp_lbc_north_3d *
4530	!!
4531	!! ** Purpose :
4532	!! Ensure proper north fold horizontal bondary condition in mpp configuration
4533	!! in case of jpn1 > 1
4534	!!
4535	!! ** Method :
4536	!! Gather the 4 northern lines of the global domain on 1 processor and
4537	!! apply lbc north-fold on this sub array. Then scatter the fold array
4538	!! back to the processors.
4539	!!
4540	!! History :
4541	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
4542	!! from lbc routine
4543	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
4544	!!----------------------------------------------------------------------
4545	!! * Arguments
4546	CHARACTER(len=1), INTENT( in ) :: &
4547	cd_type ! nature of pt3d grid-points
4548	! ! = T , U , V , F or W gridpoints
4549	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
4550	pt3d ! 3D array on which the boundary condition is applied
4551	REAL(wp), INTENT( in ) :: &
4552	psgn ! control of the sign change
4553	! ! = -1. , the sign is changed if north fold boundary
4554	! ! = 1. , the sign is kept if north fold boundary
4555
4556	!! * Local declarations
4557	INTEGER :: ji, jj, jk, jr, jproc
4558	INTEGER :: ierr
4559	INTEGER :: ildi,ilei,iilb
4560	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
4561	INTEGER :: itaille
4562	REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab
4563	REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio
4564	REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc
4565	!!----------------------------------------------------------------------
4566
4567	! If we get in this routine it s because : North fold condition and mpp with more
4568	! than one proc across i : we deal only with the North condition
4569
4570	! 0. Sign setting
4571	! ---------------
4572
4573	ijpj=4
4574	ijpjm1=3
4575
4576	! put in znorthloc the last 4 jlines of pt3d
4577	DO jk = 1, jpk
4578	DO jj = nlcj - ijpj +1, nlcj
4579	ij = jj - nlcj + ijpj
4580	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
4581	END DO
4582	END DO
4583
4584
4585	IF (npolj /= 0 ) THEN
4586	! Build in proc 0 of ncomm_north the znorthgloio
4587	znorthgloio(:,:,:,:) = 0_wp
4588
4589	#ifdef key_mpp_shmem
4590	not done : compiler error
4591	#elif defined key_mpp_mpi
4592	itaille=jpijpkijpj
4593	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4594	#endif
4595
4596	ENDIF
4597
4598	IF (narea == north_root+1 ) THEN
4599	! recover the global north array
4600	ztab(:,:,:) = 0_wp
4601
4602	DO jr = 1, ndim_rank_north
4603	jproc = nrank_north(jr) + 1
4604	ildi = nldit (jproc)
4605	ilei = nleit (jproc)
4606	iilb = nimppt(jproc)
4607	DO jk = 1, jpk
4608	DO jj = 1, 4
4609	DO ji = ildi, ilei
4610	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
4611	END DO
4612	END DO
4613	END DO
4614	END DO
4615
4616
4617	! Horizontal slab
4618	! ===============
4619
4620	DO jk = 1, jpk
4621
4622
4623	! 2. North-Fold boundary conditions
4624	! ----------------------------------
4625
4626	SELECT CASE ( npolj )
4627
4628	CASE ( 3, 4 ) ! * North fold T-point pivot
4629
4630	ztab( 1 ,ijpj,jk) = 0.e0
4631	ztab(jpiglo,ijpj,jk) = 0.e0
4632
4633	SELECT CASE ( cd_type )
4634
4635	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
4636	DO ji = 2, jpiglo
4637	ijt = jpiglo-ji+2
4638	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
4639	END DO
4640	DO ji = jpiglo/2+1, jpiglo
4641	ijt = jpiglo-ji+2
4642	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
4643	END DO
4644
4645	CASE ( 'U' ) ! U-point
4646	DO ji = 1, jpiglo-1
4647	iju = jpiglo-ji+1
4648	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
4649	END DO
4650	DO ji = jpiglo/2, jpiglo-1
4651	iju = jpiglo-ji+1
4652	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
4653	END DO
4654
4655	CASE ( 'V' ) ! V-point
4656	DO ji = 2, jpiglo
4657	ijt = jpiglo-ji+2
4658	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
4659	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
4660	END DO
4661
4662	CASE ( 'F' , 'G' ) ! F-point
4663	DO ji = 1, jpiglo-1
4664	iju = jpiglo-ji+1
4665	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
4666	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
4667	END DO
4668
4669	END SELECT
4670
4671	CASE ( 5, 6 ) ! * North fold F-point pivot
4672
4673	ztab( 1 ,ijpj,jk) = 0.e0
4674	ztab(jpiglo,ijpj,jk) = 0.e0
4675
4676	SELECT CASE ( cd_type )
4677
4678	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
4679	DO ji = 1, jpiglo
4680	ijt = jpiglo-ji+1
4681	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
4682	END DO
4683
4684	CASE ( 'U' ) ! U-point
4685	DO ji = 1, jpiglo-1
4686	iju = jpiglo-ji
4687	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
4688	END DO
4689
4690	CASE ( 'V' ) ! V-point
4691	DO ji = 1, jpiglo
4692	ijt = jpiglo-ji+1
4693	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
4694	END DO
4695	DO ji = jpiglo/2+1, jpiglo
4696	ijt = jpiglo-ji+1
4697	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
4698	END DO
4699
4700	CASE ( 'F' , 'G' ) ! F-point
4701	DO ji = 1, jpiglo-1
4702	iju = jpiglo-ji
4703	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
4704	END DO
4705	DO ji = jpiglo/2+1, jpiglo-1
4706	iju = jpiglo-ji
4707	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
4708	END DO
4709
4710	END SELECT
4711
4712	CASE DEFAULT ! * closed
4713
4714	SELECT CASE ( cd_type)
4715
4716	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
4717	ztab(:, 1 ,jk) = 0.e0
4718	ztab(:,ijpj,jk) = 0.e0
4719
4720	CASE ( 'F' ) ! F-point
4721	ztab(:,ijpj,jk) = 0.e0
4722
4723	END SELECT
4724
4725	END SELECT
4726
4727	! End of slab
4728	! ===========
4729
4730	END DO
4731
4732	!! Scatter back to pt3d
4733	DO jr = 1, ndim_rank_north
4734	jproc=nrank_north(jr)+1
4735	ildi=nldit (jproc)
4736	ilei=nleit (jproc)
4737	iilb=nimppt(jproc)
4738	DO jk= 1, jpk
4739	DO jj=1,ijpj
4740	DO ji=ildi,ilei
4741	znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
4742	END DO
4743	END DO
4744	END DO
4745	END DO
4746
4747	ENDIF ! only done on proc 0 of ncomm_north
4748
4749	#ifdef key_mpp_shmem
4750	not done yet in shmem : compiler error
4751	#elif key_mpp_mpi
4752	IF ( npolj /= 0 ) THEN
4753	itaille=jpijpkijpj
4754	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4755	ENDIF
4756	#endif
4757
4758	! put in the last ijpj jlines of pt3d znorthloc
4759	DO jk = 1 , jpk
4760	DO jj = nlcj - ijpj + 1 , nlcj
4761	ij = jj - nlcj + ijpj
4762	pt3d(:,jj,jk)= znorthloc(:,ij,jk)
4763	END DO
4764	END DO
4765
4766	END SUBROUTINE mpp_lbc_north_3d
4767
4768
4769	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
4770	!!---------------------------------------------------------------------
4771	!! * routine mpp_lbc_north_2d *
4772	!!
4773	!! ** Purpose :
4774	!! Ensure proper north fold horizontal bondary condition in mpp configuration
4775	!! in case of jpn1 > 1 (for 2d array )
4776	!!
4777	!! ** Method :
4778	!! Gather the 4 northern lines of the global domain on 1 processor and
4779	!! apply lbc north-fold on this sub array. Then scatter the fold array
4780	!! back to the processors.
4781	!!
4782	!! History :
4783	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
4784	!! from lbc routine
4785	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
4786	!!----------------------------------------------------------------------
4787
4788	!! * Arguments
4789	CHARACTER(len=1), INTENT( in ) :: &
4790	cd_type ! nature of pt2d grid-points
4791	! ! = T , U , V , F or W gridpoints
4792	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
4793	pt2d ! 2D array on which the boundary condition is applied
4794	REAL(wp), INTENT( in ) :: &
4795	psgn ! control of the sign change
4796	! ! = -1. , the sign is changed if north fold boundary
4797	! ! = 1. , the sign is kept if north fold boundary
4798
4799
4800	!! * Local declarations
4801
4802	INTEGER :: ji, jj, jr, jproc
4803	INTEGER :: ierr
4804	INTEGER :: ildi,ilei,iilb
4805	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
4806	INTEGER :: itaille
4807
4808	REAL(wp), DIMENSION(jpiglo,4) :: ztab
4809	REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio
4810	REAL(wp), DIMENSION(jpi,4) :: znorthloc
4811	!!----------------------------------------------------------------------
4812	!! OPA 8.5, LODYC-IPSL (2002)
4813	!!----------------------------------------------------------------------
4814	! If we get in this routine it s because : North fold condition and mpp with more
4815	! than one proc across i : we deal only with the North condition
4816
4817	! 0. Sign setting
4818	! ---------------
4819
4820	ijpj=4
4821	ijpjm1=3
4822
4823
4824	! put in znorthloc the last 4 jlines of pt2d
4825	DO jj = nlcj - ijpj +1, nlcj
4826	ij = jj - nlcj + ijpj
4827	znorthloc(:,ij)=pt2d(:,jj)
4828	END DO
4829
4830	IF (npolj /= 0 ) THEN
4831	! Build in proc 0 of ncomm_north the znorthgloio
4832	znorthgloio(:,:,:) = 0_wp
4833	#ifdef key_mpp_shmem
4834	not done : compiler error
4835	#elif defined key_mpp_mpi
4836	itaille=jpi*ijpj
4837	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4838	#endif
4839	ENDIF
4840
4841	IF (narea == north_root+1 ) THEN
4842	! recover the global north array
4843	ztab(:,:) = 0_wp
4844
4845	DO jr = 1, ndim_rank_north
4846	jproc=nrank_north(jr)+1
4847	ildi=nldit (jproc)
4848	ilei=nleit (jproc)
4849	iilb=nimppt(jproc)
4850	DO jj=1,4
4851	DO ji=ildi,ilei
4852	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
4853	END DO
4854	END DO
4855	END DO
4856
4857
4858	! 2. North-Fold boundary conditions
4859	! ----------------------------------
4860
4861	SELECT CASE ( npolj )
4862
4863	CASE ( 3, 4 ) ! * North fold T-point pivot
4864
4865	ztab( 1 ,ijpj) = 0.e0
4866	ztab(jpiglo,ijpj) = 0.e0
4867
4868	SELECT CASE ( cd_type )
4869
4870	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
4871	DO ji = 2, jpiglo
4872	ijt = jpiglo-ji+2
4873	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
4874	END DO
4875	DO ji = jpiglo/2+1, jpiglo
4876	ijt = jpiglo-ji+2
4877	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
4878	END DO
4879
4880	CASE ( 'U' ) ! U-point
4881	DO ji = 1, jpiglo-1
4882	iju = jpiglo-ji+1
4883	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-2)
4884	END DO
4885	DO ji = jpiglo/2, jpiglo-1
4886	iju = jpiglo-ji+1
4887	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
4888	END DO
4889
4890	CASE ( 'V' ) ! V-point
4891	DO ji = 2, jpiglo
4892	ijt = jpiglo-ji+2
4893	ztab(ji,ijpj-1) = psgn * ztab(ijt,ijpj-2)
4894	ztab(ji,ijpj ) = psgn * ztab(ijt,ijpj-3)
4895	END DO
4896
4897	CASE ( 'F' , 'G' ) ! F-point
4898	DO ji = 1, jpiglo-1
4899	iju = jpiglo-ji+1
4900	ztab(ji,ijpj-1) = psgn * ztab(iju,ijpj-2)
4901	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-3)
4902	END DO
4903
4904	CASE ( 'I' ) ! ice U-V point
4905	ztab(2,ijpj) = psgn * ztab(3,ijpj-1)
4906	DO ji = 3, jpiglo
4907	iju = jpiglo - ji + 3
4908	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
4909	END DO
4910
4911	END SELECT
4912
4913	CASE ( 5, 6 ) ! * North fold F-point pivot
4914
4915	ztab( 1 ,ijpj) = 0.e0
4916	ztab(jpiglo,ijpj) = 0.e0
4917
4918	SELECT CASE ( cd_type )
4919
4920	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
4921	DO ji = 1, jpiglo
4922	ijt = jpiglo-ji+1
4923	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-1)
4924	END DO
4925
4926	CASE ( 'U' ) ! U-point
4927	DO ji = 1, jpiglo-1
4928	iju = jpiglo-ji
4929	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
4930	END DO
4931
4932	CASE ( 'V' ) ! V-point
4933	DO ji = 1, jpiglo
4934	ijt = jpiglo-ji+1
4935	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
4936	END DO
4937	DO ji = jpiglo/2+1, jpiglo
4938	ijt = jpiglo-ji+1
4939	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
4940	END DO
4941
4942	CASE ( 'F' , 'G' ) ! F-point
4943	DO ji = 1, jpiglo-1
4944	iju = jpiglo-ji
4945	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-2)
4946	END DO
4947	DO ji = jpiglo/2+1, jpiglo-1
4948	iju = jpiglo-ji
4949	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
4950	END DO
4951
4952	CASE ( 'I' ) ! ice U-V point
4953	ztab( 2 ,ijpj) = 0.e0
4954	DO ji = 2 , jpiglo-1
4955	ijt = jpiglo - ji + 2
4956	ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) )
4957	END DO
4958
4959	END SELECT
4960
4961	CASE DEFAULT ! * closed : the code probably never go through
4962
4963	SELECT CASE ( cd_type)
4964
4965	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
4966	ztab(:, 1 ) = 0.e0
4967	ztab(:,ijpj) = 0.e0
4968
4969	CASE ( 'F' ) ! F-point
4970	ztab(:,ijpj) = 0.e0
4971
4972	CASE ( 'I' ) ! ice U-V point
4973	ztab(:, 1 ) = 0.e0
4974	ztab(:,ijpj) = 0.e0
4975
4976	END SELECT
4977
4978	END SELECT
4979
4980	! End of slab
4981	! ===========
4982
4983	!! Scatter back to pt2d
4984	DO jr = 1, ndim_rank_north
4985	jproc=nrank_north(jr)+1
4986	ildi=nldit (jproc)
4987	ilei=nleit (jproc)
4988	iilb=nimppt(jproc)
4989	DO jj=1,ijpj
4990	DO ji=ildi,ilei
4991	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
4992	END DO
4993	END DO
4994	END DO
4995
4996	ENDIF ! only done on proc 0 of ncomm_north
4997
4998	#ifdef key_mpp_shmem
4999	not done yet in shmem : compiler error
5000	#elif key_mpp_mpi
5001	IF ( npolj /= 0 ) THEN
5002	itaille=jpi*ijpj
5003	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5004	ENDIF
5005	#endif
5006
5007	! put in the last ijpj jlines of pt2d znorthloc
5008	DO jj = nlcj - ijpj + 1 , nlcj
5009	ij = jj - nlcj + ijpj
5010	pt2d(:,jj)= znorthloc(:,ij)
5011	END DO
5012
5013	END SUBROUTINE mpp_lbc_north_2d
5014
5015
5016	SUBROUTINE mpp_lbc_north_e ( pt2d, cd_type, psgn)
5017	!!---------------------------------------------------------------------
5018	!! * routine mpp_lbc_north_2d *
5019	!!
5020	!! ** Purpose :
5021	!! Ensure proper north fold horizontal bondary condition in mpp configuration
5022	!! in case of jpn1 > 1 (for 2d array with outer extra halo)
5023	!!
5024	!! ** Method :
5025	!! Gather the 4+2*jpr2dj northern lines of the global domain on 1 processor and
5026	!! apply lbc north-fold on this sub array. Then scatter the fold array
5027	!! back to the processors.
5028	!!
5029	!! History :
5030	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5031	!! from lbc routine
5032	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
5033	!! 9.0 ! 05-09 (R. Benshila ) adapt mpp_lbc_north_2d
5034	!!----------------------------------------------------------------------
5035
5036	!! * Arguments
5037	CHARACTER(len=1), INTENT( in ) :: &
5038	cd_type ! nature of pt2d grid-points
5039	! ! = T , U , V , F or W gridpoints
5040	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: &
5041	pt2d ! 2D array on which the boundary condition is applied
5042	REAL(wp), INTENT( in ) :: &
5043	psgn ! control of the sign change
5044	! ! = -1. , the sign is changed if north fold boundary
5045	! ! = 1. , the sign is kept if north fold boundary
5046
5047
5048	!! * Local declarations
5049
5050	INTEGER :: ji, jj, jr, jproc, jl
5051	INTEGER :: ierr
5052	INTEGER :: ildi,ilei,iilb
5053	INTEGER :: ijpj,ijpjm1,ij,ijt,iju, iprecj
5054	INTEGER :: itaille
5055
5056	REAL(wp), DIMENSION(jpiglo,1-jpr2dj:4+jpr2dj) :: ztab
5057	REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj,jpni) :: znorthgloio
5058	REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj) :: znorthloc
5059
5060	! If we get in this routine it s because : North fold condition and mpp with more
5061	! than one proc across i : we deal only with the North condition
5062
5063	! 0. Sign setting
5064	! ---------------
5065
5066	ijpj=4
5067	ijpjm1=3
5068	iprecj = jpr2dj+jprecj
5069
5070	! put in znorthloc the last 4 jlines of pt2d
5071	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
5072	ij = jj - nlcj + ijpj
5073	znorthloc(:,ij)=pt2d(1:jpi,jj)
5074	END DO
5075
5076	IF (npolj /= 0 ) THEN
5077	! Build in proc 0 of ncomm_north the znorthgloio
5078	znorthgloio(:,:,:) = 0_wp
5079	#ifdef key_mpp_shmem
5080	not done : compiler error
5081	#elif defined key_mpp_mpi
5082	itaille=jpi(ijpj+2jpr2dj)
5083	CALL MPI_GATHER(znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION, &
5084	& znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5085	#endif
5086	ENDIF
5087
5088	IF (narea == north_root+1 ) THEN
5089	! recover the global north array
5090	ztab(:,:) = 0_wp
5091
5092	DO jr = 1, ndim_rank_north
5093	jproc=nrank_north(jr)+1
5094	ildi=nldit (jproc)
5095	ilei=nleit (jproc)
5096	iilb=nimppt(jproc)
5097	DO jj=1-jpr2dj,ijpj+jpr2dj
5098	DO ji=ildi,ilei
5099	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
5100	END DO
5101	END DO
5102	END DO
5103
5104
5105	! 2. North-Fold boundary conditions
5106	! ----------------------------------
5107
5108	SELECT CASE ( npolj )
5109
5110	CASE ( 3, 4 ) ! * North fold T-point pivot
5111
5112	ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0
5113	ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0
5114
5115	SELECT CASE ( cd_type )
5116
5117	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5118	DO jl =0, iprecj-1
5119	DO ji = 2, jpiglo
5120	ijt = jpiglo-ji+2
5121	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl)
5122	END DO
5123	END DO
5124	DO ji = jpiglo/2+1, jpiglo
5125	ijt = jpiglo-ji+2
5126	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
5127	END DO
5128
5129	CASE ( 'U' ) ! U-point
5130	DO jl =0, iprecj-1
5131	DO ji = 1, jpiglo-1
5132	iju = jpiglo-ji+1
5133	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl)
5134	END DO
5135	END DO
5136	DO ji = jpiglo/2, jpiglo-1
5137	iju = jpiglo-ji+1
5138	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
5139	END DO
5140
5141	CASE ( 'V' ) ! V-point
5142	DO jl =-1, iprecj-1
5143	DO ji = 2, jpiglo
5144	ijt = jpiglo-ji+2
5145	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-3-jl)
5146	END DO
5147	END DO
5148
5149	CASE ( 'F' , 'G' ) ! F-point
5150	DO jl =-1, iprecj-1
5151	DO ji = 1, jpiglo-1
5152	iju = jpiglo-ji+1
5153	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-3-jl)
5154	END DO
5155	END DO
5156
5157	CASE ( 'I' ) ! ice U-V point
5158	DO jl =0, iprecj-1
5159	ztab(2,ijpj+jl) = psgn * ztab(3,ijpj-1+jl)
5160	DO ji = 3, jpiglo
5161	iju = jpiglo - ji + 3
5162	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl)
5163	END DO
5164	END DO
5165
5166	END SELECT
5167
5168	CASE ( 5, 6 ) ! * North fold F-point pivot
5169
5170	ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0
5171	ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0
5172
5173	SELECT CASE ( cd_type )
5174
5175	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5176	DO jl = 0, iprecj-1
5177	DO ji = 1, jpiglo
5178	ijt = jpiglo-ji+1
5179	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-1-jl)
5180	END DO
5181	END DO
5182
5183	CASE ( 'U' ) ! U-point
5184	DO jl = 0, iprecj-1
5185	DO ji = 1, jpiglo-1
5186	iju = jpiglo-ji
5187	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl)
5188	END DO
5189	END DO
5190
5191	CASE ( 'V' ) ! V-point
5192	DO jl = 0, iprecj-1
5193	DO ji = 1, jpiglo
5194	ijt = jpiglo-ji+1
5195	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl)
5196	END DO
5197	END DO
5198	DO ji = jpiglo/2+1, jpiglo
5199	ijt = jpiglo-ji+1
5200	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
5201	END DO
5202
5203	CASE ( 'F' , 'G' ) ! F-point
5204	DO jl = 0, iprecj-1
5205	DO ji = 1, jpiglo-1
5206	iju = jpiglo-ji
5207	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl)
5208	END DO
5209	END DO
5210	DO ji = jpiglo/2+1, jpiglo-1
5211	iju = jpiglo-ji
5212	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
5213	END DO
5214
5215	CASE ( 'I' ) ! ice U-V point
5216	ztab( 2 ,ijpj:ijpj+jpr2dj) = 0.e0
5217	DO jl = 0, jpr2dj
5218	DO ji = 2 , jpiglo-1
5219	ijt = jpiglo - ji + 2
5220	ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) )
5221	END DO
5222	END DO
5223
5224	END SELECT
5225
5226	CASE DEFAULT ! * closed : the code probably never go through
5227
5228	SELECT CASE ( cd_type)
5229
5230	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5231	ztab(:, 1:1-jpr2dj ) = 0.e0
5232	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5233
5234	CASE ( 'F' ) ! F-point
5235	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5236
5237	CASE ( 'I' ) ! ice U-V point
5238	ztab(:, 1:1-jpr2dj ) = 0.e0
5239	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5240
5241	END SELECT
5242
5243	END SELECT
5244
5245	! End of slab
5246	! ===========
5247
5248	!! Scatter back to pt2d
5249	DO jr = 1, ndim_rank_north
5250	jproc=nrank_north(jr)+1
5251	ildi=nldit (jproc)
5252	ilei=nleit (jproc)
5253	iilb=nimppt(jproc)
5254	DO jj=1-jpr2dj,ijpj+jpr2dj
5255	DO ji=ildi,ilei
5256	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
5257	END DO
5258	END DO
5259	END DO
5260
5261	ENDIF ! only done on proc 0 of ncomm_north
5262
5263	#ifdef key_mpp_shmem
5264	not done yet in shmem : compiler error
5265	#elif key_mpp_mpi
5266	IF ( npolj /= 0 ) THEN
5267	itaille=jpi(ijpj+2jpr2dj)
5268	CALL MPI_SCATTER(znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION, &
5269	& znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5270	ENDIF
5271	#endif
5272
5273	! put in the last ijpj jlines of pt2d znorthloc
5274	DO jj = nlcj - ijpj -jpr2dj + 1 , nlcj +jpr2dj
5275	ij = jj - nlcj + ijpj
5276	pt2d(1:jpi,jj)= znorthloc(:,ij)
5277	END DO
5278
5279	END SUBROUTINE mpp_lbc_north_e
5280
5281
5282	!!!!!
5283
5284
5285	!!
5286	!! This is valid on IBM machine ONLY.
5287	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -- Mode: F90 -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5288	!! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque
5289	!! MPI afin de faire, en plus de l'initialisation de
5290	!! l'environnement MPI, l'allocation d'une zone tampon
5291	!! qui sera ulterieurement utilisee automatiquement lors
5292	!! de tous les envois de messages par MPI_BSEND
5293	!!
5294	!! Auteur : CNRS/IDRIS
5295	!! Date : Tue Nov 13 12:02:14 2001
5296	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5297
5298	SUBROUTINE mpi_init_opa(code)
5299	IMPLICIT NONE
5300
5301	!$AGRIF_DO_NOT_TREAT
5302	# include <mpif.h>
5303	!$AGRIF_END_DO_NOT_TREAT
5304
5305	INTEGER :: code,rang,ierr
5306	LOGICAL :: mpi_was_called
5307
5308	! La valeur suivante doit etre au moins egale a la taille
5309	! du plus grand message qui sera transfere dans le programme
5310	! (de toute facon, il y aura un message d'erreur si cette
5311	! valeur s'avere trop petite)
5312	INTEGER :: taille_tampon
5313	CHARACTER(len=9) :: taille_tampon_alphanum
5314	REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon
5315
5316	! Le point d'entree dans la bibliotheque MPI elle-meme
5317	CALL mpi_initialized(mpi_was_called, code)
5318	IF ( code /= MPI_SUCCESS ) THEN
5319	CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
5320	CALL mpi_abort( mpi_comm_world, code, ierr )
5321	ENDIF
5322
5323	IF ( .NOT. mpi_was_called ) THEN
5324	CALL mpi_init(code)
5325	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
5326	IF ( code /= MPI_SUCCESS ) THEN
5327	CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
5328	CALL mpi_abort( mpi_comm_world, code, ierr )
5329	ENDIF
5330	ENDIF
5331	! La definition de la zone tampon pour les futurs envois
5332	! par MPI_BSEND (on alloue une fois pour toute cette zone
5333	! tampon, qui sera automatiquement utilisee lors de chaque
5334	! appel a MPI_BSEND).
5335	! La desallocation sera implicite quand on sortira de
5336	! l'environnement MPI.
5337
5338	! Recuperation de la valeur de la variable d'environnement
5339	! BUFFER_LENGTH
5340	! qui, si elle est definie, doit contenir une valeur superieure
5341	! a la taille en octets du plus gros message
5342	CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum)
5343
5344	! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par
5345	! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit
5346	! 65 536 octets
5347	IF (taille_tampon_alphanum == ' ') THEN
5348	taille_tampon = 65536
5349	ELSE
5350	READ(taille_tampon_alphanum,'(i9)') taille_tampon
5351	END IF
5352
5353	! On est limite en mode d'adressage 32 bits a 1750 Mo pour la zone
5354	! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo
5355	IF (taille_tampon > 210000000) THEN
5356	CALL ctl_stop( ' lib_mpp: Attention la valeur BUFFER_LENGTH doit etre <= 210000000' )
5357	CALL mpi_abort(MPI_COMM_WORLD,2,code)
5358	END IF
5359
5360	CALL mpi_comm_rank(MPI_COMM_OPA,rang,code)
5361	IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon
5362
5363	! Allocation du tampon et attachement
5364	ALLOCATE(tampon(taille_tampon))
5365	CALL mpi_buffer_attach(tampon,taille_tampon,code)
5366
5367	END SUBROUTINE mpi_init_opa
5368
5369	#else
5370	!!----------------------------------------------------------------------
5371	!! Default case: Dummy module share memory computing
5372	!!----------------------------------------------------------------------
5373	INTERFACE mpp_sum
5374	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
5375	END INTERFACE
5376	INTERFACE mpp_max
5377	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
5378	END INTERFACE
5379	INTERFACE mpp_min
5380	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
5381	END INTERFACE
5382	INTERFACE mpp_isl
5383	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
5384	END INTERFACE
5385	INTERFACE mppobc
5386	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
5387	END INTERFACE
5388	INTERFACE mpp_minloc
5389	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
5390	END INTERFACE
5391	INTERFACE mpp_maxloc
5392	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
5393	END INTERFACE
5394
5395
5396	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
5397	INTEGER :: ncomm_ice
5398
5399	CONTAINS
5400
5401	FUNCTION mynode(localComm) RESULT (function_value)
5402	INTEGER, OPTIONAL :: localComm
5403	function_value = 0
5404	END FUNCTION mynode
5405
5406	SUBROUTINE mppsync ! Dummy routine
5407	END SUBROUTINE mppsync
5408
5409	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
5410	REAL , DIMENSION(:) :: parr
5411	INTEGER :: kdim
5412	INTEGER, OPTIONAL :: kcom
5413	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
5414	END SUBROUTINE mpp_sum_as
5415
5416	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
5417	REAL , DIMENSION(:,:) :: parr
5418	INTEGER :: kdim
5419	INTEGER, OPTIONAL :: kcom
5420	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
5421	END SUBROUTINE mpp_sum_a2s
5422
5423	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
5424	INTEGER, DIMENSION(:) :: karr
5425	INTEGER :: kdim
5426	INTEGER, OPTIONAL :: kcom
5427	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
5428	END SUBROUTINE mpp_sum_ai
5429
5430	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
5431	REAL :: psca
5432	INTEGER, OPTIONAL :: kcom
5433	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
5434	END SUBROUTINE mpp_sum_s
5435
5436	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
5437	integer :: kint
5438	INTEGER, OPTIONAL :: kcom
5439	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
5440	END SUBROUTINE mpp_sum_i
5441
5442	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
5443	REAL , DIMENSION(:) :: parr
5444	INTEGER :: kdim
5445	INTEGER, OPTIONAL :: kcom
5446	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
5447	END SUBROUTINE mppmax_a_real
5448
5449	SUBROUTINE mppmax_real( psca, kcom )
5450	REAL :: psca
5451	INTEGER, OPTIONAL :: kcom
5452	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
5453	END SUBROUTINE mppmax_real
5454
5455	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
5456	REAL , DIMENSION(:) :: parr
5457	INTEGER :: kdim
5458	INTEGER, OPTIONAL :: kcom
5459	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
5460	END SUBROUTINE mppmin_a_real
5461
5462	SUBROUTINE mppmin_real( psca, kcom )
5463	REAL :: psca
5464	INTEGER, OPTIONAL :: kcom
5465	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
5466	END SUBROUTINE mppmin_real
5467
5468	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
5469	INTEGER, DIMENSION(:) :: karr
5470	INTEGER :: kdim
5471	INTEGER, OPTIONAL :: kcom
5472	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
5473	END SUBROUTINE mppmax_a_int
5474
5475	SUBROUTINE mppmax_int( kint, kcom)
5476	INTEGER :: kint
5477	INTEGER, OPTIONAL :: kcom
5478	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
5479	END SUBROUTINE mppmax_int
5480
5481	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
5482	INTEGER, DIMENSION(:) :: karr
5483	INTEGER :: kdim
5484	INTEGER, OPTIONAL :: kcom
5485	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
5486	END SUBROUTINE mppmin_a_int
5487
5488	SUBROUTINE mppmin_int( kint, kcom )
5489	INTEGER :: kint
5490	INTEGER, OPTIONAL :: kcom
5491	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
5492	END SUBROUTINE mppmin_int
5493
5494	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
5495	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5496	REAL, DIMENSION(:) :: parr ! variable array
5497	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5498	& parr(1), kd1, kd2, kl, kk, ktype, kij
5499	END SUBROUTINE mppobc_1d
5500
5501	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
5502	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5503	REAL, DIMENSION(:,:) :: parr ! variable array
5504	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5505	& parr(1,1), kd1, kd2, kl, kk, ktype, kij
5506	END SUBROUTINE mppobc_2d
5507
5508	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
5509	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5510	REAL, DIMENSION(:,:,:) :: parr ! variable array
5511	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5512	& parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
5513	END SUBROUTINE mppobc_3d
5514
5515	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
5516	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5517	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
5518	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5519	& parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
5520	END SUBROUTINE mppobc_4d
5521
5522
5523	SUBROUTINE mpplnks( parr ) ! Dummy routine
5524	REAL, DIMENSION(:,:) :: parr
5525	WRITE(,) 'mpplnks: You should not have seen this print! error?', parr(1,1)
5526	END SUBROUTINE mpplnks
5527
5528	SUBROUTINE mppisl_a_int( karr, kdim )
5529	INTEGER, DIMENSION(:) :: karr
5530	INTEGER :: kdim
5531	WRITE(,) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1)
5532	END SUBROUTINE mppisl_a_int
5533
5534	SUBROUTINE mppisl_int( kint )
5535	INTEGER :: kint
5536	WRITE(,) 'mppisl_int: You should not have seen this print! error?', kint
5537	END SUBROUTINE mppisl_int
5538
5539	SUBROUTINE mppisl_a_real( parr, kdim )
5540	REAL , DIMENSION(:) :: parr
5541	INTEGER :: kdim
5542	WRITE(,) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1)
5543	END SUBROUTINE mppisl_a_real
5544
5545	SUBROUTINE mppisl_real( psca )
5546	REAL :: psca
5547	WRITE(,) 'mppisl_real: You should not have seen this print! error?', psca
5548	END SUBROUTINE mppisl_real
5549
5550	SUBROUTINE mpp_minloc2d ( ptab, pmask, pmin, ki, kj )
5551	REAL :: pmin
5552	REAL , DIMENSION (:,:) :: ptab, pmask
5553	INTEGER :: ki, kj
5554	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj
5555	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
5556	END SUBROUTINE mpp_minloc2d
5557
5558	SUBROUTINE mpp_minloc3d ( ptab, pmask, pmin, ki, kj, kk )
5559	REAL :: pmin
5560	REAL , DIMENSION (:,:,:) :: ptab, pmask
5561	INTEGER :: ki, kj, kk
5562	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj, kk
5563	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
5564	END SUBROUTINE mpp_minloc3d
5565
5566	SUBROUTINE mpp_maxloc2d ( ptab, pmask, pmax, ki, kj )
5567	REAL :: pmax
5568	REAL , DIMENSION (:,:) :: ptab, pmask
5569	INTEGER :: ki, kj
5570	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj
5571	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
5572	END SUBROUTINE mpp_maxloc2d
5573
5574	SUBROUTINE mpp_maxloc3d ( ptab, pmask, pmax, ki, kj, kk )
5575	REAL :: pmax
5576	REAL , DIMENSION (:,:,:) :: ptab, pmask
5577	INTEGER :: ki, kj, kk
5578	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj, kk
5579	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
5580	END SUBROUTINE mpp_maxloc3d
5581
5582	SUBROUTINE mppstop
5583	WRITE(,) 'mppstop: You should not have seen this print! error?'
5584	END SUBROUTINE mppstop
5585
5586	SUBROUTINE mpp_ini_ice(kcom)
5587	INTEGER :: kcom
5588	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?',kcom
5589	END SUBROUTINE mpp_ini_ice
5590
5591	SUBROUTINE mpp_comm_free(kcom)
5592	INTEGER :: kcom
5593	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?',kcom
5594	END SUBROUTINE mpp_comm_free
5595
5596	#endif
5597	!!----------------------------------------------------------------------
5598	END MODULE lib_mpp

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

Download in other formats: