Home

Context Navigation

pmc_child_mod.f90 @ 4883

Last change on this file since 4883 was 4828, checked in by Giersch, 4 years ago
Copyright updated to year 2021, interface pmc_sort removed to accelarate the nesting code
Property svn:keywords set to `Id`
File size: 31.8 KB

Rev	Line
[4246]	1	MODULE pmc_child
	2
[4649]	3	!--------------------------------------------------------------------------------------------------!
[4246]	4	! This file is part of the PALM model system.
	5	!
[4649]	6	! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
	7	! Public License as published by the Free Software Foundation, either version 3 of the License, or
	8	! (at your option) any later version.
[4246]	9	!
[4649]	10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
	11	! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
	12	! Public License for more details.
[4246]	13	!
[4649]	14	! You should have received a copy of the GNU General Public License along with PALM. If not, see
	15	! <http://www.gnu.org/licenses/>.
[4246]	16	!
[4828]	17	! Copyright 1997-2021 Leibniz Universitaet Hannover
[4649]	18	!--------------------------------------------------------------------------------------------------!
[4246]	19	!
[4649]	20	!
[4246]	21	! Current revisions:
[4649]	22	! -----------------
[4629]	23	!
	24	!
[4246]	25	! Former revisions:
	26	! -----------------
	27	! $Id: pmc_child_mod.f90 4828 2021-01-05 11:21:41Z hellstea $
[4649]	28	! File re-formatted to follow the PALM coding standard
	29	!
	30	!
	31	! 4629 2020-07-29 09:37:56Z raasch
	32	! Support for MPI Fortran77 interface (mpif.h) removed
	33	!
[4629]	34	! 4360 2020-01-07 11:25:50Z suehring
[4649]	35	!
	36	!
[4245]	37	! 4182 2019-08-22 15:20:23Z scharf
[4246]	38	! Corrected "Former revisions" section
[4649]	39	!
[4246]	40	! 3964 2019-05-09 09:48:32Z suehring
	41	! Remove unused variable
[4649]	42	!
[4246]	43	! 3963 2019-05-08 20:09:11Z suehring
[4649]	44	! Bugfixes in initial settings of child and parent communication patterns.
[4246]	45	!
	46	! 3945 2019-05-02 11:29:27Z raasch
	47	!
	48	! 3932 2019-04-24 17:31:34Z suehring
[4649]	49	! Typo removed
[4246]	50	!
	51	! 2019-02-25 15:31:42Z raasch
[4649]	52	! Statement added to avoid compiler warning
	53	!
[4246]	54	! 3655 2019-01-07 16:51:22Z knoop
[4649]	55	! Explicit kind settings
[4246]	56	!
	57	! 1762 2016-02-25 12:31:13Z hellstea
	58	! Initial revision by K. Ketelsen
	59	!
[4649]	60	!--------------------------------------------------------------------------------------------------!
[4246]	61	! Description:
	62	! ------------
	63	!> Child part of Palm Model Coupler
[4649]	64	!--------------------------------------------------------------------------------------------------!
[4246]	65
	66	#if defined( __parallel )
	67
	68	USE, INTRINSIC :: iso_c_binding
	69
	70	USE MPI
	71
	72	USE kinds
	73
[4649]	74	USE pmc_general, &
	75	ONLY: arraydef, &
	76	childdef, &
	77	da_desclen, &
	78	da_namedef, &
	79	da_namelen, &
	80	pedef, &
	81	pmc_da_name_err, &
	82	pmc_g_setname, &
	83	pmc_max_array, &
	84	pmc_status_ok
[4246]	85
[4649]	86	USE pmc_handle_communicator, &
	87	ONLY: m_model_comm, &
	88	m_model_npes, &
	89	m_model_rank, &
	90	m_to_parent_comm
[4246]	91
[4649]	92	USE pmc_mpi_wrapper, &
	93	ONLY: pmc_alloc_mem, &
	94	pmc_bcast, &
	95	pmc_inter_bcast, &
	96	pmc_time
[4246]	97
	98	IMPLICIT NONE
	99
	100
	101	PRIVATE
	102	SAVE
	103
[4649]	104	INTEGER(iwp) :: myindex = 0 !< counter and unique number for data arrays
	105	INTEGER(iwp) :: next_array_in_list = 0 !<
[4246]	106
[4649]	107	TYPE(childdef), PUBLIC :: me !<
[4246]	108
	109
	110	INTERFACE pmc_childinit
	111	MODULE PROCEDURE pmc_childinit
	112	END INTERFACE pmc_childinit
	113
	114	INTERFACE pmc_c_clear_next_array_list
	115	MODULE PROCEDURE pmc_c_clear_next_array_list
	116	END INTERFACE pmc_c_clear_next_array_list
	117
	118	INTERFACE pmc_c_getbuffer
	119	MODULE PROCEDURE pmc_c_getbuffer
	120	END INTERFACE pmc_c_getbuffer
	121
	122	INTERFACE pmc_c_getnextarray
	123	MODULE PROCEDURE pmc_c_getnextarray
	124	END INTERFACE pmc_c_getnextarray
	125
	126	INTERFACE pmc_c_get_2d_index_list
	127	MODULE PROCEDURE pmc_c_get_2d_index_list
	128	END INTERFACE pmc_c_get_2d_index_list
	129
	130	INTERFACE pmc_c_putbuffer
	131	MODULE PROCEDURE pmc_c_putbuffer
	132	END INTERFACE pmc_c_putbuffer
	133
	134	INTERFACE pmc_c_setind_and_allocmem
	135	MODULE PROCEDURE pmc_c_setind_and_allocmem
	136	END INTERFACE pmc_c_setind_and_allocmem
	137
	138	INTERFACE pmc_c_set_dataarray
	139	MODULE PROCEDURE pmc_c_set_dataarray_2d
	140	MODULE PROCEDURE pmc_c_set_dataarray_3d
	141	MODULE PROCEDURE pmc_c_set_dataarray_ip2d
	142	END INTERFACE pmc_c_set_dataarray
	143
	144	INTERFACE pmc_set_dataarray_name
	145	MODULE PROCEDURE pmc_set_dataarray_name
	146	MODULE PROCEDURE pmc_set_dataarray_name_lastentry
	147	END INTERFACE pmc_set_dataarray_name
	148
	149
[4649]	150	PUBLIC pmc_childinit, &
	151	pmc_c_clear_next_array_list, &
	152	pmc_c_getbuffer, &
	153	pmc_c_getnextarray, &
	154	pmc_c_putbuffer, &
	155	pmc_c_setind_and_allocmem, &
	156	pmc_c_set_dataarray, &
	157	pmc_set_dataarray_name, &
	158	pmc_c_get_2d_index_list
[4246]	159
	160	CONTAINS
	161
	162
[4649]	163	!--------------------------------------------------------------------------------------------------!
	164	! Description:
	165	! ------------
	166	!> @Todo: Missing subroutine description.
	167	!--------------------------------------------------------------------------------------------------!
[4246]	168	SUBROUTINE pmc_childinit
	169
[4649]	170	IMPLICIT NONE
[4246]	171
[4649]	172	INTEGER(iwp) :: i !<
	173	INTEGER(iwp) :: istat !<
[4246]	174
	175	!
[4649]	176	!-- Get / define the MPI environment.
	177	me%model_comm = m_model_comm
	178	me%inter_comm = m_to_parent_comm
[4246]	179
[4649]	180	CALL MPI_COMM_RANK( me%model_comm, me%model_rank, istat )
	181	CALL MPI_COMM_SIZE( me%model_comm, me%model_npes, istat )
	182	CALL MPI_COMM_REMOTE_SIZE( me%inter_comm, me%inter_npes, istat )
[4246]	183	!
[4649]	184	!-- Intra-communicator is used for MPI_GET.
	185	CALL MPI_INTERCOMM_MERGE( me%inter_comm, .TRUE., me%intra_comm, istat )
	186	CALL MPI_COMM_RANK( me%intra_comm, me%intra_rank, istat )
[4246]	187
[4649]	188	ALLOCATE( me%pes(me%inter_npes) )
[4246]	189	!
[4649]	190	!-- Allocate an array of type arraydef for all parent processes to store information of then
	191	!-- transfer array.
	192	DO i = 1, me%inter_npes
	193	ALLOCATE( me%pes(i)%array_list(pmc_max_array) )
	194	ENDDO
[4246]	195
	196	END SUBROUTINE pmc_childinit
	197
	198
[4649]	199	!--------------------------------------------------------------------------------------------------!
	200	! Description:
	201	! ------------
	202	!> @Todo: Missing subroutine description.
	203	!--------------------------------------------------------------------------------------------------!
	204	SUBROUTINE pmc_set_dataarray_name( parentarraydesc, parentarrayname, childarraydesc, &
	205	childarrayname, istat )
[4246]	206
	207	IMPLICIT NONE
	208
[4649]	209	CHARACTER(LEN=*), INTENT(IN) :: childarraydesc !<
	210	CHARACTER(LEN=*), INTENT(IN) :: childarrayname !<
	211	CHARACTER(LEN=*), INTENT(IN) :: parentarraydesc !<
[4246]	212	CHARACTER(LEN=*), INTENT(IN) :: parentarrayname !<
	213
	214	INTEGER(iwp), INTENT(OUT) :: istat !<
	215	!
	216	!-- Local variables
[4649]	217	INTEGER(iwp) :: mype !<
	218
[4246]	219	TYPE(da_namedef) :: myname !<
	220
	221
	222	istat = pmc_status_ok
	223	!
[4649]	224	!-- Check length of array names.
	225	IF ( LEN( TRIM( parentarrayname) ) > da_namelen .OR. &
	226	LEN( TRIM( childarrayname ) ) > da_namelen ) THEN
[4246]	227	istat = pmc_da_name_err
	228	ENDIF
	229
	230	IF ( m_model_rank == 0 ) THEN
	231	myindex = myindex + 1
	232	myname%couple_index = myindex
	233	myname%parentdesc = TRIM( parentarraydesc )
	234	myname%nameonparent = TRIM( parentarrayname )
	235	myname%childdesc = TRIM( childarraydesc )
	236	myname%nameonchild = TRIM( childarrayname )
	237	ENDIF
	238
	239	!
[4649]	240	!-- Broadcast to all child processes.
	241	!-- The complete description of a transfer array is broadcasted.
[4246]	242	CALL pmc_bcast( myname%couple_index, 0, comm=m_model_comm )
	243	CALL pmc_bcast( myname%parentdesc, 0, comm=m_model_comm )
	244	CALL pmc_bcast( myname%nameonparent, 0, comm=m_model_comm )
	245	CALL pmc_bcast( myname%childdesc, 0, comm=m_model_comm )
	246	CALL pmc_bcast( myname%nameonchild, 0, comm=m_model_comm )
[4649]	247
[4246]	248	!
[4649]	249	!-- Broadcast to all parent processes.
	250	!-- The complete description of an transfer array names is broadcasted also to all parent processes.
	251	!-- Only the root PE of the broadcasts to parent is using intra communicator.
[4246]	252	IF ( m_model_rank == 0 ) THEN
	253	mype = MPI_ROOT
	254	ELSE
	255	mype = MPI_PROC_NULL
	256	ENDIF
	257
	258	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
	259	CALL pmc_bcast( myname%parentdesc, mype, comm=m_to_parent_comm )
	260	CALL pmc_bcast( myname%nameonparent, mype, comm=m_to_parent_comm )
	261	CALL pmc_bcast( myname%childdesc, mype, comm=m_to_parent_comm )
	262	CALL pmc_bcast( myname%nameonchild, mype, comm=m_to_parent_comm )
	263
	264	CALL pmc_g_setname( me, myname%couple_index, myname%nameonchild )
	265
	266	END SUBROUTINE pmc_set_dataarray_name
	267
	268
[4649]	269	!--------------------------------------------------------------------------------------------------!
	270	! Description:
	271	! ------------
	272	!> @Todo: Missing subroutine description.
	273	!--------------------------------------------------------------------------------------------------!
[4246]	274	SUBROUTINE pmc_set_dataarray_name_lastentry( lastentry )
	275
	276	IMPLICIT NONE
	277
	278	LOGICAL, INTENT(IN), OPTIONAL :: lastentry !<
	279	!
	280	!-- Local variables
	281	INTEGER :: idum !<
	282	INTEGER :: mype !<
[4649]	283
[4246]	284	TYPE(dA_namedef) :: myname !<
	285
	286	myname%couple_index = -1
	287
	288	IF ( m_model_rank == 0 ) THEN
	289	mype = MPI_ROOT
	290	ELSE
	291	mype = MPI_PROC_NULL
	292	ENDIF
	293
	294	CALL pmc_bcast( myname%couple_index, mype, comm=m_to_parent_comm )
	295
	296	!
	297	!-- Next statement is just to avoid compiler warnings about unused variables
	298	IF ( PRESENT( lastentry ) ) idum = 1
	299
	300	END SUBROUTINE pmc_set_dataarray_name_lastentry
	301
	302
[4649]	303	!--------------------------------------------------------------------------------------------------!
	304	! Description:
	305	! ------------
	306	!> @Todo: Missing subroutine description.
	307	!--------------------------------------------------------------------------------------------------!
[4246]	308	SUBROUTINE pmc_c_get_2d_index_list
	309
	310	IMPLICIT NONE
	311
[4649]	312	INTEGER(iwp) :: dummy !<
	313	INTEGER(iwp) :: i, ierr, i2, j, nr !<
	314	INTEGER(iwp) :: indwin !< MPI window object
	315	INTEGER(iwp) :: indwin2 !< MPI window object
[4246]	316
[4649]	317	INTEGER(KIND=MPI_ADDRESS_KIND) :: disp !< Displacement unit (Integer = 4, floating poit = 8
	318	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !< Size of MPI window 2 (in bytes)
	319	INTEGER(KIND=MPI_ADDRESS_KIND) :: win_size !< Size of MPI window 1 (in bytes)
[4246]	320
[4649]	321	INTEGER, DIMENSION(me%inter_npes*2) :: nrele !< Number of Elements of a horizontal slice
	322
[4246]	323	INTEGER, DIMENSION(:), POINTER :: myind !<
	324
	325	TYPE(pedef), POINTER :: ape !> Pointer to pedef structure
	326
	327
[4649]	328	win_size = STORAGE_SIZE( dummy ) / 8
	329	CALL MPI_WIN_CREATE( dummy, win_size, iwp, MPI_INFO_NULL, me%intra_comm, indwin, ierr )
[4246]	330	!
	331	!-- Close window on child side and open on parent side
	332	CALL MPI_WIN_FENCE( 0, indwin, ierr )
[4649]	333	!
	334	!-- Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window.
	335	!-- Close window on parent side and open on child side.
[4246]	336
	337	CALL MPI_WIN_FENCE( 0, indwin, ierr )
	338
	339	DO i = 1, me%inter_npes
	340	disp = me%model_rank * 2
[4649]	341	CALL MPI_GET( nrele((i-1)*2+1), 2, MPI_INTEGER, i-1, disp, 2, MPI_INTEGER, indwin, ierr )
[4246]	342	ENDDO
	343	!
[4649]	344	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is called.
[4246]	345	CALL MPI_WIN_FENCE( 0, indwin, ierr )
	346	!
	347	!-- Allocate memory for index array
	348	winsize = 0
	349	DO i = 1, me%inter_npes
	350	ape => me%pes(i)
	351	i2 = ( i-1 ) * 2 + 1
	352	nr = nrele(i2+1)
	353	IF ( nr > 0 ) THEN
	354	ALLOCATE( ape%locind(nr) )
	355	ELSE
	356	NULLIFY( ape%locind )
	357	ENDIF
	358	winsize = MAX( INT( nr, MPI_ADDRESS_KIND ), winsize )
	359	ENDDO
	360
	361	ALLOCATE( myind(2*winsize) )
	362	winsize = 1
	363	!
	364	!-- Local buffer used in MPI_GET can but must not be inside the MPI Window.
[4649]	365	!-- Here, we use a dummy for the MPI window because the parent processes do not access the RMA
	366	!-- window via MPI_GET or MPI_PUT.
	367	CALL MPI_WIN_CREATE( dummy, winsize, iwp, MPI_INFO_NULL, me%intra_comm, indwin2, ierr )
[4246]	368	!
[4649]	369	!-- MPI_GET is non-blocking -> data in nrele is not available until MPI_FENCE is called.
[4246]	370
	371	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
[4649]	372	!
	373	!-- Between the two MPI_WIN_FENCE calls, the parent can fill the RMA window
[4246]	374
	375	CALL MPI_WIN_FENCE( 0, indwin2, ierr )
	376
	377	DO i = 1, me%inter_npes
	378	ape => me%pes(i)
	379	nr = nrele(i*2)
	380	IF ( nr > 0 ) THEN
	381	disp = nrele(2*(i-1)+1)
	382	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , i-1, 0, indwin2, ierr )
[4649]	383	CALL MPI_GET( myind, 2nr, MPI_INTEGER, i-1, disp, 2nr, MPI_INTEGER, indwin2, ierr )
[4246]	384	CALL MPI_WIN_UNLOCK( i-1, indwin2, ierr )
	385	DO j = 1, nr
	386	ape%locind(j)%i = myind(2*j-1)
	387	ape%locind(j)%j = myind(2*j)
	388	ENDDO
	389	ape%nrele = nr
	390	ELSE
	391	ape%nrele = -1
	392	ENDIF
	393	ENDDO
	394	!
[4649]	395	!-- Don't know why, but this barrier is necessary before we can free the windows.
[4246]	396	CALL MPI_BARRIER( me%intra_comm, ierr )
	397
	398	CALL MPI_WIN_FREE( indWin, ierr )
	399	CALL MPI_WIN_FREE( indwin2, ierr )
	400	DEALLOCATE( myind )
	401
	402	END SUBROUTINE pmc_c_get_2d_index_list
	403
	404
	405
	406	SUBROUTINE pmc_c_clear_next_array_list
	407
	408	IMPLICIT NONE
	409
	410	next_array_in_list = 0
	411
	412	END SUBROUTINE pmc_c_clear_next_array_list
	413
	414
	415
	416	LOGICAL FUNCTION pmc_c_getnextarray( myname )
	417
	418	!
[4649]	419	!-- List handling is still required to get minimal interaction with pmc_interface.
[4246]	420	CHARACTER(LEN=*), INTENT(OUT) :: myname !<
	421	!
	422	!-- Local variables
[4649]	423	TYPE(pedef), POINTER :: ape !<
	424	TYPE(arraydef), POINTER :: ar !<
[4246]	425
	426
	427	next_array_in_list = next_array_in_list + 1
	428	!
[4649]	429	!-- Array names are the same on all child PEs, so take first process to get the name.
[4246]	430	ape => me%pes(1)
	431	!
[4649]	432	!-- Check if all arrays have been processed.
[4246]	433	IF ( next_array_in_list > ape%nr_arrays ) THEN
	434	pmc_c_getnextarray = .FALSE.
	435	RETURN
	436	ENDIF
	437
	438	ar => ape%array_list( next_array_in_list )
	439
	440	myname = ar%name
	441	!
[4649]	442	!-- Return TRUE if annother array.
	443	!-- If all array have been processed, the RETURN statement a couple of lines above is active.
[4246]	444
	445	pmc_c_getnextarray = .TRUE.
	446
	447	END FUNCTION pmc_c_getnextarray
	448
	449
[4649]	450	!--------------------------------------------------------------------------------------------------!
	451	! Description:
	452	! ------------
	453	!> @Todo: Missing subroutine description.
	454	!--------------------------------------------------------------------------------------------------!
[4246]	455	SUBROUTINE pmc_c_set_dataarray_2d( array )
	456
	457	IMPLICIT NONE
	458
[4649]	459	INTEGER(iwp) :: i !<
	460	INTEGER(iwp) :: nrdims !<
	461
	462	INTEGER(iwp), DIMENSION(4) :: dims !<
	463
[4246]	464	REAL(wp), INTENT(IN) , DIMENSION(:,:), POINTER :: array !<
	465
[4649]	466	TYPE(C_PTR) :: array_adr !<
	467	TYPE(arraydef), POINTER :: ar !<
	468	TYPE(pedef), POINTER :: ape !<
[4246]	469
	470
	471	dims = 1
	472	nrdims = 2
	473	dims(1) = SIZE( array, 1 )
	474	dims(2) = SIZE( array, 2 )
	475
	476	array_adr = C_LOC( array )
	477
	478	DO i = 1, me%inter_npes
	479	ape => me%pes(i)
	480	ar => ape%array_list(next_array_in_list)
	481	ar%nrdims = nrdims
	482	ar%dimkey = nrdims
	483	ar%a_dim = dims
	484	ar%data = array_adr
	485	ENDDO
	486
	487	END SUBROUTINE pmc_c_set_dataarray_2d
	488
[4649]	489
	490	!--------------------------------------------------------------------------------------------------!
	491	! Description:
	492	! ------------
	493	!> @Todo: Missing subroutine description.
	494	!--------------------------------------------------------------------------------------------------!
[4246]	495	SUBROUTINE pmc_c_set_dataarray_ip2d( array )
	496
	497	IMPLICIT NONE
	498
	499	INTEGER(idp), INTENT(IN) , DIMENSION(:,:), POINTER :: array !<
	500
[4649]	501	INTEGER(iwp) :: i !<
	502	INTEGER(iwp) :: nrdims !<
[4246]	503
[4649]	504	INTEGER(iwp), DIMENSION(4) :: dims !<
[4246]	505
[4649]	506	TYPE(C_PTR) :: array_adr !<
	507	TYPE(arraydef), POINTER :: ar !<
	508	TYPE(pedef), POINTER :: ape !<
	509
[4246]	510	dims = 1
	511	nrdims = 2
	512	dims(1) = SIZE( array, 1 )
	513	dims(2) = SIZE( array, 2 )
	514
	515	array_adr = C_LOC( array )
	516
	517	DO i = 1, me%inter_npes
	518	ape => me%pes(i)
	519	ar => ape%array_list(next_array_in_list)
	520	ar%nrdims = nrdims
	521	ar%dimkey = 22
	522	ar%a_dim = dims
	523	ar%data = array_adr
	524	ENDDO
	525
	526	END SUBROUTINE pmc_c_set_dataarray_ip2d
	527
[4649]	528
	529	!--------------------------------------------------------------------------------------------------!
	530	! Description:
	531	! ------------
	532	!> @Todo: Missing subroutine description.
	533	!--------------------------------------------------------------------------------------------------!
[4246]	534	SUBROUTINE pmc_c_set_dataarray_3d (array)
	535
	536	IMPLICIT NONE
	537
[4649]	538	INTEGER(iwp) :: i !<
	539	INTEGER(iwp) :: nrdims !<
	540
	541	INTEGER(iwp), DIMENSION (4) :: dims !<
	542
[4246]	543	REAL(wp), INTENT(IN), DIMENSION(:,:,:), POINTER :: array !<
	544
[4649]	545	TYPE(C_PTR) :: array_adr !<
	546	TYPE(pedef), POINTER :: ape !<
	547	TYPE(arraydef), POINTER :: ar !<
[4246]	548
	549
	550	dims = 1
	551	nrdims = 3
	552	dims(1) = SIZE( array, 1 )
	553	dims(2) = SIZE( array, 2 )
	554	dims(3) = SIZE( array, 3 )
	555
	556	array_adr = C_LOC( array )
	557
	558	DO i = 1, me%inter_npes
	559	ape => me%pes(i)
	560	ar => ape%array_list(next_array_in_list)
	561	ar%nrdims = nrdims
	562	ar%dimkey = nrdims
	563	ar%a_dim = dims
	564	ar%data = array_adr
	565	ENDDO
	566
	567	END SUBROUTINE pmc_c_set_dataarray_3d
	568
	569
	570
[4649]	571	!--------------------------------------------------------------------------------------------------!
	572	! Description:
	573	! ------------
	574	!> @Todo: Missing subroutine description.
	575	!--------------------------------------------------------------------------------------------------!
[4246]	576	SUBROUTINE pmc_c_setind_and_allocmem
	577
	578	IMPLICIT NONE
	579
	580	!
	581	!-- Naming convention for appendices: _pc -> parent to child transfer
	582	!-- _cp -> child to parent transfer
	583	!-- recv -> parent to child transfer
	584	!-- send -> child to parent transfer
[4649]	585
	586	INTEGER(iwp), PARAMETER :: noindex = -1 !<
	587
[4246]	588	INTEGER(iwp) :: arlen !<
	589	INTEGER(iwp) :: i !<
	590	INTEGER(iwp) :: ierr !<
	591	INTEGER(iwp) :: istat !<
	592	INTEGER(iwp) :: j !<
	593	INTEGER(iwp) :: lo_nr_arrays !<
[4649]	594	INTEGER(iwp) :: myindex !<
[4246]	595	INTEGER(iwp) :: rcount !<
	596	INTEGER(iwp) :: tag !<
	597	INTEGER(iwp) :: total_npes !<
	598
[4649]	599	INTEGER(idp) :: bufsize !< size of MPI data window
[4246]	600
	601	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	602
[4649]	603	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: myindex_s !<
	604	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: myindex_r !<
	605
	606	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_cp !< base array
[4246]	607	REAL(wp), DIMENSION(:), POINTER, SAVE :: base_array_pc !< base array
	608
	609	TYPE(pedef), POINTER :: ape !<
	610	TYPE(arraydef), POINTER :: ar !<
[4649]	611
[4246]	612	Type(C_PTR) :: base_ptr !<
	613
[4649]	614
[4246]	615	CALL MPI_COMM_SIZE (me%intra_comm, total_npes, ierr)
	616
	617	lo_nr_arrays = me%pes(1)%nr_arrays
	618
[4649]	619	ALLOCATE( myindex_s(lo_nr_arrays,0:total_npes-1) )
	620	ALLOCATE( myindex_r(lo_nr_arrays,0:total_npes-1) )
[4246]	621
	622	myindex_s = 0
	623
	624	!
[4649]	625	!-- Receive indices from child.
	626	CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, myindex_r, lo_nr_arrays, MPI_INTEGER, &
[4246]	627	me%intra_comm, ierr )
	628
	629	myindex = 0
	630	bufsize = 8
	631	!
	632	!-- Parent to child direction.
[4649]	633	!-- First stride: compute size and set index.
[4246]	634	DO i = 1, me%inter_npes
	635	ape => me%pes(i)
	636	DO j = 1, ape%nr_arrays
	637	ar => ape%array_list(j)
	638	ar%recvindex = myindex_r(j,i-1)
	639	!
[4649]	640	!-- Determine max, because child buffer is allocated only once.
	641	!-- All 2D and 3d arrays use the same buffer.
[4246]	642
	643	IF ( ar%nrdims == 3 ) THEN
[4649]	644	bufsize = MAX( bufsize, INT( ar%a_dim(1)ar%a_dim(2)ar%a_dim(3), MPI_ADDRESS_KIND ) )
[4246]	645	ELSE
[4649]	646	bufsize = MAX( bufsize, INT( ar%a_dim(1)*ar%a_dim(2), MPI_ADDRESS_KIND ) )
[4246]	647	ENDIF
	648	ENDDO
	649	ENDDO
	650
	651	!
	652	!-- Create RMA (one sided communication) data buffer.
[4649]	653	!-- The buffer for MPI_GET can be PE local, i.e. it can but must not be part of the MPI RMA window.
[4246]	654	CALL pmc_alloc_mem( base_array_pc, bufsize, base_ptr )
[4649]	655	me%totalbuffersize = bufsize*wp ! Total buffer size in byte
[4246]	656	!
[4649]	657	!-- Second stride: set buffer pointer.
[4246]	658	DO i = 1, me%inter_npes
	659	ape => me%pes(i)
	660	DO j = 1, ape%nr_arrays
	661	ar => ape%array_list(j)
	662	ar%recvbuf = base_ptr
	663	ENDDO
	664	ENDDO
	665	!
[4649]	666	!-- Child to parent direction.
[4246]	667	myindex = 1
	668	rcount = 0
	669	bufsize = 8
	670
	671	myindex_s = 0
	672	myindex_r = 0
	673
	674	DO i = 1, me%inter_npes
	675	ape => me%pes(i)
	676	tag = 300
	677	DO j = 1, ape%nr_arrays
	678	ar => ape%array_list(j)
	679	IF ( ar%nrdims == 2 ) THEN
	680	arlen = ape%nrele
	681	ELSEIF( ar%nrdims == 3 ) THEN
	682	arlen = ape%nrele*ar%a_dim(1)
	683	ENDIF
	684
	685	IF ( ape%nrele > 0 ) THEN
	686	ar%sendindex = myindex
	687	ELSE
	688	ar%sendindex = noindex
	689	ENDIF
	690
	691	myindex_s(j,i-1) = ar%sendindex
	692
	693	IF ( ape%nrele > 0 ) THEN
	694	ar%sendsize = arlen
	695	myindex = myindex + arlen
	696	bufsize = bufsize + arlen
	697	ENDIF
	698
	699	ENDDO
	700
	701	ENDDO
	702	!
[4649]	703	!-- Send indices to parent.
[4246]	704
[4649]	705	CALL MPI_ALLTOALL( myindex_s, lo_nr_arrays, MPI_INTEGER, myindex_r, lo_nr_arrays, MPI_INTEGER, &
[4246]	706	me%intra_comm, ierr)
	707
	708	DEALLOCATE( myindex_s )
	709	DEALLOCATE( myindex_r )
	710
	711	!
[4649]	712	!-- Create RMA (one sided communication) window for data buffer child to parent transfer.
	713	!-- The buffer of MPI_GET (counter part of transfer) can be PE-local, i.e. it can but must not be
	714	!-- part of the MPI RMA window. Only one RMA window is required to prepare the data:
[4246]	715	!-- for parent -> child transfer on the parent side
	716	!-- and
	717	!-- for child -> parent transfer on the child side
	718	CALL pmc_alloc_mem( base_array_cp, bufsize )
[4649]	719	me%totalbuffersize = bufsize * wp ! Total buffer size in byte
[4246]	720
	721	winSize = me%totalbuffersize
	722
[4649]	723	CALL MPI_WIN_CREATE( base_array_cp, winsize, wp, MPI_INFO_NULL, me%intra_comm, &
	724	me%win_parent_child, ierr )
[4246]	725	CALL MPI_WIN_FENCE( 0, me%win_parent_child, ierr )
	726	CALL MPI_BARRIER( me%intra_comm, ierr )
	727	!
[4649]	728	!-- Second stride: set buffer pointer.
[4246]	729	DO i = 1, me%inter_npes
	730	ape => me%pes(i)
	731	DO j = 1, ape%nr_arrays
[4649]	732	ar => ape%array_list(j)
[4246]	733	IF ( ape%nrele > 0 ) THEN
	734	ar%sendbuf = C_LOC( base_array_cp(ar%sendindex) )
	735	!
[4649]	736	!-- TODO: If this is an error to be really expected, replace the following message by a
	737	!-- meaningful standard PALM message using the message-routine.
[4246]	738	IF ( ar%sendindex+ar%sendsize > bufsize ) THEN
[4649]	739	WRITE( 0,'(a,i4,4i7,1x,a)') 'Child buffer too small ', i, ar%sendindex, &
	740	ar%sendsize, ar%sendindex+ar%sendsize, bufsize, TRIM( ar%name )
[4246]	741	CALL MPI_ABORT( MPI_COMM_WORLD, istat, ierr )
	742	ENDIF
	743	ENDIF
	744	ENDDO
	745	ENDDO
	746
	747	END SUBROUTINE pmc_c_setind_and_allocmem
	748
	749
[4649]	750	!--------------------------------------------------------------------------------------------------!
	751	! Description:
	752	! ------------
	753	!> @Todo: Missing subroutine description.
	754	!--------------------------------------------------------------------------------------------------!
[4246]	755	SUBROUTINE pmc_c_getbuffer( waittime, particle_transfer )
	756
	757	IMPLICIT NONE
	758
[4649]	759	INTEGER(iwp) :: ierr !<
	760	INTEGER(iwp) :: ij !<
	761	INTEGER(iwp) :: ip !<
	762	INTEGER(iwp) :: j !<
	763	INTEGER(iwp) :: myindex !<
	764	INTEGER(iwp) :: nr !< number of elements to get from parent
	765
	766	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_disp !<
	767	INTEGER,DIMENSION(1) :: buf_shape !<
	768
	769	INTEGER(idp), POINTER, DIMENSION(:) :: ibuf !<
	770	INTEGER(idp), POINTER, DIMENSION(:,:) :: idata_2d !<
	771
	772	LOGICAL :: lo_ptrans !<
	773
	774	LOGICAL, INTENT(IN), OPTIONAL :: particle_transfer !<
	775
	776	REAL(wp) :: t1 !<
	777	REAL(wp) :: t2 !<
	778
	779	REAL(wp), POINTER, DIMENSION(:) :: buf !<
	780	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
	781	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
	782
[4246]	783	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
	784
[4649]	785	TYPE(pedef), POINTER :: ape !<
	786	TYPE(arraydef), POINTER :: ar !<
[4246]	787
	788
	789
	790	!
[4649]	791	!-- Synchronization of the model is done in pmci_synchronize. Therefore the RMA window can be filled
	792	!-- without sychronization at this point and a barrier is not necessary.
[4246]	793
[4649]	794	!-- In case waittime is present, the following barrier is necessary to insure the same number of
	795	!-- barrier calls on parent and child. This means, that here on child side two barriers are called
	796	!-- successively. The parent is filling its buffer between the two barrier calls.
[4246]	797
[4649]	798	!-- Please note that waittime has to be set in pmc_s_fillbuffer AND pmc_c_getbuffer.
[4246]	799	IF ( PRESENT( waittime ) ) THEN
	800	t1 = pmc_time()
	801	CALL MPI_BARRIER( me%intra_comm, ierr )
	802	t2 = pmc_time()
	803	waittime = t2 - t1
	804	ENDIF
	805
	806	lo_ptrans = .FALSE.
[4649]	807	IF ( PRESENT( particle_transfer) ) lo_ptrans = particle_transfer
[4246]	808
	809	!
[4649]	810	!-- Wait for buffer to be filled.
[4246]	811	!
[4649]	812	!-- The parent side (in pmc_s_fillbuffer) is filling the buffer in the MPI RMA window. When the
	813	!-- filling is complet, a MPI_BARRIER is called. The child is not allowd to access the parent-buffer
	814	!-- before it is completely filled. Therefore the following barrier is required.
[4246]	815
	816	CALL MPI_BARRIER( me%intra_comm, ierr )
	817
	818	DO ip = 1, me%inter_npes
	819	ape => me%pes(ip)
	820	DO j = 1, ape%nr_arrays
	821	ar => ape%array_list(j)
	822
[4649]	823	IF ( ar%dimkey == 2 .AND. .NOT. lo_ptrans) THEN
[4246]	824	nr = ape%nrele
[4649]	825	ELSEIF ( ar%dimkey == 3 .AND. .NOT. lo_ptrans) THEN
[4246]	826	nr = ape%nrele * ar%a_dim(1)
	827	ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans) THEN
	828	nr = ape%nrele
	829	ELSE
[4649]	830	CYCLE ! Particle arrays are not transferd here
[4246]	831	ENDIF
	832	buf_shape(1) = nr
[4649]	833	IF ( lo_ptrans ) THEN
[4246]	834	CALL C_F_POINTER( ar%recvbuf, ibuf, buf_shape )
	835	ELSE
	836	CALL C_F_POINTER( ar%recvbuf, buf, buf_shape )
	837	ENDIF
	838	!
	839	!-- MPI passive target RMA
[4649]	840	!-- One data array is fetchted from MPI RMA window on parent
[4246]	841
	842	IF ( nr > 0 ) THEN
	843	target_disp = ar%recvindex - 1
[4649]	844	CALL MPI_WIN_LOCK( MPI_LOCK_SHARED , ip-1, 0, me%win_parent_child, ierr )
	845	IF ( lo_ptrans ) THEN
	846	CALL MPI_GET( ibuf, nr8, MPI_BYTE, ip-1, target_disp, nr8, MPI_BYTE, & !There is no MPI_INTEGER8 datatype
	847	me%win_parent_child, ierr )
[4246]	848	ELSE
[4649]	849	CALL MPI_GET( buf, nr, MPI_REAL, ip-1, target_disp, nr, MPI_REAL, &
	850	me%win_parent_child, ierr )
[4246]	851	ENDIF
	852	CALL MPI_WIN_UNLOCK( ip-1, me%win_parent_child, ierr )
	853	ENDIF
	854	myindex = 1
[4649]	855	IF ( ar%dimkey == 2 .AND. .NOT. lo_ptrans) THEN
[4246]	856
	857	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
	858	DO ij = 1, ape%nrele
	859	data_2d(ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex)
	860	myindex = myindex + 1
	861	ENDDO
	862
[4649]	863	ELSEIF ( ar%dimkey == 3 .AND. .NOT. lo_ptrans) THEN
[4246]	864
	865	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
	866	DO ij = 1, ape%nrele
[4649]	867	data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i) = buf(myindex:myindex+ar%a_dim(1)-1)
[4246]	868	myindex = myindex+ar%a_dim(1)
	869	ENDDO
	870
	871	ELSEIF ( ar%dimkey == 22 .AND. lo_ptrans) THEN
	872	CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
	873
	874	DO ij = 1, ape%nrele
	875	idata_2d(ape%locind(ij)%j,ape%locind(ij)%i) = ibuf(myindex)
	876	myindex = myindex + 1
	877	ENDDO
	878
	879	ENDIF
	880	ENDDO
	881	ENDDO
	882
	883	END SUBROUTINE pmc_c_getbuffer
	884
	885
[4649]	886	!--------------------------------------------------------------------------------------------------!
	887	! Description:
	888	! ------------
	889	!> @Todo: Missing subroutine description.
	890	!--------------------------------------------------------------------------------------------------!
[4246]	891	SUBROUTINE pmc_c_putbuffer( waittime , particle_transfer )
	892
	893	IMPLICIT NONE
	894
[4649]	895	INTEGER(iwp) :: ierr !<
	896	INTEGER(iwp) :: ij !<
	897	INTEGER(iwp) :: ip !<
	898	INTEGER(iwp) :: j !<
	899	INTEGER(iwp) :: myindex !<
	900
	901	INTEGER(iwp), DIMENSION(1) :: buf_shape !<
	902
	903	INTEGER(idp), POINTER, DIMENSION(:) :: ibuf !<
	904	INTEGER(idp), POINTER, DIMENSION(:,:) :: idata_2d !<
	905
[4246]	906	LOGICAL, INTENT(IN), OPTIONAL :: particle_transfer !<
	907
[4649]	908	LOGICAL :: lo_ptrans !<
[4246]	909
	910	REAL(wp) :: t1 !<
	911	REAL(wp) :: t2 !<
	912
[4649]	913	REAL(wp), INTENT(OUT), OPTIONAL :: waittime !<
[4246]	914
[4649]	915	REAL(wp), POINTER, DIMENSION(:) :: buf !<
	916	REAL(wp), POINTER, DIMENSION(:,:) :: data_2d !<
	917	REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d !<
[4246]	918
[4649]	919	TYPE(pedef), POINTER :: ape !<
	920	TYPE(arraydef), POINTER :: ar !<
	921
[4246]	922	!
[4649]	923	!-- Wait for empty buffer.
	924	!-- Switch RMA epoche.
[4246]	925
	926	t1 = pmc_time()
	927	CALL MPI_BARRIER( me%intra_comm, ierr )
	928	t2 = pmc_time()
	929	IF ( PRESENT( waittime ) ) waittime = t2 - t1
	930
	931	lo_ptrans = .FALSE.
[4649]	932	IF ( PRESENT( particle_transfer) ) lo_ptrans = particle_transfer
[4246]	933
	934	DO ip = 1, me%inter_npes
	935	ape => me%pes(ip)
	936	DO j = 1, ape%nr_arrays
	937	ar => aPE%array_list(j)
	938	myindex = 1
	939
[4649]	940	IF ( ar%dimkey == 2 .AND. .NOT. lo_ptrans ) THEN
[4246]	941
	942	buf_shape(1) = ape%nrele
	943	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
	944	CALL C_F_POINTER( ar%data, data_2d, ar%a_dim(1:2) )
	945	DO ij = 1, ape%nrele
	946	buf(myindex) = data_2d(ape%locind(ij)%j,ape%locind(ij)%i)
	947	myindex = myindex + 1
	948	ENDDO
	949
[4649]	950	ELSEIF ( ar%dimkey == 3 .AND. .NOT. lo_ptrans ) THEN
[4246]	951
	952	buf_shape(1) = ape%nrele*ar%a_dim(1)
	953	CALL C_F_POINTER( ar%sendbuf, buf, buf_shape )
	954	CALL C_F_POINTER( ar%data, data_3d, ar%a_dim(1:3) )
	955	DO ij = 1, ape%nrele
[4649]	956	buf(myindex:myindex+ar%a_dim(1)-1) = data_3d(:,ape%locind(ij)%j,ape%locind(ij)%i)
[4246]	957	myindex = myindex + ar%a_dim(1)
	958	ENDDO
	959
	960	ELSE IF ( ar%dimkey == 22 .AND. lo_ptrans) THEN
	961
	962	buf_shape(1) = ape%nrele
	963	CALL C_F_POINTER( ar%sendbuf, ibuf, buf_shape )
	964	CALL C_F_POINTER( ar%data, idata_2d, ar%a_dim(1:2) )
	965
	966	DO ij = 1, ape%nrele
	967	ibuf(myindex) = idata_2d(ape%locind(ij)%j,ape%locind(ij)%i)
	968	myindex = myindex + 1
	969	ENDDO
	970
	971	ENDIF
	972	ENDDO
	973	ENDDO
	974	!
[4649]	975	!-- Buffer is filled.
	976	!-- Switch RMA epoche.
[4246]	977
	978	CALL MPI_Barrier(me%intra_comm, ierr)
	979
	980	END SUBROUTINE pmc_c_putbuffer
	981
	982	#endif
	983	END MODULE pmc_child

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

Context Navigation

source: palm/trunk/SOURCE/pmc_child_mod.f90 @ 4883

Download in other formats: