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

Context Navigation

source: tags/nemo_dev_x1/NEMO/OPA_SRC/lib_mpp.F90 @ 6474

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

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

Download in other formats: