Home

Context Navigation

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

Last change on this file since 1859 was 1851, checked in by maronga, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 18.3 KB

Rev	Line
[1762]	1	MODULE pmc_mpi_wrapper
	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	!
	23	!
[1762]	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_mpi_wrapper_mod.f90 1851 2016-04-08 13:32:50Z hoffmann $
	27	!
[1851]	28	! 1850 2016-04-08 13:29:27Z maronga
	29	! Module renamed
	30	!
	31	!
[1809]	32	! 1808 2016-04-05 19:44:00Z raasch
	33	! MPI module used by default on all machines
	34	!
[1780]	35	! 1779 2016-03-03 08:01:28Z raasch
	36	! kind=dp replaced by wp
	37	!
[1765]	38	! 1764 2016-02-28 12:45:19Z raasch
	39	! cpp-statement added (nesting can only be used in parallel mode),
	40	! kind-parameters adjusted to PALM-kinds
	41	!
[1763]	42	! 1762 2016-02-25 12:31:13Z hellstea
	43	! Initial revision by K. Ketelsen
[1762]	44	!
	45	! Description:
	46	! ------------
	47	!
	48	! MPI Wrapper of Palm Model Coupler
	49	!------------------------------------------------------------------------------!
	50
[1764]	51	#if defined( __parallel )
[1762]	52	use, intrinsic :: iso_c_binding
	53
[1808]	54	#if defined( __mpifh )
	55	INCLUDE "mpif.h"
	56	#else
[1764]	57	USE MPI
	58	#endif
	59	USE kinds
[1762]	60	USE PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank
	61	IMPLICIT none
	62	PRIVATE
	63	SAVE
	64
	65	INTERFACE PMC_Send_to_Server
	66	MODULE PROCEDURE PMC_Send_to_Server_INTEGER
	67	MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2
	68	MODULE PROCEDURE PMC_Send_to_Server_real_r1
	69	MODULE PROCEDURE PMC_Send_to_Server_real_r2
	70	MODULE PROCEDURE PMC_Send_to_Server_real_r3
	71	END INTERFACE PMC_Send_to_Server
	72
	73	INTERFACE PMC_Recv_from_Server
	74	MODULE PROCEDURE PMC_Recv_from_Server_INTEGER
	75	MODULE PROCEDURE PMC_Recv_from_Server_real_r1
	76	MODULE PROCEDURE PMC_Recv_from_Server_real_r2
	77	MODULE PROCEDURE PMC_Recv_from_Server_real_r3
	78	END INTERFACE PMC_Recv_from_Server
	79
	80	INTERFACE PMC_Send_to_Client
	81	MODULE PROCEDURE PMC_Send_to_Client_INTEGER
	82	MODULE PROCEDURE PMC_Send_to_Client_real_r1
	83	MODULE PROCEDURE PMC_Send_to_Client_real_r2
	84	MODULE PROCEDURE PMC_Send_to_Client_real_r3
	85	END INTERFACE PMC_Send_to_Client
	86
	87	INTERFACE PMC_Recv_from_Client
	88	MODULE PROCEDURE PMC_Recv_from_Client_INTEGER
	89	MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2
	90	MODULE PROCEDURE PMC_Recv_from_Client_real_r1
	91	MODULE PROCEDURE PMC_Recv_from_Client_real_r2
	92	MODULE PROCEDURE PMC_Recv_from_Client_real_r3
	93	END INTERFACE PMC_Recv_from_Client
	94
	95	INTERFACE PMC_Bcast
	96	MODULE PROCEDURE PMC_Bcast_INTEGER
	97	MODULE PROCEDURE PMC_Bcast_character
	98	END INTERFACE PMC_Bcast
	99
	100	INTERFACE PMC_Inter_Bcast
	101	MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1
	102	END INTERFACE PMC_Inter_Bcast
	103
	104	INTERFACE PMC_Alloc_mem
	105	MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1
	106	MODULE PROCEDURE PMC_Alloc_mem_Real_1
	107	END INTERFACE PMC_Alloc_mem
	108
	109	INTERFACE PMC_TIME
	110	MODULE PROCEDURE PMC_TIME
	111	END INTERFACE PMC_TIME
	112
	113	PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server
	114	PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client
	115	PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
	116	PUBLIC PMC_TIME
	117
	118	CONTAINS
	119
	120	SUBROUTINE PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr)
	121	IMPLICIT none
	122	INTEGER, DIMENSION(:), INTENT(IN) :: buf
	123	INTEGER, INTENT(IN) :: n
	124	INTEGER, INTENT(IN) :: Server_rank
	125	INTEGER, INTENT(IN) :: tag
	126	INTEGER, INTENT(OUT) :: ierr
	127
	128	ierr = 0
	129	CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
	130
	131	return
	132	END SUBROUTINE PMC_Send_to_Server_INTEGER
	133
	134	SUBROUTINE PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr)
	135	IMPLICIT none
	136	INTEGER, DIMENSION(:), INTENT(OUT) :: buf
	137	INTEGER, INTENT(IN) :: n
	138	INTEGER, INTENT(IN) :: Server_rank
	139	INTEGER, INTENT(IN) :: tag
	140	INTEGER, INTENT(OUT) :: ierr
	141
	142	ierr = 0
	143	CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, &
	144	MPI_STATUS_IGNORE, ierr)
	145
	146	return
	147	END SUBROUTINE PMC_Recv_from_Server_INTEGER
	148
	149	SUBROUTINE PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr)
	150	IMPLICIT none
	151	INTEGER, DIMENSION(:,:), INTENT(IN) :: buf
	152	INTEGER, INTENT(IN) :: n
	153	INTEGER, INTENT(IN) :: Server_rank
	154	INTEGER, INTENT(IN) :: tag
	155	INTEGER, INTENT(OUT) :: ierr
	156
	157	ierr = 0
	158	CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr)
	159
	160	return
	161	END SUBROUTINE PMC_Send_to_Server_INTEGER_2
	162
	163	SUBROUTINE PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
[1779]	164
[1762]	165	IMPLICIT none
	166
[1779]	167	REAL(wp), 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
	172
[1762]	173	ierr = 0
[1779]	174	CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
[1762]	175
	176	return
	177	END SUBROUTINE PMC_Send_to_Server_real_r1
	178
	179	SUBROUTINE PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
[1779]	180
[1762]	181	IMPLICIT none
	182
[1779]	183	REAL(wp), DIMENSION(:), INTENT(OUT) :: buf
	184	INTEGER, INTENT(IN) :: n
	185	INTEGER, INTENT(IN) :: Server_rank
	186	INTEGER, INTENT(IN) :: tag
	187	INTEGER, INTENT(OUT) :: ierr
	188
[1762]	189	ierr = 0
[1779]	190	CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
	191	MPI_STATUS_IGNORE, ierr)
[1762]	192
	193	return
	194	END SUBROUTINE PMC_Recv_from_Server_real_r1
	195
	196	SUBROUTINE PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
[1779]	197
[1762]	198	IMPLICIT none
	199
[1779]	200	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf
	201	INTEGER, INTENT(IN) :: n
	202	INTEGER, INTENT(IN) :: Server_rank
	203	INTEGER, INTENT(IN) :: tag
	204	INTEGER, INTENT(OUT) :: ierr
	205
[1762]	206	ierr = 0
[1779]	207	CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
[1762]	208
	209	return
	210	END SUBROUTINE PMC_Send_to_Server_real_r2
	211
	212	SUBROUTINE PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
[1779]	213
[1762]	214	IMPLICIT none
	215
[1779]	216	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf
	217	INTEGER, INTENT(IN) :: n
	218	INTEGER, INTENT(IN) :: Server_rank
	219	INTEGER, INTENT(IN) :: tag
	220	INTEGER, INTENT(OUT) :: ierr
	221
[1762]	222	ierr = 0
[1779]	223	CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
[1762]	224	MPI_STATUS_IGNORE, ierr)
	225
	226	return
	227	END SUBROUTINE PMC_Recv_from_Server_real_r2
	228
	229	SUBROUTINE PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
[1779]	230
[1762]	231	IMPLICIT none
	232
[1779]	233	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf
	234	INTEGER, INTENT(IN) :: n
	235	INTEGER, INTENT(IN) :: Server_rank
	236	INTEGER, INTENT(IN) :: tag
	237	INTEGER, INTENT(OUT) :: ierr
	238
[1762]	239	ierr = 0
[1779]	240	CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
[1762]	241
	242	return
	243	END SUBROUTINE PMC_Send_to_Server_real_r3
	244
	245	SUBROUTINE PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
[1779]	246
[1762]	247	IMPLICIT none
	248
[1779]	249	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf
	250	INTEGER, INTENT(IN) :: n
	251	INTEGER, INTENT(IN) :: Server_rank
	252	INTEGER, INTENT(IN) :: tag
	253	INTEGER, INTENT(OUT) :: ierr
	254
[1762]	255	ierr = 0
[1779]	256	CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
[1762]	257	MPI_STATUS_IGNORE, ierr)
	258
	259	return
	260	END SUBROUTINE PMC_Recv_from_Server_real_r3
	261
	262
	263	SUBROUTINE PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
	264	IMPLICIT none
	265	INTEGER, INTENT(IN) :: Client_id
	266	INTEGER, DIMENSION(:), INTENT(IN) :: buf
	267	INTEGER, INTENT(IN) :: n
	268	INTEGER, INTENT(IN) :: Client_rank
	269	INTEGER, INTENT(IN) :: tag
	270	INTEGER, INTENT(OUT) :: ierr
	271
	272	ierr = 0
	273	CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr)
	274
	275	return
	276	END SUBROUTINE PMC_Send_to_Client_INTEGER
	277
	278	SUBROUTINE PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr)
	279	IMPLICIT none
	280	INTEGER, INTENT(IN) :: Client_id
	281	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf
	282	INTEGER, INTENT(IN) :: n
	283	INTEGER, INTENT(IN) :: Client_rank
	284	INTEGER, INTENT(IN) :: tag
	285	INTEGER, INTENT(OUT) :: ierr
	286
	287	ierr = 0
	288	CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
	289	MPI_STATUS_IGNORE, ierr)
	290
	291	return
	292	END SUBROUTINE PMC_Recv_from_Client_INTEGER
	293
	294	SUBROUTINE PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr)
	295	IMPLICIT none
	296	INTEGER, INTENT(IN) :: Client_id
	297	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf
	298	INTEGER, INTENT(IN) :: n
	299	INTEGER, INTENT(IN) :: Client_rank
	300	INTEGER, INTENT(IN) :: tag
	301	INTEGER, INTENT(OUT) :: ierr
	302
	303	ierr = 0
	304	CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), &
	305	MPI_STATUS_IGNORE, ierr)
	306
	307	return
	308	END SUBROUTINE PMC_Recv_from_Client_INTEGER_2
	309
	310	SUBROUTINE PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	311
[1762]	312	IMPLICIT none
	313
[1779]	314	INTEGER, INTENT(IN) :: Client_id
	315	REAL(wp), DIMENSION(:), INTENT(IN) :: buf
	316	INTEGER, INTENT(IN) :: n
	317	INTEGER, INTENT(IN) :: Client_rank
	318	INTEGER, INTENT(IN) :: tag
	319	INTEGER, INTENT(OUT) :: ierr
	320
[1762]	321	ierr = 0
[1779]	322	CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	323	ierr)
	324
	325	return
	326	END SUBROUTINE PMC_Send_to_Client_real_r1
	327
	328	SUBROUTINE PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	329
[1762]	330	IMPLICIT none
	331
[1779]	332	INTEGER, INTENT(IN) :: Client_id
	333	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf
	334	INTEGER, INTENT(IN) :: n
	335	INTEGER, INTENT(IN) :: Client_rank
	336	INTEGER, INTENT(IN) :: tag
	337	INTEGER, INTENT(OUT) :: ierr
	338
[1762]	339	ierr = 0
[1779]	340	CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	341	MPI_STATUS_IGNORE, ierr)
	342
	343	return
	344	END SUBROUTINE PMC_Recv_from_Client_real_r1
	345
	346	SUBROUTINE PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	347
[1762]	348	IMPLICIT none
	349
[1779]	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
	356
[1762]	357	ierr = 0
[1779]	358	CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	359	ierr)
	360
	361	return
	362	END SUBROUTINE PMC_Send_to_Client_real_r2
	363
	364	SUBROUTINE PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	365
[1762]	366	IMPLICIT none
	367
[1779]	368	INTEGER, INTENT(IN) :: Client_id
	369	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf
	370	INTEGER, INTENT(IN) :: n
	371	INTEGER, INTENT(IN) :: Client_rank
	372	INTEGER, INTENT(IN) :: tag
	373	INTEGER, INTENT(OUT) :: ierr
	374
[1762]	375	ierr = 0
[1779]	376	CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	377	MPI_STATUS_IGNORE, ierr)
	378
	379	return
	380	END SUBROUTINE PMC_Recv_from_Client_real_r2
	381
	382	SUBROUTINE PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	383
[1762]	384	IMPLICIT none
	385
[1779]	386	INTEGER, INTENT(IN) :: Client_id
	387	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf
	388	INTEGER, INTENT(IN) :: n
	389	INTEGER, INTENT(IN) :: Client_rank
	390	INTEGER, INTENT(IN) :: tag
	391	INTEGER, INTENT(OUT) :: ierr
	392
[1762]	393	ierr = 0
[1779]	394	CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	395	ierr)
	396
	397	return
	398	END SUBROUTINE PMC_Send_to_Client_real_r3
	399
	400	SUBROUTINE PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
[1779]	401
[1762]	402	IMPLICIT none
	403
[1779]	404	INTEGER, INTENT(IN) :: Client_id
	405	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf
	406	INTEGER, INTENT(IN) :: n
	407	INTEGER, INTENT(IN) :: Client_rank
	408	INTEGER, INTENT(IN) :: tag
	409	INTEGER, INTENT(OUT) :: ierr
	410
[1762]	411	ierr = 0
[1779]	412	CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
[1762]	413	MPI_STATUS_IGNORE, ierr)
	414
	415	return
	416	END SUBROUTINE PMC_Recv_from_Client_real_r3
	417
	418	SUBROUTINE PMC_Bcast_INTEGER (buf, root_pe, comm, ierr)
	419	IMPLICIT none
	420	INTEGER, INTENT(INOUT) :: buf
	421	INTEGER, INTENT(IN) :: root_pe
	422	INTEGER, INTENT(IN),optional :: comm
	423	INTEGER, INTENT(OUT),optional :: ierr
	424	!-- local variables
	425	INTEGER :: myComm
	426	INTEGER :: myErr
	427
	428	if(present (comm)) then
	429	myComm = comm
	430	else
	431	myComm = m_model_comm
	432	end if
	433
	434	CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr)
	435
	436	if(present (ierr)) then
	437	ierr = myErr
	438	end if
	439
	440	return
	441	END SUBROUTINE PMC_Bcast_INTEGER
	442
	443	SUBROUTINE PMC_Bcast_character (buf, root_pe, comm, ierr)
	444	IMPLICIT none
	445	character(len=*), INTENT(INOUT) :: buf
	446	INTEGER, INTENT(IN) :: root_pe
	447	INTEGER, INTENT(IN),optional :: comm
	448	INTEGER, INTENT(OUT),optional :: ierr
	449	!-- local variables
	450	INTEGER :: myComm
	451	INTEGER :: myErr
	452
	453	if(present (comm)) then
	454	myComm = comm
	455	else
	456	myComm = m_model_comm
	457	end if
	458
	459	CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr)
	460
	461	if(present (ierr)) then
	462	ierr = myErr
	463	end if
	464
	465	return
	466	END SUBROUTINE PMC_Bcast_character
	467
	468	SUBROUTINE PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr)
	469	IMPLICIT none
	470	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf
	471	INTEGER, INTENT(IN),optional :: Client_id
	472	INTEGER, INTENT(OUT),optional :: ierr
	473	!-- local variables
	474	INTEGER :: myComm
	475	INTEGER :: myErr
	476	INTEGER :: root_pe
	477
	478	! PE 0 Server Broadcast to all Client PE's
	479
	480	if(present (Client_id)) then
	481	myComm = m_to_client_comm(Client_id)
	482	if(m_model_rank == 0) then
	483	root_pe = MPI_ROOT
	484	else
	485	root_pe = MPI_PROC_NULL
	486	end if
	487	else
	488	myComm = m_to_server_comm
	489	root_pe = 0
	490	end if
	491
	492	CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr)
	493
	494	if(present (ierr)) then
	495	ierr = myErr
	496	end if
	497
	498	return
	499	END SUBROUTINE PMC_Inter_Bcast_INTEGER_1
	500
	501	! Allocate Memory with MPI_Alloc_mem using intermediate C-pointer
	502
	503	SUBROUTINE PMC_Alloc_mem_INTEGER_1 (iarray, idim1)
	504	IMPLICIT none
	505	INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray
	506	INTEGER,INTENT(IN) :: idim1
	507
	508	Type(c_ptr) :: p_myInd
	509	INTEGER,DIMENSION(1) :: aShape
	510	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
	511	INTEGER :: ierr
	512
	513	WinSize = idim1*c_sizeof(ierr) ! Length of INTEGER
	514
	515	CALL MPI_Alloc_mem (WinSize , MPI_INFO_NULL, p_myInd, ierr);
	516	aShape(1) = idim1
	517	CALL c_f_pointer(p_myInd,iarray,aShape)
	518
	519	return
	520	END SUBROUTINE PMC_Alloc_mem_INTEGER_1
	521
	522	SUBROUTINE PMC_Alloc_mem_Real_1 (array, idim1, base_ptr)
	523	IMPLICIT none
	524	REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array
[1764]	525	INTEGER(idp),INTENT(IN) :: idim1
[1762]	526	Type(c_ptr),INTENT(OUT),optional :: base_ptr
	527
	528
	529	Type(c_ptr) :: p_myInd
	530	INTEGER,DIMENSION(1) :: aShape
	531	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
	532	INTEGER :: ierr
	533
	534	WinSize = idim1*wp ! Length of INTEGER
	535
	536	CALL MPI_Alloc_mem (WinSize , MPI_INFO_NULL, p_myInd, ierr);
	537	aShape(1) = idim1
	538	CALL c_f_pointer(p_myInd,array,aShape)
	539
	540	if(present(base_ptr)) then
	541	base_ptr = p_myInd
	542	end if
	543
	544	return
	545	END SUBROUTINE PMC_Alloc_mem_Real_1
	546
	547	FUNCTION PMC_TIME ()
	548	REAL(kind=wp) :: PMC_TIME
	549
	550	PMC_TIME = MPI_Wtime ()
	551
	552	return
	553
	554	END FUNCTION PMC_TIME
	555
[1764]	556	#endif
[1762]	557	END MODULE pmc_mpi_wrapper

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |