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

Context Navigation

source: tags/nemo_dev_x6/NEMO/OPA_SRC/lib_mpp.F90 @ 3532

Last change on this file since 3532 was 51, checked in by opalod, 20 years ago

CT : BUGFIX025 : # Change the name and type of karr variable to parr and REAL in the dummy subroutine mpplnks to avoid error

# Add the missing North fold W and I points for both 2d and 3d arrays in mpp case
# Add a dummy mppstop subroutine to avoid comilation error when using the -eC option on the SX5-NEC

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 114.2 KB

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

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

Download in other formats: