Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.F90 @ 1944

Last change on this file since 1944 was 1884, checked in by rblod, 14 years ago
Light adaptation of NEMO direct model routine to handle TAM
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 185.3 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	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
17	!! mpp_lnk_e : interface defined in lbclnk
18	!! mpplnks
19	!! mpprecv
20	!! mppsend
21	!! mppscatter
22	!! mppgather
23	!! mpp_isl : generic inteface for :
24	!! mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real
25	!! mpp_min : generic interface for :
26	!! mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
27	!! mpp_max : generic interface for :
28	!! mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
29	!! mpp_sum : generic interface for :
30	!! mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
31	!! mpp_minloc
32	!! mpp_maxloc
33	!! mppsync
34	!! mppstop
35	!! mppobc : variant of mpp_lnk for open boundaries
36	!! mpp_ini_north
37	!! mpp_lbc_north
38	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo (nsolv=4)
39	!!----------------------------------------------------------------------
40	!! History :
41	!! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code
42	!! ! 97 (A.M. Treguier) SHMEM additions
43	!! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
44	!! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form
45	!! ! 04 (R. Bourdalle Badie) isend option in mpi
46	!! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
47	!! ! 05 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
48	!!----------------------------------------------------------------------
49	!! OPA 9.0 , LOCEAN-IPSL (2005)
50	!! $Id$
51	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
52	!!---------------------------------------------------------------------
53	!! * Modules used
54	USE dom_oce ! ocean space and time domain
55	USE in_out_manager ! I/O manager
56
57	IMPLICIT NONE
58
59	PRIVATE
60	PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north
61	PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks
62	PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free
63	#if defined key_oasis3 \|\| defined key_oasis4
64	PUBLIC mppsize, mpprank
65	#endif
66
67	!! * Interfaces
68	!! define generic interface for these routine as they are called sometimes
69	!! with scalar arguments instead of array arguments, which causes problems
70	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
71
72	INTERFACE mpp_isl
73	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
74	END INTERFACE
75	INTERFACE mpp_min
76	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
77	END INTERFACE
78	INTERFACE mpp_max
79	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
80	END INTERFACE
81	INTERFACE mpp_sum
82	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
83	END INTERFACE
84	INTERFACE mpp_lbc_north
85	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
86	END INTERFACE
87	INTERFACE mpp_minloc
88	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
89	END INTERFACE
90	INTERFACE mpp_maxloc
91	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
92	END INTERFACE
93
94
95	!! * Share module variables
96	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
97
98	!! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,...
99	INTEGER, PARAMETER :: &
100	nprocmax = 2**10 ! maximun dimension
101
102	#if defined key_mpp_mpi
103	!! ========================= !!
104	!! MPI variable definition !!
105	!! ========================= !!
106	!$AGRIF_DO_NOT_TREAT
107	# include <mpif.h>
108	!$AGRIF_END_DO_NOT_TREAT
109
110	INTEGER :: &
111	mppsize, & ! number of process
112	mpprank ! process number [ 0 - size-1 ]
113
114	INTEGER, PUBLIC :: &
115	mpi_comm_opa ! opa local communicator
116
117	! variables used in case of sea-ice
118	INTEGER, PUBLIC :: & !
119	ngrp_ice, & ! group ID for the ice processors (to compute rheology)
120	ncomm_ice, & ! communicator made by the processors with sea-ice
121	ndim_rank_ice, & ! number of 'ice' processors
122	n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
123	INTEGER, DIMENSION(:), ALLOCATABLE :: &
124	nrank_ice ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
125	! variables used in case of north fold condition in mpp_mpi with jpni > 1
126	INTEGER, PUBLIC :: & !
127	ngrp_world, & ! group ID for the world processors
128	ngrp_north, & ! group ID for the northern processors (to be fold)
129	ncomm_north, & ! communicator made by the processors belonging to ngrp_north
130	ndim_rank_north, & ! number of 'sea' processor in the northern line (can be /= jpni !)
131	njmppmax ! value of njmpp for the processors of the northern line
132	INTEGER, PUBLIC :: & !
133	north_root ! number (in the comm_opa) of proc 0 in the northern comm
134	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE :: &
135	nrank_north ! dimension ndim_rank_north, number of the procs belonging to ncomm_north
136	CHARACTER (len=1) :: &
137	c_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
138	LOGICAL, PUBLIC :: &
139	l_isend = .FALSE. ! isend use indicator (T if c_mpi_send='I')
140	INTEGER :: & ! size of the buffer in case of mpi_bsend
141	nn_buffer = 0
142
143	#elif defined key_mpp_shmem
144	!! ========================= !!
145	!! SHMEM variable definition !!
146	!! ========================= !!
147	# include <fpvm3.h>
148	# include <mpp/shmem.fh>
149
150	CHARACTER (len=80), PARAMETER :: simfile = 'pvm3_ndim' ! file name
151	CHARACTER (len=47), PARAMETER :: executable = 'opa' ! executable name
152	CHARACTER, PARAMETER :: opaall = "" ! group name (old def opaall())
153
154	INTEGER, PARAMETER :: & !! SHMEM control print
155	mynode_print = 0, & ! flag for print, mynode routine
156	mpprecv_print = 0, & ! flag for print, mpprecv routine
157	mppsend_print = 0, & ! flag for print, mppsend routine
158	mppsync_print = 0, & ! flag for print, mppsync routine
159	mppsum_print = 0, & ! flag for print, mpp_sum routine
160	mppisl_print = 0, & ! flag for print, mpp_isl routine
161	mppmin_print = 0, & ! flag for print, mpp_min routine
162	mppmax_print = 0, & ! flag for print, mpp_max routine
163	mpparent_print = 0 ! flag for print, mpparent routine
164
165	INTEGER, PARAMETER :: & !! Variable definition
166	jpvmint = 21 ! ???
167
168	INTEGER, PARAMETER :: & !! Maximum dimension of array to sum on the processors
169	jpmsec = 50000, & ! ???
170	jpmpplat = 30, & ! ???
171	jpmppsum = MAX( jpisljpisl, jpmpplatjpk, jpmsec ) ! ???
172
173	INTEGER :: &
174	npvm_ipas , & ! pvm initialization flag
175	npvm_mytid, & ! pvm tid
176	npvm_me , & ! node number [ 0 - nproc-1 ]
177	npvm_nproc, & ! real number of nodes
178	npvm_inum ! ???
179	INTEGER, DIMENSION(0:nprocmax-1) :: &
180	npvm_tids ! tids array [ 0 - nproc-1 ]
181
182	INTEGER :: &
183	nt3d_ipas , & ! pvm initialization flag
184	nt3d_mytid, & ! pvm tid
185	nt3d_me , & ! node number [ 0 - nproc-1 ]
186	nt3d_nproc ! real number of nodes
187	INTEGER, DIMENSION(0:nprocmax-1) :: &
188	nt3d_tids ! tids array [ 0 - nproc-1 ]
189
190	!! real sum reduction
191	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
192	nrs1sync_shmem, & !
193	nrs2sync_shmem
194	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
195	wrs1wrk_shmem, & !
196	wrs2wrk_shmem !
197	REAL(wp), DIMENSION(jpmppsum) :: &
198	wrstab_shmem !
199
200	!! minimum and maximum reduction
201	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
202	ni1sync_shmem, & !
203	ni2sync_shmem !
204	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
205	wi1wrk_shmem, & !
206	wi2wrk_shmem
207	REAL(wp), DIMENSION(jpmppsum) :: &
208	wintab_shmem, & !
209	wi1tab_shmem, & !
210	wi2tab_shmem !
211
212	!! value not equal zero for barotropic stream function around islands
213	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
214	ni11sync_shmem, & !
215	ni12sync_shmem, & !
216	ni21sync_shmem, & !
217	ni22sync_shmem !
218	REAL(wp), DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
219	wi11wrk_shmem, & !
220	wi12wrk_shmem, & !
221	wi21wrk_shmem, & !
222	wi22wrk_shmem !
223	REAL(wp), DIMENSION(jpmppsum) :: &
224	wiltab_shmem , & !
225	wi11tab_shmem, & !
226	wi12tab_shmem, & !
227	wi21tab_shmem, & !
228	wi22tab_shmem
229
230	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
231	ni11wrk_shmem, & !
232	ni12wrk_shmem, & !
233	ni21wrk_shmem, & !
234	ni22wrk_shmem !
235	INTEGER, DIMENSION(jpmppsum) :: &
236	niitab_shmem , & !
237	ni11tab_shmem, & !
238	ni12tab_shmem !
239	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
240	nis1sync_shmem, & !
241	nis2sync_shmem !
242	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
243	nis1wrk_shmem, & !
244	nis2wrk_shmem !
245	INTEGER, DIMENSION(jpmppsum) :: &
246	nistab_shmem
247
248	!! integer sum reduction
249	INTEGER, DIMENSION(SHMEM_REDUCE_SYNC_SIZE) :: &
250	nil1sync_shmem, & !
251	nil2sync_shmem !
252	INTEGER, DIMENSION( MAX( SHMEM_REDUCE_MIN_WRKDATA_SIZE, jpmppsum/2+1 ) ) :: &
253	nil1wrk_shmem, & !
254	nil2wrk_shmem !
255	INTEGER, DIMENSION(jpmppsum) :: &
256	niltab_shmem
257	#endif
258
259	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: &
260	t4ns, t4sn ! 3d message passing arrays north-south & south-north
261	REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: &
262	t4ew, t4we ! 3d message passing arrays east-west & west-east
263	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: &
264	t4p1, t4p2 ! 3d message passing arrays north fold
265	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
266	t3ns, t3sn ! 3d message passing arrays north-south & south-north
267	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: &
268	t3ew, t3we ! 3d message passing arrays east-west & west-east
269	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: &
270	t3p1, t3p2 ! 3d message passing arrays north fold
271	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
272	t2ns, t2sn ! 2d message passing arrays north-south & south-north
273	REAL(wp), DIMENSION(jpj,jpreci,2) :: &
274	t2ew, t2we ! 2d message passing arrays east-west & west-east
275	REAL(wp), DIMENSION(jpi,jprecj,2) :: &
276	t2p1, t2p2 ! 2d message passing arrays north fold
277	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) :: &
278	tr2ns, tr2sn ! 2d message passing arrays north-south & south-north including extra outer halo
279	REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) :: &
280	tr2ew, tr2we ! 2d message passing arrays east-west & west-east including extra outer halo
281	!!----------------------------------------------------------------------
282	!! OPA 9.0 , LOCEAN-IPSL (2005)
283	!! $Id$
284	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
285	!!---------------------------------------------------------------------
286
287	CONTAINS
288
289	FUNCTION mynode(localComm)
290	!!----------------------------------------------------------------------
291	!! * routine mynode *
292	!!
293	!! ** Purpose : Find processor unit
294	!!
295	!!----------------------------------------------------------------------
296	#if defined key_mpp_mpi
297	!! * Local variables (MPI version)
298	INTEGER :: mynode, ierr, code
299	LOGICAL :: mpi_was_called
300	INTEGER,OPTIONAL :: localComm
301	NAMELIST/nam_mpp/ c_mpi_send, nn_buffer
302	!!----------------------------------------------------------------------
303
304	WRITE(numout,*)
305	WRITE(numout,*) 'mynode : mpi initialisation'
306	WRITE(numout,*) '~~~~~~ '
307	WRITE(numout,*)
308
309	! Namelist namrun : parameters of the run
310	REWIND( numnam )
311	READ ( numnam, nam_mpp )
312
313	WRITE(numout,*) ' Namelist nam_mpp'
314	WRITE(numout,*) ' mpi send type c_mpi_send = ', c_mpi_send
315
316	#if defined key_agrif
317	IF( Agrif_Root() ) THEN
318	#endif
319	!!bug RB : should be clean to use Agrif in coupled mode
320	#if ! defined key_agrif
321	CALL mpi_initialized ( mpi_was_called, code )
322	IF( code /= MPI_SUCCESS ) THEN
323	CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
324	CALL mpi_abort( mpi_comm_world, code, ierr )
325	ENDIF
326
327	IF( PRESENT(localComm) .and. mpi_was_called ) THEN
328	mpi_comm_opa = localComm
329	SELECT CASE ( c_mpi_send )
330	CASE ( 'S' ) ! Standard mpi send (blocking)
331	WRITE(numout,*) ' Standard blocking mpi send (send)'
332	CASE ( 'B' ) ! Buffer mpi send (blocking)
333	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
334	CALL mpi_init_opa( ierr )
335	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
336	WRITE(numout,*) ' Immediate non-blocking send (isend)'
337	l_isend = .TRUE.
338	CASE DEFAULT
339	WRITE(numout,cform_err)
340	WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send
341	nstop = nstop + 1
342	END SELECT
343	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
344	WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator '
345	WRITE(numout,*) ' without calling MPI_Init before ! '
346	ELSE
347	#endif
348	SELECT CASE ( c_mpi_send )
349	CASE ( 'S' ) ! Standard mpi send (blocking)
350	WRITE(numout,*) ' Standard blocking mpi send (send)'
351	CALL mpi_init( ierr )
352	CASE ( 'B' ) ! Buffer mpi send (blocking)
353	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
354	CALL mpi_init_opa( ierr )
355	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
356	WRITE(numout,*) ' Immediate non-blocking send (isend)'
357	l_isend = .TRUE.
358	CALL mpi_init( ierr )
359	CASE DEFAULT
360	WRITE(ctmp1,*) ' bad value for c_mpi_send = ', c_mpi_send
361	CALL ctl_stop( ctmp1 )
362	END SELECT
363
364	#if ! defined key_agrif
365	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
366	IF( code /= MPI_SUCCESS ) THEN
367	CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
368	CALL mpi_abort( mpi_comm_world, code, ierr )
369	ENDIF
370	!
371	ENDIF
372	#endif
373	#if defined key_agrif
374	ELSE
375	SELECT CASE ( c_mpi_send )
376	CASE ( 'S' ) ! Standard mpi send (blocking)
377	WRITE(numout,*) ' Standard blocking mpi send (send)'
378	CASE ( 'B' ) ! Buffer mpi send (blocking)
379	WRITE(numout,*) ' Buffer blocking mpi send (bsend)'
380	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
381	WRITE(numout,*) ' Immediate non-blocking send (isend)'
382	l_isend = .TRUE.
383	CASE DEFAULT
384	WRITE(numout,cform_err)
385	WRITE(numout,*) ' bad value for c_mpi_send = ', c_mpi_send
386	nstop = nstop + 1
387	END SELECT
388	ENDIF
389
390	mpi_comm_opa = mpi_comm_world
391	#endif
392	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
393	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
394	mynode = mpprank
395	#else
396	!! * Local variables (SHMEM version)
397	INTEGER :: mynode
398	INTEGER :: &
399	imypid, imyhost, ji, info, iparent_tid
400	!!----------------------------------------------------------------------
401
402	IF( npvm_ipas /= nprocmax ) THEN
403	! --- first passage in mynode
404	! -------------
405	! enroll in pvm
406	! -------------
407	CALL pvmfmytid( npvm_mytid )
408	IF( mynode_print /= 0 ) THEN
409	WRITE(numout,*) 'mynode, npvm_ipas =', npvm_ipas, ' nprocmax=', nprocmax
410	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, ' after pvmfmytid'
411	ENDIF
412
413	! ---------------------------------------------------------------
414	! find out IF i am parent or child spawned processes have parents
415	! ---------------------------------------------------------------
416	CALL mpparent( iparent_tid )
417	IF( mynode_print /= 0 ) THEN
418	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
419	& ' after mpparent, npvm_tids(0) = ', &
420	& npvm_tids(0), ' iparent_tid=', iparent_tid
421	ENDIF
422	IF( iparent_tid < 0 ) THEN
423	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
424	& ' after mpparent, npvm_tids(0) = ', &
425	& npvm_tids(0), ' iparent_tid=', iparent_tid
426	npvm_tids(0) = npvm_mytid
427	npvm_me = 0
428	IF( jpnij > nprocmax ) THEN
429	WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great'
430	CALL ctl_stop( ctmp1 )
431
432	ELSE
433	npvm_nproc = jpnij
434	ENDIF
435
436	! -------------------------
437	! start up copies of myself
438	! -------------------------
439	IF( npvm_nproc > 1 ) THEN
440	DO ji = 1, npvm_nproc-1
441	npvm_tids(ji) = nt3d_tids(ji)
442	END DO
443	info=npvm_nproc-1
444
445	IF( mynode_print /= 0 ) THEN
446	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
447	& ' maitre=',executable,' info=', info &
448	& ,' npvm_nproc=',npvm_nproc
449	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
450	& ' npvm_tids ',(npvm_tids(ji),ji=0,npvm_nproc-1)
451	ENDIF
452
453	! ---------------------------
454	! multicast tids array to children
455	! ---------------------------
456	CALL pvmfinitsend( pvmdefault, info )
457	CALL pvmfpack ( jpvmint, npvm_nproc, 1 , 1, info )
458	CALL pvmfpack ( jpvmint, npvm_tids , npvm_nproc, 1, info )
459	CALL pvmfmcast( npvm_nproc-1, npvm_tids(1), 10, info )
460	ENDIF
461	ELSE
462
463	! ---------------------------------
464	! receive the tids array and set me
465	! ---------------------------------
466	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, ' pvmfrecv'
467	CALL pvmfrecv( iparent_tid, 10, info )
468	IF( mynode_print /= 0 ) WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, " fin pvmfrecv"
469	CALL pvmfunpack( jpvmint, npvm_nproc, 1 , 1, info )
470	CALL pvmfunpack( jpvmint, npvm_tids , npvm_nproc, 1, info )
471	IF( mynode_print /= 0 ) THEN
472	WRITE(numout,*) 'mynode, npvm_mytid=',npvm_mytid, &
473	& ' esclave=', executable,' info=', info,' npvm_nproc=',npvm_nproc
474	WRITE(numout,*) 'mynode, npvm_mytid=', npvm_mytid, &
475	& 'npvm_tids', ( npvm_tids(ji), ji = 0, npvm_nproc-1 )
476	ENDIF
477	DO ji = 0, npvm_nproc-1
478	IF( npvm_mytid == npvm_tids(ji) ) npvm_me = ji
479	END DO
480	ENDIF
481
482	! ------------------------------------------------------------
483	! all nproc tasks are equal now
484	! and can address each other by tids(0) thru tids(nproc-1)
485	! for each process me => process number [0-(nproc-1)]
486	! ------------------------------------------------------------
487	CALL pvmfjoingroup ( "bidon", info )
488	CALL pvmfbarrier ( "bidon", npvm_nproc, info )
489	DO ji = 0, npvm_nproc-1
490	IF( ji == npvm_me ) THEN
491	CALL pvmfjoingroup ( opaall, npvm_inum )
492	IF( npvm_inum /= npvm_me ) WRITE(numout,*) 'mynode not arrived in the good order for opaall'
493	ENDIF
494	CALL pvmfbarrier( "bidon", npvm_nproc, info )
495	END DO
496	CALL pvmfbarrier( opaall, npvm_nproc, info )
497
498	ELSE
499	! --- other passage in mynode
500	ENDIF
501
502	npvm_ipas = nprocmax
503	mynode = npvm_me
504	imypid = npvm_mytid
505	imyhost = npvm_tids(0)
506	IF( mynode_print /= 0 ) THEN
507	WRITE(numout,*)'mynode: npvm_mytid=', npvm_mytid, ' npvm_me=', npvm_me, &
508	& ' npvm_nproc=', npvm_nproc , ' npvm_ipas=', npvm_ipas
509	ENDIF
510	#endif
511	END FUNCTION mynode
512
513
514	SUBROUTINE mpparent( kparent_tid )
515	!!----------------------------------------------------------------------
516	!! * routine mpparent *
517	!!
518	!! ** Purpose : use an pvmfparent routine for T3E (key_mpp_shmem)
519	!! or only return -1 (key_mpp_mpi)
520	!!----------------------------------------------------------------------
521	!! * Arguments
522	INTEGER, INTENT(inout) :: kparent_tid ! ???
523
524	#if defined key_mpp_mpi
525	! MPI version : retour -1
526
527	kparent_tid = -1
528
529	#else
530	!! * Local variables (SHMEN onto T3E version)
531	INTEGER :: &
532	it3d_my_pe, LEADZ, ji, info
533
534	CALL pvmfmytid( nt3d_mytid )
535	CALL pvmfgetpe( nt3d_mytid, it3d_my_pe )
536	IF( mpparent_print /= 0 ) THEN
537	WRITE(numout,*) 'mpparent: nt3d_mytid= ', nt3d_mytid ,' it3d_my_pe=',it3d_my_pe
538	ENDIF
539	IF( it3d_my_pe == 0 ) THEN
540	!-----------------------------------------------------------------!
541	! process = 0 => receive other tids !
542	!-----------------------------------------------------------------!
543	kparent_tid = -1
544	IF(mpparent_print /= 0 ) THEN
545	WRITE(numout,*) 'mpparent, nt3d_mytid=',nt3d_mytid ,' kparent_tid=',kparent_tid
546	ENDIF
547	! --- END receive dimension ---
548	IF( jpnij > nprocmax ) THEN
549	WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great'
550	CALL ctl_stop( ctmp1 )
551	ELSE
552	nt3d_nproc = jpnij
553	ENDIF
554	IF( mpparent_print /= 0 ) THEN
555	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_nproc=', nt3d_nproc
556	ENDIF
557	!-------- receive tids from others process --------
558	DO ji = 1, nt3d_nproc-1
559	CALL pvmfrecv( ji , 100, info )
560	CALL pvmfunpack( jpvmint, nt3d_tids(ji), 1, 1, info )
561	IF( mpparent_print /= 0 ) THEN
562	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' receive=', nt3d_tids(ji), ' from = ', ji
563	ENDIF
564	END DO
565	nt3d_tids(0) = nt3d_mytid
566	IF( mpparent_print /= 0 ) THEN
567	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' nt3d_tids(ji) =', (nt3d_tids(ji), &
568	ji = 0, nt3d_nproc-1 )
569	WRITE(numout,*) 'mpparent, nt3d_mytid=', nt3d_mytid , ' kparent_tid=', kparent_tid
570	ENDIF
571
572	ELSE
573	!!----------------------------------------------------------------!
574	! process <> 0 => send other tids !
575	!!----------------------------------------------------------------!
576	kparent_tid = 0
577	CALL pvmfinitsend( pvmdataraw, info )
578	CALL pvmfpack( jpvmint, nt3d_mytid, 1, 1, info )
579	CALL pvmfsend( kparent_tid, 100, info )
580	ENDIF
581	#endif
582
583	END SUBROUTINE mpparent
584
585	#if defined key_mpp_shmem
586
587	SUBROUTINE mppshmem
588	!!----------------------------------------------------------------------
589	!! * routine mppshmem *
590	!!
591	!! ** Purpose : SHMEM ROUTINE
592	!!
593	!!----------------------------------------------------------------------
594	nrs1sync_shmem = SHMEM_SYNC_VALUE
595	nrs2sync_shmem = SHMEM_SYNC_VALUE
596	nis1sync_shmem = SHMEM_SYNC_VALUE
597	nis2sync_shmem = SHMEM_SYNC_VALUE
598	nil1sync_shmem = SHMEM_SYNC_VALUE
599	nil2sync_shmem = SHMEM_SYNC_VALUE
600	ni11sync_shmem = SHMEM_SYNC_VALUE
601	ni12sync_shmem = SHMEM_SYNC_VALUE
602	ni21sync_shmem = SHMEM_SYNC_VALUE
603	ni22sync_shmem = SHMEM_SYNC_VALUE
604	CALL barrier()
605
606	END SUBROUTINE mppshmem
607
608	#endif
609
610	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
611	!!----------------------------------------------------------------------
612	!! * routine mpp_lnk_3d *
613	!!
614	!! ** Purpose : Message passing manadgement
615	!!
616	!! ** Method : Use mppsend and mpprecv function for passing mask
617	!! between processors following neighboring subdomains.
618	!! domain parameters
619	!! nlci : first dimension of the local subdomain
620	!! nlcj : second dimension of the local subdomain
621	!! nbondi : mark for "east-west local boundary"
622	!! nbondj : mark for "north-south local boundary"
623	!! noea : number for local neighboring processors
624	!! nowe : number for local neighboring processors
625	!! noso : number for local neighboring processors
626	!! nono : number for local neighboring processors
627	!!
628	!! ** Action : ptab with update value at its periphery
629	!!
630	!!----------------------------------------------------------------------
631	!! * Arguments
632	CHARACTER(len=1) , INTENT( in ) :: &
633	cd_type ! define the nature of ptab array grid-points
634	! ! = T , U , V , F , W points
635	! ! = S : T-point, north fold treatment ???
636	! ! = G : F-point, north fold treatment ???
637	REAL(wp), INTENT( in ) :: &
638	psgn ! control of the sign change
639	! ! = -1. , the sign is changed if north fold boundary
640	! ! = 1. , the sign is kept if north fold boundary
641	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
642	ptab ! 3D array on which the boundary condition is applied
643	CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
644	cd_mpp ! fill the overlap area only
645	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
646
647	!! * Local variables
648	INTEGER :: ji, jj, jk, jl ! dummy loop indices
649	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
650	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
651	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
652	REAL(wp) :: zland
653	!!----------------------------------------------------------------------
654
655	! 1. standard boundary treatment
656	! ------------------------------
657
658	IF( PRESENT( pval ) ) THEN ! set land value (zero by default)
659	zland = pval
660	ELSE
661	zland = 0.e0
662	ENDIF
663
664	IF( PRESENT( cd_mpp ) ) THEN
665	DO jj = nlcj+1, jpj ! only fill extra allows last line
666	ptab(1:nlci, jj, :) = ptab(1:nlci, nlej, :)
667	END DO
668	DO ji = nlci+1, jpi ! only fill extra allows last column
669	ptab(ji , : , :) = ptab(nlei , : , :)
670	END DO
671	ELSE
672
673	! ! East-West boundaries
674	! ! ====================
675	IF( nbondi == 2 .AND. & ! Cyclic east-west
676	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
677	ptab( 1 ,:,:) = ptab(jpim1,:,:)
678	ptab(jpi,:,:) = ptab( 2 ,:,:)
679
680	ELSE ! closed
681	SELECT CASE ( cd_type )
682	CASE ( 'T', 'U', 'V', 'W' )
683	ptab( 1 :jpreci,:,:) = zland
684	ptab(nlci-jpreci+1:jpi ,:,:) = zland
685	CASE ( 'F' )
686	ptab(nlci-jpreci+1:jpi ,:,:) = zland
687	END SELECT
688	ENDIF
689
690	! ! North-South boundaries
691	! ! ======================
692	SELECT CASE ( cd_type )
693	CASE ( 'T', 'U', 'V', 'W' )
694	ptab(:, 1 :jprecj,:) = zland
695	ptab(:,nlcj-jprecj+1:jpj ,:) = zland
696	CASE ( 'F' )
697	ptab(:,nlcj-jprecj+1:jpj ,:) = zland
698	END SELECT
699
700	ENDIF
701
702	! 2. East and west directions exchange
703	! ------------------------------------
704
705	! 2.1 Read Dirichlet lateral conditions
706
707	SELECT CASE ( nbondi )
708	CASE ( -1, 0, 1 ) ! all exept 2
709	iihom = nlci-nreci
710	DO jl = 1, jpreci
711	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
712	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
713	END DO
714	END SELECT
715
716	! 2.2 Migrations
717
718	#if defined key_mpp_shmem
719	!! * SHMEM version
720
721	imigr = jpreci * jpj * jpk
722
723	SELECT CASE ( nbondi )
724	CASE ( -1 )
725	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
726	CASE ( 0 )
727	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
728	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
729	CASE ( 1 )
730	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
731	END SELECT
732
733	CALL barrier()
734	CALL shmem_udcflush()
735
736	#elif defined key_mpp_mpi
737	!! * Local variables (MPI version)
738
739	imigr = jpreci * jpj * jpk
740
741	SELECT CASE ( nbondi )
742	CASE ( -1 )
743	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
744	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
745	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
746	CASE ( 0 )
747	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
748	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
749	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
750	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
751	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
752	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
753	CASE ( 1 )
754	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
755	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
756	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
757	END SELECT
758	#endif
759
760	! 2.3 Write Dirichlet lateral conditions
761
762	iihom = nlci-jpreci
763
764	SELECT CASE ( nbondi )
765	CASE ( -1 )
766	DO jl = 1, jpreci
767	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
768	END DO
769	CASE ( 0 )
770	DO jl = 1, jpreci
771	ptab(jl ,:,:) = t3we(:,jl,:,2)
772	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
773	END DO
774	CASE ( 1 )
775	DO jl = 1, jpreci
776	ptab(jl ,:,:) = t3we(:,jl,:,2)
777	END DO
778	END SELECT
779
780
781	! 3. North and south directions
782	! -----------------------------
783
784	! 3.1 Read Dirichlet lateral conditions
785
786	IF( nbondj /= 2 ) THEN
787	ijhom = nlcj-nrecj
788	DO jl = 1, jprecj
789	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
790	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
791	END DO
792	ENDIF
793
794	! 3.2 Migrations
795
796	#if defined key_mpp_shmem
797	!! * SHMEM version
798
799	imigr = jprecj * jpi * jpk
800
801	SELECT CASE ( nbondj )
802	CASE ( -1 )
803	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
804	CASE ( 0 )
805	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
806	CALL shmem_put( t3sn(1,1,1,2), t3sn(1,1,1,1), imigr, nono )
807	CASE ( 1 )
808	CALL shmem_put( t3ns(1,1,1,2), t3ns(1,1,1,1), imigr, noso )
809	END SELECT
810
811	CALL barrier()
812	CALL shmem_udcflush()
813
814	#elif defined key_mpp_mpi
815	!! * Local variables (MPI version)
816
817	imigr=jprecjjpijpk
818
819	SELECT CASE ( nbondj )
820	CASE ( -1 )
821	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
822	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
823	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
824	CASE ( 0 )
825	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
826	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
827	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
828	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
829	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
830	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
831	CASE ( 1 )
832	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
833	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
834	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
835	END SELECT
836
837	#endif
838
839	! 3.3 Write Dirichlet lateral conditions
840
841	ijhom = nlcj-jprecj
842
843	SELECT CASE ( nbondj )
844	CASE ( -1 )
845	DO jl = 1, jprecj
846	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
847	END DO
848	CASE ( 0 )
849	DO jl = 1, jprecj
850	ptab(:,jl ,:) = t3sn(:,jl,:,2)
851	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
852	END DO
853	CASE ( 1 )
854	DO jl = 1, jprecj
855	ptab(:,jl,:) = t3sn(:,jl,:,2)
856	END DO
857	END SELECT
858
859
860	! 4. north fold treatment
861	! -----------------------
862
863	IF (PRESENT(cd_mpp)) THEN
864	! No north fold treatment (it is assumed to be already OK)
865
866	ELSE
867
868	! 4.1 treatment without exchange (jpni odd)
869	! T-point pivot
870
871	SELECT CASE ( jpni )
872
873	CASE ( 1 ) ! only one proc along I, no mpp exchange
874
875	SELECT CASE ( npolj )
876
877	CASE ( 3 , 4 ) ! T pivot
878	iloc = jpiglo - 2 * ( nimpp - 1 )
879
880	SELECT CASE ( cd_type )
881
882	CASE ( 'T' , 'S', 'W' )
883	DO jk = 1, jpk
884	DO ji = 2, nlci
885	ijt=iloc-ji+2
886	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-2,jk)
887	END DO
888	DO ji = nlci/2+1, nlci
889	ijt=iloc-ji+2
890	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
891	END DO
892	END DO
893
894	CASE ( 'U' )
895	DO jk = 1, jpk
896	DO ji = 1, nlci-1
897	iju=iloc-ji+1
898	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
899	END DO
900	DO ji = nlci/2, nlci-1
901	iju=iloc-ji+1
902	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
903	END DO
904	END DO
905
906	CASE ( 'V' )
907	DO jk = 1, jpk
908	DO ji = 2, nlci
909	ijt=iloc-ji+2
910	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-2,jk)
911	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-3,jk)
912	END DO
913	END DO
914
915	CASE ( 'F', 'G' )
916	DO jk = 1, jpk
917	DO ji = 1, nlci-1
918	iju=iloc-ji+1
919	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-2,jk)
920	ptab(ji,nlcj ,jk) = psgn * ptab(iju,nlcj-3,jk)
921	END DO
922	END DO
923
924	END SELECT
925
926	CASE ( 5 , 6 ) ! F pivot
927	iloc=jpiglo-2*(nimpp-1)
928
929	SELECT CASE ( cd_type )
930
931	CASE ( 'T' , 'S', 'W' )
932	DO jk = 1, jpk
933	DO ji = 1, nlci
934	ijt=iloc-ji+1
935	ptab(ji,nlcj,jk) = psgn * ptab(ijt,nlcj-1,jk)
936	END DO
937	END DO
938
939	CASE ( 'U' )
940	DO jk = 1, jpk
941	DO ji = 1, nlci-1
942	iju=iloc-ji
943	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-1,jk)
944	END DO
945	END DO
946
947	CASE ( 'V' )
948	DO jk = 1, jpk
949	DO ji = 1, nlci
950	ijt=iloc-ji+1
951	ptab(ji,nlcj ,jk) = psgn * ptab(ijt,nlcj-2,jk)
952	END DO
953	DO ji = nlci/2+1, nlci
954	ijt=iloc-ji+1
955	ptab(ji,nlcj-1,jk) = psgn * ptab(ijt,nlcj-1,jk)
956	END DO
957	END DO
958
959	CASE ( 'F', 'G' )
960	DO jk = 1, jpk
961	DO ji = 1, nlci-1
962	iju=iloc-ji
963	ptab(ji,nlcj,jk) = psgn * ptab(iju,nlcj-2,jk)
964	END DO
965	DO ji = nlci/2+1, nlci-1
966	iju=iloc-ji
967	ptab(ji,nlcj-1,jk) = psgn * ptab(iju,nlcj-1,jk)
968	END DO
969	END DO
970	END SELECT ! cd_type
971
972	END SELECT ! npolj
973
974	CASE DEFAULT ! more than 1 proc along I
975	IF ( npolj /= 0 ) CALL mpp_lbc_north (ptab, cd_type, psgn) ! only for northern procs.
976
977	END SELECT ! jpni
978
979	ENDIF
980
981
982	! 5. East and west directions exchange
983	! ------------------------------------
984
985	SELECT CASE ( npolj )
986
987	CASE ( 3, 4, 5, 6 )
988
989	! 5.1 Read Dirichlet lateral conditions
990
991	SELECT CASE ( nbondi )
992
993	CASE ( -1, 0, 1 )
994	iihom = nlci-nreci
995	DO jl = 1, jpreci
996	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
997	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
998	END DO
999
1000	END SELECT
1001
1002	! 5.2 Migrations
1003
1004	#if defined key_mpp_shmem
1005	!! SHMEM version
1006
1007	imigr = jpreci * jpj * jpk
1008
1009	SELECT CASE ( nbondi )
1010	CASE ( -1 )
1011	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1012	CASE ( 0 )
1013	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1014	CALL shmem_put( t3we(1,1,1,2), t3we(1,1,1,1), imigr, noea )
1015	CASE ( 1 )
1016	CALL shmem_put( t3ew(1,1,1,2), t3ew(1,1,1,1), imigr, nowe )
1017	END SELECT
1018
1019	CALL barrier()
1020	CALL shmem_udcflush()
1021
1022	#elif defined key_mpp_mpi
1023	!! MPI version
1024
1025	imigr=jprecijpjjpk
1026
1027	SELECT CASE ( nbondi )
1028	CASE ( -1 )
1029	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
1030	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1031	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1032	CASE ( 0 )
1033	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1034	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
1035	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
1036	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1037	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1038	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1039	CASE ( 1 )
1040	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
1041	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
1042	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1043	END SELECT
1044	#endif
1045
1046	! 5.3 Write Dirichlet lateral conditions
1047
1048	iihom = nlci-jpreci
1049
1050	SELECT CASE ( nbondi)
1051	CASE ( -1 )
1052	DO jl = 1, jpreci
1053	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1054	END DO
1055	CASE ( 0 )
1056	DO jl = 1, jpreci
1057	ptab(jl ,:,:) = t3we(:,jl,:,2)
1058	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
1059	END DO
1060	CASE ( 1 )
1061	DO jl = 1, jpreci
1062	ptab(jl ,:,:) = t3we(:,jl,:,2)
1063	END DO
1064	END SELECT
1065
1066	END SELECT ! npolj
1067
1068	END SUBROUTINE mpp_lnk_3d
1069
1070
1071	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
1072	!!----------------------------------------------------------------------
1073	!! * routine mpp_lnk_2d *
1074	!!
1075	!! ** Purpose : Message passing manadgement for 2d array
1076	!!
1077	!! ** Method : Use mppsend and mpprecv function for passing mask
1078	!! between processors following neighboring subdomains.
1079	!! domain parameters
1080	!! nlci : first dimension of the local subdomain
1081	!! nlcj : second dimension of the local subdomain
1082	!! nbondi : mark for "east-west local boundary"
1083	!! nbondj : mark for "north-south local boundary"
1084	!! noea : number for local neighboring processors
1085	!! nowe : number for local neighboring processors
1086	!! noso : number for local neighboring processors
1087	!! nono : number for local neighboring processors
1088	!!
1089	!!----------------------------------------------------------------------
1090	!! * Arguments
1091	CHARACTER(len=1) , INTENT( in ) :: &
1092	cd_type ! define the nature of pt2d array grid-points
1093	! ! = T , U , V , F , W
1094	! ! = S : T-point, north fold treatment
1095	! ! = G : F-point, north fold treatment
1096	! ! = I : sea-ice velocity at F-point with index shift
1097	REAL(wp), INTENT( in ) :: &
1098	psgn ! control of the sign change
1099	! ! = -1. , the sign is changed if north fold boundary
1100	! ! = 1. , the sign is kept if north fold boundary
1101	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
1102	pt2d ! 2D array on which the boundary condition is applied
1103	CHARACTER(len=3), INTENT( in ), OPTIONAL :: &
1104	cd_mpp ! fill the overlap area only
1105	REAL(wp) , INTENT(in ), OPTIONAL :: pval ! background value (used at closed boundaries)
1106
1107	!! * Local variables
1108	INTEGER :: ji, jj, jl ! dummy loop indices
1109	INTEGER :: &
1110	imigr, iihom, ijhom, & ! temporary integers
1111	iloc, ijt, iju ! " "
1112	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1113	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1114	REAL(wp) :: zland
1115	!!----------------------------------------------------------------------
1116
1117	IF( PRESENT( pval ) ) THEN ! set land value (zero by default)
1118	zland = pval
1119	ELSE
1120	zland = 0.e0
1121	ENDIF
1122
1123	! 1. standard boundary treatment
1124	! ------------------------------
1125	IF (PRESENT(cd_mpp)) THEN
1126	DO jj = nlcj+1, jpj ! only fill extra allows last line
1127	pt2d(1:nlci, jj) = pt2d(1:nlci, nlej)
1128	END DO
1129	DO ji = nlci+1, jpi ! only fill extra allows last column
1130	pt2d(ji , : ) = pt2d(nlei , : )
1131	END DO
1132	ELSE
1133
1134	! ! East-West boundaries
1135	! ! ====================
1136	IF( nbondi == 2 .AND. & ! Cyclic east-west
1137	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1138	pt2d( 1 ,:) = pt2d(jpim1,:)
1139	pt2d(jpi,:) = pt2d( 2 ,:)
1140
1141	ELSE ! ... closed
1142	SELECT CASE ( cd_type )
1143	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1144	pt2d( 1 :jpreci,:) = zland
1145	pt2d(nlci-jpreci+1:jpi ,:) = zland
1146	CASE ( 'F' )
1147	pt2d(nlci-jpreci+1:jpi ,:) = zland
1148	END SELECT
1149	ENDIF
1150
1151	! ! North-South boundaries
1152	! ! ======================
1153	SELECT CASE ( cd_type )
1154	CASE ( 'T', 'U', 'V', 'W' , 'I' )
1155	pt2d(:, 1 :jprecj) = zland
1156	pt2d(:,nlcj-jprecj+1:jpj ) = zland
1157	CASE ( 'F' )
1158	pt2d(:,nlcj-jprecj+1:jpj ) = zland
1159	END SELECT
1160
1161	ENDIF
1162
1163
1164	! 2. East and west directions
1165	! ---------------------------
1166
1167	! 2.1 Read Dirichlet lateral conditions
1168
1169	SELECT CASE ( nbondi )
1170	CASE ( -1, 0, 1 ) ! all except 2
1171	iihom = nlci-nreci
1172	DO jl = 1, jpreci
1173	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
1174	t2we(:,jl,1) = pt2d(iihom +jl,:)
1175	END DO
1176	END SELECT
1177
1178	! 2.2 Migrations
1179
1180	#if defined key_mpp_shmem
1181	!! * SHMEM version
1182
1183	imigr = jpreci * jpj
1184
1185	SELECT CASE ( nbondi )
1186	CASE ( -1 )
1187	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1188	CASE ( 0 )
1189	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1190	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1191	CASE ( 1 )
1192	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1193	END SELECT
1194
1195	CALL barrier()
1196	CALL shmem_udcflush()
1197
1198	#elif defined key_mpp_mpi
1199	!! * MPI version
1200
1201	imigr = jpreci * jpj
1202
1203	SELECT CASE ( nbondi )
1204	CASE ( -1 )
1205	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1206	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1207	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1208	CASE ( 0 )
1209	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1210	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1211	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1212	CALL mpprecv( 2, t2we(1,1,2), imigr )
1213	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1214	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1215	CASE ( 1 )
1216	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1217	CALL mpprecv( 2, t2we(1,1,2), imigr )
1218	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1219	END SELECT
1220
1221	#endif
1222
1223	! 2.3 Write Dirichlet lateral conditions
1224
1225	iihom = nlci - jpreci
1226	SELECT CASE ( nbondi )
1227	CASE ( -1 )
1228	DO jl = 1, jpreci
1229	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1230	END DO
1231	CASE ( 0 )
1232	DO jl = 1, jpreci
1233	pt2d(jl ,:) = t2we(:,jl,2)
1234	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1235	END DO
1236	CASE ( 1 )
1237	DO jl = 1, jpreci
1238	pt2d(jl ,:) = t2we(:,jl,2)
1239	END DO
1240	END SELECT
1241
1242
1243	! 3. North and south directions
1244	! -----------------------------
1245
1246	! 3.1 Read Dirichlet lateral conditions
1247
1248	IF( nbondj /= 2 ) THEN
1249	ijhom = nlcj-nrecj
1250	DO jl = 1, jprecj
1251	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
1252	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
1253	END DO
1254	ENDIF
1255
1256	! 3.2 Migrations
1257
1258	#if defined key_mpp_shmem
1259	!! * SHMEM version
1260
1261	imigr = jprecj * jpi
1262
1263	SELECT CASE ( nbondj )
1264	CASE ( -1 )
1265	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1266	CASE ( 0 )
1267	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1268	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr, nono )
1269	CASE ( 1 )
1270	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr, noso )
1271	END SELECT
1272	CALL barrier()
1273	CALL shmem_udcflush()
1274
1275	#elif defined key_mpp_mpi
1276	!! * MPI version
1277
1278	imigr = jprecj * jpi
1279
1280	SELECT CASE ( nbondj )
1281	CASE ( -1 )
1282	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
1283	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1284	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1285	CASE ( 0 )
1286	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1287	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
1288	CALL mpprecv( 3, t2ns(1,1,2), imigr )
1289	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1290	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1291	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1292	CASE ( 1 )
1293	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
1294	CALL mpprecv( 4, t2sn(1,1,2), imigr )
1295	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1296	END SELECT
1297
1298	#endif
1299
1300	! 3.3 Write Dirichlet lateral conditions
1301
1302	ijhom = nlcj - jprecj
1303
1304	SELECT CASE ( nbondj )
1305	CASE ( -1 )
1306	DO jl = 1, jprecj
1307	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1308	END DO
1309	CASE ( 0 )
1310	DO jl = 1, jprecj
1311	pt2d(:,jl ) = t2sn(:,jl,2)
1312	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
1313	END DO
1314	CASE ( 1 )
1315	DO jl = 1, jprecj
1316	pt2d(:,jl ) = t2sn(:,jl,2)
1317	END DO
1318	END SELECT
1319
1320
1321	! 4. north fold treatment
1322	! -----------------------
1323
1324	IF (PRESENT(cd_mpp)) THEN
1325	! No north fold treatment (it is assumed to be already OK)
1326
1327	ELSE
1328
1329	! 4.1 treatment without exchange (jpni odd)
1330
1331	SELECT CASE ( jpni )
1332
1333	CASE ( 1 ) ! only one proc along I, no mpp exchange
1334
1335	SELECT CASE ( npolj )
1336
1337	CASE ( 3 , 4 ) ! T pivot
1338	iloc = jpiglo - 2 * ( nimpp - 1 )
1339
1340	SELECT CASE ( cd_type )
1341
1342	CASE ( 'T' , 'S', 'W' )
1343	DO ji = 2, nlci
1344	ijt=iloc-ji+2
1345	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-2)
1346	END DO
1347	DO ji = nlci/2+1, nlci
1348	ijt=iloc-ji+2
1349	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1350	END DO
1351
1352	CASE ( 'U' )
1353	DO ji = 1, nlci-1
1354	iju=iloc-ji+1
1355	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1356	END DO
1357	DO ji = nlci/2, nlci-1
1358	iju=iloc-ji+1
1359	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1360	END DO
1361
1362	CASE ( 'V' )
1363	DO ji = 2, nlci
1364	ijt=iloc-ji+2
1365	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-2)
1366	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-3)
1367	END DO
1368
1369	CASE ( 'F', 'G' )
1370	DO ji = 1, nlci-1
1371	iju=iloc-ji+1
1372	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-2)
1373	pt2d(ji,nlcj ) = psgn * pt2d(iju,nlcj-3)
1374	END DO
1375
1376	CASE ( 'I' ) ! ice U-V point
1377	pt2d(2,nlcj) = psgn * pt2d(3,nlcj-1)
1378	DO ji = 3, nlci
1379	iju = iloc - ji + 3
1380	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1381	END DO
1382
1383	END SELECT
1384
1385	CASE ( 5 , 6 ) ! F pivot
1386	iloc=jpiglo-2*(nimpp-1)
1387
1388	SELECT CASE (cd_type )
1389
1390	CASE ( 'T', 'S', 'W' )
1391	DO ji = 1, nlci
1392	ijt=iloc-ji+1
1393	pt2d(ji,nlcj) = psgn * pt2d(ijt,nlcj-1)
1394	END DO
1395
1396	CASE ( 'U' )
1397	DO ji = 1, nlci-1
1398	iju=iloc-ji
1399	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-1)
1400	END DO
1401
1402	CASE ( 'V' )
1403	DO ji = 1, nlci
1404	ijt=iloc-ji+1
1405	pt2d(ji,nlcj ) = psgn * pt2d(ijt,nlcj-2)
1406	END DO
1407	DO ji = nlci/2+1, nlci
1408	ijt=iloc-ji+1
1409	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
1410	END DO
1411
1412	CASE ( 'F', 'G' )
1413	DO ji = 1, nlci-1
1414	iju=iloc-ji
1415	pt2d(ji,nlcj) = psgn * pt2d(iju,nlcj-2)
1416	END DO
1417	DO ji = nlci/2+1, nlci-1
1418	iju=iloc-ji
1419	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
1420	END DO
1421
1422	CASE ( 'I' ) ! ice U-V point
1423	pt2d( 2 ,nlcj) = zland
1424	DO ji = 2 , nlci-1
1425	ijt = iloc - ji + 2
1426	pt2d(ji,nlcj)= 0.5 * ( pt2d(ji,nlcj-1) + psgn * pt2d(ijt,nlcj-1) )
1427	END DO
1428
1429	END SELECT ! cd_type
1430
1431	END SELECT ! npolj
1432
1433	CASE DEFAULT ! more than 1 proc along I
1434	IF( npolj /= 0 ) CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! only for northern procs.
1435
1436	END SELECT ! jpni
1437
1438	ENDIF
1439
1440	! 5. East and west directions
1441	! ---------------------------
1442
1443	SELECT CASE ( npolj )
1444
1445	CASE ( 3, 4, 5, 6 )
1446
1447	! 5.1 Read Dirichlet lateral conditions
1448
1449	SELECT CASE ( nbondi )
1450	CASE ( -1, 0, 1 )
1451	iihom = nlci-nreci
1452	DO jl = 1, jpreci
1453	DO jj = 1, jpj
1454	t2ew(jj,jl,1) = pt2d(jpreci+jl,jj)
1455	t2we(jj,jl,1) = pt2d(iihom +jl,jj)
1456	END DO
1457	END DO
1458	END SELECT
1459
1460	! 5.2 Migrations
1461
1462	#if defined key_mpp_shmem
1463	!! * SHMEM version
1464
1465	imigr=jpreci*jpj
1466
1467	SELECT CASE ( nbondi )
1468	CASE ( -1 )
1469	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1470	CASE ( 0 )
1471	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1472	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr, noea )
1473	CASE ( 1 )
1474	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr, nowe )
1475	END SELECT
1476
1477	CALL barrier()
1478	CALL shmem_udcflush()
1479
1480	#elif defined key_mpp_mpi
1481	!! * MPI version
1482
1483	imigr=jpreci*jpj
1484
1485	SELECT CASE ( nbondi )
1486	CASE ( -1 )
1487	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
1488	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1489	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1490	CASE ( 0 )
1491	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1492	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
1493	CALL mpprecv( 1, t2ew(1,1,2), imigr )
1494	CALL mpprecv( 2, t2we(1,1,2), imigr )
1495	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1496	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
1497	CASE ( 1 )
1498	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
1499	CALL mpprecv( 2, t2we(1,1,2), imigr )
1500	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
1501	END SELECT
1502	#endif
1503
1504	! 5.3 Write Dirichlet lateral conditions
1505
1506	iihom = nlci - jpreci
1507
1508	SELECT CASE ( nbondi )
1509	CASE ( -1 )
1510	DO jl = 1, jpreci
1511	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1512	END DO
1513	CASE ( 0 )
1514	DO jl = 1, jpreci
1515	pt2d(jl ,:) = t2we(:,jl,2)
1516	pt2d(iihom+jl,:) = t2ew(:,jl,2)
1517	END DO
1518	CASE ( 1 )
1519	DO jl = 1, jpreci
1520	pt2d(jl,:) = t2we(:,jl,2)
1521	END DO
1522	END SELECT
1523
1524	END SELECT ! npolj
1525
1526	END SUBROUTINE mpp_lnk_2d
1527
1528
1529	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
1530	!!----------------------------------------------------------------------
1531	!! * routine mpp_lnk_3d_gather *
1532	!!
1533	!! ** Purpose : Message passing manadgement for two 3D arrays
1534	!!
1535	!! ** Method : Use mppsend and mpprecv function for passing mask
1536	!! between processors following neighboring subdomains.
1537	!! domain parameters
1538	!! nlci : first dimension of the local subdomain
1539	!! nlcj : second dimension of the local subdomain
1540	!! nbondi : mark for "east-west local boundary"
1541	!! nbondj : mark for "north-south local boundary"
1542	!! noea : number for local neighboring processors
1543	!! nowe : number for local neighboring processors
1544	!! noso : number for local neighboring processors
1545	!! nono : number for local neighboring processors
1546	!!
1547	!! ** Action : ptab1 and ptab2 with update value at its periphery
1548	!!
1549	!!----------------------------------------------------------------------
1550	!! * Arguments
1551	CHARACTER(len=1) , INTENT( in ) :: &
1552	cd_type1, cd_type2 ! define the nature of ptab array grid-points
1553	! ! = T , U , V , F , W points
1554	! ! = S : T-point, north fold treatment ???
1555	! ! = G : F-point, north fold treatment ???
1556	REAL(wp), INTENT( in ) :: &
1557	psgn ! control of the sign change
1558	! ! = -1. , the sign is changed if north fold boundary
1559	! ! = 1. , the sign is kept if north fold boundary
1560	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
1561	ptab1, ptab2 ! 3D array on which the boundary condition is applied
1562
1563	!! * Local variables
1564	INTEGER :: ji, jk, jl ! dummy loop indices
1565	INTEGER :: imigr, iihom, ijhom, iloc, ijt, iju ! temporary integers
1566	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
1567	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
1568	!!----------------------------------------------------------------------
1569
1570	! 1. standard boundary treatment
1571	! ------------------------------
1572	! ! East-West boundaries
1573	! ! ====================
1574	IF( nbondi == 2 .AND. & ! Cyclic east-west
1575	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
1576	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
1577	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
1578	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
1579	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
1580
1581	ELSE ! closed
1582	SELECT CASE ( cd_type1 )
1583	CASE ( 'T', 'U', 'V', 'W' )
1584	ptab1( 1 :jpreci,:,:) = 0.e0
1585	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0
1586	CASE ( 'F' )
1587	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0
1588	END SELECT
1589	SELECT CASE ( cd_type2 )
1590	CASE ( 'T', 'U', 'V', 'W' )
1591	ptab2( 1 :jpreci,:,:) = 0.e0
1592	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
1593	CASE ( 'F' )
1594	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
1595	END SELECT
1596	ENDIF
1597
1598	! ! North-South boundaries
1599	! ! ======================
1600	SELECT CASE ( cd_type1 )
1601	CASE ( 'T', 'U', 'V', 'W' )
1602	ptab1(:, 1 :jprecj,:) = 0.e0
1603	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1604	CASE ( 'F' )
1605	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1606	END SELECT
1607
1608	SELECT CASE ( cd_type2 )
1609	CASE ( 'T', 'U', 'V', 'W' )
1610	ptab2(:, 1 :jprecj,:) = 0.e0
1611	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1612	CASE ( 'F' )
1613	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
1614	END SELECT
1615
1616
1617	! 2. East and west directions exchange
1618	! ------------------------------------
1619
1620	! 2.1 Read Dirichlet lateral conditions
1621
1622	SELECT CASE ( nbondi )
1623	CASE ( -1, 0, 1 ) ! all exept 2
1624	iihom = nlci-nreci
1625	DO jl = 1, jpreci
1626	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
1627	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
1628	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
1629	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
1630	END DO
1631	END SELECT
1632
1633	! 2.2 Migrations
1634
1635	#if defined key_mpp_shmem
1636	!! * SHMEM version
1637
1638	imigr = jpreci * jpj * jpk *2
1639
1640	SELECT CASE ( nbondi )
1641	CASE ( -1 )
1642	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1643	CASE ( 0 )
1644	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1645	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
1646	CASE ( 1 )
1647	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
1648	END SELECT
1649
1650	CALL barrier()
1651	CALL shmem_udcflush()
1652
1653	#elif defined key_mpp_mpi
1654	!! * Local variables (MPI version)
1655
1656	imigr = jpreci * jpj * jpk *2
1657
1658	SELECT CASE ( nbondi )
1659	CASE ( -1 )
1660	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
1661	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1662	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1663	CASE ( 0 )
1664	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1665	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
1666	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
1667	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1668	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1669	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1670	CASE ( 1 )
1671	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
1672	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
1673	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1674	END SELECT
1675	#endif
1676
1677	! 2.3 Write Dirichlet lateral conditions
1678
1679	iihom = nlci-jpreci
1680
1681	SELECT CASE ( nbondi )
1682	CASE ( -1 )
1683	DO jl = 1, jpreci
1684	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1685	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1686	END DO
1687	CASE ( 0 )
1688	DO jl = 1, jpreci
1689	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
1690	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
1691	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
1692	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
1693	END DO
1694	CASE ( 1 )
1695	DO jl = 1, jpreci
1696	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
1697	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
1698	END DO
1699	END SELECT
1700
1701
1702	! 3. North and south directions
1703	! -----------------------------
1704
1705	! 3.1 Read Dirichlet lateral conditions
1706
1707	IF( nbondj /= 2 ) THEN
1708	ijhom = nlcj-nrecj
1709	DO jl = 1, jprecj
1710	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
1711	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
1712	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
1713	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
1714	END DO
1715	ENDIF
1716
1717	! 3.2 Migrations
1718
1719	#if defined key_mpp_shmem
1720	!! * SHMEM version
1721
1722	imigr = jprecj * jpi * jpk * 2
1723
1724	SELECT CASE ( nbondj )
1725	CASE ( -1 )
1726	CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1727	CASE ( 0 )
1728	CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1,1), imigr, noso )
1729	CALL shmem_put( t4sn(1,1,1,1,2), t4sn(1,1,1,1,1), imigr, nono )
1730	CASE ( 1 )
1731	CALL shmem_put( t4ns(1,1,1,1,2), t4ns(1,1,1,1;,1), imigr, noso )
1732	END SELECT
1733
1734	CALL barrier()
1735	CALL shmem_udcflush()
1736
1737	#elif defined key_mpp_mpi
1738	!! * Local variables (MPI version)
1739
1740	imigr=jprecj * jpi * jpk * 2
1741
1742	SELECT CASE ( nbondj )
1743	CASE ( -1 )
1744	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
1745	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1746	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1747	CASE ( 0 )
1748	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1749	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
1750	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
1751	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1752	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1753	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
1754	CASE ( 1 )
1755	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
1756	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
1757	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
1758	END SELECT
1759
1760	#endif
1761
1762	! 3.3 Write Dirichlet lateral conditions
1763
1764	ijhom = nlcj-jprecj
1765
1766	SELECT CASE ( nbondj )
1767	CASE ( -1 )
1768	DO jl = 1, jprecj
1769	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1770	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1771	END DO
1772	CASE ( 0 )
1773	DO jl = 1, jprecj
1774	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
1775	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
1776	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
1777	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
1778	END DO
1779	CASE ( 1 )
1780	DO jl = 1, jprecj
1781	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
1782	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
1783	END DO
1784	END SELECT
1785
1786
1787	! 4. north fold treatment
1788	! -----------------------
1789
1790	! 4.1 treatment without exchange (jpni odd)
1791	! T-point pivot
1792
1793	SELECT CASE ( jpni )
1794
1795	CASE ( 1 ) ! only one proc along I, no mpp exchange
1796
1797	SELECT CASE ( npolj )
1798
1799	CASE ( 3 , 4 ) ! T pivot
1800	iloc = jpiglo - 2 * ( nimpp - 1 )
1801
1802	SELECT CASE ( cd_type1 )
1803
1804	CASE ( 'T' , 'S', 'W' )
1805	DO jk = 1, jpk
1806	DO ji = 2, nlci
1807	ijt=iloc-ji+2
1808	ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1809	END DO
1810	DO ji = nlci/2+1, nlci
1811	ijt=iloc-ji+2
1812	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1813	END DO
1814	END DO
1815
1816	CASE ( 'U' )
1817	DO jk = 1, jpk
1818	DO ji = 1, nlci-1
1819	iju=iloc-ji+1
1820	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1821	END DO
1822	DO ji = nlci/2, nlci-1
1823	iju=iloc-ji+1
1824	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1825	END DO
1826	END DO
1827
1828	CASE ( 'V' )
1829	DO jk = 1, jpk
1830	DO ji = 2, nlci
1831	ijt=iloc-ji+2
1832	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1833	ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-3,jk)
1834	END DO
1835	END DO
1836
1837	CASE ( 'F', 'G' )
1838	DO jk = 1, jpk
1839	DO ji = 1, nlci-1
1840	iju=iloc-ji+1
1841	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-2,jk)
1842	ptab1(ji,nlcj ,jk) = psgn * ptab1(iju,nlcj-3,jk)
1843	END DO
1844	END DO
1845
1846	END SELECT
1847
1848	SELECT CASE ( cd_type2 )
1849
1850	CASE ( 'T' , 'S', 'W' )
1851	DO jk = 1, jpk
1852	DO ji = 2, nlci
1853	ijt=iloc-ji+2
1854	ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1855	END DO
1856	DO ji = nlci/2+1, nlci
1857	ijt=iloc-ji+2
1858	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1859	END DO
1860	END DO
1861
1862	CASE ( 'U' )
1863	DO jk = 1, jpk
1864	DO ji = 1, nlci-1
1865	iju=iloc-ji+1
1866	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1867	END DO
1868	DO ji = nlci/2, nlci-1
1869	iju=iloc-ji+1
1870	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1871	END DO
1872	END DO
1873
1874	CASE ( 'V' )
1875	DO jk = 1, jpk
1876	DO ji = 2, nlci
1877	ijt=iloc-ji+2
1878	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1879	ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-3,jk)
1880	END DO
1881	END DO
1882
1883	CASE ( 'F', 'G' )
1884	DO jk = 1, jpk
1885	DO ji = 1, nlci-1
1886	iju=iloc-ji+1
1887	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-2,jk)
1888	ptab2(ji,nlcj ,jk) = psgn * ptab2(iju,nlcj-3,jk)
1889	END DO
1890	END DO
1891
1892	END SELECT
1893
1894	CASE ( 5 , 6 ) ! F pivot
1895	iloc=jpiglo-2*(nimpp-1)
1896
1897	SELECT CASE ( cd_type1 )
1898
1899	CASE ( 'T' , 'S', 'W' )
1900	DO jk = 1, jpk
1901	DO ji = 1, nlci
1902	ijt=iloc-ji+1
1903	ptab1(ji,nlcj,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1904	END DO
1905	END DO
1906
1907	CASE ( 'U' )
1908	DO jk = 1, jpk
1909	DO ji = 1, nlci-1
1910	iju=iloc-ji
1911	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-1,jk)
1912	END DO
1913	END DO
1914
1915	CASE ( 'V' )
1916	DO jk = 1, jpk
1917	DO ji = 1, nlci
1918	ijt=iloc-ji+1
1919	ptab1(ji,nlcj ,jk) = psgn * ptab1(ijt,nlcj-2,jk)
1920	END DO
1921	DO ji = nlci/2+1, nlci
1922	ijt=iloc-ji+1
1923	ptab1(ji,nlcj-1,jk) = psgn * ptab1(ijt,nlcj-1,jk)
1924	END DO
1925	END DO
1926
1927	CASE ( 'F', 'G' )
1928	DO jk = 1, jpk
1929	DO ji = 1, nlci-1
1930	iju=iloc-ji
1931	ptab1(ji,nlcj,jk) = psgn * ptab1(iju,nlcj-2,jk)
1932	END DO
1933	DO ji = nlci/2+1, nlci-1
1934	iju=iloc-ji
1935	ptab1(ji,nlcj-1,jk) = psgn * ptab1(iju,nlcj-1,jk)
1936	END DO
1937	END DO
1938	END SELECT ! cd_type1
1939
1940	SELECT CASE ( cd_type2 )
1941
1942	CASE ( 'T' , 'S', 'W' )
1943	DO jk = 1, jpk
1944	DO ji = 1, nlci
1945	ijt=iloc-ji+1
1946	ptab2(ji,nlcj,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1947	END DO
1948	END DO
1949
1950	CASE ( 'U' )
1951	DO jk = 1, jpk
1952	DO ji = 1, nlci-1
1953	iju=iloc-ji
1954	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-1,jk)
1955	END DO
1956	END DO
1957
1958	CASE ( 'V' )
1959	DO jk = 1, jpk
1960	DO ji = 1, nlci
1961	ijt=iloc-ji+1
1962	ptab2(ji,nlcj ,jk) = psgn * ptab2(ijt,nlcj-2,jk)
1963	END DO
1964	DO ji = nlci/2+1, nlci
1965	ijt=iloc-ji+1
1966	ptab2(ji,nlcj-1,jk) = psgn * ptab2(ijt,nlcj-1,jk)
1967	END DO
1968	END DO
1969
1970	CASE ( 'F', 'G' )
1971	DO jk = 1, jpk
1972	DO ji = 1, nlci-1
1973	iju=iloc-ji
1974	ptab2(ji,nlcj,jk) = psgn * ptab2(iju,nlcj-2,jk)
1975	END DO
1976	DO ji = nlci/2+1, nlci-1
1977	iju=iloc-ji
1978	ptab2(ji,nlcj-1,jk) = psgn * ptab2(iju,nlcj-1,jk)
1979	END DO
1980	END DO
1981
1982	END SELECT ! cd_type2
1983
1984	END SELECT ! npolj
1985
1986	CASE DEFAULT ! more than 1 proc along I
1987	IF ( npolj /= 0 ) THEN
1988	CALL mpp_lbc_north (ptab1, cd_type1, psgn) ! only for northern procs.
1989	CALL mpp_lbc_north (ptab2, cd_type2, psgn) ! only for northern procs.
1990	ENDIF
1991
1992	END SELECT ! jpni
1993
1994
1995	! 5. East and west directions exchange
1996	! ------------------------------------
1997
1998	SELECT CASE ( npolj )
1999
2000	CASE ( 3, 4, 5, 6 )
2001
2002	! 5.1 Read Dirichlet lateral conditions
2003
2004	SELECT CASE ( nbondi )
2005
2006	CASE ( -1, 0, 1 )
2007	iihom = nlci-nreci
2008	DO jl = 1, jpreci
2009	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
2010	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
2011	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
2012	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
2013	END DO
2014
2015	END SELECT
2016
2017	! 5.2 Migrations
2018
2019	#if defined key_mpp_shmem
2020	!! SHMEM version
2021
2022	imigr = jpreci * jpj * jpk * 2
2023
2024	SELECT CASE ( nbondi )
2025	CASE ( -1 )
2026	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2027	CASE ( 0 )
2028	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2029	CALL shmem_put( t4we(1,1,1,1,2), t4we(1,1,1,1,1), imigr, noea )
2030	CASE ( 1 )
2031	CALL shmem_put( t4ew(1,1,1,1,2), t4ew(1,1,1,1,1), imigr, nowe )
2032	END SELECT
2033
2034	CALL barrier()
2035	CALL shmem_udcflush()
2036
2037	#elif defined key_mpp_mpi
2038	!! MPI version
2039
2040	imigr = jpreci * jpj * jpk * 2
2041
2042	SELECT CASE ( nbondi )
2043	CASE ( -1 )
2044	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
2045	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2046	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2047	CASE ( 0 )
2048	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2049	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
2050	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
2051	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2052	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2053	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2054	CASE ( 1 )
2055	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
2056	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
2057	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2058	END SELECT
2059	#endif
2060
2061	! 5.3 Write Dirichlet lateral conditions
2062
2063	iihom = nlci-jpreci
2064
2065	SELECT CASE ( nbondi)
2066	CASE ( -1 )
2067	DO jl = 1, jpreci
2068	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2069	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2070	END DO
2071	CASE ( 0 )
2072	DO jl = 1, jpreci
2073	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
2074	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
2075	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
2076	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
2077	END DO
2078	CASE ( 1 )
2079	DO jl = 1, jpreci
2080	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
2081	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
2082	END DO
2083	END SELECT
2084
2085	END SELECT ! npolj
2086
2087	END SUBROUTINE mpp_lnk_3d_gather
2088
2089
2090	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
2091	!!----------------------------------------------------------------------
2092	!! * routine mpp_lnk_2d_e *
2093	!!
2094	!! ** Purpose : Message passing manadgement for 2d array (with halo)
2095	!!
2096	!! ** Method : Use mppsend and mpprecv function for passing mask
2097	!! between processors following neighboring subdomains.
2098	!! domain parameters
2099	!! nlci : first dimension of the local subdomain
2100	!! nlcj : second dimension of the local subdomain
2101	!! jpr2di : number of rows for extra outer halo
2102	!! jpr2dj : number of columns for extra outer halo
2103	!! nbondi : mark for "east-west local boundary"
2104	!! nbondj : mark for "north-south local boundary"
2105	!! noea : number for local neighboring processors
2106	!! nowe : number for local neighboring processors
2107	!! noso : number for local neighboring processors
2108	!! nono : number for local neighboring processors
2109	!!
2110	!! History :
2111	!!
2112	!! 9.0 ! 05-09 (R. Benshila, G. Madec) original code
2113	!!
2114	!!----------------------------------------------------------------------
2115	!! * Arguments
2116	CHARACTER(len=1) , INTENT( in ) :: &
2117	cd_type ! define the nature of pt2d array grid-points
2118	! ! = T , U , V , F , W
2119	! ! = S : T-point, north fold treatment
2120	! ! = G : F-point, north fold treatment
2121	! ! = I : sea-ice velocity at F-point with index shift
2122	REAL(wp), INTENT( in ) :: &
2123	psgn ! control of the sign change
2124	! ! = -1. , the sign is changed if north fold boundary
2125	! ! = 1. , the sign is kept if north fold boundary
2126	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: &
2127	pt2d ! 2D array on which the boundary condition is applied
2128
2129	!! * Local variables
2130	INTEGER :: ji, jl ! dummy loop indices
2131	INTEGER :: &
2132	imigr, iihom, ijhom, & ! temporary integers
2133	iloc, ijt, iju ! " "
2134	INTEGER :: &
2135	ipreci, iprecj ! temporary integers
2136	INTEGER :: ml_req1, ml_req2, ml_err ! for isend
2137	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for isend
2138	!!---------------------------------------------------------------------
2139
2140	! take into account outer extra 2D overlap area
2141	ipreci = jpreci + jpr2di
2142	iprecj = jprecj + jpr2dj
2143
2144
2145	! 1. standard boundary treatment
2146	! ------------------------------
2147
2148	! ! East-West boundaries
2149	! ! ====================
2150	IF( nbondi == 2 .AND. & ! Cyclic east-west
2151	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
2152	pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:)
2153	pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:)
2154
2155	ELSE ! ... closed
2156	SELECT CASE ( cd_type )
2157	CASE ( 'T', 'U', 'V', 'W' , 'I' )
2158	pt2d( 1-jpr2di :jpreci ,:) = 0.e0
2159	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2160	CASE ( 'F' )
2161	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0
2162	END SELECT
2163	ENDIF
2164
2165	! ! North-South boundaries
2166	! ! ======================
2167	SELECT CASE ( cd_type )
2168	CASE ( 'T', 'U', 'V', 'W' , 'I' )
2169	pt2d(:, 1-jpr2dj : jprecj ) = 0.e0
2170	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2171	CASE ( 'F' )
2172	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0
2173	END SELECT
2174
2175
2176	! 2. East and west directions
2177	! ---------------------------
2178
2179	! 2.1 Read Dirichlet lateral conditions
2180
2181	SELECT CASE ( nbondi )
2182	CASE ( -1, 0, 1 ) ! all except 2
2183	iihom = nlci-nreci-jpr2di
2184	DO jl = 1, ipreci
2185	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2186	tr2we(:,jl,1) = pt2d(iihom +jl,:)
2187	END DO
2188	END SELECT
2189
2190	! 2.2 Migrations
2191
2192	#if defined key_mpp_shmem
2193	!! * SHMEM version
2194
2195	imigr = ipreci * ( jpj + 2*jpr2dj)
2196
2197	SELECT CASE ( nbondi )
2198	CASE ( -1 )
2199	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2200	CASE ( 0 )
2201	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2202	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2203	CASE ( 1 )
2204	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2205	END SELECT
2206
2207	CALL barrier()
2208	CALL shmem_udcflush()
2209
2210	#elif defined key_mpp_mpi
2211	!! * MPI version
2212
2213	imigr = ipreci * ( jpj + 2*jpr2dj)
2214
2215	SELECT CASE ( nbondi )
2216	CASE ( -1 )
2217	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2218	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2219	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2220	CASE ( 0 )
2221	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2222	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2223	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2224	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2225	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2226	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2227	CASE ( 1 )
2228	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2229	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2230	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2231	END SELECT
2232
2233	#endif
2234
2235	! 2.3 Write Dirichlet lateral conditions
2236
2237	iihom = nlci - jpreci
2238
2239	SELECT CASE ( nbondi )
2240	CASE ( -1 )
2241	DO jl = 1, ipreci
2242	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2243	END DO
2244	CASE ( 0 )
2245	DO jl = 1, ipreci
2246	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2247	pt2d( iihom+jl,:) = tr2ew(:,jl,2)
2248	END DO
2249	CASE ( 1 )
2250	DO jl = 1, ipreci
2251	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2252	END DO
2253	END SELECT
2254
2255
2256	! 3. North and south directions
2257	! -----------------------------
2258
2259	! 3.1 Read Dirichlet lateral conditions
2260
2261	IF( nbondj /= 2 ) THEN
2262	ijhom = nlcj-nrecj-jpr2dj
2263	DO jl = 1, iprecj
2264	tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
2265	tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
2266	END DO
2267	ENDIF
2268
2269	! 3.2 Migrations
2270
2271	#if defined key_mpp_shmem
2272	!! * SHMEM version
2273
2274	imigr = iprecj * ( jpi + 2*jpr2di )
2275
2276	SELECT CASE ( nbondj )
2277	CASE ( -1 )
2278	CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2279	CASE ( 0 )
2280	CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2281	CALL shmem_put( tr2sn(1-jpr2di,1,2), tr2sn(1,1,1), imigr, nono )
2282	CASE ( 1 )
2283	CALL shmem_put( tr2ns(1-jpr2di,1,2), tr2ns(1,1,1), imigr, noso )
2284	END SELECT
2285	CALL barrier()
2286	CALL shmem_udcflush()
2287
2288	#elif defined key_mpp_mpi
2289	!! * MPI version
2290
2291	imigr = iprecj * ( jpi + 2*jpr2di )
2292
2293	SELECT CASE ( nbondj )
2294	CASE ( -1 )
2295	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
2296	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2297	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2298	CASE ( 0 )
2299	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2300	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
2301	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
2302	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2303	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2304	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2305	CASE ( 1 )
2306	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
2307	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
2308	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2309	END SELECT
2310
2311	#endif
2312
2313	! 3.3 Write Dirichlet lateral conditions
2314
2315	ijhom = nlcj - jprecj
2316
2317	SELECT CASE ( nbondj )
2318	CASE ( -1 )
2319	DO jl = 1, iprecj
2320	pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
2321	END DO
2322	CASE ( 0 )
2323	DO jl = 1, iprecj
2324	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2325	pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
2326	END DO
2327	CASE ( 1 )
2328	DO jl = 1, iprecj
2329	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
2330	END DO
2331	END SELECT
2332
2333
2334	! 4. north fold treatment
2335	! -----------------------
2336
2337	! 4.1 treatment without exchange (jpni odd)
2338
2339	SELECT CASE ( jpni )
2340
2341	CASE ( 1 ) ! only one proc along I, no mpp exchange
2342
2343	SELECT CASE ( npolj )
2344
2345	CASE ( 3 , 4 ) ! T pivot
2346	iloc = jpiglo - 2 * ( nimpp - 1 )
2347
2348	SELECT CASE ( cd_type )
2349
2350	CASE ( 'T', 'S', 'W' )
2351	DO jl = 0, iprecj-1
2352	DO ji = 2-jpr2di, nlci+jpr2di
2353	ijt=iloc-ji+2
2354	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2355	END DO
2356	END DO
2357	DO ji = nlci/2+1, nlci+jpr2di
2358	ijt=iloc-ji+2
2359	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2360	END DO
2361
2362	CASE ( 'U' )
2363	DO jl =0, iprecj-1
2364	DO ji = 1-jpr2di, nlci-1-jpr2di
2365	iju=iloc-ji+1
2366	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2367	END DO
2368	END DO
2369	DO ji = nlci/2, nlci-1+jpr2di
2370	iju=iloc-ji+1
2371	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2372	END DO
2373
2374	CASE ( 'V' )
2375	DO jl = -1, iprecj-1
2376	DO ji = 2-jpr2di, nlci+jpr2di
2377	ijt=iloc-ji+2
2378	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-3-jl)
2379	END DO
2380	END DO
2381
2382	CASE ( 'F', 'G' )
2383	DO jl = -1, iprecj-1
2384	DO ji = 1-jpr2di, nlci-1+jpr2di
2385	iju=iloc-ji+1
2386	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-3-jl)
2387	END DO
2388	END DO
2389
2390	CASE ( 'I' ) ! ice U-V point
2391	DO jl = 0, iprecj-1
2392	pt2d(2,nlcj+jl) = psgn * pt2d(3,nlcj-1-jl)
2393	DO ji = 3, nlci+jpr2di
2394	iju = iloc - ji + 3
2395	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2396	END DO
2397	END DO
2398
2399	END SELECT
2400
2401	CASE ( 5 , 6 ) ! F pivot
2402	iloc=jpiglo-2*(nimpp-1)
2403
2404	SELECT CASE (cd_type )
2405
2406	CASE ( 'T', 'S', 'W' )
2407	DO jl = 0, iprecj-1
2408	DO ji = 1-jpr2di, nlci+jpr2di
2409	ijt=iloc-ji+1
2410	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-1-jl)
2411	END DO
2412	END DO
2413
2414	CASE ( 'U' )
2415	DO jl = 0, iprecj-1
2416	DO ji = 1-jpr2di, nlci-1+jpr2di
2417	iju=iloc-ji
2418	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-1-jl)
2419	END DO
2420	END DO
2421
2422	CASE ( 'V' )
2423	DO jl = 0, iprecj-1
2424	DO ji = 1-jpr2di, nlci+jpr2di
2425	ijt=iloc-ji+1
2426	pt2d(ji,nlcj+jl) = psgn * pt2d(ijt,nlcj-2-jl)
2427	END DO
2428	END DO
2429	DO ji = nlci/2+1, nlci+jpr2di
2430	ijt=iloc-ji+1
2431	pt2d(ji,nlcj-1) = psgn * pt2d(ijt,nlcj-1)
2432	END DO
2433
2434	CASE ( 'F', 'G' )
2435	DO jl = 0, iprecj-1
2436	DO ji = 1-jpr2di, nlci-1+jpr2di
2437	iju=iloc-ji
2438	pt2d(ji,nlcj+jl) = psgn * pt2d(iju,nlcj-2-jl)
2439	END DO
2440	END DO
2441	DO ji = nlci/2+1, nlci-1+jpr2di
2442	iju=iloc-ji
2443	pt2d(ji,nlcj-1) = psgn * pt2d(iju,nlcj-1)
2444	END DO
2445
2446	CASE ( 'I' ) ! ice U-V point
2447	pt2d( 2 ,nlcj) = 0.e0
2448	DO jl = 0, iprecj-1
2449	DO ji = 2 , nlci-1+jpr2di
2450	ijt = iloc - ji + 2
2451	pt2d(ji,nlcj+jl)= 0.5 * ( pt2d(ji,nlcj-1-jl) + psgn * pt2d(ijt,nlcj-1-jl) )
2452	END DO
2453	END DO
2454
2455	END SELECT ! cd_type
2456
2457	END SELECT ! npolj
2458
2459	CASE DEFAULT ! more than 1 proc along I
2460	IF( npolj /= 0 ) CALL mpp_lbc_north_e( pt2d, cd_type, psgn ) ! only for northern procs
2461
2462	END SELECT ! jpni
2463
2464
2465	! 5. East and west directions
2466	! ---------------------------
2467
2468	SELECT CASE ( npolj )
2469
2470	CASE ( 3, 4, 5, 6 )
2471
2472	! 5.1 Read Dirichlet lateral conditions
2473
2474	SELECT CASE ( nbondi )
2475	CASE ( -1, 0, 1 )
2476	iihom = nlci-nreci-jpr2di
2477	DO jl = 1, ipreci
2478	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
2479	tr2we(:,jl,1) = pt2d(iihom +jl,:)
2480	END DO
2481	END SELECT
2482
2483	! 5.2 Migrations
2484
2485	#if defined key_mpp_shmem
2486	!! * SHMEM version
2487
2488	imigr = ipreci * ( jpj + 2*jpr2dj )
2489
2490	SELECT CASE ( nbondi )
2491	CASE ( -1 )
2492	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2493	CASE ( 0 )
2494	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2495	CALL shmem_put( tr2we(1-jpr2dj,1,2), tr2we(1,1,1), imigr, noea )
2496	CASE ( 1 )
2497	CALL shmem_put( tr2ew(1-jpr2dj,1,2), tr2ew(1,1,1), imigr, nowe )
2498	END SELECT
2499
2500	CALL barrier()
2501	CALL shmem_udcflush()
2502
2503	#elif defined key_mpp_mpi
2504	!! * MPI version
2505
2506	imigr=ipreci* ( jpj + 2*jpr2dj )
2507
2508	SELECT CASE ( nbondi )
2509	CASE ( -1 )
2510	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
2511	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2512	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2513	CASE ( 0 )
2514	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2515	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
2516	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
2517	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2518	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2519	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2520	CASE ( 1 )
2521	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
2522	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
2523	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2524	END SELECT
2525	#endif
2526
2527	! 5.3 Write Dirichlet lateral conditions
2528
2529	iihom = nlci - jpreci
2530
2531	SELECT CASE ( nbondi )
2532	CASE ( -1 )
2533	DO jl = 1, ipreci
2534	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2535	END DO
2536	CASE ( 0 )
2537	DO jl = 1, ipreci
2538	pt2d(jl- jpr2di,:) = tr2we(:,jl,2)
2539	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
2540	END DO
2541	CASE ( 1 )
2542	DO jl = 1, ipreci
2543	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
2544	END DO
2545	END SELECT
2546
2547	END SELECT ! npolj
2548
2549	END SUBROUTINE mpp_lnk_2d_e
2550
2551
2552	SUBROUTINE mpplnks( ptab )
2553	!!----------------------------------------------------------------------
2554	!! * routine mpplnks *
2555	!!
2556	!! ** Purpose : Message passing manadgement for add 2d array local boundary
2557	!!
2558	!! ** Method : Use mppsend and mpprecv function for passing mask between
2559	!! processors following neighboring subdomains.
2560	!! domain parameters
2561	!! nlci : first dimension of the local subdomain
2562	!! nlcj : second dimension of the local subdomain
2563	!! nbondi : mark for "east-west local boundary"
2564	!! nbondj : mark for "north-south local boundary"
2565	!! noea : number for local neighboring processors
2566	!! nowe : number for local neighboring processors
2567	!! noso : number for local neighboring processors
2568	!! nono : number for local neighboring processors
2569	!!
2570	!!----------------------------------------------------------------------
2571	!! * Arguments
2572	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: &
2573	ptab ! 2D array
2574
2575	!! * Local variables
2576	INTEGER :: ji, jl ! dummy loop indices
2577	INTEGER :: &
2578	imigr, iihom, ijhom ! temporary integers
2579	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
2580	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
2581	!!----------------------------------------------------------------------
2582
2583
2584	! 1. north fold treatment
2585	! -----------------------
2586
2587	! 1.1 treatment without exchange (jpni odd)
2588
2589	SELECT CASE ( npolj )
2590	CASE ( 4 )
2591	DO ji = 1, nlci
2592	ptab(ji,nlcj-2) = ptab(ji,nlcj-2) + t2p1(ji,1,1)
2593	END DO
2594	CASE ( 6 )
2595	DO ji = 1, nlci
2596	ptab(ji,nlcj-1) = ptab(ji,nlcj-1) + t2p1(ji,1,1)
2597	END DO
2598
2599	! 1.2 treatment with exchange (jpni greater than 1)
2600	!
2601	CASE ( 3 )
2602	#if defined key_mpp_shmem
2603
2604	!! * SHMEN version
2605
2606	imigr=jprecj*jpi
2607
2608	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2609	CALL barrier()
2610	CALL shmem_udcflush()
2611
2612	# elif defined key_mpp_mpi
2613	!! * MPI version
2614
2615	imigr=jprecj*jpi
2616
2617	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2618	CALL mpprecv(3,t2p1(1,1,2),imigr)
2619	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2620
2621	#endif
2622
2623	! Write north fold conditions
2624
2625	DO ji = 1, nlci
2626	ptab(ji,nlcj-2) = ptab(ji,nlcj-2)+t2p1(ji,1,2)
2627	END DO
2628
2629	CASE ( 5 )
2630
2631	#if defined key_mpp_shmem
2632
2633	!! * SHMEN version
2634
2635	imigr=jprecj*jpi
2636
2637	CALL shmem_put(t2p1(1,1,2),t2p1(1,1,1),imigr,nono)
2638	CALL barrier()
2639	CALL shmem_udcflush()
2640
2641	# elif defined key_mpp_mpi
2642	!! * Local variables (MPI version)
2643
2644	imigr=jprecj*jpi
2645
2646	CALL mppsend(3,t2p1(1,1,1),imigr,nono, ml_req1)
2647	CALL mpprecv(3,t2p1(1,1,2),imigr)
2648	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2649
2650	#endif
2651
2652	! Write north fold conditions
2653
2654	DO ji = 1, nlci
2655	ptab(ji,nlcj-1) = ptab(ji,nlcj-1)+t2p1(ji,1,2)
2656	END DO
2657
2658	END SELECT
2659
2660
2661	! 2. East and west directions
2662	! ---------------------------
2663
2664	! 2.1 Read Dirichlet lateral conditions
2665
2666	iihom = nlci-jpreci
2667
2668	SELECT CASE ( nbondi )
2669
2670	CASE ( -1, 0, 1 ) ! all except 2
2671	DO jl = 1, jpreci
2672	t2ew(:,jl,1) = ptab( jl ,:)
2673	t2we(:,jl,1) = ptab(iihom+jl,:)
2674	END DO
2675	END SELECT
2676
2677	! 2.2 Migrations
2678
2679	#if defined key_mpp_shmem
2680
2681	!! * SHMEN version
2682
2683	imigr=jpreci*jpj
2684
2685	SELECT CASE ( nbondi )
2686
2687	CASE ( -1 )
2688	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2689
2690	CASE ( 0 )
2691	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2692	CALL shmem_put(t2we(1,1,2),t2we(1,1,1),imigr,noea)
2693
2694	CASE ( 1 )
2695	CALL shmem_put(t2ew(1,1,2),t2ew(1,1,1),imigr,nowe)
2696
2697	END SELECT
2698	CALL barrier()
2699	CALL shmem_udcflush()
2700
2701	# elif defined key_mpp_mpi
2702	!! * Local variables (MPI version)
2703
2704	imigr=jpreci*jpj
2705
2706	SELECT CASE ( nbondi )
2707
2708	CASE ( -1 )
2709	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
2710	CALL mpprecv(1,t2ew(1,1,2),imigr)
2711	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2712	CASE ( 0 )
2713	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2714	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
2715	CALL mpprecv(1,t2ew(1,1,2),imigr)
2716	CALL mpprecv(2,t2we(1,1,2),imigr)
2717	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2718	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2719
2720	CASE ( 1 )
2721	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
2722	CALL mpprecv(2,t2we(1,1,2),imigr)
2723	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2724
2725	END SELECT
2726
2727	#endif
2728
2729	! 2.3 Write Dirichlet lateral conditions
2730
2731	iihom = nlci-nreci
2732
2733	SELECT CASE ( nbondi )
2734
2735	CASE ( -1 )
2736	DO jl = 1, jpreci
2737	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2738	END DO
2739
2740	CASE ( 0 )
2741	DO jl = 1, jpreci
2742	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2743	ptab(iihom +jl,:) = ptab(iihom +jl,:)+t2ew(:,jl,2)
2744	END DO
2745
2746	CASE ( 1 )
2747	DO jl = 1, jpreci
2748	ptab(jpreci+jl,:) = ptab(jpreci+jl,:)+t2we(:,jl,2)
2749	END DO
2750	END SELECT
2751
2752
2753	! 3. North and south directions
2754	! -----------------------------
2755
2756	! 3.1 Read Dirichlet lateral conditions
2757
2758	ijhom = nlcj-jprecj
2759
2760	SELECT CASE ( nbondj )
2761
2762	CASE ( -1, 0, 1 )
2763	DO jl = 1, jprecj
2764	t2sn(:,jl,1) = ptab(:,ijhom+jl)
2765	t2ns(:,jl,1) = ptab(:, jl )
2766	END DO
2767
2768	END SELECT
2769
2770	! 3.2 Migrations
2771
2772	#if defined key_mpp_shmem
2773
2774	!! * SHMEN version
2775
2776	imigr=jprecj*jpi
2777
2778	SELECT CASE ( nbondj )
2779
2780	CASE ( -1 )
2781	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2782
2783	CASE ( 0 )
2784	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2785	CALL shmem_put(t2sn(1,1,2),t2sn(1,1,1),imigr,nono)
2786
2787	CASE ( 1 )
2788	CALL shmem_put(t2ns(1,1,2),t2ns(1,1,1),imigr,noso)
2789
2790	END SELECT
2791	CALL barrier()
2792	CALL shmem_udcflush()
2793
2794	# elif defined key_mpp_mpi
2795	!! * Local variables (MPI version)
2796
2797	imigr=jprecj*jpi
2798
2799	SELECT CASE ( nbondj )
2800
2801	CASE ( -1 )
2802	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
2803	CALL mpprecv(3,t2ns(1,1,2),imigr)
2804	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2805
2806	CASE ( 0 )
2807	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2808	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
2809	CALL mpprecv(3,t2ns(1,1,2),imigr)
2810	CALL mpprecv(4,t2sn(1,1,2),imigr)
2811	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2812	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
2813
2814	CASE ( 1 )
2815	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
2816	CALL mpprecv(4,t2sn(1,1,2),imigr)
2817	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
2818	END SELECT
2819
2820	#endif
2821
2822	! 3.3 Write Dirichlet lateral conditions
2823
2824	ijhom = nlcj-nrecj
2825
2826	SELECT CASE ( nbondj )
2827
2828	CASE ( -1 )
2829	DO jl = 1, jprecj
2830	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2831	END DO
2832
2833	CASE ( 0 )
2834	DO jl = 1, jprecj
2835	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2836	ptab(:,ijhom +jl) = ptab(:,ijhom +jl)+t2ns(:,jl,2)
2837	END DO
2838
2839	CASE ( 1 )
2840	DO jl = 1, jprecj
2841	ptab(:,jprecj+jl) = ptab(:,jprecj+jl)+t2sn(:,jl,2)
2842	END DO
2843
2844	END SELECT
2845
2846	END SUBROUTINE mpplnks
2847
2848
2849	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req)
2850	!!----------------------------------------------------------------------
2851	!! * routine mppsend *
2852	!!
2853	!! ** Purpose : Send messag passing array
2854	!!
2855	!!----------------------------------------------------------------------
2856	!! * Arguments
2857	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
2858	INTEGER , INTENT( in ) :: kbytes, & ! size of the array pmess
2859	& kdest , & ! receive process number
2860	& ktyp, & ! Tag of the message
2861	& md_req ! Argument for isend
2862	!!----------------------------------------------------------------------
2863	#if defined key_mpp_shmem
2864	!! * SHMEM version : routine not used
2865
2866	#elif defined key_mpp_mpi
2867	!! * MPI version
2868	INTEGER :: iflag
2869
2870	SELECT CASE ( c_mpi_send )
2871	CASE ( 'S' ) ! Standard mpi send (blocking)
2872	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2873	& mpi_comm_opa, iflag )
2874	CASE ( 'B' ) ! Buffer mpi send (blocking)
2875	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2876	& mpi_comm_opa, iflag )
2877	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
2878	! Be carefull, one more argument here : the mpi request identifier..
2879	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp, &
2880	& mpi_comm_opa, md_req, iflag )
2881	END SELECT
2882	#endif
2883
2884	END SUBROUTINE mppsend
2885
2886
2887	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
2888	!!----------------------------------------------------------------------
2889	!! * routine mpprecv *
2890	!!
2891	!! ** Purpose : Receive messag passing array
2892	!!
2893	!!----------------------------------------------------------------------
2894	!! * Arguments
2895	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
2896	INTEGER , INTENT( in ) :: kbytes, & ! suze of the array pmess
2897	& ktyp ! Tag of the recevied message
2898	!!----------------------------------------------------------------------
2899	#if defined key_mpp_shmem
2900	!! * SHMEM version : routine not used
2901
2902	# elif defined key_mpp_mpi
2903	!! * MPI version
2904	INTEGER :: istatus(mpi_status_size)
2905	INTEGER :: iflag
2906
2907	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, &
2908	& mpi_comm_opa, istatus, iflag )
2909	#endif
2910
2911	END SUBROUTINE mpprecv
2912
2913
2914	SUBROUTINE mppgather( ptab, kp, pio )
2915	!!----------------------------------------------------------------------
2916	!! * routine mppgather *
2917	!!
2918	!! ** Purpose : Transfert between a local subdomain array and a work
2919	!! array which is distributed following the vertical level.
2920	!!
2921	!! ** Method :
2922	!!
2923	!!----------------------------------------------------------------------
2924	!! * Arguments
2925	REAL(wp), DIMENSION(jpi,jpj), INTENT( in ) :: ptab ! subdomain input array
2926	INTEGER , INTENT( in ) :: kp ! record length
2927	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out ) :: pio ! subdomain input array
2928	!!---------------------------------------------------------------------
2929	#if defined key_mpp_shmem
2930	!! * SHMEM version
2931
2932	CALL barrier()
2933	CALL shmem_put( pio(1,1,npvm_me+1), ptab, jpi*jpj, kp )
2934	CALL barrier()
2935
2936	#elif defined key_mpp_mpi
2937	!! * Local variables (MPI version)
2938	INTEGER :: itaille,ierror
2939
2940	itaille=jpi*jpj
2941	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille, &
2942	& mpi_double_precision, kp , mpi_comm_opa, ierror )
2943	#endif
2944
2945	END SUBROUTINE mppgather
2946
2947
2948	SUBROUTINE mppscatter( pio, kp, ptab )
2949	!!----------------------------------------------------------------------
2950	!! * routine mppscatter *
2951	!!
2952	!! ** Purpose : Transfert between awork array which is distributed
2953	!! following the vertical level and the local subdomain array.
2954	!!
2955	!! ** Method :
2956	!!
2957	!!----------------------------------------------------------------------
2958	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
2959	INTEGER :: kp ! Tag (not used with MPI
2960	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
2961	!!---------------------------------------------------------------------
2962	#if defined key_mpp_shmem
2963	!! * SHMEM version
2964
2965	CALL barrier()
2966	CALL shmem_get( ptab, pio(1,1,npvm_me+1), jpi*jpj, kp )
2967	CALL barrier()
2968
2969	# elif defined key_mpp_mpi
2970	!! * Local variables (MPI version)
2971	INTEGER :: itaille, ierror
2972
2973	itaille=jpi*jpj
2974
2975	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille, &
2976	& mpi_double_precision, kp, mpi_comm_opa, ierror )
2977	#endif
2978
2979	END SUBROUTINE mppscatter
2980
2981
2982	SUBROUTINE mppisl_a_int( ktab, kdim )
2983	!!----------------------------------------------------------------------
2984	!! * routine mppisl_a_int *
2985	!!
2986	!! ** Purpose : Massively parallel processors
2987	!! Find the non zero value
2988	!!
2989	!!----------------------------------------------------------------------
2990	!! * Arguments
2991	INTEGER, INTENT( in ) :: kdim ! ???
2992	INTEGER, INTENT(inout), DIMENSION(kdim) :: ktab ! ???
2993
2994	#if defined key_mpp_shmem
2995	!! * Local variables (SHMEM version)
2996	INTEGER :: ji
2997	INTEGER, SAVE :: ibool=0
2998
2999	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_int routine : kdim is too big', &
3000	& 'change jpmppsum dimension in mpp.h' )
3001
3002	DO ji = 1, kdim
3003	niitab_shmem(ji) = ktab(ji)
3004	END DO
3005	CALL barrier()
3006	IF(ibool == 0 ) THEN
3007	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
3008	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3009	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
3010	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3011	ELSE
3012	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,kdim,0 &
3013	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3014	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,kdim,0 &
3015	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3016	ENDIF
3017	CALL barrier()
3018	ibool=ibool+1
3019	ibool=MOD( ibool,2)
3020	DO ji = 1, kdim
3021	IF( ni11tab_shmem(ji) /= 0. ) THEN
3022	ktab(ji) = ni11tab_shmem(ji)
3023	ELSE
3024	ktab(ji) = ni12tab_shmem(ji)
3025	ENDIF
3026	END DO
3027
3028	# elif defined key_mpp_mpi
3029	!! * Local variables (MPI version)
3030	LOGICAL :: lcommute
3031	INTEGER, DIMENSION(kdim) :: iwork
3032	INTEGER :: mpi_isl,ierror
3033
3034	lcommute = .TRUE.
3035	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3036	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer &
3037	, mpi_isl, mpi_comm_opa, ierror )
3038	ktab(:) = iwork(:)
3039	#endif
3040
3041	END SUBROUTINE mppisl_a_int
3042
3043
3044	SUBROUTINE mppisl_int( ktab )
3045	!!----------------------------------------------------------------------
3046	!! * routine mppisl_int *
3047	!!
3048	!! ** Purpose : Massively parallel processors
3049	!! Find the non zero value
3050	!!
3051	!!----------------------------------------------------------------------
3052	!! * Arguments
3053	INTEGER , INTENT( inout ) :: ktab !
3054
3055	#if defined key_mpp_shmem
3056	!! * Local variables (SHMEM version)
3057	INTEGER, SAVE :: ibool=0
3058
3059	niitab_shmem(1) = ktab
3060	CALL barrier()
3061	IF(ibool == 0 ) THEN
3062	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
3063	,0,N$PES,ni11wrk_shmem,ni11sync_shmem)
3064	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
3065	,0,N$PES,ni12wrk_shmem,ni12sync_shmem)
3066	ELSE
3067	CALL shmem_int8_min_to_all (ni11tab_shmem,niitab_shmem,1,0 &
3068	,0,N$PES,ni21wrk_shmem,ni21sync_shmem)
3069	CALL shmem_int8_max_to_all (ni12tab_shmem,niitab_shmem,1,0 &
3070	,0,N$PES,ni22wrk_shmem,ni22sync_shmem)
3071	ENDIF
3072	CALL barrier()
3073	ibool=ibool+1
3074	ibool=MOD( ibool,2)
3075	IF( ni11tab_shmem(1) /= 0. ) THEN
3076	ktab = ni11tab_shmem(1)
3077	ELSE
3078	ktab = ni12tab_shmem(1)
3079	ENDIF
3080
3081	# elif defined key_mpp_mpi
3082
3083	!! * Local variables (MPI version)
3084	LOGICAL :: lcommute
3085	INTEGER :: mpi_isl,ierror
3086	INTEGER :: iwork
3087
3088	lcommute = .TRUE.
3089	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3090	CALL mpi_allreduce(ktab, iwork, 1,mpi_integer &
3091	,mpi_isl,mpi_comm_opa,ierror)
3092	ktab = iwork
3093	#endif
3094
3095	END SUBROUTINE mppisl_int
3096
3097
3098	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
3099	!!----------------------------------------------------------------------
3100	!! * routine mppmax_a_int *
3101	!!
3102	!! ** Purpose : Find maximum value in an integer layout array
3103	!!
3104	!!----------------------------------------------------------------------
3105	!! * Arguments
3106	INTEGER , INTENT( in ) :: kdim ! size of array
3107	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
3108	INTEGER , INTENT(in) , OPTIONAL :: kcom
3109
3110	#if defined key_mpp_shmem
3111	!! * Local declarations (SHMEM version)
3112	INTEGER :: ji
3113	INTEGER, SAVE :: ibool=0
3114
3115	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_int routine : kdim is too big', &
3116	& 'change jpmppsum dimension in mpp.h' )
3117
3118	DO ji = 1, kdim
3119	niltab_shmem(ji) = ktab(ji)
3120	END DO
3121	CALL barrier()
3122	IF(ibool == 0 ) THEN
3123	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3124	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3125	ELSE
3126	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3127	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3128	ENDIF
3129	CALL barrier()
3130	ibool=ibool+1
3131	ibool=MOD( ibool,2)
3132	DO ji = 1, kdim
3133	ktab(ji) = niltab_shmem(ji)
3134	END DO
3135
3136	# elif defined key_mpp_mpi
3137
3138	!! * Local variables (MPI version)
3139	INTEGER :: ierror
3140	INTEGER :: localcomm
3141	INTEGER, DIMENSION(kdim) :: iwork
3142
3143	localcomm = mpi_comm_opa
3144	IF( PRESENT(kcom) ) localcomm = kcom
3145
3146	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
3147	& mpi_max, localcomm, ierror )
3148
3149	ktab(:) = iwork(:)
3150	#endif
3151
3152	END SUBROUTINE mppmax_a_int
3153
3154
3155	SUBROUTINE mppmax_int( ktab, kcom )
3156	!!----------------------------------------------------------------------
3157	!! * routine mppmax_int *
3158	!!
3159	!! ** Purpose :
3160	!! Massively parallel processors
3161	!! Find maximum value in an integer layout array
3162	!!
3163	!!----------------------------------------------------------------------
3164	!! * Arguments
3165	INTEGER, INTENT(inout) :: ktab ! ???
3166	INTEGER, INTENT(in), OPTIONAL :: kcom ! ???
3167
3168	!! * Local declarations
3169
3170	#if defined key_mpp_shmem
3171
3172	!! * Local variables (SHMEM version)
3173	INTEGER :: ji
3174	INTEGER, SAVE :: ibool=0
3175
3176	niltab_shmem(1) = ktab
3177	CALL barrier()
3178	IF(ibool == 0 ) THEN
3179	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3180	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3181	ELSE
3182	CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3183	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3184	ENDIF
3185	CALL barrier()
3186	ibool=ibool+1
3187	ibool=MOD( ibool,2)
3188	ktab = niltab_shmem(1)
3189
3190	# elif defined key_mpp_mpi
3191
3192	!! * Local variables (MPI version)
3193	INTEGER :: ierror, iwork
3194	INTEGER :: localcomm
3195
3196	localcomm = mpi_comm_opa
3197	IF( PRESENT(kcom) ) localcomm = kcom
3198
3199	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3200	& ,mpi_max,localcomm,ierror)
3201
3202	ktab = iwork
3203	#endif
3204
3205	END SUBROUTINE mppmax_int
3206
3207
3208	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
3209	!!----------------------------------------------------------------------
3210	!! * routine mppmin_a_int *
3211	!!
3212	!! ** Purpose : Find minimum value in an integer layout array
3213	!!
3214	!!----------------------------------------------------------------------
3215	!! * Arguments
3216	INTEGER , INTENT( in ) :: kdim ! size of array
3217	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
3218	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
3219
3220	#if defined key_mpp_shmem
3221	!! * Local declarations (SHMEM version)
3222	INTEGER :: ji
3223	INTEGER, SAVE :: ibool=0
3224
3225	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmin_a_int routine : kdim is too big', &
3226	& 'change jpmppsum dimension in mpp.h' )
3227
3228	DO ji = 1, kdim
3229	niltab_shmem(ji) = ktab(ji)
3230	END DO
3231	CALL barrier()
3232	IF(ibool == 0 ) THEN
3233	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3234	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3235	ELSE
3236	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem,kdim,0,0 &
3237	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3238	ENDIF
3239	CALL barrier()
3240	ibool=ibool+1
3241	ibool=MOD( ibool,2)
3242	DO ji = 1, kdim
3243	ktab(ji) = niltab_shmem(ji)
3244	END DO
3245
3246	# elif defined key_mpp_mpi
3247
3248	!! * Local variables (MPI version)
3249	INTEGER :: ierror
3250	INTEGER :: localcomm
3251	INTEGER, DIMENSION(kdim) :: iwork
3252
3253	localcomm = mpi_comm_opa
3254	IF( PRESENT(kcom) ) localcomm = kcom
3255
3256	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, &
3257	& mpi_min, localcomm, ierror )
3258
3259	ktab(:) = iwork(:)
3260	#endif
3261
3262	END SUBROUTINE mppmin_a_int
3263
3264
3265	SUBROUTINE mppmin_int( ktab )
3266	!!----------------------------------------------------------------------
3267	!! * routine mppmin_int *
3268	!!
3269	!! ** Purpose :
3270	!! Massively parallel processors
3271	!! Find minimum value in an integer layout array
3272	!!
3273	!!----------------------------------------------------------------------
3274	!! * Arguments
3275	INTEGER, INTENT(inout) :: ktab ! ???
3276
3277	!! * Local declarations
3278
3279	#if defined key_mpp_shmem
3280
3281	!! * Local variables (SHMEM version)
3282	INTEGER :: ji
3283	INTEGER, SAVE :: ibool=0
3284
3285	niltab_shmem(1) = ktab
3286	CALL barrier()
3287	IF(ibool == 0 ) THEN
3288	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3289	,N$PES,nil1wrk_shmem,nil1sync_shmem )
3290	ELSE
3291	CALL shmem_int8_min_to_all (niltab_shmem,niltab_shmem, 1,0,0 &
3292	,N$PES,nil2wrk_shmem,nil2sync_shmem )
3293	ENDIF
3294	CALL barrier()
3295	ibool=ibool+1
3296	ibool=MOD( ibool,2)
3297	ktab = niltab_shmem(1)
3298
3299	# elif defined key_mpp_mpi
3300
3301	!! * Local variables (MPI version)
3302	INTEGER :: ierror, iwork
3303
3304	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3305	& ,mpi_min,mpi_comm_opa,ierror)
3306
3307	ktab = iwork
3308	#endif
3309
3310	END SUBROUTINE mppmin_int
3311
3312
3313	SUBROUTINE mppsum_a_int( ktab, kdim )
3314	!!----------------------------------------------------------------------
3315	!! * routine mppsum_a_int *
3316	!!
3317	!! ** Purpose : Massively parallel processors
3318	!! Global integer sum
3319	!!
3320	!!----------------------------------------------------------------------
3321	!! * Arguments
3322	INTEGER, INTENT( in ) :: kdim ! ???
3323	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
3324
3325	#if defined key_mpp_shmem
3326
3327	!! * Local variables (SHMEM version)
3328	INTEGER :: ji
3329	INTEGER, SAVE :: ibool=0
3330
3331	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_int routine : kdim is too big', &
3332	& 'change jpmppsum dimension in mpp.h' )
3333
3334	DO ji = 1, kdim
3335	nistab_shmem(ji) = ktab(ji)
3336	END DO
3337	CALL barrier()
3338	IF(ibool == 0 ) THEN
3339	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
3340	N$PES,nis1wrk_shmem,nis1sync_shmem)
3341	ELSE
3342	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem,kdim,0,0, &
3343	N$PES,nis2wrk_shmem,nis2sync_shmem)
3344	ENDIF
3345	CALL barrier()
3346	ibool = ibool + 1
3347	ibool = MOD( ibool, 2 )
3348	DO ji = 1, kdim
3349	ktab(ji) = nistab_shmem(ji)
3350	END DO
3351
3352	# elif defined key_mpp_mpi
3353
3354	!! * Local variables (MPI version)
3355	INTEGER :: ierror
3356	INTEGER, DIMENSION (kdim) :: iwork
3357
3358	CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer &
3359	,mpi_sum,mpi_comm_opa,ierror)
3360
3361	ktab(:) = iwork(:)
3362	#endif
3363
3364	END SUBROUTINE mppsum_a_int
3365
3366
3367	SUBROUTINE mppsum_int( ktab )
3368	!!----------------------------------------------------------------------
3369	!! * routine mppsum_int *
3370	!!
3371	!! ** Purpose : Global integer sum
3372	!!
3373	!!----------------------------------------------------------------------
3374	!! * Arguments
3375	INTEGER, INTENT(inout) :: ktab
3376
3377	#if defined key_mpp_shmem
3378
3379	!! * Local variables (SHMEM version)
3380	INTEGER, SAVE :: ibool=0
3381
3382	nistab_shmem(1) = ktab
3383	CALL barrier()
3384	IF(ibool == 0 ) THEN
3385	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
3386	N$PES,nis1wrk_shmem,nis1sync_shmem)
3387	ELSE
3388	CALL shmem_int8_sum_to_all(nistab_shmem,nistab_shmem, 1,0,0, &
3389	N$PES,nis2wrk_shmem,nis2sync_shmem)
3390	ENDIF
3391	CALL barrier()
3392	ibool=ibool+1
3393	ibool=MOD( ibool,2)
3394	ktab = nistab_shmem(1)
3395
3396	# elif defined key_mpp_mpi
3397
3398	!! * Local variables (MPI version)
3399	INTEGER :: ierror, iwork
3400
3401	CALL mpi_allreduce(ktab,iwork, 1,mpi_integer &
3402	,mpi_sum,mpi_comm_opa,ierror)
3403
3404	ktab = iwork
3405
3406	#endif
3407
3408	END SUBROUTINE mppsum_int
3409
3410
3411	SUBROUTINE mppisl_a_real( ptab, kdim )
3412	!!----------------------------------------------------------------------
3413	!! * routine mppisl_a_real *
3414	!!
3415	!! ** Purpose : Massively parallel processors
3416	!! Find the non zero island barotropic stream function value
3417	!!
3418	!! Modifications:
3419	!! ! 93-09 (M. Imbard)
3420	!! ! 96-05 (j. Escobar)
3421	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3422	!!----------------------------------------------------------------------
3423	INTEGER , INTENT( in ) :: kdim ! ???
3424	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab ! ???
3425
3426	#if defined key_mpp_shmem
3427
3428	!! * Local variables (SHMEM version)
3429	INTEGER :: ji
3430	INTEGER, SAVE :: ibool=0
3431
3432	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppisl_a_real routine : kdim is too big', &
3433	& 'change jpmppsum dimension in mpp.h' )
3434
3435	DO ji = 1, kdim
3436	wiltab_shmem(ji) = ptab(ji)
3437	END DO
3438	CALL barrier()
3439	IF(ibool == 0 ) THEN
3440	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
3441	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3442	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
3443	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3444	ELSE
3445	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem,kdim,0 &
3446	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3447	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem,kdim,0 &
3448	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3449	ENDIF
3450	CALL barrier()
3451	ibool=ibool+1
3452	ibool=MOD( ibool,2)
3453	DO ji = 1, kdim
3454	IF(wi1tab_shmem(ji) /= 0. ) THEN
3455	ptab(ji) = wi1tab_shmem(ji)
3456	ELSE
3457	ptab(ji) = wi2tab_shmem(ji)
3458	ENDIF
3459	END DO
3460
3461	# elif defined key_mpp_mpi
3462
3463	!! * Local variables (MPI version)
3464	LOGICAL :: lcommute = .TRUE.
3465	INTEGER :: mpi_isl, ierror
3466	REAL(wp), DIMENSION(kdim) :: zwork
3467
3468	CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror)
3469	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3470	,mpi_isl,mpi_comm_opa,ierror)
3471	ptab(:) = zwork(:)
3472
3473	#endif
3474
3475	END SUBROUTINE mppisl_a_real
3476
3477
3478	SUBROUTINE mppisl_real( ptab )
3479	!!----------------------------------------------------------------------
3480	!! * routine mppisl_real *
3481	!!
3482	!! ** Purpose : Massively parallel processors
3483	!! Find the non zero island barotropic stream function value
3484	!!
3485	!! Modifications:
3486	!! ! 93-09 (M. Imbard)
3487	!! ! 96-05 (j. Escobar)
3488	!! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
3489	!!----------------------------------------------------------------------
3490	REAL(wp), INTENT(inout) :: ptab
3491
3492	#if defined key_mpp_shmem
3493
3494	!! * Local variables (SHMEM version)
3495	INTEGER, SAVE :: ibool=0
3496
3497	wiltab_shmem(1) = ptab
3498	CALL barrier()
3499	IF(ibool == 0 ) THEN
3500	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
3501	,0,N$PES,wi11wrk_shmem,ni11sync_shmem)
3502	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
3503	,0,N$PES,wi12wrk_shmem,ni12sync_shmem)
3504	ELSE
3505	CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0 &
3506	,0,N$PES,wi21wrk_shmem,ni21sync_shmem)
3507	CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0 &
3508	,0,N$PES,wi22wrk_shmem,ni22sync_shmem)
3509	ENDIF
3510	CALL barrier()
3511	ibool = ibool + 1
3512	ibool = MOD( ibool, 2 )
3513	IF( wi1tab_shmem(1) /= 0. ) THEN
3514	ptab = wi1tab_shmem(1)
3515	ELSE
3516	ptab = wi2tab_shmem(1)
3517	ENDIF
3518
3519	# elif defined key_mpp_mpi
3520
3521	!! * Local variables (MPI version)
3522	LOGICAL :: lcommute = .TRUE.
3523	INTEGER :: mpi_isl, ierror
3524	REAL(wp) :: zwork
3525
3526	CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror )
3527	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, &
3528	& mpi_isl , mpi_comm_opa, ierror )
3529	ptab = zwork
3530
3531	#endif
3532
3533	END SUBROUTINE mppisl_real
3534
3535
3536	FUNCTION lc_isl( py, px, kdim, kdtatyp )
3537	INTEGER :: kdim
3538	REAL(wp), DIMENSION(kdim) :: px, py
3539	INTEGER :: kdtatyp, ji
3540	INTEGER :: lc_isl
3541	DO ji = 1, kdim
3542	IF( py(ji) /= 0. ) px(ji) = py(ji)
3543	END DO
3544	lc_isl=0
3545
3546	END FUNCTION lc_isl
3547
3548
3549	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
3550	!!----------------------------------------------------------------------
3551	!! * routine mppmax_a_real *
3552	!!
3553	!! ** Purpose : Maximum
3554	!!
3555	!!----------------------------------------------------------------------
3556	!! * Arguments
3557	INTEGER , INTENT( in ) :: kdim
3558	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
3559	INTEGER , INTENT( in ), OPTIONAL :: kcom
3560
3561	#if defined key_mpp_shmem
3562
3563	!! * Local variables (SHMEM version)
3564	INTEGER :: ji
3565	INTEGER, SAVE :: ibool=0
3566
3567	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_real routine : kdim is too big', &
3568	& 'change jpmppsum dimension in mpp.h' )
3569
3570	DO ji = 1, kdim
3571	wintab_shmem(ji) = ptab(ji)
3572	END DO
3573	CALL barrier()
3574	IF(ibool == 0 ) THEN
3575	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3576	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3577	ELSE
3578	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3579	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3580	ENDIF
3581	CALL barrier()
3582	ibool=ibool+1
3583	ibool=MOD( ibool,2)
3584	DO ji = 1, kdim
3585	ptab(ji) = wintab_shmem(ji)
3586	END DO
3587
3588	# elif defined key_mpp_mpi
3589
3590	!! * Local variables (MPI version)
3591	INTEGER :: ierror
3592	INTEGER :: localcomm
3593	REAL(wp), DIMENSION(kdim) :: zwork
3594
3595	localcomm = mpi_comm_opa
3596	IF( PRESENT(kcom) ) localcomm = kcom
3597
3598	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3599	,mpi_max,localcomm,ierror)
3600	ptab(:) = zwork(:)
3601
3602	#endif
3603
3604	END SUBROUTINE mppmax_a_real
3605
3606
3607	SUBROUTINE mppmax_real( ptab, kcom )
3608	!!----------------------------------------------------------------------
3609	!! * routine mppmax_real *
3610	!!
3611	!! ** Purpose : Maximum
3612	!!
3613	!!----------------------------------------------------------------------
3614	!! * Arguments
3615	REAL(wp), INTENT(inout) :: ptab ! ???
3616	INTEGER , INTENT( in ), OPTIONAL :: kcom ! ???
3617
3618	#if defined key_mpp_shmem
3619
3620	!! * Local variables (SHMEM version)
3621	INTEGER, SAVE :: ibool=0
3622
3623	wintab_shmem(1) = ptab
3624	CALL barrier()
3625	IF(ibool == 0 ) THEN
3626	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
3627	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3628	ELSE
3629	CALL shmem_real8_max_to_all (wintab_shmem,wintab_shmem, 1,0 &
3630	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3631	ENDIF
3632	CALL barrier()
3633	ibool=ibool+1
3634	ibool=MOD( ibool,2)
3635	ptab = wintab_shmem(1)
3636
3637	# elif defined key_mpp_mpi
3638
3639	!! * Local variables (MPI version)
3640	INTEGER :: ierror
3641	INTEGER :: localcomm
3642	REAL(wp) :: zwork
3643
3644	localcomm = mpi_comm_opa
3645	IF( PRESENT(kcom) ) localcomm = kcom
3646
3647	CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, &
3648	& mpi_max, localcomm, ierror )
3649	ptab = zwork
3650
3651	#endif
3652
3653	END SUBROUTINE mppmax_real
3654
3655
3656	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
3657	!!----------------------------------------------------------------------
3658	!! * routine mppmin_a_real *
3659	!!
3660	!! ** Purpose : Minimum
3661	!!
3662	!!-----------------------------------------------------------------------
3663	!! * Arguments
3664	INTEGER , INTENT( in ) :: kdim
3665	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
3666	INTEGER , INTENT( in ), OPTIONAL :: kcom
3667
3668	#if defined key_mpp_shmem
3669
3670	!! * Local variables (SHMEM version)
3671	INTEGER :: ji
3672	INTEGER, SAVE :: ibool=0
3673
3674	IF( kdim > jpmppsum ) CALL ctl_stop( 'mpprmin routine : kdim is too big', &
3675	& 'change jpmppsum dimension in mpp.h' )
3676
3677	DO ji = 1, kdim
3678	wintab_shmem(ji) = ptab(ji)
3679	END DO
3680	CALL barrier()
3681	IF(ibool == 0 ) THEN
3682	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3683	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3684	ELSE
3685	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem,kdim,0 &
3686	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3687	ENDIF
3688	CALL barrier()
3689	ibool=ibool+1
3690	ibool=MOD( ibool,2)
3691	DO ji = 1, kdim
3692	ptab(ji) = wintab_shmem(ji)
3693	END DO
3694
3695	# elif defined key_mpp_mpi
3696
3697	!! * Local variables (MPI version)
3698	INTEGER :: ierror
3699	INTEGER :: localcomm
3700	REAL(wp), DIMENSION(kdim) :: zwork
3701
3702	localcomm = mpi_comm_opa
3703	IF( PRESENT(kcom) ) localcomm = kcom
3704
3705	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3706	,mpi_min,localcomm,ierror)
3707	ptab(:) = zwork(:)
3708
3709	#endif
3710
3711	END SUBROUTINE mppmin_a_real
3712
3713
3714	SUBROUTINE mppmin_real( ptab, kcom )
3715	!!----------------------------------------------------------------------
3716	!! * routine mppmin_real *
3717	!!
3718	!! ** Purpose : minimum in Massively Parallel Processing
3719	!! REAL scalar case
3720	!!
3721	!!-----------------------------------------------------------------------
3722	!! * Arguments
3723	REAL(wp), INTENT( inout ) :: ptab !
3724	INTEGER , INTENT( in ), OPTIONAL :: kcom
3725
3726	#if defined key_mpp_shmem
3727
3728	!! * Local variables (SHMEM version)
3729	INTEGER, SAVE :: ibool=0
3730
3731	wintab_shmem(1) = ptab
3732	CALL barrier()
3733	IF(ibool == 0 ) THEN
3734	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
3735	,0,N$PES,wi1wrk_shmem,ni1sync_shmem)
3736	ELSE
3737	CALL shmem_real8_min_to_all (wintab_shmem,wintab_shmem, 1,0 &
3738	,0,N$PES,wi2wrk_shmem,ni2sync_shmem)
3739	ENDIF
3740	CALL barrier()
3741	ibool=ibool+1
3742	ibool=MOD( ibool,2)
3743	ptab = wintab_shmem(1)
3744
3745	# elif defined key_mpp_mpi
3746
3747	!! * Local variables (MPI version)
3748	INTEGER :: ierror
3749	REAL(wp) :: zwork
3750	INTEGER :: localcomm
3751
3752	localcomm = mpi_comm_opa
3753	IF( PRESENT(kcom) ) localcomm = kcom
3754
3755	CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision &
3756	& ,mpi_min,localcomm,ierror)
3757	ptab = zwork
3758
3759	#endif
3760
3761	END SUBROUTINE mppmin_real
3762
3763
3764	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
3765	!!----------------------------------------------------------------------
3766	!! * routine mppsum_a_real *
3767	!!
3768	!! ** Purpose : global sum in Massively Parallel Processing
3769	!! REAL ARRAY argument case
3770	!!
3771	!!-----------------------------------------------------------------------
3772	INTEGER , INTENT( in ) :: kdim ! size of ptab
3773	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
3774	INTEGER , INTENT( in ), OPTIONAL :: kcom
3775
3776	#if defined key_mpp_shmem
3777
3778	!! * Local variables (SHMEM version)
3779	INTEGER :: ji
3780	INTEGER, SAVE :: ibool=0
3781
3782	IF( kdim > jpmppsum ) CALL ctl_stop( 'mppsum_a_real routine : kdim is too big', &
3783	& 'change jpmppsum dimension in mpp.h' )
3784
3785	DO ji = 1, kdim
3786	wrstab_shmem(ji) = ptab(ji)
3787	END DO
3788	CALL barrier()
3789	IF(ibool == 0 ) THEN
3790	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
3791	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3792	ELSE
3793	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem,kdim,0 &
3794	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3795	ENDIF
3796	CALL barrier()
3797	ibool=ibool+1
3798	ibool=MOD( ibool,2)
3799	DO ji = 1, kdim
3800	ptab(ji) = wrstab_shmem(ji)
3801	END DO
3802
3803	# elif defined key_mpp_mpi
3804
3805	!! * Local variables (MPI version)
3806	INTEGER :: ierror ! temporary integer
3807	INTEGER :: localcomm
3808	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
3809
3810
3811	localcomm = mpi_comm_opa
3812	IF( PRESENT(kcom) ) localcomm = kcom
3813
3814	CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision &
3815	& ,mpi_sum,localcomm,ierror)
3816	ptab(:) = zwork(:)
3817
3818	#endif
3819
3820	END SUBROUTINE mppsum_a_real
3821
3822
3823	SUBROUTINE mppsum_real( ptab, kcom )
3824	!!----------------------------------------------------------------------
3825	!! * routine mppsum_real *
3826	!!
3827	!! ** Purpose : global sum in Massively Parallel Processing
3828	!! SCALAR argument case
3829	!!
3830	!!-----------------------------------------------------------------------
3831	REAL(wp), INTENT(inout) :: ptab ! input scalar
3832	INTEGER , INTENT( in ), OPTIONAL :: kcom
3833
3834	#if defined key_mpp_shmem
3835
3836	!! * Local variables (SHMEM version)
3837	INTEGER, SAVE :: ibool=0
3838
3839	wrstab_shmem(1) = ptab
3840	CALL barrier()
3841	IF(ibool == 0 ) THEN
3842	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
3843	,0,N$PES,wrs1wrk_shmem,nrs1sync_shmem )
3844	ELSE
3845	CALL shmem_real8_sum_to_all (wrstab_shmem,wrstab_shmem, 1,0 &
3846	,0,N$PES,wrs2wrk_shmem,nrs2sync_shmem )
3847	ENDIF
3848	CALL barrier()
3849	ibool = ibool + 1
3850	ibool = MOD( ibool, 2 )
3851	ptab = wrstab_shmem(1)
3852
3853	# elif defined key_mpp_mpi
3854
3855	!! * Local variables (MPI version)
3856	INTEGER :: ierror
3857	INTEGER :: localcomm
3858	REAL(wp) :: zwork
3859
3860	localcomm = mpi_comm_opa
3861	IF( PRESENT(kcom) ) localcomm = kcom
3862
3863	CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision &
3864	& ,mpi_sum,localcomm,ierror)
3865	ptab = zwork
3866
3867	#endif
3868
3869	END SUBROUTINE mppsum_real
3870
3871	SUBROUTINE mpp_minloc2d(ptab, pmask, pmin, ki,kj )
3872	!!------------------------------------------------------------------------
3873	!! * routine mpp_minloc *
3874	!!
3875	!! ** Purpose : Compute the global minimum of an array ptab
3876	!! and also give its global position
3877	!!
3878	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3879	!!
3880	!! ** Arguments : I : ptab =local 2D array
3881	!! O : pmin = global minimum
3882	!! O : ki,kj = global position of minimum
3883	!!
3884	!! ** Author : J.M. Molines 10/10/2004
3885	!!--------------------------------------------------------------------------
3886	#ifdef key_mpp_shmem
3887	CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3888	# elif key_mpp_mpi
3889	!! * Arguments
3890	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
3891	& pmask ! Local mask
3892	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
3893	INTEGER , INTENT (out) :: ki,kj ! index of minimum in global frame
3894
3895	!! * Local variables
3896	REAL(wp) :: zmin ! local minimum
3897	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3898	INTEGER, DIMENSION (2) :: ilocs
3899	INTEGER :: ierror
3900
3901
3902	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
3903	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
3904
3905	ki = ilocs(1) + nimpp - 1
3906	kj = ilocs(2) + njmpp - 1
3907
3908	zain(1,:)=zmin
3909	zain(2,:)=ki+10000.*kj
3910
3911	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3912
3913	pmin=zaout(1,1)
3914	kj= INT(zaout(2,1)/10000.)
3915	ki= INT(zaout(2,1) - 10000.*kj )
3916	#endif
3917
3918	END SUBROUTINE mpp_minloc2d
3919
3920
3921	SUBROUTINE mpp_minloc3d(ptab, pmask, pmin, ki,kj ,kk)
3922	!!------------------------------------------------------------------------
3923	!! * routine mpp_minloc *
3924	!!
3925	!! ** Purpose : Compute the global minimum of an array ptab
3926	!! and also give its global position
3927	!!
3928	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3929	!!
3930	!! ** Arguments : I : ptab =local 2D array
3931	!! O : pmin = global minimum
3932	!! O : ki,kj = global position of minimum
3933	!!
3934	!! ** Author : J.M. Molines 10/10/2004
3935	!!--------------------------------------------------------------------------
3936	#ifdef key_mpp_shmem
3937	CALL ctl_stop( ' mpp_minloc not yet available in SHMEM' )
3938	# elif key_mpp_mpi
3939	!! * Arguments
3940	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
3941	& pmask ! Local mask
3942	REAL(wp) , INTENT (out) :: pmin ! Global minimum of ptab
3943	INTEGER , INTENT (out) :: ki,kj,kk ! index of minimum in global frame
3944
3945	!! * Local variables
3946	REAL(wp) :: zmin ! local minimum
3947	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
3948	INTEGER, DIMENSION (3) :: ilocs
3949	INTEGER :: ierror
3950
3951
3952	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
3953	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
3954
3955	ki = ilocs(1) + nimpp - 1
3956	kj = ilocs(2) + njmpp - 1
3957	kk = ilocs(3)
3958
3959	zain(1,:)=zmin
3960	zain(2,:)=ki+10000.kj+100000000.kk
3961
3962	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
3963
3964	pmin=zaout(1,1)
3965	kk= INT(zaout(2,1)/100000000.)
3966	kj= INT(zaout(2,1) - kk * 100000000. )/10000
3967	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
3968	#endif
3969
3970	END SUBROUTINE mpp_minloc3d
3971
3972
3973	SUBROUTINE mpp_maxloc2d(ptab, pmask, pmax, ki,kj )
3974	!!------------------------------------------------------------------------
3975	!! * routine mpp_maxloc *
3976	!!
3977	!! ** Purpose : Compute the global maximum of an array ptab
3978	!! and also give its global position
3979	!!
3980	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
3981	!!
3982	!! ** Arguments : I : ptab =local 2D array
3983	!! O : pmax = global maximum
3984	!! O : ki,kj = global position of maximum
3985	!!
3986	!! ** Author : J.M. Molines 10/10/2004
3987	!!--------------------------------------------------------------------------
3988	#ifdef key_mpp_shmem
3989	CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
3990	# elif key_mpp_mpi
3991	!! * Arguments
3992	REAL(wp), DIMENSION (jpi,jpj), INTENT (in) :: ptab ,& ! Local 2D array
3993	& pmask ! Local mask
3994	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
3995	INTEGER , INTENT (out) :: ki,kj ! index of maximum in global frame
3996
3997	!! * Local variables
3998	REAL(wp) :: zmax ! local maximum
3999	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
4000	INTEGER, DIMENSION (2) :: ilocs
4001	INTEGER :: ierror
4002
4003
4004	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
4005	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
4006
4007	ki = ilocs(1) + nimpp - 1
4008	kj = ilocs(2) + njmpp - 1
4009
4010	zain(1,:)=zmax
4011	zain(2,:)=ki+10000.*kj
4012
4013	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4014
4015	pmax=zaout(1,1)
4016	kj= INT(zaout(2,1)/10000.)
4017	ki= INT(zaout(2,1) - 10000.*kj )
4018	#endif
4019
4020	END SUBROUTINE mpp_maxloc2d
4021
4022	SUBROUTINE mpp_maxloc3d(ptab, pmask, pmax, ki,kj,kk )
4023	!!------------------------------------------------------------------------
4024	!! * routine mpp_maxloc *
4025	!!
4026	!! ** Purpose : Compute the global maximum of an array ptab
4027	!! and also give its global position
4028	!!
4029	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
4030	!!
4031	!! ** Arguments : I : ptab =local 2D array
4032	!! O : pmax = global maximum
4033	!! O : ki,kj = global position of maximum
4034	!!
4035	!! ** Author : J.M. Molines 10/10/2004
4036	!!--------------------------------------------------------------------------
4037	#ifdef key_mpp_shmem
4038	CALL ctl_stop( ' mpp_maxloc not yet available in SHMEM' )
4039	# elif key_mpp_mpi
4040	!! * Arguments
4041	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT (in) :: ptab ,& ! Local 2D array
4042	& pmask ! Local mask
4043	REAL(wp) , INTENT (out) :: pmax ! Global maximum of ptab
4044	INTEGER , INTENT (out) :: ki,kj,kk ! index of maximum in global frame
4045
4046	!! * Local variables
4047	REAL(wp) :: zmax ! local maximum
4048	REAL(wp) ,DIMENSION(2,1) :: zain, zaout
4049	INTEGER, DIMENSION (3) :: ilocs
4050	INTEGER :: ierror
4051
4052
4053	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
4054	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
4055
4056	ki = ilocs(1) + nimpp - 1
4057	kj = ilocs(2) + njmpp - 1
4058	kk = ilocs(3)
4059
4060	zain(1,:)=zmax
4061	zain(2,:)=ki+10000.kj+100000000.kk
4062
4063	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
4064
4065	pmax=zaout(1,1)
4066	kk= INT(zaout(2,1)/100000000.)
4067	kj= INT(zaout(2,1) - kk * 100000000. )/10000
4068	ki= INT(zaout(2,1) - kk * 100000000. -kj * 10000. )
4069	#endif
4070
4071	END SUBROUTINE mpp_maxloc3d
4072
4073	SUBROUTINE mppsync()
4074	!!----------------------------------------------------------------------
4075	!! * routine mppsync *
4076	!!
4077	!! ** Purpose : Massively parallel processors, synchroneous
4078	!!
4079	!!-----------------------------------------------------------------------
4080
4081	#if defined key_mpp_shmem
4082
4083	!! * Local variables (SHMEM version)
4084	CALL barrier()
4085
4086	# elif defined key_mpp_mpi
4087
4088	!! * Local variables (MPI version)
4089	INTEGER :: ierror
4090
4091	CALL mpi_barrier(mpi_comm_opa,ierror)
4092
4093	#endif
4094
4095	END SUBROUTINE mppsync
4096
4097
4098	SUBROUTINE mppstop
4099	!!----------------------------------------------------------------------
4100	!! * routine mppstop *
4101	!!
4102	!! ** purpose : Stop massilively parallel processors method
4103	!!
4104	!!----------------------------------------------------------------------
4105	!! * Local declarations
4106	INTEGER :: info
4107	!!----------------------------------------------------------------------
4108
4109	! 1. Mpp synchroneus
4110	! ------------------
4111
4112	CALL mppsync
4113	#if defined key_mpp_mpi
4114	CALL mpi_finalize( info )
4115	#endif
4116
4117	END SUBROUTINE mppstop
4118
4119
4120	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
4121	!!----------------------------------------------------------------------
4122	!! * routine mppobc *
4123	!!
4124	!! ** Purpose : Message passing manadgement for open boundary
4125	!! conditions array
4126	!!
4127	!! ** Method : Use mppsend and mpprecv function for passing mask
4128	!! between processors following neighboring subdomains.
4129	!! domain parameters
4130	!! nlci : first dimension of the local subdomain
4131	!! nlcj : second dimension of the local subdomain
4132	!! nbondi : mark for "east-west local boundary"
4133	!! nbondj : mark for "north-south local boundary"
4134	!! noea : number for local neighboring processors
4135	!! nowe : number for local neighboring processors
4136	!! noso : number for local neighboring processors
4137	!! nono : number for local neighboring processors
4138	!!
4139	!! History :
4140	!! ! 98-07 (J.M. Molines) Open boundary conditions
4141	!!----------------------------------------------------------------------
4142	!! * Arguments
4143	INTEGER , INTENT( in ) :: &
4144	kd1, kd2, & ! starting and ending indices
4145	kl , & ! index of open boundary
4146	kk, & ! vertical dimension
4147	ktype, & ! define north/south or east/west cdt
4148	! ! = 1 north/south ; = 2 east/west
4149	kij ! horizontal dimension
4150	REAL(wp), DIMENSION(kij,kk), INTENT( inout ) :: &
4151	ptab ! variable array
4152
4153	!! * Local variables
4154	INTEGER :: ji, jj, jk, jl ! dummy loop indices
4155	INTEGER :: &
4156	iipt0, iipt1, ilpt1, & ! temporary integers
4157	ijpt0, ijpt1, & ! " "
4158	imigr, iihom, ijhom ! " "
4159	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
4160	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
4161	REAL(wp), DIMENSION(jpi,jpj) :: &
4162	ztab ! temporary workspace
4163	!!----------------------------------------------------------------------
4164
4165
4166	! boundary condition initialization
4167	! ---------------------------------
4168
4169	ztab(:,:) = 0.e0
4170
4171	IF( ktype==1 ) THEN ! north/south boundaries
4172	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
4173	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
4174	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
4175	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
4176	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
4177	ELSEIF( ktype==2 ) THEN ! east/west boundaries
4178	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
4179	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
4180	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
4181	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
4182	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
4183	ELSE
4184	CALL ctl_stop( 'mppobc: bad ktype' )
4185	ENDIF
4186
4187	DO jk = 1, kk
4188	IF( ktype==1 ) THEN ! north/south boundaries
4189	DO jj = ijpt0, ijpt1
4190	DO ji = iipt0, iipt1
4191	ztab(ji,jj) = ptab(ji,jk)
4192	END DO
4193	END DO
4194	ELSEIF( ktype==2 ) THEN ! east/west boundaries
4195	DO jj = ijpt0, ijpt1
4196	DO ji = iipt0, iipt1
4197	ztab(ji,jj) = ptab(jj,jk)
4198	END DO
4199	END DO
4200	ENDIF
4201
4202
4203	! 1. East and west directions
4204	! ---------------------------
4205
4206	! 1.1 Read Dirichlet lateral conditions
4207
4208	IF( nbondi /= 2 ) THEN
4209	iihom = nlci-nreci
4210
4211	DO jl = 1, jpreci
4212	t2ew(:,jl,1) = ztab(jpreci+jl,:)
4213	t2we(:,jl,1) = ztab(iihom +jl,:)
4214	END DO
4215	ENDIF
4216
4217	! 1.2 Migrations
4218
4219	#if defined key_mpp_shmem
4220	!! * (SHMEM version)
4221	imigr=jprecijpjjpbyt
4222
4223	IF( nbondi == -1 ) THEN
4224	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4225	ELSEIF( nbondi == 0 ) THEN
4226	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4227	CALL shmem_put( t2we(1,1,2), t2we(1,1,1), imigr/jpbyt, noea )
4228	ELSEIF( nbondi == 1 ) THEN
4229	CALL shmem_put( t2ew(1,1,2), t2ew(1,1,1), imigr/jpbyt, nowe )
4230	ENDIF
4231	CALL barrier()
4232	CALL shmem_udcflush()
4233
4234	# elif key_mpp_mpi
4235	!! * (MPI version)
4236
4237	imigr=jpreci*jpj
4238
4239	IF( nbondi == -1 ) THEN
4240	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req1)
4241	CALL mpprecv(1,t2ew(1,1,2),imigr)
4242	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4243	ELSEIF( nbondi == 0 ) THEN
4244	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4245	CALL mppsend(2,t2we(1,1,1),imigr,noea, ml_req2)
4246	CALL mpprecv(1,t2ew(1,1,2),imigr)
4247	CALL mpprecv(2,t2we(1,1,2),imigr)
4248	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4249	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4250	ELSEIF( nbondi == 1 ) THEN
4251	CALL mppsend(1,t2ew(1,1,1),imigr,nowe, ml_req1)
4252	CALL mpprecv(2,t2we(1,1,2),imigr)
4253	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4254	ENDIF
4255	#endif
4256
4257
4258	! 1.3 Write Dirichlet lateral conditions
4259
4260	iihom = nlci-jpreci
4261	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
4262	DO jl = 1, jpreci
4263	ztab(jl,:) = t2we(:,jl,2)
4264	END DO
4265	ENDIF
4266
4267	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
4268	DO jl = 1, jpreci
4269	ztab(iihom+jl,:) = t2ew(:,jl,2)
4270	END DO
4271	ENDIF
4272
4273
4274	! 2. North and south directions
4275	! -----------------------------
4276
4277	! 2.1 Read Dirichlet lateral conditions
4278
4279	IF( nbondj /= 2 ) THEN
4280	ijhom = nlcj-nrecj
4281	DO jl = 1, jprecj
4282	t2sn(:,jl,1) = ztab(:,ijhom +jl)
4283	t2ns(:,jl,1) = ztab(:,jprecj+jl)
4284	END DO
4285	ENDIF
4286
4287	! 2.2 Migrations
4288
4289	#if defined key_mpp_shmem
4290	!! * SHMEM version
4291
4292	imigr=jprecjjpijpbyt
4293
4294	IF( nbondj == -1 ) THEN
4295	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4296	ELSEIF( nbondj == 0 ) THEN
4297	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4298	CALL shmem_put( t2sn(1,1,2), t2sn(1,1,1), imigr/jpbyt, nono )
4299	ELSEIF( nbondj == 1 ) THEN
4300	CALL shmem_put( t2ns(1,1,2), t2ns(1,1,1), imigr/jpbyt, noso )
4301	ENDIF
4302	CALL barrier()
4303	CALL shmem_udcflush()
4304
4305	# elif key_mpp_mpi
4306	!! * Local variables (MPI version)
4307
4308	imigr=jprecj*jpi
4309
4310	IF( nbondj == -1 ) THEN
4311	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req1)
4312	CALL mpprecv(3,t2ns(1,1,2),imigr)
4313	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4314	ELSEIF( nbondj == 0 ) THEN
4315	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4316	CALL mppsend(4,t2sn(1,1,1),imigr,nono, ml_req2)
4317	CALL mpprecv(3,t2ns(1,1,2),imigr)
4318	CALL mpprecv(4,t2sn(1,1,2),imigr)
4319	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4320	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
4321	ELSEIF( nbondj == 1 ) THEN
4322	CALL mppsend(3,t2ns(1,1,1),imigr,noso, ml_req1)
4323	CALL mpprecv(4,t2sn(1,1,2),imigr)
4324	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
4325	ENDIF
4326
4327	#endif
4328
4329	! 2.3 Write Dirichlet lateral conditions
4330
4331	ijhom = nlcj - jprecj
4332	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
4333	DO jl = 1, jprecj
4334	ztab(:,jl) = t2sn(:,jl,2)
4335	END DO
4336	ENDIF
4337
4338	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
4339	DO jl = 1, jprecj
4340	ztab(:,ijhom+jl) = t2ns(:,jl,2)
4341	END DO
4342	ENDIF
4343
4344	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
4345	! north/south boundaries
4346	DO jj = ijpt0,ijpt1
4347	DO ji = iipt0,ilpt1
4348	ptab(ji,jk) = ztab(ji,jj)
4349	END DO
4350	END DO
4351	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
4352	! east/west boundaries
4353	DO jj = ijpt0,ilpt1
4354	DO ji = iipt0,iipt1
4355	ptab(jj,jk) = ztab(ji,jj)
4356	END DO
4357	END DO
4358	ENDIF
4359
4360	END DO
4361
4362	END SUBROUTINE mppobc
4363
4364	SUBROUTINE mpp_comm_free( kcom)
4365
4366	INTEGER, INTENT(in) :: kcom
4367	INTEGER :: ierr
4368
4369	CALL MPI_COMM_FREE(kcom, ierr)
4370
4371	END SUBROUTINE mpp_comm_free
4372
4373
4374	SUBROUTINE mpp_ini_ice(pindic)
4375	!!----------------------------------------------------------------------
4376	!! * routine mpp_ini_ice *
4377	!!
4378	!! ** Purpose : Initialize special communicator for ice areas
4379	!! condition together with global variables needed in the ddmpp folding
4380	!!
4381	!! ** Method : - Look for ice processors in ice routines
4382	!! - Put their number in nrank_ice
4383	!! - Create groups for the world processors and the ice processors
4384	!! - Create a communicator for ice processors
4385	!!
4386	!! ** output
4387	!! njmppmax = njmpp for northern procs
4388	!! ndim_rank_ice = number of processors in the northern line
4389	!! nrank_north (ndim_rank_north) = number of the northern procs.
4390	!! ngrp_world = group ID for the world processors
4391	!! ngrp_ice = group ID for the ice processors
4392	!! ncomm_ice = communicator for the ice procs.
4393	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
4394	!!
4395	!! History :
4396	!! ! 03-09 (J.M. Molines, MPI only )
4397	!!----------------------------------------------------------------------
4398	#ifdef key_mpp_shmem
4399	CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' )
4400	# elif key_mpp_mpi
4401	INTEGER, INTENT(in) :: pindic
4402	INTEGER :: ierr
4403	INTEGER :: jproc
4404	INTEGER :: ii,ji
4405	INTEGER, DIMENSION(jpnij) :: kice
4406	INTEGER, DIMENSION(jpnij) :: zwork
4407	INTEGER :: zrank
4408	!!----------------------------------------------------------------------
4409
4410	! Look for how many procs with sea-ice
4411	!
4412	kice = 0
4413	DO jproc=1,jpnij
4414	IF(jproc == narea .AND. pindic .GT. 0) THEN
4415	kice(jproc) = 1
4416	ENDIF
4417	END DO
4418
4419	zwork = 0
4420	CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer, &
4421	mpi_sum, mpi_comm_opa, ierr )
4422	ndim_rank_ice = sum(zwork)
4423
4424	! Allocate the right size to nrank_north
4425	#if ! defined key_agrif
4426	IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice)
4427	#else
4428	DEALLOCATE(nrank_ice)
4429	#endif
4430
4431	ALLOCATE(nrank_ice(ndim_rank_ice))
4432
4433	ii = 0
4434	nrank_ice = 0
4435	DO jproc=1,jpnij
4436	IF(zwork(jproc) == 1) THEN
4437	ii = ii + 1
4438	nrank_ice(ii) = jproc -1
4439	ENDIF
4440	END DO
4441
4442	! Create the world group
4443	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4444
4445	! Create the ice group from the world group
4446	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr)
4447
4448	! Create the ice communicator , ie the pool of procs with sea-ice
4449	CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr)
4450
4451	! Find proc number in the world of proc 0 in the north
4452	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
4453	#endif
4454
4455	END SUBROUTINE mpp_ini_ice
4456
4457
4458	SUBROUTINE mpp_ini_north
4459	!!----------------------------------------------------------------------
4460	!! * routine mpp_ini_north *
4461	!!
4462	!! ** Purpose : Initialize special communicator for north folding
4463	!! condition together with global variables needed in the mpp folding
4464	!!
4465	!! ** Method : - Look for northern processors
4466	!! - Put their number in nrank_north
4467	!! - Create groups for the world processors and the north processors
4468	!! - Create a communicator for northern processors
4469	!!
4470	!! ** output
4471	!! njmppmax = njmpp for northern procs
4472	!! ndim_rank_north = number of processors in the northern line
4473	!! nrank_north (ndim_rank_north) = number of the northern procs.
4474	!! ngrp_world = group ID for the world processors
4475	!! ngrp_north = group ID for the northern processors
4476	!! ncomm_north = communicator for the northern procs.
4477	!! north_root = number (in the world) of proc 0 in the northern comm.
4478	!!
4479	!! History :
4480	!! ! 03-09 (J.M. Molines, MPI only )
4481	!!----------------------------------------------------------------------
4482	#ifdef key_mpp_shmem
4483	CALL ctl_stop( ' mpp_ini_north not available in SHMEM' )
4484	# elif key_mpp_mpi
4485	INTEGER :: ierr
4486	INTEGER :: jproc
4487	INTEGER :: ii,ji
4488	!!----------------------------------------------------------------------
4489
4490	njmppmax=MAXVAL(njmppt)
4491
4492	! Look for how many procs on the northern boundary
4493	!
4494	ndim_rank_north=0
4495	DO jproc=1,jpnij
4496	IF ( njmppt(jproc) == njmppmax ) THEN
4497	ndim_rank_north = ndim_rank_north + 1
4498	END IF
4499	END DO
4500
4501
4502	! Allocate the right size to nrank_north
4503	!
4504	ALLOCATE(nrank_north(ndim_rank_north))
4505
4506	! Fill the nrank_north array with proc. number of northern procs.
4507	! Note : the rank start at 0 in MPI
4508	!
4509	ii=0
4510	DO ji = 1, jpnij
4511	IF ( njmppt(ji) == njmppmax ) THEN
4512	ii=ii+1
4513	nrank_north(ii)=ji-1
4514	END IF
4515	END DO
4516	! create the world group
4517	!
4518	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr)
4519	!
4520	! Create the North group from the world group
4521	CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_north,nrank_north,ngrp_north,ierr)
4522
4523	! Create the North communicator , ie the pool of procs in the north group
4524	!
4525	CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr)
4526
4527
4528	! find proc number in the world of proc 0 in the north
4529	CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr)
4530	#endif
4531
4532	END SUBROUTINE mpp_ini_north
4533
4534
4535	SUBROUTINE mpp_lbc_north_3d ( pt3d, cd_type, psgn )
4536	!!---------------------------------------------------------------------
4537	!! * routine mpp_lbc_north_3d *
4538	!!
4539	!! ** Purpose :
4540	!! Ensure proper north fold horizontal bondary condition in mpp configuration
4541	!! in case of jpn1 > 1
4542	!!
4543	!! ** Method :
4544	!! Gather the 4 northern lines of the global domain on 1 processor and
4545	!! apply lbc north-fold on this sub array. Then scatter the fold array
4546	!! back to the processors.
4547	!!
4548	!! History :
4549	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
4550	!! from lbc routine
4551	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
4552	!!----------------------------------------------------------------------
4553	!! * Arguments
4554	CHARACTER(len=1), INTENT( in ) :: &
4555	cd_type ! nature of pt3d grid-points
4556	! ! = T , U , V , F or W gridpoints
4557	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: &
4558	pt3d ! 3D array on which the boundary condition is applied
4559	REAL(wp), INTENT( in ) :: &
4560	psgn ! control of the sign change
4561	! ! = -1. , the sign is changed if north fold boundary
4562	! ! = 1. , the sign is kept if north fold boundary
4563
4564	!! * Local declarations
4565	INTEGER :: ji, jj, jk, jr, jproc
4566	INTEGER :: ierr
4567	INTEGER :: ildi,ilei,iilb
4568	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
4569	INTEGER :: itaille
4570	REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab
4571	REAL(wp), DIMENSION(jpi,4,jpk,jpni) :: znorthgloio
4572	REAL(wp), DIMENSION(jpi,4,jpk) :: znorthloc
4573	!!----------------------------------------------------------------------
4574
4575	! If we get in this routine it s because : North fold condition and mpp with more
4576	! than one proc across i : we deal only with the North condition
4577
4578	! 0. Sign setting
4579	! ---------------
4580
4581	ijpj=4
4582	ijpjm1=3
4583
4584	! put in znorthloc the last 4 jlines of pt3d
4585	DO jk = 1, jpk
4586	DO jj = nlcj - ijpj +1, nlcj
4587	ij = jj - nlcj + ijpj
4588	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
4589	END DO
4590	END DO
4591
4592
4593	IF (npolj /= 0 ) THEN
4594	! Build in proc 0 of ncomm_north the znorthgloio
4595	znorthgloio(:,:,:,:) = 0_wp
4596
4597	#ifdef key_mpp_shmem
4598	not done : compiler error
4599	#elif defined key_mpp_mpi
4600	itaille=jpijpkijpj
4601	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4602	#endif
4603
4604	ENDIF
4605
4606	IF (narea == north_root+1 ) THEN
4607	! recover the global north array
4608	ztab(:,:,:) = 0_wp
4609
4610	DO jr = 1, ndim_rank_north
4611	jproc = nrank_north(jr) + 1
4612	ildi = nldit (jproc)
4613	ilei = nleit (jproc)
4614	iilb = nimppt(jproc)
4615	DO jk = 1, jpk
4616	DO jj = 1, 4
4617	DO ji = ildi, ilei
4618	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
4619	END DO
4620	END DO
4621	END DO
4622	END DO
4623
4624
4625	! Horizontal slab
4626	! ===============
4627
4628	DO jk = 1, jpk
4629
4630
4631	! 2. North-Fold boundary conditions
4632	! ----------------------------------
4633
4634	SELECT CASE ( npolj )
4635
4636	CASE ( 3, 4 ) ! * North fold T-point pivot
4637
4638	ztab( 1 ,ijpj,jk) = 0.e0
4639	ztab(jpiglo,ijpj,jk) = 0.e0
4640
4641	SELECT CASE ( cd_type )
4642
4643	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
4644	DO ji = 2, jpiglo
4645	ijt = jpiglo-ji+2
4646	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
4647	END DO
4648	DO ji = jpiglo/2+1, jpiglo
4649	ijt = jpiglo-ji+2
4650	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
4651	END DO
4652
4653	CASE ( 'U' ) ! U-point
4654	DO ji = 1, jpiglo-1
4655	iju = jpiglo-ji+1
4656	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-2,jk)
4657	END DO
4658	DO ji = jpiglo/2, jpiglo-1
4659	iju = jpiglo-ji+1
4660	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
4661	END DO
4662
4663	CASE ( 'V' ) ! V-point
4664	DO ji = 2, jpiglo
4665	ijt = jpiglo-ji+2
4666	ztab(ji,ijpj-1,jk) = psgn * ztab(ijt,ijpj-2,jk)
4667	ztab(ji,ijpj ,jk) = psgn * ztab(ijt,ijpj-3,jk)
4668	END DO
4669
4670	CASE ( 'F' , 'G' ) ! F-point
4671	DO ji = 1, jpiglo-1
4672	iju = jpiglo-ji+1
4673	ztab(ji,ijpj-1,jk) = psgn * ztab(iju,ijpj-2,jk)
4674	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-3,jk)
4675	END DO
4676
4677	END SELECT
4678
4679	CASE ( 5, 6 ) ! * North fold F-point pivot
4680
4681	ztab( 1 ,ijpj,jk) = 0.e0
4682	ztab(jpiglo,ijpj,jk) = 0.e0
4683
4684	SELECT CASE ( cd_type )
4685
4686	CASE ( 'T' , 'S' , 'W' ) ! T-, W-point
4687	DO ji = 1, jpiglo
4688	ijt = jpiglo-ji+1
4689	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-1,jk)
4690	END DO
4691
4692	CASE ( 'U' ) ! U-point
4693	DO ji = 1, jpiglo-1
4694	iju = jpiglo-ji
4695	ztab(ji,ijpj,jk) = psgn * ztab(iju,ijpj-1,jk)
4696	END DO
4697
4698	CASE ( 'V' ) ! V-point
4699	DO ji = 1, jpiglo
4700	ijt = jpiglo-ji+1
4701	ztab(ji,ijpj,jk) = psgn * ztab(ijt,ijpj-2,jk)
4702	END DO
4703	DO ji = jpiglo/2+1, jpiglo
4704	ijt = jpiglo-ji+1
4705	ztab(ji,ijpjm1,jk) = psgn * ztab(ijt,ijpjm1,jk)
4706	END DO
4707
4708	CASE ( 'F' , 'G' ) ! F-point
4709	DO ji = 1, jpiglo-1
4710	iju = jpiglo-ji
4711	ztab(ji,ijpj ,jk) = psgn * ztab(iju,ijpj-2,jk)
4712	END DO
4713	DO ji = jpiglo/2+1, jpiglo-1
4714	iju = jpiglo-ji
4715	ztab(ji,ijpjm1,jk) = psgn * ztab(iju,ijpjm1,jk)
4716	END DO
4717
4718	END SELECT
4719
4720	CASE DEFAULT ! * closed
4721
4722	SELECT CASE ( cd_type)
4723
4724	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
4725	ztab(:, 1 ,jk) = 0.e0
4726	ztab(:,ijpj,jk) = 0.e0
4727
4728	CASE ( 'F' ) ! F-point
4729	ztab(:,ijpj,jk) = 0.e0
4730
4731	END SELECT
4732
4733	END SELECT
4734
4735	! End of slab
4736	! ===========
4737
4738	END DO
4739
4740	!! Scatter back to pt3d
4741	DO jr = 1, ndim_rank_north
4742	jproc=nrank_north(jr)+1
4743	ildi=nldit (jproc)
4744	ilei=nleit (jproc)
4745	iilb=nimppt(jproc)
4746	DO jk= 1, jpk
4747	DO jj=1,ijpj
4748	DO ji=ildi,ilei
4749	znorthgloio(ji,jj,jk,jr)=ztab(ji+iilb-1,jj,jk)
4750	END DO
4751	END DO
4752	END DO
4753	END DO
4754
4755	ENDIF ! only done on proc 0 of ncomm_north
4756
4757	#ifdef key_mpp_shmem
4758	not done yet in shmem : compiler error
4759	#elif key_mpp_mpi
4760	IF ( npolj /= 0 ) THEN
4761	itaille=jpijpkijpj
4762	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4763	ENDIF
4764	#endif
4765
4766	! put in the last ijpj jlines of pt3d znorthloc
4767	DO jk = 1 , jpk
4768	DO jj = nlcj - ijpj + 1 , nlcj
4769	ij = jj - nlcj + ijpj
4770	pt3d(:,jj,jk)= znorthloc(:,ij,jk)
4771	END DO
4772	END DO
4773
4774	END SUBROUTINE mpp_lbc_north_3d
4775
4776
4777	SUBROUTINE mpp_lbc_north_2d ( pt2d, cd_type, psgn)
4778	!!---------------------------------------------------------------------
4779	!! * routine mpp_lbc_north_2d *
4780	!!
4781	!! ** Purpose :
4782	!! Ensure proper north fold horizontal bondary condition in mpp configuration
4783	!! in case of jpn1 > 1 (for 2d array )
4784	!!
4785	!! ** Method :
4786	!! Gather the 4 northern lines of the global domain on 1 processor and
4787	!! apply lbc north-fold on this sub array. Then scatter the fold array
4788	!! back to the processors.
4789	!!
4790	!! History :
4791	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
4792	!! from lbc routine
4793	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
4794	!!----------------------------------------------------------------------
4795
4796	!! * Arguments
4797	CHARACTER(len=1), INTENT( in ) :: &
4798	cd_type ! nature of pt2d grid-points
4799	! ! = T , U , V , F or W gridpoints
4800	REAL(wp), DIMENSION(jpi,jpj), INTENT( inout ) :: &
4801	pt2d ! 2D array on which the boundary condition is applied
4802	REAL(wp), INTENT( in ) :: &
4803	psgn ! control of the sign change
4804	! ! = -1. , the sign is changed if north fold boundary
4805	! ! = 1. , the sign is kept if north fold boundary
4806
4807
4808	!! * Local declarations
4809
4810	INTEGER :: ji, jj, jr, jproc
4811	INTEGER :: ierr
4812	INTEGER :: ildi,ilei,iilb
4813	INTEGER :: ijpj,ijpjm1,ij,ijt,iju
4814	INTEGER :: itaille
4815
4816	REAL(wp), DIMENSION(jpiglo,4) :: ztab
4817	REAL(wp), DIMENSION(jpi,4,jpni) :: znorthgloio
4818	REAL(wp), DIMENSION(jpi,4) :: znorthloc
4819	!!----------------------------------------------------------------------
4820	!! OPA 8.5, LODYC-IPSL (2002)
4821	!!----------------------------------------------------------------------
4822	! If we get in this routine it s because : North fold condition and mpp with more
4823	! than one proc across i : we deal only with the North condition
4824
4825	! 0. Sign setting
4826	! ---------------
4827
4828	ijpj=4
4829	ijpjm1=3
4830
4831
4832	! put in znorthloc the last 4 jlines of pt2d
4833	DO jj = nlcj - ijpj +1, nlcj
4834	ij = jj - nlcj + ijpj
4835	znorthloc(:,ij)=pt2d(:,jj)
4836	END DO
4837
4838	IF (npolj /= 0 ) THEN
4839	! Build in proc 0 of ncomm_north the znorthgloio
4840	znorthgloio(:,:,:) = 0_wp
4841	#ifdef key_mpp_shmem
4842	not done : compiler error
4843	#elif defined key_mpp_mpi
4844	itaille=jpi*ijpj
4845	CALL MPI_GATHER(znorthloc,itaille,MPI_DOUBLE_PRECISION,znorthgloio,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
4846	#endif
4847	ENDIF
4848
4849	IF (narea == north_root+1 ) THEN
4850	! recover the global north array
4851	ztab(:,:) = 0_wp
4852
4853	DO jr = 1, ndim_rank_north
4854	jproc=nrank_north(jr)+1
4855	ildi=nldit (jproc)
4856	ilei=nleit (jproc)
4857	iilb=nimppt(jproc)
4858	DO jj=1,4
4859	DO ji=ildi,ilei
4860	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
4861	END DO
4862	END DO
4863	END DO
4864
4865
4866	! 2. North-Fold boundary conditions
4867	! ----------------------------------
4868
4869	SELECT CASE ( npolj )
4870
4871	CASE ( 3, 4 ) ! * North fold T-point pivot
4872
4873	ztab( 1 ,ijpj) = 0.e0
4874	ztab(jpiglo,ijpj) = 0.e0
4875
4876	SELECT CASE ( cd_type )
4877
4878	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
4879	DO ji = 2, jpiglo
4880	ijt = jpiglo-ji+2
4881	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
4882	END DO
4883	DO ji = jpiglo/2+1, jpiglo
4884	ijt = jpiglo-ji+2
4885	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
4886	END DO
4887
4888	CASE ( 'U' ) ! U-point
4889	DO ji = 1, jpiglo-1
4890	iju = jpiglo-ji+1
4891	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-2)
4892	END DO
4893	DO ji = jpiglo/2, jpiglo-1
4894	iju = jpiglo-ji+1
4895	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
4896	END DO
4897
4898	CASE ( 'V' ) ! V-point
4899	DO ji = 2, jpiglo
4900	ijt = jpiglo-ji+2
4901	ztab(ji,ijpj-1) = psgn * ztab(ijt,ijpj-2)
4902	ztab(ji,ijpj ) = psgn * ztab(ijt,ijpj-3)
4903	END DO
4904
4905	CASE ( 'F' , 'G' ) ! F-point
4906	DO ji = 1, jpiglo-1
4907	iju = jpiglo-ji+1
4908	ztab(ji,ijpj-1) = psgn * ztab(iju,ijpj-2)
4909	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-3)
4910	END DO
4911
4912	CASE ( 'I' ) ! ice U-V point
4913	ztab(2,ijpj) = psgn * ztab(3,ijpj-1)
4914	DO ji = 3, jpiglo
4915	iju = jpiglo - ji + 3
4916	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
4917	END DO
4918
4919	END SELECT
4920
4921	CASE ( 5, 6 ) ! * North fold F-point pivot
4922
4923	ztab( 1 ,ijpj) = 0.e0
4924	ztab(jpiglo,ijpj) = 0.e0
4925
4926	SELECT CASE ( cd_type )
4927
4928	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
4929	DO ji = 1, jpiglo
4930	ijt = jpiglo-ji+1
4931	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-1)
4932	END DO
4933
4934	CASE ( 'U' ) ! U-point
4935	DO ji = 1, jpiglo-1
4936	iju = jpiglo-ji
4937	ztab(ji,ijpj) = psgn * ztab(iju,ijpj-1)
4938	END DO
4939
4940	CASE ( 'V' ) ! V-point
4941	DO ji = 1, jpiglo
4942	ijt = jpiglo-ji+1
4943	ztab(ji,ijpj) = psgn * ztab(ijt,ijpj-2)
4944	END DO
4945	DO ji = jpiglo/2+1, jpiglo
4946	ijt = jpiglo-ji+1
4947	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
4948	END DO
4949
4950	CASE ( 'F' , 'G' ) ! F-point
4951	DO ji = 1, jpiglo-1
4952	iju = jpiglo-ji
4953	ztab(ji,ijpj ) = psgn * ztab(iju,ijpj-2)
4954	END DO
4955	DO ji = jpiglo/2+1, jpiglo-1
4956	iju = jpiglo-ji
4957	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
4958	END DO
4959
4960	CASE ( 'I' ) ! ice U-V point
4961	ztab( 2 ,ijpj) = 0.e0
4962	DO ji = 2 , jpiglo-1
4963	ijt = jpiglo - ji + 2
4964	ztab(ji,ijpj)= 0.5 * ( ztab(ji,ijpj-1) + psgn * ztab(ijt,ijpj-1) )
4965	END DO
4966
4967	END SELECT
4968
4969	CASE DEFAULT ! * closed : the code probably never go through
4970
4971	SELECT CASE ( cd_type)
4972
4973	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
4974	ztab(:, 1 ) = 0.e0
4975	ztab(:,ijpj) = 0.e0
4976
4977	CASE ( 'F' ) ! F-point
4978	ztab(:,ijpj) = 0.e0
4979
4980	CASE ( 'I' ) ! ice U-V point
4981	ztab(:, 1 ) = 0.e0
4982	ztab(:,ijpj) = 0.e0
4983
4984	END SELECT
4985
4986	END SELECT
4987
4988	! End of slab
4989	! ===========
4990
4991	!! Scatter back to pt2d
4992	DO jr = 1, ndim_rank_north
4993	jproc=nrank_north(jr)+1
4994	ildi=nldit (jproc)
4995	ilei=nleit (jproc)
4996	iilb=nimppt(jproc)
4997	DO jj=1,ijpj
4998	DO ji=ildi,ilei
4999	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
5000	END DO
5001	END DO
5002	END DO
5003
5004	ENDIF ! only done on proc 0 of ncomm_north
5005
5006	#ifdef key_mpp_shmem
5007	not done yet in shmem : compiler error
5008	#elif key_mpp_mpi
5009	IF ( npolj /= 0 ) THEN
5010	itaille=jpi*ijpj
5011	CALL MPI_SCATTER(znorthgloio,itaille,MPI_DOUBLE_PRECISION,znorthloc,itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5012	ENDIF
5013	#endif
5014
5015	! put in the last ijpj jlines of pt2d znorthloc
5016	DO jj = nlcj - ijpj + 1 , nlcj
5017	ij = jj - nlcj + ijpj
5018	pt2d(:,jj)= znorthloc(:,ij)
5019	END DO
5020
5021	END SUBROUTINE mpp_lbc_north_2d
5022
5023
5024	SUBROUTINE mpp_lbc_north_e ( pt2d, cd_type, psgn)
5025	!!---------------------------------------------------------------------
5026	!! * routine mpp_lbc_north_2d *
5027	!!
5028	!! ** Purpose :
5029	!! Ensure proper north fold horizontal bondary condition in mpp configuration
5030	!! in case of jpn1 > 1 (for 2d array with outer extra halo)
5031	!!
5032	!! ** Method :
5033	!! Gather the 4+2*jpr2dj northern lines of the global domain on 1 processor and
5034	!! apply lbc north-fold on this sub array. Then scatter the fold array
5035	!! back to the processors.
5036	!!
5037	!! History :
5038	!! 8.5 ! 03-09 (J.M. Molines ) For mpp folding condition at north
5039	!! from lbc routine
5040	!! 9.0 ! 03-12 (J.M. Molines ) encapsulation into lib_mpp, coding rules of lbc_lnk
5041	!! 9.0 ! 05-09 (R. Benshila ) adapt mpp_lbc_north_2d
5042	!!----------------------------------------------------------------------
5043
5044	!! * Arguments
5045	CHARACTER(len=1), INTENT( in ) :: &
5046	cd_type ! nature of pt2d grid-points
5047	! ! = T , U , V , F or W gridpoints
5048	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT( inout ) :: &
5049	pt2d ! 2D array on which the boundary condition is applied
5050	REAL(wp), INTENT( in ) :: &
5051	psgn ! control of the sign change
5052	! ! = -1. , the sign is changed if north fold boundary
5053	! ! = 1. , the sign is kept if north fold boundary
5054
5055
5056	!! * Local declarations
5057
5058	INTEGER :: ji, jj, jr, jproc, jl
5059	INTEGER :: ierr
5060	INTEGER :: ildi,ilei,iilb
5061	INTEGER :: ijpj,ijpjm1,ij,ijt,iju, iprecj
5062	INTEGER :: itaille
5063
5064	REAL(wp), DIMENSION(jpiglo,1-jpr2dj:4+jpr2dj) :: ztab
5065	REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj,jpni) :: znorthgloio
5066	REAL(wp), DIMENSION(jpi,1-jpr2dj:4+jpr2dj) :: znorthloc
5067
5068	! If we get in this routine it s because : North fold condition and mpp with more
5069	! than one proc across i : we deal only with the North condition
5070
5071	! 0. Sign setting
5072	! ---------------
5073
5074	ijpj=4
5075	ijpjm1=3
5076	iprecj = jpr2dj+jprecj
5077
5078	! put in znorthloc the last 4 jlines of pt2d
5079	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
5080	ij = jj - nlcj + ijpj
5081	znorthloc(:,ij)=pt2d(1:jpi,jj)
5082	END DO
5083
5084	IF (npolj /= 0 ) THEN
5085	! Build in proc 0 of ncomm_north the znorthgloio
5086	znorthgloio(:,:,:) = 0_wp
5087	#ifdef key_mpp_shmem
5088	not done : compiler error
5089	#elif defined key_mpp_mpi
5090	itaille=jpi(ijpj+2jpr2dj)
5091	CALL MPI_GATHER(znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION, &
5092	& znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5093	#endif
5094	ENDIF
5095
5096	IF (narea == north_root+1 ) THEN
5097	! recover the global north array
5098	ztab(:,:) = 0_wp
5099
5100	DO jr = 1, ndim_rank_north
5101	jproc=nrank_north(jr)+1
5102	ildi=nldit (jproc)
5103	ilei=nleit (jproc)
5104	iilb=nimppt(jproc)
5105	DO jj=1-jpr2dj,ijpj+jpr2dj
5106	DO ji=ildi,ilei
5107	ztab(ji+iilb-1,jj)=znorthgloio(ji,jj,jr)
5108	END DO
5109	END DO
5110	END DO
5111
5112
5113	! 2. North-Fold boundary conditions
5114	! ----------------------------------
5115
5116	SELECT CASE ( npolj )
5117
5118	CASE ( 3, 4 ) ! * North fold T-point pivot
5119
5120	ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0
5121	ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0
5122
5123	SELECT CASE ( cd_type )
5124
5125	CASE ( 'T' , 'W' , 'S' ) ! T-, W-point
5126	DO jl =0, iprecj-1
5127	DO ji = 2, jpiglo
5128	ijt = jpiglo-ji+2
5129	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl)
5130	END DO
5131	END DO
5132	DO ji = jpiglo/2+1, jpiglo
5133	ijt = jpiglo-ji+2
5134	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
5135	END DO
5136
5137	CASE ( 'U' ) ! U-point
5138	DO jl =0, iprecj-1
5139	DO ji = 1, jpiglo-1
5140	iju = jpiglo-ji+1
5141	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl)
5142	END DO
5143	END DO
5144	DO ji = jpiglo/2, jpiglo-1
5145	iju = jpiglo-ji+1
5146	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
5147	END DO
5148
5149	CASE ( 'V' ) ! V-point
5150	DO jl =-1, iprecj-1
5151	DO ji = 2, jpiglo
5152	ijt = jpiglo-ji+2
5153	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-3-jl)
5154	END DO
5155	END DO
5156
5157	CASE ( 'F' , 'G' ) ! F-point
5158	DO jl =-1, iprecj-1
5159	DO ji = 1, jpiglo-1
5160	iju = jpiglo-ji+1
5161	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-3-jl)
5162	END DO
5163	END DO
5164
5165	CASE ( 'I' ) ! ice U-V point
5166	DO jl =0, iprecj-1
5167	ztab(2,ijpj+jl) = psgn * ztab(3,ijpj-1+jl)
5168	DO ji = 3, jpiglo
5169	iju = jpiglo - ji + 3
5170	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl)
5171	END DO
5172	END DO
5173
5174	END SELECT
5175
5176	CASE ( 5, 6 ) ! * North fold F-point pivot
5177
5178	ztab( 1 ,ijpj:ijpj+jpr2dj) = 0.e0
5179	ztab(jpiglo,ijpj:ijpj+jpr2dj) = 0.e0
5180
5181	SELECT CASE ( cd_type )
5182
5183	CASE ( 'T' , 'W' ,'S' ) ! T-, W-point
5184	DO jl = 0, iprecj-1
5185	DO ji = 1, jpiglo
5186	ijt = jpiglo-ji+1
5187	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-1-jl)
5188	END DO
5189	END DO
5190
5191	CASE ( 'U' ) ! U-point
5192	DO jl = 0, iprecj-1
5193	DO ji = 1, jpiglo-1
5194	iju = jpiglo-ji
5195	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-1-jl)
5196	END DO
5197	END DO
5198
5199	CASE ( 'V' ) ! V-point
5200	DO jl = 0, iprecj-1
5201	DO ji = 1, jpiglo
5202	ijt = jpiglo-ji+1
5203	ztab(ji,ijpj+jl) = psgn * ztab(ijt,ijpj-2-jl)
5204	END DO
5205	END DO
5206	DO ji = jpiglo/2+1, jpiglo
5207	ijt = jpiglo-ji+1
5208	ztab(ji,ijpjm1) = psgn * ztab(ijt,ijpjm1)
5209	END DO
5210
5211	CASE ( 'F' , 'G' ) ! F-point
5212	DO jl = 0, iprecj-1
5213	DO ji = 1, jpiglo-1
5214	iju = jpiglo-ji
5215	ztab(ji,ijpj+jl) = psgn * ztab(iju,ijpj-2-jl)
5216	END DO
5217	END DO
5218	DO ji = jpiglo/2+1, jpiglo-1
5219	iju = jpiglo-ji
5220	ztab(ji,ijpjm1) = psgn * ztab(iju,ijpjm1)
5221	END DO
5222
5223	CASE ( 'I' ) ! ice U-V point
5224	ztab( 2 ,ijpj:ijpj+jpr2dj) = 0.e0
5225	DO jl = 0, jpr2dj
5226	DO ji = 2 , jpiglo-1
5227	ijt = jpiglo - ji + 2
5228	ztab(ji,ijpj+jl)= 0.5 * ( ztab(ji,ijpj-1-jl) + psgn * ztab(ijt,ijpj-1-jl) )
5229	END DO
5230	END DO
5231
5232	END SELECT
5233
5234	CASE DEFAULT ! * closed : the code probably never go through
5235
5236	SELECT CASE ( cd_type)
5237
5238	CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points
5239	ztab(:, 1:1-jpr2dj ) = 0.e0
5240	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5241
5242	CASE ( 'F' ) ! F-point
5243	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5244
5245	CASE ( 'I' ) ! ice U-V point
5246	ztab(:, 1:1-jpr2dj ) = 0.e0
5247	ztab(:,ijpj:ijpj+jpr2dj) = 0.e0
5248
5249	END SELECT
5250
5251	END SELECT
5252
5253	! End of slab
5254	! ===========
5255
5256	!! Scatter back to pt2d
5257	DO jr = 1, ndim_rank_north
5258	jproc=nrank_north(jr)+1
5259	ildi=nldit (jproc)
5260	ilei=nleit (jproc)
5261	iilb=nimppt(jproc)
5262	DO jj=1-jpr2dj,ijpj+jpr2dj
5263	DO ji=ildi,ilei
5264	znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj)
5265	END DO
5266	END DO
5267	END DO
5268
5269	ENDIF ! only done on proc 0 of ncomm_north
5270
5271	#ifdef key_mpp_shmem
5272	not done yet in shmem : compiler error
5273	#elif key_mpp_mpi
5274	IF ( npolj /= 0 ) THEN
5275	itaille=jpi(ijpj+2jpr2dj)
5276	CALL MPI_SCATTER(znorthgloio(1,1-jpr2dj,1),itaille,MPI_DOUBLE_PRECISION, &
5277	& znorthloc(1,1-jpr2dj),itaille,MPI_DOUBLE_PRECISION,0,ncomm_north,ierr)
5278	ENDIF
5279	#endif
5280
5281	! put in the last ijpj jlines of pt2d znorthloc
5282	DO jj = nlcj - ijpj -jpr2dj + 1 , nlcj +jpr2dj
5283	ij = jj - nlcj + ijpj
5284	pt2d(1:jpi,jj)= znorthloc(:,ij)
5285	END DO
5286
5287	END SUBROUTINE mpp_lbc_north_e
5288
5289	SUBROUTINE mpi_init_opa(code)
5290	!!---------------------------------------------------------------------
5291	!! * routine mpp_init.opa *
5292	!!
5293	!! ** Purpose :: export and attach a MPI buffer for bsend
5294	!!
5295	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
5296	!! but classical mpi_init
5297	!!
5298	!! History :: 01/11 :: IDRIS initial version for IBM only
5299	!! 08/04 :: R. Benshila, generalisation
5300	!!
5301	!!---------------------------------------------------------------------
5302
5303	INTEGER :: code,rang,ierr
5304	LOGICAL :: mpi_was_called
5305	REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon
5306
5307	! MPI initialization
5308	CALL mpi_initialized(mpi_was_called, code)
5309	IF ( code /= MPI_SUCCESS ) THEN
5310	CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
5311	CALL mpi_abort( mpi_comm_world, code, ierr )
5312	ENDIF
5313
5314	IF ( .NOT. mpi_was_called ) THEN
5315	CALL mpi_init(code)
5316	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
5317	IF ( code /= MPI_SUCCESS ) THEN
5318	CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
5319	CALL mpi_abort( mpi_comm_world, code, ierr )
5320	ENDIF
5321	ENDIF
5322
5323	IF( nn_buffer > 0 ) THEN
5324	IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of : ', nn_buffer
5325
5326	! Buffer allocation and attachment
5327	ALLOCATE(tampon(nn_buffer))
5328	CALL mpi_buffer_attach(tampon,nn_buffer,code)
5329	ENDIF
5330
5331	END SUBROUTINE mpi_init_opa
5332
5333	#else
5334	!!----------------------------------------------------------------------
5335	!! Default case: Dummy module share memory computing
5336	!!----------------------------------------------------------------------
5337	INTERFACE mpp_sum
5338	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i
5339	END INTERFACE
5340	INTERFACE mpp_max
5341	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
5342	END INTERFACE
5343	INTERFACE mpp_min
5344	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
5345	END INTERFACE
5346	INTERFACE mpp_isl
5347	MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real
5348	END INTERFACE
5349	INTERFACE mppobc
5350	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
5351	END INTERFACE
5352	INTERFACE mpp_minloc
5353	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
5354	END INTERFACE
5355	INTERFACE mpp_maxloc
5356	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
5357	END INTERFACE
5358
5359
5360	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
5361	INTEGER :: ncomm_ice
5362
5363	CONTAINS
5364
5365	FUNCTION mynode(localComm) RESULT (function_value)
5366	INTEGER, OPTIONAL :: localComm
5367	function_value = 0
5368	END FUNCTION mynode
5369
5370	SUBROUTINE mppsync ! Dummy routine
5371	END SUBROUTINE mppsync
5372
5373	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
5374	REAL , DIMENSION(:) :: parr
5375	INTEGER :: kdim
5376	INTEGER, OPTIONAL :: kcom
5377	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
5378	END SUBROUTINE mpp_sum_as
5379
5380	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
5381	REAL , DIMENSION(:,:) :: parr
5382	INTEGER :: kdim
5383	INTEGER, OPTIONAL :: kcom
5384	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
5385	END SUBROUTINE mpp_sum_a2s
5386
5387	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
5388	INTEGER, DIMENSION(:) :: karr
5389	INTEGER :: kdim
5390	INTEGER, OPTIONAL :: kcom
5391	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
5392	END SUBROUTINE mpp_sum_ai
5393
5394	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
5395	REAL :: psca
5396	INTEGER, OPTIONAL :: kcom
5397	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
5398	END SUBROUTINE mpp_sum_s
5399
5400	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
5401	integer :: kint
5402	INTEGER, OPTIONAL :: kcom
5403	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
5404	END SUBROUTINE mpp_sum_i
5405
5406	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
5407	REAL , DIMENSION(:) :: parr
5408	INTEGER :: kdim
5409	INTEGER, OPTIONAL :: kcom
5410	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
5411	END SUBROUTINE mppmax_a_real
5412
5413	SUBROUTINE mppmax_real( psca, kcom )
5414	REAL :: psca
5415	INTEGER, OPTIONAL :: kcom
5416	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
5417	END SUBROUTINE mppmax_real
5418
5419	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
5420	REAL , DIMENSION(:) :: parr
5421	INTEGER :: kdim
5422	INTEGER, OPTIONAL :: kcom
5423	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
5424	END SUBROUTINE mppmin_a_real
5425
5426	SUBROUTINE mppmin_real( psca, kcom )
5427	REAL :: psca
5428	INTEGER, OPTIONAL :: kcom
5429	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
5430	END SUBROUTINE mppmin_real
5431
5432	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
5433	INTEGER, DIMENSION(:) :: karr
5434	INTEGER :: kdim
5435	INTEGER, OPTIONAL :: kcom
5436	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
5437	END SUBROUTINE mppmax_a_int
5438
5439	SUBROUTINE mppmax_int( kint, kcom)
5440	INTEGER :: kint
5441	INTEGER, OPTIONAL :: kcom
5442	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
5443	END SUBROUTINE mppmax_int
5444
5445	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
5446	INTEGER, DIMENSION(:) :: karr
5447	INTEGER :: kdim
5448	INTEGER, OPTIONAL :: kcom
5449	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
5450	END SUBROUTINE mppmin_a_int
5451
5452	SUBROUTINE mppmin_int( kint, kcom )
5453	INTEGER :: kint
5454	INTEGER, OPTIONAL :: kcom
5455	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
5456	END SUBROUTINE mppmin_int
5457
5458	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
5459	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5460	REAL, DIMENSION(:) :: parr ! variable array
5461	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5462	& parr(1), kd1, kd2, kl, kk, ktype, kij
5463	END SUBROUTINE mppobc_1d
5464
5465	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
5466	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5467	REAL, DIMENSION(:,:) :: parr ! variable array
5468	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5469	& parr(1,1), kd1, kd2, kl, kk, ktype, kij
5470	END SUBROUTINE mppobc_2d
5471
5472	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
5473	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5474	REAL, DIMENSION(:,:,:) :: parr ! variable array
5475	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5476	& parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
5477	END SUBROUTINE mppobc_3d
5478
5479	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
5480	INTEGER :: kd1, kd2, kl , kk, ktype, kij
5481	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
5482	WRITE(,) 'mppobc: You should not have seen this print! error?', &
5483	& parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
5484	END SUBROUTINE mppobc_4d
5485
5486
5487	SUBROUTINE mpplnks( parr ) ! Dummy routine
5488	REAL, DIMENSION(:,:) :: parr
5489	WRITE(,) 'mpplnks: You should not have seen this print! error?', parr(1,1)
5490	END SUBROUTINE mpplnks
5491
5492	SUBROUTINE mppisl_a_int( karr, kdim )
5493	INTEGER, DIMENSION(:) :: karr
5494	INTEGER :: kdim
5495	WRITE(,) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1)
5496	END SUBROUTINE mppisl_a_int
5497
5498	SUBROUTINE mppisl_int( kint )
5499	INTEGER :: kint
5500	WRITE(,) 'mppisl_int: You should not have seen this print! error?', kint
5501	END SUBROUTINE mppisl_int
5502
5503	SUBROUTINE mppisl_a_real( parr, kdim )
5504	REAL , DIMENSION(:) :: parr
5505	INTEGER :: kdim
5506	WRITE(,) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1)
5507	END SUBROUTINE mppisl_a_real
5508
5509	SUBROUTINE mppisl_real( psca )
5510	REAL :: psca
5511	WRITE(,) 'mppisl_real: You should not have seen this print! error?', psca
5512	END SUBROUTINE mppisl_real
5513
5514	SUBROUTINE mpp_minloc2d ( ptab, pmask, pmin, ki, kj )
5515	REAL :: pmin
5516	REAL , DIMENSION (:,:) :: ptab, pmask
5517	INTEGER :: ki, kj
5518	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj
5519	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
5520	END SUBROUTINE mpp_minloc2d
5521
5522	SUBROUTINE mpp_minloc3d ( ptab, pmask, pmin, ki, kj, kk )
5523	REAL :: pmin
5524	REAL , DIMENSION (:,:,:) :: ptab, pmask
5525	INTEGER :: ki, kj, kk
5526	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmin, ki, kj, kk
5527	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
5528	END SUBROUTINE mpp_minloc3d
5529
5530	SUBROUTINE mpp_maxloc2d ( ptab, pmask, pmax, ki, kj )
5531	REAL :: pmax
5532	REAL , DIMENSION (:,:) :: ptab, pmask
5533	INTEGER :: ki, kj
5534	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj
5535	WRITE(,) ' " ": " " ', ptab(1,1), pmask(1,1)
5536	END SUBROUTINE mpp_maxloc2d
5537
5538	SUBROUTINE mpp_maxloc3d ( ptab, pmask, pmax, ki, kj, kk )
5539	REAL :: pmax
5540	REAL , DIMENSION (:,:,:) :: ptab, pmask
5541	INTEGER :: ki, kj, kk
5542	WRITE(,) 'mppisl_real: You should not have seen this print! error?', pmax, ki, kj, kk
5543	WRITE(,) ' " ": " " ', ptab(1,1,1), pmask(1,1,1)
5544	END SUBROUTINE mpp_maxloc3d
5545
5546	SUBROUTINE mppstop
5547	WRITE(,) 'mppstop: You should not have seen this print! error?'
5548	END SUBROUTINE mppstop
5549
5550	SUBROUTINE mpp_ini_ice(kcom)
5551	INTEGER :: kcom
5552	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?',kcom
5553	END SUBROUTINE mpp_ini_ice
5554
5555	SUBROUTINE mpp_comm_free(kcom)
5556	INTEGER :: kcom
5557	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?',kcom
5558	END SUBROUTINE mpp_comm_free
5559
5560	#endif
5561	!!----------------------------------------------------------------------
5562	END MODULE lib_mpp

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

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

Context Navigation

source: branches/TAM_V3_0/NEMO/OPA_SRC/lib_mpp.F90 @ 1944

Download in other formats: