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

Context Navigation

source: branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4162

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

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

Download in other formats: