Home

Context Navigation

source: palm/trunk/SOURCE/pmc_client_mod.f90 @ 1875

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |