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

Context Navigation

source: branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 4785

Last change on this file since 4785 was 4785, checked in by rblod, 10 years ago
dev_r4765_CNRS_agrif: First update of AGRIF for dynamic only (_flt and _ts), see ticket #1380 and associated wiki page
Property svn:keywords set to `Id`
File size: 138.0 KB

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

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

Download in other formats: