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

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

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

Context Navigation

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

Last change on this file since 4328 was 4328, checked in by davestorkey, 10 years ago
Remove OBC module at NEMO 3.6. See ticket #1189.
Property svn:keywords set to `Id`
File size: 137.1 KB

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

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

Download in other formats: