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

Context Navigation

source: branches/2016/dev_r6519_HPC_4/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6748

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

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

Download in other formats: