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 @ 897

Last change on this file since 897 was 897, checked in by rblod, 16 years ago
Add nn_buffer in namelist nammpp to control the buffer size for bsend, see ticket #116
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 185.2 KB

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

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

Download in other formats: