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

Last change on this file since 227 was 219, checked in by opalod, 19 years ago
CT : UPDATE154 : move the closing file step done in mppstop subroutine (in lib_mpp.F90) in the subroutine opa_closefile (in opa.F90)
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 127.0 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	!!----------------------------------------------------------------------
41	!! OPA 9.0 , LODYC-IPSL (2003)
42	!!---------------------------------------------------------------------
43	!! * Modules used
44	USE dom_oce ! ocean space and time domain
45	USE in_out_manager ! I/O manager
46
47	IMPLICIT NONE
48
49	!! * Interfaces
50	!! define generic interface for these routine as they are called sometimes
51	!! with scalar arguments instead of array arguments, which causes problems
52	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
53
54	INTERFACE mpp_isl
55	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
56	END INTERFACE
57	INTERFACE mpp_min
58	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
59	END INTERFACE
60	INTERFACE mpp_max
61	MODULE PROCEDURE mppmax_a_real, mppmax_real
62	END INTERFACE
63	INTERFACE mpp_sum
64	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
65	END INTERFACE
66	INTERFACE mpp_lbc_north
67	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
68	END INTERFACE
69	INTERFACE mpp_minloc
70	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
71	END INTERFACE
72	INTERFACE mpp_maxloc
73	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
74	END INTERFACE
75
76
77	!! * Share module variables
78	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
79	LOGICAL, PUBLIC :: lk_bsend = .FALSE. !: mpp_bsend flag
80	LOGICAL, PUBLIC :: lk_isend = .FALSE. !: mpp_isend flag
81
82
83	!! * Module variables
84	!! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
85	INTEGER, PARAMETER :: &
86	nprocmax = 2**10, & ! maximun dimension
87	ndim_mpp = jpnij ! dimension for this simulation
88
89	#if defined key_mpp_mpi
90	!! ========================= !!
91	!! MPI variable definition !!
92	!! ========================= !!
93	# include <mpif.h>
94
95	INTEGER :: &
96	size, & ! number of process
97	rank ! process number [ 0 - size-1 ]
98
99	! variables used in case of north fold condition in mpp_mpi with jpni > 1
100	INTEGER :: & !
101	ngrp_world, & ! group ID for the world processors
102	ngrp_north, & ! group ID for the northern processors (to be fold)
103	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
104	ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !)
105	njmppmax ! value of njmpp for the processors of the northern line
106	INTEGER :: & !
107	north_root ! number (in the comm_world) of proc 0 in the northern comm
108	INTEGER, DIMENSION(:), ALLOCATABLE :: &
109	nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
110
111
112	#elif defined key_mpp_shmem
113	!! ========================= !!
114	!! SHMEM variable definition !!
115	!! ========================= !!
116	# include <fpvm3.h>
117	# include <mpp/shmem.fh>
118
119	CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name
120	CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name
121	CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall())
122
123	INTEGER, PARAMETER :: & !! SHMEM control print
124	mynode_print = 0, & ! flag for print, mynode routine
125	mpprecv_print = 0, & ! flag for print, mpprecv routine
126	mppsend_print = 0, & ! flag for print, mppsend routine
127	mppsync_print = 0, & ! flag for print, mppsync routine
128	mppsum_print = 0, & ! flag for print, mpp_sum routine
129	mppisl_print = 0, & ! flag for print, mpp_isl routine
130	mppmin_print = 0, & ! flag for print, mpp_min routine
131	mppmax_print = 0, & ! flag for print, mpp_max routine
132	mpparent_print = 0 ! flag for print, mpparent routine
133
134	INTEGER, PARAMETER :: & !! Variable definition
135	jpvmint = 21 ! ???
136
137	INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors
138	jpmsec = 50000, & ! ???
139	jpmpplat = 30, & ! ???
140	jpmppsum = MAX( jpisljpisl, jpmpplatjpk, jpmsec ) ! ???
141
142	INTEGER :: &
143	npvm_ipas , & ! pvm initialization flag
144	npvm_mytid, & ! pvm tid
145	npvm_me , & ! node number [ 0 - nproc-1 ]
146	npvm_nproc, & ! real number of nodes
147	npvm_inum ! ???
148	INTEGER, DIMENSION(0:nprocmax-1) :: &
149	npvm_tids ! tids array [ 0 - nproc-1 ]
150
151	INTEGER :: &
152	nt3d_ipas , & ! pvm initialization flag
153	nt3d_mytid, & ! pvm tid
154	nt3d_me , & ! node number [ 0 - nproc-1 ]
155	nt3d_nproc ! real number of nodes
156	INTEGER, DIMENSION(0:nprocmax-1) :: &
157	nt3d_tids ! tids array [ 0 - nproc-1 ]
158
159	!! real sum reduction
160	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
161	nrs1sync_shmem, & !
162	nrs2sync_shmem
163	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
164	wrs1wrk_shmem, & !
165	wrs2wrk_shmem !
166	REAL(wp), DIMENSION(jpmppsum) :: &
167	wrstab_shmem !
168
169	!! minimum and maximum reduction
170	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
171	ni1sync_shmem, & !
172	ni2sync_shmem !
173	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
174	wi1wrk_shmem, & !
175	wi2wrk_shmem
176	REAL(wp), DIMENSION(jpmppsum) :: &
177	wintab_shmem, & !
178	wi1tab_shmem, & !
179	wi2tab_shmem !
180
181	!! value not equal zero for barotropic stream function around islands
182	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
183	ni11sync_shmem, & !
184	ni12sync_shmem, & !
185	ni21sync_shmem, & !
186	ni22sync_shmem !
187	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
188	wi11wrk_shmem, & !
189	wi12wrk_shmem, & !
190	wi21wrk_shmem, & !
191	wi22wrk_shmem !
192	REAL(wp), DIMENSION(jpmppsum) :: &
193	wiltab_shmem , & !
194	wi11tab_shmem, & !
195	wi12tab_shmem, & !
196	wi21tab_shmem, & !
197	wi22tab_shmem
198
199	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
200	ni11wrk_shmem, & !
201	ni12wrk_shmem, & !
202	ni21wrk_shmem, & !
203	ni22wrk_shmem !
204	INTEGER, DIMENSION(jpmppsum) :: &
205	niitab_shmem , & !
206	ni11tab_shmem, & !
207	ni12tab_shmem !
208	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
209	nis1sync_shmem, & !
210	nis2sync_shmem !
211	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
212	nis1wrk_shmem, & !
213	nis2wrk_shmem !
214	INTEGER, DIMENSION(jpmppsum) :: &
215	nistab_shmem
216
217	!! integer sum reduction
218	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
219	nil1sync_shmem, & !
220	nil2sync_shmem !
221	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
222	nil1wrk_shmem, & !
223	nil2wrk_shmem !
224	INTEGER, DIMENSION(jpmppsum) :: &
225	niltab_shmem
226	#endif
227
228	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
229	t3ns, t3sn ! 3d message passing arrays north-south & south-north
230	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &
231	t3ew, t3we ! 3d message passing arrays east-west & west-east
232	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
233	t3p1, t3p2 ! 3d message passing arrays north fold
234	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
235	t2ns, t2sn ! 2d message passing arrays north-south & south-north
236	REAL(wp), DIMENSION(jpj,jpreci,2) :: &
237	t2ew, t2we ! 2d message passing arrays east-west & west-east
238	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
239	t2p1, t2p2 ! 2d message passing arrays north fold
240	!!----------------------------------------------------------------------
241	!! OPA 9.0 , LODYC-IPSL (2004)
242	!!---------------------------------------------------------------------
243
244	CONTAINS
245
246	FUNCTION mynode()
247	!!----------------------------------------------------------------------
248	!! * routine mynode *
249	!!
250	!! ** Purpose : Find processor unit
251	!!
252	!!----------------------------------------------------------------------
253	#if defined key_mpp_mpi
254	!! * Local variables (MPI version)
255	INTEGER :: mynode, ierr
256	!!----------------------------------------------------------------------
257	! Enroll in MPI
258	! -------------
259	# if defined key_mpi_bsend
260	lk_bsend = .TRUE. !: mpp_bsend flag
261	# endif
262	# if defined key_mpi_isend
263	lk_isend = .TRUE. !: mpp_isend flag
264	# endif
265
266	IF(lk_bsend) THEN
267	CALL mpi_init_opa( ierr )
268	ELSE
269	CALL mpi_init( ierr )
270	ENDIF
271	CALL mpi_comm_rank( mpi_comm_world, rank, ierr )
272	CALL mpi_comm_size( mpi_comm_world, size, ierr )
273	mynode = rank
274	#else
275	!! * Local variables (SHMEM version)
276	INTEGER :: mynode
277	INTEGER :: &
278	imypid, imyhost, ji, info, iparent_tid
279	!!----------------------------------------------------------------------
280
281	IF( npvm_ipas /= nprocmax ) THEN
282	! --- first passage in mynode
283	! -------------
284	! enroll in pvm
285	! -------------
286	CALL pvmfmytid( npvm_mytid )
287	IF( mynode_print /= 0 ) THEN
288	WRITE(nummpp,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
289	WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
290	ENDIF
291
292	! ---------------------------------------------------------------
293	! find out IF i am parent or child spawned processes have parents
294	! ---------------------------------------------------------------
295	CALL mpparent( iparent_tid )
296	IF( mynode_print /= 0 ) THEN
297	WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, &
298	& ' after mpparent, npvm_tids(0) = ', &
299	& npvm_tids(0), ' iparent_tid=', iparent_tid
300	ENDIF
301	IF( iparent_tid < 0 ) THEN
302	WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, &
303	& ' after mpparent, npvm_tids(0) = ', &
304	& npvm_tids(0), ' iparent_tid=', iparent_tid
305	npvm_tids(0) = npvm_mytid
306	npvm_me = 0
307	IF( ndim_mpp > nprocmax ) THEN
308	WRITE(nummpp,*) 'npvm_mytid=', npvm_mytid, ' too great'
309	STOP ' mynode '
310	ELSE
311	npvm_nproc = ndim_mpp
312	ENDIF
313
314	! -------------------------
315	! start up copies of myself
316	! -------------------------
317	IF( npvm_nproc > 1 ) THEN
318	DO ji = 1, npvm_nproc-1
319	npvm_tids(ji) = nt3d_tids(ji)
320	END DO
321	info=npvm_nproc-1
322
323	IF( mynode_print /= 0 ) THEN
324	WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, &
325	& ' maitre=',executable,' info=', info &
326	& ,' npvm_nproc=',npvm_nproc
327	WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, &
328	& ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
329	ENDIF
330
331	! ---------------------------
332	! multicast tids array to children
333	! ---------------------------
334	CALL pvmfinitsend( pvmdefault, info )
335	CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info )
336	CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
337	CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
338	ENDIF
339	ELSE
340
341	! ---------------------------------
342	! receive the tids array and set me
343	! ---------------------------------
344	IF( mynode_print /= 0 ) WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
345	CALL pvmfrecv( iparent_tid, 10, info )
346	IF( mynode_print /= 0 ) WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
347	CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info )
348	CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
349	IF( mynode_print /= 0 ) THEN
350	WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid, &
351	& ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
352	WRITE(nummpp,*) 'mynode, npvm_mytid=', npvm_mytid, &
353	& 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
354	ENDIF
355	DO ji = 0, npvm_nproc-1
356	IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
357	END DO
358	ENDIF
359
360	! ------------------------------------------------------------
361	! all nproc tasks are equal now
362	! and can address each other by tids(0) thru tids(nproc-1)
363	! for each process me => process number [0-(nproc-1)]
364	! ------------------------------------------------------------
365	CALL pvmfjoingroup ( "bidon", info )
366	CALL pvmfbarrier ( "bidon", npvm_nproc, info )
367	DO ji = 0, npvm_nproc-1
368	IF( ji == npvm_me ) THEN
369	CALL pvmfjoingroup ( opaall, npvm_inum )
370	IF( npvm_inum /= npvm_me ) WRITE(nummpp,*) 'mynode not arrived in the good order for opaall'
371	ENDIF
372	CALL pvmfbarrier( "bidon", npvm_nproc, info )
373	END DO
374	CALL pvmfbarrier( opaall, npvm_nproc, info )
375
376	ELSE
377	! --- other passage in mynode
378	ENDIF
379
380	npvm_ipas = nprocmax
381	mynode = npvm_me
382	imypid = npvm_mytid
383	imyhost = npvm_tids(0)
384	IF( mynode_print /= 0 ) THEN
385	WRITE(nummpp,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, &
386	& ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
387	ENDIF
388	#endif
389	END FUNCTION mynode
390
391
392	SUBROUTINE mpparent( kparent_tid )
393	!!----------------------------------------------------------------------
394	!! * routine mpparent *
395	!!
396	!! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem)
397	!! or only return -1 (key_mpp_mpi)
398	!!----------------------------------------------------------------------
399	!! * Arguments
400	INTEGER, INTENT(inout) :: kparent_tid ! ???
401
402	#if defined key_mpp_mpi
403	! MPI version : retour -1
404
405	kparent_tid = -1
406
407	#else
408	!! * Local variables (SHMEN onto T3E version)
409	INTEGER :: &
410	it3d_my_pe, LEADZ, ji, info
411
412	CALL pvmfmytid( nt3d_mytid )
413	CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
414	IF( mpparent_print /= 0 ) THEN
415	WRITE(nummpp,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
416	ENDIF
417	IF( it3d_my_pe == 0 ) THEN
418	!-----------------------------------------------------------------!
419	! process = 0 => receive other tids !
420	!-----------------------------------------------------------------!
421	kparent_tid = -1
422	IF(mpparent_print /= 0 ) THEN
423	WRITE(nummpp,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
424	ENDIF
425	! --- END receive dimension ---
426	IF( ndim_mpp > nprocmax ) THEN
427	WRITE(nummpp,*) 'mytid=',nt3d_mytid,' too great'
428	STOP ' mpparent '
429	ELSE
430	nt3d_nproc = ndim_mpp
431	ENDIF
432	IF( mpparent_print /= 0 ) THEN
433	WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
434	ENDIF
435	!-------- receive tids from others process --------
436	DO ji = 1, nt3d_nproc-1
437	CALL pvmfrecv( ji , 100, info )
438	CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
439	IF( mpparent_print /= 0 ) THEN
440	WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
441	ENDIF
442	END DO
443	nt3d_tids(0) = nt3d_mytid
444	IF( mpparent_print /= 0 ) THEN
445	WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), &
446	ji = 0, nt3d_nproc-1 )
447	WRITE(nummpp,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
448	ENDIF
449
450	ELSE
451	!!----------------------------------------------------------------!
452	! process <> 0 => send other tids !
453	!!----------------------------------------------------------------!
454	kparent_tid = 0
455	CALL pvmfinitsend( pvmdataraw, info )
456	CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
457	CALL pvmfsend( kparent_tid, 100, info )
458	ENDIF
459	#endif
460
461	END SUBROUTINE mpparent
462
463	#if defined key_mpp_shmem
464
465	SUBROUTINE mppshmem
466	!!----------------------------------------------------------------------
467	!! * routine mppshmem *
468	!!
469	!! ** Purpose : SHMEM ROUTINE
470	!!
471	!!----------------------------------------------------------------------
472	nrs1sync_shmem = SHMEM_SYNC_VALUE
473	nrs2sync_shmem = SHMEM_SYNC_VALUE
474	nis1sync_shmem = SHMEM_SYNC_VALUE
475	nis2sync_shmem = SHMEM_SYNC_VALUE
476	nil1sync_shmem = SHMEM_SYNC_VALUE
477	nil2sync_shmem = SHMEM_SYNC_VALUE
478	ni11sync_shmem = SHMEM_SYNC_VALUE
479	ni12sync_shmem = SHMEM_SYNC_VALUE
480	ni21sync_shmem = SHMEM_SYNC_VALUE
481	ni22sync_shmem = SHMEM_SYNC_VALUE
482	CALL barrier()
483
484	END SUBROUTINE mppshmem
485
486	#endif
487
488	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn )
489	!!----------------------------------------------------------------------
490	!! * routine mpp_lnk_3d *
491	!!
492	!! ** Purpose : Message passing manadgement
493	!!
494	!! ** Method : Use mppsend and mpprecv function for passing mask
495	!! between processors following neighboring subdomains.
496	!! domain parameters
497	!! nlci : first dimension of the local subdomain
498	!! nlcj : second dimension of the local subdomain
499	!! nbondi : mark for "east-west local boundary"
500	!! nbondj : mark for "north-south local boundary"
501	!! noea : number for local neighboring processors
502	!! nowe : number for local neighboring processors
503	!! noso : number for local neighboring processors
504	!! nono : number for local neighboring processors
505	!!
506	!! ** Action : ptab with update value at its periphery
507	!!
508	!!----------------------------------------------------------------------
509	!! * Arguments
510	CHARACTER(len=1) , INTENT( in ) :: &
511	cd_type ! define the nature of ptab array grid-points
512	! ! = T , U , V , F , W points
513	! ! = S : T-point, north fold treatment ???
514	! ! = G : F-point, north fold treatment ???
515	REAL(wp), INTENT( in ) :: &
516	psgn ! control of the sign change
517	! ! = -1. , the sign is changed if north fold boundary
518	! ! = 1. , the sign is kept if north fold boundary
519	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
520	ptab ! 3D array on which the boundary condition is applied
521
522	!! * Local variables
523	INTEGER :: ji, jk, jl ! dummy loop indices
524	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
525	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
526	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
527	!!----------------------------------------------------------------------
528
529	! 1. standard boundary treatment
530	! ------------------------------
531	! ! East-West boundaries
532	! ! ====================
533	IF( nbondi == 2 .AND. & ! Cyclic east-west
534	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
535	ptab( 1 ,:,:) = ptab(jpim1,:,:)
536	ptab(jpi,:,:) = ptab( 2 ,:,:)
537
538	ELSE ! closed
539	SELECT CASE ( cd_type )
540	CASE ( 'T', 'U', 'V', 'W' )
541	ptab( 1 :jpreci,:,:) = 0.e0
542	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
543	CASE ( 'F' )
544	ptab(nlci-jpreci+1:jpi ,:,:) = 0.e0
545	END SELECT
546	ENDIF
547
548	! ! North-South boundaries
549	! ! ======================
550	SELECT CASE ( cd_type )
551	CASE ( 'T', 'U', 'V', 'W' )
552	ptab(:, 1 :jprecj,:) = 0.e0
553	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
554	CASE ( 'F' )
555	ptab(:,nlcj-jprecj+1:jpj ,:) = 0.e0
556	END SELECT
557
558
559	! 2. East and west directions exchange
560	! ------------------------------------
561
562	! 2.1 Read Dirichlet lateral conditions
563
564	SELECT CASE ( nbondi )
565	CASE ( -1, 0, 1 ) ! all exept 2
566	iihom = nlci-nreci
567	DO jl = 1, jpreci
568	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
569	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
570	END DO
571	END SELECT
572
573	! 2.2 Migrations
574
575	#if defined key_mpp_shmem
576	!! * SHMEM version
577
578	imigr = jpreci * jpj * jpk
579
580	SELECT CASE ( nbondi )
581	CASE ( -1 )
582	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
583	CASE ( 0 )
584	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
585	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
586	CASE ( 1 )
587	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
588	END SELECT
589
590	CALL barrier()
591	CALL shmem_udcflush()
592
593	#elif defined key_mpp_mpi
594	!! * Local variables (MPI version)
595
596	imigr = jpreci * jpj * jpk
597
598	SELECT CASE ( nbondi )
599	CASE ( -1 )
600	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
601	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
602	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
603	CASE ( 0 )
604	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
605	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
606	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
607	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
608	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
609	IF(lk_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
610	CASE ( 1 )
611	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
612	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
613	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
614	END SELECT
615	#endif
616
617	! 2.3 Write Dirichlet lateral conditions
618
619	iihom = nlci-jpreci
620
621	SELECT CASE ( nbondi )
622	CASE ( -1 )
623	DO jl = 1, jpreci
624	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
625	END DO
626	CASE ( 0 )
627	DO jl = 1, jpreci
628	ptab(jl ,:,:) = t3we(:,jl,:,2)
629	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
630	END DO
631	CASE ( 1 )
632	DO jl = 1, jpreci
633	ptab(jl ,:,:) = t3we(:,jl,:,2)
634	END DO
635	END SELECT
636
637
638	! 3. North and south directions
639	! -----------------------------
640
641	! 3.1 Read Dirichlet lateral conditions
642
643	IF( nbondj /= 2 ) THEN
644	ijhom = nlcj-nrecj
645	DO jl = 1, jprecj
646	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
647	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
648	END DO
649	ENDIF
650
651	! 3.2 Migrations
652
653	#if defined key_mpp_shmem
654	!! * SHMEM version
655
656	imigr = jprecj * jpi * jpk
657
658	SELECT CASE ( nbondj )
659	CASE ( -1 )
660	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
661	CASE ( 0 )
662	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
663	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
664	CASE ( 1 )
665	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
666	END SELECT
667
668	CALL barrier()
669	CALL shmem_udcflush()
670
671	#elif defined key_mpp_mpi
672	!! * Local variables (MPI version)
673
674	imigr=jprecjjpijpk
675
676	SELECT CASE ( nbondj )
677	CASE ( -1 )
678	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
679	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
680	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
681	CASE ( 0 )
682	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
683	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
684	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
685	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
686	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
687	IF(lk_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
688	CASE ( 1 )
689	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
690	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
691	IF(lk_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
692	END SELECT
693
694	#endif
695
696	! 3.3 Write Dirichlet lateral conditions
697
698	ijhom = nlcj-jprecj
699
700	SELECT CASE ( nbondj )
701	CASE ( -1 )
702	DO jl = 1, jprecj
703	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
704	END DO
705	CASE ( 0 )
706	DO jl = 1, jprecj
707	ptab(:,jl ,:) = t3sn(:,jl,:,2)
708	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
709	END DO
710	CASE ( 1 )
711	DO jl = 1, jprecj
712	ptab(:,jl,:) = t3sn(:,jl,:,2)
713	END DO
714	END SELECT
715
716
717	! 4. north fold treatment
718	! -----------------------
719
720	! 4.1 treatment without exchange (jpni odd)
721	! T-point pivot
722
723	SELECT CASE ( jpni )
724
725	CASE ( 1 ) ! only one proc along I, no mpp exchange
726
727	SELECT CASE ( npolj )
728
729	CASE ( 4 ) ! T pivot
730	iloc = jpiglo - 2 * ( nimpp - 1 )
731
732	SELECT CASE ( cd_type )
733
734	CASE ( 'T' , 'S', 'W' )
735	DO jk = 1, jpk
736	DO ji = 2, nlci
737	ijt=iloc-ji+2
738	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
739	END DO
740	DO ji = nlci/2+1, nlci
741	ijt=iloc-ji+2
742	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
743	END DO
744	END DO
745
746	CASE ( 'U' )
747	DO jk = 1, jpk
748	DO ji = 1, nlci-1
749	iju=iloc-ji+1
750	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
751	END DO
752	DO ji = nlci/2, nlci-1
753	iju=iloc-ji+1
754	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
755	END DO
756	END DO
757
758	CASE ( 'V' )
759	DO jk = 1, jpk
760	DO ji = 2, nlci
761	ijt=iloc-ji+2
762	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
763	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)
764	END DO
765	END DO
766
767	CASE ( 'F', 'G' )
768	DO jk = 1, jpk
769	DO ji = 1, nlci-1
770	iju=iloc-ji+1
771	ptab(ji,nlcj-1,jk) = ptab(iju,nlcj-2,jk)
772	ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk)
773	END DO
774	END DO
775
776	END SELECT
777
778	CASE ( 6 ) ! F pivot
779	iloc=jpiglo-2*(nimpp-1)
780
781	SELECT CASE ( cd_type )
782
783	CASE ( 'T' , 'S', 'W' )
784	DO jk = 1, jpk
785	DO ji = 1, nlci
786	ijt=iloc-ji+1
787	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
788	END DO
789	END DO
790
791	CASE ( 'U' )
792	DO jk = 1, jpk
793	DO ji = 1, nlci-1
794	iju=iloc-ji
795	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
796	END DO
797	END DO
798
799	CASE ( 'V' )
800	DO jk = 1, jpk
801	DO ji = 1, nlci
802	ijt=iloc-ji+1
803	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)
804	END DO
805	DO ji = nlci/2+1, nlci
806	ijt=iloc-ji+1
807	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
808	END DO
809	END DO
810
811	CASE ( 'F', 'G' )
812	DO jk = 1, jpk
813	DO ji = 1, nlci-1
814	iju=iloc-ji
815	ptab(ji,nlcj,jk) = ptab(iju,nlcj-2,jk)
816	ptab(ji,nlcj ,jk) = ptab(iju,nlcj-3,jk)
817	END DO
818	DO ji = nlci/2+1, nlci-1
819	iju=iloc-ji
820	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
821	END DO
822	END DO
823	END SELECT ! cd_type
824
825	END SELECT ! npolj
826
827	CASE DEFAULT ! more than 1 proc along I
828	IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.
829
830	END SELECT ! jpni
831
832
833	! 5. East and west directions exchange
834	! ------------------------------------
835
836	SELECT CASE ( npolj )
837
838	CASE ( 3, 4, 5, 6 )
839
840	! 5.1 Read Dirichlet lateral conditions
841
842	SELECT CASE ( nbondi )
843
844	CASE ( -1, 0, 1 )
845	iihom = nlci-nreci
846	DO jl = 1, jpreci
847	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
848	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
849	END DO
850
851	END SELECT
852
853	! 5.2 Migrations
854
855	#if defined key_mpp_shmem
856	!! SHMEM version
857
858	imigr = jpreci * jpj * jpk
859
860	SELECT CASE ( nbondi )
861	CASE ( -1 )
862	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
863	CASE ( 0 )
864	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
865	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
866	CASE ( 1 )
867	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
868	END SELECT
869
870	CALL barrier()
871	CALL shmem_udcflush()
872
873	#elif defined key_mpp_mpi
874	!! MPI version
875
876	imigr=jprecijpjjpk
877
878	SELECT CASE ( nbondi )
879	CASE ( -1 )
880	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
881	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
882	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
883	CASE ( 0 )
884	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
885	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
886	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
887	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
888	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
889	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
890	CASE ( 1 )
891	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
892	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
893	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
894	END SELECT
895	#endif
896
897	! 5.3 Write Dirichlet lateral conditions
898
899	iihom = nlci-jpreci
900
901	SELECT CASE ( nbondi)
902	CASE ( -1 )
903	DO jl = 1, jpreci
904	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
905	END DO
906	CASE ( 0 )
907	DO jl = 1, jpreci
908	ptab(jl ,:,:) = t3we(:,jl,:,2)
909	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
910	END DO
911	CASE ( 1 )
912	DO jl = 1, jpreci
913	ptab(jl ,:,:) = t3we(:,jl,:,2)
914	END DO
915	END SELECT
916
917	END SELECT ! npolj
918
919	END SUBROUTINE mpp_lnk_3d
920
921
922	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn )
923	!!----------------------------------------------------------------------
924	!! * routine mpp_lnk_2d *
925	!!
926	!! ** Purpose : Message passing manadgement for 2d array
927	!!
928	!! ** Method : Use mppsend and mpprecv function for passing mask
929	!! between processors following neighboring subdomains.
930	!! domain parameters
931	!! nlci : first dimension of the local subdomain
932	!! nlcj : second dimension of the local subdomain
933	!! nbondi : mark for "east-west local boundary"
934	!! nbondj : mark for "north-south local boundary"
935	!! noea : number for local neighboring processors
936	!! nowe : number for local neighboring processors
937	!! noso : number for local neighboring processors
938	!! nono : number for local neighboring processors
939	!!
940	!!----------------------------------------------------------------------
941	!! * Arguments
942	CHARACTER(len=1) , INTENT( in ) :: &
943	cd_type ! define the nature of pt2d array grid-points
944	! ! = T , U , V , F , W
945	! ! = S : T-point, north fold treatment
946	! ! = G : F-point, north fold treatment
947	! ! = I : sea-ice velocity at F-point with index shift
948	REAL(wp), INTENT( in ) :: &
949	psgn ! control of the sign change
950	! ! = -1. , the sign is changed if north fold boundary
951	! ! = 1. , the sign is kept if north fold boundary
952	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
953	pt2d ! 2D array on which the boundary condition is applied
954
955	!! * Local variables
956	INTEGER :: ji, jj, jl ! dummy loop indices
957	INTEGER :: &
958	imigr, iihom, ijhom, & ! temporary integers
959	iloc, ijt, iju ! " "
960	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
961	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
962	!!----------------------------------------------------------------------
963
964	! 1. standard boundary treatment
965	! ------------------------------
966
967	! ! East-West boundaries
968	! ! ====================
969	IF( nbondi == 2 .AND. & ! Cyclic east-west
970	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
971	pt2d( 1 ,:) = pt2d(jpim1,:)
972	pt2d(jpi,:) = pt2d( 2 ,:)
973
974	ELSE ! ... closed
975	SELECT CASE ( cd_type )
976	CASE ( 'T', 'U', 'V', 'W' , 'I' )
977	pt2d( 1 :jpreci,:) = 0.e0
978	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
979	CASE ( 'F' )
980	pt2d(nlci-jpreci+1:jpi ,:) = 0.e0
981	END SELECT
982	ENDIF
983
984	! ! North-South boundaries
985	! ! ======================
986	SELECT CASE ( cd_type )
987	CASE ( 'T', 'U', 'V', 'W' , 'I' )
988	pt2d(:, 1 :jprecj) = 0.e0
989	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
990	CASE ( 'F' )
991	pt2d(:,nlcj-jprecj+1:jpj ) = 0.e0
992	END SELECT
993
994
995	! 2. East and west directions
996	! ---------------------------
997
998	! 2.1 Read Dirichlet lateral conditions
999
1000	SELECT CASE ( nbondi )
1001	CASE ( -1, 0, 1 ) ! all except 2
1002	iihom = nlci-nreci
1003	DO jl = 1, jpreci
1004	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1005	t2we(:,jl,1) = pt2d(iihom +jl,:)
1006	END DO
1007	END SELECT
1008
1009	! 2.2 Migrations
1010
1011	#if defined key_mpp_shmem
1012	!! * SHMEM version
1013
1014	imigr = jpreci * jpj
1015
1016	SELECT CASE ( nbondi )
1017	CASE ( -1 )
1018	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1019	CASE ( 0 )
1020	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1021	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1022	CASE ( 1 )
1023	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1024	END SELECT
1025
1026	CALL barrier()
1027	CALL shmem_udcflush()
1028
1029	#elif defined key_mpp_mpi
1030	!! * MPI version
1031
1032	imigr = jpreci * jpj
1033
1034	SELECT CASE ( nbondi )
1035	CASE ( -1 )
1036	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1037	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1038	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1039	CASE ( 0 )
1040	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1041	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1042	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1043	CALL mpprecv( 2, t2we(1,1,2), imigr )
1044	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1045	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1046	CASE ( 1 )
1047	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1048	CALL mpprecv( 2, t2we(1,1,2), imigr )
1049	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1050	END SELECT
1051
1052	#endif
1053
1054	! 2.3 Write Dirichlet lateral conditions
1055
1056	iihom = nlci - jpreci
1057	SELECT CASE ( nbondi )
1058	CASE ( -1 )
1059	DO jl = 1, jpreci
1060	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1061	END DO
1062	CASE ( 0 )
1063	DO jl = 1, jpreci
1064	pt2d(jl ,:) = t2we(:,jl,2)
1065	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1066	END DO
1067	CASE ( 1 )
1068	DO jl = 1, jpreci
1069	pt2d(jl ,:) = t2we(:,jl,2)
1070	END DO
1071	END SELECT
1072
1073
1074	! 3. North and south directions
1075	! -----------------------------
1076
1077	! 3.1 Read Dirichlet lateral conditions
1078
1079	IF( nbondj /= 2 ) THEN
1080	ijhom = nlcj-nrecj
1081	DO jl = 1, jprecj
1082	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1083	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1084	END DO
1085	ENDIF
1086
1087	! 3.2 Migrations
1088
1089	#if defined key_mpp_shmem
1090	!! * SHMEM version
1091
1092	imigr = jprecj * jpi
1093
1094	SELECT CASE ( nbondj )
1095	CASE ( -1 )
1096	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1097	CASE ( 0 )
1098	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1099	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1100	CASE ( 1 )
1101	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1102	END SELECT
1103	CALL barrier()
1104	CALL shmem_udcflush()
1105
1106	#elif defined key_mpp_mpi
1107	!! * MPI version
1108
1109	imigr = jprecj * jpi
1110
1111	SELECT CASE ( nbondj )
1112	CASE ( -1 )
1113	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1114	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1115	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1116	CASE ( 0 )
1117	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1118	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1119	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1120	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1121	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1122	IF(lk_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1123	CASE ( 1 )
1124	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1125	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1126	IF(lk_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1127	END SELECT
1128
1129	#endif
1130
1131	! 3.3 Write Dirichlet lateral conditions
1132
1133	ijhom = nlcj - jprecj
1134
1135	SELECT CASE ( nbondj )
1136	CASE ( -1 )
1137	DO jl = 1, jprecj
1138	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1139	END DO
1140	CASE ( 0 )
1141	DO jl = 1, jprecj
1142	pt2d(:,jl ) = t2sn(:,jl,2)
1143	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1144	END DO
1145	CASE ( 1 )
1146	DO jl = 1, jprecj
1147	pt2d(:,jl ) = t2sn(:,jl,2)
1148	END DO
1149	END SELECT
1150
1151
1152	! 4. north fold treatment
1153	! -----------------------
1154
1155	! 4.1 treatment without exchange (jpni odd)
1156
1157	SELECT CASE ( jpni )
1158
1159	CASE ( 1 ) ! only one proc along I, no mpp exchange
1160
1161	SELECT CASE ( npolj )
1162
1163	CASE ( 4 ) ! T pivot
1164	iloc = jpiglo - 2 * ( nimpp - 1 )
1165
1166	SELECT CASE ( cd_type )
1167
1168	CASE ( 'T' , 'S', 'W' )
1169	DO ji = 2, nlci
1170	ijt=iloc-ji+2
1171	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1172	END DO
1173	DO ji = nlci/2+1, nlci
1174	ijt=iloc-ji+2
1175	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1176	END DO
1177
1178	CASE ( 'U' )
1179	DO ji = 1, nlci-1
1180	iju=iloc-ji+1
1181	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1182	END DO
1183	DO ji = nlci/2, nlci-1
1184	iju=iloc-ji+1
1185	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1186	END DO
1187
1188	CASE ( 'V' )
1189	DO ji = 2, nlci
1190	ijt=iloc-ji+2
1191	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1192	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3)
1193	END DO
1194
1195	CASE ( 'F', 'G' )
1196	DO ji = 1, nlci-1
1197	iju=iloc-ji+1
1198	pt2d(ji,nlcj-1) = pt2d(iju,nlcj-2)
1199	pt2d(ji,nlcj ) = pt2d(iju,nlcj-3)
1200	END DO
1201
1202	CASE ( 'I' ) ! ice U-V point
1203	pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1204	DO ji = 3, nlci
1205	iju = iloc - ji + 3
1206	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1207	END DO
1208
1209	END SELECT
1210
1211	CASE (6) ! F pivot
1212	iloc=jpiglo-2*(nimpp-1)
1213
1214	SELECT CASE (cd_type )
1215
1216	CASE ( 'T', 'S', 'W' )
1217	DO ji = 1, nlci
1218	ijt=iloc-ji+1
1219	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1220	END DO
1221
1222	CASE ( 'U' )
1223	DO ji = 1, nlci-1
1224	iju=iloc-ji
1225	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1226	END DO
1227
1228	CASE ( 'V' )
1229	DO ji = 1, nlci
1230	ijt=iloc-ji+1
1231	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2)
1232	END DO
1233	DO ji = nlci/2+1, nlci
1234	ijt=iloc-ji+1
1235	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1236	END DO
1237
1238	CASE ( 'F', 'G' )
1239	DO ji = 1, nlci-1
1240	iju=iloc-ji
1241	pt2d(ji,nlcj) = pt2d(iju,nlcj-2)
1242	pt2d(ji,nlcj ) = pt2d(iju,nlcj-3)
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 !!bug ???
1251	DO ji = 1 , nlci-1 !!bug rob= 2,jpim1
1252	ijt = iloc - ji !!bug rob= ijt=jpi-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) = ztab(iju,ijpj-2,jk)
3274	ztab(ji,ijpj ,jk) = 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) = 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) = 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) = ztab(iju,ijpj-2)
3509	ztab(ji,ijpj ) = 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 ) = ztab(iju,ijpj-2)
3554	END DO
3555	DO ji = jpiglo/2+1, jpiglo-1
3556	iju = jpiglo-ji
3557	ztab(ji,ijpjm1) = ztab(iju,ijpjm1)
3558	END DO
3559
3560	END SELECT
3561
3562	CASE DEFAULT ! * closed : the code probably never go through
3563
3564	SELECT CASE ( cd_type)
3565
3566	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
3567	ztab(:, 1 ) = 0.e0
3568	ztab(:,ijpj) = 0.e0
3569
3570	CASE ( 'F' ) ! F-point
3571	ztab(:,ijpj) = 0.e0
3572
3573	CASE ( 'I' ) ! ice U-V point
3574	ztab(:, 1 ) = 0.e0
3575	ztab(:,ijpj) = 0.e0
3576
3577	END SELECT
3578
3579	END SELECT
3580
3581	! End of slab
3582	! ===========
3583
3584	!! Scatter back to pt2d
3585	DO jr = 1, ndim_rank_north
3586	jproc=nrank_north(jr)+1
3587	ildi=nldit (jproc)
3588	ilei=nleit (jproc)
3589	iilb=nimppt(jproc)
3590	DO jj=1,ijpj
3591	DO ji=ildi,ilei
3592	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
3593	END DO
3594	END DO
3595	END DO
3596
3597	ENDIF ! only done on proc 0 of ncomm_north
3598
3599	#ifdef key_mpp_shmem
3600	not done yet in shmem : compiler error
3601	#elif key_mpp_mpi
3602	IF ( npolj /= 0 ) THEN
3603	itaille=jpi*ijpj
3604	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
3605	ENDIF
3606	#endif
3607
3608	! put in the last ijpj jlines of pt2d znorthloc
3609	DO jj = nlcj - ijpj + 1 , nlcj
3610	ij = jj - nlcj + ijpj
3611	pt2d(:,jj)= znorthloc(:,ij)
3612	END DO
3613
3614	END SUBROUTINE mpp_lbc_north_2d
3615
3616
3617	!!!!!
3618
3619
3620	!!
3621	!! This is valid on IBM machine ONLY.
3622	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -- Mode: F90 -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3623	!! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque
3624	!! MPI afin de faire, en plus de l'initialisation de
3625	!! l'environnement MPI, l'allocation d'une zone tampon
3626	!! qui sera ulterieurement utilisee automatiquement lors
3627	!! de tous les envois de messages par MPI_BSEND
3628	!!
3629	!! Auteur : CNRS/IDRIS
3630	!! Date : Tue Nov 13 12:02:14 2001
3631	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3632
3633	SUBROUTINE mpi_init_opa(code)
3634	IMPLICIT NONE
3635	# include <mpif.h>
3636
3637	INTEGER :: code,rang
3638
3639	! La valeur suivante doit etre au moins egale a la taille
3640	! du plus grand message qui sera transfere dans le programme
3641	! (de toute facon, il y aura un message d'erreur si cette
3642	! valeur s'avere trop petite)
3643	INTEGER :: taille_tampon
3644	CHARACTER(len=9) :: taille_tampon_alphanum
3645	REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon
3646
3647	! Le point d'entree dans la bibliotheque MPI elle-meme
3648	CALL mpi_init(code)
3649
3650	! La definition de la zone tampon pour les futurs envois
3651	! par MPI_BSEND (on alloue une fois pour toute cette zone
3652	! tampon, qui sera automatiquement utilisee lors de chaque
3653	! appel a MPI_BSEND).
3654	! La desallocation sera implicite quand on sortira de
3655	! l'environnement MPI.
3656
3657	! Recuperation de la valeur de la variable d'environnement
3658	! BUFFER_LENGTH
3659	! qui, si elle est definie, doit contenir une valeur superieure
3660	! a la taille en octets du plus gros message
3661	CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum)
3662
3663	! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par
3664	! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit
3665	! 65 536 octets
3666	IF (taille_tampon_alphanum == ' ') THEN
3667	taille_tampon = 65536
3668	ELSE
3669	READ(taille_tampon_alphanum,'(i9)') taille_tampon
3670	END IF
3671
3672	! On est limite en mode d'adressage 32 bits a 1750 Mo pour la zone
3673	! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo
3674	IF (taille_tampon > 210000000) THEN
3675	PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000'
3676	CALL mpi_abort(MPI_COMM_WORLD,2,code)
3677	END IF
3678
3679	CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code)
3680	IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon
3681
3682	! Allocation du tampon et attachement
3683	ALLOCATE(tampon(taille_tampon))
3684	CALL mpi_buffer_attach(tampon,taille_tampon,code)
3685
3686	END SUBROUTINE mpi_init_opa
3687
3688
3689	#else
3690	!!----------------------------------------------------------------------
3691	!! Default case: Dummy module share memory computing
3692	!!----------------------------------------------------------------------
3693	INTERFACE mpp_sum
3694	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
3695	END INTERFACE
3696	INTERFACE mpp_max
3697	MODULE PROCEDURE mppmax_a_real, mppmax_real
3698	END INTERFACE
3699	INTERFACE mpp_min
3700	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
3701	END INTERFACE
3702	INTERFACE mpp_isl
3703	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
3704	END INTERFACE
3705	INTERFACE mppobc
3706	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
3707	END INTERFACE
3708	INTERFACE mpp_minloc
3709	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
3710	END INTERFACE
3711	INTERFACE mpp_maxloc
3712	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
3713	END INTERFACE
3714
3715
3716	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
3717
3718	CONTAINS
3719
3720	FUNCTION mynode() RESULT (function_value)
3721	function_value = 0
3722	END FUNCTION mynode
3723
3724	SUBROUTINE mppsync ! Dummy routine
3725	END SUBROUTINE mppsync
3726
3727	SUBROUTINE mpp_sum_as( parr, kdim ) ! Dummy routine
3728	REAL , DIMENSION(:) :: parr
3729	INTEGER :: kdim
3730	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1)
3731	END SUBROUTINE mpp_sum_as
3732
3733	SUBROUTINE mpp_sum_a2s( parr, kdim ) ! Dummy routine
3734	REAL , DIMENSION(:,:) :: parr
3735	INTEGER :: kdim
3736	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1)
3737	END SUBROUTINE mpp_sum_a2s
3738
3739	SUBROUTINE mpp_sum_ai( karr, kdim ) ! Dummy routine
3740	INTEGER, DIMENSION(:) :: karr
3741	INTEGER :: kdim
3742	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1)
3743	END SUBROUTINE mpp_sum_ai
3744
3745	SUBROUTINE mpp_sum_s( psca ) ! Dummy routine
3746	REAL :: psca
3747	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca
3748	END SUBROUTINE mpp_sum_s
3749
3750	SUBROUTINE mpp_sum_i( kint ) ! Dummy routine
3751	integer :: kint
3752	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint
3753	END SUBROUTINE mpp_sum_i
3754
3755	SUBROUTINE mppmax_a_real( parr, kdim )
3756	REAL , DIMENSION(:) :: parr
3757	INTEGER :: kdim
3758	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1)
3759	END SUBROUTINE mppmax_a_real
3760
3761	SUBROUTINE mppmax_real( psca )
3762	REAL :: psca
3763	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca
3764	END SUBROUTINE mppmax_real
3765
3766	SUBROUTINE mppmin_a_real( parr, kdim )
3767	REAL , DIMENSION(:) :: parr
3768	INTEGER :: kdim
3769	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1)
3770	END SUBROUTINE mppmin_a_real
3771
3772	SUBROUTINE mppmin_real( psca )
3773	REAL :: psca
3774	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca
3775	END SUBROUTINE mppmin_real
3776
3777	SUBROUTINE mppmin_a_int( karr, kdim )
3778	INTEGER, DIMENSION(:) :: karr
3779	INTEGER :: kdim
3780	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1)
3781	END SUBROUTINE mppmin_a_int
3782
3783	SUBROUTINE mppmin_int( kint )
3784	INTEGER :: kint
3785	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint
3786	END SUBROUTINE mppmin_int
3787
3788	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
3789	INTEGER :: kd1, kd2, kl , kk, ktype, kij
3790	REAL, DIMENSION(:) :: parr ! variable array
3791	WRITE(,) 'mppobc: You should not have seen this print! error?', &
3792	& parr(1), kd1, kd2, kl, kk, ktype, kij
3793	END SUBROUTINE mppobc_1d
3794
3795	SUBROUTINE mppobc_2d( 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,1), kd1, kd2, kl, kk, ktype, kij
3800	END SUBROUTINE mppobc_2d
3801
3802	SUBROUTINE mppobc_3d( 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,1), kd1, kd2, kl, kk, ktype, kij
3807	END SUBROUTINE mppobc_3d
3808
3809	SUBROUTINE mppobc_4d( 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,1), kd1, kd2, kl, kk, ktype, kij
3814	END SUBROUTINE mppobc_4d
3815
3816
3817	SUBROUTINE mpplnks( parr ) ! Dummy routine
3818	REAL, DIMENSION(:,:) :: parr
3819	WRITE(,) 'mpplnks: You should not have seen this print! error?', parr(1,1)
3820	END SUBROUTINE mpplnks
3821
3822	SUBROUTINE mppisl_a_int( karr, kdim )
3823	INTEGER, DIMENSION(:) :: karr
3824	INTEGER :: kdim
3825	WRITE(,) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1)
3826	END SUBROUTINE mppisl_a_int
3827
3828	SUBROUTINE mppisl_int( kint )
3829	INTEGER :: kint
3830	WRITE(,) 'mppisl_int: You should not have seen this print! error?', kint
3831	END SUBROUTINE mppisl_int
3832
3833	SUBROUTINE mppisl_a_real( parr, kdim )
3834	REAL , DIMENSION(:) :: parr
3835	INTEGER :: kdim
3836	WRITE(,) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1)
3837	END SUBROUTINE mppisl_a_real
3838
3839	SUBROUTINE mppisl_real( psca )
3840	REAL :: psca
3841	WRITE(,) 'mppisl_real: You should not have seen this print! error?', psca
3842	END SUBROUTINE mppisl_real
3843
3844	SUBROUTINE mpp_minloc2d ( ptab, pmask, pmin, ki, kj )
3845	REAL :: pmin
3846	REAL , DIMENSION (:,:) :: ptab, pmask
3847	INTEGER :: ki, kj
3848	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj
3849	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3850	END SUBROUTINE mpp_minloc2d
3851
3852	SUBROUTINE mpp_minloc3d ( ptab, pmask, pmin, ki, kj, kk )
3853	REAL :: pmin
3854	REAL , DIMENSION (:,:,:) :: ptab, pmask
3855	INTEGER :: ki, kj, kk
3856	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj, kk
3857	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3858	END SUBROUTINE mpp_minloc3d
3859
3860	SUBROUTINE mpp_maxloc2d ( ptab, pmask, pmax, ki, kj )
3861	REAL :: pmax
3862	REAL , DIMENSION (:,:) :: ptab, pmask
3863	INTEGER :: ki, kj
3864	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj
3865	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
3866	END SUBROUTINE mpp_maxloc2d
3867
3868	SUBROUTINE mpp_maxloc3d ( ptab, pmask, pmax, ki, kj, kk )
3869	REAL :: pmax
3870	REAL , DIMENSION (:,:,:) :: ptab, pmask
3871	INTEGER :: ki, kj, kk
3872	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj, kk
3873	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
3874	END SUBROUTINE mpp_maxloc3d
3875
3876	SUBROUTINE mppstop
3877	WRITE(,) 'mppstop: You should not have seen this print! error?'
3878	END SUBROUTINE mppstop
3879
3880	#endif
3881	!!----------------------------------------------------------------------
3882	END MODULE lib_mpp

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

Download in other formats: