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/UKMO/dev_r5518_GO6M_dev/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_GO6M_dev/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 8200

Last change on this file since 8200 was 8200, checked in by frrh, 7 years ago

Merge branches/UKMO/dev_r5518_GC3_couple_pkg@7985 using command:

svn merge -r 6574:7985 svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/UKMO/dev_r5518_GC3_couple_pkg

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

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

Download in other formats: