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

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

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

Download in other formats: