Home

Context Navigation

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

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

Line
1	MODULE PMC_handle_communicator
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	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_handle_communicator.f90 1765 2016-02-28 13:30:40Z hoffmann $
27	!
28	! 1764 2016-02-28 12:45:19Z raasch
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
35	!
36	! 1762 2016-02-25 12:31:13Z hellstea
37	! Initial revision by K. Ketelsen
38	!
39	! Description:
40	! ------------
41	! Handle MPI communicator in PALM model coupler
42	!------------------------------------------------------------------------------!
43
44	#if defined( __parallel )
45	USE kinds
46
47	#if defined( __lc )
48	USE MPI
49	#else
50	INCLUDE "mpif.h"
51	#endif
52
53	USE pmc_general, &
54	ONLY: pmc_status_ok, pmc_status_error, pmc_max_modell
55
56	IMPLICIT NONE
57
58	TYPE pmc_layout
59
60	CHARACTER(len=32) :: name
61
62	INTEGER :: id
63	INTEGER :: parent_id
64	INTEGER :: npe_x
65	INTEGER :: npe_y
66
67	REAL(wp) :: lower_left_x
68	REAL(wp) :: lower_left_y
69
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
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
83	TYPE(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers !Information of all coupler
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
102	INTERFACE pmc_is_rootmodel
103	MODULE PROCEDURE pmc_is_rootmodel
104	END INTERFACE pmc_is_rootmodel
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
110	PUBLIC pmc_get_local_model_info, pmc_init_model, pmc_is_rootmodel
111
112	CONTAINS
113
114	SUBROUTINE pmc_init_model( comm, nesting_mode, pmc_status )
115
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
136	comm = -1
137	m_my_cpl_id = -1
138	clientcount = 0
139	activeserver = -1
140	start_pe(:) = 0
141
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
147
148	CALL read_coupling_layout( nesting_mode, pmc_status )
149
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
160
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
175
176	ENDIF
177
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 )
184
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
190
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
200
201	ENDIF
202
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)
205
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
217
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)
228
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
242
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 )
247
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
256
257	!
258	!-- TO_DO: describe what is happening here, and why
259	m_model_comm = comm
260
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
267
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
277
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
287
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
295
296	ENDDO
297
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) )
303
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
313
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
333
334	END SUBROUTINE PMC_init_model
335
336
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 )
344
345	USE kinds
346
347	IMPLICIT NONE
348
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
356
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
365
366	END SUBROUTINE pmc_get_local_model_info
367
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?
382	! Private SUBROUTINEs
383	SUBROUTINE read_coupling_layout( nesting_mode, pmc_status )
384
385	IMPLICIT NONE
386
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
401	iunit = 345
402
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 )
418	RETURN
419
420	ELSEIF ( istat > 0 ) THEN
421	!
422	!-- Errors in reading nestpar-NAMELIST
423	pmc_status = pmc_namelist_error
424	RETURN
425
426	ENDIF
427
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
434
435	!
436	!-- Get the number of nested models given in the nestpar-NAMELIST
437	DO i = 1, pmc_max_modell
438
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 |