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/2021/dev_r14447_HPC-07_Irrmann_try_new_pt2pt/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2021/dev_r14447_HPC-07_Irrmann_try_new_pt2pt/src/OCE/LBC/lib_mpp.F90 @ 14835

Last change on this file since 14835 was 14835, checked in by girrmann, 3 years ago
Add new communication schemes, non blocking with diagonals and persistent calls for time splitting
Property svn:keywords set to `Id`
File size: 77.5 KB

Line
1	MODULE lib_mpp
2	!!======================================================================
3	!! * MODULE lib_mpp *
4	!! Ocean numerics: massively parallel processing library
5	!!=====================================================================
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
19	!! 3.2 ! 2009 (O. Marti) add mpp_ini_znl
20	!! 4.0 ! 2011 (G. Madec) move ctl_ routines from in_out_manager
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
23	!! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations
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
27	!!----------------------------------------------------------------------
28
29	!!----------------------------------------------------------------------
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	!! load_nml : Read, condense and buffer namelist file into character array for use as an internal file
35	!!----------------------------------------------------------------------
36	!!----------------------------------------------------------------------
37	!! mpp_start : get local communicator its size and rank
38	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
39	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
40	!! mpprecv :
41	!! mppsend :
42	!! mppscatter :
43	!! mppgather :
44	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
45	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
46	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
47	!! mpp_minloc :
48	!! mpp_maxloc :
49	!! mppsync :
50	!! mppstop :
51	!! mpp_ini_north : initialisation of north fold
52	!! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
53	!! mpp_bcast_nml : broadcast/receive namelist character buffer from reading process to all others
54	!!----------------------------------------------------------------------
55	USE dom_oce ! ocean space and time domain
56	USE in_out_manager ! I/O manager
57	#if ! defined key_mpi_off
58	USE MPI
59	#endif
60
61	IMPLICIT NONE
62	PRIVATE
63	!
64	PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam, load_nml
65	PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free
66	PUBLIC mpp_ini_north
67	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
68	PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv
69	PUBLIC mppscatter, mppgather
70	PUBLIC mpp_ini_znl
71	PUBLIC mpp_ini_nc
72	PUBLIC mpp_ini_pers
73	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
74	PUBLIC mppsend_sp, mpprecv_sp ! needed by TAM and ICB routines
75	PUBLIC mppsend_dp, mpprecv_dp ! needed by TAM and ICB routines
76	PUBLIC mpp_report
77	PUBLIC mpp_bcast_nml
78	PUBLIC tic_tac
79	#if defined key_mpp_off
80	PUBLIC MPI_wait
81	PUBLIC MPI_Wtime
82	#endif
83
84	!! * Interfaces
85	!! define generic interface for these routine as they are called sometimes
86	!! with scalar arguments instead of array arguments, which causes problems
87	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
88	INTERFACE mpp_min
89	MODULE PROCEDURE mppmin_a_int, mppmin_int
90	MODULE PROCEDURE mppmin_a_real_sp, mppmin_real_sp
91	MODULE PROCEDURE mppmin_a_real_dp, mppmin_real_dp
92	END INTERFACE
93	INTERFACE mpp_max
94	MODULE PROCEDURE mppmax_a_int, mppmax_int
95	MODULE PROCEDURE mppmax_a_real_sp, mppmax_real_sp
96	MODULE PROCEDURE mppmax_a_real_dp, mppmax_real_dp
97	END INTERFACE
98	INTERFACE mpp_sum
99	MODULE PROCEDURE mppsum_a_int, mppsum_int
100	MODULE PROCEDURE mppsum_realdd, mppsum_a_realdd
101	MODULE PROCEDURE mppsum_a_real_sp, mppsum_real_sp
102	MODULE PROCEDURE mppsum_a_real_dp, mppsum_real_dp
103	END INTERFACE
104	INTERFACE mpp_minloc
105	MODULE PROCEDURE mpp_minloc2d_sp ,mpp_minloc3d_sp
106	MODULE PROCEDURE mpp_minloc2d_dp ,mpp_minloc3d_dp
107	END INTERFACE
108	INTERFACE mpp_maxloc
109	MODULE PROCEDURE mpp_maxloc2d_sp ,mpp_maxloc3d_sp
110	MODULE PROCEDURE mpp_maxloc2d_dp ,mpp_maxloc3d_dp
111	END INTERFACE
112
113	TYPE, PUBLIC :: PTR_4D_sp !: array of 4D pointers (used in lbclnk and lbcnfd)
114	REAL(sp), DIMENSION (:,:,:,:), POINTER :: pt4d
115	END TYPE PTR_4D_sp
116
117	TYPE, PUBLIC :: PTR_4D_dp !: array of 4D pointers (used in lbclnk and lbcnfd)
118	REAL(dp), DIMENSION (:,:,:,:), POINTER :: pt4d
119	END TYPE PTR_4D_dp
120
121	!! ========================= !!
122	!! MPI variable definition !!
123	!! ========================= !!
124	#if ! defined key_mpi_off
125	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
126	#else
127	INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1
128	INTEGER, PUBLIC, PARAMETER :: MPI_REAL = 4
129	INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8
130	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
131	#endif
132
133	INTEGER, PUBLIC :: mppsize ! number of process
134	INTEGER, PUBLIC :: mpprank ! process number [ 0 - size-1 ]
135	!$AGRIF_DO_NOT_TREAT
136	INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator
137	!$AGRIF_END_DO_NOT_TREAT
138
139	INTEGER :: MPI_SUMDD
140
141	! Neighbourgs informations
142	INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3
143	INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg)
144	INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg)
145	INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg)
146	INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst
147	INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst
148	INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth
149	INTEGER, PARAMETER, PUBLIC :: jpno = 4 !: NOrth
150	INTEGER, PARAMETER, PUBLIC :: jpsw = 5 !: South-West
151	INTEGER, PARAMETER, PUBLIC :: jpse = 6 !: South-East
152	INTEGER, PARAMETER, PUBLIC :: jpnw = 7 !: North-West
153	INTEGER, PARAMETER, PUBLIC :: jpne = 8 !: North-East
154
155	LOGICAL, DIMENSION(8), PUBLIC :: l_SelfPerio ! should we explicitely take care of I/J periodicity
156	LOGICAL, PUBLIC :: l_IdoNFold
157
158	! variables used for zonal integration
159	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
160	LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row
161	INTEGER :: ngrp_znl !: group ID for the znl processors
162	INTEGER :: ndim_rank_znl !: number of processors on the same zonal average
163	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
164
165	! variables used for MPI3 neighbourhood collectives
166	INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com4 ! MPI3 neighbourhood collectives communicator
167	INTEGER, DIMENSION(n_hlsmax), PUBLIC :: mpi_nc_com8 ! MPI3 neighbourhood collectives communicator (with diagionals)
168
169	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
170	INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors
171	INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors
172	INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold)
173	INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north
174	INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !)
175	INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line
176	INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm
177	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north
178
179	! Communications summary report
180	CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines
181	CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines
182	CHARACTER(len=lca), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines
183	INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp
184	INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc
185	INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic
186	INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos)
187	INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record
188	INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc
189	INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications
190	INTEGER, PUBLIC :: n_sequence_dlg = 0 !: # of delayed global communications
191	INTEGER, PUBLIC :: numcom = -1 !: logical unit for communicaton report
192	LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. !: logical for a full (2lines) update of bc at North fold report
193	INTEGER, PARAMETER, PUBLIC :: nbdelay = 2 !: number of delayed operations
194	!: name (used as id) of allreduce-delayed operations
195	! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
196	CHARACTER(len=32), DIMENSION(nbdelay), PUBLIC :: c_delaylist = (/ 'cflice', 'fwb ' /)
197	!: component name where the allreduce-delayed operation is performed
198	CHARACTER(len=3), DIMENSION(nbdelay), PUBLIC :: c_delaycpnt = (/ 'ICE' , 'OCE' /)
199	TYPE, PUBLIC :: DELAYARR
200	REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL()
201	COMPLEX(dp), POINTER, DIMENSION(:) :: y1d => NULL()
202	END TYPE DELAYARR
203	TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR
204	INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations
205
206	! timing summary report
207	REAL(dp), DIMENSION(2), PUBLIC :: waiting_time = 0._dp
208	REAL(dp) , PUBLIC :: compute_time = 0._dp, elapsed_time = 0._dp
209
210	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms
211	INTEGER, PUBLIC :: nn_comm !: namelist control of comms
212
213	INTEGER, PUBLIC, PARAMETER :: jpfillnothing = 1
214	INTEGER, PUBLIC, PARAMETER :: jpfillcst = 2
215	INTEGER, PUBLIC, PARAMETER :: jpfillcopy = 3
216	INTEGER, PUBLIC, PARAMETER :: jpfillperio = 4
217	INTEGER, PUBLIC, PARAMETER :: jpfillmpi = 5
218
219	! Variables for eventual persistent call
220	REAL(wp), DIMENSION(:), ALLOCATABLE, PUBLIC :: buffS_pers, buffR_pers
221	INTEGER , DIMENSION(:), ALLOCATABLE, PUBLIC :: nreq_pers
222	LOGICAL , PUBLIC :: lints = .FALSE. ! indicate if currently in time-splitting (for persistent calls)
223	LOGICAL , PUBLIC :: ln_tspers ! indicate if persistent call enabled in time-splitting
224
225	!! * Substitutions
226	# include "do_loop_substitute.h90"
227	!!----------------------------------------------------------------------
228	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
229	!! $Id$
230	!! Software governed by the CeCILL license (see ./LICENSE)
231	!!----------------------------------------------------------------------
232	CONTAINS
233
234	SUBROUTINE mpp_start( localComm )
235	!!----------------------------------------------------------------------
236	!! * routine mpp_start *
237	!!
238	!! ** Purpose : get mpi_comm_oce, mpprank and mppsize
239	!!----------------------------------------------------------------------
240	INTEGER , OPTIONAL , INTENT(in ) :: localComm !
241	!
242	INTEGER :: ierr
243	LOGICAL :: llmpi_init
244	!!----------------------------------------------------------------------
245	#if ! defined key_mpi_off
246	!
247	CALL mpi_initialized ( llmpi_init, ierr )
248	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' )
249
250	IF( .NOT. llmpi_init ) THEN
251	IF( PRESENT(localComm) ) THEN
252	WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator '
253	WRITE(ctmp2,*) ' without calling MPI_Init before ! '
254	CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
255	ENDIF
256	CALL mpi_init( ierr )
257	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' )
258	ENDIF
259
260	IF( PRESENT(localComm) ) THEN
261	IF( Agrif_Root() ) THEN
262	mpi_comm_oce = localComm
263	ENDIF
264	ELSE
265	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr)
266	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' )
267	ENDIF
268
269	# if defined key_agrif
270	IF( Agrif_Root() ) THEN
271	CALL Agrif_MPI_Init(mpi_comm_oce)
272	ELSE
273	CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
274	ENDIF
275	# endif
276
277	CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
278	CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
279	!
280	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
281	!
282	#else
283	IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
284	mppsize = 1
285	mpprank = 0
286	#endif
287	END SUBROUTINE mpp_start
288
289
290	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
291	!!----------------------------------------------------------------------
292	!! * routine mppsend *
293	!!
294	!! ** Purpose : Send messag passing array
295	!!
296	!!----------------------------------------------------------------------
297	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
298	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
299	INTEGER , INTENT(in ) :: kdest ! receive process number
300	INTEGER , INTENT(in ) :: ktyp ! tag of the message
301	INTEGER , INTENT(inout) :: md_req ! argument for isend
302	!!
303	INTEGER :: iflag
304	INTEGER :: mpi_working_type
305	!!----------------------------------------------------------------------
306	!
307	#if ! defined key_mpi_off
308	IF (wp == dp) THEN
309	mpi_working_type = mpi_double_precision
310	ELSE
311	mpi_working_type = mpi_real
312	END IF
313	CALL mpi_isend( pmess, kbytes, mpi_working_type, kdest , ktyp, mpi_comm_oce, md_req, iflag )
314	#endif
315	!
316	END SUBROUTINE mppsend
317
318
319	SUBROUTINE mppsend_dp( ktyp, pmess, kbytes, kdest, md_req )
320	!!----------------------------------------------------------------------
321	!! * routine mppsend *
322	!!
323	!! ** Purpose : Send messag passing array
324	!!
325	!!----------------------------------------------------------------------
326	REAL(dp), INTENT(inout) :: pmess(*) ! array of real
327	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
328	INTEGER , INTENT(in ) :: kdest ! receive process number
329	INTEGER , INTENT(in ) :: ktyp ! tag of the message
330	INTEGER , INTENT(inout) :: md_req ! argument for isend
331	!!
332	INTEGER :: iflag
333	!!----------------------------------------------------------------------
334	!
335	#if ! defined key_mpi_off
336	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
337	#endif
338	!
339	END SUBROUTINE mppsend_dp
340
341
342	SUBROUTINE mppsend_sp( ktyp, pmess, kbytes, kdest, md_req )
343	!!----------------------------------------------------------------------
344	!! * routine mppsend *
345	!!
346	!! ** Purpose : Send messag passing array
347	!!
348	!!----------------------------------------------------------------------
349	REAL(sp), INTENT(inout) :: pmess(*) ! array of real
350	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
351	INTEGER , INTENT(in ) :: kdest ! receive process number
352	INTEGER , INTENT(in ) :: ktyp ! tag of the message
353	INTEGER , INTENT(inout) :: md_req ! argument for isend
354	!!
355	INTEGER :: iflag
356	!!----------------------------------------------------------------------
357	!
358	#if ! defined key_mpi_off
359	CALL mpi_isend( pmess, kbytes, mpi_real, kdest , ktyp, mpi_comm_oce, md_req, iflag )
360	#endif
361	!
362	END SUBROUTINE mppsend_sp
363
364
365	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
366	!!----------------------------------------------------------------------
367	!! * routine mpprecv *
368	!!
369	!! ** Purpose : Receive messag passing array
370	!!
371	!!----------------------------------------------------------------------
372	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
373	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
374	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
375	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
376	!!
377	INTEGER :: istatus(mpi_status_size)
378	INTEGER :: iflag
379	INTEGER :: use_source
380	INTEGER :: mpi_working_type
381	!!----------------------------------------------------------------------
382	!
383	#if ! defined key_mpi_off
384	! If a specific process number has been passed to the receive call,
385	! use that one. Default is to use mpi_any_source
386	use_source = mpi_any_source
387	IF( PRESENT(ksource) ) use_source = ksource
388	!
389	IF (wp == dp) THEN
390	mpi_working_type = mpi_double_precision
391	ELSE
392	mpi_working_type = mpi_real
393	END IF
394	CALL mpi_recv( pmess, kbytes, mpi_working_type, use_source, ktyp, mpi_comm_oce, istatus, iflag )
395	#endif
396	!
397	END SUBROUTINE mpprecv
398
399	SUBROUTINE mpprecv_dp( ktyp, pmess, kbytes, ksource )
400	!!----------------------------------------------------------------------
401	!! * routine mpprecv *
402	!!
403	!! ** Purpose : Receive messag passing array
404	!!
405	!!----------------------------------------------------------------------
406	REAL(dp), INTENT(inout) :: pmess(*) ! array of real
407	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
408	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
409	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
410	!!
411	INTEGER :: istatus(mpi_status_size)
412	INTEGER :: iflag
413	INTEGER :: use_source
414	!!----------------------------------------------------------------------
415	!
416	#if ! defined key_mpi_off
417	! If a specific process number has been passed to the receive call,
418	! use that one. Default is to use mpi_any_source
419	use_source = mpi_any_source
420	IF( PRESENT(ksource) ) use_source = ksource
421	!
422	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
423	#endif
424	!
425	END SUBROUTINE mpprecv_dp
426
427
428	SUBROUTINE mpprecv_sp( ktyp, pmess, kbytes, ksource )
429	!!----------------------------------------------------------------------
430	!! * routine mpprecv *
431	!!
432	!! ** Purpose : Receive messag passing array
433	!!
434	!!----------------------------------------------------------------------
435	REAL(sp), INTENT(inout) :: pmess(*) ! array of real
436	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
437	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
438	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
439	!!
440	INTEGER :: istatus(mpi_status_size)
441	INTEGER :: iflag
442	INTEGER :: use_source
443	!!----------------------------------------------------------------------
444	!
445	#if ! defined key_mpi_off
446	! If a specific process number has been passed to the receive call,
447	! use that one. Default is to use mpi_any_source
448	use_source = mpi_any_source
449	IF( PRESENT(ksource) ) use_source = ksource
450	!
451	CALL mpi_recv( pmess, kbytes, mpi_real, use_source, ktyp, mpi_comm_oce, istatus, iflag )
452	#endif
453	!
454	END SUBROUTINE mpprecv_sp
455
456
457	SUBROUTINE mppgather( ptab, kp, pio )
458	!!----------------------------------------------------------------------
459	!! * routine mppgather *
460	!!
461	!! ** Purpose : Transfert between a local subdomain array and a work
462	!! array which is distributed following the vertical level.
463	!!
464	!!----------------------------------------------------------------------
465	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array
466	INTEGER , INTENT(in ) :: kp ! record length
467	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
468	!!
469	INTEGER :: itaille, ierror ! temporary integer
470	!!---------------------------------------------------------------------
471	!
472	itaille = jpi * jpj
473	#if ! defined key_mpi_off
474	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
475	& mpi_double_precision, kp , mpi_comm_oce, ierror )
476	#else
477	pio(:,:,1) = ptab(:,:)
478	#endif
479	!
480	END SUBROUTINE mppgather
481
482
483	SUBROUTINE mppscatter( pio, kp, ptab )
484	!!----------------------------------------------------------------------
485	!! * routine mppscatter *
486	!!
487	!! ** Purpose : Transfert between awork array which is distributed
488	!! following the vertical level and the local subdomain array.
489	!!
490	!!----------------------------------------------------------------------
491	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
492	INTEGER :: kp ! Tag (not used with MPI
493	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
494	!!
495	INTEGER :: itaille, ierror ! temporary integer
496	!!---------------------------------------------------------------------
497	!
498	itaille = jpi * jpj
499	!
500	#if ! defined key_mpi_off
501	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
502	& mpi_double_precision, kp , mpi_comm_oce, ierror )
503	#else
504	ptab(:,:) = pio(:,:,1)
505	#endif
506	!
507	END SUBROUTINE mppscatter
508
509
510	SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom )
511	!!----------------------------------------------------------------------
512	!! * routine mpp_delay_sum *
513	!!
514	!! ** Purpose : performed delayed mpp_sum, the result is received on next call
515	!!
516	!!----------------------------------------------------------------------
517	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
518	CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
519	COMPLEX(dp), INTENT(in ), DIMENSION(:) :: y_in
520	REAL(wp), INTENT( out), DIMENSION(:) :: pout
521	LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
522	INTEGER, INTENT(in ), OPTIONAL :: kcom
523	!!
524	INTEGER :: ji, isz
525	INTEGER :: idvar
526	INTEGER :: ierr, ilocalcomm
527	COMPLEX(dp), ALLOCATABLE, DIMENSION(:) :: ytmp
528	!!----------------------------------------------------------------------
529	#if ! defined key_mpi_off
530	ilocalcomm = mpi_comm_oce
531	IF( PRESENT(kcom) ) ilocalcomm = kcom
532
533	isz = SIZE(y_in)
534
535	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
536
537	idvar = -1
538	DO ji = 1, nbdelay
539	IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
540	END DO
541	IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_sum : please add a new delayed exchange for '//TRIM(cdname) )
542
543	IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst
544	! --------------------------
545	IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence
546	IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
547	DEALLOCATE(todelay(idvar)%z1d)
548	ndelayid(idvar) = -1 ! do as if we had no restart
549	ELSE
550	ALLOCATE(todelay(idvar)%y1d(isz))
551	todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd
552	ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value
553	END IF
554	ENDIF
555
556	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce
557	! --------------------------
558	ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart
559	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d
560	ndelayid(idvar) = MPI_REQUEST_NULL
561	ENDIF
562
563	CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
564
565	! send back pout from todelay(idvar)%z1d defined at previous call
566	pout(:) = todelay(idvar)%z1d(:)
567
568	! send y_in into todelay(idvar)%y1d with a non-blocking communication
569	# if defined key_mpi2
570	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
571	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )
572	ndelayid(idvar) = MPI_REQUEST_NULL
573	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
574	# else
575	CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
576	# endif
577	#else
578	pout(:) = REAL(y_in(:), wp)
579	#endif
580
581	END SUBROUTINE mpp_delay_sum
582
583
584	SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom )
585	!!----------------------------------------------------------------------
586	!! * routine mpp_delay_max *
587	!!
588	!! ** Purpose : performed delayed mpp_max, the result is received on next call
589	!!
590	!!----------------------------------------------------------------------
591	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
592	CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
593	REAL(wp), INTENT(in ), DIMENSION(:) :: p_in !
594	REAL(wp), INTENT( out), DIMENSION(:) :: pout !
595	LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
596	INTEGER, INTENT(in ), OPTIONAL :: kcom
597	!!
598	INTEGER :: ji, isz
599	INTEGER :: idvar
600	INTEGER :: ierr, ilocalcomm
601	INTEGER :: MPI_TYPE
602	!!----------------------------------------------------------------------
603
604	#if ! defined key_mpi_off
605	if( wp == dp ) then
606	MPI_TYPE = MPI_DOUBLE_PRECISION
607	else if ( wp == sp ) then
608	MPI_TYPE = MPI_REAL
609	else
610	CALL ctl_stop( "Error defining type, wp is neither dp nor sp" )
611
612	end if
613
614	ilocalcomm = mpi_comm_oce
615	IF( PRESENT(kcom) ) ilocalcomm = kcom
616
617	isz = SIZE(p_in)
618
619	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
620
621	idvar = -1
622	DO ji = 1, nbdelay
623	IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
624	END DO
625	IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) )
626
627	IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst
628	! --------------------------
629	IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence
630	IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
631	DEALLOCATE(todelay(idvar)%z1d)
632	ndelayid(idvar) = -1 ! do as if we had no restart
633	ELSE
634	ndelayid(idvar) = MPI_REQUEST_NULL
635	END IF
636	ENDIF
637
638	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce
639	! --------------------------
640	ALLOCATE(todelay(idvar)%z1d(isz))
641	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d
642	ndelayid(idvar) = MPI_REQUEST_NULL
643	ENDIF
644
645	CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
646
647	! send back pout from todelay(idvar)%z1d defined at previous call
648	pout(:) = todelay(idvar)%z1d(:)
649
650	! send p_in into todelay(idvar)%z1d with a non-blocking communication
651	! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ?
652	# if defined key_mpi2
653	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
654	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ierr )
655	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
656	# else
657	CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_TYPE, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
658	# endif
659	#else
660	pout(:) = p_in(:)
661	#endif
662
663	END SUBROUTINE mpp_delay_max
664
665
666	SUBROUTINE mpp_delay_rcv( kid )
667	!!----------------------------------------------------------------------
668	!! * routine mpp_delay_rcv *
669	!!
670	!! ** Purpose : force barrier for delayed mpp (needed for restart)
671	!!
672	!!----------------------------------------------------------------------
673	INTEGER,INTENT(in ) :: kid
674	INTEGER :: ierr
675	!!----------------------------------------------------------------------
676	#if ! defined key_mpi_off
677	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
678	! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL
679	CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL
680	IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.)
681	IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d
682	#endif
683	END SUBROUTINE mpp_delay_rcv
684
685	SUBROUTINE mpp_bcast_nml( cdnambuff , kleng )
686	CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff
687	INTEGER , INTENT(INOUT) :: kleng
688	!!----------------------------------------------------------------------
689	!! * routine mpp_bcast_nml *
690	!!
691	!! ** Purpose : broadcast namelist character buffer
692	!!
693	!!----------------------------------------------------------------------
694	!!
695	INTEGER :: iflag
696	!!----------------------------------------------------------------------
697	!
698	#if ! defined key_mpi_off
699	call MPI_BCAST(kleng, 1, MPI_INT, 0, mpi_comm_oce, iflag)
700	call MPI_BARRIER(mpi_comm_oce, iflag)
701	!$AGRIF_DO_NOT_TREAT
702	IF ( .NOT. ALLOCATED(cdnambuff) ) ALLOCATE( CHARACTER(LEN=kleng) :: cdnambuff )
703	!$AGRIF_END_DO_NOT_TREAT
704	call MPI_BCAST(cdnambuff, kleng, MPI_CHARACTER, 0, mpi_comm_oce, iflag)
705	call MPI_BARRIER(mpi_comm_oce, iflag)
706	#endif
707	!
708	END SUBROUTINE mpp_bcast_nml
709
710
711	!!----------------------------------------------------------------------
712	!! * mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *
713	!!
714	!!----------------------------------------------------------------------
715	!!
716	# define OPERATION_MAX
717	# define INTEGER_TYPE
718	# define DIM_0d
719	# define ROUTINE_ALLREDUCE mppmax_int
720	# include "mpp_allreduce_generic.h90"
721	# undef ROUTINE_ALLREDUCE
722	# undef DIM_0d
723	# define DIM_1d
724	# define ROUTINE_ALLREDUCE mppmax_a_int
725	# include "mpp_allreduce_generic.h90"
726	# undef ROUTINE_ALLREDUCE
727	# undef DIM_1d
728	# undef INTEGER_TYPE
729	!
730	!!
731	!! ---- SINGLE PRECISION VERSIONS
732	!!
733	# define SINGLE_PRECISION
734	# define REAL_TYPE
735	# define DIM_0d
736	# define ROUTINE_ALLREDUCE mppmax_real_sp
737	# include "mpp_allreduce_generic.h90"
738	# undef ROUTINE_ALLREDUCE
739	# undef DIM_0d
740	# define DIM_1d
741	# define ROUTINE_ALLREDUCE mppmax_a_real_sp
742	# include "mpp_allreduce_generic.h90"
743	# undef ROUTINE_ALLREDUCE
744	# undef DIM_1d
745	# undef SINGLE_PRECISION
746	!!
747	!!
748	!! ---- DOUBLE PRECISION VERSIONS
749	!!
750	!
751	# define DIM_0d
752	# define ROUTINE_ALLREDUCE mppmax_real_dp
753	# include "mpp_allreduce_generic.h90"
754	# undef ROUTINE_ALLREDUCE
755	# undef DIM_0d
756	# define DIM_1d
757	# define ROUTINE_ALLREDUCE mppmax_a_real_dp
758	# include "mpp_allreduce_generic.h90"
759	# undef ROUTINE_ALLREDUCE
760	# undef DIM_1d
761	# undef REAL_TYPE
762	# undef OPERATION_MAX
763	!!----------------------------------------------------------------------
764	!! * mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *
765	!!
766	!!----------------------------------------------------------------------
767	!!
768	# define OPERATION_MIN
769	# define INTEGER_TYPE
770	# define DIM_0d
771	# define ROUTINE_ALLREDUCE mppmin_int
772	# include "mpp_allreduce_generic.h90"
773	# undef ROUTINE_ALLREDUCE
774	# undef DIM_0d
775	# define DIM_1d
776	# define ROUTINE_ALLREDUCE mppmin_a_int
777	# include "mpp_allreduce_generic.h90"
778	# undef ROUTINE_ALLREDUCE
779	# undef DIM_1d
780	# undef INTEGER_TYPE
781	!
782	!!
783	!! ---- SINGLE PRECISION VERSIONS
784	!!
785	# define SINGLE_PRECISION
786	# define REAL_TYPE
787	# define DIM_0d
788	# define ROUTINE_ALLREDUCE mppmin_real_sp
789	# include "mpp_allreduce_generic.h90"
790	# undef ROUTINE_ALLREDUCE
791	# undef DIM_0d
792	# define DIM_1d
793	# define ROUTINE_ALLREDUCE mppmin_a_real_sp
794	# include "mpp_allreduce_generic.h90"
795	# undef ROUTINE_ALLREDUCE
796	# undef DIM_1d
797	# undef SINGLE_PRECISION
798	!!
799	!! ---- DOUBLE PRECISION VERSIONS
800	!!
801
802	# define DIM_0d
803	# define ROUTINE_ALLREDUCE mppmin_real_dp
804	# include "mpp_allreduce_generic.h90"
805	# undef ROUTINE_ALLREDUCE
806	# undef DIM_0d
807	# define DIM_1d
808	# define ROUTINE_ALLREDUCE mppmin_a_real_dp
809	# include "mpp_allreduce_generic.h90"
810	# undef ROUTINE_ALLREDUCE
811	# undef DIM_1d
812	# undef REAL_TYPE
813	# undef OPERATION_MIN
814
815	!!----------------------------------------------------------------------
816	!! * mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *
817	!!
818	!! Global sum of 1D array or a variable (integer, real or complex)
819	!!----------------------------------------------------------------------
820	!!
821	# define OPERATION_SUM
822	# define INTEGER_TYPE
823	# define DIM_0d
824	# define ROUTINE_ALLREDUCE mppsum_int
825	# include "mpp_allreduce_generic.h90"
826	# undef ROUTINE_ALLREDUCE
827	# undef DIM_0d
828	# define DIM_1d
829	# define ROUTINE_ALLREDUCE mppsum_a_int
830	# include "mpp_allreduce_generic.h90"
831	# undef ROUTINE_ALLREDUCE
832	# undef DIM_1d
833	# undef INTEGER_TYPE
834
835	!!
836	!! ---- SINGLE PRECISION VERSIONS
837	!!
838	# define OPERATION_SUM
839	# define SINGLE_PRECISION
840	# define REAL_TYPE
841	# define DIM_0d
842	# define ROUTINE_ALLREDUCE mppsum_real_sp
843	# include "mpp_allreduce_generic.h90"
844	# undef ROUTINE_ALLREDUCE
845	# undef DIM_0d
846	# define DIM_1d
847	# define ROUTINE_ALLREDUCE mppsum_a_real_sp
848	# include "mpp_allreduce_generic.h90"
849	# undef ROUTINE_ALLREDUCE
850	# undef DIM_1d
851	# undef REAL_TYPE
852	# undef OPERATION_SUM
853
854	# undef SINGLE_PRECISION
855
856	!!
857	!! ---- DOUBLE PRECISION VERSIONS
858	!!
859	# define OPERATION_SUM
860	# define REAL_TYPE
861	# define DIM_0d
862	# define ROUTINE_ALLREDUCE mppsum_real_dp
863	# include "mpp_allreduce_generic.h90"
864	# undef ROUTINE_ALLREDUCE
865	# undef DIM_0d
866	# define DIM_1d
867	# define ROUTINE_ALLREDUCE mppsum_a_real_dp
868	# include "mpp_allreduce_generic.h90"
869	# undef ROUTINE_ALLREDUCE
870	# undef DIM_1d
871	# undef REAL_TYPE
872	# undef OPERATION_SUM
873
874	# define OPERATION_SUM_DD
875	# define COMPLEX_TYPE
876	# define DIM_0d
877	# define ROUTINE_ALLREDUCE mppsum_realdd
878	# include "mpp_allreduce_generic.h90"
879	# undef ROUTINE_ALLREDUCE
880	# undef DIM_0d
881	# define DIM_1d
882	# define ROUTINE_ALLREDUCE mppsum_a_realdd
883	# include "mpp_allreduce_generic.h90"
884	# undef ROUTINE_ALLREDUCE
885	# undef DIM_1d
886	# undef COMPLEX_TYPE
887	# undef OPERATION_SUM_DD
888
889	!!----------------------------------------------------------------------
890	!! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
891	!!
892	!!----------------------------------------------------------------------
893	!!
894	!!
895	!! ---- SINGLE PRECISION VERSIONS
896	!!
897	# define SINGLE_PRECISION
898	# define OPERATION_MINLOC
899	# define DIM_2d
900	# define ROUTINE_LOC mpp_minloc2d_sp
901	# include "mpp_loc_generic.h90"
902	# undef ROUTINE_LOC
903	# undef DIM_2d
904	# define DIM_3d
905	# define ROUTINE_LOC mpp_minloc3d_sp
906	# include "mpp_loc_generic.h90"
907	# undef ROUTINE_LOC
908	# undef DIM_3d
909	# undef OPERATION_MINLOC
910
911	# define OPERATION_MAXLOC
912	# define DIM_2d
913	# define ROUTINE_LOC mpp_maxloc2d_sp
914	# include "mpp_loc_generic.h90"
915	# undef ROUTINE_LOC
916	# undef DIM_2d
917	# define DIM_3d
918	# define ROUTINE_LOC mpp_maxloc3d_sp
919	# include "mpp_loc_generic.h90"
920	# undef ROUTINE_LOC
921	# undef DIM_3d
922	# undef OPERATION_MAXLOC
923	# undef SINGLE_PRECISION
924	!!
925	!! ---- DOUBLE PRECISION VERSIONS
926	!!
927	# define OPERATION_MINLOC
928	# define DIM_2d
929	# define ROUTINE_LOC mpp_minloc2d_dp
930	# include "mpp_loc_generic.h90"
931	# undef ROUTINE_LOC
932	# undef DIM_2d
933	# define DIM_3d
934	# define ROUTINE_LOC mpp_minloc3d_dp
935	# include "mpp_loc_generic.h90"
936	# undef ROUTINE_LOC
937	# undef DIM_3d
938	# undef OPERATION_MINLOC
939
940	# define OPERATION_MAXLOC
941	# define DIM_2d
942	# define ROUTINE_LOC mpp_maxloc2d_dp
943	# include "mpp_loc_generic.h90"
944	# undef ROUTINE_LOC
945	# undef DIM_2d
946	# define DIM_3d
947	# define ROUTINE_LOC mpp_maxloc3d_dp
948	# include "mpp_loc_generic.h90"
949	# undef ROUTINE_LOC
950	# undef DIM_3d
951	# undef OPERATION_MAXLOC
952
953
954	SUBROUTINE mppsync()
955	!!----------------------------------------------------------------------
956	!! * routine mppsync *
957	!!
958	!! ** Purpose : Massively parallel processors, synchroneous
959	!!
960	!!-----------------------------------------------------------------------
961	INTEGER :: ierror
962	!!-----------------------------------------------------------------------
963	!
964	#if ! defined key_mpi_off
965	CALL mpi_barrier( mpi_comm_oce, ierror )
966	#endif
967	!
968	END SUBROUTINE mppsync
969
970
971	SUBROUTINE mppstop( ld_abort )
972	!!----------------------------------------------------------------------
973	!! * routine mppstop *
974	!!
975	!! ** purpose : Stop massively parallel processors method
976	!!
977	!!----------------------------------------------------------------------
978	LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number
979	LOGICAL :: ll_abort
980	INTEGER :: info, ierr
981	!!----------------------------------------------------------------------
982	ll_abort = .FALSE.
983	IF( PRESENT(ld_abort) ) ll_abort = ld_abort
984	!
985	#if ! defined key_mpi_off
986	IF(ll_abort) THEN
987	CALL mpi_abort( MPI_COMM_WORLD, 123, info )
988	ELSE
989	CALL mppsync
990	CALL mpi_finalize( info )
991	ENDIF
992	#endif
993	IF( ll_abort ) STOP 123
994	!
995	END SUBROUTINE mppstop
996
997
998	SUBROUTINE mpp_comm_free( kcom )
999	!!----------------------------------------------------------------------
1000	INTEGER, INTENT(inout) :: kcom
1001	!!
1002	INTEGER :: ierr
1003	!!----------------------------------------------------------------------
1004	!
1005	#if ! defined key_mpi_off
1006	CALL MPI_COMM_FREE(kcom, ierr)
1007	#endif
1008	!
1009	END SUBROUTINE mpp_comm_free
1010
1011
1012	SUBROUTINE mpp_ini_znl( kumout )
1013	!!----------------------------------------------------------------------
1014	!! * routine mpp_ini_znl *
1015	!!
1016	!! ** Purpose : Initialize special communicator for computing zonal sum
1017	!!
1018	!! ** Method : - Look for processors in the same row
1019	!! - Put their number in nrank_znl
1020	!! - Create group for the znl processors
1021	!! - Create a communicator for znl processors
1022	!! - Determine if processor should write znl files
1023	!!
1024	!! ** output
1025	!! ndim_rank_znl = number of processors on the same row
1026	!! ngrp_znl = group ID for the znl processors
1027	!! ncomm_znl = communicator for the ice procs.
1028	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
1029	!!
1030	!!----------------------------------------------------------------------
1031	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
1032	!
1033	INTEGER :: jproc ! dummy loop integer
1034	INTEGER :: ierr, ii ! local integer
1035	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
1036	!!----------------------------------------------------------------------
1037	#if ! defined key_mpi_off
1038	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_world : ', ngrp_world
1039	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_world : ', mpi_comm_world
1040	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - mpi_comm_oce : ', mpi_comm_oce
1041	!
1042	ALLOCATE( kwork(jpnij), STAT=ierr )
1043	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij')
1044
1045	IF( jpnj == 1 ) THEN
1046	ngrp_znl = ngrp_world
1047	ncomm_znl = mpi_comm_oce
1048	ELSE
1049	!
1050	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
1051	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - kwork pour njmpp : ', kwork
1052	!-$$ CALL flush(numout)
1053	!
1054	! Count number of processors on the same row
1055	ndim_rank_znl = 0
1056	DO jproc=1,jpnij
1057	IF ( kwork(jproc) == njmpp ) THEN
1058	ndim_rank_znl = ndim_rank_znl + 1
1059	ENDIF
1060	END DO
1061	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ndim_rank_znl : ', ndim_rank_znl
1062	!-$$ CALL flush(numout)
1063	! Allocate the right size to nrank_znl
1064	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
1065	ALLOCATE(nrank_znl(ndim_rank_znl))
1066	ii = 0
1067	nrank_znl (:) = 0
1068	DO jproc=1,jpnij
1069	IF ( kwork(jproc) == njmpp) THEN
1070	ii = ii + 1
1071	nrank_znl(ii) = jproc -1
1072	ENDIF
1073	END DO
1074	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - nrank_znl : ', nrank_znl
1075	!-$$ CALL flush(numout)
1076
1077	! Create the opa group
1078	CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
1079	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_opa : ', ngrp_opa
1080	!-$$ CALL flush(numout)
1081
1082	! Create the znl group from the opa group
1083	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
1084	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ngrp_znl ', ngrp_znl
1085	!-$$ CALL flush(numout)
1086
1087	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
1088	CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
1089	!-$$ WRITE (numout,*) 'mpp_ini_znl ', mpprank, ' - ncomm_znl ', ncomm_znl
1090	!-$$ CALL flush(numout)
1091	!
1092	END IF
1093
1094	! Determines if processor if the first (starting from i=1) on the row
1095	IF ( jpni == 1 ) THEN
1096	l_znl_root = .TRUE.
1097	ELSE
1098	l_znl_root = .FALSE.
1099	kwork (1) = nimpp
1100	CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
1101	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
1102	END IF
1103
1104	DEALLOCATE(kwork)
1105	#endif
1106
1107	END SUBROUTINE mpp_ini_znl
1108
1109
1110	SUBROUTINE mpp_ini_nc( khls )
1111	!!----------------------------------------------------------------------
1112	!! * routine mpp_ini_nc *
1113	!!
1114	!! ** Purpose : Initialize special communicators for MPI3 neighbourhood
1115	!! collectives
1116	!!
1117	!! ** Method : - Create graph communicators starting from the processes
1118	!! distribution along i and j directions
1119	!
1120	!! ** output
1121	!! mpi_nc_com4 = MPI3 neighbourhood collectives communicator
1122	!! mpi_nc_com8 = MPI3 neighbourhood collectives communicator (with diagonals)
1123	!!----------------------------------------------------------------------
1124	INTEGER, INTENT(in ) :: khls ! halo size, default = nn_hls
1125	!
1126	INTEGER, DIMENSION(:), ALLOCATABLE :: iSnei4, iRnei4, iSnei8, iRnei8
1127	INTEGER :: iScnt4, iRcnt4, iScnt8, iRcnt8
1128	INTEGER :: ierr
1129	LOGICAL, PARAMETER :: ireord = .FALSE.
1130	!!----------------------------------------------------------------------
1131	#if ! defined key_mpi_off && ! defined key_mpi2
1132
1133	iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 )
1134	iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 )
1135	iScnt8 = COUNT( mpiSnei(khls,1:8) >= 0 )
1136	iRcnt8 = COUNT( mpiRnei(khls,1:8) >= 0 )
1137
1138	ALLOCATE( iSnei4(iScnt4), iRnei4(iRcnt4), iSnei8(iScnt8), iRnei8(iRcnt8) ) ! ok if icnt4 or icnt8 = 0
1139
1140	iSnei4 = PACK( mpiSnei(khls,1:4), mask = mpiSnei(khls,1:4) >= 0 )
1141	iRnei4 = PACK( mpiRnei(khls,1:4), mask = mpiRnei(khls,1:4) >= 0 )
1142	iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 )
1143	iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 )
1144
1145	CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, &
1146	& MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr )
1147	CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, &
1148	& MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr)
1149
1150	DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 )
1151	#endif
1152	END SUBROUTINE mpp_ini_nc
1153
1154
1155	SUBROUTINE mpp_ini_pers
1156	!!----------------------------------------------------------------------
1157	!! * routine mpp_ini_pers *
1158	!!
1159	!! ** Purpose : Initialize special requests and buffers for persistent calls
1160	!!
1161	!! ** Method : - Allocate buffers to the size required in dynspg_ts's communications
1162	!! - Need : shift in buffer to get to first element of region (E-W-N-S + diag)
1163	!! size of that region
1164	!! MPI index of neighbour and tag
1165	!!
1166	!! ** output
1167	!! - requests to be used in communications called in dynspg_ts
1168	!! ** Note
1169	!! - only coded for 2D arrays in dynspg_ts with 1 halo
1170	!!----------------------------------------------------------------------
1171	INTEGER, DIMENSION(8) :: ishtS, ishtR, iStag, iRtag ! shifts, tag
1172	INTEGER, DIMENSION(8) :: icount ! size of buffer
1173	LOGICAL, DIMENSION(8) :: llsend, llrecv
1174	INTEGER :: iszS, iszR
1175	INTEGER :: ireq, idxreq
1176	INTEGER :: ifldmax, ierr, MPI_TYPE
1177	INTEGER :: jn
1178	!!----------------------------------------------------------------------
1179
1180	if( wp == dp ) then
1181	MPI_TYPE = MPI_DOUBLE_PRECISION
1182	else if ( wp == sp ) then
1183	MPI_TYPE = MPI_REAL
1184	else
1185	CALL ctl_stop( "Error defining type, wp is neither dp nor sp" )
1186	end if
1187	!
1188	!
1189	! Size of region
1190	ifldmax = 6 ! 6 arrays updated max in a single call in dynspg_ts
1191	icount(1:2) = ifldmax * (jpi-2) ! west - east
1192	icount(3:4) = ifldmax * (jpj-2) ! south - north
1193	icount(5:8) = ifldmax ! diagonals
1194	!
1195	llsend(:) = mpiSnei(1,:) >= 0 ! hypothesis : 1 halo in time splitting
1196	llrecv(:) = mpiRnei(1,:) >= 0
1197	!
1198	! Shift in buffer to get to the first element of region
1199	ishtS(1) = 0 ; ishtR(1) = 0
1200	DO jn = 2, 8
1201	ishtS(jn) = ishtS(jn-1) + icount(jn-1) * COUNT( (/llsend(jn-1)/) )
1202	ishtR(jn) = ishtR(jn-1) + icount(jn-1) * COUNT( (/llrecv(jn-1)/) )
1203	END DO
1204	!
1205	! Allocate buffer here, might be possible to allocate in dynspg_ts
1206	iszS = SUM(icount, mask = llsend) ! send buffer size
1207	iszR = SUM(icount, mask = llrecv) ! recv buffer size
1208	ALLOCATE( buffS_pers(iszS), buffR_pers(iszR) )
1209	!
1210	! Tags
1211	iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different
1212	! define iRtag with the corresponding iStag, e.g. data received at west where sent at east.
1213	iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso)
1214	iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw)
1215	!
1216	! Requests
1217	! Allocate requests (initialization at MPI_REQUEST_NULL is not allowed with persistent calls)
1218	ireq = COUNT(llsend)+COUNT(llrecv)
1219	ALLOCATE( nreq_pers(ireq) )
1220	idxreq = 1
1221	DO jn = 1, 8
1222	IF( llsend(jn) ) THEN ! MPI_Start(requests) behaves as MPI_Isend
1223	CALL MPI_Send_init(buffS_pers(ishtS(jn)+1), icount(jn), MPI_TYPE, mpiSnei(nn_hls,jn), iStag(jn), mpi_comm_oce, nreq_pers(idxreq), ierr)
1224	idxreq = idxreq + 1
1225	END IF
1226	END DO
1227	DO jn = 1, 8
1228	IF( llrecv(jn) ) THEN ! MPI_Start(requests) behaves as MPI_Irecv
1229	CALL MPI_Recv_init(buffR_pers(ishtR(jn)+1), icount(jn), MPI_TYPE, mpiRnei(nn_hls,jn), iRtag(jn), mpi_comm_oce, nreq_pers(idxreq), ierr)
1230	idxreq = idxreq + 1
1231	END IF
1232	END DO
1233	!
1234	END SUBROUTINE mpp_ini_pers
1235
1236
1237	SUBROUTINE mpp_ini_north
1238	!!----------------------------------------------------------------------
1239	!! * routine mpp_ini_north *
1240	!!
1241	!! ** Purpose : Initialize special communicator for north folding
1242	!! condition together with global variables needed in the mpp folding
1243	!!
1244	!! ** Method : - Look for northern processors
1245	!! - Put their number in nrank_north
1246	!! - Create groups for the world processors and the north processors
1247	!! - Create a communicator for northern processors
1248	!!
1249	!! ** output
1250	!! ndim_rank_north = number of processors in the northern line
1251	!! nrank_north (ndim_rank_north) = number of the northern procs.
1252	!! ngrp_world = group ID for the world processors
1253	!! ngrp_north = group ID for the northern processors
1254	!! ncomm_north = communicator for the northern procs.
1255	!! north_root = number (in the world) of proc 0 in the northern comm.
1256	!!
1257	!!----------------------------------------------------------------------
1258	INTEGER :: ierr
1259	INTEGER :: jjproc
1260	INTEGER :: ii, ji
1261	!!----------------------------------------------------------------------
1262	!
1263	#if ! defined key_mpi_off
1264	!
1265	! Look for how many procs on the northern boundary
1266	ndim_rank_north = 0
1267	DO jjproc = 1, jpni
1268	IF( nfproc(jjproc) /= -1 ) ndim_rank_north = ndim_rank_north + 1
1269	END DO
1270	!
1271	! Allocate the right size to nrank_north
1272	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
1273	ALLOCATE( nrank_north(ndim_rank_north) )
1274
1275	! Fill the nrank_north array with proc. number of northern procs.
1276	! Note : the rank start at 0 in MPI
1277	ii = 0
1278	DO ji = 1, jpni
1279	IF ( nfproc(ji) /= -1 ) THEN
1280	ii=ii+1
1281	nrank_north(ii)=nfproc(ji)
1282	END IF
1283	END DO
1284	!
1285	! create the world group
1286	CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
1287	!
1288	! Create the North group from the world group
1289	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
1290	!
1291	! Create the North communicator , ie the pool of procs in the north group
1292	CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
1293	!
1294	#endif
1295	END SUBROUTINE mpp_ini_north
1296
1297
1298	SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
1299	!!---------------------------------------------------------------------
1300	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
1301	!!
1302	!! Modification of original codes written by David H. Bailey
1303	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
1304	!!---------------------------------------------------------------------
1305	INTEGER , INTENT(in) :: ilen, itype
1306	COMPLEX(dp), DIMENSION(ilen), INTENT(in) :: ydda
1307	COMPLEX(dp), DIMENSION(ilen), INTENT(inout) :: yddb
1308	!
1309	REAL(dp) :: zerr, zt1, zt2 ! local work variables
1310	INTEGER :: ji, ztmp ! local scalar
1311	!!---------------------------------------------------------------------
1312	!
1313	ztmp = itype ! avoid compilation warning
1314	!
1315	DO ji=1,ilen
1316	! Compute ydda + yddb using Knuth's trick.
1317	zt1 = real(ydda(ji)) + real(yddb(ji))
1318	zerr = zt1 - real(ydda(ji))
1319	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
1320	+ aimag(ydda(ji)) + aimag(yddb(ji))
1321
1322	! The result is zt1 + zt2, after normalization.
1323	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
1324	END DO
1325	!
1326	END SUBROUTINE DDPDD_MPI
1327
1328
1329	SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
1330	!!----------------------------------------------------------------------
1331	!! * routine mpp_report *
1332	!!
1333	!! ** Purpose : report use of mpp routines per time-setp
1334	!!
1335	!!----------------------------------------------------------------------
1336	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
1337	INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf
1338	LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg
1339	!!
1340	CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications
1341	LOGICAL :: ll_lbc, ll_glb, ll_dlg
1342	INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices
1343	!!----------------------------------------------------------------------
1344	#if ! defined key_mpi_off
1345	!
1346	ll_lbc = .FALSE.
1347	IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
1348	ll_glb = .FALSE.
1349	IF( PRESENT(ld_glb) ) ll_glb = ld_glb
1350	ll_dlg = .FALSE.
1351	IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg
1352	!
1353	! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
1354	ncom_freq = ncom_fsbc
1355	!
1356	IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000
1357	IF( ll_lbc ) THEN
1358	IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
1359	IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) )
1360	n_sequence_lbc = n_sequence_lbc + 1
1361	IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
1362	crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine
1363	ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions
1364	ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi)
1365	ENDIF
1366	IF( ll_glb ) THEN
1367	IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
1368	n_sequence_glb = n_sequence_glb + 1
1369	IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
1370	crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine
1371	ENDIF
1372	IF( ll_dlg ) THEN
1373	IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) )
1374	n_sequence_dlg = n_sequence_dlg + 1
1375	IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
1376	crname_dlg(n_sequence_dlg) = cdname ! keep the name of the calling routine
1377	ENDIF
1378	ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
1379	CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
1380	WRITE(numcom,*) ' '
1381	WRITE(numcom,*) ' ------------------------------------------------------------'
1382	WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
1383	WRITE(numcom,*) ' ------------------------------------------------------------'
1384	WRITE(numcom,*) ' '
1385	WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
1386	jj = 0; jk = 0; jf = 0; jh = 0
1387	DO ji = 1, n_sequence_lbc
1388	IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
1389	IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
1390	IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
1391	jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
1392	END DO
1393	WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
1394	WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
1395	WRITE(numcom,'(A,I3)') ' from which 3D : ', jj
1396	WRITE(numcom,'(A,I10)') ' Array max size : ', jhjpijpj
1397	WRITE(numcom,*) ' '
1398	WRITE(numcom,*) ' lbc_lnk called'
1399	DO ji = 1, n_sequence_lbc - 1
1400	IF ( crname_lbc(ji) /= 'already counted' ) THEN
1401	ccountname = crname_lbc(ji)
1402	crname_lbc(ji) = 'already counted'
1403	jcount = 1
1404	DO jj = ji + 1, n_sequence_lbc
1405	IF ( ccountname == crname_lbc(jj) ) THEN
1406	jcount = jcount + 1
1407	crname_lbc(jj) = 'already counted'
1408	END IF
1409	END DO
1410	WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname)
1411	END IF
1412	END DO
1413	IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN
1414	WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(n_sequence_lbc))
1415	END IF
1416	WRITE(numcom,*) ' '
1417	IF ( n_sequence_glb > 0 ) THEN
1418	WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
1419	jj = 1
1420	DO ji = 2, n_sequence_glb
1421	IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
1422	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
1423	jj = 0
1424	END IF
1425	jj = jj + 1
1426	END DO
1427	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
1428	DEALLOCATE(crname_glb)
1429	ELSE
1430	WRITE(numcom,*) ' No MPI global communication '
1431	ENDIF
1432	WRITE(numcom,*) ' '
1433	IF ( n_sequence_dlg > 0 ) THEN
1434	WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg
1435	jj = 1
1436	DO ji = 2, n_sequence_dlg
1437	IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN
1438	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1))
1439	jj = 0
1440	END IF
1441	jj = jj + 1
1442	END DO
1443	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg))
1444	DEALLOCATE(crname_dlg)
1445	ELSE
1446	WRITE(numcom,*) ' No MPI delayed global communication '
1447	ENDIF
1448	WRITE(numcom,*) ' '
1449	WRITE(numcom,*) ' -----------------------------------------------'
1450	WRITE(numcom,*) ' '
1451	DEALLOCATE(ncomm_sequence)
1452	DEALLOCATE(crname_lbc)
1453	ENDIF
1454	#endif
1455	END SUBROUTINE mpp_report
1456
1457
1458	SUBROUTINE tic_tac (ld_tic, ld_global)
1459
1460	LOGICAL, INTENT(IN) :: ld_tic
1461	LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1462	REAL(dp), DIMENSION(2), SAVE :: tic_wt
1463	REAL(dp), SAVE :: tic_ct = 0._dp
1464	INTEGER :: ii
1465	#if ! defined key_mpi_off
1466
1467	IF( ncom_stp <= nit000 ) RETURN
1468	IF( ncom_stp == nitend ) RETURN
1469	ii = 1
1470	IF( PRESENT( ld_global ) ) THEN
1471	IF( ld_global ) ii = 2
1472	END IF
1473
1474	IF ( ld_tic ) THEN
1475	tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time)
1476	IF ( tic_ct > 0.0_dp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
1477	ELSE
1478	waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac
1479	tic_ct = MPI_Wtime() ! start count tac->tic (waiting time)
1480	ENDIF
1481	#endif
1482
1483	END SUBROUTINE tic_tac
1484
1485	#if defined key_mpi_off
1486	SUBROUTINE mpi_wait(request, status, ierror)
1487	INTEGER , INTENT(in ) :: request
1488	INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status
1489	INTEGER , INTENT( out) :: ierror
1490	END SUBROUTINE mpi_wait
1491
1492
1493	FUNCTION MPI_Wtime()
1494	REAL(wp) :: MPI_Wtime
1495	MPI_Wtime = -1.
1496	END FUNCTION MPI_Wtime
1497	#endif
1498
1499	!!----------------------------------------------------------------------
1500	!! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam, load_nml routines
1501	!!----------------------------------------------------------------------
1502
1503	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
1504	& cd6, cd7, cd8, cd9, cd10 )
1505	!!----------------------------------------------------------------------
1506	!! * ROUTINE stop_opa *
1507	!!
1508	!! ** Purpose : print in ocean.outpput file a error message and
1509	!! increment the error number (nstop) by one.
1510	!!----------------------------------------------------------------------
1511	CHARACTER(len=*), INTENT(in ) :: cd1
1512	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5
1513	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1514	!
1515	CHARACTER(LEN=8) :: clfmt ! writing format
1516	INTEGER :: inum
1517	!!----------------------------------------------------------------------
1518	!
1519	nstop = nstop + 1
1520	!
1521	IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file
1522	CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
1523	WRITE(inum,*)
1524	WRITE(inum,) ' ==>>> Look for "E R R O R" messages in all existing ocean.output* files'
1525	CLOSE(inum)
1526	ENDIF
1527	IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened
1528	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea )
1529	ENDIF
1530	!
1531	WRITE(numout,*)
1532	WRITE(numout,*) ' ===>>> : E R R O R'
1533	WRITE(numout,*)
1534	WRITE(numout,*) ' ==========='
1535	WRITE(numout,*)
1536	WRITE(numout,*) TRIM(cd1)
1537	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1538	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1539	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1540	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1541	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1542	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1543	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1544	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1545	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1546	WRITE(numout,*)
1547	!
1548	CALL FLUSH(numout )
1549	IF( numstp /= -1 ) CALL FLUSH(numstp )
1550	IF( numrun /= -1 ) CALL FLUSH(numrun )
1551	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
1552	!
1553	IF( cd1 == 'STOP' ) THEN
1554	WRITE(numout,*)
1555	WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
1556	WRITE(numout,*)
1557	CALL FLUSH(numout)
1558	CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough...
1559	CALL mppstop( ld_abort = .true. )
1560	ENDIF
1561	!
1562	END SUBROUTINE ctl_stop
1563
1564
1565	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
1566	& cd6, cd7, cd8, cd9, cd10 )
1567	!!----------------------------------------------------------------------
1568	!! * ROUTINE stop_warn *
1569	!!
1570	!! ** Purpose : print in ocean.outpput file a error message and
1571	!! increment the warning number (nwarn) by one.
1572	!!----------------------------------------------------------------------
1573	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
1574	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1575	!!----------------------------------------------------------------------
1576	!
1577	nwarn = nwarn + 1
1578	!
1579	IF(lwp) THEN
1580	WRITE(numout,*)
1581	WRITE(numout,*) ' ===>>> : W A R N I N G'
1582	WRITE(numout,*)
1583	WRITE(numout,*) ' ==============='
1584	WRITE(numout,*)
1585	IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1)
1586	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1587	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1588	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1589	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1590	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1591	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1592	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1593	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1594	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1595	WRITE(numout,*)
1596	ENDIF
1597	CALL FLUSH(numout)
1598	!
1599	END SUBROUTINE ctl_warn
1600
1601
1602	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1603	!!----------------------------------------------------------------------
1604	!! * ROUTINE ctl_opn *
1605	!!
1606	!! ** Purpose : Open file and check if required file is available.
1607	!!
1608	!! ** Method : Fortan open
1609	!!----------------------------------------------------------------------
1610	INTEGER , INTENT( out) :: knum ! logical unit to open
1611	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
1612	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
1613	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
1614	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
1615	INTEGER , INTENT(in ) :: klengh ! record length
1616	INTEGER , INTENT(in ) :: kout ! number of logical units for write
1617	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
1618	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
1619	!
1620	CHARACTER(len=80) :: clfile
1621	CHARACTER(LEN=10) :: clfmt ! writing format
1622	INTEGER :: iost
1623	INTEGER :: idg ! number of digits
1624	!!----------------------------------------------------------------------
1625	!
1626	! adapt filename
1627	! ----------------
1628	clfile = TRIM(cdfile)
1629	IF( PRESENT( karea ) ) THEN
1630	IF( karea > 1 ) THEN
1631	! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij
1632	idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
1633	WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)'
1634	WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1
1635	ENDIF
1636	ENDIF
1637	#if defined key_agrif
1638	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1639	knum=Agrif_Get_Unit()
1640	#else
1641	knum=get_unit()
1642	#endif
1643	IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null
1644	!
1645	IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters
1646	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost )
1647	ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters
1648	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost )
1649	ELSE
1650	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1651	ENDIF
1652	IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) & ! for windows
1653	& OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1654	IF( iost == 0 ) THEN
1655	IF(ldwp .AND. kout > 0) THEN
1656	WRITE(kout,*) ' file : ', TRIM(clfile),' open ok'
1657	WRITE(kout,*) ' unit = ', knum
1658	WRITE(kout,*) ' status = ', cdstat
1659	WRITE(kout,*) ' form = ', cdform
1660	WRITE(kout,*) ' access = ', cdacce
1661	WRITE(kout,*)
1662	ENDIF
1663	ENDIF
1664	100 CONTINUE
1665	IF( iost /= 0 ) THEN
1666	WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile)
1667	WRITE(ctmp2,*) ' ======= === '
1668	WRITE(ctmp3,*) ' unit = ', knum
1669	WRITE(ctmp4,*) ' status = ', cdstat
1670	WRITE(ctmp5,*) ' form = ', cdform
1671	WRITE(ctmp6,*) ' access = ', cdacce
1672	WRITE(ctmp7,*) ' iostat = ', iost
1673	WRITE(ctmp8,*) ' we stop. verify the file '
1674	CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 )
1675	ENDIF
1676	!
1677	END SUBROUTINE ctl_opn
1678
1679
1680	SUBROUTINE ctl_nam ( kios, cdnam )
1681	!!----------------------------------------------------------------------
1682	!! * ROUTINE ctl_nam *
1683	!!
1684	!! ** Purpose : Informations when error while reading a namelist
1685	!!
1686	!! ** Method : Fortan open
1687	!!----------------------------------------------------------------------
1688	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
1689	CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs
1690	!
1691	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
1692	!!----------------------------------------------------------------------
1693	!
1694	WRITE (clios, '(I5.0)') kios
1695	IF( kios < 0 ) THEN
1696	CALL ctl_warn( 'end of record or file while reading namelist ' &
1697	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1698	ENDIF
1699	!
1700	IF( kios > 0 ) THEN
1701	CALL ctl_stop( 'misspelled variable in namelist ' &
1702	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1703	ENDIF
1704	kios = 0
1705	!
1706	END SUBROUTINE ctl_nam
1707
1708
1709	INTEGER FUNCTION get_unit()
1710	!!----------------------------------------------------------------------
1711	!! * FUNCTION get_unit *
1712	!!
1713	!! ** Purpose : return the index of an unused logical unit
1714	!!----------------------------------------------------------------------
1715	LOGICAL :: llopn
1716	!!----------------------------------------------------------------------
1717	!
1718	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
1719	llopn = .TRUE.
1720	DO WHILE( (get_unit < 998) .AND. llopn )
1721	get_unit = get_unit + 1
1722	INQUIRE( unit = get_unit, opened = llopn )
1723	END DO
1724	IF( (get_unit == 999) .AND. llopn ) THEN
1725	CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' )
1726	ENDIF
1727	!
1728	END FUNCTION get_unit
1729
1730	SUBROUTINE load_nml( cdnambuff , cdnamfile, kout, ldwp)
1731	CHARACTER(LEN=:) , ALLOCATABLE, INTENT(INOUT) :: cdnambuff
1732	CHARACTER(LEN=*), INTENT(IN ) :: cdnamfile
1733	CHARACTER(LEN=256) :: chline
1734	CHARACTER(LEN=1) :: csp
1735	INTEGER, INTENT(IN) :: kout
1736	LOGICAL, INTENT(IN) :: ldwp !: .true. only for the root broadcaster
1737	INTEGER :: itot, iun, iltc, inl, ios, itotsav
1738	!
1739	!csp = NEW_LINE('A')
1740	! a new line character is the best seperator but some systems (e.g.Cray)
1741	! seem to terminate namelist reads from internal files early if they
1742	! encounter new-lines. Use a single space for safety.
1743	csp = ' '
1744	!
1745	! Check if the namelist buffer has already been allocated. Return if it has.
1746	!
1747	IF ( ALLOCATED( cdnambuff ) ) RETURN
1748	IF( ldwp ) THEN
1749	!
1750	! Open namelist file
1751	!
1752	CALL ctl_opn( iun, cdnamfile, 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, kout, ldwp )
1753	!
1754	! First pass: count characters excluding comments and trimable white space
1755	!
1756	itot=0
1757	10 READ(iun,'(A256)',END=20,ERR=20) chline
1758	iltc = LEN_TRIM(chline)
1759	IF ( iltc.GT.0 ) THEN
1760	inl = INDEX(chline, '!')
1761	IF( inl.eq.0 ) THEN
1762	itot = itot + iltc + 1 ! +1 for the newline character
1763	ELSEIF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl-1) ).GT.0 ) THEN
1764	itot = itot + inl ! includes +1 for the newline character
1765	ENDIF
1766	ENDIF
1767	GOTO 10
1768	20 CONTINUE
1769	!
1770	! Allocate text cdnambuff for condensed namelist
1771	!
1772	!$AGRIF_DO_NOT_TREAT
1773	ALLOCATE( CHARACTER(LEN=itot) :: cdnambuff )
1774	!$AGRIF_END_DO_NOT_TREAT
1775	itotsav = itot
1776	!
1777	! Second pass: read and transfer pruned characters into cdnambuff
1778	!
1779	REWIND(iun)
1780	itot=1
1781	30 READ(iun,'(A256)',END=40,ERR=40) chline
1782	iltc = LEN_TRIM(chline)
1783	IF ( iltc.GT.0 ) THEN
1784	inl = INDEX(chline, '!')
1785	IF( inl.eq.0 ) THEN
1786	inl = iltc
1787	ELSE
1788	inl = inl - 1
1789	ENDIF
1790	IF( inl.GT.0 .AND. LEN_TRIM( chline(1:inl) ).GT.0 ) THEN
1791	cdnambuff(itot:itot+inl-1) = chline(1:inl)
1792	WRITE( cdnambuff(itot+inl:itot+inl), '(a)' ) csp
1793	itot = itot + inl + 1
1794	ENDIF
1795	ENDIF
1796	GOTO 30
1797	40 CONTINUE
1798	itot = itot - 1
1799	IF( itotsav .NE. itot ) WRITE(,) 'WARNING in load_nml. Allocated ',itotsav,' for read buffer; but used ',itot
1800	!
1801	! Close namelist file
1802	!
1803	CLOSE(iun)
1804	!write(*,'(32A)') cdnambuff
1805	ENDIF
1806	#if ! defined key_mpi_off
1807	CALL mpp_bcast_nml( cdnambuff, itot )
1808	#endif
1809	END SUBROUTINE load_nml
1810
1811
1812	!!----------------------------------------------------------------------
1813	END MODULE lib_mpp

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

Download in other formats: