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

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

lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

Context Navigation

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

Last change on this file since 1213 was 1209, checked in by rblod, 16 years ago
Correct a stupid mistake I did in previous commit, and desesperately trying to reach 1210 revison number for the release
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 185.3 KB

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

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

Download in other formats: