Home

Context Navigation

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

Last change on this file since 4592 was 4360, checked in by suehring, 5 years ago
Bugfix in output of time-averaged plant-canopy quanities; Output of plant-canopy data only where tall canopy is defined; land-surface model: fix wrong location strings; tests: update urban test case; all source code files: copyright update
Property svn:keywords set to `Id`
File size: 20.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-2020 Leibniz Universitaet Hannover
19	!------------------------------------------------------------------------------!
20	!
21	! Current revisions:
22	! ------------------
23	!
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: pmc_mpi_wrapper_mod.f90 4360 2020-01-07 11:25:50Z raasch $
28	! Corrected "Former revisions" section
29	!
30	! 3655 2019-01-07 16:51:22Z knoop
31	! Extent interface by logical buffer
32	!
33	! 1762 2016-02-25 12:31:13Z hellstea
34	! Initial revision by K. Ketelsen
35	!
36	! Description:
37	! ------------
38	!
39	! MPI Wrapper of Palm Model Coupler
40	!-------------------------------------------------------------------------------!
41
42	#if defined( __parallel )
43	USE, INTRINSIC :: ISO_C_BINDING
44
45	#if !defined( __mpifh )
46	USE MPI
47	#endif
48
49	USE kinds
50	USE pmc_handle_communicator, &
51	ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
52
53	IMPLICIT NONE
54
55	#if defined( __mpifh )
56	INCLUDE "mpif.h"
57	#endif
58
59	PRIVATE
60	SAVE
61
62	INTERFACE pmc_send_to_parent
63	MODULE PROCEDURE pmc_send_to_parent_integer
64	MODULE PROCEDURE pmc_send_to_parent_integer_2
65	MODULE PROCEDURE pmc_send_to_parent_real_r1
66	MODULE PROCEDURE pmc_send_to_parent_real_r2
67	MODULE PROCEDURE pmc_send_to_parent_real_r3
68	END INTERFACE pmc_send_to_parent
69
70	INTERFACE pmc_recv_from_parent
71	MODULE PROCEDURE pmc_recv_from_parent_logical
72	MODULE PROCEDURE pmc_recv_from_parent_integer
73	MODULE PROCEDURE pmc_recv_from_parent_real_r1
74	MODULE PROCEDURE pmc_recv_from_parent_real_r2
75	MODULE PROCEDURE pmc_recv_from_parent_real_r3
76	END INTERFACE pmc_recv_from_parent
77
78	INTERFACE pmc_send_to_child
79	MODULE PROCEDURE pmc_send_to_child_logical
80	MODULE PROCEDURE pmc_send_to_child_integer
81	MODULE PROCEDURE pmc_send_to_child_real_r1
82	MODULE PROCEDURE pmc_send_to_child_real_r2
83	MODULE PROCEDURE pmc_send_to_child_real_r3
84	END INTERFACE pmc_send_to_child
85
86	INTERFACE pmc_recv_from_child
87	MODULE PROCEDURE pmc_recv_from_child_integer
88	MODULE PROCEDURE pmc_recv_from_child_integer_2
89	MODULE PROCEDURE pmc_recv_from_child_real_r1
90	MODULE PROCEDURE pmc_recv_from_child_real_r2
91	MODULE PROCEDURE pmc_recv_from_child_real_r3
92	END INTERFACE pmc_recv_from_child
93
94	INTERFACE pmc_bcast
95	MODULE PROCEDURE pmc_bcast_integer
96	MODULE PROCEDURE pmc_bcast_character
97	END INTERFACE pmc_bcast
98
99	INTERFACE pmc_inter_bcast
100	MODULE PROCEDURE pmc_inter_bcast_integer_1
101	END INTERFACE pmc_inter_bcast
102
103	INTERFACE pmc_alloc_mem
104	MODULE PROCEDURE pmc_alloc_mem_integer_1
105	MODULE PROCEDURE pmc_alloc_mem_Real_1
106	END INTERFACE pmc_alloc_mem
107
108	INTERFACE pmc_time
109	MODULE PROCEDURE pmc_time
110	END INTERFACE pmc_time
111
112	PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_child, &
113	pmc_recv_from_parent, pmc_send_to_child, pmc_send_to_parent, &
114	pmc_time
115
116	CONTAINS
117
118
119	SUBROUTINE pmc_recv_from_parent_logical( buf, n, parent_rank, tag, ierr )
120
121	IMPLICIT NONE
122
123	INTEGER, INTENT(IN) :: n !<
124	INTEGER, INTENT(IN) :: parent_rank !<
125	INTEGER, INTENT(IN) :: tag !<
126	INTEGER, INTENT(OUT) :: ierr !<
127
128	LOGICAL, INTENT(OUT) :: buf !<
129
130	ierr = 0
131	CALL MPI_RECV( buf, n, MPI_LOGICAL, parent_rank, tag, m_to_parent_comm, &
132	MPI_STATUS_IGNORE, ierr )
133
134	END SUBROUTINE pmc_recv_from_parent_logical
135
136	SUBROUTINE pmc_send_to_child_logical( child_id, buf, n, child_rank, tag, &
137	ierr )
138
139	IMPLICIT NONE
140
141	INTEGER, INTENT(IN) :: child_id !<
142	INTEGER, INTENT(IN) :: n !<
143	INTEGER, INTENT(IN) :: child_rank !<
144	INTEGER, INTENT(IN) :: tag !<
145	INTEGER, INTENT(OUT) :: ierr !<
146
147	LOGICAL, INTENT(IN) :: buf !<
148
149	ierr = 0
150	CALL MPI_SEND( buf, n, MPI_LOGICAL, child_rank, tag, &
151	m_to_child_comm(child_id), ierr )
152
153	END SUBROUTINE pmc_send_to_child_logical
154
155
156	SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
157
158	IMPLICIT NONE
159
160	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
161	INTEGER, INTENT(IN) :: n !<
162	INTEGER, INTENT(IN) :: parent_rank !<
163	INTEGER, INTENT(IN) :: tag !<
164	INTEGER, INTENT(OUT) :: ierr !<
165
166
167	ierr = 0
168	CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, &
169	ierr )
170
171	END SUBROUTINE pmc_send_to_parent_integer
172
173
174	SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
175
176	IMPLICIT NONE
177
178	INTEGER, DIMENSION(:), INTENT(OUT) :: buf !<
179	INTEGER, INTENT(IN) :: n !<
180	INTEGER, INTENT(IN) :: parent_rank !<
181	INTEGER, INTENT(IN) :: tag !<
182	INTEGER, INTENT(OUT) :: ierr !<
183
184
185	ierr = 0
186	CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, &
187	MPI_STATUS_IGNORE, ierr )
188
189	END SUBROUTINE pmc_recv_from_parent_integer
190
191
192
193	SUBROUTINE pmc_send_to_parent_integer_2( 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_2
209
210
211
212	SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
213
214	IMPLICIT NONE
215
216	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
217	INTEGER, INTENT(IN) :: n !<
218	INTEGER, INTENT(IN) :: parent_rank !<
219	INTEGER, INTENT(IN) :: tag !<
220	INTEGER, INTENT(OUT) :: ierr !<
221
222
223	ierr = 0
224	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
225
226	END SUBROUTINE pmc_send_to_parent_real_r1
227
228
229
230	SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
231
232	IMPLICIT NONE
233
234	REAL(wp), DIMENSION(:), INTENT(OUT) :: 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_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, &
243	MPI_STATUS_IGNORE, ierr )
244
245	END SUBROUTINE pmc_recv_from_parent_real_r1
246
247
248
249	SUBROUTINE pmc_send_to_parent_real_r2( 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_r2
264
265
266	SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
267
268	IMPLICIT NONE
269
270	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
271	INTEGER, INTENT(IN) :: n !<
272	INTEGER, INTENT(IN) :: parent_rank !<
273	INTEGER, INTENT(IN) :: tag !<
274	INTEGER, INTENT(OUT) :: ierr !<
275
276	ierr = 0
277	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, &
278	MPI_STATUS_IGNORE, ierr )
279
280	END SUBROUTINE pmc_recv_from_parent_real_r2
281
282
283
284	SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
285
286	IMPLICIT NONE
287
288	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
289	INTEGER, INTENT(IN) :: n !<
290	INTEGER, INTENT(IN) :: parent_rank !<
291	INTEGER, INTENT(IN) :: tag !<
292	INTEGER, INTENT(OUT) :: ierr !<
293
294
295	ierr = 0
296	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
297
298	END SUBROUTINE pmc_send_to_parent_real_r3
299
300
301
302	SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
303
304	IMPLICIT NONE
305
306	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
307	INTEGER, INTENT(IN) :: n !<
308	INTEGER, INTENT(IN) :: parent_rank !<
309	INTEGER, INTENT(IN) :: tag !<
310	INTEGER, INTENT(OUT) :: ierr !<
311
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_r3
318
319
320	SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag, &
321	ierr )
322
323	IMPLICIT NONE
324
325	INTEGER, INTENT(IN) :: child_id !<
326	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
327	INTEGER, INTENT(IN) :: n !<
328	INTEGER, INTENT(IN) :: child_rank !<
329	INTEGER, INTENT(IN) :: tag !<
330	INTEGER, INTENT(OUT) :: ierr !<
331
332
333	ierr = 0
334	CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag, &
335	m_to_child_comm(child_id), ierr )
336
337	END SUBROUTINE pmc_send_to_child_integer
338
339
340
341	SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag, &
342	ierr )
343
344	IMPLICIT NONE
345
346	INTEGER, INTENT(IN) :: child_id !<
347	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf !<
348	INTEGER, INTENT(IN) :: n !<
349	INTEGER, INTENT(IN) :: child_rank !<
350	INTEGER, INTENT(IN) :: tag !<
351	INTEGER, INTENT(OUT) :: ierr !<
352
353
354	ierr = 0
355	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, &
356	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
357
358	END SUBROUTINE pmc_recv_from_child_integer
359
360
361
362	SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank, &
363	tag, ierr )
364
365	IMPLICIT NONE
366
367	INTEGER, INTENT(IN) :: child_id !<
368	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf !<
369	INTEGER, INTENT(IN) :: n !<
370	INTEGER, INTENT(IN) :: child_rank !<
371	INTEGER, INTENT(IN) :: tag !<
372	INTEGER, INTENT(OUT) :: ierr !<
373
374
375	ierr = 0
376	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, &
377	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
378
379	END SUBROUTINE pmc_recv_from_child_integer_2
380
381
382
383	SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag, &
384	ierr )
385
386	IMPLICIT NONE
387
388	INTEGER, INTENT(IN) :: child_id !<
389	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
390	INTEGER, INTENT(IN) :: n !<
391	INTEGER, INTENT(IN) :: child_rank !<
392	INTEGER, INTENT(IN) :: tag !<
393	INTEGER, INTENT(OUT) :: ierr !<
394
395
396	ierr = 0
397	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
398	m_to_child_comm(child_id), ierr )
399
400	END SUBROUTINE pmc_send_to_child_real_r1
401
402
403
404	SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag, &
405	ierr )
406
407	IMPLICIT NONE
408
409	INTEGER, INTENT(IN) :: child_id !<
410	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf !<
411	INTEGER, INTENT(IN) :: n !<
412	INTEGER, INTENT(IN) :: child_rank !<
413	INTEGER, INTENT(IN) :: tag !<
414	INTEGER, INTENT(OUT) :: ierr !<
415
416
417	ierr = 0
418	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
419	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
420
421	END SUBROUTINE pmc_recv_from_child_real_r1
422
423
424
425	SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag, &
426	ierr )
427
428	IMPLICIT NONE
429
430	INTEGER, INTENT(IN) :: child_id !<
431	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
432	INTEGER, INTENT(IN) :: n !<
433	INTEGER, INTENT(IN) :: child_rank !<
434	INTEGER, INTENT(IN) :: tag !<
435	INTEGER, INTENT(OUT) :: ierr !<
436
437
438	ierr = 0
439	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
440	m_to_child_comm(child_id), ierr )
441
442	END SUBROUTINE pmc_send_to_child_real_r2
443
444
445
446	SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag, &
447	ierr )
448
449	IMPLICIT NONE
450
451	INTEGER, INTENT(IN) :: child_id !<
452	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
453	INTEGER, INTENT(IN) :: n !<
454	INTEGER, INTENT(IN) :: child_rank !<
455	INTEGER, INTENT(IN) :: tag !<
456	INTEGER, INTENT(OUT) :: ierr !<
457
458
459	ierr = 0
460	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
461	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
462
463	END SUBROUTINE pmc_recv_from_child_real_r2
464
465
466
467	SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag, &
468	ierr )
469
470	IMPLICIT NONE
471
472	INTEGER, INTENT(IN) :: child_id !<
473	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
474	INTEGER, INTENT(IN) :: n !<
475	INTEGER, INTENT(IN) :: child_rank !<
476	INTEGER, INTENT(IN) :: tag !<
477	INTEGER, INTENT(OUT) :: ierr !<
478
479
480	ierr = 0
481	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
482	m_to_child_comm(child_id), ierr )
483
484	END SUBROUTINE pmc_send_to_child_real_r3
485
486
487
488	SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag, &
489	ierr )
490
491	IMPLICIT NONE
492
493	INTEGER, INTENT(IN) :: child_id !<
494	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
495	INTEGER, INTENT(IN) :: n !<
496	INTEGER, INTENT(IN) :: child_rank !<
497	INTEGER, INTENT(IN) :: tag !<
498	INTEGER, INTENT(OUT) :: ierr !<
499
500
501	ierr = 0
502	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
503	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
504
505	END SUBROUTINE pmc_recv_from_child_real_r3
506
507
508
509	SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
510
511	IMPLICIT NONE
512
513	INTEGER, INTENT(INOUT) :: buf !<
514	INTEGER, INTENT(IN) :: root_pe !<
515	INTEGER, INTENT(IN), OPTIONAL :: comm !<
516	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
517
518	INTEGER :: mycomm !<
519	INTEGER :: myerr !<
520
521
522	IF ( PRESENT( comm ) ) THEN
523	mycomm = comm
524	ELSE
525	mycomm = m_model_comm
526	ENDIF
527
528	CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
529
530	IF ( PRESENT( ierr ) ) THEN
531	ierr = myerr
532	ENDIF
533
534	END SUBROUTINE pmc_bcast_integer
535
536
537
538	SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
539
540	IMPLICIT NONE
541
542	CHARACTER(LEN=*), INTENT(INOUT) :: buf !<
543	INTEGER, INTENT(IN) :: root_pe !<
544	INTEGER, INTENT(IN), OPTIONAL :: comm !<
545	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
546
547	INTEGER :: mycomm !<
548	INTEGER :: myerr !<
549
550
551	IF ( PRESENT( comm ) ) THEN
552	mycomm = comm
553	ELSE
554	mycomm = m_model_comm
555	ENDIF
556
557	CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
558
559	IF ( PRESENT( ierr ) ) THEN
560	ierr = myerr
561	ENDIF
562
563	END SUBROUTINE pmc_bcast_character
564
565
566
567	SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
568
569	IMPLICIT NONE
570
571	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf !<
572	INTEGER, INTENT(IN),optional :: child_id !<
573	INTEGER, INTENT(OUT),optional :: ierr !<
574
575	INTEGER :: mycomm !<
576	INTEGER :: myerr !<
577	INTEGER :: root_pe !<
578
579	!
580	!-- Process 0 on parent broadcast to all child processes
581	IF ( PRESENT( child_id ) ) THEN
582
583	mycomm = m_to_child_comm(child_id)
584
585	IF ( m_model_rank == 0 ) THEN
586	root_pe = MPI_ROOT
587	ELSE
588	root_pe = MPI_PROC_NULL
589	ENDIF
590
591	ELSE
592	mycomm = m_to_parent_comm
593	root_pe = 0
594	ENDIF
595
596	CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
597
598	IF ( PRESENT( ierr ) ) THEN
599	ierr = myerr
600	ENDIF
601
602	END SUBROUTINE pmc_inter_bcast_integer_1
603
604
605
606	SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
607	!
608	!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
609
610	IMPLICIT NONE
611
612	INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) :: iarray !<
613	INTEGER, INTENT(IN) :: idim1 !<
614
615	INTEGER, DIMENSION(1) :: ashape !<
616	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
617	INTEGER :: ierr !<
618
619	TYPE(C_PTR) :: p_myind !<
620
621
622	winsize = idim1 * STORAGE_SIZE( ierr )/8
623
624	CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
625	ashape(1) = idim1
626	CALL C_F_POINTER( p_myind, iarray, ashape )
627
628	END SUBROUTINE pmc_alloc_mem_integer_1
629
630
631
632	SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
633
634	IMPLICIT NONE
635
636	INTEGER(idp), INTENT(IN) :: idim1 !<
637	REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) :: array !<
638	TYPE(C_PTR), INTENT(OUT), OPTIONAL :: base_ptr !<
639
640	INTEGER, DIMENSION(1) :: ashape !<
641	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
642	INTEGER :: ierr !<
643
644	TYPE(C_PTR) :: p_myind !<
645
646
647	winsize = idim1 * wp
648
649	CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
650	ashape(1) = idim1
651	CALL C_F_POINTER( p_myind, array, ashape )
652
653	IF ( PRESENT( base_ptr ) ) THEN
654	base_ptr = p_myind
655	ENDIF
656
657	END SUBROUTINE pmc_alloc_mem_Real_1
658
659
660
661	FUNCTION pmc_time()
662
663	REAL(kind=wp) :: pmc_time !<
664
665
666	pmc_time = MPI_WTIME()
667
668	END FUNCTION pmc_time
669
670	#endif
671	END MODULE pmc_mpi_wrapper

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |