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

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

lib_mpp.F90 in NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90 @ 11317

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

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

Download in other formats: