Home

Context Navigation

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

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |