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

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

lib_mpp.F90 in trunk/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

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

Last change on this file since 5412 was 5412, checked in by hadcv, 9 years ago
Set mpi_comm_opa in non-MPP cases (addresses #1533) Add an xios_context_finalize in step_C1D
Property svn:keywords set to `Id`
File size: 149.3 KB

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

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

Download in other formats: