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

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

lib_mpp.F90 in NEMO/branches/UKMO/NEMO_4.0.1_NGMS_couple_stage2_spmd/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.1_NGMS_couple_stage2_spmd/src/OCE/LBC/lib_mpp.F90 @ 15205

Last change on this file since 15205 was 15205, checked in by vsmart, 3 years ago
Make new subroutine public
File size: 57.5 KB

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

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

Download in other formats: