Home

Context Navigation

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

Last change on this file since 1762 was 1762, checked in by hellstea, 9 years ago
Introduction of nested domain system
Property svn:keywords set to `Id`
File size: 12.4 KB

Rev	Line
[1762]	1	MODULE PMC_handle_communicator
	2
	3
	4	!--------------------------------------------------------------------------------!
	5	! This file is part of PALM.
	6	!
	7	! PALM is free software: you can redistribute it and/or modify it under the terms
	8	! of the GNU General Public License as published by the Free Software Foundation,
	9	! either version 3 of the License, or (at your option) any later version.
	10	!
	11	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
	12	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
	13	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
	14	!
	15	! You should have received a copy of the GNU General Public License along with
	16	! PALM. If not, see <http://www.gnu.org/licenses/>.
	17	!
	18	! Copyright 1997-2015 Leibniz Universitaet Hannover
	19	!--------------------------------------------------------------------------------!
	20	!
	21	! Current revisions:
	22	! ------------------
	23	!
	24	! Former revisions:
	25	! -----------------
	26	! $Id: pmc_handle_communicator.f90 1762 2016-02-25 12:31:13Z hellstea $
	27	!
	28	! Intoduction of the pure FORTRAN Palm Model Coupler (PMC) 12.11.2015 K. Ketelsen
	29	!
	30	! Description:
	31	! ------------
	32	!
	33	! Handle MPI Communicator in Palm Model Coupler
	34	!------------------------------------------------------------------------------!
	35
	36	USE mpi
	37	USE pmc_general, &
	38	ONLY: PMC_STATUS_OK, PMC_STATUS_ERROR, PMC_MAX_MODELL
	39
	40	IMPLICIT none
	41
	42	! Define Types
	43
	44	type PMC_layout
	45	INTEGER :: comm_parent
	46	INTEGER :: comm_cpl
	47	INTEGER :: Id
	48	INTEGER :: Parent_id
	49
	50	INTEGER :: npe_x
	51	INTEGER :: npe_y
	52
	53	REAL(kind=8) :: lower_left_x
	54	REAL(kind=8) :: lower_left_y
	55
	56	CHARACTER(len=32) :: name
	57	END type PMC_layout
	58
	59	! return status
	60	PUBLIC PMC_STATUS_OK, PMC_STATUS_ERROR
	61	INTEGER,parameter,PUBLIC :: PMC_ERROR_NPES = 1 ! illegal Number of PEs
	62	INTEGER,parameter,PUBLIC :: PMC_ERROR_MPI = 2 ! MPI Error
	63	INTEGER,parameter,PUBLIC :: PMC_ERRO_NOF = 3 ! No couple layout file found
	64
	65	! Coupler Setup
	66
	67	INTEGER :: m_my_CPL_id !Coupler id of this model
	68	INTEGER :: m_Parent_id !Coupler id of parent of this model
	69	INTEGER :: m_NrOfCpl !Number of Coupler in layout file
	70	type(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers !Information of all coupler
	71
	72	! MPI settings
	73
	74	INTEGER,PUBLIC :: m_model_comm !Communicator of this model
	75	INTEGER,PUBLIC :: m_to_server_comm !Communicator to the server
	76	INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm !Communicator to the client(s)
	77	INTEGER,PUBLIC :: m_world_rank
	78	INTEGER :: m_world_npes
	79	INTEGER,PUBLIC :: m_model_rank
	80	INTEGER,PUBLIC :: m_model_npes
	81	INTEGER :: m_server_remote_size !Number of Server PE's
	82
	83	PUBLIC m_to_client_comm
	84
	85	!Indicates this PE is server for Cleint NR
	86
	87	INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
	88
	89	!INTERFACE Section
	90
	91	INTERFACE PMC_is_RootModel
	92	MODULE PROCEDURE PMC_is_RootModel
	93	END INTERFACE PMC_is_RootModel
	94
	95	INTERFACE PMC_get_local_model_info
	96	MODULE PROCEDURE PMC_get_local_model_info
	97	END INTERFACE PMC_get_local_model_info
	98
	99	PUBLIC PMC_init_model,PMC_get_local_model_info, PMC_is_RootModel
	100	CONTAINS
	101
	102	SUBROUTINE PMC_init_model (comm, PMC_status)
	103	IMPLICIT none
	104	INTEGER,INTENT(OUT) :: comm
	105	INTEGER,INTENT(OUT) :: PMC_status
	106
	107	!-- local declarations
	108	INTEGER :: i,istat, ierr
	109	INTEGER,DIMENSION(PMC_MAX_MODELL+1) :: start_PE
	110	INTEGER :: m_my_CPL_rank
	111	INTEGER :: tag, ClientCount
	112	INTEGER,DIMENSION(PMC_MAX_MODELL) :: activeServer !I am active server for this client ID
	113
	114	PMC_status = PMC_STATUS_OK
	115	comm = -1
	116	m_my_CPL_id = -1
	117	ClientCount = 0
	118	activeServer = -1
	119	start_PE(:) = 0
	120
	121	CALL MPI_Comm_rank (MPI_COMM_WORLD, m_world_rank, istat)
	122	CALL MPI_Comm_size (MPI_COMM_WORLD, m_world_npes, istat)
	123
	124	if(m_world_rank == 0) then ! only PE 0 of root model reads
	125
	126	CALL read_coupling_layout (PMC_status)
	127
	128	IF (PMC_status /= PMC_ERRO_NOF ) THEN
	129	! Compute Start PE of every model
	130	start_PE(1) = 0
	131	do i=2,m_NrOfCpl+1
	132	start_pe(i) = start_PE(i-1) + m_couplers(i-1)%npe_x*m_couplers(i-1)%npe_y
	133	END do
	134	if(start_pe(m_NrOfCpl+1) /= m_world_npes) then
	135	if(m_world_rank == 0) then
	136	write(0,*) 'PMC ERROR: Coupler Setup Not equal Nr. MPI procs ',start_pe(m_NrOfCpl+1),m_world_npes
	137	END if
	138	CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
	139	END if
	140	END IF
	141	END if
	142
	143	CALL MPI_Bcast (PMC_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	144	IF (PMC_status == PMC_ERRO_NOF ) THEN
	145	if(m_world_rank == 0) write(0,*) 'PMC ERROR: file PMC_couple_layout not found'
	146	CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
	147	END IF
	148
	149	CALL MPI_Bcast (m_NrOfCpl, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	150	CALL MPI_Bcast (start_PE, m_NrOfCpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	151
	152	! Broadcast coupling layout
	153
	154	do i=1,m_NrOfCpl
	155	CALL MPI_Bcast (m_couplers(i)%name, len(m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat)
	156	CALL MPI_Bcast (m_couplers(i)%id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	157	CALL MPI_Bcast (m_couplers(i)%Parent_id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	158	CALL MPI_Bcast (m_couplers(i)%npe_x, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	159	CALL MPI_Bcast (m_couplers(i)%npe_y, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	160	CALL MPI_Bcast (m_couplers(i)%lower_left_x, 1, MPI_REAL8, 0, MPI_COMM_WORLD, istat)
	161	CALL MPI_Bcast (m_couplers(i)%lower_left_y, 1, MPI_REAL8, 0, MPI_COMM_WORLD, istat)
	162	END do
	163
	164	! Assign global MPI processes to individual models by setting the couple id
	165
	166	do i=1,m_NrOfCpl
	167	if(m_world_rank >= start_PE(i) .and. m_world_rank < start_PE(i+1) ) then
	168	m_my_CPL_id = i
	169	EXIT
	170	END if
	171	END do
	172	m_my_CPL_rank = m_world_rank-start_PE(i)
	173
	174	! MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach)
	175	! The communictors for the individual models a created by MPI_Comm_split
	176	! The color of the model is represented by the Coupler id
	177
	178	CALL MPI_Comm_split (MPI_COMM_WORLD, m_my_CPL_id, m_my_CPL_rank, comm, istat)
	179	if(istat /= MPI_SUCCESS) then
	180	if(m_world_rank == 0) write(0,*) 'PMC: Error in MPI_Comm_split '
	181	CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
	182	END if
	183
	184	! Get size and rank of the model running on THIS PE
	185
	186	CALL MPI_Comm_rank (comm, m_model_rank, istat)
	187	CALL MPI_Comm_size (comm, m_model_npes, istat)
	188
	189	! Pe 0 brodcasts the Parent ID and Id of every model
	190
	191	do i=1,m_NrOfCpl
	192	CALL MPI_Bcast (m_couplers(i)%Parent_Id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	193	CALL MPI_Bcast (m_couplers(i)%Id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
	194	END do
	195
	196	m_model_comm = comm
	197
	198	! create Intercommunicator to server and clients
	199	! MPI_Intercomm_create creates an intercommunicator between 2 groups of different colors
	200	! The grouping with done prior with MPI_Comm_split
	201
	202	do i=2,m_NrOfCpl
	203	if(m_couplers(i)%Parent_Id == m_my_CPL_id) then !collect server PEs
	204	tag = 500+i
	205	!kk write(0,'(a,6i4)') 'server Part ',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag,start_pe(i)
	206	CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(i), &
	207	tag, m_to_client_comm(i), istat)
	208
	209	clientCount = clientCount+1
	210	activeServer(i) = 1
	211	else if (i == m_my_CPL_id) then !collect client PEs
	212	tag = 500+i
	213	CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(m_couplers(i)%Parent_Id), &
	214	tag, m_to_server_comm, istat)
	215	!kk write(0,'(a,7i4)') 'client Part',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag, start_pe(m_couplers(i)%Parent_Id)
	216	END if
	217	if(istat /= MPI_SUCCESS) then
	218	if(m_world_rank == 0) write(0,*) 'PMC: Error in Coupler Setup '
	219	CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
	220	END if
	221	END do
	222
	223	! If I am server, count nr. of clients
	224	! Although this loop is symetric on all processes, the active server flag is valid only on the individual PE.
	225
	226	ALLOCATE(PMC_Server_for_Client(ClientCount+1))
	227	ClientCount = 0
	228	do i=2,m_NrOfCpl
	229	if(activeServer(i) == 1) then
	230	ClientCount = clientCount+1
	231	PMC_Server_for_Client(ClientCount) = i
	232	END if
	233	END do
	234	PMC_Server_for_Client(ClientCount+1) = -1
	235
	236	! Get size of the server model
	237
	238	if(m_my_CPL_id > 1) then
	239	CALL MPI_Comm_remote_size (m_to_server_comm, m_server_remote_size, istat)
	240	else
	241	m_server_remote_size = -1 ! root model does not have a server
	242	END if
	243
	244	! write(0,'(a,a,1x,9i7)') 'New Communicator ',trim(m_couplers(m_my_CPL_id)%name),m_world_npes,m_model_npes,m_world_rank, &
	245	! m_model_rank,m_my_CPL_id,m_my_CPL_rank,m_server_remote_size,ClientCount
	246
	247	return
	248	END SUBROUTINE PMC_init_model
	249
	250	! Make module private variables available to palm
	251
	252	SUBROUTINE PMC_get_local_model_info (my_CPL_id, CPL_name, npe_x, npe_y, lower_left_x, lower_left_y)
	253	IMPLICIT none
	254	INTEGER,INTENT(OUT),optional :: my_CPL_id
	255	CHARACTER(len=*),INTENT(OUT),optional :: CPL_name
	256	INTEGER,INTENT(OUT),optional :: npe_x
	257	INTEGER,INTENT(OUT),optional :: npe_y
	258	REAL(kind=8),INTENT(OUT),optional :: lower_left_x
	259	REAL(kind=8),INTENT(OUT),optional :: lower_left_y
	260
	261	if(present(my_CPL_id)) my_CPL_id = m_my_CPL_id
	262	if(present(CPL_name)) CPL_name = m_couplers(my_CPL_id)%name
	263	if(present(npe_x)) npe_x = m_couplers(my_CPL_id)%npe_x
	264	if(present(npe_y)) npe_y = m_couplers(my_CPL_id)%npe_y
	265	if(present(lower_left_x)) lower_left_x = m_couplers(my_CPL_id)%lower_left_x
	266	if(present(lower_left_y)) lower_left_y = m_couplers(my_CPL_id)%lower_left_y
	267
	268	return
	269	END SUBROUTINE PMC_get_local_model_info
	270
	271	LOGICAL function PMC_is_RootModel ()
	272	IMPLICIT none
	273
	274	PMC_is_RootModel = (m_my_CPL_id == 1)
	275
	276	return
	277	END function PMC_is_RootModel
	278
	279	! Private SUBROUTINEs
	280
	281	SUBROUTINE read_coupling_layout (PMC_status)
	282	IMPLICIT none
	283	INTEGER,INTENT(INOUT) :: PMC_status
	284	INTEGER :: i,iunit,istat
	285	CHARACTER(LEN=*), PARAMETER :: fname = 'PMC_couple_layout'
	286	LOGICAL :: lex
	287
	288	m_NrOfCpl = 0
	289	iunit = 345
	290
	291	PMC_STATUS = PMC_STATUS_OK
	292	INQUIRE(file=TRIM(fname), exist=lex)
	293	IF (.NOT. lex) THEN
	294	PMC_status = PMC_ERRO_NOF
	295	RETURN
	296	END IF
	297
	298	open(iunit,file=TRIM(fname),status='OLD')
	299	do i=1,PMC_MAX_MODELL
	300	read(iunit,*,iostat=istat) m_couplers(i)%name &
	301	, m_couplers(i)%id,m_couplers(i)%Parent_id &
	302	, m_couplers(i)%npe_x,m_couplers(i)%npe_y &
	303	, m_couplers(i)%lower_left_x, m_couplers(i)%lower_left_y
	304	if(istat /= 0) EXIT
	305
	306	write(0,'(a,a,1x,4i7,1x,2F10.2)') 'Set up Model ',trim(m_couplers(i)%name),m_couplers(i)%id,m_couplers(i)%Parent_id, &
	307	m_couplers(i)%npe_x,m_couplers(i)%npe_y, &
	308	m_couplers(i)%lower_left_x,m_couplers(i)%lower_left_y
	309
	310	m_NrOfCpl = i
	311	END do
	312	close(iunit)
	313
	314	return
	315	END SUBROUTINE read_coupling_layout
	316
	317	END MODULE PMC_handle_communicator

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |