Home

Context Navigation

source: palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90 @ 1903

Last change on this file since 1903 was 1901, checked in by raasch, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 18.8 KB

Line
1	MODULE pmc_mpi_wrapper
2
3	!--------------------------------------------------------------------------------!
4	! This file is part of PALM.
5	!
6	! PALM is free software: you can redistribute it and/or modify it under the terms
7	! of the GNU General Public License as published by the Free Software Foundation,
8	! either version 3 of the License, or (at your option) any later version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 1997-2016 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_mpi_wrapper_mod.f90 1901 2016-05-04 15:39:38Z suehring $
27	!
28	! 1900 2016-05-04 15:27:53Z raasch
29	! re-formatted to match PALM style
30	!
31	! 1850 2016-04-08 13:29:27Z maronga
32	! Module renamed
33	!
34	!
35	! 1808 2016-04-05 19:44:00Z raasch
36	! MPI module used by default on all machines
37	!
38	! 1779 2016-03-03 08:01:28Z raasch
39	! kind=dp replaced by wp
40	!
41	! 1764 2016-02-28 12:45:19Z raasch
42	! cpp-statement added (nesting can only be used in parallel mode),
43	! kind-parameters adjusted to PALM-kinds
44	!
45	! 1762 2016-02-25 12:31:13Z hellstea
46	! Initial revision by K. Ketelsen
47	!
48	! Description:
49	! ------------
50	!
51	! MPI Wrapper of Palm Model Coupler
52	!------------------------------------------------------------------------------!
53
54	#if defined( __parallel )
55	USE, INTRINSIC :: ISO_C_BINDING
56
57	#if defined( __mpifh )
58	INCLUDE "mpif.h"
59	#else
60	USE MPI
61	#endif
62
63	USE kinds
64	USE pmc_handle_communicator, &
65	ONLY: m_model_comm, m_model_rank, m_to_server_comm, m_to_client_comm
66
67	IMPLICIT NONE
68
69	PRIVATE
70	SAVE
71
72	INTERFACE pmc_send_to_server
73	MODULE PROCEDURE pmc_send_to_server_integer
74	MODULE PROCEDURE pmc_send_to_server_integer_2
75	MODULE PROCEDURE pmc_send_to_server_real_r1
76	MODULE PROCEDURE pmc_send_to_server_real_r2
77	MODULE PROCEDURE pmc_send_to_server_real_r3
78	END INTERFACE pmc_send_to_server
79
80	INTERFACE pmc_recv_from_server
81	MODULE PROCEDURE pmc_recv_from_server_integer
82	MODULE PROCEDURE pmc_recv_from_server_real_r1
83	MODULE PROCEDURE pmc_recv_from_server_real_r2
84	MODULE PROCEDURE pmc_recv_from_server_real_r3
85	END INTERFACE pmc_recv_from_server
86
87	INTERFACE pmc_send_to_client
88	MODULE PROCEDURE pmc_send_to_client_integer
89	MODULE PROCEDURE pmc_send_to_client_real_r1
90	MODULE PROCEDURE pmc_send_to_client_real_r2
91	MODULE PROCEDURE pmc_send_to_client_real_r3
92	END INTERFACE pmc_send_to_client
93
94	INTERFACE pmc_recv_from_client
95	MODULE PROCEDURE pmc_recv_from_client_integer
96	MODULE PROCEDURE pmc_recv_from_client_integer_2
97	MODULE PROCEDURE pmc_recv_from_client_real_r1
98	MODULE PROCEDURE pmc_recv_from_client_real_r2
99	MODULE PROCEDURE pmc_recv_from_client_real_r3
100	END INTERFACE pmc_recv_from_client
101
102	INTERFACE pmc_bcast
103	MODULE PROCEDURE pmc_bcast_integer
104	MODULE PROCEDURE pmc_bcast_character
105	END INTERFACE pmc_bcast
106
107	INTERFACE pmc_inter_bcast
108	MODULE PROCEDURE pmc_inter_bcast_integer_1
109	END INTERFACE pmc_inter_bcast
110
111	INTERFACE pmc_alloc_mem
112	MODULE PROCEDURE pmc_alloc_mem_integer_1
113	MODULE PROCEDURE pmc_alloc_mem_Real_1
114	END INTERFACE pmc_alloc_mem
115
116	INTERFACE pmc_time
117	MODULE PROCEDURE pmc_time
118	END INTERFACE pmc_time
119
120	PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_client, &
121	pmc_recv_from_server, pmc_send_to_client, pmc_send_to_server, &
122	pmc_time
123
124	CONTAINS
125
126
127	SUBROUTINE pmc_send_to_server_integer( buf, n, server_rank, tag, ierr )
128
129	IMPLICIT NONE
130
131	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
132	INTEGER, INTENT(IN) :: n !<
133	INTEGER, INTENT(IN) :: server_rank !<
134	INTEGER, INTENT(IN) :: tag !<
135	INTEGER, INTENT(OUT) :: ierr !<
136
137	ierr = 0
138	CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
139	ierr)
140
141	END SUBROUTINE pmc_send_to_server_integer
142
143
144
145	SUBROUTINE pmc_recv_from_server_integer( buf, n, server_rank, tag, ierr )
146
147	IMPLICIT NONE
148
149	INTEGER, DIMENSION(:), INTENT(OUT) :: buf !<
150	INTEGER, INTENT(IN) :: n !<
151	INTEGER, INTENT(IN) :: server_rank !<
152	INTEGER, INTENT(IN) :: tag !<
153	INTEGER, INTENT(OUT) :: ierr !<
154
155	ierr = 0
156	CALL MPI_RECV( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
157	MPI_STATUS_IGNORE, ierr )
158
159	END SUBROUTINE pmc_recv_from_server_integer
160
161
162
163	SUBROUTINE pmc_send_to_server_integer_2( buf, n, server_rank, tag, ierr )
164
165	IMPLICIT NONE
166
167	INTEGER, DIMENSION(:,:), INTENT(IN) :: buf !<
168	INTEGER, INTENT(IN) :: n !<
169	INTEGER, INTENT(IN) :: server_rank !<
170	INTEGER, INTENT(IN) :: tag !<
171	INTEGER, INTENT(OUT) :: ierr !<
172
173	ierr = 0
174	CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
175	ierr )
176
177	END SUBROUTINE pmc_send_to_server_integer_2
178
179
180
181	SUBROUTINE pmc_send_to_server_real_r1( buf, n, server_rank, tag, ierr )
182
183	IMPLICIT NONE
184
185	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
186	INTEGER, INTENT(IN) :: n !<
187	INTEGER, INTENT(IN) :: server_rank !<
188	INTEGER, INTENT(IN) :: tag !<
189	INTEGER, INTENT(OUT) :: ierr !<
190
191	ierr = 0
192	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
193
194	END SUBROUTINE pmc_send_to_server_real_r1
195
196
197
198	SUBROUTINE pmc_recv_from_server_real_r1( buf, n, server_rank, tag, ierr )
199
200	IMPLICIT NONE
201
202	REAL(wp), DIMENSION(:), INTENT(OUT) :: buf !<
203	INTEGER, INTENT(IN) :: n !<
204	INTEGER, INTENT(IN) :: server_rank !<
205	INTEGER, INTENT(IN) :: tag !<
206	INTEGER, INTENT(OUT) :: ierr !<
207
208	ierr = 0
209	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
210	MPI_STATUS_IGNORE, ierr )
211
212	END SUBROUTINE pmc_recv_from_server_real_r1
213
214
215
216	SUBROUTINE pmc_send_to_server_real_r2( buf, n, server_rank, tag, ierr )
217
218	IMPLICIT NONE
219
220	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
221	INTEGER, INTENT(IN) :: n !<
222	INTEGER, INTENT(IN) :: server_rank !<
223	INTEGER, INTENT(IN) :: tag !<
224	INTEGER, INTENT(OUT) :: ierr !<
225
226	ierr = 0
227	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
228
229	END SUBROUTINE pmc_send_to_server_real_r2
230
231
232	SUBROUTINE pmc_recv_from_server_real_r2( buf, n, server_rank, tag, ierr )
233
234	IMPLICIT NONE
235
236	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
237	INTEGER, INTENT(IN) :: n !<
238	INTEGER, INTENT(IN) :: server_rank !<
239	INTEGER, INTENT(IN) :: tag !<
240	INTEGER, INTENT(OUT) :: ierr !<
241
242	ierr = 0
243	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
244	MPI_STATUS_IGNORE, ierr )
245
246	END SUBROUTINE pmc_recv_from_server_real_r2
247
248
249
250	SUBROUTINE pmc_send_to_server_real_r3( buf, n, server_rank, tag, ierr )
251
252	IMPLICIT NONE
253
254	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
255	INTEGER, INTENT(IN) :: n !<
256	INTEGER, INTENT(IN) :: server_rank !<
257	INTEGER, INTENT(IN) :: tag !<
258	INTEGER, INTENT(OUT) :: ierr !<
259
260	ierr = 0
261	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
262
263	END SUBROUTINE pmc_send_to_server_real_r3
264
265
266
267	SUBROUTINE pmc_recv_from_server_real_r3( buf, n, server_rank, tag, ierr )
268
269	IMPLICIT NONE
270
271	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
272	INTEGER, INTENT(IN) :: n !<
273	INTEGER, INTENT(IN) :: server_rank !<
274	INTEGER, INTENT(IN) :: tag !<
275	INTEGER, INTENT(OUT) :: ierr !<
276
277	ierr = 0
278	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
279	MPI_STATUS_IGNORE, ierr )
280
281	END SUBROUTINE pmc_recv_from_server_real_r3
282
283
284
285	SUBROUTINE pmc_send_to_client_integer( client_id, buf, n, client_rank, tag, &
286	ierr )
287
288	IMPLICIT NONE
289
290	INTEGER, INTENT(IN) :: client_id !<
291	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
292	INTEGER, INTENT(IN) :: n !<
293	INTEGER, INTENT(IN) :: client_rank !<
294	INTEGER, INTENT(IN) :: tag !<
295	INTEGER, INTENT(OUT) :: ierr !<
296
297	ierr = 0
298	CALL MPI_SEND( buf, n, MPI_INTEGER, client_rank, tag, &
299	m_to_client_comm(client_id), ierr )
300
301	END SUBROUTINE pmc_send_to_client_integer
302
303
304
305	SUBROUTINE pmc_recv_from_client_integer( client_id, buf, n, client_rank, tag, &
306	ierr )
307
308	IMPLICIT NONE
309
310	INTEGER, INTENT(IN) :: client_id !<
311	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf !<
312	INTEGER, INTENT(IN) :: n !<
313	INTEGER, INTENT(IN) :: client_rank !<
314	INTEGER, INTENT(IN) :: tag !<
315	INTEGER, INTENT(OUT) :: ierr !<
316
317	ierr = 0
318	CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag, &
319	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
320
321	END SUBROUTINE pmc_recv_from_client_integer
322
323
324
325	SUBROUTINE pmc_recv_from_client_integer_2( client_id, buf, n, client_rank, &
326	tag, ierr )
327
328	IMPLICIT NONE
329
330	INTEGER, INTENT(IN) :: client_id !<
331	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf !<
332	INTEGER, INTENT(IN) :: n !<
333	INTEGER, INTENT(IN) :: client_rank !<
334	INTEGER, INTENT(IN) :: tag !<
335	INTEGER, INTENT(OUT) :: ierr !<
336
337	ierr = 0
338	CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag, &
339	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
340
341	END SUBROUTINE pmc_recv_from_client_integer_2
342
343
344
345	SUBROUTINE pmc_send_to_client_real_r1( client_id, buf, n, client_rank, tag, &
346	ierr )
347
348	IMPLICIT NONE
349
350	INTEGER, INTENT(IN) :: client_id !<
351	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
352	INTEGER, INTENT(IN) :: n !<
353	INTEGER, INTENT(IN) :: client_rank !<
354	INTEGER, INTENT(IN) :: tag !<
355	INTEGER, INTENT(OUT) :: ierr !<
356
357	ierr = 0
358	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
359	m_to_client_comm(client_id), ierr )
360
361	END SUBROUTINE pmc_send_to_client_real_r1
362
363
364
365	SUBROUTINE pmc_recv_from_client_real_r1( client_id, buf, n, client_rank, tag, &
366	ierr )
367
368	IMPLICIT NONE
369
370	INTEGER, INTENT(IN) :: client_id !<
371	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf !<
372	INTEGER, INTENT(IN) :: n !<
373	INTEGER, INTENT(IN) :: client_rank !<
374	INTEGER, INTENT(IN) :: tag !<
375	INTEGER, INTENT(OUT) :: ierr !<
376
377	ierr = 0
378	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
379	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
380
381	END SUBROUTINE pmc_recv_from_client_real_r1
382
383
384
385	SUBROUTINE pmc_send_to_client_real_r2( client_id, buf, n, client_rank, tag, &
386	ierr )
387
388	IMPLICIT NONE
389
390	INTEGER, INTENT(IN) :: client_id !<
391	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
392	INTEGER, INTENT(IN) :: n !<
393	INTEGER, INTENT(IN) :: client_rank !<
394	INTEGER, INTENT(IN) :: tag !<
395	INTEGER, INTENT(OUT) :: ierr !<
396
397	ierr = 0
398	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
399	m_to_client_comm(client_id), ierr )
400
401	END SUBROUTINE pmc_send_to_client_real_r2
402
403
404
405	SUBROUTINE pmc_recv_from_client_real_r2( client_id, buf, n, client_rank, tag, &
406	ierr )
407
408	IMPLICIT NONE
409
410	INTEGER, INTENT(IN) :: client_id !<
411	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
412	INTEGER, INTENT(IN) :: n !<
413	INTEGER, INTENT(IN) :: client_rank !<
414	INTEGER, INTENT(IN) :: tag !<
415	INTEGER, INTENT(OUT) :: ierr !<
416
417	ierr = 0
418	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
419	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
420
421	END SUBROUTINE pmc_recv_from_client_real_r2
422
423
424
425	SUBROUTINE pmc_send_to_client_real_r3( client_id, buf, n, client_rank, tag, &
426	ierr)
427
428	IMPLICIT NONE
429
430	INTEGER, INTENT(IN) :: client_id !<
431	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
432	INTEGER, INTENT(IN) :: n !<
433	INTEGER, INTENT(IN) :: client_rank !<
434	INTEGER, INTENT(IN) :: tag !<
435	INTEGER, INTENT(OUT) :: ierr !<
436
437	ierr = 0
438	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
439	m_to_client_comm(client_id), ierr )
440
441	END SUBROUTINE pmc_send_to_client_real_r3
442
443
444
445	SUBROUTINE pmc_recv_from_client_real_r3( client_id, buf, n, client_rank, tag, &
446	ierr )
447
448	IMPLICIT NONE
449
450	INTEGER, INTENT(IN) :: client_id !<
451	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
452	INTEGER, INTENT(IN) :: n !<
453	INTEGER, INTENT(IN) :: client_rank !<
454	INTEGER, INTENT(IN) :: tag !<
455	INTEGER, INTENT(OUT) :: ierr !<
456
457	ierr = 0
458	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
459	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
460
461	END SUBROUTINE pmc_recv_from_client_real_r3
462
463
464
465	SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
466
467	IMPLICIT NONE
468
469	INTEGER, INTENT(INOUT) :: buf !<
470	INTEGER, INTENT(IN) :: root_pe !<
471	INTEGER, INTENT(IN), OPTIONAL :: comm !<
472	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
473
474	INTEGER :: mycomm !<
475	INTEGER :: myerr !<
476
477
478	IF ( PRESENT( comm ) ) THEN
479	mycomm = comm
480	ELSE
481	mycomm = m_model_comm
482	ENDIF
483
484	CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
485
486	IF ( PRESENT( ierr ) ) THEN
487	ierr = myerr
488	ENDIF
489
490	END SUBROUTINE pmc_bcast_integer
491
492
493
494	SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
495
496	IMPLICIT NONE
497
498	CHARACTER(LEN=*), INTENT(INOUT) :: buf !<
499	INTEGER, INTENT(IN) :: root_pe !<
500	INTEGER, INTENT(IN), OPTIONAL :: comm !<
501	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
502
503	INTEGER :: mycomm !<
504	INTEGER :: myerr !<
505
506	IF ( PRESENT( comm ) ) THEN
507	mycomm = comm
508	ELSE
509	mycomm = m_model_comm
510	ENDIF
511
512	CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
513
514	IF ( PRESENT( ierr ) ) THEN
515	ierr = myerr
516	ENDIF
517
518	END SUBROUTINE pmc_bcast_character
519
520
521
522	SUBROUTINE pmc_inter_bcast_integer_1( buf, client_id, ierr )
523
524	IMPLICIT NONE
525
526	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf !<
527	INTEGER, INTENT(IN),optional :: client_id !<
528	INTEGER, INTENT(OUT),optional :: ierr !<
529
530	INTEGER :: mycomm !<
531	INTEGER :: myerr !<
532	INTEGER :: root_pe !<
533
534	!
535	!-- PE 0 server broadcast to all client PEs
536	IF ( PRESENT( client_id ) ) THEN
537
538	mycomm = m_to_client_comm(client_id)
539
540	IF ( m_model_rank == 0 ) THEN
541	root_pe = MPI_ROOT
542	ELSE
543	root_pe = MPI_PROC_NULL
544	ENDIF
545
546	ELSE
547	mycomm = m_to_server_comm
548	root_pe = 0
549	ENDIF
550
551	CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
552
553	IF ( PRESENT( ierr ) ) THEN
554	ierr = myerr
555	ENDIF
556
557	END SUBROUTINE pmc_inter_bcast_integer_1
558
559
560
561	SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
562	!
563	!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
564
565	IMPLICIT NONE
566
567	INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) :: iarray !<
568	INTEGER, INTENT(IN) :: idim1 !<
569
570	INTEGER, DIMENSION(1) :: ashape !<
571	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
572	INTEGER :: ierr !<
573
574	TYPE(C_PTR) :: p_myind !<
575
576	winsize = idim1 * C_SIZEOF( ierr )
577
578	CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
579	ashape(1) = idim1
580	CALL C_F_POINTER( p_myind, iarray, ashape )
581
582	END SUBROUTINE pmc_alloc_mem_integer_1
583
584
585
586	SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
587
588	IMPLICIT NONE
589
590	INTEGER(idp), INTENT(IN) :: idim1 !<
591	REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) :: array !<
592	TYPE(C_PTR), INTENT(OUT), OPTIONAL :: base_ptr !<
593
594	INTEGER, DIMENSION(1) :: ashape !<
595	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
596	INTEGER :: ierr !<
597
598	TYPE(C_PTR) :: p_myind !<
599
600	winsize = idim1 * wp
601
602	CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
603	ashape(1) = idim1
604	CALL C_F_POINTER( p_myind, array, ashape )
605
606	IF ( PRESENT( base_ptr ) ) THEN
607	base_ptr = p_myind
608	ENDIF
609
610	END SUBROUTINE pmc_alloc_mem_Real_1
611
612
613
614	FUNCTION pmc_time()
615
616	REAL(kind=wp) :: pmc_time !<
617
618	pmc_time = MPI_WTIME()
619
620	END FUNCTION pmc_time
621
622	#endif
623	END MODULE pmc_mpi_wrapper

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |