Home

Context Navigation

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

Last change on this file since 4646 was 4629, checked in by raasch, 4 years ago
support for MPI Fortran77 interface (mpif.h) removed
Property svn:keywords set to `Id`
File size: 20.0 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |