Home

Context Navigation

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

Last change on this file since 3742 was 3655, checked in by knoop, 6 years ago
Bugfix: made "unit" and "found" intend INOUT in module interface subroutines + automatic copyright update
Property svn:keywords set to `Id`
File size: 21.0 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |