Home

Context Navigation

source: palm/trunk/SOURCE/pmc_handle_communicator.f90 @ 1767

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

Rev	Line
[1764]	1	MODULE PMC_handle_communicator
[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	!
	17	! Copyright 1997-2015 Leibniz Universitaet Hannover
	18	!--------------------------------------------------------------------------------!
	19	!
	20	! Current revisions:
	21	! ------------------
[1765]	22	!
	23	!
	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_handle_communicator.f90 1765 2016-02-28 13:30:40Z raasch $
	27	!
	28	! 1764 2016-02-28 12:45:19Z raasch
[1764]	29	! pmc_layout type: comm_cpl and comm_parent removed, character "name" moved at
	30	! the beginning of the variable list,
	31	! domain layout is read with new NAMELIST nestpar from standard file PARIN,
	32	! MPI-datatype REAL8 replaced by REAL, kind=8 replaced by wp,
	33	! variable domain_layouts instead of m_couplers introduced for this NAMELIST,
	34	! general format changed to PALM style
[1762]	35	!
[1763]	36	! 1762 2016-02-25 12:31:13Z hellstea
	37	! Initial revision by K. Ketelsen
	38	!
[1762]	39	! Description:
	40	! ------------
[1764]	41	! Handle MPI communicator in PALM model coupler
[1762]	42	!------------------------------------------------------------------------------!
	43
[1764]	44	#if defined( __parallel )
	45	USE kinds
[1762]	46
[1764]	47	#if defined( __lc )
	48	USE MPI
	49	#else
	50	INCLUDE "mpif.h"
	51	#endif
[1762]	52
[1764]	53	USE pmc_general, &
	54	ONLY: pmc_status_ok, pmc_status_error, pmc_max_modell
[1762]	55
[1764]	56	IMPLICIT NONE
[1762]	57
[1764]	58	TYPE pmc_layout
[1762]	59
[1764]	60	CHARACTER(len=32) :: name
[1762]	61
[1764]	62	INTEGER :: id
	63	INTEGER :: parent_id
	64	INTEGER :: npe_x
	65	INTEGER :: npe_y
[1762]	66
[1764]	67	REAL(wp) :: lower_left_x
	68	REAL(wp) :: lower_left_y
[1762]	69
[1764]	70	END TYPE pmc_layout
	71
	72	PUBLIC pmc_status_ok, pmc_status_error
	73
	74	INTEGER, PARAMETER, PUBLIC :: pmc_error_npes = 1 ! illegal number of PEs
	75	INTEGER, PARAMETER, PUBLIC :: pmc_namelist_error = 2 ! error(s) in nestpar namelist
	76	INTEGER, PARAMETER, PUBLIC :: pmc_no_namelist_found = 3 ! No couple layout file found
	77
[1762]	78	! Coupler Setup
	79
	80	INTEGER :: m_my_CPL_id !Coupler id of this model
	81	INTEGER :: m_Parent_id !Coupler id of parent of this model
	82	INTEGER :: m_NrOfCpl !Number of Coupler in layout file
[1764]	83	TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers !Information of all coupler
[1762]	84
	85	! MPI settings
	86
	87	INTEGER,PUBLIC :: m_model_comm !Communicator of this model
	88	INTEGER,PUBLIC :: m_to_server_comm !Communicator to the server
	89	INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm !Communicator to the client(s)
	90	INTEGER,PUBLIC :: m_world_rank
	91	INTEGER :: m_world_npes
	92	INTEGER,PUBLIC :: m_model_rank
	93	INTEGER,PUBLIC :: m_model_npes
	94	INTEGER :: m_server_remote_size !Number of Server PE's
	95
	96	PUBLIC m_to_client_comm
	97
	98	!Indicates this PE is server for Cleint NR
	99
	100	INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
	101
[1764]	102	INTERFACE pmc_is_rootmodel
	103	MODULE PROCEDURE pmc_is_rootmodel
	104	END INTERFACE pmc_is_rootmodel
[1762]	105
	106	INTERFACE PMC_get_local_model_info
	107	MODULE PROCEDURE PMC_get_local_model_info
	108	END INTERFACE PMC_get_local_model_info
	109
[1764]	110	PUBLIC pmc_get_local_model_info, pmc_init_model, pmc_is_rootmodel
[1762]	111
[1764]	112	CONTAINS
[1762]	113
[1764]	114	SUBROUTINE pmc_init_model( comm, nesting_mode, pmc_status )
[1762]	115
[1764]	116	USE control_parameters, &
	117	ONLY: message_string
	118
	119	USE pegrid, &
	120	ONLY: myid
	121
	122	IMPLICIT NONE
	123
	124	CHARACTER(LEN=7), INTENT(OUT) :: nesting_mode
	125
	126	INTEGER, INTENT(OUT) :: comm
	127	INTEGER, INTENT(OUT) :: pmc_status
	128
	129	INTEGER :: i, ierr, istat
	130	INTEGER,DIMENSION(pmc_max_modell+1) :: start_pe
	131	INTEGER :: m_my_cpl_rank
	132	INTEGER :: tag, clientcount
	133	INTEGER,DIMENSION(pmc_max_modell) :: activeserver ! I am active server for this client ID
	134
	135	pmc_status = pmc_status_ok
[1762]	136	comm = -1
[1764]	137	m_my_cpl_id = -1
	138	clientcount = 0
	139	activeserver = -1
	140	start_pe(:) = 0
[1762]	141
[1764]	142	CALL MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat )
	143	CALL MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat )
	144	!
	145	!-- Only PE 0 of root model reads
	146	IF ( m_world_rank == 0 ) THEN
[1762]	147
[1764]	148	CALL read_coupling_layout( nesting_mode, pmc_status )
[1762]	149
[1764]	150	IF ( pmc_status /= pmc_no_namelist_found .AND. &
	151	pmc_status /= pmc_namelist_error ) &
	152	THEN
	153	!
	154	!-- Calculate start PE of every model
	155	start_pe(1) = 0
	156	DO i = 2, m_nrofcpl+1
	157	start_pe(i) = start_pe(i-1) + &
	158	m_couplers(i-1)%npe_x * m_couplers(i-1)%npe_y
	159	ENDDO
[1762]	160
[1764]	161	!
	162	!-- The number of cores provided with the run must be the same as the
	163	!-- total sum of cores required by all nest domains
	164	!-- TO_DO: can we use > instead of /= ?
	165	IF ( start_pe(m_nrofcpl+1) /= m_world_npes ) THEN
	166	!-- TO_DO: this IF statement is redundant
	167	IF ( m_world_rank == 0 ) THEN
	168	WRITE ( message_string, '(A,I6,A,I6,A)' ) &
	169	'nesting-setup requires more MPI procs (', &
	170	start_pe(m_nrofcpl+1), ') than provided (', &
	171	m_world_npes,')'
	172	CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
	173	ENDIF
	174	ENDIF
[1762]	175
[1764]	176	ENDIF
[1762]	177
[1764]	178	ENDIF
	179	!
	180	!-- Broadcast the read status. This synchronises all other PEs with PE 0 of
	181	!-- the root model. Without synchronisation, they would not behave in the
	182	!-- correct way (e.g. they would not return in case of a missing NAMELIST)
	183	CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
[1762]	184
[1764]	185	IF ( pmc_status == pmc_no_namelist_found ) THEN
	186	!
	187	!-- Not a nested run; return the MPI_WORLD communicator
	188	comm = MPI_COMM_WORLD
	189	RETURN
[1762]	190
[1764]	191	ELSEIF ( pmc_status == pmc_namelist_error ) THEN
	192	!
	193	!-- Only the root model gives the error message. Others are aborted by the
	194	!-- message-routine with MPI_ABORT. Must be done this way since myid and
	195	!-- comm2d have not yet been assigned at this point.
	196	IF ( m_world_rank == 0 ) THEN
	197	message_string = 'errors in \$nestpar'
	198	CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 )
	199	ENDIF
[1762]	200
[1764]	201	ENDIF
[1762]	202
[1764]	203	CALL MPI_BCAST( m_nrofcpl, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	204	CALL MPI_BCAST( start_pe, m_nrofcpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
[1762]	205
[1764]	206	!
	207	!-- Broadcast coupling layout
	208	DO i = 1, m_nrofcpl
	209	CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
	210	CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
	211	CALL MPI_BCAST( m_couplers(i)%Parent_id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
	212	CALL MPI_BCAST( m_couplers(i)%npe_x, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
	213	CALL MPI_BCAST( m_couplers(i)%npe_y, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
	214	CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL, 0, MPI_COMM_WORLD, istat )
	215	CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL, 0, MPI_COMM_WORLD, istat )
	216	ENDDO
[1762]	217
[1764]	218	!
	219	!-- Assign global MPI processes to individual models by setting the couple id
	220	DO i = 1, m_nrofcpl
	221	IF ( m_world_rank >= start_pe(i) .AND. m_world_rank < start_pe(i+1) ) &
	222	THEN
	223	m_my_cpl_id = i
	224	EXIT
	225	ENDIF
	226	ENDDO
	227	m_my_cpl_rank = m_world_rank - start_pe(i)
[1762]	228
[1764]	229	!
	230	!-- MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach).
	231	!-- The communictors for the individual models as created by MPI_COMM_SPLIT.
	232	!-- The color of the model is represented by the coupler id
	233	CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm, &
	234	istat )
	235	IF ( istat /= MPI_SUCCESS ) THEN
	236	!
	237	!-- TO_DO: replace by message-call
	238	!-- TO_DO: Can this really happen, or is this just for the debugging phase?
	239	IF ( m_world_rank == 0 ) WRITE (0,*) 'PMC: Error in MPI_Comm_split '
	240	CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
	241	ENDIF
[1762]	242
[1764]	243	!
	244	!-- Get size and rank of the model running on this PE
	245	CALL MPI_COMM_RANK( comm, m_model_rank, istat )
	246	CALL MPI_COMM_SIZE( comm, m_model_npes, istat )
[1762]	247
[1764]	248	!
	249	!-- Broadcast (from PE 0) the parent id and id of every model
	250	DO i = 1, m_nrofcpl
	251	CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0, &
	252	MPI_COMM_WORLD, istat )
	253	CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, &
	254	MPI_COMM_WORLD, istat )
	255	ENDDO
[1762]	256
[1764]	257	!
	258	!-- TO_DO: describe what is happening here, and why
[1762]	259	m_model_comm = comm
	260
[1764]	261	!
	262	!-- Create intercommunicator between server and clients.
	263	!-- MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
	264	!-- different colors.
	265	!-- The grouping was done above with MPI_COMM_SPLIT
	266	DO i = 2, m_nrofcpl
[1762]	267
[1764]	268	IF ( m_couplers(i)%parent_id == m_my_cpl_id ) THEN
	269	!
	270	!-- Collect server PEs
	271	!-- TO_DO: explain in more details, what is done here
	272	tag = 500 + i
	273	CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i), &
	274	tag, m_to_client_comm(i), istat)
	275	clientcount = clientcount + 1
	276	activeserver(i) = 1
[1762]	277
[1764]	278	ELSEIF ( i == m_my_cpl_id) THEN
	279	!
	280	!-- Collect client PEs
	281	!-- TO_DO: explain in more detail, what is happening here
	282	tag = 500 + i
	283	CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, &
	284	start_pe(m_couplers(i)%parent_id), &
	285	tag, m_to_server_comm, istat )
	286	ENDIF
[1762]	287
[1764]	288	IF ( istat /= MPI_SUCCESS ) THEN
	289	!
	290	!-- TO_DO: replace by message-call
	291	!-- TO_DO: can this really happen, or is this just for debugging?
	292	IF ( m_world_rank == 0 ) WRITE (0,*) 'PMC: Error in Coupler Setup '
	293	CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
	294	ENDIF
[1762]	295
[1764]	296	ENDDO
[1762]	297
[1764]	298	!
	299	!-- If I am server, count the number of clients that I have
	300	!-- Although this loop is symmetric on all processes, the "activeserver" flag
	301	!-- is true (==1) on the respective individual PE only.
	302	ALLOCATE( pmc_server_for_client(clientcount+1) )
[1762]	303
[1764]	304	clientcount = 0
	305	DO i = 2, m_nrofcpl
	306	IF ( activeserver(i) == 1 ) THEN
	307	clientcount = clientcount + 1
	308	pmc_server_for_client(clientcount) = i
	309	ENDIF
	310	ENDDO
	311	!-- TO_DO: explain why this is done
	312	pmc_server_for_client(clientcount+1) = -1
[1762]	313
[1764]	314	!
	315	!-- Get the size of the server model
	316	!-- TO_DO: what does "size" mean here? Number of PEs?
	317	IF ( m_my_cpl_id > 1 ) THEN
	318	CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size, &
	319	istat)
	320	ELSE
	321	!
	322	!-- The root model does not have a server
	323	m_server_remote_size = -1 !
	324	ENDIF
	325	!
	326	!-- Set myid to non-tero value except for the root domain. This is a setting
	327	!-- for the message routine which is called at the end of pmci_init. That
	328	!-- routine outputs messages for myid = 0, only. However, myid has not been
	329	!-- assigened so far, so that all PEs of the root model would output a
	330	!-- message. To avoid this, set myid to some other value except for PE0 of the
	331	!-- root domain.
	332	IF ( m_world_rank /= 0 ) myid = 1
[1762]	333
	334	END SUBROUTINE PMC_init_model
	335
	336
[1764]	337	!
	338	!-- Make module private variables available to palm
	339	!-- TO_DO: why can't they be available from the beginning, i.e. why do they
	340	!-- first have to be declared as different private variables?
	341	SUBROUTINE pmc_get_local_model_info( my_cpl_id, my_cpl_parent_id, cpl_name, &
	342	npe_x, npe_y, lower_left_x, &
	343	lower_left_y )
[1762]	344
[1764]	345	USE kinds
[1762]	346
[1764]	347	IMPLICIT NONE
[1762]	348
[1764]	349	CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: cpl_name
	350	INTEGER, INTENT(OUT), OPTIONAL :: my_cpl_id
	351	INTEGER, INTENT(OUT), OPTIONAL :: my_cpl_parent_id
	352	INTEGER, INTENT(OUT), OPTIONAL :: npe_x
	353	INTEGER, INTENT(OUT), OPTIONAL :: npe_y
	354	REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_x
	355	REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_y
[1762]	356
[1764]	357	!-- TO_DO: is the PRESENT clause really required here?
	358	IF ( PRESENT( my_cpl_id ) ) my_cpl_id = m_my_cpl_id
	359	IF ( PRESENT( my_cpl_parent_id ) ) my_cpl_parent_id = m_couplers(my_cpl_id)%parent_id
	360	IF ( PRESENT( cpl_name ) ) cpl_name = m_couplers(my_cpl_id)%name
	361	IF ( PRESENT( npe_x ) ) npe_x = m_couplers(my_cpl_id)%npe_x
	362	IF ( PRESENT( npe_y ) ) npe_y = m_couplers(my_cpl_id)%npe_y
	363	IF ( PRESENT( lower_left_x ) ) lower_left_x = m_couplers(my_cpl_id)%lower_left_x
	364	IF ( PRESENT( lower_left_y ) ) lower_left_y = m_couplers(my_cpl_id)%lower_left_y
[1762]	365
[1764]	366	END SUBROUTINE pmc_get_local_model_info
[1762]	367
[1764]	368
	369
	370	LOGICAL function pmc_is_rootmodel( )
	371
	372	IMPLICIT NONE
	373
	374	pmc_is_rootmodel = ( m_my_cpl_id == 1 )
	375
	376	END FUNCTION pmc_is_rootmodel
	377
	378
	379
	380
	381	!-- TO_DO: what does this comment mean?
[1762]	382	! Private SUBROUTINEs
[1764]	383	SUBROUTINE read_coupling_layout( nesting_mode, pmc_status )
[1762]	384
[1764]	385	IMPLICIT NONE
[1762]	386
[1764]	387	CHARACTER(LEN=7) :: nesting_mode
	388
	389	INTEGER, INTENT(INOUT) :: pmc_status
	390	INTEGER :: i, istat, iunit
	391
	392	TYPE(pmc_layout), DIMENSION(pmc_max_modell) :: domain_layouts
	393
	394
	395	NAMELIST /nestpar/ domain_layouts, nesting_mode
	396
	397	!
	398	!-- Initialize some coupling variables
	399	domain_layouts(1:pmc_max_modell)%id = -1
	400	m_nrofcpl = 0
[1762]	401	iunit = 345
	402
[1764]	403	pmc_status = pmc_status_ok
	404
	405	!
	406	!-- Open the NAMELIST-file and read the nesting layout
	407	CALL check_open( 11 )
	408	READ ( 11, nestpar, IOSTAT=istat )
	409
	410	IF ( istat < 0 ) THEN
	411	!
	412	!-- No nestpar-NAMELIST found
	413	pmc_status = pmc_no_namelist_found
	414	!
	415	!-- Set filepointer to the beginning of the file. Otherwise PE0 will later
	416	!-- be unable to read the inipar-NAMELIST
	417	REWIND ( 11 )
[1762]	418	RETURN
	419
[1764]	420	ELSEIF ( istat > 0 ) THEN
	421	!
	422	!-- Errors in reading nestpar-NAMELIST
	423	pmc_status = pmc_namelist_error
	424	RETURN
[1762]	425
[1764]	426	ENDIF
[1762]	427
[1764]	428	!
	429	!-- Output location message
	430	CALL location_message( 'initialize communicators for nesting', .FALSE. )
	431	!
	432	!-- Assign the layout to the internally used variable
	433	m_couplers = domain_layouts
[1762]	434
[1764]	435	!
	436	!-- Get the number of nested models given in the nestpar-NAMELIST
	437	DO i = 1, pmc_max_modell
[1762]	438
[1764]	439	IF ( m_couplers(i)%id /= -1 .AND. i <= pmc_max_modell ) THEN
	440	WRITE ( 0, '(A,A,1X,4I7,1X,2F10.2)' ) 'Set up Model ', &
	441	TRIM( m_couplers(i)%name ), m_couplers(i)%id, &
	442	m_couplers(i)%Parent_id, m_couplers(i)%npe_x, &
	443	m_couplers(i)%npe_y, m_couplers(i)%lower_left_x, &
	444	m_couplers(i)%lower_left_y
	445	ELSE
	446	!
	447	!-- When id=-1 is found for the first time, the list of domains is
	448	!-- finished (or latest after pmc_max_modell entries
	449	m_nrofcpl = i - 1
	450	EXIT
	451	ENDIF
	452
	453	ENDDO
	454
	455	END SUBROUTINE read_coupling_layout
	456
	457	#endif
	458	END MODULE pmc_handle_communicator

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |