Home

Context Navigation

pmc_mpi_wrapper_mod.f90 @ 4894

Last change on this file since 4894 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: 24.8 KB

Rev	Line
[1900]	1	MODULE pmc_mpi_wrapper
[4649]	2	!--------------------------------------------------------------------------------------------------!
[2696]	3	! This file is part of the PALM model system.
[1762]	4	!
[4649]	5	! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General
	6	! Public License as published by the Free Software Foundation, either version 3 of the License, or
	7	! (at your option) any later version.
[1762]	8	!
[4649]	9	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
	10	! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
	11	! Public License for more details.
[1762]	12	!
[4649]	13	! You should have received a copy of the GNU General Public License along with PALM. If not, see
	14	! <http://www.gnu.org/licenses/>.
[1762]	15	!
[4828]	16	! Copyright 1997-2021 Leibniz Universitaet Hannover
[4649]	17	!--------------------------------------------------------------------------------------------------!
[1762]	18	!
[4649]	19	!
[1762]	20	! Current revisions:
[4649]	21	! -----------------
[4629]	22	!
	23	!
[1762]	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_mpi_wrapper_mod.f90 4828 2021-01-05 11:21:41Z raasch $
[4649]	27	! File re-formatted to follow the PALM coding standard
	28	!
	29	! Current revisions:
	30	! ------------------
	31	!
	32	!
	33	! 4629 2020-07-29 09:37:56Z raasch
	34	! Support for MPI Fortran77 interface (mpif.h) removed
	35	!
[4629]	36	! 4360 2020-01-07 11:25:50Z suehring
[4182]	37	! Corrected "Former revisions" section
[4649]	38	!
[4182]	39	! 3655 2019-01-07 16:51:22Z knoop
[4649]	40	! Extent interface by logical buffer
	41	!
[4182]	42	! 1762 2016-02-25 12:31:13Z hellstea
	43	! Initial revision by K. Ketelsen
[2716]	44	!
[4649]	45	!
	46	!--------------------------------------------------------------------------------------------------!
[1762]	47	! Description:
	48	! ------------
	49	!
	50	! MPI Wrapper of Palm Model Coupler
[4649]	51	!--------------------------------------------------------------------------------------------------!
[1762]	52
[1764]	53	#if defined( __parallel )
[1900]	54	USE, INTRINSIC :: ISO_C_BINDING
[1762]	55
[1764]	56	USE MPI
[1762]	57
[1900]	58	USE kinds
[4649]	59	USE pmc_handle_communicator, &
	60	ONLY: m_model_comm, &
	61	m_model_rank, &
	62	m_to_child_comm, &
	63	m_to_parent_comm
[1762]	64
[4649]	65
[1900]	66	IMPLICIT NONE
[1762]	67
[2841]	68
[1900]	69	PRIVATE
	70	SAVE
[1762]	71
[1933]	72	INTERFACE pmc_send_to_parent
	73	MODULE PROCEDURE pmc_send_to_parent_integer
	74	MODULE PROCEDURE pmc_send_to_parent_integer_2
	75	MODULE PROCEDURE pmc_send_to_parent_real_r1
	76	MODULE PROCEDURE pmc_send_to_parent_real_r2
	77	MODULE PROCEDURE pmc_send_to_parent_real_r3
	78	END INTERFACE pmc_send_to_parent
[1762]	79
[1933]	80	INTERFACE pmc_recv_from_parent
[2938]	81	MODULE PROCEDURE pmc_recv_from_parent_logical
[1933]	82	MODULE PROCEDURE pmc_recv_from_parent_integer
	83	MODULE PROCEDURE pmc_recv_from_parent_real_r1
	84	MODULE PROCEDURE pmc_recv_from_parent_real_r2
	85	MODULE PROCEDURE pmc_recv_from_parent_real_r3
	86	END INTERFACE pmc_recv_from_parent
[1762]	87
[1933]	88	INTERFACE pmc_send_to_child
[2938]	89	MODULE PROCEDURE pmc_send_to_child_logical
[1933]	90	MODULE PROCEDURE pmc_send_to_child_integer
	91	MODULE PROCEDURE pmc_send_to_child_real_r1
	92	MODULE PROCEDURE pmc_send_to_child_real_r2
	93	MODULE PROCEDURE pmc_send_to_child_real_r3
	94	END INTERFACE pmc_send_to_child
[1762]	95
[1933]	96	INTERFACE pmc_recv_from_child
	97	MODULE PROCEDURE pmc_recv_from_child_integer
	98	MODULE PROCEDURE pmc_recv_from_child_integer_2
	99	MODULE PROCEDURE pmc_recv_from_child_real_r1
	100	MODULE PROCEDURE pmc_recv_from_child_real_r2
	101	MODULE PROCEDURE pmc_recv_from_child_real_r3
	102	END INTERFACE pmc_recv_from_child
[1762]	103
[1900]	104	INTERFACE pmc_bcast
	105	MODULE PROCEDURE pmc_bcast_integer
	106	MODULE PROCEDURE pmc_bcast_character
	107	END INTERFACE pmc_bcast
[1762]	108
[1900]	109	INTERFACE pmc_inter_bcast
	110	MODULE PROCEDURE pmc_inter_bcast_integer_1
	111	END INTERFACE pmc_inter_bcast
[1762]	112
[1900]	113	INTERFACE pmc_alloc_mem
	114	MODULE PROCEDURE pmc_alloc_mem_integer_1
	115	MODULE PROCEDURE pmc_alloc_mem_Real_1
	116	END INTERFACE pmc_alloc_mem
[1762]	117
[1900]	118	INTERFACE pmc_time
	119	MODULE PROCEDURE pmc_time
	120	END INTERFACE pmc_time
[1762]	121
[4649]	122	PUBLIC pmc_alloc_mem, &
	123	pmc_bcast, &
	124	pmc_inter_bcast, &
	125	pmc_recv_from_child, &
	126	pmc_recv_from_parent, &
	127	pmc_send_to_child, &
	128	pmc_send_to_parent, &
[1900]	129	pmc_time
[1762]	130
[1900]	131	CONTAINS
[1762]	132
[4649]	133	!--------------------------------------------------------------------------------------------------!
	134	! Description:
	135	! ------------
	136	!
	137	!> @Todo: Missing subroutine description.
	138	!--------------------------------------------------------------------------------------------------!
[2938]	139	SUBROUTINE pmc_recv_from_parent_logical( buf, n, parent_rank, tag, ierr )
	140
	141	IMPLICIT NONE
	142
[4649]	143	INTEGER, INTENT(IN) :: n !<
	144	INTEGER, INTENT(IN) :: parent_rank !<
	145	INTEGER, INTENT(IN) :: tag !<
[2938]	146
[4649]	147	INTEGER, INTENT(OUT) :: ierr !<
	148
	149	LOGICAL, INTENT(OUT) :: buf !<
	150
[2938]	151	ierr = 0
[4649]	152	CALL MPI_RECV( buf, n, MPI_LOGICAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, &
	153	ierr )
[2938]	154
	155	END SUBROUTINE pmc_recv_from_parent_logical
	156
	157
[4649]	158	!--------------------------------------------------------------------------------------------------!
	159	! Description:
	160	! ------------
	161	!
	162	!> @Todo: Missing subroutine description.
	163	!--------------------------------------------------------------------------------------------------!
	164	SUBROUTINE pmc_send_to_child_logical( child_id, buf, n, child_rank, tag, ierr )
	165
[2938]	166	IMPLICIT NONE
	167
[4649]	168	INTEGER, INTENT(IN) :: child_id !<
	169	INTEGER, INTENT(IN) :: child_rank !<
	170	INTEGER, INTENT(IN) :: n !<
	171	INTEGER, INTENT(IN) :: tag !<
[2938]	172
[4649]	173	INTEGER, INTENT(OUT) :: ierr !<
	174
	175	LOGICAL, INTENT(IN) :: buf !<
	176
[2938]	177	ierr = 0
[4649]	178	CALL MPI_SEND( buf, n, MPI_LOGICAL, child_rank, tag, m_to_child_comm(child_id), ierr )
[2938]	179
	180	END SUBROUTINE pmc_send_to_child_logical
	181
	182
[4649]	183	!--------------------------------------------------------------------------------------------------!
	184	! Description:
	185	! ------------
	186	!
	187	!> @Todo: Missing subroutine description.
	188	!--------------------------------------------------------------------------------------------------!
[1933]	189	SUBROUTINE pmc_send_to_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]	190
[1900]	191	IMPLICIT NONE
[1762]	192
[4649]	193	INTEGER, INTENT(IN) :: n !<
	194	INTEGER, INTENT(IN) :: parent_rank !<
	195	INTEGER, INTENT(IN) :: tag !<
[1762]	196
[4649]	197	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	198
	199	INTEGER, INTENT(OUT) :: ierr !<
	200
	201
[1900]	202	ierr = 0
[4649]	203	CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, ierr )
[1779]	204
[1933]	205	END SUBROUTINE pmc_send_to_parent_integer
[1762]	206
[1779]	207
[4649]	208	!--------------------------------------------------------------------------------------------------!
	209	! Description:
	210	! ------------
	211	!
	212	!> @Todo: Missing subroutine description.
	213	!--------------------------------------------------------------------------------------------------!
[1933]	214	SUBROUTINE pmc_recv_from_parent_integer( buf, n, parent_rank, tag, ierr )
[1762]	215
[1900]	216	IMPLICIT NONE
[1779]	217
[4649]	218	INTEGER, INTENT(IN) :: n !<
	219	INTEGER, INTENT(IN) :: parent_rank !<
	220	INTEGER, INTENT(IN) :: tag !<
[1762]	221
[4649]	222	INTEGER, INTENT(OUT) :: ierr !<
	223
	224	INTEGER, DIMENSION(:), INTENT(OUT) :: buf !<
	225
	226
[1900]	227	ierr = 0
[4649]	228	CALL MPI_RECV( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, &
	229	ierr )
[1779]	230
[1933]	231	END SUBROUTINE pmc_recv_from_parent_integer
[1762]	232
	233
[4649]	234	!--------------------------------------------------------------------------------------------------!
	235	! Description:
	236	! ------------
	237	!
	238	!> @Todo: Missing subroutine description.
	239	!--------------------------------------------------------------------------------------------------!
[1933]	240	SUBROUTINE pmc_send_to_parent_integer_2( buf, n, parent_rank, tag, ierr )
[1762]	241
[1900]	242	IMPLICIT NONE
[1779]	243
[4649]	244	INTEGER, INTENT(IN) :: n !<
	245	INTEGER, INTENT(IN) :: parent_rank !<
	246	INTEGER, INTENT(IN) :: tag !<
[1762]	247
[4649]	248	INTEGER, DIMENSION(:,:), INTENT(IN) :: buf !<
	249
	250	INTEGER, INTENT(OUT) :: ierr !<
	251
	252
[1900]	253	ierr = 0
[4649]	254	CALL MPI_SEND( buf, n, MPI_INTEGER, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	255
[1933]	256	END SUBROUTINE pmc_send_to_parent_integer_2
[1779]	257
[1762]	258
[1779]	259
[4649]	260	!--------------------------------------------------------------------------------------------------!
	261	! Description:
	262	! ------------
	263	!
	264	!> @Todo: Missing subroutine description.
	265	!--------------------------------------------------------------------------------------------------!
[1933]	266	SUBROUTINE pmc_send_to_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1762]	267
[1900]	268	IMPLICIT NONE
[1762]	269
[1779]	270
[4649]	271	INTEGER, INTENT(IN) :: n !<
	272	INTEGER, INTENT(IN) :: parent_rank !<
	273	INTEGER, INTENT(IN) :: tag !<
	274
	275	INTEGER, INTENT(OUT) :: ierr !<
	276
	277	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	278
	279
[1900]	280	ierr = 0
[1933]	281	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	282
[1933]	283	END SUBROUTINE pmc_send_to_parent_real_r1
[1779]	284
[1762]	285
[4649]	286	!--------------------------------------------------------------------------------------------------!
	287	! Description:
	288	! ------------
	289	!
	290	!> @Todo: Missing subroutine description.
	291	!--------------------------------------------------------------------------------------------------!
[1933]	292	SUBROUTINE pmc_recv_from_parent_real_r1( buf, n, parent_rank, tag, ierr )
[1779]	293
[1900]	294	IMPLICIT NONE
[1762]	295
[4649]	296	INTEGER, INTENT(IN) :: n !<
	297	INTEGER, INTENT(IN) :: parent_rank !<
	298	INTEGER, INTENT(IN) :: tag !<
[1779]	299
[4649]	300	INTEGER, INTENT(OUT) :: ierr !<
	301
	302	REAL(wp), DIMENSION(:), INTENT(OUT) :: buf !<
	303
	304
[1900]	305	ierr = 0
[4649]	306	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
[1762]	307
[1933]	308	END SUBROUTINE pmc_recv_from_parent_real_r1
[1762]	309
	310
[4649]	311	!--------------------------------------------------------------------------------------------------!
	312	! Description:
	313	! ------------
	314	!
	315	!> @Todo: Missing subroutine description.
	316	!--------------------------------------------------------------------------------------------------!
[1933]	317	SUBROUTINE pmc_send_to_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]	318
[1900]	319	IMPLICIT NONE
[1762]	320
[4649]	321	INTEGER, INTENT(IN) :: n !<
	322	INTEGER, INTENT(IN) :: parent_rank !<
	323	INTEGER, INTENT(IN) :: tag !<
[1762]	324
[4649]	325	INTEGER, INTENT(OUT) :: ierr !<
	326
	327	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	328
	329
[1900]	330	ierr = 0
[1933]	331	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	332
[1933]	333	END SUBROUTINE pmc_send_to_parent_real_r2
[1762]	334
	335
[4649]	336	!--------------------------------------------------------------------------------------------------!
	337	! Description:
	338	! ------------
	339	!
	340	!> @Todo: Missing subroutine description.
	341	!--------------------------------------------------------------------------------------------------!
[1933]	342	SUBROUTINE pmc_recv_from_parent_real_r2( buf, n, parent_rank, tag, ierr )
[1762]	343
[1900]	344	IMPLICIT NONE
[1762]	345
[4649]	346	INTEGER, INTENT(IN) :: n !<
	347	INTEGER, INTENT(IN) :: parent_rank !<
	348	INTEGER, INTENT(IN) :: tag !<
[1779]	349
[4649]	350	INTEGER, INTENT(OUT) :: ierr !<
	351
	352	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	353
	354
[1900]	355	ierr = 0
[4649]	356	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
[1762]	357
[1933]	358	END SUBROUTINE pmc_recv_from_parent_real_r2
[1779]	359
[1762]	360
[4649]	361	!--------------------------------------------------------------------------------------------------!
	362	! Description:
	363	! ------------
	364	!
	365	!> @Todo: Missing subroutine description.
	366	!--------------------------------------------------------------------------------------------------!
[1933]	367	SUBROUTINE pmc_send_to_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]	368
[1900]	369	IMPLICIT NONE
[1762]	370
[4649]	371	INTEGER, INTENT(IN) :: n !<
	372	INTEGER, INTENT(IN) :: parent_rank !<
	373	INTEGER, INTENT(IN) :: tag !<
[1779]	374
[4649]	375	INTEGER, INTENT(OUT) :: ierr !<
	376
	377	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	378
	379
[1900]	380	ierr = 0
[1933]	381	CALL MPI_SEND( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, ierr )
[1762]	382
[1933]	383	END SUBROUTINE pmc_send_to_parent_real_r3
[1762]	384
[1779]	385
[4649]	386	!--------------------------------------------------------------------------------------------------!
	387	! Description:
	388	! ------------
	389	!
	390	!> @Todo: Missing subroutine description.
	391	!--------------------------------------------------------------------------------------------------!
[1933]	392	SUBROUTINE pmc_recv_from_parent_real_r3( buf, n, parent_rank, tag, ierr )
[1779]	393
[1900]	394	IMPLICIT NONE
[1762]	395
[4649]	396	INTEGER, INTENT(IN) :: n !<
	397	INTEGER, INTENT(IN) :: parent_rank !<
	398	INTEGER, INTENT(IN) :: tag !<
[1762]	399
[4649]	400	INTEGER, INTENT(OUT) :: ierr !<
	401
	402	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	403
	404
[1900]	405	ierr = 0
[4649]	406	CALL MPI_RECV( buf, n, MPI_REAL, parent_rank, tag, m_to_parent_comm, MPI_STATUS_IGNORE, ierr )
[1779]	407
[1933]	408	END SUBROUTINE pmc_recv_from_parent_real_r3
[1762]	409
[1779]	410
[4649]	411	!--------------------------------------------------------------------------------------------------!
	412	! Description:
	413	! ------------
	414	!
	415	!> @Todo: Missing subroutine description.
	416	!--------------------------------------------------------------------------------------------------!
	417	SUBROUTINE pmc_send_to_child_integer( child_id, buf, n, child_rank, tag, ierr )
[1762]	418
[1900]	419	IMPLICIT NONE
[1779]	420
[4649]	421	INTEGER, INTENT(IN) :: child_id !<
	422	INTEGER, INTENT(IN) :: child_rank !<
	423	INTEGER, INTENT(IN) :: n !<
	424	INTEGER, INTENT(IN) :: tag !<
[1762]	425
[4649]	426	INTEGER, DIMENSION(:), INTENT(IN) :: buf !<
	427
	428	INTEGER, INTENT(OUT) :: ierr !<
	429
	430
[1900]	431	ierr = 0
[4649]	432	CALL MPI_SEND( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id), ierr )
[1779]	433
[1933]	434	END SUBROUTINE pmc_send_to_child_integer
[1762]	435
	436
[4649]	437	!--------------------------------------------------------------------------------------------------!
	438	! Description:
	439	! ------------
	440	!
	441	!> @Todo: Missing subroutine description.
	442	!--------------------------------------------------------------------------------------------------!
	443	SUBROUTINE pmc_recv_from_child_integer( child_id, buf, n, child_rank, tag, ierr )
[1779]	444
[1900]	445	IMPLICIT NONE
[1779]	446
[4649]	447	INTEGER, INTENT(IN) :: child_id !<
	448	INTEGER, INTENT(IN) :: child_rank !<
	449	INTEGER, INTENT(IN) :: n !<
	450	INTEGER, INTENT(IN) :: tag !<
[1762]	451
[4649]	452	INTEGER, INTENT(OUT) :: ierr !<
	453
	454	INTEGER, DIMENSION(:), INTENT(INOUT) :: buf !<
	455
	456
[1900]	457	ierr = 0
[4649]	458	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id), &
	459	MPI_STATUS_IGNORE, ierr )
[1762]	460
[1933]	461	END SUBROUTINE pmc_recv_from_child_integer
[1762]	462
	463
[4649]	464	!--------------------------------------------------------------------------------------------------!
	465	! Description:
	466	! ------------
	467	!
	468	!> @Todo: Missing subroutine description.
	469	!--------------------------------------------------------------------------------------------------!
	470	SUBROUTINE pmc_recv_from_child_integer_2( child_id, buf, n, child_rank, tag, ierr )
[1762]	471
[1900]	472	IMPLICIT NONE
[1762]	473
[4649]	474	INTEGER, INTENT(IN) :: child_id !<
	475	INTEGER, INTENT(IN) :: child_rank !<
	476	INTEGER, INTENT(IN) :: n !<
	477	INTEGER, INTENT(IN) :: tag !<
[1762]	478
[4649]	479	INTEGER, INTENT(OUT) :: ierr !<
	480
	481	INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf !<
	482
	483
[1900]	484	ierr = 0
[4649]	485	CALL MPI_RECV( buf, n, MPI_INTEGER, child_rank, tag, m_to_child_comm(child_id), &
	486	MPI_STATUS_IGNORE, ierr )
[1762]	487
[1933]	488	END SUBROUTINE pmc_recv_from_child_integer_2
[1762]	489
	490
[4649]	491	!--------------------------------------------------------------------------------------------------!
	492	! Description:
	493	! ------------
	494	!
	495	!> @Todo: Missing subroutine description.
	496	!--------------------------------------------------------------------------------------------------!
	497	SUBROUTINE pmc_send_to_child_real_r1( child_id, buf, n, child_rank, tag, ierr )
[1762]	498
[1900]	499	IMPLICIT NONE
[1762]	500
[4649]	501	INTEGER, INTENT(IN) :: child_id !<
	502	INTEGER, INTENT(IN) :: child_rank !<
	503	INTEGER, INTENT(IN) :: n !<
	504	INTEGER, INTENT(IN) :: tag !<
[1762]	505
[4649]	506	INTEGER, INTENT(OUT) :: ierr !<
	507
	508	REAL(wp), DIMENSION(:), INTENT(IN) :: buf !<
	509
	510
[1900]	511	ierr = 0
[4649]	512	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
[1762]	513
[1933]	514	END SUBROUTINE pmc_send_to_child_real_r1
[1762]	515
	516
	517
[4649]	518	!--------------------------------------------------------------------------------------------------!
	519	! Description:
	520	! ------------
	521	!
	522	!> @Todo: Missing subroutine description.
	523	!--------------------------------------------------------------------------------------------------!
	524	SUBROUTINE pmc_recv_from_child_real_r1( child_id, buf, n, child_rank, tag, ierr )
[1762]	525
[1900]	526	IMPLICIT NONE
[1762]	527
[4649]	528	INTEGER, INTENT(IN) :: child_id !<
	529	INTEGER, INTENT(IN) :: child_rank !<
	530	INTEGER, INTENT(IN) :: n !<
	531	INTEGER, INTENT(IN) :: tag !<
[1762]	532
[4649]	533	INTEGER, INTENT(OUT) :: ierr !<
	534
	535	REAL(wp), DIMENSION(:), INTENT(INOUT) :: buf !<
	536
	537
[1900]	538	ierr = 0
[4649]	539	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), &
	540	MPI_STATUS_IGNORE, ierr )
[1762]	541
[1933]	542	END SUBROUTINE pmc_recv_from_child_real_r1
[1762]	543
	544
[4649]	545	!--------------------------------------------------------------------------------------------------!
	546	! Description:
	547	! ------------
	548	!
	549	!> @Todo: Missing subroutine description.
	550	!--------------------------------------------------------------------------------------------------!
	551	SUBROUTINE pmc_send_to_child_real_r2( child_id, buf, n, child_rank, tag, ierr )
[1762]	552
[1900]	553	IMPLICIT NONE
[1762]	554
[4649]	555	INTEGER, INTENT(IN) :: child_id !<
	556	INTEGER, INTENT(IN) :: child_rank !<
	557	INTEGER, INTENT(IN) :: n !<
	558	INTEGER, INTENT(IN) :: tag !<
[1762]	559
[4649]	560	INTEGER, INTENT(OUT) :: ierr !<
	561
	562	REAL(wp), DIMENSION(:,:), INTENT(IN) :: buf !<
	563
	564
[1900]	565	ierr = 0
[4649]	566	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
[1762]	567
[1933]	568	END SUBROUTINE pmc_send_to_child_real_r2
[1762]	569
	570
	571
[4649]	572	!--------------------------------------------------------------------------------------------------!
	573	! Description:
	574	! ------------
	575	!
	576	!> @Todo: Missing subroutine description.
	577	!--------------------------------------------------------------------------------------------------!
	578	SUBROUTINE pmc_recv_from_child_real_r2( child_id, buf, n, child_rank, tag, ierr )
[1762]	579
[1900]	580	IMPLICIT NONE
[1762]	581
[4649]	582	INTEGER, INTENT(IN) :: child_id !<
	583	INTEGER, INTENT(IN) :: child_rank !<
	584	INTEGER, INTENT(IN) :: n !<
	585	INTEGER, INTENT(IN) :: tag !<
[1900]	586
[4649]	587	INTEGER, INTENT(OUT) :: ierr !<
	588
	589	REAL(wp), DIMENSION(:,:), INTENT(OUT) :: buf !<
	590
	591
[1900]	592	ierr = 0
[4649]	593	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), &
	594	MPI_STATUS_IGNORE, ierr )
[1900]	595
[1933]	596	END SUBROUTINE pmc_recv_from_child_real_r2
[1900]	597
	598
[4649]	599	!--------------------------------------------------------------------------------------------------!
	600	! Description:
	601	! ------------
	602	!
	603	!> @Todo: Missing subroutine description.
	604	!--------------------------------------------------------------------------------------------------!
	605	SUBROUTINE pmc_send_to_child_real_r3( child_id, buf, n, child_rank, tag, ierr )
[1900]	606
	607	IMPLICIT NONE
	608
[4649]	609	INTEGER, INTENT(IN) :: child_id !<
	610	INTEGER, INTENT(IN) :: child_rank !<
	611	INTEGER, INTENT(IN) :: n !<
	612	INTEGER, INTENT(IN) :: tag !<
[1900]	613
[4649]	614	INTEGER, INTENT(OUT) :: ierr !<
	615
	616	REAL(wp), DIMENSION(:,:,:), INTENT(IN) :: buf !<
	617
	618
[1900]	619	ierr = 0
[4649]	620	CALL MPI_SEND( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), ierr )
[1900]	621
[1933]	622	END SUBROUTINE pmc_send_to_child_real_r3
[1900]	623
	624
	625
[4649]	626	!--------------------------------------------------------------------------------------------------!
	627	! Description:
	628	! ------------
	629	!
	630	!> @Todo: Missing subroutine description.
	631	!--------------------------------------------------------------------------------------------------!
	632	SUBROUTINE pmc_recv_from_child_real_r3( child_id, buf, n, child_rank, tag, ierr )
[1900]	633
	634	IMPLICIT NONE
	635
[4649]	636	INTEGER, INTENT(IN) :: child_id !<
	637	INTEGER, INTENT(IN) :: child_rank !<
	638	INTEGER, INTENT(IN) :: n !<
	639	INTEGER, INTENT(IN) :: tag !<
[1900]	640
[4649]	641	INTEGER, INTENT(OUT) :: ierr !<
	642
	643	REAL(wp), DIMENSION(:,:,:), INTENT(OUT) :: buf !<
	644
	645
[1900]	646	ierr = 0
[4649]	647	CALL MPI_RECV( buf, n, MPI_REAL, child_rank, tag, m_to_child_comm(child_id), &
	648	MPI_STATUS_IGNORE, ierr )
[1900]	649
[1933]	650	END SUBROUTINE pmc_recv_from_child_real_r3
[1900]	651
	652
	653
[4649]	654	!--------------------------------------------------------------------------------------------------!
	655	! Description:
	656	! ------------
	657	!
	658	!> @Todo: Missing subroutine description.
	659	!--------------------------------------------------------------------------------------------------!
[1900]	660	SUBROUTINE pmc_bcast_integer( buf, root_pe, comm, ierr )
	661
	662	IMPLICIT NONE
	663
[4649]	664	INTEGER, INTENT(IN) :: root_pe !<
[1900]	665
[4649]	666	INTEGER, INTENT(INOUT) :: buf !<
	667
	668	INTEGER, INTENT(IN), OPTIONAL :: comm !<
	669
	670	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
	671
[1900]	672	INTEGER :: mycomm !<
	673	INTEGER :: myerr !<
	674
	675
	676	IF ( PRESENT( comm ) ) THEN
	677	mycomm = comm
	678	ELSE
	679	mycomm = m_model_comm
	680	ENDIF
	681
	682	CALL MPI_BCAST( buf, 1, MPI_INTEGER, root_pe, mycomm, myerr )
	683
	684	IF ( PRESENT( ierr ) ) THEN
	685	ierr = myerr
	686	ENDIF
	687
	688	END SUBROUTINE pmc_bcast_integer
	689
	690
[4649]	691	!--------------------------------------------------------------------------------------------------!
	692	! Description:
	693	! ------------
	694	!
	695	!> @Todo: Missing subroutine description.
	696	!--------------------------------------------------------------------------------------------------!
[1900]	697	SUBROUTINE pmc_bcast_character( buf, root_pe, comm, ierr )
	698
	699	IMPLICIT NONE
	700
[4649]	701	CHARACTER(LEN=*), INTENT(INOUT) :: buf !<
[1900]	702
[4649]	703	INTEGER, INTENT(IN) :: root_pe !<
	704
	705	INTEGER, INTENT(IN), OPTIONAL :: comm !<
	706
	707	INTEGER, INTENT(OUT), OPTIONAL :: ierr !<
	708
[1900]	709	INTEGER :: mycomm !<
	710	INTEGER :: myerr !<
	711
[4649]	712
[1900]	713	IF ( PRESENT( comm ) ) THEN
	714	mycomm = comm
	715	ELSE
	716	mycomm = m_model_comm
	717	ENDIF
	718
[4649]	719	CALL MPI_BCAST( buf, LEN( buf ), MPI_CHARACTER, root_pe, mycomm, myerr )
[1900]	720
	721	IF ( PRESENT( ierr ) ) THEN
	722	ierr = myerr
	723	ENDIF
	724
	725	END SUBROUTINE pmc_bcast_character
	726
	727
[4649]	728	!--------------------------------------------------------------------------------------------------!
	729	! Description:
	730	! ------------
	731	!
	732	!> @Todo: Missing subroutine description.
	733	!--------------------------------------------------------------------------------------------------!
[1933]	734	SUBROUTINE pmc_inter_bcast_integer_1( buf, child_id, ierr )
[1900]	735
	736	IMPLICIT NONE
	737
[4649]	738	INTEGER, INTENT(IN),optional :: child_id !<
[1900]	739
[4649]	740	INTEGER, INTENT(OUT),optional :: ierr !<
	741
	742	INTEGER, INTENT(INOUT),DIMENSION(:) :: buf !<
	743
[1900]	744	INTEGER :: mycomm !<
	745	INTEGER :: myerr !<
	746	INTEGER :: root_pe !<
	747
	748	!
[2599]	749	!-- Process 0 on parent broadcast to all child processes
[1933]	750	IF ( PRESENT( child_id ) ) THEN
[1900]	751
[1933]	752	mycomm = m_to_child_comm(child_id)
[1900]	753
	754	IF ( m_model_rank == 0 ) THEN
	755	root_pe = MPI_ROOT
	756	ELSE
	757	root_pe = MPI_PROC_NULL
	758	ENDIF
	759
	760	ELSE
[1933]	761	mycomm = m_to_parent_comm
[1900]	762	root_pe = 0
	763	ENDIF
	764
	765	CALL MPI_BCAST( buf, SIZE( buf ), MPI_INTEGER, root_pe, mycomm, myerr )
	766
	767	IF ( PRESENT( ierr ) ) THEN
	768	ierr = myerr
	769	ENDIF
	770
	771	END SUBROUTINE pmc_inter_bcast_integer_1
	772
	773
	774
[4649]	775	!--------------------------------------------------------------------------------------------------!
	776	! Description:
	777	! ------------
	778	!
	779	!> @Todo: Missing subroutine description.
	780	!--------------------------------------------------------------------------------------------------!
[1900]	781	SUBROUTINE pmc_alloc_mem_integer_1( iarray, idim1 )
	782	!
	783	!-- Allocate memory with MPI_ALLOC_MEM using intermediate C-pointer
	784
	785	IMPLICIT NONE
	786
[4649]	787	INTEGER, INTENT(IN) :: idim1 !<
	788
	789	INTEGER :: ierr !<
	790
	791	INTEGER, DIMENSION(1) :: ashape !<
	792
[1900]	793	INTEGER, DIMENSION(:), POINTER, INTENT(INOUT) :: iarray !<
	794
	795	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	796
[4649]	797	TYPE(C_PTR) :: p_myind !<
[1900]	798
	799
[4649]	800	winsize = idim1 * STORAGE_SIZE( ierr ) / 8
	801
[1900]	802	CALL MPI_ALLOC_MEM( winsize, MPI_INFO_NULL, p_myind, ierr )
	803	ashape(1) = idim1
	804	CALL C_F_POINTER( p_myind, iarray, ashape )
	805
	806	END SUBROUTINE pmc_alloc_mem_integer_1
	807
	808
	809
[4649]	810	!--------------------------------------------------------------------------------------------------!
	811	! Description:
	812	! ------------
	813	!
	814	!> @Todo: Missing subroutine description.
	815	!--------------------------------------------------------------------------------------------------!
[1900]	816	SUBROUTINE pmc_alloc_mem_real_1( array, idim1, base_ptr )
	817
	818	IMPLICIT NONE
	819
[4649]	820	INTEGER(idp), INTENT(IN) :: idim1 !<
[1900]	821
[4649]	822	INTEGER :: ierr !<
[1900]	823
[4649]	824	INTEGER, DIMENSION(1) :: ashape !<
[1900]	825
[4649]	826	INTEGER(KIND=MPI_ADDRESS_KIND) :: winsize !<
	827
	828	REAL(KIND=wp), DIMENSION(:), POINTER, INTENT(INOUT) :: array !<
	829
	830	TYPE(C_PTR) :: p_myind !<
	831
	832	TYPE(C_PTR), INTENT(OUT), OPTIONAL :: base_ptr !<
	833
	834
[1900]	835	winsize = idim1 * wp
	836
	837	CALL MPI_ALLOC_MEM( winsize , MPI_INFO_NULL, p_myind, ierr )
	838	ashape(1) = idim1
	839	CALL C_F_POINTER( p_myind, array, ashape )
	840
	841	IF ( PRESENT( base_ptr ) ) THEN
	842	base_ptr = p_myind
	843	ENDIF
	844
	845	END SUBROUTINE pmc_alloc_mem_Real_1
	846
	847
	848
	849	FUNCTION pmc_time()
	850
[4649]	851	REAL(KIND=wp) :: pmc_time !<
[1900]	852
[4649]	853
[1900]	854	pmc_time = MPI_WTIME()
	855
	856	END FUNCTION pmc_time
	857
[1764]	858	#endif
[4649]	859	END MODULE pmc_mpi_wrapper

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

Context Navigation

source: palm/trunk/SOURCE/pmc_mpi_wrapper_mod.f90 @ 4894

Download in other formats: