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

Last change on this file since 389 was 389, checked in by opalod, 18 years ago

RB:nemo_v1_update_038: first integration of Agrif :

configuration parameters are just integer when agrif is used
add call to agrif routines with key_agrif

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 153.7 KB

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

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

Download in other formats: