Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

lib_mpp.F90 @ 12004

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

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

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

Context Navigation

source: branches/UKMO/AMM15_v3_6_STABLE_package_collate/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90 @ 12004

Download in other formats: