Home

Context Navigation

source: palm/trunk/SOURCE/pmc_client.f90 @ 1779

Last change on this file since 1779 was 1779, checked in by raasch, 8 years ago
pmc array management changed from linked list to sequential loop; further small changes and cosmetics for the pmc
Property svn:keywords set to `Id`
File size: 21.0 KB

Rev	Line
[1762]	1	MODULE pmc_client
	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	!
	17	! Copyright 1997-2015 Leibniz Universitaet Hannover
	18	!--------------------------------------------------------------------------------!
	19	!
	20	! Current revisions:
	21	! ------------------
[1779]	22	! kind=dp replaced by wp, dim_order removed
	23	! array management changed from linked list to sequential loop
[1762]	24	!
	25	! Former revisions:
	26	! -----------------
	27	! $Id: pmc_client.f90 1779 2016-03-03 08:01:28Z raasch $
	28	!
[1765]	29	! 1764 2016-02-28 12:45:19Z raasch
	30	! cpp-statement added (nesting can only be used in parallel mode),
	31	! all kinds given in PALM style
	32	!
[1763]	33	! 1762 2016-02-25 12:31:13Z hellstea
	34	! Initial revision by K. Ketelsen
[1762]	35	!
	36	! Description:
	37	! ------------
	38	!
	39	! Client part of Palm Model Coupler
	40	!------------------------------------------------------------------------------!
	41
[1764]	42	#if defined( __parallel )
[1762]	43
	44	use, intrinsic :: iso_c_binding
	45
[1764]	46	#if defined( __lc )
	47	USE MPI
	48	#else
	49	INCLUDE "mpif.h"
	50	#endif
	51	USE kinds
[1762]	52	USE PMC_general, ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
[1779]	53	DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
[1762]	54	USE PMC_handle_communicator, ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
	55	USE PMC_MPI_wrapper, ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time, &
	56	PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem
	57	IMPLICIT none
	58	PRIVATE
	59	SAVE
	60
	61	Type(ClientDef) :: me
	62
[1779]	63	INTEGER :: next_array_in_list = 0
	64	INTEGER :: myIndex = 0 !Counter and unique number for Data Arrays
[1762]	65
	66	! INTERFACE section
	67
	68	INTERFACE PMC_ClientInit
	69	MODULE procedure PMC_ClientInit
	70	END INTERFACE PMC_ClientInit
	71
	72	INTERFACE PMC_Set_DataArray_Name
	73	MODULE procedure PMC_Set_DataArray_Name
	74	MODULE procedure PMC_Set_DataArray_Name_LastEntry
	75	END INTERFACE PMC_Set_DataArray_Name
	76
	77	INTERFACE PMC_C_Get_2D_index_list
	78	MODULE procedure PMC_C_Get_2D_index_list
	79	END INTERFACE PMC_C_Get_2D_index_list
	80
[1779]	81	INTERFACE PMC_C_clear_next_array_list
	82	MODULE procedure PMC_C_clear_next_array_list
	83	END INTERFACE PMC_C_clear_next_array_list
	84
[1762]	85	INTERFACE PMC_C_GetNextArray
	86	MODULE procedure PMC_C_GetNextArray
	87	END INTERFACE PMC_C_GetNextArray
	88
	89	INTERFACE PMC_C_Set_DataArray
	90	MODULE procedure PMC_C_Set_DataArray_2d
	91	MODULE procedure PMC_C_Set_DataArray_3d
	92	END INTERFACE PMC_C_Set_DataArray
	93
	94	INTERFACE PMC_C_setInd_and_AllocMem
	95	MODULE procedure PMC_C_setInd_and_AllocMem
	96	END INTERFACE PMC_C_setInd_and_AllocMem
	97
	98	INTERFACE PMC_C_GetBuffer
	99	MODULE procedure PMC_C_GetBuffer
	100	END INTERFACE PMC_C_GetBuffer
	101
	102	INTERFACE PMC_C_PutBuffer
	103	MODULE procedure PMC_C_PutBuffer
	104	END INTERFACE PMC_C_PutBuffer
	105
	106	! Public section
	107
	108	PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
[1779]	109	PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
	110	PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
[1762]	111
	112	CONTAINS
	113
	114	SUBROUTINE PMC_ClientInit
	115	IMPLICIT none
	116
	117	INTEGER :: i
	118	INTEGER :: istat
	119
	120
	121	! Tailor MPI environment
	122
	123	me%model_comm = m_model_comm
	124	me%inter_comm = m_to_server_comm
	125
	126	! Get rank and size
	127	CALL MPI_Comm_rank (me%model_comm, me%model_rank, istat);
	128	CALL MPI_Comm_size (me%model_comm, me%model_npes, istat);
	129	CALL MPI_Comm_remote_size (me%inter_comm, me%inter_npes, istat);
	130
	131	! intra communicater is used for MPI_Get
	132	CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
	133	CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
	134	ALLOCATE (me%PEs(me%inter_npes))
	135
[1779]	136	!
	137	!-- Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
[1762]	138	do i=1,me%inter_npes
[1779]	139	ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
[1762]	140	end do
	141
	142	if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
	143
	144	return
	145	END SUBROUTINE PMC_ClientInit
	146
[1779]	147	SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
[1762]	148	IMPLICIT none
	149	character(len=*),INTENT(IN) :: ServerArrayName
	150	character(len=*),INTENT(IN) :: ServerArrayDesc
	151	character(len=*),INTENT(IN) :: ClientArrayName
	152	character(len=*),INTENT(IN) :: ClientArrayDesc
	153	INTEGER,INTENT(OUT) :: istat
	154
	155	!-- local variables
	156	type(DA_NameDef) :: myName
	157	INTEGER :: myPe
	158	INTEGER :: my_AddiArray=0
	159
	160	istat = PMC_STATUS_OK
	161	if(len(trim(ServerArrayName)) > DA_Namelen .or. &
	162	len(trim(ClientArrayName)) > DA_Namelen) then !Name too long
	163	istat = PMC_DA_NAME_ERR
	164	end if
	165
	166	if(m_model_rank == 0) then
	167	myIndex = myIndex+1
	168	myName%couple_index = myIndex
	169	myName%ServerDesc = trim(ServerArrayDesc)
	170	myName%NameOnServer = trim(ServerArrayName)
	171	myName%ClientDesc = trim(ClientArrayDesc)
	172	myName%NameOnClient = trim(ClientArrayName)
	173	end if
	174
	175	! Broadcat to all Client PEs
	176
	177	CALL PMC_Bcast ( myName%couple_index, 0, comm=m_model_comm)
	178	CALL PMC_Bcast ( myName%ServerDesc, 0, comm=m_model_comm)
	179	CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_model_comm)
	180	CALL PMC_Bcast ( myName%ClientDesc, 0, comm=m_model_comm)
	181	CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_model_comm)
	182
	183	! Broadcat to all Server PEs
	184
	185	if(m_model_rank == 0) then
	186	myPE = MPI_ROOT
	187	else
	188	myPE = MPI_PROC_NULL
	189	endif
	190	CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
	191	CALL PMC_Bcast ( myName%ServerDesc, myPE, comm=m_to_server_comm)
	192	CALL PMC_Bcast ( myName%NameOnServer, myPE, comm=m_to_server_comm)
	193	CALL PMC_Bcast ( myName%ClientDesc, myPE, comm=m_to_server_comm)
	194	CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
	195
	196	CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
	197
	198	return
	199	END SUBROUTINE PMC_Set_DataArray_Name
	200
	201	SUBROUTINE PMC_Set_DataArray_Name_LastEntry (LastEntry)
	202	IMPLICIT none
	203	LOGICAL,INTENT(IN),optional :: LastEntry
	204
	205	!-- local variables
	206	type(DA_NameDef) :: myName
	207	INTEGER :: myPe
	208
	209	myName%couple_index = -1
	210
	211	if(m_model_rank == 0) then
	212	myPE = MPI_ROOT
	213	else
	214	myPE = MPI_PROC_NULL
	215	endif
	216	CALL PMC_Bcast ( myName%couple_index, myPE, comm=m_to_server_comm)
	217
	218	return
	219	END SUBROUTINE PMC_Set_DataArray_Name_LastEntry
	220
	221	SUBROUTINE PMC_C_Get_2D_index_list
	222	IMPLICIT none
	223
	224	INTEGER :: i,j,i2,nr,ierr
	225	INTEGER :: dummy
	226	INTEGER :: indWin !: MPI window object
	227	INTEGER :: indWin2 !: MPI window object
	228	INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !: Size of MPI window 1 (in bytes)
	229	INTEGER(KIND=MPI_ADDRESS_KIND) :: disp !: Displacement Unit (Integer = 4, floating poit = 8
	230	INTEGER,DIMENSION(me%inter_npes*2) :: NrEle !: Number of Elements of a horizontal slice
[1779]	231	TYPE(PeDef),POINTER :: aPE !: Pointer to PeDef structure
[1762]	232	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize !: Size of MPI window 2 (in bytes)
	233	INTEGER,DIMENSION(:),POINTER :: myInd
	234
	235	! CALL PMC_C_CGet_Rem_index_list
	236
	237	win_size = c_sizeof(dummy)
	238	CALL MPI_Win_create (dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indWin, ierr);
	239	CALL MPI_Win_fence (0, indWin, ierr) ! Open Window on Server side
	240	CALL MPI_Win_fence (0, indWin, ierr) ! Close Window on Server Side and opem on Client side
	241
	242	do i=1,me%inter_npes
	243	disp = me%model_rank*2
	244	CALL MPI_Get (NrEle((i-1)*2+1),2,MPI_INTEGER,i-1,disp,2,MPI_INTEGER,indWin, ierr)
	245	end do
	246	CALL MPI_Win_fence (0, indWin, ierr) ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
	247
	248	WinSize = 0
	249	do i=1,me%inter_npes !Allocate memory for index array
	250	aPE => me%PEs(i)
	251	i2 = (i-1)*2+1
	252	nr = NrEle(i2+1)
	253	if(nr > 0) then
	254	ALLOCATE(aPE%locInd(nr))
	255	else
	256	NULLIFY (aPE%locInd)
	257	endif
	258	WinSize = max(nr,WinSize) !Maximum window size
	259	end do
	260
	261	ALLOCATE(myInd(2*WinSize))
	262	WinSize = WinSize*c_sizeof(i)
	263
	264	! local Buffer used in MPI_Get can but must not be inside the MPI Window
	265	! Here, we use a dummy for MPI Window because the server PEs do not access the RMA window via MPI_get or MPI_Put
	266
	267	CALL MPI_Win_create (dummy, 1, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
	268
	269	CALL MPI_Win_fence (0, indWin2, ierr) ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
	270	CALL MPI_Win_fence (0, indWin2, ierr) ! MPI_get is Non-blocking -> data in NrEle is not available until MPI_fence CALL
	271
	272	do i=1,me%inter_npes
	273	aPE => me%PEs(i)
	274	nr = NrEle(i*2)
	275	if(nr > 0 ) then
	276	disp = NrEle(2*(i-1)+1)
	277	CALL MPI_Win_lock (MPI_LOCK_SHARED , i-1, 0, indWin2, ierr)
	278	CALL MPI_Get (myInd,2nr,MPI_INTEGER,i-1,disp,2nr,MPI_INTEGER,indWin2, ierr)
	279	CALL MPI_Win_unlock (i-1, indWin2, ierr)
	280	do j=1,nr
	281	aPE%locInd(j)%i = myInd(2*j-1)
	282	aPE%locInd(j)%j = myInd(2*j)
	283	end do
	284	aPE%NrEle = nr
	285	else
	286	aPE%NrEle = -1
	287	end if
	288	end do
	289
	290	CALL MPI_Barrier(me%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
	291
	292	CALL MPI_Win_free(indWin, ierr);
	293	CALL MPI_Win_free(indWin2, ierr);
	294	DEALLOCATE (myInd)
	295
	296	return
	297	END SUBROUTINE PMC_C_Get_2D_index_list
	298
[1779]	299	SUBROUTINE PMC_C_clear_next_array_list
	300	IMPLICIT none
	301
	302	next_array_in_list = 0
	303
	304	return
	305	END SUBROUTINE PMC_C_clear_next_array_list
	306
	307	! List handling is still required to get minimal interaction with pmc_interface
[1762]	308	LOGICAL function PMC_C_GetNextArray (myName)
	309	character(len=*),INTENT(OUT) :: myName
	310
	311	!-- local variables
[1779]	312	TYPE(PeDef),POINTER :: aPE
	313	TYPE(ArrayDef),POINTER :: ar
[1762]	314
[1779]	315	next_array_in_list = next_array_in_list+1
[1762]	316
[1779]	317	!-- Array Names are the same on all client PE, so take first PE to get the name
	318	aPE => me%PEs(1)
[1762]	319
[1779]	320	if(next_array_in_list > aPE%Nr_arrays) then
	321	PMC_C_GetNextArray = .false. !all arrays done
	322	return
	323	end if
[1762]	324
[1779]	325	ar => aPE%array_list(next_array_in_list)
[1762]	326
[1779]	327	myName = ar%name
	328
	329	PMC_C_GetNextArray = .true. ! Return true if legal array
	330	return
[1762]	331	END function PMC_C_GetNextArray
	332
	333	SUBROUTINE PMC_C_Set_DataArray_2d (array)
[1779]	334
[1762]	335	IMPLICIT none
	336
[1779]	337	REAL(wp), INTENT(IN) ,DIMENSION(:,:) :: array
[1762]	338
[1779]	339	INTEGER :: NrDims
	340	INTEGER,DIMENSION (4) :: dims
	341	TYPE(c_ptr) :: array_adr
	342	INTEGER :: i
	343	TYPE(PeDef),POINTER :: aPE
	344	TYPE(ArrayDef),POINTER :: ar
	345
	346
[1762]	347	dims = 1
	348
	349	NrDims = 2
	350	dims(1) = size(array,1)
	351	dims(2) = size(array,2)
	352
	353	array_adr = c_loc(array)
	354
	355	do i=1,me%inter_npes
	356	aPE => me%PEs(i)
[1779]	357	ar => aPE%array_list(next_array_in_list) !actual array is last array in list
[1762]	358	ar%NrDims = NrDims
	359	ar%A_dim = dims
	360	ar%data = array_adr
	361	end do
	362
	363	return
	364	END SUBROUTINE PMC_C_Set_DataArray_2d
	365
	366	SUBROUTINE PMC_C_Set_DataArray_3d (array)
[1779]	367
[1762]	368	IMPLICIT none
	369
[1779]	370	REAL(wp),INTENT(IN),DIMENSION(:,:,:) :: array
	371
	372	INTEGER :: NrDims
	373	INTEGER,DIMENSION (4) :: dims
	374	TYPE(c_ptr) :: array_adr
	375	INTEGER :: i
	376	TYPE(PeDef),POINTER :: aPE
	377	TYPE(ArrayDef),POINTER :: ar
	378
[1762]	379	dims = 1
	380
	381	NrDims = 3
	382	dims(1) = size(array,1)
	383	dims(2) = size(array,2)
	384	dims(3) = size(array,3)
	385
	386	array_adr = c_loc(array)
	387
	388	do i=1,me%inter_npes
	389	aPE => me%PEs(i)
[1779]	390	ar => aPE%array_list(next_array_in_list) !actual array is last array in list
[1762]	391	ar%NrDims = NrDims
	392	ar%A_dim = dims
	393	ar%data = array_adr
	394	end do
	395
	396	return
	397	END SUBROUTINE PMC_C_Set_DataArray_3d
	398
	399	SUBROUTINE PMC_C_setInd_and_AllocMem
[1764]	400
[1762]	401	IMPLICIT none
	402
[1779]	403	INTEGER :: i, ierr, j
[1762]	404	INTEGER :: arlen, myIndex, tag
[1764]	405	INTEGER(idp) :: bufsize ! Size of MPI data Window
[1762]	406	TYPE(PeDef),POINTER :: aPE
	407	TYPE(ArrayDef),POINTER :: ar
	408	character(len=DA_Namelen) :: myName
	409	Type(c_ptr) :: base_ptr
	410	REAL(kind=wp),DIMENSION(:),POINTER :: base_array
	411	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
	412
	413	myIndex = 0
	414	bufsize = 8
	415
	416	! First stride, Compute size and set index
	417
	418	do i=1,me%inter_npes
	419	aPE => me%PEs(i)
	420	tag = 200
	421
[1779]	422	do j=1,aPE%Nr_arrays
	423	ar => aPE%array_list(j)
[1762]	424
	425	! Receive Index from client
	426	tag = tag+1
	427	CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
	428
[1779]	429	if(ar%NrDims == 3) then ! PALM has k in first dimension
[1762]	430	bufsize = max(bufsize,ar%A_dim(1)ar%A_dim(2)ar%A_dim(3)) ! determine max, because client buffer is allocated only once
	431	else
	432	bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2))
	433	end if
	434	ar%BufIndex = myIndex
	435	end do
	436	end do
	437
	438	! Create RMA (One Sided Communication) window for data buffer
	439
	440	CALL PMC_Alloc_mem (base_array, bufsize, base_ptr)
	441	me%TotalBufferSize = bufsize*wp !Total buffer size in Byte
	442
	443	WinSize = me%TotalBufferSize
	444	! write(9,'(a,8i7)') 'PMC_S_SetInd_and_Mem ',m_model_rank,me%inter_npes,WinSize,ar%A_dim
	445	CALL MPI_Win_create (base_array, WinSize, wp, MPI_INFO_NULL, me%intra_comm, me%BufWin, ierr);
	446	CALL MPI_Win_fence (0, me%BufWin, ierr); ! Open Window to set data
	447	CALL MPI_Barrier(me%intra_comm, ierr)
	448
	449	do i=1,me%inter_npes
	450	aPE => me%PEs(i)
	451
[1779]	452	do j=1,aPE%Nr_arrays
	453	ar => aPE%array_list(j)
[1762]	454	ar%SendBuf = base_ptr
	455	end do
	456	end do
	457
	458	return
	459	END SUBROUTINE PMC_C_setInd_and_AllocMem
	460
	461	SUBROUTINE PMC_C_GetBuffer (WaitTime)
[1779]	462
[1762]	463	IMPLICIT none
	464
[1779]	465	REAL(wp), INTENT(OUT), optional :: WaitTime
	466
[1762]	467	!-- local variables
[1779]	468	INTEGER :: ip, ij, ierr, j
	469	INTEGER :: nr ! Number of Elements to getb from server
	470	INTEGER :: myIndex
	471	REAL(wp) :: t1,t2
	472	TYPE(PeDef),POINTER :: aPE
	473	TYPE(ArrayDef),POINTER :: ar
	474	INTEGER,DIMENSION(1) :: buf_shape
	475	REAL(wp),POINTER,DIMENSION(:) :: buf
	476	REAL(wp),POINTER,DIMENSION(:,:) :: data_2d
	477	REAL(wp),POINTER,DIMENSION(:,:,:) :: data_3d
	478	character(len=DA_Namelen) :: myName
	479	INTEGER(kind=MPI_ADDRESS_KIND) :: target_disp
[1762]	480
	481	t1 = PMC_Time()
	482	CALL MPI_Barrier(me%intra_comm, ierr) ! Wait for server to fill buffer
[1779]	483	t2 = PMC_Time()-t1
	484	if(present(WaitTime)) WaitTime = t2
[1762]	485
	486	CALL MPI_Barrier(me%intra_comm, ierr) ! Wait for buffer is filled
	487
	488	do ip=1,me%inter_npes
	489	aPE => me%PEs(ip)
	490
[1779]	491	do j=1,aPE%Nr_arrays
	492	ar => aPE%array_list(j)
	493	if(ar%NrDims == 2) then
[1762]	494	nr = aPE%NrEle
[1779]	495	else if(ar%NrDims == 3) then
[1762]	496	nr = aPE%NrEle*ar%A_dim(1)
	497	end if
	498
	499	buf_shape(1) = nr
	500	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
[1779]	501	!
	502	!-- MPI passive target RMA
[1762]	503	if(nr > 0) then
	504	target_disp = (ar%BufIndex-1)
	505	CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%BufWin, ierr)
	506	CALL MPI_Get (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%BufWin, ierr)
	507	CALL MPI_Win_unlock (ip-1, me%BufWin, ierr)
	508	end if
	509
	510	myIndex = 1
[1779]	511	if(ar%NrDims == 2) then
[1762]	512
	513	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
	514	do ij=1,aPE%NrEle
	515	data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
	516	myIndex = myIndex+1
	517	end do
[1779]	518	else if(ar%NrDims == 3) then
[1762]	519	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
	520	do ij=1,aPE%NrEle
	521	data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(1)-1)
	522	myIndex = myIndex+ar%A_dim(1)
	523	end do
	524	end if
	525
	526	end do
	527	end do
	528	return
	529	END SUBROUTINE PMC_C_GetBuffer
	530
	531	SUBROUTINE PMC_C_PutBuffer (WaitTime)
[1779]	532
[1762]	533	IMPLICIT none
	534
[1779]	535	REAL(wp), INTENT(OUT), optional :: WaitTime
	536
[1762]	537	!-- local variables
[1779]	538	INTEGER :: ip, ij, ierr, j
	539	INTEGER :: nr ! Number of Elements to getb from server
	540	INTEGER :: myIndex
	541	REAL(wp) :: t1,t2
	542	TYPE(PeDef),POINTER :: aPE
	543	TYPE(ArrayDef),POINTER :: ar
	544	INTEGER,DIMENSION(1) :: buf_shape
	545	REAL(wp),POINTER,DIMENSION(:) :: buf
	546	REAL(wp),POINTER,DIMENSION(:,:) :: data_2d
	547	REAL(wp),POINTER,DIMENSION(:,:,:) :: data_3d
	548	character(len=DA_Namelen) :: myName
	549	INTEGER(kind=MPI_ADDRESS_KIND) :: target_disp
[1762]	550
	551
	552	do ip=1,me%inter_npes
	553	aPE => me%PEs(ip)
	554
[1779]	555	do j=1,aPE%Nr_arrays
	556	ar => aPE%array_list(j)
	557	if(ar%NrDims == 2) then
[1762]	558	nr = aPE%NrEle
[1779]	559	else if(ar%NrDims == 3) then
[1762]	560	nr = aPE%NrEle*ar%A_dim(1)
	561	end if
	562
	563	buf_shape(1) = nr
	564	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
	565
	566	myIndex = 1
[1779]	567	if(ar%NrDims == 2) then
[1762]	568	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
	569	do ij=1,aPE%NrEle
	570	buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
	571	myIndex = myIndex+1
	572	end do
[1779]	573	else if(ar%NrDims == 3) then
[1762]	574	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
	575	do ij=1,aPE%NrEle
	576	buf(myIndex:myIndex+ar%A_dim(1)-1) = data_3d(:,aPE%locInd(ij)%j,aPE%locInd(ij)%i)
	577	myIndex = myIndex+ar%A_dim(1)
	578	end do
	579	end if
[1779]	580	!
	581	!-- MPI passiv target RMA
[1762]	582	if(nr > 0) then
	583	target_disp = (ar%BufIndex-1)
	584	CALL MPI_Win_lock (MPI_LOCK_SHARED , ip-1, 0, me%BufWin, ierr)
	585	CALL MPI_Put (buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, me%BufWin, ierr)
	586	CALL MPI_Win_unlock (ip-1, me%BufWin, ierr)
	587	end if
	588
	589	end do
	590	end do
	591
	592
	593	t1 = PMC_Time()
	594	CALL MPI_Barrier(me%intra_comm, ierr) ! Wait for server to fill buffer
	595	t2 = PMC_Time()
	596	if(present(WaitTime)) WaitTime = t2-t1
	597
	598	CALL MPI_Barrier(me%intra_comm, ierr) ! Wait for buffer is filled
	599
	600
	601	return
	602	END SUBROUTINE PMC_C_PutBuffer
	603
[1764]	604	#endif
[1762]	605	END MODULE pmc_client

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |