Home

Context Navigation

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

Last change on this file since 2675 was 2599, checked in by hellstea, 7 years ago
i/o grouping update for nested runs
Property svn:keywords set to `Id`
File size: 19.1 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |