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, 8 years ago
Introduction of nested domain system
Property svn:keywords set to `Id`
File size: 12.4 KB

Line
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 |