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

Context Navigation

source: branches/2017/dev_r7832_HPC08_lbclnk_3rd_dim/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 7897

Last change on this file since 7897 was 7897, checked in by gm, 7 years ago
#1880: (HPC-08) 3D lbc_lnk with any 3rd dim + regroup global comm in stpctl.F90
Property svn:keywords set to `Id`
File size: 187.0 KB

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

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

Download in other formats: