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

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

lib_mpp.F90 in trunk/NEMO/OPA_SRC – NEMO

Context Navigation

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

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

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

Download in other formats: