Context Navigation

mpi_mod.f90 @ cd85138

10.4.1_peseiGFS_025bugfixes+enhancementsdevrelease-10release-10.4.1scaling-bugunivie

Last change on this file since cd85138 was 8a65cb0, checked in by Espen Sollum ATMOS <espen@…>, 9 years ago
Added code, makefile for dev branch
Property mode set to `100755`
File size: 72.2 KB

Line
1	!**********************************************************************
2	! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
3	! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
4	! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
5	! *
6	! This file is part of FLEXPART. *
7	! *
8	! FLEXPART is free software: you can redistribute it and/or modify *
9	! it under the terms of the GNU General Public License as published by*
10	! the Free Software Foundation, either version 3 of the License, or *
11	! (at your option) any later version. *
12	! *
13	! FLEXPART is distributed in the hope that it will be useful, *
14	! but WITHOUT ANY WARRANTY; without even the implied warranty of *
15	! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
16	! GNU General Public License for more details. *
17	! *
18	! You should have received a copy of the GNU General Public License *
19	! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
20	!**********************************************************************
21
22	module mpi_mod
23
24	!*****************************************************************************
25	! *
26	! DESCRIPTION *
27	! This module contains subroutines and common variables used for the *
28	! MPI parallelization of FLEXPART. *
29	! *
30	! NOTE *
31	! Depending on the MPI library installed on your system (e.g. mpich2, *
32	! OpenMPI) you may need to choose below in this file between *
33	! use mpi *
34	! (if the MPI library comes with the file 'mpi.mod'); or *
35	! include 'mpif.h' *
36	! *
37	! *
38	!*****************************************************************************
39	! *
40	! Variables: *
41	! *
42	! mp_ierr MPI error code *
43	! mp_np Number of MPI processes *
44	! mp_pid Process ID of each MPI process *
45	! mp_seed Parameter for random number seed *
46	! numpart_mpi, Number of particles per node *
47	! maxpart_mpi *
48	! mp_partid MPI process ID for particle calculation *
49	! mp_partgroup_ Refers to the subset of processors performing *
50	! loops over particles. Will be all processes *
51	! unless a dedicated process runs getfields/readwind *
52	! *
53	! *
54	! *
55	! *
56	! *
57	!*****************************************************************************
58
59	use mpi
60	use par_mod, only: dp, sp
61	use com_mod, only: lroot
62
63	implicit none
64
65	! include 'mpif.h'
66
67	public
68
69	! Set aside a process for reading windfields if using at least these many processes
70	!==================================================
71	integer, parameter, private :: read_grp_min=99
72	!==================================================
73
74	! Variables for each MPI process in the world group
75	integer :: mp_ierr, mp_np, mp_pid, mp_partid
76	integer, private :: world_group_id
77
78	! Variables for MPI processes in the 'particle' group
79	integer, allocatable, dimension(:) :: mp_partgroup_rank
80	integer :: mp_partgroup_comm, mp_partgroup_pid, mp_partgroup_np
81
82	integer :: mp_seed=0
83	integer, parameter :: mp_sp=MPI_REAL4, mp_dp=MPI_REAL8
84	integer, parameter :: mp_pp=mp_sp
85	integer, parameter :: id_root=0 ! master process
86
87	! MPI tags/requests for send/receive operation
88	integer :: tm1!=100
89	integer, parameter :: nvar_async=27
90	!integer, dimension(:), allocatable :: tags
91	integer, dimension(:), allocatable :: reqs
92
93
94	integer :: id_read ! readwind/getfield process
95	integer :: numpart_mpi,maxpart_mpi ! number of particles per node
96	integer :: tot_numpart=0
97	integer :: mp_comm_used ! global or subgroup communicator
98
99	logical :: lmpreader=.false. ! is set to true for reading process(es) only.
100	logical :: lmp_use_reader=.false. ! true if separate readwind process is used
101
102	! true if only using synchronous MPI send/recv:
103	! If setting this to .false., numwfmem must be set to 3
104	!===============================================================================
105	logical :: lmp_sync=.true.
106	!===============================================================================
107
108	! mp_dbg_mode MPI related output for debugging etc.
109	! mp_dev_mode various checks related to debugging the parallel code
110	! mp_dbg_out write some arrays to data file for debugging
111	! mp_measure_time Measure cpu/wall time, write out at end of run
112	! mp_time_barrier Measure MPI barrier time
113	logical, parameter :: mp_dbg_mode = .false.
114	logical, parameter :: mp_dev_mode = .false.
115	logical, parameter :: mp_dbg_out = .false.
116	logical, parameter :: mp_time_barrier=.true.
117	logical, parameter :: mp_measure_time=.true.
118
119	! for measuring CPU/Wall time
120	real(sp) :: mp_comm_time_beg, mp_comm_time_end, mp_comm_time_total=0.
121	real(dp) :: mp_comm_wtime_beg, mp_comm_wtime_end, mp_comm_wtime_total=0.
122	real(sp) :: mp_root_time_beg, mp_root_time_end, mp_root_time_total=0.
123	real(dp) :: mp_root_wtime_beg, mp_root_wtime_end, mp_root_wtime_total=0.
124	real(sp) :: mp_barrier_time_beg, mp_barrier_time_end, mp_barrier_time_total=0.
125	real(dp) :: mp_barrier_wtime_beg, mp_barrier_wtime_end, mp_barrier_wtime_total=0.
126	real(sp) :: tm_nploop_beg, tm_nploop_end, tm_nploop_total=0.
127	real(sp) :: tm_tot_beg, tm_tot_end, tm_tot_total=0.
128	real(dp) :: mp_getfields_wtime_beg, mp_getfields_wtime_end, mp_getfields_wtime_total=0.
129	real(sp) :: mp_getfields_time_beg, mp_getfields_time_end, mp_getfields_time_total=0.
130	real(dp) :: mp_readwind_wtime_beg, mp_readwind_wtime_end, mp_readwind_wtime_total=0.
131	real(sp) :: mp_readwind_time_beg, mp_readwind_time_end, mp_readwind_time_total=0.
132	real(dp) :: mp_io_wtime_beg, mp_io_wtime_end, mp_io_wtime_total=0.
133	real(sp) :: mp_io_time_beg, mp_io_time_end, mp_io_time_total=0.
134	real(dp) :: mp_wetdepo_wtime_beg, mp_wetdepo_wtime_end, mp_wetdepo_wtime_total=0.
135	real(sp) :: mp_wetdepo_time_beg, mp_wetdepo_time_end, mp_wetdepo_time_total=0.
136	real(dp) :: mp_advance_wtime_beg, mp_advance_wtime_end, mp_advance_wtime_total=0.
137	real(dp) :: mp_conccalc_time_beg, mp_conccalc_time_end, mp_conccalc_time_total=0.
138	real(dp) :: mp_total_wtime_beg, mp_total_wtime_end, mp_total_wtime_total=0.
139
140	! dat_lun logical unit number for i/o
141	integer, private :: dat_lun
142
143	contains
144
145	subroutine mpif_init
146	!***********************************************************************
147	! DESCRIPTION
148	! Initialize MPI.
149	!
150	! Create the global communicator MPI_COMM_WORLD
151	! If using a separate MPI process for getfields/readwind, a subgroup
152	! is created for the other processes.
153	!
154	! VARIABLES
155	! mpi_mode default 0, set to 2/3 if running MPI version
156	! mp_np number of running processes, decided at run-time
157	!***********************************************************************
158	use par_mod, only: maxpart, numwfmem
159	use com_mod, only: mpi_mode
160
161	implicit none
162
163	integer :: i,j,s,addmaxpart=0
164
165	! each process gets an ID (mp_pid) in the range 0,..,mp_np-1
166	call MPI_INIT(mp_ierr)
167	if (mp_ierr /= 0) goto 100
168	call MPI_COMM_RANK(MPI_COMM_WORLD, mp_pid, mp_ierr)
169	if (mp_ierr /= 0) goto 100
170	call MPI_COMM_SIZE(MPI_COMM_WORLD, mp_np, mp_ierr)
171	if (mp_ierr /= 0) goto 100
172
173
174	! this variable is used to handle subroutines common to parallel/serial version
175	if (lmp_sync) then
176	mpi_mode=2 ! hold 2 windfields in memory
177	else
178	mpi_mode=3 ! hold 3 windfields in memory
179	end if
180
181	if (mp_pid.ne.0) then
182	lroot = .false.
183	end if
184
185	! Check for sensible combination of parameters
186	!*********************************************
187
188	if (.not.lmp_sync.and.numwfmem.ne.3.and.lroot) then
189	write(*,FMT='(80("#"))')
190	write(,) '#### mpi_mod::mpif_init> ERROR: ', &
191	& 'numwfmem must be set to 3 for asyncronous reading ####'
192	write(*,FMT='(80("#"))')
193	stop
194	else if (lmp_sync.and.numwfmem.ne.2.and.lroot) then
195	write(*,FMT='(80("#"))')
196	write(,) '#### mpi_mod::mpif_init> WARNING: ', &
197	& 'numwfmem should be set to 2 for syncronous reading'
198	write(*,FMT='(80("#"))')
199	end if
200
201	! Set ID of process that calls getfield/readwind.
202	! Using the last process in the group ensures statistical identical results
203	! as running with one process less but not using separate read process
204	!**********************************************************************
205
206	! id_read = min(mp_np-1, 1)
207	id_read = mp_np-1
208
209	if (mp_pid.eq.id_read) lmpreader=.true.
210
211	call MPI_Comm_group (MPI_COMM_WORLD, world_group_id, mp_ierr)
212
213	! Create a MPI group/communiactor that will calculate trajectories.
214	! Skip this step if program is run with only a few processes
215	!************************************************************************
216	allocate(mp_partgroup_rank(0:mp_np-2))
217
218	! This allows checking for allocation of arrays when no subgroup is used
219	mp_partgroup_pid=0
220
221	if (read_grp_min.lt.2) then
222	write(,) '#### mpi_mod::mpif_init> ERROR ####', &
223	& 'read_grp_min should be at least 2. Exiting'
224	stop
225	end if
226
227	if (mp_np.ge.read_grp_min) then
228	lmp_use_reader = .true.
229
230	! Map the subgroup IDs= 0,1,2,...,mp_np-2, skipping 'readwind' process
231	j=-1
232	do i=0, mp_np-2 !loop over all (subgroup) IDs
233	j=j+1
234	if (i.eq.id_read) then
235	j=j+1
236	end if
237	mp_partgroup_rank(i) = j
238	end do
239
240	call MPI_Group_incl (world_group_id, mp_np-1, mp_partgroup_rank, &
241	&mp_partgroup_pid, mp_ierr)
242	if (mp_ierr /= 0) goto 100
243	call MPI_Comm_create (MPI_COMM_WORLD, mp_partgroup_pid, mp_partgroup_comm, mp_ierr)
244	if (mp_ierr /= 0) goto 100
245
246	if (mp_pid.ne.id_read) then
247	call MPI_Comm_rank (mp_partgroup_comm, mp_partgroup_pid, mp_ierr)
248	if (mp_ierr /= 0) goto 100
249
250	! Get size of new group (=mp_np-1)
251	call MPI_COMM_SIZE(mp_partgroup_comm, mp_partgroup_np, mp_ierr)
252	if (mp_ierr /= 0) goto 100
253	if (mp_partgroup_np.ne.mp_np-1) then
254	write(,) '#### mpi_mod:: mpif_init> ERROR ####&
255	& mp_partgroup_np.ne.mp_np-1'
256	stop
257	endif
258
259	else
260	mp_partgroup_pid = -1
261	end if
262	end if
263
264	if (lmp_use_reader) then
265	mp_comm_used = mp_partgroup_comm
266	mp_partid = mp_partgroup_pid
267	mp_partgroup_np=mp_np-1
268	else
269	mp_comm_used = MPI_COMM_WORLD
270	mp_partgroup_np = mp_np
271	mp_partid = mp_pid
272	end if
273
274	! Set maxpart per process
275	if (mp_partid.lt.mod(maxpart,mp_partgroup_np)) addmaxpart=1
276	maxpart_mpi=int(maxpart/mp_partgroup_np)+addmaxpart
277
278	! Do not allocate particle data arrays for readwind process
279	if (lmpreader.and.lmp_use_reader) then
280	maxpart_mpi=0
281	end if
282
283	! Set random seed for each non-root process
284	if (mp_pid.gt.0) then
285	! if (mp_pid.ge.0) then
286	! call system_clock(s)
287	s = 244
288	mp_seed = -abs(mod((s181)((mp_pid-83)*359), 104729))
289	end if
290	if (mp_dev_mode) write(,) 'PID, mp_seed: ',mp_pid, mp_seed
291
292	! Allocate request array for asynchronous MPI
293	if (.not.lmp_sync) then
294	allocate(reqs(0:nvar_async*mp_np-1))
295	reqs=MPI_REQUEST_NULL
296	else
297	allocate(reqs(0:1))
298	reqs=MPI_REQUEST_NULL
299	end if
300
301	goto 101
302
303	100 write(,) '#### mpi_mod::mpif_init> ERROR ####', mp_ierr
304	stop
305
306	101 end subroutine mpif_init
307
308
309	subroutine mpif_mpi_barrier
310	!***********************************************************************
311	! Set MPI barrier (all processes are synchronized here), with the
312	! possible exception of a separate 'readwind' process.
313	! Optionally measure cpu/wall time.
314	!
315	!***********************************************************************
316	implicit none
317
318	if (mp_time_barrier) then
319	call cpu_time(mp_barrier_time_beg)
320	mp_barrier_wtime_beg = mpi_wtime()
321	endif
322
323	call MPI_BARRIER(mp_comm_used, mp_ierr)
324	if (mp_ierr /= 0) goto 100
325
326	if (mp_time_barrier) then
327	call cpu_time(mp_barrier_time_end)
328	mp_barrier_wtime_end = mpi_wtime()
329
330	mp_barrier_time_total=mp_barrier_time_total+&
331	&(mp_barrier_time_end-mp_barrier_time_beg)
332	mp_barrier_wtime_total=mp_barrier_wtime_total+&
333	&(mp_barrier_wtime_end-mp_barrier_wtime_beg)
334	end if
335
336	goto 101
337
338	100 write(,) '#### mpi_mod::mpif_mpi_barrier> ERROR ####', mp_ierr
339	stop
340
341	101 end subroutine mpif_mpi_barrier
342
343
344	subroutine mpif_com_mod_allocate
345	!*******************************************************************************
346	! Dynamic allocation of arrays (in serial code these have size maxpart)
347	!
348	!*******************************************************************************
349	use com_mod
350
351	implicit none
352
353	integer :: array_size
354
355	array_size = maxpart_mpi
356
357	allocate(itra1(array_size),npoint(array_size),&
358	& nclass(array_size),idt(array_size),&
359	& itramem(array_size),itrasplit(array_size),&
360	& xtra1(array_size),ytra1(array_size),&
361	& ztra1(array_size),xmass1(array_size, maxspec))
362
363	allocate(uap(array_size),ucp(array_size),&
364	& uzp(array_size),us(array_size),&
365	& vs(array_size),&
366	& ws(array_size),cbt(array_size))
367
368
369	end subroutine mpif_com_mod_allocate
370
371
372	subroutine mpif_tm_send_dims
373	!***********************************************************************
374	! Distribute array dimensions from pid0 to all processes.
375	! numpart_mpi/numpart is sent to allow dynamic allocation
376	!
377	! Currently not in use.
378	!
379	! Variables of similar type (integer, real) are placed in an array
380	! and sent collectively, to avoid the overhead associated with individual
381	! MPI send/receives
382	!
383	!
384	!***********************************************************************
385	use com_mod
386
387	implicit none
388
389	integer :: add_part=0
390
391	call MPI_BCAST(numpart, 1, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
392
393	! MPI subgroup does the particle-loop
394	if (lmp_use_reader) then
395	if (mod(numpart,mp_partgroup_np).ne.0) add_part=1
396	numpart_mpi=int(numpart/mp_partgroup_np)+add_part
397	else
398	if (mod(numpart,mp_np).ne.0) add_part=1
399	numpart_mpi=int(numpart/mp_np)+add_part
400	end if
401
402
403
404	! redefine numpart as 'numpart per process' throughout the code
405	!**************************************************************
406	numpart = numpart_mpi
407
408	end subroutine mpif_tm_send_dims
409
410
411	subroutine mpif_tm_send_vars
412	!***********************************************************************
413	! Distribute particle variables from pid0 to all processes.
414	! Called from timemanager
415	!
416	!
417	!***********************************************************************
418	use com_mod
419
420	implicit none
421
422	integer :: i
423
424
425	!***********************************************************************
426
427
428	! Time for MPI communications
429	!****************************
430	if (mp_measure_time) call mpif_mtime('commtime',0)
431
432	! Distribute variables, send from pid 0 to other processes
433	!**********************************************************************
434
435	! integers
436	if (lroot) then
437	call MPI_SCATTER(npoint,numpart_mpi,MPI_INTEGER,MPI_IN_PLACE,&
438	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
439	if (mp_ierr /= 0) goto 600
440	call MPI_SCATTER(idt,numpart_mpi,MPI_INTEGER,MPI_IN_PLACE,&
441	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
442	if (mp_ierr /= 0) goto 600
443	call MPI_SCATTER(itra1,numpart_mpi,MPI_INTEGER,MPI_IN_PLACE,&
444	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
445	if (mp_ierr /= 0) goto 600
446	call MPI_SCATTER(nclass,numpart_mpi,MPI_INTEGER,MPI_IN_PLACE,&
447	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
448	if (mp_ierr /= 0) goto 600
449	call MPI_SCATTER(itramem,numpart_mpi,MPI_INTEGER,MPI_IN_PLACE,&
450	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
451	if (mp_ierr /= 0) goto 600
452
453	! int2
454	call MPI_SCATTER(cbt,numpart_mpi,MPI_INTEGER2,MPI_IN_PLACE,&
455	&numpart_mpi,MPI_INTEGER2,id_root,mp_comm_used,mp_ierr)
456	if (mp_ierr /= 0) goto 600
457
458	! real
459	call MPI_SCATTER(uap,numpart_mpi,mp_pp,MPI_IN_PLACE,&
460	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
461	if (mp_ierr /= 0) goto 600
462	call MPI_SCATTER(ucp,numpart_mpi,mp_pp,MPI_IN_PLACE,&
463	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
464	if (mp_ierr /= 0) goto 600
465	call MPI_SCATTER(uzp,numpart_mpi,mp_pp,MPI_IN_PLACE,&
466	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
467	if (mp_ierr /= 0) goto 600
468
469	call MPI_SCATTER(us,numpart_mpi,mp_pp,MPI_IN_PLACE,&
470	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
471	if (mp_ierr /= 0) goto 600
472	call MPI_SCATTER(vs,numpart_mpi,mp_pp,MPI_IN_PLACE,&
473	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
474	if (mp_ierr /= 0) goto 600
475	call MPI_SCATTER(ws,numpart_mpi,mp_pp,MPI_IN_PLACE,&
476	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
477	if (mp_ierr /= 0) goto 600
478
479	call MPI_SCATTER(xtra1,numpart_mpi,mp_dp,MPI_IN_PLACE,&
480	&numpart_mpi,mp_dp,id_root,mp_comm_used,mp_ierr)
481	if (mp_ierr /= 0) goto 600
482	call MPI_SCATTER(ytra1,numpart_mpi,mp_dp,MPI_IN_PLACE,&
483	&numpart_mpi,mp_dp,id_root,mp_comm_used,mp_ierr)
484	if (mp_ierr /= 0) goto 600
485	call MPI_SCATTER(ztra1,numpart_mpi,mp_pp,MPI_IN_PLACE,&
486	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
487	if (mp_ierr /= 0) goto 600
488
489	do i=1,nspec
490	call MPI_SCATTER(xmass1(:,i),numpart_mpi,mp_pp,MPI_IN_PLACE,&
491	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
492	if (mp_ierr /= 0) goto 600
493	end do
494
495	else ! (mp_pid >= 1)
496	! integers
497	call MPI_SCATTER(npoint,numpart_mpi,MPI_INTEGER,npoint,&
498	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
499	if (mp_ierr /= 0) goto 600
500	call MPI_SCATTER(idt,numpart_mpi,MPI_INTEGER,idt,&
501	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
502	if (mp_ierr /= 0) goto 600
503	call MPI_SCATTER(itra1,numpart_mpi,MPI_INTEGER,itra1,&
504	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
505	if (mp_ierr /= 0) goto 600
506	call MPI_SCATTER(nclass,numpart_mpi,MPI_INTEGER,nclass,&
507	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
508	if (mp_ierr /= 0) goto 600
509	call MPI_SCATTER(itramem,numpart_mpi,MPI_INTEGER,itramem,&
510	&numpart_mpi,MPI_INTEGER,id_root,mp_comm_used,mp_ierr)
511	if (mp_ierr /= 0) goto 600
512
513	! int2
514	call MPI_SCATTER(cbt,numpart_mpi,MPI_INTEGER2,cbt,&
515	&numpart_mpi,MPI_INTEGER2,id_root,mp_comm_used,mp_ierr)
516	if (mp_ierr /= 0) goto 600
517
518	! reals
519	call MPI_SCATTER(uap,numpart_mpi,mp_pp,uap,&
520	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
521	if (mp_ierr /= 0) goto 600
522	call MPI_SCATTER(ucp,numpart_mpi,mp_pp,ucp,&
523	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
524	if (mp_ierr /= 0) goto 600
525	call MPI_SCATTER(uzp,numpart_mpi,mp_pp,uzp,&
526	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
527	if (mp_ierr /= 0) goto 600
528
529	call MPI_SCATTER(us,numpart_mpi,mp_pp,us,&
530	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
531	if (mp_ierr /= 0) goto 600
532	call MPI_SCATTER(vs,numpart_mpi,mp_pp,vs,&
533	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
534	if (mp_ierr /= 0) goto 600
535	call MPI_SCATTER(ws,numpart_mpi,mp_pp,ws,&
536	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
537	if (mp_ierr /= 0) goto 600
538
539	call MPI_SCATTER(xtra1,numpart_mpi,mp_dp,xtra1,&
540	&numpart_mpi,mp_dp,id_root,mp_comm_used,mp_ierr)
541	if (mp_ierr /= 0) goto 600
542	call MPI_SCATTER(ytra1,numpart_mpi,mp_dp,ytra1,&
543	&numpart_mpi,mp_dp,id_root,mp_comm_used,mp_ierr)
544	if (mp_ierr /= 0) goto 600
545	call MPI_SCATTER(ztra1,numpart_mpi,mp_pp,ztra1,&
546	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
547	if (mp_ierr /= 0) goto 600
548
549	do i=1,nspec
550	call MPI_SCATTER(xmass1(:,i),numpart_mpi,mp_pp,xmass1(:,i),&
551	&numpart_mpi,mp_pp,id_root,mp_comm_used,mp_ierr)
552	if (mp_ierr /= 0) goto 600
553	end do
554
555	end if !(lroot)
556
557	if (mp_measure_time) call mpif_mtime('commtime',1)
558
559	goto 601
560
561	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
562	stop
563	601 end subroutine mpif_tm_send_vars
564
565
566	subroutine mpif_tm_collect_vars
567	!*******************************************************************************
568	! Collect particle data to PID 0 from all processes. *
569	! *
570	! This can be called from timemanager_mpi, before caclulating *
571	! concentrations/writing output grids. *
572	! *
573	! Currently not in use, as each process calculates concentrations *
574	! separately. *
575	! *
576	! To use this routine (together with mpif_tm_send_vars) to transfer data *
577	! to the MPI root process (useful for debugging), insert code like this *
578	! (in timemanager_mpi.f90) *
579	! *
580	! if (lroot) tot_numpart=numpart ! root stores total numpart *
581	! call mpif_tm_send_dims *
582	! if (numpart>1) then *
583	! call mpif_tm_send_vars *
584	! end if *
585	! *
586	! To collect data from all processes to root process after a parallel *
587	! region: *
588	! *
589	! if (numpart>0) then *
590	! if (lroot) numpart = tot_numpart *
591	! call mpif_tm_collect_vars *
592	! end if *
593	! *
594	! Then a section that begins with "if (lroot) ..." will behave like *
595	! serial flexpart *
596	! *
597	!*******************************************************************************
598	use com_mod !, only: numpart, nspec, itra1, npoint, nclass
599
600	implicit none
601
602	integer :: i
603
604	logical :: use_mp_vars = .false.! use mp_... type allocated vars
605	logical :: use_in_place = .true.! use MPI_IN_PLACE to collect vars.
606
607
608	! Time for MPI communications
609	if (mp_measure_time) call mpif_mtime('commtime',0)
610
611	! Distribute variables, send from pid 0 to other processes
612	!**********************************************************************
613
614	if (.not. use_mp_vars.and..not.use_in_place) then
615
616	! Integers:
617	call MPI_GATHER(npoint, numpart_mpi, MPI_INTEGER, npoint, &
618	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
619	if (mp_ierr /= 0) goto 600
620	call MPI_GATHER(idt, numpart_mpi, MPI_INTEGER, idt, &
621	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
622	if (mp_ierr /= 0) goto 600
623	call MPI_GATHER(itra1, numpart_mpi, MPI_INTEGER, itra1, &
624	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
625	if (mp_ierr /= 0) goto 600
626	call MPI_GATHER(nclass, numpart_mpi, MPI_INTEGER, nclass, &
627	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
628	if (mp_ierr /= 0) goto 600
629	call MPI_GATHER(itramem, numpart_mpi, MPI_INTEGER, itramem, &
630	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
631	if (mp_ierr /= 0) goto 600
632
633	! int2
634	call MPI_GATHER(cbt, numpart_mpi, MPI_INTEGER2, cbt, &
635	&numpart_mpi, MPI_INTEGER2, id_root, mp_comm_used, mp_ierr)
636	if (mp_ierr /= 0) goto 600
637
638	! Reals:
639	call MPI_GATHER(uap, numpart_mpi, mp_pp, uap, &
640	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
641	if (mp_ierr /= 0) goto 600
642	call MPI_GATHER(ucp, numpart_mpi, mp_pp, ucp, &
643	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
644	if (mp_ierr /= 0) goto 600
645	call MPI_GATHER(uzp, numpart_mpi, mp_pp, uzp, &
646	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
647	if (mp_ierr /= 0) goto 600
648
649	call MPI_GATHER(us, numpart_mpi, mp_pp, us, &
650	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
651	if (mp_ierr /= 0) goto 600
652	call MPI_GATHER(vs, numpart_mpi, mp_pp, vs, &
653	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
654	if (mp_ierr /= 0) goto 600
655	call MPI_GATHER(ws, numpart_mpi, mp_pp, ws, &
656	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
657	if (mp_ierr /= 0) goto 600
658
659
660	call MPI_GATHER(xtra1, numpart_mpi, mp_dp, xtra1, &
661	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
662	if (mp_ierr /= 0) goto 600
663	call MPI_GATHER(ytra1, numpart_mpi, mp_dp, ytra1, &
664	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
665	if (mp_ierr /= 0) goto 600
666	call MPI_GATHER(ztra1, numpart_mpi, mp_pp, ztra1, &
667	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
668	if (mp_ierr /= 0) goto 600
669
670	do i=1, nspec
671	call MPI_GATHER(xmass1(:,i), numpart_mpi, mp_pp, xmass1(:,i), &
672	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
673	if (mp_ierr /= 0) goto 600
674
675	end do
676
677	! Use variables npoint etc directly for communications
678	!***********************************************************************
679	else if (use_in_place.and..not.use_mp_vars) then
680	if (lroot) then
681	! Integers:
682	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER, npoint, &
683	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
684	if (mp_ierr /= 0) goto 600
685	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER, idt, &
686	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
687	if (mp_ierr /= 0) goto 600
688	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER, itra1, &
689	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
690	if (mp_ierr /= 0) goto 600
691	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER, nclass, &
692	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
693	if (mp_ierr /= 0) goto 600
694	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER, itramem, &
695	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
696	if (mp_ierr /= 0) goto 600
697
698	! int2
699	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, MPI_INTEGER2, cbt, &
700	&numpart_mpi, MPI_INTEGER2, id_root, mp_comm_used, mp_ierr)
701	if (mp_ierr /= 0) goto 600
702
703	! Reals:
704	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, uap, &
705	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
706	if (mp_ierr /= 0) goto 600
707	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, ucp, &
708	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
709	if (mp_ierr /= 0) goto 600
710	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, uzp, &
711	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
712	if (mp_ierr /= 0) goto 600
713
714	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, us, &
715	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
716	if (mp_ierr /= 0) goto 600
717	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, vs, &
718	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
719	if (mp_ierr /= 0) goto 600
720	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, ws, &
721	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
722	if (mp_ierr /= 0) goto 600
723
724
725	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_dp, xtra1, &
726	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
727	if (mp_ierr /= 0) goto 600
728	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_dp, ytra1, &
729	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
730	if (mp_ierr /= 0) goto 600
731	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, ztra1, &
732	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
733	if (mp_ierr /= 0) goto 600
734
735	do i=1, nspec
736	call MPI_GATHER(MPI_IN_PLACE, numpart_mpi, mp_pp, xmass1(:,i), &
737	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
738	if (mp_ierr /= 0) goto 600
739	end do
740
741	else ! (for mp_pid >= 1)
742
743	! Integers:
744	call MPI_GATHER(npoint, numpart_mpi, MPI_INTEGER, npoint, &
745	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
746	if (mp_ierr /= 0) goto 600
747	call MPI_GATHER(idt, numpart_mpi, MPI_INTEGER, idt, &
748	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
749	if (mp_ierr /= 0) goto 600
750	call MPI_GATHER(itra1, numpart_mpi, MPI_INTEGER, itra1, &
751	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
752	if (mp_ierr /= 0) goto 600
753	call MPI_GATHER(nclass, numpart_mpi, MPI_INTEGER, nclass, &
754	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
755	if (mp_ierr /= 0) goto 600
756	call MPI_GATHER(itramem, numpart_mpi, MPI_INTEGER, itramem, &
757	&numpart_mpi, MPI_INTEGER, id_root, mp_comm_used, mp_ierr)
758	if (mp_ierr /= 0) goto 600
759
760	! int2
761	call MPI_GATHER(cbt, numpart_mpi, MPI_INTEGER2, cbt, &
762	&numpart_mpi, MPI_INTEGER2, id_root, mp_comm_used, mp_ierr)
763	if (mp_ierr /= 0) goto 600
764
765	! Reals:
766	call MPI_GATHER(uap, numpart_mpi, mp_pp, uap, &
767	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
768	if (mp_ierr /= 0) goto 600
769	call MPI_GATHER(ucp, numpart_mpi, mp_pp, ucp, &
770	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
771	if (mp_ierr /= 0) goto 600
772	call MPI_GATHER(uzp, numpart_mpi, mp_pp, uzp, &
773	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
774	if (mp_ierr /= 0) goto 600
775
776	call MPI_GATHER(us, numpart_mpi, mp_pp, us, &
777	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
778	if (mp_ierr /= 0) goto 600
779	call MPI_GATHER(vs, numpart_mpi, mp_pp, vs, &
780	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
781	if (mp_ierr /= 0) goto 600
782	call MPI_GATHER(ws, numpart_mpi, mp_pp, ws, &
783	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
784	if (mp_ierr /= 0) goto 600
785
786
787	call MPI_GATHER(xtra1, numpart_mpi, mp_dp, xtra1, &
788	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
789	if (mp_ierr /= 0) goto 600
790	call MPI_GATHER(ytra1, numpart_mpi, mp_dp, ytra1, &
791	&numpart_mpi, mp_dp, id_root, mp_comm_used, mp_ierr)
792	if (mp_ierr /= 0) goto 600
793	call MPI_GATHER(ztra1, numpart_mpi, mp_pp, ztra1, &
794	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
795	if (mp_ierr /= 0) goto 600
796
797	do i=1, nspec
798	call MPI_GATHER(xmass1(:,i), numpart_mpi, mp_pp, xmass1(:,i), &
799	&numpart_mpi, mp_pp, id_root, mp_comm_used, mp_ierr)
800	if (mp_ierr /= 0) goto 600
801	end do
802	end if ! (lroot)
803	end if ! (use_in_place)
804
805	if (mp_measure_time) call mpif_mtime('commtime',1)
806
807	goto 601
808
809	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
810	stop
811	601 end subroutine mpif_tm_collect_vars
812
813
814	subroutine mpif_gf_send_vars(memstat)
815	!*******************************************************************************
816	! DESCRIPTION
817	! Distribute 'getfield' variables from reader process to all processes.
818	!
819	! Called from timemanager
820	!
821	! NOTE
822	! This subroutine distributes windfields read from the reader process to
823	! all other processes. Usually one set of fields is transfered, but at
824	! first timestep when there are no fields in memory, both are transfered.
825	! MPI_Bcast is used, so implicitly all processes are synchronized at this
826	! step
827	!
828	! TODO
829	! GFS version
830	!
831	!*******************************************************************************
832	use com_mod
833	use par_mod,only: numwfmem
834
835	implicit none
836
837	integer, intent(in) :: memstat
838
839	! Common array sizes used for communications
840	integer, parameter :: d3_size1 = nxmaxnymaxnzmax
841	integer, parameter :: d3_size2 = nxmaxnymaxnuvzmax
842	integer, parameter :: d2_size1 = nxmax*nymax
843	integer, parameter :: d2_size2 = nxmaxnymaxmaxspec
844	integer, parameter :: d2_size3 = nxmax*nymax
845	integer, parameter :: d1_size1 = maxwf
846
847	integer :: d3s1,d3s2,d2s1,d2s2
848
849	! li,ui lower,upper indices of fields to be transfered (1-3, ui>=li)
850	integer :: li,ui
851
852	! First time routine is called the unchangeable fields will be transfered
853	logical :: first_call=.true.
854
855	!**********************************************************************
856
857	! Sizes of arrays transfered
858	d3s1=d3_size1
859	d3s2=d3_size2
860	d2s1=d2_size1
861	d2s2=d2_size2
862
863	! Decide which field(s) need to be transfered
864	if (memstat.ge.32) then ! distribute 2 fields, to 1st/2nd indices
865	li=1; ui=2
866	d3s1=2*d3_size1
867	d3s2=2*d3_size2
868	d2s1=2*d2_size1
869	d2s2=2*d2_size2
870	else if (memstat.eq.17) then ! distribute 1 field, place on 1st index
871	li=1; ui=1
872	else if (memstat.eq.18) then ! distribute 1 field, place on 2nd index
873	li=2; ui=2
874	else if (memstat.eq.19) then ! distribute 1 field, place on 3nd index
875	li=3; ui=3
876	else
877	write(,) '#### mpi_mod::mpif_gf_send_vars> ERROR: ', &
878	& 'wrong value of memstat, exiting ####', memstat
879	stop
880	end if
881
882
883	! Time for MPI communications
884	if (mp_measure_time) call mpif_mtime('commtime',0)
885
886	! Send variables from getfield process (id_read) to other processes
887	!**********************************************************************
888
889	! Static fields/variables sent only at startup
890	if (first_call) then
891	call MPI_Bcast(oro(:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
892	if (mp_ierr /= 0) goto 600
893	call MPI_Bcast(excessoro(:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
894	if (mp_ierr /= 0) goto 600
895	call MPI_Bcast(lsm(:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
896	if (mp_ierr /= 0) goto 600
897	call MPI_Bcast(xlanduse(:,:,:),d2_size3*numclass,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
898	if (mp_ierr /= 0) goto 600
899	call MPI_Bcast(wftime,d1_size1,MPI_INTEGER,id_read,MPI_COMM_WORLD,mp_ierr)
900	if (mp_ierr /= 0) goto 600
901	call MPI_Bcast(numbwf,1,MPI_INTEGER,id_read,MPI_COMM_WORLD,mp_ierr)
902	if (mp_ierr /= 0) goto 600
903	call MPI_Bcast(nmixz,1,MPI_INTEGER,id_read,MPI_COMM_WORLD,mp_ierr)
904	if (mp_ierr /= 0) goto 600
905	call MPI_Bcast(height,nzmax,MPI_INTEGER,id_read,MPI_COMM_WORLD,mp_ierr)
906	if (mp_ierr /= 0) goto 600
907
908	first_call=.false.
909	endif
910
911	call MPI_Bcast(uu(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
912	if (mp_ierr /= 0) goto 600
913	call MPI_Bcast(vv(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
914	if (mp_ierr /= 0) goto 600
915	call MPI_Bcast(uupol(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
916	if (mp_ierr /= 0) goto 600
917	call MPI_Bcast(vvpol(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
918	if (mp_ierr /= 0) goto 600
919	call MPI_Bcast(ww(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
920	if (mp_ierr /= 0) goto 600
921	call MPI_Bcast(tt(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
922	if (mp_ierr /= 0) goto 600
923	call MPI_Bcast(rho(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
924	if (mp_ierr /= 0) goto 600
925	call MPI_Bcast(drhodz(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
926	if (mp_ierr /= 0) goto 600
927	call MPI_Bcast(tth(:,:,:,li:ui),d3s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
928	if (mp_ierr /= 0) goto 600
929	call MPI_Bcast(qvh(:,:,:,li:ui),d3s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
930	if (mp_ierr /= 0) goto 600
931	call MPI_Bcast(qv(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
932	if (mp_ierr /= 0) goto 600
933	call MPI_Bcast(pv(:,:,:,li:ui),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
934	if (mp_ierr /= 0) goto 600
935	call MPI_Bcast(clouds(:,:,:,li:ui),d3s1,MPI_INTEGER1,id_read,MPI_COMM_WORLD,mp_ierr)
936	if (mp_ierr /= 0) goto 600
937
938	! 2D fields
939	call MPI_Bcast(cloudsh(:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
940	if (mp_ierr /= 0) goto 600
941	call MPI_Bcast(vdep(:,:,:,li:ui),d2s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
942	if (mp_ierr /= 0) goto 600
943	call MPI_Bcast(ps(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
944	if (mp_ierr /= 0) goto 600
945	call MPI_Bcast(sd(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
946	if (mp_ierr /= 0) goto 600
947	call MPI_Bcast(tcc(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
948	if (mp_ierr /= 0) goto 600
949	call MPI_Bcast(tt2(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
950	if (mp_ierr /= 0) goto 600
951	call MPI_Bcast(td2(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
952	if (mp_ierr /= 0) goto 600
953	call MPI_Bcast(lsprec(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
954	if (mp_ierr /= 0) goto 600
955	call MPI_Bcast(convprec(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
956	if (mp_ierr /= 0) goto 600
957	call MPI_Bcast(ustar(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
958	if (mp_ierr /= 0) goto 600
959	call MPI_Bcast(wstar(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
960	if (mp_ierr /= 0) goto 600
961	call MPI_Bcast(hmix(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
962	if (mp_ierr /= 0) goto 600
963	call MPI_Bcast(tropopause(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
964	if (mp_ierr /= 0) goto 600
965	call MPI_Bcast(oli(:,:,:,li:ui),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
966	if (mp_ierr /= 0) goto 600
967
968	call MPI_Bcast(z0,numclass,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
969	if (mp_ierr /= 0) goto 600
970
971
972	if (mp_measure_time) call mpif_mtime('commtime',1)
973
974	goto 601
975
976	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
977	stop
978
979	601 end subroutine mpif_gf_send_vars
980
981
982	subroutine mpif_gf_send_vars_nest(memstat)
983	!***********************************************************************
984	! DESCRIPTION
985	! Distribute 'getfield' variables from reader process to all processes.
986	! For nested fields
987	!
988	! Called from timemanager
989	!
990	! NOTE
991	! This subroutine distributes nested windfields from the reader process to
992	! all other processes. Usually one set of fields is transfered, but at
993	! first timestep when there are no fields in memory, both are transfered.
994	! MPI_Bcast is used, so implicitly all processes are synchronized at this
995	! step
996	!
997	!
998	!***********************************************************************
999	use com_mod
1000	use par_mod, only: numwfmem
1001
1002	implicit none
1003
1004	integer, intent(in) :: memstat
1005	integer :: i
1006	! li,ui lower,upper indices of fields to be transfered (1-3, ui>=li)
1007	integer :: li,ui
1008
1009	! Common array sizes used for communications
1010	integer :: d3_size1 = nxmaxnnymaxnnzmax*maxnests
1011	integer :: d3_size2 = nxmaxnnymaxnnuvzmax*maxnests
1012	integer :: d2_size1 = nxmaxnnymaxnmaxnests
1013	integer :: d2_size2 = nxmaxnnymaxnmaxspec*maxnests
1014	integer :: d2_size3 = nxmaxnnymaxnmaxnests
1015
1016	integer :: d3s1,d3s2,d2s1,d2s2
1017
1018	! First time routine is called the unchangeable fields will be transfered
1019	logical :: first_call=.true.
1020
1021	!**********************************************************************
1022
1023	! Sizes of arrays transfered
1024	d3s1=d3_size1
1025	d3s2=d3_size2
1026	d2s1=d2_size1
1027	d2s2=d2_size2
1028
1029	! Decide which field(s) need to be transfered
1030	if (memstat.ge.32) then ! distribute 2 fields
1031	li=1; ui=2
1032	d3s1=2*d3_size1
1033	d3s2=2*d3_size2
1034	d2s1=2*d2_size1
1035	d2s2=2*d2_size2
1036	else if (memstat.eq.17) then ! distribute 1 field, on 1st index
1037	li=1; ui=1
1038	else if (memstat.eq.18) then ! distribute 1 field, on 2nd index
1039	li=2; ui=2
1040	else if (memstat.eq.19) then ! distribute 1 field, on 3nd index
1041	li=3; ui=3
1042	else
1043	write(,) '#### mpi_mod::mpif_gf_send_vars_nest> ERROR: ', &
1044	& 'wrong value of memstat, exiting ####', memstat
1045	stop
1046	end if
1047
1048
1049	! Time for MPI communications
1050	if (mp_measure_time) call mpif_mtime('commtime',0)
1051
1052	! Distribute variables, send from getfield process (id_read) to other
1053	! processes
1054	!**********************************************************************
1055
1056	! Static fields/variables sent only at startup
1057	if (first_call) then
1058	call MPI_Bcast(oron(:,:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1059	if (mp_ierr /= 0) goto 600
1060	call MPI_Bcast(excessoron(:,:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1061	if (mp_ierr /= 0) goto 600
1062	call MPI_Bcast(lsmn(:,:,:),d2_size3,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1063	if (mp_ierr /= 0) goto 600
1064	call MPI_Bcast(xlandusen(:,:,:,:),d2_size3*numclass,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1065	if (mp_ierr /= 0) goto 600
1066	first_call=.false.
1067	end if
1068
1069	! MPI prefers contiguous arrays for sending (else a buffer is created),
1070	! hence the loop
1071
1072	do i=1, numbnests
1073	! 3D fields
1074	call MPI_Bcast(uun(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1075	if (mp_ierr /= 0) goto 600
1076	call MPI_Bcast(vvn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1077	if (mp_ierr /= 0) goto 600
1078	call MPI_Bcast(wwn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1079	if (mp_ierr /= 0) goto 600
1080	call MPI_Bcast(ttn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1081	if (mp_ierr /= 0) goto 600
1082	call MPI_Bcast(rhon(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1083	if (mp_ierr /= 0) goto 600
1084	call MPI_Bcast(drhodzn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1085	if (mp_ierr /= 0) goto 600
1086	call MPI_Bcast(tthn(:,:,:,li:ui,i),d3s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1087	if (mp_ierr /= 0) goto 600
1088	call MPI_Bcast(qvhn(:,:,:,li:ui,i),d3s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1089	if (mp_ierr /= 0) goto 600
1090	call MPI_Bcast(qvn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1091	if (mp_ierr /= 0) goto 600
1092	call MPI_Bcast(pvn(:,:,:,li:ui,i),d3s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1093	if (mp_ierr /= 0) goto 600
1094	call MPI_Bcast(cloudsn(:,:,:,li:ui,i),d3s1,MPI_INTEGER1,id_read,MPI_COMM_WORLD,mp_ierr)
1095	if (mp_ierr /= 0) goto 600
1096
1097	! 2D fields
1098	call MPI_Bcast(cloudsnh(:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1099	if (mp_ierr /= 0) goto 600
1100	call MPI_Bcast(vdepn(:,:,:,li:ui,i),d2s2,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1101	if (mp_ierr /= 0) goto 600
1102	call MPI_Bcast(psn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1103	if (mp_ierr /= 0) goto 600
1104	call MPI_Bcast(sdn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1105	if (mp_ierr /= 0) goto 600
1106	call MPI_Bcast(tccn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1107	if (mp_ierr /= 0) goto 600
1108	call MPI_Bcast(tt2n(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1109	if (mp_ierr /= 0) goto 600
1110	call MPI_Bcast(td2n(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1111	if (mp_ierr /= 0) goto 600
1112	call MPI_Bcast(lsprecn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1113	if (mp_ierr /= 0) goto 600
1114	call MPI_Bcast(convprecn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1115	if (mp_ierr /= 0) goto 600
1116	call MPI_Bcast(ustarn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1117	if (mp_ierr /= 0) goto 600
1118	call MPI_Bcast(wstarn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1119	if (mp_ierr /= 0) goto 600
1120	call MPI_Bcast(olin(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1121	if (mp_ierr /= 0) goto 600
1122	call MPI_Bcast(hmixn(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1123	if (mp_ierr /= 0) goto 600
1124	call MPI_Bcast(tropopausen(:,:,:,li:ui,i),d2s1,mp_pp,id_read,MPI_COMM_WORLD,mp_ierr)
1125	if (mp_ierr /= 0) goto 600
1126	end do
1127
1128	if (mp_measure_time) call mpif_mtime('commtime',1)
1129
1130	goto 601
1131
1132	600 write(,) "mpi_mod> mp_ierr \= 0",mp_ierr
1133	stop
1134
1135	601 end subroutine mpif_gf_send_vars_nest
1136
1137
1138	subroutine mpif_gf_send_vars_async(memstat)
1139	!*******************************************************************************
1140	! DESCRIPTION
1141	! Distribute 'getfield' variables from reader process to all processes.
1142	!
1143	! Called from timemanager by root process only
1144	!
1145	! NOTE
1146	! This version uses asynchronious sends. The newest fields are sent in the
1147	! background, so calculations can continue while
1148	! MPI communications are performed.
1149	!
1150	! The way the MPI tags/requests are sequenced means that this routine must
1151	! carefully match routine 'mpif_gf_recv_vars_async'
1152	!
1153	! VARIABLES
1154	! memstat -- input, for resolving pointer to windfield index being read
1155	! mind -- index where to place new fields
1156	! !!! Under development, don't use yet !!!
1157	!
1158	!
1159	!*******************************************************************************
1160	use com_mod
1161
1162	implicit none
1163
1164	integer, intent(in) :: memstat
1165	integer :: mind
1166	integer :: dest,i
1167
1168	! Common array sizes used for communications
1169	integer :: d3s1 = nxmaxnymaxnzmax
1170	integer :: d3s2 = nxmaxnymaxnuvzmax
1171	integer :: d2s1 = nxmax*nymax
1172	integer :: d2s2 = nxmaxnymaxmaxspec
1173	integer :: d1s1 = maxwf
1174
1175	!integer :: d3s1,d3s2,d2s1,d2s2
1176
1177	!*******************************************************************************
1178
1179	! :TODO: don't need these
1180	! d3s1=d3_size1
1181	! d3s2=d3_size2
1182	! d2s1=d2_size1
1183	! d2s2=d2_size2
1184
1185	! At the time the send is posted, the reader process is one step further
1186	! in the permutation of memstat compared with the receiving processes
1187
1188	if (memstat.ge.32) then
1189	! last read was synchronous, to indices 1 and 2, 3 is free
1190	write(,) "#### mpi_mod::mpif_gf_send_vars_async> ERROR: &
1191	& memstat>=32 should never happen here."
1192	stop
1193	else if (memstat.eq.17) then
1194	! old fields on 1,2, send 3
1195	mind=3
1196	else if (memstat.eq.18) then
1197	! old fields on 2,3, send 1
1198	mind=1
1199	else if (memstat.eq.19) then
1200	! old fields on 3,1, send 2
1201	mind=2
1202	else
1203	write(,) "#### mpi_mod::mpif_gf_send_vars_async> ERROR: &
1204	& invalid memstat"
1205	end if
1206
1207	if (mp_dev_mode) then
1208	if (mp_pid.ne.id_read) then
1209	write(,) 'MPI_DEV_MODE: error calling mpif_gf_send_vars_async'
1210	end if
1211	end if
1212
1213	if (mp_dev_mode) write(,) '## in mpif_gf_send_vars_async, memstat:', memstat
1214
1215	! Time for MPI communications
1216	if (mp_measure_time) call mpif_mtime('commtime',0)
1217
1218	! Loop over receiving processes, initiate data sending
1219	!*****************************************************
1220
1221	do dest=0,mp_np-1 ! mp_np-2 will also work if last proc reserved for reading
1222	! :TODO: use mp_partgroup_np here
1223	if (dest.eq.id_read) cycle
1224	i=dest*nvar_async
1225	call MPI_Isend(uu(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1226	if (mp_ierr /= 0) goto 600
1227	i=i+1
1228	call MPI_Isend(vv(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1229	if (mp_ierr /= 0) goto 600
1230	i=i+1
1231	call MPI_Isend(uupol(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1232	if (mp_ierr /= 0) goto 600
1233	i=i+1
1234	call MPI_Isend(vvpol(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1235	if (mp_ierr /= 0) goto 600
1236	i=i+1
1237	call MPI_Isend(ww(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1238	if (mp_ierr /= 0) goto 600
1239	i=i+1
1240	call MPI_Isend(tt(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1241	if (mp_ierr /= 0) goto 600
1242	i=i+1
1243	call MPI_Isend(rho(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1244	if (mp_ierr /= 0) goto 600
1245	i=i+1
1246	call MPI_Isend(drhodz(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1247	if (mp_ierr /= 0) goto 600
1248	i=i+1
1249	call MPI_Isend(tth(:,:,:,mind),d3s2,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1250	if (mp_ierr /= 0) goto 600
1251	i=i+1
1252	call MPI_Isend(qvh(:,:,:,mind),d3s2,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1253	if (mp_ierr /= 0) goto 600
1254	i=i+1
1255	call MPI_Isend(qv(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1256	if (mp_ierr /= 0) goto 600
1257	i=i+1
1258	call MPI_Isend(pv(:,:,:,mind),d3s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1259	if (mp_ierr /= 0) goto 600
1260	i=i+1
1261	call MPI_Isend(clouds(:,:,:,mind),d3s1,MPI_INTEGER1,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1262	i=i+1
1263	if (mp_ierr /= 0) goto 600
1264
1265	call MPI_Isend(cloudsh(:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1266	if (mp_ierr /= 0) goto 600
1267	i=i+1
1268	call MPI_Isend(vdep(:,:,:,mind),d2s2,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1269	if (mp_ierr /= 0) goto 600
1270	i=i+1
1271	call MPI_Isend(ps(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1272	if (mp_ierr /= 0) goto 600
1273	i=i+1
1274	call MPI_Isend(sd(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1275	if (mp_ierr /= 0) goto 600
1276	i=i+1
1277	call MPI_Isend(tcc(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1278	if (mp_ierr /= 0) goto 600
1279	i=i+1
1280	call MPI_Isend(tt2(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1281	if (mp_ierr /= 0) goto 600
1282	i=i+1
1283	call MPI_Isend(td2(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1284	if (mp_ierr /= 0) goto 600
1285	i=i+1
1286	call MPI_Isend(lsprec(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1287	if (mp_ierr /= 0) goto 600
1288	i=i+1
1289	call MPI_Isend(convprec(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1290	if (mp_ierr /= 0) goto 600
1291	i=i+1
1292	call MPI_Isend(ustar(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1293	if (mp_ierr /= 0) goto 600
1294	i=i+1
1295	call MPI_Isend(wstar(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1296	if (mp_ierr /= 0) goto 600
1297	i=i+1
1298	call MPI_Isend(hmix(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1299	if (mp_ierr /= 0) goto 600
1300	i=i+1
1301	call MPI_Isend(tropopause(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1302	if (mp_ierr /= 0) goto 600
1303	i=i+1
1304	call MPI_Isend(oli(:,:,:,mind),d2s1,mp_pp,dest,tm1,MPI_COMM_WORLD,reqs(i),mp_ierr)
1305	if (mp_ierr /= 0) goto 600
1306
1307	end do
1308
1309	if (mp_measure_time) call mpif_mtime('commtime',1)
1310
1311	goto 601
1312
1313	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
1314	stop
1315
1316	601 end subroutine mpif_gf_send_vars_async
1317
1318
1319	subroutine mpif_gf_recv_vars_async(memstat)
1320	!*******************************************************************************
1321	! DESCRIPTION
1322	! Receive 'getfield' variables from reader process to all processes.
1323	!
1324	! Called from timemanager by all processes except root
1325	!
1326	! NOTE
1327	! This version uses asynchronious communications.
1328	!
1329	! VARIABLES
1330	! memstat -- input, used to resolve windfield index being received
1331	!
1332	!
1333	!*******************************************************************************
1334	use com_mod
1335
1336	implicit none
1337
1338	integer, intent(in) :: memstat
1339	integer :: mind,j
1340
1341	! Common array sizes used for communications
1342	integer :: d3s1 = nxmaxnymaxnzmax
1343	integer :: d3s2 = nxmaxnymaxnuvzmax
1344	integer :: d2s1 = nxmax*nymax
1345	integer :: d2s2 = nxmaxnymaxmaxspec
1346	integer :: d1_size1 = maxwf
1347
1348	! integer :: d3s1,d3s2,d2s1,d2s2
1349	!*******************************************************************************
1350
1351	! :TODO: don't need these
1352	! d3s1=d3_size1
1353	! d3s2=d3_size2
1354	! d2s1=d2_size1
1355	! d2s2=d2_size2
1356
1357	! At the time this immediate receive is posted, memstat is the state of
1358	! windfield indices at the previous/current time. From this, the future
1359	! state is deduced.
1360	if (memstat.eq.32) then
1361	! last read was synchronous to indices 1 and 2, 3 is free
1362	mind=3
1363	else if (memstat.eq.17) then
1364	! last read was asynchronous to index 3, 1 is free
1365	mind=1
1366	else if (memstat.eq.18) then
1367	! last read was asynchronous to index 1, 2 is free
1368	mind=2
1369	else if (memstat.eq.19) then
1370	! last read was asynchronous to index 2, 3 is free
1371	mind=3
1372	end if
1373
1374	if (mp_dev_mode) then
1375	if (mp_pid.eq.id_read) then
1376	write(,) 'MPI_DEV_MODE: error calling mpif_gf_recv_vars_async'
1377	end if
1378	end if
1379
1380	! Time for MPI communications
1381	if (mp_measure_time) call mpif_mtime('commtime',0)
1382
1383	if (mp_dev_mode) write(,) '## in mpif_gf_send_vars_async, memstat:', memstat
1384
1385	! Initiate receiving of data
1386	!***************************
1387
1388	! Get MPI tags/requests for communications
1389	j=mp_pid*nvar_async
1390	call MPI_Irecv(uu(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1391	if (mp_ierr /= 0) goto 600
1392	j=j+1
1393	call MPI_Irecv(vv(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1394	if (mp_ierr /= 0) goto 600
1395	j=j+1
1396	call MPI_Irecv(uupol(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1397	if (mp_ierr /= 0) goto 600
1398	j=j+1
1399	call MPI_Irecv(vvpol(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1400	if (mp_ierr /= 0) goto 600
1401	j=j+1
1402	call MPI_Irecv(ww(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1403	if (mp_ierr /= 0) goto 600
1404	j=j+1
1405	call MPI_Irecv(tt(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1406	if (mp_ierr /= 0) goto 600
1407	j=j+1
1408	call MPI_Irecv(rho(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1409	if (mp_ierr /= 0) goto 600
1410	j=j+1
1411	call MPI_Irecv(drhodz(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1412	if (mp_ierr /= 0) goto 600
1413	j=j+1
1414	call MPI_Irecv(tth(:,:,:,mind),d3s2,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1415	if (mp_ierr /= 0) goto 600
1416	j=j+1
1417	call MPI_Irecv(qvh(:,:,:,mind),d3s2,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1418	if (mp_ierr /= 0) goto 600
1419	j=j+1
1420
1421	call MPI_Irecv(qv(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1422	if (mp_ierr /= 0) goto 600
1423	j=j+1
1424	call MPI_Irecv(pv(:,:,:,mind),d3s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1425	if (mp_ierr /= 0) goto 600
1426	j=j+1
1427	call MPI_Irecv(clouds(:,:,:,mind),d3s1,MPI_INTEGER1,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1428	if (mp_ierr /= 0) goto 600
1429	j=j+1
1430
1431	call MPI_Irecv(cloudsh(:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1432	if (mp_ierr /= 0) goto 600
1433	j=j+1
1434	call MPI_Irecv(vdep(:,:,:,mind),d2s2,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1435	if (mp_ierr /= 0) goto 600
1436	j=j+1
1437
1438	call MPI_Irecv(ps(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1439	if (mp_ierr /= 0) goto 600
1440	j=j+1
1441	call MPI_Irecv(sd(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1442	if (mp_ierr /= 0) goto 600
1443	j=j+1
1444	call MPI_Irecv(tcc(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1445	if (mp_ierr /= 0) goto 600
1446	j=j+1
1447	call MPI_Irecv(tt2(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1448	if (mp_ierr /= 0) goto 600
1449	j=j+1
1450	call MPI_Irecv(td2(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1451	if (mp_ierr /= 0) goto 600
1452	j=j+1
1453	call MPI_Irecv(lsprec(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1454	if (mp_ierr /= 0) goto 600
1455	j=j+1
1456	call MPI_Irecv(convprec(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1457	if (mp_ierr /= 0) goto 600
1458
1459	call MPI_Irecv(ustar(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1460	if (mp_ierr /= 0) goto 600
1461	j=j+1
1462	call MPI_Irecv(wstar(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1463	if (mp_ierr /= 0) goto 600
1464	j=j+1
1465	call MPI_Irecv(hmix(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1466	if (mp_ierr /= 0) goto 600
1467	j=j+1
1468	call MPI_Irecv(tropopause(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1469	if (mp_ierr /= 0) goto 600
1470	j=j+1
1471	call MPI_Irecv(oli(:,:,:,mind),d2s1,mp_pp,id_read,MPI_ANY_TAG,MPI_COMM_WORLD,reqs(j),mp_ierr)
1472	if (mp_ierr /= 0) goto 600
1473
1474
1475	if (mp_measure_time) call mpif_mtime('commtime',1)
1476
1477	goto 601
1478
1479	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
1480	stop
1481
1482	601 end subroutine mpif_gf_recv_vars_async
1483
1484
1485	subroutine mpif_gf_request
1486	!*******************************************************************************
1487	! DESCRIPTION
1488	! Check for completion of MPI_Isend/MPI_Irecv data transfer.
1489	!
1490	!
1491	! NOTE
1492	! implicit synchronisation between all processes takes place here
1493	!
1494	!
1495	!*******************************************************************************
1496	implicit none
1497
1498	! if (mp_measure_time) call mpif_mtime('commtime',0)
1499
1500	! call MPI_Wait(rm1,MPI_STATUS_IGNORE,mp_ierr)
1501	call MPI_Waitall(nvar_async*mp_np,reqs,MPI_STATUSES_IGNORE,mp_ierr)
1502	if (mp_ierr /= 0) goto 600
1503
1504	! if (mp_measure_time) call mpif_mtime('commtime',1)
1505
1506	goto 601
1507
1508	600 write(,) "#### mpi_mod::mpif_gf_request> ERROR, mp_ierr \= 0 ", mp_ierr
1509	stop
1510
1511	601 end subroutine mpif_gf_request
1512
1513
1514	subroutine mpif_tm_reduce_grid
1515	!***********************************************************************
1516	! Collect grid variable to PID 0, adding from all processes.
1517	!
1518	! NOTE
1519	! - Older MPI implementations may lack the MPI_IN_PLACE operation.
1520	! If so use 1) below and change unc_mod
1521	!
1522	!***********************************************************************
1523	use com_mod
1524	use unc_mod
1525	use par_mod
1526
1527	implicit none
1528
1529	integer :: grid_size2d,grid_size3d
1530	integer, parameter :: rcpt_size=maxreceptor*maxspec
1531
1532	!**********************************************************************
1533	grid_size2d=numxgridnumygridmaxspec* &
1534	& maxpointspec_actnclassuncmaxageclass
1535	grid_size3d=numxgridnumygridnumzgridmaxspec &
1536	& maxpointspec_actnclassuncmaxageclass
1537
1538
1539	! Time for MPI communications
1540	if (mp_measure_time) call mpif_mtime('commtime',0)
1541
1542	! 1) Using a separate grid (gridunc0) for received values
1543	! call MPI_Reduce(gridunc, gridunc0, grid_size3d, mp_pp, MPI_SUM, id_root, &
1544	! & mp_comm_used, mp_ierr)
1545	! if (mp_ierr /= 0) goto 600
1546
1547	! 2) Using in-place reduction
1548	if (lroot) then
1549	call MPI_Reduce(MPI_IN_PLACE, gridunc, grid_size3d, mp_pp, MPI_SUM, id_root, &
1550	& mp_comm_used, mp_ierr)
1551	if (mp_ierr /= 0) goto 600
1552	else
1553	call MPI_Reduce(gridunc, gridunc, grid_size3d, mp_pp, MPI_SUM, id_root, &
1554	& mp_comm_used, mp_ierr)
1555	end if
1556
1557	if ((WETDEP).and.(ldirect.gt.0)) then
1558	call MPI_Reduce(wetgridunc, wetgridunc0, grid_size2d, mp_pp, MPI_SUM, id_root, &
1559	& mp_comm_used, mp_ierr)
1560	if (mp_ierr /= 0) goto 600
1561	end if
1562
1563	if ((DRYDEP).and.(ldirect.gt.0)) then
1564	call MPI_Reduce(drygridunc, drygridunc0, grid_size2d, mp_pp, MPI_SUM, id_root, &
1565	& mp_comm_used, mp_ierr)
1566	if (mp_ierr /= 0) goto 600
1567	end if
1568
1569	! Receptor concentrations
1570	if (lroot) then
1571	call MPI_Reduce(MPI_IN_PLACE,creceptor,rcpt_size,mp_pp,MPI_SUM,id_root, &
1572	& mp_comm_used,mp_ierr)
1573	if (mp_ierr /= 0) goto 600
1574	else
1575	call MPI_Reduce(creceptor,creceptor,rcpt_size,mp_pp,MPI_SUM,id_root, &
1576	& mp_comm_used,mp_ierr)
1577	end if
1578
1579	if (mp_measure_time) call mpif_mtime('commtime',1)
1580
1581	goto 601
1582
1583	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
1584	stop
1585
1586	601 end subroutine mpif_tm_reduce_grid
1587
1588
1589	subroutine mpif_tm_reduce_grid_nest
1590	!***********************************************************************
1591	! Collect nested grids to PID 0, adding from all processes.
1592	!
1593	! NOTE
1594	! - Compiling with 'fcheck=all' (gfortran) will cause a run-time error
1595	! as wetgriduncn0 is only allocated for root process. Possibly valid
1596	! MPI code but invalid gfortran.
1597	!
1598	!***********************************************************************
1599	use com_mod
1600	use unc_mod
1601	use par_mod
1602
1603	implicit none
1604
1605	integer :: grid_size2d,grid_size3d
1606
1607	!**********************************************************************
1608	grid_size3d=numxgridnnumygridnnumzgridmaxspec &
1609	& maxpointspec_actnclassuncmaxageclass
1610	grid_size2d=numxgridnnumygridnmaxspec* &
1611	& maxpointspec_actnclassuncmaxageclass
1612
1613
1614	! Time for MPI communications
1615	if (mp_measure_time) call mpif_mtime('commtime',0)
1616
1617	! Using a separate grid (gridunc0) for received values, for debugging
1618	! call MPI_Reduce(griduncn, griduncn0, grid_size3d, mp_pp, MPI_SUM, id_root, &
1619	! & mp_comm_used, mp_ierr)
1620	! if (mp_ierr /= 0) goto 600
1621
1622	! Using in-place reduction
1623	if (lroot) then
1624	call MPI_Reduce(MPI_IN_PLACE, griduncn, grid_size3d, mp_pp, MPI_SUM, id_root, &
1625	& mp_comm_used, mp_ierr)
1626	if (mp_ierr /= 0) goto 600
1627	else
1628	call MPI_Reduce(griduncn, griduncn, grid_size3d, mp_pp, MPI_SUM, id_root, &
1629	& mp_comm_used, mp_ierr)
1630	end if
1631
1632
1633	if ((WETDEP).and.(ldirect.gt.0)) then
1634	call MPI_Reduce(wetgriduncn, wetgriduncn0, grid_size2d, mp_pp, MPI_SUM, id_root, &
1635	& mp_comm_used, mp_ierr)
1636	if (mp_ierr /= 0) goto 600
1637	end if
1638
1639	if ((DRYDEP).and.(ldirect.gt.0)) then
1640	call MPI_Reduce(drygriduncn, drygriduncn0, grid_size2d, mp_pp, MPI_SUM, id_root, &
1641	& mp_comm_used, mp_ierr)
1642	if (mp_ierr /= 0) goto 600
1643	end if
1644
1645	if (mp_measure_time) call mpif_mtime('commtime',1)
1646
1647	goto 601
1648
1649	600 write(,) "mpi_mod> mp_ierr \= 0", mp_ierr
1650	stop
1651
1652	601 end subroutine mpif_tm_reduce_grid_nest
1653
1654
1655	subroutine mpif_mtime(ident,imode)
1656	!***********************************************************************
1657	! Measure CPU/Wall time in various parts of the code
1658	!
1659	! VARIABLES
1660	! ident character, identifies routine to measure
1661	! imode integer, 0:start clock(s) 1: stop clock(s)
1662	!
1663	!***********************************************************************
1664	implicit none
1665
1666	character(LEN=*), intent(in) :: ident
1667	integer, intent(in) :: imode
1668
1669	select case(ident)
1670
1671	case ('timemanager')
1672	if (imode.eq.0) then
1673	call cpu_time(tm_tot_beg)
1674	else
1675	call cpu_time(tm_tot_end)
1676	tm_tot_total = tm_tot_total + (tm_tot_end-tm_tot_beg)
1677	end if
1678
1679	case ('wetdepo')
1680	if (imode.eq.0) then
1681	mp_wetdepo_wtime_beg = mpi_wtime()
1682	call cpu_time(mp_wetdepo_time_beg)
1683	else
1684	mp_wetdepo_wtime_end = mpi_wtime()
1685	call cpu_time(mp_wetdepo_time_end)
1686
1687	mp_wetdepo_wtime_total = mp_wetdepo_wtime_total + &
1688	&(mp_wetdepo_wtime_end - mp_wetdepo_wtime_beg)
1689	mp_wetdepo_time_total = mp_wetdepo_time_total + &
1690	&(mp_wetdepo_time_end - mp_wetdepo_time_beg)
1691	end if
1692
1693	case ('getfields')
1694	if (imode.eq.0) then
1695	mp_getfields_wtime_beg = mpi_wtime()
1696	call cpu_time(mp_getfields_time_beg)
1697	else
1698	mp_getfields_wtime_end = mpi_wtime()
1699	call cpu_time(mp_getfields_time_end)
1700
1701	mp_getfields_wtime_total = mp_getfields_wtime_total + &
1702	&(mp_getfields_wtime_end - mp_getfields_wtime_beg)
1703	mp_getfields_time_total = mp_getfields_time_total + &
1704	&(mp_getfields_time_end - mp_getfields_time_beg)
1705	end if
1706
1707	case ('partloop1')
1708	if (imode.eq.0) then
1709	call cpu_time(tm_nploop_beg)
1710	else
1711	call cpu_time(tm_nploop_end)
1712	tm_nploop_total = tm_nploop_total + (tm_nploop_end - tm_nploop_beg)
1713	end if
1714
1715	case ('conccalc')
1716	if (imode.eq.0) then
1717	call cpu_time(mp_conccalc_time_beg)
1718	else
1719	call cpu_time(mp_conccalc_time_end)
1720	mp_conccalc_time_total = mp_conccalc_time_total + mp_conccalc_time_end - &
1721	&mp_conccalc_time_beg
1722	end if
1723	case ('rootonly')
1724	if (imode.eq.0) then
1725	call cpu_time(mp_root_time_beg)
1726	mp_root_wtime_beg = mpi_wtime()
1727	else
1728	call cpu_time(mp_root_time_end)
1729	mp_root_wtime_end = mpi_wtime()
1730	mp_root_time_total = mp_root_time_total + &
1731	&(mp_root_time_end - mp_root_time_beg)
1732	mp_root_wtime_total = mp_root_wtime_total + &
1733	&(mp_root_wtime_end - mp_root_wtime_beg)
1734	end if
1735
1736	case ('iotime')
1737	if (imode.eq.0) then
1738	mp_io_wtime_beg = mpi_wtime()
1739	call cpu_time(mp_io_time_beg)
1740	else
1741	mp_io_wtime_end = mpi_wtime()
1742	call cpu_time(mp_io_time_end)
1743
1744	mp_io_wtime_total = mp_io_wtime_total + (mp_io_wtime_end - &
1745	& mp_io_wtime_beg)
1746	mp_io_time_total = mp_io_time_total + (mp_io_time_end - &
1747	& mp_io_time_beg)
1748	end if
1749
1750	case ('readwind')
1751	if (imode.eq.0) then
1752	call cpu_time(mp_readwind_time_beg)
1753	mp_readwind_wtime_beg = mpi_wtime()
1754	else
1755	call cpu_time(mp_readwind_time_end)
1756	mp_readwind_wtime_end = mpi_wtime()
1757
1758	mp_readwind_time_total = mp_readwind_time_total + &
1759	&(mp_readwind_time_end - mp_readwind_time_beg)
1760	mp_readwind_wtime_total = mp_readwind_wtime_total + &
1761	&(mp_readwind_wtime_end - mp_readwind_wtime_beg)
1762	end if
1763
1764	case ('commtime')
1765	if (imode.eq.0) then
1766	call cpu_time(mp_comm_time_beg)
1767	mp_comm_wtime_beg = mpi_wtime()
1768	else
1769	call cpu_time(mp_comm_time_end)
1770	mp_comm_wtime_end = mpi_wtime()
1771	mp_comm_time_total = mp_comm_time_total + &
1772	&(mp_comm_time_end - mp_comm_time_beg)
1773	mp_comm_wtime_total = mp_comm_wtime_total + &
1774	&(mp_comm_wtime_end - mp_comm_wtime_beg)
1775	end if
1776
1777	case ('flexpart')
1778	if (imode.eq.0) then
1779	mp_total_wtime_beg=mpi_wtime()
1780	else
1781	mp_total_wtime_end=mpi_wtime()
1782	mp_total_wtime_total = mp_total_wtime_end-mp_total_wtime_beg
1783	end if
1784
1785	case default
1786	write(,) 'mpi_mod::mpif_mtime> WARNING: unknown case identifier'
1787
1788	end select
1789
1790
1791	end subroutine mpif_mtime
1792
1793
1794	subroutine mpif_finalize
1795	!***********************************************************************
1796	! Finalize MPI
1797	! Optionally print detailed time diagnostics
1798	!***********************************************************************
1799	implicit none
1800
1801	integer :: ip,j,r
1802
1803	if (mp_measure_time) then
1804	do ip=0, mp_np-1
1805	call MPI_BARRIER(MPI_COMM_WORLD, mp_ierr)
1806
1807	if (ip == mp_pid) then
1808	write(*,FMT='(72("#"))')
1809	write(*,FMT='(A60,I3)') 'STATISTICS FOR MPI PROCESS:', mp_pid
1810	if (ip == 0) then
1811	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR ROOT-ONLY (PID 0) &
1812	&SECTIONS: ', mp_root_time_total
1813	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR ROOT-ONLY (PID 0) &
1814	&SECTIONS:', mp_root_wtime_total
1815	end if
1816	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR FLEXPART: ' &
1817	&, mp_total_wtime_total
1818	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR MPI COMMUNICATIONS:',&
1819	& mp_comm_time_total
1820	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR MPI COMMUNICATIONS:',&
1821	& mp_comm_wtime_total
1822	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR MPI BARRIERS:',&
1823	& mp_barrier_time_total
1824	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR MPI BARRIERS:',&
1825	& mp_barrier_wtime_total
1826	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR TIMEMANAGER:',&
1827	& tm_tot_total
1828	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR TIMEMANAGER/NUMPART LOOP:',&
1829	& tm_nploop_total
1830	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR ADVANCE:',&
1831	& mp_advance_wtime_total
1832	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR GETFIELDS:',&
1833	& mp_getfields_wtime_total
1834	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR GETFIELDS:',&
1835	& mp_getfields_time_total
1836	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR READWIND:',&
1837	& mp_readwind_wtime_total
1838	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR READWIND:',&
1839	& mp_readwind_time_total
1840	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR FILE IO:',&
1841	& mp_io_wtime_total
1842	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR FILE IO:',&
1843	& mp_io_time_total
1844	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR WETDEPO:',&
1845	& mp_wetdepo_wtime_total
1846	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL CPU TIME FOR WETDEPO:',&
1847	& mp_wetdepo_time_total
1848	write(*,FMT='(A60,TR1,F9.2)') 'TOTAL WALL TIME FOR CONCCALC:',&
1849	& mp_conccalc_time_total
1850	! NB: the 'flush' function is possibly a gfortran-specific extension
1851	call flush()
1852	end if
1853	end do
1854	end if
1855
1856	! j=mp_pid*nvar_async
1857	! In the implementation with 3 fields, the processes may have posted
1858	! MPI_Irecv requests that should be cancelled here
1859	!! :TODO:
1860	! if (.not.lmp_sync) then
1861	! r=mp_pid*nvar_async
1862	! do j=r,r+nvar_async-1
1863	! call MPI_Cancel(j,mp_ierr)
1864	! if (mp_ierr /= 0) write(,) '#### mpif_finalize::MPI_Cancel> ERROR ####'
1865	! end do
1866	! end if
1867
1868	call MPI_FINALIZE(mp_ierr)
1869	if (mp_ierr /= 0) then
1870	write(,) '#### mpif_finalize::MPI_FINALIZE> ERROR ####'
1871	stop
1872	end if
1873
1874
1875	end subroutine mpif_finalize
1876
1877
1878	subroutine get_lun(my_lun)
1879	!***********************************************************************
1880	! get_lun:
1881	! Starting from 100, get next free logical unit number
1882	!***********************************************************************
1883
1884	implicit none
1885
1886	integer, intent(inout) :: my_lun
1887	integer, save :: free_lun=100
1888	logical :: exists, iopen
1889
1890	loop1: do
1891	inquire(UNIT=free_lun, EXIST=exists, OPENED=iopen)
1892	if (exists .and. .not.iopen) exit loop1
1893	free_lun = free_lun+1
1894	end do loop1
1895	my_lun = free_lun
1896
1897	end subroutine get_lun
1898
1899
1900	subroutine write_data_dbg(array_in, array_name, tstep, ident)
1901	!***********************************************************************
1902	! Write one-dimensional arrays to disk (for debugging purposes)
1903	!***********************************************************************
1904	implicit none
1905
1906	real, intent(in), dimension(:) :: array_in
1907	integer, intent(in) :: tstep
1908	integer :: lios
1909	character(LEN=*), intent(in) :: ident, array_name
1910
1911	character(LEN=8) :: c_ts
1912	character(LEN=40) :: fn_1, fn_2
1913
1914	write(c_ts, FMT='(I8.8,BZ)') tstep
1915	fn_1='-'//trim(adjustl(c_ts))//'-'//trim(ident)
1916	write(c_ts, FMT='(I2.2,BZ)') mp_np
1917	fn_2= trim(adjustl(array_name))//trim(adjustl(fn_1))//'-np'//trim(adjustl(c_ts))//'.dat'
1918
1919	call get_lun(dat_lun)
1920	open(UNIT=dat_lun, FILE=fn_2, IOSTAT=lios, ACTION='WRITE', &
1921	FORM='UNFORMATTED', STATUS='REPLACE')
1922	write(UNIT=dat_lun, IOSTAT=lios) array_in
1923	close(UNIT=dat_lun)
1924
1925	end subroutine write_data_dbg
1926
1927
1928	end module mpi_mod

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

Download in other formats:

Original Format