Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

lib_mpp.F90 @ 2240

Last change on this file since 2240 was 2236, checked in by cetlod, 14 years ago
First guess of NEMO_v3.3
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 115.4 KB

Rev	Line
[3]	1	MODULE lib_mpp
[13]	2	!!======================================================================
	3	!! * MODULE lib_mpp *
[1344]	4	!! Ocean numerics: massively parallel processing library
[13]	5	!!=====================================================================
[1344]	6	!! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code
	7	!! 7.0 ! 1997 (A.M. Treguier) SHMEM additions
	8	!! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
	9	!! ! 1998 (J.M. Molines) Open boundary conditions
	10	!! NEMO 1.0 ! 2003 (J.-M. Molines, G. Madec) F90, free form
	11	!! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d)
	12	!! - ! 2004 (R. Bourdalle Badie) isend option in mpi
	13	!! ! 2004 (J.M. Molines) minloc, maxloc
	14	!! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
	15	!! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
	16	!! - ! 2005 (R. Benshila, G. Madec) add extra halo case
	17	!! - ! 2008 (R. Benshila) add mpp_ini_ice
	18	!! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd
[1345]	19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
[13]	20	!!----------------------------------------------------------------------
[1344]	21	#if defined key_mpp_mpi
[13]	22	!!----------------------------------------------------------------------
[1344]	23	!! 'key_mpp_mpi' MPI massively parallel processing library
	24	!!----------------------------------------------------------------------
	25	!! mynode : indentify the processor unit
	26	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
[473]	27	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
[1344]	28	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
	29	!! mpprecv :
[1345]	30	!! mppsend : SUBROUTINE mpp_ini_znl
[1344]	31	!! mppscatter :
	32	!! mppgather :
	33	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
	34	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
	35	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
	36	!! mpp_minloc :
	37	!! mpp_maxloc :
	38	!! mppsync :
	39	!! mppstop :
	40	!! mppobc : variant of mpp_lnk for open boundary condition
	41	!! mpp_ini_north : initialisation of north fold
	42	!! mpp_lbc_north : north fold processors gathering
	43	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
[13]	44	!!----------------------------------------------------------------------
	45	!! History :
	46	!! ! 94 (M. Guyon, J. Escobar, M. Imbard) Original code
	47	!! ! 97 (A.M. Treguier) SHMEM additions
	48	!! ! 98 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
	49	!! 9.0 ! 03 (J.-M. Molines, G. Madec) F90, free form
[233]	50	!! ! 04 (R. Bourdalle Badie) isend option in mpi
	51	!! ! 05 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
[532]	52	!! ! 05 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
[1344]	53	!! ! 09 (R. Benshila) SHMEM suppression, north fold in lbc_nfd
[13]	54	!!----------------------------------------------------------------------
[247]	55	!! OPA 9.0 , LOCEAN-IPSL (2005)
[888]	56	!! $Id$
[247]	57	!! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt
[13]	58	!!---------------------------------------------------------------------
	59	!! * Modules used
[473]	60	USE dom_oce ! ocean space and time domain
	61	USE in_out_manager ! I/O manager
[1344]	62	USE lbcnfd ! north fold treatment
[3]	63
[13]	64	IMPLICIT NONE
[415]	65	PRIVATE
[1344]	66
	67	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
	68	PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
	69	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
	70	PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
	71	PUBLIC mpprecv, mppsend, mppscatter, mppgather
[1528]	72	PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl
[1344]	73	PUBLIC mppsize, mpprank
[415]	74
[1976]	75	# if defined key_mpp_rep1
	76	PUBLIC mpp_allgatherv
	77	# endif
	78
[13]	79	!! * Interfaces
	80	!! define generic interface for these routine as they are called sometimes
[1344]	81	!! with scalar arguments instead of array arguments, which causes problems
	82	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
[13]	83	INTERFACE mpp_min
	84	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	85	END INTERFACE
	86	INTERFACE mpp_max
[681]	87	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	88	END INTERFACE
	89	INTERFACE mpp_sum
[1976]	90	# if defined key_mpp_rep2
	91	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
	92	mppsum_realdd, mppsum_a_realdd
	93	# else
[13]	94	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real
[1976]	95	# endif
[13]	96	END INTERFACE
	97	INTERFACE mpp_lbc_north
	98	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
	99	END INTERFACE
[1344]	100	INTERFACE mpp_minloc
	101	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	102	END INTERFACE
	103	INTERFACE mpp_maxloc
	104	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	105	END INTERFACE
[1976]	106
	107	# if defined key_mpp_rep1
	108	INTERFACE mpp_allgatherv
	109	MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int
	110	END INTERFACE
	111	# endif
[3]	112
[51]	113	!! ========================= !!
	114	!! MPI variable definition !!
	115	!! ========================= !!
[1629]	116	!$AGRIF_DO_NOT_TREAT
[2004]	117	INCLUDE 'mpif.h'
[1629]	118	!$AGRIF_END_DO_NOT_TREAT
[1344]	119
	120	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
[3]	121
[1344]	122	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
	123
	124	INTEGER :: mppsize ! number of process
	125	INTEGER :: mpprank ! process number [ 0 - size-1 ]
[1976]	126	INTEGER :: mpi_comm_opa ! opa local communicator
[3]	127
[1976]	128	INTEGER, PUBLIC :: MPI_SUMDD
	129
[869]	130	! variables used in case of sea-ice
[1344]	131	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice
[1345]	132	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
	133	INTEGER :: ndim_rank_ice ! number of 'ice' processors
	134	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
[1344]	135	INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_ice ! dimension ndim_rank_ice
[1345]	136
	137	! variables used for zonal integration
	138	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
	139	LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row
	140	INTEGER :: ngrp_znl ! group ID for the znl processors
	141	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
	142	INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
[1344]	143
	144	! North fold condition in mpp_mpi with jpni > 1
	145	INTEGER :: ngrp_world ! group ID for the world processors
[1345]	146	INTEGER :: ngrp_opa ! group ID for the opa processors
[1344]	147	INTEGER :: ngrp_north ! group ID for the northern processors (to be fold)
	148	INTEGER :: ncomm_north ! communicator made by the processors belonging to ngrp_north
	149	INTEGER :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
	150	INTEGER :: njmppmax ! value of njmpp for the processors of the northern line
	151	INTEGER :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
	152	INTEGER, DIMENSION(:), ALLOCATABLE :: nrank_north ! dimension ndim_rank_north
[3]	153
[1344]	154	! Type of send : standard, buffered, immediate
[1601]	155	CHARACTER(len=1) :: cn_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
	156	LOGICAL :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I')
[1344]	157	INTEGER :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend
	158
	159	REAL(wp), ALLOCATABLE, DIMENSION(:) :: tampon ! buffer in case of bsend
[3]	160
[1344]	161	! message passing arrays
	162	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: t4ns, t4sn ! 2 x 3d for north-south & south-north
	163	REAL(wp), DIMENSION(jpj,jpreci,jpk,2,2) :: t4ew, t4we ! 2 x 3d for east-west & west-east
	164	REAL(wp), DIMENSION(jpi,jprecj,jpk,2,2) :: t4p1, t4p2 ! 2 x 3d for north fold
	165	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: t3ns, t3sn ! 3d for north-south & south-north
	166	REAL(wp), DIMENSION(jpj,jpreci,jpk,2) :: t3ew, t3we ! 3d for east-west & west-east
	167	REAL(wp), DIMENSION(jpi,jprecj,jpk,2) :: t3p1, t3p2 ! 3d for north fold
	168	REAL(wp), DIMENSION(jpi,jprecj,2) :: t2ns, t2sn ! 2d for north-south & south-north
	169	REAL(wp), DIMENSION(jpj,jpreci,2) :: t2ew, t2we ! 2d for east-west & west-east
	170	REAL(wp), DIMENSION(jpi,jprecj,2) :: t2p1, t2p2 ! 2d for north fold
	171	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,jprecj+jpr2dj,2) :: tr2ns, tr2sn ! 2d for north-south & south-north + extra outer halo
	172	REAL(wp), DIMENSION(1-jpr2dj:jpj+jpr2dj,jpreci+jpr2di,2) :: tr2ew, tr2we ! 2d for east-west & west-east + extra outer halo
[51]	173	!!----------------------------------------------------------------------
[1344]	174	!! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)
[888]	175	!! $Id$
[2236]	176	!! Software governed by the CeCILL licence (NEMOGCM/License_CeCILL.txt)
[1344]	177	!!----------------------------------------------------------------------
[3]	178
	179	CONTAINS
	180
[1579]	181	FUNCTION mynode(ldtxt, localComm)
[51]	182	!!----------------------------------------------------------------------
	183	!! * routine mynode *
	184	!!
	185	!! ** Purpose : Find processor unit
	186	!!
	187	!!----------------------------------------------------------------------
[1579]	188	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
	189	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[532]	190	INTEGER :: mynode, ierr, code
	191	LOGICAL :: mpi_was_called
[1579]	192
[1601]	193	NAMELIST/nammpp/ cn_mpi_send, nn_buffer
[51]	194	!!----------------------------------------------------------------------
[1344]	195	!
[1579]	196	WRITE(ldtxt(1),*)
	197	WRITE(ldtxt(2),*) 'mynode : mpi initialisation'
	198	WRITE(ldtxt(3),*) '~~~~~~ '
[1344]	199	!
	200	REWIND( numnam ) ! Namelist namrun : parameters of the run
[1601]	201	READ ( numnam, nammpp )
[1344]	202	! ! control print
[1601]	203	WRITE(ldtxt(4),*) ' Namelist nammpp'
	204	WRITE(ldtxt(5),*) ' mpi send type cn_mpi_send = ', cn_mpi_send
	205	WRITE(ldtxt(6),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer
[300]	206
[1976]	207	#if defined key_agrif
	208	IF( Agrif_Root() ) THEN
	209	#endif
	210	!!bug RB : should be clean to use Agrif in coupled mode
	211	#if ! defined key_agrif
	212	CALL mpi_initialized ( mpi_was_called, code )
	213	IF( code /= MPI_SUCCESS ) THEN
	214	WRITE(*, cform_err)
	215	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
	216	CALL mpi_abort( mpi_comm_world, code, ierr )
	217	ENDIF
[415]	218
[1976]	219	IF( PRESENT(localComm) .and. mpi_was_called ) THEN
	220	mpi_comm_opa = localComm
	221	SELECT CASE ( cn_mpi_send )
	222	CASE ( 'S' ) ! Standard mpi send (blocking)
	223	WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)'
	224	CASE ( 'B' ) ! Buffer mpi send (blocking)
	225	WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)'
	226	CALL mpi_init_opa( ierr )
	227	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
	228	WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)'
	229	l_isend = .TRUE.
	230	CASE DEFAULT
	231	WRITE(ldtxt(7),cform_err)
	232	WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send
	233	nstop = nstop + 1
	234	END SELECT
	235	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
	236	WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator '
	237	WRITE(ldtxt(8),*) ' without calling MPI_Init before ! '
[1579]	238	nstop = nstop + 1
[1976]	239	ELSE
	240	#endif
	241	SELECT CASE ( cn_mpi_send )
	242	CASE ( 'S' ) ! Standard mpi send (blocking)
	243	WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)'
	244	CALL mpi_init( ierr )
	245	CASE ( 'B' ) ! Buffer mpi send (blocking)
	246	WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)'
	247	CALL mpi_init_opa( ierr )
	248	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
	249	WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)'
	250	l_isend = .TRUE.
	251	CALL mpi_init( ierr )
	252	CASE DEFAULT
	253	WRITE(ldtxt(7),cform_err)
	254	WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send
	255	nstop = nstop + 1
	256	END SELECT
	257
	258	#if ! defined key_agrif
	259	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
	260	IF( code /= MPI_SUCCESS ) THEN
	261	WRITE(*, cform_err)
	262	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
	263	CALL mpi_abort( mpi_comm_world, code, ierr )
	264	ENDIF
	265	!
	266	ENDIF
	267	#endif
	268	#if defined key_agrif
[532]	269	ELSE
[1601]	270	SELECT CASE ( cn_mpi_send )
[524]	271	CASE ( 'S' ) ! Standard mpi send (blocking)
[1579]	272	WRITE(ldtxt(7),*) ' Standard blocking mpi send (send)'
[524]	273	CASE ( 'B' ) ! Buffer mpi send (blocking)
[1579]	274	WRITE(ldtxt(7),*) ' Buffer blocking mpi send (bsend)'
[524]	275	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[1579]	276	WRITE(ldtxt(7),*) ' Immediate non-blocking send (isend)'
[524]	277	l_isend = .TRUE.
	278	CASE DEFAULT
[1579]	279	WRITE(ldtxt(7),cform_err)
[1601]	280	WRITE(ldtxt(8),*) ' bad value for cn_mpi_send = ', cn_mpi_send
[524]	281	nstop = nstop + 1
	282	END SELECT
[415]	283	ENDIF
[570]	284
[1976]	285	mpi_comm_opa = mpi_comm_world
	286	#endif
[1344]	287	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
	288	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
[629]	289	mynode = mpprank
[1344]	290	!
[1976]	291	#if defined key_mpp_rep2
	292	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
	293	#endif
	294	!
[51]	295	END FUNCTION mynode
[3]	296
	297
[888]	298	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
[51]	299	!!----------------------------------------------------------------------
	300	!! * routine mpp_lnk_3d *
	301	!!
	302	!! ** Purpose : Message passing manadgement
	303	!!
	304	!! ** Method : Use mppsend and mpprecv function for passing mask
	305	!! between processors following neighboring subdomains.
	306	!! domain parameters
	307	!! nlci : first dimension of the local subdomain
	308	!! nlcj : second dimension of the local subdomain
	309	!! nbondi : mark for "east-west local boundary"
	310	!! nbondj : mark for "north-south local boundary"
	311	!! noea : number for local neighboring processors
	312	!! nowe : number for local neighboring processors
	313	!! noso : number for local neighboring processors
	314	!! nono : number for local neighboring processors
	315	!!
	316	!! ** Action : ptab with update value at its periphery
	317	!!
	318	!!----------------------------------------------------------------------
[1344]	319	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	320	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	321	! ! = T , U , V , F , W points
	322	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	323	! ! = 1. , the sign is kept
	324	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
	325	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
	326	!!
[1718]	327	INTEGER :: ji, jj, jk, jl ! dummy loop indices
[1344]	328	INTEGER :: imigr, iihom, ijhom ! temporary integers
	329	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
[888]	330	REAL(wp) :: zland
[1344]	331	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[51]	332	!!----------------------------------------------------------------------
[3]	333
[1344]	334	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
	335	ELSE ; zland = 0.e0 ! zero by default
	336	ENDIF
	337
[51]	338	! 1. standard boundary treatment
	339	! ------------------------------
[1718]	340	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
[1344]	341	!
[1718]	342	! WARNING ptab is defined only between nld and nle
	343	DO jk = 1, jpk
	344	DO jj = nlcj+1, jpj ! added line(s) (inner only)
	345	ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)
	346	ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)
	347	ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)
	348	END DO
	349	DO ji = nlci+1, jpi ! added column(s) (full)
	350	ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)
	351	ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)
	352	ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)
	353	END DO
[610]	354	END DO
[1344]	355	!
	356	ELSE ! standard close or cyclic treatment
	357	!
	358	! ! East-West boundaries
	359	! !* Cyclic east-west
	360	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]	361	ptab( 1 ,:,:) = ptab(jpim1,:,:)
	362	ptab(jpi,:,:) = ptab( 2 ,:,:)
[1344]	363	ELSE !* closed
	364	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	365	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
[473]	366	ENDIF
[1344]	367	! ! North-South boundaries (always closed)
	368	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
	369	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
	370	!
[51]	371	ENDIF
[3]	372
[51]	373	! 2. East and west directions exchange
	374	! ------------------------------------
[1344]	375	! we play with the neigbours AND the row number because of the periodicity
	376	!
	377	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	378	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[51]	379	iihom = nlci-nreci
	380	DO jl = 1, jpreci
	381	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
	382	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
	383	END DO
[1345]	384	END SELECT
[1344]	385	!
	386	! ! Migrations
[51]	387	imigr = jpreci * jpj * jpk
[1344]	388	!
[51]	389	SELECT CASE ( nbondi )
	390	CASE ( -1 )
[181]	391	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
[51]	392	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
[300]	393	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	394	CASE ( 0 )
[181]	395	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	396	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
[51]	397	CALL mpprecv( 1, t3ew(1,1,1,2), imigr )
	398	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
[300]	399	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	400	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[51]	401	CASE ( 1 )
[181]	402	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
[51]	403	CALL mpprecv( 2, t3we(1,1,1,2), imigr )
[300]	404	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	405	END SELECT
[1344]	406	!
	407	! ! Write Dirichlet lateral conditions
[51]	408	iihom = nlci-jpreci
[1344]	409	!
[51]	410	SELECT CASE ( nbondi )
	411	CASE ( -1 )
	412	DO jl = 1, jpreci
	413	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	414	END DO
	415	CASE ( 0 )
	416	DO jl = 1, jpreci
	417	ptab(jl ,:,:) = t3we(:,jl,:,2)
	418	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	419	END DO
	420	CASE ( 1 )
	421	DO jl = 1, jpreci
	422	ptab(jl ,:,:) = t3we(:,jl,:,2)
	423	END DO
	424	END SELECT
[3]	425
	426
[51]	427	! 3. North and south directions
	428	! -----------------------------
[1344]	429	! always closed : we play only with the neigbours
	430	!
	431	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[51]	432	ijhom = nlcj-nrecj
	433	DO jl = 1, jprecj
	434	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
	435	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
	436	END DO
	437	ENDIF
[1344]	438	!
	439	! ! Migrations
[51]	440	imigr = jprecj * jpi * jpk
[1344]	441	!
[51]	442	SELECT CASE ( nbondj )
	443	CASE ( -1 )
[181]	444	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
[51]	445	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
[300]	446	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	447	CASE ( 0 )
[181]	448	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	449	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
[51]	450	CALL mpprecv( 3, t3ns(1,1,1,2), imigr )
	451	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
[300]	452	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	453	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[51]	454	CASE ( 1 )
[181]	455	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
[51]	456	CALL mpprecv( 4, t3sn(1,1,1,2), imigr )
[300]	457	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	458	END SELECT
[1344]	459	!
	460	! ! Write Dirichlet lateral conditions
[51]	461	ijhom = nlcj-jprecj
[1344]	462	!
[51]	463	SELECT CASE ( nbondj )
	464	CASE ( -1 )
	465	DO jl = 1, jprecj
	466	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	467	END DO
	468	CASE ( 0 )
	469	DO jl = 1, jprecj
	470	ptab(:,jl ,:) = t3sn(:,jl,:,2)
	471	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	472	END DO
	473	CASE ( 1 )
	474	DO jl = 1, jprecj
	475	ptab(:,jl,:) = t3sn(:,jl,:,2)
	476	END DO
	477	END SELECT
[3]	478
	479
[51]	480	! 4. north fold treatment
	481	! -----------------------
[1344]	482	!
	483	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
	484	!
	485	SELECT CASE ( jpni )
	486	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	487	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	488	END SELECT
	489	!
[473]	490	ENDIF
[1344]	491	!
[51]	492	END SUBROUTINE mpp_lnk_3d
[3]	493
	494
[888]	495	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[51]	496	!!----------------------------------------------------------------------
	497	!! * routine mpp_lnk_2d *
	498	!!
	499	!! ** Purpose : Message passing manadgement for 2d array
	500	!!
	501	!! ** Method : Use mppsend and mpprecv function for passing mask
	502	!! between processors following neighboring subdomains.
	503	!! domain parameters
	504	!! nlci : first dimension of the local subdomain
	505	!! nlcj : second dimension of the local subdomain
	506	!! nbondi : mark for "east-west local boundary"
	507	!! nbondj : mark for "north-south local boundary"
	508	!! noea : number for local neighboring processors
	509	!! nowe : number for local neighboring processors
	510	!! noso : number for local neighboring processors
	511	!! nono : number for local neighboring processors
	512	!!
	513	!!----------------------------------------------------------------------
[1344]	514	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
	515	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	516	! ! = T , U , V , F , W and I points
	517	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	518	! ! = 1. , the sign is kept
	519	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
	520	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
	521	!!
	522	INTEGER :: ji, jj, jl ! dummy loop indices
	523	INTEGER :: imigr, iihom, ijhom ! temporary integers
	524	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
[888]	525	REAL(wp) :: zland
[1344]	526	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[51]	527	!!----------------------------------------------------------------------
[3]	528
[1344]	529	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
	530	ELSE ; zland = 0.e0 ! zero by default
[888]	531	ENDIF
	532
[51]	533	! 1. standard boundary treatment
	534	! ------------------------------
[1344]	535	!
[1718]	536	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
[1344]	537	!
[1718]	538	! WARNING pt2d is defined only between nld and nle
	539	DO jj = nlcj+1, jpj ! added line(s) (inner only)
	540	pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
	541	pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
	542	pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
[610]	543	END DO
[1718]	544	DO ji = nlci+1, jpi ! added column(s) (full)
	545	pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
	546	pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
	547	pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
[1344]	548	END DO
	549	!
	550	ELSE ! standard close or cyclic treatment
	551	!
	552	! ! East-West boundaries
	553	IF( nbondi == 2 .AND. & ! Cyclic east-west
[473]	554	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[1344]	555	pt2d( 1 ,:) = pt2d(jpim1,:) ! west
	556	pt2d(jpi,:) = pt2d( 2 ,:) ! east
	557	ELSE ! closed
	558	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
	559	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
[473]	560	ENDIF
[1344]	561	! ! North-South boundaries (always closed)
	562	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
	563	pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
	564	!
[51]	565	ENDIF
[3]	566
[1344]	567	! 2. East and west directions exchange
	568	! ------------------------------------
	569	! we play with the neigbours AND the row number because of the periodicity
	570	!
	571	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	572	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[51]	573	iihom = nlci-nreci
	574	DO jl = 1, jpreci
	575	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
	576	t2we(:,jl,1) = pt2d(iihom +jl,:)
	577	END DO
	578	END SELECT
[1344]	579	!
	580	! ! Migrations
[51]	581	imigr = jpreci * jpj
[1344]	582	!
[51]	583	SELECT CASE ( nbondi )
	584	CASE ( -1 )
[181]	585	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
[51]	586	CALL mpprecv( 1, t2ew(1,1,2), imigr )
[300]	587	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	588	CASE ( 0 )
[181]	589	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	590	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
[51]	591	CALL mpprecv( 1, t2ew(1,1,2), imigr )
	592	CALL mpprecv( 2, t2we(1,1,2), imigr )
[300]	593	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	594	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]	595	CASE ( 1 )
[181]	596	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
[51]	597	CALL mpprecv( 2, t2we(1,1,2), imigr )
[300]	598	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	599	END SELECT
[1344]	600	!
	601	! ! Write Dirichlet lateral conditions
[51]	602	iihom = nlci - jpreci
[1344]	603	!
[51]	604	SELECT CASE ( nbondi )
	605	CASE ( -1 )
	606	DO jl = 1, jpreci
	607	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	608	END DO
	609	CASE ( 0 )
	610	DO jl = 1, jpreci
	611	pt2d(jl ,:) = t2we(:,jl,2)
	612	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	613	END DO
	614	CASE ( 1 )
	615	DO jl = 1, jpreci
	616	pt2d(jl ,:) = t2we(:,jl,2)
	617	END DO
	618	END SELECT
[3]	619
	620
[51]	621	! 3. North and south directions
	622	! -----------------------------
[1344]	623	! always closed : we play only with the neigbours
	624	!
	625	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[51]	626	ijhom = nlcj-nrecj
	627	DO jl = 1, jprecj
	628	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
	629	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
	630	END DO
	631	ENDIF
[1344]	632	!
	633	! ! Migrations
[51]	634	imigr = jprecj * jpi
[1344]	635	!
[51]	636	SELECT CASE ( nbondj )
	637	CASE ( -1 )
[181]	638	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
[51]	639	CALL mpprecv( 3, t2ns(1,1,2), imigr )
[300]	640	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	641	CASE ( 0 )
[181]	642	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	643	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
[51]	644	CALL mpprecv( 3, t2ns(1,1,2), imigr )
	645	CALL mpprecv( 4, t2sn(1,1,2), imigr )
[300]	646	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	647	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]	648	CASE ( 1 )
[181]	649	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
[51]	650	CALL mpprecv( 4, t2sn(1,1,2), imigr )
[300]	651	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	652	END SELECT
[1344]	653	!
	654	! ! Write Dirichlet lateral conditions
[51]	655	ijhom = nlcj - jprecj
[1344]	656	!
[51]	657	SELECT CASE ( nbondj )
	658	CASE ( -1 )
	659	DO jl = 1, jprecj
	660	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	661	END DO
	662	CASE ( 0 )
	663	DO jl = 1, jprecj
	664	pt2d(:,jl ) = t2sn(:,jl,2)
	665	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	666	END DO
	667	CASE ( 1 )
	668	DO jl = 1, jprecj
	669	pt2d(:,jl ) = t2sn(:,jl,2)
	670	END DO
[1344]	671	END SELECT
[3]	672
[1344]	673
[51]	674	! 4. north fold treatment
	675	! -----------------------
[1344]	676	!
	677	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
	678	!
	679	SELECT CASE ( jpni )
	680	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
	681	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
	682	END SELECT
	683	!
[473]	684	ENDIF
[1344]	685	!
[51]	686	END SUBROUTINE mpp_lnk_2d
[3]	687
	688
[473]	689	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
	690	!!----------------------------------------------------------------------
	691	!! * routine mpp_lnk_3d_gather *
	692	!!
	693	!! ** Purpose : Message passing manadgement for two 3D arrays
	694	!!
	695	!! ** Method : Use mppsend and mpprecv function for passing mask
	696	!! between processors following neighboring subdomains.
	697	!! domain parameters
	698	!! nlci : first dimension of the local subdomain
	699	!! nlcj : second dimension of the local subdomain
	700	!! nbondi : mark for "east-west local boundary"
	701	!! nbondj : mark for "north-south local boundary"
	702	!! noea : number for local neighboring processors
	703	!! nowe : number for local neighboring processors
	704	!! noso : number for local neighboring processors
	705	!! nono : number for local neighboring processors
	706	!!
	707	!! ** Action : ptab1 and ptab2 with update value at its periphery
	708	!!
	709	!!----------------------------------------------------------------------
[1344]	710	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which
	711	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied
	712	CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays
	713	CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points
	714	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	715	!! ! = 1. , the sign is kept
	716	INTEGER :: jl ! dummy loop indices
	717	INTEGER :: imigr, iihom, ijhom ! temporary integers
	718	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	719	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[473]	720	!!----------------------------------------------------------------------
	721
	722	! 1. standard boundary treatment
	723	! ------------------------------
[1344]	724	! ! East-West boundaries
	725	! !* Cyclic east-west
	726	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]	727	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
	728	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
	729	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
	730	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
[1344]	731	ELSE !* closed
	732	IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point
	733	IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0
	734	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north
	735	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
[473]	736	ENDIF
	737
[1344]	738
	739	! ! North-South boundaries
	740	IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point
	741	IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0
	742	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north
	743	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
[473]	744
	745
	746	! 2. East and west directions exchange
	747	! ------------------------------------
[1344]	748	! we play with the neigbours AND the row number because of the periodicity
	749	!
	750	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	751	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[473]	752	iihom = nlci-nreci
	753	DO jl = 1, jpreci
	754	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
	755	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
	756	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
	757	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
	758	END DO
	759	END SELECT
[1344]	760	!
	761	! ! Migrations
[473]	762	imigr = jpreci * jpj * jpk *2
[1344]	763	!
[473]	764	SELECT CASE ( nbondi )
	765	CASE ( -1 )
	766	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
	767	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
	768	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	769	CASE ( 0 )
	770	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
	771	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
	772	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr )
	773	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
	774	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	775	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	776	CASE ( 1 )
	777	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
	778	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr )
	779	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	780	END SELECT
[1344]	781	!
	782	! ! Write Dirichlet lateral conditions
	783	iihom = nlci - jpreci
	784	!
[473]	785	SELECT CASE ( nbondi )
	786	CASE ( -1 )
	787	DO jl = 1, jpreci
	788	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
	789	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
	790	END DO
	791	CASE ( 0 )
	792	DO jl = 1, jpreci
	793	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
	794	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
	795	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
	796	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
	797	END DO
	798	CASE ( 1 )
	799	DO jl = 1, jpreci
	800	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
	801	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
	802	END DO
	803	END SELECT
	804
	805
	806	! 3. North and south directions
	807	! -----------------------------
[1344]	808	! always closed : we play only with the neigbours
	809	!
	810	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	811	ijhom = nlcj - nrecj
[473]	812	DO jl = 1, jprecj
	813	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
	814	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
	815	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
	816	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
	817	END DO
	818	ENDIF
[1344]	819	!
	820	! ! Migrations
[473]	821	imigr = jprecj * jpi * jpk * 2
[1344]	822	!
[473]	823	SELECT CASE ( nbondj )
	824	CASE ( -1 )
	825	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
	826	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
	827	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	828	CASE ( 0 )
	829	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
	830	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
	831	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr )
	832	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
	833	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	834	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	835	CASE ( 1 )
	836	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
	837	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr )
	838	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	839	END SELECT
[1344]	840	!
	841	! ! Write Dirichlet lateral conditions
	842	ijhom = nlcj - jprecj
	843	!
[473]	844	SELECT CASE ( nbondj )
	845	CASE ( -1 )
	846	DO jl = 1, jprecj
	847	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
	848	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
	849	END DO
	850	CASE ( 0 )
	851	DO jl = 1, jprecj
	852	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
	853	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
	854	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
	855	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
	856	END DO
	857	CASE ( 1 )
	858	DO jl = 1, jprecj
	859	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
	860	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
	861	END DO
	862	END SELECT
	863
	864
	865	! 4. north fold treatment
	866	! -----------------------
[1344]	867	IF( npolj /= 0 ) THEN
	868	!
	869	SELECT CASE ( jpni )
	870	CASE ( 1 )
	871	CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs.
	872	CALL lbc_nfd ( ptab2, cd_type2, psgn )
	873	CASE DEFAULT
	874	CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
	875	CALL mpp_lbc_north (ptab2, cd_type2, psgn)
	876	END SELECT
	877	!
	878	ENDIF
	879	!
[473]	880	END SUBROUTINE mpp_lnk_3d_gather
	881
	882
[311]	883	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn )
	884	!!----------------------------------------------------------------------
	885	!! * routine mpp_lnk_2d_e *
	886	!!
	887	!! ** Purpose : Message passing manadgement for 2d array (with halo)
	888	!!
	889	!! ** Method : Use mppsend and mpprecv function for passing mask
	890	!! between processors following neighboring subdomains.
	891	!! domain parameters
	892	!! nlci : first dimension of the local subdomain
	893	!! nlcj : second dimension of the local subdomain
	894	!! jpr2di : number of rows for extra outer halo
	895	!! jpr2dj : number of columns for extra outer halo
	896	!! nbondi : mark for "east-west local boundary"
	897	!! nbondj : mark for "north-south local boundary"
	898	!! noea : number for local neighboring processors
	899	!! nowe : number for local neighboring processors
	900	!! noso : number for local neighboring processors
	901	!! nono : number for local neighboring processors
	902	!!
	903	!!----------------------------------------------------------------------
[1344]	904	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
	905	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
	906	! ! = T , U , V , F , W and I points
	907	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
	908	!! ! north boundary, = 1. otherwise
	909	INTEGER :: jl ! dummy loop indices
	910	INTEGER :: imigr, iihom, ijhom ! temporary integers
	911	INTEGER :: ipreci, iprecj ! temporary integers
	912	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	913	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	914	!!----------------------------------------------------------------------
[311]	915
[1344]	916	ipreci = jpreci + jpr2di ! take into account outer extra 2D overlap area
[311]	917	iprecj = jprecj + jpr2dj
	918
	919
	920	! 1. standard boundary treatment
	921	! ------------------------------
[1344]	922	! Order matters Here !!!!
	923	!
	924	! !* North-South boundaries (always colsed)
	925	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jpr2dj : jprecj ) = 0.e0 ! south except at F-point
	926	pt2d(:,nlcj-jprecj+1:jpj+jpr2dj) = 0.e0 ! north
	927
	928	! ! East-West boundaries
	929	! !* Cyclic east-west
	930	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
	931	pt2d(1-jpr2di: 1 ,:) = pt2d(jpim1-jpr2di: jpim1 ,:) ! east
	932	pt2d( jpi :jpi+jpr2di,:) = pt2d( 2 :2+jpr2di,:) ! west
	933	!
	934	ELSE !* closed
	935	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpr2di :jpreci ,:) = 0.e0 ! south except at F-point
	936	pt2d(nlci-jpreci+1:jpi+jpr2di,:) = 0.e0 ! north
	937	ENDIF
	938	!
[311]	939
[1344]	940	! north fold treatment
	941	! -----------------------
	942	IF( npolj /= 0 ) THEN
	943	!
	944	SELECT CASE ( jpni )
	945	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jpr2dj), cd_type, psgn, pr2dj=jpr2dj )
	946	CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
	947	END SELECT
	948	!
[311]	949	ENDIF
	950
[1344]	951	! 2. East and west directions exchange
	952	! ------------------------------------
	953	! we play with the neigbours AND the row number because of the periodicity
	954	!
	955	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	956	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[311]	957	iihom = nlci-nreci-jpr2di
	958	DO jl = 1, ipreci
	959	tr2ew(:,jl,1) = pt2d(jpreci+jl,:)
	960	tr2we(:,jl,1) = pt2d(iihom +jl,:)
	961	END DO
	962	END SELECT
[1344]	963	!
	964	! ! Migrations
[311]	965	imigr = ipreci * ( jpj + 2*jpr2dj)
[1344]	966	!
[311]	967	SELECT CASE ( nbondi )
	968	CASE ( -1 )
	969	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req1 )
	970	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
	971	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	972	CASE ( 0 )
	973	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
	974	CALL mppsend( 2, tr2we(1-jpr2dj,1,1), imigr, noea, ml_req2 )
	975	CALL mpprecv( 1, tr2ew(1-jpr2dj,1,2), imigr )
	976	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
	977	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	978	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	979	CASE ( 1 )
	980	CALL mppsend( 1, tr2ew(1-jpr2dj,1,1), imigr, nowe, ml_req1 )
	981	CALL mpprecv( 2, tr2we(1-jpr2dj,1,2), imigr )
	982	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	983	END SELECT
[1344]	984	!
	985	! ! Write Dirichlet lateral conditions
[311]	986	iihom = nlci - jpreci
[1344]	987	!
[311]	988	SELECT CASE ( nbondi )
	989	CASE ( -1 )
	990	DO jl = 1, ipreci
	991	pt2d(iihom+jl,:) = tr2ew(:,jl,2)
	992	END DO
	993	CASE ( 0 )
	994	DO jl = 1, ipreci
	995	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
	996	pt2d( iihom+jl,:) = tr2ew(:,jl,2)
	997	END DO
	998	CASE ( 1 )
	999	DO jl = 1, ipreci
	1000	pt2d(jl-jpr2di,:) = tr2we(:,jl,2)
	1001	END DO
	1002	END SELECT
	1003
	1004
	1005	! 3. North and south directions
	1006	! -----------------------------
[1344]	1007	! always closed : we play only with the neigbours
	1008	!
	1009	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[311]	1010	ijhom = nlcj-nrecj-jpr2dj
	1011	DO jl = 1, iprecj
	1012	tr2sn(:,jl,1) = pt2d(:,ijhom +jl)
	1013	tr2ns(:,jl,1) = pt2d(:,jprecj+jl)
	1014	END DO
	1015	ENDIF
[1344]	1016	!
	1017	! ! Migrations
[311]	1018	imigr = iprecj * ( jpi + 2*jpr2di )
[1344]	1019	!
[311]	1020	SELECT CASE ( nbondj )
	1021	CASE ( -1 )
	1022	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req1 )
	1023	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
	1024	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1025	CASE ( 0 )
	1026	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
	1027	CALL mppsend( 4, tr2sn(1-jpr2di,1,1), imigr, nono, ml_req2 )
	1028	CALL mpprecv( 3, tr2ns(1-jpr2di,1,2), imigr )
	1029	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
	1030	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1031	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	1032	CASE ( 1 )
	1033	CALL mppsend( 3, tr2ns(1-jpr2di,1,1), imigr, noso, ml_req1 )
	1034	CALL mpprecv( 4, tr2sn(1-jpr2di,1,2), imigr )
	1035	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1036	END SELECT
[1344]	1037	!
	1038	! ! Write Dirichlet lateral conditions
[311]	1039	ijhom = nlcj - jprecj
[1344]	1040	!
[311]	1041	SELECT CASE ( nbondj )
	1042	CASE ( -1 )
	1043	DO jl = 1, iprecj
	1044	pt2d(:,ijhom+jl) = tr2ns(:,jl,2)
	1045	END DO
	1046	CASE ( 0 )
	1047	DO jl = 1, iprecj
	1048	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
	1049	pt2d(:,ijhom+jl ) = tr2ns(:,jl,2)
	1050	END DO
	1051	CASE ( 1 )
	1052	DO jl = 1, iprecj
	1053	pt2d(:,jl-jpr2dj) = tr2sn(:,jl,2)
	1054	END DO
[1344]	1055	END SELECT
[311]	1056
	1057	END SUBROUTINE mpp_lnk_2d_e
	1058
	1059
[1344]	1060	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
[51]	1061	!!----------------------------------------------------------------------
	1062	!! * routine mppsend *
	1063	!!
	1064	!! ** Purpose : Send messag passing array
	1065	!!
	1066	!!----------------------------------------------------------------------
[1344]	1067	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	1068	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
	1069	INTEGER , INTENT(in ) :: kdest ! receive process number
	1070	INTEGER , INTENT(in ) :: ktyp ! tag of the message
	1071	INTEGER , INTENT(in ) :: md_req ! argument for isend
	1072	!!
	1073	INTEGER :: iflag
[51]	1074	!!----------------------------------------------------------------------
[1344]	1075	!
[1601]	1076	SELECT CASE ( cn_mpi_send )
[300]	1077	CASE ( 'S' ) ! Standard mpi send (blocking)
[1344]	1078	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
[300]	1079	CASE ( 'B' ) ! Buffer mpi send (blocking)
[1344]	1080	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
[300]	1081	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[1344]	1082	! be carefull, one more argument here : the mpi request identifier..
	1083	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
[300]	1084	END SELECT
[1344]	1085	!
[51]	1086	END SUBROUTINE mppsend
[3]	1087
	1088
[51]	1089	SUBROUTINE mpprecv( ktyp, pmess, kbytes )
	1090	!!----------------------------------------------------------------------
	1091	!! * routine mpprecv *
	1092	!!
	1093	!! ** Purpose : Receive messag passing array
	1094	!!
	1095	!!----------------------------------------------------------------------
[1344]	1096	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	1097	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
	1098	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
	1099	!!
[51]	1100	INTEGER :: istatus(mpi_status_size)
	1101	INTEGER :: iflag
[1344]	1102	!!----------------------------------------------------------------------
	1103	!
	1104	CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp, mpi_comm_opa, istatus, iflag )
	1105	!
[51]	1106	END SUBROUTINE mpprecv
[3]	1107
	1108
[51]	1109	SUBROUTINE mppgather( ptab, kp, pio )
	1110	!!----------------------------------------------------------------------
	1111	!! * routine mppgather *
	1112	!!
	1113	!! ** Purpose : Transfert between a local subdomain array and a work
	1114	!! array which is distributed following the vertical level.
	1115	!!
[1344]	1116	!!----------------------------------------------------------------------
	1117	REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ptab ! subdomain input array
	1118	INTEGER , INTENT(in ) :: kp ! record length
	1119	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
[51]	1120	!!
[1344]	1121	INTEGER :: itaille, ierror ! temporary integer
[51]	1122	!!---------------------------------------------------------------------
[1344]	1123	!
	1124	itaille = jpi * jpj
	1125	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
[532]	1126	& mpi_double_precision, kp , mpi_comm_opa, ierror )
[1344]	1127	!
[51]	1128	END SUBROUTINE mppgather
[3]	1129
	1130
[51]	1131	SUBROUTINE mppscatter( pio, kp, ptab )
	1132	!!----------------------------------------------------------------------
	1133	!! * routine mppscatter *
	1134	!!
	1135	!! ** Purpose : Transfert between awork array which is distributed
	1136	!! following the vertical level and the local subdomain array.
	1137	!!
	1138	!!----------------------------------------------------------------------
	1139	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
	1140	INTEGER :: kp ! Tag (not used with MPI
	1141	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
[1344]	1142	!!
	1143	INTEGER :: itaille, ierror ! temporary integer
[51]	1144	!!---------------------------------------------------------------------
[1344]	1145	!
[51]	1146	itaille=jpi*jpj
[1344]	1147	!
	1148	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
	1149	& mpi_double_precision, kp , mpi_comm_opa, ierror )
	1150	!
[51]	1151	END SUBROUTINE mppscatter
[3]	1152
	1153
[869]	1154	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
[681]	1155	!!----------------------------------------------------------------------
	1156	!! * routine mppmax_a_int *
	1157	!!
	1158	!! ** Purpose : Find maximum value in an integer layout array
	1159	!!
	1160	!!----------------------------------------------------------------------
[1344]	1161	INTEGER , INTENT(in ) :: kdim ! size of array
	1162	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
	1163	INTEGER , INTENT(in ), OPTIONAL :: kcom !
	1164	!!
	1165	INTEGER :: ierror, localcomm ! temporary integer
[681]	1166	INTEGER, DIMENSION(kdim) :: iwork
[1344]	1167	!!----------------------------------------------------------------------
	1168	!
[869]	1169	localcomm = mpi_comm_opa
[1344]	1170	IF( PRESENT(kcom) ) localcomm = kcom
	1171	!
	1172	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
	1173	!
[681]	1174	ktab(:) = iwork(:)
[1344]	1175	!
[681]	1176	END SUBROUTINE mppmax_a_int
	1177
	1178
[869]	1179	SUBROUTINE mppmax_int( ktab, kcom )
[681]	1180	!!----------------------------------------------------------------------
	1181	!! * routine mppmax_int *
	1182	!!
[1344]	1183	!! ** Purpose : Find maximum value in an integer layout array
[681]	1184	!!
	1185	!!----------------------------------------------------------------------
[1344]	1186	INTEGER, INTENT(inout) :: ktab ! ???
	1187	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
	1188	!!
	1189	INTEGER :: ierror, iwork, localcomm ! temporary integer
	1190	!!----------------------------------------------------------------------
	1191	!
[869]	1192	localcomm = mpi_comm_opa
[1344]	1193	IF( PRESENT(kcom) ) localcomm = kcom
	1194	!
	1195	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
	1196	!
[681]	1197	ktab = iwork
[1344]	1198	!
[681]	1199	END SUBROUTINE mppmax_int
	1200
	1201
[869]	1202	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
[51]	1203	!!----------------------------------------------------------------------
	1204	!! * routine mppmin_a_int *
	1205	!!
	1206	!! ** Purpose : Find minimum value in an integer layout array
	1207	!!
	1208	!!----------------------------------------------------------------------
	1209	INTEGER , INTENT( in ) :: kdim ! size of array
	1210	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
[888]	1211	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	1212	!!
	1213	INTEGER :: ierror, localcomm ! temporary integer
[51]	1214	INTEGER, DIMENSION(kdim) :: iwork
[1344]	1215	!!----------------------------------------------------------------------
	1216	!
[869]	1217	localcomm = mpi_comm_opa
[1344]	1218	IF( PRESENT(kcom) ) localcomm = kcom
	1219	!
	1220	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
	1221	!
[51]	1222	ktab(:) = iwork(:)
[1344]	1223	!
[51]	1224	END SUBROUTINE mppmin_a_int
[3]	1225
[13]	1226
[1345]	1227	SUBROUTINE mppmin_int( ktab, kcom )
[51]	1228	!!----------------------------------------------------------------------
	1229	!! * routine mppmin_int *
	1230	!!
[1344]	1231	!! ** Purpose : Find minimum value in an integer layout array
[51]	1232	!!
	1233	!!----------------------------------------------------------------------
	1234	INTEGER, INTENT(inout) :: ktab ! ???
[1345]	1235	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	1236	!!
[1345]	1237	INTEGER :: ierror, iwork, localcomm
[1344]	1238	!!----------------------------------------------------------------------
	1239	!
[1345]	1240	localcomm = mpi_comm_opa
	1241	IF( PRESENT(kcom) ) localcomm = kcom
[1344]	1242	!
[1345]	1243	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
	1244	!
[51]	1245	ktab = iwork
[1344]	1246	!
[51]	1247	END SUBROUTINE mppmin_int
[3]	1248
[13]	1249
[51]	1250	SUBROUTINE mppsum_a_int( ktab, kdim )
	1251	!!----------------------------------------------------------------------
	1252	!! * routine mppsum_a_int *
	1253	!!
[1344]	1254	!! ** Purpose : Global integer sum, 1D array case
[51]	1255	!!
	1256	!!----------------------------------------------------------------------
[1344]	1257	INTEGER, INTENT(in ) :: kdim ! ???
[51]	1258	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
[1344]	1259	!!
[51]	1260	INTEGER :: ierror
	1261	INTEGER, DIMENSION (kdim) :: iwork
[1344]	1262	!!----------------------------------------------------------------------
	1263	!
	1264	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
	1265	!
[51]	1266	ktab(:) = iwork(:)
[1344]	1267	!
[51]	1268	END SUBROUTINE mppsum_a_int
[3]	1269
[13]	1270
[1344]	1271	SUBROUTINE mppsum_int( ktab )
	1272	!!----------------------------------------------------------------------
	1273	!! * routine mppsum_int *
	1274	!!
	1275	!! ** Purpose : Global integer sum
	1276	!!
	1277	!!----------------------------------------------------------------------
	1278	INTEGER, INTENT(inout) :: ktab
	1279	!!
	1280	INTEGER :: ierror, iwork
	1281	!!----------------------------------------------------------------------
	1282	!
	1283	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
	1284	!
	1285	ktab = iwork
	1286	!
	1287	END SUBROUTINE mppsum_int
[3]	1288
[13]	1289
[1344]	1290	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
	1291	!!----------------------------------------------------------------------
	1292	!! * routine mppmax_a_real *
	1293	!!
	1294	!! ** Purpose : Maximum
	1295	!!
	1296	!!----------------------------------------------------------------------
	1297	INTEGER , INTENT(in ) :: kdim
	1298	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
	1299	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1300	!!
	1301	INTEGER :: ierror, localcomm
	1302	REAL(wp), DIMENSION(kdim) :: zwork
	1303	!!----------------------------------------------------------------------
	1304	!
	1305	localcomm = mpi_comm_opa
	1306	IF( PRESENT(kcom) ) localcomm = kcom
	1307	!
	1308	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
	1309	ptab(:) = zwork(:)
	1310	!
	1311	END SUBROUTINE mppmax_a_real
[3]	1312
	1313
[1344]	1314	SUBROUTINE mppmax_real( ptab, kcom )
	1315	!!----------------------------------------------------------------------
	1316	!! * routine mppmax_real *
	1317	!!
	1318	!! ** Purpose : Maximum
	1319	!!
	1320	!!----------------------------------------------------------------------
	1321	REAL(wp), INTENT(inout) :: ptab ! ???
	1322	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
	1323	!!
	1324	INTEGER :: ierror, localcomm
	1325	REAL(wp) :: zwork
	1326	!!----------------------------------------------------------------------
	1327	!
	1328	localcomm = mpi_comm_opa
	1329	IF( PRESENT(kcom) ) localcomm = kcom
	1330	!
	1331	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
	1332	ptab = zwork
	1333	!
	1334	END SUBROUTINE mppmax_real
[13]	1335
[3]	1336
[1344]	1337	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
	1338	!!----------------------------------------------------------------------
	1339	!! * routine mppmin_a_real *
	1340	!!
	1341	!! ** Purpose : Minimum of REAL, array case
	1342	!!
	1343	!!-----------------------------------------------------------------------
	1344	INTEGER , INTENT(in ) :: kdim
	1345	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
	1346	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1347	!!
	1348	INTEGER :: ierror, localcomm
	1349	REAL(wp), DIMENSION(kdim) :: zwork
	1350	!!-----------------------------------------------------------------------
	1351	!
	1352	localcomm = mpi_comm_opa
	1353	IF( PRESENT(kcom) ) localcomm = kcom
	1354	!
	1355	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
	1356	ptab(:) = zwork(:)
	1357	!
	1358	END SUBROUTINE mppmin_a_real
[3]	1359
	1360
[1344]	1361	SUBROUTINE mppmin_real( ptab, kcom )
	1362	!!----------------------------------------------------------------------
	1363	!! * routine mppmin_real *
	1364	!!
	1365	!! ** Purpose : minimum of REAL, scalar case
	1366	!!
	1367	!!-----------------------------------------------------------------------
	1368	REAL(wp), INTENT(inout) :: ptab !
	1369	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1370	!!
	1371	INTEGER :: ierror
	1372	REAL(wp) :: zwork
	1373	INTEGER :: localcomm
	1374	!!-----------------------------------------------------------------------
	1375	!
	1376	localcomm = mpi_comm_opa
	1377	IF( PRESENT(kcom) ) localcomm = kcom
	1378	!
	1379	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
	1380	ptab = zwork
	1381	!
	1382	END SUBROUTINE mppmin_real
[13]	1383
[3]	1384
[1344]	1385	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
	1386	!!----------------------------------------------------------------------
	1387	!! * routine mppsum_a_real *
	1388	!!
	1389	!! ** Purpose : global sum, REAL ARRAY argument case
	1390	!!
	1391	!!-----------------------------------------------------------------------
	1392	INTEGER , INTENT( in ) :: kdim ! size of ptab
	1393	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
	1394	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1395	!!
	1396	INTEGER :: ierror ! temporary integer
	1397	INTEGER :: localcomm
	1398	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
	1399	!!-----------------------------------------------------------------------
	1400	!
	1401	localcomm = mpi_comm_opa
	1402	IF( PRESENT(kcom) ) localcomm = kcom
	1403	!
	1404	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
	1405	ptab(:) = zwork(:)
	1406	!
	1407	END SUBROUTINE mppsum_a_real
[869]	1408
[3]	1409
[1344]	1410	SUBROUTINE mppsum_real( ptab, kcom )
	1411	!!----------------------------------------------------------------------
	1412	!! * routine mppsum_real *
	1413	!!
	1414	!! ** Purpose : global sum, SCALAR argument case
	1415	!!
	1416	!!-----------------------------------------------------------------------
	1417	REAL(wp), INTENT(inout) :: ptab ! input scalar
	1418	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1419	!!
	1420	INTEGER :: ierror, localcomm
	1421	REAL(wp) :: zwork
	1422	!!-----------------------------------------------------------------------
	1423	!
	1424	localcomm = mpi_comm_opa
	1425	IF( PRESENT(kcom) ) localcomm = kcom
	1426	!
	1427	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
	1428	ptab = zwork
	1429	!
	1430	END SUBROUTINE mppsum_real
[3]	1431
[1976]	1432	# if defined key_mpp_rep2
	1433	SUBROUTINE mppsum_realdd( ytab, kcom )
	1434	!!----------------------------------------------------------------------
	1435	!! * routine mppsum_realdd *
	1436	!!
	1437	!! ** Purpose : global sum in Massively Parallel Processing
	1438	!! SCALAR argument case for double-double precision
	1439	!!
	1440	!!-----------------------------------------------------------------------
	1441	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
	1442	INTEGER , INTENT( in ), OPTIONAL :: kcom
[3]	1443
[1976]	1444	!! * Local variables (MPI version)
	1445	INTEGER :: ierror
	1446	INTEGER :: localcomm
	1447	COMPLEX(wp) :: zwork
	1448
	1449	localcomm = mpi_comm_opa
	1450	IF( PRESENT(kcom) ) localcomm = kcom
	1451
	1452	! reduce local sums into global sum
	1453	CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
	1454	MPI_SUMDD,localcomm,ierror)
	1455	ytab = zwork
	1456
	1457	END SUBROUTINE mppsum_realdd
	1458
	1459
	1460	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	1461	!!----------------------------------------------------------------------
	1462	!! * routine mppsum_a_realdd *
	1463	!!
	1464	!! ** Purpose : global sum in Massively Parallel Processing
	1465	!! COMPLEX ARRAY case for double-double precision
	1466	!!
	1467	!!-----------------------------------------------------------------------
	1468	INTEGER , INTENT( in ) :: kdim ! size of ytab
	1469	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
	1470	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1471
	1472	!! * Local variables (MPI version)
	1473	INTEGER :: ierror ! temporary integer
	1474	INTEGER :: localcomm
	1475	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
	1476
	1477	localcomm = mpi_comm_opa
	1478	IF( PRESENT(kcom) ) localcomm = kcom
	1479
	1480	CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
	1481	MPI_SUMDD,localcomm,ierror)
	1482	ytab(:) = zwork(:)
	1483
	1484	END SUBROUTINE mppsum_a_realdd
	1485	# endif
	1486
[1344]	1487	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
	1488	!!------------------------------------------------------------------------
	1489	!! * routine mpp_minloc *
	1490	!!
	1491	!! ** Purpose : Compute the global minimum of an array ptab
	1492	!! and also give its global position
	1493	!!
	1494	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1495	!!
	1496	!!--------------------------------------------------------------------------
	1497	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	1498	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	1499	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
	1500	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
	1501	!!
	1502	INTEGER , DIMENSION(2) :: ilocs
	1503	INTEGER :: ierror
	1504	REAL(wp) :: zmin ! local minimum
	1505	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1506	!!-----------------------------------------------------------------------
	1507	!
	1508	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
	1509	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
	1510	!
	1511	ki = ilocs(1) + nimpp - 1
	1512	kj = ilocs(2) + njmpp - 1
	1513	!
	1514	zain(1,:)=zmin
	1515	zain(2,:)=ki+10000.*kj
	1516	!
	1517	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
	1518	!
	1519	pmin = zaout(1,1)
	1520	kj = INT(zaout(2,1)/10000.)
	1521	ki = INT(zaout(2,1) - 10000.*kj )
	1522	!
	1523	END SUBROUTINE mpp_minloc2d
[13]	1524
[3]	1525
[1344]	1526	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
	1527	!!------------------------------------------------------------------------
	1528	!! * routine mpp_minloc *
	1529	!!
	1530	!! ** Purpose : Compute the global minimum of an array ptab
	1531	!! and also give its global position
	1532	!!
	1533	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1534	!!
	1535	!!--------------------------------------------------------------------------
	1536	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
	1537	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
	1538	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
	1539	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
	1540	!!
	1541	INTEGER :: ierror
	1542	REAL(wp) :: zmin ! local minimum
	1543	INTEGER , DIMENSION(3) :: ilocs
	1544	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1545	!!-----------------------------------------------------------------------
	1546	!
	1547	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
	1548	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
	1549	!
	1550	ki = ilocs(1) + nimpp - 1
	1551	kj = ilocs(2) + njmpp - 1
	1552	kk = ilocs(3)
	1553	!
	1554	zain(1,:)=zmin
	1555	zain(2,:)=ki+10000.kj+100000000.kk
	1556	!
	1557	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
	1558	!
	1559	pmin = zaout(1,1)
	1560	kk = INT( zaout(2,1) / 100000000. )
	1561	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	1562	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	1563	!
	1564	END SUBROUTINE mpp_minloc3d
[13]	1565
[3]	1566
[1344]	1567	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
	1568	!!------------------------------------------------------------------------
	1569	!! * routine mpp_maxloc *
	1570	!!
	1571	!! ** Purpose : Compute the global maximum of an array ptab
	1572	!! and also give its global position
	1573	!!
	1574	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1575	!!
	1576	!!--------------------------------------------------------------------------
	1577	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	1578	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	1579	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	1580	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
	1581	!!
	1582	INTEGER :: ierror
	1583	INTEGER, DIMENSION (2) :: ilocs
	1584	REAL(wp) :: zmax ! local maximum
	1585	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1586	!!-----------------------------------------------------------------------
	1587	!
	1588	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
	1589	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
	1590	!
	1591	ki = ilocs(1) + nimpp - 1
	1592	kj = ilocs(2) + njmpp - 1
	1593	!
	1594	zain(1,:) = zmax
	1595	zain(2,:) = ki + 10000. * kj
	1596	!
	1597	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
	1598	!
	1599	pmax = zaout(1,1)
	1600	kj = INT( zaout(2,1) / 10000. )
	1601	ki = INT( zaout(2,1) - 10000.* kj )
	1602	!
	1603	END SUBROUTINE mpp_maxloc2d
[3]	1604
[13]	1605
[1344]	1606	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
	1607	!!------------------------------------------------------------------------
	1608	!! * routine mpp_maxloc *
	1609	!!
	1610	!! ** Purpose : Compute the global maximum of an array ptab
	1611	!! and also give its global position
	1612	!!
	1613	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1614	!!
	1615	!!--------------------------------------------------------------------------
	1616	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
	1617	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
	1618	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	1619	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
	1620	!!
	1621	REAL(wp) :: zmax ! local maximum
	1622	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1623	INTEGER , DIMENSION(3) :: ilocs
	1624	INTEGER :: ierror
	1625	!!-----------------------------------------------------------------------
	1626	!
	1627	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
	1628	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
	1629	!
	1630	ki = ilocs(1) + nimpp - 1
	1631	kj = ilocs(2) + njmpp - 1
	1632	kk = ilocs(3)
	1633	!
	1634	zain(1,:)=zmax
	1635	zain(2,:)=ki+10000.kj+100000000.kk
	1636	!
	1637	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
	1638	!
	1639	pmax = zaout(1,1)
	1640	kk = INT( zaout(2,1) / 100000000. )
	1641	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	1642	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	1643	!
	1644	END SUBROUTINE mpp_maxloc3d
[3]	1645
[869]	1646
[1344]	1647	SUBROUTINE mppsync()
	1648	!!----------------------------------------------------------------------
	1649	!! * routine mppsync *
	1650	!!
	1651	!! ** Purpose : Massively parallel processors, synchroneous
	1652	!!
	1653	!!-----------------------------------------------------------------------
	1654	INTEGER :: ierror
	1655	!!-----------------------------------------------------------------------
	1656	!
	1657	CALL mpi_barrier( mpi_comm_opa, ierror )
	1658	!
	1659	END SUBROUTINE mppsync
[3]	1660
	1661
[1344]	1662	SUBROUTINE mppstop
	1663	!!----------------------------------------------------------------------
	1664	!! * routine mppstop *
	1665	!!
	1666	!! ** purpose : Stop massilively parallel processors method
	1667	!!
	1668	!!----------------------------------------------------------------------
	1669	INTEGER :: info
	1670	!!----------------------------------------------------------------------
	1671	!
	1672	CALL mppsync
	1673	CALL mpi_finalize( info )
	1674	!
	1675	END SUBROUTINE mppstop
[3]	1676
	1677
[1344]	1678	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij )
	1679	!!----------------------------------------------------------------------
	1680	!! * routine mppobc *
	1681	!!
	1682	!! ** Purpose : Message passing manadgement for open boundary
	1683	!! conditions array
	1684	!!
	1685	!! ** Method : Use mppsend and mpprecv function for passing mask
	1686	!! between processors following neighboring subdomains.
	1687	!! domain parameters
	1688	!! nlci : first dimension of the local subdomain
	1689	!! nlcj : second dimension of the local subdomain
	1690	!! nbondi : mark for "east-west local boundary"
	1691	!! nbondj : mark for "north-south local boundary"
	1692	!! noea : number for local neighboring processors
	1693	!! nowe : number for local neighboring processors
	1694	!! noso : number for local neighboring processors
	1695	!! nono : number for local neighboring processors
	1696	!!
	1697	!!----------------------------------------------------------------------
	1698	INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices
	1699	INTEGER , INTENT(in ) :: kl ! index of open boundary
	1700	INTEGER , INTENT(in ) :: kk ! vertical dimension
	1701	INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt
	1702	! ! = 1 north/south ; = 2 east/west
	1703	INTEGER , INTENT(in ) :: kij ! horizontal dimension
	1704	REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array
	1705	!!
	1706	INTEGER :: ji, jj, jk, jl ! dummy loop indices
	1707	INTEGER :: iipt0, iipt1, ilpt1 ! temporary integers
	1708	INTEGER :: ijpt0, ijpt1 ! - -
	1709	INTEGER :: imigr, iihom, ijhom ! - -
	1710	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	1711	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
	1712	REAL(wp), DIMENSION(jpi,jpj) :: ztab ! temporary workspace
	1713	!!----------------------------------------------------------------------
[3]	1714
[1344]	1715	! boundary condition initialization
	1716	! ---------------------------------
	1717	ztab(:,:) = 0.e0
	1718	!
	1719	IF( ktype==1 ) THEN ! north/south boundaries
	1720	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
	1721	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
	1722	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
	1723	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
	1724	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
	1725	ELSEIF( ktype==2 ) THEN ! east/west boundaries
	1726	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
	1727	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
	1728	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
	1729	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
	1730	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
	1731	ELSE
	1732	CALL ctl_stop( 'mppobc: bad ktype' )
	1733	ENDIF
	1734
	1735	! Communication level by level
	1736	! ----------------------------
	1737	!!gm Remark : this is very time consumming!!!
	1738	! ! ------------------------ !
	1739	DO jk = 1, kk ! Loop over the levels !
	1740	! ! ------------------------ !
	1741	!
	1742	IF( ktype == 1 ) THEN ! north/south boundaries
	1743	DO jj = ijpt0, ijpt1
	1744	DO ji = iipt0, iipt1
	1745	ztab(ji,jj) = ptab(ji,jk)
	1746	END DO
	1747	END DO
	1748	ELSEIF( ktype == 2 ) THEN ! east/west boundaries
	1749	DO jj = ijpt0, ijpt1
	1750	DO ji = iipt0, iipt1
	1751	ztab(ji,jj) = ptab(jj,jk)
	1752	END DO
	1753	END DO
	1754	ENDIF
[13]	1755
[3]	1756
[1344]	1757	! 1. East and west directions
	1758	! ---------------------------
	1759	!
	1760	IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions
	1761	iihom = nlci-nreci
	1762	DO jl = 1, jpreci
	1763	t2ew(:,jl,1) = ztab(jpreci+jl,:)
	1764	t2we(:,jl,1) = ztab(iihom +jl,:)
	1765	END DO
	1766	ENDIF
	1767	!
	1768	! ! Migrations
	1769	imigr=jpreci*jpj
	1770	!
	1771	IF( nbondi == -1 ) THEN
	1772	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
	1773	CALL mpprecv( 1, t2ew(1,1,2), imigr )
	1774	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1775	ELSEIF( nbondi == 0 ) THEN
	1776	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	1777	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
	1778	CALL mpprecv( 1, t2ew(1,1,2), imigr )
	1779	CALL mpprecv( 2, t2we(1,1,2), imigr )
	1780	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1781	IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
	1782	ELSEIF( nbondi == 1 ) THEN
	1783	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	1784	CALL mpprecv( 2, t2we(1,1,2), imigr )
	1785	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1786	ENDIF
	1787	!
	1788	! ! Write Dirichlet lateral conditions
	1789	iihom = nlci-jpreci
	1790	!
	1791	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
	1792	DO jl = 1, jpreci
	1793	ztab(jl,:) = t2we(:,jl,2)
	1794	END DO
	1795	ENDIF
	1796	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
	1797	DO jl = 1, jpreci
	1798	ztab(iihom+jl,:) = t2ew(:,jl,2)
	1799	END DO
	1800	ENDIF
[3]	1801
	1802
[1344]	1803	! 2. North and south directions
	1804	! -----------------------------
	1805	!
	1806	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	1807	ijhom = nlcj-nrecj
	1808	DO jl = 1, jprecj
	1809	t2sn(:,jl,1) = ztab(:,ijhom +jl)
	1810	t2ns(:,jl,1) = ztab(:,jprecj+jl)
	1811	END DO
	1812	ENDIF
	1813	!
	1814	! ! Migrations
	1815	imigr = jprecj * jpi
	1816	!
	1817	IF( nbondj == -1 ) THEN
	1818	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
	1819	CALL mpprecv( 3, t2ns(1,1,2), imigr )
	1820	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1821	ELSEIF( nbondj == 0 ) THEN
	1822	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	1823	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
	1824	CALL mpprecv( 3, t2ns(1,1,2), imigr )
	1825	CALL mpprecv( 4, t2sn(1,1,2), imigr )
	1826	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1827	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
	1828	ELSEIF( nbondj == 1 ) THEN
	1829	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	1830	CALL mpprecv( 4, t2sn(1,1,2), imigr)
	1831	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	1832	ENDIF
	1833	!
	1834	! ! Write Dirichlet lateral conditions
	1835	ijhom = nlcj - jprecj
	1836	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
	1837	DO jl = 1, jprecj
	1838	ztab(:,jl) = t2sn(:,jl,2)
	1839	END DO
	1840	ENDIF
	1841	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
	1842	DO jl = 1, jprecj
	1843	ztab(:,ijhom+jl) = t2ns(:,jl,2)
	1844	END DO
	1845	ENDIF
	1846	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
	1847	DO jj = ijpt0, ijpt1 ! north/south boundaries
	1848	DO ji = iipt0,ilpt1
	1849	ptab(ji,jk) = ztab(ji,jj)
	1850	END DO
	1851	END DO
	1852	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
	1853	DO jj = ijpt0, ilpt1 ! east/west boundaries
	1854	DO ji = iipt0,iipt1
	1855	ptab(jj,jk) = ztab(ji,jj)
	1856	END DO
	1857	END DO
	1858	ENDIF
	1859	!
	1860	END DO
	1861	!
	1862	END SUBROUTINE mppobc
	1863
[13]	1864
[1344]	1865	SUBROUTINE mpp_comm_free( kcom )
	1866	!!----------------------------------------------------------------------
	1867	!!----------------------------------------------------------------------
	1868	INTEGER, INTENT(in) :: kcom
	1869	!!
	1870	INTEGER :: ierr
	1871	!!----------------------------------------------------------------------
	1872	!
	1873	CALL MPI_COMM_FREE(kcom, ierr)
	1874	!
	1875	END SUBROUTINE mpp_comm_free
[3]	1876
[869]	1877
[1344]	1878	SUBROUTINE mpp_ini_ice( pindic )
	1879	!!----------------------------------------------------------------------
	1880	!! * routine mpp_ini_ice *
	1881	!!
	1882	!! ** Purpose : Initialize special communicator for ice areas
	1883	!! condition together with global variables needed in the ddmpp folding
	1884	!!
	1885	!! ** Method : - Look for ice processors in ice routines
	1886	!! - Put their number in nrank_ice
	1887	!! - Create groups for the world processors and the ice processors
	1888	!! - Create a communicator for ice processors
	1889	!!
	1890	!! ** output
	1891	!! njmppmax = njmpp for northern procs
	1892	!! ndim_rank_ice = number of processors with ice
	1893	!! nrank_ice (ndim_rank_ice) = ice processors
	1894	!! ngrp_world = group ID for the world processors
	1895	!! ngrp_ice = group ID for the ice processors
	1896	!! ncomm_ice = communicator for the ice procs.
	1897	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
	1898	!!
	1899	!!----------------------------------------------------------------------
	1900	INTEGER, INTENT(in) :: pindic
	1901	!!
	1902	INTEGER :: ierr
	1903	INTEGER :: jjproc
	1904	INTEGER :: ii
	1905	INTEGER, DIMENSION(jpnij) :: kice
	1906	INTEGER, DIMENSION(jpnij) :: zwork
	1907	!!----------------------------------------------------------------------
	1908	!
	1909	! Look for how many procs with sea-ice
	1910	!
	1911	kice = 0
	1912	DO jjproc = 1, jpnij
	1913	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
	1914	END DO
	1915	!
	1916	zwork = 0
	1917	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
	1918	ndim_rank_ice = SUM( zwork )
[3]	1919
[1344]	1920	! Allocate the right size to nrank_north
[1208]	1921	#if ! defined key_agrif
[1441]	1922	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
[1208]	1923	#else
[1441]	1924	IF( ASSOCIATED( nrank_ice ) ) DEALLOCATE( nrank_ice )
[1208]	1925	#endif
[1344]	1926	ALLOCATE( nrank_ice(ndim_rank_ice) )
	1927	!
	1928	ii = 0
	1929	nrank_ice = 0
	1930	DO jjproc = 1, jpnij
	1931	IF( zwork(jjproc) == 1) THEN
	1932	ii = ii + 1
	1933	nrank_ice(ii) = jjproc -1
	1934	ENDIF
	1935	END DO
[1208]	1936
[1344]	1937	! Create the world group
	1938	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
[869]	1939
[1344]	1940	! Create the ice group from the world group
	1941	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
[869]	1942
[1344]	1943	! Create the ice communicator , ie the pool of procs with sea-ice
	1944	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
[869]	1945
[1344]	1946	! Find proc number in the world of proc 0 in the north
	1947	! The following line seems to be useless, we just comment & keep it as reminder
	1948	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr)
	1949	!
	1950	END SUBROUTINE mpp_ini_ice
[869]	1951
	1952
[1345]	1953	SUBROUTINE mpp_ini_znl
	1954	!!----------------------------------------------------------------------
	1955	!! * routine mpp_ini_znl *
	1956	!!
	1957	!! ** Purpose : Initialize special communicator for computing zonal sum
	1958	!!
	1959	!! ** Method : - Look for processors in the same row
	1960	!! - Put their number in nrank_znl
	1961	!! - Create group for the znl processors
	1962	!! - Create a communicator for znl processors
	1963	!! - Determine if processor should write znl files
	1964	!!
	1965	!! ** output
	1966	!! ndim_rank_znl = number of processors on the same row
	1967	!! ngrp_znl = group ID for the znl processors
	1968	!! ncomm_znl = communicator for the ice procs.
	1969	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
	1970	!!
	1971	!!----------------------------------------------------------------------
	1972	INTEGER :: ierr
	1973	INTEGER :: jproc
	1974	INTEGER :: ii
	1975	INTEGER, DIMENSION(jpnij) :: kwork
	1976	!
	1977	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
	1978	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
	1979	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
	1980	!
	1981	IF ( jpnj == 1 ) THEN
	1982	ngrp_znl = ngrp_world
	1983	ncomm_znl = mpi_comm_opa
	1984	ELSE
	1985	!
	1986	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
	1987	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
	1988	!-$$ CALL flush(numout)
	1989	!
	1990	! Count number of processors on the same row
	1991	ndim_rank_znl = 0
	1992	DO jproc=1,jpnij
	1993	IF ( kwork(jproc) == njmpp ) THEN
	1994	ndim_rank_znl = ndim_rank_znl + 1
	1995	ENDIF
	1996	END DO
	1997	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
	1998	!-$$ CALL flush(numout)
	1999	! Allocate the right size to nrank_znl
	2000	#if ! defined key_agrif
[1441]	2001	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]	2002	#else
[1441]	2003	IF (ASSOCIATED(nrank_znl)) DEALLOCATE(nrank_znl)
[1345]	2004	#endif
	2005	ALLOCATE(nrank_znl(ndim_rank_znl))
	2006	ii = 0
	2007	nrank_znl (:) = 0
	2008	DO jproc=1,jpnij
	2009	IF ( kwork(jproc) == njmpp) THEN
	2010	ii = ii + 1
	2011	nrank_znl(ii) = jproc -1
	2012	ENDIF
	2013	END DO
	2014	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
	2015	!-$$ CALL flush(numout)
	2016
	2017	! Create the opa group
	2018	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
	2019	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
	2020	!-$$ CALL flush(numout)
	2021
	2022	! Create the znl group from the opa group
	2023	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
	2024	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
	2025	!-$$ CALL flush(numout)
	2026
	2027	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
	2028	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
	2029	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
	2030	!-$$ CALL flush(numout)
	2031	!
	2032	END IF
	2033
	2034	! Determines if processor if the first (starting from i=1) on the row
	2035	IF ( jpni == 1 ) THEN
	2036	l_znl_root = .TRUE.
	2037	ELSE
	2038	l_znl_root = .FALSE.
	2039	kwork (1) = nimpp
	2040	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
	2041	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
	2042	END IF
	2043
	2044	END SUBROUTINE mpp_ini_znl
	2045
	2046
[1344]	2047	SUBROUTINE mpp_ini_north
	2048	!!----------------------------------------------------------------------
	2049	!! * routine mpp_ini_north *
	2050	!!
	2051	!! ** Purpose : Initialize special communicator for north folding
	2052	!! condition together with global variables needed in the mpp folding
	2053	!!
	2054	!! ** Method : - Look for northern processors
	2055	!! - Put their number in nrank_north
	2056	!! - Create groups for the world processors and the north processors
	2057	!! - Create a communicator for northern processors
	2058	!!
	2059	!! ** output
	2060	!! njmppmax = njmpp for northern procs
	2061	!! ndim_rank_north = number of processors in the northern line
	2062	!! nrank_north (ndim_rank_north) = number of the northern procs.
	2063	!! ngrp_world = group ID for the world processors
	2064	!! ngrp_north = group ID for the northern processors
	2065	!! ncomm_north = communicator for the northern procs.
	2066	!! north_root = number (in the world) of proc 0 in the northern comm.
	2067	!!
	2068	!!----------------------------------------------------------------------
	2069	INTEGER :: ierr
	2070	INTEGER :: jjproc
	2071	INTEGER :: ii, ji
	2072	!!----------------------------------------------------------------------
	2073	!
	2074	njmppmax = MAXVAL( njmppt )
	2075	!
	2076	! Look for how many procs on the northern boundary
	2077	ndim_rank_north = 0
	2078	DO jjproc = 1, jpnij
	2079	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
	2080	END DO
	2081	!
	2082	! Allocate the right size to nrank_north
[1441]	2083	#if ! defined key_agrif
	2084	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
	2085	#else
	2086	IF (ASSOCIATED(nrank_north)) DEALLOCATE(nrank_north)
	2087	#endif
[1344]	2088	ALLOCATE( nrank_north(ndim_rank_north) )
[869]	2089
[1344]	2090	! Fill the nrank_north array with proc. number of northern procs.
	2091	! Note : the rank start at 0 in MPI
	2092	ii = 0
	2093	DO ji = 1, jpnij
	2094	IF ( njmppt(ji) == njmppmax ) THEN
	2095	ii=ii+1
	2096	nrank_north(ii)=ji-1
	2097	END IF
	2098	END DO
	2099	!
	2100	! create the world group
	2101	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
	2102	!
	2103	! Create the North group from the world group
	2104	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
	2105	!
	2106	! Create the North communicator , ie the pool of procs in the north group
	2107	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
	2108	!
	2109	END SUBROUTINE mpp_ini_north
[869]	2110
	2111
[1344]	2112	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
[51]	2113	!!---------------------------------------------------------------------
	2114	!! * routine mpp_lbc_north_3d *
	2115	!!
[1344]	2116	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	2117	!! in mpp configuration in case of jpn1 > 1
[51]	2118	!!
[1344]	2119	!! ** Method : North fold condition and mpp with more than one proc
	2120	!! in i-direction require a specific treatment. We gather
	2121	!! the 4 northern lines of the global domain on 1 processor
	2122	!! and apply lbc north-fold on this sub array. Then we
	2123	!! scatter the north fold array back to the processors.
[51]	2124	!!
	2125	!!----------------------------------------------------------------------
[1344]	2126	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
	2127	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2128	! ! = T , U , V , F or W gridpoints
	2129	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
	2130	!! ! = 1. , the sign is kept
	2131	INTEGER :: ji, jj, jr
	2132	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2133	INTEGER :: ijpj, ijpjm1, ij, iproc
	2134	REAL(wp), DIMENSION(jpiglo,4,jpk) :: ztab
	2135	REAL(wp), DIMENSION(jpi ,4,jpk) :: znorthloc
	2136	REAL(wp), DIMENSION(jpi ,4,jpk,jpni) :: znorthgloio
[51]	2137	!!----------------------------------------------------------------------
[1344]	2138	!
	2139	ijpj = 4
	2140	ijpjm1 = 3
	2141	!
	2142	DO jj = nlcj - ijpj +1, nlcj ! put in znorthloc the last 4 jlines of pt3d
	2143	ij = jj - nlcj + ijpj
	2144	znorthloc(:,ij,:) = pt3d(:,jj,:)
	2145	END DO
	2146	!
	2147	! ! Build in procs of ncomm_north the znorthgloio
	2148	itaille = jpi * jpk * ijpj
	2149	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
	2150	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
	2151	!
	2152	! ! recover the global north array
	2153	DO jr = 1, ndim_rank_north
	2154	iproc = nrank_north(jr) + 1
	2155	ildi = nldit (iproc)
	2156	ilei = nleit (iproc)
	2157	iilb = nimppt(iproc)
	2158	DO jj = 1, 4
	2159	DO ji = ildi, ilei
	2160	ztab(ji+iilb-1,jj,:) = znorthgloio(ji,jj,:,jr)
	2161	END DO
	2162	END DO
	2163	END DO
	2164	!
	2165	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
	2166	!
	2167	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
	2168	ij = jj - nlcj + ijpj
	2169	DO ji= 1, nlci
	2170	pt3d(ji,jj,:) = ztab(ji+nimpp-1,ij,:)
	2171	END DO
	2172	END DO
	2173	!
	2174	END SUBROUTINE mpp_lbc_north_3d
[3]	2175
	2176
[1344]	2177	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
	2178	!!---------------------------------------------------------------------
	2179	!! * routine mpp_lbc_north_2d *
	2180	!!
	2181	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	2182	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
	2183	!!
	2184	!! ** Method : North fold condition and mpp with more than one proc
	2185	!! in i-direction require a specific treatment. We gather
	2186	!! the 4 northern lines of the global domain on 1 processor
	2187	!! and apply lbc north-fold on this sub array. Then we
	2188	!! scatter the north fold array back to the processors.
	2189	!!
	2190	!!----------------------------------------------------------------------
	2191	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied
	2192	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2193	! ! = T , U , V , F or W gridpoints
	2194	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
	2195	!! ! = 1. , the sign is kept
	2196	INTEGER :: ji, jj, jr
	2197	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2198	INTEGER :: ijpj, ijpjm1, ij, iproc
	2199	REAL(wp), DIMENSION(jpiglo,4) :: ztab
	2200	REAL(wp), DIMENSION(jpi ,4) :: znorthloc
	2201	REAL(wp), DIMENSION(jpi ,4,jpni) :: znorthgloio
	2202	!!----------------------------------------------------------------------
	2203	!
	2204	ijpj = 4
	2205	ijpjm1 = 3
	2206	!
	2207	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d
	2208	ij = jj - nlcj + ijpj
	2209	znorthloc(:,ij) = pt2d(:,jj)
	2210	END DO
[3]	2211
[1344]	2212	! ! Build in procs of ncomm_north the znorthgloio
	2213	itaille = jpi * ijpj
	2214	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
	2215	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
	2216	!
	2217	DO jr = 1, ndim_rank_north ! recover the global north array
	2218	iproc = nrank_north(jr) + 1
	2219	ildi=nldit (iproc)
	2220	ilei=nleit (iproc)
	2221	iilb=nimppt(iproc)
	2222	DO jj = 1, 4
	2223	DO ji = ildi, ilei
	2224	ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
[13]	2225	END DO
	2226	END DO
[1344]	2227	END DO
	2228	!
	2229	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
	2230	!
	2231	!
	2232	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
[13]	2233	ij = jj - nlcj + ijpj
[1344]	2234	DO ji = 1, nlci
	2235	pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
	2236	END DO
[13]	2237	END DO
[1344]	2238	!
[13]	2239	END SUBROUTINE mpp_lbc_north_2d
[3]	2240
	2241
[1344]	2242	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
	2243	!!---------------------------------------------------------------------
	2244	!! * routine mpp_lbc_north_2d *
	2245	!!
	2246	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	2247	!! in mpp configuration in case of jpn1 > 1 and for 2d
	2248	!! array with outer extra halo
	2249	!!
	2250	!! ** Method : North fold condition and mpp with more than one proc
	2251	!! in i-direction require a specific treatment. We gather
	2252	!! the 4+2*jpr2dj northern lines of the global domain on 1
	2253	!! processor and apply lbc north-fold on this sub array.
	2254	!! Then we scatter the north fold array back to the processors.
	2255	!!
	2256	!!----------------------------------------------------------------------
	2257	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
	2258	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2259	! ! = T , U , V , F or W -points
	2260	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
	2261	!! ! north fold, = 1. otherwise
	2262	INTEGER :: ji, jj, jr
	2263	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2264	INTEGER :: ijpj, ij, iproc
	2265	REAL(wp), DIMENSION(jpiglo,4+2*jpr2dj) :: ztab
	2266	REAL(wp), DIMENSION(jpi ,4+2*jpr2dj) :: znorthloc
	2267	REAL(wp), DIMENSION(jpi ,4+2*jpr2dj,jpni) :: znorthgloio
	2268	!!----------------------------------------------------------------------
	2269	!
	2270	ijpj=4
[311]	2271
[1344]	2272	ij=0
	2273	! put in znorthloc the last 4 jlines of pt2d
	2274	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
	2275	ij = ij + 1
	2276	DO ji = 1, jpi
	2277	znorthloc(ji,ij)=pt2d(ji,jj)
	2278	END DO
	2279	END DO
	2280	!
	2281	itaille = jpi * ( ijpj + 2 * jpr2dj )
	2282	CALL MPI_ALLGATHER( znorthloc(1,1) , itaille, MPI_DOUBLE_PRECISION, &
	2283	& znorthgloio(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
	2284	!
	2285	DO jr = 1, ndim_rank_north ! recover the global north array
	2286	iproc = nrank_north(jr) + 1
	2287	ildi = nldit (iproc)
	2288	ilei = nleit (iproc)
	2289	iilb = nimppt(iproc)
	2290	DO jj = 1, ijpj+2*jpr2dj
	2291	DO ji = ildi, ilei
	2292	ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
[311]	2293	END DO
[1344]	2294	END DO
	2295	END DO
[311]	2296
	2297
[1344]	2298	! 2. North-Fold boundary conditions
	2299	! ----------------------------------
	2300	CALL lbc_nfd( ztab(:,:), cd_type, psgn, pr2dj = jpr2dj )
[311]	2301
[1344]	2302	ij = jpr2dj
	2303	!! Scatter back to pt2d
	2304	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
	2305	ij = ij +1
	2306	DO ji= 1, nlci
	2307	pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
[311]	2308	END DO
	2309	END DO
[1344]	2310	!
[311]	2311	END SUBROUTINE mpp_lbc_north_e
	2312
[389]	2313
[1344]	2314	SUBROUTINE mpi_init_opa( code )
	2315	!!---------------------------------------------------------------------
	2316	!! * routine mpp_init.opa *
	2317	!!
	2318	!! ** Purpose :: export and attach a MPI buffer for bsend
	2319	!!
	2320	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
	2321	!! but classical mpi_init
	2322	!!
	2323	!! History :: 01/11 :: IDRIS initial version for IBM only
	2324	!! 08/04 :: R. Benshila, generalisation
	2325	!!---------------------------------------------------------------------
[1237]	2326	INTEGER :: code, ierr
[532]	2327	LOGICAL :: mpi_was_called
[1344]	2328	!!---------------------------------------------------------------------
	2329	!
	2330	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
[532]	2331	IF ( code /= MPI_SUCCESS ) THEN
[1344]	2332	CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' )
	2333	CALL mpi_abort( mpi_comm_world, code, ierr )
[532]	2334	ENDIF
[1344]	2335	!
	2336	IF( .NOT. mpi_was_called ) THEN
	2337	CALL mpi_init( code )
	2338	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
[532]	2339	IF ( code /= MPI_SUCCESS ) THEN
	2340	CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' )
	2341	CALL mpi_abort( mpi_comm_world, code, ierr )
	2342	ENDIF
	2343	ENDIF
[1344]	2344	!
[897]	2345	IF( nn_buffer > 0 ) THEN
	2346	IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of : ', nn_buffer
	2347	! Buffer allocation and attachment
[1344]	2348	ALLOCATE( tampon(nn_buffer) )
	2349	CALL mpi_buffer_attach( tampon, nn_buffer,code )
[897]	2350	ENDIF
[1344]	2351	!
[13]	2352	END SUBROUTINE mpi_init_opa
[3]	2353
[1976]	2354	#if defined key_mpp_rep1
	2355	SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, &
	2356	& knoout, kstartout )
	2357	!!----------------------------------------------------------------------
	2358	!! * ROUTINE mpp_allgatherv_real *
	2359	!!
	2360	!! ** Purpose : Gather a real array on all processors
	2361	!!
	2362	!! ** Method : MPI all gatherv
	2363	!!
	2364	!! ** Action : This does only work for MPI.
	2365	!! It does not work for SHMEM.
	2366	!!
	2367	!! References : http://www.mpi-forum.org
	2368	!!
	2369	!! History :
	2370	!! ! 08-08 (K. Mogensen) Original code
	2371	!!----------------------------------------------------------------------
	2372
	2373	!! * Arguments
	2374	INTEGER, INTENT(IN) :: &
	2375	& knoin, &
	2376	& ksizeout
	2377	REAL(wp), DIMENSION(knoin), INTENT(IN) :: &
	2378	& pvalsin
	2379	REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: &
	2380	& pvalsout
	2381	INTEGER, DIMENSION(jpnij), INTENT(OUT) :: &
	2382	& kstartout, &
	2383	& knoout
	2384
	2385	!! * Local declarations
	2386	INTEGER :: &
	2387	& ierr
	2388	INTEGER :: &
	2389	& ji
	2390	!-----------------------------------------------------------------------
	2391	! Call the MPI library to get number of data per processor
	2392	!-----------------------------------------------------------------------
	2393	CALL mpi_allgather( knoin, 1, mpi_integer, &
	2394	& knoout, 1, mpi_integer, &
	2395	& mpi_comm_opa, ierr )
	2396	!-----------------------------------------------------------------------
	2397	! Compute starts of each processors contribution
	2398	!-----------------------------------------------------------------------
	2399	kstartout(1) = 0
	2400	DO ji = 2, jpnij
	2401	kstartout(ji) = kstartout(ji-1) + knoout(ji-1)
	2402	ENDDO
	2403	!-----------------------------------------------------------------------
	2404	! Call the MPI library to do the gathering of the data
	2405	!-----------------------------------------------------------------------
	2406	CALL mpi_allgatherv( pvalsin, knoin, MPI_DOUBLE_PRECISION, &
	2407	& pvalsout, knoout, kstartout, MPI_DOUBLE_PRECISION, &
	2408	& mpi_comm_opa, ierr )
	2409
	2410	END SUBROUTINE mpp_allgatherv_real
	2411
	2412	SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, &
	2413	& knoout, kstartout )
	2414	!!----------------------------------------------------------------------
	2415	!! * ROUTINE mpp_allgatherv *
	2416	!!
	2417	!! ** Purpose : Gather an integer array on all processors
	2418	!!
	2419	!! ** Method : MPI all gatherv
	2420	!!
	2421	!! ** Action : This does only work for MPI.
	2422	!! It does not work for SHMEM.
	2423	!!
	2424	!! References : http://www.mpi-forum.org
	2425	!!
	2426	!! History :
	2427	!! ! 06-07 (K. Mogensen) Original code
	2428	!!----------------------------------------------------------------------
	2429
	2430	!! * Arguments
	2431	INTEGER, INTENT(IN) :: &
	2432	& knoin, &
	2433	& ksizeout
	2434	INTEGER, DIMENSION(knoin), INTENT(IN) :: &
	2435	& kvalsin
	2436	INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: &
	2437	& kvalsout
	2438	INTEGER, DIMENSION(jpnij), INTENT(OUT) :: &
	2439	& kstartout, &
	2440	& knoout
	2441
	2442	!! * Local declarations
	2443	INTEGER :: &
	2444	& ierr
	2445	INTEGER :: &
	2446	& ji
	2447	!-----------------------------------------------------------------------
	2448	! Call the MPI library to get number of data per processor
	2449	!-----------------------------------------------------------------------
	2450	CALL mpi_allgather( knoin, 1, mpi_integer, &
	2451	& knoout, 1, mpi_integer, &
	2452	& mpi_comm_opa, ierr )
	2453	!-----------------------------------------------------------------------
	2454	! Compute starts of each processors contribution
	2455	!-----------------------------------------------------------------------
	2456	kstartout(1) = 0
	2457	DO ji = 2, jpnij
	2458	kstartout(ji) = kstartout(ji-1) + knoout(ji-1)
	2459	ENDDO
	2460	!-----------------------------------------------------------------------
	2461	! Call the MPI library to do the gathering of the data
	2462	!-----------------------------------------------------------------------
	2463	CALL mpi_allgatherv( kvalsin, knoin, mpi_integer, &
	2464	& kvalsout, knoout, kstartout, mpi_integer, &
	2465	& mpi_comm_opa, ierr )
	2466
	2467	END SUBROUTINE mpp_allgatherv_int
	2468	#endif
	2469
	2470	#if defined key_mpp_rep2
	2471	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
	2472	!!---------------------------------------------------------------------
	2473	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
	2474	!!
	2475	!! Modification of original codes written by David H. Bailey
	2476	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
	2477	!!---------------------------------------------------------------------
	2478	INTEGER, INTENT(in) :: ilen, itype
	2479	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
	2480	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
	2481	!
	2482	REAL(wp) :: zerr, zt1, zt2 ! local work variables
	2483	INTEGER :: ji, ztmp ! local scalar
	2484
	2485	ztmp = itype ! avoid compilation warning
	2486
	2487	DO ji=1,ilen
	2488	! Compute ydda + yddb using Knuth's trick.
	2489	zt1 = real(ydda(ji)) + real(yddb(ji))
	2490	zerr = zt1 - real(ydda(ji))
	2491	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
	2492	+ aimag(ydda(ji)) + aimag(yddb(ji))
	2493
	2494	! The result is zt1 + zt2, after normalization.
	2495	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
	2496	END DO
	2497
	2498	END SUBROUTINE DDPDD_MPI
	2499	#endif
	2500
[13]	2501	#else
	2502	!!----------------------------------------------------------------------
	2503	!! Default case: Dummy module share memory computing
	2504	!!----------------------------------------------------------------------
[1976]	2505	# if defined key_mpp_rep1
	2506	USE par_kind
	2507	USE par_oce
	2508
	2509	PUBLIC mpp_allgatherv
	2510	# endif
	2511
[13]	2512	INTERFACE mpp_sum
[1976]	2513	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, &
	2514	& mpp_sum_c, mpp_sum_ac
[13]	2515	END INTERFACE
	2516	INTERFACE mpp_max
[681]	2517	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	2518	END INTERFACE
	2519	INTERFACE mpp_min
	2520	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	2521	END INTERFACE
	2522	INTERFACE mppobc
	2523	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
	2524	END INTERFACE
[1344]	2525	INTERFACE mpp_minloc
	2526	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	2527	END INTERFACE
	2528	INTERFACE mpp_maxloc
	2529	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	2530	END INTERFACE
[3]	2531
[1976]	2532	# if defined key_mpp_rep1
	2533	INTERFACE mpp_allgatherv
	2534	MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int
	2535	END INTERFACE
	2536	# endif
[181]	2537
[1976]	2538
[13]	2539	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
[869]	2540	INTEGER :: ncomm_ice
[3]	2541
[13]	2542	CONTAINS
[3]	2543
[1579]	2544	FUNCTION mynode( ldtxt, localComm ) RESULT (function_value)
	2545	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
	2546	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[1559]	2547	IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0
[1579]	2548	IF( .FALSE. ) ldtxt(:) = 'never done'
[13]	2549	END FUNCTION mynode
[3]	2550
[13]	2551	SUBROUTINE mppsync ! Dummy routine
	2552	END SUBROUTINE mppsync
[3]	2553
[869]	2554	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
[13]	2555	REAL , DIMENSION(:) :: parr
	2556	INTEGER :: kdim
[869]	2557	INTEGER, OPTIONAL :: kcom
	2558	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	2559	END SUBROUTINE mpp_sum_as
[3]	2560
[869]	2561	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
[13]	2562	REAL , DIMENSION(:,:) :: parr
	2563	INTEGER :: kdim
[869]	2564	INTEGER, OPTIONAL :: kcom
	2565	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]	2566	END SUBROUTINE mpp_sum_a2s
[3]	2567
[869]	2568	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
[13]	2569	INTEGER, DIMENSION(:) :: karr
	2570	INTEGER :: kdim
[869]	2571	INTEGER, OPTIONAL :: kcom
	2572	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	2573	END SUBROUTINE mpp_sum_ai
[3]	2574
[1976]	2575	SUBROUTINE mpp_sum_ac( yarr, kdim, kcom ) ! Dummy routine
	2576	COMPLEX, DIMENSION(:) :: yarr
	2577	INTEGER :: kdim
	2578	INTEGER, OPTIONAL :: kcom
	2579	WRITE(,) 'mpp_sum_ac: You should not have seen this print! error?', kdim, yarr(1), kcom
	2580	END SUBROUTINE mpp_sum_ac
	2581
[869]	2582	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
[13]	2583	REAL :: psca
[869]	2584	INTEGER, OPTIONAL :: kcom
	2585	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]	2586	END SUBROUTINE mpp_sum_s
[1976]	2587
[869]	2588	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
[13]	2589	integer :: kint
[1976]	2590	INTEGER, OPTIONAL :: kcom
[869]	2591	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]	2592	END SUBROUTINE mpp_sum_i
	2593
[1976]	2594	SUBROUTINE mpp_sum_c( ysca, kcom ) ! Dummy routine
	2595	COMPLEX :: ysca
	2596	INTEGER, OPTIONAL :: kcom
	2597	WRITE(,) 'mpp_sum_c: You should not have seen this print! error?', ysca, kcom
	2598	END SUBROUTINE mpp_sum_c
	2599
[869]	2600	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]	2601	REAL , DIMENSION(:) :: parr
	2602	INTEGER :: kdim
[869]	2603	INTEGER, OPTIONAL :: kcom
	2604	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	2605	END SUBROUTINE mppmax_a_real
	2606
[869]	2607	SUBROUTINE mppmax_real( psca, kcom )
[13]	2608	REAL :: psca
[869]	2609	INTEGER, OPTIONAL :: kcom
	2610	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]	2611	END SUBROUTINE mppmax_real
	2612
[869]	2613	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]	2614	REAL , DIMENSION(:) :: parr
	2615	INTEGER :: kdim
[869]	2616	INTEGER, OPTIONAL :: kcom
	2617	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	2618	END SUBROUTINE mppmin_a_real
	2619
[869]	2620	SUBROUTINE mppmin_real( psca, kcom )
[13]	2621	REAL :: psca
[869]	2622	INTEGER, OPTIONAL :: kcom
	2623	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]	2624	END SUBROUTINE mppmin_real
	2625
[869]	2626	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]	2627	INTEGER, DIMENSION(:) :: karr
	2628	INTEGER :: kdim
[869]	2629	INTEGER, OPTIONAL :: kcom
[888]	2630	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]	2631	END SUBROUTINE mppmax_a_int
	2632
[869]	2633	SUBROUTINE mppmax_int( kint, kcom)
[681]	2634	INTEGER :: kint
[869]	2635	INTEGER, OPTIONAL :: kcom
	2636	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]	2637	END SUBROUTINE mppmax_int
	2638
[869]	2639	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]	2640	INTEGER, DIMENSION(:) :: karr
	2641	INTEGER :: kdim
[869]	2642	INTEGER, OPTIONAL :: kcom
	2643	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	2644	END SUBROUTINE mppmin_a_int
	2645
[869]	2646	SUBROUTINE mppmin_int( kint, kcom )
[13]	2647	INTEGER :: kint
[869]	2648	INTEGER, OPTIONAL :: kcom
	2649	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]	2650	END SUBROUTINE mppmin_int
	2651
	2652	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij )
[1344]	2653	INTEGER :: kd1, kd2, kl , kk, ktype, kij
	2654	REAL, DIMENSION(:) :: parr ! variable array
	2655	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij
[13]	2656	END SUBROUTINE mppobc_1d
	2657
	2658	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij )
[1344]	2659	INTEGER :: kd1, kd2, kl , kk, ktype, kij
	2660	REAL, DIMENSION(:,:) :: parr ! variable array
	2661	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij
[13]	2662	END SUBROUTINE mppobc_2d
	2663
	2664	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij )
[1344]	2665	INTEGER :: kd1, kd2, kl , kk, ktype, kij
	2666	REAL, DIMENSION(:,:,:) :: parr ! variable array
	2667	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij
[13]	2668	END SUBROUTINE mppobc_3d
	2669
	2670	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij )
[1344]	2671	INTEGER :: kd1, kd2, kl , kk, ktype, kij
	2672	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
	2673	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij
[13]	2674	END SUBROUTINE mppobc_4d
	2675
[1344]	2676	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]	2677	REAL :: pmin
	2678	REAL , DIMENSION (:,:) :: ptab, pmask
	2679	INTEGER :: ki, kj
[1528]	2680	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]	2681	END SUBROUTINE mpp_minloc2d
	2682
[1344]	2683	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]	2684	REAL :: pmin
	2685	REAL , DIMENSION (:,:,:) :: ptab, pmask
	2686	INTEGER :: ki, kj, kk
[1528]	2687	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	2688	END SUBROUTINE mpp_minloc3d
	2689
[1344]	2690	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]	2691	REAL :: pmax
	2692	REAL , DIMENSION (:,:) :: ptab, pmask
	2693	INTEGER :: ki, kj
[1528]	2694	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]	2695	END SUBROUTINE mpp_maxloc2d
	2696
[1344]	2697	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]	2698	REAL :: pmax
	2699	REAL , DIMENSION (:,:,:) :: ptab, pmask
	2700	INTEGER :: ki, kj, kk
[1528]	2701	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	2702	END SUBROUTINE mpp_maxloc3d
	2703
[51]	2704	SUBROUTINE mppstop
	2705	WRITE(,) 'mppstop: You should not have seen this print! error?'
	2706	END SUBROUTINE mppstop
	2707
[1344]	2708	SUBROUTINE mpp_ini_ice( kcom )
[888]	2709	INTEGER :: kcom
[1344]	2710	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom
[888]	2711	END SUBROUTINE mpp_ini_ice
[869]	2712
[1345]	2713	SUBROUTINE mpp_ini_znl
	2714	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?'
	2715	END SUBROUTINE mpp_ini_znl
	2716
[1344]	2717	SUBROUTINE mpp_comm_free( kcom )
[869]	2718	INTEGER :: kcom
[1344]	2719	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]	2720	END SUBROUTINE mpp_comm_free
	2721
[1976]	2722	# if defined key_mpp_rep1
	2723	SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, &
	2724	& knoout, kstartout )
	2725	INTEGER, INTENT(IN) :: &
	2726	& knoin, &
	2727	& ksizeout
	2728	REAL(wp), DIMENSION(knoin), INTENT(IN) :: &
	2729	& pvalsin
	2730	REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: &
	2731	& pvalsout
	2732	INTEGER, DIMENSION(jpnij), INTENT(OUT) :: &
	2733	& kstartout, &
	2734	& knoout
	2735	pvalsout(1:knoin) = pvalsin(1:knoin)
	2736	kstartout(1) = 0
	2737	knoout(1) = knoin
	2738	END SUBROUTINE mpp_allgatherv_real
	2739
	2740	SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, &
	2741	& knoout, kstartout )
	2742	INTEGER, INTENT(IN) :: &
	2743	& knoin, &
	2744	& ksizeout
	2745	INTEGER, DIMENSION(knoin), INTENT(IN) :: &
	2746	& kvalsin
	2747	INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: &
	2748	& kvalsout
	2749	INTEGER, DIMENSION(jpnij), INTENT(OUT) :: &
	2750	& kstartout, &
	2751	& knoout
	2752
	2753	kvalsout(1:knoin) = kvalsin(1:knoin)
	2754	kstartout(1) = 0
	2755	knoout(1) = knoin
	2756	END SUBROUTINE mpp_allgatherv_int
	2757	# endif
	2758
[3]	2759	#endif
[13]	2760	!!----------------------------------------------------------------------
[3]	2761	END MODULE lib_mpp

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

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

Context Navigation

source: branches/DEV_r2106_LOCEAN2010/NEMO/OPA_SRC/lib_mpp.F90 @ 2240

Download in other formats: