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

Context Navigation

source: branches/UKMO/dev_r5518_GC3_couple_pkg/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 6576

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

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

Download in other formats: