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

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

lib_mpp.F90 in branches/dev_001_SBC/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/dev_001_SBC/NEMO/OPA_SRC/lib_mpp.F90 @ 885

Last change on this file since 885 was 717, checked in by smasson, 17 years ago
finalize the first set of modifications related to ticket:3
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 181.1 KB

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

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

Download in other formats: