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

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

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

Download in other formats: