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

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

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

Context Navigation

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

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

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

Download in other formats: