Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |