Context Navigation

lib_mpp.F90 @ 6546

Last change on this file since 6546 was 6546, checked in by frrh, 8 years ago

Commit final changes relating to manual addition of relevant code
from fcm:NEMO.xm/branches/UKMO/dev_r5107_hadgem3_mct@6355.

Note this is a subset of the total changnes... I have ecluded those which
have become or appear redundant or unnecessary.

This version bit compares with the original.

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

Download in other formats: