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

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

lib_mpp.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

Context Navigation

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4314

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

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

Download in other formats: