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

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

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

Download in other formats: