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

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

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

Download in other formats: