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 branches/dev_003_CPL/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/dev_003_CPL/NEMO/OPA_SRC/lib_mpp.F90 @ 991

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

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

Download in other formats: