New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/lib_mpp.F90 @ 812

Last change on this file since 812 was 719, checked in by ctlod, 17 years ago
get back to the nemo_v2_3 version for trunk
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 180.7 KB

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

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

Download in other formats: