Home

Context Navigation

pmc_server_mod.f90 @ 1929

Last change on this file since 1929 was 1901, checked in by raasch, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 30.2 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	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_server_mod.f90 1901 2016-05-04 15:39:38Z suehring $
27	!
28	! 1900 2016-05-04 15:27:53Z raasch
29	! re-formatted to match PALM style
30	!
31	! 1850 2016-04-08 13:29:27Z maronga
32	! Module renamed
33	!
34	!
35	! 1833 2016-04-07 14:23:03Z raasch
36	! gfortran requires pointer attributes for some array declarations,
37	! long line wrapped
38	!
39	! 1808 2016-04-05 19:44:00Z raasch
40	! MPI module used by default on all machines
41	!
42	! 1797 2016-03-21 16:50:28Z raasch
43	! introduction of different datatransfer modes
44	!
45	! 1791 2016-03-11 10:41:25Z raasch
46	! Debug write-statements commented out
47	!
48	! 1786 2016-03-08 05:49:27Z raasch
49	! change in client-server data transfer: server now gets data from client
50	! instead that client put's it to the server
51	!
52	! 1779 2016-03-03 08:01:28Z raasch
53	! kind=dp replaced by wp,
54	! error messages removed or changed to PALM style, dim_order removed
55	! array management changed from linked list to sequential loop
56	!
57	! 1766 2016-02-29 08:37:15Z raasch
58	! modifications to allow for using PALM's pointer version
59	! +new routine pmc_s_set_active_data_array
60	!
61	! 1764 2016-02-28 12:45:19Z raasch
62	! cpp-statement added (nesting can only be used in parallel mode)
63	!
64	! 1762 2016-02-25 12:31:13Z hellstea
65	! Initial revision by K. Ketelsen
66	!
67	! Description:
68	! ------------
69	!
70	! Server part of Palm Model Coupler
71	!------------------------------------------------------------------------------!
72
73	#if defined( __parallel )
74	USE, INTRINSIC :: ISO_C_BINDING
75
76	#if defined( __mpifh )
77	INCLUDE "mpif.h"
78	#else
79	USE MPI
80	#endif
81	USE kinds
82	USE pmc_general, &
83	ONLY: arraydef, clientdef, da_namedef, da_namelen, pedef, &
84	pmc_g_setname, pmc_max_array, pmc_max_models, pmc_sort
85
86	USE pmc_handle_communicator, &
87	ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm, &
88	m_world_rank, pmc_server_for_client
89
90	USE pmc_mpi_wrapper, &
91	ONLY: pmc_alloc_mem, pmc_bcast, pmc_time
92
93	IMPLICIT NONE
94
95	PRIVATE
96	SAVE
97
98	TYPE clientindexdef
99	INTEGER :: nrpoints !<
100	INTEGER, DIMENSION(:,:), ALLOCATABLE :: index_list_2d !<
101	END TYPE clientindexdef
102
103	TYPE(clientdef), DIMENSION(pmc_max_models) :: clients !<
104	TYPE(clientindexdef), DIMENSION(pmc_max_models) :: indclients !<
105
106	INTEGER :: next_array_in_list = 0 !<
107
108
109	PUBLIC pmc_server_for_client
110
111
112	INTERFACE pmc_serverinit
113	MODULE PROCEDURE pmc_serverinit
114	END INTERFACE pmc_serverinit
115
116	INTERFACE pmc_s_set_2d_index_list
117	MODULE PROCEDURE pmc_s_set_2d_index_list
118	END INTERFACE pmc_s_set_2d_index_list
119
120	INTERFACE pmc_s_clear_next_array_list
121	MODULE PROCEDURE pmc_s_clear_next_array_list
122	END INTERFACE pmc_s_clear_next_array_list
123
124	INTERFACE pmc_s_getnextarray
125	MODULE PROCEDURE pmc_s_getnextarray
126	END INTERFACE pmc_s_getnextarray
127
128	INTERFACE pmc_s_set_dataarray
129	MODULE PROCEDURE pmc_s_set_dataarray_2d
130	MODULE PROCEDURE pmc_s_set_dataarray_3d
131	END INTERFACE pmc_s_set_dataarray
132
133	INTERFACE pmc_s_setind_and_allocmem
134	MODULE PROCEDURE pmc_s_setind_and_allocmem
135	END INTERFACE pmc_s_setind_and_allocmem
136
137	INTERFACE pmc_s_fillbuffer
138	MODULE PROCEDURE pmc_s_fillbuffer
139	END INTERFACE pmc_s_fillbuffer
140
141	INTERFACE pmc_s_getdata_from_buffer
142	MODULE PROCEDURE pmc_s_getdata_from_buffer
143	END INTERFACE pmc_s_getdata_from_buffer
144
145	INTERFACE pmc_s_set_active_data_array
146	MODULE PROCEDURE pmc_s_set_active_data_array
147	END INTERFACE pmc_s_set_active_data_array
148
149	PUBLIC pmc_serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer, &
150	pmc_s_getdata_from_buffer, pmc_s_getnextarray, &
151	pmc_s_setind_and_allocmem, pmc_s_set_active_data_array, &
152	pmc_s_set_dataarray, pmc_s_set_2d_index_list
153
154	CONTAINS
155
156
157	SUBROUTINE pmc_serverinit
158
159	IMPLICIT NONE
160
161	INTEGER :: clientid !<
162	INTEGER :: i !<
163	INTEGER :: j !<
164	INTEGER :: istat !<
165
166
167	DO i = 1, SIZE( pmc_server_for_client )-1
168
169	clientid = pmc_server_for_client( i )
170
171	clients(clientid)%model_comm = m_model_comm
172	clients(clientid)%inter_comm = m_to_client_comm(clientid)
173	!
174	!-- Get rank and size
175	CALL MPI_COMM_RANK( clients(clientid)%model_comm, &
176	clients(clientid)%model_rank, istat )
177	CALL MPI_COMM_SIZE( clients(clientid)%model_comm, &
178	clients(clientid)%model_npes, istat )
179	CALL MPI_COMM_REMOTE_SIZE( clients(clientid)%inter_comm, &
180	clients(clientid)%inter_npes, istat )
181	!
182	!-- Intra communicater is used for MPI_GET
183	CALL MPI_INTERCOMM_MERGE( clients(clientid)%inter_comm, .FALSE., &
184	clients(clientid)%intra_comm, istat )
185	CALL MPI_COMM_RANK( clients(clientid)%intra_comm, &
186	clients(clientid)%intra_rank, istat )
187
188	ALLOCATE( clients(clientid)%pes(clients(clientid)%inter_npes))
189	!
190	!-- Allocate array of TYPE arraydef for all client PEs to store information
191	!-- of the transfer array
192	DO j = 1, clients(clientid)%inter_npes
193	ALLOCATE( clients(clientid)%pes(j)%array_list(pmc_max_array) )
194	ENDDO
195
196	CALL get_da_names_from_client (clientid)
197
198	ENDDO
199
200	END SUBROUTINE pmc_serverinit
201
202
203
204	SUBROUTINE pmc_s_set_2d_index_list( clientid, index_list )
205
206	IMPLICIT NONE
207
208	INTEGER, INTENT(IN) :: clientid !<
209	INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list !<
210
211	INTEGER :: ian !<
212	INTEGER :: ic !<
213	INTEGER :: ie !<
214	INTEGER :: ip !<
215	INTEGER :: is !<
216	INTEGER :: istat !<
217	INTEGER :: n !<
218
219
220	IF ( m_model_rank == 0 ) THEN
221	!
222	!-- Sort to ascending server PE
223	CALL pmc_sort( index_list, 6 )
224
225	is = 1
226	DO ip = 0, m_model_npes-1
227	!
228	!-- Split into server PEs
229	ie = is - 1
230	!
231	!-- There may be no entry for this PE
232	IF ( is <= SIZE( index_list,2 ) .AND. ie >= 0 ) THEN
233
234	DO WHILE ( index_list(6,ie+1 ) == ip )
235	ie = ie + 1
236	IF ( ie == SIZE( index_list,2 ) ) EXIT
237	ENDDO
238
239	ian = ie - is + 1
240
241	ELSE
242	is = -1
243	ie = -2
244	ian = 0
245	ENDIF
246	!
247	!-- Send data to other server PEs
248	IF ( ip == 0 ) THEN
249	indclients(clientid)%nrpoints = ian
250	IF ( ian > 0) THEN
251	ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
252	indclients(clientid)%index_list_2d(:,1:ian) = &
253	index_list(:,is:ie)
254	ENDIF
255	ELSE
256	CALL MPI_SEND( ian, 1, MPI_INTEGER, ip, 1000, m_model_comm, &
257	istat )
258	IF ( ian > 0) THEN
259	CALL MPI_SEND( index_list(1,is), 6*ian, MPI_INTEGER, ip, &
260	1001, m_model_comm, istat )
261	ENDIF
262	ENDIF
263	is = ie + 1
264
265	ENDDO
266
267	ELSE
268
269	CALL MPI_RECV( indclients(clientid)%nrpoints, 1, MPI_INTEGER, 0, 1000, &
270	m_model_comm, MPI_STATUS_IGNORE, istat )
271	ian = indclients(clientid)%nrpoints
272
273	IF ( ian > 0 ) THEN
274	ALLOCATE( indclients(clientid)%index_list_2d(6,ian) )
275	CALL MPI_RECV( indclients(clientid)%index_list_2d, 6*ian, &
276	MPI_INTEGER, 0, 1001, m_model_comm, &
277	MPI_STATUS_IGNORE, istat)
278	ENDIF
279
280	ENDIF
281
282	CALL set_pe_index_list( clientid, clients(clientid), &
283	indclients(clientid)%index_list_2d, &
284	indclients(clientid)%nrpoints )
285
286	END SUBROUTINE pmc_s_set_2d_index_list
287
288
289
290	SUBROUTINE pmc_s_clear_next_array_list
291
292	IMPLICIT NONE
293
294	next_array_in_list = 0
295
296	END SUBROUTINE pmc_s_clear_next_array_list
297
298
299
300	LOGICAL FUNCTION pmc_s_getnextarray( clientid, myname )
301	!
302	!-- List handling is still required to get minimal interaction with
303	!-- pmc_interface
304	!-- TODO: what does "still" mean? Is there a chance to change this!
305	CHARACTER(LEN=*), INTENT(OUT) :: myname !<
306	INTEGER(iwp), INTENT(IN) :: clientid !<
307
308	TYPE(arraydef), POINTER :: ar
309	TYPE(pedef), POINTER :: ape
310
311	next_array_in_list = next_array_in_list + 1
312	!
313	!-- Array names are the same on all client PEs, so take first PE to get the name
314	ape => clients(clientid)%pes(1)
315
316	IF ( next_array_in_list > ape%nr_arrays ) THEN
317	!
318	!-- All arrays are done
319	pmc_s_getnextarray = .FALSE.
320	RETURN
321	ENDIF
322
323	ar => ape%array_list(next_array_in_list)
324	myname = ar%name
325	!
326	!-- Return true if legal array
327	!-- TODO: what does this comment mean? Can there be non-legal arrays??
328	pmc_s_getnextarray = .TRUE.
329
330	END FUNCTION pmc_s_getnextarray
331
332
333
334	SUBROUTINE pmc_s_set_dataarray_2d( clientid, array, array_2 )
335
336	IMPLICIT NONE
337
338	INTEGER,INTENT(IN) :: clientid !<
339
340	REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER :: array !<
341	REAL(wp), INTENT(IN), DIMENSION(:,:), POINTER, OPTIONAL :: array_2 !<
342
343	INTEGER :: nrdims !<
344	INTEGER, DIMENSION(4) :: dims !<
345	TYPE(C_PTR) :: array_adr !<
346	TYPE(C_PTR) :: second_adr !<
347
348
349	dims = 1
350	nrdims = 2
351	dims(1) = SIZE( array,1 )
352	dims(2) = SIZE( array,2 )
353	array_adr = C_LOC( array )
354
355	IF ( PRESENT( array_2 ) ) THEN
356	second_adr = C_LOC(array_2)
357	CALL pmc_s_setarray( clientid, nrdims, dims, array_adr, &
358	second_adr = second_adr)
359	ELSE
360	CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
361	ENDIF
362
363	END SUBROUTINE pmc_s_set_dataarray_2d
364
365
366
367	SUBROUTINE pmc_s_set_dataarray_3d( clientid, array, nz_cl, nz, array_2 )
368
369	IMPLICIT NONE
370
371	INTEGER, INTENT(IN) :: clientid !<
372	INTEGER, INTENT(IN) :: nz !<
373	INTEGER, INTENT(IN) :: nz_cl !<
374
375	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER :: array !<
376	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER, OPTIONAL :: array_2 !<
377
378	INTEGER :: nrdims !<
379	INTEGER, DIMENSION(4) :: dims !<
380	TYPE(C_PTR) :: array_adr !<
381	TYPE(C_PTR) :: second_adr !<
382
383	!-- TODO: the next assignment seems to be obsolete. Please check!
384	dims = 1
385	dims = 0
386	nrdims = 3
387	dims(1) = SIZE( array,1 )
388	dims(2) = SIZE( array,2 )
389	dims(3) = SIZE( array,3 )
390	dims(4) = nz_cl+dims(1)-nz ! works for first dimension 1:nz and 0:nz+1
391
392	array_adr = C_LOC(array)
393
394	!
395	!-- In PALM's pointer version, two indices have to be stored internally.
396	!-- The active address of the data array is set in swap_timelevel.
397	IF ( PRESENT( array_2 ) ) THEN
398	second_adr = C_LOC( array_2 )
399	CALL pmc_s_setarray( clientid, nrdims, dims, array_adr, &
400	second_adr = second_adr)
401	ELSE
402	CALL pmc_s_setarray( clientid, nrdims, dims, array_adr )
403	ENDIF
404
405	END SUBROUTINE pmc_s_set_dataarray_3d
406
407
408
409	SUBROUTINE pmc_s_setind_and_allocmem( clientid )
410
411	USE control_parameters, &
412	ONLY: message_string
413
414	IMPLICIT NONE
415
416	!
417	!-- Naming convention for appendices: _sc -> server to client transfer
418	!-- _cs -> client to server transfer
419	!-- send -> server to client transfer
420	!-- recv -> client to server transfer
421	INTEGER, INTENT(IN) :: clientid !<
422
423	INTEGER :: arlen !<
424	INTEGER :: i !<
425	INTEGER :: ierr !<
426	INTEGER :: istat !<
427	INTEGER :: j !<
428	INTEGER :: myindex !<
429	INTEGER :: rcount !< count MPI requests
430	INTEGER :: tag !<
431
432	INTEGER(idp) :: bufsize !< size of MPI data window
433	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
434
435	INTEGER, DIMENSION(1024) :: req !<
436
437	TYPE(C_PTR) :: base_ptr !<
438	TYPE(pedef), POINTER :: ape !<
439	TYPE(arraydef), POINTER :: ar !<
440
441	REAL(wp),DIMENSION(:), POINTER, SAVE :: base_array_sc !< base array for server to client transfer
442	REAL(wp),DIMENSION(:), POINTER, SAVE :: base_array_cs !< base array for client to server transfer
443
444	!
445	!-- Server to client direction
446	myindex = 1
447	rcount = 0
448	bufsize = 8
449
450	!
451	!-- First stride: compute size and set index
452	DO i = 1, clients(clientid)%inter_npes
453
454	ape => clients(clientid)%pes(i)
455	tag = 200
456
457	DO j = 1, ape%nr_arrays
458
459	ar => ape%array_list(j)
460	IF ( ar%nrdims == 2 ) THEN
461	arlen = ape%nrele
462	ELSEIF ( ar%nrdims == 3 ) THEN
463	arlen = ape%nrele * ar%a_dim(4)
464	ELSE
465	arlen = -1
466	ENDIF
467	ar%sendindex = myindex
468
469	tag = tag + 1
470	rcount = rcount + 1
471	CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, &
472	clients(clientid)%inter_comm, req(rcount), ierr )
473	!
474	!-- Maximum of 1024 outstanding requests
475	!-- TODO: what does this limit means?
476	IF ( rcount == 1024 ) THEN
477	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
478	rcount = 0
479	ENDIF
480
481	myindex = myindex + arlen
482	bufsize = bufsize + arlen
483	ar%sendsize = arlen
484
485	ENDDO
486
487	IF ( rcount > 0 ) THEN
488	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
489	ENDIF
490
491	ENDDO
492
493	!
494	!-- Create RMA (One Sided Communication) window for data buffer server to
495	!-- client transfer.
496	!-- The buffer of MPI_GET (counterpart of transfer) can be PE-local, i.e.
497	!-- it can but must not be part of the MPI RMA window. Only one RMA window is
498	!-- required to prepare the data for
499	!-- server -> client transfer on the server side
500	!-- and for
501	!-- client -> server transfer on the client side
502	CALL pmc_alloc_mem( base_array_sc, bufsize )
503	clients(clientid)%totalbuffersize = bufsize * wp
504
505	winsize = bufsize * wp
506	CALL MPI_WIN_CREATE( base_array_sc, winsize, wp, MPI_INFO_NULL, &
507	clients(clientid)%intra_comm, &
508	clients(clientid)%win_server_client, ierr )
509	!
510	!-- Open window to set data
511	CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr )
512	!
513	!-- Second stride: set buffer pointer
514	DO i = 1, clients(clientid)%inter_npes
515
516	ape => clients(clientid)%pes(i)
517
518	DO j = 1, ape%nr_arrays
519
520	ar => ape%array_list(j)
521	ar%sendbuf = C_LOC( base_array_sc(ar%sendindex) )
522
523	!-- TODO: replace this by standard PALM error message using the message routine
524	IF ( ar%sendindex + ar%sendsize > bufsize ) THEN
525	write(0,'(a,i4,4i7,1x,a)') 'Server Buffer too small ',i, &
526	ar%sendindex,ar%sendsize,ar%sendindex+ar%sendsize,bufsize,trim(ar%name)
527	CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
528	ENDIF
529	ENDDO
530	ENDDO
531
532	!
533	!-- Client to server direction
534	bufsize = 8
535	!
536	!-- First stride: compute size and set index
537	DO i = 1, clients(clientid)%inter_npes
538
539	ape => clients(clientid)%pes(i)
540	tag = 300
541
542	DO j = 1, ape%nr_arrays
543
544	ar => ape%array_list(j)
545	!
546	!-- Receive index from client
547	tag = tag + 1
548	CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, &
549	clients(clientid)%inter_comm, MPI_STATUS_IGNORE, ierr )
550
551	IF ( ar%nrdims == 3 ) THEN
552	bufsize = MAX( bufsize, ape%nrele * ar%a_dim(4) )
553	ELSE
554	bufsize = MAX( bufsize, ape%nrele )
555	ENDIF
556	ar%recvindex = myindex
557
558	ENDDO
559
560	ENDDO
561
562	!
563	!-- Create RMA (one sided communication) data buffer.
564	!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
565	!-- the MPI RMA window
566	CALL pmc_alloc_mem( base_array_cs, bufsize, base_ptr )
567	clients(clientid)%totalbuffersize = bufsize * wp
568
569	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
570	!
571	!-- Second stride: set buffer pointer
572	DO i = 1, clients(clientid)%inter_npes
573
574	ape => clients(clientid)%pes(i)
575
576	DO j = 1, ape%nr_arrays
577	ar => ape%array_list(j)
578	ar%recvbuf = base_ptr
579	ENDDO
580
581	ENDDO
582
583	END SUBROUTINE pmc_s_setind_and_allocmem
584
585
586
587	SUBROUTINE pmc_s_fillbuffer( clientid, waittime )
588
589	IMPLICIT NONE
590
591	INTEGER, INTENT(IN) :: clientid !<
592
593	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
594
595	INTEGER :: ierr !<
596	INTEGER :: ij !<
597	INTEGER :: ip !<
598	INTEGER :: istat !<
599	INTEGER :: j !<
600	INTEGER :: myindex !<
601
602	INTEGER, DIMENSION(1) :: buf_shape
603
604	REAL(wp) :: t1 !<
605	REAL(wp) :: t2 !<
606	REAL(wp), POINTER, DIMENSION(:) :: buf !<
607	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
608	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
609
610	TYPE(pedef), POINTER :: ape !<
611	TYPE(arraydef), POINTER :: ar !<
612
613	!
614	!-- Synchronization of the model is done in pmci_client_synchronize and
615	!-- pmci_server_synchronize. Therefor the RMA window can be filled without
616	!-- sychronization at this point and a barrier is not necessary.
617	!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
618	!-- pmc_c_getbuffer
619	IF ( PRESENT( waittime) ) THEN
620	t1 = pmc_time()
621	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
622	t2 = pmc_time()
623	waittime = t2- t1
624	ENDIF
625
626	DO ip = 1, clients(clientid)%inter_npes
627
628	ape => clients(clientid)%pes(ip)
629
630	DO j = 1, ape%nr_arrays
631
632	ar => ape%array_list(j)
633	myindex = 1
634
635	IF ( ar%nrdims == 2 ) THEN
636
637	buf_shape(1) = ape%nrele
638	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
639	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
640	DO ij = 1, ape%nrele
641	buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
642	myindex = myindex + 1
643	ENDDO
644
645	ELSEIF ( ar%nrdims == 3 ) THEN
646
647	buf_shape(1) = ape%nrele*ar%a_dim(4)
648	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
649	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
650	DO ij = 1, ape%nrele
651	buf(myindex:myindex+ar%a_dim(4)-1) = &
652	data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i)
653	myindex = myindex + ar%a_dim(4)
654	ENDDO
655
656	ENDIF
657
658	ENDDO
659
660	ENDDO
661	!
662	!-- Buffer is filled
663	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
664
665	END SUBROUTINE pmc_s_fillbuffer
666
667
668
669	SUBROUTINE pmc_s_getdata_from_buffer( clientid, waittime )
670
671	IMPLICIT NONE
672
673	INTEGER, INTENT(IN) :: clientid !<
674	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
675
676	INTEGER :: ierr !<
677	INTEGER :: ij !<
678	INTEGER :: ip !<
679	INTEGER :: istat !<
680	INTEGER :: j !<
681	INTEGER :: myindex !<
682	INTEGER :: nr !<
683	INTEGER :: target_pe !<
684	INTEGER(kind=MPI_ADDRESS_KIND) :: target_disp !<
685
686	INTEGER, DIMENSION(1) :: buf_shape !<
687
688	REAL(wp) :: t1 !<
689	REAL(wp) :: t2 !<
690	REAL(wp), POINTER, DIMENSION(:) :: buf !<
691	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
692	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
693
694	TYPE(pedef), POINTER :: ape !<
695	TYPE(arraydef), POINTER :: ar !<
696
697
698	t1 = pmc_time()
699	!
700	!-- Wait for client to fill buffer
701	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
702	t2 = pmc_time() - t1
703	IF ( PRESENT( waittime ) ) waittime = t2
704	!
705	!-- TODO: check next statement
706	!-- Fence might do it, test later
707	!-- CALL MPI_WIN_FENCE( 0, clients(clientid)%win_server_client, ierr)
708	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
709
710	DO ip = 1, clients(clientid)%inter_npes
711
712	ape => clients(clientid)%pes(ip)
713
714	DO j = 1, ape%nr_arrays
715
716	ar => ape%array_list(j)
717
718	IF ( ar%recvindex < 0 ) CYCLE
719
720	IF ( ar%nrdims == 2 ) THEN
721	nr = ape%nrele
722	ELSEIF ( ar%nrdims == 3 ) THEN
723	nr = ape%nrele * ar%a_dim(4)
724	ENDIF
725
726	buf_shape(1) = nr
727	CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
728
729	!
730	!-- MPI passive target RMA
731	IF ( nr > 0 ) THEN
732	target_disp = ar%recvindex - 1
733	!
734	!-- Client PEs are located behind server PEs
735	target_pe = ip - 1 + m_model_npes
736	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED, target_pe, 0, &
737	clients(clientid)%win_server_client, ierr )
738	CALL MPI_GET( buf, nr, MPI_REAL, target_pe, target_disp, nr, &
739	MPI_REAL, clients(clientid)%win_server_client, ierr )
740	CALL MPI_WIN_UNLOCK( target_pe, &
741	clients(clientid)%win_server_client, ierr )
742	ENDIF
743
744	myindex = 1
745	IF ( ar%nrdims == 2 ) THEN
746
747	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
748	DO ij = 1, ape%nrele
749	data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
750	myindex = myindex + 1
751	ENDDO
752
753	ELSEIF ( ar%nrdims == 3 ) THEN
754
755	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3))
756	DO ij = 1, ape%nrele
757	data_3d(1:ar%a_dim(4),ape%locind(ij)%j,ape%locind(ij)%i) = &
758	buf(myindex:myindex+ar%a_dim(4)-1)
759	myindex = myindex + ar%a_dim(4)
760	ENDDO
761
762	ENDIF
763
764	ENDDO
765
766	ENDDO
767
768	END SUBROUTINE pmc_s_getdata_from_buffer
769
770
771
772	SUBROUTINE get_da_names_from_client( clientid )
773	!
774	!-- Get data array description and name from client
775	IMPLICIT NONE
776
777	INTEGER, INTENT(IN) :: clientid !<
778
779	TYPE(da_namedef) :: myname !<
780
781	DO
782	CALL pmc_bcast( myname%couple_index, 0, comm=m_to_client_comm(clientid) )
783	IF ( myname%couple_index == -1 ) EXIT
784	CALL pmc_bcast( myname%serverdesc, 0, comm=m_to_client_comm(clientid) )
785	CALL pmc_bcast( myname%nameonserver, 0, comm=m_to_client_comm(clientid) )
786	CALL pmc_bcast( myname%clientdesc, 0, comm=m_to_client_comm(clientid) )
787	CALL pmc_bcast( myname%nameonclient, 0, comm=m_to_client_comm(clientid) )
788
789	CALL pmc_g_setname( clients(clientid), myname%couple_index, &
790	myname%nameonserver )
791	ENDDO
792
793	END SUBROUTINE get_da_names_from_client
794
795
796
797	SUBROUTINE pmc_s_setarray(clientid, nrdims, dims, array_adr, second_adr )
798	!
799	!-- Set array for client interPE 0
800	IMPLICIT NONE
801
802	INTEGER, INTENT(IN) :: clientid !<
803	INTEGER, INTENT(IN) :: nrdims !<
804	INTEGER, INTENT(IN), DIMENSION(:) :: dims !<
805
806	TYPE(C_PTR), INTENT(IN) :: array_adr !<
807	TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr !<
808
809	INTEGER :: i !< local counter
810
811	TYPE(pedef), POINTER :: ape !<
812	TYPE(arraydef), POINTER :: ar !<
813
814
815	DO i = 1, clients(clientid)%inter_npes
816
817	ape => clients(clientid)%pes(i)
818	ar => ape%array_list(next_array_in_list)
819	ar%nrdims = nrdims
820	ar%a_dim = dims
821	ar%data = array_adr
822
823	IF ( PRESENT( second_adr ) ) THEN
824	ar%po_data(1) = array_adr
825	ar%po_data(2) = second_adr
826	ELSE
827	ar%po_data(1) = C_NULL_PTR
828	ar%po_data(2) = C_NULL_PTR
829	ENDIF
830
831	ENDDO
832
833	END SUBROUTINE pmc_s_setarray
834
835
836
837	SUBROUTINE pmc_s_set_active_data_array( clientid, iactive )
838
839	IMPLICIT NONE
840
841	INTEGER, INTENT(IN) :: clientid !<
842	INTEGER, INTENT(IN) :: iactive !<
843
844	INTEGER :: i !<
845	INTEGER :: ip !<
846	INTEGER :: j !<
847
848	TYPE(pedef), POINTER :: ape !<
849	TYPE(arraydef), POINTER :: ar !<
850
851	DO ip = 1, clients(clientid)%inter_npes
852
853	ape => clients(clientid)%pes(ip)
854
855	DO j = 1, ape%nr_arrays
856
857	ar => ape%array_list(j)
858	IF ( iactive == 1 .OR. iactive == 2 ) THEN
859	ar%data = ar%po_data(iactive)
860	ENDIF
861
862	ENDDO
863
864	ENDDO
865
866	END SUBROUTINE pmc_s_set_active_data_array
867
868
869
870	SUBROUTINE set_pe_index_list( clientid, myclient, index_list, nrp )
871
872	IMPLICIT NONE
873
874	INTEGER, INTENT(IN) :: clientid !<
875	INTEGER, INTENT(IN), DIMENSION(:,:) :: index_list !<
876	INTEGER, INTENT(IN) :: nrp !<
877
878	TYPE(clientdef), INTENT(INOUT) :: myclient !<
879
880	INTEGER :: i !<
881	INTEGER :: ierr !<
882	INTEGER :: ind !<
883	INTEGER :: indwin !<
884	INTEGER :: indwin2 !<
885	INTEGER :: i2 !<
886	INTEGER :: j !<
887	INTEGER :: rempe !<
888	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
889
890	INTEGER, DIMENSION(myclient%inter_npes) :: remind !<
891
892	INTEGER, DIMENSION(:), POINTER :: remindw !<
893	INTEGER, DIMENSION(:), POINTER :: rldef !<
894
895	TYPE(pedef), POINTER :: ape !<
896
897	!
898	!-- First, count entries for every remote client PE
899	DO i = 1, myclient%inter_npes
900	ape => myclient%pes(i)
901	ape%nrele = 0
902	ENDDO
903	!
904	!-- Loop over number of coarse grid cells
905	DO j = 1, nrp
906	rempe = index_list(5,j) + 1 ! PE number on remote PE
907	ape => myclient%pes(rempe)
908	ape%nrele = ape%nrele + 1 ! Increment number of elements for this client PE
909	ENDDO
910
911	DO i = 1, myclient%inter_npes
912	ape => myclient%pes(i)
913	ALLOCATE( ape%locind(ape%nrele) )
914	ENDDO
915
916	remind = 0
917
918	!
919	!-- Second, create lists
920	!-- Loop over number of coarse grid cells
921	DO j = 1, nrp
922	rempe = index_list(5,j) + 1
923	ape => myclient%pes(rempe)
924	remind(rempe) = remind(rempe)+1
925	ind = remind(rempe)
926	ape%locind(ind)%i = index_list(1,j)
927	ape%locind(ind)%j = index_list(2,j)
928	ENDDO
929	!
930	!-- Prepare number of elements for client PEs
931	CALL pmc_alloc_mem( rldef, myclient%inter_npes*2 )
932	!
933	!-- Number of client PEs * size of INTEGER (i just arbitrary INTEGER)
934	winsize = myclient%inter_npesc_sizeof(i)2
935
936	CALL MPI_WIN_CREATE( rldef, winsize, iwp, MPI_INFO_NULL, &
937	myclient%intra_comm, indwin, ierr )
938	!
939	!-- Open window to set data
940	CALL MPI_WIN_FENCE( 0, indwin, ierr )
941
942	rldef(1) = 0 ! index on remote PE 0
943	rldef(2) = remind(1) ! number of elements on remote PE 0
944	!
945	!-- Reserve buffer for index array
946	DO i = 2, myclient%inter_npes
947	i2 = (i-1) * 2 + 1
948	rldef(i2) = rldef(i2-2) + rldef(i2-1) * 2 ! index on remote PE
949	rldef(i2+1) = remind(i) ! number of elements on remote PE
950	ENDDO
951	!
952	!-- Close window to allow client to access data
953	CALL MPI_WIN_FENCE( 0, indwin, ierr )
954	!
955	!-- Client has retrieved data
956	CALL MPI_WIN_FENCE( 0, indwin, ierr )
957
958	i2 = 2 * myclient%inter_npes - 1
959	winsize = ( rldef(i2) + rldef(i2+1) ) * 2
960	!
961	!-- Make sure, MPI_ALLOC_MEM works
962	winsize = MAX( winsize, 1 )
963
964	CALL pmc_alloc_mem( remindw, INT( winsize ) )
965
966	CALL MPI_BARRIER( m_model_comm, ierr )
967	CALL MPI_WIN_CREATE( remindw, winsize*c_sizeof(i), iwp, MPI_INFO_NULL, &
968	myclient%intra_comm, indwin2, ierr )
969	!
970	!-- Open window to set data
971	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
972	!
973	!-- Create the 2D index list
974	DO j = 1, nrp
975	rempe = index_list(5,j) + 1 ! PE number on remote PE
976	ape => myclient%pes(rempe)
977	i2 = rempe * 2 - 1
978	ind = rldef(i2) + 1
979	remindw(ind) = index_list(3,j)
980	remindw(ind+1) = index_list(4,j)
981	rldef(i2) = rldef(i2)+2
982	ENDDO
983	!
984	!-- All data areset
985	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
986	!
987	!-- Don't know why, but this barrier is necessary before windows can be freed
988	!-- TODO: find out why this is required
989	CALL MPI_BARRIER( myclient%intra_comm, ierr )
990
991	CALL MPI_WIN_FREE( indwin, ierr )
992	CALL MPI_WIN_FREE( indwin2, ierr )
993
994	!-- TODO: check if the following idea needs to be done
995	!-- Sollte funktionieren, Problem mit MPI implementation
996	!-- https://www.lrz.de/services/software/parallel/mpi/onesided
997	!-- CALL MPI_Free_mem (remindw, ierr)
998
999	END SUBROUTINE set_pe_index_list
1000
1001	#endif
1002	END MODULE pmc_server

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

Context Navigation

source: palm/trunk/SOURCE/pmc_server_mod.f90 @ 1929

Download in other formats: