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 tags/start/NEMO/OPA_SRC – NEMO

Context Navigation

source: tags/start/NEMO/OPA_SRC/lib_mpp.F90 @ 2915

Last change on this file since 2915 was 3, checked in by opalod, 20 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 132.9 KB

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

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

Download in other formats: