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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

lib_mpp.F90 in branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2015/dev_r5546_CNRS19_HPC_scalability/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5579

Last change on this file since 5579 was 5579, checked in by mcastril, 9 years ago
ticket #1539 Performance optimizations on NEMO 3.6 limhdf routine
Property svn:keywords set to `Id`
File size: 172.7 KB

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

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

Download in other formats: