Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |