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/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 2715

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

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

Download in other formats: