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

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

lib_mpp.F90 in NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2018/dev_r10164_HPC09_ESIWACE_PREP_MERGE/src/OCE/LBC/lib_mpp.F90 @ 10180

Last change on this file since 10180 was 10180, checked in by smasson, 6 years ago
dev_r10164_HPC09_ESIWACE_PREP_MERGE: action 4b: reduce communications in si3, see #2133
Property svn:keywords set to `Id`
File size: 84.8 KB

Rev	Line
[3]	1	MODULE lib_mpp
[13]	2	!!======================================================================
	3	!! * MODULE lib_mpp *
[1344]	4	!! Ocean numerics: massively parallel processing library
[13]	5	!!=====================================================================
[1344]	6	!! History : OPA ! 1994 (M. Guyon, J. Escobar, M. Imbard) Original code
	7	!! 7.0 ! 1997 (A.M. Treguier) SHMEM additions
	8	!! 8.0 ! 1998 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI
	9	!! ! 1998 (J.M. Molines) Open boundary conditions
[9019]	10	!! NEMO 1.0 ! 2003 (J.M. Molines, G. Madec) F90, free form
[1344]	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
[9019]	21	!! 3.5 ! 2012 (S.Mocavero, I. Epicoco) Add mpp_lnk_bdy_3d/2d routines to optimize the BDY comm.
	22	!! 3.5 ! 2013 (C. Ethe, G. Madec) message passing arrays as local variables
[6140]	23	!! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
[9019]	24	!! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added '_multiple' case for 2D lbc and max
	25	!! 4.0 ! 2017 (G. Madec) automatique allocation of array argument (use any 3rd dimension)
	26	!! - ! 2017 (G. Madec) create generic.h90 files to generate all lbc and north fold routines
[13]	27	!!----------------------------------------------------------------------
[2715]	28
	29	!!----------------------------------------------------------------------
[6140]	30	!! ctl_stop : update momentum and tracer Kz from a tke scheme
	31	!! ctl_warn : initialization, namelist read, and parameters control
	32	!! ctl_opn : Open file and check if required file is available.
	33	!! ctl_nam : Prints informations when an error occurs while reading a namelist
	34	!! get_unit : give the index of an unused logical unit
[2715]	35	!!----------------------------------------------------------------------
[3764]	36	#if defined key_mpp_mpi
[13]	37	!!----------------------------------------------------------------------
[1344]	38	!! 'key_mpp_mpi' MPI massively parallel processing library
	39	!!----------------------------------------------------------------------
[2715]	40	!! lib_mpp_alloc : allocate mpp arrays
	41	!! mynode : indentify the processor unit
	42	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
[4990]	43	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
[6140]	44	!! mpprecv :
[9019]	45	!! mppsend :
[2715]	46	!! mppscatter :
	47	!! mppgather :
	48	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
	49	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
	50	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
	51	!! mpp_minloc :
	52	!! mpp_maxloc :
	53	!! mppsync :
	54	!! mppstop :
[1344]	55	!! mpp_ini_north : initialisation of north fold
[9019]	56	!! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
[13]	57	!!----------------------------------------------------------------------
[3764]	58	USE dom_oce ! ocean space and time domain
[2715]	59	USE lbcnfd ! north fold treatment
	60	USE in_out_manager ! I/O manager
[3]	61
[13]	62	IMPLICIT NONE
[415]	63	PRIVATE
[9019]	64
	65	INTERFACE mpp_nfd
	66	MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d
	67	MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
	68	END INTERFACE
	69
	70	! Interface associated to the mpp_lnk_... routines is defined in lbclnk
	71	PUBLIC mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d
	72	PUBLIC mpp_lnk_2d_ptr, mpp_lnk_3d_ptr, mpp_lnk_4d_ptr
	73	!
	74	!!gm this should be useless
	75	PUBLIC mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d
	76	PUBLIC mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr
	77	!!gm end
	78	!
[4147]	79	PUBLIC ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam
[1344]	80	PUBLIC mynode, mppstop, mppsync, mpp_comm_free
[9019]	81	PUBLIC mpp_ini_north
	82	PUBLIC mpp_lnk_2d_icb
	83	PUBLIC mpp_lbc_north_icb
[1344]	84	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
[6490]	85	PUBLIC mpp_max_multiple
[3294]	86	PUBLIC mppscatter, mppgather
[10180]	87	PUBLIC mpp_ini_znl
[2715]	88	PUBLIC mppsize
[3764]	89	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
[9890]	90	PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d, mpp_lnk_bdy_4d
[6490]	91	PUBLIC mpprank
[5429]	92
[13]	93	!! * Interfaces
	94	!! define generic interface for these routine as they are called sometimes
[1344]	95	!! with scalar arguments instead of array arguments, which causes problems
	96	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
[13]	97	INTERFACE mpp_min
	98	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	99	END INTERFACE
	100	INTERFACE mpp_max
[681]	101	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	102	END INTERFACE
	103	INTERFACE mpp_sum
[6140]	104	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
[9019]	105	& mppsum_realdd, mppsum_a_realdd
[13]	106	END INTERFACE
[1344]	107	INTERFACE mpp_minloc
	108	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	109	END INTERFACE
	110	INTERFACE mpp_maxloc
	111	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	112	END INTERFACE
[6490]	113	INTERFACE mpp_max_multiple
	114	MODULE PROCEDURE mppmax_real_multiple
	115	END INTERFACE
	116
[51]	117	!! ========================= !!
	118	!! MPI variable definition !!
	119	!! ========================= !!
[1629]	120	!$AGRIF_DO_NOT_TREAT
[2004]	121	INCLUDE 'mpif.h'
[1629]	122	!$AGRIF_END_DO_NOT_TREAT
[3764]	123
[1344]	124	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
[3]	125
[1344]	126	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
[3764]	127
[1344]	128	INTEGER :: mppsize ! number of process
	129	INTEGER :: mpprank ! process number [ 0 - size-1 ]
[2363]	130	!$AGRIF_DO_NOT_TREAT
[9570]	131	INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator
[2363]	132	!$AGRIF_END_DO_NOT_TREAT
[3]	133
[2480]	134	INTEGER :: MPI_SUMDD
[1976]	135
[1345]	136	! variables used for zonal integration
	137	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
[9019]	138	LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row
	139	INTEGER :: ngrp_znl ! group ID for the znl processors
	140	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
[2715]	141	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
[3]	142
[3764]	143	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
[9019]	144	INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors
	145	INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors
	146	INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold)
	147	INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north
	148	INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !)
	149	INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line
	150	INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm
	151	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north
[3764]	152
[1344]	153	! Type of send : standard, buffered, immediate
[9019]	154	CHARACTER(len=1), PUBLIC :: cn_mpi_send !: type od mpi send/recieve (S=standard, B=bsend, I=isend)
	155	LOGICAL , PUBLIC :: l_isend = .FALSE. !: isend use indicator (T if cn_mpi_send='I')
	156	INTEGER , PUBLIC :: nn_buffer !: size of the buffer in case of mpi_bsend
[3764]	157
[10170]	158	! Communications summary report
	159	CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname !: names of calling routines
	160	INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp
	161	INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos)
	162	INTEGER, PUBLIC :: n_sequence = 0 !: # of communicated arrays
	163	LOGICAL :: l_comm_report_done = .false. !: print report only once
[10172]	164
	165	! timing summary report
	166	REAL(wp), PUBLIC :: waiting_time = 0._wp, compute_time = 0._wp, elapsed_time = 0._wp
	167
[9019]	168	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
[3]	169
[9019]	170	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms
	171	LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms
	172
[51]	173	!!----------------------------------------------------------------------
[9598]	174	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
[888]	175	!! $Id$
[10068]	176	!! Software governed by the CeCILL license (see ./LICENSE)
[1344]	177	!!----------------------------------------------------------------------
[3]	178	CONTAINS
	179
[9019]	180	FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm )
[2715]	181	!!----------------------------------------------------------------------
[51]	182	!! * routine mynode *
[3764]	183	!!
[51]	184	!! ** Purpose : Find processor unit
	185	!!----------------------------------------------------------------------
[6140]	186	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt !
	187	CHARACTER(len=*) , INTENT(in ) :: ldname !
	188	INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist
	189	INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist
	190	INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output
	191	INTEGER , INTENT(inout) :: kstop ! stop indicator
	192	INTEGER , OPTIONAL , INTENT(in ) :: localComm !
[2715]	193	!
[4147]	194	INTEGER :: mynode, ierr, code, ji, ii, ios
[532]	195	LOGICAL :: mpi_was_called
[2715]	196	!
[3294]	197	NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, jpnij, ln_nnogather
[51]	198	!!----------------------------------------------------------------------
[1344]	199	!
[2481]	200	ii = 1
[6140]	201	WRITE(ldtxt(ii),*) ; ii = ii + 1
	202	WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1
	203	WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1
[1344]	204	!
[4147]	205	REWIND( kumnam_ref ) ! Namelist nammpp in reference namelist: mpi variables
	206	READ ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901)
[9168]	207	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp )
[9019]	208	!
[4147]	209	REWIND( kumnam_cfg ) ! Namelist nammpp in configuration namelist: mpi variables
	210	READ ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 )
[9168]	211	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp )
[9019]	212	!
[1344]	213	! ! control print
[6140]	214	WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1
	215	WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
	216	WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1
[9019]	217	!
[2731]	218	#if defined key_agrif
	219	IF( .NOT. Agrif_Root() ) THEN
[3764]	220	jpni = Agrif_Parent(jpni )
[2731]	221	jpnj = Agrif_Parent(jpnj )
	222	jpnij = Agrif_Parent(jpnij)
	223	ENDIF
	224	#endif
[9019]	225	!
	226	IF( jpnij < 1 ) THEN ! If jpnij is not specified in namelist then we calculate it
	227	jpnij = jpni * jpnj ! this means there will be no land cutting out.
	228	ENDIF
[2731]	229
[9019]	230	IF( jpni < 1 .OR. jpnj < 1 ) THEN
[6140]	231	WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1
[2715]	232	ELSE
[6140]	233	WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1
	234	WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1
	235	WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1
[9019]	236	ENDIF
[2715]	237
[3294]	238	WRITE(ldtxt(ii),*) ' avoid use of mpi_allgather at the north fold ln_nnogather = ', ln_nnogather ; ii = ii + 1
	239
[2480]	240	CALL mpi_initialized ( mpi_was_called, code )
	241	IF( code /= MPI_SUCCESS ) THEN
[3764]	242	DO ji = 1, SIZE(ldtxt)
[2481]	243	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
[3764]	244	END DO
[2480]	245	WRITE(*, cform_err)
	246	WRITE(, ) 'lib_mpp: Error in routine mpi_initialized'
	247	CALL mpi_abort( mpi_comm_world, code, ierr )
	248	ENDIF
[415]	249
[2480]	250	IF( mpi_was_called ) THEN
	251	!
	252	SELECT CASE ( cn_mpi_send )
	253	CASE ( 'S' ) ! Standard mpi send (blocking)
[6140]	254	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
[2480]	255	CASE ( 'B' ) ! Buffer mpi send (blocking)
[6140]	256	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
[9570]	257	IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr )
[2480]	258	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[6140]	259	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
[2480]	260	l_isend = .TRUE.
	261	CASE DEFAULT
[6140]	262	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
	263	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
[2715]	264	kstop = kstop + 1
[2480]	265	END SELECT
[9019]	266	!
	267	ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN
[6140]	268	WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1
	269	WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1
[2715]	270	kstop = kstop + 1
[532]	271	ELSE
[1601]	272	SELECT CASE ( cn_mpi_send )
[524]	273	CASE ( 'S' ) ! Standard mpi send (blocking)
[6140]	274	WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1
[2480]	275	CALL mpi_init( ierr )
[524]	276	CASE ( 'B' ) ! Buffer mpi send (blocking)
[6140]	277	WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1
[9570]	278	IF( Agrif_Root() ) CALL mpi_init_oce( ldtxt, ii, ierr )
[524]	279	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[6140]	280	WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1
[524]	281	l_isend = .TRUE.
[2480]	282	CALL mpi_init( ierr )
[524]	283	CASE DEFAULT
[6140]	284	WRITE(ldtxt(ii),cform_err) ; ii = ii + 1
	285	WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1
[2715]	286	kstop = kstop + 1
[524]	287	END SELECT
[2480]	288	!
[415]	289	ENDIF
[570]	290
[3764]	291	IF( PRESENT(localComm) ) THEN
[2480]	292	IF( Agrif_Root() ) THEN
[9570]	293	mpi_comm_oce = localComm
[2480]	294	ENDIF
	295	ELSE
[9570]	296	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code)
[2480]	297	IF( code /= MPI_SUCCESS ) THEN
[3764]	298	DO ji = 1, SIZE(ldtxt)
[2481]	299	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	300	END DO
[2480]	301	WRITE(*, cform_err)
	302	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
	303	CALL mpi_abort( mpi_comm_world, code, ierr )
	304	ENDIF
[3764]	305	ENDIF
[2480]	306
[5656]	307	#if defined key_agrif
[9019]	308	IF( Agrif_Root() ) THEN
[9570]	309	CALL Agrif_MPI_Init(mpi_comm_oce)
[5656]	310	ELSE
[9570]	311	CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
[5656]	312	ENDIF
	313	#endif
	314
[9570]	315	CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
	316	CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
[629]	317	mynode = mpprank
[4624]	318
	319	IF( mynode == 0 ) THEN
[5407]	320	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
	321	WRITE(kumond, nammpp)
[4624]	322	ENDIF
[3764]	323	!
[1976]	324	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
	325	!
[51]	326	END FUNCTION mynode
[3]	327
[9019]	328	!!----------------------------------------------------------------------
	329	!! * routine mpp_lnk_(2,3,4)d *
	330	!!
	331	!! * Argument : dummy argument use in mpp_lnk_... routines
	332	!! ptab : array or pointer of arrays on which the boundary condition is applied
	333	!! cd_nat : nature of array grid-points
	334	!! psgn : sign used across the north fold boundary
	335	!! kfld : optional, number of pt3d arrays
	336	!! cd_mpp : optional, fill the overlap area only
	337	!! pval : optional, background value (used at closed boundaries)
	338	!!----------------------------------------------------------------------
	339	!
	340	! !== 2D array and array of 2D pointer ==!
	341	!
	342	# define DIM_2d
	343	# define ROUTINE_LNK mpp_lnk_2d
	344	# include "mpp_lnk_generic.h90"
	345	# undef ROUTINE_LNK
	346	# define MULTI
	347	# define ROUTINE_LNK mpp_lnk_2d_ptr
	348	# include "mpp_lnk_generic.h90"
	349	# undef ROUTINE_LNK
	350	# undef MULTI
	351	# undef DIM_2d
	352	!
	353	! !== 3D array and array of 3D pointer ==!
	354	!
	355	# define DIM_3d
	356	# define ROUTINE_LNK mpp_lnk_3d
	357	# include "mpp_lnk_generic.h90"
	358	# undef ROUTINE_LNK
	359	# define MULTI
	360	# define ROUTINE_LNK mpp_lnk_3d_ptr
	361	# include "mpp_lnk_generic.h90"
	362	# undef ROUTINE_LNK
	363	# undef MULTI
	364	# undef DIM_3d
	365	!
	366	! !== 4D array and array of 4D pointer ==!
	367	!
	368	# define DIM_4d
	369	# define ROUTINE_LNK mpp_lnk_4d
	370	# include "mpp_lnk_generic.h90"
	371	# undef ROUTINE_LNK
	372	# define MULTI
	373	# define ROUTINE_LNK mpp_lnk_4d_ptr
	374	# include "mpp_lnk_generic.h90"
	375	# undef ROUTINE_LNK
	376	# undef MULTI
	377	# undef DIM_4d
[6140]	378
[9019]	379	!!----------------------------------------------------------------------
	380	!! * routine mpp_nfd_(2,3,4)d *
	381	!!
	382	!! * Argument : dummy argument use in mpp_nfd_... routines
	383	!! ptab : array or pointer of arrays on which the boundary condition is applied
	384	!! cd_nat : nature of array grid-points
	385	!! psgn : sign used across the north fold boundary
	386	!! kfld : optional, number of pt3d arrays
	387	!! cd_mpp : optional, fill the overlap area only
	388	!! pval : optional, background value (used at closed boundaries)
	389	!!----------------------------------------------------------------------
	390	!
	391	! !== 2D array and array of 2D pointer ==!
	392	!
	393	# define DIM_2d
	394	# define ROUTINE_NFD mpp_nfd_2d
	395	# include "mpp_nfd_generic.h90"
	396	# undef ROUTINE_NFD
	397	# define MULTI
	398	# define ROUTINE_NFD mpp_nfd_2d_ptr
	399	# include "mpp_nfd_generic.h90"
	400	# undef ROUTINE_NFD
	401	# undef MULTI
	402	# undef DIM_2d
	403	!
	404	! !== 3D array and array of 3D pointer ==!
	405	!
	406	# define DIM_3d
	407	# define ROUTINE_NFD mpp_nfd_3d
	408	# include "mpp_nfd_generic.h90"
	409	# undef ROUTINE_NFD
	410	# define MULTI
	411	# define ROUTINE_NFD mpp_nfd_3d_ptr
	412	# include "mpp_nfd_generic.h90"
	413	# undef ROUTINE_NFD
	414	# undef MULTI
	415	# undef DIM_3d
	416	!
	417	! !== 4D array and array of 4D pointer ==!
	418	!
	419	# define DIM_4d
	420	# define ROUTINE_NFD mpp_nfd_4d
	421	# include "mpp_nfd_generic.h90"
	422	# undef ROUTINE_NFD
	423	# define MULTI
	424	# define ROUTINE_NFD mpp_nfd_4d_ptr
	425	# include "mpp_nfd_generic.h90"
	426	# undef ROUTINE_NFD
	427	# undef MULTI
	428	# undef DIM_4d
[3]	429
[1344]	430
[9019]	431	!!----------------------------------------------------------------------
	432	!! * routine mpp_lnk_bdy_(2,3,4)d *
	433	!!
	434	!! * Argument : dummy argument use in mpp_lnk_... routines
	435	!! ptab : array or pointer of arrays on which the boundary condition is applied
	436	!! cd_nat : nature of array grid-points
	437	!! psgn : sign used across the north fold boundary
	438	!! kb_bdy : BDY boundary set
	439	!! kfld : optional, number of pt3d arrays
	440	!!----------------------------------------------------------------------
	441	!
	442	! !== 2D array and array of 2D pointer ==!
	443	!
	444	# define DIM_2d
	445	# define ROUTINE_BDY mpp_lnk_bdy_2d
	446	# include "mpp_bdy_generic.h90"
	447	# undef ROUTINE_BDY
	448	# undef DIM_2d
	449	!
	450	! !== 3D array and array of 3D pointer ==!
	451	!
	452	# define DIM_3d
	453	# define ROUTINE_BDY mpp_lnk_bdy_3d
	454	# include "mpp_bdy_generic.h90"
	455	# undef ROUTINE_BDY
	456	# undef DIM_3d
	457	!
	458	! !== 4D array and array of 4D pointer ==!
	459	!
[9890]	460	# define DIM_4d
	461	# define ROUTINE_BDY mpp_lnk_bdy_4d
	462	# include "mpp_bdy_generic.h90"
	463	# undef ROUTINE_BDY
	464	# undef DIM_4d
[3]	465
[9019]	466	!!----------------------------------------------------------------------
	467	!!
	468	!! load_array & mpp_lnk_2d_9 à generaliser a 3D et 4D
[5429]	469
	470
[9019]	471	!! mpp_lnk_sum_2d et 3D ====>>>>>> à virer du code !!!!
[5429]	472
[9019]	473
	474	!!----------------------------------------------------------------------
[5429]	475
	476
[888]	477
[1344]	478	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
[51]	479	!!----------------------------------------------------------------------
	480	!! * routine mppsend *
[3764]	481	!!
[51]	482	!! ** Purpose : Send messag passing array
	483	!!
	484	!!----------------------------------------------------------------------
[1344]	485	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	486	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
	487	INTEGER , INTENT(in ) :: kdest ! receive process number
	488	INTEGER , INTENT(in ) :: ktyp ! tag of the message
	489	INTEGER , INTENT(in ) :: md_req ! argument for isend
	490	!!
	491	INTEGER :: iflag
[51]	492	!!----------------------------------------------------------------------
[1344]	493	!
[1601]	494	SELECT CASE ( cn_mpi_send )
[300]	495	CASE ( 'S' ) ! Standard mpi send (blocking)
[9570]	496	CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag )
[300]	497	CASE ( 'B' ) ! Buffer mpi send (blocking)
[9570]	498	CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce , iflag )
[300]	499	CASE ( 'I' ) ! Immediate mpi send (non-blocking send)
[1344]	500	! be carefull, one more argument here : the mpi request identifier..
[9570]	501	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
[300]	502	END SELECT
[1344]	503	!
[51]	504	END SUBROUTINE mppsend
[3]	505
	506
[3294]	507	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
[51]	508	!!----------------------------------------------------------------------
	509	!! * routine mpprecv *
	510	!!
	511	!! ** Purpose : Receive messag passing array
	512	!!
	513	!!----------------------------------------------------------------------
[1344]	514	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
	515	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
	516	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
[3764]	517	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
[1344]	518	!!
[51]	519	INTEGER :: istatus(mpi_status_size)
	520	INTEGER :: iflag
[3294]	521	INTEGER :: use_source
[1344]	522	!!----------------------------------------------------------------------
	523	!
[3764]	524	! If a specific process number has been passed to the receive call,
[3294]	525	! use that one. Default is to use mpi_any_source
[6140]	526	use_source = mpi_any_source
	527	IF( PRESENT(ksource) ) use_source = ksource
	528	!
[9570]	529	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
[1344]	530	!
[51]	531	END SUBROUTINE mpprecv
[3]	532
	533
[51]	534	SUBROUTINE mppgather( ptab, kp, pio )
	535	!!----------------------------------------------------------------------
	536	!! * routine mppgather *
[3764]	537	!!
	538	!! ** Purpose : Transfert between a local subdomain array and a work
[51]	539	!! array which is distributed following the vertical level.
	540	!!
[1344]	541	!!----------------------------------------------------------------------
[6140]	542	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array
	543	INTEGER , INTENT(in ) :: kp ! record length
[1344]	544	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
[51]	545	!!
[1344]	546	INTEGER :: itaille, ierror ! temporary integer
[51]	547	!!---------------------------------------------------------------------
[1344]	548	!
	549	itaille = jpi * jpj
	550	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
[9570]	551	& mpi_double_precision, kp , mpi_comm_oce, ierror )
[1344]	552	!
[51]	553	END SUBROUTINE mppgather
[3]	554
	555
[51]	556	SUBROUTINE mppscatter( pio, kp, ptab )
	557	!!----------------------------------------------------------------------
	558	!! * routine mppscatter *
	559	!!
[3764]	560	!! ** Purpose : Transfert between awork array which is distributed
[51]	561	!! following the vertical level and the local subdomain array.
	562	!!
	563	!!----------------------------------------------------------------------
[6140]	564	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
	565	INTEGER :: kp ! Tag (not used with MPI
	566	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
[1344]	567	!!
	568	INTEGER :: itaille, ierror ! temporary integer
[51]	569	!!---------------------------------------------------------------------
[1344]	570	!
[6140]	571	itaille = jpi * jpj
[1344]	572	!
	573	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
[9570]	574	& mpi_double_precision, kp , mpi_comm_oce, ierror )
[1344]	575	!
[51]	576	END SUBROUTINE mppscatter
[3]	577
[9019]	578	!!----------------------------------------------------------------------
	579	!! * mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *
	580	!!
	581	!!----------------------------------------------------------------------
	582	!!
[869]	583	SUBROUTINE mppmax_a_int( ktab, kdim, kcom )
[681]	584	!!----------------------------------------------------------------------
[1344]	585	INTEGER , INTENT(in ) :: kdim ! size of array
	586	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
[3764]	587	INTEGER , INTENT(in ), OPTIONAL :: kcom !
[9019]	588	INTEGER :: ierror, ilocalcomm ! temporary integer
[681]	589	INTEGER, DIMENSION(kdim) :: iwork
[1344]	590	!!----------------------------------------------------------------------
[9570]	591	ilocalcomm = mpi_comm_oce
[9019]	592	IF( PRESENT(kcom) ) ilocalcomm = kcom
	593	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_max, ilocalcomm, ierror )
[681]	594	ktab(:) = iwork(:)
	595	END SUBROUTINE mppmax_a_int
[9019]	596	!!
[869]	597	SUBROUTINE mppmax_int( ktab, kcom )
[681]	598	!!----------------------------------------------------------------------
[6140]	599	INTEGER, INTENT(inout) :: ktab ! ???
	600	INTEGER, INTENT(in ), OPTIONAL :: kcom ! ???
[9019]	601	INTEGER :: ierror, iwork, ilocalcomm ! temporary integer
[1344]	602	!!----------------------------------------------------------------------
[9570]	603	ilocalcomm = mpi_comm_oce
[9019]	604	IF( PRESENT(kcom) ) ilocalcomm = kcom
	605	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, ilocalcomm, ierror )
[681]	606	ktab = iwork
	607	END SUBROUTINE mppmax_int
[9019]	608	!!
	609	SUBROUTINE mppmax_a_real( ptab, kdim, kcom )
	610	!!----------------------------------------------------------------------
	611	REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab
	612	INTEGER , INTENT(in ) :: kdim
	613	INTEGER , OPTIONAL , INTENT(in ) :: kcom
	614	INTEGER :: ierror, ilocalcomm
	615	REAL(wp), DIMENSION(kdim) :: zwork
	616	!!----------------------------------------------------------------------
[9570]	617	ilocalcomm = mpi_comm_oce
[9019]	618	IF( PRESENT(kcom) ) ilocalcomm = kcom
	619	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
	620	ptab(:) = zwork(:)
	621	END SUBROUTINE mppmax_a_real
	622	!!
	623	SUBROUTINE mppmax_real( ptab, kcom )
	624	!!----------------------------------------------------------------------
	625	REAL(wp), INTENT(inout) :: ptab ! ???
	626	INTEGER , INTENT(in ), OPTIONAL :: kcom ! ???
	627	INTEGER :: ierror, ilocalcomm
	628	REAL(wp) :: zwork
	629	!!----------------------------------------------------------------------
[9570]	630	ilocalcomm = mpi_comm_oce
[9019]	631	IF( PRESENT(kcom) ) ilocalcomm = kcom!
	632	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_max, ilocalcomm, ierror )
	633	ptab = zwork
	634	END SUBROUTINE mppmax_real
[681]	635
	636
[9019]	637	!!----------------------------------------------------------------------
	638	!! * mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *
	639	!!
	640	!!----------------------------------------------------------------------
	641	!!
[869]	642	SUBROUTINE mppmin_a_int( ktab, kdim, kcom )
[51]	643	!!----------------------------------------------------------------------
[6140]	644	INTEGER , INTENT( in ) :: kdim ! size of array
	645	INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array
	646	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	647	!!
[9019]	648	INTEGER :: ierror, ilocalcomm ! temporary integer
[51]	649	INTEGER, DIMENSION(kdim) :: iwork
[1344]	650	!!----------------------------------------------------------------------
[9570]	651	ilocalcomm = mpi_comm_oce
[9019]	652	IF( PRESENT(kcom) ) ilocalcomm = kcom
	653	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_min, ilocalcomm, ierror )
[51]	654	ktab(:) = iwork(:)
	655	END SUBROUTINE mppmin_a_int
[9019]	656	!!
[1345]	657	SUBROUTINE mppmin_int( ktab, kcom )
[51]	658	!!----------------------------------------------------------------------
	659	INTEGER, INTENT(inout) :: ktab ! ???
[1345]	660	INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array
[1344]	661	!!
[9019]	662	INTEGER :: ierror, iwork, ilocalcomm
[1344]	663	!!----------------------------------------------------------------------
[9570]	664	ilocalcomm = mpi_comm_oce
[9019]	665	IF( PRESENT(kcom) ) ilocalcomm = kcom
	666	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, ilocalcomm, ierror )
[51]	667	ktab = iwork
	668	END SUBROUTINE mppmin_int
[9019]	669	!!
	670	SUBROUTINE mppmin_a_real( ptab, kdim, kcom )
	671	!!----------------------------------------------------------------------
	672	INTEGER , INTENT(in ) :: kdim
	673	REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab
	674	INTEGER , INTENT(in ), OPTIONAL :: kcom
	675	INTEGER :: ierror, ilocalcomm
	676	REAL(wp), DIMENSION(kdim) :: zwork
	677	!!-----------------------------------------------------------------------
[9570]	678	ilocalcomm = mpi_comm_oce
[9019]	679	IF( PRESENT(kcom) ) ilocalcomm = kcom
	680	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_min, ilocalcomm, ierror )
	681	ptab(:) = zwork(:)
	682	END SUBROUTINE mppmin_a_real
	683	!!
	684	SUBROUTINE mppmin_real( ptab, kcom )
	685	!!-----------------------------------------------------------------------
	686	REAL(wp), INTENT(inout) :: ptab !
	687	INTEGER , INTENT(in ), OPTIONAL :: kcom
	688	INTEGER :: ierror, ilocalcomm
	689	REAL(wp) :: zwork
	690	!!-----------------------------------------------------------------------
[9570]	691	ilocalcomm = mpi_comm_oce
[9019]	692	IF( PRESENT(kcom) ) ilocalcomm = kcom
	693	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_min, ilocalcomm, ierror )
	694	ptab = zwork
	695	END SUBROUTINE mppmin_real
[3]	696
[13]	697
[9019]	698	!!----------------------------------------------------------------------
	699	!! * mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *
	700	!!
	701	!! Global sum of 1D array or a variable (integer, real or complex)
	702	!!----------------------------------------------------------------------
	703	!!
[51]	704	SUBROUTINE mppsum_a_int( ktab, kdim )
	705	!!----------------------------------------------------------------------
[6140]	706	INTEGER, INTENT(in ) :: kdim ! ???
	707	INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ???
[51]	708	INTEGER :: ierror
	709	INTEGER, DIMENSION (kdim) :: iwork
[1344]	710	!!----------------------------------------------------------------------
[9570]	711	CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, mpi_sum, mpi_comm_oce, ierror )
[51]	712	ktab(:) = iwork(:)
	713	END SUBROUTINE mppsum_a_int
[9019]	714	!!
[1344]	715	SUBROUTINE mppsum_int( ktab )
	716	!!----------------------------------------------------------------------
	717	INTEGER, INTENT(inout) :: ktab
	718	INTEGER :: ierror, iwork
	719	!!----------------------------------------------------------------------
[9570]	720	CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_sum, mpi_comm_oce, ierror )
[1344]	721	ktab = iwork
	722	END SUBROUTINE mppsum_int
[9019]	723	!!
[1344]	724	SUBROUTINE mppsum_a_real( ptab, kdim, kcom )
	725	!!-----------------------------------------------------------------------
[9019]	726	INTEGER , INTENT(in ) :: kdim ! size of ptab
	727	REAL(wp), DIMENSION(kdim), INTENT(inout) :: ptab ! input array
	728	INTEGER , OPTIONAL , INTENT(in ) :: kcom ! specific communicator
	729	INTEGER :: ierror, ilocalcomm ! local integer
	730	REAL(wp) :: zwork(kdim) ! local workspace
[1344]	731	!!-----------------------------------------------------------------------
[9570]	732	ilocalcomm = mpi_comm_oce
[9019]	733	IF( PRESENT(kcom) ) ilocalcomm = kcom
	734	CALL mpi_allreduce( ptab, zwork, kdim, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
[1344]	735	ptab(:) = zwork(:)
	736	END SUBROUTINE mppsum_a_real
[9019]	737	!!
[1344]	738	SUBROUTINE mppsum_real( ptab, kcom )
	739	!!-----------------------------------------------------------------------
[9019]	740	REAL(wp) , INTENT(inout) :: ptab ! input scalar
	741	INTEGER , OPTIONAL, INTENT(in ) :: kcom
	742	INTEGER :: ierror, ilocalcomm
[1344]	743	REAL(wp) :: zwork
	744	!!-----------------------------------------------------------------------
[9570]	745	ilocalcomm = mpi_comm_oce
[9019]	746	IF( PRESENT(kcom) ) ilocalcomm = kcom
	747	CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision, mpi_sum, ilocalcomm, ierror )
[1344]	748	ptab = zwork
	749	END SUBROUTINE mppsum_real
[9019]	750	!!
[1976]	751	SUBROUTINE mppsum_realdd( ytab, kcom )
	752	!!-----------------------------------------------------------------------
[9019]	753	COMPLEX(wp) , INTENT(inout) :: ytab ! input scalar
	754	INTEGER , OPTIONAL, INTENT(in ) :: kcom
	755	INTEGER :: ierror, ilocalcomm
[6140]	756	COMPLEX(wp) :: zwork
	757	!!-----------------------------------------------------------------------
[9570]	758	ilocalcomm = mpi_comm_oce
[9019]	759	IF( PRESENT(kcom) ) ilocalcomm = kcom
	760	CALL MPI_ALLREDUCE( ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
[1976]	761	ytab = zwork
	762	END SUBROUTINE mppsum_realdd
[9019]	763	!!
[1976]	764	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	765	!!----------------------------------------------------------------------
[6140]	766	INTEGER , INTENT(in ) :: kdim ! size of ytab
	767	COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array
	768	INTEGER , OPTIONAL , INTENT(in ) :: kcom
[9019]	769	INTEGER:: ierror, ilocalcomm ! local integer
[1976]	770	COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace
[6140]	771	!!-----------------------------------------------------------------------
[9570]	772	ilocalcomm = mpi_comm_oce
[9019]	773	IF( PRESENT(kcom) ) ilocalcomm = kcom
	774	CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, ilocalcomm, ierror )
[1976]	775	ytab(:) = zwork(:)
	776	END SUBROUTINE mppsum_a_realdd
[9019]	777
[3764]	778
[9019]	779	SUBROUTINE mppmax_real_multiple( pt1d, kdim, kcom )
	780	!!----------------------------------------------------------------------
	781	!! * routine mppmax_real *
	782	!!
	783	!! ** Purpose : Maximum across processor of each element of a 1D arrays
	784	!!
	785	!!----------------------------------------------------------------------
	786	REAL(wp), DIMENSION(kdim), INTENT(inout) :: pt1d ! 1D arrays
	787	INTEGER , INTENT(in ) :: kdim
	788	INTEGER , OPTIONAL , INTENT(in ) :: kcom ! local communicator
	789	!!
	790	INTEGER :: ierror, ilocalcomm
	791	REAL(wp), DIMENSION(kdim) :: zwork
	792	!!----------------------------------------------------------------------
[9570]	793	ilocalcomm = mpi_comm_oce
[9019]	794	IF( PRESENT(kcom) ) ilocalcomm = kcom
	795	!
	796	CALL mpi_allreduce( pt1d, zwork, kdim, mpi_double_precision, mpi_max, ilocalcomm, ierror )
	797	pt1d(:) = zwork(:)
	798	!
	799	END SUBROUTINE mppmax_real_multiple
[6140]	800
[9019]	801
[1344]	802	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj )
	803	!!------------------------------------------------------------------------
	804	!! * routine mpp_minloc *
	805	!!
	806	!! ** Purpose : Compute the global minimum of an array ptab
	807	!! and also give its global position
	808	!!
	809	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	810	!!
	811	!!--------------------------------------------------------------------------
	812	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	813	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	814	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
[9019]	815	INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame
[6140]	816	!
	817	INTEGER :: ierror
[1344]	818	INTEGER , DIMENSION(2) :: ilocs
	819	REAL(wp) :: zmin ! local minimum
	820	REAL(wp), DIMENSION(2,1) :: zain, zaout
	821	!!-----------------------------------------------------------------------
	822	!
[9019]	823	zmin = MINVAL( ptab(:,:) , mask= pmask == 1._wp )
	824	ilocs = MINLOC( ptab(:,:) , mask= pmask == 1._wp )
[1344]	825	!
	826	ki = ilocs(1) + nimpp - 1
	827	kj = ilocs(2) + njmpp - 1
	828	!
	829	zain(1,:)=zmin
	830	zain(2,:)=ki+10000.*kj
	831	!
[9570]	832	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror)
[1344]	833	!
	834	pmin = zaout(1,1)
	835	kj = INT(zaout(2,1)/10000.)
	836	ki = INT(zaout(2,1) - 10000.*kj )
	837	!
	838	END SUBROUTINE mpp_minloc2d
[13]	839
[3]	840
[1344]	841	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj ,kk)
	842	!!------------------------------------------------------------------------
	843	!! * routine mpp_minloc *
	844	!!
	845	!! ** Purpose : Compute the global minimum of an array ptab
	846	!! and also give its global position
	847	!!
	848	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	849	!!
	850	!!--------------------------------------------------------------------------
[9019]	851	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: ptab ! Local 2D array
	852	REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pmask ! Local mask
	853	REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab
	854	INTEGER , INTENT( out) :: ki, kj, kk ! index of minimum in global frame
	855	!
[1344]	856	INTEGER :: ierror
	857	REAL(wp) :: zmin ! local minimum
	858	INTEGER , DIMENSION(3) :: ilocs
	859	REAL(wp), DIMENSION(2,1) :: zain, zaout
	860	!!-----------------------------------------------------------------------
	861	!
[9019]	862	zmin = MINVAL( ptab(:,:,:) , mask= pmask == 1._wp )
	863	ilocs = MINLOC( ptab(:,:,:) , mask= pmask == 1._wp )
[1344]	864	!
	865	ki = ilocs(1) + nimpp - 1
	866	kj = ilocs(2) + njmpp - 1
	867	kk = ilocs(3)
	868	!
[9019]	869	zain(1,:) = zmin
	870	zain(2,:) = ki + 10000.kj + 100000000.kk
[1344]	871	!
[9570]	872	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OCE,ierror)
[1344]	873	!
	874	pmin = zaout(1,1)
	875	kk = INT( zaout(2,1) / 100000000. )
	876	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	877	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	878	!
	879	END SUBROUTINE mpp_minloc3d
[13]	880
[3]	881
[1344]	882	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
	883	!!------------------------------------------------------------------------
	884	!! * routine mpp_maxloc *
	885	!!
	886	!! ** Purpose : Compute the global maximum of an array ptab
	887	!! and also give its global position
	888	!!
	889	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	890	!!
	891	!!--------------------------------------------------------------------------
	892	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: ptab ! Local 2D array
	893	REAL(wp), DIMENSION (jpi,jpj), INTENT(in ) :: pmask ! Local mask
	894	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	895	INTEGER , INTENT( out) :: ki, kj ! index of maximum in global frame
[3764]	896	!!
[1344]	897	INTEGER :: ierror
	898	INTEGER, DIMENSION (2) :: ilocs
	899	REAL(wp) :: zmax ! local maximum
	900	REAL(wp), DIMENSION(2,1) :: zain, zaout
	901	!!-----------------------------------------------------------------------
	902	!
[9019]	903	zmax = MAXVAL( ptab(:,:) , mask= pmask == 1._wp )
	904	ilocs = MAXLOC( ptab(:,:) , mask= pmask == 1._wp )
[1344]	905	!
	906	ki = ilocs(1) + nimpp - 1
	907	kj = ilocs(2) + njmpp - 1
	908	!
	909	zain(1,:) = zmax
	910	zain(2,:) = ki + 10000. * kj
	911	!
[9570]	912	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror)
[1344]	913	!
	914	pmax = zaout(1,1)
	915	kj = INT( zaout(2,1) / 10000. )
	916	ki = INT( zaout(2,1) - 10000.* kj )
	917	!
	918	END SUBROUTINE mpp_maxloc2d
[3]	919
[13]	920
[1344]	921	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
	922	!!------------------------------------------------------------------------
	923	!! * routine mpp_maxloc *
	924	!!
	925	!! ** Purpose : Compute the global maximum of an array ptab
	926	!! and also give its global position
	927	!!
	928	!! ** Method : Use MPI_ALLREDUCE with MPI_MINLOC
	929	!!
	930	!!--------------------------------------------------------------------------
[9019]	931	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: ptab ! Local 2D array
	932	REAL(wp), DIMENSION (:,:,:), INTENT(in ) :: pmask ! Local mask
	933	REAL(wp) , INTENT( out) :: pmax ! Global maximum of ptab
	934	INTEGER , INTENT( out) :: ki, kj, kk ! index of maximum in global frame
	935	!
	936	INTEGER :: ierror ! local integer
	937	REAL(wp) :: zmax ! local maximum
[1344]	938	REAL(wp), DIMENSION(2,1) :: zain, zaout
	939	INTEGER , DIMENSION(3) :: ilocs
	940	!!-----------------------------------------------------------------------
	941	!
[9019]	942	zmax = MAXVAL( ptab(:,:,:) , mask= pmask == 1._wp )
	943	ilocs = MAXLOC( ptab(:,:,:) , mask= pmask == 1._wp )
[1344]	944	!
	945	ki = ilocs(1) + nimpp - 1
	946	kj = ilocs(2) + njmpp - 1
	947	kk = ilocs(3)
	948	!
[9019]	949	zain(1,:) = zmax
	950	zain(2,:) = ki + 10000.kj + 100000000.kk
[1344]	951	!
[9570]	952	CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OCE,ierror)
[1344]	953	!
	954	pmax = zaout(1,1)
	955	kk = INT( zaout(2,1) / 100000000. )
	956	kj = INT( zaout(2,1) - kk * 100000000. ) / 10000
	957	ki = INT( zaout(2,1) - kk * 100000000. -kj * 10000. )
	958	!
	959	END SUBROUTINE mpp_maxloc3d
[3]	960
[869]	961
[1344]	962	SUBROUTINE mppsync()
	963	!!----------------------------------------------------------------------
	964	!! * routine mppsync *
[3764]	965	!!
[1344]	966	!! ** Purpose : Massively parallel processors, synchroneous
	967	!!
	968	!!-----------------------------------------------------------------------
	969	INTEGER :: ierror
	970	!!-----------------------------------------------------------------------
	971	!
[9570]	972	CALL mpi_barrier( mpi_comm_oce, ierror )
[1344]	973	!
	974	END SUBROUTINE mppsync
[3]	975
	976
[1344]	977	SUBROUTINE mppstop
	978	!!----------------------------------------------------------------------
	979	!! * routine mppstop *
[3764]	980	!!
[3294]	981	!! ** purpose : Stop massively parallel processors method
[1344]	982	!!
	983	!!----------------------------------------------------------------------
	984	INTEGER :: info
	985	!!----------------------------------------------------------------------
	986	!
	987	CALL mppsync
	988	CALL mpi_finalize( info )
	989	!
	990	END SUBROUTINE mppstop
[3]	991
	992
[1344]	993	SUBROUTINE mpp_comm_free( kcom )
	994	!!----------------------------------------------------------------------
	995	INTEGER, INTENT(in) :: kcom
	996	!!
	997	INTEGER :: ierr
	998	!!----------------------------------------------------------------------
	999	!
	1000	CALL MPI_COMM_FREE(kcom, ierr)
	1001	!
	1002	END SUBROUTINE mpp_comm_free
[3]	1003
[869]	1004
[2715]	1005	SUBROUTINE mpp_ini_znl( kumout )
[1345]	1006	!!----------------------------------------------------------------------
	1007	!! * routine mpp_ini_znl *
	1008	!!
	1009	!! ** Purpose : Initialize special communicator for computing zonal sum
	1010	!!
	1011	!! ** Method : - Look for processors in the same row
	1012	!! - Put their number in nrank_znl
	1013	!! - Create group for the znl processors
	1014	!! - Create a communicator for znl processors
	1015	!! - Determine if processor should write znl files
	1016	!!
	1017	!! ** output
	1018	!! ndim_rank_znl = number of processors on the same row
	1019	!! ngrp_znl = group ID for the znl processors
	1020	!! ncomm_znl = communicator for the ice procs.
	1021	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
	1022	!!
	1023	!!----------------------------------------------------------------------
[2715]	1024	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
[1345]	1025	!
[2715]	1026	INTEGER :: jproc ! dummy loop integer
	1027	INTEGER :: ierr, ii ! local integer
	1028	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
	1029	!!----------------------------------------------------------------------
[1345]	1030	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
	1031	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
[9570]	1032	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce : ', mpi_comm_oce
[1345]	1033	!
[2715]	1034	ALLOCATE( kwork(jpnij), STAT=ierr )
	1035	IF( ierr /= 0 ) THEN
	1036	WRITE(kumout, cform_err)
	1037	WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij'
	1038	CALL mppstop
	1039	ENDIF
	1040
	1041	IF( jpnj == 1 ) THEN
[1345]	1042	ngrp_znl = ngrp_world
[9570]	1043	ncomm_znl = mpi_comm_oce
[1345]	1044	ELSE
	1045	!
[9570]	1046	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
[1345]	1047	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
	1048	!-$$ CALL flush(numout)
	1049	!
	1050	! Count number of processors on the same row
	1051	ndim_rank_znl = 0
	1052	DO jproc=1,jpnij
	1053	IF ( kwork(jproc) == njmpp ) THEN
	1054	ndim_rank_znl = ndim_rank_znl + 1
	1055	ENDIF
	1056	END DO
	1057	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
	1058	!-$$ CALL flush(numout)
	1059	! Allocate the right size to nrank_znl
[1441]	1060	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
[1345]	1061	ALLOCATE(nrank_znl(ndim_rank_znl))
[3764]	1062	ii = 0
[1345]	1063	nrank_znl (:) = 0
	1064	DO jproc=1,jpnij
	1065	IF ( kwork(jproc) == njmpp) THEN
	1066	ii = ii + 1
[3764]	1067	nrank_znl(ii) = jproc -1
[1345]	1068	ENDIF
	1069	END DO
	1070	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
	1071	!-$$ CALL flush(numout)
	1072
	1073	! Create the opa group
[9570]	1074	CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
[1345]	1075	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
	1076	!-$$ CALL flush(numout)
	1077
	1078	! Create the znl group from the opa group
	1079	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
	1080	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
	1081	!-$$ CALL flush(numout)
	1082
	1083	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
[9570]	1084	CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
[1345]	1085	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
	1086	!-$$ CALL flush(numout)
	1087	!
	1088	END IF
	1089
	1090	! Determines if processor if the first (starting from i=1) on the row
[3764]	1091	IF ( jpni == 1 ) THEN
[1345]	1092	l_znl_root = .TRUE.
	1093	ELSE
	1094	l_znl_root = .FALSE.
	1095	kwork (1) = nimpp
	1096	CALL mpp_min ( kwork(1), kcom = ncomm_znl)
	1097	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
	1098	END IF
	1099
[2715]	1100	DEALLOCATE(kwork)
	1101
[1345]	1102	END SUBROUTINE mpp_ini_znl
	1103
	1104
[1344]	1105	SUBROUTINE mpp_ini_north
	1106	!!----------------------------------------------------------------------
	1107	!! * routine mpp_ini_north *
	1108	!!
[3764]	1109	!! ** Purpose : Initialize special communicator for north folding
[1344]	1110	!! condition together with global variables needed in the mpp folding
	1111	!!
	1112	!! ** Method : - Look for northern processors
	1113	!! - Put their number in nrank_north
	1114	!! - Create groups for the world processors and the north processors
	1115	!! - Create a communicator for northern processors
	1116	!!
	1117	!! ** output
	1118	!! njmppmax = njmpp for northern procs
	1119	!! ndim_rank_north = number of processors in the northern line
	1120	!! nrank_north (ndim_rank_north) = number of the northern procs.
	1121	!! ngrp_world = group ID for the world processors
	1122	!! ngrp_north = group ID for the northern processors
	1123	!! ncomm_north = communicator for the northern procs.
	1124	!! north_root = number (in the world) of proc 0 in the northern comm.
	1125	!!
	1126	!!----------------------------------------------------------------------
	1127	INTEGER :: ierr
	1128	INTEGER :: jjproc
	1129	INTEGER :: ii, ji
	1130	!!----------------------------------------------------------------------
	1131	!
	1132	njmppmax = MAXVAL( njmppt )
	1133	!
	1134	! Look for how many procs on the northern boundary
	1135	ndim_rank_north = 0
	1136	DO jjproc = 1, jpnij
	1137	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
	1138	END DO
	1139	!
	1140	! Allocate the right size to nrank_north
[1441]	1141	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
[1344]	1142	ALLOCATE( nrank_north(ndim_rank_north) )
[869]	1143
[1344]	1144	! Fill the nrank_north array with proc. number of northern procs.
	1145	! Note : the rank start at 0 in MPI
	1146	ii = 0
	1147	DO ji = 1, jpnij
	1148	IF ( njmppt(ji) == njmppmax ) THEN
	1149	ii=ii+1
	1150	nrank_north(ii)=ji-1
	1151	END IF
	1152	END DO
	1153	!
	1154	! create the world group
[9570]	1155	CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
[1344]	1156	!
	1157	! Create the North group from the world group
	1158	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
	1159	!
	1160	! Create the North communicator , ie the pool of procs in the north group
[9570]	1161	CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
[1344]	1162	!
	1163	END SUBROUTINE mpp_ini_north
[869]	1164
	1165
[9570]	1166	SUBROUTINE mpi_init_oce( ldtxt, ksft, code )
[1344]	1167	!!---------------------------------------------------------------------
	1168	!! * routine mpp_init.opa *
	1169	!!
	1170	!! ** Purpose :: export and attach a MPI buffer for bsend
	1171	!!
	1172	!! ** Method :: define buffer size in namelist, if 0 no buffer attachment
	1173	!! but classical mpi_init
[3764]	1174	!!
	1175	!! History :: 01/11 :: IDRIS initial version for IBM only
[1344]	1176	!! 08/04 :: R. Benshila, generalisation
	1177	!!---------------------------------------------------------------------
[3764]	1178	CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt
[2481]	1179	INTEGER , INTENT(inout) :: ksft
	1180	INTEGER , INTENT( out) :: code
	1181	INTEGER :: ierr, ji
	1182	LOGICAL :: mpi_was_called
[1344]	1183	!!---------------------------------------------------------------------
	1184	!
	1185	CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization
[532]	1186	IF ( code /= MPI_SUCCESS ) THEN
[3764]	1187	DO ji = 1, SIZE(ldtxt)
[2481]	1188	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
[3764]	1189	END DO
[2481]	1190	WRITE(*, cform_err)
	1191	WRITE(, ) ' lib_mpp: Error in routine mpi_initialized'
[1344]	1192	CALL mpi_abort( mpi_comm_world, code, ierr )
[532]	1193	ENDIF
[1344]	1194	!
	1195	IF( .NOT. mpi_was_called ) THEN
	1196	CALL mpi_init( code )
[9570]	1197	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )
[532]	1198	IF ( code /= MPI_SUCCESS ) THEN
[3764]	1199	DO ji = 1, SIZE(ldtxt)
[2481]	1200	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	1201	END DO
	1202	WRITE(*, cform_err)
	1203	WRITE(, ) ' lib_mpp: Error in routine mpi_comm_dup'
[532]	1204	CALL mpi_abort( mpi_comm_world, code, ierr )
	1205	ENDIF
	1206	ENDIF
[1344]	1207	!
[897]	1208	IF( nn_buffer > 0 ) THEN
[2481]	1209	WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 1
[897]	1210	! Buffer allocation and attachment
[2481]	1211	ALLOCATE( tampon(nn_buffer), stat = ierr )
[3764]	1212	IF( ierr /= 0 ) THEN
	1213	DO ji = 1, SIZE(ldtxt)
[2481]	1214	IF( TRIM(ldtxt(ji)) /= '' ) WRITE(,) ldtxt(ji) ! control print of mynode
	1215	END DO
	1216	WRITE(*, cform_err)
	1217	WRITE(, ) ' lib_mpp: Error in ALLOCATE', ierr
	1218	CALL mpi_abort( mpi_comm_world, code, ierr )
	1219	END IF
	1220	CALL mpi_buffer_attach( tampon, nn_buffer, code )
[897]	1221	ENDIF
[1344]	1222	!
[9570]	1223	END SUBROUTINE mpi_init_oce
[3]	1224
[9019]	1225
	1226	SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
[1976]	1227	!!---------------------------------------------------------------------
	1228	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
	1229	!!
	1230	!! Modification of original codes written by David H. Bailey
	1231	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
	1232	!!---------------------------------------------------------------------
[9019]	1233	INTEGER , INTENT(in) :: ilen, itype
	1234	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
	1235	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
[1976]	1236	!
	1237	REAL(wp) :: zerr, zt1, zt2 ! local work variables
[9019]	1238	INTEGER :: ji, ztmp ! local scalar
	1239	!!---------------------------------------------------------------------
	1240	!
[1976]	1241	ztmp = itype ! avoid compilation warning
[9019]	1242	!
[1976]	1243	DO ji=1,ilen
	1244	! Compute ydda + yddb using Knuth's trick.
	1245	zt1 = real(ydda(ji)) + real(yddb(ji))
	1246	zerr = zt1 - real(ydda(ji))
	1247	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
	1248	+ aimag(ydda(ji)) + aimag(yddb(ji))
	1249
	1250	! The result is zt1 + zt2, after normalization.
	1251	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
	1252	END DO
[9019]	1253	!
[1976]	1254	END SUBROUTINE DDPDD_MPI
	1255
[6140]	1256
[9019]	1257	SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, kextj)
[4990]	1258	!!---------------------------------------------------------------------
	1259	!! * routine mpp_lbc_north_icb *
	1260	!!
	1261	!! ** Purpose : Ensure proper north fold horizontal bondary condition
	1262	!! in mpp configuration in case of jpn1 > 1 and for 2d
	1263	!! array with outer extra halo
	1264	!!
	1265	!! ** Method : North fold condition and mpp with more than one proc
	1266	!! in i-direction require a specific treatment. We gather
[9019]	1267	!! the 4+kextj northern lines of the global domain on 1
[4990]	1268	!! processor and apply lbc north-fold on this sub array.
	1269	!! Then we scatter the north fold array back to the processors.
[9019]	1270	!! This routine accounts for an extra halo with icebergs
	1271	!! and assumes ghost rows and columns have been suppressed.
[4990]	1272	!!
	1273	!!----------------------------------------------------------------------
	1274	REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo
	1275	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points
	1276	! ! = T , U , V , F or W -points
	1277	REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the
	1278	!! ! north fold, = 1. otherwise
[9019]	1279	INTEGER , INTENT(in ) :: kextj ! Extra halo width at north fold
[6140]	1280	!
[4990]	1281	INTEGER :: ji, jj, jr
	1282	INTEGER :: ierr, itaille, ildi, ilei, iilb
[9019]	1283	INTEGER :: ipj, ij, iproc
[4990]	1284	!
	1285	REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e
	1286	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e
	1287	!!----------------------------------------------------------------------
	1288	!
[9019]	1289	ipj=4
[9467]	1290	ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , &
	1291	& znorthloc_e(jpimax, 1-kextj:ipj+kextj) , &
	1292	& znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) )
[4990]	1293	!
[9019]	1294	ztab_e(:,:) = 0._wp
	1295	znorthloc_e(:,:) = 0._wp
[6140]	1296	!
[9467]	1297	ij = 1 - kextj
	1298	! put the last ipj+2*kextj lines of pt2d into znorthloc_e
	1299	DO jj = jpj - ipj + 1 - kextj , jpj + kextj
	1300	znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
[4990]	1301	ij = ij + 1
	1302	END DO
	1303	!
[9467]	1304	itaille = jpimax * ( ipj + 2*kextj )
	1305	CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj) , itaille, MPI_DOUBLE_PRECISION, &
	1306	& znorthgloio_e(1,1-kextj,1), itaille, MPI_DOUBLE_PRECISION, &
	1307	& ncomm_north, ierr )
[4990]	1308	!
	1309	DO jr = 1, ndim_rank_north ! recover the global north array
	1310	iproc = nrank_north(jr) + 1
	1311	ildi = nldit (iproc)
	1312	ilei = nleit (iproc)
	1313	iilb = nimppt(iproc)
[9467]	1314	DO jj = 1-kextj, ipj+kextj
[4990]	1315	DO ji = ildi, ilei
	1316	ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
	1317	END DO
	1318	END DO
	1319	END DO
	1320
	1321	! 2. North-Fold boundary conditions
	1322	! ----------------------------------
[9467]	1323	CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
[4990]	1324
[9467]	1325	ij = 1 - kextj
[4990]	1326	!! Scatter back to pt2d
[9467]	1327	DO jj = jpj - ipj + 1 - kextj , jpj + kextj
[9019]	1328	DO ji= 1, jpi
[4990]	1329	pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
	1330	END DO
[9467]	1331	ij = ij +1
[4990]	1332	END DO
	1333	!
	1334	DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
	1335	!
	1336	END SUBROUTINE mpp_lbc_north_icb
	1337
[6140]	1338
[9019]	1339	SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, kexti, kextj )
[4990]	1340	!!----------------------------------------------------------------------
	1341	!! * routine mpp_lnk_2d_icb *
	1342	!!
[9019]	1343	!! ** Purpose : Message passing management for 2d array (with extra halo for icebergs)
	1344	!! This routine receives a (1-kexti:jpi+kexti,1-kexti:jpj+kextj)
	1345	!! array (usually (0:jpi+1, 0:jpj+1)) from lbc_lnk_icb calls.
[4990]	1346	!!
	1347	!! ** Method : Use mppsend and mpprecv function for passing mask
	1348	!! between processors following neighboring subdomains.
	1349	!! domain parameters
[9019]	1350	!! jpi : first dimension of the local subdomain
	1351	!! jpj : second dimension of the local subdomain
	1352	!! kexti : number of columns for extra outer halo
	1353	!! kextj : number of rows for extra outer halo
[4990]	1354	!! nbondi : mark for "east-west local boundary"
	1355	!! nbondj : mark for "north-south local boundary"
	1356	!! noea : number for local neighboring processors
	1357	!! nowe : number for local neighboring processors
	1358	!! noso : number for local neighboring processors
	1359	!! nono : number for local neighboring processors
	1360	!!----------------------------------------------------------------------
[9019]	1361	REAL(wp), DIMENSION(1-kexti:jpi+kexti,1-kextj:jpj+kextj), INTENT(inout) :: pt2d ! 2D array with extra halo
	1362	CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points
	1363	REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold
	1364	INTEGER , INTENT(in ) :: kexti ! extra i-halo width
	1365	INTEGER , INTENT(in ) :: kextj ! extra j-halo width
	1366	!
[4990]	1367	INTEGER :: jl ! dummy loop indices
[9019]	1368	INTEGER :: imigr, iihom, ijhom ! local integers
	1369	INTEGER :: ipreci, iprecj ! - -
[4990]	1370	INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend
	1371	INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend
	1372	!!
[9019]	1373	REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn
	1374	REAL(wp), DIMENSION(1-kextj:jpj+kextj,nn_hls+kexti,2) :: r2dwe, r2dew
[4990]	1375	!!----------------------------------------------------------------------
	1376
[9019]	1377	ipreci = nn_hls + kexti ! take into account outer extra 2D overlap area
	1378	iprecj = nn_hls + kextj
[4990]	1379
	1380
	1381	! 1. standard boundary treatment
	1382	! ------------------------------
	1383	! Order matters Here !!!!
	1384	!
	1385	! ! East-West boundaries
	1386	! !* Cyclic east-west
[9667]	1387	IF( l_Iperio ) THEN
	1388	pt2d(1-kexti: 1 ,:) = pt2d(jpim1-kexti: jpim1 ,:) ! east
	1389	pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west
[4990]	1390	!
	1391	ELSE !* closed
[9667]	1392	IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point
	1393	pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west
[4990]	1394	ENDIF
[9667]	1395	! ! North-South boundaries
	1396	IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split)
	1397	pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north
	1398	pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south
	1399	ELSE !* closed
	1400	IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point
	1401	pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south
	1402	ENDIF
[4990]	1403	!
	1404
	1405	! north fold treatment
	1406	! -----------------------
	1407	IF( npolj /= 0 ) THEN
	1408	!
	1409	SELECT CASE ( jpni )
[9019]	1410	CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
	1411	CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
[4990]	1412	END SELECT
	1413	!
	1414	ENDIF
	1415
	1416	! 2. East and west directions exchange
	1417	! ------------------------------------
	1418	! we play with the neigbours AND the row number because of the periodicity
	1419	!
	1420	SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions
	1421	CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case)
[9019]	1422	iihom = jpi-nreci-kexti
[4990]	1423	DO jl = 1, ipreci
[9019]	1424	r2dew(:,jl,1) = pt2d(nn_hls+jl,:)
[4990]	1425	r2dwe(:,jl,1) = pt2d(iihom +jl,:)
	1426	END DO
	1427	END SELECT
	1428	!
	1429	! ! Migrations
[9019]	1430	imigr = ipreci * ( jpj + 2*kextj )
[4990]	1431	!
	1432	SELECT CASE ( nbondi )
	1433	CASE ( -1 )
[9019]	1434	CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 )
	1435	CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
[4990]	1436	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1437	CASE ( 0 )
[9019]	1438	CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
	1439	CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 )
	1440	CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea )
	1441	CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
[4990]	1442	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1443	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	1444	CASE ( 1 )
[9019]	1445	CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 )
	1446	CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe )
[4990]	1447	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1448	END SELECT
	1449	!
	1450	! ! Write Dirichlet lateral conditions
[9019]	1451	iihom = jpi - nn_hls
[4990]	1452	!
	1453	SELECT CASE ( nbondi )
	1454	CASE ( -1 )
	1455	DO jl = 1, ipreci
	1456	pt2d(iihom+jl,:) = r2dew(:,jl,2)
	1457	END DO
	1458	CASE ( 0 )
	1459	DO jl = 1, ipreci
[9019]	1460	pt2d(jl-kexti,:) = r2dwe(:,jl,2)
	1461	pt2d(iihom+jl,:) = r2dew(:,jl,2)
[4990]	1462	END DO
	1463	CASE ( 1 )
	1464	DO jl = 1, ipreci
[9019]	1465	pt2d(jl-kexti,:) = r2dwe(:,jl,2)
[4990]	1466	END DO
	1467	END SELECT
	1468
	1469
	1470	! 3. North and south directions
	1471	! -----------------------------
	1472	! always closed : we play only with the neigbours
	1473	!
	1474	IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions
[9019]	1475	ijhom = jpj-nrecj-kextj
[4990]	1476	DO jl = 1, iprecj
	1477	r2dsn(:,jl,1) = pt2d(:,ijhom +jl)
[9019]	1478	r2dns(:,jl,1) = pt2d(:,nn_hls+jl)
[4990]	1479	END DO
	1480	ENDIF
	1481	!
	1482	! ! Migrations
[9019]	1483	imigr = iprecj * ( jpi + 2*kexti )
[4990]	1484	!
	1485	SELECT CASE ( nbondj )
	1486	CASE ( -1 )
[9019]	1487	CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 )
	1488	CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
[4990]	1489	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1490	CASE ( 0 )
[9019]	1491	CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
	1492	CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 )
	1493	CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono )
	1494	CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
[4990]	1495	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1496	IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err)
	1497	CASE ( 1 )
[9019]	1498	CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 )
	1499	CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso )
[4990]	1500	IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err)
	1501	END SELECT
	1502	!
	1503	! ! Write Dirichlet lateral conditions
[9019]	1504	ijhom = jpj - nn_hls
[4990]	1505	!
	1506	SELECT CASE ( nbondj )
	1507	CASE ( -1 )
	1508	DO jl = 1, iprecj
	1509	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
	1510	END DO
	1511	CASE ( 0 )
	1512	DO jl = 1, iprecj
[9019]	1513	pt2d(:,jl-kextj) = r2dsn(:,jl,2)
	1514	pt2d(:,ijhom+jl) = r2dns(:,jl,2)
[4990]	1515	END DO
	1516	CASE ( 1 )
	1517	DO jl = 1, iprecj
[9019]	1518	pt2d(:,jl-kextj) = r2dsn(:,jl,2)
[4990]	1519	END DO
	1520	END SELECT
[9019]	1521	!
[4990]	1522	END SUBROUTINE mpp_lnk_2d_icb
[10172]	1523
[6140]	1524
[10172]	1525	SUBROUTINE tic_tac (l_tic)
	1526
	1527	LOGICAL, INTENT(IN) :: l_tic
	1528	REAL(wp), SAVE :: tic_wt, tic_ct = 0._wp
	1529
	1530	IF( ncom_stp <= nit000 ) RETURN
	1531	IF( ncom_stp == nitend ) RETURN
	1532
	1533	#if defined key_mpp_mpi
	1534	IF ( l_tic ) THEN
	1535	tic_wt = MPI_Wtime() ! start count tic->tac (waiting time)
	1536	IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
	1537	ELSE
	1538	waiting_time = waiting_time + MPI_Wtime() - tic_wt ! cumulate count tic->tac
	1539	tic_ct = MPI_Wtime() ! start count tac->tic (waiting time)
	1540	ENDIF
	1541	#endif
	1542
	1543	END SUBROUTINE tic_tac
	1544
	1545
[13]	1546	#else
	1547	!!----------------------------------------------------------------------
	1548	!! Default case: Dummy module share memory computing
	1549	!!----------------------------------------------------------------------
[2715]	1550	USE in_out_manager
[1976]	1551
[13]	1552	INTERFACE mpp_sum
[3294]	1553	MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i, mppsum_realdd, mppsum_a_realdd
[13]	1554	END INTERFACE
	1555	INTERFACE mpp_max
[681]	1556	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
[13]	1557	END INTERFACE
	1558	INTERFACE mpp_min
	1559	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
	1560	END INTERFACE
[1344]	1561	INTERFACE mpp_minloc
	1562	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
	1563	END INTERFACE
	1564	INTERFACE mpp_maxloc
	1565	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
	1566	END INTERFACE
[9019]	1567	INTERFACE mpp_max_multiple
	1568	MODULE PROCEDURE mppmax_real_multiple
	1569	END INTERFACE
[3]	1570
[13]	1571	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
[4147]	1572	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used)
[9570]	1573	INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator
[2715]	1574	!!----------------------------------------------------------------------
[13]	1575	CONTAINS
[3]	1576
[2715]	1577	INTEGER FUNCTION lib_mpp_alloc(kumout) ! Dummy function
	1578	INTEGER, INTENT(in) :: kumout
	1579	lib_mpp_alloc = 0
	1580	END FUNCTION lib_mpp_alloc
	1581
[5407]	1582	FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)
[1579]	1583	INTEGER, OPTIONAL , INTENT(in ) :: localComm
[3764]	1584	CHARACTER(len=*),DIMENSION(:) :: ldtxt
[5407]	1585	CHARACTER(len=*) :: ldname
[4314]	1586	INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop
[9570]	1587	IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
[5412]	1588	function_value = 0
[1579]	1589	IF( .FALSE. ) ldtxt(:) = 'never done'
[5407]	1590	CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )
[13]	1591	END FUNCTION mynode
[3]	1592
[13]	1593	SUBROUTINE mppsync ! Dummy routine
	1594	END SUBROUTINE mppsync
[3]	1595
[869]	1596	SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine
[13]	1597	REAL , DIMENSION(:) :: parr
	1598	INTEGER :: kdim
[3764]	1599	INTEGER, OPTIONAL :: kcom
[869]	1600	WRITE(,) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	1601	END SUBROUTINE mpp_sum_as
[3]	1602
[869]	1603	SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine
[13]	1604	REAL , DIMENSION(:,:) :: parr
	1605	INTEGER :: kdim
[3764]	1606	INTEGER, OPTIONAL :: kcom
[869]	1607	WRITE(,) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom
[13]	1608	END SUBROUTINE mpp_sum_a2s
[3]	1609
[869]	1610	SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine
[13]	1611	INTEGER, DIMENSION(:) :: karr
	1612	INTEGER :: kdim
[3764]	1613	INTEGER, OPTIONAL :: kcom
[869]	1614	WRITE(,) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	1615	END SUBROUTINE mpp_sum_ai
[3]	1616
[869]	1617	SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine
[13]	1618	REAL :: psca
[3764]	1619	INTEGER, OPTIONAL :: kcom
[869]	1620	WRITE(,) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom
[13]	1621	END SUBROUTINE mpp_sum_s
[2480]	1622
[869]	1623	SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine
[13]	1624	integer :: kint
[3764]	1625	INTEGER, OPTIONAL :: kcom
[869]	1626	WRITE(,) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom
[13]	1627	END SUBROUTINE mpp_sum_i
	1628
[3294]	1629	SUBROUTINE mppsum_realdd( ytab, kcom )
	1630	COMPLEX(wp), INTENT(inout) :: ytab ! input scalar
	1631	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1632	WRITE(,) 'mppsum_realdd: You should not have seen this print! error?', ytab
	1633	END SUBROUTINE mppsum_realdd
[3764]	1634
[3294]	1635	SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom )
	1636	INTEGER , INTENT( in ) :: kdim ! size of ytab
	1637	COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array
	1638	INTEGER , INTENT( in ), OPTIONAL :: kcom
	1639	WRITE(,) 'mppsum_a_realdd: You should not have seen this print! error?', kdim, ytab(1), kcom
	1640	END SUBROUTINE mppsum_a_realdd
	1641
[869]	1642	SUBROUTINE mppmax_a_real( parr, kdim, kcom )
[13]	1643	REAL , DIMENSION(:) :: parr
	1644	INTEGER :: kdim
[3764]	1645	INTEGER, OPTIONAL :: kcom
[869]	1646	WRITE(,) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	1647	END SUBROUTINE mppmax_a_real
	1648
[869]	1649	SUBROUTINE mppmax_real( psca, kcom )
[13]	1650	REAL :: psca
[3764]	1651	INTEGER, OPTIONAL :: kcom
[869]	1652	WRITE(,) 'mppmax_real: You should not have seen this print! error?', psca, kcom
[13]	1653	END SUBROUTINE mppmax_real
	1654
[869]	1655	SUBROUTINE mppmin_a_real( parr, kdim, kcom )
[13]	1656	REAL , DIMENSION(:) :: parr
	1657	INTEGER :: kdim
[3764]	1658	INTEGER, OPTIONAL :: kcom
[869]	1659	WRITE(,) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom
[13]	1660	END SUBROUTINE mppmin_a_real
	1661
[869]	1662	SUBROUTINE mppmin_real( psca, kcom )
[13]	1663	REAL :: psca
[3764]	1664	INTEGER, OPTIONAL :: kcom
[869]	1665	WRITE(,) 'mppmin_real: You should not have seen this print! error?', psca, kcom
[13]	1666	END SUBROUTINE mppmin_real
	1667
[869]	1668	SUBROUTINE mppmax_a_int( karr, kdim ,kcom)
[681]	1669	INTEGER, DIMENSION(:) :: karr
	1670	INTEGER :: kdim
[3764]	1671	INTEGER, OPTIONAL :: kcom
[888]	1672	WRITE(,) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[681]	1673	END SUBROUTINE mppmax_a_int
	1674
[869]	1675	SUBROUTINE mppmax_int( kint, kcom)
[681]	1676	INTEGER :: kint
[3764]	1677	INTEGER, OPTIONAL :: kcom
[869]	1678	WRITE(,) 'mppmax_int: You should not have seen this print! error?', kint, kcom
[681]	1679	END SUBROUTINE mppmax_int
	1680
[869]	1681	SUBROUTINE mppmin_a_int( karr, kdim, kcom )
[13]	1682	INTEGER, DIMENSION(:) :: karr
	1683	INTEGER :: kdim
[3764]	1684	INTEGER, OPTIONAL :: kcom
[869]	1685	WRITE(,) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom
[13]	1686	END SUBROUTINE mppmin_a_int
	1687
[869]	1688	SUBROUTINE mppmin_int( kint, kcom )
[13]	1689	INTEGER :: kint
[3764]	1690	INTEGER, OPTIONAL :: kcom
[869]	1691	WRITE(,) 'mppmin_int: You should not have seen this print! error?', kint, kcom
[13]	1692	END SUBROUTINE mppmin_int
	1693
[1344]	1694	SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki, kj )
[181]	1695	REAL :: pmin
	1696	REAL , DIMENSION (:,:) :: ptab, pmask
	1697	INTEGER :: ki, kj
[1528]	1698	WRITE(,) 'mpp_minloc2d: You should not have seen this print! error?', pmin, ki, kj, ptab(1,1), pmask(1,1)
[181]	1699	END SUBROUTINE mpp_minloc2d
	1700
[1344]	1701	SUBROUTINE mpp_minloc3d( ptab, pmask, pmin, ki, kj, kk )
[181]	1702	REAL :: pmin
	1703	REAL , DIMENSION (:,:,:) :: ptab, pmask
	1704	INTEGER :: ki, kj, kk
[1528]	1705	WRITE(,) 'mpp_minloc3d: You should not have seen this print! error?', pmin, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	1706	END SUBROUTINE mpp_minloc3d
	1707
[1344]	1708	SUBROUTINE mpp_maxloc2d( ptab, pmask, pmax, ki, kj )
[181]	1709	REAL :: pmax
	1710	REAL , DIMENSION (:,:) :: ptab, pmask
	1711	INTEGER :: ki, kj
[1528]	1712	WRITE(,) 'mpp_maxloc2d: You should not have seen this print! error?', pmax, ki, kj, ptab(1,1), pmask(1,1)
[181]	1713	END SUBROUTINE mpp_maxloc2d
	1714
[1344]	1715	SUBROUTINE mpp_maxloc3d( ptab, pmask, pmax, ki, kj, kk )
[181]	1716	REAL :: pmax
	1717	REAL , DIMENSION (:,:,:) :: ptab, pmask
	1718	INTEGER :: ki, kj, kk
[1528]	1719	WRITE(,) 'mpp_maxloc3d: You should not have seen this print! error?', pmax, ki, kj, kk, ptab(1,1,1), pmask(1,1,1)
[181]	1720	END SUBROUTINE mpp_maxloc3d
	1721
[51]	1722	SUBROUTINE mppstop
[3799]	1723	STOP ! non MPP case, just stop the run
[51]	1724	END SUBROUTINE mppstop
	1725
[2715]	1726	SUBROUTINE mpp_ini_znl( knum )
	1727	INTEGER :: knum
	1728	WRITE(,) 'mpp_ini_znl: You should not have seen this print! error?', knum
[1345]	1729	END SUBROUTINE mpp_ini_znl
	1730
[1344]	1731	SUBROUTINE mpp_comm_free( kcom )
[869]	1732	INTEGER :: kcom
[1344]	1733	WRITE(,) 'mpp_comm_free: You should not have seen this print! error?', kcom
[869]	1734	END SUBROUTINE mpp_comm_free
[9019]	1735
	1736	SUBROUTINE mppmax_real_multiple( ptab, kdim , kcom )
	1737	REAL, DIMENSION(:) :: ptab !
	1738	INTEGER :: kdim !
	1739	INTEGER, OPTIONAL :: kcom !
	1740	WRITE(,) 'mppmax_real_multiple: You should not have seen this print! error?', ptab(1), kdim
	1741	END SUBROUTINE mppmax_real_multiple
	1742
[3]	1743	#endif
[2715]	1744
[13]	1745	!!----------------------------------------------------------------------
[4147]	1746	!! All cases: ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
[2715]	1747	!!----------------------------------------------------------------------
	1748
	1749	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
	1750	& cd6, cd7, cd8, cd9, cd10 )
	1751	!!----------------------------------------------------------------------
	1752	!! * ROUTINE stop_opa *
	1753	!!
[3764]	1754	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	1755	!! increment the error number (nstop) by one.
	1756	!!----------------------------------------------------------------------
	1757	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	1758	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	1759	!!----------------------------------------------------------------------
	1760	!
[3764]	1761	nstop = nstop + 1
[2715]	1762	IF(lwp) THEN
	1763	WRITE(numout,cform_err)
	1764	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	1765	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	1766	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	1767	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	1768	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	1769	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	1770	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	1771	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	1772	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	1773	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	1774	ENDIF
	1775	CALL FLUSH(numout )
	1776	IF( numstp /= -1 ) CALL FLUSH(numstp )
[9019]	1777	IF( numrun /= -1 ) CALL FLUSH(numrun )
[2715]	1778	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
	1779	!
	1780	IF( cd1 == 'STOP' ) THEN
	1781	IF(lwp) WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
	1782	CALL mppstop()
	1783	ENDIF
	1784	!
	1785	END SUBROUTINE ctl_stop
	1786
	1787
	1788	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
	1789	& cd6, cd7, cd8, cd9, cd10 )
	1790	!!----------------------------------------------------------------------
	1791	!! * ROUTINE stop_warn *
	1792	!!
[3764]	1793	!! ** Purpose : print in ocean.outpput file a error message and
[2715]	1794	!! increment the warning number (nwarn) by one.
	1795	!!----------------------------------------------------------------------
	1796	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
	1797	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
	1798	!!----------------------------------------------------------------------
[3764]	1799	!
	1800	nwarn = nwarn + 1
[2715]	1801	IF(lwp) THEN
	1802	WRITE(numout,cform_war)
	1803	IF( PRESENT(cd1 ) ) WRITE(numout,*) cd1
	1804	IF( PRESENT(cd2 ) ) WRITE(numout,*) cd2
	1805	IF( PRESENT(cd3 ) ) WRITE(numout,*) cd3
	1806	IF( PRESENT(cd4 ) ) WRITE(numout,*) cd4
	1807	IF( PRESENT(cd5 ) ) WRITE(numout,*) cd5
	1808	IF( PRESENT(cd6 ) ) WRITE(numout,*) cd6
	1809	IF( PRESENT(cd7 ) ) WRITE(numout,*) cd7
	1810	IF( PRESENT(cd8 ) ) WRITE(numout,*) cd8
	1811	IF( PRESENT(cd9 ) ) WRITE(numout,*) cd9
	1812	IF( PRESENT(cd10) ) WRITE(numout,*) cd10
	1813	ENDIF
	1814	CALL FLUSH(numout)
	1815	!
	1816	END SUBROUTINE ctl_warn
	1817
	1818
	1819	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
	1820	!!----------------------------------------------------------------------
	1821	!! * ROUTINE ctl_opn *
	1822	!!
	1823	!! ** Purpose : Open file and check if required file is available.
	1824	!!
	1825	!! ** Method : Fortan open
	1826	!!----------------------------------------------------------------------
	1827	INTEGER , INTENT( out) :: knum ! logical unit to open
	1828	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
	1829	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
	1830	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
	1831	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
	1832	INTEGER , INTENT(in ) :: klengh ! record length
	1833	INTEGER , INTENT(in ) :: kout ! number of logical units for write
	1834	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
	1835	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
[5836]	1836	!
[2715]	1837	CHARACTER(len=80) :: clfile
	1838	INTEGER :: iost
	1839	!!----------------------------------------------------------------------
[5836]	1840	!
[2715]	1841	! adapt filename
	1842	! ----------------
	1843	clfile = TRIM(cdfile)
	1844	IF( PRESENT( karea ) ) THEN
	1845	IF( karea > 1 ) WRITE(clfile, "(a,'_',i4.4)") TRIM(clfile), karea-1
	1846	ENDIF
	1847	#if defined key_agrif
	1848	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
	1849	knum=Agrif_Get_Unit()
	1850	#else
	1851	knum=get_unit()
	1852	#endif
[5836]	1853	!
[2715]	1854	iost=0
	1855	IF( cdacce(1:6) == 'DIRECT' ) THEN
	1856	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh, ERR=100, IOSTAT=iost )
	1857	ELSE
	1858	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
	1859	ENDIF
	1860	IF( iost == 0 ) THEN
	1861	IF(ldwp) THEN
	1862	WRITE(kout,*) ' file : ', clfile,' open ok'
	1863	WRITE(kout,*) ' unit = ', knum
	1864	WRITE(kout,*) ' status = ', cdstat
	1865	WRITE(kout,*) ' form = ', cdform
	1866	WRITE(kout,*) ' access = ', cdacce
	1867	WRITE(kout,*)
	1868	ENDIF
	1869	ENDIF
	1870	100 CONTINUE
	1871	IF( iost /= 0 ) THEN
	1872	IF(ldwp) THEN
	1873	WRITE(kout,*)
	1874	WRITE(kout,*) ' ===>>>> : bad opening file: ', clfile
	1875	WRITE(kout,*) ' ======= === '
	1876	WRITE(kout,*) ' unit = ', knum
	1877	WRITE(kout,*) ' status = ', cdstat
	1878	WRITE(kout,*) ' form = ', cdform
	1879	WRITE(kout,*) ' access = ', cdacce
	1880	WRITE(kout,*) ' iostat = ', iost
	1881	WRITE(kout,*) ' we stop. verify the file '
	1882	WRITE(kout,*)
[9438]	1883	ELSE !!! Force writing to make sure we get the information - at least once - in this violent STOP!!
	1884	WRITE(,)
	1885	WRITE(,) ' ===>>>> : bad opening file: ', clfile
	1886	WRITE(,) ' ======= === '
	1887	WRITE(,) ' unit = ', knum
	1888	WRITE(,) ' status = ', cdstat
	1889	WRITE(,) ' form = ', cdform
	1890	WRITE(,) ' access = ', cdacce
	1891	WRITE(,) ' iostat = ', iost
	1892	WRITE(,) ' we stop. verify the file '
	1893	WRITE(,)
[2715]	1894	ENDIF
[9019]	1895	CALL FLUSH( kout )
[2715]	1896	STOP 'ctl_opn bad opening'
	1897	ENDIF
[5836]	1898	!
[2715]	1899	END SUBROUTINE ctl_opn
	1900
[5836]	1901
[4147]	1902	SUBROUTINE ctl_nam ( kios, cdnam, ldwp )
	1903	!!----------------------------------------------------------------------
	1904	!! * ROUTINE ctl_nam *
	1905	!!
	1906	!! ** Purpose : Informations when error while reading a namelist
	1907	!!
	1908	!! ** Method : Fortan open
	1909	!!----------------------------------------------------------------------
[5836]	1910	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
	1911	CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs
[7646]	1912	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
[5836]	1913	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
[4147]	1914	!!----------------------------------------------------------------------
[5836]	1915	!
[7646]	1916	WRITE (clios, '(I5.0)') kios
[4147]	1917	IF( kios < 0 ) THEN
[5836]	1918	CALL ctl_warn( 'end of record or file while reading namelist ' &
	1919	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
[4147]	1920	ENDIF
[5836]	1921	!
[4147]	1922	IF( kios > 0 ) THEN
[5836]	1923	CALL ctl_stop( 'misspelled variable in namelist ' &
	1924	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
[4147]	1925	ENDIF
	1926	kios = 0
	1927	RETURN
[5836]	1928	!
[4147]	1929	END SUBROUTINE ctl_nam
	1930
[5836]	1931
[2715]	1932	INTEGER FUNCTION get_unit()
	1933	!!----------------------------------------------------------------------
	1934	!! * FUNCTION get_unit *
	1935	!!
	1936	!! ** Purpose : return the index of an unused logical unit
	1937	!!----------------------------------------------------------------------
[3764]	1938	LOGICAL :: llopn
[2715]	1939	!!----------------------------------------------------------------------
	1940	!
	1941	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
	1942	llopn = .TRUE.
	1943	DO WHILE( (get_unit < 998) .AND. llopn )
	1944	get_unit = get_unit + 1
	1945	INQUIRE( unit = get_unit, opened = llopn )
	1946	END DO
	1947	IF( (get_unit == 999) .AND. llopn ) THEN
	1948	CALL ctl_stop( 'get_unit: All logical units until 999 are used...' )
	1949	get_unit = -1
	1950	ENDIF
	1951	!
	1952	END FUNCTION get_unit
	1953
	1954	!!----------------------------------------------------------------------
[3]	1955	END MODULE lib_mpp

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

Download in other formats: