Context Navigation

lib_mpp.F90 @ 12803

Last change on this file since 12803 was 12803, checked in by dancopsey, 4 years ago
Merge in NEMO_4.0.1_GC_couple_pkg
File size: 56.6 KB

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

Download in other formats: