Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

lib_mpp.F90 @ 6808

Last change on this file since 6808 was 6808, checked in by jamesharle, 8 years ago
merge with trunk@6232 for consistency with SSB code
Property svn:keywords set to `Id`
File size: 179.0 KB

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

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6808

Download in other formats: