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

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

lib_mpp.F90 in branches/DEV_r2191_3partymerge2010/NEMO/OPA_SRC – NEMO

Context Navigation

source: branches/DEV_r2191_3partymerge2010/NEMO/OPA_SRC/lib_mpp.F90 @ 2208

Last change on this file since 2208 was 2208, checked in by rblod, 14 years ago
Put FCM NEMO code changes in DEV_r2191_3partymerge2010 branch
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 104.2 KB

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

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

Download in other formats: