Home

Context Navigation

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

Last change on this file since 1928 was 1901, checked in by raasch, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 18.8 KB

Rev	Line
[1900]	1	MODULE pmc_mpi_wrapper
[1762]	2
	3	!--------------------------------------------------------------------------------!
	4	! This file is part of PALM.
	5	!
	6	! PALM is free software: you can redistribute it and/or modify it under the terms
	7	! of the GNU General Public License as published by the Free Software Foundation,
	8	! either version 3 of the License, or (at your option) any later version.
	9	!
	10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
	11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
	12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
	13	!
	14	! You should have received a copy of the GNU General Public License along with
	15	! PALM. If not, see <http://www.gnu.org/licenses/>.
	16	!
[1818]	17	! Copyright 1997-2016 Leibniz Universitaet Hannover
[1762]	18	!--------------------------------------------------------------------------------!
	19	!
	20	! Current revisions:
	21	! ------------------
[1851]	22	!
[1901]	23	!
[1762]	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_mpi_wrapper_mod.f90 1901 2016-05-04 15:39:38Z hellstea $
	27	!
[1901]	28	! 1900 2016-05-04 15:27:53Z raasch
	29	! re-formatted to match PALM style
	30	!
[1851]	31	! 1850 2016-04-08 13:29:27Z maronga
	32	! Module renamed
	33	!
	34	!
[1809]	35	! 1808 2016-04-05 19:44:00Z raasch
	36	! MPI module used by default on all machines
	37	!
[1780]	38	! 1779 2016-03-03 08:01:28Z raasch
	39	! kind=dp replaced by wp
	40	!
[1765]	41	! 1764 2016-02-28 12:45:19Z raasch
	42	! cpp-statement added (nesting can only be used in parallel mode),
	43	! kind-parameters adjusted to PALM-kinds
	44	!
[1763]	45	! 1762 2016-02-25 12:31:13Z hellstea
	46	! Initial revision by K. Ketelsen
[1762]	47	!
	48	! Description:
	49	! ------------
	50	!
	51	! MPI Wrapper of Palm Model Coupler
	52	!------------------------------------------------------------------------------!
	53
[1764]	54	#if defined( __parallel )
[1900]	55	USE, INTRINSIC :: ISO_C_BINDING
[1762]	56
[1808]	57	#if defined( __mpifh )
	58	INCLUDE "mpif.h"
	59	#else
[1764]	60	USE MPI
	61	#endif
[1762]	62
[1900]	63	USE kinds
	64	USE pmc_handle_communicator, &
	65	ONLY: m_model_comm, m_model_rank, m_to_server_comm, m_to_client_comm
[1762]	66
[1900]	67	IMPLICIT NONE
[1762]	68
[1900]	69	PRIVATE
	70	SAVE
[1762]	71
[1900]	72	INTERFACE pmc_send_to_server
	73	MODULE PROCEDURE pmc_send_to_server_integer
	74	MODULE PROCEDURE pmc_send_to_server_integer_2
	75	MODULE PROCEDURE pmc_send_to_server_real_r1
	76	MODULE PROCEDURE pmc_send_to_server_real_r2
	77	MODULE PROCEDURE pmc_send_to_server_real_r3
	78	END INTERFACE pmc_send_to_server
[1762]	79
[1900]	80	INTERFACE pmc_recv_from_server
	81	MODULE PROCEDURE pmc_recv_from_server_integer
	82	MODULE PROCEDURE pmc_recv_from_server_real_r1
	83	MODULE PROCEDURE pmc_recv_from_server_real_r2
	84	MODULE PROCEDURE pmc_recv_from_server_real_r3
	85	END INTERFACE pmc_recv_from_server
[1762]	86
[1900]	87	INTERFACE pmc_send_to_client
	88	MODULE PROCEDURE pmc_send_to_client_integer
	89	MODULE PROCEDURE pmc_send_to_client_real_r1
	90	MODULE PROCEDURE pmc_send_to_client_real_r2
	91	MODULE PROCEDURE pmc_send_to_client_real_r3
	92	END INTERFACE pmc_send_to_client
[1762]	93
[1900]	94	INTERFACE pmc_recv_from_client
	95	MODULE PROCEDURE pmc_recv_from_client_integer
	96	MODULE PROCEDURE pmc_recv_from_client_integer_2
	97	MODULE PROCEDURE pmc_recv_from_client_real_r1
	98	MODULE PROCEDURE pmc_recv_from_client_real_r2
	99	MODULE PROCEDURE pmc_recv_from_client_real_r3
	100	END INTERFACE pmc_recv_from_client
[1762]	101
[1900]	102	INTERFACE pmc_bcast
	103	MODULE PROCEDURE pmc_bcast_integer
	104	MODULE PROCEDURE pmc_bcast_character
	105	END INTERFACE pmc_bcast
[1762]	106
[1900]	107	INTERFACE pmc_inter_bcast
	108	MODULE PROCEDURE pmc_inter_bcast_integer_1
	109	END INTERFACE pmc_inter_bcast
[1762]	110
[1900]	111	INTERFACE pmc_alloc_mem
	112	MODULE PROCEDURE pmc_alloc_mem_integer_1
	113	MODULE PROCEDURE pmc_alloc_mem_Real_1
	114	END INTERFACE pmc_alloc_mem
[1762]	115
[1900]	116	INTERFACE pmc_time
	117	MODULE PROCEDURE pmc_time
	118	END INTERFACE pmc_time
[1762]	119
[1900]	120	PUBLIC pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, pmc_recv_from_client, &
	121	pmc_recv_from_server, pmc_send_to_client, pmc_send_to_server, &
	122	pmc_time
[1762]	123
[1900]	124	CONTAINS
[1762]	125
	126
[1900]	127	SUBROUTINE pmc_send_to_server_integer( buf, n, server_rank, tag, ierr )
[1762]	128
[1900]	129	IMPLICIT NONE
[1762]	130
[1900]	131	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	132	INTEGER, INTENT(IN) :: n !<
	133	INTEGER, INTENT(IN) :: server_rank !<
	134	INTEGER, INTENT(IN) :: tag !<
	135	INTEGER, INTENT(OUT) :: ierr !<
[1762]	136
[1900]	137	ierr = 0
	138	CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
	139	ierr)
[1779]	140
[1900]	141	END SUBROUTINE pmc_send_to_server_integer
[1762]	142
[1779]	143
[1762]	144
[1900]	145	SUBROUTINE pmc_recv_from_server_integer( buf, n, server_rank, tag, ierr )
[1762]	146
[1900]	147	IMPLICIT NONE
[1779]	148
[1900]	149	INTEGER, DIMENSION(:), INTENT(OUT) :: buf !<
	150	INTEGER, INTENT(IN) :: n !<
	151	INTEGER, INTENT(IN) :: server_rank !<
	152	INTEGER, INTENT(IN) :: tag !<
	153	INTEGER, INTENT(OUT) :: ierr !<
[1762]	154
[1900]	155	ierr = 0
	156	CALL MPI_RECV( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
	157	MPI_STATUS_IGNORE, ierr )
[1779]	158
[1900]	159	END SUBROUTINE pmc_recv_from_server_integer
[1762]	160
	161
[1779]	162
[1900]	163	SUBROUTINE pmc_send_to_server_integer_2( buf, n, server_rank, tag, ierr )
[1762]	164
[1900]	165	IMPLICIT NONE
[1779]	166
[1900]	167	INTEGER, DIMENSION(:,:), INTENT(IN) :: buf !<
	168	INTEGER, INTENT(IN) :: n !<
	169	INTEGER, INTENT(IN) :: server_rank !<
	170	INTEGER, INTENT(IN) :: tag !<
	171	INTEGER, INTENT(OUT) :: ierr !<
[1762]	172
[1900]	173	ierr = 0
	174	CALL MPI_SEND( buf, n, MPI_INTEGER, server_rank, tag, m_to_server_comm, &
	175	ierr )
[1762]	176
[1900]	177	END SUBROUTINE pmc_send_to_server_integer_2
[1779]	178
[1762]	179
[1779]	180
[1900]	181	SUBROUTINE pmc_send_to_server_real_r1( buf, n, server_rank, tag, ierr )
[1762]	182
[1900]	183	IMPLICIT NONE
[1762]	184
[1900]	185	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	186	INTEGER, INTENT(IN) :: n !<
	187	INTEGER, INTENT(IN) :: server_rank !<
	188	INTEGER, INTENT(IN) :: tag !<
	189	INTEGER, INTENT(OUT) :: ierr !<
[1779]	190
[1900]	191	ierr = 0
	192	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
[1762]	193
[1900]	194	END SUBROUTINE pmc_send_to_server_real_r1
[1779]	195
[1762]	196
	197
[1900]	198	SUBROUTINE pmc_recv_from_server_real_r1( buf, n, server_rank, tag, ierr )
[1779]	199
[1900]	200	IMPLICIT NONE
[1762]	201
[1900]	202	REAL(wp), DIMENSION(:), INTENT(OUT) :: buf !<
	203	INTEGER, INTENT(IN) :: n !<
	204	INTEGER, INTENT(IN) :: server_rank !<
	205	INTEGER, INTENT(IN) :: tag !<
	206	INTEGER, INTENT(OUT) :: ierr !<
[1779]	207
[1900]	208	ierr = 0
	209	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
	210	MPI_STATUS_IGNORE, ierr )
[1762]	211
[1900]	212	END SUBROUTINE pmc_recv_from_server_real_r1
[1762]	213
	214
	215
[1900]	216	SUBROUTINE pmc_send_to_server_real_r2( buf, n, server_rank, tag, ierr )
[1762]	217
[1900]	218	IMPLICIT NONE
[1762]	219
[1900]	220	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	221	INTEGER, INTENT(IN) :: n !<
	222	INTEGER, INTENT(IN) :: server_rank !<
	223	INTEGER, INTENT(IN) :: tag !<
	224	INTEGER, INTENT(OUT) :: ierr !<
[1762]	225
[1900]	226	ierr = 0
	227	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
[1762]	228
[1900]	229	END SUBROUTINE pmc_send_to_server_real_r2
[1762]	230
	231
[1900]	232	SUBROUTINE pmc_recv_from_server_real_r2( buf, n, server_rank, tag, ierr )
[1762]	233
[1900]	234	IMPLICIT NONE
[1762]	235
[1900]	236	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	237	INTEGER, INTENT(IN) :: n !<
	238	INTEGER, INTENT(IN) :: server_rank !<
	239	INTEGER, INTENT(IN) :: tag !<
	240	INTEGER, INTENT(OUT) :: ierr !<
[1779]	241
[1900]	242	ierr = 0
	243	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
	244	MPI_STATUS_IGNORE, ierr )
[1762]	245
[1900]	246	END SUBROUTINE pmc_recv_from_server_real_r2
[1779]	247
[1762]	248
	249
[1900]	250	SUBROUTINE pmc_send_to_server_real_r3( buf, n, server_rank, tag, ierr )
[1779]	251
[1900]	252	IMPLICIT NONE
[1762]	253
[1900]	254	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	255	INTEGER, INTENT(IN) :: n !<
	256	INTEGER, INTENT(IN) :: server_rank !<
	257	INTEGER, INTENT(IN) :: tag !<
	258	INTEGER, INTENT(OUT) :: ierr !<
[1779]	259
[1900]	260	ierr = 0
	261	CALL MPI_SEND( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, ierr )
[1762]	262
[1900]	263	END SUBROUTINE pmc_send_to_server_real_r3
[1762]	264
[1779]	265
[1762]	266
[1900]	267	SUBROUTINE pmc_recv_from_server_real_r3( buf, n, server_rank, tag, ierr )
[1779]	268
[1900]	269	IMPLICIT NONE
[1762]	270
[1900]	271	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	272	INTEGER, INTENT(IN) :: n !<
	273	INTEGER, INTENT(IN) :: server_rank !<
	274	INTEGER, INTENT(IN) :: tag !<
	275	INTEGER, INTENT(OUT) :: ierr !<
[1762]	276
[1900]	277	ierr = 0
	278	CALL MPI_RECV( buf, n, MPI_REAL, server_rank, tag, m_to_server_comm, &
	279	MPI_STATUS_IGNORE, ierr )
[1779]	280
[1900]	281	END SUBROUTINE pmc_recv_from_server_real_r3
[1762]	282
[1779]	283
[1762]	284
[1900]	285	SUBROUTINE pmc_send_to_client_integer( client_id, buf, n, client_rank, tag, &
	286	ierr )
[1762]	287
[1900]	288	IMPLICIT NONE
[1779]	289
[1900]	290	INTEGER, INTENT(IN) :: client_id !<
	291	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	292	INTEGER, INTENT(IN) :: n !<
	293	INTEGER, INTENT(IN) :: client_rank !<
	294	INTEGER, INTENT(IN) :: tag !<
	295	INTEGER, INTENT(OUT) :: ierr !<
[1762]	296
[1900]	297	ierr = 0
	298	CALL MPI_SEND( buf, n, MPI_INTEGER, client_rank, tag, &
	299	m_to_client_comm(client_id), ierr )
[1779]	300
[1900]	301	END SUBROUTINE pmc_send_to_client_integer
[1762]	302
	303
[1779]	304
[1900]	305	SUBROUTINE pmc_recv_from_client_integer( client_id, buf, n, client_rank, tag, &
	306	ierr )
[1762]	307
[1900]	308	IMPLICIT NONE
[1779]	309
[1900]	310	INTEGER, INTENT(IN) :: client_id !<
	311	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf !<
	312	INTEGER, INTENT(IN) :: n !<
	313	INTEGER, INTENT(IN) :: client_rank !<
	314	INTEGER, INTENT(IN) :: tag !<
	315	INTEGER, INTENT(OUT) :: ierr !<
[1762]	316
[1900]	317	ierr = 0
	318	CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag, &
	319	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
[1762]	320
[1900]	321	END SUBROUTINE pmc_recv_from_client_integer
[1762]	322
	323
	324
[1900]	325	SUBROUTINE pmc_recv_from_client_integer_2( client_id, buf, n, client_rank, &
	326	tag, ierr )
[1762]	327
[1900]	328	IMPLICIT NONE
[1762]	329
[1900]	330	INTEGER, INTENT(IN) :: client_id !<
	331	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf !<
	332	INTEGER, INTENT(IN) :: n !<
	333	INTEGER, INTENT(IN) :: client_rank !<
	334	INTEGER, INTENT(IN) :: tag !<
	335	INTEGER, INTENT(OUT) :: ierr !<
[1762]	336
[1900]	337	ierr = 0
	338	CALL MPI_RECV( buf, n, MPI_INTEGER, client_rank, tag, &
	339	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
[1762]	340
[1900]	341	END SUBROUTINE pmc_recv_from_client_integer_2
[1762]	342
	343
	344
[1900]	345	SUBROUTINE pmc_send_to_client_real_r1( client_id, buf, n, client_rank, tag, &
	346	ierr )
[1762]	347
[1900]	348	IMPLICIT NONE
[1762]	349
[1900]	350	INTEGER, INTENT(IN) :: client_id !<
	351	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	352	INTEGER, INTENT(IN) :: n !<
	353	INTEGER, INTENT(IN) :: client_rank !<
	354	INTEGER, INTENT(IN) :: tag !<
	355	INTEGER, INTENT(OUT) :: ierr !<
[1762]	356
[1900]	357	ierr = 0
	358	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
	359	m_to_client_comm(client_id), ierr )
[1762]	360
[1900]	361	END SUBROUTINE pmc_send_to_client_real_r1
[1762]	362
	363
	364
[1900]	365	SUBROUTINE pmc_recv_from_client_real_r1( client_id, buf, n, client_rank, tag, &
	366	ierr )
[1762]	367
[1900]	368	IMPLICIT NONE
[1762]	369
[1900]	370	INTEGER, INTENT(IN) :: client_id !<
	371	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf !<
	372	INTEGER, INTENT(IN) :: n !<
	373	INTEGER, INTENT(IN) :: client_rank !<
	374	INTEGER, INTENT(IN) :: tag !<
	375	INTEGER, INTENT(OUT) :: ierr !<
[1762]	376
[1900]	377	ierr = 0
	378	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
	379	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
[1762]	380
[1900]	381	END SUBROUTINE pmc_recv_from_client_real_r1
[1762]	382
	383
	384
[1900]	385	SUBROUTINE pmc_send_to_client_real_r2( client_id, buf, n, client_rank, tag, &
	386	ierr )
[1762]	387
[1900]	388	IMPLICIT NONE
[1762]	389
[1900]	390	INTEGER, INTENT(IN) :: client_id !<
	391	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	392	INTEGER, INTENT(IN) :: n !<
	393	INTEGER, INTENT(IN) :: client_rank !<
	394	INTEGER, INTENT(IN) :: tag !<
	395	INTEGER, INTENT(OUT) :: ierr !<
[1762]	396
[1900]	397	ierr = 0
	398	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
	399	m_to_client_comm(client_id), ierr )
[1762]	400
[1900]	401	END SUBROUTINE pmc_send_to_client_real_r2
[1762]	402
	403
	404
[1900]	405	SUBROUTINE pmc_recv_from_client_real_r2( client_id, buf, n, client_rank, tag, &
	406	ierr )
[1762]	407
[1900]	408	IMPLICIT NONE
[1762]	409
[1900]	410	INTEGER, INTENT(IN) :: client_id !<
	411	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	412	INTEGER, INTENT(IN) :: n !<
	413	INTEGER, INTENT(IN) :: client_rank !<
	414	INTEGER, INTENT(IN) :: tag !<
	415	INTEGER, INTENT(OUT) :: ierr !<
	416
	417	ierr = 0
	418	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
	419	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
	420
	421	END SUBROUTINE pmc_recv_from_client_real_r2
	422
	423
	424
	425	SUBROUTINE pmc_send_to_client_real_r3( client_id, buf, n, client_rank, tag, &
	426	ierr)
	427
	428	IMPLICIT NONE
	429
	430	INTEGER, INTENT(IN) :: client_id !<
	431	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	432	INTEGER, INTENT(IN) :: n !<
	433	INTEGER, INTENT(IN) :: client_rank !<
	434	INTEGER, INTENT(IN) :: tag !<
	435	INTEGER, INTENT(OUT) :: ierr !<
	436
	437	ierr = 0
	438	CALL MPI_SEND( buf, n, MPI_REAL, client_rank, tag, &
	439	m_to_client_comm(client_id), ierr )
	440
	441	END SUBROUTINE pmc_send_to_client_real_r3
	442
	443
	444
	445	SUBROUTINE pmc_recv_from_client_real_r3( client_id, buf, n, client_rank, tag, &
	446	ierr )
	447
	448	IMPLICIT NONE
	449
	450	INTEGER, INTENT(IN) :: client_id !<
	451	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	452	INTEGER, INTENT(IN) :: n !<
	453	INTEGER, INTENT(IN) :: client_rank !<
	454	INTEGER, INTENT(IN) :: tag !<
	455	INTEGER, INTENT(OUT) :: ierr !<
	456
	457	ierr = 0
	458	CALL MPI_RECV( buf, n, MPI_REAL, client_rank, tag, &
	459	m_to_client_comm(client_id), MPI_STATUS_IGNORE, ierr )
	460
	461	END SUBROUTINE pmc_recv_from_client_real_r3
	462
	463
	464
	465	SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
	466
	467	IMPLICIT NONE
	468
	469	INTEGER, INTENT(INOUT) :: buf !<
	470	INTEGER, INTENT(IN) :: root_pe !<
	471	INTEGER, INTENT(IN), OPTIONAL :: comm !<
	472	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
	473
	474	INTEGER :: mycomm !<
	475	INTEGER :: myerr !<
	476
	477
	478	IF ( PRESENT( comm ) ) THEN
	479	mycomm = comm
	480	ELSE
	481	mycomm = m_model_comm
	482	ENDIF
	483
	484	CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
	485
	486	IF ( PRESENT( ierr ) ) THEN
	487	ierr = myerr
	488	ENDIF
	489
	490	END SUBROUTINE pmc_bcast_integer
	491
	492
	493
	494	SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
	495
	496	IMPLICIT NONE
	497
	498	CHARACTER(LEN=*), INTENT(INOUT) :: buf !<
	499	INTEGER, INTENT(IN) :: root_pe !<
	500	INTEGER, INTENT(IN), OPTIONAL :: comm !<
	501	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
	502
	503	INTEGER :: mycomm !<
	504	INTEGER :: myerr !<
	505
	506	IF ( PRESENT( comm ) ) THEN
	507	mycomm = comm
	508	ELSE
	509	mycomm = m_model_comm
	510	ENDIF
	511
	512	CALL MPI_BCAST( buf, LEN(buf), MPI_CHARACTER, root_pe, mycomm, myerr )
	513
	514	IF ( PRESENT( ierr ) ) THEN
	515	ierr = myerr
	516	ENDIF
	517
	518	END SUBROUTINE pmc_bcast_character
	519
	520
	521
	522	SUBROUTINE pmc_inter_bcast_integer_1( buf, client_id, ierr )
	523
	524	IMPLICIT NONE
	525
	526	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf !<
	527	INTEGER, INTENT(IN),optional :: client_id !<
	528	INTEGER, INTENT(OUT),optional :: ierr !<
	529
	530	INTEGER :: mycomm !<
	531	INTEGER :: myerr !<
	532	INTEGER :: root_pe !<
	533
	534	!
	535	!-- PE 0 server broadcast to all client PEs
	536	IF ( PRESENT( client_id ) ) THEN
	537
	538	mycomm = m_to_client_comm(client_id)
	539
	540	IF ( m_model_rank == 0 ) THEN
	541	root_pe = MPI_ROOT
	542	ELSE
	543	root_pe = MPI_PROC_NULL
	544	ENDIF
	545
	546	ELSE
	547	mycomm = m_to_server_comm
	548	root_pe = 0
	549	ENDIF
	550
	551	CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
	552
	553	IF ( PRESENT( ierr ) ) THEN
	554	ierr = myerr
	555	ENDIF
	556
	557	END SUBROUTINE pmc_inter_bcast_integer_1
	558
	559
	560
	561	SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
	562	!
	563	!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
	564
	565	IMPLICIT NONE
	566
	567	INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) :: iarray !<
	568	INTEGER, INTENT(IN) :: idim1 !<
	569
	570	INTEGER, DIMENSION(1) :: ashape !<
	571	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	572	INTEGER :: ierr !<
	573
	574	TYPE(C_PTR) :: p_myind !<
	575
	576	winsize = idim1 * C_SIZEOF( ierr )
	577
	578	CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
	579	ashape(1) = idim1
	580	CALL C_F_POINTER( p_myind, iarray, ashape )
	581
	582	END SUBROUTINE pmc_alloc_mem_integer_1
	583
	584
	585
	586	SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
	587
	588	IMPLICIT NONE
	589
	590	INTEGER(idp), INTENT(IN) :: idim1 !<
	591	REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) :: array !<
	592	TYPE(C_PTR), INTENT(OUT), OPTIONAL :: base_ptr !<
	593
	594	INTEGER, DIMENSION(1) :: ashape !<
	595	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	596	INTEGER :: ierr !<
	597
	598	TYPE(C_PTR) :: p_myind !<
	599
	600	winsize = idim1 * wp
	601
	602	CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
	603	ashape(1) = idim1
	604	CALL C_F_POINTER( p_myind, array, ashape )
	605
	606	IF ( PRESENT( base_ptr ) ) THEN
	607	base_ptr = p_myind
	608	ENDIF
	609
	610	END SUBROUTINE pmc_alloc_mem_Real_1
	611
	612
	613
	614	FUNCTION pmc_time()
	615
	616	REAL(kind=wp) :: pmc_time !<
	617
	618	pmc_time = MPI_WTIME()
	619
	620	END FUNCTION pmc_time
	621
[1764]	622	#endif
[1762]	623	END MODULE pmc_mpi_wrapper

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |