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

Last change on this file since 300 was 300, checked in by opalod, 19 years ago
nemo_v1_update_013 : CT : replace cpp keys key_mpi_isend, key_mpi_bsend by a character parameter in the ocean namelist
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 128.6 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	!! mpplnks
17	!! mpprecv
18	!! mppsend
19	!! mppscatter
20	!! mppgather
21	!! mpp_isl : generic inteface for :
22	!! mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real
23	!! mpp_min : generic interface for :
24	!! mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
25	!! mpp_max : generic interface for :
26	!! mppmax_real, mppmax_a_real
27	!! mpp_sum : generic interface for :
28	!! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
29	!! mppsync
30	!! mppstop
31	!! mppobc : variant of mpp_lnk for open boundaries
32	!! mpp_ini_north
33	!! mpp_lbc_north
34	!!----------------------------------------------------------------------
35	!! History :
36	!! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code
37	!! ! 97 (A.M. Treguier) SHMEM additions
38	!! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
39	!! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form
40	!! ! 04 (R. Bourdalle Badie) isend option in mpi
41	!! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
42	!!----------------------------------------------------------------------
43	!! OPA 9.0 , LOCEAN-IPSL (2005)
44	!! $Header$
45	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
46	!!---------------------------------------------------------------------
47	!! * Modules used
48	USE dom_oce ! ocean space and time domain
49	USE in_out_manager ! I/O manager
50
51	IMPLICIT NONE
52
53	!! * Interfaces
54	!! define generic interface for these routine as they are called sometimes
55	!! with scalar arguments instead of array arguments, which causes problems
56	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
57
58	INTERFACE mpp_isl
59	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
60	END INTERFACE
61	INTERFACE mpp_min
62	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
63	END INTERFACE
64	INTERFACE mpp_max
65	MODULE PROCEDURE mppmax_a_real, mppmax_real
66	END INTERFACE
67	INTERFACE mpp_sum
68	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
69	END INTERFACE
70	INTERFACE mpp_lbc_north
71	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
72	END INTERFACE
73	INTERFACE mpp_minloc
74	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
75	END INTERFACE
76	INTERFACE mpp_maxloc
77	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
78	END INTERFACE
79
80
81	!! * Share module variables
82	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
83
84
85	!! * Module variables
86	!! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
87	INTEGER, PARAMETER :: &
88	nprocmax = 2**10, & ! maximun dimension
89	ndim_mpp = jpnij ! dimension for this simulation
90
91	#if defined key_mpp_mpi
92	!! ========================= !!
93	!! MPI variable definition !!
94	!! ========================= !!
95	# include <mpif.h>
96
97	INTEGER :: &
98	size, & ! number of process
99	rank ! process number [ 0 - size-1 ]
100
101	! variables used in case of north fold condition in mpp_mpi with jpni > 1
102	INTEGER :: & !
103	ngrp_world, & ! group ID for the world processors
104	ngrp_north, & ! group ID for the northern processors (to be fold)
105	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
106	ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !)
107	njmppmax ! value of njmpp for the processors of the northern line
108	INTEGER :: & !
109	north_root ! number (in the comm_world) of proc 0 in the northern comm
110	INTEGER, DIMENSION(:), ALLOCATABLE :: &
111	nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
112	CHARACTER (len=1) :: &
113	c_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
114	LOGICAL :: &
115	l_isend = .FALSE. ! isend use indicator (T if c_mpi_send='I')
116
117
118	#elif defined key_mpp_shmem
119	!! ========================= !!
120	!! SHMEM variable definition !!
121	!! ========================= !!
122	# include <fpvm3.h>
123	# include <mpp/shmem.fh>
124
125	CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name
126	CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name
127	CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall())
128
129	INTEGER, PARAMETER :: & !! SHMEM control print
130	mynode_print = 0, & ! flag for print, mynode routine
131	mpprecv_print = 0, & ! flag for print, mpprecv routine
132	mppsend_print = 0, & ! flag for print, mppsend routine
133	mppsync_print = 0, & ! flag for print, mppsync routine
134	mppsum_print = 0, & ! flag for print, mpp_sum routine
135	mppisl_print = 0, & ! flag for print, mpp_isl routine
136	mppmin_print = 0, & ! flag for print, mpp_min routine
137	mppmax_print = 0, & ! flag for print, mpp_max routine
138	mpparent_print = 0 ! flag for print, mpparent routine
139
140	INTEGER, PARAMETER :: & !! Variable definition
141	jpvmint = 21 ! ???
142
143	INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors
144	jpmsec = 50000, & ! ???
145	jpmpplat = 30, & ! ???
146	jpmppsum = MAX( jpisljpisl, jpmpplatjpk, jpmsec ) ! ???
147
148	INTEGER :: &
149	npvm_ipas , & ! pvm initialization flag
150	npvm_mytid, & ! pvm tid
151	npvm_me , & ! node number [ 0 - nproc-1 ]
152	npvm_nproc, & ! real number of nodes
153	npvm_inum ! ???
154	INTEGER, DIMENSION(0:nprocmax-1) :: &
155	npvm_tids ! tids array [ 0 - nproc-1 ]
156
157	INTEGER :: &
158	nt3d_ipas , & ! pvm initialization flag
159	nt3d_mytid, & ! pvm tid
160	nt3d_me , & ! node number [ 0 - nproc-1 ]
161	nt3d_nproc ! real number of nodes
162	INTEGER, DIMENSION(0:nprocmax-1) :: &
163	nt3d_tids ! tids array [ 0 - nproc-1 ]
164
165	!! real sum reduction
166	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
167	nrs1sync_shmem, & !
168	nrs2sync_shmem
169	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
170	wrs1wrk_shmem, & !
171	wrs2wrk_shmem !
172	REAL(wp), DIMENSION(jpmppsum) :: &
173	wrstab_shmem !
174
175	!! minimum and maximum reduction
176	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
177	ni1sync_shmem, & !
178	ni2sync_shmem !
179	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
180	wi1wrk_shmem, & !
181	wi2wrk_shmem
182	REAL(wp), DIMENSION(jpmppsum) :: &
183	wintab_shmem, & !
184	wi1tab_shmem, & !
185	wi2tab_shmem !
186
187	!! value not equal zero for barotropic stream function around islands
188	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
189	ni11sync_shmem, & !
190	ni12sync_shmem, & !
191	ni21sync_shmem, & !
192	ni22sync_shmem !
193	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
194	wi11wrk_shmem, & !
195	wi12wrk_shmem, & !
196	wi21wrk_shmem, & !
197	wi22wrk_shmem !
198	REAL(wp), DIMENSION(jpmppsum) :: &
199	wiltab_shmem , & !
200	wi11tab_shmem, & !
201	wi12tab_shmem, & !
202	wi21tab_shmem, & !
203	wi22tab_shmem
204
205	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
206	ni11wrk_shmem, & !
207	ni12wrk_shmem, & !
208	ni21wrk_shmem, & !
209	ni22wrk_shmem !
210	INTEGER, DIMENSION(jpmppsum) :: &
211	niitab_shmem , & !
212	ni11tab_shmem, & !
213	ni12tab_shmem !
214	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
215	nis1sync_shmem, & !
216	nis2sync_shmem !
217	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
218	nis1wrk_shmem, & !
219	nis2wrk_shmem !
220	INTEGER, DIMENSION(jpmppsum) :: &
221	nistab_shmem
222
223	!! integer sum reduction
224	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
225	nil1sync_shmem, & !
226	nil2sync_shmem !
227	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
228	nil1wrk_shmem, & !
229	nil2wrk_shmem !
230	INTEGER, DIMENSION(jpmppsum) :: &
231	niltab_shmem
232	#endif
233
234	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
235	t3ns, t3sn ! 3d message passing arrays north-south & south-north
236	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &
237	t3ew, t3we ! 3d message passing arrays east-west & west-east
238	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
239	t3p1, t3p2 ! 3d message passing arrays north fold
240	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
241	t2ns, t2sn ! 2d message passing arrays north-south & south-north
242	REAL(wp), DIMENSION(jpj,jpreci,2) :: &
243	t2ew, t2we ! 2d message passing arrays east-west & west-east
244	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
245	t2p1, t2p2 ! 2d message passing arrays north fold
246	!!----------------------------------------------------------------------
247	!! OPA 9.0 , LOCEAN-IPSL (2005)
248	!! $Header$
249	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
250	!!---------------------------------------------------------------------
251
252	CONTAINS
253
254	FUNCTION mynode()
255	!!----------------------------------------------------------------------
256	!! * routine mynode *
257	!!
258	!! ** Purpose : Find processor unit
259	!!
260	!!----------------------------------------------------------------------
261	#if defined key_mpp_mpi
262	!! * Local variables (MPI version)
263	INTEGER :: mynode, ierr
264	NAMELIST/nam_mpp/ c_mpi_send
265	!!----------------------------------------------------------------------
266
267	WRITE(numout,*)
268	WRITE(numout,*) 'mynode : mpi initialisation'
269	WRITE(numout,*) '~~~~~~ '
270	WRITE(numout,*)
271
272	! Namelist namrun : parameters of the run
273	REWIND( numnam )
274	READ ( numnam, nam_mpp )
275
276	WRITE(numout,*) ' Namelist nam_mpp'
277	WRITE(numout,*) ' mpi send type c_mpi_send = ', c_mpi_send
278
279	SELECT CASE ( c_mpi_send )
280	CASE ( 'S' ) ! Standard mpi send (blocking)
281	WRITE(numout,*) ' Standard blocking mpi send (send)'
282	CALL mpi_init( ierr )
283	CASE ( 'B' ) ! Buffer mpi send (blocking)
284	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
285	CALL mpi_init_opa( ierr )
286	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
287	WRITE(numout,*) ' Immediate non-blocking send (isend)'
288	l_isend = .TRUE.
289	CALL mpi_init( ierr )
290	CASE DEFAULT
291	WRITE(numout,cform_err)
292	WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send
293	nstop = nstop + 1
294	END SELECT
295
296	CALL mpi_comm_rank( mpi_comm_world, rank, ierr )
297	CALL mpi_comm_size( mpi_comm_world, size, ierr )
298	mynode = rank
299	#else
300	!! * Local variables (SHMEM version)
301	INTEGER :: mynode
302	INTEGER :: &
303	imypid, imyhost, ji, info, iparent_tid
304	!!----------------------------------------------------------------------
305
306	IF( npvm_ipas /= nprocmax ) THEN
307	! --- first passage in mynode
308	! -------------
309	! enroll in pvm
310	! -------------
311	CALL pvmfmytid( npvm_mytid )
312	IF( mynode_print /= 0 ) THEN
313	WRITE(numout,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
314	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
315	ENDIF
316
317	! ---------------------------------------------------------------
318	! find out IF i am parent or child spawned processes have parents
319	! ---------------------------------------------------------------
320	CALL mpparent( iparent_tid )
321	IF( mynode_print /= 0 ) THEN
322	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
323	& ' after mpparent, npvm_tids(0) = ', &
324	& npvm_tids(0), ' iparent_tid=', iparent_tid
325	ENDIF
326	IF( iparent_tid < 0 ) THEN
327	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
328	& ' after mpparent, npvm_tids(0) = ', &
329	& npvm_tids(0), ' iparent_tid=', iparent_tid
330	npvm_tids(0) = npvm_mytid
331	npvm_me = 0
332	IF( ndim_mpp > nprocmax ) THEN
333	WRITE(numout,*) 'npvm_mytid=', npvm_mytid, ' too great'
334	STOP ' mynode '
335	ELSE
336	npvm_nproc = ndim_mpp
337	ENDIF
338
339	! -------------------------
340	! start up copies of myself
341	! -------------------------
342	IF( npvm_nproc > 1 ) THEN
343	DO ji = 1, npvm_nproc-1
344	npvm_tids(ji) = nt3d_tids(ji)
345	END DO
346	info=npvm_nproc-1
347
348	IF( mynode_print /= 0 ) THEN
349	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
350	& ' maitre=',executable,' info=', info &
351	& ,' npvm_nproc=',npvm_nproc
352	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
353	& ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
354	ENDIF
355
356	! ---------------------------
357	! multicast tids array to children
358	! ---------------------------
359	CALL pvmfinitsend( pvmdefault, info )
360	CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info )
361	CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
362	CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
363	ENDIF
364	ELSE
365
366	! ---------------------------------
367	! receive the tids array and set me
368	! ---------------------------------
369	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
370	CALL pvmfrecv( iparent_tid, 10, info )
371	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
372	CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info )
373	CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
374	IF( mynode_print /= 0 ) THEN
375	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
376	& ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
377	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
378	& 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
379	ENDIF
380	DO ji = 0, npvm_nproc-1
381	IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
382	END DO
383	ENDIF
384
385	! ------------------------------------------------------------
386	! all nproc tasks are equal now
387	! and can address each other by tids(0) thru tids(nproc-1)
388	! for each process me => process number [0-(nproc-1)]
389	! ------------------------------------------------------------
390	CALL pvmfjoingroup ( "bidon", info )
391	CALL pvmfbarrier ( "bidon", npvm_nproc, info )
392	DO ji = 0, npvm_nproc-1
393	IF( ji == npvm_me ) THEN
394	CALL pvmfjoingroup ( opaall, npvm_inum )
395	IF( npvm_inum /= npvm_me ) WRITE(numout,*) 'mynode not arrived in the good order for opaall'
396	ENDIF
397	CALL pvmfbarrier( "bidon", npvm_nproc, info )
398	END DO
399	CALL pvmfbarrier( opaall, npvm_nproc, info )
400
401	ELSE
402	! --- other passage in mynode
403	ENDIF
404
405	npvm_ipas = nprocmax
406	mynode = npvm_me
407	imypid = npvm_mytid
408	imyhost = npvm_tids(0)
409	IF( mynode_print /= 0 ) THEN
410	WRITE(numout,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, &
411	& ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
412	ENDIF
413	#endif
414	END FUNCTION mynode
415
416
417	SUBROUTINE mpparent( kparent_tid )
418	!!----------------------------------------------------------------------
419	!! * routine mpparent *
420	!!
421	!! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem)
422	!! or only return -1 (key_mpp_mpi)
423	!!----------------------------------------------------------------------
424	!! * Arguments
425	INTEGER, INTENT(inout) :: kparent_tid ! ???
426
427	#if defined key_mpp_mpi
428	! MPI version : retour -1
429
430	kparent_tid = -1
431
432	#else
433	!! * Local variables (SHMEN onto T3E version)
434	INTEGER :: &
435	it3d_my_pe, LEADZ, ji, info
436
437	CALL pvmfmytid( nt3d_mytid )
438	CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
439	IF( mpparent_print /= 0 ) THEN
440	WRITE(numout,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
441	ENDIF
442	IF( it3d_my_pe == 0 ) THEN
443	!-----------------------------------------------------------------!
444	! process = 0 => receive other tids !
445	!-----------------------------------------------------------------!
446	kparent_tid = -1
447	IF(mpparent_print /= 0 ) THEN
448	WRITE(numout,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
449	ENDIF
450	! --- END receive dimension ---
451	IF( ndim_mpp > nprocmax ) THEN
452	WRITE(numout,*) 'mytid=',nt3d_mytid,' too great'
453	STOP ' mpparent '
454	ELSE
455	nt3d_nproc = ndim_mpp
456	ENDIF
457	IF( mpparent_print /= 0 ) THEN
458	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
459	ENDIF
460	!-------- receive tids from others process --------
461	DO ji = 1, nt3d_nproc-1
462	CALL pvmfrecv( ji , 100, info )
463	CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
464	IF( mpparent_print /= 0 ) THEN
465	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
466	ENDIF
467	END DO
468	nt3d_tids(0) = nt3d_mytid
469	IF( mpparent_print /= 0 ) THEN
470	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), &
471	ji = 0, nt3d_nproc-1 )
472	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
473	ENDIF
474
475	ELSE
476	!!----------------------------------------------------------------!
477	! process <> 0 => send other tids !
478	!!----------------------------------------------------------------!
479	kparent_tid = 0
480	CALL pvmfinitsend( pvmdataraw, info )
481	CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
482	CALL pvmfsend( kparent_tid, 100, info )
483	ENDIF
484	#endif
485
486	END SUBROUTINE mpparent
487
488	#if defined key_mpp_shmem
489
490	SUBROUTINE mppshmem
491	!!----------------------------------------------------------------------
492	!! * routine mppshmem *
493	!!
494	!! ** Purpose : SHMEM ROUTINE
495	!!
496	!!----------------------------------------------------------------------
497	nrs1sync_shmem = SHMEM_SYNC_VALUE
498	nrs2sync_shmem = SHMEM_SYNC_VALUE
499	nis1sync_shmem = SHMEM_SYNC_VALUE
500	nis2sync_shmem = SHMEM_SYNC_VALUE
501	nil1sync_shmem = SHMEM_SYNC_VALUE
502	nil2sync_shmem = SHMEM_SYNC_VALUE
503	ni11sync_shmem = SHMEM_SYNC_VALUE
504	ni12sync_shmem = SHMEM_SYNC_VALUE
505	ni21sync_shmem = SHMEM_SYNC_VALUE
506	ni22sync_shmem = SHMEM_SYNC_VALUE
507	CALL barrier()
508
509	END SUBROUTINE mppshmem
510
511	#endif
512
513	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )
514	!!----------------------------------------------------------------------
515	!! * routine mpp_lnk_3d *
516	!!
517	!! ** Purpose : Message passing manadgement
518	!!
519	!! ** Method : Use mppsend and mpprecv function for passing mask
520	!! between processors following neighboring subdomains.
521	!! domain parameters
522	!! nlci : first dimension of the local subdomain
523	!! nlcj : second dimension of the local subdomain
524	!! nbondi : mark for "east-west local boundary"
525	!! nbondj : mark for "north-south local boundary"
526	!! noea : number for local neighboring processors
527	!! nowe : number for local neighboring processors
528	!! noso : number for local neighboring processors
529	!! nono : number for local neighboring processors
530	!!
531	!! ** Action : ptab with update value at its periphery
532	!!
533	!!----------------------------------------------------------------------
534	!! * Arguments
535	CHARACTER(len=1) , INTENT( in ) :: &
536	cd_type ! define the nature of ptab array grid-points
537	! ! = T , U , V , F , W points
538	! ! = S : T-point, north fold treatment ???
539	! ! = G : F-point, north fold treatment ???
540	REAL(wp), INTENT( in ) :: &
541	psgn ! control of the sign change
542	! ! = -1. , the sign is changed if north fold boundary
543	! ! = 1. , the sign is kept if north fold boundary
544	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
545	ptab ! 3D array on which the boundary condition is applied
546
547	!! * Local variables
548	INTEGER :: ji, jk, jl ! dummy loop indices
549	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
550	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
551	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
552	!!----------------------------------------------------------------------
553
554	! 1. standard boundary treatment
555	! ------------------------------
556	! ! East-West boundaries
557	! ! ====================
558	IF( nbondi == 2 .AND. & ! Cyclic east-west
559	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
560	ptab( 1 ,:,:) = ptab(jpim1,:,:)
561	ptab(jpi,:,:) = ptab( 2 ,:,:)
562
563	ELSE ! closed
564	SELECT CASE ( cd_type )
565	CASE ( 'T', 'U', 'V', 'W' )
566	ptab( 1 :jpreci,:,:) = 0.e0
567	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
568	CASE ( 'F' )
569	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
570	END SELECT
571	ENDIF
572
573	! ! North-South boundaries
574	! ! ======================
575	SELECT CASE ( cd_type )
576	CASE ( 'T', 'U', 'V', 'W' )
577	ptab(:, 1 :jprecj,:) = 0.e0
578	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
579	CASE ( 'F' )
580	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
581	END SELECT
582
583
584	! 2. East and west directions exchange
585	! ------------------------------------
586
587	! 2.1 Read Dirichlet lateral conditions
588
589	SELECT CASE ( nbondi )
590	CASE ( -1, 0, 1 ) ! all exept 2
591	iihom = nlci-nreci
592	DO jl = 1, jpreci
593	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
594	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
595	END DO
596	END SELECT
597
598	! 2.2 Migrations
599
600	#if defined key_mpp_shmem
601	!! * SHMEM version
602
603	imigr = jpreci * jpj * jpk
604
605	SELECT CASE ( nbondi )
606	CASE ( -1 )
607	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
608	CASE ( 0 )
609	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
610	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
611	CASE ( 1 )
612	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
613	END SELECT
614
615	CALL barrier()
616	CALL shmem_udcflush()
617
618	#elif defined key_mpp_mpi
619	!! * Local variables (MPI version)
620
621	imigr = jpreci * jpj * jpk
622
623	SELECT CASE ( nbondi )
624	CASE ( -1 )
625	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
626	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
627	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
628	CASE ( 0 )
629	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
630	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
631	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
632	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
633	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
634	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
635	CASE ( 1 )
636	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
637	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
638	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
639	END SELECT
640	#endif
641
642	! 2.3 Write Dirichlet lateral conditions
643
644	iihom = nlci-jpreci
645
646	SELECT CASE ( nbondi )
647	CASE ( -1 )
648	DO jl = 1, jpreci
649	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
650	END DO
651	CASE ( 0 )
652	DO jl = 1, jpreci
653	ptab(jl ,:,:) = t3we(:,jl,:,2)
654	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
655	END DO
656	CASE ( 1 )
657	DO jl = 1, jpreci
658	ptab(jl ,:,:) = t3we(:,jl,:,2)
659	END DO
660	END SELECT
661
662
663	! 3. North and south directions
664	! -----------------------------
665
666	! 3.1 Read Dirichlet lateral conditions
667
668	IF( nbondj /= 2 ) THEN
669	ijhom = nlcj-nrecj
670	DO jl = 1, jprecj
671	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
672	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
673	END DO
674	ENDIF
675
676	! 3.2 Migrations
677
678	#if defined key_mpp_shmem
679	!! * SHMEM version
680
681	imigr = jprecj * jpi * jpk
682
683	SELECT CASE ( nbondj )
684	CASE ( -1 )
685	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
686	CASE ( 0 )
687	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
688	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
689	CASE ( 1 )
690	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
691	END SELECT
692
693	CALL barrier()
694	CALL shmem_udcflush()
695
696	#elif defined key_mpp_mpi
697	!! * Local variables (MPI version)
698
699	imigr=jprecjjpijpk
700
701	SELECT CASE ( nbondj )
702	CASE ( -1 )
703	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
704	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
705	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
706	CASE ( 0 )
707	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
708	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
709	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
710	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
711	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
712	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
713	CASE ( 1 )
714	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
715	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
716	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
717	END SELECT
718
719	#endif
720
721	! 3.3 Write Dirichlet lateral conditions
722
723	ijhom = nlcj-jprecj
724
725	SELECT CASE ( nbondj )
726	CASE ( -1 )
727	DO jl = 1, jprecj
728	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
729	END DO
730	CASE ( 0 )
731	DO jl = 1, jprecj
732	ptab(:,jl ,:) = t3sn(:,jl,:,2)
733	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
734	END DO
735	CASE ( 1 )
736	DO jl = 1, jprecj
737	ptab(:,jl,:) = t3sn(:,jl,:,2)
738	END DO
739	END SELECT
740
741
742	! 4. north fold treatment
743	! -----------------------
744
745	! 4.1 treatment without exchange (jpni odd)
746	! T-point pivot
747
748	SELECT CASE ( jpni )
749
750	CASE ( 1 ) ! only one proc along I, no mpp exchange
751
752	SELECT CASE ( npolj )
753
754	CASE ( 3 , 4 ) ! T pivot
755	iloc = jpiglo - 2 * ( nimpp - 1 )
756
757	SELECT CASE ( cd_type )
758
759	CASE ( 'T' , 'S', 'W' )
760	DO jk = 1, jpk
761	DO ji = 2, nlci
762	ijt=iloc-ji+2
763	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
764	END DO
765	DO ji = nlci/2+1, nlci
766	ijt=iloc-ji+2
767	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
768	END DO
769	END DO
770
771	CASE ( 'U' )
772	DO jk = 1, jpk
773	DO ji = 1, nlci-1
774	iju=iloc-ji+1
775	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
776	END DO
777	DO ji = nlci/2, nlci-1
778	iju=iloc-ji+1
779	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
780	END DO
781	END DO
782
783	CASE ( 'V' )
784	DO jk = 1, jpk
785	DO ji = 2, nlci
786	ijt=iloc-ji+2
787	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
788	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)
789	END DO
790	END DO
791
792	CASE ( 'F', 'G' )
793	DO jk = 1, jpk
794	DO ji = 1, nlci-1
795	iju=iloc-ji+1
796	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-2,jk)
797	ptab(ji,nlcj ,jk) = psgn * ptab(iju,nlcj-3,jk)
798	END DO
799	END DO
800
801	END SELECT
802
803	CASE ( 5 , 6 ) ! F pivot
804	iloc=jpiglo-2*(nimpp-1)
805
806	SELECT CASE ( cd_type )
807
808	CASE ( 'T' , 'S', 'W' )
809	DO jk = 1, jpk
810	DO ji = 1, nlci
811	ijt=iloc-ji+1
812	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
813	END DO
814	END DO
815
816	CASE ( 'U' )
817	DO jk = 1, jpk
818	DO ji = 1, nlci-1
819	iju=iloc-ji
820	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
821	END DO
822	END DO
823
824	CASE ( 'V' )
825	DO jk = 1, jpk
826	DO ji = 1, nlci
827	ijt=iloc-ji+1
828	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)
829	END DO
830	DO ji = nlci/2+1, nlci
831	ijt=iloc-ji+1
832	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
833	END DO
834	END DO
835
836	CASE ( 'F', 'G' )
837	DO jk = 1, jpk
838	DO ji = 1, nlci-1
839	iju=iloc-ji
840	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
841	END DO
842	DO ji = nlci/2+1, nlci-1
843	iju=iloc-ji
844	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
845	END DO
846	END DO
847	END SELECT ! cd_type
848
849	END SELECT ! npolj
850
851	CASE DEFAULT ! more than 1 proc along I
852	IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.
853
854	END SELECT ! jpni
855
856
857	! 5. East and west directions exchange
858	! ------------------------------------
859
860	SELECT CASE ( npolj )
861
862	CASE ( 3, 4, 5, 6 )
863
864	! 5.1 Read Dirichlet lateral conditions
865
866	SELECT CASE ( nbondi )
867
868	CASE ( -1, 0, 1 )
869	iihom = nlci-nreci
870	DO jl = 1, jpreci
871	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
872	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
873	END DO
874
875	END SELECT
876
877	! 5.2 Migrations
878
879	#if defined key_mpp_shmem
880	!! SHMEM version
881
882	imigr = jpreci * jpj * jpk
883
884	SELECT CASE ( nbondi )
885	CASE ( -1 )
886	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
887	CASE ( 0 )
888	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
889	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
890	CASE ( 1 )
891	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
892	END SELECT
893
894	CALL barrier()
895	CALL shmem_udcflush()
896
897	#elif defined key_mpp_mpi
898	!! MPI version
899
900	imigr=jprecijpjjpk
901
902	SELECT CASE ( nbondi )
903	CASE ( -1 )
904	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
905	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
906	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
907	CASE ( 0 )
908	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
909	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
910	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
911	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
912	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
913	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
914	CASE ( 1 )
915	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
916	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
917	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
918	END SELECT
919	#endif
920
921	! 5.3 Write Dirichlet lateral conditions
922
923	iihom = nlci-jpreci
924
925	SELECT CASE ( nbondi)
926	CASE ( -1 )
927	DO jl = 1, jpreci
928	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
929	END DO
930	CASE ( 0 )
931	DO jl = 1, jpreci
932	ptab(jl ,:,:) = t3we(:,jl,:,2)
933	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
934	END DO
935	CASE ( 1 )
936	DO jl = 1, jpreci
937	ptab(jl ,:,:) = t3we(:,jl,:,2)
938	END DO
939	END SELECT
940
941	END SELECT ! npolj
942
943	END SUBROUTINE mpp_lnk_3d
944
945
946	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn )
947	!!----------------------------------------------------------------------
948	!! * routine mpp_lnk_2d *
949	!!
950	!! ** Purpose : Message passing manadgement for 2d array
951	!!
952	!! ** Method : Use mppsend and mpprecv function for passing mask
953	!! between processors following neighboring subdomains.
954	!! domain parameters
955	!! nlci : first dimension of the local subdomain
956	!! nlcj : second dimension of the local subdomain
957	!! nbondi : mark for "east-west local boundary"
958	!! nbondj : mark for "north-south local boundary"
959	!! noea : number for local neighboring processors
960	!! nowe : number for local neighboring processors
961	!! noso : number for local neighboring processors
962	!! nono : number for local neighboring processors
963	!!
964	!!----------------------------------------------------------------------
965	!! * Arguments
966	CHARACTER(len=1) , INTENT( in ) :: &
967	cd_type ! define the nature of pt2d array grid-points
968	! ! = T , U , V , F , W
969	! ! = S : T-point, north fold treatment
970	! ! = G : F-point, north fold treatment
971	! ! = I : sea-ice velocity at F-point with index shift
972	REAL(wp), INTENT( in ) :: &
973	psgn ! control of the sign change
974	! ! = -1. , the sign is changed if north fold boundary
975	! ! = 1. , the sign is kept if north fold boundary
976	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
977	pt2d ! 2D array on which the boundary condition is applied
978
979	!! * Local variables
980	INTEGER :: ji, jj, jl ! dummy loop indices
981	INTEGER :: &
982	imigr, iihom, ijhom, & ! temporary integers
983	iloc, ijt, iju ! " "
984	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
985	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
986	!!----------------------------------------------------------------------
987
988	! 1. standard boundary treatment
989	! ------------------------------
990
991	! ! East-West boundaries
992	! ! ====================
993	IF( nbondi == 2 .AND. & ! Cyclic east-west
994	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
995	pt2d( 1 ,:) = pt2d(jpim1,:)
996	pt2d(jpi,:) = pt2d( 2 ,:)
997
998	ELSE ! ... closed
999	SELECT CASE ( cd_type )
1000	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1001	pt2d( 1 :jpreci,:) = 0.e0
1002	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
1003	CASE ( 'F' )
1004	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
1005	END SELECT
1006	ENDIF
1007
1008	! ! North-South boundaries
1009	! ! ======================
1010	SELECT CASE ( cd_type )
1011	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1012	pt2d(:, 1 :jprecj) = 0.e0
1013	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
1014	CASE ( 'F' )
1015	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
1016	END SELECT
1017
1018
1019	! 2. East and west directions
1020	! ---------------------------
1021
1022	! 2.1 Read Dirichlet lateral conditions
1023
1024	SELECT CASE ( nbondi )
1025	CASE ( -1, 0, 1 ) ! all except 2
1026	iihom = nlci-nreci
1027	DO jl = 1, jpreci
1028	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1029	t2we(:,jl,1) = pt2d(iihom +jl,:)
1030	END DO
1031	END SELECT
1032
1033	! 2.2 Migrations
1034
1035	#if defined key_mpp_shmem
1036	!! * SHMEM version
1037
1038	imigr = jpreci * jpj
1039
1040	SELECT CASE ( nbondi )
1041	CASE ( -1 )
1042	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1043	CASE ( 0 )
1044	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1045	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1046	CASE ( 1 )
1047	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1048	END SELECT
1049
1050	CALL barrier()
1051	CALL shmem_udcflush()
1052
1053	#elif defined key_mpp_mpi
1054	!! * MPI version
1055
1056	imigr = jpreci * jpj
1057
1058	SELECT CASE ( nbondi )
1059	CASE ( -1 )
1060	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1061	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1062	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1063	CASE ( 0 )
1064	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1065	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1066	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1067	CALL mpprecv( 2, t2we(1,1,2), imigr )
1068	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1069	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1070	CASE ( 1 )
1071	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1072	CALL mpprecv( 2, t2we(1,1,2), imigr )
1073	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1074	END SELECT
1075
1076	#endif
1077
1078	! 2.3 Write Dirichlet lateral conditions
1079
1080	iihom = nlci - jpreci
1081	SELECT CASE ( nbondi )
1082	CASE ( -1 )
1083	DO jl = 1, jpreci
1084	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1085	END DO
1086	CASE ( 0 )
1087	DO jl = 1, jpreci
1088	pt2d(jl ,:) = t2we(:,jl,2)
1089	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1090	END DO
1091	CASE ( 1 )
1092	DO jl = 1, jpreci
1093	pt2d(jl ,:) = t2we(:,jl,2)
1094	END DO
1095	END SELECT
1096
1097
1098	! 3. North and south directions
1099	! -----------------------------
1100
1101	! 3.1 Read Dirichlet lateral conditions
1102
1103	IF( nbondj /= 2 ) THEN
1104	ijhom = nlcj-nrecj
1105	DO jl = 1, jprecj
1106	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1107	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1108	END DO
1109	ENDIF
1110
1111	! 3.2 Migrations
1112
1113	#if defined key_mpp_shmem
1114	!! * SHMEM version
1115
1116	imigr = jprecj * jpi
1117
1118	SELECT CASE ( nbondj )
1119	CASE ( -1 )
1120	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1121	CASE ( 0 )
1122	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1123	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1124	CASE ( 1 )
1125	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1126	END SELECT
1127	CALL barrier()
1128	CALL shmem_udcflush()
1129
1130	#elif defined key_mpp_mpi
1131	!! * MPI version
1132
1133	imigr = jprecj * jpi
1134
1135	SELECT CASE ( nbondj )
1136	CASE ( -1 )
1137	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1138	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1139	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1140	CASE ( 0 )
1141	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1142	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1143	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1144	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1145	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1146	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1147	CASE ( 1 )
1148	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1149	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1150	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1151	END SELECT
1152
1153	#endif
1154
1155	! 3.3 Write Dirichlet lateral conditions
1156
1157	ijhom = nlcj - jprecj
1158
1159	SELECT CASE ( nbondj )
1160	CASE ( -1 )
1161	DO jl = 1, jprecj
1162	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1163	END DO
1164	CASE ( 0 )
1165	DO jl = 1, jprecj
1166	pt2d(:,jl ) = t2sn(:,jl,2)
1167	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1168	END DO
1169	CASE ( 1 )
1170	DO jl = 1, jprecj
1171	pt2d(:,jl ) = t2sn(:,jl,2)
1172	END DO
1173	END SELECT
1174
1175
1176	! 4. north fold treatment
1177	! -----------------------
1178
1179	! 4.1 treatment without exchange (jpni odd)
1180
1181	SELECT CASE ( jpni )
1182
1183	CASE ( 1 ) ! only one proc along I, no mpp exchange
1184
1185	SELECT CASE ( npolj )
1186
1187	CASE ( 3 , 4 ) ! T pivot
1188	iloc = jpiglo - 2 * ( nimpp - 1 )
1189
1190	SELECT CASE ( cd_type )
1191
1192	CASE ( 'T' , 'S', 'W' )
1193	DO ji = 2, nlci
1194	ijt=iloc-ji+2
1195	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1196	END DO
1197	DO ji = nlci/2+1, nlci
1198	ijt=iloc-ji+2
1199	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1200	END DO
1201
1202	CASE ( 'U' )
1203	DO ji = 1, nlci-1
1204	iju=iloc-ji+1
1205	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1206	END DO
1207	DO ji = nlci/2, nlci-1
1208	iju=iloc-ji+1
1209	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1210	END DO
1211
1212	CASE ( 'V' )
1213	DO ji = 2, nlci
1214	ijt=iloc-ji+2
1215	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1216	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3)
1217	END DO
1218
1219	CASE ( 'F', 'G' )
1220	DO ji = 1, nlci-1
1221	iju=iloc-ji+1
1222	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-2)
1223	pt2d(ji,nlcj ) = psgn * pt2d(iju,nlcj-3)
1224	END DO
1225
1226	CASE ( 'I' ) ! ice U-V point
1227	pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1228	DO ji = 3, nlci
1229	iju = iloc - ji + 3
1230	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1231	END DO
1232
1233	END SELECT
1234
1235	CASE ( 5 , 6 ) ! F pivot
1236	iloc=jpiglo-2*(nimpp-1)
1237
1238	SELECT CASE (cd_type )
1239
1240	CASE ( 'T', 'S', 'W' )
1241	DO ji = 1, nlci
1242	ijt=iloc-ji+1
1243	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1244	END DO
1245
1246	CASE ( 'U' )
1247	DO ji = 1, nlci-1
1248	iju=iloc-ji
1249	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1250	END DO
1251
1252	CASE ( 'V' )
1253	DO ji = 1, nlci
1254	ijt=iloc-ji+1
1255	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2)
1256	END DO
1257	DO ji = nlci/2+1, nlci
1258	ijt=iloc-ji+1
1259	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1260	END DO
1261
1262	CASE ( 'F', 'G' )
1263	DO ji = 1, nlci-1
1264	iju=iloc-ji
1265	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1266	END DO
1267	DO ji = nlci/2+1, nlci-1
1268	iju=iloc-ji
1269	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1270	END DO
1271
1272	CASE ( 'I' ) ! ice U-V point
1273	pt2d( 2 ,nlcj) = 0.e0
1274	DO ji = 2 , nlci-1
1275	ijt = iloc - ji + 2
1276	pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) )
1277	END DO
1278
1279	END SELECT ! cd_type
1280
1281	END SELECT ! npolj
1282
1283	CASE DEFAULT ! more than 1 proc along I
1284	IF( npolj /= 0 ) CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! only for northern procs.
1285
1286	END SELECT ! jpni
1287
1288
1289	! 5. East and west directions
1290	! ---------------------------
1291
1292	SELECT CASE ( npolj )
1293
1294	CASE ( 3, 4, 5, 6 )
1295
1296	! 5.1 Read Dirichlet lateral conditions
1297
1298	SELECT CASE ( nbondi )
1299	CASE ( -1, 0, 1 )
1300	iihom = nlci-nreci
1301	DO jl = 1, jpreci
1302	DO jj = 1, jpj
1303	t2ew(jj,jl,1) = pt2d(jpreci+jl,jj)
1304	t2we(jj,jl,1) = pt2d(iihom +jl,jj)
1305	END DO
1306	END DO
1307	END SELECT
1308
1309	! 5.2 Migrations
1310
1311	#if defined key_mpp_shmem
1312	!! * SHMEM version
1313
1314	imigr=jpreci*jpj
1315
1316	SELECT CASE ( nbondi )
1317	CASE ( -1 )
1318	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1319	CASE ( 0 )
1320	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1321	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1322	CASE ( 1 )
1323	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1324	END SELECT
1325
1326	CALL barrier()
1327	CALL shmem_udcflush()
1328
1329	#elif defined key_mpp_mpi
1330	!! * MPI version
1331
1332	imigr=jpreci*jpj
1333
1334	SELECT CASE ( nbondi )
1335	CASE ( -1 )
1336	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1337	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1338	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1339	CASE ( 0 )
1340	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1341	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1342	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1343	CALL mpprecv( 2, t2we(1,1,2), imigr )
1344	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1345	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1346	CASE ( 1 )
1347	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1348	CALL mpprecv( 2, t2we(1,1,2), imigr )
1349	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1350	END SELECT
1351	#endif
1352
1353	! 5.3 Write Dirichlet lateral conditions
1354
1355	iihom = nlci - jpreci
1356
1357	SELECT CASE ( nbondi )
1358	CASE ( -1 )
1359	DO jl = 1, jpreci
1360	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1361	END DO
1362	CASE ( 0 )
1363	DO jl = 1, jpreci
1364	pt2d(jl ,:) = t2we(:,jl,2)
1365	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1366	END DO
1367	CASE ( 1 )
1368	DO jl = 1, jpreci
1369	pt2d(jl,:) = t2we(:,jl,2)
1370	END DO
1371	END SELECT
1372
1373	END SELECT ! npolj
1374
1375	END SUBROUTINE mpp_lnk_2d
1376
1377
1378	SUBROUTINE mpplnks( ptab )
1379	!!----------------------------------------------------------------------
1380	!! * routine mpplnks *
1381	!!
1382	!! ** Purpose : Message passing manadgement for add 2d array local boundary
1383	!!
1384	!! ** Method : Use mppsend and mpprecv function for passing mask between
1385	!! processors following neighboring subdomains.
1386	!! domain parameters
1387	!! nlci : first dimension of the local subdomain
1388	!! nlcj : second dimension of the local subdomain
1389	!! nbondi : mark for "east-west local boundary"
1390	!! nbondj : mark for "north-south local boundary"
1391	!! noea : number for local neighboring processors
1392	!! nowe : number for local neighboring processors
1393	!! noso : number for local neighboring processors
1394	!! nono : number for local neighboring processors
1395	!!
1396	!!----------------------------------------------------------------------
1397	!! * Arguments
1398	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: &
1399	ptab ! 2D array
1400
1401	!! * Local variables
1402	INTEGER :: ji, jl ! dummy loop indices
1403	INTEGER :: &
1404	imigr, iihom, ijhom ! temporary integers
1405	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1406	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1407	!!----------------------------------------------------------------------
1408
1409
1410	! 1. north fold treatment
1411	! -----------------------
1412
1413	! 1.1 treatment without exchange (jpni odd)
1414
1415	SELECT CASE ( npolj )
1416	CASE ( 4 )
1417	DO ji = 1, nlci
1418	ptab(ji,nlcj-2) = ptab(ji,nlcj-2) + t2p1(ji,1,1)
1419	END DO
1420	CASE ( 6 )
1421	DO ji = 1, nlci
1422	ptab(ji,nlcj-1) = ptab(ji,nlcj-1) + t2p1(ji,1,1)
1423	END DO
1424
1425	! 1.2 treatment with exchange (jpni greater than 1)
1426	!
1427	CASE ( 3 )
1428	#if defined key_mpp_shmem
1429
1430	!! * SHMEN version
1431
1432	imigr=jprecj*jpi
1433
1434	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
1435	CALL barrier()
1436	CALL shmem_udcflush()
1437
1438	# elif defined key_mpp_mpi
1439	!! * MPI version
1440
1441	imigr=jprecj*jpi
1442
1443	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
1444	CALL mpprecv(3,t2p1(1,1,2),imigr)
1445	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1446
1447	#endif
1448
1449	! Write north fold conditions
1450
1451	DO ji = 1, nlci
1452	ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2)
1453	END DO
1454
1455	CASE ( 5 )
1456
1457	#if defined key_mpp_shmem
1458
1459	!! * SHMEN version
1460
1461	imigr=jprecj*jpi
1462
1463	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
1464	CALL barrier()
1465	CALL shmem_udcflush()
1466
1467	# elif defined key_mpp_mpi
1468	!! * Local variables (MPI version)
1469
1470	imigr=jprecj*jpi
1471
1472	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
1473	CALL mpprecv(3,t2p1(1,1,2),imigr)
1474	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1475
1476	#endif
1477
1478	! Write north fold conditions
1479
1480	DO ji = 1, nlci
1481	ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,2)
1482	END DO
1483
1484	END SELECT
1485
1486
1487	! 2. East and west directions
1488	! ---------------------------
1489
1490	! 2.1 Read Dirichlet lateral conditions
1491
1492	iihom = nlci-jpreci
1493
1494	SELECT CASE ( nbondi )
1495
1496	CASE ( -1, 0, 1 ) ! all except 2
1497	DO jl = 1, jpreci
1498	t2ew(:,jl,1) = ptab( jl ,:)
1499	t2we(:,jl,1) = ptab(iihom+jl,:)
1500	END DO
1501	END SELECT
1502
1503	! 2.2 Migrations
1504
1505	#if defined key_mpp_shmem
1506
1507	!! * SHMEN version
1508
1509	imigr=jpreci*jpj
1510
1511	SELECT CASE ( nbondi )
1512
1513	CASE ( -1 )
1514	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
1515
1516	CASE ( 0 )
1517	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
1518	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
1519
1520	CASE ( 1 )
1521	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
1522
1523	END SELECT
1524	CALL barrier()
1525	CALL shmem_udcflush()
1526
1527	# elif defined key_mpp_mpi
1528	!! * Local variables (MPI version)
1529
1530	imigr=jpreci*jpj
1531
1532	SELECT CASE ( nbondi )
1533
1534	CASE ( -1 )
1535	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
1536	CALL mpprecv(1,t2ew(1,1,2),imigr)
1537	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1538	CASE ( 0 )
1539	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
1540	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
1541	CALL mpprecv(1,t2ew(1,1,2),imigr)
1542	CALL mpprecv(2,t2we(1,1,2),imigr)
1543	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1544	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1545
1546	CASE ( 1 )
1547	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
1548	CALL mpprecv(2,t2we(1,1,2),imigr)
1549	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1550
1551	END SELECT
1552
1553	#endif
1554
1555	! 2.3 Write Dirichlet lateral conditions
1556
1557	iihom = nlci-nreci
1558
1559	SELECT CASE ( nbondi )
1560
1561	CASE ( -1 )
1562	DO jl = 1, jpreci
1563	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
1564	END DO
1565
1566	CASE ( 0 )
1567	DO jl = 1, jpreci
1568	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
1569	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
1570	END DO
1571
1572	CASE ( 1 )
1573	DO jl = 1, jpreci
1574	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
1575	END DO
1576	END SELECT
1577
1578
1579	! 3. North and south directions
1580	! -----------------------------
1581
1582	! 3.1 Read Dirichlet lateral conditions
1583
1584	ijhom = nlcj-jprecj
1585
1586	SELECT CASE ( nbondj )
1587
1588	CASE ( -1, 0, 1 )
1589	DO jl = 1, jprecj
1590	t2sn(:,jl,1) = ptab(:,ijhom+jl)
1591	t2ns(:,jl,1) = ptab(:, jl )
1592	END DO
1593
1594	END SELECT
1595
1596	! 3.2 Migrations
1597
1598	#if defined key_mpp_shmem
1599
1600	!! * SHMEN version
1601
1602	imigr=jprecj*jpi
1603
1604	SELECT CASE ( nbondj )
1605
1606	CASE ( -1 )
1607	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
1608
1609	CASE ( 0 )
1610	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
1611	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
1612
1613	CASE ( 1 )
1614	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
1615
1616	END SELECT
1617	CALL barrier()
1618	CALL shmem_udcflush()
1619
1620	# elif defined key_mpp_mpi
1621	!! * Local variables (MPI version)
1622
1623	imigr=jprecj*jpi
1624
1625	SELECT CASE ( nbondj )
1626
1627	CASE ( -1 )
1628	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
1629	CALL mpprecv(3,t2ns(1,1,2),imigr)
1630	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1631
1632	CASE ( 0 )
1633	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
1634	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
1635	CALL mpprecv(3,t2ns(1,1,2),imigr)
1636	CALL mpprecv(4,t2sn(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
1640	CASE ( 1 )
1641	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
1642	CALL mpprecv(4,t2sn(1,1,2),imigr)
1643	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1644	END SELECT
1645
1646	#endif
1647
1648	! 3.3 Write Dirichlet lateral conditions
1649
1650	ijhom = nlcj-nrecj
1651
1652	SELECT CASE ( nbondj )
1653
1654	CASE ( -1 )
1655	DO jl = 1, jprecj
1656	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
1657	END DO
1658
1659	CASE ( 0 )
1660	DO jl = 1, jprecj
1661	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
1662	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
1663	END DO
1664
1665	CASE ( 1 )
1666	DO jl = 1, jprecj
1667	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
1668	END DO
1669
1670	END SELECT
1671
1672	END SUBROUTINE mpplnks
1673
1674
1675	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req)
1676	!!----------------------------------------------------------------------
1677	!! * routine mppsend *
1678	!!
1679	!! ** Purpose : Send messag passing array
1680	!!
1681	!!----------------------------------------------------------------------
1682	!! * Arguments
1683	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1684	INTEGER , INTENT( in ) :: kbytes, & ! size of the array pmess
1685	& kdest , & ! receive process number
1686	& ktyp, & ! Tag of the message
1687	& md_req ! Argument for isend
1688	!!----------------------------------------------------------------------
1689	#if defined key_mpp_shmem
1690	!! * SHMEM version : routine not used
1691
1692	#elif defined key_mpp_mpi
1693	!! * MPI version
1694	INTEGER :: iflag
1695
1696	SELECT CASE ( c_mpi_send )
1697	CASE ( 'S' ) ! Standard mpi send (blocking)
1698	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1699	& mpi_comm_world, iflag )
1700	CASE ( 'B' ) ! Buffer mpi send (blocking)
1701	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1702	& mpi_comm_world, iflag )
1703	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
1704	! Be carefull, one more argument here : the mpi request identifier..
1705	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1706	& mpi_comm_world, md_req, iflag )
1707	END SELECT
1708	#endif
1709
1710	END SUBROUTINE mppsend
1711
1712
1713	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1714	!!----------------------------------------------------------------------
1715	!! * routine mpprecv *
1716	!!
1717	!! ** Purpose : Receive messag passing array
1718	!!
1719	!!----------------------------------------------------------------------
1720	!! * Arguments
1721	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1722	INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess
1723	& ktyp ! Tag of the recevied message
1724	!!----------------------------------------------------------------------
1725	#if defined key_mpp_shmem
1726	!! * SHMEM version : routine not used
1727
1728	# elif defined key_mpp_mpi
1729	!! * MPI version
1730	INTEGER :: istatus(mpi_status_size)
1731	INTEGER :: iflag
1732
1733	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, &
1734	& mpi_comm_world, istatus, iflag )
1735	#endif
1736
1737	END SUBROUTINE mpprecv
1738
1739
1740	SUBROUTINE mppgather( ptab, kp, pio )
1741	!!----------------------------------------------------------------------
1742	!! * routine mppgather *
1743	!!
1744	!! ** Purpose : Transfert between a local subdomain array and a work
1745	!! array which is distributed following the vertical level.
1746	!!
1747	!! ** Method :
1748	!!
1749	!!----------------------------------------------------------------------
1750	!! * Arguments
1751	REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ptab ! subdomain input array
1752	INTEGER , INTENT( in ) :: kp ! record length
1753	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: pio ! subdomain input array
1754	!!---------------------------------------------------------------------
1755	#if defined key_mpp_shmem
1756	!! * SHMEM version
1757
1758	CALL barrier()
1759	CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp )
1760	CALL barrier()
1761
1762	#elif defined key_mpp_mpi
1763	!! * Local variables (MPI version)
1764	INTEGER :: itaille,ierror
1765
1766	itaille=jpi*jpj
1767	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille, &
1768	& mpi_double_precision, kp , mpi_comm_world, ierror )
1769	#endif
1770
1771	END SUBROUTINE mppgather
1772
1773
1774	SUBROUTINE mppscatter( pio, kp, ptab )
1775	!!----------------------------------------------------------------------
1776	!! * routine mppscatter *
1777	!!
1778	!! ** Purpose : Transfert between awork array which is distributed
1779	!! following the vertical level and the local subdomain array.
1780	!!
1781	!! ** Method :
1782	!!
1783	!!----------------------------------------------------------------------
1784	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
1785	INTEGER :: kp ! Tag (not used with MPI
1786	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
1787	!!---------------------------------------------------------------------
1788	#if defined key_mpp_shmem
1789	!! * SHMEM version
1790
1791	CALL barrier()
1792	CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp )
1793	CALL barrier()
1794
1795	# elif defined key_mpp_mpi
1796	!! * Local variables (MPI version)
1797	INTEGER :: itaille, ierror
1798
1799	itaille=jpi*jpj
1800
1801	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille, &
1802	& mpi_double_precision, kp, mpi_comm_world, ierror )
1803	#endif
1804
1805	END SUBROUTINE mppscatter
1806
1807
1808	SUBROUTINE mppisl_a_int( ktab, kdim )
1809	!!----------------------------------------------------------------------
1810	!! * routine mppisl_a_int *
1811	!!
1812	!! ** Purpose : Massively parallel processors
1813	!! Find the non zero value
1814	!!
1815	!!----------------------------------------------------------------------
1816	!! * Arguments
1817	INTEGER, INTENT( in ) :: kdim ! ???
1818	INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ???
1819
1820	#if defined key_mpp_shmem
1821	!! * Local variables (SHMEM version)
1822	INTEGER :: ji
1823	INTEGER, SAVE :: ibool=0
1824
1825	IF( kdim > jpmppsum ) THEN
1826	WRITE(numout,*) 'mppisl_a_int routine : kdim is too big'
1827	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
1828	STOP 'mppisl_a_int'
1829	ENDIF
1830
1831	DO ji = 1, kdim
1832	niitab_shmem(ji) = ktab(ji)
1833	END DO
1834	CALL barrier()
1835	IF(ibool == 0 ) THEN
1836	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
1837	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
1838	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
1839	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
1840	ELSE
1841	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
1842	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
1843	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
1844	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
1845	ENDIF
1846	CALL barrier()
1847	ibool=ibool+1
1848	ibool=MOD( ibool,2)
1849	DO ji = 1, kdim
1850	IF( ni11tab_shmem(ji) /= 0. ) THEN
1851	ktab(ji) = ni11tab_shmem(ji)
1852	ELSE
1853	ktab(ji) = ni12tab_shmem(ji)
1854	ENDIF
1855	END DO
1856
1857	# elif defined key_mpp_mpi
1858	!! * Local variables (MPI version)
1859	LOGICAL :: lcommute
1860	INTEGER, DIMENSION(kdim) :: iwork
1861	INTEGER :: mpi_isl,ierror
1862
1863	lcommute = .TRUE.
1864	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
1865	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer &
1866	, mpi_isl, mpi_comm_world, ierror )
1867	ktab(:) = iwork(:)
1868	#endif
1869
1870	END SUBROUTINE mppisl_a_int
1871
1872
1873	SUBROUTINE mppisl_int( ktab )
1874	!!----------------------------------------------------------------------
1875	!! * routine mppisl_int *
1876	!!
1877	!! ** Purpose : Massively parallel processors
1878	!! Find the non zero value
1879	!!
1880	!!----------------------------------------------------------------------
1881	!! * Arguments
1882	INTEGER , INTENT( inout ) :: ktab !
1883
1884	#if defined key_mpp_shmem
1885	!! * Local variables (SHMEM version)
1886	INTEGER, SAVE :: ibool=0
1887
1888	niitab_shmem(1) = ktab
1889	CALL barrier()
1890	IF(ibool == 0 ) THEN
1891	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
1892	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
1893	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
1894	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
1895	ELSE
1896	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
1897	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
1898	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
1899	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
1900	ENDIF
1901	CALL barrier()
1902	ibool=ibool+1
1903	ibool=MOD( ibool,2)
1904	IF( ni11tab_shmem(1) /= 0. ) THEN
1905	ktab = ni11tab_shmem(1)
1906	ELSE
1907	ktab = ni12tab_shmem(1)
1908	ENDIF
1909
1910	# elif defined key_mpp_mpi
1911
1912	!! * Local variables (MPI version)
1913	LOGICAL :: lcommute
1914	INTEGER :: mpi_isl,ierror
1915	INTEGER :: iwork
1916
1917	lcommute = .TRUE.
1918	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
1919	CALL mpi_allreduce(ktab, iwork, 1,mpi_integer &
1920	,mpi_isl,mpi_comm_world,ierror)
1921	ktab = iwork
1922	#endif
1923
1924	END SUBROUTINE mppisl_int
1925
1926
1927	SUBROUTINE mppmin_a_int( ktab, kdim )
1928	!!----------------------------------------------------------------------
1929	!! * routine mppmin_a_int *
1930	!!
1931	!! ** Purpose : Find minimum value in an integer layout array
1932	!!
1933	!!----------------------------------------------------------------------
1934	!! * Arguments
1935	INTEGER , INTENT( in ) :: kdim ! size of array
1936	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1937
1938	#if defined key_mpp_shmem
1939	!! * Local declarations (SHMEM version)
1940	INTEGER :: ji
1941	INTEGER, SAVE :: ibool=0
1942
1943	IF( kdim > jpmppsum ) THEN
1944	WRITE(numout,*) 'mppmin_a_int routine : kdim is too big'
1945	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
1946	STOP 'min_a_int'
1947	ENDIF
1948
1949	DO ji = 1, kdim
1950	niltab_shmem(ji) = ktab(ji)
1951	END DO
1952	CALL barrier()
1953	IF(ibool == 0 ) THEN
1954	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
1955	,N$PES,nil1wrk_shmem,nil1sync_shmem )
1956	ELSE
1957	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
1958	,N$PES,nil2wrk_shmem,nil2sync_shmem )
1959	ENDIF
1960	CALL barrier()
1961	ibool=ibool+1
1962	ibool=MOD( ibool,2)
1963	DO ji = 1, kdim
1964	ktab(ji) = niltab_shmem(ji)
1965	END DO
1966
1967	# elif defined key_mpp_mpi
1968
1969	!! * Local variables (MPI version)
1970	INTEGER :: ierror
1971	INTEGER, DIMENSION(kdim) :: iwork
1972
1973	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
1974	& mpi_min, mpi_comm_world, ierror )
1975
1976	ktab(:) = iwork(:)
1977	#endif
1978
1979	END SUBROUTINE mppmin_a_int
1980
1981
1982	SUBROUTINE mppmin_int( ktab )
1983	!!----------------------------------------------------------------------
1984	!! * routine mppmin_int *
1985	!!
1986	!! ** Purpose :
1987	!! Massively parallel processors
1988	!! Find minimum value in an integer layout array
1989	!!
1990	!!----------------------------------------------------------------------
1991	!! * Arguments
1992	INTEGER, INTENT(inout) :: ktab ! ???
1993
1994	!! * Local declarations
1995
1996	#if defined key_mpp_shmem
1997
1998	!! * Local variables (SHMEM version)
1999	INTEGER :: ji
2000	INTEGER, SAVE :: ibool=0
2001
2002	niltab_shmem(1) = ktab
2003	CALL barrier()
2004	IF(ibool == 0 ) THEN
2005	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
2006	,N$PES,nil1wrk_shmem,nil1sync_shmem )
2007	ELSE
2008	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
2009	,N$PES,nil2wrk_shmem,nil2sync_shmem )
2010	ENDIF
2011	CALL barrier()
2012	ibool=ibool+1
2013	ibool=MOD( ibool,2)
2014	ktab = niltab_shmem(1)
2015
2016	# elif defined key_mpp_mpi
2017
2018	!! * Local variables (MPI version)
2019	INTEGER :: ierror, iwork
2020
2021	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
2022	& ,mpi_min,mpi_comm_world,ierror)
2023
2024	ktab = iwork
2025	#endif
2026
2027	END SUBROUTINE mppmin_int
2028
2029
2030	SUBROUTINE mppsum_a_int( ktab, kdim )
2031	!!----------------------------------------------------------------------
2032	!! * routine mppsum_a_int *
2033	!!
2034	!! ** Purpose : Massively parallel processors
2035	!! Global integer sum
2036	!!
2037	!!----------------------------------------------------------------------
2038	!! * Arguments
2039	INTEGER, INTENT( in ) :: kdim ! ???
2040	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
2041
2042	#if defined key_mpp_shmem
2043
2044	!! * Local variables (SHMEM version)
2045	INTEGER :: ji
2046	INTEGER, SAVE :: ibool=0
2047
2048	IF( kdim > jpmppsum ) THEN
2049	WRITE(numout,*) 'mppsum_a_int routine : kdim is too big'
2050	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2051	STOP 'mppsum_a_int'
2052	ENDIF
2053
2054	DO ji = 1, kdim
2055	nistab_shmem(ji) = ktab(ji)
2056	END DO
2057	CALL barrier()
2058	IF(ibool == 0 ) THEN
2059	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
2060	N$PES,nis1wrk_shmem,nis1sync_shmem)
2061	ELSE
2062	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
2063	N$PES,nis2wrk_shmem,nis2sync_shmem)
2064	ENDIF
2065	CALL barrier()
2066	ibool = ibool + 1
2067	ibool = MOD( ibool, 2 )
2068	DO ji = 1, kdim
2069	ktab(ji) = nistab_shmem(ji)
2070	END DO
2071
2072	# elif defined key_mpp_mpi
2073
2074	!! * Local variables (MPI version)
2075	INTEGER :: ierror
2076	INTEGER, DIMENSION (kdim) :: iwork
2077
2078	CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer &
2079	,mpi_sum,mpi_comm_world,ierror)
2080
2081	ktab(:) = iwork(:)
2082	#endif
2083
2084	END SUBROUTINE mppsum_a_int
2085
2086
2087	SUBROUTINE mppsum_int( ktab )
2088	!!----------------------------------------------------------------------
2089	!! * routine mppsum_int *
2090	!!
2091	!! ** Purpose : Global integer sum
2092	!!
2093	!!----------------------------------------------------------------------
2094	!! * Arguments
2095	INTEGER, INTENT(inout) :: ktab
2096
2097	#if defined key_mpp_shmem
2098
2099	!! * Local variables (SHMEM version)
2100	INTEGER, SAVE :: ibool=0
2101
2102	nistab_shmem(1) = ktab
2103	CALL barrier()
2104	IF(ibool == 0 ) THEN
2105	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
2106	N$PES,nis1wrk_shmem,nis1sync_shmem)
2107	ELSE
2108	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
2109	N$PES,nis2wrk_shmem,nis2sync_shmem)
2110	ENDIF
2111	CALL barrier()
2112	ibool=ibool+1
2113	ibool=MOD( ibool,2)
2114	ktab = nistab_shmem(1)
2115
2116	# elif defined key_mpp_mpi
2117
2118	!! * Local variables (MPI version)
2119	INTEGER :: ierror, iwork
2120
2121	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
2122	,mpi_sum,mpi_comm_world,ierror)
2123
2124	ktab = iwork
2125
2126	#endif
2127
2128	END SUBROUTINE mppsum_int
2129
2130
2131	SUBROUTINE mppisl_a_real( ptab, kdim )
2132	!!----------------------------------------------------------------------
2133	!! * routine mppisl_a_real *
2134	!!
2135	!! ** Purpose : Massively parallel processors
2136	!! Find the non zero island barotropic stream function value
2137	!!
2138	!! Modifications:
2139	!! ! 93-09 (M. Imbard)
2140	!! ! 96-05 (j. Escobar)
2141	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
2142	!!----------------------------------------------------------------------
2143	INTEGER , INTENT( in ) :: kdim ! ???
2144	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab ! ???
2145
2146	#if defined key_mpp_shmem
2147
2148	!! * Local variables (SHMEM version)
2149	INTEGER :: ji
2150	INTEGER, SAVE :: ibool=0
2151
2152	IF( kdim > jpmppsum ) THEN
2153	WRITE(numout,*) 'mppisl_a_real routine : kdim is too big'
2154	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2155	STOP 'mppisl_a_real'
2156	ENDIF
2157
2158	DO ji = 1, kdim
2159	wiltab_shmem(ji) = ptab(ji)
2160	END DO
2161	CALL barrier()
2162	IF(ibool == 0 ) THEN
2163	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
2164	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
2165	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
2166	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
2167	ELSE
2168	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
2169	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
2170	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
2171	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
2172	ENDIF
2173	CALL barrier()
2174	ibool=ibool+1
2175	ibool=MOD( ibool,2)
2176	DO ji = 1, kdim
2177	IF(wi1tab_shmem(ji) /= 0. ) THEN
2178	ptab(ji) = wi1tab_shmem(ji)
2179	ELSE
2180	ptab(ji) = wi2tab_shmem(ji)
2181	ENDIF
2182	END DO
2183
2184	# elif defined key_mpp_mpi
2185
2186	!! * Local variables (MPI version)
2187	LOGICAL :: lcommute = .TRUE.
2188	INTEGER :: mpi_isl, ierror
2189	REAL(wp), DIMENSION(kdim) :: zwork
2190
2191	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
2192	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2193	,mpi_isl,mpi_comm_world,ierror)
2194	ptab(:) = zwork(:)
2195
2196	#endif
2197
2198	END SUBROUTINE mppisl_a_real
2199
2200
2201	SUBROUTINE mppisl_real( ptab )
2202	!!----------------------------------------------------------------------
2203	!! * routine mppisl_real *
2204	!!
2205	!! ** Purpose : Massively parallel processors
2206	!! Find the non zero island barotropic stream function value
2207	!!
2208	!! Modifications:
2209	!! ! 93-09 (M. Imbard)
2210	!! ! 96-05 (j. Escobar)
2211	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
2212	!!----------------------------------------------------------------------
2213	REAL(wp), INTENT(inout) :: ptab
2214
2215	#if defined key_mpp_shmem
2216
2217	!! * Local variables (SHMEM version)
2218	INTEGER, SAVE :: ibool=0
2219
2220	wiltab_shmem(1) = ptab
2221	CALL barrier()
2222	IF(ibool == 0 ) THEN
2223	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
2224	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
2225	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
2226	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
2227	ELSE
2228	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
2229	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
2230	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
2231	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
2232	ENDIF
2233	CALL barrier()
2234	ibool = ibool + 1
2235	ibool = MOD( ibool, 2 )
2236	IF( wi1tab_shmem(1) /= 0. ) THEN
2237	ptab = wi1tab_shmem(1)
2238	ELSE
2239	ptab = wi2tab_shmem(1)
2240	ENDIF
2241
2242	# elif defined key_mpp_mpi
2243
2244	!! * Local variables (MPI version)
2245	LOGICAL :: lcommute = .TRUE.
2246	INTEGER :: mpi_isl, ierror
2247	REAL(wp) :: zwork
2248
2249	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
2250	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, &
2251	& mpi_isl , mpi_comm_world, ierror )
2252	ptab = zwork
2253
2254	#endif
2255
2256	END SUBROUTINE mppisl_real
2257
2258
2259	FUNCTION lc_isl( py, px, kdim, kdtatyp )
2260	INTEGER :: kdim
2261	REAL(wp), DIMENSION(kdim) :: px, py
2262	INTEGER :: kdtatyp, ji
2263	INTEGER :: lc_isl
2264	DO ji = 1, kdim
2265	IF( py(ji) /= 0. ) px(ji) = py(ji)
2266	END DO
2267	lc_isl=0
2268
2269	END FUNCTION lc_isl
2270
2271
2272	SUBROUTINE mppmax_a_real( ptab, kdim )
2273	!!----------------------------------------------------------------------
2274	!! * routine mppmax_a_real *
2275	!!
2276	!! ** Purpose : Maximum
2277	!!
2278	!!----------------------------------------------------------------------
2279	!! * Arguments
2280	INTEGER , INTENT( in ) :: kdim
2281	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
2282
2283	#if defined key_mpp_shmem
2284
2285	!! * Local variables (SHMEM version)
2286	INTEGER :: ji
2287	INTEGER, SAVE :: ibool=0
2288
2289	IF( kdim > jpmppsum ) THEN
2290	WRITE(numout,*) 'mppmax_a_real routine : kdim is too big'
2291	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2292	STOP 'mppmax_a_real'
2293	ENDIF
2294
2295	DO ji = 1, kdim
2296	wintab_shmem(ji) = ptab(ji)
2297	END DO
2298	CALL barrier()
2299	IF(ibool == 0 ) THEN
2300	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2301	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2302	ELSE
2303	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2304	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2305	ENDIF
2306	CALL barrier()
2307	ibool=ibool+1
2308	ibool=MOD( ibool,2)
2309	DO ji = 1, kdim
2310	ptab(ji) = wintab_shmem(ji)
2311	END DO
2312
2313	# elif defined key_mpp_mpi
2314
2315	!! * Local variables (MPI version)
2316	INTEGER :: ierror
2317	REAL(wp), DIMENSION(kdim) :: zwork
2318
2319	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2320	,mpi_max,mpi_comm_world,ierror)
2321	ptab(:) = zwork(:)
2322
2323	#endif
2324
2325	END SUBROUTINE mppmax_a_real
2326
2327
2328	SUBROUTINE mppmax_real( ptab )
2329	!!----------------------------------------------------------------------
2330	!! * routine mppmax_real *
2331	!!
2332	!! ** Purpose : Maximum
2333	!!
2334	!!----------------------------------------------------------------------
2335	!! * Arguments
2336	REAL(wp), INTENT(inout) :: ptab ! ???
2337
2338	#if defined key_mpp_shmem
2339
2340	!! * Local variables (SHMEM version)
2341	INTEGER, SAVE :: ibool=0
2342
2343	wintab_shmem(1) = ptab
2344	CALL barrier()
2345	IF(ibool == 0 ) THEN
2346	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
2347	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2348	ELSE
2349	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
2350	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2351	ENDIF
2352	CALL barrier()
2353	ibool=ibool+1
2354	ibool=MOD( ibool,2)
2355	ptab = wintab_shmem(1)
2356
2357	# elif defined key_mpp_mpi
2358
2359	!! * Local variables (MPI version)
2360	INTEGER :: ierror
2361	REAL(wp) :: zwork
2362
2363	CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, &
2364	& mpi_max, mpi_comm_world, ierror )
2365	ptab = zwork
2366
2367	#endif
2368
2369	END SUBROUTINE mppmax_real
2370
2371
2372	SUBROUTINE mppmin_a_real( ptab, kdim )
2373	!!----------------------------------------------------------------------
2374	!! * routine mppmin_a_real *
2375	!!
2376	!! ** Purpose : Minimum
2377	!!
2378	!!-----------------------------------------------------------------------
2379	!! * Arguments
2380	INTEGER , INTENT( in ) :: kdim
2381	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
2382
2383	#if defined key_mpp_shmem
2384
2385	!! * Local variables (SHMEM version)
2386	INTEGER :: ji
2387	INTEGER, SAVE :: ibool=0
2388
2389	IF( kdim > jpmppsum ) THEN
2390	WRITE(numout,*) 'mpprmin routine : kdim is too big'
2391	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2392	STOP 'mpprmin'
2393	ENDIF
2394
2395	DO ji = 1, kdim
2396	wintab_shmem(ji) = ptab(ji)
2397	END DO
2398	CALL barrier()
2399	IF(ibool == 0 ) THEN
2400	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2401	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2402	ELSE
2403	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2404	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2405	ENDIF
2406	CALL barrier()
2407	ibool=ibool+1
2408	ibool=MOD( ibool,2)
2409	DO ji = 1, kdim
2410	ptab(ji) = wintab_shmem(ji)
2411	END DO
2412
2413	# elif defined key_mpp_mpi
2414
2415	!! * Local variables (MPI version)
2416	INTEGER :: ierror
2417	REAL(wp), DIMENSION(kdim) :: zwork
2418
2419	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2420	,mpi_min,mpi_comm_world,ierror)
2421	ptab(:) = zwork(:)
2422
2423	#endif
2424
2425	END SUBROUTINE mppmin_a_real
2426
2427
2428	SUBROUTINE mppmin_real( ptab )
2429	!!----------------------------------------------------------------------
2430	!! * routine mppmin_real *
2431	!!
2432	!! ** Purpose : minimum in Massively Parallel Processing
2433	!! REAL scalar case
2434	!!
2435	!!-----------------------------------------------------------------------
2436	!! * Arguments
2437	REAL(wp), INTENT( inout ) :: ptab !
2438
2439	#if defined key_mpp_shmem
2440
2441	!! * Local variables (SHMEM version)
2442	INTEGER, SAVE :: ibool=0
2443
2444	wintab_shmem(1) = ptab
2445	CALL barrier()
2446	IF(ibool == 0 ) THEN
2447	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
2448	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2449	ELSE
2450	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
2451	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2452	ENDIF
2453	CALL barrier()
2454	ibool=ibool+1
2455	ibool=MOD( ibool,2)
2456	ptab = wintab_shmem(1)
2457
2458	# elif defined key_mpp_mpi
2459
2460	!! * Local variables (MPI version)
2461	INTEGER :: ierror
2462	REAL(wp) :: zwork
2463
2464	CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision &
2465	& ,mpi_min,mpi_comm_world,ierror)
2466	ptab = zwork
2467
2468	#endif
2469
2470	END SUBROUTINE mppmin_real
2471
2472
2473	SUBROUTINE mppsum_a_real( ptab, kdim )
2474	!!----------------------------------------------------------------------
2475	!! * routine mppsum_a_real *
2476	!!
2477	!! ** Purpose : global sum in Massively Parallel Processing
2478	!! REAL ARRAY argument case
2479	!!
2480	!!-----------------------------------------------------------------------
2481	INTEGER , INTENT( in ) :: kdim ! size of ptab
2482	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
2483
2484	#if defined key_mpp_shmem
2485
2486	!! * Local variables (SHMEM version)
2487	INTEGER :: ji
2488	INTEGER, SAVE :: ibool=0
2489
2490	IF( kdim > jpmppsum ) THEN
2491	WRITE(numout,*) 'mppsum_a_real routine : kdim is too big'
2492	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2493	STOP 'mppsum_a_real'
2494	ENDIF
2495
2496	DO ji = 1, kdim
2497	wrstab_shmem(ji) = ptab(ji)
2498	END DO
2499	CALL barrier()
2500	IF(ibool == 0 ) THEN
2501	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
2502	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
2503	ELSE
2504	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
2505	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
2506	ENDIF
2507	CALL barrier()
2508	ibool=ibool+1
2509	ibool=MOD( ibool,2)
2510	DO ji = 1, kdim
2511	ptab(ji) = wrstab_shmem(ji)
2512	END DO
2513
2514	# elif defined key_mpp_mpi
2515
2516	!! * Local variables (MPI version)
2517	INTEGER :: ierror ! temporary integer
2518	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
2519
2520	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2521	& ,mpi_sum,mpi_comm_world,ierror)
2522	ptab(:) = zwork(:)
2523
2524	#endif
2525
2526	END SUBROUTINE mppsum_a_real
2527
2528
2529	SUBROUTINE mppsum_real( ptab )
2530	!!----------------------------------------------------------------------
2531	!! * routine mppsum_real *
2532	!!
2533	!! ** Purpose : global sum in Massively Parallel Processing
2534	!! SCALAR argument case
2535	!!
2536	!!-----------------------------------------------------------------------
2537	REAL(wp), INTENT(inout) :: ptab ! input scalar
2538
2539	#if defined key_mpp_shmem
2540
2541	!! * Local variables (SHMEM version)
2542	INTEGER, SAVE :: ibool=0
2543
2544	wrstab_shmem(1) = ptab
2545	CALL barrier()
2546	IF(ibool == 0 ) THEN
2547	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
2548	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
2549	ELSE
2550	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
2551	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
2552	ENDIF
2553	CALL barrier()
2554	ibool = ibool + 1
2555	ibool = MOD( ibool, 2 )
2556	ptab = wrstab_shmem(1)
2557
2558	# elif defined key_mpp_mpi
2559
2560	!! * Local variables (MPI version)
2561	INTEGER :: ierror
2562	REAL(wp) :: zwork
2563
2564	CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision &
2565	& ,mpi_sum,mpi_comm_world,ierror)
2566	ptab = zwork
2567
2568	#endif
2569
2570	END SUBROUTINE mppsum_real
2571
2572	SUBROUTINE mpp_minloc2d(ptab, pmask, pmin, ki,kj )
2573	!!------------------------------------------------------------------------
2574	!! * routine mpp_minloc *
2575	!!
2576	!! ** Purpose : Compute the global minimum of an array ptab
2577	!! and also give its global position
2578	!!
2579	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2580	!!
2581	!! ** Arguments : I : ptab =local 2D array
2582	!! O : pmin = global minimum
2583	!! O : ki,kj = global position of minimum
2584	!!
2585	!! ** Author : J.M. Molines 10/10/2004
2586	!!--------------------------------------------------------------------------
2587	#ifdef key_mpp_shmem
2588	IF (lwp) THEN
2589	WRITE(numout,*) ' mpp_minloc not yet available in SHMEM'
2590	STOP
2591	ENDIF
2592	# elif key_mpp_mpi
2593	!! * Arguments
2594	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
2595	& pmask ! Local mask
2596	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
2597	INTEGER , INTENT (out) :: ki,kj ! index of minimum in global frame
2598
2599	!! * Local variables
2600	REAL(wp) :: zmin ! local minimum
2601	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2602	INTEGER, DIMENSION (2) :: ilocs
2603	INTEGER :: ierror
2604
2605
2606	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
2607	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
2608
2609	ki = ilocs(1) + nimpp - 1
2610	kj = ilocs(2) + njmpp - 1
2611
2612	zain(1,:)=zmin
2613	zain(2,:)=ki+10000.*kj
2614
2615	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror)
2616
2617	pmin=zaout(1,1)
2618	kj= INT(zaout(2,1)/10000.)
2619	ki= INT(zaout(2,1) - 10000.*kj )
2620	#endif
2621
2622	END SUBROUTINE mpp_minloc2d
2623
2624
2625	SUBROUTINE mpp_minloc3d(ptab, pmask, pmin, ki,kj ,kk)
2626	!!------------------------------------------------------------------------
2627	!! * routine mpp_minloc *
2628	!!
2629	!! ** Purpose : Compute the global minimum of an array ptab
2630	!! and also give its global position
2631	!!
2632	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2633	!!
2634	!! ** Arguments : I : ptab =local 2D array
2635	!! O : pmin = global minimum
2636	!! O : ki,kj = global position of minimum
2637	!!
2638	!! ** Author : J.M. Molines 10/10/2004
2639	!!--------------------------------------------------------------------------
2640	#ifdef key_mpp_shmem
2641	IF (lwp) THEN
2642	WRITE(numout,*) ' mpp_minloc not yet available in SHMEM'
2643	STOP
2644	ENDIF
2645	# elif key_mpp_mpi
2646	!! * Arguments
2647	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
2648	& pmask ! Local mask
2649	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
2650	INTEGER , INTENT (out) :: ki,kj,kk ! index of minimum in global frame
2651
2652	!! * Local variables
2653	REAL(wp) :: zmin ! local minimum
2654	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2655	INTEGER, DIMENSION (3) :: ilocs
2656	INTEGER :: ierror
2657
2658
2659	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2660	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2661
2662	ki = ilocs(1) + nimpp - 1
2663	kj = ilocs(2) + njmpp - 1
2664	kk = ilocs(3)
2665
2666	zain(1,:)=zmin
2667	zain(2,:)=ki+10000.kj+100000000.kk
2668
2669	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror)
2670
2671	pmin=zaout(1,1)
2672	kk= INT(zaout(2,1)/100000000.)
2673	kj= INT(zaout(2,1) - kk * 100000000. )/10000
2674	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
2675	#endif
2676
2677	END SUBROUTINE mpp_minloc3d
2678
2679
2680	SUBROUTINE mpp_maxloc2d(ptab, pmask, pmax, ki,kj )
2681	!!------------------------------------------------------------------------
2682	!! * routine mpp_maxloc *
2683	!!
2684	!! ** Purpose : Compute the global maximum of an array ptab
2685	!! and also give its global position
2686	!!
2687	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2688	!!
2689	!! ** Arguments : I : ptab =local 2D array
2690	!! O : pmax = global maximum
2691	!! O : ki,kj = global position of maximum
2692	!!
2693	!! ** Author : J.M. Molines 10/10/2004
2694	!!--------------------------------------------------------------------------
2695	#ifdef key_mpp_shmem
2696	IF (lwp) THEN
2697	WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM'
2698	STOP
2699	ENDIF
2700	# elif key_mpp_mpi
2701	!! * Arguments
2702	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
2703	& pmask ! Local mask
2704	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
2705	INTEGER , INTENT (out) :: ki,kj ! index of maximum in global frame
2706
2707	!! * Local variables
2708	REAL(wp) :: zmax ! local maximum
2709	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2710	INTEGER, DIMENSION (2) :: ilocs
2711	INTEGER :: ierror
2712
2713
2714	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
2715	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
2716
2717	ki = ilocs(1) + nimpp - 1
2718	kj = ilocs(2) + njmpp - 1
2719
2720	zain(1,:)=zmax
2721	zain(2,:)=ki+10000.*kj
2722
2723	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror)
2724
2725	pmax=zaout(1,1)
2726	kj= INT(zaout(2,1)/10000.)
2727	ki= INT(zaout(2,1) - 10000.*kj )
2728	#endif
2729
2730	END SUBROUTINE mpp_maxloc2d
2731
2732	SUBROUTINE mpp_maxloc3d(ptab, pmask, pmax, ki,kj,kk )
2733	!!------------------------------------------------------------------------
2734	!! * routine mpp_maxloc *
2735	!!
2736	!! ** Purpose : Compute the global maximum of an array ptab
2737	!! and also give its global position
2738	!!
2739	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2740	!!
2741	!! ** Arguments : I : ptab =local 2D array
2742	!! O : pmax = global maximum
2743	!! O : ki,kj = global position of maximum
2744	!!
2745	!! ** Author : J.M. Molines 10/10/2004
2746	!!--------------------------------------------------------------------------
2747	#ifdef key_mpp_shmem
2748	IF (lwp) THEN
2749	WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM'
2750	STOP
2751	ENDIF
2752	# elif key_mpp_mpi
2753	!! * Arguments
2754	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
2755	& pmask ! Local mask
2756	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
2757	INTEGER , INTENT (out) :: ki,kj,kk ! index of maximum in global frame
2758
2759	!! * Local variables
2760	REAL(wp) :: zmax ! local maximum
2761	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2762	INTEGER, DIMENSION (3) :: ilocs
2763	INTEGER :: ierror
2764
2765
2766	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2767	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2768
2769	ki = ilocs(1) + nimpp - 1
2770	kj = ilocs(2) + njmpp - 1
2771	kk = ilocs(3)
2772
2773	zain(1,:)=zmax
2774	zain(2,:)=ki+10000.kj+100000000.kk
2775
2776	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror)
2777
2778	pmax=zaout(1,1)
2779	kk= INT(zaout(2,1)/100000000.)
2780	kj= INT(zaout(2,1) - kk * 100000000. )/10000
2781	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
2782	#endif
2783
2784	END SUBROUTINE mpp_maxloc3d
2785
2786	SUBROUTINE mppsync()
2787	!!----------------------------------------------------------------------
2788	!! * routine mppsync *
2789	!!
2790	!! ** Purpose : Massively parallel processors, synchroneous
2791	!!
2792	!!-----------------------------------------------------------------------
2793
2794	#if defined key_mpp_shmem
2795
2796	!! * Local variables (SHMEM version)
2797	CALL barrier()
2798
2799	# elif defined key_mpp_mpi
2800
2801	!! * Local variables (MPI version)
2802	INTEGER :: ierror
2803
2804	CALL mpi_barrier(mpi_comm_world,ierror)
2805
2806	#endif
2807
2808	END SUBROUTINE mppsync
2809
2810
2811	SUBROUTINE mppstop
2812	!!----------------------------------------------------------------------
2813	!! * routine mppstop *
2814	!!
2815	!! ** purpose : Stop massilively parallel processors method
2816	!!
2817	!!----------------------------------------------------------------------
2818	!! * Local declarations
2819	INTEGER :: info
2820	!!----------------------------------------------------------------------
2821
2822	! 1. Mpp synchroneus
2823	! ------------------
2824
2825	CALL mppsync
2826	#if defined key_mpp_mpi
2827	CALL mpi_finalize( info )
2828	#endif
2829
2830	END SUBROUTINE mppstop
2831
2832
2833	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
2834	!!----------------------------------------------------------------------
2835	!! * routine mppobc *
2836	!!
2837	!! ** Purpose : Message passing manadgement for open boundary
2838	!! conditions array
2839	!!
2840	!! ** Method : Use mppsend and mpprecv function for passing mask
2841	!! between processors following neighboring subdomains.
2842	!! domain parameters
2843	!! nlci : first dimension of the local subdomain
2844	!! nlcj : second dimension of the local subdomain
2845	!! nbondi : mark for "east-west local boundary"
2846	!! nbondj : mark for "north-south local boundary"
2847	!! noea : number for local neighboring processors
2848	!! nowe : number for local neighboring processors
2849	!! noso : number for local neighboring processors
2850	!! nono : number for local neighboring processors
2851	!!
2852	!! History :
2853	!! ! 98-07 (J.M. Molines) Open boundary conditions
2854	!!----------------------------------------------------------------------
2855	!! * Arguments
2856	INTEGER , INTENT( in ) :: &
2857	kd1, kd2, & ! starting and ending indices
2858	kl , & ! index of open boundary
2859	kk, & ! vertical dimension
2860	ktype, & ! define north/south or east/west cdt
2861	! ! = 1 north/south ; = 2 east/west
2862	kij ! horizontal dimension
2863	REAL(wp), DIMENSION(kij,kk), INTENT( inout ) :: &
2864	ptab ! variable array
2865
2866	!! * Local variables
2867	INTEGER :: ji, jj, jk, jl ! dummy loop indices
2868	INTEGER :: &
2869	iipt0, iipt1, ilpt1, & ! temporary integers
2870	ijpt0, ijpt1, & ! " "
2871	imigr, iihom, ijhom ! " "
2872	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
2873	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
2874	REAL(wp), DIMENSION(jpi,jpj) :: &
2875	ztab ! temporary workspace
2876	!!----------------------------------------------------------------------
2877
2878
2879	! boundary condition initialization
2880	! ---------------------------------
2881
2882	ztab(:,:) = 0.e0
2883
2884	IF( ktype==1 ) THEN ! north/south boundaries
2885	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
2886	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
2887	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
2888	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
2889	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
2890	ELSEIF( ktype==2 ) THEN ! east/west boundaries
2891	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
2892	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
2893	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
2894	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
2895	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
2896	ELSE
2897	IF(lwp)WRITE(numout,*) 'mppobc: bad ktype'
2898	STOP 'mppobc'
2899	ENDIF
2900
2901	DO jk = 1, kk
2902	IF( ktype==1 ) THEN ! north/south boundaries
2903	DO jj = ijpt0, ijpt1
2904	DO ji = iipt0, iipt1
2905	ztab(ji,jj) = ptab(ji,jk)
2906	END DO
2907	END DO
2908	ELSEIF( ktype==2 ) THEN ! east/west boundaries
2909	DO jj = ijpt0, ijpt1
2910	DO ji = iipt0, iipt1
2911	ztab(ji,jj) = ptab(jj,jk)
2912	END DO
2913	END DO
2914	ENDIF
2915
2916
2917	! 1. East and west directions
2918	! ---------------------------
2919
2920	! 1.1 Read Dirichlet lateral conditions
2921
2922	IF( nbondi /= 2 ) THEN
2923	iihom = nlci-nreci
2924
2925	DO jl = 1, jpreci
2926	t2ew(:,jl,1) = ztab(jpreci+jl,:)
2927	t2we(:,jl,1) = ztab(iihom +jl,:)
2928	END DO
2929	ENDIF
2930
2931	! 1.2 Migrations
2932
2933	#if defined key_mpp_shmem
2934	!! * (SHMEM version)
2935	imigr=jprecijpjjpbyt
2936
2937	IF( nbondi == -1 ) THEN
2938	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
2939	ELSEIF( nbondi == 0 ) THEN
2940	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
2941	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
2942	ELSEIF( nbondi == 1 ) THEN
2943	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
2944	ENDIF
2945	CALL barrier()
2946	CALL shmem_udcflush()
2947
2948	# elif key_mpp_mpi
2949	!! * (MPI version)
2950
2951	imigr=jpreci*jpj
2952
2953	IF( nbondi == -1 ) THEN
2954	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
2955	CALL mpprecv(1,t2ew(1,1,2),imigr)
2956	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2957	ELSEIF( nbondi == 0 ) THEN
2958	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2959	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
2960	CALL mpprecv(1,t2ew(1,1,2),imigr)
2961	CALL mpprecv(2,t2we(1,1,2),imigr)
2962	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2963	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2964	ELSEIF( nbondi == 1 ) THEN
2965	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2966	CALL mpprecv(2,t2we(1,1,2),imigr)
2967	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2968	ENDIF
2969	#endif
2970
2971
2972	! 1.3 Write Dirichlet lateral conditions
2973
2974	iihom = nlci-jpreci
2975	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
2976	DO jl = 1, jpreci
2977	ztab(jl,:) = t2we(:,jl,2)
2978	END DO
2979	ENDIF
2980
2981	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
2982	DO jl = 1, jpreci
2983	ztab(iihom+jl,:) = t2ew(:,jl,2)
2984	END DO
2985	ENDIF
2986
2987
2988	! 2. North and south directions
2989	! -----------------------------
2990
2991	! 2.1 Read Dirichlet lateral conditions
2992
2993	IF( nbondj /= 2 ) THEN
2994	ijhom = nlcj-nrecj
2995	DO jl = 1, jprecj
2996	t2sn(:,jl,1) = ztab(:,ijhom +jl)
2997	t2ns(:,jl,1) = ztab(:,jprecj+jl)
2998	END DO
2999	ENDIF
3000
3001	! 2.2 Migrations
3002
3003	#if defined key_mpp_shmem
3004	!! * SHMEM version
3005
3006	imigr=jprecjjpijpbyt
3007
3008	IF( nbondj == -1 ) THEN
3009	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
3010	ELSEIF( nbondj == 0 ) THEN
3011	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
3012	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
3013	ELSEIF( nbondj == 1 ) THEN
3014	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
3015	ENDIF
3016	CALL barrier()
3017	CALL shmem_udcflush()
3018
3019	# elif key_mpp_mpi
3020	!! * Local variables (MPI version)
3021
3022	imigr=jprecj*jpi
3023
3024	IF( nbondj == -1 ) THEN
3025	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
3026	CALL mpprecv(3,t2ns(1,1,2),imigr)
3027	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3028	ELSEIF( nbondj == 0 ) THEN
3029	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
3030	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
3031	CALL mpprecv(3,t2ns(1,1,2),imigr)
3032	CALL mpprecv(4,t2sn(1,1,2),imigr)
3033	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3034	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3035	ELSEIF( nbondj == 1 ) THEN
3036	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
3037	CALL mpprecv(4,t2sn(1,1,2),imigr)
3038	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3039	ENDIF
3040
3041	#endif
3042
3043	! 2.3 Write Dirichlet lateral conditions
3044
3045	ijhom = nlcj - jprecj
3046	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
3047	DO jl = 1, jprecj
3048	ztab(:,jl) = t2sn(:,jl,2)
3049	END DO
3050	ENDIF
3051
3052	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
3053	DO jl = 1, jprecj
3054	ztab(:,ijhom+jl) = t2ns(:,jl,2)
3055	END DO
3056	ENDIF
3057
3058	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
3059	! north/south boundaries
3060	DO jj = ijpt0,ijpt1
3061	DO ji = iipt0,ilpt1
3062	ptab(ji,jk) = ztab(ji,jj)
3063	END DO
3064	END DO
3065	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
3066	! east/west boundaries
3067	DO jj = ijpt0,ilpt1
3068	DO ji = iipt0,iipt1
3069	ptab(jj,jk) = ztab(ji,jj)
3070	END DO
3071	END DO
3072	ENDIF
3073
3074	END DO
3075
3076	END SUBROUTINE mppobc
3077
3078
3079	SUBROUTINE mpp_ini_north
3080	!!----------------------------------------------------------------------
3081	!! * routine mpp_ini_north *
3082	!!
3083	!! ** Purpose : Initialize special communicator for north folding
3084	!! condition together with global variables needed in the mpp folding
3085	!!
3086	!! ** Method : - Look for northern processors
3087	!! - Put their number in nrank_north
3088	!! - Create groups for the world processors and the north processors
3089	!! - Create a communicator for northern processors
3090	!!
3091	!! ** output
3092	!! njmppmax = njmpp for northern procs
3093	!! ndim_rank_north = number of processors in the northern line
3094	!! nrank_north (ndim_rank_north) = number of the northern procs.
3095	!! ngrp_world = group ID for the world processors
3096	!! ngrp_north = group ID for the northern processors
3097	!! ncomm_north = communicator for the northern procs.
3098	!! north_root = number (in the world) of proc 0 in the northern comm.
3099	!!
3100	!! History :
3101	!! ! 03-09 (J.M. Molines, MPI only )
3102	!!----------------------------------------------------------------------
3103	#ifdef key_mpp_shmem
3104	IF (lwp) THEN
3105	WRITE(numout,*) ' mpp_ini_north not available in SHMEM'
3106	STOP
3107	ENDIF
3108	# elif key_mpp_mpi
3109	INTEGER :: ierr
3110	INTEGER :: jproc
3111	INTEGER :: ii,ji
3112	!!----------------------------------------------------------------------
3113
3114	njmppmax=MAXVAL(njmppt)
3115
3116	! Look for how many procs on the northern boundary
3117	!
3118	ndim_rank_north=0
3119	DO jproc=1,jpnij
3120	IF ( njmppt(jproc) == njmppmax ) THEN
3121	ndim_rank_north = ndim_rank_north + 1
3122	END IF
3123	END DO
3124
3125
3126	! Allocate the right size to nrank_north
3127	!
3128	ALLOCATE(nrank_north(ndim_rank_north))
3129
3130	! Fill the nrank_north array with proc. number of northern procs.
3131	! Note : the rank start at 0 in MPI
3132	!
3133	ii=0
3134	DO ji = 1, jpnij
3135	IF ( njmppt(ji) == njmppmax ) THEN
3136	ii=ii+1
3137	nrank_north(ii)=ji-1
3138	END IF
3139	END DO
3140	! create the world group
3141	!
3142	CALL MPI_COMM_GROUP(mpi_comm_world,ngrp_world,ierr)
3143	!
3144	! Create the North group from the world group
3145	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr)
3146
3147	! Create the North communicator , ie the pool of procs in the north group
3148	!
3149	CALL MPI_COMM_CREATE(mpi_comm_world,ngrp_north,ncomm_north,ierr)
3150
3151
3152	! find proc number in the world of proc 0 in the north
3153	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr)
3154	#endif
3155
3156	END SUBROUTINE mpp_ini_north
3157
3158
3159	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
3160	!!---------------------------------------------------------------------
3161	!! * routine mpp_lbc_north_3d *
3162	!!
3163	!! ** Purpose :
3164	!! Ensure proper north fold horizontal bondary condition in mpp configuration
3165	!! in case of jpn1 > 1
3166	!!
3167	!! ** Method :
3168	!! Gather the 4 northern lines of the global domain on 1 processor and
3169	!! apply lbc north-fold on this sub array. Then scatter the fold array
3170	!! back to the processors.
3171	!!
3172	!! History :
3173	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
3174	!! from lbc routine
3175	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
3176	!!----------------------------------------------------------------------
3177	!! * Arguments
3178	CHARACTER(len=1), INTENT( in ) :: &
3179	cd_type ! nature of pt3d grid-points
3180	! ! = T , U , V , F or W gridpoints
3181	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
3182	pt3d ! 3D array on which the boundary condition is applied
3183	REAL(wp), INTENT( in ) :: &
3184	psgn ! control of the sign change
3185	! ! = -1. , the sign is changed if north fold boundary
3186	! ! = 1. , the sign is kept if north fold boundary
3187
3188	!! * Local declarations
3189	INTEGER :: ji, jj, jk, jr, jproc
3190	INTEGER :: ierr
3191	INTEGER :: ildi,ilei,iilb
3192	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
3193	INTEGER :: itaille
3194	REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab
3195	REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio
3196	REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc
3197	!!----------------------------------------------------------------------
3198
3199	! If we get in this routine it s because : North fold condition and mpp with more
3200	! than one proc across i : we deal only with the North condition
3201
3202	! 0. Sign setting
3203	! ---------------
3204
3205	ijpj=4
3206	ijpjm1=3
3207
3208	! put in znorthloc the last 4 jlines of pt3d
3209	DO jk = 1, jpk
3210	DO jj = nlcj - ijpj +1, nlcj
3211	ij = jj - nlcj + ijpj
3212	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
3213	END DO
3214	END DO
3215
3216
3217	IF (npolj /= 0 ) THEN
3218	! Build in proc 0 of ncomm_north the znorthgloio
3219	znorthgloio(:,:,:,:) = 0_wp
3220
3221	#ifdef key_mpp_shmem
3222	not done : compiler error
3223	#elif defined key_mpp_mpi
3224	itaille=jpijpkijpj
3225	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3226	#endif
3227
3228	ENDIF
3229
3230	IF (narea == north_root+1 ) THEN
3231	! recover the global north array
3232	ztab(:,:,:) = 0_wp
3233
3234	DO jr = 1, ndim_rank_north
3235	jproc = nrank_north(jr) + 1
3236	ildi = nldit (jproc)
3237	ilei = nleit (jproc)
3238	iilb = nimppt(jproc)
3239	DO jk = 1, jpk
3240	DO jj = 1, 4
3241	DO ji = ildi, ilei
3242	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
3243	END DO
3244	END DO
3245	END DO
3246	END DO
3247
3248
3249	! Horizontal slab
3250	! ===============
3251
3252	DO jk = 1, jpk
3253
3254
3255	! 2. North-Fold boundary conditions
3256	! ----------------------------------
3257
3258	SELECT CASE ( npolj )
3259
3260	CASE ( 3, 4 ) ! * North fold T-point pivot
3261
3262	ztab( 1 ,ijpj,jk) = 0.e0
3263	ztab(jpiglo,ijpj,jk) = 0.e0
3264
3265	SELECT CASE ( cd_type )
3266
3267	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
3268	DO ji = 2, jpiglo
3269	ijt = jpiglo-ji+2
3270	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
3271	END DO
3272	DO ji = jpiglo/2+1, jpiglo
3273	ijt = jpiglo-ji+2
3274	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
3275	END DO
3276
3277	CASE ( 'U' ) ! U-point
3278	DO ji = 1, jpiglo-1
3279	iju = jpiglo-ji+1
3280	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
3281	END DO
3282	DO ji = jpiglo/2, jpiglo-1
3283	iju = jpiglo-ji+1
3284	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
3285	END DO
3286
3287	CASE ( 'V' ) ! V-point
3288	DO ji = 2, jpiglo
3289	ijt = jpiglo-ji+2
3290	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
3291	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
3292	END DO
3293
3294	CASE ( 'F' , 'G' ) ! F-point
3295	DO ji = 1, jpiglo-1
3296	iju = jpiglo-ji+1
3297	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
3298	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
3299	END DO
3300
3301	END SELECT
3302
3303	CASE ( 5, 6 ) ! * North fold F-point pivot
3304
3305	ztab( 1 ,ijpj,jk) = 0.e0
3306	ztab(jpiglo,ijpj,jk) = 0.e0
3307
3308	SELECT CASE ( cd_type )
3309
3310	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
3311	DO ji = 1, jpiglo
3312	ijt = jpiglo-ji+1
3313	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
3314	END DO
3315
3316	CASE ( 'U' ) ! U-point
3317	DO ji = 1, jpiglo-1
3318	iju = jpiglo-ji
3319	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
3320	END DO
3321
3322	CASE ( 'V' ) ! V-point
3323	DO ji = 1, jpiglo
3324	ijt = jpiglo-ji+1
3325	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
3326	END DO
3327	DO ji = jpiglo/2+1, jpiglo
3328	ijt = jpiglo-ji+1
3329	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
3330	END DO
3331
3332	CASE ( 'F' , 'G' ) ! F-point
3333	DO ji = 1, jpiglo-1
3334	iju = jpiglo-ji
3335	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
3336	END DO
3337	DO ji = jpiglo/2+1, jpiglo-1
3338	iju = jpiglo-ji
3339	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
3340	END DO
3341
3342	END SELECT
3343
3344	CASE DEFAULT ! * closed
3345
3346	SELECT CASE ( cd_type)
3347
3348	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
3349	ztab(:, 1 ,jk) = 0.e0
3350	ztab(:,ijpj,jk) = 0.e0
3351
3352	CASE ( 'F' ) ! F-point
3353	ztab(:,ijpj,jk) = 0.e0
3354
3355	END SELECT
3356
3357	END SELECT
3358
3359	! End of slab
3360	! ===========
3361
3362	END DO
3363
3364	!! Scatter back to pt3d
3365	DO jr = 1, ndim_rank_north
3366	jproc=nrank_north(jr)+1
3367	ildi=nldit (jproc)
3368	ilei=nleit (jproc)
3369	iilb=nimppt(jproc)
3370	DO jk= 1, jpk
3371	DO jj=1,ijpj
3372	DO ji=ildi,ilei
3373	znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
3374	END DO
3375	END DO
3376	END DO
3377	END DO
3378
3379	ENDIF ! only done on proc 0 of ncomm_north
3380
3381	#ifdef key_mpp_shmem
3382	not done yet in shmem : compiler error
3383	#elif key_mpp_mpi
3384	IF ( npolj /= 0 ) THEN
3385	itaille=jpijpkijpj
3386	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3387	ENDIF
3388	#endif
3389
3390	! put in the last ijpj jlines of pt3d znorthloc
3391	DO jk = 1 , jpk
3392	DO jj = nlcj - ijpj + 1 , nlcj
3393	ij = jj - nlcj + ijpj
3394	pt3d(:,jj,jk)= znorthloc(:,ij,jk)
3395	END DO
3396	END DO
3397
3398	END SUBROUTINE mpp_lbc_north_3d
3399
3400
3401	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
3402	!!---------------------------------------------------------------------
3403	!! * routine mpp_lbc_north_2d *
3404	!!
3405	!! ** Purpose :
3406	!! Ensure proper north fold horizontal bondary condition in mpp configuration
3407	!! in case of jpn1 > 1 (for 2d array )
3408	!!
3409	!! ** Method :
3410	!! Gather the 4 northern lines of the global domain on 1 processor and
3411	!! apply lbc north-fold on this sub array. Then scatter the fold array
3412	!! back to the processors.
3413	!!
3414	!! History :
3415	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
3416	!! from lbc routine
3417	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
3418	!!----------------------------------------------------------------------
3419
3420	!! * Arguments
3421	CHARACTER(len=1), INTENT( in ) :: &
3422	cd_type ! nature of pt2d grid-points
3423	! ! = T , U , V , F or W gridpoints
3424	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
3425	pt2d ! 2D array on which the boundary condition is applied
3426	REAL(wp), INTENT( in ) :: &
3427	psgn ! control of the sign change
3428	! ! = -1. , the sign is changed if north fold boundary
3429	! ! = 1. , the sign is kept if north fold boundary
3430
3431
3432	!! * Local declarations
3433
3434	INTEGER :: ji, jj, jr, jproc
3435	INTEGER :: ierr
3436	INTEGER :: ildi,ilei,iilb
3437	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
3438	INTEGER :: itaille
3439
3440	REAL(wp), DIMENSION(jpiglo,4) :: ztab
3441	REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio
3442	REAL(wp), DIMENSION(jpi,4) :: znorthloc
3443	!!----------------------------------------------------------------------
3444	!! OPA 8.5, LODYC-IPSL (2002)
3445	!!----------------------------------------------------------------------
3446	! If we get in this routine it s because : North fold condition and mpp with more
3447	! than one proc across i : we deal only with the North condition
3448
3449	! 0. Sign setting
3450	! ---------------
3451
3452	ijpj=4
3453	ijpjm1=3
3454
3455
3456	! put in znorthloc the last 4 jlines of pt2d
3457	DO jj = nlcj - ijpj +1, nlcj
3458	ij = jj - nlcj + ijpj
3459	znorthloc(:,ij)=pt2d(:,jj)
3460	END DO
3461
3462	IF (npolj /= 0 ) THEN
3463	! Build in proc 0 of ncomm_north the znorthgloio
3464	znorthgloio(:,:,:) = 0_wp
3465	#ifdef key_mpp_shmem
3466	not done : compiler error
3467	#elif defined key_mpp_mpi
3468	itaille=jpi*ijpj
3469	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3470	#endif
3471	ENDIF
3472
3473	IF (narea == north_root+1 ) THEN
3474	! recover the global north array
3475	ztab(:,:) = 0_wp
3476
3477	DO jr = 1, ndim_rank_north
3478	jproc=nrank_north(jr)+1
3479	ildi=nldit (jproc)
3480	ilei=nleit (jproc)
3481	iilb=nimppt(jproc)
3482	DO jj=1,4
3483	DO ji=ildi,ilei
3484	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
3485	END DO
3486	END DO
3487	END DO
3488
3489
3490	! 2. North-Fold boundary conditions
3491	! ----------------------------------
3492
3493	SELECT CASE ( npolj )
3494
3495	CASE ( 3, 4 ) ! * North fold T-point pivot
3496
3497	ztab( 1 ,ijpj) = 0.e0
3498	ztab(jpiglo,ijpj) = 0.e0
3499
3500	SELECT CASE ( cd_type )
3501
3502	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
3503	DO ji = 2, jpiglo
3504	ijt = jpiglo-ji+2
3505	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
3506	END DO
3507	DO ji = jpiglo/2+1, jpiglo
3508	ijt = jpiglo-ji+2
3509	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
3510	END DO
3511
3512	CASE ( 'U' ) ! U-point
3513	DO ji = 1, jpiglo-1
3514	iju = jpiglo-ji+1
3515	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-2)
3516	END DO
3517	DO ji = jpiglo/2, jpiglo-1
3518	iju = jpiglo-ji+1
3519	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
3520	END DO
3521
3522	CASE ( 'V' ) ! V-point
3523	DO ji = 2, jpiglo
3524	ijt = jpiglo-ji+2
3525	ztab(ji,ijpj-1) = psgn * ztab(ijt,ijpj-2)
3526	ztab(ji,ijpj ) = psgn * ztab(ijt,ijpj-3)
3527	END DO
3528
3529	CASE ( 'F' , 'G' ) ! F-point
3530	DO ji = 1, jpiglo-1
3531	iju = jpiglo-ji+1
3532	ztab(ji,ijpj-1) = psgn * ztab(iju,ijpj-2)
3533	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-3)
3534	END DO
3535
3536	CASE ( 'I' ) ! ice U-V point
3537	ztab(2,ijpj) = psgn * ztab(3,ijpj-1)
3538	DO ji = 3, jpiglo
3539	iju = jpiglo - ji + 3
3540	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
3541	END DO
3542
3543	END SELECT
3544
3545	CASE ( 5, 6 ) ! * North fold F-point pivot
3546
3547	ztab( 1 ,ijpj) = 0.e0
3548	ztab(jpiglo,ijpj) = 0.e0
3549
3550	SELECT CASE ( cd_type )
3551
3552	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
3553	DO ji = 1, jpiglo
3554	ijt = jpiglo-ji+1
3555	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-1)
3556	END DO
3557
3558	CASE ( 'U' ) ! U-point
3559	DO ji = 1, jpiglo-1
3560	iju = jpiglo-ji
3561	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
3562	END DO
3563
3564	CASE ( 'V' ) ! V-point
3565	DO ji = 1, jpiglo
3566	ijt = jpiglo-ji+1
3567	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
3568	END DO
3569	DO ji = jpiglo/2+1, jpiglo
3570	ijt = jpiglo-ji+1
3571	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
3572	END DO
3573
3574	CASE ( 'F' , 'G' ) ! F-point
3575	DO ji = 1, jpiglo-1
3576	iju = jpiglo-ji
3577	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-2)
3578	END DO
3579	DO ji = jpiglo/2+1, jpiglo-1
3580	iju = jpiglo-ji
3581	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
3582	END DO
3583
3584	CASE ( 'I' ) ! ice U-V point
3585	ztab( 2 ,ijpj) = 0.e0
3586	DO ji = 2 , jpiglo-1
3587	ijt = jpi - ji + 2
3588	ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) )
3589	END DO
3590
3591	END SELECT
3592
3593	CASE DEFAULT ! * closed : the code probably never go through
3594
3595	SELECT CASE ( cd_type)
3596
3597	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
3598	ztab(:, 1 ) = 0.e0
3599	ztab(:,ijpj) = 0.e0
3600
3601	CASE ( 'F' ) ! F-point
3602	ztab(:,ijpj) = 0.e0
3603
3604	CASE ( 'I' ) ! ice U-V point
3605	ztab(:, 1 ) = 0.e0
3606	ztab(:,ijpj) = 0.e0
3607
3608	END SELECT
3609
3610	END SELECT
3611
3612	! End of slab
3613	! ===========
3614
3615	!! Scatter back to pt2d
3616	DO jr = 1, ndim_rank_north
3617	jproc=nrank_north(jr)+1
3618	ildi=nldit (jproc)
3619	ilei=nleit (jproc)
3620	iilb=nimppt(jproc)
3621	DO jj=1,ijpj
3622	DO ji=ildi,ilei
3623	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
3624	END DO
3625	END DO
3626	END DO
3627
3628	ENDIF ! only done on proc 0 of ncomm_north
3629
3630	#ifdef key_mpp_shmem
3631	not done yet in shmem : compiler error
3632	#elif key_mpp_mpi
3633	IF ( npolj /= 0 ) THEN
3634	itaille=jpi*ijpj
3635	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3636	ENDIF
3637	#endif
3638
3639	! put in the last ijpj jlines of pt2d znorthloc
3640	DO jj = nlcj - ijpj + 1 , nlcj
3641	ij = jj - nlcj + ijpj
3642	pt2d(:,jj)= znorthloc(:,ij)
3643	END DO
3644
3645	END SUBROUTINE mpp_lbc_north_2d
3646
3647
3648	!!!!!
3649
3650
3651	!!
3652	!! This is valid on IBM machine ONLY.
3653	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -- Mode: F90 -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3654	!! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque
3655	!! MPI afin de faire, en plus de l'initialisation de
3656	!! l'environnement MPI, l'allocation d'une zone tampon
3657	!! qui sera ulterieurement utilisee automatiquement lors
3658	!! de tous les envois de messages par MPI_BSEND
3659	!!
3660	!! Auteur : CNRS/IDRIS
3661	!! Date : Tue Nov 13 12:02:14 2001
3662	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3663
3664	SUBROUTINE mpi_init_opa(code)
3665	IMPLICIT NONE
3666	# include <mpif.h>
3667
3668	INTEGER :: code,rang
3669
3670	! La valeur suivante doit etre au moins egale a la taille
3671	! du plus grand message qui sera transfere dans le programme
3672	! (de toute facon, il y aura un message d'erreur si cette
3673	! valeur s'avere trop petite)
3674	INTEGER :: taille_tampon
3675	CHARACTER(len=9) :: taille_tampon_alphanum
3676	REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon
3677
3678	! Le point d'entree dans la bibliotheque MPI elle-meme
3679	CALL mpi_init(code)
3680
3681	! La definition de la zone tampon pour les futurs envois
3682	! par MPI_BSEND (on alloue une fois pour toute cette zone
3683	! tampon, qui sera automatiquement utilisee lors de chaque
3684	! appel a MPI_BSEND).
3685	! La desallocation sera implicite quand on sortira de
3686	! l'environnement MPI.
3687
3688	! Recuperation de la valeur de la variable d'environnement
3689	! BUFFER_LENGTH
3690	! qui, si elle est definie, doit contenir une valeur superieure
3691	! a la taille en octets du plus gros message
3692	CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum)
3693
3694	! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par
3695	! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit
3696	! 65 536 octets
3697	IF (taille_tampon_alphanum == ' ') THEN
3698	taille_tampon = 65536
3699	ELSE
3700	READ(taille_tampon_alphanum,'(i9)') taille_tampon
3701	END IF
3702
3703	! On est limite en mode d'adressage 32 bits a 1750 Mo pour la zone
3704	! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo
3705	IF (taille_tampon > 210000000) THEN
3706	PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000'
3707	CALL mpi_abort(MPI_COMM_WORLD,2,code)
3708	END IF
3709
3710	CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code)
3711	IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon
3712
3713	! Allocation du tampon et attachement
3714	ALLOCATE(tampon(taille_tampon))
3715	CALL mpi_buffer_attach(tampon,taille_tampon,code)
3716
3717	END SUBROUTINE mpi_init_opa
3718
3719
3720	#else
3721	!!----------------------------------------------------------------------
3722	!! Default case: Dummy module share memory computing
3723	!!----------------------------------------------------------------------
3724	INTERFACE mpp_sum
3725	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
3726	END INTERFACE
3727	INTERFACE mpp_max
3728	MODULE PROCEDURE mppmax_a_real, mppmax_real
3729	END INTERFACE
3730	INTERFACE mpp_min
3731	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3732	END INTERFACE
3733	INTERFACE mpp_isl
3734	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
3735	END INTERFACE
3736	INTERFACE mppobc
3737	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
3738	END INTERFACE
3739	INTERFACE mpp_minloc
3740	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3741	END INTERFACE
3742	INTERFACE mpp_maxloc
3743	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3744	END INTERFACE
3745
3746
3747	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
3748
3749	CONTAINS
3750
3751	FUNCTION mynode() RESULT (function_value)
3752	function_value = 0
3753	END FUNCTION mynode
3754
3755	SUBROUTINE mppsync ! Dummy routine
3756	END SUBROUTINE mppsync
3757
3758	SUBROUTINE mpp_sum_as( parr, kdim ) ! Dummy routine
3759	REAL , DIMENSION(:) :: parr
3760	INTEGER :: kdim
3761	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1)
3762	END SUBROUTINE mpp_sum_as
3763
3764	SUBROUTINE mpp_sum_a2s( parr, kdim ) ! Dummy routine
3765	REAL , DIMENSION(:,:) :: parr
3766	INTEGER :: kdim
3767	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1)
3768	END SUBROUTINE mpp_sum_a2s
3769
3770	SUBROUTINE mpp_sum_ai( karr, kdim ) ! Dummy routine
3771	INTEGER, DIMENSION(:) :: karr
3772	INTEGER :: kdim
3773	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1)
3774	END SUBROUTINE mpp_sum_ai
3775
3776	SUBROUTINE mpp_sum_s( psca ) ! Dummy routine
3777	REAL :: psca
3778	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca
3779	END SUBROUTINE mpp_sum_s
3780
3781	SUBROUTINE mpp_sum_i( kint ) ! Dummy routine
3782	integer :: kint
3783	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint
3784	END SUBROUTINE mpp_sum_i
3785
3786	SUBROUTINE mppmax_a_real( parr, kdim )
3787	REAL , DIMENSION(:) :: parr
3788	INTEGER :: kdim
3789	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1)
3790	END SUBROUTINE mppmax_a_real
3791
3792	SUBROUTINE mppmax_real( psca )
3793	REAL :: psca
3794	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca
3795	END SUBROUTINE mppmax_real
3796
3797	SUBROUTINE mppmin_a_real( parr, kdim )
3798	REAL , DIMENSION(:) :: parr
3799	INTEGER :: kdim
3800	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1)
3801	END SUBROUTINE mppmin_a_real
3802
3803	SUBROUTINE mppmin_real( psca )
3804	REAL :: psca
3805	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca
3806	END SUBROUTINE mppmin_real
3807
3808	SUBROUTINE mppmin_a_int( karr, kdim )
3809	INTEGER, DIMENSION(:) :: karr
3810	INTEGER :: kdim
3811	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1)
3812	END SUBROUTINE mppmin_a_int
3813
3814	SUBROUTINE mppmin_int( kint )
3815	INTEGER :: kint
3816	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint
3817	END SUBROUTINE mppmin_int
3818
3819	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
3820	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3821	REAL, DIMENSION(:) :: parr ! variable array
3822	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3823	& parr(1), kd1, kd2, kl, kk, ktype, kij
3824	END SUBROUTINE mppobc_1d
3825
3826	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
3827	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3828	REAL, DIMENSION(:,:) :: parr ! variable array
3829	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3830	& parr(1,1), kd1, kd2, kl, kk, ktype, kij
3831	END SUBROUTINE mppobc_2d
3832
3833	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
3834	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3835	REAL, DIMENSION(:,:,:) :: parr ! variable array
3836	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3837	& parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
3838	END SUBROUTINE mppobc_3d
3839
3840	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
3841	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3842	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
3843	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3844	& parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
3845	END SUBROUTINE mppobc_4d
3846
3847
3848	SUBROUTINE mpplnks( parr ) ! Dummy routine
3849	REAL, DIMENSION(:,:) :: parr
3850	WRITE(,) 'mpplnks: You should not have seen this print! error?', parr(1,1)
3851	END SUBROUTINE mpplnks
3852
3853	SUBROUTINE mppisl_a_int( karr, kdim )
3854	INTEGER, DIMENSION(:) :: karr
3855	INTEGER :: kdim
3856	WRITE(,) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1)
3857	END SUBROUTINE mppisl_a_int
3858
3859	SUBROUTINE mppisl_int( kint )
3860	INTEGER :: kint
3861	WRITE(,) 'mppisl_int: You should not have seen this print! error?', kint
3862	END SUBROUTINE mppisl_int
3863
3864	SUBROUTINE mppisl_a_real( parr, kdim )
3865	REAL , DIMENSION(:) :: parr
3866	INTEGER :: kdim
3867	WRITE(,) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1)
3868	END SUBROUTINE mppisl_a_real
3869
3870	SUBROUTINE mppisl_real( psca )
3871	REAL :: psca
3872	WRITE(,) 'mppisl_real: You should not have seen this print! error?', psca
3873	END SUBROUTINE mppisl_real
3874
3875	SUBROUTINE mpp_minloc2d ( ptab, pmask, pmin, ki, kj )
3876	REAL :: pmin
3877	REAL , DIMENSION (:,:) :: ptab, pmask
3878	INTEGER :: ki, kj
3879	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj
3880	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3881	END SUBROUTINE mpp_minloc2d
3882
3883	SUBROUTINE mpp_minloc3d ( ptab, pmask, pmin, ki, kj, kk )
3884	REAL :: pmin
3885	REAL , DIMENSION (:,:,:) :: ptab, pmask
3886	INTEGER :: ki, kj, kk
3887	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj, kk
3888	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3889	END SUBROUTINE mpp_minloc3d
3890
3891	SUBROUTINE mpp_maxloc2d ( ptab, pmask, pmax, ki, kj )
3892	REAL :: pmax
3893	REAL , DIMENSION (:,:) :: ptab, pmask
3894	INTEGER :: ki, kj
3895	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj
3896	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3897	END SUBROUTINE mpp_maxloc2d
3898
3899	SUBROUTINE mpp_maxloc3d ( ptab, pmask, pmax, ki, kj, kk )
3900	REAL :: pmax
3901	REAL , DIMENSION (:,:,:) :: ptab, pmask
3902	INTEGER :: ki, kj, kk
3903	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj, kk
3904	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3905	END SUBROUTINE mpp_maxloc3d
3906
3907	SUBROUTINE mppstop
3908	WRITE(,) 'mppstop: You should not have seen this print! error?'
3909	END SUBROUTINE mppstop
3910
3911	#endif
3912	!!----------------------------------------------------------------------
3913	END MODULE lib_mpp

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

Download in other formats: