Home

Context Navigation

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

Last change on this file since 1833 was 1833, checked in by raasch, 8 years ago
spectrum renamed spactra_par and further modularized, POINTER-attributes added in coupler-routines to avoid gfortran error messages
Property svn:keywords set to `Id`
File size: 30.0 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-2016 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	! gfortran requires pointer attributes for some array declarations,
23	! long line wrapped
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: pmc_server.f90 1833 2016-04-07 14:23:03Z raasch $
28	!
29	! 1808 2016-04-05 19:44:00Z raasch
30	! MPI module used by default on all machines
31	!
32	! 1797 2016-03-21 16:50:28Z raasch
33	! introduction of different datatransfer modes
34	!
35	! 1791 2016-03-11 10:41:25Z raasch
36	! Debug write-statements commented out
37	!
38	! 1786 2016-03-08 05:49:27Z raasch
39	! change in client-server data transfer: server now gets data from client
40	! instead that client put's it to the server
41	!
42	! 1779 2016-03-03 08:01:28Z raasch
43	! kind=dp replaced by wp,
44	! error messages removed or changed to PALM style, dim_order removed
45	! array management changed from linked list to sequential loop
46	!
47	! 1766 2016-02-29 08:37:15Z raasch
48	! modifications to allow for using PALM's pointer version
49	! +new routine pmc_s_set_active_data_array
50	!
51	! 1764 2016-02-28 12:45:19Z raasch
52	! cpp-statement added (nesting can only be used in parallel mode)
53	!
54	! 1762 2016-02-25 12:31:13Z hellstea
55	! Initial revision by K. Ketelsen
56	!
57	! Description:
58	! ------------
59	!
60	! Server part of Palm Model Coupler
61	!------------------------------------------------------------------------------!
62
63	#if defined( __parallel )
64	use, intrinsic :: iso_c_binding
65
66	#if defined( __mpifh )
67	INCLUDE "mpif.h"
68	#else
69	USE MPI
70	#endif
71	USE kinds
72	USE PMC_general, ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen, &
73	PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
74	USE PMC_handle_communicator, ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm, &
75	PMC_Server_for_Client, m_world_rank
76	USE PMC_MPI_wrapper, ONLY: PMC_Send_to_Client, PMC_Recv_from_Client, PMC_Bcast, PMC_Inter_Bcast, &
77	PMC_Alloc_mem, PMC_Time
78
79	IMPLICIT none
80	PRIVATE
81	SAVE
82
83	TYPE ClientIndexDef
84	INTEGER :: NrPoints
85	INTEGER,DIMENSION(:,:),allocatable :: index_list_2d
86	END TYPE ClientIndexDef
87
88	TYPE(ClientDef),DIMENSION(PMC_MAX_MODELL) :: Clients
89	TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL) :: indClients
90
91	INTEGER :: next_array_in_list = 0
92
93	PUBLIC PMC_Server_for_Client
94
95	INTERFACE PMC_ServerInit
96	MODULE procedure PMC_ServerInit
97	END INTERFACE PMC_ServerInit
98
99	INTERFACE PMC_S_Set_2D_index_list
100	MODULE procedure PMC_S_Set_2D_index_list
101	END INTERFACE PMC_S_Set_2D_index_list
102
103	INTERFACE PMC_S_clear_next_array_list
104	MODULE procedure PMC_S_clear_next_array_list
105	END INTERFACE PMC_S_clear_next_array_list
106
107	INTERFACE PMC_S_GetNextArray
108	MODULE procedure PMC_S_GetNextArray
109	END INTERFACE PMC_S_GetNextArray
110
111	INTERFACE PMC_S_Set_DataArray
112	MODULE procedure PMC_S_Set_DataArray_2d
113	MODULE procedure PMC_S_Set_DataArray_3d
114	END INTERFACE PMC_S_Set_DataArray
115
116	INTERFACE PMC_S_setInd_and_AllocMem
117	MODULE procedure PMC_S_setInd_and_AllocMem
118	END INTERFACE PMC_S_setInd_and_AllocMem
119
120	INTERFACE PMC_S_FillBuffer
121	MODULE procedure PMC_S_FillBuffer
122	END INTERFACE PMC_S_FillBuffer
123
124	INTERFACE PMC_S_GetData_from_Buffer
125	MODULE procedure PMC_S_GetData_from_Buffer
126	END INTERFACE PMC_S_GetData_from_Buffer
127
128	INTERFACE PMC_S_Set_Active_data_array
129	MODULE procedure PMC_S_Set_Active_data_array
130	END INTERFACE PMC_S_Set_Active_data_array
131
132	! PUBLIC section
133
134	PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
135	PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
136	PUBLIC PMC_S_clear_next_array_list
137
138	CONTAINS
139
140	SUBROUTINE PMC_ServerInit
141	IMPLICIT none
142	INTEGER :: i
143	INTEGER :: j
144	INTEGER :: ClientId
145	INTEGER :: istat
146
147	do i=1,size(PMC_Server_for_Client)-1
148	! if(m_model_comm == 0) write(0,*) 'PMC_Server: Initialize client Id',PMC_Server_for_Client(i)
149
150	ClientId = PMC_Server_for_Client(i)
151
152	Clients(ClientId)%model_comm = m_model_comm
153	Clients(ClientId)%inter_comm = m_to_client_comm(ClientId)
154
155	! Get rank and size
156	CALL MPI_Comm_rank (Clients(ClientId)%model_comm, Clients(ClientId)%model_rank, istat);
157	CALL MPI_Comm_size (Clients(ClientId)%model_comm, Clients(ClientId)%model_npes, istat);
158	CALL MPI_Comm_remote_size (Clients(ClientId)%inter_comm, Clients(ClientId)%inter_npes, istat);
159
160	! Intra communicater is used for MPI_Get
161	CALL MPI_Intercomm_merge (Clients(ClientId)%inter_comm, .false., Clients(ClientId)%intra_comm, istat);
162	CALL MPI_Comm_rank (Clients(ClientId)%intra_comm, Clients(ClientId)%intra_rank, istat);
163
164	! write(9,*) 'ClientId ',i,ClientId,m_world_rank, Clients(ClientId)%inter_npes
165
166	ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
167	!
168	!-- Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
169	do j=1,Clients(ClientId)%inter_npes
170	Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
171	end do
172
173	CALL Get_DA_names_from_client (ClientId)
174	end do
175
176	return
177	END SUBROUTINE PMC_ServerInit
178
179	SUBROUTINE PMC_S_Set_2D_index_list (ClientId, index_list)
180	IMPLICIT none
181	INTEGER,INTENT(IN) :: ClientId
182	INTEGER,DIMENSION(:,:),INTENT(INOUT) :: index_list !Index list will be modified in sort, therefore INOUT
183
184	!-- Local variables
185	INTEGER :: ip,is,ie,ian,ic,n
186	INTEGER :: istat
187
188	if(m_model_rank == 0) then
189	CALL PMC_sort (index_list, 6) ! Sort to ascending Server PE
190	is = 1
191
192	do ip=0,m_model_npes-1
193
194	! Split into Server PEs
195	ie = is-1 !there may be no entry for this PE
196	if(is <= size(index_list,2) .and. ie >= 0) then
197	do while ( index_list(6,ie+1) == ip)
198	ie = ie+1
199	if( ie == size(index_list,2)) EXIT
200	end do
201
202	ian = ie-is+1
203	else
204	is = -1
205	ie = -2
206	ian = 0
207	end if
208
209	! Send data to other server PEs
210
211	if(ip == 0) then
212	indClients(ClientId)%NrPoints = ian
213	if(ian > 0) then
214	ALLOCATE (indClients(ClientId)%index_list_2d(6,ian))
215	indClients(ClientId)%index_list_2d(:,1:ian) = index_list(:,is:ie)
216	end if
217	else
218	CALL MPI_Send (ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, istat)
219	if(ian > 0) then
220	CALL MPI_Send (index_list(1,is), 6*ian, MPI_INTEGER, ip, 1001, &
221	m_model_comm, istat)
222	end if
223	end if
224	is = ie+1
225	end do
226	else
227	CALL MPI_Recv (indClients(ClientId)%NrPoints, 1, MPI_INTEGER, 0, 1000, m_model_comm, &
228	MPI_STATUS_IGNORE, istat)
229	ian = indClients(ClientId)%NrPoints
230	if(ian > 0) then
231	ALLOCATE(indClients(ClientId)%index_list_2d(6,ian))
232	CALL MPI_RECV (indClients(ClientId)%index_list_2d, 6*ian, MPI_INTEGER, 0, 1001, &
233	m_model_comm, MPI_STATUS_IGNORE, istat)
234	end if
235	end if
236
237	CALL Set_PE_index_list (ClientId,Clients(ClientId),indClients(ClientId)%index_list_2d,indClients(ClientId)%NrPoints)
238
239	return
240	END SUBROUTINE PMC_S_Set_2D_index_list
241
242	SUBROUTINE PMC_S_clear_next_array_list
243	IMPLICIT none
244
245	next_array_in_list = 0
246
247	return
248	END SUBROUTINE PMC_S_clear_next_array_list
249
250	! List handling is still required to get minimal interaction with pmc_interface
251	logical function PMC_S_GetNextArray (ClientId, myName)
252	INTEGER(iwp),INTENT(IN) :: ClientId
253	CHARACTER(len=*),INTENT(OUT) :: myName
254
255	!-- local variables
256	TYPE(PeDef),POINTER :: aPE
257	TYPE(ArrayDef),POINTER :: ar
258
259	next_array_in_list = next_array_in_list+1
260
261	!-- Array Names are the same on all client PE, so take first PE to get the name
262	aPE => Clients(ClientId)%PEs(1)
263
264	if(next_array_in_list > aPE%Nr_arrays) then
265	PMC_S_GetNextArray = .false. ! all arrays done
266	return
267	end if
268
269	ar => aPE%array_list(next_array_in_list)
270	myName = ar%name
271
272	PMC_S_GetNextArray = .true. ! Return true if legal array
273	return
274	END function PMC_S_GetNextArray
275
276	SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
277
278	IMPLICIT none
279
280	INTEGER,INTENT(IN) :: ClientId
281
282	REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER :: array
283	REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL :: array_2
284
285	INTEGER :: NrDims
286	INTEGER,DIMENSION (4) :: dims
287	TYPE(c_ptr) :: array_adr
288	TYPE(c_ptr) :: second_adr
289
290	dims = 1
291
292	NrDims = 2
293	dims(1) = size(array,1)
294	dims(2) = size(array,2)
295	array_adr = c_loc(array)
296
297	IF ( PRESENT( array_2 ) ) THEN
298	second_adr = c_loc(array_2)
299	CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
300	ELSE
301	CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
302	ENDIF
303
304	return
305	END SUBROUTINE PMC_S_Set_DataArray_2d
306
307	SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
308
309	IMPLICIT none
310
311	INTEGER,INTENT(IN) :: ClientId
312
313	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER :: array
314	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL :: array_2
315	INTEGER,INTENT(IN) :: nz_cl
316	INTEGER,INTENT(IN) :: nz
317
318	INTEGER :: NrDims
319	INTEGER,DIMENSION (4) :: dims
320	TYPE(c_ptr) :: array_adr
321	TYPE(c_ptr) :: second_adr
322
323	dims = 1
324
325	dims = 0
326	NrDims = 3
327	dims(1) = size(array,1)
328	dims(2) = size(array,2)
329	dims(3) = size(array,3)
330	dims(4) = nz_cl+dims(1)-nz ! works for first dimension 1:nz and 0:nz+1
331
332	array_adr = c_loc(array)
333
334	!
335	!-- In PALM's pointer version, two indices have to be stored internally.
336	!-- The active address of the data array is set in swap_timelevel
337	IF ( PRESENT( array_2 ) ) THEN
338	second_adr = c_loc(array_2)
339	CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
340	ELSE
341	CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
342	ENDIF
343
344	return
345	END SUBROUTINE PMC_S_Set_DataArray_3d
346
347	SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
348
349	USE control_parameters, &
350	ONLY: message_string
351
352	IMPLICIT none
353
354	!
355	!-- Naming convention for appendices: _sc -> server to client transfer
356	!-- _cs -> client to server transfer
357	!-- Send -> Server to client transfer
358	!-- Recv -> client to server transfer
359	INTEGER,INTENT(IN) :: ClientId
360
361	INTEGER :: i, istat, ierr, j
362	INTEGER :: arlen, myIndex, tag
363	INTEGER :: rCount ! count MPI requests
364	INTEGER(idp) :: bufsize ! Size of MPI data Window
365	TYPE(PeDef),POINTER :: aPE
366	TYPE(ArrayDef),POINTER :: ar
367	CHARACTER(len=DA_Namelen) :: myName
368	INTEGER,DIMENSION(1024) :: req
369	Type(c_ptr) :: base_ptr
370	REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_sc !Base array for server to client transfer
371	REAL(wp),DIMENSION(:),POINTER,SAVE :: base_array_cs !Base array for client to server transfer
372	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
373
374	!
375	!-- Server to client direction
376	myIndex = 1
377	rCount = 0
378	bufsize = 8
379
380	!
381	!-- First stride: Compute size and set index
382	do i=1,Clients(ClientId)%inter_npes
383	aPE => Clients(ClientId)%PEs(i)
384	tag = 200
385	do j=1,aPE%Nr_arrays
386	ar => aPE%array_list(j)
387	if(ar%NrDims == 2) then
388	arlen = aPE%NrEle ! 2D
389	else if(ar%NrDims == 3) then
390	arlen = aPE%NrEle * ar%A_dim(4); ! 3D
391	else
392	arlen = -1
393	end if
394	ar%SendIndex = myIndex
395
396	tag = tag+1
397	rCount = rCount+1
398	CALL MPI_Isend (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, req(rCount),ierr)
399
400	if(rCount == 1024) then ! Maximum of 1024 outstanding requests
401	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
402	rCount = 0;
403	end if
404
405	myIndex = myIndex+arlen
406	bufsize = bufsize+arlen
407	ar%SendSize = arlen
408
409	end do
410	if(rCount > 0) then ! Wait for all send completed
411	CALL MPI_Waitall (rCount, req, MPI_STATUSES_IGNORE, ierr)
412	end if
413	end do
414
415	!
416	!-- Create RMA (One Sided Communication) window for data buffer server to
417	!-- client transfer.
418	!-- The buffer of MPI_Get (counter part of transfer) can be PE-local, i.e.
419	!-- it can but must not be part of the MPI RMA window.
420	!-- Only one RMA window is required to prepare the data
421	!-- for server -> client transfer on the server side and
422	!-- for client -> server transfer on the client side
423	CALL PMC_Alloc_mem (base_array_sc, bufsize)
424	Clients(ClientId)%TotalBufferSize = bufsize*wp !Total buffer size in Byte
425
426	WinSize = bufsize*wp
427	CALL MPI_Win_create (base_array_sc, WinSize, wp, MPI_INFO_NULL, &
428	Clients(ClientId)%intra_comm, Clients(ClientId)%win_server_client, ierr)
429	CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr); ! Open Window to set data
430	!
431	!-- Second stride: Set Buffer pointer
432	do i=1,Clients(ClientId)%inter_npes
433	aPE => Clients(ClientId)%PEs(i)
434	do j=1,aPE%Nr_arrays
435	ar => aPE%array_list(j)
436	ar%SendBuf = c_loc(base_array_sc(ar%SendIndex))
437	if(ar%SendIndex+ar%SendSize > bufsize) then
438	write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i, &
439	ar%SendIndex,ar%SendSize,ar%SendIndex+ar%SendSize,bufsize,trim(ar%name)
440	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
441	end if
442	end do
443	end do
444
445	!-- Client to server direction
446
447	bufsize = 8
448
449	!-- First stride, Compute size and set index
450
451	do i=1,Clients(ClientId)%inter_npes
452	aPE => Clients(ClientId)%PEs(i)
453	tag = 300
454
455	do j=1,aPE%Nr_arrays
456	ar => aPE%array_list(j)
457
458	! Receive Index from client
459	tag = tag+1
460	CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, Clients(ClientId)%inter_comm, MPI_STATUS_IGNORE, ierr)
461
462	if(ar%NrDims == 3) then
463	bufsize = max(bufsize,aPE%NrEle * ar%A_dim(4)) ! 3D
464	else
465	bufsize = max(bufsize,aPE%NrEle) ! 2D
466	end if
467	ar%RecvIndex = myIndex
468	end do
469
470	end do
471
472	!-- Create RMA (One Sided Communication) data buffer
473	!-- The buffer for MPI_Get can be PE local, i.e. it can but must not be part of the MPI RMA window
474
475	CALL PMC_Alloc_mem (base_array_cs, bufsize, base_ptr)
476	Clients(ClientId)%TotalBufferSize = bufsize*wp !Total buffer size in Byte
477
478	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
479
480	!-- Second stride, Set Buffer pointer
481
482	do i=1,Clients(ClientId)%inter_npes
483	aPE => Clients(ClientId)%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	return
492	END SUBROUTINE PMC_S_setInd_and_AllocMem
493
494	SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
495	IMPLICIT none
496	INTEGER,INTENT(IN) :: ClientId
497	REAL(wp), INTENT(OUT), OPTIONAL :: WaitTime
498
499	INTEGER :: ip,ij,istat,ierr,j
500	INTEGER :: myIndex
501	REAL(wp) :: t1,t2
502	TYPE(PeDef),POINTER :: aPE
503	TYPE(ArrayDef),POINTER :: ar
504	CHARACTER(len=DA_Namelen) :: myName
505	INTEGER,DIMENSION(1) :: buf_shape
506	REAL(wp), POINTER, DIMENSION(:) :: buf
507	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d
508	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d
509
510	!-- Synchronization of the model is done in pmci_client_synchronize and pmci_server_synchronize
511	!-- Therefor the RMA window cann be filled without sychronization at this point and the barrier
512	!-- is not necessary
513	!-- Please note that WaitTime has to be set in PMC_S_FillBuffer AND PMC_C_GetBuffer
514
515	if(present(WaitTime)) then
516	t1 = PMC_Time()
517	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)
518	t2 = PMC_Time()
519	WaitTime = t2-t1
520	end if
521
522	do ip=1,Clients(ClientId)%inter_npes
523	aPE => Clients(ClientId)%PEs(ip)
524	do j=1,aPE%Nr_arrays
525	ar => aPE%array_list(j)
526	myIndex=1
527	if(ar%NrDims == 2) then
528	buf_shape(1) = aPE%NrEle
529	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
530	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
531	do ij=1,aPE%NrEle
532	buf(myIndex) = data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i)
533	myIndex = myIndex+1
534	end do
535	else if(ar%NrDims == 3) then
536	buf_shape(1) = aPE%NrEle*ar%A_dim(4)
537	CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
538	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
539	do ij=1,aPE%NrEle
540	buf(myIndex:myIndex+ar%A_dim(4)-1) = data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i)
541	myIndex = myIndex+ar%A_dim(4)
542	end do
543	end if
544	end do
545	end do
546
547	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! buffer is filled
548
549	return
550	END SUBROUTINE PMC_S_FillBuffer
551
552	SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
553
554	IMPLICIT none
555
556	INTEGER,INTENT(IN) :: ClientId
557	REAL(wp), INTENT(OUT), OPTIONAL :: WaitTime
558
559	!-- local variables
560	INTEGER :: ip,ij,istat,ierr,j
561	INTEGER :: myIndex
562	INTEGER :: nr
563	REAL(wp) :: t1,t2
564	TYPE(PeDef),POINTER :: aPE
565	TYPE(ArrayDef),POINTER :: ar
566	CHARACTER(len=DA_Namelen) :: myName
567	INTEGER,DIMENSION(1) :: buf_shape
568	REAL(wp), POINTER, DIMENSION(:) :: buf
569	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d
570	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d
571	INTEGER :: target_pe
572	INTEGER(kind=MPI_ADDRESS_KIND) :: target_disp
573
574	t1 = PMC_Time()
575	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! Wait for client to fill buffer
576	t2 = PMC_Time()-t1
577	if(present(WaitTime)) WaitTime = t2
578
579	! CALL MPI_Win_fence (0, Clients(ClientId)%win_server_client, ierr) ! Fence might do it, test later
580	CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr) ! Wait for buffer is filled
581
582	do ip=1,Clients(ClientId)%inter_npes
583	aPE => Clients(ClientId)%PEs(ip)
584	do j=1,aPE%Nr_arrays
585	ar => aPE%array_list(j)
586
587	if(ar%RecvIndex < 0) CYCLE
588
589	if(ar%NrDims == 2) then
590	nr = aPE%NrEle
591	else if(ar%NrDims == 3) then
592	nr = aPE%NrEle*ar%A_dim(4)
593	end if
594
595	buf_shape(1) = nr
596	CALL c_f_pointer(ar%RecvBuf, buf, buf_shape)
597	!
598	!-- MPI passive target RMA
599
600	if(nr > 0) then
601	target_disp = ar%RecvIndex-1
602	target_pe = ip-1+m_model_npes ! client PEs are located behind server PEs
603	CALL MPI_Win_lock (MPI_LOCK_SHARED , target_pe, 0, Clients(ClientId)%win_server_client, ierr)
604	CALL MPI_Get (buf, nr, MPI_REAL, target_pe, target_disp, nr, MPI_REAL, Clients(ClientId)%win_server_client, ierr)
605	CALL MPI_Win_unlock (target_pe, Clients(ClientId)%win_server_client, ierr)
606	end if
607
608	myIndex=1
609	if(ar%NrDims == 2) then
610	CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
611	do ij=1,aPE%NrEle
612	data_2d(aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex)
613	myIndex = myIndex+1
614	end do
615	else if(ar%NrDims == 3) then
616	CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
617	do ij=1,aPE%NrEle
618	data_3d(1:ar%A_dim(4),aPE%locInd(ij)%j,aPE%locInd(ij)%i) = buf(myIndex:myIndex+ar%A_dim(4)-1)
619	myIndex = myIndex+ar%A_dim(4)
620	end do
621	end if
622	end do
623	end do
624
625	END SUBROUTINE PMC_S_GetData_from_Buffer
626
627	! Private SUBROUTINEs
628
629	SUBROUTINE Get_DA_names_from_client (ClientId)
630	IMPLICIT none
631	INTEGER,INTENT(IN) :: ClientId
632	!-- local variables
633	type(DA_NameDef) :: myName
634
635	! Get Data Array Description and Name from Client
636
637	do
638	CALL PMC_Bcast ( myName%couple_index, 0, comm=m_to_client_comm(ClientId))
639	if(myName%couple_index == -1) EXIT
640	CALL PMC_Bcast ( myName%ServerDesc, 0, comm=m_to_client_comm(ClientId))
641	CALL PMC_Bcast ( myName%NameOnServer, 0, comm=m_to_client_comm(ClientId))
642	CALL PMC_Bcast ( myName%ClientDesc, 0, comm=m_to_client_comm(ClientId))
643	CALL PMC_Bcast ( myName%NameOnClient, 0, comm=m_to_client_comm(ClientId))
644
645	CALL PMC_G_SetName (clients(ClientID), myName%couple_index, myName%NameOnServer )
646	end do
647
648	return
649	END SUBROUTINE Get_DA_names_from_client
650
651	SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
652	IMPLICIT none
653
654	INTEGER,INTENT(IN) :: ClientId
655	INTEGER,INTENT(IN) :: NrDims
656	INTEGER,INTENT(IN),DIMENSION(:) :: dims
657	TYPE(c_ptr),INTENT(IN) :: array_adr
658	TYPE(c_ptr),INTENT(IN),OPTIONAL :: second_adr
659
660	INTEGER :: i
661	TYPE(PeDef),POINTER :: aPE
662	TYPE(ArrayDef),POINTER :: ar
663	CHARACTER(len=DA_Namelen) :: myName
664
665	! Set Array for Client interPE 0
666
667	do i=1,Clients(ClientId)%inter_npes
668	aPE => Clients(ClientId)%PEs(i)
669	ar => aPE%array_list(next_array_in_list)
670	ar%NrDims = NrDims
671	ar%A_dim = dims
672	ar%data = array_adr
673	if(present(second_adr)) then
674	ar%po_data(1) = array_adr
675	ar%po_data(2) = second_adr
676	else
677	ar%po_data(1) = C_NULL_PTR
678	ar%po_data(2) = C_NULL_PTR
679	end if
680	end do
681
682	return
683	END SUBROUTINE PMC_S_SetArray
684
685
686	SUBROUTINE PMC_S_Set_Active_data_array (ClientId,iactive)
687	IMPLICIT none
688
689	INTEGER,INTENT(IN) :: ClientId
690	INTEGER,INTENT(IN) :: iactive
691
692	!-- local variables
693	INTEGER :: i, ip, j
694	TYPE(PeDef),POINTER :: aPE
695	TYPE(ArrayDef),POINTER :: ar
696	CHARACTER(len=DA_Namelen) :: myName
697
698	do ip=1,Clients(ClientId)%inter_npes
699	aPE => Clients(ClientId)%PEs(ip)
700	do j=1,aPE%Nr_arrays
701	ar => aPE%array_list(j)
702	if(iactive == 1 .OR. iactive == 2) then
703	ar%data = ar%po_data(iactive)
704	end if
705	end do
706	end do
707
708	return
709	END SUBROUTINE PMC_S_Set_Active_data_array
710
711
712	SUBROUTINE Set_PE_index_list (ClientId, myClient,index_list,NrP)
713	IMPLICIT none
714
715	INTEGER,INTENT(IN) :: ClientId
716	TYPE(ClientDef),INTENT(INOUT) :: myClient
717	INTEGER,INTENT(IN),DIMENSION(:,:) :: index_list
718	INTEGER,INTENT(IN) :: NrP
719
720	!-- local variables
721	INTEGER :: i,j,ind,ierr,i2
722	TYPE(PeDef),POINTER :: aPE
723	INTEGER :: RemPE
724	INTEGER,DIMENSION(myClient%inter_npes) :: RemInd
725	INTEGER,DIMENSION(:),POINTER :: RemIndw
726	INTEGER,DIMENSION(:),POINTER :: RLdef
727	INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize
728	INTEGER :: indWin,indWin2
729
730	! First, count entries for every remote client PE
731
732	do i=1,myClient%inter_npes
733	aPE => myClient%PEs(i)
734	aPE%NrEle = 0
735	end do
736
737	do j=1,NrP ! loop over number of cells coarse grid
738	RemPE = index_list(5,j)+1 ! Pe number remote PE
739	aPE => myClient%PEs(RemPE)
740	aPE% NrEle = aPE% NrEle+1 ! Increment Number of elements for this client Pe
741	end do
742
743	do i=1,myClient%inter_npes
744	aPE => myClient%PEs(i)
745	ALLOCATE(aPE%locInd(aPE%NrEle))
746	end do
747
748	RemInd = 0
749
750	! Second, Create lists
751
752	do j=1,NrP ! loop over number of cells coarse grid
753	RemPE = index_list(5,j)+1 ! Pe number remote PE
754	aPE => myClient%PEs(RemPE)
755	RemInd(RemPE) = RemInd(RemPE)+1
756	ind = RemInd(RemPE)
757	aPE%locInd(ind)%i = index_list(1,j)
758	aPE%locInd(ind)%j = index_list(2,j)
759	end do
760
761	! Prepare Number of Elements for Client PEs
762	CALL PMC_Alloc_mem (RLdef, myClient%inter_npes*2)
763	WinSize = myClient%inter_npesc_sizeof(i)2 ! Number of Client PEs * size of INTEGER (i just arbitrary INTEGER)
764
765	CALL MPI_Win_create (RLdef, WinSize, iwp, MPI_INFO_NULL, myClient%intra_comm, indWin, ierr);
766	CALL MPI_Win_fence (0, indWin, ierr); ! Open Window to set data
767
768	RLdef(1) = 0 ! Index on Remote PE 0
769	RLdef(2) = RemInd(1) ! Number of Elements on Rem PE 0
770
771	do i=2,myClient%inter_npes ! Reserve Buffer for index array
772	i2 = (i-1)*2+1
773	RLdef(i2) = RLdef(i2-2) + RLdef(i2-1)*2 ! Index on Remote PE
774	RLdef(i2+1) = RemInd(i) ! Number of Elements on Remote PE
775	end do
776
777	CALL MPI_Win_fence (0, indWin, ierr); ! Close Window to allow client to access data
778	CALL MPI_Win_fence (0, indWin, ierr); ! Client has retrieved data
779
780	i2 = 2*myClient%inter_npes-1
781	WinSize = (RLdef(i2)+RLdef(i2+1))*2
782	WinSize = max(WinSize,1) ! Make sure, MPI_Alloc_mem works
783
784	CALL PMC_Alloc_mem (RemIndw, int(WinSize))
785
786	CALL MPI_Barrier (m_model_comm, ierr)
787	CALL MPI_Win_create (RemIndw, WinSize*c_sizeof(i), iwp, MPI_INFO_NULL, myClient%intra_comm, indWin2, ierr);
788
789	CALL MPI_Win_fence (0, indWin2, ierr); ! Open Window to set data
790	do j=1,NrP ! this loop creates the 2D index list
791	RemPE = index_list(5,j)+1 ! Pe number remote PE
792	aPE => myClient%PEs(RemPE)
793	i2 = RemPE*2-1
794	ind = RLdef(i2)+1
795	RemIndw(ind) = index_list(3,j)
796	RemIndw(ind+1) = index_list(4,j)
797	RLdef(i2) = RLdef(i2)+2
798	end do
799	CALL MPI_Win_fence (0, indWin2, ierr); !all data set
800
801	CALL MPI_Barrier(myClient%intra_comm, ierr) ! Dont know why, but this barrier is necessary before we can free the windows
802
803	CALL MPI_Win_free(indWin, ierr)
804	CALL MPI_Win_free(indWin2, ierr)
805
806	! Sollte funktionieren, Problem mit MPI implementation
807	! https://www.lrz.de/services/software/parallel/mpi/onesided
808	! CALL MPI_Free_mem (RemIndw, ierr)
809
810	return
811	END SUBROUTINE Set_PE_index_list
812
813	#endif
814	END MODULE pmc_server

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |