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

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

lib_mpp.F90 in branches/UKMO/dev_r5518_clean_shutdown/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_clean_shutdown/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6897

Last change on this file since 6897 was 5675, checked in by dancopsey, 9 years ago
Applied clean shutdown code imported from Met Office internal branch http://fcm2/projects/NEMO/browser/NEMO/branches/dev/frrh/vn3.5_beta_clean_shutdown
File size: 164.7 KB

Rev	Line
[3]	1	MODULE lib_mpp
[13]	2	!!======================================================================
	3	!! * MODULE lib_mpp *
[1344]	4	!! Ocean numerics: massively parallel processing library
[13]	5	!!=====================================================================
[1344]	6	!! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code
	7	!! 7.0 ! 1997 (A.M. Treguier) SHMEM additions
	8	!! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
	9	!! ! 1998 (J.M. Molines) Open boundary conditions
	10	!! NEMO 1.0 ! 2003 (J.-M. Molines, G. Madec) F90, free form
	11	!! ! 2003 (J.M. Molines) add mpp_ini_north(_3d,_2d)
	12	!! - ! 2004 (R. Bourdalle Badie) isend option in mpi
	13	!! ! 2004 (J.M. Molines) minloc, maxloc
	14	!! - ! 2005 (G. Madec, S. Masson) npolj=5,6 F-point & ice cases
	15	!! - ! 2005 (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort
	16	!! - ! 2005 (R. Benshila, G. Madec) add extra halo case
	17	!! - ! 2008 (R. Benshila) add mpp_ini_ice
	18	!! 3.2 ! 2009 (R. Benshila) SHMEM suppression, north fold in lbc_nfd
[3764]	19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
[2715]	20	!! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager
[3680]	21	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add 'mpp_lnk_bdy_3d', 'mpp_lnk_obc_3d',
	22	!! 'mpp_lnk_bdy_2d' and 'mpp_lnk_obc_2d' routines and update
	23	!! the mppobc routine to optimize the BDY and OBC communications
[4230]	24	!! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables
	25	!! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
[13]	26	!!----------------------------------------------------------------------
[2715]	27
	28	!!----------------------------------------------------------------------
	29	!! ctl_stop : update momentum and tracer Kz from a tke scheme
	30	!! ctl_warn : initialization, namelist read, and parameters control
	31	!! ctl_opn : Open file and check if required file is available.
[4147]	32	!! ctl_nam : Prints informations when an error occurs while reading a namelist
	33	!! get_unit : give the index of an unused logical unit
[2715]	34	!!----------------------------------------------------------------------
[3764]	35	#if defined key_mpp_mpi
[13]	36	!!----------------------------------------------------------------------
[1344]	37	!! 'key_mpp_mpi' MPI massively parallel processing library
	38	!!----------------------------------------------------------------------
[2715]	39	!! lib_mpp_alloc : allocate mpp arrays
	40	!! mynode : indentify the processor unit
	41	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
[473]	42	!! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays
[2715]	43	!! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e)
[4990]	44	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
[2715]	45	!! mpprecv :
	46	!! mppsend : SUBROUTINE mpp_ini_znl
	47	!! mppscatter :
	48	!! mppgather :
	49	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
	50	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
	51	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
	52	!! mpp_minloc :
	53	!! mpp_maxloc :
	54	!! mppsync :
	55	!! mppstop :
[1344]	56	!! mpp_ini_north : initialisation of north fold
	57	!! mpp_lbc_north : north fold processors gathering
	58	!! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo
[4990]	59	!! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs
[13]	60	!!----------------------------------------------------------------------
[3764]	61	USE dom_oce ! ocean space and time domain
[2715]	62	USE lbcnfd ! north fold treatment
	63	USE in_out_manager ! I/O manager
[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
[5675]	2008
	2009	#if defined key_oasis3 \|\| defined key_oasis3mct
	2010
	2011	#if defined key_oasis3mct
	2012	USE mod_oasis
	2013	#endif
	2014
	2015	#endif
[1344]	2016	!!----------------------------------------------------------------------
	2017	!! * routine mppstop *
[3764]	2018	!!
[3294]	2019	!! ** purpose : Stop massively parallel processors method
[1344]	2020	!!
	2021	!!----------------------------------------------------------------------
	2022	INTEGER :: info
	2023	!!----------------------------------------------------------------------
	2024	!
[5675]	2025	#if defined key_oasis3 \|\| defined key_oasis3mct
	2026	! If we're trying to shut down cleanly then we need to consider the fact
	2027	! that this could be part of an MPMD configuration - we don't want to
	2028	! leave other components deadlocked.
	2029
	2030	CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
	2031
	2032	#else
	2033
[1344]	2034	CALL mppsync
	2035	CALL mpi_finalize( info )
[5675]	2036
	2037	#endif
[1344]	2038	END SUBROUTINE mppstop
[3]	2039
	2040
[1344]	2041	SUBROUTINE mpp_comm_free( kcom )
	2042	!!----------------------------------------------------------------------
	2043	!!----------------------------------------------------------------------
	2044	INTEGER, INTENT(in) :: kcom
	2045	!!
	2046	INTEGER :: ierr
	2047	!!----------------------------------------------------------------------
	2048	!
	2049	CALL MPI_COMM_FREE(kcom, ierr)
	2050	!
	2051	END SUBROUTINE mpp_comm_free
[3]	2052
[869]	2053
[2715]	2054	SUBROUTINE mpp_ini_ice( pindic, kumout )
[1344]	2055	!!----------------------------------------------------------------------
	2056	!! * routine mpp_ini_ice *
	2057	!!
	2058	!! ** Purpose : Initialize special communicator for ice areas
	2059	!! condition together with global variables needed in the ddmpp folding
	2060	!!
	2061	!! ** Method : - Look for ice processors in ice routines
	2062	!! - Put their number in nrank_ice
	2063	!! - Create groups for the world processors and the ice processors
	2064	!! - Create a communicator for ice processors
	2065	!!
	2066	!! ** output
	2067	!! njmppmax = njmpp for northern procs
	2068	!! ndim_rank_ice = number of processors with ice
	2069	!! nrank_ice (ndim_rank_ice) = ice processors
[3625]	2070	!! ngrp_iworld = group ID for the world processors
[1344]	2071	!! ngrp_ice = group ID for the ice processors
	2072	!! ncomm_ice = communicator for the ice procs.
	2073	!! n_ice_root = number (in the world) of proc 0 in the ice comm.
	2074	!!
	2075	!!----------------------------------------------------------------------
[2715]	2076	INTEGER, INTENT(in) :: pindic
	2077	INTEGER, INTENT(in) :: kumout ! ocean.output logical unit
[1344]	2078	!!
	2079	INTEGER :: jjproc
[2715]	2080	INTEGER :: ii, ierr
	2081	INTEGER, ALLOCATABLE, DIMENSION(:) :: kice
	2082	INTEGER, ALLOCATABLE, DIMENSION(:) :: zwork
[1344]	2083	!!----------------------------------------------------------------------
	2084	!
[2715]	2085	! Since this is just an init routine and these arrays are of length jpnij
	2086	! then don't use wrk_nemo module - just allocate and deallocate.
	2087	ALLOCATE( kice(jpnij), zwork(jpnij), STAT=ierr )
	2088	IF( ierr /= 0 ) THEN
	2089	WRITE(kumout, cform_err)
	2090	WRITE(kumout,*) 'mpp_ini_ice : failed to allocate 2, 1D arrays (jpnij in length)'
	2091	CALL mppstop
	2092	ENDIF
	2093
[1344]	2094	! Look for how many procs with sea-ice
	2095	!
	2096	kice = 0
	2097	DO jjproc = 1, jpnij
[3764]	2098	IF( jjproc == narea .AND. pindic .GT. 0 ) kice(jjproc) = 1
[1344]	2099	END DO
	2100	!
	2101	zwork = 0
	2102	CALL MPI_ALLREDUCE( kice, zwork, jpnij, mpi_integer, mpi_sum, mpi_comm_opa, ierr )
[3764]	2103	ndim_rank_ice = SUM( zwork )
[3]	2104
[1344]	2105	! Allocate the right size to nrank_north
[1441]	2106	IF( ALLOCATED ( nrank_ice ) ) DEALLOCATE( nrank_ice )
[1344]	2107	ALLOCATE( nrank_ice(ndim_rank_ice) )
	2108	!
[3764]	2109	ii = 0
[1344]	2110	nrank_ice = 0
	2111	DO jjproc = 1, jpnij
	2112	IF( zwork(jjproc) == 1) THEN
	2113	ii = ii + 1
[3764]	2114	nrank_ice(ii) = jjproc -1
[1344]	2115	ENDIF
	2116	END DO
[1208]	2117
[1344]	2118	! Create the world group
[3625]	2119	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_iworld, ierr )
[869]	2120
[1344]	2121	! Create the ice group from the world group
[3625]	2122	CALL MPI_GROUP_INCL( ngrp_iworld, ndim_rank_ice, nrank_ice, ngrp_ice, ierr )
[869]	2123
[1344]	2124	! Create the ice communicator , ie the pool of procs with sea-ice
	2125	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_ice, ncomm_ice, ierr )
[869]	2126
[1344]	2127	! Find proc number in the world of proc 0 in the north
	2128	! The following line seems to be useless, we just comment & keep it as reminder
[3625]	2129	! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_iworld,n_ice_root,ierr)
[1344]	2130	!
[3625]	2131	CALL MPI_GROUP_FREE(ngrp_ice, ierr)
	2132	CALL MPI_GROUP_FREE(ngrp_iworld, ierr)
	2133
[2715]	2134	DEALLOCATE(kice, zwork)
	2135	!
[1344]	2136	END SUBROUTINE mpp_ini_ice
[869]	2137
	2138
[2715]	2139	SUBROUTINE mpp_ini_znl( kumout )
[1345]	2140	!!----------------------------------------------------------------------
	2141	!! * routine mpp_ini_znl *
	2142	!!
	2143	!! ** Purpose : Initialize special communicator for computing zonal sum
	2144	!!
	2145	!! ** Method : - Look for processors in the same row
	2146	!! - Put their number in nrank_znl
	2147	!! - Create group for the znl processors
	2148	!! - Create a communicator for znl processors
	2149	!! - Determine if processor should write znl files
	2150	!!
	2151	!! ** output
	2152	!! ndim_rank_znl = number of processors on the same row
	2153	!! ngrp_znl = group ID for the znl processors
	2154	!! ncomm_znl = communicator for the ice procs.
	2155	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
	2156	!!
	2157	!!----------------------------------------------------------------------
[2715]	2158	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
[1345]	2159	!
[2715]	2160	INTEGER :: jproc ! dummy loop integer
	2161	INTEGER :: ierr, ii ! local integer
	2162	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
	2163	!!----------------------------------------------------------------------
[1345]	2164	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
	2165	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
	2166	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_opa : ', mpi_comm_opa
	2167	!
[2715]	2168	ALLOCATE( kwork(jpnij), STAT=ierr )
	2169	IF( ierr /= 0 ) THEN
	2170	WRITE(kumout, cform_err)
	2171	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
	2172	CALL mppstop
	2173	ENDIF
	2174
	2175	IF( jpnj == 1 ) THEN
[1345]	2176	ngrp_znl = ngrp_world
	2177	ncomm_znl = mpi_comm_opa
	2178	ELSE
	2179	!
	2180	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_opa, ierr )
	2181	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
	2182	!-$$ CALL flush(numout)
	2183	!
	2184	! Count number of processors on the same row
	2185	ndim_rank_znl = 0
	2186	DO jproc=1,jpnij
	2187	IF ( kwork(jproc) == njmpp ) THEN
	2188	ndim_rank_znl = ndim_rank_znl + 1
	2189	ENDIF
	2190	END DO
	2191	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
	2192	!-$$ CALL flush(numout)
	2193	! Allocate the right size to nrank_znl
[1441]	2194	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]	2195	ALLOCATE(nrank_znl(ndim_rank_znl))
[3764]	2196	ii = 0
[1345]	2197	nrank_znl (:) = 0
	2198	DO jproc=1,jpnij
	2199	IF ( kwork(jproc) == njmpp) THEN
	2200	ii = ii + 1
[3764]	2201	nrank_znl(ii) = jproc -1
[1345]	2202	ENDIF
	2203	END DO
	2204	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
	2205	!-$$ CALL flush(numout)
	2206
	2207	! Create the opa group
	2208	CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_opa,ierr)
	2209	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
	2210	!-$$ CALL flush(numout)
	2211
	2212	! Create the znl group from the opa group
	2213	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
	2214	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
	2215	!-$$ CALL flush(numout)
	2216
	2217	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
	2218	CALL MPI_COMM_CREATE ( mpi_comm_opa, ngrp_znl, ncomm_znl, ierr )
	2219	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
	2220	!-$$ CALL flush(numout)
	2221	!
	2222	END IF
	2223
	2224	! Determines if processor if the first (starting from i=1) on the row
[3764]	2225	IF ( jpni == 1 ) THEN
[1345]	2226	l_znl_root = .TRUE.
	2227	ELSE
	2228	l_znl_root = .FALSE.
	2229	kwork (1) = nimpp
	2230	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
	2231	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
	2232	END IF
	2233
[2715]	2234	DEALLOCATE(kwork)
	2235
[1345]	2236	END SUBROUTINE mpp_ini_znl
	2237
	2238
[1344]	2239	SUBROUTINE mpp_ini_north
	2240	!!----------------------------------------------------------------------
	2241	!! * routine mpp_ini_north *
	2242	!!
[3764]	2243	!! ** Purpose : Initialize special communicator for north folding
[1344]	2244	!! condition together with global variables needed in the mpp folding
	2245	!!
	2246	!! ** Method : - Look for northern processors
	2247	!! - Put their number in nrank_north
	2248	!! - Create groups for the world processors and the north processors
	2249	!! - Create a communicator for northern processors
	2250	!!
	2251	!! ** output
	2252	!! njmppmax = njmpp for northern procs
	2253	!! ndim_rank_north = number of processors in the northern line
	2254	!! nrank_north (ndim_rank_north) = number of the northern procs.
	2255	!! ngrp_world = group ID for the world processors
	2256	!! ngrp_north = group ID for the northern processors
	2257	!! ncomm_north = communicator for the northern procs.
	2258	!! north_root = number (in the world) of proc 0 in the northern comm.
	2259	!!
	2260	!!----------------------------------------------------------------------
	2261	INTEGER :: ierr
	2262	INTEGER :: jjproc
	2263	INTEGER :: ii, ji
	2264	!!----------------------------------------------------------------------
	2265	!
	2266	njmppmax = MAXVAL( njmppt )
	2267	!
	2268	! Look for how many procs on the northern boundary
	2269	ndim_rank_north = 0
	2270	DO jjproc = 1, jpnij
	2271	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
	2272	END DO
	2273	!
	2274	! Allocate the right size to nrank_north
[1441]	2275	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
[1344]	2276	ALLOCATE( nrank_north(ndim_rank_north) )
[869]	2277
[1344]	2278	! Fill the nrank_north array with proc. number of northern procs.
	2279	! Note : the rank start at 0 in MPI
	2280	ii = 0
	2281	DO ji = 1, jpnij
	2282	IF ( njmppt(ji) == njmppmax ) THEN
	2283	ii=ii+1
	2284	nrank_north(ii)=ji-1
	2285	END IF
	2286	END DO
	2287	!
	2288	! create the world group
	2289	CALL MPI_COMM_GROUP( mpi_comm_opa, ngrp_world, ierr )
	2290	!
	2291	! Create the North group from the world group
	2292	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
	2293	!
	2294	! Create the North communicator , ie the pool of procs in the north group
	2295	CALL MPI_COMM_CREATE( mpi_comm_opa, ngrp_north, ncomm_north, ierr )
	2296	!
	2297	END SUBROUTINE mpp_ini_north
[869]	2298
	2299
[1344]	2300	SUBROUTINE mpp_lbc_north_3d( pt3d, cd_type, psgn )
[51]	2301	!!---------------------------------------------------------------------
	2302	!! * routine mpp_lbc_north_3d *
	2303	!!
[3764]	2304	!! ** Purpose : Ensure proper north fold horizontal bondary condition
[1344]	2305	!! in mpp configuration in case of jpn1 > 1
[51]	2306	!!
[1344]	2307	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2308	!! in i-direction require a specific treatment. We gather
[1344]	2309	!! the 4 northern lines of the global domain on 1 processor
	2310	!! and apply lbc north-fold on this sub array. Then we
	2311	!! scatter the north fold array back to the processors.
[51]	2312	!!
	2313	!!----------------------------------------------------------------------
[1344]	2314	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pt3d ! 3D array on which the b.c. is applied
	2315	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2316	! ! = T , U , V , F or W gridpoints
[4230]	2317	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
[1344]	2318	!! ! = 1. , the sign is kept
[4230]	2319	INTEGER :: ji, jj, jr, jk
[1344]	2320	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2321	INTEGER :: ijpj, ijpjm1, ij, iproc
[4230]	2322	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather
[3294]	2323	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
	2324	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather
[4152]	2325	! ! Workspace for message transfers avoiding mpi_allgather
	2326	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab
	2327	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk
	2328	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio
[4230]	2329	REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr
[4152]	2330
[4230]	2331	INTEGER :: istatus(mpi_status_size)
	2332	INTEGER :: iflag
[51]	2333	!!----------------------------------------------------------------------
[3764]	2334	!
[4230]	2335	ALLOCATE( ztab(jpiglo,4,jpk) , znorthloc(jpi,4,jpk), zfoldwk(jpi,4,jpk), znorthgloio(jpi,4,jpk,jpni) )
	2336	ALLOCATE( ztabl(jpi,4,jpk), ztabr(jpi*jpmaxngh, 4, jpk) )
[4152]	2337
[1344]	2338	ijpj = 4
	2339	ijpjm1 = 3
	2340	!
[4671]	2341	znorthloc(:,:,:) = 0
[4230]	2342	DO jk = 1, jpk
	2343	DO jj = nlcj - ijpj +1, nlcj ! put in xnorthloc the last 4 jlines of pt3d
	2344	ij = jj - nlcj + ijpj
	2345	znorthloc(:,ij,jk) = pt3d(:,jj,jk)
	2346	END DO
[1344]	2347	END DO
	2348	!
[4152]	2349	! ! Build in procs of ncomm_north the znorthgloio
[1344]	2350	itaille = jpi * jpk * ijpj
[4230]	2351
[3294]	2352	IF ( l_north_nogather ) THEN
	2353	!
[4230]	2354	ztabr(:,:,:) = 0
[4671]	2355	ztabl(:,:,:) = 0
	2356
[4230]	2357	DO jk = 1, jpk
	2358	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
	2359	ij = jj - nlcj + ijpj
[4671]	2360	DO ji = nfsloop, nfeloop
[4230]	2361	ztabl(ji,ij,jk) = pt3d(ji,jj,jk)
	2362	END DO
	2363	END DO
	2364	END DO
	2365
	2366	DO jr = 1,nsndto
[4671]	2367	IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
	2368	CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
	2369	ENDIF
[4230]	2370	END DO
	2371	DO jr = 1,nsndto
[4671]	2372	iproc = nfipproc(isendto(jr),jpnj)
	2373	IF(iproc .ne. -1) THEN
	2374	ilei = nleit (iproc+1)
	2375	ildi = nldit (iproc+1)
	2376	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
	2377	ENDIF
	2378	IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
	2379	CALL mpprecv(5, zfoldwk, itaille, iproc)
[4230]	2380	DO jk = 1, jpk
	2381	DO jj = 1, ijpj
[4671]	2382	DO ji = ildi, ilei
[4230]	2383	ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)
	2384	END DO
	2385	END DO
	2386	END DO
[4671]	2387	ELSE IF (iproc .eq. (narea-1)) THEN
[4230]	2388	DO jk = 1, jpk
	2389	DO jj = 1, ijpj
[4671]	2390	DO ji = ildi, ilei
[4230]	2391	ztabr(iilb+ji,jj,jk) = pt3d(ji,nlcj-ijpj+jj,jk)
	2392	END DO
	2393	END DO
	2394	END DO
	2395	ENDIF
	2396	END DO
	2397	IF (l_isend) THEN
	2398	DO jr = 1,nsndto
[4765]	2399	IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
	2400	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
	2401	ENDIF
[4230]	2402	END DO
	2403	ENDIF
[4232]	2404	CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition
[4230]	2405	DO jk = 1, jpk
	2406	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
	2407	ij = jj - nlcj + ijpj
	2408	DO ji= 1, nlci
	2409	pt3d(ji,jj,jk) = ztabl(ji,ij,jk)
	2410	END DO
[1344]	2411	END DO
	2412	END DO
[3294]	2413	!
	2414
[4230]	2415	ELSE
[4152]	2416	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
	2417	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]	2418	!
[4230]	2419	ztab(:,:,:) = 0.e0
[3294]	2420	DO jr = 1, ndim_rank_north ! recover the global north array
	2421	iproc = nrank_north(jr) + 1
	2422	ildi = nldit (iproc)
	2423	ilei = nleit (iproc)
	2424	iilb = nimppt(iproc)
[4230]	2425	DO jk = 1, jpk
	2426	DO jj = 1, ijpj
	2427	DO ji = ildi, ilei
	2428	ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr)
	2429	END DO
[3294]	2430	END DO
	2431	END DO
	2432	END DO
[4230]	2433	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
	2434	!
	2435	DO jk = 1, jpk
	2436	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt3d
	2437	ij = jj - nlcj + ijpj
	2438	DO ji= 1, nlci
	2439	pt3d(ji,jj,jk) = ztab(ji+nimpp-1,ij,jk)
	2440	END DO
	2441	END DO
	2442	END DO
	2443	!
[3294]	2444	ENDIF
[1344]	2445	!
[4152]	2446	! The ztab array has been either:
[3294]	2447	! a. Fully populated by the mpi_allgather operation or
[3764]	2448	! b. Had the active points for this domain and northern neighbours populated
[3294]	2449	! by peer to peer exchanges
[3764]	2450	! Either way the array may be folded by lbc_nfd and the result for the span of
[3294]	2451	! this domain will be identical.
	2452	!
[4152]	2453	DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
[4230]	2454	DEALLOCATE( ztabl, ztabr )
[4152]	2455	!
[1344]	2456	END SUBROUTINE mpp_lbc_north_3d
[3]	2457
	2458
[1344]	2459	SUBROUTINE mpp_lbc_north_2d( pt2d, cd_type, psgn)
	2460	!!---------------------------------------------------------------------
	2461	!! * routine mpp_lbc_north_2d *
	2462	!!
[3764]	2463	!! ** Purpose : Ensure proper north fold horizontal bondary condition
[1344]	2464	!! in mpp configuration in case of jpn1 > 1 (for 2d array )
	2465	!!
	2466	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2467	!! in i-direction require a specific treatment. We gather
[1344]	2468	!! the 4 northern lines of the global domain on 1 processor
	2469	!! and apply lbc north-fold on this sub array. Then we
	2470	!! scatter the north fold array back to the processors.
	2471	!!
	2472	!!----------------------------------------------------------------------
[4230]	2473	REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the b.c. is applied
	2474	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt2d grid-points
[1344]	2475	! ! = T , U , V , F or W gridpoints
[4230]	2476	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the north fold
[1344]	2477	!! ! = 1. , the sign is kept
	2478	INTEGER :: ji, jj, jr
	2479	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2480	INTEGER :: ijpj, ijpjm1, ij, iproc
[4230]	2481	INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather
[3294]	2482	INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather
	2483	INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather
[4152]	2484	! ! Workspace for message transfers avoiding mpi_allgather
	2485	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab
	2486	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: znorthloc, zfoldwk
	2487	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio
[4230]	2488	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztabl, ztabr
	2489	INTEGER :: istatus(mpi_status_size)
	2490	INTEGER :: iflag
[1344]	2491	!!----------------------------------------------------------------------
	2492	!
[4152]	2493	ALLOCATE( ztab(jpiglo,4), znorthloc(jpi,4), zfoldwk(jpi,4), znorthgloio(jpi,4,jpni) )
[4230]	2494	ALLOCATE( ztabl(jpi,4), ztabr(jpi*jpmaxngh, 4) )
[4152]	2495	!
[1344]	2496	ijpj = 4
	2497	ijpjm1 = 3
	2498	!
[4152]	2499	DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d
[1344]	2500	ij = jj - nlcj + ijpj
[4152]	2501	znorthloc(:,ij) = pt2d(:,jj)
[1344]	2502	END DO
[3]	2503
[4152]	2504	! ! Build in procs of ncomm_north the znorthgloio
[1344]	2505	itaille = jpi * ijpj
[3294]	2506	IF ( l_north_nogather ) THEN
	2507	!
[4230]	2508	! Avoid the use of mpi_allgather by exchanging only with the processes already identified
[3294]	2509	! (in nemo_northcomms) as being involved in this process' northern boundary exchange
	2510	!
[4230]	2511	ztabr(:,:) = 0
[4671]	2512	ztabl(:,:) = 0
	2513
[3294]	2514	DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array
	2515	ij = jj - nlcj + ijpj
[4671]	2516	DO ji = nfsloop, nfeloop
[4230]	2517	ztabl(ji,ij) = pt2d(ji,jj)
[13]	2518	END DO
	2519	END DO
[3294]	2520
[4230]	2521	DO jr = 1,nsndto
[4671]	2522	IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
	2523	CALL mppsend(5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr))
	2524	ENDIF
[4230]	2525	END DO
	2526	DO jr = 1,nsndto
[4671]	2527	iproc = nfipproc(isendto(jr),jpnj)
	2528	IF(iproc .ne. -1) THEN
	2529	ilei = nleit (iproc+1)
	2530	ildi = nldit (iproc+1)
	2531	iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
	2532	ENDIF
	2533	IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN
	2534	CALL mpprecv(5, zfoldwk, itaille, iproc)
[4230]	2535	DO jj = 1, ijpj
[4671]	2536	DO ji = ildi, ilei
[4230]	2537	ztabr(iilb+ji,jj) = zfoldwk(ji,jj)
	2538	END DO
	2539	END DO
[4671]	2540	ELSE IF (iproc .eq. (narea-1)) THEN
[4230]	2541	DO jj = 1, ijpj
[4671]	2542	DO ji = ildi, ilei
[4230]	2543	ztabr(iilb+ji,jj) = pt2d(ji,nlcj-ijpj+jj)
	2544	END DO
	2545	END DO
	2546	ENDIF
	2547	END DO
	2548	IF (l_isend) THEN
	2549	DO jr = 1,nsndto
[4671]	2550	IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN
	2551	CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err)
	2552	ENDIF
[4230]	2553	END DO
	2554	ENDIF
	2555	CALL mpp_lbc_nfd( ztabl, ztabr, cd_type, psgn ) ! North fold boundary condition
[3294]	2556	!
[4230]	2557	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
	2558	ij = jj - nlcj + ijpj
	2559	DO ji = 1, nlci
	2560	pt2d(ji,jj) = ztabl(ji,ij)
	2561	END DO
	2562	END DO
[3294]	2563	!
[4230]	2564	ELSE
[4152]	2565	CALL MPI_ALLGATHER( znorthloc , itaille, MPI_DOUBLE_PRECISION, &
	2566	& znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[3294]	2567	!
[4230]	2568	ztab(:,:) = 0.e0
[3294]	2569	DO jr = 1, ndim_rank_north ! recover the global north array
	2570	iproc = nrank_north(jr) + 1
	2571	ildi = nldit (iproc)
	2572	ilei = nleit (iproc)
	2573	iilb = nimppt(iproc)
	2574	DO jj = 1, ijpj
	2575	DO ji = ildi, ilei
[4152]	2576	ztab(ji+iilb-1,jj) = znorthgloio(ji,jj,jr)
[3294]	2577	END DO
	2578	END DO
	2579	END DO
[4230]	2580	CALL lbc_nfd( ztab, cd_type, psgn ) ! North fold boundary condition
	2581	!
	2582	DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d
	2583	ij = jj - nlcj + ijpj
	2584	DO ji = 1, nlci
	2585	pt2d(ji,jj) = ztab(ji+nimpp-1,ij)
	2586	END DO
	2587	END DO
	2588	!
[3294]	2589	ENDIF
[4152]	2590	DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
[4230]	2591	DEALLOCATE( ztabl, ztabr )
[4152]	2592	!
[13]	2593	END SUBROUTINE mpp_lbc_north_2d
[3]	2594
	2595
[1344]	2596	SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn)
	2597	!!---------------------------------------------------------------------
	2598	!! * routine mpp_lbc_north_2d *
	2599	!!
[3764]	2600	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	2601	!! in mpp configuration in case of jpn1 > 1 and for 2d
[1344]	2602	!! array with outer extra halo
	2603	!!
	2604	!! ** Method : North fold condition and mpp with more than one proc
[3764]	2605	!! in i-direction require a specific treatment. We gather
	2606	!! the 4+2*jpr2dj northern lines of the global domain on 1
	2607	!! processor and apply lbc north-fold on this sub array.
[1344]	2608	!! Then we scatter the north fold array back to the processors.
	2609	!!
	2610	!!----------------------------------------------------------------------
	2611	REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) :: pt2d ! 2D array with extra halo
	2612	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	2613	! ! = T , U , V , F or W -points
[3764]	2614	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
[1344]	2615	!! ! north fold, = 1. otherwise
	2616	INTEGER :: ji, jj, jr
	2617	INTEGER :: ierr, itaille, ildi, ilei, iilb
	2618	INTEGER :: ijpj, ij, iproc
[4152]	2619	!
	2620	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
	2621	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
	2622
[1344]	2623	!!----------------------------------------------------------------------
	2624	!
[4152]	2625	ALLOCATE( ztab_e(jpiglo,4+2jpr2dj), znorthloc_e(jpi,4+2jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) )
	2626
	2627	!
[1344]	2628	ijpj=4
[4152]	2629	ztab_e(:,:) = 0.e0
[311]	2630
[1344]	2631	ij=0
[4152]	2632	! put in znorthloc_e the last 4 jlines of pt2d
[1344]	2633	DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj
	2634	ij = ij + 1
	2635	DO ji = 1, jpi
[4152]	2636	znorthloc_e(ji,ij)=pt2d(ji,jj)
[1344]	2637	END DO
	2638	END DO
	2639	!
	2640	itaille = jpi * ( ijpj + 2 * jpr2dj )
[4152]	2641	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
	2642	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
[1344]	2643	!
	2644	DO jr = 1, ndim_rank_north ! recover the global north array
	2645	iproc = nrank_north(jr) + 1
	2646	ildi = nldit (iproc)
	2647	ilei = nleit (iproc)
	2648	iilb = nimppt(iproc)
	2649	DO jj = 1, ijpj+2*jpr2dj
	2650	DO ji = ildi, ilei
[4152]	2651	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
[311]	2652	END DO
[1344]	2653	END DO
	2654	END DO
[311]	2655
	2656
[1344]	2657	! 2. North-Fold boundary conditions
	2658	! ----------------------------------
[4152]	2659	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = jpr2dj )
[311]	2660
[1344]	2661	ij = jpr2dj
	2662	!! Scatter back to pt2d
	2663	DO jj = nlcj - ijpj + 1 , nlcj +jpr2dj
[3764]	2664	ij = ij +1
[1344]	2665	DO ji= 1, nlci
[4152]	2666	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
[311]	2667	END DO
	2668	END DO
[1344]	2669	!
[4152]	2670	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
	2671	!
[311]	2672	END SUBROUTINE mpp_lbc_north_e
	2673
[3680]	2674	SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy )
	2675	!!----------------------------------------------------------------------
	2676	!! * routine mpp_lnk_bdy_3d *
	2677	!!
	2678	!! ** Purpose : Message passing management
	2679	!!
	2680	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
	2681	!! between processors following neighboring subdomains.
	2682	!! domain parameters
	2683	!! nlci : first dimension of the local subdomain
	2684	!! nlcj : second dimension of the local subdomain
	2685	!! nbondi_bdy : mark for "east-west local boundary"
	2686	!! nbondj_bdy : mark for "north-south local boundary"
	2687	!! noea : number for local neighboring processors
	2688	!! nowe : number for local neighboring processors
	2689	!! noso : number for local neighboring processors
	2690	!! nono : number for local neighboring processors
	2691	!!
	2692	!! ** Action : ptab with update value at its periphery
	2693	!!
	2694	!!----------------------------------------------------------------------
[389]	2695
[3680]	2696	USE lbcnfd ! north fold
	2697
	2698	INCLUDE 'mpif.h'
	2699
	2700	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	2701	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	2702	! ! = T , U , V , F , W points
	2703	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	2704	! ! = 1. , the sign is kept
	2705	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	2706	INTEGER :: ji, jj, jk, jl ! dummy loop indices
	2707	INTEGER :: imigr, iihom, ijhom ! temporary integers
	2708	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	2709	REAL(wp) :: zland
	2710	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[4152]	2711	!
	2712	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north
	2713	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east
	2714
[3680]	2715	!!----------------------------------------------------------------------
[4152]	2716
	2717	ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), &
	2718	& zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) )
[3680]	2719
	2720	zland = 0.e0
	2721
	2722	! 1. standard boundary treatment
	2723	! ------------------------------
	2724
	2725	! ! East-West boundaries
	2726	! !* Cyclic east-west
	2727
	2728	IF( nbondi == 2) THEN
	2729	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	2730	ptab( 1 ,:,:) = ptab(jpim1,:,:)
	2731	ptab(jpi,:,:) = ptab( 2 ,:,:)
	2732	ELSE
	2733	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	2734	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	2735	ENDIF
	2736	ELSEIF(nbondi == -1) THEN
	2737	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:,:) = zland ! south except F-point
	2738	ELSEIF(nbondi == 1) THEN
	2739	ptab(nlci-jpreci+1:jpi ,:,:) = zland ! north
	2740	ENDIF !* closed
	2741
	2742	IF (nbondj == 2 .OR. nbondj == -1) THEN
	2743	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj,:) = zland ! south except F-point
	2744	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	2745	ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north
	2746	ENDIF
	2747
	2748	!
	2749
	2750	! 2. East and west directions exchange
	2751	! ------------------------------------
	2752	! we play with the neigbours AND the row number because of the periodicity
	2753	!
	2754	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
	2755	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	2756	iihom = nlci-nreci
	2757	DO jl = 1, jpreci
[4152]	2758	zt3ew(:,jl,:,1) = ptab(jpreci+jl,:,:)
	2759	zt3we(:,jl,:,1) = ptab(iihom +jl,:,:)
[3680]	2760	END DO
	2761	END SELECT
	2762	!
	2763	! ! Migrations
	2764	imigr = jpreci * jpj * jpk
	2765	!
	2766	SELECT CASE ( nbondi_bdy(ib_bdy) )
	2767	CASE ( -1 )
[4152]	2768	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 )
[3680]	2769	CASE ( 0 )
[4152]	2770	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
	2771	CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 )
[3680]	2772	CASE ( 1 )
[4152]	2773	CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 )
[3680]	2774	END SELECT
	2775	!
	2776	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	2777	CASE ( -1 )
[4152]	2778	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
[3680]	2779	CASE ( 0 )
[4152]	2780	CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea )
	2781	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[3680]	2782	CASE ( 1 )
[4152]	2783	CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe )
[3680]	2784	END SELECT
	2785	!
	2786	SELECT CASE ( nbondi_bdy(ib_bdy) )
	2787	CASE ( -1 )
	2788	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2789	CASE ( 0 )
	2790	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2791	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	2792	CASE ( 1 )
	2793	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2794	END SELECT
	2795	!
	2796	! ! Write Dirichlet lateral conditions
	2797	iihom = nlci-jpreci
	2798	!
	2799	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	2800	CASE ( -1 )
	2801	DO jl = 1, jpreci
[4152]	2802	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[3680]	2803	END DO
	2804	CASE ( 0 )
	2805	DO jl = 1, jpreci
[4152]	2806	ptab(jl ,:,:) = zt3we(:,jl,:,2)
	2807	ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2)
[3680]	2808	END DO
	2809	CASE ( 1 )
	2810	DO jl = 1, jpreci
[4152]	2811	ptab(jl ,:,:) = zt3we(:,jl,:,2)
[3680]	2812	END DO
	2813	END SELECT
	2814
	2815
	2816	! 3. North and south directions
	2817	! -----------------------------
	2818	! always closed : we play only with the neigbours
	2819	!
	2820	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
	2821	ijhom = nlcj-nrecj
	2822	DO jl = 1, jprecj
[4152]	2823	zt3sn(:,jl,:,1) = ptab(:,ijhom +jl,:)
	2824	zt3ns(:,jl,:,1) = ptab(:,jprecj+jl,:)
[3680]	2825	END DO
	2826	ENDIF
	2827	!
	2828	! ! Migrations
	2829	imigr = jprecj * jpi * jpk
	2830	!
	2831	SELECT CASE ( nbondj_bdy(ib_bdy) )
	2832	CASE ( -1 )
[4152]	2833	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 )
[3680]	2834	CASE ( 0 )
[4152]	2835	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
	2836	CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 )
[3680]	2837	CASE ( 1 )
[4152]	2838	CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 )
[3680]	2839	END SELECT
	2840	!
	2841	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	2842	CASE ( -1 )
[4152]	2843	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
[3680]	2844	CASE ( 0 )
[4152]	2845	CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono )
	2846	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[3680]	2847	CASE ( 1 )
[4152]	2848	CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso )
[3680]	2849	END SELECT
	2850	!
	2851	SELECT CASE ( nbondj_bdy(ib_bdy) )
	2852	CASE ( -1 )
	2853	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2854	CASE ( 0 )
	2855	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2856	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	2857	CASE ( 1 )
	2858	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	2859	END SELECT
	2860	!
	2861	! ! Write Dirichlet lateral conditions
	2862	ijhom = nlcj-jprecj
	2863	!
	2864	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	2865	CASE ( -1 )
	2866	DO jl = 1, jprecj
[4152]	2867	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[3680]	2868	END DO
	2869	CASE ( 0 )
	2870	DO jl = 1, jprecj
[4152]	2871	ptab(:,jl ,:) = zt3sn(:,jl,:,2)
	2872	ptab(:,ijhom+jl,:) = zt3ns(:,jl,:,2)
[3680]	2873	END DO
	2874	CASE ( 1 )
	2875	DO jl = 1, jprecj
[4152]	2876	ptab(:,jl,:) = zt3sn(:,jl,:,2)
[3680]	2877	END DO
	2878	END SELECT
	2879
	2880
	2881	! 4. north fold treatment
	2882	! -----------------------
	2883	!
	2884	IF( npolj /= 0) THEN
	2885	!
	2886	SELECT CASE ( jpni )
	2887	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	2888	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	2889	END SELECT
	2890	!
	2891	ENDIF
	2892	!
[4152]	2893	DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we )
	2894	!
[3680]	2895	END SUBROUTINE mpp_lnk_bdy_3d
	2896
	2897	SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy )
	2898	!!----------------------------------------------------------------------
	2899	!! * routine mpp_lnk_bdy_2d *
	2900	!!
	2901	!! ** Purpose : Message passing management
	2902	!!
	2903	!! ** Method : Use mppsend and mpprecv function for passing BDY boundaries
	2904	!! between processors following neighboring subdomains.
	2905	!! domain parameters
	2906	!! nlci : first dimension of the local subdomain
	2907	!! nlcj : second dimension of the local subdomain
	2908	!! nbondi_bdy : mark for "east-west local boundary"
	2909	!! nbondj_bdy : mark for "north-south local boundary"
	2910	!! noea : number for local neighboring processors
	2911	!! nowe : number for local neighboring processors
	2912	!! noso : number for local neighboring processors
	2913	!! nono : number for local neighboring processors
	2914	!!
	2915	!! ** Action : ptab with update value at its periphery
	2916	!!
	2917	!!----------------------------------------------------------------------
	2918
	2919	USE lbcnfd ! north fold
	2920
	2921	INCLUDE 'mpif.h'
	2922
	2923	REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied
	2924	CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points
	2925	! ! = T , U , V , F , W points
	2926	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary
	2927	! ! = 1. , the sign is kept
	2928	INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set
	2929	INTEGER :: ji, jj, jl ! dummy loop indices
	2930	INTEGER :: imigr, iihom, ijhom ! temporary integers
	2931	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	2932	REAL(wp) :: zland
	2933	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
[4152]	2934	!
	2935	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north
	2936	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east
	2937
[3680]	2938	!!----------------------------------------------------------------------
	2939
[4152]	2940	ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), &
	2941	& zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) )
	2942
[3680]	2943	zland = 0.e0
	2944
	2945	! 1. standard boundary treatment
	2946	! ------------------------------
	2947
	2948	! ! East-West boundaries
	2949	! !* Cyclic east-west
	2950
	2951	IF( nbondi == 2) THEN
	2952	IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN
	2953	ptab( 1 ,:) = ptab(jpim1,:)
	2954	ptab(jpi,:) = ptab( 2 ,:)
	2955	ELSE
	2956	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
	2957	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
	2958	ENDIF
	2959	ELSEIF(nbondi == -1) THEN
	2960	IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point
	2961	ELSEIF(nbondi == 1) THEN
	2962	ptab(nlci-jpreci+1:jpi ,:) = zland ! north
	2963	ENDIF !* closed
	2964
	2965	IF (nbondj == 2 .OR. nbondj == -1) THEN
	2966	IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point
	2967	ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN
	2968	ptab(:,nlcj-jprecj+1:jpj) = zland ! north
	2969	ENDIF
	2970
	2971	!
	2972
	2973	! 2. East and west directions exchange
	2974	! ------------------------------------
	2975	! we play with the neigbours AND the row number because of the periodicity
	2976	!
	2977	SELECT CASE ( nbondi_bdy(ib_bdy) ) ! Read Dirichlet lateral conditions
	2978	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	2979	iihom = nlci-nreci
	2980	DO jl = 1, jpreci
[4152]	2981	zt2ew(:,jl,1) = ptab(jpreci+jl,:)
	2982	zt2we(:,jl,1) = ptab(iihom +jl,:)
[3680]	2983	END DO
	2984	END SELECT
	2985	!
	2986	! ! Migrations
	2987	imigr = jpreci * jpj
	2988	!
	2989	SELECT CASE ( nbondi_bdy(ib_bdy) )
	2990	CASE ( -1 )
[4152]	2991	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 )
[3680]	2992	CASE ( 0 )
[4152]	2993	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
	2994	CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 )
[3680]	2995	CASE ( 1 )
[4152]	2996	CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 )
[3680]	2997	END SELECT
	2998	!
	2999	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3000	CASE ( -1 )
[4152]	3001	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
[3680]	3002	CASE ( 0 )
[4152]	3003	CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea )
	3004	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[3680]	3005	CASE ( 1 )
[4152]	3006	CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe )
[3680]	3007	END SELECT
	3008	!
	3009	SELECT CASE ( nbondi_bdy(ib_bdy) )
	3010	CASE ( -1 )
	3011	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3012	CASE ( 0 )
	3013	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3014	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3015	CASE ( 1 )
	3016	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3017	END SELECT
	3018	!
	3019	! ! Write Dirichlet lateral conditions
	3020	iihom = nlci-jpreci
	3021	!
	3022	SELECT CASE ( nbondi_bdy_b(ib_bdy) )
	3023	CASE ( -1 )
	3024	DO jl = 1, jpreci
[4152]	3025	ptab(iihom+jl,:) = zt2ew(:,jl,2)
[3680]	3026	END DO
	3027	CASE ( 0 )
	3028	DO jl = 1, jpreci
[4152]	3029	ptab(jl ,:) = zt2we(:,jl,2)
	3030	ptab(iihom+jl,:) = zt2ew(:,jl,2)
[3680]	3031	END DO
	3032	CASE ( 1 )
	3033	DO jl = 1, jpreci
[4152]	3034	ptab(jl ,:) = zt2we(:,jl,2)
[3680]	3035	END DO
	3036	END SELECT
	3037
	3038
	3039	! 3. North and south directions
	3040	! -----------------------------
	3041	! always closed : we play only with the neigbours
	3042	!
	3043	IF( nbondj_bdy(ib_bdy) /= 2 ) THEN ! Read Dirichlet lateral conditions
	3044	ijhom = nlcj-nrecj
	3045	DO jl = 1, jprecj
[4152]	3046	zt2sn(:,jl,1) = ptab(:,ijhom +jl)
	3047	zt2ns(:,jl,1) = ptab(:,jprecj+jl)
[3680]	3048	END DO
	3049	ENDIF
	3050	!
	3051	! ! Migrations
	3052	imigr = jprecj * jpi
	3053	!
	3054	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3055	CASE ( -1 )
[4152]	3056	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 )
[3680]	3057	CASE ( 0 )
[4152]	3058	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
	3059	CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 )
[3680]	3060	CASE ( 1 )
[4152]	3061	CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 )
[3680]	3062	END SELECT
	3063	!
	3064	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3065	CASE ( -1 )
[4152]	3066	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
[3680]	3067	CASE ( 0 )
[4152]	3068	CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono )
	3069	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[3680]	3070	CASE ( 1 )
[4152]	3071	CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso )
[3680]	3072	END SELECT
	3073	!
	3074	SELECT CASE ( nbondj_bdy(ib_bdy) )
	3075	CASE ( -1 )
	3076	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3077	CASE ( 0 )
	3078	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3079	IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err)
	3080	CASE ( 1 )
	3081	IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err)
	3082	END SELECT
	3083	!
	3084	! ! Write Dirichlet lateral conditions
	3085	ijhom = nlcj-jprecj
	3086	!
	3087	SELECT CASE ( nbondj_bdy_b(ib_bdy) )
	3088	CASE ( -1 )
	3089	DO jl = 1, jprecj
[4152]	3090	ptab(:,ijhom+jl) = zt2ns(:,jl,2)
[3680]	3091	END DO
	3092	CASE ( 0 )
	3093	DO jl = 1, jprecj
[4152]	3094	ptab(:,jl ) = zt2sn(:,jl,2)
	3095	ptab(:,ijhom+jl) = zt2ns(:,jl,2)
[3680]	3096	END DO
	3097	CASE ( 1 )
	3098	DO jl = 1, jprecj
[4152]	3099	ptab(:,jl) = zt2sn(:,jl,2)
[3680]	3100	END DO
	3101	END SELECT
	3102
	3103
	3104	! 4. north fold treatment
	3105	! -----------------------
	3106	!
	3107	IF( npolj /= 0) THEN
	3108	!
	3109	SELECT CASE ( jpni )
	3110	CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp
	3111	CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs.
	3112	END SELECT
	3113	!
	3114	ENDIF
	3115	!
[4152]	3116	DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we )
	3117	!
[3680]	3118	END SUBROUTINE mpp_lnk_bdy_2d
	3119
[2481]	3120	SUBROUTINE mpi_init_opa( ldtxt, ksft, code )
[1344]	3121	!!---------------------------------------------------------------------
	3122	!! * routine mpp_init.opa *
	3123	!!
	3124	!! ** Purpose :: export and attach a MPI buffer for bsend
	3125	!!
	3126	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
	3127	!! but classical mpi_init
[3764]	3128	!!
	3129	!! History :: 01/11 :: IDRIS initial version for IBM only
[1344]	3130	!! 08/04 :: R. Benshila, generalisation
	3131	!!---------------------------------------------------------------------
[3764]	3132	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
[2481]	3133	INTEGER , INTENT(inout) :: ksft
	3134	INTEGER , INTENT( out) :: code
	3135	INTEGER :: ierr, ji
	3136	LOGICAL :: mpi_was_called
[1344]	3137	!!---------------------------------------------------------------------
	3138	!
	3139	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
[532]	3140	IF ( code /= MPI_SUCCESS ) THEN
[3764]	3141	DO ji = 1, SIZE(ldtxt)
[2481]	3142	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
[3764]	3143	END DO
[2481]	3144	WRITE(*, cform_err)
	3145	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
[1344]	3146	CALL mpi_abort( mpi_comm_world, code, ierr )
[532]	3147	ENDIF
[1344]	3148	!
	3149	IF( .NOT. mpi_was_called ) THEN
	3150	CALL mpi_init( code )
	3151	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code )
[532]	3152	IF ( code /= MPI_SUCCESS ) THEN
[3764]	3153	DO ji = 1, SIZE(ldtxt)
[2481]	3154	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	3155	END DO
	3156	WRITE(*, cform_err)
	3157	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
[532]	3158	CALL mpi_abort( mpi_comm_world, code, ierr )
	3159	ENDIF
	3160	ENDIF
[1344]	3161	!
[897]	3162	IF( nn_buffer > 0 ) THEN
[2481]	3163	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
[897]	3164	! Buffer allocation and attachment
[2481]	3165	ALLOCATE( tampon(nn_buffer), stat = ierr )
[3764]	3166	IF( ierr /= 0 ) THEN
	3167	DO ji = 1, SIZE(ldtxt)
[2481]	3168	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	3169	END DO
	3170	WRITE(*, cform_err)
	3171	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
	3172	CALL mpi_abort( mpi_comm_world, code, ierr )
	3173	END IF
	3174	CALL mpi_buffer_attach( tampon, nn_buffer, code )
[897]	3175	ENDIF
[1344]	3176	!
[13]	3177	END SUBROUTINE mpi_init_opa
[3]	3178
[1976]	3179	SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype)
	3180	!!---------------------------------------------------------------------
	3181	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
	3182	!!
	3183	!! Modification of original codes written by David H. Bailey
	3184	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
	3185	!!---------------------------------------------------------------------
	3186	INTEGER, INTENT(in) :: ilen, itype
	3187	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
	3188	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
	3189	!
	3190	REAL(wp) :: zerr, zt1, zt2 ! local work variables
	3191	INTEGER :: ji, ztmp ! local scalar
	3192
	3193	ztmp = itype ! avoid compilation warning
	3194
	3195	DO ji=1,ilen
	3196	! Compute ydda + yddb using Knuth's trick.
	3197	zt1 = real(ydda(ji)) + real(yddb(ji))
	3198	zerr = zt1 - real(ydda(ji))
	3199	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
	3200	+ aimag(ydda(ji)) + aimag(yddb(ji))
	3201
	3202	! The result is zt1 + zt2, after normalization.
	3203	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
	3204	END DO
	3205
	3206	END SUBROUTINE DDPDD_MPI
	3207
[4990]	3208	SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj)
	3209	!!---------------------------------------------------------------------
	3210	!! * routine mpp_lbc_north_icb *
	3211	!!
	3212	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	3213	!! in mpp configuration in case of jpn1 > 1 and for 2d
	3214	!! array with outer extra halo
	3215	!!
	3216	!! ** Method : North fold condition and mpp with more than one proc
	3217	!! in i-direction require a specific treatment. We gather
	3218	!! the 4+2*jpr2dj northern lines of the global domain on 1
	3219	!! processor and apply lbc north-fold on this sub array.
	3220	!! Then we scatter the north fold array back to the processors.
	3221	!! This version accounts for an extra halo with icebergs.
	3222	!!
	3223	!!----------------------------------------------------------------------
	3224	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
	3225	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	3226	! ! = T , U , V , F or W -points
	3227	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
	3228	!! ! north fold, = 1. otherwise
	3229	INTEGER, OPTIONAL , INTENT(in ) :: pr2dj
	3230	INTEGER :: ji, jj, jr
	3231	INTEGER :: ierr, itaille, ildi, ilei, iilb
	3232	INTEGER :: ijpj, ij, iproc, ipr2dj
	3233	!
	3234	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
	3235	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
	3236
	3237	!!----------------------------------------------------------------------
	3238	!
	3239	ijpj=4
	3240	IF( PRESENT(pr2dj) ) THEN ! use of additional halos
	3241	ipr2dj = pr2dj
	3242	ELSE
	3243	ipr2dj = 0
	3244	ENDIF
	3245	ALLOCATE( ztab_e(jpiglo,4+2ipr2dj), znorthloc_e(jpi,4+2ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) )
	3246
	3247	!
	3248	ztab_e(:,:) = 0.e0
	3249
	3250	ij=0
	3251	! put in znorthloc_e the last 4 jlines of pt2d
	3252	DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj
	3253	ij = ij + 1
	3254	DO ji = 1, jpi
	3255	znorthloc_e(ji,ij)=pt2d(ji,jj)
	3256	END DO
	3257	END DO
	3258	!
	3259	itaille = jpi * ( ijpj + 2 * ipr2dj )
	3260	CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, &
	3261	& znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
	3262	!
	3263	DO jr = 1, ndim_rank_north ! recover the global north array
	3264	iproc = nrank_north(jr) + 1
	3265	ildi = nldit (iproc)
	3266	ilei = nleit (iproc)
	3267	iilb = nimppt(iproc)
	3268	DO jj = 1, ijpj+2*ipr2dj
	3269	DO ji = ildi, ilei
	3270	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
	3271	END DO
	3272	END DO
	3273	END DO
	3274
	3275
	3276	! 2. North-Fold boundary conditions
	3277	! ----------------------------------
	3278	CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj )
	3279
	3280	ij = ipr2dj
	3281	!! Scatter back to pt2d
	3282	DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj
	3283	ij = ij +1
	3284	DO ji= 1, nlci
	3285	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
	3286	END DO
	3287	END DO
	3288	!
	3289	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
	3290	!
	3291	END SUBROUTINE mpp_lbc_north_icb
	3292
	3293	SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj )
	3294	!!----------------------------------------------------------------------
	3295	!! * routine mpp_lnk_2d_icb *
	3296	!!
	3297	!! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs)
	3298	!!
	3299	!! ** Method : Use mppsend and mpprecv function for passing mask
	3300	!! between processors following neighboring subdomains.
	3301	!! domain parameters
	3302	!! nlci : first dimension of the local subdomain
	3303	!! nlcj : second dimension of the local subdomain
	3304	!! jpri : number of rows for extra outer halo
	3305	!! jprj : number of columns for extra outer halo
	3306	!! nbondi : mark for "east-west local boundary"
	3307	!! nbondj : mark for "north-south local boundary"
	3308	!! noea : number for local neighboring processors
	3309	!! nowe : number for local neighboring processors
	3310	!! noso : number for local neighboring processors
	3311	!! nono : number for local neighboring processors
	3312	!!
	3313	!!----------------------------------------------------------------------
	3314	INTEGER , INTENT(in ) :: jpri
	3315	INTEGER , INTENT(in ) :: jprj
	3316	REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo
	3317	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
	3318	! ! = T , U , V , F , W and I points
	3319	REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the
	3320	!! ! north boundary, = 1. otherwise
	3321	INTEGER :: jl ! dummy loop indices
	3322	INTEGER :: imigr, iihom, ijhom ! temporary integers
	3323	INTEGER :: ipreci, iprecj ! temporary integers
	3324	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	3325	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	3326	!!
	3327	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns
	3328	REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn
	3329	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe
	3330	REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew
	3331	!!----------------------------------------------------------------------
	3332
	3333	ipreci = jpreci + jpri ! take into account outer extra 2D overlap area
	3334	iprecj = jprecj + jprj
	3335
	3336
	3337	! 1. standard boundary treatment
	3338	! ------------------------------
	3339	! Order matters Here !!!!
	3340	!
	3341	! ! East-West boundaries
	3342	! !* Cyclic east-west
	3343	IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN
	3344	pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east
	3345	pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west
	3346	!
	3347	ELSE !* closed
	3348	IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point
	3349	pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north
	3350	ENDIF
	3351	!
	3352
	3353	! north fold treatment
	3354	! -----------------------
	3355	IF( npolj /= 0 ) THEN
	3356	!
	3357	SELECT CASE ( jpni )
	3358	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj )
	3359	CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj )
	3360	END SELECT
	3361	!
	3362	ENDIF
	3363
	3364	! 2. East and west directions exchange
	3365	! ------------------------------------
	3366	! we play with the neigbours AND the row number because of the periodicity
	3367	!
	3368	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	3369	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
	3370	iihom = nlci-nreci-jpri
	3371	DO jl = 1, ipreci
	3372	r2dew(:,jl,1) = pt2d(jpreci+jl,:)
	3373	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
	3374	END DO
	3375	END SELECT
	3376	!
	3377	! ! Migrations
	3378	imigr = ipreci * ( jpj + 2*jprj)
	3379	!
	3380	SELECT CASE ( nbondi )
	3381	CASE ( -1 )
	3382	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 )
	3383	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
	3384	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3385	CASE ( 0 )
	3386	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
	3387	CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 )
	3388	CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea )
	3389	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
	3390	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3391	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	3392	CASE ( 1 )
	3393	CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 )
	3394	CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe )
	3395	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3396	END SELECT
	3397	!
	3398	! ! Write Dirichlet lateral conditions
	3399	iihom = nlci - jpreci
	3400	!
	3401	SELECT CASE ( nbondi )
	3402	CASE ( -1 )
	3403	DO jl = 1, ipreci
	3404	pt2d(iihom+jl,:) = r2dew(:,jl,2)
	3405	END DO
	3406	CASE ( 0 )
	3407	DO jl = 1, ipreci
	3408	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
	3409	pt2d( iihom+jl,:) = r2dew(:,jl,2)
	3410	END DO
	3411	CASE ( 1 )
	3412	DO jl = 1, ipreci
	3413	pt2d(jl-jpri,:) = r2dwe(:,jl,2)
	3414	END DO
	3415	END SELECT
	3416
	3417
	3418	! 3. North and south directions
	3419	! -----------------------------
	3420	! always closed : we play only with the neigbours
	3421	!
	3422	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
	3423	ijhom = nlcj-nrecj-jprj
	3424	DO jl = 1, iprecj
	3425	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
	3426	r2dns(:,jl,1) = pt2d(:,jprecj+jl)
	3427	END DO
	3428	ENDIF
	3429	!
	3430	! ! Migrations
	3431	imigr = iprecj * ( jpi + 2*jpri )
	3432	!
	3433	SELECT CASE ( nbondj )
	3434	CASE ( -1 )
	3435	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 )
	3436	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
	3437	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3438	CASE ( 0 )
	3439	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
	3440	CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 )
	3441	CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono )
	3442	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
	3443	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3444	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	3445	CASE ( 1 )
	3446	CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 )
	3447	CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso )
	3448	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	3449	END SELECT
	3450	!
	3451	! ! Write Dirichlet lateral conditions
	3452	ijhom = nlcj - jprecj
	3453	!
	3454	SELECT CASE ( nbondj )
	3455	CASE ( -1 )
	3456	DO jl = 1, iprecj
	3457	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
	3458	END DO
	3459	CASE ( 0 )
	3460	DO jl = 1, iprecj
	3461	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
	3462	pt2d(:,ijhom+jl ) = r2dns(:,jl,2)
	3463	END DO
	3464	CASE ( 1 )
	3465	DO jl = 1, iprecj
	3466	pt2d(:,jl-jprj) = r2dsn(:,jl,2)
	3467	END DO
	3468	END SELECT
	3469
	3470	END SUBROUTINE mpp_lnk_2d_icb
[13]	3471	#else
	3472	!!----------------------------------------------------------------------
	3473	!! Default case: Dummy module share memory computing
	3474	!!----------------------------------------------------------------------
[2715]	3475	USE in_out_manager
[1976]	3476
[13]	3477	INTERFACE mpp_sum
[3294]	3478	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
[13]	3479	END INTERFACE
	3480	INTERFACE mpp_max
[681]	3481	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	3482	END INTERFACE
	3483	INTERFACE mpp_min
	3484	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	3485	END INTERFACE
[1344]	3486	INTERFACE mpp_minloc
	3487	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	3488	END INTERFACE
	3489	INTERFACE mpp_maxloc
	3490	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	3491	END INTERFACE
[3]	3492
[13]	3493	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
[4147]	3494	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
[869]	3495	INTEGER :: ncomm_ice
[5412]	3496	INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator
[2715]	3497	!!----------------------------------------------------------------------
[13]	3498	CONTAINS
[3]	3499
[2715]	3500	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
	3501	INTEGER, INTENT(in) :: kumout
	3502	lib_mpp_alloc = 0
	3503	END FUNCTION lib_mpp_alloc
	3504
[5407]	3505	FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)
[1579]	3506	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[3764]	3507	CHARACTER(len=*),DIMENSION(:) :: ldtxt
[5407]	3508	CHARACTER(len=*) :: ldname
[4314]	3509	INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop
[5412]	3510	IF( PRESENT( localComm ) ) mpi_comm_opa = localComm
	3511	function_value = 0
[1579]	3512	IF( .FALSE. ) ldtxt(:) = 'never done'
[5407]	3513	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
[13]	3514	END FUNCTION mynode
[3]	3515
[13]	3516	SUBROUTINE mppsync ! Dummy routine
	3517	END SUBROUTINE mppsync
[3]	3518
[869]	3519	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
[13]	3520	REAL , DIMENSION(:) :: parr
	3521	INTEGER :: kdim
[3764]	3522	INTEGER, OPTIONAL :: kcom
[869]	3523	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3524	END SUBROUTINE mpp_sum_as
[3]	3525
[869]	3526	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
[13]	3527	REAL , DIMENSION(:,:) :: parr
	3528	INTEGER :: kdim
[3764]	3529	INTEGER, OPTIONAL :: kcom
[869]	3530	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]	3531	END SUBROUTINE mpp_sum_a2s
[3]	3532
[869]	3533	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
[13]	3534	INTEGER, DIMENSION(:) :: karr
	3535	INTEGER :: kdim
[3764]	3536	INTEGER, OPTIONAL :: kcom
[869]	3537	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	3538	END SUBROUTINE mpp_sum_ai
[3]	3539
[869]	3540	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
[13]	3541	REAL :: psca
[3764]	3542	INTEGER, OPTIONAL :: kcom
[869]	3543	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]	3544	END SUBROUTINE mpp_sum_s
[2480]	3545
[869]	3546	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
[13]	3547	integer :: kint
[3764]	3548	INTEGER, OPTIONAL :: kcom
[869]	3549	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]	3550	END SUBROUTINE mpp_sum_i
	3551
[3294]	3552	SUBROUTINE mppsum_realdd( ytab, kcom )
	3553	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
	3554	INTEGER , INTENT( in ), OPTIONAL :: kcom
	3555	WRITE(,) 'mppsum_realdd: You should not have seen this print! error?', ytab
	3556	END SUBROUTINE mppsum_realdd
[3764]	3557
[3294]	3558	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	3559	INTEGER , INTENT( in ) :: kdim ! size of ytab
	3560	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
	3561	INTEGER , INTENT( in ), OPTIONAL :: kcom
	3562	WRITE(,) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
	3563	END SUBROUTINE mppsum_a_realdd
	3564
[869]	3565	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]	3566	REAL , DIMENSION(:) :: parr
	3567	INTEGER :: kdim
[3764]	3568	INTEGER, OPTIONAL :: kcom
[869]	3569	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3570	END SUBROUTINE mppmax_a_real
	3571
[869]	3572	SUBROUTINE mppmax_real( psca, kcom )
[13]	3573	REAL :: psca
[3764]	3574	INTEGER, OPTIONAL :: kcom
[869]	3575	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]	3576	END SUBROUTINE mppmax_real
	3577
[869]	3578	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]	3579	REAL , DIMENSION(:) :: parr
	3580	INTEGER :: kdim
[3764]	3581	INTEGER, OPTIONAL :: kcom
[869]	3582	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	3583	END SUBROUTINE mppmin_a_real
	3584
[869]	3585	SUBROUTINE mppmin_real( psca, kcom )
[13]	3586	REAL :: psca
[3764]	3587	INTEGER, OPTIONAL :: kcom
[869]	3588	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]	3589	END SUBROUTINE mppmin_real
	3590
[869]	3591	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]	3592	INTEGER, DIMENSION(:) :: karr
	3593	INTEGER :: kdim
[3764]	3594	INTEGER, OPTIONAL :: kcom
[888]	3595	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]	3596	END SUBROUTINE mppmax_a_int
	3597
[869]	3598	SUBROUTINE mppmax_int( kint, kcom)
[681]	3599	INTEGER :: kint
[3764]	3600	INTEGER, OPTIONAL :: kcom
[869]	3601	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]	3602	END SUBROUTINE mppmax_int
	3603
[869]	3604	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]	3605	INTEGER, DIMENSION(:) :: karr
	3606	INTEGER :: kdim
[3764]	3607	INTEGER, OPTIONAL :: kcom
[869]	3608	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	3609	END SUBROUTINE mppmin_a_int
	3610
[869]	3611	SUBROUTINE mppmin_int( kint, kcom )
[13]	3612	INTEGER :: kint
[3764]	3613	INTEGER, OPTIONAL :: kcom
[869]	3614	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]	3615	END SUBROUTINE mppmin_int
	3616
[1344]	3617	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]	3618	REAL :: pmin
	3619	REAL , DIMENSION (:,:) :: ptab, pmask
	3620	INTEGER :: ki, kj
[1528]	3621	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]	3622	END SUBROUTINE mpp_minloc2d
	3623
[1344]	3624	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]	3625	REAL :: pmin
	3626	REAL , DIMENSION (:,:,:) :: ptab, pmask
	3627	INTEGER :: ki, kj, kk
[1528]	3628	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	3629	END SUBROUTINE mpp_minloc3d
	3630
[1344]	3631	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]	3632	REAL :: pmax
	3633	REAL , DIMENSION (:,:) :: ptab, pmask
	3634	INTEGER :: ki, kj
[1528]	3635	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]	3636	END SUBROUTINE mpp_maxloc2d
	3637
[1344]	3638	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]	3639	REAL :: pmax
	3640	REAL , DIMENSION (:,:,:) :: ptab, pmask
	3641	INTEGER :: ki, kj, kk
[1528]	3642	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	3643	END SUBROUTINE mpp_maxloc3d
	3644
[51]	3645	SUBROUTINE mppstop
[3799]	3646	STOP ! non MPP case, just stop the run
[51]	3647	END SUBROUTINE mppstop
	3648
[2715]	3649	SUBROUTINE mpp_ini_ice( kcom, knum )
	3650	INTEGER :: kcom, knum
	3651	WRITE(,) 'mpp_ini_ice: You should not have seen this print! error?', kcom, knum
[888]	3652	END SUBROUTINE mpp_ini_ice
[869]	3653
[2715]	3654	SUBROUTINE mpp_ini_znl( knum )
	3655	INTEGER :: knum
	3656	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
[1345]	3657	END SUBROUTINE mpp_ini_znl
	3658
[1344]	3659	SUBROUTINE mpp_comm_free( kcom )
[869]	3660	INTEGER :: kcom
[1344]	3661	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]	3662	END SUBROUTINE mpp_comm_free
[3]	3663	#endif
[2715]	3664
[13]	3665	!!----------------------------------------------------------------------
[4147]	3666	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
[2715]	3667	!!----------------------------------------------------------------------
	3668
	3669	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
	3670	& cd6, cd7, cd8, cd9, cd10 )
	3671	!!----------------------------------------------------------------------
	3672	!! * ROUTINE stop_opa *
	3673	!!
[3764]	3674	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	3675	!! increment the error number (nstop) by one.
	3676	!!----------------------------------------------------------------------
	3677	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	3678	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	3679	!!----------------------------------------------------------------------
	3680	!
[3764]	3681	nstop = nstop + 1
[2715]	3682	IF(lwp) THEN
	3683	WRITE(numout,cform_err)
	3684	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	3685	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	3686	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	3687	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	3688	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	3689	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	3690	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	3691	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	3692	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	3693	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	3694	ENDIF
	3695	CALL FLUSH(numout )
	3696	IF( numstp /= -1 ) CALL FLUSH(numstp )
	3697	IF( numsol /= -1 ) CALL FLUSH(numsol )
	3698	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
	3699	!
	3700	IF( cd1 == 'STOP' ) THEN
	3701	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
	3702	CALL mppstop()
	3703	ENDIF
	3704	!
	3705	END SUBROUTINE ctl_stop
	3706
	3707
	3708	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
	3709	& cd6, cd7, cd8, cd9, cd10 )
	3710	!!----------------------------------------------------------------------
	3711	!! * ROUTINE stop_warn *
	3712	!!
[3764]	3713	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	3714	!! increment the warning number (nwarn) by one.
	3715	!!----------------------------------------------------------------------
	3716	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	3717	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	3718	!!----------------------------------------------------------------------
[3764]	3719	!
	3720	nwarn = nwarn + 1
[2715]	3721	IF(lwp) THEN
	3722	WRITE(numout,cform_war)
	3723	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	3724	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	3725	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	3726	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	3727	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	3728	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	3729	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	3730	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	3731	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	3732	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	3733	ENDIF
	3734	CALL FLUSH(numout)
	3735	!
	3736	END SUBROUTINE ctl_warn
	3737
	3738
	3739	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
	3740	!!----------------------------------------------------------------------
	3741	!! * ROUTINE ctl_opn *
	3742	!!
	3743	!! ** Purpose : Open file and check if required file is available.
	3744	!!
	3745	!! ** Method : Fortan open
	3746	!!----------------------------------------------------------------------
	3747	INTEGER , INTENT( out) :: knum ! logical unit to open
	3748	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
	3749	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
	3750	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
	3751	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
	3752	INTEGER , INTENT(in ) :: klengh ! record length
	3753	INTEGER , INTENT(in ) :: kout ! number of logical units for write
	3754	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
	3755	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
	3756	!!
	3757	CHARACTER(len=80) :: clfile
	3758	INTEGER :: iost
	3759	!!----------------------------------------------------------------------
	3760
	3761	! adapt filename
	3762	! ----------------
	3763	clfile = TRIM(cdfile)
	3764	IF( PRESENT( karea ) ) THEN
	3765	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
	3766	ENDIF
	3767	#if defined key_agrif
	3768	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
	3769	knum=Agrif_Get_Unit()
	3770	#else
	3771	knum=get_unit()
	3772	#endif
	3773
	3774	iost=0
	3775	IF( cdacce(1:6) == 'DIRECT' ) THEN
	3776	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
	3777	ELSE
	3778	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
	3779	ENDIF
	3780	IF( iost == 0 ) THEN
	3781	IF(ldwp) THEN
	3782	WRITE(kout,*) ' file : ', clfile,' open ok'
	3783	WRITE(kout,*) ' unit = ', knum
	3784	WRITE(kout,*) ' status = ', cdstat
	3785	WRITE(kout,*) ' form = ', cdform
	3786	WRITE(kout,*) ' access = ', cdacce
	3787	WRITE(kout,*)
	3788	ENDIF
	3789	ENDIF
	3790	100 CONTINUE
	3791	IF( iost /= 0 ) THEN
	3792	IF(ldwp) THEN
	3793	WRITE(kout,*)
	3794	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
	3795	WRITE(kout,*) ' ======= === '
	3796	WRITE(kout,*) ' unit = ', knum
	3797	WRITE(kout,*) ' status = ', cdstat
	3798	WRITE(kout,*) ' form = ', cdform
	3799	WRITE(kout,*) ' access = ', cdacce
	3800	WRITE(kout,*) ' iostat = ', iost
	3801	WRITE(kout,*) ' we stop. verify the file '
	3802	WRITE(kout,*)
	3803	ENDIF
[5675]	3804	CALL ctl_stop ('STOP', 'NEMO abort ctl_opn bad opening')
[2715]	3805	ENDIF
[3764]	3806
[2715]	3807	END SUBROUTINE ctl_opn
	3808
[4147]	3809	SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
	3810	!!----------------------------------------------------------------------
	3811	!! * ROUTINE ctl_nam *
	3812	!!
	3813	!! ** Purpose : Informations when error while reading a namelist
	3814	!!
	3815	!! ** Method : Fortan open
	3816	!!----------------------------------------------------------------------
	3817	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
	3818	CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs
	3819	CHARACTER(len=4) :: clios ! string to convert iostat in character for print
	3820	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
	3821	!!----------------------------------------------------------------------
[2715]	3822
[4147]	3823	!
	3824	! ----------------
	3825	WRITE (clios, '(I4.0)') kios
	3826	IF( kios < 0 ) THEN
	3827	CALL ctl_warn( 'W A R N I N G: end of record or file while reading namelist ' &
	3828	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
	3829	ENDIF
	3830
	3831	IF( kios > 0 ) THEN
	3832	CALL ctl_stop( 'E R R O R : misspelled variable in namelist ' &
	3833	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
	3834	ENDIF
	3835	kios = 0
	3836	RETURN
	3837
	3838	END SUBROUTINE ctl_nam
	3839
[2715]	3840	INTEGER FUNCTION get_unit()
	3841	!!----------------------------------------------------------------------
	3842	!! * FUNCTION get_unit *
	3843	!!
	3844	!! ** Purpose : return the index of an unused logical unit
	3845	!!----------------------------------------------------------------------
[3764]	3846	LOGICAL :: llopn
[2715]	3847	!!----------------------------------------------------------------------
	3848	!
	3849	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
	3850	llopn = .TRUE.
	3851	DO WHILE( (get_unit < 998) .AND. llopn )
	3852	get_unit = get_unit + 1
	3853	INQUIRE( unit = get_unit, opened = llopn )
	3854	END DO
	3855	IF( (get_unit == 999) .AND. llopn ) THEN
	3856	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
	3857	get_unit = -1
	3858	ENDIF
	3859	!
	3860	END FUNCTION get_unit
	3861
	3862	!!----------------------------------------------------------------------
[3]	3863	END MODULE lib_mpp

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

Download in other formats: