Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |