Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |