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

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

lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

Context Navigation

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

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

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

Download in other formats: