Home

Context Navigation

pmc_server_mod.f90 @ 1924

Last change on this file since 1924 was 1901, checked in by raasch, 9 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 30.2 KB

Rev	Line
[1900]	1	MODULE pmc_server
[1762]	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	!
[1818]	17	! Copyright 1997-2016 Leibniz Universitaet Hannover
[1762]	18	!--------------------------------------------------------------------------------!
	19	!
	20	! Current revisions:
	21	! ------------------
[1834]	22	!
[1901]	23	!
[1762]	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_server_mod.f90 1901 2016-05-04 15:39:38Z knoop $
	27	!
[1901]	28	! 1900 2016-05-04 15:27:53Z raasch
	29	! re-formatted to match PALM style
	30	!
[1851]	31	! 1850 2016-04-08 13:29:27Z maronga
	32	! Module renamed
	33	!
	34	!
[1834]	35	! 1833 2016-04-07 14:23:03Z raasch
	36	! gfortran requires pointer attributes for some array declarations,
	37	! long line wrapped
	38	!
[1809]	39	! 1808 2016-04-05 19:44:00Z raasch
	40	! MPI module used by default on all machines
	41	!
[1798]	42	! 1797 2016-03-21 16:50:28Z raasch
	43	! introduction of different datatransfer modes
	44	!
[1792]	45	! 1791 2016-03-11 10:41:25Z raasch
	46	! Debug write-statements commented out
	47	!
[1787]	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	!
[1780]	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	!
[1767]	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	!
[1765]	61	! 1764 2016-02-28 12:45:19Z raasch
	62	! cpp-statement added (nesting can only be used in parallel mode)
	63	!
[1763]	64	! 1762 2016-02-25 12:31:13Z hellstea
	65	! Initial revision by K. Ketelsen
[1762]	66	!
	67	! Description:
	68	! ------------
	69	!
	70	! Server part of Palm Model Coupler
	71	!------------------------------------------------------------------------------!
	72
[1764]	73	#if defined( __parallel )
[1900]	74	USE, INTRINSIC :: ISO_C_BINDING
[1762]	75
[1808]	76	#if defined( __mpifh )
	77	INCLUDE "mpif.h"
	78	#else
[1764]	79	USE MPI
	80	#endif
[1900]	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
[1762]	85
[1900]	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
[1762]	95	PRIVATE
	96	SAVE
	97
[1900]	98	TYPE clientindexdef
	99	INTEGER :: nrpoints !<
	100	INTEGER, DIMENSION(:,:), ALLOCATABLE :: index_list_2d !<
	101	END TYPE clientindexdef
[1762]	102
[1900]	103	TYPE(clientdef), DIMENSION(pmc_max_models) :: clients !<
	104	TYPE(clientindexdef), DIMENSION(pmc_max_models) :: indclients !<
[1762]	105
[1900]	106	INTEGER :: next_array_in_list = 0 !<
[1779]	107
[1762]	108
[1900]	109	PUBLIC pmc_server_for_client
[1762]	110
	111
[1900]	112	INTERFACE pmc_serverinit
	113	MODULE PROCEDURE pmc_serverinit
	114	END INTERFACE pmc_serverinit
[1779]	115
[1900]	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
[1762]	119
[1900]	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
[1762]	123
[1900]	124	INTERFACE pmc_s_getnextarray
	125	MODULE PROCEDURE pmc_s_getnextarray
	126	END INTERFACE pmc_s_getnextarray
[1762]	127
[1900]	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
[1762]	132
[1900]	133	INTERFACE pmc_s_setind_and_allocmem
	134	MODULE PROCEDURE pmc_s_setind_and_allocmem
	135	END INTERFACE pmc_s_setind_and_allocmem
[1762]	136
[1900]	137	INTERFACE pmc_s_fillbuffer
	138	MODULE PROCEDURE pmc_s_fillbuffer
	139	END INTERFACE pmc_s_fillbuffer
[1766]	140
[1900]	141	INTERFACE pmc_s_getdata_from_buffer
	142	MODULE PROCEDURE pmc_s_getdata_from_buffer
	143	END INTERFACE pmc_s_getdata_from_buffer
[1762]	144
[1900]	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
[1762]	148
[1900]	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
[1762]	153
[1900]	154	CONTAINS
[1762]	155
	156
[1900]	157	SUBROUTINE pmc_serverinit
[1762]	158
[1900]	159	IMPLICIT NONE
[1762]	160
[1900]	161	INTEGER :: clientid !<
	162	INTEGER :: i !<
	163	INTEGER :: j !<
	164	INTEGER :: istat !<
[1762]	165
	166
[1900]	167	DO i = 1, SIZE( pmc_server_for_client )-1
[1762]	168
[1900]	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)
[1779]	173	!
[1900]	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 )
[1762]	187
[1900]	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
[1762]	195
[1900]	196	CALL get_da_names_from_client (clientid)
[1762]	197
[1900]	198	ENDDO
[1762]	199
[1900]	200	END SUBROUTINE pmc_serverinit
[1762]	201
	202
	203
[1900]	204	SUBROUTINE pmc_s_set_2d_index_list( clientid, index_list )
[1762]	205
[1900]	206	IMPLICIT NONE
[1762]	207
[1900]	208	INTEGER, INTENT(IN) :: clientid !<
	209	INTEGER, DIMENSION(:,:), INTENT(INOUT) :: index_list !<
[1762]	210
[1900]	211	INTEGER :: ian !<
	212	INTEGER :: ic !<
	213	INTEGER :: ie !<
	214	INTEGER :: ip !<
	215	INTEGER :: is !<
	216	INTEGER :: istat !<
	217	INTEGER :: n !<
[1762]	218
	219
[1900]	220	IF ( m_model_rank == 0 ) THEN
	221	!
	222	!-- Sort to ascending server PE
	223	CALL pmc_sort( index_list, 6 )
[1762]	224
[1900]	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
[1762]	233
[1900]	234	DO WHILE ( index_list(6,ie+1 ) == ip )
	235	ie = ie + 1
	236	IF ( ie == SIZE( index_list,2 ) ) EXIT
	237	ENDDO
[1762]	238
[1900]	239	ian = ie - is + 1
[1762]	240
[1900]	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
[1762]	264
[1900]	265	ENDDO
[1762]	266
[1900]	267	ELSE
[1762]	268
[1900]	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
[1779]	272
[1900]	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
[1779]	279
[1900]	280	ENDIF
[1779]	281
[1900]	282	CALL set_pe_index_list( clientid, clients(clientid), &
	283	indclients(clientid)%index_list_2d, &
	284	indclients(clientid)%nrpoints )
[1762]	285
[1900]	286	END SUBROUTINE pmc_s_set_2d_index_list
[1779]	287
	288
	289
[1900]	290	SUBROUTINE pmc_s_clear_next_array_list
[1833]	291
[1900]	292	IMPLICIT NONE
[1762]	293
[1900]	294	next_array_in_list = 0
[1762]	295
[1900]	296	END SUBROUTINE pmc_s_clear_next_array_list
[1762]	297
	298
	299
[1900]	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 !<
[1779]	307
[1900]	308	TYPE(arraydef), POINTER :: ar
	309	TYPE(pedef), POINTER :: ape
[1779]	310
[1900]	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)
[1833]	315
[1900]	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
[1779]	322
[1900]	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.
[1762]	329
[1900]	330	END FUNCTION pmc_s_getnextarray
[1762]	331
	332
	333
[1900]	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
[1766]	394	!
[1900]	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
[1762]	404
[1900]	405	END SUBROUTINE pmc_s_set_dataarray_3d
[1762]	406
[1779]	407
	408
[1900]	409	SUBROUTINE pmc_s_setind_and_allocmem( clientid )
[1779]	410
[1900]	411	USE control_parameters, &
	412	ONLY: message_string
	413
	414	IMPLICIT NONE
	415
[1786]	416	!
[1900]	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 !<
[1762]	422
[1900]	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 !<
[1762]	431
[1900]	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
[1786]	444	!
[1900]	445	!-- Server to client direction
	446	myindex = 1
	447	rcount = 0
	448	bufsize = 8
[1762]	449
[1786]	450	!
[1900]	451	!-- First stride: compute size and set index
	452	DO i = 1, clients(clientid)%inter_npes
[1762]	453
[1900]	454	ape => clients(clientid)%pes(i)
	455	tag = 200
[1762]	456
[1900]	457	DO j = 1, ape%nr_arrays
[1762]	458
[1900]	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
[1762]	468
[1900]	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
[1762]	480
[1900]	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
[1786]	493	!
[1900]	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
[1762]	504
[1900]	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 )
[1786]	509	!
[1900]	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
[1786]	515
[1900]	516	ape => clients(clientid)%pes(i)
[1786]	517
[1900]	518	DO j = 1, ape%nr_arrays
[1786]	519
[1900]	520	ar => ape%array_list(j)
	521	ar%sendbuf = C_LOC( base_array_sc(ar%sendindex) )
[1786]	522
[1900]	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
[1786]	531
[1900]	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
[1786]	538
[1900]	539	ape => clients(clientid)%pes(i)
	540	tag = 300
[1786]	541
[1900]	542	DO j = 1, ape%nr_arrays
[1786]	543
[1900]	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 )
[1786]	550
[1900]	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
[1786]	557
[1900]	558	ENDDO
[1762]	559
[1900]	560	ENDDO
[1762]	561
[1900]	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
[1762]	568
[1900]	569	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
	570	!
	571	!-- Second stride: set buffer pointer
	572	DO i = 1, clients(clientid)%inter_npes
[1786]	573
[1900]	574	ape => clients(clientid)%pes(i)
[1762]	575
[1900]	576	DO j = 1, ape%nr_arrays
	577	ar => ape%array_list(j)
	578	ar%recvbuf = base_ptr
	579	ENDDO
[1762]	580
[1900]	581	ENDDO
[1762]	582
[1900]	583	END SUBROUTINE pmc_s_setind_and_allocmem
[1762]	584
	585
[1797]	586
[1900]	587	SUBROUTINE pmc_s_fillbuffer( clientid, waittime )
[1762]	588
[1900]	589	IMPLICIT NONE
[1762]	590
[1900]	591	INTEGER, INTENT(IN) :: clientid !<
[1762]	592
[1900]	593	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
[1779]	594
[1900]	595	INTEGER :: ierr !<
	596	INTEGER :: ij !<
	597	INTEGER :: ip !<
	598	INTEGER :: istat !<
	599	INTEGER :: j !<
	600	INTEGER :: myindex !<
[1762]	601
[1900]	602	INTEGER, DIMENSION(1) :: buf_shape
[1779]	603
[1900]	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 !<
[1762]	609
[1900]	610	TYPE(pedef), POINTER :: ape !<
	611	TYPE(arraydef), POINTER :: ar !<
[1762]	612
[1900]	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
[1786]	625
[1900]	626	DO ip = 1, clients(clientid)%inter_npes
[1786]	627
[1900]	628	ape => clients(clientid)%pes(ip)
[1786]	629
[1900]	630	DO j = 1, ape%nr_arrays
[1786]	631
[1900]	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
[1786]	661	!
[1900]	662	!-- Buffer is filled
	663	CALL MPI_BARRIER( clients(clientid)%intra_comm, ierr )
[1786]	664
[1900]	665	END SUBROUTINE pmc_s_fillbuffer
[1786]	666
[1762]	667
	668
[1900]	669	SUBROUTINE pmc_s_getdata_from_buffer( clientid, waittime )
[1762]	670
[1900]	671	IMPLICIT NONE
[1762]	672
[1900]	673	INTEGER, INTENT(IN) :: clientid !<
	674	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
[1762]	675
[1900]	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 !<
[1762]	685
[1900]	686	INTEGER, DIMENSION(1) :: buf_shape !<
[1762]	687
[1900]	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 !<
[1762]	693
[1900]	694	TYPE(pedef), POINTER :: ape !<
	695	TYPE(arraydef), POINTER :: ar !<
[1762]	696
	697
[1900]	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 )
[1762]	709
[1900]	710	DO ip = 1, clients(clientid)%inter_npes
[1762]	711
[1900]	712	ape => clients(clientid)%pes(ip)
[1762]	713
[1900]	714	DO j = 1, ape%nr_arrays
[1762]	715
[1900]	716	ar => ape%array_list(j)
[1762]	717
[1900]	718	IF ( ar%recvindex < 0 ) CYCLE
[1766]	719
[1900]	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
[1766]	725
[1900]	726	buf_shape(1) = nr
	727	CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
[1766]	728
[1900]	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
[1766]	743
[1900]	744	myindex = 1
	745	IF ( ar%nrdims == 2 ) THEN
[1766]	746
[1900]	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
[1766]	752
[1900]	753	ELSEIF ( ar%nrdims == 3 ) THEN
[1762]	754
[1900]	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
[1762]	761
[1900]	762	ENDIF
[1762]	763
[1900]	764	ENDDO
[1762]	765
[1900]	766	ENDDO
[1762]	767
[1900]	768	END SUBROUTINE pmc_s_getdata_from_buffer
[1762]	769
	770
	771
[1900]	772	SUBROUTINE get_da_names_from_client( clientid )
	773	!
	774	!-- Get data array description and name from client
	775	IMPLICIT NONE
[1762]	776
[1900]	777	INTEGER, INTENT(IN) :: clientid !<
[1762]	778
[1900]	779	TYPE(da_namedef) :: myname !<
[1762]	780
[1900]	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) )
[1762]	788
[1900]	789	CALL pmc_g_setname( clients(clientid), myname%couple_index, &
	790	myname%nameonserver )
	791	ENDDO
[1762]	792
[1900]	793	END SUBROUTINE get_da_names_from_client
[1762]	794
	795
	796
[1900]	797	SUBROUTINE pmc_s_setarray(clientid, nrdims, dims, array_adr, second_adr )
	798	!
	799	!-- Set array for client interPE 0
	800	IMPLICIT NONE
[1762]	801
[1900]	802	INTEGER, INTENT(IN) :: clientid !<
	803	INTEGER, INTENT(IN) :: nrdims !<
	804	INTEGER, INTENT(IN), DIMENSION(:) :: dims !<
[1762]	805
[1900]	806	TYPE(C_PTR), INTENT(IN) :: array_adr !<
	807	TYPE(C_PTR), INTENT(IN), OPTIONAL :: second_adr !<
[1762]	808
[1900]	809	INTEGER :: i !< local counter
[1762]	810
[1900]	811	TYPE(pedef), POINTER :: ape !<
	812	TYPE(arraydef), POINTER :: ar !<
[1762]	813
	814
[1900]	815	DO i = 1, clients(clientid)%inter_npes
[1762]	816
[1900]	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
[1764]	1001	#endif
[1900]	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 @ 1924

Download in other formats: