Context Navigation

lib_mpp.F90

Last change on this file was 15661, checked in by jpalmier, 2 years ago
4th and 5th merge : GC couple and isnow comb
File size: 57.8 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	ndelayid(idvar) = MPI_REQUEST_NULL ! initialised request to a valid value
383	END IF
384	ENDIF
385
386	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %y1d and %z1d from y_in with blocking allreduce
387	! --------------------------
388	ALLOCATE(todelay(idvar)%z1d(isz), todelay(idvar)%y1d(isz)) ! allocate also %z1d as used for the restart
389	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) ! get %y1d
390	ndelayid(idvar) = MPI_REQUEST_NULL
391	ENDIF
392
393	CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
394
395	! send back pout from todelay(idvar)%z1d defined at previous call
396	pout(:) = todelay(idvar)%z1d(:)
397
398	! send y_in into todelay(idvar)%y1d with a non-blocking communication
399	# if defined key_mpi2
400	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
401	CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr )
402	ndelayid(idvar) = MPI_REQUEST_NULL
403	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
404	# else
405	CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr )
406	# endif
407	#else
408	pout(:) = REAL(y_in(:), wp)
409	#endif
410
411	END SUBROUTINE mpp_delay_sum
412
413
414	SUBROUTINE mpp_delay_max( cdname, cdelay, p_in, pout, ldlast, kcom )
415	!!----------------------------------------------------------------------
416	!! * routine mpp_delay_max *
417	!!
418	!! ** Purpose : performed delayed mpp_max, the result is received on next call
419	!!
420	!!----------------------------------------------------------------------
421	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
422	CHARACTER(len=*), INTENT(in ) :: cdelay ! name (used as id) of the delayed operation
423	REAL(wp), INTENT(in ), DIMENSION(:) :: p_in !
424	REAL(wp), INTENT( out), DIMENSION(:) :: pout !
425	LOGICAL, INTENT(in ) :: ldlast ! true if this is the last time we call this routine
426	INTEGER, INTENT(in ), OPTIONAL :: kcom
427	!!
428	INTEGER :: ji, isz
429	INTEGER :: idvar
430	INTEGER :: ierr, ilocalcomm
431	!!----------------------------------------------------------------------
432
433	#if defined key_mpp_mpi
434	ilocalcomm = mpi_comm_oce
435	IF( PRESENT(kcom) ) ilocalcomm = kcom
436
437	isz = SIZE(p_in)
438
439	IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_dlg = .TRUE. )
440
441	idvar = -1
442	DO ji = 1, nbdelay
443	IF( TRIM(cdelay) == TRIM(c_delaylist(ji)) ) idvar = ji
444	END DO
445	IF ( idvar == -1 ) CALL ctl_stop( 'STOP',' mpp_delay_max : please add a new delayed exchange for '//TRIM(cdname) )
446
447	IF ( ndelayid(idvar) == 0 ) THEN ! first call with restart: %z1d defined in iom_delay_rst
448	! --------------------------
449	IF ( SIZE(todelay(idvar)%z1d) /= isz ) THEN ! Check dimension coherence
450	IF(lwp) WRITE(numout,*) ' WARNING: the nb of delayed variables in restart file is not the model one'
451	DEALLOCATE(todelay(idvar)%z1d)
452	ndelayid(idvar) = -1 ! do as if we had no restart
453	ELSE
454	ndelayid(idvar) = MPI_REQUEST_NULL
455	END IF
456	ENDIF
457
458	IF( ndelayid(idvar) == -1 ) THEN ! first call without restart: define %z1d from p_in with a blocking allreduce
459	! --------------------------
460	ALLOCATE(todelay(idvar)%z1d(isz))
461	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) ! get %z1d
462	ndelayid(idvar) = MPI_REQUEST_NULL
463	ENDIF
464
465	CALL mpp_delay_rcv( idvar ) ! make sure %z1d is received
466
467	! send back pout from todelay(idvar)%z1d defined at previous call
468	pout(:) = todelay(idvar)%z1d(:)
469
470	! send p_in into todelay(idvar)%z1d with a non-blocking communication
471	! (PM) Should we get rid of MPI2 option ? MPI3 was release in 2013. Who is still using MPI2 ?
472	# if defined key_mpi2
473	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
474	CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr )
475	IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.)
476	# else
477	CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr )
478	# endif
479	#else
480	pout(:) = p_in(:)
481	#endif
482
483	END SUBROUTINE mpp_delay_max
484
485
486	SUBROUTINE mpp_delay_rcv( kid )
487	!!----------------------------------------------------------------------
488	!! * routine mpp_delay_rcv *
489	!!
490	!! ** Purpose : force barrier for delayed mpp (needed for restart)
491	!!
492	!!----------------------------------------------------------------------
493	INTEGER,INTENT(in ) :: kid
494	INTEGER :: ierr
495	!!----------------------------------------------------------------------
496	#if defined key_mpp_mpi
497	IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.)
498	! test on ndelayid(kid) useless as mpi_wait return immediatly if the request handle is MPI_REQUEST_NULL
499	CALL mpi_wait( ndelayid(kid), MPI_STATUS_IGNORE, ierr ) ! after this ndelayid(kid) = MPI_REQUEST_NULL
500	IF( ln_timing ) CALL tic_tac( .FALSE., ld_global = .TRUE.)
501	IF( ASSOCIATED(todelay(kid)%y1d) ) todelay(kid)%z1d(:) = REAL(todelay(kid)%y1d(:), wp) ! define %z1d from %y1d
502	#endif
503	END SUBROUTINE mpp_delay_rcv
504
505
506	!!----------------------------------------------------------------------
507	!! * mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *
508	!!
509	!!----------------------------------------------------------------------
510	!!
511	# define OPERATION_MAX
512	# define INTEGER_TYPE
513	# define DIM_0d
514	# define ROUTINE_ALLREDUCE mppmax_int
515	# include "mpp_allreduce_generic.h90"
516	# undef ROUTINE_ALLREDUCE
517	# undef DIM_0d
518	# define DIM_1d
519	# define ROUTINE_ALLREDUCE mppmax_a_int
520	# include "mpp_allreduce_generic.h90"
521	# undef ROUTINE_ALLREDUCE
522	# undef DIM_1d
523	# undef INTEGER_TYPE
524	!
525	# define REAL_TYPE
526	# define DIM_0d
527	# define ROUTINE_ALLREDUCE mppmax_real
528	# include "mpp_allreduce_generic.h90"
529	# undef ROUTINE_ALLREDUCE
530	# undef DIM_0d
531	# define DIM_1d
532	# define ROUTINE_ALLREDUCE mppmax_a_real
533	# include "mpp_allreduce_generic.h90"
534	# undef ROUTINE_ALLREDUCE
535	# undef DIM_1d
536	# undef REAL_TYPE
537	# undef OPERATION_MAX
538	!!----------------------------------------------------------------------
539	!! * mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *
540	!!
541	!!----------------------------------------------------------------------
542	!!
543	# define OPERATION_MIN
544	# define INTEGER_TYPE
545	# define DIM_0d
546	# define ROUTINE_ALLREDUCE mppmin_int
547	# include "mpp_allreduce_generic.h90"
548	# undef ROUTINE_ALLREDUCE
549	# undef DIM_0d
550	# define DIM_1d
551	# define ROUTINE_ALLREDUCE mppmin_a_int
552	# include "mpp_allreduce_generic.h90"
553	# undef ROUTINE_ALLREDUCE
554	# undef DIM_1d
555	# undef INTEGER_TYPE
556	!
557	# define REAL_TYPE
558	# define DIM_0d
559	# define ROUTINE_ALLREDUCE mppmin_real
560	# include "mpp_allreduce_generic.h90"
561	# undef ROUTINE_ALLREDUCE
562	# undef DIM_0d
563	# define DIM_1d
564	# define ROUTINE_ALLREDUCE mppmin_a_real
565	# include "mpp_allreduce_generic.h90"
566	# undef ROUTINE_ALLREDUCE
567	# undef DIM_1d
568	# undef REAL_TYPE
569	# undef OPERATION_MIN
570
571	!!----------------------------------------------------------------------
572	!! * mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *
573	!!
574	!! Global sum of 1D array or a variable (integer, real or complex)
575	!!----------------------------------------------------------------------
576	!!
577	# define OPERATION_SUM
578	# define INTEGER_TYPE
579	# define DIM_0d
580	# define ROUTINE_ALLREDUCE mppsum_int
581	# include "mpp_allreduce_generic.h90"
582	# undef ROUTINE_ALLREDUCE
583	# undef DIM_0d
584	# define DIM_1d
585	# define ROUTINE_ALLREDUCE mppsum_a_int
586	# include "mpp_allreduce_generic.h90"
587	# undef ROUTINE_ALLREDUCE
588	# undef DIM_1d
589	# undef INTEGER_TYPE
590	!
591	# define REAL_TYPE
592	# define DIM_0d
593	# define ROUTINE_ALLREDUCE mppsum_real
594	# include "mpp_allreduce_generic.h90"
595	# undef ROUTINE_ALLREDUCE
596	# undef DIM_0d
597	# define DIM_1d
598	# define ROUTINE_ALLREDUCE mppsum_a_real
599	# include "mpp_allreduce_generic.h90"
600	# undef ROUTINE_ALLREDUCE
601	# undef DIM_1d
602	# undef REAL_TYPE
603	# undef OPERATION_SUM
604
605	# define OPERATION_SUM_DD
606	# define COMPLEX_TYPE
607	# define DIM_0d
608	# define ROUTINE_ALLREDUCE mppsum_realdd
609	# include "mpp_allreduce_generic.h90"
610	# undef ROUTINE_ALLREDUCE
611	# undef DIM_0d
612	# define DIM_1d
613	# define ROUTINE_ALLREDUCE mppsum_a_realdd
614	# include "mpp_allreduce_generic.h90"
615	# undef ROUTINE_ALLREDUCE
616	# undef DIM_1d
617	# undef COMPLEX_TYPE
618	# undef OPERATION_SUM_DD
619
620	!!----------------------------------------------------------------------
621	!! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d
622	!!
623	!!----------------------------------------------------------------------
624	!!
625	# define OPERATION_MINLOC
626	# define DIM_2d
627	# define ROUTINE_LOC mpp_minloc2d
628	# include "mpp_loc_generic.h90"
629	# undef ROUTINE_LOC
630	# undef DIM_2d
631	# define DIM_3d
632	# define ROUTINE_LOC mpp_minloc3d
633	# include "mpp_loc_generic.h90"
634	# undef ROUTINE_LOC
635	# undef DIM_3d
636	# undef OPERATION_MINLOC
637
638	# define OPERATION_MAXLOC
639	# define DIM_2d
640	# define ROUTINE_LOC mpp_maxloc2d
641	# include "mpp_loc_generic.h90"
642	# undef ROUTINE_LOC
643	# undef DIM_2d
644	# define DIM_3d
645	# define ROUTINE_LOC mpp_maxloc3d
646	# include "mpp_loc_generic.h90"
647	# undef ROUTINE_LOC
648	# undef DIM_3d
649	# undef OPERATION_MAXLOC
650
651	SUBROUTINE mppsync()
652	!!----------------------------------------------------------------------
653	!! * routine mppsync *
654	!!
655	!! ** Purpose : Massively parallel processors, synchroneous
656	!!
657	!!-----------------------------------------------------------------------
658	INTEGER :: ierror
659	!!-----------------------------------------------------------------------
660	!
661	#if defined key_mpp_mpi
662	CALL mpi_barrier( mpi_comm_oce, ierror )
663	#endif
664	!
665	END SUBROUTINE mppsync
666
667
668	SUBROUTINE mppstop( ld_abort )
669
670	USE mod_oasis ! coupling routines
671
672	!!----------------------------------------------------------------------
673	!! * routine mppstop *
674	!!
675	!! ** purpose : Stop massively parallel processors method
676	!!
677	!!----------------------------------------------------------------------
678	LOGICAL, OPTIONAL, INTENT(in) :: ld_abort ! source process number
679	LOGICAL :: ll_abort
680	INTEGER :: info
681	!!----------------------------------------------------------------------
682	ll_abort = .FALSE.
683	IF( PRESENT(ld_abort) ) ll_abort = ld_abort
684	!
685
686	#if defined key_oasis3
687	! If we're trying to shut down cleanly then we need to consider the fact
688	! that this could be part of an MPMD configuration - we don't want to
689	! leave other components deadlocked.
690
691	CALL oasis_abort(nproc,"mppstop","NEMO initiated abort")
692
693
694	#else
695	#if defined key_mpp_mpi
696	IF(ll_abort) THEN
697	CALL mpi_abort( MPI_COMM_WORLD )
698	ELSE
699	CALL mppsync
700	CALL mpi_finalize( info )
701	ENDIF
702	#endif
703	IF( ll_abort ) STOP 123
704	!
705	#endif
706	END SUBROUTINE mppstop
707
708
709	SUBROUTINE mpp_comm_free( kcom )
710	!!----------------------------------------------------------------------
711	INTEGER, INTENT(in) :: kcom
712	!!
713	INTEGER :: ierr
714	!!----------------------------------------------------------------------
715	!
716	#if defined key_mpp_mpi
717	CALL MPI_COMM_FREE(kcom, ierr)
718	#endif
719	!
720	END SUBROUTINE mpp_comm_free
721
722
723	SUBROUTINE mpp_ini_znl( kumout )
724	!!----------------------------------------------------------------------
725	!! * routine mpp_ini_znl *
726	!!
727	!! ** Purpose : Initialize special communicator for computing zonal sum
728	!!
729	!! ** Method : - Look for processors in the same row
730	!! - Put their number in nrank_znl
731	!! - Create group for the znl processors
732	!! - Create a communicator for znl processors
733	!! - Determine if processor should write znl files
734	!!
735	!! ** output
736	!! ndim_rank_znl = number of processors on the same row
737	!! ngrp_znl = group ID for the znl processors
738	!! ncomm_znl = communicator for the ice procs.
739	!! n_znl_root = number (in the world) of proc 0 in the ice comm.
740	!!
741	!!----------------------------------------------------------------------
742	INTEGER, INTENT(in) :: kumout ! ocean.output logical units
743	!
744	INTEGER :: jproc ! dummy loop integer
745	INTEGER :: ierr, ii ! local integer
746	INTEGER, ALLOCATABLE, DIMENSION(:) :: kwork
747	!!----------------------------------------------------------------------
748	#if defined key_mpp_mpi
749	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world
750	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world
751	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_oce : ', mpi_comm_oce
752	!
753	ALLOCATE( kwork(jpnij), STAT=ierr )
754	IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij')
755
756	IF( jpnj == 1 ) THEN
757	ngrp_znl = ngrp_world
758	ncomm_znl = mpi_comm_oce
759	ELSE
760	!
761	CALL MPI_ALLGATHER ( njmpp, 1, mpi_integer, kwork, 1, mpi_integer, mpi_comm_oce, ierr )
762	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - kwork pour njmpp : ', kwork
763	!-$$ CALL flush(numout)
764	!
765	! Count number of processors on the same row
766	ndim_rank_znl = 0
767	DO jproc=1,jpnij
768	IF ( kwork(jproc) == njmpp ) THEN
769	ndim_rank_znl = ndim_rank_znl + 1
770	ENDIF
771	END DO
772	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ndim_rank_znl : ', ndim_rank_znl
773	!-$$ CALL flush(numout)
774	! Allocate the right size to nrank_znl
775	IF (ALLOCATED (nrank_znl)) DEALLOCATE(nrank_znl)
776	ALLOCATE(nrank_znl(ndim_rank_znl))
777	ii = 0
778	nrank_znl (:) = 0
779	DO jproc=1,jpnij
780	IF ( kwork(jproc) == njmpp) THEN
781	ii = ii + 1
782	nrank_znl(ii) = jproc -1
783	ENDIF
784	END DO
785	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - nrank_znl : ', nrank_znl
786	!-$$ CALL flush(numout)
787
788	! Create the opa group
789	CALL MPI_COMM_GROUP(mpi_comm_oce,ngrp_opa,ierr)
790	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_opa : ', ngrp_opa
791	!-$$ CALL flush(numout)
792
793	! Create the znl group from the opa group
794	CALL MPI_GROUP_INCL ( ngrp_opa, ndim_rank_znl, nrank_znl, ngrp_znl, ierr )
795	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_znl ', ngrp_znl
796	!-$$ CALL flush(numout)
797
798	! Create the znl communicator from the opa communicator, ie the pool of procs in the same row
799	CALL MPI_COMM_CREATE ( mpi_comm_oce, ngrp_znl, ncomm_znl, ierr )
800	!-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ncomm_znl ', ncomm_znl
801	!-$$ CALL flush(numout)
802	!
803	END IF
804
805	! Determines if processor if the first (starting from i=1) on the row
806	IF ( jpni == 1 ) THEN
807	l_znl_root = .TRUE.
808	ELSE
809	l_znl_root = .FALSE.
810	kwork (1) = nimpp
811	CALL mpp_min ( 'lib_mpp', kwork(1), kcom = ncomm_znl)
812	IF ( nimpp == kwork(1)) l_znl_root = .TRUE.
813	END IF
814
815	DEALLOCATE(kwork)
816	#endif
817
818	END SUBROUTINE mpp_ini_znl
819
820
821	SUBROUTINE mpp_ini_north
822	!!----------------------------------------------------------------------
823	!! * routine mpp_ini_north *
824	!!
825	!! ** Purpose : Initialize special communicator for north folding
826	!! condition together with global variables needed in the mpp folding
827	!!
828	!! ** Method : - Look for northern processors
829	!! - Put their number in nrank_north
830	!! - Create groups for the world processors and the north processors
831	!! - Create a communicator for northern processors
832	!!
833	!! ** output
834	!! njmppmax = njmpp for northern procs
835	!! ndim_rank_north = number of processors in the northern line
836	!! nrank_north (ndim_rank_north) = number of the northern procs.
837	!! ngrp_world = group ID for the world processors
838	!! ngrp_north = group ID for the northern processors
839	!! ncomm_north = communicator for the northern procs.
840	!! north_root = number (in the world) of proc 0 in the northern comm.
841	!!
842	!!----------------------------------------------------------------------
843	INTEGER :: ierr
844	INTEGER :: jjproc
845	INTEGER :: ii, ji
846	!!----------------------------------------------------------------------
847	!
848	#if defined key_mpp_mpi
849	njmppmax = MAXVAL( njmppt )
850	!
851	! Look for how many procs on the northern boundary
852	ndim_rank_north = 0
853	DO jjproc = 1, jpnij
854	IF( njmppt(jjproc) == njmppmax ) ndim_rank_north = ndim_rank_north + 1
855	END DO
856	!
857	! Allocate the right size to nrank_north
858	IF (ALLOCATED (nrank_north)) DEALLOCATE(nrank_north)
859	ALLOCATE( nrank_north(ndim_rank_north) )
860
861	! Fill the nrank_north array with proc. number of northern procs.
862	! Note : the rank start at 0 in MPI
863	ii = 0
864	DO ji = 1, jpnij
865	IF ( njmppt(ji) == njmppmax ) THEN
866	ii=ii+1
867	nrank_north(ii)=ji-1
868	END IF
869	END DO
870	!
871	! create the world group
872	CALL MPI_COMM_GROUP( mpi_comm_oce, ngrp_world, ierr )
873	!
874	! Create the North group from the world group
875	CALL MPI_GROUP_INCL( ngrp_world, ndim_rank_north, nrank_north, ngrp_north, ierr )
876	!
877	! Create the North communicator , ie the pool of procs in the north group
878	CALL MPI_COMM_CREATE( mpi_comm_oce, ngrp_north, ncomm_north, ierr )
879	!
880	#endif
881	END SUBROUTINE mpp_ini_north
882
883
884	SUBROUTINE DDPDD_MPI( ydda, yddb, ilen, itype )
885	!!---------------------------------------------------------------------
886	!! Routine DDPDD_MPI: used by reduction operator MPI_SUMDD
887	!!
888	!! Modification of original codes written by David H. Bailey
889	!! This subroutine computes yddb(i) = ydda(i)+yddb(i)
890	!!---------------------------------------------------------------------
891	INTEGER , INTENT(in) :: ilen, itype
892	COMPLEX(wp), DIMENSION(ilen), INTENT(in) :: ydda
893	COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb
894	!
895	REAL(wp) :: zerr, zt1, zt2 ! local work variables
896	INTEGER :: ji, ztmp ! local scalar
897	!!---------------------------------------------------------------------
898	!
899	ztmp = itype ! avoid compilation warning
900	!
901	DO ji=1,ilen
902	! Compute ydda + yddb using Knuth's trick.
903	zt1 = real(ydda(ji)) + real(yddb(ji))
904	zerr = zt1 - real(ydda(ji))
905	zt2 = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) &
906	+ aimag(ydda(ji)) + aimag(yddb(ji))
907
908	! The result is zt1 + zt2, after normalization.
909	yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp )
910	END DO
911	!
912	END SUBROUTINE DDPDD_MPI
913
914
915	SUBROUTINE mpp_report( cdname, kpk, kpl, kpf, ld_lbc, ld_glb, ld_dlg )
916	!!----------------------------------------------------------------------
917	!! * routine mpp_report *
918	!!
919	!! ** Purpose : report use of mpp routines per time-setp
920	!!
921	!!----------------------------------------------------------------------
922	CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine
923	INTEGER , OPTIONAL, INTENT(in ) :: kpk, kpl, kpf
924	LOGICAL , OPTIONAL, INTENT(in ) :: ld_lbc, ld_glb, ld_dlg
925	!!
926	CHARACTER(len=128) :: ccountname ! name of a subroutine to count communications
927	LOGICAL :: ll_lbc, ll_glb, ll_dlg
928	INTEGER :: ji, jj, jk, jh, jf, jcount ! dummy loop indices
929	!!----------------------------------------------------------------------
930	#if defined key_mpp_mpi
931	!
932	ll_lbc = .FALSE.
933	IF( PRESENT(ld_lbc) ) ll_lbc = ld_lbc
934	ll_glb = .FALSE.
935	IF( PRESENT(ld_glb) ) ll_glb = ld_glb
936	ll_dlg = .FALSE.
937	IF( PRESENT(ld_dlg) ) ll_dlg = ld_dlg
938	!
939	! find the smallest common frequency: default = frequency product, if multiple, choose the larger of the 2 frequency
940	IF( ncom_dttrc /= 1 ) CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' )
941	ncom_freq = ncom_fsbc
942	!
943	IF ( ncom_stp == nit000+ncom_freq ) THEN ! avoid to count extra communications in potential initializations at nit000
944	IF( ll_lbc ) THEN
945	IF( .NOT. ALLOCATED(ncomm_sequence) ) ALLOCATE( ncomm_sequence(ncom_rec_max,2) )
946	IF( .NOT. ALLOCATED( crname_lbc) ) ALLOCATE( crname_lbc(ncom_rec_max ) )
947	n_sequence_lbc = n_sequence_lbc + 1
948	IF( n_sequence_lbc > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
949	crname_lbc(n_sequence_lbc) = cdname ! keep the name of the calling routine
950	ncomm_sequence(n_sequence_lbc,1) = kpk*kpl ! size of 3rd and 4th dimensions
951	ncomm_sequence(n_sequence_lbc,2) = kpf ! number of arrays to be treated (multi)
952	ENDIF
953	IF( ll_glb ) THEN
954	IF( .NOT. ALLOCATED(crname_glb) ) ALLOCATE( crname_glb(ncom_rec_max) )
955	n_sequence_glb = n_sequence_glb + 1
956	IF( n_sequence_glb > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
957	crname_glb(n_sequence_glb) = cdname ! keep the name of the calling routine
958	ENDIF
959	IF( ll_dlg ) THEN
960	IF( .NOT. ALLOCATED(crname_dlg) ) ALLOCATE( crname_dlg(ncom_rec_max) )
961	n_sequence_dlg = n_sequence_dlg + 1
962	IF( n_sequence_dlg > ncom_rec_max ) CALL ctl_stop( 'STOP', 'lib_mpp, increase ncom_rec_max' ) ! deadlock
963	crname_dlg(n_sequence_dlg) = cdname ! keep the name of the calling routine
964	ENDIF
965	ELSE IF ( ncom_stp == nit000+2*ncom_freq ) THEN
966	CALL ctl_opn( numcom, 'communication_report.txt', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea )
967	WRITE(numcom,*) ' '
968	WRITE(numcom,*) ' ------------------------------------------------------------'
969	WRITE(numcom,*) ' Communication pattern report (second oce+sbc+top time step):'
970	WRITE(numcom,*) ' ------------------------------------------------------------'
971	WRITE(numcom,*) ' '
972	WRITE(numcom,'(A,I4)') ' Exchanged halos : ', n_sequence_lbc
973	jj = 0; jk = 0; jf = 0; jh = 0
974	DO ji = 1, n_sequence_lbc
975	IF ( ncomm_sequence(ji,1) .GT. 1 ) jk = jk + 1
976	IF ( ncomm_sequence(ji,2) .GT. 1 ) jf = jf + 1
977	IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
978	jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
979	END DO
980	WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
981	WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
982	WRITE(numcom,'(A,I3)') ' from which 3D : ', jj
983	WRITE(numcom,'(A,I10)') ' Array max size : ', jhjpijpj
984	WRITE(numcom,*) ' '
985	WRITE(numcom,*) ' lbc_lnk called'
986	DO ji = 1, n_sequence_lbc - 1
987	IF ( crname_lbc(ji) /= 'already counted' ) THEN
988	ccountname = crname_lbc(ji)
989	crname_lbc(ji) = 'already counted'
990	jcount = 1
991	DO jj = ji + 1, n_sequence_lbc
992	IF ( ccountname == crname_lbc(jj) ) THEN
993	jcount = jcount + 1
994	crname_lbc(jj) = 'already counted'
995	END IF
996	END DO
997	WRITE(numcom,'(A, I4, A, A)') ' - ', jcount,' times by subroutine ', TRIM(ccountname)
998	END IF
999	END DO
1000	IF ( crname_lbc(n_sequence_lbc) /= 'already counted' ) THEN
1001	WRITE(numcom,'(A, I4, A, A)') ' - ', 1,' times by subroutine ', TRIM(crname_lbc(ncom_rec_max))
1002	END IF
1003	WRITE(numcom,*) ' '
1004	IF ( n_sequence_glb > 0 ) THEN
1005	WRITE(numcom,'(A,I4)') ' Global communications : ', n_sequence_glb
1006	jj = 1
1007	DO ji = 2, n_sequence_glb
1008	IF( crname_glb(ji-1) /= crname_glb(ji) ) THEN
1009	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(ji-1))
1010	jj = 0
1011	END IF
1012	jj = jj + 1
1013	END DO
1014	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_glb(n_sequence_glb))
1015	DEALLOCATE(crname_glb)
1016	ELSE
1017	WRITE(numcom,*) ' No MPI global communication '
1018	ENDIF
1019	WRITE(numcom,*) ' '
1020	IF ( n_sequence_dlg > 0 ) THEN
1021	WRITE(numcom,'(A,I4)') ' Delayed global communications : ', n_sequence_dlg
1022	jj = 1
1023	DO ji = 2, n_sequence_dlg
1024	IF( crname_dlg(ji-1) /= crname_dlg(ji) ) THEN
1025	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(ji-1))
1026	jj = 0
1027	END IF
1028	jj = jj + 1
1029	END DO
1030	WRITE(numcom,'(A, I4, A, A)') ' - ', jj,' times by subroutine ', TRIM(crname_dlg(n_sequence_dlg))
1031	DEALLOCATE(crname_dlg)
1032	ELSE
1033	WRITE(numcom,*) ' No MPI delayed global communication '
1034	ENDIF
1035	WRITE(numcom,*) ' '
1036	WRITE(numcom,*) ' -----------------------------------------------'
1037	WRITE(numcom,*) ' '
1038	DEALLOCATE(ncomm_sequence)
1039	DEALLOCATE(crname_lbc)
1040	ENDIF
1041	#endif
1042	END SUBROUTINE mpp_report
1043
1044
1045	SUBROUTINE tic_tac (ld_tic, ld_global)
1046
1047	LOGICAL, INTENT(IN) :: ld_tic
1048	LOGICAL, OPTIONAL, INTENT(IN) :: ld_global
1049	REAL(wp), DIMENSION(2), SAVE :: tic_wt
1050	REAL(wp), SAVE :: tic_ct = 0._wp
1051	INTEGER :: ii
1052	#if defined key_mpp_mpi
1053
1054	IF( ncom_stp <= nit000 ) RETURN
1055	IF( ncom_stp == nitend ) RETURN
1056	ii = 1
1057	IF( PRESENT( ld_global ) ) THEN
1058	IF( ld_global ) ii = 2
1059	END IF
1060
1061	IF ( ld_tic ) THEN
1062	tic_wt(ii) = MPI_Wtime() ! start count tic->tac (waiting time)
1063	IF ( tic_ct > 0.0_wp ) compute_time = compute_time + MPI_Wtime() - tic_ct ! cumulate count tac->tic
1064	ELSE
1065	waiting_time(ii) = waiting_time(ii) + MPI_Wtime() - tic_wt(ii) ! cumulate count tic->tac
1066	tic_ct = MPI_Wtime() ! start count tac->tic (waiting time)
1067	ENDIF
1068	#endif
1069
1070	END SUBROUTINE tic_tac
1071
1072	#if ! defined key_mpp_mpi
1073	SUBROUTINE mpi_wait(request, status, ierror)
1074	INTEGER , INTENT(in ) :: request
1075	INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status
1076	INTEGER , INTENT( out) :: ierror
1077	END SUBROUTINE mpi_wait
1078
1079
1080	FUNCTION MPI_Wtime()
1081	REAL(wp) :: MPI_Wtime
1082	MPI_Wtime = -1.
1083	END FUNCTION MPI_Wtime
1084	#endif
1085
1086	!!----------------------------------------------------------------------
1087	!! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam routines
1088	!!----------------------------------------------------------------------
1089
1090	SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5 , &
1091	& cd6, cd7, cd8, cd9, cd10 )
1092	!!----------------------------------------------------------------------
1093	!! * ROUTINE stop_opa *
1094	!!
1095	!! ** Purpose : print in ocean.outpput file a error message and
1096	!! increment the error number (nstop) by one.
1097	!!----------------------------------------------------------------------
1098	CHARACTER(len=*), INTENT(in ) :: cd1
1099	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd2, cd3, cd4, cd5
1100	CHARACTER(len=*), INTENT(in ), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1101	!
1102	INTEGER :: inum
1103	!!----------------------------------------------------------------------
1104	!
1105	nstop = nstop + 1
1106	!
1107	IF( cd1 == 'STOP' .AND. narea /= 1 ) THEN ! Immediate stop: add an arror message in 'ocean.output' file
1108	CALL ctl_opn( inum, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. )
1109	WRITE(inum,*)
1110	WRITE(inum,) ' ==>>> Look for "E R R O R" messages in all existing ocean.output* files'
1111	CLOSE(inum)
1112	ENDIF
1113	IF( numout == 6 ) THEN ! force to open ocean.output file if not already opened
1114	CALL ctl_opn( numout, 'ocean.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE., narea )
1115	ENDIF
1116	!
1117	WRITE(numout,*)
1118	WRITE(numout,*) ' ===>>> : E R R O R'
1119	WRITE(numout,*)
1120	WRITE(numout,*) ' ==========='
1121	WRITE(numout,*)
1122	WRITE(numout,*) TRIM(cd1)
1123	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1124	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1125	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1126	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1127	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1128	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1129	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1130	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1131	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1132	WRITE(numout,*)
1133	!
1134	CALL FLUSH(numout )
1135	IF( numstp /= -1 ) CALL FLUSH(numstp )
1136	IF( numrun /= -1 ) CALL FLUSH(numrun )
1137	IF( numevo_ice /= -1 ) CALL FLUSH(numevo_ice)
1138	!
1139	IF( cd1 == 'STOP' ) THEN
1140	WRITE(numout,*)
1141	WRITE(numout,*) 'huge E-R-R-O-R : immediate stop'
1142	WRITE(numout,*)
1143	CALL FLUSH(numout)
1144	CALL SLEEP(60) ! make sure that all output and abort files are written by all cores. 60s should be enough...
1145	CALL mppstop( ld_abort = .true. )
1146	ENDIF
1147	!
1148	END SUBROUTINE ctl_stop
1149
1150
1151	SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5, &
1152	& cd6, cd7, cd8, cd9, cd10 )
1153	!!----------------------------------------------------------------------
1154	!! * ROUTINE stop_warn *
1155	!!
1156	!! ** Purpose : print in ocean.outpput file a error message and
1157	!! increment the warning number (nwarn) by one.
1158	!!----------------------------------------------------------------------
1159	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd1, cd2, cd3, cd4, cd5
1160	CHARACTER(len=*), INTENT(in), OPTIONAL :: cd6, cd7, cd8, cd9, cd10
1161	!!----------------------------------------------------------------------
1162	!
1163	nwarn = nwarn + 1
1164	!
1165	IF(lwp) THEN
1166	WRITE(numout,*)
1167	WRITE(numout,*) ' ===>>> : W A R N I N G'
1168	WRITE(numout,*)
1169	WRITE(numout,*) ' ==============='
1170	WRITE(numout,*)
1171	IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1)
1172	IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2)
1173	IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3)
1174	IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4)
1175	IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5)
1176	IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6)
1177	IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7)
1178	IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8)
1179	IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9)
1180	IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10)
1181	WRITE(numout,*)
1182	ENDIF
1183	CALL FLUSH(numout)
1184	!
1185	END SUBROUTINE ctl_warn
1186
1187
1188	SUBROUTINE ctl_opn( knum, cdfile, cdstat, cdform, cdacce, klengh, kout, ldwp, karea )
1189	!!----------------------------------------------------------------------
1190	!! * ROUTINE ctl_opn *
1191	!!
1192	!! ** Purpose : Open file and check if required file is available.
1193	!!
1194	!! ** Method : Fortan open
1195	!!----------------------------------------------------------------------
1196	INTEGER , INTENT( out) :: knum ! logical unit to open
1197	CHARACTER(len=*) , INTENT(in ) :: cdfile ! file name to open
1198	CHARACTER(len=*) , INTENT(in ) :: cdstat ! disposition specifier
1199	CHARACTER(len=*) , INTENT(in ) :: cdform ! formatting specifier
1200	CHARACTER(len=*) , INTENT(in ) :: cdacce ! access specifier
1201	INTEGER , INTENT(in ) :: klengh ! record length
1202	INTEGER , INTENT(in ) :: kout ! number of logical units for write
1203	LOGICAL , INTENT(in ) :: ldwp ! boolean term for print
1204	INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number
1205	!
1206	CHARACTER(len=80) :: clfile
1207	CHARACTER(LEN=10) :: clfmt ! writing format
1208	INTEGER :: iost
1209	INTEGER :: idg ! number of digits
1210	!!----------------------------------------------------------------------
1211	!
1212	! adapt filename
1213	! ----------------
1214	clfile = TRIM(cdfile)
1215	IF( PRESENT( karea ) ) THEN
1216	IF( karea > 1 ) THEN
1217	! Warning: jpnij is maybe not already defined when calling ctl_opn -> use mppsize instead of jpnij
1218	idg = MAX( INT(LOG10(REAL(MAX(1,mppsize-1),wp))) + 1, 4 ) ! how many digits to we need to write? min=4, max=9
1219	WRITE(clfmt, "('(a,a,i', i1, '.', i1, ')')") idg, idg ! '(a,a,ix.x)'
1220	WRITE(clfile, clfmt) TRIM(clfile), '_', karea-1
1221	ENDIF
1222	ENDIF
1223	#if defined key_agrif
1224	IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile)
1225	knum=Agrif_Get_Unit()
1226	#else
1227	knum=get_unit()
1228	#endif
1229	IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null
1230	!
1231	IF( cdacce(1:6) == 'DIRECT' ) THEN ! cdacce has always more than 6 characters
1232	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost )
1233	ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters
1234	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS='UNKNOWN', POSITION='APPEND', ERR=100, IOSTAT=iost )
1235	ELSE
1236	OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1237	ENDIF
1238	IF( iost /= 0 .AND. TRIM(clfile) == '/dev/null' ) & ! for windows
1239	& OPEN(UNIT=knum,FILE='NUL', FORM=cdform, ACCESS=cdacce, STATUS=cdstat , ERR=100, IOSTAT=iost )
1240	IF( iost == 0 ) THEN
1241	IF(ldwp .AND. kout > 0) THEN
1242	WRITE(kout,*) ' file : ', TRIM(clfile),' open ok'
1243	WRITE(kout,*) ' unit = ', knum
1244	WRITE(kout,*) ' status = ', cdstat
1245	WRITE(kout,*) ' form = ', cdform
1246	WRITE(kout,*) ' access = ', cdacce
1247	WRITE(kout,*)
1248	ENDIF
1249	ENDIF
1250	100 CONTINUE
1251	IF( iost /= 0 ) THEN
1252	WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile)
1253	WRITE(ctmp2,*) ' ======= === '
1254	WRITE(ctmp3,*) ' unit = ', knum
1255	WRITE(ctmp4,*) ' status = ', cdstat
1256	WRITE(ctmp5,*) ' form = ', cdform
1257	WRITE(ctmp6,*) ' access = ', cdacce
1258	WRITE(ctmp7,*) ' iostat = ', iost
1259	WRITE(ctmp8,*) ' we stop. verify the file '
1260	CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 )
1261	ENDIF
1262	!
1263	END SUBROUTINE ctl_opn
1264
1265
1266	SUBROUTINE ctl_nam ( kios, cdnam )
1267	!!----------------------------------------------------------------------
1268	!! * ROUTINE ctl_nam *
1269	!!
1270	!! ** Purpose : Informations when error while reading a namelist
1271	!!
1272	!! ** Method : Fortan open
1273	!!----------------------------------------------------------------------
1274	INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist
1275	CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs
1276	!
1277	CHARACTER(len=5) :: clios ! string to convert iostat in character for print
1278	!!----------------------------------------------------------------------
1279	!
1280	WRITE (clios, '(I5.0)') kios
1281	IF( kios < 0 ) THEN
1282	CALL ctl_warn( 'end of record or file while reading namelist ' &
1283	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1284	ENDIF
1285	!
1286	IF( kios > 0 ) THEN
1287	CALL ctl_stop( 'misspelled variable in namelist ' &
1288	& // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )
1289	ENDIF
1290	kios = 0
1291	!
1292	END SUBROUTINE ctl_nam
1293
1294
1295	INTEGER FUNCTION get_unit()
1296	!!----------------------------------------------------------------------
1297	!! * FUNCTION get_unit *
1298	!!
1299	!! ** Purpose : return the index of an unused logical unit
1300	!!----------------------------------------------------------------------
1301	LOGICAL :: llopn
1302	!!----------------------------------------------------------------------
1303	!
1304	get_unit = 15 ! choose a unit that is big enough then it is not already used in NEMO
1305	llopn = .TRUE.
1306	DO WHILE( (get_unit < 998) .AND. llopn )
1307	get_unit = get_unit + 1
1308	INQUIRE( unit = get_unit, opened = llopn )
1309	END DO
1310	IF( (get_unit == 999) .AND. llopn ) THEN
1311	CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' )
1312	ENDIF
1313	!
1314	END FUNCTION get_unit
1315
1316	!!----------------------------------------------------------------------
1317	END MODULE lib_mpp

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

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

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.4_GO8_paquage_branch/src/OCE/LBC/lib_mpp.F90

Download in other formats: