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_r11943_MERGE_2019/src/OCE/LBC – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/LBC/lib_mpp.F90 @ 11949

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

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

Download in other formats: