Home

Context Navigation

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

Last change on this file since 1851 was 1851, checked in by maronga, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 24.9 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-2016 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_client_mod.f90 1851 2016-04-08 13:32:50Z maronga $
27	!
28	! 1850 2016-04-08 13:29:27Z maronga
29	! Module renamed
30	!
31	!
32	! 1833 2016-04-07 14:23:03Z raasch
33	! gfortran requires pointer attributes for some array declarations,
34	! long line wrapped
35	!
36	! 1808 2016-04-05 19:44:00Z raasch
37	! MPI module used by default on all machines
38	!
39	! 1797 2016-03-21 16:50:28Z raasch
40	! introduction of different datatransfer modes
41	!
42	! 1791 2016-03-11 10:41:25Z raasch
43	! Debug write-statement commented out
44	!
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	!
49	! 1783 2016-03-06 18:36:17Z raasch
50	! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
51	!
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	!
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	!
60	! 1762 2016-02-25 12:31:13Z hellstea
61	! Initial revision by K. Ketelsen
62	!
63	! Description:
64	! ------------
65	!
66	! Client part of Palm Model Coupler
67	!------------------------------------------------------------------------------!
68
69	#if defined( __parallel )
70
71	use, intrinsic :: iso_c_binding
72
73	#if defined( __mpifh )
74	INCLUDE "mpif.h"
75	#else
76	USE MPI
77	#endif
78	USE kinds
79	USE PMC_general, ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
80	DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
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
90	INTEGER :: next_array_in_list = 0
91	INTEGER :: myIndex = 0 !Counter and unique number for Data Arrays
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
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
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
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
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
163	!
164	!-- Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
165	do i=1,me%inter_npes
166	ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
167	end do
168
169	! if(me%model_rank == 0) write(0,'(a,5i6)') 'PMC_ClientInit ',me%model_rank,me%model_npes,me%inter_npes,me%intra_rank
170
171	return
172	END SUBROUTINE PMC_ClientInit
173
174	SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
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
258	TYPE(PeDef),POINTER :: aPE !: Pointer to PeDef structure
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))
289	WinSize = 1
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
294	CALL MPI_Win_create (dummy, WinSize, iwp, MPI_INFO_NULL, me%intra_comm, indWin2, ierr);
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
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
335	LOGICAL function PMC_C_GetNextArray (myName)
336	character(len=*),INTENT(OUT) :: myName
337
338	!-- local variables
339	TYPE(PeDef),POINTER :: aPE
340	TYPE(ArrayDef),POINTER :: ar
341
342	next_array_in_list = next_array_in_list+1
343
344	!-- Array Names are the same on all client PE, so take first PE to get the name
345	aPE => me%PEs(1)
346
347	if(next_array_in_list > aPE%Nr_arrays) then
348	PMC_C_GetNextArray = .false. !all arrays done
349	return
350	end if
351
352	ar => aPE%array_list(next_array_in_list)
353
354	myName = ar%name
355
356	PMC_C_GetNextArray = .true. ! Return true if legal array
357	return
358	END function PMC_C_GetNextArray
359
360	SUBROUTINE PMC_C_Set_DataArray_2d (array)
361
362	IMPLICIT none
363
364	REAL(wp), INTENT(IN) ,DIMENSION(:,:), POINTER :: array
365
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
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)
384	ar => aPE%array_list(next_array_in_list)
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)
394
395	IMPLICIT none
396
397	REAL(wp),INTENT(IN),DIMENSION(:,:,:), POINTER :: array
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
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)
417	ar => aPE%array_list(next_array_in_list)
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
427
428	IMPLICIT none
429
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
438	INTEGER :: arlen, myIndex, tag
439	INTEGER(idp) :: bufsize ! Size of MPI data Window
440	TYPE(PeDef),POINTER :: aPE
441	TYPE(ArrayDef),POINTER :: ar
442	INTEGER,DIMENSION(1024) :: req
443	character(len=DA_Namelen) :: myName
444	Type(c_ptr) :: base_ptr
445	REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_sc !Base array
446	REAL(kind=wp),DIMENSION(:),POINTER,save :: base_array_cs !Base array
447	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
448
449	myIndex = 0
450	bufsize = 8
451
452	!-- Server to client direction
453
454	!-- First stride, Compute size and set index
455
456	do i=1,me%inter_npes
457	aPE => me%PEs(i)
458	tag = 200
459
460	do j=1,aPE%Nr_arrays
461	ar => aPE%array_list(j)
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
467	if(ar%NrDims == 3) then
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
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
532	end do
533	if(rCount > 0) then ! Wait for all send completed
534	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
535	end if
536	end do
537
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
542
543	CALL PMC_Alloc_mem (base_array_cs, bufsize)
544	me%TotalBufferSize = bufsize*wp !Total buffer size in Byte
545
546	WinSize = me%TotalBufferSize
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
549	CALL MPI_Barrier(me%intra_comm, ierr)
550
551	!-- Second stride, Set Buffer pointer
552
553	do i=1,me%inter_npes
554	aPE => me%PEs(i)
555
556	do j=1,aPE%Nr_arrays
557	ar => aPE%array_list(j)
558	if(aPE%NrEle > 0) then
559	ar%SendBuf = c_loc(base_array_cs(ar%SendIndex))
560	if(ar%SendIndex+ar%SendSize > bufsize) then
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)
563	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
564	end if
565	end if
566	end do
567	end do
568
569	return
570	END SUBROUTINE PMC_C_setInd_and_AllocMem
571
572	SUBROUTINE PMC_C_GetBuffer (WaitTime)
573
574	IMPLICIT none
575
576	REAL(wp), INTENT(OUT), optional :: WaitTime
577
578	!-- local variables
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
591
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
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
609	do j=1,aPE%Nr_arrays
610	ar => aPE%array_list(j)
611	if(ar%NrDims == 2) then
612	nr = aPE%NrEle
613	else if(ar%NrDims == 3) then
614	nr = aPE%NrEle*ar%A_dim(1)
615	end if
616
617	buf_shape(1) = nr
618	CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
619	!
620	!-- MPI passive target RMA
621	if(nr > 0) then
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)
626	end if
627
628	myIndex = 1
629	if(ar%NrDims == 2) then
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
636	else if(ar%NrDims == 3) then
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)
650
651	IMPLICIT none
652
653	REAL(wp), INTENT(OUT), optional :: WaitTime
654
655	!-- local variables
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
668
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
673
674	do ip=1,me%inter_npes
675	aPE => me%PEs(ip)
676
677	do j=1,aPE%Nr_arrays
678	ar => aPE%array_list(j)
679	myIndex=1
680	if(ar%NrDims == 2) then
681	buf_shape(1) = aPE%NrEle
682	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
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
688	else if(ar%NrDims == 3) then
689	buf_shape(1) = aPE%NrEle*ar%A_dim(1)
690	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
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
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
703
704	return
705	END SUBROUTINE PMC_C_PutBuffer
706
707	#endif
708	END MODULE pmc_client

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |