Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lib_mpp.F90 @ 13311

Last change on this file since 13311 was 13311, checked in by frrh, 4 years ago
Save dev changes for concurrent LFRIC + GO8 running
File size: 56.8 KB

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

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

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

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.1_NGMS_couple_pkg/src/OCE/LBC/lib_mpp.F90 @ 13311

Download in other formats: