Home

Context Navigation

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

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

Line
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	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_client.f90 1787 2016-03-08 06:57:00Z raasch $
27	!
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	!
32	! 1783 2016-03-06 18:36:17Z raasch
33	! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
34	!
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	!
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	!
43	! 1762 2016-02-25 12:31:13Z hellstea
44	! Initial revision by K. Ketelsen
45	!
46	! Description:
47	! ------------
48	!
49	! Client part of Palm Model Coupler
50	!------------------------------------------------------------------------------!
51
52	#if defined( __parallel )
53
54	use, intrinsic :: iso_c_binding
55
56	#if defined( __lc )
57	USE MPI
58	#else
59	INCLUDE "mpif.h"
60	#endif
61	USE kinds
62	USE PMC_general, ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
63	DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
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
73	INTEGER :: next_array_in_list = 0
74	INTEGER :: myIndex = 0 !Counter and unique number for Data Arrays
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
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
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
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
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
146	!
147	!-- Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
148	do i=1,me%inter_npes
149	ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
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
157	SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
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
241	TYPE(PeDef),POINTER :: aPE !: Pointer to PeDef structure
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))
272	WinSize = 1
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
277	CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
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
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
318	LOGICAL function PMC_C_GetNextArray (myName)
319	character(len=*),INTENT(OUT) :: myName
320
321	!-- local variables
322	TYPE(PeDef),POINTER :: aPE
323	TYPE(ArrayDef),POINTER :: ar
324
325	next_array_in_list = next_array_in_list+1
326
327	!-- Array Names are the same on all client PE, so take first PE to get the name
328	aPE => me%PEs(1)
329
330	if(next_array_in_list > aPE%Nr_arrays) then
331	PMC_C_GetNextArray = .false. !all arrays done
332	return
333	end if
334
335	ar => aPE%array_list(next_array_in_list)
336
337	myName = ar%name
338
339	PMC_C_GetNextArray = .true. ! Return true if legal array
340	return
341	END function PMC_C_GetNextArray
342
343	SUBROUTINE PMC_C_Set_DataArray_2d (array)
344
345	IMPLICIT none
346
347	REAL(wp), INTENT(IN) ,DIMENSION(:,:) :: array
348
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
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)
367	ar => aPE%array_list(next_array_in_list)
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)
377
378	IMPLICIT none
379
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
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)
400	ar => aPE%array_list(next_array_in_list) !actual array is last array in list
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
410
411	IMPLICIT none
412
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
421	INTEGER :: arlen, myIndex, tag
422	INTEGER(idp) :: bufsize ! Size of MPI data Window
423	TYPE(PeDef),POINTER :: aPE
424	TYPE(ArrayDef),POINTER :: ar
425	INTEGER,DIMENSION(1024) :: req
426	character(len=DA_Namelen) :: myName
427	Type(c_ptr) :: base_ptr
428	REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc !Base array
429	REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs !Base array
430	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
431
432	myIndex = 0
433	bufsize = 8
434
435	!-- Server to client direction
436
437	!-- First stride, Compute size and set index
438
439	do i=1,me%inter_npes
440	aPE => me%PEs(i)
441	tag = 200
442
443	do j=1,aPE%Nr_arrays
444	ar => aPE%array_list(j)
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
450	if(ar%NrDims == 3) then
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
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
515	end do
516	if(rCount > 0) then ! Wait for all send completed
517	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
518	end if
519	end do
520
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
525
526	CALL PMC_Alloc_mem (base_array_cs, bufsize)
527	me%TotalBufferSize = bufsize*wp !Total buffer size in Byte
528
529	WinSize = me%TotalBufferSize
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
532	CALL MPI_Barrier(me%intra_comm, ierr)
533
534	!-- Second stride, Set Buffer pointer
535
536	do i=1,me%inter_npes
537	aPE => me%PEs(i)
538
539	do j=1,aPE%Nr_arrays
540	ar => aPE%array_list(j)
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
548	end do
549	end do
550
551	return
552	END SUBROUTINE PMC_C_setInd_and_AllocMem
553
554	SUBROUTINE PMC_C_GetBuffer (WaitTime)
555
556	IMPLICIT none
557
558	REAL(wp), INTENT(OUT), optional :: WaitTime
559
560	!-- local variables
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
573
574	t1 = PMC_Time()
575	CALL MPI_Barrier(me%intra_comm, ierr) ! Wait for server to fill buffer
576	t2 = PMC_Time()-t1
577	if(present(WaitTime)) WaitTime = t2
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
584	do j=1,aPE%Nr_arrays
585	ar => aPE%array_list(j)
586	if(ar%NrDims == 2) then
587	nr = aPE%NrEle
588	else if(ar%NrDims == 3) then
589	nr = aPE%NrEle*ar%A_dim(1)
590	end if
591
592	buf_shape(1) = nr
593	CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
594	!
595	!-- MPI passive target RMA
596	if(nr > 0) then
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)
601	end if
602
603	myIndex = 1
604	if(ar%NrDims == 2) then
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
611	else if(ar%NrDims == 3) then
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)
625
626	IMPLICIT none
627
628	REAL(wp), INTENT(OUT), optional :: WaitTime
629
630	!-- local variables
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
643
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
648
649	do ip=1,me%inter_npes
650	aPE => me%PEs(ip)
651
652	do j=1,aPE%Nr_arrays
653	ar => aPE%array_list(j)
654	myIndex=1
655	if(ar%NrDims == 2) then
656	buf_shape(1) = aPE%NrEle
657	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
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
663	else if(ar%NrDims == 3) then
664	buf_shape(1) = aPE%NrEle*ar%A_dim(1)
665	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
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
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
678
679	return
680	END SUBROUTINE PMC_C_PutBuffer
681
682	#endif
683	END MODULE pmc_client

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |