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

Last change on this file since 4231 was 4145, checked in by hadcv, 11 years ago
Ticket #1157 (C1D fixes): redo the fix for #1096 to work for XIOS detached mode and add xios_context_finalize.
Property svn:keywords set to `Id`
File size: 160.3 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
[3764]	19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
[2715]	20	!! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager
[3680]	21	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
	22	!! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
	23	!! the mppobc routine to optimize the BDY and OBC communications
[13]	24	!!----------------------------------------------------------------------
[2715]	25
	26	!!----------------------------------------------------------------------
	27	!! ctl_stop : update momentum and tracer Kz from a tke scheme
	28	!! ctl_warn : initialization, namelist read, and parameters control
	29	!! ctl_opn : Open file and check if required file is available.
	30	!! get_unit : give the index of an unused logical unit
	31	!!----------------------------------------------------------------------
[3764]	32	#if defined key_mpp_mpi
[13]	33	!!----------------------------------------------------------------------
[1344]	34	!! 'key_mpp_mpi' MPI massively parallel processing library
	35	!!----------------------------------------------------------------------
[2715]	36	!! lib_mpp_alloc : allocate mpp arrays
	37	!! mynode : indentify the processor unit
	38	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
[473]	39	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
[2715]	40	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
	41	!! mpprecv :
	42	!! mppsend : SUBROUTINE mpp_ini_znl
	43	!! mppscatter :
	44	!! mppgather :
	45	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
	46	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
	47	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
	48	!! mpp_minloc :
	49	!! mpp_maxloc :
	50	!! mppsync :
	51	!! mppstop :
	52	!! mppobc : variant of mpp_lnk for open boundary condition
[1344]	53	!! mpp_ini_north : initialisation of north fold
	54	!! mpp_lbc_north : north fold processors gathering
	55	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
[13]	56	!!----------------------------------------------------------------------
[3764]	57	USE dom_oce ! ocean space and time domain
[2715]	58	USE lbcnfd ! north fold treatment
	59	USE in_out_manager ! I/O manager
[3]	60
[13]	61	IMPLICIT NONE
[415]	62	PRIVATE
[3764]	63
[2715]	64	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn
[1344]	65	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
	66	PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e
	67	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
	68	PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e
[3294]	69	PUBLIC mppscatter, mppgather
[1528]	70	PUBLIC mppobc, mpp_ini_ice, mpp_ini_znl
[2715]	71	PUBLIC mppsize
[3764]	72	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
[2715]	73	PUBLIC lib_mpp_alloc ! Called in nemogcm.F90
[3680]	74	PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d
	75	PUBLIC mpp_lnk_obc_2d, mpp_lnk_obc_3d
[415]	76
[13]	77	!! * Interfaces
	78	!! define generic interface for these routine as they are called sometimes
[1344]	79	!! with scalar arguments instead of array arguments, which causes problems
	80	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
[13]	81	INTERFACE mpp_min
	82	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	83	END INTERFACE
	84	INTERFACE mpp_max
[681]	85	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	86	END INTERFACE
	87	INTERFACE mpp_sum
[1976]	88	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
	89	mppsum_realdd, mppsum_a_realdd
[13]	90	END INTERFACE
	91	INTERFACE mpp_lbc_north
[3764]	92	MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d
[13]	93	END INTERFACE
[1344]	94	INTERFACE mpp_minloc
	95	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	96	END INTERFACE
	97	INTERFACE mpp_maxloc
	98	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	99	END INTERFACE
[3764]	100
[51]	101	!! ========================= !!
	102	!! MPI variable definition !!
	103	!! ========================= !!
[1629]	104	!$AGRIF_DO_NOT_TREAT
[2004]	105	INCLUDE 'mpif.h'
[1629]	106	!$AGRIF_END_DO_NOT_TREAT
[3764]	107
[1344]	108	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
[3]	109
[1344]	110	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
[3764]	111
[1344]	112	INTEGER :: mppsize ! number of process
	113	INTEGER :: mpprank ! process number [ 0 - size-1 ]
[2363]	114	!$AGRIF_DO_NOT_TREAT
[2249]	115	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
[2363]	116	!$AGRIF_END_DO_NOT_TREAT
[3]	117
[2480]	118	INTEGER :: MPI_SUMDD
[1976]	119
[869]	120	! variables used in case of sea-ice
[3625]	121	INTEGER, PUBLIC :: ncomm_ice !: communicator made by the processors with sea-ice (public so that it can be freed in limthd)
	122	INTEGER :: ngrp_iworld ! group ID for the world processors (for rheology)
[1345]	123	INTEGER :: ngrp_ice ! group ID for the ice processors (for rheology)
	124	INTEGER :: ndim_rank_ice ! number of 'ice' processors
	125	INTEGER :: n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm
[2715]	126	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_ice ! dimension ndim_rank_ice
[1345]	127
	128	! variables used for zonal integration
	129	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
	130	LOGICAL, PUBLIC :: l_znl_root ! True on the 'left'most processor on the same row
	131	INTEGER :: ngrp_znl ! group ID for the znl processors
	132	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
[2715]	133	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
[3]	134
[3764]	135	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
	136	INTEGER, PUBLIC :: ngrp_world ! group ID for the world processors
	137	INTEGER, PUBLIC :: ngrp_opa ! group ID for the opa processors
	138	INTEGER, PUBLIC :: ngrp_north ! group ID for the northern processors (to be fold)
	139	INTEGER, PUBLIC :: ncomm_north ! communicator made by the processors belonging to ngrp_north
	140	INTEGER, PUBLIC :: ndim_rank_north ! number of 'sea' processor in the northern line (can be /= jpni !)
	141	INTEGER, PUBLIC :: njmppmax ! value of njmpp for the processors of the northern line
	142	INTEGER, PUBLIC :: north_root ! number (in the comm_opa) of proc 0 in the northern comm
	143	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE, PUBLIC :: nrank_north ! dimension ndim_rank_north
	144
[1344]	145	! Type of send : standard, buffered, immediate
[3764]	146	CHARACTER(len=1), PUBLIC :: cn_mpi_send = 'S' ! type od mpi send/recieve (S=standard, B=bsend, I=isend)
	147	LOGICAL, PUBLIC :: l_isend = .FALSE. ! isend use indicator (T if cn_mpi_send='I')
	148	INTEGER, PUBLIC :: nn_buffer = 0 ! size of the buffer in case of mpi_bsend
	149
[2715]	150	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
[3]	151
[1344]	152	! message passing arrays
[2715]	153	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ns, t4sn ! 2 x 3d for north-south & south-north
	154	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4ew, t4we ! 2 x 3d for east-west & west-east
	155	REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE, SAVE :: t4p1, t4p2 ! 2 x 3d for north fold
	156	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ns, t3sn ! 3d for north-south & south-north
	157	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3ew, t3we ! 3d for east-west & west-east
	158	REAL(wp), DIMENSION(:,:,:,:) , ALLOCATABLE, SAVE :: t3p1, t3p2 ! 3d for north fold
	159	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ns, t2sn ! 2d for north-south & south-north
	160	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2ew, t2we ! 2d for east-west & west-east
	161	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: t2p1, t2p2 ! 2d for north fold
	162
	163	! Arrays used in mpp_lbc_north_3d()
[3918]	164	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: tab_3d, xnorthloc
	165	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE, SAVE :: xnorthgloio
	166	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE, SAVE :: foldwk ! Workspace for message transfers avoiding mpi_allgather
[2715]	167
	168	! Arrays used in mpp_lbc_north_2d()
[3918]	169	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: tab_2d, xnorthloc_2d
	170	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: xnorthgloio_2d
	171	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: foldwk_2d ! Workspace for message transfers avoiding mpi_allgather
[2715]	172
	173	! Arrays used in mpp_lbc_north_e()
[3918]	174	REAL(wp), DIMENSION(:,:) , ALLOCATABLE, SAVE :: tab_e, xnorthloc_e
	175	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: xnorthgloio_e
[2715]	176
[3294]	177	! North fold arrays used to minimise the use of allgather operations. Set in nemo_northcomms (nemogcm) so need to be public
	178	INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 8 ! Assumed maximum number of active neighbours
[3764]	179	INTEGER, PUBLIC, PARAMETER :: jptyps = 5 ! Number of different neighbour lists to be used for northfold exchanges
[3294]	180	INTEGER, PUBLIC, DIMENSION (jpmaxngh,jptyps) :: isendto
	181	INTEGER, PUBLIC, DIMENSION (jptyps) :: nsndto
	182	LOGICAL, PUBLIC :: ln_nnogather = .FALSE. ! namelist control of northfold comms
	183	LOGICAL, PUBLIC :: l_north_nogather = .FALSE. ! internal control of northfold comms
	184	INTEGER, PUBLIC :: ityp
[51]	185	!!----------------------------------------------------------------------
[2287]	186	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[888]	187	!! $Id$
[2715]	188	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1344]	189	!!----------------------------------------------------------------------
[3]	190	CONTAINS
	191
[2715]	192	INTEGER FUNCTION lib_mpp_alloc( kumout )
[51]	193	!!----------------------------------------------------------------------
[2715]	194	!! * routine lib_mpp_alloc *
	195	!!----------------------------------------------------------------------
	196	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
	197	!!----------------------------------------------------------------------
	198	!
	199	ALLOCATE( t4ns(jpi,jprecj,jpk,2,2) , t4sn(jpi,jprecj,jpk,2,2) , &
	200	& t4ew(jpj,jpreci,jpk,2,2) , t4we(jpj,jpreci,jpk,2,2) , &
	201	& t4p1(jpi,jprecj,jpk,2,2) , t4p2(jpi,jprecj,jpk,2,2) , &
	202	& t3ns(jpi,jprecj,jpk,2) , t3sn(jpi,jprecj,jpk,2) , &
	203	& t3ew(jpj,jpreci,jpk,2) , t3we(jpj,jpreci,jpk,2) , &
	204	& t3p1(jpi,jprecj,jpk,2) , t3p2(jpi,jprecj,jpk,2) , &
	205	& t2ns(jpi,jprecj ,2) , t2sn(jpi,jprecj ,2) , &
	206	& t2ew(jpj,jpreci ,2) , t2we(jpj,jpreci ,2) , &
	207	& t2p1(jpi,jprecj ,2) , t2p2(jpi,jprecj ,2) , &
	208	!
[3918]	209	& tab_3d(jpiglo,4,jpk) , xnorthloc(jpi,4,jpk) , xnorthgloio(jpi,4,jpk,jpni) , &
	210	& foldwk(jpi,4,jpk) , &
[2715]	211	!
[3918]	212	& tab_2d(jpiglo,4) , xnorthloc_2d(jpi,4) , xnorthgloio_2d(jpi,4,jpni) , &
	213	& foldwk_2d(jpi,4) , &
[2715]	214	!
[3918]	215	& tab_e(jpiglo,4+2jpr2dj) , xnorthloc_e(jpi,4+2jpr2dj) , xnorthgloio_e(jpi,4+2*jpr2dj,jpni) , &
[2715]	216	!
	217	& STAT=lib_mpp_alloc )
	218	!
	219	IF( lib_mpp_alloc /= 0 ) THEN
	220	WRITE(kumout,cform_war)
	221	WRITE(kumout,*) 'lib_mpp_alloc : failed to allocate arrays'
	222	ENDIF
	223	!
	224	END FUNCTION lib_mpp_alloc
	225
	226
	227	FUNCTION mynode( ldtxt, kumnam, kstop, localComm )
	228	!!----------------------------------------------------------------------
[51]	229	!! * routine mynode *
[3764]	230	!!
[51]	231	!! ** Purpose : Find processor unit
	232	!!----------------------------------------------------------------------
[3764]	233	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
	234	INTEGER , INTENT(in ) :: kumnam ! namelist logical unit
	235	INTEGER , INTENT(inout) :: kstop ! stop indicator
[1579]	236	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[2715]	237	!
[2481]	238	INTEGER :: mynode, ierr, code, ji, ii
[532]	239	LOGICAL :: mpi_was_called
[2715]	240	!
[3294]	241	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
[51]	242	!!----------------------------------------------------------------------
[1344]	243	!
[2481]	244	ii = 1
	245	WRITE(ldtxt(ii),*) ; ii = ii + 1
	246	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
	247	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
[1344]	248	!
[2715]	249	jpni = -1; jpnj = -1; jpnij = -1
	250	REWIND( kumnam ) ! Namelist namrun : parameters of the run
	251	READ ( kumnam, nammpp )
[1344]	252	! ! control print
[2481]	253	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
	254	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
	255	WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer ; ii = ii + 1
[300]	256
[2731]	257	#if defined key_agrif
	258	IF( .NOT. Agrif_Root() ) THEN
[3764]	259	jpni = Agrif_Parent(jpni )
[2731]	260	jpnj = Agrif_Parent(jpnj )
	261	jpnij = Agrif_Parent(jpnij)
	262	ENDIF
	263	#endif
	264
[2715]	265	IF(jpnij < 1)THEN
	266	! If jpnij is not specified in namelist then we calculate it - this
	267	! means there will be no land cutting out.
	268	jpnij = jpni * jpnj
	269	END IF
	270
	271	IF( (jpni < 1) .OR. (jpnj < 1) )THEN
	272	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically'; ii = ii + 1
	273	ELSE
	274	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni; ii = ii + 1
	275	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj; ii = ii + 1
	276	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij; ii = ii +1
	277	END IF
	278
[3294]	279	WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1
	280
[2480]	281	CALL mpi_initialized ( mpi_was_called, code )
	282	IF( code /= MPI_SUCCESS ) THEN
[3764]	283	DO ji = 1, SIZE(ldtxt)
[2481]	284	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
[3764]	285	END DO
[2480]	286	WRITE(*, cform_err)
	287	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
	288	CALL mpi_abort( mpi_comm_world, code, ierr )
	289	ENDIF
[415]	290
[2480]	291	IF( mpi_was_called ) THEN
	292	!
	293	SELECT CASE ( cn_mpi_send )
	294	CASE ( 'S' ) ! Standard mpi send (blocking)
[2481]	295	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
[2480]	296	CASE ( 'B' ) ! Buffer mpi send (blocking)
[2481]	297	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
[3764]	298	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
[2480]	299	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[2481]	300	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
[2480]	301	l_isend = .TRUE.
	302	CASE DEFAULT
[2481]	303	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
	304	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
[2715]	305	kstop = kstop + 1
[2480]	306	END SELECT
	307	ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN
[2481]	308	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
	309	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
[2715]	310	kstop = kstop + 1
[532]	311	ELSE
[1601]	312	SELECT CASE ( cn_mpi_send )
[524]	313	CASE ( 'S' ) ! Standard mpi send (blocking)
[2481]	314	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
[2480]	315	CALL mpi_init( ierr )
[524]	316	CASE ( 'B' ) ! Buffer mpi send (blocking)
[2481]	317	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
	318	IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr )
[524]	319	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[2481]	320	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
[524]	321	l_isend = .TRUE.
[2480]	322	CALL mpi_init( ierr )
[524]	323	CASE DEFAULT
[2481]	324	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
	325	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
[2715]	326	kstop = kstop + 1
[524]	327	END SELECT
[2480]	328	!
[415]	329	ENDIF
[570]	330
[3764]	331	IF( PRESENT(localComm) ) THEN
[2480]	332	IF( Agrif_Root() ) THEN
	333	mpi_comm_opa = localComm
	334	ENDIF
	335	ELSE
	336	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code)
	337	IF( code /= MPI_SUCCESS ) THEN
[3764]	338	DO ji = 1, SIZE(ldtxt)
[2481]	339	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	340	END DO
[2480]	341	WRITE(*, cform_err)
	342	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
	343	CALL mpi_abort( mpi_comm_world, code, ierr )
	344	ENDIF
[3764]	345	ENDIF
[2480]	346
[1344]	347	CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr )
	348	CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr )
[629]	349	mynode = mpprank
[3764]	350	!
[1976]	351	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
	352	!
[51]	353	END FUNCTION mynode
[3]	354
[3680]	355	SUBROUTINE mpp_lnk_obc_3d( ptab, cd_type, psgn )
	356	!!----------------------------------------------------------------------
	357	!! * routine mpp_lnk_obc_3d *
	358	!!
	359	!! ** Purpose : Message passing manadgement
	360	!!
	361	!! ** Method : Use mppsend and mpprecv function for passing OBC boundaries
	362	!! between processors following neighboring subdomains.
	363	!! domain parameters
	364	!! nlci : first dimension of the local subdomain
	365	!! nlcj : second dimension of the local subdomain
	366	!! nbondi : mark for "east-west local boundary"
	367	!! nbondj : mark for "north-south local boundary"
	368	!! noea : number for local neighboring processors
	369	!! nowe : number for local neighboring processors
	370	!! noso : number for local neighboring processors
	371	!! nono : number for local neighboring processors
	372	!!
	373	!! ** Action : ptab with update value at its periphery
	374	!!
	375	!!----------------------------------------------------------------------
	376	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	377	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	378	! ! = T , U , V , F , W points
	379	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	380	! ! = 1. , the sign is kept
	381	!!
	382	INTEGER :: ji, jj, jk, jl ! dummy loop indices
	383	INTEGER :: imigr, iihom, ijhom ! temporary integers
	384	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	385	REAL(wp) :: zland
	386	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	387	!!----------------------------------------------------------------------
[3]	388
[3680]	389	zland = 0.e0 ! zero by default
	390
	391	! 1. standard boundary treatment
	392	! ------------------------------
	393	IF( nbondi == 2) THEN
	394	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	395	ptab( 1 ,:,:) = ptab(jpim1,:,:)
	396	ptab(jpi,:,:) = ptab( 2 ,:,:)
	397	ELSE
	398	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	399	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	400	ENDIF
	401	ELSEIF(nbondi == -1) THEN
	402	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	403	ELSEIF(nbondi == 1) THEN
	404	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	405	ENDIF !* closed
	406
	407	IF (nbondj == 2 .OR. nbondj == -1) THEN
	408	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
	409	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	410	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
	411	ENDIF
	412
	413	! 2. East and west directions exchange
	414	! ------------------------------------
	415	! we play with the neigbours AND the row number because of the periodicity
	416	!
	417	IF(nbondj .ne. 0) THEN
	418	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	419	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	420	iihom = nlci-nreci
	421	DO jl = 1, jpreci
	422	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
	423	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
	424	END DO
	425	END SELECT
	426	!
	427	! ! Migrations
	428	imigr = jpreci * jpj * jpk
	429	!
	430	SELECT CASE ( nbondi )
	431	CASE ( -1 )
	432	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
	433	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
	434	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	435	CASE ( 0 )
	436	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	437	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
	438	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
	439	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
	440	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	441	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	442	CASE ( 1 )
	443	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	444	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
	445	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	446	END SELECT
	447	!
	448	! ! Write Dirichlet lateral conditions
	449	iihom = nlci-jpreci
	450	!
	451	SELECT CASE ( nbondi )
	452	CASE ( -1 )
	453	DO jl = 1, jpreci
	454	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	455	END DO
	456	CASE ( 0 )
	457	DO jl = 1, jpreci
	458	ptab(jl ,:,:) = t3we(:,jl,:,2)
	459	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	460	END DO
	461	CASE ( 1 )
	462	DO jl = 1, jpreci
	463	ptab(jl ,:,:) = t3we(:,jl,:,2)
	464	END DO
	465	END SELECT
	466	ENDIF
	467
	468
	469	! 3. North and south directions
	470	! -----------------------------
	471	! always closed : we play only with the neigbours
	472	!
	473	IF(nbondi .ne. 0) THEN
	474	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	475	ijhom = nlcj-nrecj
	476	DO jl = 1, jprecj
	477	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
	478	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
	479	END DO
	480	ENDIF
	481	!
	482	! ! Migrations
	483	imigr = jprecj * jpi * jpk
	484	!
	485	SELECT CASE ( nbondj )
	486	CASE ( -1 )
	487	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
	488	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
	489	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	490	CASE ( 0 )
	491	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	492	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
	493	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
	494	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
	495	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	496	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	497	CASE ( 1 )
	498	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	499	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
	500	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	501	END SELECT
	502	!
	503	! ! Write Dirichlet lateral conditions
	504	ijhom = nlcj-jprecj
	505	!
	506	SELECT CASE ( nbondj )
	507	CASE ( -1 )
	508	DO jl = 1, jprecj
	509	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	510	END DO
	511	CASE ( 0 )
	512	DO jl = 1, jprecj
	513	ptab(:,jl ,:) = t3sn(:,jl,:,2)
	514	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	515	END DO
	516	CASE ( 1 )
	517	DO jl = 1, jprecj
	518	ptab(:,jl,:) = t3sn(:,jl,:,2)
	519	END DO
	520	END SELECT
	521	ENDIF
	522
	523
	524	! 4. north fold treatment
	525	! -----------------------
	526	!
	527	IF( npolj /= 0 ) THEN
	528	!
	529	SELECT CASE ( jpni )
	530	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	531	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	532	END SELECT
	533	!
	534	ENDIF
	535	!
	536	END SUBROUTINE mpp_lnk_obc_3d
	537
	538
	539	SUBROUTINE mpp_lnk_obc_2d( pt2d, cd_type, psgn )
	540	!!----------------------------------------------------------------------
	541	!! * routine mpp_lnk_obc_2d *
	542	!!
	543	!! ** Purpose : Message passing manadgement for 2d array
	544	!!
	545	!! ** Method : Use mppsend and mpprecv function for passing OBC boundaries
	546	!! between processors following neighboring subdomains.
	547	!! domain parameters
	548	!! nlci : first dimension of the local subdomain
	549	!! nlcj : second dimension of the local subdomain
	550	!! nbondi : mark for "east-west local boundary"
	551	!! nbondj : mark for "north-south local boundary"
	552	!! noea : number for local neighboring processors
	553	!! nowe : number for local neighboring processors
	554	!! noso : number for local neighboring processors
	555	!! nono : number for local neighboring processors
	556	!!
	557	!!----------------------------------------------------------------------
	558	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
	559	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	560	! ! = T , U , V , F , W and I points
	561	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	562	! ! = 1. , the sign is kept
	563	!!
	564	INTEGER :: ji, jj, jl ! dummy loop indices
	565	INTEGER :: imigr, iihom, ijhom ! temporary integers
	566	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	567	REAL(wp) :: zland
	568	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	569	!!----------------------------------------------------------------------
	570
	571	zland = 0.e0 ! zero by default
	572
	573	! 1. standard boundary treatment
	574	! ------------------------------
	575	!
	576	IF( nbondi == 2) THEN
	577	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	578	pt2d( 1 ,:) = pt2d(jpim1,:)
	579	pt2d(jpi,:) = pt2d( 2 ,:)
	580	ELSE
	581	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
	582	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
	583	ENDIF
	584	ELSEIF(nbondi == -1) THEN
	585	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
	586	ELSEIF(nbondi == 1) THEN
	587	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
	588	ENDIF !* closed
	589
	590	IF (nbondj == 2 .OR. nbondj == -1) THEN
	591	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland ! south except F-point
	592	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	593	pt2d(:,nlcj-jprecj+1:jpj) = zland ! north
	594	ENDIF
	595
	596	! 2. East and west directions exchange
	597	! ------------------------------------
	598	! we play with the neigbours AND the row number because of the periodicity
	599	!
	600	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	601	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	602	iihom = nlci-nreci
	603	DO jl = 1, jpreci
	604	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
	605	t2we(:,jl,1) = pt2d(iihom +jl,:)
	606	END DO
	607	END SELECT
	608	!
	609	! ! Migrations
	610	imigr = jpreci * jpj
	611	!
	612	SELECT CASE ( nbondi )
	613	CASE ( -1 )
	614	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
	615	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	616	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	617	CASE ( 0 )
	618	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	619	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
	620	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	621	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
	622	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	623	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	624	CASE ( 1 )
	625	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	626	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
	627	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	628	END SELECT
	629	!
	630	! ! Write Dirichlet lateral conditions
	631	iihom = nlci - jpreci
	632	!
	633	SELECT CASE ( nbondi )
	634	CASE ( -1 )
	635	DO jl = 1, jpreci
	636	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	637	END DO
	638	CASE ( 0 )
	639	DO jl = 1, jpreci
	640	pt2d(jl ,:) = t2we(:,jl,2)
	641	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	642	END DO
	643	CASE ( 1 )
	644	DO jl = 1, jpreci
	645	pt2d(jl ,:) = t2we(:,jl,2)
	646	END DO
	647	END SELECT
	648
	649
	650	! 3. North and south directions
	651	! -----------------------------
	652	! always closed : we play only with the neigbours
	653	!
	654	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	655	ijhom = nlcj-nrecj
	656	DO jl = 1, jprecj
	657	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
	658	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
	659	END DO
	660	ENDIF
	661	!
	662	! ! Migrations
	663	imigr = jprecj * jpi
	664	!
	665	SELECT CASE ( nbondj )
	666	CASE ( -1 )
	667	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
	668	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	669	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	670	CASE ( 0 )
	671	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	672	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
	673	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	674	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
	675	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	676	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	677	CASE ( 1 )
	678	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	679	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
	680	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	681	END SELECT
	682	!
	683	! ! Write Dirichlet lateral conditions
	684	ijhom = nlcj - jprecj
	685	!
	686	SELECT CASE ( nbondj )
	687	CASE ( -1 )
	688	DO jl = 1, jprecj
	689	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	690	END DO
	691	CASE ( 0 )
	692	DO jl = 1, jprecj
	693	pt2d(:,jl ) = t2sn(:,jl,2)
	694	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	695	END DO
	696	CASE ( 1 )
	697	DO jl = 1, jprecj
	698	pt2d(:,jl ) = t2sn(:,jl,2)
	699	END DO
	700	END SELECT
	701
	702
	703	! 4. north fold treatment
	704	! -----------------------
	705	!
	706	IF( npolj /= 0 ) THEN
	707	!
	708	SELECT CASE ( jpni )
	709	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
	710	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
	711	END SELECT
	712	!
	713	ENDIF
	714	!
	715	END SUBROUTINE mpp_lnk_obc_2d
	716
[888]	717	SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval )
[51]	718	!!----------------------------------------------------------------------
	719	!! * routine mpp_lnk_3d *
	720	!!
	721	!! ** Purpose : Message passing manadgement
	722	!!
[3764]	723	!! ** Method : Use mppsend and mpprecv function for passing mask
[51]	724	!! between processors following neighboring subdomains.
	725	!! domain parameters
	726	!! nlci : first dimension of the local subdomain
	727	!! nlcj : second dimension of the local subdomain
	728	!! nbondi : mark for "east-west local boundary"
	729	!! nbondj : mark for "north-south local boundary"
[3764]	730	!! noea : number for local neighboring processors
[51]	731	!! nowe : number for local neighboring processors
	732	!! noso : number for local neighboring processors
	733	!! nono : number for local neighboring processors
	734	!!
	735	!! ** Action : ptab with update value at its periphery
	736	!!
	737	!!----------------------------------------------------------------------
[1344]	738	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	739	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	740	! ! = T , U , V , F , W points
	741	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	742	! ! = 1. , the sign is kept
[3764]	743	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
[1344]	744	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
	745	!!
[1718]	746	INTEGER :: ji, jj, jk, jl ! dummy loop indices
[1344]	747	INTEGER :: imigr, iihom, ijhom ! temporary integers
	748	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
[888]	749	REAL(wp) :: zland
[1344]	750	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[51]	751	!!----------------------------------------------------------------------
[3]	752
[1344]	753	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
	754	ELSE ; zland = 0.e0 ! zero by default
	755	ENDIF
	756
[51]	757	! 1. standard boundary treatment
	758	! ------------------------------
[1718]	759	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
[1344]	760	!
[1718]	761	! WARNING ptab is defined only between nld and nle
	762	DO jk = 1, jpk
	763	DO jj = nlcj+1, jpj ! added line(s) (inner only)
[3764]	764	ptab(nldi :nlei , jj ,jk) = ptab(nldi:nlei, nlej,jk)
[1718]	765	ptab(1 :nldi-1, jj ,jk) = ptab(nldi , nlej,jk)
	766	ptab(nlei+1:nlci , jj ,jk) = ptab( nlei, nlej,jk)
	767	END DO
	768	DO ji = nlci+1, jpi ! added column(s) (full)
	769	ptab(ji ,nldj :nlej ,jk) = ptab( nlei,nldj:nlej,jk)
	770	ptab(ji ,1 :nldj-1,jk) = ptab( nlei,nldj ,jk)
	771	ptab(ji ,nlej+1:jpj ,jk) = ptab( nlei, nlej,jk)
	772	END DO
[610]	773	END DO
[1344]	774	!
[3764]	775	ELSE ! standard close or cyclic treatment
[1344]	776	!
	777	! ! East-West boundaries
	778	! !* Cyclic east-west
	779	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]	780	ptab( 1 ,:,:) = ptab(jpim1,:,:)
	781	ptab(jpi,:,:) = ptab( 2 ,:,:)
[1344]	782	ELSE !* closed
	783	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	784	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
[473]	785	ENDIF
[1344]	786	! ! North-South boundaries (always closed)
	787	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
	788	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
	789	!
[51]	790	ENDIF
[3]	791
[51]	792	! 2. East and west directions exchange
	793	! ------------------------------------
[3764]	794	! we play with the neigbours AND the row number because of the periodicity
[1344]	795	!
	796	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	797	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[51]	798	iihom = nlci-nreci
	799	DO jl = 1, jpreci
	800	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
	801	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
	802	END DO
[3764]	803	END SELECT
[1344]	804	!
	805	! ! Migrations
[51]	806	imigr = jpreci * jpj * jpk
[1344]	807	!
[3764]	808	SELECT CASE ( nbondi )
[51]	809	CASE ( -1 )
[181]	810	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
[3294]	811	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
[300]	812	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	813	CASE ( 0 )
[181]	814	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	815	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
[3294]	816	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
	817	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
[300]	818	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	819	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[51]	820	CASE ( 1 )
[181]	821	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
[3294]	822	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
[300]	823	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	824	END SELECT
[1344]	825	!
	826	! ! Write Dirichlet lateral conditions
[51]	827	iihom = nlci-jpreci
[1344]	828	!
[51]	829	SELECT CASE ( nbondi )
	830	CASE ( -1 )
	831	DO jl = 1, jpreci
	832	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	833	END DO
[3764]	834	CASE ( 0 )
[51]	835	DO jl = 1, jpreci
	836	ptab(jl ,:,:) = t3we(:,jl,:,2)
	837	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	838	END DO
	839	CASE ( 1 )
	840	DO jl = 1, jpreci
	841	ptab(jl ,:,:) = t3we(:,jl,:,2)
	842	END DO
	843	END SELECT
[3]	844
	845
[51]	846	! 3. North and south directions
	847	! -----------------------------
[1344]	848	! always closed : we play only with the neigbours
	849	!
	850	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[51]	851	ijhom = nlcj-nrecj
	852	DO jl = 1, jprecj
	853	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
	854	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
	855	END DO
	856	ENDIF
[1344]	857	!
	858	! ! Migrations
[51]	859	imigr = jprecj * jpi * jpk
[1344]	860	!
[3764]	861	SELECT CASE ( nbondj )
[51]	862	CASE ( -1 )
[181]	863	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
[3294]	864	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
[300]	865	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	866	CASE ( 0 )
[181]	867	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	868	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
[3294]	869	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
	870	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
[300]	871	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	872	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[3764]	873	CASE ( 1 )
[181]	874	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
[3294]	875	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
[300]	876	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
[51]	877	END SELECT
[1344]	878	!
	879	! ! Write Dirichlet lateral conditions
[51]	880	ijhom = nlcj-jprecj
[1344]	881	!
[51]	882	SELECT CASE ( nbondj )
	883	CASE ( -1 )
	884	DO jl = 1, jprecj
	885	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	886	END DO
[3764]	887	CASE ( 0 )
[51]	888	DO jl = 1, jprecj
	889	ptab(:,jl ,:) = t3sn(:,jl,:,2)
	890	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	891	END DO
	892	CASE ( 1 )
	893	DO jl = 1, jprecj
	894	ptab(:,jl,:) = t3sn(:,jl,:,2)
	895	END DO
	896	END SELECT
[3]	897
	898
[51]	899	! 4. north fold treatment
	900	! -----------------------
[1344]	901	!
	902	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
	903	!
	904	SELECT CASE ( jpni )
	905	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	906	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	907	END SELECT
	908	!
[473]	909	ENDIF
[1344]	910	!
[51]	911	END SUBROUTINE mpp_lnk_3d
[3]	912
	913
[888]	914	SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval )
[51]	915	!!----------------------------------------------------------------------
	916	!! * routine mpp_lnk_2d *
[3764]	917	!!
[51]	918	!! ** Purpose : Message passing manadgement for 2d array
	919	!!
[3764]	920	!! ** Method : Use mppsend and mpprecv function for passing mask
[51]	921	!! between processors following neighboring subdomains.
	922	!! domain parameters
	923	!! nlci : first dimension of the local subdomain
	924	!! nlcj : second dimension of the local subdomain
	925	!! nbondi : mark for "east-west local boundary"
	926	!! nbondj : mark for "north-south local boundary"
[3764]	927	!! noea : number for local neighboring processors
[51]	928	!! nowe : number for local neighboring processors
	929	!! noso : number for local neighboring processors
	930	!! nono : number for local neighboring processors
	931	!!
	932	!!----------------------------------------------------------------------
[1344]	933	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied
	934	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	935	! ! = T , U , V , F , W and I points
	936	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	937	! ! = 1. , the sign is kept
[3764]	938	CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only
[1344]	939	REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries)
	940	!!
	941	INTEGER :: ji, jj, jl ! dummy loop indices
	942	INTEGER :: imigr, iihom, ijhom ! temporary integers
	943	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
[888]	944	REAL(wp) :: zland
[1344]	945	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[51]	946	!!----------------------------------------------------------------------
[3]	947
[1344]	948	IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value
	949	ELSE ; zland = 0.e0 ! zero by default
[888]	950	ENDIF
	951
[51]	952	! 1. standard boundary treatment
	953	! ------------------------------
[1344]	954	!
[1718]	955	IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values
[1344]	956	!
[1718]	957	! WARNING pt2d is defined only between nld and nle
	958	DO jj = nlcj+1, jpj ! added line(s) (inner only)
[3764]	959	pt2d(nldi :nlei , jj ) = pt2d(nldi:nlei, nlej)
[1718]	960	pt2d(1 :nldi-1, jj ) = pt2d(nldi , nlej)
	961	pt2d(nlei+1:nlci , jj ) = pt2d( nlei, nlej)
[610]	962	END DO
[1718]	963	DO ji = nlci+1, jpi ! added column(s) (full)
	964	pt2d(ji ,nldj :nlej ) = pt2d( nlei,nldj:nlej)
	965	pt2d(ji ,1 :nldj-1) = pt2d( nlei,nldj )
	966	pt2d(ji ,nlej+1:jpj ) = pt2d( nlei, nlej)
[1344]	967	END DO
	968	!
[3764]	969	ELSE ! standard close or cyclic treatment
[1344]	970	!
	971	! ! East-West boundaries
	972	IF( nbondi == 2 .AND. & ! Cyclic east-west
[473]	973	& (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[1344]	974	pt2d( 1 ,:) = pt2d(jpim1,:) ! west
	975	pt2d(jpi,:) = pt2d( 2 ,:) ! east
	976	ELSE ! closed
	977	IF( .NOT. cd_type == 'F' ) pt2d( 1 :jpreci,:) = zland ! south except F-point
	978	pt2d(nlci-jpreci+1:jpi ,:) = zland ! north
[473]	979	ENDIF
[1344]	980	! ! North-South boundaries (always closed)
	981	IF( .NOT. cd_type == 'F' ) pt2d(:, 1 :jprecj) = zland !south except F-point
	982	pt2d(:,nlcj-jprecj+1:jpj ) = zland ! north
	983	!
[51]	984	ENDIF
[3]	985
[1344]	986	! 2. East and west directions exchange
	987	! ------------------------------------
[3764]	988	! we play with the neigbours AND the row number because of the periodicity
[1344]	989	!
	990	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	991	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[51]	992	iihom = nlci-nreci
	993	DO jl = 1, jpreci
	994	t2ew(:,jl,1) = pt2d(jpreci+jl,:)
	995	t2we(:,jl,1) = pt2d(iihom +jl,:)
	996	END DO
	997	END SELECT
[1344]	998	!
	999	! ! Migrations
[51]	1000	imigr = jpreci * jpj
[1344]	1001	!
[51]	1002	SELECT CASE ( nbondi )
	1003	CASE ( -1 )
[181]	1004	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
[3294]	1005	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
[300]	1006	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	1007	CASE ( 0 )
[181]	1008	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	1009	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
[3294]	1010	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	1011	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
[300]	1012	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1013	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]	1014	CASE ( 1 )
[181]	1015	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
[3294]	1016	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
[300]	1017	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	1018	END SELECT
[1344]	1019	!
	1020	! ! Write Dirichlet lateral conditions
[51]	1021	iihom = nlci - jpreci
[1344]	1022	!
[51]	1023	SELECT CASE ( nbondi )
	1024	CASE ( -1 )
	1025	DO jl = 1, jpreci
	1026	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	1027	END DO
	1028	CASE ( 0 )
	1029	DO jl = 1, jpreci
	1030	pt2d(jl ,:) = t2we(:,jl,2)
	1031	pt2d(iihom+jl,:) = t2ew(:,jl,2)
	1032	END DO
	1033	CASE ( 1 )
	1034	DO jl = 1, jpreci
	1035	pt2d(jl ,:) = t2we(:,jl,2)
	1036	END DO
	1037	END SELECT
[3]	1038
	1039
[51]	1040	! 3. North and south directions
	1041	! -----------------------------
[1344]	1042	! always closed : we play only with the neigbours
	1043	!
	1044	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[51]	1045	ijhom = nlcj-nrecj
	1046	DO jl = 1, jprecj
	1047	t2sn(:,jl,1) = pt2d(:,ijhom +jl)
	1048	t2ns(:,jl,1) = pt2d(:,jprecj+jl)
	1049	END DO
	1050	ENDIF
[1344]	1051	!
	1052	! ! Migrations
[51]	1053	imigr = jprecj * jpi
[1344]	1054	!
[51]	1055	SELECT CASE ( nbondj )
	1056	CASE ( -1 )
[181]	1057	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
[3294]	1058	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
[300]	1059	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	1060	CASE ( 0 )
[181]	1061	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	1062	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
[3294]	1063	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	1064	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
[300]	1065	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1066	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
[51]	1067	CASE ( 1 )
[181]	1068	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
[3294]	1069	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
[300]	1070	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
[51]	1071	END SELECT
[1344]	1072	!
	1073	! ! Write Dirichlet lateral conditions
[51]	1074	ijhom = nlcj - jprecj
[1344]	1075	!
[51]	1076	SELECT CASE ( nbondj )
	1077	CASE ( -1 )
	1078	DO jl = 1, jprecj
	1079	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	1080	END DO
	1081	CASE ( 0 )
	1082	DO jl = 1, jprecj
	1083	pt2d(:,jl ) = t2sn(:,jl,2)
	1084	pt2d(:,ijhom+jl) = t2ns(:,jl,2)
	1085	END DO
[3764]	1086	CASE ( 1 )
[51]	1087	DO jl = 1, jprecj
	1088	pt2d(:,jl ) = t2sn(:,jl,2)
	1089	END DO
[1344]	1090	END SELECT
[3]	1091
[1344]	1092
[51]	1093	! 4. north fold treatment
	1094	! -----------------------
[1344]	1095	!
	1096	IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN
	1097	!
	1098	SELECT CASE ( jpni )
	1099	CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp
	1100	CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs.
	1101	END SELECT
	1102	!
[473]	1103	ENDIF
[1344]	1104	!
[51]	1105	END SUBROUTINE mpp_lnk_2d
[3]	1106
	1107
[473]	1108	SUBROUTINE mpp_lnk_3d_gather( ptab1, cd_type1, ptab2, cd_type2, psgn )
	1109	!!----------------------------------------------------------------------
	1110	!! * routine mpp_lnk_3d_gather *
	1111	!!
	1112	!! ** Purpose : Message passing manadgement for two 3D arrays
	1113	!!
[3764]	1114	!! ** Method : Use mppsend and mpprecv function for passing mask
[473]	1115	!! between processors following neighboring subdomains.
	1116	!! domain parameters
	1117	!! nlci : first dimension of the local subdomain
	1118	!! nlcj : second dimension of the local subdomain
	1119	!! nbondi : mark for "east-west local boundary"
	1120	!! nbondj : mark for "north-south local boundary"
[3764]	1121	!! noea : number for local neighboring processors
[473]	1122	!! nowe : number for local neighboring processors
	1123	!! noso : number for local neighboring processors
	1124	!! nono : number for local neighboring processors
	1125	!!
	1126	!! ** Action : ptab1 and ptab2 with update value at its periphery
	1127	!!
	1128	!!----------------------------------------------------------------------
[3764]	1129	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab1 ! first and second 3D array on which
[1344]	1130	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab2 ! the boundary condition is applied
[3764]	1131	CHARACTER(len=1) , INTENT(in ) :: cd_type1 ! nature of ptab1 and ptab2 arrays
[1344]	1132	CHARACTER(len=1) , INTENT(in ) :: cd_type2 ! i.e. grid-points = T , U , V , F or W points
	1133	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	1134	!! ! = 1. , the sign is kept
	1135	INTEGER :: jl ! dummy loop indices
	1136	INTEGER :: imigr, iihom, ijhom ! temporary integers
	1137	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	1138	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[473]	1139	!!----------------------------------------------------------------------
	1140
	1141	! 1. standard boundary treatment
	1142	! ------------------------------
[1344]	1143	! ! East-West boundaries
	1144	! !* Cyclic east-west
	1145	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[473]	1146	ptab1( 1 ,:,:) = ptab1(jpim1,:,:)
	1147	ptab1(jpi,:,:) = ptab1( 2 ,:,:)
	1148	ptab2( 1 ,:,:) = ptab2(jpim1,:,:)
	1149	ptab2(jpi,:,:) = ptab2( 2 ,:,:)
[1344]	1150	ELSE !* closed
	1151	IF( .NOT. cd_type1 == 'F' ) ptab1( 1 :jpreci,:,:) = 0.e0 ! south except at F-point
	1152	IF( .NOT. cd_type2 == 'F' ) ptab2( 1 :jpreci,:,:) = 0.e0
	1153	ptab1(nlci-jpreci+1:jpi ,:,:) = 0.e0 ! north
	1154	ptab2(nlci-jpreci+1:jpi ,:,:) = 0.e0
[473]	1155	ENDIF
	1156
[3764]	1157
[1344]	1158	! ! North-South boundaries
	1159	IF( .NOT. cd_type1 == 'F' ) ptab1(:, 1 :jprecj,:) = 0.e0 ! south except at F-point
	1160	IF( .NOT. cd_type2 == 'F' ) ptab2(:, 1 :jprecj,:) = 0.e0
	1161	ptab1(:,nlcj-jprecj+1:jpj ,:) = 0.e0 ! north
	1162	ptab2(:,nlcj-jprecj+1:jpj ,:) = 0.e0
[473]	1163
	1164
	1165	! 2. East and west directions exchange
	1166	! ------------------------------------
[3764]	1167	! we play with the neigbours AND the row number because of the periodicity
[1344]	1168	!
	1169	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	1170	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[473]	1171	iihom = nlci-nreci
	1172	DO jl = 1, jpreci
	1173	t4ew(:,jl,:,1,1) = ptab1(jpreci+jl,:,:)
	1174	t4we(:,jl,:,1,1) = ptab1(iihom +jl,:,:)
	1175	t4ew(:,jl,:,2,1) = ptab2(jpreci+jl,:,:)
	1176	t4we(:,jl,:,2,1) = ptab2(iihom +jl,:,:)
	1177	END DO
	1178	END SELECT
[1344]	1179	!
	1180	! ! Migrations
[473]	1181	imigr = jpreci * jpj * jpk *2
[1344]	1182	!
[3764]	1183	SELECT CASE ( nbondi )
[473]	1184	CASE ( -1 )
	1185	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req1 )
[3294]	1186	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
[473]	1187	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1188	CASE ( 0 )
	1189	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
	1190	CALL mppsend( 2, t4we(1,1,1,1,1), imigr, noea, ml_req2 )
[3294]	1191	CALL mpprecv( 1, t4ew(1,1,1,1,2), imigr, noea )
	1192	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
[473]	1193	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1194	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	1195	CASE ( 1 )
	1196	CALL mppsend( 1, t4ew(1,1,1,1,1), imigr, nowe, ml_req1 )
[3294]	1197	CALL mpprecv( 2, t4we(1,1,1,1,2), imigr, nowe )
[473]	1198	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1199	END SELECT
[1344]	1200	!
	1201	! ! Write Dirichlet lateral conditions
	1202	iihom = nlci - jpreci
	1203	!
[473]	1204	SELECT CASE ( nbondi )
	1205	CASE ( -1 )
	1206	DO jl = 1, jpreci
	1207	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
	1208	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
	1209	END DO
[3764]	1210	CASE ( 0 )
[473]	1211	DO jl = 1, jpreci
	1212	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
	1213	ptab1(iihom+jl,:,:) = t4ew(:,jl,:,1,2)
	1214	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
	1215	ptab2(iihom+jl,:,:) = t4ew(:,jl,:,2,2)
	1216	END DO
	1217	CASE ( 1 )
	1218	DO jl = 1, jpreci
	1219	ptab1(jl ,:,:) = t4we(:,jl,:,1,2)
	1220	ptab2(jl ,:,:) = t4we(:,jl,:,2,2)
	1221	END DO
	1222	END SELECT
	1223
	1224
	1225	! 3. North and south directions
	1226	! -----------------------------
[1344]	1227	! always closed : we play only with the neigbours
	1228	!
	1229	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	1230	ijhom = nlcj - nrecj
[473]	1231	DO jl = 1, jprecj
	1232	t4sn(:,jl,:,1,1) = ptab1(:,ijhom +jl,:)
	1233	t4ns(:,jl,:,1,1) = ptab1(:,jprecj+jl,:)
	1234	t4sn(:,jl,:,2,1) = ptab2(:,ijhom +jl,:)
	1235	t4ns(:,jl,:,2,1) = ptab2(:,jprecj+jl,:)
	1236	END DO
	1237	ENDIF
[1344]	1238	!
	1239	! ! Migrations
[473]	1240	imigr = jprecj * jpi * jpk * 2
[1344]	1241	!
[3764]	1242	SELECT CASE ( nbondj )
[473]	1243	CASE ( -1 )
	1244	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req1 )
[3294]	1245	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
[473]	1246	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1247	CASE ( 0 )
	1248	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
	1249	CALL mppsend( 4, t4sn(1,1,1,1,1), imigr, nono, ml_req2 )
[3294]	1250	CALL mpprecv( 3, t4ns(1,1,1,1,2), imigr, nono )
	1251	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
[473]	1252	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1253	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
[3764]	1254	CASE ( 1 )
[473]	1255	CALL mppsend( 3, t4ns(1,1,1,1,1), imigr, noso, ml_req1 )
[3294]	1256	CALL mpprecv( 4, t4sn(1,1,1,1,2), imigr, noso )
[473]	1257	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	1258	END SELECT
[1344]	1259	!
	1260	! ! Write Dirichlet lateral conditions
	1261	ijhom = nlcj - jprecj
	1262	!
[473]	1263	SELECT CASE ( nbondj )
	1264	CASE ( -1 )
	1265	DO jl = 1, jprecj
	1266	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
	1267	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
	1268	END DO
[3764]	1269	CASE ( 0 )
[473]	1270	DO jl = 1, jprecj
	1271	ptab1(:,jl ,:) = t4sn(:,jl,:,1,2)
	1272	ptab1(:,ijhom+jl,:) = t4ns(:,jl,:,1,2)
	1273	ptab2(:,jl ,:) = t4sn(:,jl,:,2,2)
	1274	ptab2(:,ijhom+jl,:) = t4ns(:,jl,:,2,2)
	1275	END DO
	1276	CASE ( 1 )
	1277	DO jl = 1, jprecj
	1278	ptab1(:,jl,:) = t4sn(:,jl,:,1,2)
	1279	ptab2(:,jl,:) = t4sn(:,jl,:,2,2)
	1280	END DO
	1281	END SELECT
	1282
	1283
	1284	! 4. north fold treatment
	1285	! -----------------------
[1344]	1286	IF( npolj /= 0 ) THEN
	1287	!
	1288	SELECT CASE ( jpni )
[3764]	1289	CASE ( 1 )
[1344]	1290	CALL lbc_nfd ( ptab1, cd_type1, psgn ) ! only for northern procs.
	1291	CALL lbc_nfd ( ptab2, cd_type2, psgn )
	1292	CASE DEFAULT
	1293	CALL mpp_lbc_north( ptab1, cd_type1, psgn ) ! for all northern procs.
	1294	CALL mpp_lbc_north (ptab2, cd_type2, psgn)
[3764]	1295	END SELECT
[1344]	1296	!
	1297	ENDIF
	1298	!
[473]	1299	END SUBROUTINE mpp_lnk_3d_gather
	1300
	1301
[3609]	1302	SUBROUTINE mpp_lnk_2d_e( pt2d, cd_type, psgn, jpri, jprj )
[311]	1303	!!----------------------------------------------------------------------
	1304	!! * routine mpp_lnk_2d_e *
[3764]	1305	!!
[311]	1306	!! ** Purpose : Message passing manadgement for 2d array (with halo)
	1307	!!
[3764]	1308	!! ** Method : Use mppsend and mpprecv function for passing mask
[311]	1309	!! between processors following neighboring subdomains.
	1310	!! domain parameters
	1311	!! nlci : first dimension of the local subdomain
	1312	!! nlcj : second dimension of the local subdomain
[3609]	1313	!! jpri : number of rows for extra outer halo
	1314	!! jprj : number of columns for extra outer halo
[311]	1315	!! nbondi : mark for "east-west local boundary"
	1316	!! nbondj : mark for "north-south local boundary"
[3764]	1317	!! noea : number for local neighboring processors
[311]	1318	!! nowe : number for local neighboring processors
	1319	!! noso : number for local neighboring processors
	1320	!! nono : number for local neighboring processors
	1321	!!
	1322	!!----------------------------------------------------------------------
[3609]	1323	INTEGER , INTENT(in ) :: jpri
	1324	INTEGER , INTENT(in ) :: jprj
	1325	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
	1326	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
	1327	! ! = T , U , V , F , W and I points
	1328	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
	1329	!! ! north boundary, = 1. otherwise
[1344]	1330	INTEGER :: jl ! dummy loop indices
	1331	INTEGER :: imigr, iihom, ijhom ! temporary integers
	1332	INTEGER :: ipreci, iprecj ! temporary integers
	1333	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	1334	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[3609]	1335	!!
	1336	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
	1337	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
	1338	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
	1339	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
[1344]	1340	!!----------------------------------------------------------------------
[311]	1341
[3609]	1342	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
	1343	iprecj = jprecj + jprj
[311]	1344
	1345
	1346	! 1. standard boundary treatment
	1347	! ------------------------------
[1344]	1348	! Order matters Here !!!!
	1349	!
	1350	! !* North-South boundaries (always colsed)
[3609]	1351	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-jprj : jprecj ) = 0.e0 ! south except at F-point
	1352	pt2d(:,nlcj-jprecj+1:jpj+jprj) = 0.e0 ! north
[3764]	1353
[1344]	1354	! ! East-West boundaries
	1355	! !* Cyclic east-west
	1356	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
[3609]	1357	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
	1358	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
[1344]	1359	!
	1360	ELSE !* closed
[3609]	1361	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point
	1362	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north
[1344]	1363	ENDIF
	1364	!
[311]	1365
[1344]	1366	! north fold treatment
	1367	! -----------------------
	1368	IF( npolj /= 0 ) THEN
	1369	!
	1370	SELECT CASE ( jpni )
[3609]	1371	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
[1344]	1372	CASE DEFAULT ; CALL mpp_lbc_north_e( pt2d , cd_type, psgn )
[3764]	1373	END SELECT
[1344]	1374	!
[311]	1375	ENDIF
	1376
[1344]	1377	! 2. East and west directions exchange
	1378	! ------------------------------------
[3764]	1379	! we play with the neigbours AND the row number because of the periodicity
[1344]	1380	!
	1381	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	1382	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[3609]	1383	iihom = nlci-nreci-jpri
[311]	1384	DO jl = 1, ipreci
[3609]	1385	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
	1386	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
[311]	1387	END DO
	1388	END SELECT
[1344]	1389	!
	1390	! ! Migrations
[3609]	1391	imigr = ipreci * ( jpj + 2*jprj)
[1344]	1392	!
[311]	1393	SELECT CASE ( nbondi )
	1394	CASE ( -1 )
[3609]	1395	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
	1396	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
[311]	1397	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1398	CASE ( 0 )
[3609]	1399	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
	1400	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
	1401	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
	1402	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
[311]	1403	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1404	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	1405	CASE ( 1 )
[3609]	1406	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
	1407	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
[311]	1408	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1409	END SELECT
[1344]	1410	!
	1411	! ! Write Dirichlet lateral conditions
[311]	1412	iihom = nlci - jpreci
[1344]	1413	!
[311]	1414	SELECT CASE ( nbondi )
	1415	CASE ( -1 )
	1416	DO jl = 1, ipreci
[3609]	1417	pt2d(iihom+jl,:) = r2dew(:,jl,2)
[311]	1418	END DO
	1419	CASE ( 0 )
	1420	DO jl = 1, ipreci
[3609]	1421	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
	1422	pt2d( iihom+jl,:) = r2dew(:,jl,2)
[311]	1423	END DO
	1424	CASE ( 1 )
	1425	DO jl = 1, ipreci
[3609]	1426	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
[311]	1427	END DO
	1428	END SELECT
	1429
	1430
	1431	! 3. North and south directions
	1432	! -----------------------------
[1344]	1433	! always closed : we play only with the neigbours
	1434	!
	1435	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[3609]	1436	ijhom = nlcj-nrecj-jprj
[311]	1437	DO jl = 1, iprecj
[3609]	1438	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
	1439	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
[311]	1440	END DO
	1441	ENDIF
[1344]	1442	!
	1443	! ! Migrations
[3609]	1444	imigr = iprecj * ( jpi + 2*jpri )
[1344]	1445	!
[311]	1446	SELECT CASE ( nbondj )
	1447	CASE ( -1 )
[3609]	1448	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
	1449	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
[311]	1450	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1451	CASE ( 0 )
[3609]	1452	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
	1453	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
	1454	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
	1455	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
[311]	1456	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1457	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	1458	CASE ( 1 )
[3609]	1459	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
	1460	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
[311]	1461	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1462	END SELECT
[1344]	1463	!
	1464	! ! Write Dirichlet lateral conditions
[3764]	1465	ijhom = nlcj - jprecj
[1344]	1466	!
[311]	1467	SELECT CASE ( nbondj )
	1468	CASE ( -1 )
	1469	DO jl = 1, iprecj
[3609]	1470	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
[311]	1471	END DO
	1472	CASE ( 0 )
	1473	DO jl = 1, iprecj
[3609]	1474	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
	1475	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
[311]	1476	END DO
[3764]	1477	CASE ( 1 )
[311]	1478	DO jl = 1, iprecj
[3609]	1479	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
[311]	1480	END DO
[1344]	1481	END SELECT
[311]	1482
	1483	END SUBROUTINE mpp_lnk_2d_e
	1484
	1485
[1344]	1486	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
[51]	1487	!!----------------------------------------------------------------------
	1488	!! * routine mppsend *
[3764]	1489	!!
[51]	1490	!! ** Purpose : Send messag passing array
	1491	!!
	1492	!!----------------------------------------------------------------------
[1344]	1493	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	1494	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
	1495	INTEGER , INTENT(in ) :: kdest ! receive process number
	1496	INTEGER , INTENT(in ) :: ktyp ! tag of the message
	1497	INTEGER , INTENT(in ) :: md_req ! argument for isend
	1498	!!
	1499	INTEGER :: iflag
[51]	1500	!!----------------------------------------------------------------------
[1344]	1501	!
[1601]	1502	SELECT CASE ( cn_mpi_send )
[300]	1503	CASE ( 'S' ) ! Standard mpi send (blocking)
[1344]	1504	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
[300]	1505	CASE ( 'B' ) ! Buffer mpi send (blocking)
[1344]	1506	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa , iflag )
[300]	1507	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[1344]	1508	! be carefull, one more argument here : the mpi request identifier..
	1509	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_opa, md_req, iflag )
[300]	1510	END SELECT
[1344]	1511	!
[51]	1512	END SUBROUTINE mppsend
[3]	1513
	1514
[3294]	1515	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
[51]	1516	!!----------------------------------------------------------------------
	1517	!! * routine mpprecv *
	1518	!!
	1519	!! ** Purpose : Receive messag passing array
	1520	!!
	1521	!!----------------------------------------------------------------------
[1344]	1522	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	1523	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
	1524	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
[3764]	1525	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
[1344]	1526	!!
[51]	1527	INTEGER :: istatus(mpi_status_size)
	1528	INTEGER :: iflag
[3294]	1529	INTEGER :: use_source
[1344]	1530	!!----------------------------------------------------------------------
	1531	!
[3294]	1532
[3764]	1533	! If a specific process number has been passed to the receive call,
[3294]	1534	! use that one. Default is to use mpi_any_source
	1535	use_source=mpi_any_source
	1536	if(present(ksource)) then
	1537	use_source=ksource
	1538	end if
	1539
	1540	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag )
[1344]	1541	!
[51]	1542	END SUBROUTINE mpprecv
[3]	1543
	1544
[51]	1545	SUBROUTINE mppgather( ptab, kp, pio )
	1546	!!----------------------------------------------------------------------
	1547	!! * routine mppgather *
[3764]	1548	!!
	1549	!! ** Purpose : Transfert between a local subdomain array and a work
[51]	1550	!! array which is distributed following the vertical level.
	1551	!!
[1344]	1552	!!----------------------------------------------------------------------
	1553	REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: ptab ! subdomain input array
	1554	INTEGER , INTENT(in ) :: kp ! record length
	1555	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
[51]	1556	!!
[1344]	1557	INTEGER :: itaille, ierror ! temporary integer
[51]	1558	!!---------------------------------------------------------------------
[1344]	1559	!
	1560	itaille = jpi * jpj
	1561	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
[3764]	1562	& mpi_double_precision, kp , mpi_comm_opa, ierror )
[1344]	1563	!
[51]	1564	END SUBROUTINE mppgather
[3]	1565
	1566
[51]	1567	SUBROUTINE mppscatter( pio, kp, ptab )
	1568	!!----------------------------------------------------------------------
	1569	!! * routine mppscatter *
	1570	!!
[3764]	1571	!! ** Purpose : Transfert between awork array which is distributed
[51]	1572	!! following the vertical level and the local subdomain array.
	1573	!!
	1574	!!----------------------------------------------------------------------
	1575	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
	1576	INTEGER :: kp ! Tag (not used with MPI
	1577	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
[1344]	1578	!!
	1579	INTEGER :: itaille, ierror ! temporary integer
[51]	1580	!!---------------------------------------------------------------------
[1344]	1581	!
[51]	1582	itaille=jpi*jpj
[1344]	1583	!
	1584	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
	1585	& mpi_double_precision, kp , mpi_comm_opa, ierror )
	1586	!
[51]	1587	END SUBROUTINE mppscatter
[3]	1588
	1589
[869]	1590	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
[681]	1591	!!----------------------------------------------------------------------
	1592	!! * routine mppmax_a_int *
[3764]	1593	!!
[681]	1594	!! ** Purpose : Find maximum value in an integer layout array
	1595	!!
	1596	!!----------------------------------------------------------------------
[1344]	1597	INTEGER , INTENT(in ) :: kdim ! size of array
	1598	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
[3764]	1599	INTEGER , INTENT(in ), OPTIONAL :: kcom !
[1344]	1600	!!
	1601	INTEGER :: ierror, localcomm ! temporary integer
[681]	1602	INTEGER, DIMENSION(kdim) :: iwork
[1344]	1603	!!----------------------------------------------------------------------
	1604	!
[869]	1605	localcomm = mpi_comm_opa
[1344]	1606	IF( PRESENT(kcom) ) localcomm = kcom
	1607	!
	1608	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, localcomm, ierror )
	1609	!
[681]	1610	ktab(:) = iwork(:)
[1344]	1611	!
[681]	1612	END SUBROUTINE mppmax_a_int
	1613
	1614
[869]	1615	SUBROUTINE mppmax_int( ktab, kcom )
[681]	1616	!!----------------------------------------------------------------------
	1617	!! * routine mppmax_int *
	1618	!!
[1344]	1619	!! ** Purpose : Find maximum value in an integer layout array
[681]	1620	!!
	1621	!!----------------------------------------------------------------------
[1344]	1622	INTEGER, INTENT(inout) :: ktab ! ???
	1623	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
[3764]	1624	!!
[1344]	1625	INTEGER :: ierror, iwork, localcomm ! temporary integer
	1626	!!----------------------------------------------------------------------
	1627	!
[3764]	1628	localcomm = mpi_comm_opa
[1344]	1629	IF( PRESENT(kcom) ) localcomm = kcom
	1630	!
	1631	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror)
	1632	!
[681]	1633	ktab = iwork
[1344]	1634	!
[681]	1635	END SUBROUTINE mppmax_int
	1636
	1637
[869]	1638	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
[51]	1639	!!----------------------------------------------------------------------
	1640	!! * routine mppmin_a_int *
[3764]	1641	!!
[51]	1642	!! ** Purpose : Find minimum value in an integer layout array
	1643	!!
	1644	!!----------------------------------------------------------------------
	1645	INTEGER , INTENT( in ) :: kdim ! size of array
	1646	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
[888]	1647	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	1648	!!
	1649	INTEGER :: ierror, localcomm ! temporary integer
[51]	1650	INTEGER, DIMENSION(kdim) :: iwork
[1344]	1651	!!----------------------------------------------------------------------
	1652	!
[869]	1653	localcomm = mpi_comm_opa
[1344]	1654	IF( PRESENT(kcom) ) localcomm = kcom
	1655	!
	1656	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, localcomm, ierror )
	1657	!
[51]	1658	ktab(:) = iwork(:)
[1344]	1659	!
[51]	1660	END SUBROUTINE mppmin_a_int
[3]	1661
[13]	1662
[1345]	1663	SUBROUTINE mppmin_int( ktab, kcom )
[51]	1664	!!----------------------------------------------------------------------
	1665	!! * routine mppmin_int *
	1666	!!
[1344]	1667	!! ** Purpose : Find minimum value in an integer layout array
[51]	1668	!!
	1669	!!----------------------------------------------------------------------
	1670	INTEGER, INTENT(inout) :: ktab ! ???
[1345]	1671	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	1672	!!
[1345]	1673	INTEGER :: ierror, iwork, localcomm
[1344]	1674	!!----------------------------------------------------------------------
	1675	!
[1345]	1676	localcomm = mpi_comm_opa
	1677	IF( PRESENT(kcom) ) localcomm = kcom
[1344]	1678	!
[1345]	1679	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )
	1680	!
[51]	1681	ktab = iwork
[1344]	1682	!
[51]	1683	END SUBROUTINE mppmin_int
[3]	1684
[13]	1685
[51]	1686	SUBROUTINE mppsum_a_int( ktab, kdim )
	1687	!!----------------------------------------------------------------------
	1688	!! * routine mppsum_a_int *
[3764]	1689	!!
[1344]	1690	!! ** Purpose : Global integer sum, 1D array case
[51]	1691	!!
	1692	!!----------------------------------------------------------------------
[1344]	1693	INTEGER, INTENT(in ) :: kdim ! ???
[51]	1694	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
[1344]	1695	!!
[51]	1696	INTEGER :: ierror
	1697	INTEGER, DIMENSION (kdim) :: iwork
[1344]	1698	!!----------------------------------------------------------------------
	1699	!
	1700	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
	1701	!
[51]	1702	ktab(:) = iwork(:)
[1344]	1703	!
[51]	1704	END SUBROUTINE mppsum_a_int
[3]	1705
[13]	1706
[1344]	1707	SUBROUTINE mppsum_int( ktab )
	1708	!!----------------------------------------------------------------------
	1709	!! * routine mppsum_int *
[3764]	1710	!!
[1344]	1711	!! ** Purpose : Global integer sum
	1712	!!
	1713	!!----------------------------------------------------------------------
	1714	INTEGER, INTENT(inout) :: ktab
[3764]	1715	!!
[1344]	1716	INTEGER :: ierror, iwork
	1717	!!----------------------------------------------------------------------
	1718	!
	1719	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_opa, ierror )
	1720	!
	1721	ktab = iwork
	1722	!
	1723	END SUBROUTINE mppsum_int
[3]	1724
[13]	1725
[1344]	1726	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
	1727	!!----------------------------------------------------------------------
	1728	!! * routine mppmax_a_real *
[3764]	1729	!!
[1344]	1730	!! ** Purpose : Maximum
	1731	!!
	1732	!!----------------------------------------------------------------------
	1733	INTEGER , INTENT(in ) :: kdim
	1734	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
	1735	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1736	!!
	1737	INTEGER :: ierror, localcomm
	1738	REAL(wp), DIMENSION(kdim) :: zwork
	1739	!!----------------------------------------------------------------------
	1740	!
	1741	localcomm = mpi_comm_opa
	1742	IF( PRESENT(kcom) ) localcomm = kcom
	1743	!
	1744	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, localcomm, ierror )
	1745	ptab(:) = zwork(:)
	1746	!
	1747	END SUBROUTINE mppmax_a_real
[3]	1748
	1749
[1344]	1750	SUBROUTINE mppmax_real( ptab, kcom )
	1751	!!----------------------------------------------------------------------
	1752	!! * routine mppmax_real *
[3764]	1753	!!
[1344]	1754	!! ** Purpose : Maximum
	1755	!!
	1756	!!----------------------------------------------------------------------
	1757	REAL(wp), INTENT(inout) :: ptab ! ???
	1758	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
	1759	!!
	1760	INTEGER :: ierror, localcomm
	1761	REAL(wp) :: zwork
	1762	!!----------------------------------------------------------------------
	1763	!
[3764]	1764	localcomm = mpi_comm_opa
[1344]	1765	IF( PRESENT(kcom) ) localcomm = kcom
	1766	!
	1767	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, localcomm, ierror )
	1768	ptab = zwork
	1769	!
	1770	END SUBROUTINE mppmax_real
[13]	1771
[3]	1772
[1344]	1773	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
	1774	!!----------------------------------------------------------------------
	1775	!! * routine mppmin_a_real *
[3764]	1776	!!
[1344]	1777	!! ** Purpose : Minimum of REAL, array case
	1778	!!
	1779	!!-----------------------------------------------------------------------
	1780	INTEGER , INTENT(in ) :: kdim
	1781	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
	1782	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1783	!!
	1784	INTEGER :: ierror, localcomm
	1785	REAL(wp), DIMENSION(kdim) :: zwork
	1786	!!-----------------------------------------------------------------------
	1787	!
[3764]	1788	localcomm = mpi_comm_opa
[1344]	1789	IF( PRESENT(kcom) ) localcomm = kcom
	1790	!
	1791	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, localcomm, ierror )
	1792	ptab(:) = zwork(:)
	1793	!
	1794	END SUBROUTINE mppmin_a_real
[3]	1795
	1796
[1344]	1797	SUBROUTINE mppmin_real( ptab, kcom )
	1798	!!----------------------------------------------------------------------
	1799	!! * routine mppmin_real *
[3764]	1800	!!
[1344]	1801	!! ** Purpose : minimum of REAL, scalar case
	1802	!!
	1803	!!-----------------------------------------------------------------------
[3764]	1804	REAL(wp), INTENT(inout) :: ptab !
[1344]	1805	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1806	!!
	1807	INTEGER :: ierror
	1808	REAL(wp) :: zwork
	1809	INTEGER :: localcomm
	1810	!!-----------------------------------------------------------------------
	1811	!
[3764]	1812	localcomm = mpi_comm_opa
[1344]	1813	IF( PRESENT(kcom) ) localcomm = kcom
	1814	!
	1815	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, localcomm, ierror )
	1816	ptab = zwork
	1817	!
	1818	END SUBROUTINE mppmin_real
[13]	1819
[3]	1820
[1344]	1821	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
	1822	!!----------------------------------------------------------------------
	1823	!! * routine mppsum_a_real *
[3764]	1824	!!
[1344]	1825	!! ** Purpose : global sum, REAL ARRAY argument case
	1826	!!
	1827	!!-----------------------------------------------------------------------
	1828	INTEGER , INTENT( in ) :: kdim ! size of ptab
	1829	REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array
	1830	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1831	!!
	1832	INTEGER :: ierror ! temporary integer
[3764]	1833	INTEGER :: localcomm
	1834	REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace
[1344]	1835	!!-----------------------------------------------------------------------
	1836	!
[3764]	1837	localcomm = mpi_comm_opa
[1344]	1838	IF( PRESENT(kcom) ) localcomm = kcom
	1839	!
	1840	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, localcomm, ierror )
	1841	ptab(:) = zwork(:)
	1842	!
	1843	END SUBROUTINE mppsum_a_real
[869]	1844
[3]	1845
[1344]	1846	SUBROUTINE mppsum_real( ptab, kcom )
	1847	!!----------------------------------------------------------------------
	1848	!! * routine mppsum_real *
[3764]	1849	!!
[1344]	1850	!! ** Purpose : global sum, SCALAR argument case
	1851	!!
	1852	!!-----------------------------------------------------------------------
	1853	REAL(wp), INTENT(inout) :: ptab ! input scalar
	1854	INTEGER , INTENT(in ), OPTIONAL :: kcom
	1855	!!
[3764]	1856	INTEGER :: ierror, localcomm
[1344]	1857	REAL(wp) :: zwork
	1858	!!-----------------------------------------------------------------------
	1859	!
[3764]	1860	localcomm = mpi_comm_opa
[1344]	1861	IF( PRESENT(kcom) ) localcomm = kcom
	1862	!
	1863	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, localcomm, ierror )
	1864	ptab = zwork
	1865	!
	1866	END SUBROUTINE mppsum_real
[3]	1867
[1976]	1868	SUBROUTINE mppsum_realdd( ytab, kcom )
	1869	!!----------------------------------------------------------------------
	1870	!! * routine mppsum_realdd *
	1871	!!
	1872	!! ** Purpose : global sum in Massively Parallel Processing
	1873	!! SCALAR argument case for double-double precision
	1874	!!
	1875	!!-----------------------------------------------------------------------
	1876	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
	1877	INTEGER , INTENT( in ), OPTIONAL :: kcom
[3]	1878
[1976]	1879	!! * Local variables (MPI version)
	1880	INTEGER :: ierror
	1881	INTEGER :: localcomm
	1882	COMPLEX(wp) :: zwork
	1883
	1884	localcomm = mpi_comm_opa
	1885	IF( PRESENT(kcom) ) localcomm = kcom
	1886
	1887	! reduce local sums into global sum
	1888	CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, &
	1889	MPI_SUMDD,localcomm,ierror)
	1890	ytab = zwork
	1891
	1892	END SUBROUTINE mppsum_realdd
[3764]	1893
	1894
[1976]	1895	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	1896	!!----------------------------------------------------------------------
	1897	!! * routine mppsum_a_realdd *
	1898	!!
	1899	!! ** Purpose : global sum in Massively Parallel Processing
	1900	!! COMPLEX ARRAY case for double-double precision
	1901	!!
	1902	!!-----------------------------------------------------------------------
	1903	INTEGER , INTENT( in ) :: kdim ! size of ytab
	1904	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
	1905	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1906
	1907	!! * Local variables (MPI version)
	1908	INTEGER :: ierror ! temporary integer
	1909	INTEGER :: localcomm
	1910	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
	1911
	1912	localcomm = mpi_comm_opa
	1913	IF( PRESENT(kcom) ) localcomm = kcom
	1914
	1915	CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, &
	1916	MPI_SUMDD,localcomm,ierror)
	1917	ytab(:) = zwork(:)
	1918
	1919	END SUBROUTINE mppsum_a_realdd
[3764]	1920
[1344]	1921	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
	1922	!!------------------------------------------------------------------------
	1923	!! * routine mpp_minloc *
	1924	!!
	1925	!! ** Purpose : Compute the global minimum of an array ptab
	1926	!! and also give its global position
	1927	!!
	1928	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1929	!!
	1930	!!--------------------------------------------------------------------------
	1931	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	1932	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	1933	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
	1934	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
	1935	!!
	1936	INTEGER , DIMENSION(2) :: ilocs
	1937	INTEGER :: ierror
	1938	REAL(wp) :: zmin ! local minimum
	1939	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1940	!!-----------------------------------------------------------------------
	1941	!
	1942	zmin = MINVAL( ptab(:,:) , mask= pmask == 1.e0 )
	1943	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1.e0 )
	1944	!
	1945	ki = ilocs(1) + nimpp - 1
	1946	kj = ilocs(2) + njmpp - 1
	1947	!
	1948	zain(1,:)=zmin
	1949	zain(2,:)=ki+10000.*kj
	1950	!
	1951	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
	1952	!
	1953	pmin = zaout(1,1)
	1954	kj = INT(zaout(2,1)/10000.)
	1955	ki = INT(zaout(2,1) - 10000.*kj )
	1956	!
	1957	END SUBROUTINE mpp_minloc2d
[13]	1958
[3]	1959
[1344]	1960	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
	1961	!!------------------------------------------------------------------------
	1962	!! * routine mpp_minloc *
	1963	!!
	1964	!! ** Purpose : Compute the global minimum of an array ptab
	1965	!! and also give its global position
	1966	!!
	1967	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	1968	!!
	1969	!!--------------------------------------------------------------------------
	1970	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
	1971	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
	1972	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
	1973	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
	1974	!!
	1975	INTEGER :: ierror
	1976	REAL(wp) :: zmin ! local minimum
	1977	INTEGER , DIMENSION(3) :: ilocs
	1978	REAL(wp), DIMENSION(2,1) :: zain, zaout
	1979	!!-----------------------------------------------------------------------
	1980	!
	1981	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
	1982	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
	1983	!
	1984	ki = ilocs(1) + nimpp - 1
	1985	kj = ilocs(2) + njmpp - 1
	1986	kk = ilocs(3)
	1987	!
	1988	zain(1,:)=zmin
	1989	zain(2,:)=ki+10000.kj+100000000.kk
	1990	!
	1991	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror)
	1992	!
	1993	pmin = zaout(1,1)
	1994	kk = INT( zaout(2,1) / 100000000. )
	1995	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	1996	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	1997	!
	1998	END SUBROUTINE mpp_minloc3d
[13]	1999
[3]	2000
[1344]	2001	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
	2002	!!------------------------------------------------------------------------
	2003	!! * routine mpp_maxloc *
	2004	!!
	2005	!! ** Purpose : Compute the global maximum of an array ptab
	2006	!! and also give its global position
	2007	!!
	2008	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	2009	!!
	2010	!!--------------------------------------------------------------------------
	2011	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	2012	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	2013	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	2014	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
[3764]	2015	!!
[1344]	2016	INTEGER :: ierror
	2017	INTEGER, DIMENSION (2) :: ilocs
	2018	REAL(wp) :: zmax ! local maximum
	2019	REAL(wp), DIMENSION(2,1) :: zain, zaout
	2020	!!-----------------------------------------------------------------------
	2021	!
	2022	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1.e0 )
	2023	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1.e0 )
	2024	!
	2025	ki = ilocs(1) + nimpp - 1
	2026	kj = ilocs(2) + njmpp - 1
	2027	!
	2028	zain(1,:) = zmax
	2029	zain(2,:) = ki + 10000. * kj
	2030	!
	2031	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
	2032	!
	2033	pmax = zaout(1,1)
	2034	kj = INT( zaout(2,1) / 10000. )
	2035	ki = INT( zaout(2,1) - 10000.* kj )
	2036	!
	2037	END SUBROUTINE mpp_maxloc2d
[3]	2038
[13]	2039
[1344]	2040	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
	2041	!!------------------------------------------------------------------------
	2042	!! * routine mpp_maxloc *
	2043	!!
	2044	!! ** Purpose : Compute the global maximum of an array ptab
	2045	!! and also give its global position
	2046	!!
	2047	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	2048	!!
	2049	!!--------------------------------------------------------------------------
	2050	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: ptab ! Local 2D array
	2051	REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pmask ! Local mask
	2052	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	2053	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
[3764]	2054	!!
[1344]	2055	REAL(wp) :: zmax ! local maximum
	2056	REAL(wp), DIMENSION(2,1) :: zain, zaout
	2057	INTEGER , DIMENSION(3) :: ilocs
	2058	INTEGER :: ierror
	2059	!!-----------------------------------------------------------------------
	2060	!
	2061	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1.e0 )
	2062	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1.e0 )
	2063	!
	2064	ki = ilocs(1) + nimpp - 1
	2065	kj = ilocs(2) + njmpp - 1
	2066	kk = ilocs(3)
	2067	!
	2068	zain(1,:)=zmax
	2069	zain(2,:)=ki+10000.kj+100000000.kk
	2070	!
	2071	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror)
	2072	!
	2073	pmax = zaout(1,1)
	2074	kk = INT( zaout(2,1) / 100000000. )
	2075	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	2076	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	2077	!
	2078	END SUBROUTINE mpp_maxloc3d
[3]	2079
[869]	2080
[1344]	2081	SUBROUTINE mppsync()
	2082	!!----------------------------------------------------------------------
	2083	!! * routine mppsync *
[3764]	2084	!!
[1344]	2085	!! ** Purpose : Massively parallel processors, synchroneous
	2086	!!
	2087	!!-----------------------------------------------------------------------
	2088	INTEGER :: ierror
	2089	!!-----------------------------------------------------------------------
	2090	!
	2091	CALL mpi_barrier( mpi_comm_opa, ierror )
	2092	!
	2093	END SUBROUTINE mppsync
[3]	2094
	2095
[1344]	2096	SUBROUTINE mppstop
	2097	!!----------------------------------------------------------------------
	2098	!! * routine mppstop *
[3764]	2099	!!
[3294]	2100	!! ** purpose : Stop massively parallel processors method
[1344]	2101	!!
	2102	!!----------------------------------------------------------------------
	2103	INTEGER :: info
	2104	!!----------------------------------------------------------------------
	2105	!
	2106	CALL mppsync
	2107	CALL mpi_finalize( info )
	2108	!
	2109	END SUBROUTINE mppstop
[3]	2110
	2111
[2715]	2112	SUBROUTINE mppobc( ptab, kd1, kd2, kl, kk, ktype, kij , kumout)
[1344]	2113	!!----------------------------------------------------------------------
	2114	!! * routine mppobc *
[3764]	2115	!!
[1344]	2116	!! ** Purpose : Message passing manadgement for open boundary
	2117	!! conditions array
	2118	!!
	2119	!! ** Method : Use mppsend and mpprecv function for passing mask
	2120	!! between processors following neighboring subdomains.
	2121	!! domain parameters
	2122	!! nlci : first dimension of the local subdomain
	2123	!! nlcj : second dimension of the local subdomain
	2124	!! nbondi : mark for "east-west local boundary"
	2125	!! nbondj : mark for "north-south local boundary"
[3764]	2126	!! noea : number for local neighboring processors
[1344]	2127	!! nowe : number for local neighboring processors
	2128	!! noso : number for local neighboring processors
	2129	!! nono : number for local neighboring processors
	2130	!!
	2131	!!----------------------------------------------------------------------
[3294]	2132	USE wrk_nemo ! Memory allocation
[2715]	2133	!
[1344]	2134	INTEGER , INTENT(in ) :: kd1, kd2 ! starting and ending indices
	2135	INTEGER , INTENT(in ) :: kl ! index of open boundary
	2136	INTEGER , INTENT(in ) :: kk ! vertical dimension
	2137	INTEGER , INTENT(in ) :: ktype ! define north/south or east/west cdt
	2138	! ! = 1 north/south ; = 2 east/west
	2139	INTEGER , INTENT(in ) :: kij ! horizontal dimension
[2715]	2140	INTEGER , INTENT(in ) :: kumout ! ocean.output logical unit
[1344]	2141	REAL(wp), INTENT(inout), DIMENSION(kij,kk) :: ptab ! variable array
[2715]	2142	!
	2143	INTEGER :: ji, jj, jk, jl ! dummy loop indices
	2144	INTEGER :: iipt0, iipt1, ilpt1 ! local integers
	2145	INTEGER :: ijpt0, ijpt1 ! - -
	2146	INTEGER :: imigr, iihom, ijhom ! - -
[1344]	2147	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	2148	INTEGER :: ml_stat(MPI_STATUS_SIZE) ! for key_mpi_isend
[3294]	2149	REAL(wp), POINTER, DIMENSION(:,:) :: ztab ! temporary workspace
[3680]	2150	LOGICAL :: lmigr ! is true for those processors that have to migrate the OB
[1344]	2151	!!----------------------------------------------------------------------
[3]	2152
[3294]	2153	CALL wrk_alloc( jpi,jpj, ztab )
[2715]	2154
[1344]	2155	! boundary condition initialization
	2156	! ---------------------------------
	2157	ztab(:,:) = 0.e0
	2158	!
	2159	IF( ktype==1 ) THEN ! north/south boundaries
	2160	iipt0 = MAX( 1, MIN(kd1 - nimpp+1, nlci ) )
	2161	iipt1 = MAX( 0, MIN(kd2 - nimpp+1, nlci - 1 ) )
	2162	ilpt1 = MAX( 1, MIN(kd2 - nimpp+1, nlci ) )
	2163	ijpt0 = MAX( 1, MIN(kl - njmpp+1, nlcj ) )
	2164	ijpt1 = MAX( 0, MIN(kl - njmpp+1, nlcj - 1 ) )
	2165	ELSEIF( ktype==2 ) THEN ! east/west boundaries
	2166	iipt0 = MAX( 1, MIN(kl - nimpp+1, nlci ) )
	2167	iipt1 = MAX( 0, MIN(kl - nimpp+1, nlci - 1 ) )
	2168	ijpt0 = MAX( 1, MIN(kd1 - njmpp+1, nlcj ) )
	2169	ijpt1 = MAX( 0, MIN(kd2 - njmpp+1, nlcj - 1 ) )
	2170	ilpt1 = MAX( 1, MIN(kd2 - njmpp+1, nlcj ) )
	2171	ELSE
[2715]	2172	WRITE(kumout, cform_err)
	2173	WRITE(kumout,*) 'mppobc : bad ktype'
	2174	CALL mppstop
[1344]	2175	ENDIF
[3680]	2176
[1344]	2177	! Communication level by level
	2178	! ----------------------------
	2179	!!gm Remark : this is very time consumming!!!
	2180	! ! ------------------------ !
[4017]	2181	IF(((nbondi .ne. 0) .AND. (ktype .eq. 2)) .OR. ((nbondj .ne. 0) .AND. (ktype .eq. 1))) THEN
[3680]	2182	! there is nothing to be migrated
[4047]	2183	lmigr = .TRUE.
[3680]	2184	ELSE
[4047]	2185	lmigr = .FALSE.
[3680]	2186	ENDIF
	2187
	2188	IF( lmigr ) THEN
	2189
[1344]	2190	DO jk = 1, kk ! Loop over the levels !
	2191	! ! ------------------------ !
	2192	!
	2193	IF( ktype == 1 ) THEN ! north/south boundaries
	2194	DO jj = ijpt0, ijpt1
	2195	DO ji = iipt0, iipt1
	2196	ztab(ji,jj) = ptab(ji,jk)
	2197	END DO
	2198	END DO
	2199	ELSEIF( ktype == 2 ) THEN ! east/west boundaries
	2200	DO jj = ijpt0, ijpt1
	2201	DO ji = iipt0, iipt1
	2202	ztab(ji,jj) = ptab(jj,jk)
	2203	END DO
	2204	END DO
	2205	ENDIF
[13]	2206
[3]	2207
[1344]	2208	! 1. East and west directions
	2209	! ---------------------------
	2210	!
[3680]	2211	IF( ktype == 1 ) THEN
	2212
[1344]	2213	IF( nbondi /= 2 ) THEN ! Read Dirichlet lateral conditions
	2214	iihom = nlci-nreci
[3680]	2215	t2ew(1:jpreci,1,1) = ztab(jpreci+1:nreci, ijpt0)
	2216	t2we(1:jpreci,1,1) = ztab(iihom+1:iihom+jpreci, ijpt0)
[1344]	2217	ENDIF
	2218	!
	2219	! ! Migrations
[3680]	2220	imigr = jpreci
[1344]	2221	!
	2222	IF( nbondi == -1 ) THEN
	2223	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
[3294]	2224	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
[1344]	2225	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2226	ELSEIF( nbondi == 0 ) THEN
	2227	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	2228	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
[3294]	2229	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	2230	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
[1344]	2231	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2232	IF(l_isend) CALL mpi_wait( ml_req2, ml_stat, ml_err )
	2233	ELSEIF( nbondi == 1 ) THEN
	2234	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
[3294]	2235	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
[1344]	2236	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2237	ENDIF
	2238	!
	2239	! ! Write Dirichlet lateral conditions
	2240	iihom = nlci-jpreci
	2241	!
	2242	IF( nbondi == 0 .OR. nbondi == 1 ) THEN
[3680]	2243	ztab(1:jpreci, ijpt0) = t2we(1:jpreci,1,2)
[1344]	2244	ENDIF
	2245	IF( nbondi == -1 .OR. nbondi == 0 ) THEN
[3680]	2246	ztab(iihom+1:iihom+jpreci, ijpt0) = t2ew(1:jpreci,1,2)
[1344]	2247	ENDIF
[3680]	2248	ENDIF ! (ktype == 1)
[3]	2249
[1344]	2250	! 2. North and south directions
	2251	! -----------------------------
	2252	!
[3680]	2253	IF(ktype == 2 ) THEN
[1344]	2254	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	2255	ijhom = nlcj-nrecj
[3680]	2256	t2sn(1:jprecj,1,1) = ztab(iipt0, ijhom+1:ijhom+jprecj)
	2257	t2ns(1:jprecj,1,1) = ztab(iipt0, jprecj+1:nrecj)
[1344]	2258	ENDIF
	2259	!
	2260	! ! Migrations
[3680]	2261	imigr = jprecj
[1344]	2262	!
	2263	IF( nbondj == -1 ) THEN
	2264	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
[3294]	2265	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
[1344]	2266	IF(l_isend) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2267	ELSEIF( nbondj == 0 ) THEN
	2268	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	2269	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
[3294]	2270	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	2271	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
[1344]	2272	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2273	IF( l_isend ) CALL mpi_wait( ml_req2, ml_stat, ml_err )
	2274	ELSEIF( nbondj == 1 ) THEN
	2275	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
[3294]	2276	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso)
[1344]	2277	IF( l_isend ) CALL mpi_wait( ml_req1, ml_stat, ml_err )
	2278	ENDIF
	2279	!
	2280	! ! Write Dirichlet lateral conditions
	2281	ijhom = nlcj - jprecj
	2282	IF( nbondj == 0 .OR. nbondj == 1 ) THEN
[3680]	2283	ztab(iipt0,1:jprecj) = t2sn(1:jprecj,1,2)
[1344]	2284	ENDIF
	2285	IF( nbondj == 0 .OR. nbondj == -1 ) THEN
[3680]	2286	ztab(iipt0, ijhom+1:ijhom+jprecj) = t2ns(1:jprecj,1,2)
[1344]	2287	ENDIF
[3680]	2288	ENDIF ! (ktype == 2)
[1344]	2289	IF( ktype==1 .AND. kd1 <= jpi+nimpp-1 .AND. nimpp <= kd2 ) THEN
	2290	DO jj = ijpt0, ijpt1 ! north/south boundaries
	2291	DO ji = iipt0,ilpt1
[3680]	2292	ptab(ji,jk) = ztab(ji,jj)
[1344]	2293	END DO
	2294	END DO
	2295	ELSEIF( ktype==2 .AND. kd1 <= jpj+njmpp-1 .AND. njmpp <= kd2 ) THEN
	2296	DO jj = ijpt0, ilpt1 ! east/west boundaries
	2297	DO ji = iipt0,iipt1
[3680]	2298	ptab(jj,jk) = ztab(ji,jj)
[1344]	2299	END DO
	2300	END DO
	2301	ENDIF
	2302	!
	2303	END DO
	2304	!
[3680]	2305	ENDIF ! ( lmigr )
[3294]	2306	CALL wrk_dealloc( jpi,jpj, ztab )
[2715]	2307	!
[1344]	2308	END SUBROUTINE mppobc
[13]	2309
[3764]	2310
[1344]	2311	SUBROUTINE mpp_comm_free( kcom )
	2312	!!----------------------------------------------------------------------
	2313	!!----------------------------------------------------------------------
	2314	INTEGER, INTENT(in) :: kcom
	2315	!!
	2316	INTEGER :: ierr
	2317	!!----------------------------------------------------------------------
	2318	!
	2319	CALL MPI_COMM_FREE(kcom, ierr)
	2320	!
	2321	END SUBROUTINE mpp_comm_free
[3]	2322
[869]	2323
[2715]	2324	SUBROUTINE mpp_ini_ice( pindic, kumout )
[1344]	2325	!!----------------------------------------------------------------------
	2326	!! * routine mpp_ini_ice *
	2327	!!
	2328	!! ** Purpose : Initialize special communicator for ice areas
	2329	!! condition together with global variables needed in the ddmpp folding
	2330	!!
	2331	!! ** Method : - Look for ice processors in ice routines
	2332	!! - Put their number in nrank_ice
	2333	!! - Create groups for the world processors and the ice processors
	2334	!! - Create a communicator for ice processors
	2335	!!
	2336	!! ** output
	2337	!! njmppmax = njmpp for northern procs
	2338	!! ndim_rank_ice = number of processors with ice
	2339	!! nrank_ice (ndim_rank_ice) = ice processors
[3625]	2340	!! ngrp_iworld = group ID for the world processors
[1344]	2341	!! ngrp_ice = group ID for the ice processors
	2342	!! ncomm_ice = communicator for the ice procs.
	2343	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
	2344	!!
	2345	!!----------------------------------------------------------------------
[2715]	2346	INTEGER, INTENT(in) :: pindic
	2347	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
[1344]	2348	!!
	2349	INTEGER :: jjproc
[2715]	2350	INTEGER :: ii, ierr
	2351	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
	2352	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
[1344]	2353	!!----------------------------------------------------------------------
	2354	!
[2715]	2355	! Since this is just an init routine and these arrays are of length jpnij
	2356	! then don't use wrk_nemo module - just allocate and deallocate.
	2357	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
	2358	IF( ierr /= 0 ) THEN
	2359	WRITE(kumout, cform_err)
	2360	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
	2361	CALL mppstop
	2362	ENDIF
	2363
[1344]	2364	! Look for how many procs with sea-ice
	2365	!
	2366	kice = 0
	2367	DO jjproc = 1, jpnij
[3764]	2368	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
[1344]	2369	END DO
	2370	!
	2371	zwork = 0
	2372	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
[3764]	2373	ndim_rank_ice = SUM( zwork )
[3]	2374
[1344]	2375	! Allocate the right size to nrank_north
[1441]	2376	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
[1344]	2377	ALLOCATE( nrank_ice(ndim_rank_ice) )
	2378	!
[3764]	2379	ii = 0
[1344]	2380	nrank_ice = 0
	2381	DO jjproc = 1, jpnij
	2382	IF( zwork(jjproc) == 1) THEN
	2383	ii = ii + 1
[3764]	2384	nrank_ice(ii) = jjproc -1
[1344]	2385	ENDIF
	2386	END DO
[1208]	2387
[1344]	2388	! Create the world group
[3625]	2389	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
[869]	2390
[1344]	2391	! Create the ice group from the world group
[3625]	2392	CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
[869]	2393
[1344]	2394	! Create the ice communicator , ie the pool of procs with sea-ice
	2395	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
[869]	2396
[1344]	2397	! Find proc number in the world of proc 0 in the north
	2398	! The following line seems to be useless, we just comment & keep it as reminder
[3625]	2399	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
[1344]	2400	!
[3625]	2401	CALL MPI_GROUP_FREE(ngrp_ice, ierr)
	2402	CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
	2403
[2715]	2404	DEALLOCATE(kice, zwork)
	2405	!
[1344]	2406	END SUBROUTINE mpp_ini_ice
[869]	2407
	2408
[2715]	2409	SUBROUTINE mpp_ini_znl( kumout )
[1345]	2410	!!----------------------------------------------------------------------
	2411	!! * routine mpp_ini_znl *
	2412	!!
	2413	!! ** Purpose : Initialize special communicator for computing zonal sum
	2414	!!
	2415	!! ** Method : - Look for processors in the same row
	2416	!! - Put their number in nrank_znl
	2417	!! - Create group for the znl processors
	2418	!! - Create a communicator for znl processors
	2419	!! - Determine if processor should write znl files
	2420	!!
	2421	!! ** output
	2422	!! ndim_rank_znl = number of processors on the same row
	2423	!! ngrp_znl = group ID for the znl processors
	2424	!! ncomm_znl = communicator for the ice procs.
	2425	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
	2426	!!
	2427	!!----------------------------------------------------------------------
[2715]	2428	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
[1345]	2429	!
[2715]	2430	INTEGER :: jproc ! dummy loop integer
	2431	INTEGER :: ierr, ii ! local integer
	2432	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
	2433	!!----------------------------------------------------------------------
[1345]	2434	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
	2435	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
	2436	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
	2437	!
[2715]	2438	ALLOCATE( kwork(jpnij), STAT=ierr )
	2439	IF( ierr /= 0 ) THEN
	2440	WRITE(kumout, cform_err)
	2441	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
	2442	CALL mppstop
	2443	ENDIF
	2444
	2445	IF( jpnj == 1 ) THEN
[1345]	2446	ngrp_znl = ngrp_world
	2447	ncomm_znl = mpi_comm_opa
	2448	ELSE
	2449	!
	2450	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
	2451	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
	2452	!-$$ CALL flush(numout)
	2453	!
	2454	! Count number of processors on the same row
	2455	ndim_rank_znl = 0
	2456	DO jproc=1,jpnij
	2457	IF ( kwork(jproc) == njmpp ) THEN
	2458	ndim_rank_znl = ndim_rank_znl + 1
	2459	ENDIF
	2460	END DO
	2461	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
	2462	!-$$ CALL flush(numout)
	2463	! Allocate the right size to nrank_znl
[1441]	2464	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]	2465	ALLOCATE(nrank_znl(ndim_rank_znl))
[3764]	2466	ii = 0
[1345]	2467	nrank_znl (:) = 0
	2468	DO jproc=1,jpnij
	2469	IF ( kwork(jproc) == njmpp) THEN
	2470	ii = ii + 1
[3764]	2471	nrank_znl(ii) = jproc -1
[1345]	2472	ENDIF
	2473	END DO
	2474	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
	2475	!-$$ CALL flush(numout)
	2476
	2477	! Create the opa group
	2478	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
	2479	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
	2480	!-$$ CALL flush(numout)
	2481
	2482	! Create the znl group from the opa group
	2483	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
	2484	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
	2485	!-$$ CALL flush(numout)
	2486
	2487	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
	2488	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
	2489	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
	2490	!-$$ CALL flush(numout)
	2491	!
	2492	END IF
	2493
	2494	! Determines if processor if the first (starting from i=1) on the row
[3764]	2495	IF ( jpni == 1 ) THEN
[1345]	2496	l_znl_root = .TRUE.
	2497	ELSE
	2498	l_znl_root = .FALSE.
	2499	kwork (1) = nimpp
	2500	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
	2501	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
	2502	END IF
	2503
[2715]	2504	DEALLOCATE(kwork)
	2505
[1345]	2506	END SUBROUTINE mpp_ini_znl
	2507
	2508
[1344]	2509	SUBROUTINE mpp_ini_north
	2510	!!----------------------------------------------------------------------
	2511	!! * routine mpp_ini_north *
	2512	!!
[3764]	2513	!! ** Purpose : Initialize special communicator for north folding
[1344]	2514	!! condition together with global variables needed in the mpp folding
	2515	!!
	2516	!! ** Method : - Look for northern processors
	2517	!! - Put their number in nrank_north
	2518	!! - Create groups for the world processors and the north processors
	2519	!! - Create a communicator for northern processors
	2520	!!
	2521	!! ** output
	2522	!! njmppmax = njmpp for northern procs
	2523	!! ndim_rank_north = number of processors in the northern line
	2524	!! nrank_north (ndim_rank_north) = number of the northern procs.
	2525	!! ngrp_world = group ID for the world processors
	2526	!! ngrp_north = group ID for the northern processors
	2527	!! ncomm_north = communicator for the northern procs.
	2528	!! north_root = number (in the world) of proc 0 in the northern comm.
	2529	!!
	2530	!!----------------------------------------------------------------------
	2531	INTEGER :: ierr
	2532	INTEGER :: jjproc
	2533	INTEGER :: ii, ji
	2534	!!----------------------------------------------------------------------
	2535	!
	2536	njmppmax = MAXVAL( njmppt )
	2537	!
	2538	! Look for how many procs on the northern boundary
	2539	ndim_rank_north = 0
	2540	DO jjproc = 1, jpnij
	2541	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
	2542	END DO
	2543	!
	2544	! Allocate the right size to nrank_north
[1441]	2545	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
[1344]	2546	ALLOCATE( nrank_north(ndim_rank_north) )
[869]	2547
[1344]	2548	! Fill the nrank_north array with proc. number of northern procs.
	2549	! Note : the rank start at 0 in MPI
	2550	ii = 0
	2551	DO ji = 1, jpnij
	2552	IF ( njmppt(ji) == njmppmax ) THEN
	2553	ii=ii+1
	2554	nrank_north(ii)=ji-1
	2555	END IF
	2556	END DO
	2557	!
	2558	! create the world group
	2559	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
	2560	!
	2561	! Create the North group from the world group
	2562	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
	2563	!
	2564	! Create the North communicator , ie the pool of procs in the north group
	2565	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
	2566	!
	2567	END SUBROUTINE mpp_ini_north
[869]	2568
	2569
[1344]	2570	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
[51]	2571	!!---------------------------------------------------------------------
	2572	!! * routine mpp_lbc_north_3d *
	2573	!!
[3764]	2574	!! ** Purpose : Ensure proper north fold horizontal bondary condition
[1344]	2575	!! in mpp configuration in case of jpn1 > 1
[51]	2576	!!
[1344]	2577	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2578	!! in i-direction require a specific treatment. We gather
[1344]	2579	!! the 4 northern lines of the global domain on 1 processor
	2580	!! and apply lbc north-fold on this sub array. Then we
	2581	!! scatter the north fold array back to the processors.
[51]	2582	!!
	2583	!!----------------------------------------------------------------------
[1344]	2584	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
	2585	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2586	! ! = T , U , V , F or W gridpoints
[3764]	2587	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
[1344]	2588	!! ! = 1. , the sign is kept
	2589	INTEGER :: ji, jj, jr
	2590	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2591	INTEGER :: ijpj, ijpjm1, ij, iproc
[3294]	2592	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
	2593	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
	2594	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
[51]	2595	!!----------------------------------------------------------------------
[3764]	2596	!
[1344]	2597	ijpj = 4
[3294]	2598	ityp = -1
[1344]	2599	ijpjm1 = 3
[3918]	2600	tab_3d(:,:,:) = 0.e0
[1344]	2601	!
[3918]	2602	DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d
[1344]	2603	ij = jj - nlcj + ijpj
[3918]	2604	xnorthloc(:,ij,:) = pt3d(:,jj,:)
[1344]	2605	END DO
	2606	!
[3918]	2607	! ! Build in procs of ncomm_north the xnorthgloio
[1344]	2608	itaille = jpi * jpk * ijpj
[3294]	2609	IF ( l_north_nogather ) THEN
	2610	!
[3764]	2611	! Avoid the use of mpi_allgather by exchanging only with the processes already identified
[3294]	2612	! (in nemo_northcomms) as being involved in this process' northern boundary exchange
	2613	!
	2614	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
	2615	ij = jj - nlcj + ijpj
	2616	DO ji = 1, nlci
[3918]	2617	tab_3d(ji+nimpp-1,ij,:) = pt3d(ji,jj,:)
[1344]	2618	END DO
	2619	END DO
[3294]	2620
	2621	!
	2622	! Set the exchange type in order to access the correct list of active neighbours
	2623	!
	2624	SELECT CASE ( cd_type )
	2625	CASE ( 'T' , 'W' )
	2626	ityp = 1
	2627	CASE ( 'U' )
	2628	ityp = 2
	2629	CASE ( 'V' )
	2630	ityp = 3
	2631	CASE ( 'F' )
	2632	ityp = 4
	2633	CASE ( 'I' )
	2634	ityp = 5
	2635	CASE DEFAULT
[3764]	2636	ityp = -1 ! Set a default value for unsupported types which
[3294]	2637	! will cause a fallback to the mpi_allgather method
	2638	END SELECT
	2639	IF ( ityp .gt. 0 ) THEN
	2640
	2641	DO jr = 1,nsndto(ityp)
[3918]	2642	CALL mppsend(5, xnorthloc, itaille, isendto(jr,ityp), ml_req_nf(jr) )
[3294]	2643	END DO
	2644	DO jr = 1,nsndto(ityp)
[3918]	2645	CALL mpprecv(5, foldwk, itaille, isendto(jr,ityp))
[3294]	2646	iproc = isendto(jr,ityp) + 1
	2647	ildi = nldit (iproc)
	2648	ilei = nleit (iproc)
	2649	iilb = nimppt(iproc)
	2650	DO jj = 1, ijpj
	2651	DO ji = ildi, ilei
[3918]	2652	tab_3d(ji+iilb-1,jj,:) = foldwk(ji,jj,:)
[3294]	2653	END DO
	2654	END DO
	2655	END DO
	2656	IF (l_isend) THEN
	2657	DO jr = 1,nsndto(ityp)
	2658	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
	2659	END DO
	2660	ENDIF
	2661
	2662	ENDIF
	2663
	2664	ENDIF
	2665
	2666	IF ( ityp .lt. 0 ) THEN
[3918]	2667	CALL MPI_ALLGATHER( xnorthloc , itaille, MPI_DOUBLE_PRECISION, &
	2668	& xnorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]	2669	!
	2670	DO jr = 1, ndim_rank_north ! recover the global north array
	2671	iproc = nrank_north(jr) + 1
	2672	ildi = nldit (iproc)
	2673	ilei = nleit (iproc)
	2674	iilb = nimppt(iproc)
	2675	DO jj = 1, ijpj
	2676	DO ji = ildi, ilei
[3918]	2677	tab_3d(ji+iilb-1,jj,:) = xnorthgloio(ji,jj,:,jr)
[3294]	2678	END DO
	2679	END DO
	2680	END DO
	2681	ENDIF
[1344]	2682	!
[3918]	2683	! The tab_3d array has been either:
[3294]	2684	! a. Fully populated by the mpi_allgather operation or
[3764]	2685	! b. Had the active points for this domain and northern neighbours populated
[3294]	2686	! by peer to peer exchanges
[3764]	2687	! Either way the array may be folded by lbc_nfd and the result for the span of
[3294]	2688	! this domain will be identical.
	2689	!
[3918]	2690	CALL lbc_nfd( tab_3d, cd_type, psgn ) ! North fold boundary condition
[1344]	2691	!
	2692	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
	2693	ij = jj - nlcj + ijpj
	2694	DO ji= 1, nlci
[3918]	2695	pt3d(ji,jj,:) = tab_3d(ji+nimpp-1,ij,:)
[1344]	2696	END DO
	2697	END DO
	2698	!
	2699	END SUBROUTINE mpp_lbc_north_3d
[3]	2700
	2701
[1344]	2702	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
	2703	!!---------------------------------------------------------------------
	2704	!! * routine mpp_lbc_north_2d *
	2705	!!
[3764]	2706	!! ** Purpose : Ensure proper north fold horizontal bondary condition
[1344]	2707	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
	2708	!!
	2709	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2710	!! in i-direction require a specific treatment. We gather
[1344]	2711	!! the 4 northern lines of the global domain on 1 processor
	2712	!! and apply lbc north-fold on this sub array. Then we
	2713	!! scatter the north fold array back to the processors.
	2714	!!
	2715	!!----------------------------------------------------------------------
	2716	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 3D array on which the b.c. is applied
	2717	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2718	! ! = T , U , V , F or W gridpoints
[3764]	2719	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
[1344]	2720	!! ! = 1. , the sign is kept
	2721	INTEGER :: ji, jj, jr
	2722	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2723	INTEGER :: ijpj, ijpjm1, ij, iproc
[3294]	2724	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather
	2725	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
	2726	INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather
[1344]	2727	!!----------------------------------------------------------------------
	2728	!
	2729	ijpj = 4
[3294]	2730	ityp = -1
[1344]	2731	ijpjm1 = 3
[3918]	2732	tab_2d(:,:) = 0.e0
[1344]	2733	!
[3918]	2734	DO jj = nlcj-ijpj+1, nlcj ! put in xnorthloc_2d the last 4 jlines of pt2d
[1344]	2735	ij = jj - nlcj + ijpj
[3918]	2736	xnorthloc_2d(:,ij) = pt2d(:,jj)
[1344]	2737	END DO
[3]	2738
[3918]	2739	! ! Build in procs of ncomm_north the xnorthgloio_2d
[1344]	2740	itaille = jpi * ijpj
[3294]	2741	IF ( l_north_nogather ) THEN
	2742	!
[3764]	2743	! Avoid the use of mpi_allgather by exchanging only with the processes already identified
[3294]	2744	! (in nemo_northcomms) as being involved in this process' northern boundary exchange
	2745	!
	2746	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
	2747	ij = jj - nlcj + ijpj
	2748	DO ji = 1, nlci
[3918]	2749	tab_2d(ji+nimpp-1,ij) = pt2d(ji,jj)
[13]	2750	END DO
	2751	END DO
[3294]	2752
	2753	!
	2754	! Set the exchange type in order to access the correct list of active neighbours
	2755	!
	2756	SELECT CASE ( cd_type )
	2757	CASE ( 'T' , 'W' )
	2758	ityp = 1
	2759	CASE ( 'U' )
	2760	ityp = 2
	2761	CASE ( 'V' )
	2762	ityp = 3
	2763	CASE ( 'F' )
	2764	ityp = 4
	2765	CASE ( 'I' )
	2766	ityp = 5
	2767	CASE DEFAULT
[3764]	2768	ityp = -1 ! Set a default value for unsupported types which
[3294]	2769	! will cause a fallback to the mpi_allgather method
	2770	END SELECT
	2771
	2772	IF ( ityp .gt. 0 ) THEN
	2773
	2774	DO jr = 1,nsndto(ityp)
[3918]	2775	CALL mppsend(5, xnorthloc_2d, itaille, isendto(jr,ityp), ml_req_nf(jr) )
[3294]	2776	END DO
	2777	DO jr = 1,nsndto(ityp)
[3918]	2778	CALL mpprecv(5, foldwk_2d, itaille, isendto(jr,ityp))
[3294]	2779	iproc = isendto(jr,ityp) + 1
	2780	ildi = nldit (iproc)
	2781	ilei = nleit (iproc)
	2782	iilb = nimppt(iproc)
	2783	DO jj = 1, ijpj
	2784	DO ji = ildi, ilei
[3918]	2785	tab_2d(ji+iilb-1,jj) = foldwk_2d(ji,jj)
[3294]	2786	END DO
	2787	END DO
	2788	END DO
	2789	IF (l_isend) THEN
	2790	DO jr = 1,nsndto(ityp)
	2791	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
	2792	END DO
	2793	ENDIF
	2794
	2795	ENDIF
	2796
	2797	ENDIF
	2798
	2799	IF ( ityp .lt. 0 ) THEN
[3918]	2800	CALL MPI_ALLGATHER( xnorthloc_2d , itaille, MPI_DOUBLE_PRECISION, &
	2801	& xnorthgloio_2d, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]	2802	!
	2803	DO jr = 1, ndim_rank_north ! recover the global north array
	2804	iproc = nrank_north(jr) + 1
	2805	ildi = nldit (iproc)
	2806	ilei = nleit (iproc)
	2807	iilb = nimppt(iproc)
	2808	DO jj = 1, ijpj
	2809	DO ji = ildi, ilei
[3918]	2810	tab_2d(ji+iilb-1,jj) = xnorthgloio_2d(ji,jj,jr)
[3294]	2811	END DO
	2812	END DO
	2813	END DO
	2814	ENDIF
[1344]	2815	!
[3918]	2816	! The tab array has been either:
[3294]	2817	! a. Fully populated by the mpi_allgather operation or
[3764]	2818	! b. Had the active points for this domain and northern neighbours populated
[3294]	2819	! by peer to peer exchanges
[3764]	2820	! Either way the array may be folded by lbc_nfd and the result for the span of
[3294]	2821	! this domain will be identical.
	2822	!
[3918]	2823	CALL lbc_nfd( tab_2d, cd_type, psgn ) ! North fold boundary condition
[1344]	2824	!
	2825	!
	2826	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
[13]	2827	ij = jj - nlcj + ijpj
[1344]	2828	DO ji = 1, nlci
[3918]	2829	pt2d(ji,jj) = tab_2d(ji+nimpp-1,ij)
[1344]	2830	END DO
[13]	2831	END DO
[1344]	2832	!
[13]	2833	END SUBROUTINE mpp_lbc_north_2d
[3]	2834
	2835
[1344]	2836	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
	2837	!!---------------------------------------------------------------------
	2838	!! * routine mpp_lbc_north_2d *
	2839	!!
[3764]	2840	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	2841	!! in mpp configuration in case of jpn1 > 1 and for 2d
[1344]	2842	!! array with outer extra halo
	2843	!!
	2844	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2845	!! in i-direction require a specific treatment. We gather
	2846	!! the 4+2*jpr2dj northern lines of the global domain on 1
	2847	!! processor and apply lbc north-fold on this sub array.
[1344]	2848	!! Then we scatter the north fold array back to the processors.
	2849	!!
	2850	!!----------------------------------------------------------------------
	2851	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
	2852	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2853	! ! = T , U , V , F or W -points
[3764]	2854	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
[1344]	2855	!! ! north fold, = 1. otherwise
	2856	INTEGER :: ji, jj, jr
	2857	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2858	INTEGER :: ijpj, ij, iproc
	2859	!!----------------------------------------------------------------------
	2860	!
	2861	ijpj=4
[3918]	2862	tab_e(:,:) = 0.e0
[311]	2863
[1344]	2864	ij=0
[3918]	2865	! put in xnorthloc_e the last 4 jlines of pt2d
[1344]	2866	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
	2867	ij = ij + 1
	2868	DO ji = 1, jpi
[3918]	2869	xnorthloc_e(ji,ij)=pt2d(ji,jj)
[1344]	2870	END DO
	2871	END DO
	2872	!
	2873	itaille = jpi * ( ijpj + 2 * jpr2dj )
[3918]	2874	CALL MPI_ALLGATHER( xnorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
	2875	& xnorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[1344]	2876	!
	2877	DO jr = 1, ndim_rank_north ! recover the global north array
	2878	iproc = nrank_north(jr) + 1
	2879	ildi = nldit (iproc)
	2880	ilei = nleit (iproc)
	2881	iilb = nimppt(iproc)
	2882	DO jj = 1, ijpj+2*jpr2dj
	2883	DO ji = ildi, ilei
[3918]	2884	tab_e(ji+iilb-1,jj) = xnorthgloio_e(ji,jj,jr)
[311]	2885	END DO
[1344]	2886	END DO
	2887	END DO
[311]	2888
	2889
[1344]	2890	! 2. North-Fold boundary conditions
	2891	! ----------------------------------
[3918]	2892	CALL lbc_nfd( tab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
[311]	2893
[1344]	2894	ij = jpr2dj
	2895	!! Scatter back to pt2d
	2896	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
[3764]	2897	ij = ij +1
[1344]	2898	DO ji= 1, nlci
[3918]	2899	pt2d(ji,jj) = tab_e(ji+nimpp-1,ij)
[311]	2900	END DO
	2901	END DO
[1344]	2902	!
[311]	2903	END SUBROUTINE mpp_lbc_north_e
	2904
[3680]	2905	SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
	2906	!!----------------------------------------------------------------------
	2907	!! * routine mpp_lnk_bdy_3d *
	2908	!!
	2909	!! ** Purpose : Message passing management
	2910	!!
	2911	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
	2912	!! between processors following neighboring subdomains.
	2913	!! domain parameters
	2914	!! nlci : first dimension of the local subdomain
	2915	!! nlcj : second dimension of the local subdomain
	2916	!! nbondi_bdy : mark for "east-west local boundary"
	2917	!! nbondj_bdy : mark for "north-south local boundary"
	2918	!! noea : number for local neighboring processors
	2919	!! nowe : number for local neighboring processors
	2920	!! noso : number for local neighboring processors
	2921	!! nono : number for local neighboring processors
	2922	!!
	2923	!! ** Action : ptab with update value at its periphery
	2924	!!
	2925	!!----------------------------------------------------------------------
[389]	2926
[3680]	2927	USE lbcnfd ! north fold
	2928
	2929	INCLUDE 'mpif.h'
	2930
	2931	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	2932	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	2933	! ! = T , U , V , F , W points
	2934	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	2935	! ! = 1. , the sign is kept
	2936	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	2937	INTEGER :: ji, jj, jk, jl ! dummy loop indices
	2938	INTEGER :: imigr, iihom, ijhom ! temporary integers
	2939	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	2940	REAL(wp) :: zland
	2941	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	2942	!!----------------------------------------------------------------------
	2943
	2944	zland = 0.e0
	2945
	2946	! 1. standard boundary treatment
	2947	! ------------------------------
	2948
	2949	! ! East-West boundaries
	2950	! !* Cyclic east-west
	2951
	2952	IF( nbondi == 2) THEN
	2953	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	2954	ptab( 1 ,:,:) = ptab(jpim1,:,:)
	2955	ptab(jpi,:,:) = ptab( 2 ,:,:)
	2956	ELSE
	2957	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	2958	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	2959	ENDIF
	2960	ELSEIF(nbondi == -1) THEN
	2961	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	2962	ELSEIF(nbondi == 1) THEN
	2963	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	2964	ENDIF !* closed
	2965
	2966	IF (nbondj == 2 .OR. nbondj == -1) THEN
	2967	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
	2968	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	2969	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
	2970	ENDIF
	2971
	2972	!
	2973
	2974	! 2. East and west directions exchange
	2975	! ------------------------------------
	2976	! we play with the neigbours AND the row number because of the periodicity
	2977	!
	2978	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
	2979	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	2980	iihom = nlci-nreci
	2981	DO jl = 1, jpreci
	2982	t3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
	2983	t3we(:,jl,:,1) = ptab(iihom +jl,:,:)
	2984	END DO
	2985	END SELECT
	2986	!
	2987	! ! Migrations
	2988	imigr = jpreci * jpj * jpk
	2989	!
	2990	SELECT CASE ( nbondi_bdy(ib_bdy) )
	2991	CASE ( -1 )
	2992	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req1 )
	2993	CASE ( 0 )
	2994	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	2995	CALL mppsend( 2, t3we(1,1,1,1), imigr, noea, ml_req2 )
	2996	CASE ( 1 )
	2997	CALL mppsend( 1, t3ew(1,1,1,1), imigr, nowe, ml_req1 )
	2998	END SELECT
	2999	!
	3000	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3001	CASE ( -1 )
	3002	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
	3003	CASE ( 0 )
	3004	CALL mpprecv( 1, t3ew(1,1,1,2), imigr, noea )
	3005	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
	3006	CASE ( 1 )
	3007	CALL mpprecv( 2, t3we(1,1,1,2), imigr, nowe )
	3008	END SELECT
	3009	!
	3010	SELECT CASE ( nbondi_bdy(ib_bdy) )
	3011	CASE ( -1 )
	3012	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3013	CASE ( 0 )
	3014	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3015	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3016	CASE ( 1 )
	3017	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3018	END SELECT
	3019	!
	3020	! ! Write Dirichlet lateral conditions
	3021	iihom = nlci-jpreci
	3022	!
	3023	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3024	CASE ( -1 )
	3025	DO jl = 1, jpreci
	3026	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	3027	END DO
	3028	CASE ( 0 )
	3029	DO jl = 1, jpreci
	3030	ptab(jl ,:,:) = t3we(:,jl,:,2)
	3031	ptab(iihom+jl,:,:) = t3ew(:,jl,:,2)
	3032	END DO
	3033	CASE ( 1 )
	3034	DO jl = 1, jpreci
	3035	ptab(jl ,:,:) = t3we(:,jl,:,2)
	3036	END DO
	3037	END SELECT
	3038
	3039
	3040	! 3. North and south directions
	3041	! -----------------------------
	3042	! always closed : we play only with the neigbours
	3043	!
	3044	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
	3045	ijhom = nlcj-nrecj
	3046	DO jl = 1, jprecj
	3047	t3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
	3048	t3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
	3049	END DO
	3050	ENDIF
	3051	!
	3052	! ! Migrations
	3053	imigr = jprecj * jpi * jpk
	3054	!
	3055	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3056	CASE ( -1 )
	3057	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req1 )
	3058	CASE ( 0 )
	3059	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	3060	CALL mppsend( 4, t3sn(1,1,1,1), imigr, nono, ml_req2 )
	3061	CASE ( 1 )
	3062	CALL mppsend( 3, t3ns(1,1,1,1), imigr, noso, ml_req1 )
	3063	END SELECT
	3064	!
	3065	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3066	CASE ( -1 )
	3067	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
	3068	CASE ( 0 )
	3069	CALL mpprecv( 3, t3ns(1,1,1,2), imigr, nono )
	3070	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
	3071	CASE ( 1 )
	3072	CALL mpprecv( 4, t3sn(1,1,1,2), imigr, noso )
	3073	END SELECT
	3074	!
	3075	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3076	CASE ( -1 )
	3077	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3078	CASE ( 0 )
	3079	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3080	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3081	CASE ( 1 )
	3082	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3083	END SELECT
	3084	!
	3085	! ! Write Dirichlet lateral conditions
	3086	ijhom = nlcj-jprecj
	3087	!
	3088	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3089	CASE ( -1 )
	3090	DO jl = 1, jprecj
	3091	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	3092	END DO
	3093	CASE ( 0 )
	3094	DO jl = 1, jprecj
	3095	ptab(:,jl ,:) = t3sn(:,jl,:,2)
	3096	ptab(:,ijhom+jl,:) = t3ns(:,jl,:,2)
	3097	END DO
	3098	CASE ( 1 )
	3099	DO jl = 1, jprecj
	3100	ptab(:,jl,:) = t3sn(:,jl,:,2)
	3101	END DO
	3102	END SELECT
	3103
	3104
	3105	! 4. north fold treatment
	3106	! -----------------------
	3107	!
	3108	IF( npolj /= 0) THEN
	3109	!
	3110	SELECT CASE ( jpni )
	3111	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	3112	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	3113	END SELECT
	3114	!
	3115	ENDIF
	3116	!
	3117	END SUBROUTINE mpp_lnk_bdy_3d
	3118
	3119	SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
	3120	!!----------------------------------------------------------------------
	3121	!! * routine mpp_lnk_bdy_2d *
	3122	!!
	3123	!! ** Purpose : Message passing management
	3124	!!
	3125	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
	3126	!! between processors following neighboring subdomains.
	3127	!! domain parameters
	3128	!! nlci : first dimension of the local subdomain
	3129	!! nlcj : second dimension of the local subdomain
	3130	!! nbondi_bdy : mark for "east-west local boundary"
	3131	!! nbondj_bdy : mark for "north-south local boundary"
	3132	!! noea : number for local neighboring processors
	3133	!! nowe : number for local neighboring processors
	3134	!! noso : number for local neighboring processors
	3135	!! nono : number for local neighboring processors
	3136	!!
	3137	!! ** Action : ptab with update value at its periphery
	3138	!!
	3139	!!----------------------------------------------------------------------
	3140
	3141	USE lbcnfd ! north fold
	3142
	3143	INCLUDE 'mpif.h'
	3144
	3145	REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	3146	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	3147	! ! = T , U , V , F , W points
	3148	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	3149	! ! = 1. , the sign is kept
	3150	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	3151	INTEGER :: ji, jj, jl ! dummy loop indices
	3152	INTEGER :: imigr, iihom, ijhom ! temporary integers
	3153	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	3154	REAL(wp) :: zland
	3155	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	3156	!!----------------------------------------------------------------------
	3157
	3158	zland = 0.e0
	3159
	3160	! 1. standard boundary treatment
	3161	! ------------------------------
	3162
	3163	! ! East-West boundaries
	3164	! !* Cyclic east-west
	3165
	3166	IF( nbondi == 2) THEN
	3167	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	3168	ptab( 1 ,:) = ptab(jpim1,:)
	3169	ptab(jpi,:) = ptab( 2 ,:)
	3170	ELSE
	3171	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
	3172	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
	3173	ENDIF
	3174	ELSEIF(nbondi == -1) THEN
	3175	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
	3176	ELSEIF(nbondi == 1) THEN
	3177	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
	3178	ENDIF !* closed
	3179
	3180	IF (nbondj == 2 .OR. nbondj == -1) THEN
	3181	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point
	3182	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	3183	ptab(:,nlcj-jprecj+1:jpj) = zland ! north
	3184	ENDIF
	3185
	3186	!
	3187
	3188	! 2. East and west directions exchange
	3189	! ------------------------------------
	3190	! we play with the neigbours AND the row number because of the periodicity
	3191	!
	3192	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
	3193	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	3194	iihom = nlci-nreci
	3195	DO jl = 1, jpreci
	3196	t2ew(:,jl,1) = ptab(jpreci+jl,:)
	3197	t2we(:,jl,1) = ptab(iihom +jl,:)
	3198	END DO
	3199	END SELECT
	3200	!
	3201	! ! Migrations
	3202	imigr = jpreci * jpj
	3203	!
	3204	SELECT CASE ( nbondi_bdy(ib_bdy) )
	3205	CASE ( -1 )
	3206	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req1 )
	3207	CASE ( 0 )
	3208	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	3209	CALL mppsend( 2, t2we(1,1,1), imigr, noea, ml_req2 )
	3210	CASE ( 1 )
	3211	CALL mppsend( 1, t2ew(1,1,1), imigr, nowe, ml_req1 )
	3212	END SELECT
	3213	!
	3214	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3215	CASE ( -1 )
	3216	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	3217	CASE ( 0 )
	3218	CALL mpprecv( 1, t2ew(1,1,2), imigr, noea )
	3219	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
	3220	CASE ( 1 )
	3221	CALL mpprecv( 2, t2we(1,1,2), imigr, nowe )
	3222	END SELECT
	3223	!
	3224	SELECT CASE ( nbondi_bdy(ib_bdy) )
	3225	CASE ( -1 )
	3226	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3227	CASE ( 0 )
	3228	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3229	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3230	CASE ( 1 )
	3231	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3232	END SELECT
	3233	!
	3234	! ! Write Dirichlet lateral conditions
	3235	iihom = nlci-jpreci
	3236	!
	3237	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3238	CASE ( -1 )
	3239	DO jl = 1, jpreci
	3240	ptab(iihom+jl,:) = t2ew(:,jl,2)
	3241	END DO
	3242	CASE ( 0 )
	3243	DO jl = 1, jpreci
	3244	ptab(jl ,:) = t2we(:,jl,2)
	3245	ptab(iihom+jl,:) = t2ew(:,jl,2)
	3246	END DO
	3247	CASE ( 1 )
	3248	DO jl = 1, jpreci
	3249	ptab(jl ,:) = t2we(:,jl,2)
	3250	END DO
	3251	END SELECT
	3252
	3253
	3254	! 3. North and south directions
	3255	! -----------------------------
	3256	! always closed : we play only with the neigbours
	3257	!
	3258	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
	3259	ijhom = nlcj-nrecj
	3260	DO jl = 1, jprecj
	3261	t2sn(:,jl,1) = ptab(:,ijhom +jl)
	3262	t2ns(:,jl,1) = ptab(:,jprecj+jl)
	3263	END DO
	3264	ENDIF
	3265	!
	3266	! ! Migrations
	3267	imigr = jprecj * jpi
	3268	!
	3269	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3270	CASE ( -1 )
	3271	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req1 )
	3272	CASE ( 0 )
	3273	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	3274	CALL mppsend( 4, t2sn(1,1,1), imigr, nono, ml_req2 )
	3275	CASE ( 1 )
	3276	CALL mppsend( 3, t2ns(1,1,1), imigr, noso, ml_req1 )
	3277	END SELECT
	3278	!
	3279	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3280	CASE ( -1 )
	3281	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	3282	CASE ( 0 )
	3283	CALL mpprecv( 3, t2ns(1,1,2), imigr, nono )
	3284	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
	3285	CASE ( 1 )
	3286	CALL mpprecv( 4, t2sn(1,1,2), imigr, noso )
	3287	END SELECT
	3288	!
	3289	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3290	CASE ( -1 )
	3291	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3292	CASE ( 0 )
	3293	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3294	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3295	CASE ( 1 )
	3296	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3297	END SELECT
	3298	!
	3299	! ! Write Dirichlet lateral conditions
	3300	ijhom = nlcj-jprecj
	3301	!
	3302	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3303	CASE ( -1 )
	3304	DO jl = 1, jprecj
	3305	ptab(:,ijhom+jl) = t2ns(:,jl,2)
	3306	END DO
	3307	CASE ( 0 )
	3308	DO jl = 1, jprecj
	3309	ptab(:,jl ) = t2sn(:,jl,2)
	3310	ptab(:,ijhom+jl) = t2ns(:,jl,2)
	3311	END DO
	3312	CASE ( 1 )
	3313	DO jl = 1, jprecj
	3314	ptab(:,jl) = t2sn(:,jl,2)
	3315	END DO
	3316	END SELECT
	3317
	3318
	3319	! 4. north fold treatment
	3320	! -----------------------
	3321	!
	3322	IF( npolj /= 0) THEN
	3323	!
	3324	SELECT CASE ( jpni )
	3325	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	3326	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	3327	END SELECT
	3328	!
	3329	ENDIF
	3330	!
	3331	END SUBROUTINE mpp_lnk_bdy_2d
	3332
[2481]	3333	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
[1344]	3334	!!---------------------------------------------------------------------
	3335	!! * routine mpp_init.opa *
	3336	!!
	3337	!! ** Purpose :: export and attach a MPI buffer for bsend
	3338	!!
	3339	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
	3340	!! but classical mpi_init
[3764]	3341	!!
	3342	!! History :: 01/11 :: IDRIS initial version for IBM only
[1344]	3343	!! 08/04 :: R. Benshila, generalisation
	3344	!!---------------------------------------------------------------------
[3764]	3345	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
[2481]	3346	INTEGER , INTENT(inout) :: ksft
	3347	INTEGER , INTENT( out) :: code
	3348	INTEGER :: ierr, ji
	3349	LOGICAL :: mpi_was_called
[1344]	3350	!!---------------------------------------------------------------------
	3351	!
	3352	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
[532]	3353	IF ( code /= MPI_SUCCESS ) THEN
[3764]	3354	DO ji = 1, SIZE(ldtxt)
[2481]	3355	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
[3764]	3356	END DO
[2481]	3357	WRITE(*, cform_err)
	3358	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
[1344]	3359	CALL mpi_abort( mpi_comm_world, code, ierr )
[532]	3360	ENDIF
[1344]	3361	!
	3362	IF( .NOT. mpi_was_called ) THEN
	3363	CALL mpi_init( code )
	3364	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
[532]	3365	IF ( code /= MPI_SUCCESS ) THEN
[3764]	3366	DO ji = 1, SIZE(ldtxt)
[2481]	3367	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	3368	END DO
	3369	WRITE(*, cform_err)
	3370	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
[532]	3371	CALL mpi_abort( mpi_comm_world, code, ierr )
	3372	ENDIF
	3373	ENDIF
[1344]	3374	!
[897]	3375	IF( nn_buffer > 0 ) THEN
[2481]	3376	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
[897]	3377	! Buffer allocation and attachment
[2481]	3378	ALLOCATE( tampon(nn_buffer), stat = ierr )
[3764]	3379	IF( ierr /= 0 ) THEN
	3380	DO ji = 1, SIZE(ldtxt)
[2481]	3381	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	3382	END DO
	3383	WRITE(*, cform_err)
	3384	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
	3385	CALL mpi_abort( mpi_comm_world, code, ierr )
	3386	END IF
	3387	CALL mpi_buffer_attach( tampon, nn_buffer, code )
[897]	3388	ENDIF
[1344]	3389	!
[13]	3390	END SUBROUTINE mpi_init_opa
[3]	3391
[1976]	3392	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
	3393	!!---------------------------------------------------------------------
	3394	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
	3395	!!
	3396	!! Modification of original codes written by David H. Bailey
	3397	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
	3398	!!---------------------------------------------------------------------
	3399	INTEGER, INTENT(in) :: ilen, itype
	3400	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
	3401	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
	3402	!
	3403	REAL(wp) :: zerr, zt1, zt2 ! local work variables
	3404	INTEGER :: ji, ztmp ! local scalar
	3405
	3406	ztmp = itype ! avoid compilation warning
	3407
	3408	DO ji=1,ilen
	3409	! Compute ydda + yddb using Knuth's trick.
	3410	zt1 = real(ydda(ji)) + real(yddb(ji))
	3411	zerr = zt1 - real(ydda(ji))
	3412	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
	3413	+ aimag(ydda(ji)) + aimag(yddb(ji))
	3414
	3415	! The result is zt1 + zt2, after normalization.
	3416	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
	3417	END DO
	3418
	3419	END SUBROUTINE DDPDD_MPI
	3420
[13]	3421	#else
	3422	!!----------------------------------------------------------------------
	3423	!! Default case: Dummy module share memory computing
	3424	!!----------------------------------------------------------------------
[2715]	3425	USE in_out_manager
[1976]	3426
[13]	3427	INTERFACE mpp_sum
[3294]	3428	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
[13]	3429	END INTERFACE
	3430	INTERFACE mpp_max
[681]	3431	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	3432	END INTERFACE
	3433	INTERFACE mpp_min
	3434	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	3435	END INTERFACE
	3436	INTERFACE mppobc
	3437	MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d
	3438	END INTERFACE
[1344]	3439	INTERFACE mpp_minloc
	3440	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	3441	END INTERFACE
	3442	INTERFACE mpp_maxloc
	3443	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	3444	END INTERFACE
[3]	3445
[13]	3446	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
[3294]	3447	LOGICAL, PUBLIC :: ln_nnogather = .FALSE. !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
[4145]	3448	INTEGER :: ncomm_ice
	3449	INTEGER, PUBLIC :: mpi_comm_opa !: opa local communicator
[2715]	3450	!!----------------------------------------------------------------------
[13]	3451	CONTAINS
[3]	3452
[2715]	3453	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
	3454	INTEGER, INTENT(in) :: kumout
	3455	lib_mpp_alloc = 0
	3456	END FUNCTION lib_mpp_alloc
	3457
	3458	FUNCTION mynode( ldtxt, kumnam, kstop, localComm ) RESULT (function_value)
[1579]	3459	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[3764]	3460	CHARACTER(len=*),DIMENSION(:) :: ldtxt
[2715]	3461	INTEGER :: kumnam, kstop
[4145]	3462	IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
	3463	function_value = 0
[1579]	3464	IF( .FALSE. ) ldtxt(:) = 'never done'
[13]	3465	END FUNCTION mynode
[3]	3466
[13]	3467	SUBROUTINE mppsync ! Dummy routine
	3468	END SUBROUTINE mppsync
[3]	3469
[869]	3470	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
[13]	3471	REAL , DIMENSION(:) :: parr
	3472	INTEGER :: kdim
[3764]	3473	INTEGER, OPTIONAL :: kcom
[869]	3474	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3475	END SUBROUTINE mpp_sum_as
[3]	3476
[869]	3477	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
[13]	3478	REAL , DIMENSION(:,:) :: parr
	3479	INTEGER :: kdim
[3764]	3480	INTEGER, OPTIONAL :: kcom
[869]	3481	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]	3482	END SUBROUTINE mpp_sum_a2s
[3]	3483
[869]	3484	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
[13]	3485	INTEGER, DIMENSION(:) :: karr
	3486	INTEGER :: kdim
[3764]	3487	INTEGER, OPTIONAL :: kcom
[869]	3488	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	3489	END SUBROUTINE mpp_sum_ai
[3]	3490
[869]	3491	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
[13]	3492	REAL :: psca
[3764]	3493	INTEGER, OPTIONAL :: kcom
[869]	3494	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]	3495	END SUBROUTINE mpp_sum_s
[2480]	3496
[869]	3497	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
[13]	3498	integer :: kint
[3764]	3499	INTEGER, OPTIONAL :: kcom
[869]	3500	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]	3501	END SUBROUTINE mpp_sum_i
	3502
[3294]	3503	SUBROUTINE mppsum_realdd( ytab, kcom )
	3504	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
	3505	INTEGER , INTENT( in ), OPTIONAL :: kcom
	3506	WRITE(,) 'mppsum_realdd: You should not have seen this print! error?', ytab
	3507	END SUBROUTINE mppsum_realdd
[3764]	3508
[3294]	3509	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	3510	INTEGER , INTENT( in ) :: kdim ! size of ytab
	3511	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
	3512	INTEGER , INTENT( in ), OPTIONAL :: kcom
	3513	WRITE(,) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
	3514	END SUBROUTINE mppsum_a_realdd
	3515
[869]	3516	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]	3517	REAL , DIMENSION(:) :: parr
	3518	INTEGER :: kdim
[3764]	3519	INTEGER, OPTIONAL :: kcom
[869]	3520	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3521	END SUBROUTINE mppmax_a_real
	3522
[869]	3523	SUBROUTINE mppmax_real( psca, kcom )
[13]	3524	REAL :: psca
[3764]	3525	INTEGER, OPTIONAL :: kcom
[869]	3526	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]	3527	END SUBROUTINE mppmax_real
	3528
[869]	3529	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]	3530	REAL , DIMENSION(:) :: parr
	3531	INTEGER :: kdim
[3764]	3532	INTEGER, OPTIONAL :: kcom
[869]	3533	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3534	END SUBROUTINE mppmin_a_real
	3535
[869]	3536	SUBROUTINE mppmin_real( psca, kcom )
[13]	3537	REAL :: psca
[3764]	3538	INTEGER, OPTIONAL :: kcom
[869]	3539	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]	3540	END SUBROUTINE mppmin_real
	3541
[869]	3542	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]	3543	INTEGER, DIMENSION(:) :: karr
	3544	INTEGER :: kdim
[3764]	3545	INTEGER, OPTIONAL :: kcom
[888]	3546	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]	3547	END SUBROUTINE mppmax_a_int
	3548
[869]	3549	SUBROUTINE mppmax_int( kint, kcom)
[681]	3550	INTEGER :: kint
[3764]	3551	INTEGER, OPTIONAL :: kcom
[869]	3552	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]	3553	END SUBROUTINE mppmax_int
	3554
[869]	3555	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]	3556	INTEGER, DIMENSION(:) :: karr
	3557	INTEGER :: kdim
[3764]	3558	INTEGER, OPTIONAL :: kcom
[869]	3559	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	3560	END SUBROUTINE mppmin_a_int
	3561
[869]	3562	SUBROUTINE mppmin_int( kint, kcom )
[13]	3563	INTEGER :: kint
[3764]	3564	INTEGER, OPTIONAL :: kcom
[869]	3565	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]	3566	END SUBROUTINE mppmin_int
	3567
[2715]	3568	SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
	3569	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
[1344]	3570	REAL, DIMENSION(:) :: parr ! variable array
[2715]	3571	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1), kd1, kd2, kl, kk, ktype, kij, knum
[13]	3572	END SUBROUTINE mppobc_1d
	3573
[2715]	3574	SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
	3575	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
[1344]	3576	REAL, DIMENSION(:,:) :: parr ! variable array
[2715]	3577	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]	3578	END SUBROUTINE mppobc_2d
	3579
[2715]	3580	SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
	3581	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
[1344]	3582	REAL, DIMENSION(:,:,:) :: parr ! variable array
[2715]	3583	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]	3584	END SUBROUTINE mppobc_3d
	3585
[2715]	3586	SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij, knum )
	3587	INTEGER :: kd1, kd2, kl , kk, ktype, kij, knum
[1344]	3588	REAL, DIMENSION(:,:,:,:) :: parr ! variable array
[2715]	3589	WRITE(,) 'mppobc: You should not have seen this print! error?', parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij, knum
[13]	3590	END SUBROUTINE mppobc_4d
	3591
[1344]	3592	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]	3593	REAL :: pmin
	3594	REAL , DIMENSION (:,:) :: ptab, pmask
	3595	INTEGER :: ki, kj
[1528]	3596	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]	3597	END SUBROUTINE mpp_minloc2d
	3598
[1344]	3599	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]	3600	REAL :: pmin
	3601	REAL , DIMENSION (:,:,:) :: ptab, pmask
	3602	INTEGER :: ki, kj, kk
[1528]	3603	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	3604	END SUBROUTINE mpp_minloc3d
	3605
[1344]	3606	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]	3607	REAL :: pmax
	3608	REAL , DIMENSION (:,:) :: ptab, pmask
	3609	INTEGER :: ki, kj
[1528]	3610	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]	3611	END SUBROUTINE mpp_maxloc2d
	3612
[1344]	3613	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]	3614	REAL :: pmax
	3615	REAL , DIMENSION (:,:,:) :: ptab, pmask
	3616	INTEGER :: ki, kj, kk
[1528]	3617	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	3618	END SUBROUTINE mpp_maxloc3d
	3619
[51]	3620	SUBROUTINE mppstop
[3799]	3621	STOP ! non MPP case, just stop the run
[51]	3622	END SUBROUTINE mppstop
	3623
[2715]	3624	SUBROUTINE mpp_ini_ice( kcom, knum )
	3625	INTEGER :: kcom, knum
	3626	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
[888]	3627	END SUBROUTINE mpp_ini_ice
[869]	3628
[2715]	3629	SUBROUTINE mpp_ini_znl( knum )
	3630	INTEGER :: knum
	3631	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
[1345]	3632	END SUBROUTINE mpp_ini_znl
	3633
[1344]	3634	SUBROUTINE mpp_comm_free( kcom )
[869]	3635	INTEGER :: kcom
[1344]	3636	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]	3637	END SUBROUTINE mpp_comm_free
[3]	3638	#endif
[2715]	3639
[13]	3640	!!----------------------------------------------------------------------
[2715]	3641	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn routines
	3642	!!----------------------------------------------------------------------
	3643
	3644	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
	3645	& cd6, cd7, cd8, cd9, cd10 )
	3646	!!----------------------------------------------------------------------
	3647	!! * ROUTINE stop_opa *
	3648	!!
[3764]	3649	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	3650	!! increment the error number (nstop) by one.
	3651	!!----------------------------------------------------------------------
	3652	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	3653	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	3654	!!----------------------------------------------------------------------
	3655	!
[3764]	3656	nstop = nstop + 1
[2715]	3657	IF(lwp) THEN
	3658	WRITE(numout,cform_err)
	3659	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	3660	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	3661	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	3662	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	3663	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	3664	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	3665	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	3666	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	3667	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	3668	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	3669	ENDIF
	3670	CALL FLUSH(numout )
	3671	IF( numstp /= -1 ) CALL FLUSH(numstp )
	3672	IF( numsol /= -1 ) CALL FLUSH(numsol )
	3673	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
	3674	!
	3675	IF( cd1 == 'STOP' ) THEN
	3676	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
	3677	CALL mppstop()
	3678	ENDIF
	3679	!
	3680	END SUBROUTINE ctl_stop
	3681
	3682
	3683	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
	3684	& cd6, cd7, cd8, cd9, cd10 )
	3685	!!----------------------------------------------------------------------
	3686	!! * ROUTINE stop_warn *
	3687	!!
[3764]	3688	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	3689	!! increment the warning number (nwarn) by one.
	3690	!!----------------------------------------------------------------------
	3691	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	3692	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	3693	!!----------------------------------------------------------------------
[3764]	3694	!
	3695	nwarn = nwarn + 1
[2715]	3696	IF(lwp) THEN
	3697	WRITE(numout,cform_war)
	3698	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	3699	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	3700	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	3701	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	3702	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	3703	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	3704	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	3705	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	3706	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	3707	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	3708	ENDIF
	3709	CALL FLUSH(numout)
	3710	!
	3711	END SUBROUTINE ctl_warn
	3712
	3713
	3714	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
	3715	!!----------------------------------------------------------------------
	3716	!! * ROUTINE ctl_opn *
	3717	!!
	3718	!! ** Purpose : Open file and check if required file is available.
	3719	!!
	3720	!! ** Method : Fortan open
	3721	!!----------------------------------------------------------------------
	3722	INTEGER , INTENT( out) :: knum ! logical unit to open
	3723	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
	3724	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
	3725	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
	3726	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
	3727	INTEGER , INTENT(in ) :: klengh ! record length
	3728	INTEGER , INTENT(in ) :: kout ! number of logical units for write
	3729	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
	3730	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
	3731	!!
	3732	CHARACTER(len=80) :: clfile
	3733	INTEGER :: iost
	3734	!!----------------------------------------------------------------------
	3735
	3736	! adapt filename
	3737	! ----------------
	3738	clfile = TRIM(cdfile)
	3739	IF( PRESENT( karea ) ) THEN
	3740	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
	3741	ENDIF
	3742	#if defined key_agrif
	3743	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
	3744	knum=Agrif_Get_Unit()
	3745	#else
	3746	knum=get_unit()
	3747	#endif
	3748
	3749	iost=0
	3750	IF( cdacce(1:6) == 'DIRECT' ) THEN
	3751	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
	3752	ELSE
	3753	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
	3754	ENDIF
	3755	IF( iost == 0 ) THEN
	3756	IF(ldwp) THEN
	3757	WRITE(kout,*) ' file : ', clfile,' open ok'
	3758	WRITE(kout,*) ' unit = ', knum
	3759	WRITE(kout,*) ' status = ', cdstat
	3760	WRITE(kout,*) ' form = ', cdform
	3761	WRITE(kout,*) ' access = ', cdacce
	3762	WRITE(kout,*)
	3763	ENDIF
	3764	ENDIF
	3765	100 CONTINUE
	3766	IF( iost /= 0 ) THEN
	3767	IF(ldwp) THEN
	3768	WRITE(kout,*)
	3769	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
	3770	WRITE(kout,*) ' ======= === '
	3771	WRITE(kout,*) ' unit = ', knum
	3772	WRITE(kout,*) ' status = ', cdstat
	3773	WRITE(kout,*) ' form = ', cdform
	3774	WRITE(kout,*) ' access = ', cdacce
	3775	WRITE(kout,*) ' iostat = ', iost
	3776	WRITE(kout,*) ' we stop. verify the file '
	3777	WRITE(kout,*)
	3778	ENDIF
	3779	STOP 'ctl_opn bad opening'
	3780	ENDIF
[3764]	3781
[2715]	3782	END SUBROUTINE ctl_opn
	3783
	3784
	3785	INTEGER FUNCTION get_unit()
	3786	!!----------------------------------------------------------------------
	3787	!! * FUNCTION get_unit *
	3788	!!
	3789	!! ** Purpose : return the index of an unused logical unit
	3790	!!----------------------------------------------------------------------
[3764]	3791	LOGICAL :: llopn
[2715]	3792	!!----------------------------------------------------------------------
	3793	!
	3794	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
	3795	llopn = .TRUE.
	3796	DO WHILE( (get_unit < 998) .AND. llopn )
	3797	get_unit = get_unit + 1
	3798	INQUIRE( unit = get_unit, opened = llopn )
	3799	END DO
	3800	IF( (get_unit == 999) .AND. llopn ) THEN
	3801	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
	3802	get_unit = -1
	3803	ENDIF
	3804	!
	3805	END FUNCTION get_unit
	3806
	3807	!!----------------------------------------------------------------------
[3]	3808	END MODULE lib_mpp

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

Download in other formats: