Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |