Home

Context Navigation

pmc_client_mod.f90 @ 1897

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

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

Context Navigation

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

Download in other formats: