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

Last change on this file since 642 was 635, checked in by opalod, 17 years ago
nemo_v2_update_007:RB: add key_mpp_dyndist for dynamic distribution with key_agrif activated
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 177.1 KB

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

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

Download in other formats: