New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/lib_mpp.F90 @ 182

Last change on this file since 182 was 181, checked in by opalod, 20 years ago
CT : UPDATE126 : improve MPI send possiblities with mpi_bsen and mpi_isend; update the search of extremum of scale factors in mpp
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 127.7 KB

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

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

Download in other formats: