Home

Context Navigation

source: palm/trunk/SOURCE/pmc_client_mod.f90 @ 1896

Last change on this file since 1896 was 1896, checked in by raasch, 8 years ago
re-formatting to match PALM style
Property svn:keywords set to `Id`
File size: 25.0 KB

Line
1	MODULE pmc_client
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	! re-formatted to match PALM style
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_client_mod.f90 1896 2016-05-03 08:06:41Z raasch $
27	!
28	! 1850 2016-04-08 13:29:27Z maronga
29	! Module renamed
30	!
31	!
32	! 1833 2016-04-07 14:23:03Z raasch
33	! gfortran requires pointer attributes for some array declarations,
34	! long line wrapped
35	!
36	! 1808 2016-04-05 19:44:00Z raasch
37	! MPI module used by default on all machines
38	!
39	! 1797 2016-03-21 16:50:28Z raasch
40	! introduction of different datatransfer modes
41	!
42	! 1791 2016-03-11 10:41:25Z raasch
43	! Debug write-statement commented out
44	!
45	! 1786 2016-03-08 05:49:27Z raasch
46	! change in client-server data transfer: server now gets data from client
47	! instead that client put's it to the server
48	!
49	! 1783 2016-03-06 18:36:17Z raasch
50	! Bugfix: wrong data-type in MPI_WIN_CREATE replaced
51	!
52	! 1779 2016-03-03 08:01:28Z raasch
53	! kind=dp replaced by wp, dim_order removed
54	! array management changed from linked list to sequential loop
55	!
56	! 1764 2016-02-28 12:45:19Z raasch
57	! cpp-statement added (nesting can only be used in parallel mode),
58	! all kinds given in PALM style
59	!
60	! 1762 2016-02-25 12:31:13Z hellstea
61	! Initial revision by K. Ketelsen
62	!
63	! Description:
64	! ------------
65	!
66	! Client part of Palm Model Coupler
67	!------------------------------------------------------------------------------!
68
69	#if defined( __parallel )
70
71	USE, INTRINSIC :: iso_c_binding
72
73	#if defined( __mpifh )
74	INCLUDE "mpif.h"
75	#else
76	USE MPI
77	#endif
78
79	USE kinds
80	USE pmc_general, &
81	ONLY: arraydef, clientdef, da_desclen, da_namedef, da_namelen, pedef, &
82	pmc_da_name_err, pmc_g_setname, pmc_max_array, pmc_status_ok
83
84	USE pmc_handle_communicator, &
85	ONLY: m_model_comm, m_model_npes, m_model_rank, m_to_server_comm
86
87	USE pmc_mpi_wrapper, &
88	ONLY: pmc_alloc_mem, pmc_bcast, pmc_inter_bcast, &
89	pmc_recv_from_server, pmc_send_to_server, pmc_time
90
91	IMPLICIT NONE
92
93	PRIVATE
94	SAVE
95
96	TYPE(clientdef) :: me !<
97
98	INTEGER :: myindex = 0 !< counter and unique number for data arrays
99	INTEGER :: next_array_in_list = 0 !<
100
101
102	INTERFACE pmc_clientinit
103	MODULE PROCEDURE pmc_clientinit
104	END INTERFACE PMC_ClientInit
105
106	INTERFACE pmc_c_clear_next_array_list
107	MODULE PROCEDURE pmc_c_clear_next_array_list
108	END INTERFACE pmc_c_clear_next_array_list
109
110	INTERFACE pmc_c_getbuffer
111	MODULE PROCEDURE pmc_c_getbuffer
112	END INTERFACE pmc_c_getbuffer
113
114	INTERFACE pmc_c_getnextarray
115	MODULE PROCEDURE pmc_c_getnextarray
116	END INTERFACE pmc_c_getnextarray
117
118	INTERFACE pmc_c_get_2d_index_list
119	MODULE PROCEDURE pmc_c_get_2d_index_list
120	END INTERFACE pmc_c_get_2d_index_list
121
122	INTERFACE pmc_c_putbuffer
123	MODULE PROCEDURE pmc_c_putbuffer
124	END INTERFACE pmc_c_putbuffer
125
126	INTERFACE pmc_c_setind_and_allocmem
127	MODULE PROCEDURE pmc_c_setind_and_allocmem
128	END INTERFACE pmc_c_setind_and_allocmem
129
130	INTERFACE pmc_c_set_dataarray
131	MODULE PROCEDURE pmc_c_set_dataarray_2d
132	MODULE PROCEDURE pmc_c_set_dataarray_3d
133	END INTERFACE pmc_c_set_dataarray
134
135	INTERFACE pmc_set_dataarray_name
136	MODULE PROCEDURE pmc_set_dataarray_name
137	MODULE PROCEDURE pmc_set_dataarray_name_lastentry
138	END INTERFACE pmc_set_dataarray_name
139
140
141	PUBLIC pmc_clientinit, pmc_c_clear_next_array_list, pmc_c_getbuffer, &
142	pmc_c_getnextarray, pmc_c_putbuffer, pmc_c_setind_and_allocmem, &
143	pmc_c_set_dataarray, pmc_set_dataarray_name, pmc_c_get_2d_index_list
144
145	CONTAINS
146
147
148
149	SUBROUTINE pmc_clientinit
150
151	IMPLICIT NONE
152
153	INTEGER :: i !<
154	INTEGER :: istat !<
155
156	!
157	!-- Get / define the MPI environment
158	me%model_comm = m_model_comm
159	me%inter_comm = m_to_server_comm
160
161	CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
162	CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
163	CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
164	!
165	!-- Intra-communicater is used for MPI_GET
166	CALL MPI_INTERCOMM_MERGE( me%inter_comm, .TRUE., me%intra_comm, istat )
167	CALL MPI_COMM_RANK( me%intra_comm, me%intra_rank, istat )
168
169	ALLOCATE( me%pes(me%inter_npes) )
170
171	!
172	!-- Allocate an array of type arraydef for all server PEs to store information
173	!-- of then transfer array
174	DO i = 1, me%inter_npes
175	ALLOCATE( me%pes(i)%array_list(pmc_max_array) )
176	ENDDO
177
178	END SUBROUTINE pmc_clientinit
179
180
181
182	SUBROUTINE pmc_set_dataarray_name( serverarraydesc, serverarrayname, &
183	clientarraydesc, clientarrayname, istat )
184
185	IMPLICIT NONE
186
187	CHARACTER(LEN=*), INTENT(IN) :: serverarrayname !<
188	CHARACTER(LEN=*), INTENT(IN) :: serverarraydesc !<
189	CHARACTER(LEN=*), INTENT(IN) :: clientarrayname !<
190	CHARACTER(LEN=*), INTENT(IN) :: clientarraydesc !<
191
192	INTEGER, INTENT(OUT) :: istat !<
193
194	!
195	!-- Local variables
196	TYPE(da_namedef) :: myname !<
197
198	INTEGER :: mype !<
199	INTEGER :: my_addiarray = 0 !<
200
201
202	istat = pmc_status_ok
203	!
204	!-- Check length of array names
205	IF ( LEN( TRIM( serverarrayname) ) > da_namelen .OR. &
206	LEN( TRIM( clientarrayname) ) > da_namelen ) THEN
207	istat = pmc_da_name_err
208	ENDIF
209
210	IF ( m_model_rank == 0 ) THEN
211	myindex = myindex + 1
212	myname%couple_index = myIndex
213	myname%serverdesc = TRIM( serverarraydesc )
214	myname%nameonserver = TRIM( serverarrayname )
215	myname%clientdesc = TRIM( clientarraydesc )
216	myname%nameonclient = TRIM( clientarrayname )
217	ENDIF
218
219	!
220	!-- Broadcat to all client PEs
221	!-- TODO: describe what is broadcast here and why it is done
222	CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
223	CALL pmc_bcast( myname%serverdesc, 0, comm=m_model_comm )
224	CALL pmc_bcast( myname%nameonserver, 0, comm=m_model_comm )
225	CALL pmc_bcast( myname%clientdesc, 0, comm=m_model_comm )
226	CALL pmc_bcast( myname%nameonclient, 0, comm=m_model_comm )
227
228	!
229	!-- Broadcat to all server PEs
230	!-- TODO: describe what is broadcast here and why it is done
231	IF ( m_model_rank == 0 ) THEN
232	mype = MPI_ROOT
233	ELSE
234	mype = MPI_PROC_NULL
235	ENDIF
236
237	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
238	CALL pmc_bcast( myname%serverdesc, mype, comm=m_to_server_comm )
239	CALL pmc_bcast( myname%nameonserver, mype, comm=m_to_server_comm )
240	CALL pmc_bcast( myname%clientdesc, mype, comm=m_to_server_comm )
241	CALL pmc_bcast( myname%nameonclient, mype, comm=m_to_server_comm )
242
243	CALL pmc_g_setname( me, myname%couple_index, myname%nameonclient )
244
245	END SUBROUTINE pmc_set_dataarray_name
246
247
248
249	SUBROUTINE pmc_set_dataarray_name_lastentry( lastentry )
250
251	IMPLICIT NONE
252
253	LOGICAL, INTENT(IN), OPTIONAL :: lastentry !<
254
255	!
256	!-- Local variables
257	INTEGER :: mype !<
258	TYPE(dA_namedef) :: myname !<
259
260	myname%couple_index = -1
261
262	IF ( m_model_rank == 0 ) THEN
263	mype = MPI_ROOT
264	ELSE
265	mype = MPI_PROC_NULL
266	ENDIF
267
268	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_server_comm )
269
270	END SUBROUTINE pmc_set_dataarray_name_lastentry
271
272
273
274	SUBROUTINE pmc_c_get_2d_index_list
275
276	IMPLICIT NONE
277
278	INTEGER :: dummy !<
279	INTEGER :: i, ierr, i2, j, nr !<
280	INTEGER :: indwin !< MPI window object
281	INTEGER :: indwin2 ! < MPI window object
282
283	INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
284	INTEGER(KIND=MPI_ADDRESS_KIND) :: disp !< Displacement unit (Integer = 4, floating poit = 8
285	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !< Size of MPI window 2 (in bytes)
286
287	INTEGER, DIMENSION(me%inter_npes*2) :: nrele !< Number of Elements of a
288	!< horizontal slice
289	INTEGER, DIMENSION(:), POINTER :: myind !<
290
291	TYPE(pedef), POINTER :: ape !> Pointer to pedef structure
292
293
294	win_size = C_SIZEOF( dummy )
295	CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, &
296	indwin, ierr )
297	!
298	!-- Open window on server side
299	!-- TODO: why is the next MPI routine called twice??
300	CALL MPI_WIN_FENCE( 0, indwin, ierr )
301	!
302	!-- Close window on server side and open on client side
303	CALL MPI_WIN_FENCE( 0, indwin, ierr )
304
305	DO i = 1, me%inter_npes
306	disp = me%model_rank * 2
307	CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2, &
308	MPI_INTEGER, indwin, ierr )
309	ENDDO
310	!
311	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
312	!-- called
313	CALL MPI_WIN_FENCE( 0, indwin, ierr )
314
315	!
316	!-- Allocate memory for index array
317	winsize = 0
318	DO i = 1, me%inter_npes
319	ape => me%pes(i)
320	i2 = ( i-1 ) * 2 + 1
321	nr = nrele(i2+1)
322	IF ( nr > 0 ) THEN
323	ALLOCATE( ape%locind(nr) )
324	ELSE
325	NULLIFY( ape%locind )
326	ENDIF
327	winsize = MAX( nr, winsize )
328	ENDDO
329
330	ALLOCATE( myind(2*winsize) )
331	winsize = 1
332
333	!
334	!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
335	!-- Here, we use a dummy for the MPI window because the server PEs do not access
336	!-- the RMA window via MPI_GET or MPI_PUT
337	CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm, &
338	indwin2, ierr )
339	!
340	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is
341	!-- called
342	!-- TODO: as before: why is this called twice??
343	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
344	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
345
346	DO i = 1, me%inter_npes
347	ape => me%pes(i)
348	nr = nrele(i*2)
349	IF ( nr > 0 ) THEN
350	disp = nrele(2*(i-1)+1)
351	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
352	CALL MPI_GET( myind, 2nr, MPI_INTEGER, i-1, disp, 2nr, &
353	MPI_INTEGER, indwin2, ierr )
354	CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
355	DO j = 1, nr
356	ape%locind(j)%i = myind(2*j-1)
357	ape%locind(j)%j = myind(2*j)
358	ENDDO
359	ape%nrele = nr
360	ELSE
361	ape%nrele = -1
362	ENDIF
363	ENDDO
364
365	!
366	!-- Don't know why, but this barrier is necessary before we can free the windows
367	CALL MPI_BARRIER( me%intra_comm, ierr )
368
369	CALL MPI_WIN_FREE( indWin, ierr )
370	CALL MPI_WIN_FREE( indwin2, ierr )
371	DEALLOCATE( myind )
372
373	END SUBROUTINE pmc_c_get_2d_index_list
374
375
376
377	SUBROUTINE pmc_c_clear_next_array_list
378
379	IMPLICIT NONE
380
381	next_array_in_list = 0
382
383	END SUBROUTINE pmc_c_clear_next_array_list
384
385
386
387	LOGICAL FUNCTION pmc_c_getnextarray( myname )
388	!
389	!-- List handling is still required to get minimal interaction with
390	!-- pmc_interface
391	CHARACTER(LEN=*), INTENT(OUT) :: myname !<
392
393	!
394	!-- Local variables
395	TYPE(pedef), POINTER :: ape
396	TYPE(arraydef), POINTER :: ar
397
398
399	next_array_in_list = next_array_in_list + 1
400
401	!
402	!-- Array names are the same on all client PEs, so take first PE to get the name
403	ape => me%pes(1)
404	!
405	!-- Check if all arrays have been processed
406	IF ( next_array_in_list > ape%nr_arrays ) THEN
407	pmc_c_getnextarray = .FALSE.
408	RETURN
409	ENDIF
410
411	ar => ape%array_list( next_array_in_list )
412
413	myname = ar%name
414
415	!
416	!-- Return true if legal array
417	!-- TODO: the case of a non-legal array does not seem to appear, so why is this
418	!-- setting required at all?
419	pmc_c_getnextarray = .TRUE.
420
421	END function pmc_c_getnextarray
422
423
424
425	SUBROUTINE pmc_c_set_dataarray_2d( array )
426
427	IMPLICIT NONE
428
429	REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER :: array !<
430
431	INTEGER :: i !<
432	INTEGER :: nrdims !<
433	INTEGER, DIMENSION(4) :: dims !<
434
435	TYPE(C_PTR) :: array_adr
436	TYPE(arraydef), POINTER :: ar
437	TYPE(pedef), POINTER :: ape
438
439
440	dims = 1
441	nrdims = 2
442	dims(1) = SIZE( array, 1 )
443	dims(2) = SIZE( array, 2 )
444
445	array_adr = C_LOC( array )
446
447	DO i = 1, me%inter_npes
448	ape => me%pes(i)
449	ar => ape%array_list(next_array_in_list)
450	ar%nrdims = nrdims
451	ar%a_dim = dims
452	ar%data = array_adr
453	ENDDO
454
455	END SUBROUTINE pmc_c_set_dataarray_2d
456
457
458
459	SUBROUTINE pmc_c_set_dataarray_3d (array)
460
461	IMPLICIT NONE
462
463	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER :: array !<
464
465	INTEGER :: i
466	INTEGER :: nrdims
467	INTEGER, DIMENSION (4) :: dims
468	TYPE(C_PTR) :: array_adr
469	TYPE(pedef), POINTER :: ape
470	TYPE(arraydef), POINTER :: ar
471
472
473	dims = 1
474	nrdims = 3
475	dims(1) = SIZE( array, 1 )
476	dims(2) = SIZE( array, 2 )
477	dims(3) = SIZE( array, 3 )
478
479	array_adr = C_LOC( array )
480
481	DO i = 1, me%inter_npes
482	ape => me%pes(i)
483	ar => ape%array_list(next_array_in_list)
484	ar%nrdims = nrdims
485	ar%a_dim = dims
486	ar%data = array_adr
487	ENDDO
488
489	END SUBROUTINE pmc_c_set_dataarray_3d
490
491
492
493	SUBROUTINE pmc_c_setind_and_allocmem
494
495	IMPLICIT NONE
496	!
497	!-- Naming convention for appendices: _sc -> server to client transfer
498	!-- _cs -> client to server transfer
499	!-- recv -> server to client transfer
500	!-- send -> client to server transfer
501	CHARACTER(LEN=da_namelen) :: myname !<
502
503	INTEGER :: arlen !<
504	INTEGER :: myindex !<
505	INTEGER :: i !<
506	INTEGER :: ierr !<
507	INTEGER :: istat !<
508	INTEGER :: j !<
509	INTEGER :: rcount !<
510	INTEGER :: tag !<
511
512	INTEGER, PARAMETER :: noindex = -1 !<
513
514	INTEGER(idp) :: bufsize !< size of MPI data window
515	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
516
517	INTEGER,DIMENSION(1024) :: req !<
518
519	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_sc !< base array
520	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_cs !< base array
521
522	TYPE(pedef), POINTER :: ape !<
523	TYPE(arraydef), POINTER :: ar !<
524	Type(C_PTR) :: base_ptr !<
525
526
527	myindex = 0
528	bufsize = 8
529
530	!
531	!-- Server to client direction.
532	!-- First stride: compute size and set index
533	DO i = 1, me%inter_npes
534
535	ape => me%pes(i)
536	tag = 200
537
538	DO j = 1, ape%nr_arrays
539
540	ar => ape%array_list(j)
541	!
542	!-- Receive index from client
543	tag = tag + 1
544	CALL MPI_RECV( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
545	MPI_STATUS_IGNORE, ierr )
546	ar%recvindex = myindex
547	!
548	!-- Determine max, because client buffer is allocated only once
549	!-- TODO: give a more meaningful comment
550	IF( ar%nrdims == 3 ) THEN
551	bufsize = MAX( bufsize, ar%a_dim(1)ar%a_dim(2)ar%a_dim(3) )
552	ELSE
553	bufsize = MAX( bufsize, ar%a_dim(1)*ar%a_dim(2) )
554	ENDIF
555
556	ENDDO
557
558	ENDDO
559
560	!
561	!-- Create RMA (one sided communication) data buffer.
562	!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of
563	!-- the MPI RMA window
564	CALL pmc_alloc_mem( base_array_sc, bufsize, base_ptr )
565	me%totalbuffersize = bufsize*wp ! total buffer size in byte
566
567	!
568	!-- Second stride: set buffer pointer
569	DO i = 1, me%inter_npes
570
571	ape => me%pes(i)
572
573	DO j = 1, ape%nr_arrays
574	ar => ape%array_list(j)
575	ar%recvbuf = base_ptr
576	ENDDO
577
578	ENDDO
579
580	!
581	!-- Client to server direction
582	myindex = 1
583	rcount = 0
584	bufsize = 8
585
586	DO i = 1, me%inter_npes
587
588	ape => me%pes(i)
589	tag = 300
590
591	DO j = 1, ape%nr_arrays
592
593	ar => ape%array_list(j)
594	IF( ar%nrdims == 2 ) THEN
595	arlen = ape%nrele
596	ELSEIF( ar%nrdims == 3 ) THEN
597	arlen = ape%nrele*ar%a_dim(1)
598	ENDIF
599
600	tag = tag + 1
601	rcount = rcount + 1
602	IF ( ape%nrele > 0 ) THEN
603	CALL MPI_ISEND( myindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
604	req(rcount), ierr )
605	ar%sendindex = myindex
606	ELSE
607	CALL MPI_ISEND( noindex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, &
608	req(rcount), ierr )
609	ar%sendindex = noindex
610	ENDIF
611	!
612	!-- Maximum of 1024 outstanding requests
613	!-- TODO: explain where this maximum comes from (arbitrary?)
614	IF ( rcount == 1024 ) THEN
615	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
616	rcount = 0
617	ENDIF
618
619	IF ( ape%nrele > 0 ) THEN
620	ar%sendsize = arlen
621	myindex = myindex + arlen
622	bufsize = bufsize + arlen
623	ENDIF
624
625	ENDDO
626
627	IF ( rcount > 0 ) THEN
628	CALL MPI_WAITALL( rcount, req, MPI_STATUSES_IGNORE, ierr )
629	ENDIF
630
631	ENDDO
632
633	!
634	!-- Create RMA (one sided communication) window for data buffer client to server
635	!-- transfer.
636	!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it
637	!-- can but must not be part of the MPI RMA window. Only one RMA window is
638	!-- required to prepare the data
639	!-- for server -> client transfer on the server side
640	!-- and
641	!-- for client -> server transfer on the client side
642
643	CALL pmc_alloc_mem( base_array_cs, bufsize )
644	me%totalbuffersize = bufsize * wp ! total buffer size in byte
645
646	winSize = me%totalbuffersize
647
648	CALL MPI_WIN_CREATE( base_array_cs, winsize, wp, MPI_INFO_NULL, &
649	me%intra_comm, me%win_server_client, ierr )
650	CALL MPI_WIN_FENCE( 0, me%win_server_client, ierr )
651	CALL MPI_BARRIER( me%intra_comm, ierr )
652
653	!
654	!-- Second stride: set buffer pointer
655	DO i = 1, me%inter_npes
656
657	ape => me%pes(i)
658
659	DO j = 1, ape%nr_arrays
660
661	ar => ape%array_list(j)
662
663	IF ( ape%nrele > 0 ) THEN
664	ar%sendbuf = C_LOC( base_array_cs(ar%sendindex) )
665	!-- TODO: if this is an error to be really expected, replace the
666	!-- following message by a meaningful standard PALM message using
667	!-- the message-routine
668	IF ( ar%sendindex+ar%sendsize > bufsize ) THEN
669	WRITE( 0,'(a,i4,4i7,1x,a)') 'Client Buffer too small ', i, &
670	ar%sendindex, ar%sendsize, ar%sendindex+ar%sendsize, &
671	bufsize, TRIM( ar%name )
672	CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
673	ENDIF
674	ENDIF
675
676	ENDDO
677
678	ENDDO
679
680	END SUBROUTINE pmc_c_setind_and_allocmem
681
682
683
684	SUBROUTINE pmc_c_getbuffer( waittime )
685
686	IMPLICIT NONE
687
688	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
689
690	CHARACTER(LEN=da_namelen) :: myname !<
691
692	INTEGER :: ierr !<
693	INTEGER :: ij !<
694	INTEGER :: ip !<
695	INTEGER :: j !<
696	INTEGER :: myindex !<
697	INTEGER :: nr !< number of elements to get
698	!< from server
699	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp
700	INTEGER,DIMENSION(1) :: buf_shape
701
702	REAL(wp) :: t1
703	REAL(wp) :: t2
704
705	REAL(wp), POINTER, DIMENSION(:) :: buf
706	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d
707	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d
708	TYPE(pedef), POINTER :: ape
709	TYPE(arraydef), POINTER :: ar
710
711	!
712	!-- Synchronization of the model is done in pmci_client_synchronize and
713	!-- pmci_server_synchronize. Therefor the RMA window can be filled without
714	!-- sychronization at this point and a barrier is not necessary.
715	!-- Please note that waittime has to be set in pmc_s_fillbuffer AND
716	!-- pmc_c_getbuffer
717	IF ( PRESENT( waittime ) ) THEN
718	t1 = pmc_time()
719	CALL MPI_BARRIER( me%intra_comm, ierr )
720	t2 = pmc_time()
721	waittime = t2 - t1
722	ENDIF
723	!
724	!-- Wait for buffer is filled
725	!-- TODO: explain in more detail what is happening here. The barrier seems to
726	!-- contradict what is said a few lines beforer (i.e. that no barrier is necessary)
727	!-- TODO: In case of PRESENT( waittime ) the barrrier would be calles twice. Why?
728	!-- Shouldn't it be done the same way as in pmc_putbuffer?
729	CALL MPI_BARRIER( me%intra_comm, ierr )
730
731	DO ip = 1, me%inter_npes
732
733	ape => me%pes(ip)
734
735	DO j = 1, ape%nr_arrays
736
737	ar => ape%array_list(j)
738
739	IF ( ar%nrdims == 2 ) THEN
740	nr = ape%nrele
741	ELSEIF ( ar%nrdims == 3 ) THEN
742	nr = ape%nrele * ar%a_dim(1)
743	ENDIF
744
745	buf_shape(1) = nr
746	CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
747	!
748	!-- MPI passive target RMA
749	!-- TODO: explain the above comment
750	IF ( nr > 0 ) THEN
751	target_disp = ar%recvindex - 1
752	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0, &
753	me%win_server_client, ierr )
754	CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
755	me%win_server_client, ierr )
756	CALL MPI_WIN_UNLOCK( ip-1, me%win_server_client, ierr )
757	ENDIF
758
759	myindex = 1
760	IF ( ar%nrdims == 2 ) THEN
761
762	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
763
764	DO ij = 1, ape%nrele
765	data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
766	myindex = myindex + 1
767	ENDDO
768
769	ELSEIF ( ar%nrdims == 3 ) THEN
770
771	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
772
773	DO ij = 1, ape%nrele
774	data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) = &
775	buf(myindex:myindex+ar%a_dim(1)-1)
776	myindex = myindex+ar%a_dim(1)
777	ENDDO
778
779	ENDIF
780
781	ENDDO
782
783	ENDDO
784
785	END SUBROUTINE pmc_c_getbuffer
786
787
788
789	SUBROUTINE pmc_c_putbuffer( waittime )
790
791	IMPLICIT NONE
792
793	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
794
795	CHARACTER(LEN=da_namelen) :: myname !<
796
797	INTEGER :: ierr !<
798	INTEGER :: ij !<
799	INTEGER :: ip !<
800	INTEGER :: j !<
801	INTEGER :: myindex !<
802	INTEGER :: nr !< number of elements to get
803	!< from server
804	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp !<
805
806	INTEGER, DIMENSION(1) :: buf_shape !<
807
808	REAL(wp) :: t1 !<
809	REAL(wp) :: t2 !<
810
811	REAL(wp), POINTER, DIMENSION(:) :: buf !<
812	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
813	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
814
815	TYPE(pedef), POINTER :: ape !<
816	TYPE(arraydef), POINTER :: ar !<
817
818	!
819	!-- Wait for empty buffer
820	!-- TODO: explain what is done here
821	t1 = pmc_time()
822	CALL MPI_BARRIER( me%intra_comm, ierr )
823	t2 = pmc_time()
824	IF ( PRESENT( waittime ) ) waittime = t2 - t1
825
826	DO ip = 1, me%inter_npes
827
828	ape => me%pes(ip)
829
830	DO j = 1, ape%nr_arrays
831
832	ar => aPE%array_list(j)
833	myindex = 1
834
835	IF ( ar%nrdims == 2 ) THEN
836
837	buf_shape(1) = ape%nrele
838	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
839	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
840
841	DO ij = 1, ape%nrele
842	buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
843	myindex = myindex + 1
844	ENDDO
845
846	ELSEIF ( ar%nrdims == 3 ) THEN
847
848	buf_shape(1) = ape%nrele*ar%a_dim(1)
849	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
850	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
851
852	DO ij = 1, ape%nrele
853	buf(myindex:myindex+ar%a_dim(1)-1) = &
854	data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
855	myindex = myindex + ar%a_dim(1)
856	ENDDO
857
858	ENDIF
859
860	ENDDO
861
862	ENDDO
863	!
864	!-- TODO: Fence might do it, test later
865	!-- Call MPI_WIN_FENCE( 0, me%win_server_client, ierr) !
866	!
867	!-- Buffer is filled
868	!-- TODO: explain in more detail what is happening here
869	CALL MPI_Barrier(me%intra_comm, ierr)
870
871	END SUBROUTINE pmc_c_putbuffer
872
873	#endif
874	END MODULE pmc_client

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |