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

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

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

Download in other formats: