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

Last change on this file since 247 was 247, checked in by opalod, 19 years ago
CL : Add CVS Header and CeCILL licence information
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 127.6 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	!! mpplnks
17	!! mpprecv
18	!! mppsend
19	!! mppscatter
20	!! mppgather
21	!! mpp_isl : generic inteface for :
22	!! mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real
23	!! mpp_min : generic interface for :
24	!! mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
25	!! mpp_max : generic interface for :
26	!! mppmax_real, mppmax_a_real
27	!! mpp_sum : generic interface for :
28	!! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
29	!! mppsync
30	!! mppstop
31	!! mppobc : variant of mpp_lnk for open boundaries
32	!! mpp_ini_north
33	!! mpp_lbc_north
34	!!----------------------------------------------------------------------
35	!! History :
36	!! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code
37	!! ! 97 (A.M. Treguier) SHMEM additions
38	!! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
39	!! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form
40	!! ! 04 (R. Bourdalle Badie) isend option in mpi
41	!! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
42	!!----------------------------------------------------------------------
43	!! OPA 9.0 , LOCEAN-IPSL (2005)
44	!! $Header$
45	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
46	!!---------------------------------------------------------------------
47	!! * Modules used
48	USE dom_oce ! ocean space and time domain
49	USE in_out_manager ! I/O manager
50
51	IMPLICIT NONE
52
53	!! * Interfaces
54	!! define generic interface for these routine as they are called sometimes
55	!! with scalar arguments instead of array arguments, which causes problems
56	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
57
58	INTERFACE mpp_isl
59	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
60	END INTERFACE
61	INTERFACE mpp_min
62	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
63	END INTERFACE
64	INTERFACE mpp_max
65	MODULE PROCEDURE mppmax_a_real, mppmax_real
66	END INTERFACE
67	INTERFACE mpp_sum
68	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
69	END INTERFACE
70	INTERFACE mpp_lbc_north
71	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
72	END INTERFACE
73	INTERFACE mpp_minloc
74	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
75	END INTERFACE
76	INTERFACE mpp_maxloc
77	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
78	END INTERFACE
79
80
81	!! * Share module variables
82	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
83	LOGICAL, PUBLIC :: lk_bsend = .FALSE. !: mpp_bsend flag
84	LOGICAL, PUBLIC :: lk_isend = .FALSE. !: mpp_isend flag
85
86
87	!! * Module variables
88	!! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
89	INTEGER, PARAMETER :: &
90	nprocmax = 2**10, & ! maximun dimension
91	ndim_mpp = jpnij ! dimension for this simulation
92
93	#if defined key_mpp_mpi
94	!! ========================= !!
95	!! MPI variable definition !!
96	!! ========================= !!
97	# include <mpif.h>
98
99	INTEGER :: &
100	size, & ! number of process
101	rank ! process number [ 0 - size-1 ]
102
103	! variables used in case of north fold condition in mpp_mpi with jpni > 1
104	INTEGER :: & !
105	ngrp_world, & ! group ID for the world processors
106	ngrp_north, & ! group ID for the northern processors (to be fold)
107	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
108	ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !)
109	njmppmax ! value of njmpp for the processors of the northern line
110	INTEGER :: & !
111	north_root ! number (in the comm_world) of proc 0 in the northern comm
112	INTEGER, DIMENSION(:), ALLOCATABLE :: &
113	nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
114
115
116	#elif defined key_mpp_shmem
117	!! ========================= !!
118	!! SHMEM variable definition !!
119	!! ========================= !!
120	# include <fpvm3.h>
121	# include <mpp/shmem.fh>
122
123	CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name
124	CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name
125	CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall())
126
127	INTEGER, PARAMETER :: & !! SHMEM control print
128	mynode_print = 0, & ! flag for print, mynode routine
129	mpprecv_print = 0, & ! flag for print, mpprecv routine
130	mppsend_print = 0, & ! flag for print, mppsend routine
131	mppsync_print = 0, & ! flag for print, mppsync routine
132	mppsum_print = 0, & ! flag for print, mpp_sum routine
133	mppisl_print = 0, & ! flag for print, mpp_isl routine
134	mppmin_print = 0, & ! flag for print, mpp_min routine
135	mppmax_print = 0, & ! flag for print, mpp_max routine
136	mpparent_print = 0 ! flag for print, mpparent routine
137
138	INTEGER, PARAMETER :: & !! Variable definition
139	jpvmint = 21 ! ???
140
141	INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors
142	jpmsec = 50000, & ! ???
143	jpmpplat = 30, & ! ???
144	jpmppsum = MAX( jpisljpisl, jpmpplatjpk, jpmsec ) ! ???
145
146	INTEGER :: &
147	npvm_ipas , & ! pvm initialization flag
148	npvm_mytid, & ! pvm tid
149	npvm_me , & ! node number [ 0 - nproc-1 ]
150	npvm_nproc, & ! real number of nodes
151	npvm_inum ! ???
152	INTEGER, DIMENSION(0:nprocmax-1) :: &
153	npvm_tids ! tids array [ 0 - nproc-1 ]
154
155	INTEGER :: &
156	nt3d_ipas , & ! pvm initialization flag
157	nt3d_mytid, & ! pvm tid
158	nt3d_me , & ! node number [ 0 - nproc-1 ]
159	nt3d_nproc ! real number of nodes
160	INTEGER, DIMENSION(0:nprocmax-1) :: &
161	nt3d_tids ! tids array [ 0 - nproc-1 ]
162
163	!! real sum reduction
164	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
165	nrs1sync_shmem, & !
166	nrs2sync_shmem
167	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
168	wrs1wrk_shmem, & !
169	wrs2wrk_shmem !
170	REAL(wp), DIMENSION(jpmppsum) :: &
171	wrstab_shmem !
172
173	!! minimum and maximum reduction
174	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
175	ni1sync_shmem, & !
176	ni2sync_shmem !
177	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
178	wi1wrk_shmem, & !
179	wi2wrk_shmem
180	REAL(wp), DIMENSION(jpmppsum) :: &
181	wintab_shmem, & !
182	wi1tab_shmem, & !
183	wi2tab_shmem !
184
185	!! value not equal zero for barotropic stream function around islands
186	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
187	ni11sync_shmem, & !
188	ni12sync_shmem, & !
189	ni21sync_shmem, & !
190	ni22sync_shmem !
191	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
192	wi11wrk_shmem, & !
193	wi12wrk_shmem, & !
194	wi21wrk_shmem, & !
195	wi22wrk_shmem !
196	REAL(wp), DIMENSION(jpmppsum) :: &
197	wiltab_shmem , & !
198	wi11tab_shmem, & !
199	wi12tab_shmem, & !
200	wi21tab_shmem, & !
201	wi22tab_shmem
202
203	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
204	ni11wrk_shmem, & !
205	ni12wrk_shmem, & !
206	ni21wrk_shmem, & !
207	ni22wrk_shmem !
208	INTEGER, DIMENSION(jpmppsum) :: &
209	niitab_shmem , & !
210	ni11tab_shmem, & !
211	ni12tab_shmem !
212	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
213	nis1sync_shmem, & !
214	nis2sync_shmem !
215	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
216	nis1wrk_shmem, & !
217	nis2wrk_shmem !
218	INTEGER, DIMENSION(jpmppsum) :: &
219	nistab_shmem
220
221	!! integer sum reduction
222	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
223	nil1sync_shmem, & !
224	nil2sync_shmem !
225	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
226	nil1wrk_shmem, & !
227	nil2wrk_shmem !
228	INTEGER, DIMENSION(jpmppsum) :: &
229	niltab_shmem
230	#endif
231
232	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
233	t3ns, t3sn ! 3d message passing arrays north-south & south-north
234	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &
235	t3ew, t3we ! 3d message passing arrays east-west & west-east
236	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
237	t3p1, t3p2 ! 3d message passing arrays north fold
238	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
239	t2ns, t2sn ! 2d message passing arrays north-south & south-north
240	REAL(wp), DIMENSION(jpj,jpreci,2) :: &
241	t2ew, t2we ! 2d message passing arrays east-west & west-east
242	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
243	t2p1, t2p2 ! 2d message passing arrays north fold
244	!!----------------------------------------------------------------------
245	!! OPA 9.0 , LOCEAN-IPSL (2005)
246	!! $Header$
247	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
248	!!---------------------------------------------------------------------
249
250	CONTAINS
251
252	FUNCTION mynode()
253	!!----------------------------------------------------------------------
254	!! * routine mynode *
255	!!
256	!! ** Purpose : Find processor unit
257	!!
258	!!----------------------------------------------------------------------
259	#if defined key_mpp_mpi
260	!! * Local variables (MPI version)
261	INTEGER :: mynode, ierr
262	!!----------------------------------------------------------------------
263	! Enroll in MPI
264	! -------------
265	# if defined key_mpi_bsend
266	lk_bsend = .TRUE. !: mpp_bsend flag
267	# endif
268	# if defined key_mpi_isend
269	lk_isend = .TRUE. !: mpp_isend flag
270	# endif
271
272	IF(lk_bsend) THEN
273	CALL mpi_init_opa( ierr )
274	ELSE
275	CALL mpi_init( ierr )
276	ENDIF
277	CALL mpi_comm_rank( mpi_comm_world, rank, ierr )
278	CALL mpi_comm_size( mpi_comm_world, size, ierr )
279	mynode = rank
280	#else
281	!! * Local variables (SHMEM version)
282	INTEGER :: mynode
283	INTEGER :: &
284	imypid, imyhost, ji, info, iparent_tid
285	!!----------------------------------------------------------------------
286
287	IF( npvm_ipas /= nprocmax ) THEN
288	! --- first passage in mynode
289	! -------------
290	! enroll in pvm
291	! -------------
292	CALL pvmfmytid( npvm_mytid )
293	IF( mynode_print /= 0 ) THEN
294	WRITE(numout,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
295	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
296	ENDIF
297
298	! ---------------------------------------------------------------
299	! find out IF i am parent or child spawned processes have parents
300	! ---------------------------------------------------------------
301	CALL mpparent( iparent_tid )
302	IF( mynode_print /= 0 ) THEN
303	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
304	& ' after mpparent, npvm_tids(0) = ', &
305	& npvm_tids(0), ' iparent_tid=', iparent_tid
306	ENDIF
307	IF( iparent_tid < 0 ) THEN
308	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
309	& ' after mpparent, npvm_tids(0) = ', &
310	& npvm_tids(0), ' iparent_tid=', iparent_tid
311	npvm_tids(0) = npvm_mytid
312	npvm_me = 0
313	IF( ndim_mpp > nprocmax ) THEN
314	WRITE(numout,*) 'npvm_mytid=', npvm_mytid, ' too great'
315	STOP ' mynode '
316	ELSE
317	npvm_nproc = ndim_mpp
318	ENDIF
319
320	! -------------------------
321	! start up copies of myself
322	! -------------------------
323	IF( npvm_nproc > 1 ) THEN
324	DO ji = 1, npvm_nproc-1
325	npvm_tids(ji) = nt3d_tids(ji)
326	END DO
327	info=npvm_nproc-1
328
329	IF( mynode_print /= 0 ) THEN
330	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
331	& ' maitre=',executable,' info=', info &
332	& ,' npvm_nproc=',npvm_nproc
333	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
334	& ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
335	ENDIF
336
337	! ---------------------------
338	! multicast tids array to children
339	! ---------------------------
340	CALL pvmfinitsend( pvmdefault, info )
341	CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info )
342	CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
343	CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
344	ENDIF
345	ELSE
346
347	! ---------------------------------
348	! receive the tids array and set me
349	! ---------------------------------
350	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
351	CALL pvmfrecv( iparent_tid, 10, info )
352	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
353	CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info )
354	CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
355	IF( mynode_print /= 0 ) THEN
356	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
357	& ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
358	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
359	& 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
360	ENDIF
361	DO ji = 0, npvm_nproc-1
362	IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
363	END DO
364	ENDIF
365
366	! ------------------------------------------------------------
367	! all nproc tasks are equal now
368	! and can address each other by tids(0) thru tids(nproc-1)
369	! for each process me => process number [0-(nproc-1)]
370	! ------------------------------------------------------------
371	CALL pvmfjoingroup ( "bidon", info )
372	CALL pvmfbarrier ( "bidon", npvm_nproc, info )
373	DO ji = 0, npvm_nproc-1
374	IF( ji == npvm_me ) THEN
375	CALL pvmfjoingroup ( opaall, npvm_inum )
376	IF( npvm_inum /= npvm_me ) WRITE(numout,*) 'mynode not arrived in the good order for opaall'
377	ENDIF
378	CALL pvmfbarrier( "bidon", npvm_nproc, info )
379	END DO
380	CALL pvmfbarrier( opaall, npvm_nproc, info )
381
382	ELSE
383	! --- other passage in mynode
384	ENDIF
385
386	npvm_ipas = nprocmax
387	mynode = npvm_me
388	imypid = npvm_mytid
389	imyhost = npvm_tids(0)
390	IF( mynode_print /= 0 ) THEN
391	WRITE(numout,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, &
392	& ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
393	ENDIF
394	#endif
395	END FUNCTION mynode
396
397
398	SUBROUTINE mpparent( kparent_tid )
399	!!----------------------------------------------------------------------
400	!! * routine mpparent *
401	!!
402	!! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem)
403	!! or only return -1 (key_mpp_mpi)
404	!!----------------------------------------------------------------------
405	!! * Arguments
406	INTEGER, INTENT(inout) :: kparent_tid ! ???
407
408	#if defined key_mpp_mpi
409	! MPI version : retour -1
410
411	kparent_tid = -1
412
413	#else
414	!! * Local variables (SHMEN onto T3E version)
415	INTEGER :: &
416	it3d_my_pe, LEADZ, ji, info
417
418	CALL pvmfmytid( nt3d_mytid )
419	CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
420	IF( mpparent_print /= 0 ) THEN
421	WRITE(numout,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
422	ENDIF
423	IF( it3d_my_pe == 0 ) THEN
424	!-----------------------------------------------------------------!
425	! process = 0 => receive other tids !
426	!-----------------------------------------------------------------!
427	kparent_tid = -1
428	IF(mpparent_print /= 0 ) THEN
429	WRITE(numout,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
430	ENDIF
431	! --- END receive dimension ---
432	IF( ndim_mpp > nprocmax ) THEN
433	WRITE(numout,*) 'mytid=',nt3d_mytid,' too great'
434	STOP ' mpparent '
435	ELSE
436	nt3d_nproc = ndim_mpp
437	ENDIF
438	IF( mpparent_print /= 0 ) THEN
439	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
440	ENDIF
441	!-------- receive tids from others process --------
442	DO ji = 1, nt3d_nproc-1
443	CALL pvmfrecv( ji , 100, info )
444	CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
445	IF( mpparent_print /= 0 ) THEN
446	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
447	ENDIF
448	END DO
449	nt3d_tids(0) = nt3d_mytid
450	IF( mpparent_print /= 0 ) THEN
451	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), &
452	ji = 0, nt3d_nproc-1 )
453	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
454	ENDIF
455
456	ELSE
457	!!----------------------------------------------------------------!
458	! process <> 0 => send other tids !
459	!!----------------------------------------------------------------!
460	kparent_tid = 0
461	CALL pvmfinitsend( pvmdataraw, info )
462	CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
463	CALL pvmfsend( kparent_tid, 100, info )
464	ENDIF
465	#endif
466
467	END SUBROUTINE mpparent
468
469	#if defined key_mpp_shmem
470
471	SUBROUTINE mppshmem
472	!!----------------------------------------------------------------------
473	!! * routine mppshmem *
474	!!
475	!! ** Purpose : SHMEM ROUTINE
476	!!
477	!!----------------------------------------------------------------------
478	nrs1sync_shmem = SHMEM_SYNC_VALUE
479	nrs2sync_shmem = SHMEM_SYNC_VALUE
480	nis1sync_shmem = SHMEM_SYNC_VALUE
481	nis2sync_shmem = SHMEM_SYNC_VALUE
482	nil1sync_shmem = SHMEM_SYNC_VALUE
483	nil2sync_shmem = SHMEM_SYNC_VALUE
484	ni11sync_shmem = SHMEM_SYNC_VALUE
485	ni12sync_shmem = SHMEM_SYNC_VALUE
486	ni21sync_shmem = SHMEM_SYNC_VALUE
487	ni22sync_shmem = SHMEM_SYNC_VALUE
488	CALL barrier()
489
490	END SUBROUTINE mppshmem
491
492	#endif
493
494	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )
495	!!----------------------------------------------------------------------
496	!! * routine mpp_lnk_3d *
497	!!
498	!! ** Purpose : Message passing manadgement
499	!!
500	!! ** Method : Use mppsend and mpprecv function for passing mask
501	!! between processors following neighboring subdomains.
502	!! domain parameters
503	!! nlci : first dimension of the local subdomain
504	!! nlcj : second dimension of the local subdomain
505	!! nbondi : mark for "east-west local boundary"
506	!! nbondj : mark for "north-south local boundary"
507	!! noea : number for local neighboring processors
508	!! nowe : number for local neighboring processors
509	!! noso : number for local neighboring processors
510	!! nono : number for local neighboring processors
511	!!
512	!! ** Action : ptab with update value at its periphery
513	!!
514	!!----------------------------------------------------------------------
515	!! * Arguments
516	CHARACTER(len=1) , INTENT( in ) :: &
517	cd_type ! define the nature of ptab array grid-points
518	! ! = T , U , V , F , W points
519	! ! = S : T-point, north fold treatment ???
520	! ! = G : F-point, north fold treatment ???
521	REAL(wp), INTENT( in ) :: &
522	psgn ! control of the sign change
523	! ! = -1. , the sign is changed if north fold boundary
524	! ! = 1. , the sign is kept if north fold boundary
525	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
526	ptab ! 3D array on which the boundary condition is applied
527
528	!! * Local variables
529	INTEGER :: ji, jk, jl ! dummy loop indices
530	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
531	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
532	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
533	!!----------------------------------------------------------------------
534
535	! 1. standard boundary treatment
536	! ------------------------------
537	! ! East-West boundaries
538	! ! ====================
539	IF( nbondi == 2 .AND. & ! Cyclic east-west
540	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
541	ptab( 1 ,:,:) = ptab(jpim1,:,:)
542	ptab(jpi,:,:) = ptab( 2 ,:,:)
543
544	ELSE ! closed
545	SELECT CASE ( cd_type )
546	CASE ( 'T', 'U', 'V', 'W' )
547	ptab( 1 :jpreci,:,:) = 0.e0
548	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
549	CASE ( 'F' )
550	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
551	END SELECT
552	ENDIF
553
554	! ! North-South boundaries
555	! ! ======================
556	SELECT CASE ( cd_type )
557	CASE ( 'T', 'U', 'V', 'W' )
558	ptab(:, 1 :jprecj,:) = 0.e0
559	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
560	CASE ( 'F' )
561	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
562	END SELECT
563
564
565	! 2. East and west directions exchange
566	! ------------------------------------
567
568	! 2.1 Read Dirichlet lateral conditions
569
570	SELECT CASE ( nbondi )
571	CASE ( -1, 0, 1 ) ! all exept 2
572	iihom = nlci-nreci
573	DO jl = 1, jpreci
574	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
575	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
576	END DO
577	END SELECT
578
579	! 2.2 Migrations
580
581	#if defined key_mpp_shmem
582	!! * SHMEM version
583
584	imigr = jpreci * jpj * jpk
585
586	SELECT CASE ( nbondi )
587	CASE ( -1 )
588	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
589	CASE ( 0 )
590	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
591	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
592	CASE ( 1 )
593	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
594	END SELECT
595
596	CALL barrier()
597	CALL shmem_udcflush()
598
599	#elif defined key_mpp_mpi
600	!! * Local variables (MPI version)
601
602	imigr = jpreci * jpj * jpk
603
604	SELECT CASE ( nbondi )
605	CASE ( -1 )
606	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
607	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
608	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
609	CASE ( 0 )
610	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
611	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
612	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
613	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
614	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
615	IF(lk_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
616	CASE ( 1 )
617	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
618	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
619	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
620	END SELECT
621	#endif
622
623	! 2.3 Write Dirichlet lateral conditions
624
625	iihom = nlci-jpreci
626
627	SELECT CASE ( nbondi )
628	CASE ( -1 )
629	DO jl = 1, jpreci
630	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
631	END DO
632	CASE ( 0 )
633	DO jl = 1, jpreci
634	ptab(jl ,:,:) = t3we(:,jl,:,2)
635	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
636	END DO
637	CASE ( 1 )
638	DO jl = 1, jpreci
639	ptab(jl ,:,:) = t3we(:,jl,:,2)
640	END DO
641	END SELECT
642
643
644	! 3. North and south directions
645	! -----------------------------
646
647	! 3.1 Read Dirichlet lateral conditions
648
649	IF( nbondj /= 2 ) THEN
650	ijhom = nlcj-nrecj
651	DO jl = 1, jprecj
652	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
653	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
654	END DO
655	ENDIF
656
657	! 3.2 Migrations
658
659	#if defined key_mpp_shmem
660	!! * SHMEM version
661
662	imigr = jprecj * jpi * jpk
663
664	SELECT CASE ( nbondj )
665	CASE ( -1 )
666	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
667	CASE ( 0 )
668	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
669	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
670	CASE ( 1 )
671	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
672	END SELECT
673
674	CALL barrier()
675	CALL shmem_udcflush()
676
677	#elif defined key_mpp_mpi
678	!! * Local variables (MPI version)
679
680	imigr=jprecjjpijpk
681
682	SELECT CASE ( nbondj )
683	CASE ( -1 )
684	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
685	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
686	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
687	CASE ( 0 )
688	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
689	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
690	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
691	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
692	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
693	IF(lk_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
694	CASE ( 1 )
695	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
696	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
697	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
698	END SELECT
699
700	#endif
701
702	! 3.3 Write Dirichlet lateral conditions
703
704	ijhom = nlcj-jprecj
705
706	SELECT CASE ( nbondj )
707	CASE ( -1 )
708	DO jl = 1, jprecj
709	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
710	END DO
711	CASE ( 0 )
712	DO jl = 1, jprecj
713	ptab(:,jl ,:) = t3sn(:,jl,:,2)
714	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
715	END DO
716	CASE ( 1 )
717	DO jl = 1, jprecj
718	ptab(:,jl,:) = t3sn(:,jl,:,2)
719	END DO
720	END SELECT
721
722
723	! 4. north fold treatment
724	! -----------------------
725
726	! 4.1 treatment without exchange (jpni odd)
727	! T-point pivot
728
729	SELECT CASE ( jpni )
730
731	CASE ( 1 ) ! only one proc along I, no mpp exchange
732
733	SELECT CASE ( npolj )
734
735	CASE ( 3 , 4 ) ! T pivot
736	iloc = jpiglo - 2 * ( nimpp - 1 )
737
738	SELECT CASE ( cd_type )
739
740	CASE ( 'T' , 'S', 'W' )
741	DO jk = 1, jpk
742	DO ji = 2, nlci
743	ijt=iloc-ji+2
744	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
745	END DO
746	DO ji = nlci/2+1, nlci
747	ijt=iloc-ji+2
748	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
749	END DO
750	END DO
751
752	CASE ( 'U' )
753	DO jk = 1, jpk
754	DO ji = 1, nlci-1
755	iju=iloc-ji+1
756	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
757	END DO
758	DO ji = nlci/2, nlci-1
759	iju=iloc-ji+1
760	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
761	END DO
762	END DO
763
764	CASE ( 'V' )
765	DO jk = 1, jpk
766	DO ji = 2, nlci
767	ijt=iloc-ji+2
768	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
769	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)
770	END DO
771	END DO
772
773	CASE ( 'F', 'G' )
774	DO jk = 1, jpk
775	DO ji = 1, nlci-1
776	iju=iloc-ji+1
777	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-2,jk)
778	ptab(ji,nlcj ,jk) = psgn * ptab(iju,nlcj-3,jk)
779	END DO
780	END DO
781
782	END SELECT
783
784	CASE ( 5 , 6 ) ! F pivot
785	iloc=jpiglo-2*(nimpp-1)
786
787	SELECT CASE ( cd_type )
788
789	CASE ( 'T' , 'S', 'W' )
790	DO jk = 1, jpk
791	DO ji = 1, nlci
792	ijt=iloc-ji+1
793	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
794	END DO
795	END DO
796
797	CASE ( 'U' )
798	DO jk = 1, jpk
799	DO ji = 1, nlci-1
800	iju=iloc-ji
801	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
802	END DO
803	END DO
804
805	CASE ( 'V' )
806	DO jk = 1, jpk
807	DO ji = 1, nlci
808	ijt=iloc-ji+1
809	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)
810	END DO
811	DO ji = nlci/2+1, nlci
812	ijt=iloc-ji+1
813	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
814	END DO
815	END DO
816
817	CASE ( 'F', 'G' )
818	DO jk = 1, jpk
819	DO ji = 1, nlci-1
820	iju=iloc-ji
821	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
822	END DO
823	DO ji = nlci/2+1, nlci-1
824	iju=iloc-ji
825	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
826	END DO
827	END DO
828	END SELECT ! cd_type
829
830	END SELECT ! npolj
831
832	CASE DEFAULT ! more than 1 proc along I
833	IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.
834
835	END SELECT ! jpni
836
837
838	! 5. East and west directions exchange
839	! ------------------------------------
840
841	SELECT CASE ( npolj )
842
843	CASE ( 3, 4, 5, 6 )
844
845	! 5.1 Read Dirichlet lateral conditions
846
847	SELECT CASE ( nbondi )
848
849	CASE ( -1, 0, 1 )
850	iihom = nlci-nreci
851	DO jl = 1, jpreci
852	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
853	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
854	END DO
855
856	END SELECT
857
858	! 5.2 Migrations
859
860	#if defined key_mpp_shmem
861	!! SHMEM version
862
863	imigr = jpreci * jpj * jpk
864
865	SELECT CASE ( nbondi )
866	CASE ( -1 )
867	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
868	CASE ( 0 )
869	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
870	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
871	CASE ( 1 )
872	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
873	END SELECT
874
875	CALL barrier()
876	CALL shmem_udcflush()
877
878	#elif defined key_mpp_mpi
879	!! MPI version
880
881	imigr=jprecijpjjpk
882
883	SELECT CASE ( nbondi )
884	CASE ( -1 )
885	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
886	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
887	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
888	CASE ( 0 )
889	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
890	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
891	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
892	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
893	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
894	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
895	CASE ( 1 )
896	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
897	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
898	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
899	END SELECT
900	#endif
901
902	! 5.3 Write Dirichlet lateral conditions
903
904	iihom = nlci-jpreci
905
906	SELECT CASE ( nbondi)
907	CASE ( -1 )
908	DO jl = 1, jpreci
909	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
910	END DO
911	CASE ( 0 )
912	DO jl = 1, jpreci
913	ptab(jl ,:,:) = t3we(:,jl,:,2)
914	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
915	END DO
916	CASE ( 1 )
917	DO jl = 1, jpreci
918	ptab(jl ,:,:) = t3we(:,jl,:,2)
919	END DO
920	END SELECT
921
922	END SELECT ! npolj
923
924	END SUBROUTINE mpp_lnk_3d
925
926
927	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn )
928	!!----------------------------------------------------------------------
929	!! * routine mpp_lnk_2d *
930	!!
931	!! ** Purpose : Message passing manadgement for 2d array
932	!!
933	!! ** Method : Use mppsend and mpprecv function for passing mask
934	!! between processors following neighboring subdomains.
935	!! domain parameters
936	!! nlci : first dimension of the local subdomain
937	!! nlcj : second dimension of the local subdomain
938	!! nbondi : mark for "east-west local boundary"
939	!! nbondj : mark for "north-south local boundary"
940	!! noea : number for local neighboring processors
941	!! nowe : number for local neighboring processors
942	!! noso : number for local neighboring processors
943	!! nono : number for local neighboring processors
944	!!
945	!!----------------------------------------------------------------------
946	!! * Arguments
947	CHARACTER(len=1) , INTENT( in ) :: &
948	cd_type ! define the nature of pt2d array grid-points
949	! ! = T , U , V , F , W
950	! ! = S : T-point, north fold treatment
951	! ! = G : F-point, north fold treatment
952	! ! = I : sea-ice velocity at F-point with index shift
953	REAL(wp), INTENT( in ) :: &
954	psgn ! control of the sign change
955	! ! = -1. , the sign is changed if north fold boundary
956	! ! = 1. , the sign is kept if north fold boundary
957	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
958	pt2d ! 2D array on which the boundary condition is applied
959
960	!! * Local variables
961	INTEGER :: ji, jj, jl ! dummy loop indices
962	INTEGER :: &
963	imigr, iihom, ijhom, & ! temporary integers
964	iloc, ijt, iju ! " "
965	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
966	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
967	!!----------------------------------------------------------------------
968
969	! 1. standard boundary treatment
970	! ------------------------------
971
972	! ! East-West boundaries
973	! ! ====================
974	IF( nbondi == 2 .AND. & ! Cyclic east-west
975	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
976	pt2d( 1 ,:) = pt2d(jpim1,:)
977	pt2d(jpi,:) = pt2d( 2 ,:)
978
979	ELSE ! ... closed
980	SELECT CASE ( cd_type )
981	CASE ( 'T', 'U', 'V', 'W' , 'I' )
982	pt2d( 1 :jpreci,:) = 0.e0
983	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
984	CASE ( 'F' )
985	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
986	END SELECT
987	ENDIF
988
989	! ! North-South boundaries
990	! ! ======================
991	SELECT CASE ( cd_type )
992	CASE ( 'T', 'U', 'V', 'W' , 'I' )
993	pt2d(:, 1 :jprecj) = 0.e0
994	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
995	CASE ( 'F' )
996	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
997	END SELECT
998
999
1000	! 2. East and west directions
1001	! ---------------------------
1002
1003	! 2.1 Read Dirichlet lateral conditions
1004
1005	SELECT CASE ( nbondi )
1006	CASE ( -1, 0, 1 ) ! all except 2
1007	iihom = nlci-nreci
1008	DO jl = 1, jpreci
1009	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1010	t2we(:,jl,1) = pt2d(iihom +jl,:)
1011	END DO
1012	END SELECT
1013
1014	! 2.2 Migrations
1015
1016	#if defined key_mpp_shmem
1017	!! * SHMEM version
1018
1019	imigr = jpreci * jpj
1020
1021	SELECT CASE ( nbondi )
1022	CASE ( -1 )
1023	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1024	CASE ( 0 )
1025	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1026	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1027	CASE ( 1 )
1028	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1029	END SELECT
1030
1031	CALL barrier()
1032	CALL shmem_udcflush()
1033
1034	#elif defined key_mpp_mpi
1035	!! * MPI version
1036
1037	imigr = jpreci * jpj
1038
1039	SELECT CASE ( nbondi )
1040	CASE ( -1 )
1041	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1042	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1043	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1044	CASE ( 0 )
1045	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1046	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1047	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1048	CALL mpprecv( 2, t2we(1,1,2), imigr )
1049	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1050	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1051	CASE ( 1 )
1052	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1053	CALL mpprecv( 2, t2we(1,1,2), imigr )
1054	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1055	END SELECT
1056
1057	#endif
1058
1059	! 2.3 Write Dirichlet lateral conditions
1060
1061	iihom = nlci - jpreci
1062	SELECT CASE ( nbondi )
1063	CASE ( -1 )
1064	DO jl = 1, jpreci
1065	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1066	END DO
1067	CASE ( 0 )
1068	DO jl = 1, jpreci
1069	pt2d(jl ,:) = t2we(:,jl,2)
1070	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1071	END DO
1072	CASE ( 1 )
1073	DO jl = 1, jpreci
1074	pt2d(jl ,:) = t2we(:,jl,2)
1075	END DO
1076	END SELECT
1077
1078
1079	! 3. North and south directions
1080	! -----------------------------
1081
1082	! 3.1 Read Dirichlet lateral conditions
1083
1084	IF( nbondj /= 2 ) THEN
1085	ijhom = nlcj-nrecj
1086	DO jl = 1, jprecj
1087	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1088	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1089	END DO
1090	ENDIF
1091
1092	! 3.2 Migrations
1093
1094	#if defined key_mpp_shmem
1095	!! * SHMEM version
1096
1097	imigr = jprecj * jpi
1098
1099	SELECT CASE ( nbondj )
1100	CASE ( -1 )
1101	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1102	CASE ( 0 )
1103	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1104	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1105	CASE ( 1 )
1106	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1107	END SELECT
1108	CALL barrier()
1109	CALL shmem_udcflush()
1110
1111	#elif defined key_mpp_mpi
1112	!! * MPI version
1113
1114	imigr = jprecj * jpi
1115
1116	SELECT CASE ( nbondj )
1117	CASE ( -1 )
1118	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1119	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1120	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1121	CASE ( 0 )
1122	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1123	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1124	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1125	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1126	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1127	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1128	CASE ( 1 )
1129	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1130	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1131	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1132	END SELECT
1133
1134	#endif
1135
1136	! 3.3 Write Dirichlet lateral conditions
1137
1138	ijhom = nlcj - jprecj
1139
1140	SELECT CASE ( nbondj )
1141	CASE ( -1 )
1142	DO jl = 1, jprecj
1143	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1144	END DO
1145	CASE ( 0 )
1146	DO jl = 1, jprecj
1147	pt2d(:,jl ) = t2sn(:,jl,2)
1148	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1149	END DO
1150	CASE ( 1 )
1151	DO jl = 1, jprecj
1152	pt2d(:,jl ) = t2sn(:,jl,2)
1153	END DO
1154	END SELECT
1155
1156
1157	! 4. north fold treatment
1158	! -----------------------
1159
1160	! 4.1 treatment without exchange (jpni odd)
1161
1162	SELECT CASE ( jpni )
1163
1164	CASE ( 1 ) ! only one proc along I, no mpp exchange
1165
1166	SELECT CASE ( npolj )
1167
1168	CASE ( 3 , 4 ) ! T pivot
1169	iloc = jpiglo - 2 * ( nimpp - 1 )
1170
1171	SELECT CASE ( cd_type )
1172
1173	CASE ( 'T' , 'S', 'W' )
1174	DO ji = 2, nlci
1175	ijt=iloc-ji+2
1176	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1177	END DO
1178	DO ji = nlci/2+1, nlci
1179	ijt=iloc-ji+2
1180	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1181	END DO
1182
1183	CASE ( 'U' )
1184	DO ji = 1, nlci-1
1185	iju=iloc-ji+1
1186	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1187	END DO
1188	DO ji = nlci/2, nlci-1
1189	iju=iloc-ji+1
1190	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1191	END DO
1192
1193	CASE ( 'V' )
1194	DO ji = 2, nlci
1195	ijt=iloc-ji+2
1196	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1197	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3)
1198	END DO
1199
1200	CASE ( 'F', 'G' )
1201	DO ji = 1, nlci-1
1202	iju=iloc-ji+1
1203	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-2)
1204	pt2d(ji,nlcj ) = psgn * pt2d(iju,nlcj-3)
1205	END DO
1206
1207	CASE ( 'I' ) ! ice U-V point
1208	pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1209	DO ji = 3, nlci
1210	iju = iloc - ji + 3
1211	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1212	END DO
1213
1214	END SELECT
1215
1216	CASE ( 5 , 6 ) ! F pivot
1217	iloc=jpiglo-2*(nimpp-1)
1218
1219	SELECT CASE (cd_type )
1220
1221	CASE ( 'T', 'S', 'W' )
1222	DO ji = 1, nlci
1223	ijt=iloc-ji+1
1224	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1225	END DO
1226
1227	CASE ( 'U' )
1228	DO ji = 1, nlci-1
1229	iju=iloc-ji
1230	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1231	END DO
1232
1233	CASE ( 'V' )
1234	DO ji = 1, nlci
1235	ijt=iloc-ji+1
1236	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2)
1237	END DO
1238	DO ji = nlci/2+1, nlci
1239	ijt=iloc-ji+1
1240	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1241	END DO
1242
1243	CASE ( 'F', 'G' )
1244	DO ji = 1, nlci-1
1245	iju=iloc-ji
1246	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1247	END DO
1248	DO ji = nlci/2+1, nlci-1
1249	iju=iloc-ji
1250	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1251	END DO
1252
1253	CASE ( 'I' ) ! ice U-V point
1254	pt2d( 2 ,nlcj) = 0.e0
1255	DO ji = 2 , nlci-1
1256	ijt = iloc - ji + 2
1257	pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) )
1258	END DO
1259
1260	END SELECT ! cd_type
1261
1262	END SELECT ! npolj
1263
1264	CASE DEFAULT ! more than 1 proc along I
1265	IF( npolj /= 0 ) CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! only for northern procs.
1266
1267	END SELECT ! jpni
1268
1269
1270	! 5. East and west directions
1271	! ---------------------------
1272
1273	SELECT CASE ( npolj )
1274
1275	CASE ( 3, 4, 5, 6 )
1276
1277	! 5.1 Read Dirichlet lateral conditions
1278
1279	SELECT CASE ( nbondi )
1280	CASE ( -1, 0, 1 )
1281	iihom = nlci-nreci
1282	DO jl = 1, jpreci
1283	DO jj = 1, jpj
1284	t2ew(jj,jl,1) = pt2d(jpreci+jl,jj)
1285	t2we(jj,jl,1) = pt2d(iihom +jl,jj)
1286	END DO
1287	END DO
1288	END SELECT
1289
1290	! 5.2 Migrations
1291
1292	#if defined key_mpp_shmem
1293	!! * SHMEM version
1294
1295	imigr=jpreci*jpj
1296
1297	SELECT CASE ( nbondi )
1298	CASE ( -1 )
1299	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1300	CASE ( 0 )
1301	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1302	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1303	CASE ( 1 )
1304	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1305	END SELECT
1306
1307	CALL barrier()
1308	CALL shmem_udcflush()
1309
1310	#elif defined key_mpp_mpi
1311	!! * MPI version
1312
1313	imigr=jpreci*jpj
1314
1315	SELECT CASE ( nbondi )
1316	CASE ( -1 )
1317	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1318	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1319	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1320	CASE ( 0 )
1321	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1322	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1323	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1324	CALL mpprecv( 2, t2we(1,1,2), imigr )
1325	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1326	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1327	CASE ( 1 )
1328	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1329	CALL mpprecv( 2, t2we(1,1,2), imigr )
1330	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1331	END SELECT
1332	#endif
1333
1334	! 5.3 Write Dirichlet lateral conditions
1335
1336	iihom = nlci - jpreci
1337
1338	SELECT CASE ( nbondi )
1339	CASE ( -1 )
1340	DO jl = 1, jpreci
1341	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1342	END DO
1343	CASE ( 0 )
1344	DO jl = 1, jpreci
1345	pt2d(jl ,:) = t2we(:,jl,2)
1346	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1347	END DO
1348	CASE ( 1 )
1349	DO jl = 1, jpreci
1350	pt2d(jl,:) = t2we(:,jl,2)
1351	END DO
1352	END SELECT
1353
1354	END SELECT ! npolj
1355
1356	END SUBROUTINE mpp_lnk_2d
1357
1358
1359	SUBROUTINE mpplnks( ptab )
1360	!!----------------------------------------------------------------------
1361	!! * routine mpplnks *
1362	!!
1363	!! ** Purpose : Message passing manadgement for add 2d array local boundary
1364	!!
1365	!! ** Method : Use mppsend and mpprecv function for passing mask between
1366	!! processors following neighboring subdomains.
1367	!! domain parameters
1368	!! nlci : first dimension of the local subdomain
1369	!! nlcj : second dimension of the local subdomain
1370	!! nbondi : mark for "east-west local boundary"
1371	!! nbondj : mark for "north-south local boundary"
1372	!! noea : number for local neighboring processors
1373	!! nowe : number for local neighboring processors
1374	!! noso : number for local neighboring processors
1375	!! nono : number for local neighboring processors
1376	!!
1377	!!----------------------------------------------------------------------
1378	!! * Arguments
1379	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: &
1380	ptab ! 2D array
1381
1382	!! * Local variables
1383	INTEGER :: ji, jl ! dummy loop indices
1384	INTEGER :: &
1385	imigr, iihom, ijhom ! temporary integers
1386	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1387	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1388	!!----------------------------------------------------------------------
1389
1390
1391	! 1. north fold treatment
1392	! -----------------------
1393
1394	! 1.1 treatment without exchange (jpni odd)
1395
1396	SELECT CASE ( npolj )
1397	CASE ( 4 )
1398	DO ji = 1, nlci
1399	ptab(ji,nlcj-2) = ptab(ji,nlcj-2) + t2p1(ji,1,1)
1400	END DO
1401	CASE ( 6 )
1402	DO ji = 1, nlci
1403	ptab(ji,nlcj-1) = ptab(ji,nlcj-1) + t2p1(ji,1,1)
1404	END DO
1405
1406	! 1.2 treatment with exchange (jpni greater than 1)
1407	!
1408	CASE ( 3 )
1409	#if defined key_mpp_shmem
1410
1411	!! * SHMEN version
1412
1413	imigr=jprecj*jpi
1414
1415	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
1416	CALL barrier()
1417	CALL shmem_udcflush()
1418
1419	# elif defined key_mpp_mpi
1420	!! * MPI version
1421
1422	imigr=jprecj*jpi
1423
1424	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
1425	CALL mpprecv(3,t2p1(1,1,2),imigr)
1426	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1427
1428	#endif
1429
1430	! Write north fold conditions
1431
1432	DO ji = 1, nlci
1433	ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2)
1434	END DO
1435
1436	CASE ( 5 )
1437
1438	#if defined key_mpp_shmem
1439
1440	!! * SHMEN version
1441
1442	imigr=jprecj*jpi
1443
1444	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
1445	CALL barrier()
1446	CALL shmem_udcflush()
1447
1448	# elif defined key_mpp_mpi
1449	!! * Local variables (MPI version)
1450
1451	imigr=jprecj*jpi
1452
1453	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
1454	CALL mpprecv(3,t2p1(1,1,2),imigr)
1455	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1456
1457	#endif
1458
1459	! Write north fold conditions
1460
1461	DO ji = 1, nlci
1462	ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,2)
1463	END DO
1464
1465	END SELECT
1466
1467
1468	! 2. East and west directions
1469	! ---------------------------
1470
1471	! 2.1 Read Dirichlet lateral conditions
1472
1473	iihom = nlci-jpreci
1474
1475	SELECT CASE ( nbondi )
1476
1477	CASE ( -1, 0, 1 ) ! all except 2
1478	DO jl = 1, jpreci
1479	t2ew(:,jl,1) = ptab( jl ,:)
1480	t2we(:,jl,1) = ptab(iihom+jl,:)
1481	END DO
1482	END SELECT
1483
1484	! 2.2 Migrations
1485
1486	#if defined key_mpp_shmem
1487
1488	!! * SHMEN version
1489
1490	imigr=jpreci*jpj
1491
1492	SELECT CASE ( nbondi )
1493
1494	CASE ( -1 )
1495	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
1496
1497	CASE ( 0 )
1498	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
1499	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
1500
1501	CASE ( 1 )
1502	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
1503
1504	END SELECT
1505	CALL barrier()
1506	CALL shmem_udcflush()
1507
1508	# elif defined key_mpp_mpi
1509	!! * Local variables (MPI version)
1510
1511	imigr=jpreci*jpj
1512
1513	SELECT CASE ( nbondi )
1514
1515	CASE ( -1 )
1516	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
1517	CALL mpprecv(1,t2ew(1,1,2),imigr)
1518	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1519	CASE ( 0 )
1520	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
1521	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
1522	CALL mpprecv(1,t2ew(1,1,2),imigr)
1523	CALL mpprecv(2,t2we(1,1,2),imigr)
1524	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1525	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1526
1527	CASE ( 1 )
1528	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
1529	CALL mpprecv(2,t2we(1,1,2),imigr)
1530	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1531
1532	END SELECT
1533
1534	#endif
1535
1536	! 2.3 Write Dirichlet lateral conditions
1537
1538	iihom = nlci-nreci
1539
1540	SELECT CASE ( nbondi )
1541
1542	CASE ( -1 )
1543	DO jl = 1, jpreci
1544	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
1545	END DO
1546
1547	CASE ( 0 )
1548	DO jl = 1, jpreci
1549	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
1550	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
1551	END DO
1552
1553	CASE ( 1 )
1554	DO jl = 1, jpreci
1555	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
1556	END DO
1557	END SELECT
1558
1559
1560	! 3. North and south directions
1561	! -----------------------------
1562
1563	! 3.1 Read Dirichlet lateral conditions
1564
1565	ijhom = nlcj-jprecj
1566
1567	SELECT CASE ( nbondj )
1568
1569	CASE ( -1, 0, 1 )
1570	DO jl = 1, jprecj
1571	t2sn(:,jl,1) = ptab(:,ijhom+jl)
1572	t2ns(:,jl,1) = ptab(:, jl )
1573	END DO
1574
1575	END SELECT
1576
1577	! 3.2 Migrations
1578
1579	#if defined key_mpp_shmem
1580
1581	!! * SHMEN version
1582
1583	imigr=jprecj*jpi
1584
1585	SELECT CASE ( nbondj )
1586
1587	CASE ( -1 )
1588	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
1589
1590	CASE ( 0 )
1591	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
1592	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
1593
1594	CASE ( 1 )
1595	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
1596
1597	END SELECT
1598	CALL barrier()
1599	CALL shmem_udcflush()
1600
1601	# elif defined key_mpp_mpi
1602	!! * Local variables (MPI version)
1603
1604	imigr=jprecj*jpi
1605
1606	SELECT CASE ( nbondj )
1607
1608	CASE ( -1 )
1609	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
1610	CALL mpprecv(3,t2ns(1,1,2),imigr)
1611	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1612
1613	CASE ( 0 )
1614	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
1615	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
1616	CALL mpprecv(3,t2ns(1,1,2),imigr)
1617	CALL mpprecv(4,t2sn(1,1,2),imigr)
1618	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1619	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1620
1621	CASE ( 1 )
1622	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
1623	CALL mpprecv(4,t2sn(1,1,2),imigr)
1624	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1625	END SELECT
1626
1627	#endif
1628
1629	! 3.3 Write Dirichlet lateral conditions
1630
1631	ijhom = nlcj-nrecj
1632
1633	SELECT CASE ( nbondj )
1634
1635	CASE ( -1 )
1636	DO jl = 1, jprecj
1637	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
1638	END DO
1639
1640	CASE ( 0 )
1641	DO jl = 1, jprecj
1642	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
1643	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
1644	END DO
1645
1646	CASE ( 1 )
1647	DO jl = 1, jprecj
1648	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
1649	END DO
1650
1651	END SELECT
1652
1653	END SUBROUTINE mpplnks
1654
1655
1656	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req)
1657	!!----------------------------------------------------------------------
1658	!! * routine mppsend *
1659	!!
1660	!! ** Purpose : Send messag passing array
1661	!!
1662	!!----------------------------------------------------------------------
1663	!! * Arguments
1664	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1665	INTEGER , INTENT( in ) :: kbytes, & ! size of the array pmess
1666	& kdest , & ! receive process number
1667	& ktyp, & ! Tag of the message
1668	& md_req ! Argument for isend
1669	!!----------------------------------------------------------------------
1670	#if defined key_mpp_shmem
1671	!! * SHMEM version : routine not used
1672
1673	#elif defined key_mpp_mpi
1674	!! * MPI version
1675	INTEGER :: iflag
1676
1677	IF(lk_bsend) THEN
1678	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1679	& mpi_comm_world, iflag )
1680	ELSEIF (lk_isend) THEN
1681	! Carefull here : one more argument for mpi_isend : the mpi request identifier..
1682	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1683	& mpi_comm_world, md_req, iflag )
1684	ELSE
1685	CALL mpi_send( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
1686	& mpi_comm_world, iflag )
1687	ENDIF
1688	#endif
1689
1690	END SUBROUTINE mppsend
1691
1692
1693	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
1694	!!----------------------------------------------------------------------
1695	!! * routine mpprecv *
1696	!!
1697	!! ** Purpose : Receive messag passing array
1698	!!
1699	!!----------------------------------------------------------------------
1700	!! * Arguments
1701	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
1702	INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess
1703	& ktyp ! Tag of the recevied message
1704	!!----------------------------------------------------------------------
1705	#if defined key_mpp_shmem
1706	!! * SHMEM version : routine not used
1707
1708	# elif defined key_mpp_mpi
1709	!! * MPI version
1710	INTEGER :: istatus(mpi_status_size)
1711	INTEGER :: iflag
1712
1713	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, &
1714	& mpi_comm_world, istatus, iflag )
1715	#endif
1716
1717	END SUBROUTINE mpprecv
1718
1719
1720	SUBROUTINE mppgather( ptab, kp, pio )
1721	!!----------------------------------------------------------------------
1722	!! * routine mppgather *
1723	!!
1724	!! ** Purpose : Transfert between a local subdomain array and a work
1725	!! array which is distributed following the vertical level.
1726	!!
1727	!! ** Method :
1728	!!
1729	!!----------------------------------------------------------------------
1730	!! * Arguments
1731	REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ptab ! subdomain input array
1732	INTEGER , INTENT( in ) :: kp ! record length
1733	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: pio ! subdomain input array
1734	!!---------------------------------------------------------------------
1735	#if defined key_mpp_shmem
1736	!! * SHMEM version
1737
1738	CALL barrier()
1739	CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp )
1740	CALL barrier()
1741
1742	#elif defined key_mpp_mpi
1743	!! * Local variables (MPI version)
1744	INTEGER :: itaille,ierror
1745
1746	itaille=jpi*jpj
1747	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille, &
1748	& mpi_double_precision, kp , mpi_comm_world, ierror )
1749	#endif
1750
1751	END SUBROUTINE mppgather
1752
1753
1754	SUBROUTINE mppscatter( pio, kp, ptab )
1755	!!----------------------------------------------------------------------
1756	!! * routine mppscatter *
1757	!!
1758	!! ** Purpose : Transfert between awork array which is distributed
1759	!! following the vertical level and the local subdomain array.
1760	!!
1761	!! ** Method :
1762	!!
1763	!!----------------------------------------------------------------------
1764	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
1765	INTEGER :: kp ! Tag (not used with MPI
1766	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
1767	!!---------------------------------------------------------------------
1768	#if defined key_mpp_shmem
1769	!! * SHMEM version
1770
1771	CALL barrier()
1772	CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp )
1773	CALL barrier()
1774
1775	# elif defined key_mpp_mpi
1776	!! * Local variables (MPI version)
1777	INTEGER :: itaille, ierror
1778
1779	itaille=jpi*jpj
1780
1781	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille, &
1782	& mpi_double_precision, kp, mpi_comm_world, ierror )
1783	#endif
1784
1785	END SUBROUTINE mppscatter
1786
1787
1788	SUBROUTINE mppisl_a_int( ktab, kdim )
1789	!!----------------------------------------------------------------------
1790	!! * routine mppisl_a_int *
1791	!!
1792	!! ** Purpose : Massively parallel processors
1793	!! Find the non zero value
1794	!!
1795	!!----------------------------------------------------------------------
1796	!! * Arguments
1797	INTEGER, INTENT( in ) :: kdim ! ???
1798	INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ???
1799
1800	#if defined key_mpp_shmem
1801	!! * Local variables (SHMEM version)
1802	INTEGER :: ji
1803	INTEGER, SAVE :: ibool=0
1804
1805	IF( kdim > jpmppsum ) THEN
1806	WRITE(numout,*) 'mppisl_a_int routine : kdim is too big'
1807	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
1808	STOP 'mppisl_a_int'
1809	ENDIF
1810
1811	DO ji = 1, kdim
1812	niitab_shmem(ji) = ktab(ji)
1813	END DO
1814	CALL barrier()
1815	IF(ibool == 0 ) THEN
1816	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
1817	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
1818	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
1819	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
1820	ELSE
1821	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
1822	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
1823	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
1824	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
1825	ENDIF
1826	CALL barrier()
1827	ibool=ibool+1
1828	ibool=MOD( ibool,2)
1829	DO ji = 1, kdim
1830	IF( ni11tab_shmem(ji) /= 0. ) THEN
1831	ktab(ji) = ni11tab_shmem(ji)
1832	ELSE
1833	ktab(ji) = ni12tab_shmem(ji)
1834	ENDIF
1835	END DO
1836
1837	# elif defined key_mpp_mpi
1838	!! * Local variables (MPI version)
1839	LOGICAL :: lcommute
1840	INTEGER, DIMENSION(kdim) :: iwork
1841	INTEGER :: mpi_isl,ierror
1842
1843	lcommute = .TRUE.
1844	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
1845	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer &
1846	, mpi_isl, mpi_comm_world, ierror )
1847	ktab(:) = iwork(:)
1848	#endif
1849
1850	END SUBROUTINE mppisl_a_int
1851
1852
1853	SUBROUTINE mppisl_int( ktab )
1854	!!----------------------------------------------------------------------
1855	!! * routine mppisl_int *
1856	!!
1857	!! ** Purpose : Massively parallel processors
1858	!! Find the non zero value
1859	!!
1860	!!----------------------------------------------------------------------
1861	!! * Arguments
1862	INTEGER , INTENT( inout ) :: ktab !
1863
1864	#if defined key_mpp_shmem
1865	!! * Local variables (SHMEM version)
1866	INTEGER, SAVE :: ibool=0
1867
1868	niitab_shmem(1) = ktab
1869	CALL barrier()
1870	IF(ibool == 0 ) THEN
1871	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
1872	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
1873	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
1874	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
1875	ELSE
1876	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
1877	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
1878	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
1879	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
1880	ENDIF
1881	CALL barrier()
1882	ibool=ibool+1
1883	ibool=MOD( ibool,2)
1884	IF( ni11tab_shmem(1) /= 0. ) THEN
1885	ktab = ni11tab_shmem(1)
1886	ELSE
1887	ktab = ni12tab_shmem(1)
1888	ENDIF
1889
1890	# elif defined key_mpp_mpi
1891
1892	!! * Local variables (MPI version)
1893	LOGICAL :: lcommute
1894	INTEGER :: mpi_isl,ierror
1895	INTEGER :: iwork
1896
1897	lcommute = .TRUE.
1898	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
1899	CALL mpi_allreduce(ktab, iwork, 1,mpi_integer &
1900	,mpi_isl,mpi_comm_world,ierror)
1901	ktab = iwork
1902	#endif
1903
1904	END SUBROUTINE mppisl_int
1905
1906
1907	SUBROUTINE mppmin_a_int( ktab, kdim )
1908	!!----------------------------------------------------------------------
1909	!! * routine mppmin_a_int *
1910	!!
1911	!! ** Purpose : Find minimum value in an integer layout array
1912	!!
1913	!!----------------------------------------------------------------------
1914	!! * Arguments
1915	INTEGER , INTENT( in ) :: kdim ! size of array
1916	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
1917
1918	#if defined key_mpp_shmem
1919	!! * Local declarations (SHMEM version)
1920	INTEGER :: ji
1921	INTEGER, SAVE :: ibool=0
1922
1923	IF( kdim > jpmppsum ) THEN
1924	WRITE(numout,*) 'mppmin_a_int routine : kdim is too big'
1925	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
1926	STOP 'min_a_int'
1927	ENDIF
1928
1929	DO ji = 1, kdim
1930	niltab_shmem(ji) = ktab(ji)
1931	END DO
1932	CALL barrier()
1933	IF(ibool == 0 ) THEN
1934	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
1935	,N$PES,nil1wrk_shmem,nil1sync_shmem )
1936	ELSE
1937	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
1938	,N$PES,nil2wrk_shmem,nil2sync_shmem )
1939	ENDIF
1940	CALL barrier()
1941	ibool=ibool+1
1942	ibool=MOD( ibool,2)
1943	DO ji = 1, kdim
1944	ktab(ji) = niltab_shmem(ji)
1945	END DO
1946
1947	# elif defined key_mpp_mpi
1948
1949	!! * Local variables (MPI version)
1950	INTEGER :: ierror
1951	INTEGER, DIMENSION(kdim) :: iwork
1952
1953	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
1954	& mpi_min, mpi_comm_world, ierror )
1955
1956	ktab(:) = iwork(:)
1957	#endif
1958
1959	END SUBROUTINE mppmin_a_int
1960
1961
1962	SUBROUTINE mppmin_int( ktab )
1963	!!----------------------------------------------------------------------
1964	!! * routine mppmin_int *
1965	!!
1966	!! ** Purpose :
1967	!! Massively parallel processors
1968	!! Find minimum value in an integer layout array
1969	!!
1970	!!----------------------------------------------------------------------
1971	!! * Arguments
1972	INTEGER, INTENT(inout) :: ktab ! ???
1973
1974	!! * Local declarations
1975
1976	#if defined key_mpp_shmem
1977
1978	!! * Local variables (SHMEM version)
1979	INTEGER :: ji
1980	INTEGER, SAVE :: ibool=0
1981
1982	niltab_shmem(1) = ktab
1983	CALL barrier()
1984	IF(ibool == 0 ) THEN
1985	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
1986	,N$PES,nil1wrk_shmem,nil1sync_shmem )
1987	ELSE
1988	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
1989	,N$PES,nil2wrk_shmem,nil2sync_shmem )
1990	ENDIF
1991	CALL barrier()
1992	ibool=ibool+1
1993	ibool=MOD( ibool,2)
1994	ktab = niltab_shmem(1)
1995
1996	# elif defined key_mpp_mpi
1997
1998	!! * Local variables (MPI version)
1999	INTEGER :: ierror, iwork
2000
2001	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
2002	& ,mpi_min,mpi_comm_world,ierror)
2003
2004	ktab = iwork
2005	#endif
2006
2007	END SUBROUTINE mppmin_int
2008
2009
2010	SUBROUTINE mppsum_a_int( ktab, kdim )
2011	!!----------------------------------------------------------------------
2012	!! * routine mppsum_a_int *
2013	!!
2014	!! ** Purpose : Massively parallel processors
2015	!! Global integer sum
2016	!!
2017	!!----------------------------------------------------------------------
2018	!! * Arguments
2019	INTEGER, INTENT( in ) :: kdim ! ???
2020	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
2021
2022	#if defined key_mpp_shmem
2023
2024	!! * Local variables (SHMEM version)
2025	INTEGER :: ji
2026	INTEGER, SAVE :: ibool=0
2027
2028	IF( kdim > jpmppsum ) THEN
2029	WRITE(numout,*) 'mppsum_a_int routine : kdim is too big'
2030	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2031	STOP 'mppsum_a_int'
2032	ENDIF
2033
2034	DO ji = 1, kdim
2035	nistab_shmem(ji) = ktab(ji)
2036	END DO
2037	CALL barrier()
2038	IF(ibool == 0 ) THEN
2039	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
2040	N$PES,nis1wrk_shmem,nis1sync_shmem)
2041	ELSE
2042	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
2043	N$PES,nis2wrk_shmem,nis2sync_shmem)
2044	ENDIF
2045	CALL barrier()
2046	ibool = ibool + 1
2047	ibool = MOD( ibool, 2 )
2048	DO ji = 1, kdim
2049	ktab(ji) = nistab_shmem(ji)
2050	END DO
2051
2052	# elif defined key_mpp_mpi
2053
2054	!! * Local variables (MPI version)
2055	INTEGER :: ierror
2056	INTEGER, DIMENSION (kdim) :: iwork
2057
2058	CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer &
2059	,mpi_sum,mpi_comm_world,ierror)
2060
2061	ktab(:) = iwork(:)
2062	#endif
2063
2064	END SUBROUTINE mppsum_a_int
2065
2066
2067	SUBROUTINE mppsum_int( ktab )
2068	!!----------------------------------------------------------------------
2069	!! * routine mppsum_int *
2070	!!
2071	!! ** Purpose : Global integer sum
2072	!!
2073	!!----------------------------------------------------------------------
2074	!! * Arguments
2075	INTEGER, INTENT(inout) :: ktab
2076
2077	#if defined key_mpp_shmem
2078
2079	!! * Local variables (SHMEM version)
2080	INTEGER, SAVE :: ibool=0
2081
2082	nistab_shmem(1) = ktab
2083	CALL barrier()
2084	IF(ibool == 0 ) THEN
2085	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
2086	N$PES,nis1wrk_shmem,nis1sync_shmem)
2087	ELSE
2088	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
2089	N$PES,nis2wrk_shmem,nis2sync_shmem)
2090	ENDIF
2091	CALL barrier()
2092	ibool=ibool+1
2093	ibool=MOD( ibool,2)
2094	ktab = nistab_shmem(1)
2095
2096	# elif defined key_mpp_mpi
2097
2098	!! * Local variables (MPI version)
2099	INTEGER :: ierror, iwork
2100
2101	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
2102	,mpi_sum,mpi_comm_world,ierror)
2103
2104	ktab = iwork
2105
2106	#endif
2107
2108	END SUBROUTINE mppsum_int
2109
2110
2111	SUBROUTINE mppisl_a_real( ptab, kdim )
2112	!!----------------------------------------------------------------------
2113	!! * routine mppisl_a_real *
2114	!!
2115	!! ** Purpose : Massively parallel processors
2116	!! Find the non zero island barotropic stream function value
2117	!!
2118	!! Modifications:
2119	!! ! 93-09 (M. Imbard)
2120	!! ! 96-05 (j. Escobar)
2121	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
2122	!!----------------------------------------------------------------------
2123	INTEGER , INTENT( in ) :: kdim ! ???
2124	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab ! ???
2125
2126	#if defined key_mpp_shmem
2127
2128	!! * Local variables (SHMEM version)
2129	INTEGER :: ji
2130	INTEGER, SAVE :: ibool=0
2131
2132	IF( kdim > jpmppsum ) THEN
2133	WRITE(numout,*) 'mppisl_a_real routine : kdim is too big'
2134	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2135	STOP 'mppisl_a_real'
2136	ENDIF
2137
2138	DO ji = 1, kdim
2139	wiltab_shmem(ji) = ptab(ji)
2140	END DO
2141	CALL barrier()
2142	IF(ibool == 0 ) THEN
2143	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
2144	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
2145	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
2146	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
2147	ELSE
2148	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
2149	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
2150	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
2151	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
2152	ENDIF
2153	CALL barrier()
2154	ibool=ibool+1
2155	ibool=MOD( ibool,2)
2156	DO ji = 1, kdim
2157	IF(wi1tab_shmem(ji) /= 0. ) THEN
2158	ptab(ji) = wi1tab_shmem(ji)
2159	ELSE
2160	ptab(ji) = wi2tab_shmem(ji)
2161	ENDIF
2162	END DO
2163
2164	# elif defined key_mpp_mpi
2165
2166	!! * Local variables (MPI version)
2167	LOGICAL :: lcommute = .TRUE.
2168	INTEGER :: mpi_isl, ierror
2169	REAL(wp), DIMENSION(kdim) :: zwork
2170
2171	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
2172	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2173	,mpi_isl,mpi_comm_world,ierror)
2174	ptab(:) = zwork(:)
2175
2176	#endif
2177
2178	END SUBROUTINE mppisl_a_real
2179
2180
2181	SUBROUTINE mppisl_real( ptab )
2182	!!----------------------------------------------------------------------
2183	!! * routine mppisl_real *
2184	!!
2185	!! ** Purpose : Massively parallel processors
2186	!! Find the non zero island barotropic stream function value
2187	!!
2188	!! Modifications:
2189	!! ! 93-09 (M. Imbard)
2190	!! ! 96-05 (j. Escobar)
2191	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
2192	!!----------------------------------------------------------------------
2193	REAL(wp), INTENT(inout) :: ptab
2194
2195	#if defined key_mpp_shmem
2196
2197	!! * Local variables (SHMEM version)
2198	INTEGER, SAVE :: ibool=0
2199
2200	wiltab_shmem(1) = ptab
2201	CALL barrier()
2202	IF(ibool == 0 ) THEN
2203	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
2204	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
2205	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
2206	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
2207	ELSE
2208	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
2209	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
2210	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
2211	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
2212	ENDIF
2213	CALL barrier()
2214	ibool = ibool + 1
2215	ibool = MOD( ibool, 2 )
2216	IF( wi1tab_shmem(1) /= 0. ) THEN
2217	ptab = wi1tab_shmem(1)
2218	ELSE
2219	ptab = wi2tab_shmem(1)
2220	ENDIF
2221
2222	# elif defined key_mpp_mpi
2223
2224	!! * Local variables (MPI version)
2225	LOGICAL :: lcommute = .TRUE.
2226	INTEGER :: mpi_isl, ierror
2227	REAL(wp) :: zwork
2228
2229	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
2230	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, &
2231	& mpi_isl , mpi_comm_world, ierror )
2232	ptab = zwork
2233
2234	#endif
2235
2236	END SUBROUTINE mppisl_real
2237
2238
2239	FUNCTION lc_isl( py, px, kdim, kdtatyp )
2240	INTEGER :: kdim
2241	REAL(wp), DIMENSION(kdim) :: px, py
2242	INTEGER :: kdtatyp, ji
2243	INTEGER :: lc_isl
2244	DO ji = 1, kdim
2245	IF( py(ji) /= 0. ) px(ji) = py(ji)
2246	END DO
2247	lc_isl=0
2248
2249	END FUNCTION lc_isl
2250
2251
2252	SUBROUTINE mppmax_a_real( ptab, kdim )
2253	!!----------------------------------------------------------------------
2254	!! * routine mppmax_a_real *
2255	!!
2256	!! ** Purpose : Maximum
2257	!!
2258	!!----------------------------------------------------------------------
2259	!! * Arguments
2260	INTEGER , INTENT( in ) :: kdim
2261	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
2262
2263	#if defined key_mpp_shmem
2264
2265	!! * Local variables (SHMEM version)
2266	INTEGER :: ji
2267	INTEGER, SAVE :: ibool=0
2268
2269	IF( kdim > jpmppsum ) THEN
2270	WRITE(numout,*) 'mppmax_a_real routine : kdim is too big'
2271	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2272	STOP 'mppmax_a_real'
2273	ENDIF
2274
2275	DO ji = 1, kdim
2276	wintab_shmem(ji) = ptab(ji)
2277	END DO
2278	CALL barrier()
2279	IF(ibool == 0 ) THEN
2280	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2281	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2282	ELSE
2283	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2284	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2285	ENDIF
2286	CALL barrier()
2287	ibool=ibool+1
2288	ibool=MOD( ibool,2)
2289	DO ji = 1, kdim
2290	ptab(ji) = wintab_shmem(ji)
2291	END DO
2292
2293	# elif defined key_mpp_mpi
2294
2295	!! * Local variables (MPI version)
2296	INTEGER :: ierror
2297	REAL(wp), DIMENSION(kdim) :: zwork
2298
2299	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2300	,mpi_max,mpi_comm_world,ierror)
2301	ptab(:) = zwork(:)
2302
2303	#endif
2304
2305	END SUBROUTINE mppmax_a_real
2306
2307
2308	SUBROUTINE mppmax_real( ptab )
2309	!!----------------------------------------------------------------------
2310	!! * routine mppmax_real *
2311	!!
2312	!! ** Purpose : Maximum
2313	!!
2314	!!----------------------------------------------------------------------
2315	!! * Arguments
2316	REAL(wp), INTENT(inout) :: ptab ! ???
2317
2318	#if defined key_mpp_shmem
2319
2320	!! * Local variables (SHMEM version)
2321	INTEGER, SAVE :: ibool=0
2322
2323	wintab_shmem(1) = ptab
2324	CALL barrier()
2325	IF(ibool == 0 ) THEN
2326	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
2327	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2328	ELSE
2329	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
2330	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2331	ENDIF
2332	CALL barrier()
2333	ibool=ibool+1
2334	ibool=MOD( ibool,2)
2335	ptab = wintab_shmem(1)
2336
2337	# elif defined key_mpp_mpi
2338
2339	!! * Local variables (MPI version)
2340	INTEGER :: ierror
2341	REAL(wp) :: zwork
2342
2343	CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, &
2344	& mpi_max, mpi_comm_world, ierror )
2345	ptab = zwork
2346
2347	#endif
2348
2349	END SUBROUTINE mppmax_real
2350
2351
2352	SUBROUTINE mppmin_a_real( ptab, kdim )
2353	!!----------------------------------------------------------------------
2354	!! * routine mppmin_a_real *
2355	!!
2356	!! ** Purpose : Minimum
2357	!!
2358	!!-----------------------------------------------------------------------
2359	!! * Arguments
2360	INTEGER , INTENT( in ) :: kdim
2361	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
2362
2363	#if defined key_mpp_shmem
2364
2365	!! * Local variables (SHMEM version)
2366	INTEGER :: ji
2367	INTEGER, SAVE :: ibool=0
2368
2369	IF( kdim > jpmppsum ) THEN
2370	WRITE(numout,*) 'mpprmin routine : kdim is too big'
2371	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2372	STOP 'mpprmin'
2373	ENDIF
2374
2375	DO ji = 1, kdim
2376	wintab_shmem(ji) = ptab(ji)
2377	END DO
2378	CALL barrier()
2379	IF(ibool == 0 ) THEN
2380	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2381	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2382	ELSE
2383	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
2384	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2385	ENDIF
2386	CALL barrier()
2387	ibool=ibool+1
2388	ibool=MOD( ibool,2)
2389	DO ji = 1, kdim
2390	ptab(ji) = wintab_shmem(ji)
2391	END DO
2392
2393	# elif defined key_mpp_mpi
2394
2395	!! * Local variables (MPI version)
2396	INTEGER :: ierror
2397	REAL(wp), DIMENSION(kdim) :: zwork
2398
2399	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2400	,mpi_min,mpi_comm_world,ierror)
2401	ptab(:) = zwork(:)
2402
2403	#endif
2404
2405	END SUBROUTINE mppmin_a_real
2406
2407
2408	SUBROUTINE mppmin_real( ptab )
2409	!!----------------------------------------------------------------------
2410	!! * routine mppmin_real *
2411	!!
2412	!! ** Purpose : minimum in Massively Parallel Processing
2413	!! REAL scalar case
2414	!!
2415	!!-----------------------------------------------------------------------
2416	!! * Arguments
2417	REAL(wp), INTENT( inout ) :: ptab !
2418
2419	#if defined key_mpp_shmem
2420
2421	!! * Local variables (SHMEM version)
2422	INTEGER, SAVE :: ibool=0
2423
2424	wintab_shmem(1) = ptab
2425	CALL barrier()
2426	IF(ibool == 0 ) THEN
2427	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
2428	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
2429	ELSE
2430	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
2431	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
2432	ENDIF
2433	CALL barrier()
2434	ibool=ibool+1
2435	ibool=MOD( ibool,2)
2436	ptab = wintab_shmem(1)
2437
2438	# elif defined key_mpp_mpi
2439
2440	!! * Local variables (MPI version)
2441	INTEGER :: ierror
2442	REAL(wp) :: zwork
2443
2444	CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision &
2445	& ,mpi_min,mpi_comm_world,ierror)
2446	ptab = zwork
2447
2448	#endif
2449
2450	END SUBROUTINE mppmin_real
2451
2452
2453	SUBROUTINE mppsum_a_real( ptab, kdim )
2454	!!----------------------------------------------------------------------
2455	!! * routine mppsum_a_real *
2456	!!
2457	!! ** Purpose : global sum in Massively Parallel Processing
2458	!! REAL ARRAY argument case
2459	!!
2460	!!-----------------------------------------------------------------------
2461	INTEGER , INTENT( in ) :: kdim ! size of ptab
2462	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
2463
2464	#if defined key_mpp_shmem
2465
2466	!! * Local variables (SHMEM version)
2467	INTEGER :: ji
2468	INTEGER, SAVE :: ibool=0
2469
2470	IF( kdim > jpmppsum ) THEN
2471	WRITE(numout,*) 'mppsum_a_real routine : kdim is too big'
2472	WRITE(numout,*) 'change jpmppsum dimension in mpp.h'
2473	STOP 'mppsum_a_real'
2474	ENDIF
2475
2476	DO ji = 1, kdim
2477	wrstab_shmem(ji) = ptab(ji)
2478	END DO
2479	CALL barrier()
2480	IF(ibool == 0 ) THEN
2481	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
2482	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
2483	ELSE
2484	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
2485	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
2486	ENDIF
2487	CALL barrier()
2488	ibool=ibool+1
2489	ibool=MOD( ibool,2)
2490	DO ji = 1, kdim
2491	ptab(ji) = wrstab_shmem(ji)
2492	END DO
2493
2494	# elif defined key_mpp_mpi
2495
2496	!! * Local variables (MPI version)
2497	INTEGER :: ierror ! temporary integer
2498	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
2499
2500	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
2501	& ,mpi_sum,mpi_comm_world,ierror)
2502	ptab(:) = zwork(:)
2503
2504	#endif
2505
2506	END SUBROUTINE mppsum_a_real
2507
2508
2509	SUBROUTINE mppsum_real( ptab )
2510	!!----------------------------------------------------------------------
2511	!! * routine mppsum_real *
2512	!!
2513	!! ** Purpose : global sum in Massively Parallel Processing
2514	!! SCALAR argument case
2515	!!
2516	!!-----------------------------------------------------------------------
2517	REAL(wp), INTENT(inout) :: ptab ! input scalar
2518
2519	#if defined key_mpp_shmem
2520
2521	!! * Local variables (SHMEM version)
2522	INTEGER, SAVE :: ibool=0
2523
2524	wrstab_shmem(1) = ptab
2525	CALL barrier()
2526	IF(ibool == 0 ) THEN
2527	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
2528	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
2529	ELSE
2530	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
2531	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
2532	ENDIF
2533	CALL barrier()
2534	ibool = ibool + 1
2535	ibool = MOD( ibool, 2 )
2536	ptab = wrstab_shmem(1)
2537
2538	# elif defined key_mpp_mpi
2539
2540	!! * Local variables (MPI version)
2541	INTEGER :: ierror
2542	REAL(wp) :: zwork
2543
2544	CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision &
2545	& ,mpi_sum,mpi_comm_world,ierror)
2546	ptab = zwork
2547
2548	#endif
2549
2550	END SUBROUTINE mppsum_real
2551
2552	SUBROUTINE mpp_minloc2d(ptab, pmask, pmin, ki,kj )
2553	!!------------------------------------------------------------------------
2554	!! * routine mpp_minloc *
2555	!!
2556	!! ** Purpose : Compute the global minimum of an array ptab
2557	!! and also give its global position
2558	!!
2559	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2560	!!
2561	!! ** Arguments : I : ptab =local 2D array
2562	!! O : pmin = global minimum
2563	!! O : ki,kj = global position of minimum
2564	!!
2565	!! ** Author : J.M. Molines 10/10/2004
2566	!!--------------------------------------------------------------------------
2567	#ifdef key_mpp_shmem
2568	IF (lwp) THEN
2569	WRITE(numout,*) ' mpp_minloc not yet available in SHMEM'
2570	STOP
2571	ENDIF
2572	# elif key_mpp_mpi
2573	!! * Arguments
2574	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
2575	& pmask ! Local mask
2576	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
2577	INTEGER , INTENT (out) :: ki,kj ! index of minimum in global frame
2578
2579	!! * Local variables
2580	REAL(wp) :: zmin ! local minimum
2581	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2582	INTEGER, DIMENSION (2) :: ilocs
2583	INTEGER :: ierror
2584
2585
2586	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
2587	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
2588
2589	ki = ilocs(1) + nimpp - 1
2590	kj = ilocs(2) + njmpp - 1
2591
2592	zain(1,:)=zmin
2593	zain(2,:)=ki+10000.*kj
2594
2595	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror)
2596
2597	pmin=zaout(1,1)
2598	kj= INT(zaout(2,1)/10000.)
2599	ki= INT(zaout(2,1) - 10000.*kj )
2600	#endif
2601
2602	END SUBROUTINE mpp_minloc2d
2603
2604
2605	SUBROUTINE mpp_minloc3d(ptab, pmask, pmin, ki,kj ,kk)
2606	!!------------------------------------------------------------------------
2607	!! * routine mpp_minloc *
2608	!!
2609	!! ** Purpose : Compute the global minimum of an array ptab
2610	!! and also give its global position
2611	!!
2612	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2613	!!
2614	!! ** Arguments : I : ptab =local 2D array
2615	!! O : pmin = global minimum
2616	!! O : ki,kj = global position of minimum
2617	!!
2618	!! ** Author : J.M. Molines 10/10/2004
2619	!!--------------------------------------------------------------------------
2620	#ifdef key_mpp_shmem
2621	IF (lwp) THEN
2622	WRITE(numout,*) ' mpp_minloc not yet available in SHMEM'
2623	STOP
2624	ENDIF
2625	# elif key_mpp_mpi
2626	!! * Arguments
2627	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
2628	& pmask ! Local mask
2629	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
2630	INTEGER , INTENT (out) :: ki,kj,kk ! index of minimum in global frame
2631
2632	!! * Local variables
2633	REAL(wp) :: zmin ! local minimum
2634	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2635	INTEGER, DIMENSION (3) :: ilocs
2636	INTEGER :: ierror
2637
2638
2639	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2640	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2641
2642	ki = ilocs(1) + nimpp - 1
2643	kj = ilocs(2) + njmpp - 1
2644	kk = ilocs(3)
2645
2646	zain(1,:)=zmin
2647	zain(2,:)=ki+10000.kj+100000000.kk
2648
2649	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror)
2650
2651	pmin=zaout(1,1)
2652	kk= INT(zaout(2,1)/100000000.)
2653	kj= INT(zaout(2,1) - kk * 100000000. )/10000
2654	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
2655	#endif
2656
2657	END SUBROUTINE mpp_minloc3d
2658
2659
2660	SUBROUTINE mpp_maxloc2d(ptab, pmask, pmax, ki,kj )
2661	!!------------------------------------------------------------------------
2662	!! * routine mpp_maxloc *
2663	!!
2664	!! ** Purpose : Compute the global maximum of an array ptab
2665	!! and also give its global position
2666	!!
2667	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2668	!!
2669	!! ** Arguments : I : ptab =local 2D array
2670	!! O : pmax = global maximum
2671	!! O : ki,kj = global position of maximum
2672	!!
2673	!! ** Author : J.M. Molines 10/10/2004
2674	!!--------------------------------------------------------------------------
2675	#ifdef key_mpp_shmem
2676	IF (lwp) THEN
2677	WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM'
2678	STOP
2679	ENDIF
2680	# elif key_mpp_mpi
2681	!! * Arguments
2682	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
2683	& pmask ! Local mask
2684	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
2685	INTEGER , INTENT (out) :: ki,kj ! index of maximum in global frame
2686
2687	!! * Local variables
2688	REAL(wp) :: zmax ! local maximum
2689	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2690	INTEGER, DIMENSION (2) :: ilocs
2691	INTEGER :: ierror
2692
2693
2694	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
2695	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
2696
2697	ki = ilocs(1) + nimpp - 1
2698	kj = ilocs(2) + njmpp - 1
2699
2700	zain(1,:)=zmax
2701	zain(2,:)=ki+10000.*kj
2702
2703	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror)
2704
2705	pmax=zaout(1,1)
2706	kj= INT(zaout(2,1)/10000.)
2707	ki= INT(zaout(2,1) - 10000.*kj )
2708	#endif
2709
2710	END SUBROUTINE mpp_maxloc2d
2711
2712	SUBROUTINE mpp_maxloc3d(ptab, pmask, pmax, ki,kj,kk )
2713	!!------------------------------------------------------------------------
2714	!! * routine mpp_maxloc *
2715	!!
2716	!! ** Purpose : Compute the global maximum of an array ptab
2717	!! and also give its global position
2718	!!
2719	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
2720	!!
2721	!! ** Arguments : I : ptab =local 2D array
2722	!! O : pmax = global maximum
2723	!! O : ki,kj = global position of maximum
2724	!!
2725	!! ** Author : J.M. Molines 10/10/2004
2726	!!--------------------------------------------------------------------------
2727	#ifdef key_mpp_shmem
2728	IF (lwp) THEN
2729	WRITE(numout,*) ' mpp_maxloc not yet available in SHMEM'
2730	STOP
2731	ENDIF
2732	# elif key_mpp_mpi
2733	!! * Arguments
2734	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
2735	& pmask ! Local mask
2736	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
2737	INTEGER , INTENT (out) :: ki,kj,kk ! index of maximum in global frame
2738
2739	!! * Local variables
2740	REAL(wp) :: zmax ! local maximum
2741	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
2742	INTEGER, DIMENSION (3) :: ilocs
2743	INTEGER :: ierror
2744
2745
2746	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
2747	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
2748
2749	ki = ilocs(1) + nimpp - 1
2750	kj = ilocs(2) + njmpp - 1
2751	kk = ilocs(3)
2752
2753	zain(1,:)=zmax
2754	zain(2,:)=ki+10000.kj+100000000.kk
2755
2756	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror)
2757
2758	pmax=zaout(1,1)
2759	kk= INT(zaout(2,1)/100000000.)
2760	kj= INT(zaout(2,1) - kk * 100000000. )/10000
2761	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
2762	#endif
2763
2764	END SUBROUTINE mpp_maxloc3d
2765
2766	SUBROUTINE mppsync()
2767	!!----------------------------------------------------------------------
2768	!! * routine mppsync *
2769	!!
2770	!! ** Purpose : Massively parallel processors, synchroneous
2771	!!
2772	!!-----------------------------------------------------------------------
2773
2774	#if defined key_mpp_shmem
2775
2776	!! * Local variables (SHMEM version)
2777	CALL barrier()
2778
2779	# elif defined key_mpp_mpi
2780
2781	!! * Local variables (MPI version)
2782	INTEGER :: ierror
2783
2784	CALL mpi_barrier(mpi_comm_world,ierror)
2785
2786	#endif
2787
2788	END SUBROUTINE mppsync
2789
2790
2791	SUBROUTINE mppstop
2792	!!----------------------------------------------------------------------
2793	!! * routine mppstop *
2794	!!
2795	!! ** purpose : Stop massilively parallel processors method
2796	!!
2797	!!----------------------------------------------------------------------
2798	!! * Local declarations
2799	INTEGER :: info
2800	!!----------------------------------------------------------------------
2801
2802	! 1. Mpp synchroneus
2803	! ------------------
2804
2805	CALL mppsync
2806	#if defined key_mpp_mpi
2807	CALL mpi_finalize( info )
2808	#endif
2809
2810	END SUBROUTINE mppstop
2811
2812
2813	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
2814	!!----------------------------------------------------------------------
2815	!! * routine mppobc *
2816	!!
2817	!! ** Purpose : Message passing manadgement for open boundary
2818	!! conditions array
2819	!!
2820	!! ** Method : Use mppsend and mpprecv function for passing mask
2821	!! between processors following neighboring subdomains.
2822	!! domain parameters
2823	!! nlci : first dimension of the local subdomain
2824	!! nlcj : second dimension of the local subdomain
2825	!! nbondi : mark for "east-west local boundary"
2826	!! nbondj : mark for "north-south local boundary"
2827	!! noea : number for local neighboring processors
2828	!! nowe : number for local neighboring processors
2829	!! noso : number for local neighboring processors
2830	!! nono : number for local neighboring processors
2831	!!
2832	!! History :
2833	!! ! 98-07 (J.M. Molines) Open boundary conditions
2834	!!----------------------------------------------------------------------
2835	!! * Arguments
2836	INTEGER , INTENT( in ) :: &
2837	kd1, kd2, & ! starting and ending indices
2838	kl , & ! index of open boundary
2839	kk, & ! vertical dimension
2840	ktype, & ! define north/south or east/west cdt
2841	! ! = 1 north/south ; = 2 east/west
2842	kij ! horizontal dimension
2843	REAL(wp), DIMENSION(kij,kk), INTENT( inout ) :: &
2844	ptab ! variable array
2845
2846	!! * Local variables
2847	INTEGER :: ji, jj, jk, jl ! dummy loop indices
2848	INTEGER :: &
2849	iipt0, iipt1, ilpt1, & ! temporary integers
2850	ijpt0, ijpt1, & ! " "
2851	imigr, iihom, ijhom ! " "
2852	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
2853	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
2854	REAL(wp), DIMENSION(jpi,jpj) :: &
2855	ztab ! temporary workspace
2856	!!----------------------------------------------------------------------
2857
2858
2859	! boundary condition initialization
2860	! ---------------------------------
2861
2862	ztab(:,:) = 0.e0
2863
2864	IF( ktype==1 ) THEN ! north/south boundaries
2865	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
2866	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
2867	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
2868	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
2869	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
2870	ELSEIF( ktype==2 ) THEN ! east/west boundaries
2871	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
2872	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
2873	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
2874	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
2875	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
2876	ELSE
2877	IF(lwp)WRITE(numout,*) 'mppobc: bad ktype'
2878	STOP 'mppobc'
2879	ENDIF
2880
2881	DO jk = 1, kk
2882	IF( ktype==1 ) THEN ! north/south boundaries
2883	DO jj = ijpt0, ijpt1
2884	DO ji = iipt0, iipt1
2885	ztab(ji,jj) = ptab(ji,jk)
2886	END DO
2887	END DO
2888	ELSEIF( ktype==2 ) THEN ! east/west boundaries
2889	DO jj = ijpt0, ijpt1
2890	DO ji = iipt0, iipt1
2891	ztab(ji,jj) = ptab(jj,jk)
2892	END DO
2893	END DO
2894	ENDIF
2895
2896
2897	! 1. East and west directions
2898	! ---------------------------
2899
2900	! 1.1 Read Dirichlet lateral conditions
2901
2902	IF( nbondi /= 2 ) THEN
2903	iihom = nlci-nreci
2904
2905	DO jl = 1, jpreci
2906	t2ew(:,jl,1) = ztab(jpreci+jl,:)
2907	t2we(:,jl,1) = ztab(iihom +jl,:)
2908	END DO
2909	ENDIF
2910
2911	! 1.2 Migrations
2912
2913	#if defined key_mpp_shmem
2914	!! * (SHMEM version)
2915	imigr=jprecijpjjpbyt
2916
2917	IF( nbondi == -1 ) THEN
2918	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
2919	ELSEIF( nbondi == 0 ) THEN
2920	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
2921	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
2922	ELSEIF( nbondi == 1 ) THEN
2923	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
2924	ENDIF
2925	CALL barrier()
2926	CALL shmem_udcflush()
2927
2928	# elif key_mpp_mpi
2929	!! * (MPI version)
2930
2931	imigr=jpreci*jpj
2932
2933	IF( nbondi == -1 ) THEN
2934	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
2935	CALL mpprecv(1,t2ew(1,1,2),imigr)
2936	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2937	ELSEIF( nbondi == 0 ) THEN
2938	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2939	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
2940	CALL mpprecv(1,t2ew(1,1,2),imigr)
2941	CALL mpprecv(2,t2we(1,1,2),imigr)
2942	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2943	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2944	ELSEIF( nbondi == 1 ) THEN
2945	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2946	CALL mpprecv(2,t2we(1,1,2),imigr)
2947	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2948	ENDIF
2949	#endif
2950
2951
2952	! 1.3 Write Dirichlet lateral conditions
2953
2954	iihom = nlci-jpreci
2955	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
2956	DO jl = 1, jpreci
2957	ztab(jl,:) = t2we(:,jl,2)
2958	END DO
2959	ENDIF
2960
2961	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
2962	DO jl = 1, jpreci
2963	ztab(iihom+jl,:) = t2ew(:,jl,2)
2964	END DO
2965	ENDIF
2966
2967
2968	! 2. North and south directions
2969	! -----------------------------
2970
2971	! 2.1 Read Dirichlet lateral conditions
2972
2973	IF( nbondj /= 2 ) THEN
2974	ijhom = nlcj-nrecj
2975	DO jl = 1, jprecj
2976	t2sn(:,jl,1) = ztab(:,ijhom +jl)
2977	t2ns(:,jl,1) = ztab(:,jprecj+jl)
2978	END DO
2979	ENDIF
2980
2981	! 2.2 Migrations
2982
2983	#if defined key_mpp_shmem
2984	!! * SHMEM version
2985
2986	imigr=jprecjjpijpbyt
2987
2988	IF( nbondj == -1 ) THEN
2989	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
2990	ELSEIF( nbondj == 0 ) THEN
2991	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
2992	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
2993	ELSEIF( nbondj == 1 ) THEN
2994	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
2995	ENDIF
2996	CALL barrier()
2997	CALL shmem_udcflush()
2998
2999	# elif key_mpp_mpi
3000	!! * Local variables (MPI version)
3001
3002	imigr=jprecj*jpi
3003
3004	IF( nbondj == -1 ) THEN
3005	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
3006	CALL mpprecv(3,t2ns(1,1,2),imigr)
3007	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3008	ELSEIF( nbondj == 0 ) THEN
3009	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
3010	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
3011	CALL mpprecv(3,t2ns(1,1,2),imigr)
3012	CALL mpprecv(4,t2sn(1,1,2),imigr)
3013	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3014	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
3015	ELSEIF( nbondj == 1 ) THEN
3016	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
3017	CALL mpprecv(4,t2sn(1,1,2),imigr)
3018	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
3019	ENDIF
3020
3021	#endif
3022
3023	! 2.3 Write Dirichlet lateral conditions
3024
3025	ijhom = nlcj - jprecj
3026	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
3027	DO jl = 1, jprecj
3028	ztab(:,jl) = t2sn(:,jl,2)
3029	END DO
3030	ENDIF
3031
3032	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
3033	DO jl = 1, jprecj
3034	ztab(:,ijhom+jl) = t2ns(:,jl,2)
3035	END DO
3036	ENDIF
3037
3038	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
3039	! north/south boundaries
3040	DO jj = ijpt0,ijpt1
3041	DO ji = iipt0,ilpt1
3042	ptab(ji,jk) = ztab(ji,jj)
3043	END DO
3044	END DO
3045	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
3046	! east/west boundaries
3047	DO jj = ijpt0,ilpt1
3048	DO ji = iipt0,iipt1
3049	ptab(jj,jk) = ztab(ji,jj)
3050	END DO
3051	END DO
3052	ENDIF
3053
3054	END DO
3055
3056	END SUBROUTINE mppobc
3057
3058
3059	SUBROUTINE mpp_ini_north
3060	!!----------------------------------------------------------------------
3061	!! * routine mpp_ini_north *
3062	!!
3063	!! ** Purpose : Initialize special communicator for north folding
3064	!! condition together with global variables needed in the mpp folding
3065	!!
3066	!! ** Method : - Look for northern processors
3067	!! - Put their number in nrank_north
3068	!! - Create groups for the world processors and the north processors
3069	!! - Create a communicator for northern processors
3070	!!
3071	!! ** output
3072	!! njmppmax = njmpp for northern procs
3073	!! ndim_rank_north = number of processors in the northern line
3074	!! nrank_north (ndim_rank_north) = number of the northern procs.
3075	!! ngrp_world = group ID for the world processors
3076	!! ngrp_north = group ID for the northern processors
3077	!! ncomm_north = communicator for the northern procs.
3078	!! north_root = number (in the world) of proc 0 in the northern comm.
3079	!!
3080	!! History :
3081	!! ! 03-09 (J.M. Molines, MPI only )
3082	!!----------------------------------------------------------------------
3083	#ifdef key_mpp_shmem
3084	IF (lwp) THEN
3085	WRITE(numout,*) ' mpp_ini_north not available in SHMEM'
3086	STOP
3087	ENDIF
3088	# elif key_mpp_mpi
3089	INTEGER :: ierr
3090	INTEGER :: jproc
3091	INTEGER :: ii,ji
3092	!!----------------------------------------------------------------------
3093
3094	njmppmax=MAXVAL(njmppt)
3095
3096	! Look for how many procs on the northern boundary
3097	!
3098	ndim_rank_north=0
3099	DO jproc=1,jpnij
3100	IF ( njmppt(jproc) == njmppmax ) THEN
3101	ndim_rank_north = ndim_rank_north + 1
3102	END IF
3103	END DO
3104
3105
3106	! Allocate the right size to nrank_north
3107	!
3108	ALLOCATE(nrank_north(ndim_rank_north))
3109
3110	! Fill the nrank_north array with proc. number of northern procs.
3111	! Note : the rank start at 0 in MPI
3112	!
3113	ii=0
3114	DO ji = 1, jpnij
3115	IF ( njmppt(ji) == njmppmax ) THEN
3116	ii=ii+1
3117	nrank_north(ii)=ji-1
3118	END IF
3119	END DO
3120	! create the world group
3121	!
3122	CALL MPI_COMM_GROUP(mpi_comm_world,ngrp_world,ierr)
3123	!
3124	! Create the North group from the world group
3125	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr)
3126
3127	! Create the North communicator , ie the pool of procs in the north group
3128	!
3129	CALL MPI_COMM_CREATE(mpi_comm_world,ngrp_north,ncomm_north,ierr)
3130
3131
3132	! find proc number in the world of proc 0 in the north
3133	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr)
3134	#endif
3135
3136	END SUBROUTINE mpp_ini_north
3137
3138
3139	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
3140	!!---------------------------------------------------------------------
3141	!! * routine mpp_lbc_north_3d *
3142	!!
3143	!! ** Purpose :
3144	!! Ensure proper north fold horizontal bondary condition in mpp configuration
3145	!! in case of jpn1 > 1
3146	!!
3147	!! ** Method :
3148	!! Gather the 4 northern lines of the global domain on 1 processor and
3149	!! apply lbc north-fold on this sub array. Then scatter the fold array
3150	!! back to the processors.
3151	!!
3152	!! History :
3153	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
3154	!! from lbc routine
3155	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
3156	!!----------------------------------------------------------------------
3157	!! * Arguments
3158	CHARACTER(len=1), INTENT( in ) :: &
3159	cd_type ! nature of pt3d grid-points
3160	! ! = T , U , V , F or W gridpoints
3161	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
3162	pt3d ! 3D array on which the boundary condition is applied
3163	REAL(wp), INTENT( in ) :: &
3164	psgn ! control of the sign change
3165	! ! = -1. , the sign is changed if north fold boundary
3166	! ! = 1. , the sign is kept if north fold boundary
3167
3168	!! * Local declarations
3169	INTEGER :: ji, jj, jk, jr, jproc
3170	INTEGER :: ierr
3171	INTEGER :: ildi,ilei,iilb
3172	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
3173	INTEGER :: itaille
3174	REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab
3175	REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio
3176	REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc
3177	!!----------------------------------------------------------------------
3178
3179	! If we get in this routine it s because : North fold condition and mpp with more
3180	! than one proc across i : we deal only with the North condition
3181
3182	! 0. Sign setting
3183	! ---------------
3184
3185	ijpj=4
3186	ijpjm1=3
3187
3188	! put in znorthloc the last 4 jlines of pt3d
3189	DO jk = 1, jpk
3190	DO jj = nlcj - ijpj +1, nlcj
3191	ij = jj - nlcj + ijpj
3192	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
3193	END DO
3194	END DO
3195
3196
3197	IF (npolj /= 0 ) THEN
3198	! Build in proc 0 of ncomm_north the znorthgloio
3199	znorthgloio(:,:,:,:) = 0_wp
3200
3201	#ifdef key_mpp_shmem
3202	not done : compiler error
3203	#elif defined key_mpp_mpi
3204	itaille=jpijpkijpj
3205	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3206	#endif
3207
3208	ENDIF
3209
3210	IF (narea == north_root+1 ) THEN
3211	! recover the global north array
3212	ztab(:,:,:) = 0_wp
3213
3214	DO jr = 1, ndim_rank_north
3215	jproc = nrank_north(jr) + 1
3216	ildi = nldit (jproc)
3217	ilei = nleit (jproc)
3218	iilb = nimppt(jproc)
3219	DO jk = 1, jpk
3220	DO jj = 1, 4
3221	DO ji = ildi, ilei
3222	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
3223	END DO
3224	END DO
3225	END DO
3226	END DO
3227
3228
3229	! Horizontal slab
3230	! ===============
3231
3232	DO jk = 1, jpk
3233
3234
3235	! 2. North-Fold boundary conditions
3236	! ----------------------------------
3237
3238	SELECT CASE ( npolj )
3239
3240	CASE ( 3, 4 ) ! * North fold T-point pivot
3241
3242	ztab( 1 ,ijpj,jk) = 0.e0
3243	ztab(jpiglo,ijpj,jk) = 0.e0
3244
3245	SELECT CASE ( cd_type )
3246
3247	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
3248	DO ji = 2, jpiglo
3249	ijt = jpiglo-ji+2
3250	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
3251	END DO
3252	DO ji = jpiglo/2+1, jpiglo
3253	ijt = jpiglo-ji+2
3254	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
3255	END DO
3256
3257	CASE ( 'U' ) ! U-point
3258	DO ji = 1, jpiglo-1
3259	iju = jpiglo-ji+1
3260	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
3261	END DO
3262	DO ji = jpiglo/2, jpiglo-1
3263	iju = jpiglo-ji+1
3264	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
3265	END DO
3266
3267	CASE ( 'V' ) ! V-point
3268	DO ji = 2, jpiglo
3269	ijt = jpiglo-ji+2
3270	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
3271	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
3272	END DO
3273
3274	CASE ( 'F' , 'G' ) ! F-point
3275	DO ji = 1, jpiglo-1
3276	iju = jpiglo-ji+1
3277	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
3278	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
3279	END DO
3280
3281	END SELECT
3282
3283	CASE ( 5, 6 ) ! * North fold F-point pivot
3284
3285	ztab( 1 ,ijpj,jk) = 0.e0
3286	ztab(jpiglo,ijpj,jk) = 0.e0
3287
3288	SELECT CASE ( cd_type )
3289
3290	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
3291	DO ji = 1, jpiglo
3292	ijt = jpiglo-ji+1
3293	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
3294	END DO
3295
3296	CASE ( 'U' ) ! U-point
3297	DO ji = 1, jpiglo-1
3298	iju = jpiglo-ji
3299	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
3300	END DO
3301
3302	CASE ( 'V' ) ! V-point
3303	DO ji = 1, jpiglo
3304	ijt = jpiglo-ji+1
3305	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
3306	END DO
3307	DO ji = jpiglo/2+1, jpiglo
3308	ijt = jpiglo-ji+1
3309	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
3310	END DO
3311
3312	CASE ( 'F' , 'G' ) ! F-point
3313	DO ji = 1, jpiglo-1
3314	iju = jpiglo-ji
3315	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
3316	END DO
3317	DO ji = jpiglo/2+1, jpiglo-1
3318	iju = jpiglo-ji
3319	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
3320	END DO
3321
3322	END SELECT
3323
3324	CASE DEFAULT ! * closed
3325
3326	SELECT CASE ( cd_type)
3327
3328	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
3329	ztab(:, 1 ,jk) = 0.e0
3330	ztab(:,ijpj,jk) = 0.e0
3331
3332	CASE ( 'F' ) ! F-point
3333	ztab(:,ijpj,jk) = 0.e0
3334
3335	END SELECT
3336
3337	END SELECT
3338
3339	! End of slab
3340	! ===========
3341
3342	END DO
3343
3344	!! Scatter back to pt3d
3345	DO jr = 1, ndim_rank_north
3346	jproc=nrank_north(jr)+1
3347	ildi=nldit (jproc)
3348	ilei=nleit (jproc)
3349	iilb=nimppt(jproc)
3350	DO jk= 1, jpk
3351	DO jj=1,ijpj
3352	DO ji=ildi,ilei
3353	znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
3354	END DO
3355	END DO
3356	END DO
3357	END DO
3358
3359	ENDIF ! only done on proc 0 of ncomm_north
3360
3361	#ifdef key_mpp_shmem
3362	not done yet in shmem : compiler error
3363	#elif key_mpp_mpi
3364	IF ( npolj /= 0 ) THEN
3365	itaille=jpijpkijpj
3366	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3367	ENDIF
3368	#endif
3369
3370	! put in the last ijpj jlines of pt3d znorthloc
3371	DO jk = 1 , jpk
3372	DO jj = nlcj - ijpj + 1 , nlcj
3373	ij = jj - nlcj + ijpj
3374	pt3d(:,jj,jk)= znorthloc(:,ij,jk)
3375	END DO
3376	END DO
3377
3378	END SUBROUTINE mpp_lbc_north_3d
3379
3380
3381	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
3382	!!---------------------------------------------------------------------
3383	!! * routine mpp_lbc_north_2d *
3384	!!
3385	!! ** Purpose :
3386	!! Ensure proper north fold horizontal bondary condition in mpp configuration
3387	!! in case of jpn1 > 1 (for 2d array )
3388	!!
3389	!! ** Method :
3390	!! Gather the 4 northern lines of the global domain on 1 processor and
3391	!! apply lbc north-fold on this sub array. Then scatter the fold array
3392	!! back to the processors.
3393	!!
3394	!! History :
3395	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
3396	!! from lbc routine
3397	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
3398	!!----------------------------------------------------------------------
3399
3400	!! * Arguments
3401	CHARACTER(len=1), INTENT( in ) :: &
3402	cd_type ! nature of pt2d grid-points
3403	! ! = T , U , V , F or W gridpoints
3404	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
3405	pt2d ! 2D array on which the boundary condition is applied
3406	REAL(wp), INTENT( in ) :: &
3407	psgn ! control of the sign change
3408	! ! = -1. , the sign is changed if north fold boundary
3409	! ! = 1. , the sign is kept if north fold boundary
3410
3411
3412	!! * Local declarations
3413
3414	INTEGER :: ji, jj, jr, jproc
3415	INTEGER :: ierr
3416	INTEGER :: ildi,ilei,iilb
3417	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
3418	INTEGER :: itaille
3419
3420	REAL(wp), DIMENSION(jpiglo,4) :: ztab
3421	REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio
3422	REAL(wp), DIMENSION(jpi,4) :: znorthloc
3423	!!----------------------------------------------------------------------
3424	!! OPA 8.5, LODYC-IPSL (2002)
3425	!!----------------------------------------------------------------------
3426	! If we get in this routine it s because : North fold condition and mpp with more
3427	! than one proc across i : we deal only with the North condition
3428
3429	! 0. Sign setting
3430	! ---------------
3431
3432	ijpj=4
3433	ijpjm1=3
3434
3435
3436	! put in znorthloc the last 4 jlines of pt2d
3437	DO jj = nlcj - ijpj +1, nlcj
3438	ij = jj - nlcj + ijpj
3439	znorthloc(:,ij)=pt2d(:,jj)
3440	END DO
3441
3442	IF (npolj /= 0 ) THEN
3443	! Build in proc 0 of ncomm_north the znorthgloio
3444	znorthgloio(:,:,:) = 0_wp
3445	#ifdef key_mpp_shmem
3446	not done : compiler error
3447	#elif defined key_mpp_mpi
3448	itaille=jpi*ijpj
3449	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3450	#endif
3451	ENDIF
3452
3453	IF (narea == north_root+1 ) THEN
3454	! recover the global north array
3455	ztab(:,:) = 0_wp
3456
3457	DO jr = 1, ndim_rank_north
3458	jproc=nrank_north(jr)+1
3459	ildi=nldit (jproc)
3460	ilei=nleit (jproc)
3461	iilb=nimppt(jproc)
3462	DO jj=1,4
3463	DO ji=ildi,ilei
3464	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
3465	END DO
3466	END DO
3467	END DO
3468
3469
3470	! 2. North-Fold boundary conditions
3471	! ----------------------------------
3472
3473	SELECT CASE ( npolj )
3474
3475	CASE ( 3, 4 ) ! * North fold T-point pivot
3476
3477	ztab( 1 ,ijpj) = 0.e0
3478	ztab(jpiglo,ijpj) = 0.e0
3479
3480	SELECT CASE ( cd_type )
3481
3482	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
3483	DO ji = 2, jpiglo
3484	ijt = jpiglo-ji+2
3485	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
3486	END DO
3487	DO ji = jpiglo/2+1, jpiglo
3488	ijt = jpiglo-ji+2
3489	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
3490	END DO
3491
3492	CASE ( 'U' ) ! U-point
3493	DO ji = 1, jpiglo-1
3494	iju = jpiglo-ji+1
3495	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-2)
3496	END DO
3497	DO ji = jpiglo/2, jpiglo-1
3498	iju = jpiglo-ji+1
3499	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
3500	END DO
3501
3502	CASE ( 'V' ) ! V-point
3503	DO ji = 2, jpiglo
3504	ijt = jpiglo-ji+2
3505	ztab(ji,ijpj-1) = psgn * ztab(ijt,ijpj-2)
3506	ztab(ji,ijpj ) = psgn * ztab(ijt,ijpj-3)
3507	END DO
3508
3509	CASE ( 'F' , 'G' ) ! F-point
3510	DO ji = 1, jpiglo-1
3511	iju = jpiglo-ji+1
3512	ztab(ji,ijpj-1) = psgn * ztab(iju,ijpj-2)
3513	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-3)
3514	END DO
3515
3516	CASE ( 'I' ) ! ice U-V point
3517	ztab(2,ijpj) = psgn * ztab(3,ijpj-1)
3518	DO ji = 3, jpiglo
3519	iju = jpiglo - ji + 3
3520	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
3521	END DO
3522
3523	END SELECT
3524
3525	CASE ( 5, 6 ) ! * North fold F-point pivot
3526
3527	ztab( 1 ,ijpj) = 0.e0
3528	ztab(jpiglo,ijpj) = 0.e0
3529
3530	SELECT CASE ( cd_type )
3531
3532	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
3533	DO ji = 1, jpiglo
3534	ijt = jpiglo-ji+1
3535	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-1)
3536	END DO
3537
3538	CASE ( 'U' ) ! U-point
3539	DO ji = 1, jpiglo-1
3540	iju = jpiglo-ji
3541	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
3542	END DO
3543
3544	CASE ( 'V' ) ! V-point
3545	DO ji = 1, jpiglo
3546	ijt = jpiglo-ji+1
3547	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
3548	END DO
3549	DO ji = jpiglo/2+1, jpiglo
3550	ijt = jpiglo-ji+1
3551	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
3552	END DO
3553
3554	CASE ( 'F' , 'G' ) ! F-point
3555	DO ji = 1, jpiglo-1
3556	iju = jpiglo-ji
3557	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-2)
3558	END DO
3559	DO ji = jpiglo/2+1, jpiglo-1
3560	iju = jpiglo-ji
3561	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
3562	END DO
3563
3564	CASE ( 'I' ) ! ice U-V point
3565	ztab( 2 ,ijpj) = 0.e0
3566	DO ji = 2 , jpiglo-1
3567	ijt = jpi - ji + 2
3568	ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) )
3569	END DO
3570
3571	END SELECT
3572
3573	CASE DEFAULT ! * closed : the code probably never go through
3574
3575	SELECT CASE ( cd_type)
3576
3577	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
3578	ztab(:, 1 ) = 0.e0
3579	ztab(:,ijpj) = 0.e0
3580
3581	CASE ( 'F' ) ! F-point
3582	ztab(:,ijpj) = 0.e0
3583
3584	CASE ( 'I' ) ! ice U-V point
3585	ztab(:, 1 ) = 0.e0
3586	ztab(:,ijpj) = 0.e0
3587
3588	END SELECT
3589
3590	END SELECT
3591
3592	! End of slab
3593	! ===========
3594
3595	!! Scatter back to pt2d
3596	DO jr = 1, ndim_rank_north
3597	jproc=nrank_north(jr)+1
3598	ildi=nldit (jproc)
3599	ilei=nleit (jproc)
3600	iilb=nimppt(jproc)
3601	DO jj=1,ijpj
3602	DO ji=ildi,ilei
3603	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
3604	END DO
3605	END DO
3606	END DO
3607
3608	ENDIF ! only done on proc 0 of ncomm_north
3609
3610	#ifdef key_mpp_shmem
3611	not done yet in shmem : compiler error
3612	#elif key_mpp_mpi
3613	IF ( npolj /= 0 ) THEN
3614	itaille=jpi*ijpj
3615	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3616	ENDIF
3617	#endif
3618
3619	! put in the last ijpj jlines of pt2d znorthloc
3620	DO jj = nlcj - ijpj + 1 , nlcj
3621	ij = jj - nlcj + ijpj
3622	pt2d(:,jj)= znorthloc(:,ij)
3623	END DO
3624
3625	END SUBROUTINE mpp_lbc_north_2d
3626
3627
3628	!!!!!
3629
3630
3631	!!
3632	!! This is valid on IBM machine ONLY.
3633	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -- Mode: F90 -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3634	!! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque
3635	!! MPI afin de faire, en plus de l'initialisation de
3636	!! l'environnement MPI, l'allocation d'une zone tampon
3637	!! qui sera ulterieurement utilisee automatiquement lors
3638	!! de tous les envois de messages par MPI_BSEND
3639	!!
3640	!! Auteur : CNRS/IDRIS
3641	!! Date : Tue Nov 13 12:02:14 2001
3642	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3643
3644	SUBROUTINE mpi_init_opa(code)
3645	IMPLICIT NONE
3646	# include <mpif.h>
3647
3648	INTEGER :: code,rang
3649
3650	! La valeur suivante doit etre au moins egale a la taille
3651	! du plus grand message qui sera transfere dans le programme
3652	! (de toute facon, il y aura un message d'erreur si cette
3653	! valeur s'avere trop petite)
3654	INTEGER :: taille_tampon
3655	CHARACTER(len=9) :: taille_tampon_alphanum
3656	REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon
3657
3658	! Le point d'entree dans la bibliotheque MPI elle-meme
3659	CALL mpi_init(code)
3660
3661	! La definition de la zone tampon pour les futurs envois
3662	! par MPI_BSEND (on alloue une fois pour toute cette zone
3663	! tampon, qui sera automatiquement utilisee lors de chaque
3664	! appel a MPI_BSEND).
3665	! La desallocation sera implicite quand on sortira de
3666	! l'environnement MPI.
3667
3668	! Recuperation de la valeur de la variable d'environnement
3669	! BUFFER_LENGTH
3670	! qui, si elle est definie, doit contenir une valeur superieure
3671	! a la taille en octets du plus gros message
3672	CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum)
3673
3674	! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par
3675	! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit
3676	! 65 536 octets
3677	IF (taille_tampon_alphanum == ' ') THEN
3678	taille_tampon = 65536
3679	ELSE
3680	READ(taille_tampon_alphanum,'(i9)') taille_tampon
3681	END IF
3682
3683	! On est limite en mode d'adressage 32 bits a 1750 Mo pour la zone
3684	! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo
3685	IF (taille_tampon > 210000000) THEN
3686	PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000'
3687	CALL mpi_abort(MPI_COMM_WORLD,2,code)
3688	END IF
3689
3690	CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code)
3691	IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon
3692
3693	! Allocation du tampon et attachement
3694	ALLOCATE(tampon(taille_tampon))
3695	CALL mpi_buffer_attach(tampon,taille_tampon,code)
3696
3697	END SUBROUTINE mpi_init_opa
3698
3699
3700	#else
3701	!!----------------------------------------------------------------------
3702	!! Default case: Dummy module share memory computing
3703	!!----------------------------------------------------------------------
3704	INTERFACE mpp_sum
3705	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
3706	END INTERFACE
3707	INTERFACE mpp_max
3708	MODULE PROCEDURE mppmax_a_real, mppmax_real
3709	END INTERFACE
3710	INTERFACE mpp_min
3711	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3712	END INTERFACE
3713	INTERFACE mpp_isl
3714	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
3715	END INTERFACE
3716	INTERFACE mppobc
3717	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
3718	END INTERFACE
3719	INTERFACE mpp_minloc
3720	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3721	END INTERFACE
3722	INTERFACE mpp_maxloc
3723	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3724	END INTERFACE
3725
3726
3727	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
3728
3729	CONTAINS
3730
3731	FUNCTION mynode() RESULT (function_value)
3732	function_value = 0
3733	END FUNCTION mynode
3734
3735	SUBROUTINE mppsync ! Dummy routine
3736	END SUBROUTINE mppsync
3737
3738	SUBROUTINE mpp_sum_as( parr, kdim ) ! Dummy routine
3739	REAL , DIMENSION(:) :: parr
3740	INTEGER :: kdim
3741	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1)
3742	END SUBROUTINE mpp_sum_as
3743
3744	SUBROUTINE mpp_sum_a2s( parr, kdim ) ! Dummy routine
3745	REAL , DIMENSION(:,:) :: parr
3746	INTEGER :: kdim
3747	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1)
3748	END SUBROUTINE mpp_sum_a2s
3749
3750	SUBROUTINE mpp_sum_ai( karr, kdim ) ! Dummy routine
3751	INTEGER, DIMENSION(:) :: karr
3752	INTEGER :: kdim
3753	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1)
3754	END SUBROUTINE mpp_sum_ai
3755
3756	SUBROUTINE mpp_sum_s( psca ) ! Dummy routine
3757	REAL :: psca
3758	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca
3759	END SUBROUTINE mpp_sum_s
3760
3761	SUBROUTINE mpp_sum_i( kint ) ! Dummy routine
3762	integer :: kint
3763	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint
3764	END SUBROUTINE mpp_sum_i
3765
3766	SUBROUTINE mppmax_a_real( parr, kdim )
3767	REAL , DIMENSION(:) :: parr
3768	INTEGER :: kdim
3769	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1)
3770	END SUBROUTINE mppmax_a_real
3771
3772	SUBROUTINE mppmax_real( psca )
3773	REAL :: psca
3774	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca
3775	END SUBROUTINE mppmax_real
3776
3777	SUBROUTINE mppmin_a_real( parr, kdim )
3778	REAL , DIMENSION(:) :: parr
3779	INTEGER :: kdim
3780	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1)
3781	END SUBROUTINE mppmin_a_real
3782
3783	SUBROUTINE mppmin_real( psca )
3784	REAL :: psca
3785	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca
3786	END SUBROUTINE mppmin_real
3787
3788	SUBROUTINE mppmin_a_int( karr, kdim )
3789	INTEGER, DIMENSION(:) :: karr
3790	INTEGER :: kdim
3791	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1)
3792	END SUBROUTINE mppmin_a_int
3793
3794	SUBROUTINE mppmin_int( kint )
3795	INTEGER :: kint
3796	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint
3797	END SUBROUTINE mppmin_int
3798
3799	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
3800	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3801	REAL, DIMENSION(:) :: parr ! variable array
3802	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3803	& parr(1), kd1, kd2, kl, kk, ktype, kij
3804	END SUBROUTINE mppobc_1d
3805
3806	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
3807	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3808	REAL, DIMENSION(:,:) :: parr ! variable array
3809	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3810	& parr(1,1), kd1, kd2, kl, kk, ktype, kij
3811	END SUBROUTINE mppobc_2d
3812
3813	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
3814	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3815	REAL, DIMENSION(:,:,:) :: parr ! variable array
3816	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3817	& parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
3818	END SUBROUTINE mppobc_3d
3819
3820	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
3821	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3822	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
3823	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3824	& parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
3825	END SUBROUTINE mppobc_4d
3826
3827
3828	SUBROUTINE mpplnks( parr ) ! Dummy routine
3829	REAL, DIMENSION(:,:) :: parr
3830	WRITE(,) 'mpplnks: You should not have seen this print! error?', parr(1,1)
3831	END SUBROUTINE mpplnks
3832
3833	SUBROUTINE mppisl_a_int( karr, kdim )
3834	INTEGER, DIMENSION(:) :: karr
3835	INTEGER :: kdim
3836	WRITE(,) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1)
3837	END SUBROUTINE mppisl_a_int
3838
3839	SUBROUTINE mppisl_int( kint )
3840	INTEGER :: kint
3841	WRITE(,) 'mppisl_int: You should not have seen this print! error?', kint
3842	END SUBROUTINE mppisl_int
3843
3844	SUBROUTINE mppisl_a_real( parr, kdim )
3845	REAL , DIMENSION(:) :: parr
3846	INTEGER :: kdim
3847	WRITE(,) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1)
3848	END SUBROUTINE mppisl_a_real
3849
3850	SUBROUTINE mppisl_real( psca )
3851	REAL :: psca
3852	WRITE(,) 'mppisl_real: You should not have seen this print! error?', psca
3853	END SUBROUTINE mppisl_real
3854
3855	SUBROUTINE mpp_minloc2d ( ptab, pmask, pmin, ki, kj )
3856	REAL :: pmin
3857	REAL , DIMENSION (:,:) :: ptab, pmask
3858	INTEGER :: ki, kj
3859	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj
3860	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3861	END SUBROUTINE mpp_minloc2d
3862
3863	SUBROUTINE mpp_minloc3d ( ptab, pmask, pmin, ki, kj, kk )
3864	REAL :: pmin
3865	REAL , DIMENSION (:,:,:) :: ptab, pmask
3866	INTEGER :: ki, kj, kk
3867	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj, kk
3868	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3869	END SUBROUTINE mpp_minloc3d
3870
3871	SUBROUTINE mpp_maxloc2d ( ptab, pmask, pmax, ki, kj )
3872	REAL :: pmax
3873	REAL , DIMENSION (:,:) :: ptab, pmask
3874	INTEGER :: ki, kj
3875	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj
3876	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3877	END SUBROUTINE mpp_maxloc2d
3878
3879	SUBROUTINE mpp_maxloc3d ( ptab, pmask, pmax, ki, kj, kk )
3880	REAL :: pmax
3881	REAL , DIMENSION (:,:,:) :: ptab, pmask
3882	INTEGER :: ki, kj, kk
3883	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj, kk
3884	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3885	END SUBROUTINE mpp_maxloc3d
3886
3887	SUBROUTINE mppstop
3888	WRITE(,) 'mppstop: You should not have seen this print! error?'
3889	END SUBROUTINE mppstop
3890
3891	#endif
3892	!!----------------------------------------------------------------------
3893	END MODULE lib_mpp

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

Download in other formats: