Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

lib_mpp.F90 @ 1920

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

Download in other formats: