Home

Context Navigation

pmc_client.f90 @ 1849

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

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

Context Navigation

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

Download in other formats: