Home

Context Navigation

source: palm/trunk/SOURCE/pmc_server.f90 @ 1765

Last change on this file since 1765 was 1765, checked in by raasch, 8 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 24.6 KB

Line
1	MODULE pmc_server
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_server.f90 1765 2016-02-28 13:30:40Z raasch $
27	!
28	! 1764 2016-02-28 12:45:19Z raasch
29	! cpp-statement added (nesting can only be used in parallel mode)
30	!
31	! 1762 2016-02-25 12:31:13Z hellstea
32	! Initial revision by K. Ketelsen
33	!
34	! Description:
35	! ------------
36	!
37	! Server part of Palm Model Coupler
38	!------------------------------------------------------------------------------!
39
40	#if defined( __parallel )
41	use, intrinsic :: iso_c_binding
42
43	#if defined( __lc )
44	USE MPI
45	#else
46	INCLUDE "mpif.h"
47	#endif
48	USE kinds
49	USE PMC_general, ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen, &
50	PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
51	USE PMC_handle_communicator, ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm, &
52	PMC_Server_for_Client, m_world_rank
53	USE PMC_MPI_wrapper, ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast, &
54	PMC_Alloc_mem, PMC_Time
55
56	IMPLICIT none
57	PRIVATE
58	SAVE
59
60	TYPE ClientIndexDef
61	INTEGER :: NrPoints
62	INTEGER,DIMENSION(:,:),allocatable :: index_list_2d
63	END TYPE ClientIndexDef
64
65	TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL) :: Clients
66	TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL) :: indClients
67
68	PUBLIC PMC_Server_for_Client
69
70	!-- TO_DO: what is the meaning of this? Could variables declared in this module
71	!-- also have single precision?
72	! INTEGER, PARAMETER :: dp = wp
73
74	! INTERFACE section
75
76	INTERFACE PMC_ServerInit
77	MODULE procedure PMC_ServerInit
78	END INTERFACE PMC_ServerInit
79
80	INTERFACE PMC_S_Set_2D_index_list
81	MODULE procedure PMC_S_Set_2D_index_list
82	END INTERFACE PMC_S_Set_2D_index_list
83
84	INTERFACE PMC_S_GetNextArray
85	MODULE procedure PMC_S_GetNextArray
86	END INTERFACE PMC_S_GetNextArray
87
88	INTERFACE PMC_S_Set_DataArray
89	MODULE procedure PMC_S_Set_DataArray_2d
90	MODULE procedure PMC_S_Set_DataArray_3d
91	END INTERFACE PMC_S_Set_DataArray
92
93	INTERFACE PMC_S_setInd_and_AllocMem
94	MODULE procedure PMC_S_setInd_and_AllocMem
95	END INTERFACE PMC_S_setInd_and_AllocMem
96
97	INTERFACE PMC_S_FillBuffer
98	MODULE procedure PMC_S_FillBuffer
99	END INTERFACE PMC_S_FillBuffer
100
101	INTERFACE PMC_S_GetData_from_Buffer
102	MODULE procedure PMC_S_GetData_from_Buffer
103	END INTERFACE PMC_S_GetData_from_Buffer
104
105	! PUBLIC section
106
107	PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
108	PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer
109
110	CONTAINS
111
112	SUBROUTINE PMC_ServerInit
113	IMPLICIT none
114	INTEGER :: i
115	INTEGER :: j
116	INTEGER :: ClientId
117	INTEGER :: istat
118
119	do i=1,size(PMC_Server_for_Client)-1
120	if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
121
122	ClientId = PMC_Server_for_Client(i)
123
124	Clients(ClientId)%model_comm = m_model_comm
125	Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
126
127	! Get rank and size
128	CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
129	CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
130	CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
131
132	! Intra communicater is used for MPI_Get
133	CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
134	CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
135
136	write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
137
138	ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
139
140	do j=1,Clients(ClientId)%inter_npes ! Loop over all client PEs
141	NULLIFY(Clients(ClientId)%PEs(j)%Arrays)
142	end do
143
144	CALL Get_DA_names_from_client (ClientId)
145	end do
146
147	return
148	END SUBROUTINE PMC_ServerInit
149
150	SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
151	IMPLICIT none
152	INTEGER,INTENT(IN) :: ClientId
153	INTEGER,DIMENSION(:,:),INTENT(INOUT) :: index_list !Index list will be modified in sort, therefore INOUT
154
155	!-- Local variables
156	INTEGER :: ip,is,ie,ian,ic,n
157	INTEGER :: istat
158
159	if(m_model_rank == 0) then
160	CALL PMC_sort (index_list, 6) ! Sort to ascending Server PE
161	is = 1
162
163	do ip=0,m_model_npes-1
164
165	! Split into Server PEs
166	ie = is-1 !there may be no entry for this PE
167	if(is <= size(index_list,2) .and. ie >= 0) then
168	do while ( index_list(6,ie+1) == ip)
169	ie = ie+1
170	if( ie == size(index_list,2)) EXIT
171	end do
172
173	ian = ie-is+1
174	else
175	is = -1
176	ie = -2
177	ian = 0
178	end if
179
180	! Send data to other server PEs
181
182	if(ip == 0) then
183	indClients(ClientId)%NrPoints = ian
184	if(ian > 0) then
185	ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
186	indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
187	end if
188	else
189	CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
190	if(ian > 0) then
191	CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001, &
192	m_model_comm, istat)
193	end if
194	end if
195	is = ie+1
196	end do
197	else
198	CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm, &
199	MPI_STATUS_IGNORE, istat)
200	ian = indClients(ClientId)%NrPoints
201	if(ian > 0) then
202	ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
203	CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001, &
204	m_model_comm, MPI_STATUS_IGNORE, istat)
205	end if
206	end if
207
208	CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
209
210	return
211	END SUBROUTINE PMC_S_Set_2D_index_list
212
213	logical function PMC_S_GetNextArray (ClientId, myName,Client_PeIndex)
214	INTEGER,INTENT(IN) :: ClientId
215	CHARACTER(len=*),INTENT(OUT) :: myName
216
217	!-- local variables
218	INTEGER :: MyCoupleIndex
219	logical :: MyLast
220	CHARACTER(len=DA_Namelen) :: loName
221	INTEGER,INTENT(IN),optional :: Client_PeIndex
222
223	loName = ' '
224
225	CALL PMC_G_GetName (clients(ClientId), MyCoupleIndex, loName, MyLast, Client_PeIndex)
226
227	myName = loName
228
229	PMC_S_GetNextArray = .NOT. MyLast ! Return true if valid array
230
231	return
232	END function PMC_S_GetNextArray
233
234	SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array)
235	IMPLICIT none
236	INTEGER,INTENT(IN) :: ClientId
237	!-- TO_DO: has array always to be of dp-kind, or can wp used here
238	!-- this effects all respective declarations in this file
239	REAL(kind=dp),INTENT(IN),DIMENSION(:,:) :: array
240	!-- local variables
241	INTEGER :: NrDims
242	INTEGER,DIMENSION (4) :: dims
243	INTEGER :: dim_order
244	TYPE(c_ptr) :: array_adr
245
246	dims = 1
247
248	NrDims = 2
249	dims(1) = size(array,1)
250	dims(2) = size(array,2)
251	dim_order = 2
252
253	array_adr = c_loc(array)
254
255	CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
256
257	return
258	END SUBROUTINE PMC_S_Set_DataArray_2d
259
260	SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz)
261	IMPLICIT none
262	INTEGER,INTENT(IN) :: ClientId
263	REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:) :: array
264	INTEGER,INTENT(IN) :: nz_cl
265	INTEGER,INTENT(IN) :: nz
266	!-- local variables
267	INTEGER :: NrDims
268	INTEGER,DIMENSION (4) :: dims
269	INTEGER :: dim_order
270	TYPE(c_ptr) :: array_adr
271
272	dims = 1
273
274	dims = 0
275	NrDims = 3
276	dims(1) = size(array,1)
277	dims(2) = size(array,2)
278	dims(3) = size(array,3)
279	dim_order = 33
280	dims(4) = nz_cl+dims(1)-nz ! works for first dimension 1:nz and 0:nz+1
281
282	array_adr = c_loc(array)
283
284	CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
285
286	return
287	END SUBROUTINE PMC_S_Set_DataArray_3d
288
289	SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
290	IMPLICIT none
291	INTEGER,INTENT(IN) :: ClientId
292
293	INTEGER :: i, istat, ierr
294	INTEGER :: arlen, myIndex, tag
295	INTEGER :: rCount ! count MPI requests
296	INTEGER(idp) :: bufsize ! Size of MPI data Window
297	TYPE(PeDef),POINTER :: aPE
298	TYPE(ArrayDef),POINTER :: ar
299	CHARACTER(len=DA_Namelen) :: myName
300	INTEGER,DIMENSION(1024) :: req
301	Type(c_ptr) :: base_ptr
302	REAL(kind=wp),DIMENSION(:),POINTER :: base_array
303	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
304
305	myIndex = 1
306	rCount = 0
307	bufsize = 8
308
309	! First stride, Compute size and set index
310
311	do i=1,Clients(ClientId)%inter_npes
312	aPE => Clients(ClientId)%PEs(i)
313	tag = 200
314	do while (PMC_S_GetNextArray ( ClientId, myName,i))
315	ar => aPE%Arrays
316	if(ar%dim_order == 2) then
317	arlen = aPE%NrEle; ! 2D
318	else if(ar%dim_order == 33) then
319	arlen = aPE%NrEle * ar%A_dim(4); ! PALM 3D
320	else
321	arlen = -1
322	end if
323	ar%BufIndex = myIndex
324
325	tag = tag+1
326	rCount = rCount+1
327	CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
328
329	if(rCount == 1024) then ! Maximum of 1024 outstanding requests
330	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
331	rCount = 0;
332	end if
333
334	myIndex = myIndex+arlen
335	bufsize = bufsize+arlen
336	ar%BufSize = arlen
337
338	end do
339	if(rCount > 0) then ! Wait for all send completed
340	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
341	end if
342	end do
343
344	! Create RMA (One Sided Communication) window for data buffer
345
346	CALL PMC_Alloc_mem (base_array, bufsize, base_ptr)
347	Clients(ClientId)%TotalBufferSize = bufsize*wp !Total buffer size in Byte
348
349	WinSize = bufsize*wp
350	! write(9,*) 'PMC_S_SetInd_and_Mem ',m_model_rank,Clients(ClientId)%inter_npes,WinSize,bufsize
351	CALL MPI_Win_create (base_array, WinSize, wp, MPI_INFO_NULL, Clients(ClientId)%intra_comm, Clients(ClientId)%BufWin, ierr);
352	CALL MPI_Win_fence (0, Clients(ClientId)%BufWin, ierr); ! Open Window to set data
353	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
354
355	! Second stride, Set Buffer pointer
356
357	do i=1,Clients(ClientId)%inter_npes
358	aPE => Clients(ClientId)%PEs(i)
359	do while (PMC_S_GetNextArray ( ClientId, myName,i))
360	ar => aPE%Arrays
361	!-- TO_DO: Adressrechnung ueberlegen?
362	ar%SendBuf = c_loc(base_array(ar%BufIndex)) !kk Adressrechnung ueberlegen
363	if(ar%BufIndex+ar%BufSize > bufsize) then
364	!-- TO_DO: can this error really happen, and what can be the reason?
365	write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
366	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
367	end if
368	end do
369	end do
370
371	return
372	END SUBROUTINE PMC_S_setInd_and_AllocMem
373
374	SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
375	IMPLICIT none
376	INTEGER,INTENT(IN) :: ClientId
377	REAL(kind=dp),INTENT(OUT),optional :: WaitTime
378
379	!-- local variables
380	INTEGER :: ip,ij,istat,ierr
381	INTEGER :: myIndex
382	REAL(kind=dp) :: t1,t2
383	TYPE(PeDef),POINTER :: aPE
384	TYPE(ArrayDef),POINTER :: ar
385	CHARACTER(len=DA_Namelen) :: myName
386	INTEGER,DIMENSION(1) :: buf_shape
387	REAL(kind=wp),POINTER,DIMENSION(:) :: buf
388	REAL(kind=wp),POINTER,DIMENSION(:,:) :: data_2d
389	REAL(kind=wp),POINTER,DIMENSION(:,:,:) :: data_3d
390
391	t1 = PMC_Time()
392	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! Wait for buffer empty
393	t2 = PMC_Time()
394	if(present(WaitTime)) WaitTime = t2-t1
395
396	do ip=1,Clients(ClientId)%inter_npes
397	aPE => Clients(ClientId)%PEs(ip)
398	do while (PMC_S_GetNextArray ( ClientId, myName,ip))
399	ar => aPE%Arrays
400	myIndex=1
401	if(ar%dim_order == 2) then
402	buf_shape(1) = aPE%NrEle
403	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
404	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
405	do ij=1,aPE%NrEle
406	buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
407	myIndex = myIndex+1
408	end do
409	else if(ar%dim_order == 33) then
410	buf_shape(1) = aPE%NrEle*ar%A_dim(4)
411	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
412	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
413	do ij=1,aPE%NrEle
414	buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
415	myIndex = myIndex+ar%A_dim(4)
416	end do
417	else
418	!-- TO_DO: can this error really happen, and what can be the reason?
419	write(0,*) "Illegal Order of Dimension ",ar%dim_order
420	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
421
422	end if
423	end do
424	end do
425
426	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! buffer is full
427
428	return
429	END SUBROUTINE PMC_S_FillBuffer
430
431	SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
432	IMPLICIT none
433	INTEGER,INTENT(IN) :: ClientId
434	REAL(kind=dp),INTENT(OUT),optional :: WaitTime
435
436	!-- local variables
437	INTEGER :: ip,ij,istat,ierr
438	INTEGER :: myIndex
439	REAL(kind=dp) :: t1,t2
440	TYPE(PeDef),POINTER :: aPE
441	TYPE(ArrayDef),POINTER :: ar
442	CHARACTER(len=DA_Namelen) :: myName
443	INTEGER,DIMENSION(1) :: buf_shape
444	REAL(kind=wp),POINTER,DIMENSION(:) :: buf
445	REAL(kind=wp),POINTER,DIMENSION(:,:) :: data_2d
446	REAL(kind=wp),POINTER,DIMENSION(:,:,:) :: data_3d
447
448	t1 = PMC_Time()
449	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! Wait for MPI_Put from client
450	t2 = PMC_Time()
451	if(present(WaitTime)) WaitTime = t2-t1
452
453	do ip=1,Clients(ClientId)%inter_npes
454	aPE => Clients(ClientId)%PEs(ip)
455	do while (PMC_S_GetNextArray ( ClientId, myName,ip))
456	ar => aPE%Arrays
457	myIndex=1
458	if(ar%dim_order == 2) then
459	buf_shape(1) = aPE%NrEle
460	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
461	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
462	do ij=1,aPE%NrEle
463	data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
464	myIndex = myIndex+1
465	end do
466	else if(ar%dim_order == 33) then
467	buf_shape(1) = aPE%NrEle*ar%A_dim(4)
468	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
469	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
470	do ij=1,aPE%NrEle
471	data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
472	myIndex = myIndex+ar%A_dim(4)
473	end do
474	else
475	!-- TO_DO: can this error really happen, and what can be the reason?
476	write(0,*) "Illegal Order of Dimension ",ar%dim_order
477	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
478
479	end if
480	end do
481	end do
482
483	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! data copy finished, buffer is free for use agein
484
485	return
486	END SUBROUTINE PMC_S_GetData_from_Buffer
487
488	! Private SUBROUTINEs
489
490	SUBROUTINE Get_DA_names_from_client (ClientId)
491	IMPLICIT none
492	INTEGER,INTENT(IN) :: ClientId
493	!-- local variables
494	type(DA_NameDef) :: myName
495
496	! Get Data Array Description and Name from Client
497
498	do
499	CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
500	if(myName%couple_index == -1) EXIT
501	CALL PMC_Bcast ( myName%ServerDesc, 0, comm=m_to_client_comm(ClientId))
502	CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
503	CALL PMC_Bcast ( myName%ClientDesc, 0, comm=m_to_client_comm(ClientId))
504	CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
505
506	CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
507	end do
508
509	return
510	END SUBROUTINE Get_DA_names_from_client
511
512	SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
513	IMPLICIT none
514
515	INTEGER,INTENT(IN) :: ClientId
516	INTEGER,INTENT(IN) :: NrDims
517	INTEGER,INTENT(IN),DIMENSION(:) :: dims
518	INTEGER,INTENT(IN) :: dim_order
519	TYPE(c_ptr),INTENT(IN) :: array_adr
520
521	INTEGER :: i
522	TYPE(PeDef),POINTER :: aPE
523	TYPE(ArrayDef),POINTER :: ar
524	CHARACTER(len=DA_Namelen) :: myName
525
526	! Set Array for Client interPE 0
527
528	do i=1,Clients(ClientId)%inter_npes
529	aPE => Clients(ClientId)%PEs(i)
530	ar => aPE%Arrays
531	ar%NrDims = NrDims
532	ar%A_dim = dims
533	ar%dim_order = dim_order
534	ar%data = array_adr
535	end do
536
537	return
538	END SUBROUTINE PMC_S_SetArray
539
540
541	SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
542	IMPLICIT none
543
544	INTEGER,INTENT(IN) :: ClientId
545	TYPE(ClientDef),INTENT(INOUT) :: myClient
546	INTEGER,INTENT(IN),DIMENSION(:,:) :: index_list
547	INTEGER,INTENT(IN) :: NrP
548
549	!-- local variables
550	INTEGER :: i,j,ind,ierr,i2
551	TYPE(PeDef),POINTER :: aPE
552	INTEGER :: RemPE
553	INTEGER,DIMENSION(myClient%inter_npes) :: RemInd
554	INTEGER,DIMENSION(:),POINTER :: RemIndw
555	INTEGER,DIMENSION(:),POINTER :: RLdef
556	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
557	INTEGER :: indWin,indWin2
558
559	! First, count entries for every remote client PE
560
561	do i=1,myClient%inter_npes
562	aPE => myClient%PEs(i)
563	aPE%NrEle = 0
564	end do
565
566	do j=1,NrP ! loop over number of cells coarse grid
567	RemPE = index_list(5,j)+1 ! Pe number remote PE
568	aPE => myClient%PEs(RemPE)
569	aPE% NrEle = aPE% NrEle+1 ! Increment Number of elements for this client Pe
570	end do
571
572	do i=1,myClient%inter_npes
573	aPE => myClient%PEs(i)
574	ALLOCATE(aPE%locInd(aPE%NrEle))
575	end do
576
577	RemInd = 0
578
579	! Second, Create lists
580
581	do j=1,NrP ! loop over number of cells coarse grid
582	RemPE = index_list(5,j)+1 ! Pe number remote PE
583	aPE => myClient%PEs(RemPE)
584	RemInd(RemPE) = RemInd(RemPE)+1
585	ind = RemInd(RemPE)
586	aPE%locInd(ind)%i = index_list(1,j)
587	aPE%locInd(ind)%j = index_list(2,j)
588	end do
589
590	! Prepare Number of Elements for Client PEs
591	CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
592	WinSize = myClient%inter_npesc_sizeof(i)2 ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
593
594	CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
595	CALL MPI_Win_fence (0, indWin, ierr); ! Open Window to set data
596
597	RLdef(1) = 0 ! Index on Remote PE 0
598	RLdef(2) = RemInd(1) ! Number of Elements on Rem PE 0
599
600	do i=2,myClient%inter_npes ! Reserve Buffer for index array
601	i2 = (i-1)*2+1
602	RLdef(i2) = RLdef(i2-2) + RLdef(i2-1)*2 ! Index on Remote PE
603	RLdef(i2+1) = RemInd(i) ! Number of Elements on Remote PE
604	end do
605
606	CALL MPI_Win_fence (0, indWin, ierr); ! Close Window to allow client to access data
607	CALL MPI_Win_fence (0, indWin, ierr); ! Client has retrieved data
608
609	i2 = 2*myClient%inter_npes-1
610	WinSize = (RLdef(i2)+RLdef(i2+1))*2
611	WinSize = max(WinSize,1) ! Make sure, MPI_Alloc_mem works
612
613	CALL PMC_Alloc_mem (RemIndw, int(WinSize))
614
615	CALL MPI_Barrier (m_model_comm, ierr)
616	CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
617
618	CALL MPI_Win_fence (0, indWin2, ierr); ! Open Window to set data
619	do j=1,NrP ! this loop creates the 2D index list
620	RemPE = index_list(5,j)+1 ! Pe number remote PE
621	aPE => myClient%PEs(RemPE)
622	i2 = RemPE*2-1
623	ind = RLdef(i2)+1
624	RemIndw(ind) = index_list(3,j)
625	RemIndw(ind+1) = index_list(4,j)
626	RLdef(i2) = RLdef(i2)+2
627	end do
628	CALL MPI_Win_fence (0, indWin2, ierr); !all data set
629
630	CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
631
632	CALL MPI_Win_free(indWin, ierr)
633	CALL MPI_Win_free(indWin2, ierr)
634
635	! Sollte funktionieren, Problem mit MPI implementation
636	! https://www.lrz.de/services/software/parallel/mpi/onesided
637	! CALL MPI_Free_mem (RemIndw, ierr)
638
639	return
640	END SUBROUTINE Set_PE_index_list
641
642	#endif
643	END MODULE pmc_server

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |