Home

Context Navigation

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

Last change on this file since 4590 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

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	! ------------------
[1851]	23	!
[2001]	24	!
[1762]	25	! Former revisions:
	26	! -----------------
	27	! $Id: pmc_mpi_wrapper_mod.f90 4360 2020-01-07 11:25:50Z suehring $
[4182]	28	! Corrected "Former revisions" section
	29	!
	30	! 3655 2019-01-07 16:51:22Z knoop
[2938]	31	! Extent interface by logical buffer
	32	!
[4182]	33	! 1762 2016-02-25 12:31:13Z hellstea
	34	! Initial revision by K. Ketelsen
[2716]	35	!
[1762]	36	! Description:
	37	! ------------
	38	!
	39	! MPI Wrapper of Palm Model Coupler
[1933]	40	!-------------------------------------------------------------------------------!
[1762]	41
[1764]	42	#if defined( __parallel )
[1900]	43	USE, INTRINSIC :: ISO_C_BINDING
[1762]	44
[2841]	45	#if !defined( __mpifh )
[1764]	46	USE MPI
	47	#endif
[1762]	48
[1900]	49	USE kinds
[1933]	50	USE pmc_handle_communicator, &
	51	ONLY: m_model_comm, m_model_rank, m_to_parent_comm, m_to_child_comm
[1762]	52
[1900]	53	IMPLICIT NONE
[1762]	54
[2841]	55	#if defined( __mpifh )
	56	INCLUDE "mpif.h"
	57	#endif
	58
[1900]	59	PRIVATE
	60	SAVE
[1762]	61
[1933]	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
[1762]	69
[1933]	70	INTERFACE pmc_recv_from_parent
[2938]	71	MODULE PROCEDURE pmc_recv_from_parent_logical
[1933]	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
[1762]	77
[1933]	78	INTERFACE pmc_send_to_child
[2938]	79	MODULE PROCEDURE pmc_send_to_child_logical
[1933]	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
[1762]	85
[1933]	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
[1762]	93
[1900]	94	INTERFACE pmc_bcast
	95	MODULE PROCEDURE pmc_bcast_integer
	96	MODULE PROCEDURE pmc_bcast_character
	97	END INTERFACE pmc_bcast
[1762]	98
[1900]	99	INTERFACE pmc_inter_bcast
	100	MODULE PROCEDURE pmc_inter_bcast_integer_1
	101	END INTERFACE pmc_inter_bcast
[1762]	102
[1900]	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
[1762]	107
[1900]	108	INTERFACE pmc_time
	109	MODULE PROCEDURE pmc_time
	110	END INTERFACE pmc_time
[1762]	111
[1933]	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, &
[1900]	114	pmc_time
[1762]	115
[1900]	116	CONTAINS
[1762]	117
	118
[2938]	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
[1933]	156	SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]	157
[1900]	158	IMPLICIT NONE
[1762]	159
[1900]	160	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	161	INTEGER, INTENT(IN) :: n !<
[1933]	162	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	163	INTEGER, INTENT(IN) :: tag !<
	164	INTEGER, INTENT(OUT) :: ierr !<
[1762]	165
[2599]	166
[1900]	167	ierr = 0
[1933]	168	CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, &
[2599]	169	ierr )
[1779]	170
[1933]	171	END SUBROUTINE pmc_send_to_parent_integer
[1762]	172
[1779]	173
[1933]	174	SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]	175
[1900]	176	IMPLICIT NONE
[1779]	177
[1900]	178	INTEGER, DIMENSION(:), INTENT(OUT) :: buf !<
	179	INTEGER, INTENT(IN) :: n !<
[1933]	180	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	181	INTEGER, INTENT(IN) :: tag !<
	182	INTEGER, INTENT(OUT) :: ierr !<
[1762]	183
[2599]	184
[1900]	185	ierr = 0
[1933]	186	CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, &
[1900]	187	MPI_STATUS_IGNORE, ierr )
[1779]	188
[1933]	189	END SUBROUTINE pmc_recv_from_parent_integer
[1762]	190
	191
[1779]	192
[1933]	193	SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
[1762]	194
[1900]	195	IMPLICIT NONE
[1779]	196
[1900]	197	INTEGER, DIMENSION(:,:), INTENT(IN) :: buf !<
	198	INTEGER, INTENT(IN) :: n !<
[1933]	199	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	200	INTEGER, INTENT(IN) :: tag !<
	201	INTEGER, INTENT(OUT) :: ierr !<
[1762]	202
[2599]	203
[1900]	204	ierr = 0
[1933]	205	CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, &
[1900]	206	ierr )
[1762]	207
[1933]	208	END SUBROUTINE pmc_send_to_parent_integer_2
[1779]	209
[1762]	210
[1779]	211
[1933]	212	SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1762]	213
[1900]	214	IMPLICIT NONE
[1762]	215
[1900]	216	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	217	INTEGER, INTENT(IN) :: n !<
[1933]	218	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	219	INTEGER, INTENT(IN) :: tag !<
	220	INTEGER, INTENT(OUT) :: ierr !<
[1779]	221
[2599]	222
[1900]	223	ierr = 0
[1933]	224	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	225
[1933]	226	END SUBROUTINE pmc_send_to_parent_real_r1
[1779]	227
[1762]	228
	229
[1933]	230	SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1779]	231
[1900]	232	IMPLICIT NONE
[1762]	233
[1900]	234	REAL(wp), DIMENSION(:), INTENT(OUT) :: buf !<
	235	INTEGER, INTENT(IN) :: n !<
[1933]	236	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	237	INTEGER, INTENT(IN) :: tag !<
	238	INTEGER, INTENT(OUT) :: ierr !<
[1779]	239
[2599]	240
[1900]	241	ierr = 0
[1933]	242	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, &
[1900]	243	MPI_STATUS_IGNORE, ierr )
[1762]	244
[1933]	245	END SUBROUTINE pmc_recv_from_parent_real_r1
[1762]	246
	247
	248
[1933]	249	SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]	250
[1900]	251	IMPLICIT NONE
[1762]	252
[1900]	253	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	254	INTEGER, INTENT(IN) :: n !<
[1933]	255	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	256	INTEGER, INTENT(IN) :: tag !<
	257	INTEGER, INTENT(OUT) :: ierr !<
[1762]	258
[2599]	259
[1900]	260	ierr = 0
[1933]	261	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	262
[1933]	263	END SUBROUTINE pmc_send_to_parent_real_r2
[1762]	264
	265
[1933]	266	SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]	267
[1900]	268	IMPLICIT NONE
[1762]	269
[1900]	270	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	271	INTEGER, INTENT(IN) :: n !<
[1933]	272	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	273	INTEGER, INTENT(IN) :: tag !<
	274	INTEGER, INTENT(OUT) :: ierr !<
[1779]	275
[1900]	276	ierr = 0
[1933]	277	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, &
[1900]	278	MPI_STATUS_IGNORE, ierr )
[1762]	279
[1933]	280	END SUBROUTINE pmc_recv_from_parent_real_r2
[1779]	281
[1762]	282
	283
[1933]	284	SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]	285
[1900]	286	IMPLICIT NONE
[1762]	287
[1900]	288	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	289	INTEGER, INTENT(IN) :: n !<
[1933]	290	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	291	INTEGER, INTENT(IN) :: tag !<
	292	INTEGER, INTENT(OUT) :: ierr !<
[1779]	293
[2599]	294
[1900]	295	ierr = 0
[1933]	296	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	297
[1933]	298	END SUBROUTINE pmc_send_to_parent_real_r3
[1762]	299
[1779]	300
[1762]	301
[1933]	302	SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]	303
[1900]	304	IMPLICIT NONE
[1762]	305
[1900]	306	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	307	INTEGER, INTENT(IN) :: n !<
[1933]	308	INTEGER, INTENT(IN) :: parent_rank !<
[1900]	309	INTEGER, INTENT(IN) :: tag !<
	310	INTEGER, INTENT(OUT) :: ierr !<
[1762]	311
[2599]	312
[1900]	313	ierr = 0
[1933]	314	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, &
[1900]	315	MPI_STATUS_IGNORE, ierr )
[1779]	316
[1933]	317	END SUBROUTINE pmc_recv_from_parent_real_r3
[1762]	318
[1779]	319
[1933]	320	SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag, &
	321	ierr )
[1762]	322
[1900]	323	IMPLICIT NONE
[1779]	324
[1933]	325	INTEGER, INTENT(IN) :: child_id !<
[1900]	326	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	327	INTEGER, INTENT(IN) :: n !<
[1933]	328	INTEGER, INTENT(IN) :: child_rank !<
[1900]	329	INTEGER, INTENT(IN) :: tag !<
	330	INTEGER, INTENT(OUT) :: ierr !<
[1762]	331
[2599]	332
[1900]	333	ierr = 0
[1933]	334	CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag, &
	335	m_to_child_comm(child_id), ierr )
[1779]	336
[1933]	337	END SUBROUTINE pmc_send_to_child_integer
[1762]	338
	339
[1779]	340
[1933]	341	SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag, &
	342	ierr )
[1762]	343
[1900]	344	IMPLICIT NONE
[1779]	345
[1933]	346	INTEGER, INTENT(IN) :: child_id !<
[1900]	347	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf !<
	348	INTEGER, INTENT(IN) :: n !<
[1933]	349	INTEGER, INTENT(IN) :: child_rank !<
[1900]	350	INTEGER, INTENT(IN) :: tag !<
	351	INTEGER, INTENT(OUT) :: ierr !<
[1762]	352
[2599]	353
[1900]	354	ierr = 0
[1933]	355	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, &
	356	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]	357
[1933]	358	END SUBROUTINE pmc_recv_from_child_integer
[1762]	359
	360
	361
[1933]	362	SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank, &
	363	tag, ierr )
[1762]	364
[1900]	365	IMPLICIT NONE
[1762]	366
[1933]	367	INTEGER, INTENT(IN) :: child_id !<
[1900]	368	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf !<
	369	INTEGER, INTENT(IN) :: n !<
[1933]	370	INTEGER, INTENT(IN) :: child_rank !<
[1900]	371	INTEGER, INTENT(IN) :: tag !<
	372	INTEGER, INTENT(OUT) :: ierr !<
[1762]	373
[2599]	374
[1900]	375	ierr = 0
[1933]	376	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, &
	377	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]	378
[1933]	379	END SUBROUTINE pmc_recv_from_child_integer_2
[1762]	380
	381
	382
[1933]	383	SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag, &
	384	ierr )
[1762]	385
[1900]	386	IMPLICIT NONE
[1762]	387
[1933]	388	INTEGER, INTENT(IN) :: child_id !<
[1900]	389	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	390	INTEGER, INTENT(IN) :: n !<
[1933]	391	INTEGER, INTENT(IN) :: child_rank !<
[1900]	392	INTEGER, INTENT(IN) :: tag !<
	393	INTEGER, INTENT(OUT) :: ierr !<
[1762]	394
[2599]	395
[1900]	396	ierr = 0
[1933]	397	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
	398	m_to_child_comm(child_id), ierr )
[1762]	399
[1933]	400	END SUBROUTINE pmc_send_to_child_real_r1
[1762]	401
	402
	403
[1933]	404	SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag, &
	405	ierr )
[1762]	406
[1900]	407	IMPLICIT NONE
[1762]	408
[1933]	409	INTEGER, INTENT(IN) :: child_id !<
[1900]	410	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf !<
	411	INTEGER, INTENT(IN) :: n !<
[1933]	412	INTEGER, INTENT(IN) :: child_rank !<
[1900]	413	INTEGER, INTENT(IN) :: tag !<
	414	INTEGER, INTENT(OUT) :: ierr !<
[1762]	415
[2599]	416
[1900]	417	ierr = 0
[1933]	418	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
	419	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1762]	420
[1933]	421	END SUBROUTINE pmc_recv_from_child_real_r1
[1762]	422
	423
	424
[1933]	425	SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag, &
	426	ierr )
[1762]	427
[1900]	428	IMPLICIT NONE
[1762]	429
[1933]	430	INTEGER, INTENT(IN) :: child_id !<
[1900]	431	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	432	INTEGER, INTENT(IN) :: n !<
[1933]	433	INTEGER, INTENT(IN) :: child_rank !<
[1900]	434	INTEGER, INTENT(IN) :: tag !<
	435	INTEGER, INTENT(OUT) :: ierr !<
[1762]	436
[2599]	437
[1900]	438	ierr = 0
[1933]	439	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
	440	m_to_child_comm(child_id), ierr )
[1762]	441
[1933]	442	END SUBROUTINE pmc_send_to_child_real_r2
[1762]	443
	444
	445
[1933]	446	SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag, &
	447	ierr )
[1762]	448
[1900]	449	IMPLICIT NONE
[1762]	450
[1933]	451	INTEGER, INTENT(IN) :: child_id !<
[1900]	452	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	453	INTEGER, INTENT(IN) :: n !<
[1933]	454	INTEGER, INTENT(IN) :: child_rank !<
[1900]	455	INTEGER, INTENT(IN) :: tag !<
	456	INTEGER, INTENT(OUT) :: ierr !<
	457
[2599]	458
[1900]	459	ierr = 0
[1933]	460	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
	461	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]	462
[1933]	463	END SUBROUTINE pmc_recv_from_child_real_r2
[1900]	464
	465
	466
[1933]	467	SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag, &
[2599]	468	ierr )
[1900]	469
	470	IMPLICIT NONE
	471
[1933]	472	INTEGER, INTENT(IN) :: child_id !<
[1900]	473	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	474	INTEGER, INTENT(IN) :: n !<
[1933]	475	INTEGER, INTENT(IN) :: child_rank !<
[1900]	476	INTEGER, INTENT(IN) :: tag !<
	477	INTEGER, INTENT(OUT) :: ierr !<
	478
[2599]	479
[1900]	480	ierr = 0
[1933]	481	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, &
	482	m_to_child_comm(child_id), ierr )
[1900]	483
[1933]	484	END SUBROUTINE pmc_send_to_child_real_r3
[1900]	485
	486
	487
[1933]	488	SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag, &
	489	ierr )
[1900]	490
	491	IMPLICIT NONE
	492
[1933]	493	INTEGER, INTENT(IN) :: child_id !<
[1900]	494	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	495	INTEGER, INTENT(IN) :: n !<
[1933]	496	INTEGER, INTENT(IN) :: child_rank !<
[1900]	497	INTEGER, INTENT(IN) :: tag !<
	498	INTEGER, INTENT(OUT) :: ierr !<
	499
[2599]	500
[1900]	501	ierr = 0
[1933]	502	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, &
	503	m_to_child_comm(child_id), MPI_STATUS_IGNORE, ierr )
[1900]	504
[1933]	505	END SUBROUTINE pmc_recv_from_child_real_r3
[1900]	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
[2599]	550
[1900]	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
[1933]	567	SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
[1900]	568
	569	IMPLICIT NONE
	570
	571	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf !<
[1933]	572	INTEGER, INTENT(IN),optional :: child_id !<
[1900]	573	INTEGER, INTENT(OUT),optional :: ierr !<
	574
	575	INTEGER :: mycomm !<
	576	INTEGER :: myerr !<
	577	INTEGER :: root_pe !<
	578
	579	!
[2599]	580	!-- Process 0 on parent broadcast to all child processes
[1933]	581	IF ( PRESENT( child_id ) ) THEN
[1900]	582
[1933]	583	mycomm = m_to_child_comm(child_id)
[1900]	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
[1933]	592	mycomm = m_to_parent_comm
[1900]	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
[2599]	621
[2809]	622	winsize = idim1 * STORAGE_SIZE( ierr )/8
[1900]	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
[2599]	646
[1900]	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
[2599]	665
[1900]	666	pmc_time = MPI_WTIME()
	667
	668	END FUNCTION pmc_time
	669
[1764]	670	#endif
[1762]	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 |