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

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

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

Context Navigation

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

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

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

Download in other formats: