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

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 5429

Last change on this file since 5429 was 5429, checked in by smasson, 9 years ago
merge dev_r5302_CNRS18_HPC_scalability into the trunk, see #1523
Property svn:keywords set to `Id`
File size: 164.3 KB

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

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

Download in other formats: