Home

Context Navigation

pmc_mpi_wrapper_mod.f90 @ 4869

Last change on this file since 4869 was 4828, checked in by Giersch, 4 years ago
Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code
Property svn:keywords set to `Id`
File size: 24.8 KB

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

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

Context Navigation

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

Download in other formats: