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 @ 15204

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

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

Download in other formats: