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/releases/r4.0/r4.0-HEAD/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/releases/r4.0/r4.0-HEAD/src/OCE/LBC/lib_mpp.F90 @ 13061

Last change on this file since 13061 was 13061, checked in by smasson, 4 years ago
r4.0-HEAD: fix max number of digits for the cpu number in filename, see #2424
Property svn:keywords set to `Id`
File size: 57.3 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	!!----------------------------------------------------------------------
35	!!----------------------------------------------------------------------
36	!! mpp_start : get local communicator its size and rank
37	!! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d)
38	!! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb)
39	!! mpprecv :
40	!! mppsend :
41	!! mppscatter :
42	!! mppgather :
43	!! mpp_min : generic interface for mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real
44	!! mpp_max : generic interface for mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real
45	!! mpp_sum : generic interface for mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real
46	!! mpp_minloc :
47	!! mpp_maxloc :
48	!! mppsync :
49	!! mppstop :
50	!! mpp_ini_north : initialisation of north fold
51	!! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs
52	!!----------------------------------------------------------------------
53	USE dom_oce ! ocean space and time domain
54	USE in_out_manager ! I/O manager
55
56	IMPLICIT NONE
57	PRIVATE
58	!
59	PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam
60	PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free
61	PUBLIC mpp_ini_north
62	PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc
63	PUBLIC mpp_delay_max, mpp_delay_sum, mpp_delay_rcv
64	PUBLIC mppscatter, mppgather
65	PUBLIC mpp_ini_znl
66	PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines
67	PUBLIC mpp_report
68	PUBLIC tic_tac
69	#if ! defined key_mpp_mpi
70	PUBLIC MPI_Wtime
71	#endif
72
73	!! * Interfaces
74	!! define generic interface for these routine as they are called sometimes
75	!! with scalar arguments instead of array arguments, which causes problems
76	!! for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ
77	INTERFACE mpp_min
78	MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real
79	END INTERFACE
80	INTERFACE mpp_max
81	MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real
82	END INTERFACE
83	INTERFACE mpp_sum
84	MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &
85	& mppsum_realdd, mppsum_a_realdd
86	END INTERFACE
87	INTERFACE mpp_minloc
88	MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d
89	END INTERFACE
90	INTERFACE mpp_maxloc
91	MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d
92	END INTERFACE
93
94	!! ========================= !!
95	!! MPI variable definition !!
96	!! ========================= !!
97	#if defined key_mpp_mpi
98	!$AGRIF_DO_NOT_TREAT
99	INCLUDE 'mpif.h'
100	!$AGRIF_END_DO_NOT_TREAT
101	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag
102	#else
103	INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1
104	INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8
105	LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag
106	#endif
107
108	INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2)
109
110	INTEGER, PUBLIC :: mppsize ! number of process
111	INTEGER, PUBLIC :: mpprank ! process number [ 0 - size-1 ]
112	!$AGRIF_DO_NOT_TREAT
113	INTEGER, PUBLIC :: mpi_comm_oce ! opa local communicator
114	!$AGRIF_END_DO_NOT_TREAT
115
116	INTEGER :: MPI_SUMDD
117
118	! variables used for zonal integration
119	INTEGER, PUBLIC :: ncomm_znl !: communicator made by the processors on the same zonal average
120	LOGICAL, PUBLIC :: l_znl_root !: True on the 'left'most processor on the same row
121	INTEGER :: ngrp_znl ! group ID for the znl processors
122	INTEGER :: ndim_rank_znl ! number of processors on the same zonal average
123	INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_znl ! dimension ndim_rank_znl, number of the procs into the same znl domain
124
125	! North fold condition in mpp_mpi with jpni > 1 (PUBLIC for TAM)
126	INTEGER, PUBLIC :: ngrp_world !: group ID for the world processors
127	INTEGER, PUBLIC :: ngrp_opa !: group ID for the opa processors
128	INTEGER, PUBLIC :: ngrp_north !: group ID for the northern processors (to be fold)
129	INTEGER, PUBLIC :: ncomm_north !: communicator made by the processors belonging to ngrp_north
130	INTEGER, PUBLIC :: ndim_rank_north !: number of 'sea' processor in the northern line (can be /= jpni !)
131	INTEGER, PUBLIC :: njmppmax !: value of njmpp for the processors of the northern line
132	INTEGER, PUBLIC :: north_root !: number (in the comm_opa) of proc 0 in the northern comm
133	INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north
134
135	! Communications summary report
136	CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines
137	CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines
138	CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_dlg !: names of delayed global comm calling routines
139	INTEGER, PUBLIC :: ncom_stp = 0 !: copy of time step # istp
140	INTEGER, PUBLIC :: ncom_fsbc = 1 !: copy of sbc time step # nn_fsbc
141	INTEGER, PUBLIC :: ncom_dttrc = 1 !: copy of top time step # nn_dttrc
142	INTEGER, PUBLIC :: ncom_freq !: frequency of comm diagnostic
143	INTEGER, PUBLIC , DIMENSION(:,:), ALLOCATABLE :: ncomm_sequence !: size of communicated arrays (halos)
144	INTEGER, PARAMETER, PUBLIC :: ncom_rec_max = 5000 !: max number of communication record
145	INTEGER, PUBLIC :: n_sequence_lbc = 0 !: # of communicated arraysvia lbc
146	INTEGER, PUBLIC :: n_sequence_glb = 0 !: # of global communications
147	INTEGER, PUBLIC :: n_sequence_dlg = 0 !: # of delayed global communications
148	INTEGER, PUBLIC :: numcom = -1 !: logical unit for communicaton report
149	LOGICAL, PUBLIC :: l_full_nf_update = .TRUE. !: logical for a full (2lines) update of bc at North fold report
150	INTEGER, PARAMETER, PUBLIC :: nbdelay = 2 !: number of delayed operations
151	!: name (used as id) of allreduce-delayed operations
152	! Warning: we must use the same character length in an array constructor (at least for gcc compiler)
153	CHARACTER(len=32), DIMENSION(nbdelay), PUBLIC :: c_delaylist = (/ 'cflice', 'fwb ' /)
154	!: component name where the allreduce-delayed operation is performed
155	CHARACTER(len=3), DIMENSION(nbdelay), PUBLIC :: c_delaycpnt = (/ 'ICE' , 'OCE' /)
156	TYPE, PUBLIC :: DELAYARR
157	REAL( wp), POINTER, DIMENSION(:) :: z1d => NULL()
158	COMPLEX(wp), POINTER, DIMENSION(:) :: y1d => NULL()
159	END TYPE DELAYARR
160	TYPE( DELAYARR ), DIMENSION(nbdelay), PUBLIC, SAVE :: todelay !: must have SAVE for default initialization of DELAYARR
161	INTEGER, DIMENSION(nbdelay), PUBLIC :: ndelayid = -1 !: mpi request id of the delayed operations
162
163	! timing summary report
164	REAL(wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp
165	REAL(wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp
166
167	REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend
168
169	LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms
170	LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms
171
172	!!----------------------------------------------------------------------
173	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
174	!! $Id$
175	!! Software governed by the CeCILL license (see ./LICENSE)
176	!!----------------------------------------------------------------------
177	CONTAINS
178
179	SUBROUTINE mpp_start( localComm )
180	!!----------------------------------------------------------------------
181	!! * routine mpp_start *
182	!!
183	!! ** Purpose : get mpi_comm_oce, mpprank and mppsize
184	!!----------------------------------------------------------------------
185	INTEGER , OPTIONAL , INTENT(in ) :: localComm !
186	!
187	INTEGER :: ierr
188	LOGICAL :: llmpi_init
189	!!----------------------------------------------------------------------
190	#if defined key_mpp_mpi
191	!
192	CALL mpi_initialized ( llmpi_init, ierr )
193	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' )
194
195	IF( .NOT. llmpi_init ) THEN
196	IF( PRESENT(localComm) ) THEN
197	WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator '
198	WRITE(ctmp2,*) ' without calling MPI_Init before ! '
199	CALL ctl_stop( 'STOP', ctmp1, ctmp2 )
200	ENDIF
201	CALL mpi_init( ierr )
202	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' )
203	ENDIF
204
205	IF( PRESENT(localComm) ) THEN
206	IF( Agrif_Root() ) THEN
207	mpi_comm_oce = localComm
208	ENDIF
209	ELSE
210	CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr)
211	IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' )
212	ENDIF
213
214	# if defined key_agrif
215	IF( Agrif_Root() ) THEN
216	CALL Agrif_MPI_Init(mpi_comm_oce)
217	ELSE
218	CALL Agrif_MPI_set_grid_comm(mpi_comm_oce)
219	ENDIF
220	# endif
221
222	CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr )
223	CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr )
224	!
225	CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr)
226	!
227	#else
228	IF( PRESENT( localComm ) ) mpi_comm_oce = localComm
229	mppsize = 1
230	mpprank = 0
231	#endif
232	END SUBROUTINE mpp_start
233
234
235	SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req )
236	!!----------------------------------------------------------------------
237	!! * routine mppsend *
238	!!
239	!! ** Purpose : Send messag passing array
240	!!
241	!!----------------------------------------------------------------------
242	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
243	INTEGER , INTENT(in ) :: kbytes ! size of the array pmess
244	INTEGER , INTENT(in ) :: kdest ! receive process number
245	INTEGER , INTENT(in ) :: ktyp ! tag of the message
246	INTEGER , INTENT(in ) :: md_req ! argument for isend
247	!!
248	INTEGER :: iflag
249	!!----------------------------------------------------------------------
250	!
251	#if defined key_mpp_mpi
252	CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag )
253	#endif
254	!
255	END SUBROUTINE mppsend
256
257
258	SUBROUTINE mpprecv( ktyp, pmess, kbytes, ksource )
259	!!----------------------------------------------------------------------
260	!! * routine mpprecv *
261	!!
262	!! ** Purpose : Receive messag passing array
263	!!
264	!!----------------------------------------------------------------------
265	REAL(wp), INTENT(inout) :: pmess(*) ! array of real
266	INTEGER , INTENT(in ) :: kbytes ! suze of the array pmess
267	INTEGER , INTENT(in ) :: ktyp ! Tag of the recevied message
268	INTEGER, OPTIONAL, INTENT(in) :: ksource ! source process number
269	!!
270	INTEGER :: istatus(mpi_status_size)
271	INTEGER :: iflag
272	INTEGER :: use_source
273	!!----------------------------------------------------------------------
274	!
275	#if defined key_mpp_mpi
276	! If a specific process number has been passed to the receive call,
277	! use that one. Default is to use mpi_any_source
278	use_source = mpi_any_source
279	IF( PRESENT(ksource) ) use_source = ksource
280	!
281	CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_oce, istatus, iflag )
282	#endif
283	!
284	END SUBROUTINE mpprecv
285
286
287	SUBROUTINE mppgather( ptab, kp, pio )
288	!!----------------------------------------------------------------------
289	!! * routine mppgather *
290	!!
291	!! ** Purpose : Transfert between a local subdomain array and a work
292	!! array which is distributed following the vertical level.
293	!!
294	!!----------------------------------------------------------------------
295	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array
296	INTEGER , INTENT(in ) :: kp ! record length
297	REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array
298	!!
299	INTEGER :: itaille, ierror ! temporary integer
300	!!---------------------------------------------------------------------
301	!
302	itaille = jpi * jpj
303	#if defined key_mpp_mpi
304	CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , &
305	& mpi_double_precision, kp , mpi_comm_oce, ierror )
306	#else
307	pio(:,:,1) = ptab(:,:)
308	#endif
309	!
310	END SUBROUTINE mppgather
311
312
313	SUBROUTINE mppscatter( pio, kp, ptab )
314	!!----------------------------------------------------------------------
315	!! * routine mppscatter *
316	!!
317	!! ** Purpose : Transfert between awork array which is distributed
318	!! following the vertical level and the local subdomain array.
319	!!
320	!!----------------------------------------------------------------------
321	REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array
322	INTEGER :: kp ! Tag (not used with MPI
323	REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input
324	!!
325	INTEGER :: itaille, ierror ! temporary integer
326	!!---------------------------------------------------------------------
327	!
328	itaille = jpi * jpj
329	!
330	#if defined key_mpp_mpi
331	CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , &
332	& mpi_double_precision, kp , mpi_comm_oce, ierror )
333	#else
334	ptab(:,:) = pio(:,:,1)
335	#endif
336	!
337	END SUBROUTINE mppscatter
338
339
340	SUBROUTINE mpp_delay_sum( cdname, cdelay, y_in, pout, ldlast, kcom )
341	!!----------------------------------------------------------------------
342	!! * routine mpp_delay_sum *
343	!!
344	!! ** Purpose : performed delayed mpp_sum, the result is received on next call
345	!!
346	!!----------------------------------------------------------------------
347	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
348	CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
349	COMPLEX(wp), INTENT(in ), DIMENSION(:) :: y_in
350	REAL(wp), INTENT( out), DIMENSION(:) :: pout
351	LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
352	INTEGER, INTENT(in ), OPTIONAL :: kcom
353	!!
354	INTEGER :: ji, isz
355	INTEGER :: idvar
356	INTEGER :: ierr, ilocalcomm
357	COMPLEX(wp), ALLOCATABLE, DIMENSION(:) :: ytmp
358	!!----------------------------------------------------------------------
359	#if defined key_mpp_mpi
360	ilocalcomm = mpi_comm_oce
361	IF( PRESENT(kcom) ) ilocalcomm = kcom
362
363	isz = SIZE(y_in)
364
365	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
366
367	idvar = -1
368	DO ji = 1, nbdelay
369	IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
370	END DO
371	IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_sum : please add a new delayed exchange for '//TRIM(cdname) )
372
373	IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst
374	! --------------------------
375	IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence
376	IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
377	DEALLOCATE(todelay(idvar)%z1d)
378	ndelayid(idvar) = -1 ! do as if we had no restart
379	ELSE
380	ALLOCATE(todelay(idvar)%y1d(isz))
381	todelay(idvar)%y1d(:) = CMPLX(todelay(idvar)%z1d(:), 0., wp) ! create %y1d, complex variable needed by mpi_sumdd
382	END IF
383	ENDIF
384
385	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce
386	! --------------------------
387	ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart
388	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d
389	todelay(idvar)%z1d(:) = REAL(todelay(idvar)%y1d(:), wp) ! define %z1d from %y1d
390	ENDIF
391
392	IF( ndelayid(idvar) > 0 ) CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
393
394	! send back pout from todelay(idvar)%z1d defined at previous call
395	pout(:) = todelay(idvar)%z1d(:)
396
397	! send y_in into todelay(idvar)%y1d with a non-blocking communication
398	# if defined key_mpi2
399	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
400	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )
401	ndelayid(idvar) = 1
402	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
403	# else
404	CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
405	# endif
406	#else
407	pout(:) = REAL(y_in(:), wp)
408	#endif
409
410	END SUBROUTINE mpp_delay_sum
411
412
413	SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom )
414	!!----------------------------------------------------------------------
415	!! * routine mpp_delay_max *
416	!!
417	!! ** Purpose : performed delayed mpp_max, the result is received on next call
418	!!
419	!!----------------------------------------------------------------------
420	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
421	CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
422	REAL(wp), INTENT(in ), DIMENSION(:) :: p_in !
423	REAL(wp), INTENT( out), DIMENSION(:) :: pout !
424	LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
425	INTEGER, INTENT(in ), OPTIONAL :: kcom
426	!!
427	INTEGER :: ji, isz
428	INTEGER :: idvar
429	INTEGER :: ierr, ilocalcomm
430	!!----------------------------------------------------------------------
431	#if defined key_mpp_mpi
432	ilocalcomm = mpi_comm_oce
433	IF( PRESENT(kcom) ) ilocalcomm = kcom
434
435	isz = SIZE(p_in)
436
437	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
438
439	idvar = -1
440	DO ji = 1, nbdelay
441	IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
442	END DO
443	IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) )
444
445	IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst
446	! --------------------------
447	IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence
448	IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
449	DEALLOCATE(todelay(idvar)%z1d)
450	ndelayid(idvar) = -1 ! do as if we had no restart
451	END IF
452	ENDIF
453
454	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce
455	! --------------------------
456	ALLOCATE(todelay(idvar)%z1d(isz))
457	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d
458	ENDIF
459
460	IF( ndelayid(idvar) > 0 ) CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
461
462	! send back pout from todelay(idvar)%z1d defined at previous call
463	pout(:) = todelay(idvar)%z1d(:)
464
465	! send p_in into todelay(idvar)%z1d with a non-blocking communication
466	# if defined key_mpi2
467	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
468	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr )
469	ndelayid(idvar) = 1
470	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
471	# else
472	CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
473	# endif
474	#else
475	pout(:) = p_in(:)
476	#endif
477
478	END SUBROUTINE mpp_delay_max
479
480
481	SUBROUTINE mpp_delay_rcv( kid )
482	!!----------------------------------------------------------------------
483	!! * routine mpp_delay_rcv *
484	!!
485	!! ** Purpose : force barrier for delayed mpp (needed for restart)
486	!!
487	!!----------------------------------------------------------------------
488	INTEGER,INTENT(in ) :: kid
489	INTEGER :: ierr
490	!!----------------------------------------------------------------------
491	#if defined key_mpp_mpi
492	IF( ndelayid(kid) /= -2 ) THEN
493	#if ! defined key_mpi2
494	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
495	CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! make sure todelay(kid) is received
496	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
497	#endif
498	IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d
499	ndelayid(kid) = -2 ! add flag to know that mpi_wait was already called on kid
500	ENDIF
501	#endif
502	END SUBROUTINE mpp_delay_rcv
503
504
505	!!----------------------------------------------------------------------
506	!! * mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *
507	!!
508	!!----------------------------------------------------------------------
509	!!
510	# define OPERATION_MAX
511	# define INTEGER_TYPE
512	# define DIM_0d
513	# define ROUTINE_ALLREDUCE mppmax_int
514	# include "mpp_allreduce_generic.h90"
515	# undef ROUTINE_ALLREDUCE
516	# undef DIM_0d
517	# define DIM_1d
518	# define ROUTINE_ALLREDUCE mppmax_a_int
519	# include "mpp_allreduce_generic.h90"
520	# undef ROUTINE_ALLREDUCE
521	# undef DIM_1d
522	# undef INTEGER_TYPE
523	!
524	# define REAL_TYPE
525	# define DIM_0d
526	# define ROUTINE_ALLREDUCE mppmax_real
527	# include "mpp_allreduce_generic.h90"
528	# undef ROUTINE_ALLREDUCE
529	# undef DIM_0d
530	# define DIM_1d
531	# define ROUTINE_ALLREDUCE mppmax_a_real
532	# include "mpp_allreduce_generic.h90"
533	# undef ROUTINE_ALLREDUCE
534	# undef DIM_1d
535	# undef REAL_TYPE
536	# undef OPERATION_MAX
537	!!----------------------------------------------------------------------
538	!! * mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *
539	!!
540	!!----------------------------------------------------------------------
541	!!
542	# define OPERATION_MIN
543	# define INTEGER_TYPE
544	# define DIM_0d
545	# define ROUTINE_ALLREDUCE mppmin_int
546	# include "mpp_allreduce_generic.h90"
547	# undef ROUTINE_ALLREDUCE
548	# undef DIM_0d
549	# define DIM_1d
550	# define ROUTINE_ALLREDUCE mppmin_a_int
551	# include "mpp_allreduce_generic.h90"
552	# undef ROUTINE_ALLREDUCE
553	# undef DIM_1d
554	# undef INTEGER_TYPE
555	!
556	# define REAL_TYPE
557	# define DIM_0d
558	# define ROUTINE_ALLREDUCE mppmin_real
559	# include "mpp_allreduce_generic.h90"
560	# undef ROUTINE_ALLREDUCE
561	# undef DIM_0d
562	# define DIM_1d
563	# define ROUTINE_ALLREDUCE mppmin_a_real
564	# include "mpp_allreduce_generic.h90"
565	# undef ROUTINE_ALLREDUCE
566	# undef DIM_1d
567	# undef REAL_TYPE
568	# undef OPERATION_MIN
569
570	!!----------------------------------------------------------------------
571	!! * mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *
572	!!
573	!! Global sum of 1D array or a variable (integer, real or complex)
574	!!----------------------------------------------------------------------
575	!!
576	# define OPERATION_SUM
577	# define INTEGER_TYPE
578	# define DIM_0d
579	# define ROUTINE_ALLREDUCE mppsum_int
580	# include "mpp_allreduce_generic.h90"
581	# undef ROUTINE_ALLREDUCE
582	# undef DIM_0d
583	# define DIM_1d
584	# define ROUTINE_ALLREDUCE mppsum_a_int
585	# include "mpp_allreduce_generic.h90"
586	# undef ROUTINE_ALLREDUCE
587	# undef DIM_1d
588	# undef INTEGER_TYPE
589	!
590	# define REAL_TYPE
591	# define DIM_0d
592	# define ROUTINE_ALLREDUCE mppsum_real
593	# include "mpp_allreduce_generic.h90"
594	# undef ROUTINE_ALLREDUCE
595	# undef DIM_0d
596	# define DIM_1d
597	# define ROUTINE_ALLREDUCE mppsum_a_real
598	# include "mpp_allreduce_generic.h90"
599	# undef ROUTINE_ALLREDUCE
600	# undef DIM_1d
601	# undef REAL_TYPE
602	# undef OPERATION_SUM
603
604	# define OPERATION_SUM_DD
605	# define COMPLEX_TYPE
606	# define DIM_0d
607	# define ROUTINE_ALLREDUCE mppsum_realdd
608	# include "mpp_allreduce_generic.h90"
609	# undef ROUTINE_ALLREDUCE
610	# undef DIM_0d
611	# define DIM_1d
612	# define ROUTINE_ALLREDUCE mppsum_a_realdd
613	# include "mpp_allreduce_generic.h90"
614	# undef ROUTINE_ALLREDUCE
615	# undef DIM_1d
616	# undef COMPLEX_TYPE
617	# undef OPERATION_SUM_DD
618
619	!!----------------------------------------------------------------------
620	!! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
621	!!
622	!!----------------------------------------------------------------------
623	!!
624	# define OPERATION_MINLOC
625	# define DIM_2d
626	# define ROUTINE_LOC mpp_minloc2d
627	# include "mpp_loc_generic.h90"
628	# undef ROUTINE_LOC
629	# undef DIM_2d
630	# define DIM_3d
631	# define ROUTINE_LOC mpp_minloc3d
632	# include "mpp_loc_generic.h90"
633	# undef ROUTINE_LOC
634	# undef DIM_3d
635	# undef OPERATION_MINLOC
636
637	# define OPERATION_MAXLOC
638	# define DIM_2d
639	# define ROUTINE_LOC mpp_maxloc2d
640	# include "mpp_loc_generic.h90"
641	# undef ROUTINE_LOC
642	# undef DIM_2d
643	# define DIM_3d
644	# define ROUTINE_LOC mpp_maxloc3d
645	# include "mpp_loc_generic.h90"
646	# undef ROUTINE_LOC
647	# undef DIM_3d
648	# undef OPERATION_MAXLOC
649
650	SUBROUTINE mppsync()
651	!!----------------------------------------------------------------------
652	!! * routine mppsync *
653	!!
654	!! ** Purpose : Massively parallel processors, synchroneous
655	!!
656	!!-----------------------------------------------------------------------
657	INTEGER :: ierror
658	!!-----------------------------------------------------------------------
659	!
660	#if defined key_mpp_mpi
661	CALL mpi_barrier( mpi_comm_oce, ierror )
662	#endif
663	!
664	END SUBROUTINE mppsync
665
666
667	SUBROUTINE mppstop( ld_abort )
668	!!----------------------------------------------------------------------
669	!! * routine mppstop *
670	!!
671	!! ** purpose : Stop massively parallel processors method
672	!!
673	!!----------------------------------------------------------------------
674	LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number
675	LOGICAL :: ll_abort
676	INTEGER :: info
677	!!----------------------------------------------------------------------
678	ll_abort = .FALSE.
679	IF( PRESENT(ld_abort) ) ll_abort = ld_abort
680	!
681	#if defined key_mpp_mpi
682	IF(ll_abort) THEN
683	CALL mpi_abort( MPI_COMM_WORLD )
684	ELSE
685	CALL mppsync
686	CALL mpi_finalize( info )
687	ENDIF
688	#endif
689	IF( ll_abort ) STOP 123
690	!
691	END SUBROUTINE mppstop
692
693
694	SUBROUTINE mpp_comm_free( kcom )
695	!!----------------------------------------------------------------------
696	INTEGER, INTENT(in) :: kcom
697	!!
698	INTEGER :: ierr
699	!!----------------------------------------------------------------------
700	!
701	#if defined key_mpp_mpi
702	CALL MPI_COMM_FREE(kcom, ierr)
703	#endif
704	!
705	END SUBROUTINE mpp_comm_free
706
707
708	SUBROUTINE mpp_ini_znl( kumout )
709	!!----------------------------------------------------------------------
710	!! * routine mpp_ini_znl *
711	!!
712	!! ** Purpose : Initialize special communicator for computing zonal sum
713	!!
714	!! ** Method : - Look for processors in the same row
715	!! - Put their number in nrank_znl
716	!! - Create group for the znl processors
717	!! - Create a communicator for znl processors
718	!! - Determine if processor should write znl files
719	!!
720	!! ** output
721	!! ndim_rank_znl = number of processors on the same row
722	!! ngrp_znl = group ID for the znl processors
723	!! ncomm_znl = communicator for the ice procs.
724	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
725	!!
726	!!----------------------------------------------------------------------
727	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
728	!
729	INTEGER :: jproc ! dummy loop integer
730	INTEGER :: ierr, ii ! local integer
731	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
732	!!----------------------------------------------------------------------
733	#if defined key_mpp_mpi
734	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
735	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
736	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce : ', mpi_comm_oce
737	!
738	ALLOCATE( kwork(jpnij), STAT=ierr )
739	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij')
740
741	IF( jpnj == 1 ) THEN
742	ngrp_znl = ngrp_world
743	ncomm_znl = mpi_comm_oce
744	ELSE
745	!
746	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
747	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
748	!-$$ CALL flush(numout)
749	!
750	! Count number of processors on the same row
751	ndim_rank_znl = 0
752	DO jproc=1,jpnij
753	IF ( kwork(jproc) == njmpp ) THEN
754	ndim_rank_znl = ndim_rank_znl + 1
755	ENDIF
756	END DO
757	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
758	!-$$ CALL flush(numout)
759	! Allocate the right size to nrank_znl
760	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
761	ALLOCATE(nrank_znl(ndim_rank_znl))
762	ii = 0
763	nrank_znl (:) = 0
764	DO jproc=1,jpnij
765	IF ( kwork(jproc) == njmpp) THEN
766	ii = ii + 1
767	nrank_znl(ii) = jproc -1
768	ENDIF
769	END DO
770	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
771	!-$$ CALL flush(numout)
772
773	! Create the opa group
774	CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
775	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
776	!-$$ CALL flush(numout)
777
778	! Create the znl group from the opa group
779	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
780	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
781	!-$$ CALL flush(numout)
782
783	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
784	CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
785	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
786	!-$$ CALL flush(numout)
787	!
788	END IF
789
790	! Determines if processor if the first (starting from i=1) on the row
791	IF ( jpni == 1 ) THEN
792	l_znl_root = .TRUE.
793	ELSE
794	l_znl_root = .FALSE.
795	kwork (1) = nimpp
796	CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
797	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
798	END IF
799
800	DEALLOCATE(kwork)
801	#endif
802
803	END SUBROUTINE mpp_ini_znl
804
805
806	SUBROUTINE mpp_ini_north
807	!!----------------------------------------------------------------------
808	!! * routine mpp_ini_north *
809	!!
810	!! ** Purpose : Initialize special communicator for north folding
811	!! condition together with global variables needed in the mpp folding
812	!!
813	!! ** Method : - Look for northern processors
814	!! - Put their number in nrank_north
815	!! - Create groups for the world processors and the north processors
816	!! - Create a communicator for northern processors
817	!!
818	!! ** output
819	!! njmppmax = njmpp for northern procs
820	!! ndim_rank_north = number of processors in the northern line
821	!! nrank_north (ndim_rank_north) = number of the northern procs.
822	!! ngrp_world = group ID for the world processors
823	!! ngrp_north = group ID for the northern processors
824	!! ncomm_north = communicator for the northern procs.
825	!! north_root = number (in the world) of proc 0 in the northern comm.
826	!!
827	!!----------------------------------------------------------------------
828	INTEGER :: ierr
829	INTEGER :: jjproc
830	INTEGER :: ii, ji
831	!!----------------------------------------------------------------------
832	!
833	#if defined key_mpp_mpi
834	njmppmax = MAXVAL( njmppt )
835	!
836	! Look for how many procs on the northern boundary
837	ndim_rank_north = 0
838	DO jjproc = 1, jpnij
839	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
840	END DO
841	!
842	! Allocate the right size to nrank_north
843	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
844	ALLOCATE( nrank_north(ndim_rank_north) )
845
846	! Fill the nrank_north array with proc. number of northern procs.
847	! Note : the rank start at 0 in MPI
848	ii = 0
849	DO ji = 1, jpnij
850	IF ( njmppt(ji) == njmppmax ) THEN
851	ii=ii+1
852	nrank_north(ii)=ji-1
853	END IF
854	END DO
855	!
856	! create the world group
857	CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
858	!
859	! Create the North group from the world group
860	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
861	!
862	! Create the North communicator , ie the pool of procs in the north group
863	CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
864	!
865	#endif
866	END SUBROUTINE mpp_ini_north
867
868
869	SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
870	!!---------------------------------------------------------------------
871	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
872	!!
873	!! Modification of original codes written by David H. Bailey
874	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
875	!!---------------------------------------------------------------------
876	INTEGER , INTENT(in) :: ilen, itype
877	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
878	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
879	!
880	REAL(wp) :: zerr, zt1, zt2 ! local work variables
881	INTEGER :: ji, ztmp ! local scalar
882	!!---------------------------------------------------------------------
883	!
884	ztmp = itype ! avoid compilation warning
885	!
886	DO ji=1,ilen
887	! Compute ydda + yddb using Knuth's trick.
888	zt1 = real(ydda(ji)) + real(yddb(ji))
889	zerr = zt1 - real(ydda(ji))
890	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
891	+ aimag(ydda(ji)) + aimag(yddb(ji))
892
893	! The result is zt1 + zt2, after normalization.
894	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
895	END DO
896	!
897	END SUBROUTINE DDPDD_MPI
898
899
900	SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
901	!!----------------------------------------------------------------------
902	!! * routine mpp_report *
903	!!
904	!! ** Purpose : report use of mpp routines per time-setp
905	!!
906	!!----------------------------------------------------------------------
907	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
908	INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf
909	LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg
910	!!
911	CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications
912	LOGICAL :: ll_lbc, ll_glb, ll_dlg
913	INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices
914	!!----------------------------------------------------------------------
915	#if defined key_mpp_mpi
916	!
917	ll_lbc = .FALSE.
918	IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
919	ll_glb = .FALSE.
920	IF( PRESENT(ld_glb) ) ll_glb = ld_glb
921	ll_dlg = .FALSE.
922	IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg
923	!
924	! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
925	IF( ncom_dttrc /= 1 ) CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' )
926	ncom_freq = ncom_fsbc
927	!
928	IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000
929	IF( ll_lbc ) THEN
930	IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
931	IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) )
932	n_sequence_lbc = n_sequence_lbc + 1
933	IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
934	crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine
935	ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions
936	ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi)
937	ENDIF
938	IF( ll_glb ) THEN
939	IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
940	n_sequence_glb = n_sequence_glb + 1
941	IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
942	crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine
943	ENDIF
944	IF( ll_dlg ) THEN
945	IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) )
946	n_sequence_dlg = n_sequence_dlg + 1
947	IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
948	crname_dlg(n_sequence_dlg) = cdname ! keep the name of the calling routine
949	ENDIF
950	ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
951	CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
952	WRITE(numcom,*) ' '
953	WRITE(numcom,*) ' ------------------------------------------------------------'
954	WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
955	WRITE(numcom,*) ' ------------------------------------------------------------'
956	WRITE(numcom,*) ' '
957	WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
958	jj = 0; jk = 0; jf = 0; jh = 0
959	DO ji = 1, n_sequence_lbc
960	IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
961	IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
962	IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
963	jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
964	END DO
965	WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
966	WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
967	WRITE(numcom,'(A,I3)') ' from which 3D : ', jj
968	WRITE(numcom,'(A,I10)') ' Array max size : ', jhjpijpj
969	WRITE(numcom,*) ' '
970	WRITE(numcom,*) ' lbc_lnk called'
971	DO ji = 1, n_sequence_lbc - 1
972	IF ( crname_lbc(ji) /= 'already counted' ) THEN
973	ccountname = crname_lbc(ji)
974	crname_lbc(ji) = 'already counted'
975	jcount = 1
976	DO jj = ji + 1, n_sequence_lbc
977	IF ( ccountname == crname_lbc(jj) ) THEN
978	jcount = jcount + 1
979	crname_lbc(jj) = 'already counted'
980	END IF
981	END DO
982	WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname)
983	END IF
984	END DO
985	IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN
986	WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max))
987	END IF
988	WRITE(numcom,*) ' '
989	IF ( n_sequence_glb > 0 ) THEN
990	WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
991	jj = 1
992	DO ji = 2, n_sequence_glb
993	IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
994	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
995	jj = 0
996	END IF
997	jj = jj + 1
998	END DO
999	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
1000	DEALLOCATE(crname_glb)
1001	ELSE
1002	WRITE(numcom,*) ' No MPI global communication '
1003	ENDIF
1004	WRITE(numcom,*) ' '
1005	IF ( n_sequence_dlg > 0 ) THEN
1006	WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg
1007	jj = 1
1008	DO ji = 2, n_sequence_dlg
1009	IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN
1010	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1))
1011	jj = 0
1012	END IF
1013	jj = jj + 1
1014	END DO
1015	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg))
1016	DEALLOCATE(crname_dlg)
1017	ELSE
1018	WRITE(numcom,*) ' No MPI delayed global communication '
1019	ENDIF
1020	WRITE(numcom,*) ' '
1021	WRITE(numcom,*) ' -----------------------------------------------'
1022	WRITE(numcom,*) ' '
1023	DEALLOCATE(ncomm_sequence)
1024	DEALLOCATE(crname_lbc)
1025	ENDIF
1026	#endif
1027	END SUBROUTINE mpp_report
1028
1029
1030	SUBROUTINE tic_tac (ld_tic, ld_global)
1031
1032	LOGICAL, INTENT(IN) :: ld_tic
1033	LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1034	REAL(wp), DIMENSION(2), SAVE :: tic_wt
1035	REAL(wp), SAVE :: tic_ct = 0._wp
1036	INTEGER :: ii
1037	#if defined key_mpp_mpi
1038
1039	IF( ncom_stp <= nit000 ) RETURN
1040	IF( ncom_stp == nitend ) RETURN
1041	ii = 1
1042	IF( PRESENT( ld_global ) ) THEN
1043	IF( ld_global ) ii = 2
1044	END IF
1045
1046	IF ( ld_tic ) THEN
1047	tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time)
1048	IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
1049	ELSE
1050	waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac
1051	tic_ct = MPI_Wtime() ! start count tac->tic (waiting time)
1052	ENDIF
1053	#endif
1054
1055	END SUBROUTINE tic_tac
1056
1057	#if ! defined key_mpp_mpi
1058	SUBROUTINE mpi_wait(request, status, ierror)
1059	INTEGER , INTENT(in ) :: request
1060	INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status
1061	INTEGER , INTENT( out) :: ierror
1062	END SUBROUTINE mpi_wait
1063
1064
1065	FUNCTION MPI_Wtime()
1066	REAL(wp) :: MPI_Wtime
1067	MPI_Wtime = -1.
1068	END FUNCTION MPI_Wtime
1069	#endif
1070
1071	!!----------------------------------------------------------------------
1072	!! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
1073	!!----------------------------------------------------------------------
1074
1075	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
1076	& cd6, cd7, cd8, cd9, cd10 )
1077	!!----------------------------------------------------------------------
1078	!! * ROUTINE stop_opa *
1079	!!
1080	!! ** Purpose : print in ocean.outpput file a error message and
1081	!! increment the error number (nstop) by one.
1082	!!----------------------------------------------------------------------
1083	CHARACTER(len=*), INTENT(in ) :: cd1
1084	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5
1085	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1086	!
1087	INTEGER :: inum
1088	!!----------------------------------------------------------------------
1089	!
1090	nstop = nstop + 1
1091	!
1092	IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file
1093	CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
1094	WRITE(inum,*)
1095	WRITE(inum,) ' ==>>> Look for "E R R O R" messages in all existing ocean.output* files'
1096	CLOSE(inum)
1097	ENDIF
1098	IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened
1099	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea )
1100	ENDIF
1101	!
1102	WRITE(numout,*)
1103	WRITE(numout,*) ' ===>>> : E R R O R'
1104	WRITE(numout,*)
1105	WRITE(numout,*) ' ==========='
1106	WRITE(numout,*)
1107	WRITE(numout,*) TRIM(cd1)
1108	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1109	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1110	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1111	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1112	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1113	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1114	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1115	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1116	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1117	WRITE(numout,*)
1118	!
1119	CALL FLUSH(numout )
1120	IF( numstp /= -1 ) CALL FLUSH(numstp )
1121	IF( numrun /= -1 ) CALL FLUSH(numrun )
1122	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
1123	!
1124	IF( cd1 == 'STOP' ) THEN
1125	WRITE(numout,*)
1126	WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
1127	WRITE(numout,*)
1128	CALL FLUSH(numout)
1129	CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough...
1130	CALL mppstop( ld_abort = .true. )
1131	ENDIF
1132	!
1133	END SUBROUTINE ctl_stop
1134
1135
1136	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
1137	& cd6, cd7, cd8, cd9, cd10 )
1138	!!----------------------------------------------------------------------
1139	!! * ROUTINE stop_warn *
1140	!!
1141	!! ** Purpose : print in ocean.outpput file a error message and
1142	!! increment the warning number (nwarn) by one.
1143	!!----------------------------------------------------------------------
1144	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
1145	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1146	!!----------------------------------------------------------------------
1147	!
1148	nwarn = nwarn + 1
1149	!
1150	IF(lwp) THEN
1151	WRITE(numout,*)
1152	WRITE(numout,*) ' ===>>> : W A R N I N G'
1153	WRITE(numout,*)
1154	WRITE(numout,*) ' ==============='
1155	WRITE(numout,*)
1156	IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1)
1157	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1158	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1159	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1160	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1161	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1162	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1163	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1164	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1165	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1166	WRITE(numout,*)
1167	ENDIF
1168	CALL FLUSH(numout)
1169	!
1170	END SUBROUTINE ctl_warn
1171
1172
1173	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1174	!!----------------------------------------------------------------------
1175	!! * ROUTINE ctl_opn *
1176	!!
1177	!! ** Purpose : Open file and check if required file is available.
1178	!!
1179	!! ** Method : Fortan open
1180	!!----------------------------------------------------------------------
1181	INTEGER , INTENT( out) :: knum ! logical unit to open
1182	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
1183	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
1184	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
1185	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
1186	INTEGER , INTENT(in ) :: klengh ! record length
1187	INTEGER , INTENT(in ) :: kout ! number of logical units for write
1188	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
1189	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
1190	!
1191	CHARACTER(len=80) :: clfile
1192	CHARACTER(LEN=10) :: clfmt ! writing format
1193	INTEGER :: iost
1194	INTEGER :: idg ! number of digits
1195	!!----------------------------------------------------------------------
1196	!
1197	! adapt filename
1198	! ----------------
1199	clfile = TRIM(cdfile)
1200	IF( PRESENT( karea ) ) THEN
1201	IF( karea > 1 ) THEN
1202	! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij
1203	idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
1204	WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)'
1205	WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1
1206	ENDIF
1207	ENDIF
1208	#if defined key_agrif
1209	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1210	knum=Agrif_Get_Unit()
1211	#else
1212	knum=get_unit()
1213	#endif
1214	IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null
1215	!
1216	IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters
1217	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost )
1218	ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters
1219	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost )
1220	ELSE
1221	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1222	ENDIF
1223	IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) & ! for windows
1224	& OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1225	IF( iost == 0 ) THEN
1226	IF(ldwp .AND. kout > 0) THEN
1227	WRITE(kout,*) ' file : ', TRIM(clfile),' open ok'
1228	WRITE(kout,*) ' unit = ', knum
1229	WRITE(kout,*) ' status = ', cdstat
1230	WRITE(kout,*) ' form = ', cdform
1231	WRITE(kout,*) ' access = ', cdacce
1232	WRITE(kout,*)
1233	ENDIF
1234	ENDIF
1235	100 CONTINUE
1236	IF( iost /= 0 ) THEN
1237	WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile)
1238	WRITE(ctmp2,*) ' ======= === '
1239	WRITE(ctmp3,*) ' unit = ', knum
1240	WRITE(ctmp4,*) ' status = ', cdstat
1241	WRITE(ctmp5,*) ' form = ', cdform
1242	WRITE(ctmp6,*) ' access = ', cdacce
1243	WRITE(ctmp7,*) ' iostat = ', iost
1244	WRITE(ctmp8,*) ' we stop. verify the file '
1245	CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 )
1246	ENDIF
1247	!
1248	END SUBROUTINE ctl_opn
1249
1250
1251	SUBROUTINE ctl_nam ( kios, cdnam )
1252	!!----------------------------------------------------------------------
1253	!! * ROUTINE ctl_nam *
1254	!!
1255	!! ** Purpose : Informations when error while reading a namelist
1256	!!
1257	!! ** Method : Fortan open
1258	!!----------------------------------------------------------------------
1259	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
1260	CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs
1261	!
1262	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
1263	!!----------------------------------------------------------------------
1264	!
1265	WRITE (clios, '(I5.0)') kios
1266	IF( kios < 0 ) THEN
1267	CALL ctl_warn( 'end of record or file while reading namelist ' &
1268	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1269	ENDIF
1270	!
1271	IF( kios > 0 ) THEN
1272	CALL ctl_stop( 'misspelled variable in namelist ' &
1273	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1274	ENDIF
1275	kios = 0
1276	!
1277	END SUBROUTINE ctl_nam
1278
1279
1280	INTEGER FUNCTION get_unit()
1281	!!----------------------------------------------------------------------
1282	!! * FUNCTION get_unit *
1283	!!
1284	!! ** Purpose : return the index of an unused logical unit
1285	!!----------------------------------------------------------------------
1286	LOGICAL :: llopn
1287	!!----------------------------------------------------------------------
1288	!
1289	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
1290	llopn = .TRUE.
1291	DO WHILE( (get_unit < 998) .AND. llopn )
1292	get_unit = get_unit + 1
1293	INQUIRE( unit = get_unit, opened = llopn )
1294	END DO
1295	IF( (get_unit == 999) .AND. llopn ) THEN
1296	CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' )
1297	ENDIF
1298	!
1299	END FUNCTION get_unit
1300
1301	!!----------------------------------------------------------------------
1302	END MODULE lib_mpp

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

Download in other formats: