Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |