Home

Context Navigation

source: palm/trunk/SOURCE/pmc_handle_communicator_mod.f90 @ 1900

Last change on this file since 1900 was 1900, checked in by raasch, 8 years ago
re-formatting of remaining pmc routines
Property svn:keywords set to `Id`
File size: 16.7 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-2016 Leibniz Universitaet Hannover
18	!--------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	! re-formatting to match PALM style
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: pmc_handle_communicator_mod.f90 1900 2016-05-04 15:27:53Z raasch $
27	!
28	! 1882 2016-04-20 15:24:46Z hellstea
29	! MPI_BCAST-calls to broadcast nesting_mode and nesting_datatransfer_mode
30	! are moved out from the DO i = 1, m_ncpl loop.
31	!
32	! 1850 2016-04-08 13:29:27Z maronga
33	! Module renamed
34	!
35	! 1808 2016-04-05 19:44:00Z raasch
36	! MPI module used by default on all machines
37	!
38	! 1797 2016-03-21 16:50:28Z raasch
39	! introduction of different datatransfer modes,
40	! export of comm_world_nesting
41	!
42	! 1791 2016-03-11 10:41:25Z raasch
43	! m_nrofcpl renamed m_ncpl,
44	! pmc_get_local_model_info renamed pmc_get_model_info, some keywords also
45	! renamed and some added,
46	! debug write-statements commented out
47	!
48	! 1786 2016-03-08 05:49:27Z raasch
49	! Bugfix: nesting_mode is broadcast now
50	!
51	! 1779 2016-03-03 08:01:28Z raasch
52	! only the total number of PEs is given in the nestpar-NAMELIST,
53	! additional comments included
54	!
55	! 1764 2016-02-28 12:45:19Z raasch
56	! pmc_layout type: comm_cpl and comm_parent removed, character "name" moved at
57	! the beginning of the variable list,
58	! domain layout is read with new NAMELIST nestpar from standard file PARIN,
59	! MPI-datatype REAL8 replaced by REAL, kind=8 replaced by wp,
60	! variable domain_layouts instead of m_couplers introduced for this NAMELIST,
61	! general format changed to PALM style
62	!
63	! 1762 2016-02-25 12:31:13Z hellstea
64	! Initial revision by K. Ketelsen
65	!
66	! Description:
67	! ------------
68	! Handle MPI communicator in PALM model coupler
69	!------------------------------------------------------------------------------!
70
71	#if defined( __parallel )
72	USE kinds
73
74	#if defined( __mpifh )
75	INCLUDE "mpif.h"
76	#else
77	USE MPI
78	#endif
79
80	USE pmc_general, &
81	ONLY: pmc_status_ok, pmc_status_error, pmc_max_models
82
83	IMPLICIT NONE
84
85	TYPE pmc_layout
86
87	CHARACTER(LEN=32) :: name
88
89	INTEGER :: id !<
90	INTEGER :: parent_id !<
91	INTEGER :: npe_total !<
92
93	REAL(wp) :: lower_left_x !<
94	REAL(wp) :: lower_left_y !<
95
96	END TYPE pmc_layout
97
98	PUBLIC pmc_status_ok, pmc_status_error
99
100	INTEGER, PARAMETER, PUBLIC :: pmc_error_npes = 1 !< illegal number of PEs
101	INTEGER, PARAMETER, PUBLIC :: pmc_namelist_error = 2 !< error(s) in nestpar namelist
102	INTEGER, PARAMETER, PUBLIC :: pmc_no_namelist_found = 3 !< no couple layout namelist found
103
104	INTEGER :: m_world_comm !< global nesting communicator
105	INTEGER :: m_my_cpl_id !< coupler id of this model
106	INTEGER :: m_parent_id !< coupler id of parent of this model
107	INTEGER :: m_ncpl !< number of couplers given in nestpar namelist
108
109	TYPE(pmc_layout), DIMENSION(pmc_max_models) :: m_couplers !< information of all couplers
110
111	INTEGER, PUBLIC :: m_model_comm !< communicator of this model
112	INTEGER, PUBLIC :: m_to_server_comm !< communicator to the server
113	INTEGER, PUBLIC :: m_world_rank !<
114	INTEGER :: m_world_npes !<
115	INTEGER, PUBLIC :: m_model_rank !<
116	INTEGER, PUBLIC :: m_model_npes !<
117	INTEGER :: m_server_remote_size !< number of server PEs
118
119	INTEGER, DIMENSION(pmc_max_models), PUBLIC :: m_to_client_comm !< communicator to the client(s)
120	INTEGER, DIMENSION(:), POINTER, PUBLIC :: pmc_server_for_client !<
121
122
123	INTERFACE pmc_is_rootmodel
124	MODULE PROCEDURE pmc_is_rootmodel
125	END INTERFACE pmc_is_rootmodel
126
127	INTERFACE pmc_get_model_info
128	MODULE PROCEDURE pmc_get_model_info
129	END INTERFACE pmc_get_model_info
130
131	PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel
132
133	CONTAINS
134
135	SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode, &
136	pmc_status )
137
138	USE control_parameters, &
139	ONLY: message_string
140
141	USE pegrid, &
142	ONLY: myid
143
144	IMPLICIT NONE
145
146	CHARACTER(LEN=7), INTENT(OUT) :: nesting_mode !<
147	CHARACTER(LEN=7), INTENT(OUT) :: nesting_datatransfer_mode !<
148
149	INTEGER, INTENT(OUT) :: comm !<
150	INTEGER, INTENT(OUT) :: pmc_status !<
151
152	INTEGER :: clientcount !<
153	INTEGER :: i !<
154	INTEGER :: ierr !<
155	INTEGER :: istat !<
156	INTEGER :: m_my_cpl_rank !<
157	INTEGER :: tag !<
158
159	INTEGER, DIMENSION(pmc_max_models) :: activeserver ! I am active server for this client ID
160	INTEGER, DIMENSION(pmc_max_models+1) :: start_pe
161
162	pmc_status = pmc_status_ok
163	comm = -1
164	m_world_comm = MPI_COMM_WORLD
165	m_my_cpl_id = -1
166	clientcount = 0
167	activeserver = -1
168	start_pe(:) = 0
169
170	CALL MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat )
171	CALL MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat )
172	!
173	!-- Only PE 0 of root model reads
174	IF ( m_world_rank == 0 ) THEN
175
176	CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode, &
177	pmc_status )
178
179	IF ( pmc_status /= pmc_no_namelist_found .AND. &
180	pmc_status /= pmc_namelist_error ) &
181	THEN
182	!
183	!-- Calculate start PE of every model
184	start_pe(1) = 0
185	DO i = 2, m_ncpl+1
186	start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
187	ENDDO
188
189	!
190	!-- The number of cores provided with the run must be the same as the
191	!-- total sum of cores required by all nest domains
192	IF ( start_pe(m_ncpl+1) /= m_world_npes ) THEN
193	WRITE ( message_string, '(A,I6,A,I6,A)' ) &
194	'nesting-setup requires more MPI procs (', &
195	start_pe(m_ncpl+1), ') than provided (', &
196	m_world_npes,')'
197	CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
198	ENDIF
199
200	ENDIF
201
202	ENDIF
203	!
204	!-- Broadcast the read status. This synchronises all other PEs with PE 0 of
205	!-- the root model. Without synchronisation, they would not behave in the
206	!-- correct way (e.g. they would not return in case of a missing NAMELIST)
207	CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
208
209	IF ( pmc_status == pmc_no_namelist_found ) THEN
210	!
211	!-- Not a nested run; return the MPI_WORLD communicator
212	comm = MPI_COMM_WORLD
213	RETURN
214
215	ELSEIF ( pmc_status == pmc_namelist_error ) THEN
216	!
217	!-- Only the root model gives the error message. Others are aborted by the
218	!-- message-routine with MPI_ABORT. Must be done this way since myid and
219	!-- comm2d have not yet been assigned at this point.
220	IF ( m_world_rank == 0 ) THEN
221	message_string = 'errors in \$nestpar'
222	CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 )
223	ENDIF
224
225	ENDIF
226
227	CALL MPI_BCAST( m_ncpl, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
228	CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
229
230	!
231	!-- Broadcast coupling layout
232	DO i = 1, m_ncpl
233	CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ), &
234	MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
235	CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, &
236	MPI_COMM_WORLD, istat )
237	CALL MPI_BCAST( m_couplers(i)%Parent_id, 1, MPI_INTEGER, 0, &
238	MPI_COMM_WORLD, istat )
239	CALL MPI_BCAST( m_couplers(i)%npe_total, 1, MPI_INTEGER, 0, &
240	MPI_COMM_WORLD, istat )
241	CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL, 0, &
242	MPI_COMM_WORLD, istat )
243	CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL, 0, &
244	MPI_COMM_WORLD, istat )
245	ENDDO
246	CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0, &
247	MPI_COMM_WORLD, istat )
248	CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), &
249	MPI_CHARACTER, 0, MPI_COMM_WORLD, istat )
250
251	!
252	!-- Assign global MPI processes to individual models by setting the couple id
253	DO i = 1, m_ncpl
254	IF ( m_world_rank >= start_pe(i) .AND. m_world_rank < start_pe(i+1) ) &
255	THEN
256	m_my_cpl_id = i
257	EXIT
258	ENDIF
259	ENDDO
260	m_my_cpl_rank = m_world_rank - start_pe(i)
261
262	!
263	!-- MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach).
264	!-- The communictors for the individual models as created by MPI_COMM_SPLIT.
265	!-- The color of the model is represented by the coupler id
266	CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm, &
267	istat )
268	!
269	!-- Get size and rank of the model running on this PE
270	CALL MPI_COMM_RANK( comm, m_model_rank, istat )
271	CALL MPI_COMM_SIZE( comm, m_model_npes, istat )
272
273	!
274	!-- Broadcast (from PE 0) the parent id and id of every model
275	DO i = 1, m_ncpl
276	CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0, &
277	MPI_COMM_WORLD, istat )
278	CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, &
279	MPI_COMM_WORLD, istat )
280	ENDDO
281
282	!
283	!-- Save the current model communicator for pmc internal use
284	m_model_comm = comm
285
286	!
287	!-- Create intercommunicator between server and clients.
288	!-- MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of
289	!-- different colors.
290	!-- The grouping was done above with MPI_COMM_SPLIT
291	DO i = 2, m_ncpl
292
293	IF ( m_couplers(i)%parent_id == m_my_cpl_id ) THEN
294	!
295	!-- Collect server PEs.
296	!-- Every model exept the root model has a parent model which acts as
297	!-- server model. Create an intercommunicator to connect current PE to
298	!-- all client PEs
299	tag = 500 + i
300	CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i), &
301	tag, m_to_client_comm(i), istat)
302	clientcount = clientcount + 1
303	activeserver(i) = 1
304
305	ELSEIF ( i == m_my_cpl_id) THEN
306	!
307	!-- Collect client PEs.
308	!-- Every model exept the root model has a paremt model which acts as
309	!-- server model. Create an intercommunicator to connect current PE to
310	!-- all server PEs
311	tag = 500 + i
312	CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, &
313	start_pe(m_couplers(i)%parent_id), &
314	tag, m_to_server_comm, istat )
315	ENDIF
316
317	ENDDO
318
319	!
320	!-- If I am server, count the number of clients that I have
321	!-- Although this loop is symmetric on all processes, the "activeserver" flag
322	!-- is true (==1) on the respective individual PE only.
323	ALLOCATE( pmc_server_for_client(clientcount+1) )
324
325	clientcount = 0
326	DO i = 2, m_ncpl
327	IF ( activeserver(i) == 1 ) THEN
328	clientcount = clientcount + 1
329	pmc_server_for_client(clientcount) = i
330	ENDIF
331	ENDDO
332	!
333	!-- Get the size of the server model
334	IF ( m_my_cpl_id > 1 ) THEN
335	CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size, &
336	istat)
337	ELSE
338	!
339	!-- The root model does not have a server
340	m_server_remote_size = -1
341	ENDIF
342	!
343	!-- Set myid to non-tero value except for the root domain. This is a setting
344	!-- for the message routine which is called at the end of pmci_init. That
345	!-- routine outputs messages for myid = 0, only. However, myid has not been
346	!-- assigened so far, so that all PEs of the root model would output a
347	!-- message. To avoid this, set myid to some other value except for PE0 of the
348	!-- root domain.
349	IF ( m_world_rank /= 0 ) myid = 1
350
351	END SUBROUTINE PMC_init_model
352
353
354
355	SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name, &
356	cpl_parent_id, lower_left_x, lower_left_y, &
357	ncpl, npe_total, request_for_cpl_id )
358	!
359	!-- Provide module private variables of the pmc for PALM
360
361	USE kinds
362
363	IMPLICIT NONE
364
365	CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: cpl_name !<
366
367	INTEGER, INTENT(IN), OPTIONAL :: request_for_cpl_id !<
368
369	INTEGER, INTENT(OUT), OPTIONAL :: comm_world_nesting !<
370	INTEGER, INTENT(OUT), OPTIONAL :: cpl_id !<
371	INTEGER, INTENT(OUT), OPTIONAL :: cpl_parent_id !<
372	INTEGER, INTENT(OUT), OPTIONAL :: ncpl !<
373	INTEGER, INTENT(OUT), OPTIONAL :: npe_total !<
374
375	INTEGER :: requested_cpl_id !<
376
377	REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_x !<
378	REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_y !<
379
380	!
381	!-- Set the requested coupler id
382	IF ( PRESENT( request_for_cpl_id ) ) THEN
383	requested_cpl_id = request_for_cpl_id
384	!
385	!-- Check for allowed range of values
386	IF ( requested_cpl_id < 1 .OR. requested_cpl_id > m_ncpl ) RETURN
387	ELSE
388	requested_cpl_id = m_my_cpl_id
389	ENDIF
390
391	!
392	!-- Return the requested information
393	IF ( PRESENT( comm_world_nesting ) ) THEN
394	comm_world_nesting = m_world_comm
395	ENDIF
396	IF ( PRESENT( cpl_id ) ) THEN
397	cpl_id = requested_cpl_id
398	ENDIF
399	IF ( PRESENT( cpl_parent_id ) ) THEN
400	cpl_parent_id = m_couplers(requested_cpl_id)%parent_id
401	ENDIF
402	IF ( PRESENT( cpl_name ) ) THEN
403	cpl_name = m_couplers(requested_cpl_id)%name
404	ENDIF
405	IF ( PRESENT( ncpl ) ) THEN
406	ncpl = m_ncpl
407	ENDIF
408	IF ( PRESENT( npe_total ) ) THEN
409	npe_total = m_couplers(requested_cpl_id)%npe_total
410	ENDIF
411	IF ( PRESENT( lower_left_x ) ) THEN
412	lower_left_x = m_couplers(requested_cpl_id)%lower_left_x
413	ENDIF
414	IF ( PRESENT( lower_left_y ) ) THEN
415	lower_left_y = m_couplers(requested_cpl_id)%lower_left_y
416	ENDIF
417
418	END SUBROUTINE pmc_get_model_info
419
420
421
422	LOGICAL function pmc_is_rootmodel( )
423
424	IMPLICIT NONE
425
426	pmc_is_rootmodel = ( m_my_cpl_id == 1 )
427
428	END FUNCTION pmc_is_rootmodel
429
430
431
432	SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode, &
433	pmc_status )
434
435	IMPLICIT NONE
436
437	CHARACTER(LEN=7), INTENT(INOUT) :: nesting_mode
438	CHARACTER(LEN=7), INTENT(INOUT) :: nesting_datatransfer_mode
439
440	INTEGER, INTENT(INOUT) :: pmc_status
441	INTEGER :: i, istat
442
443	TYPE(pmc_layout), DIMENSION(pmc_max_models) :: domain_layouts
444
445	!-- TO_DO: include anterp_relax_length_? into nestpar and communicate them.
446	NAMELIST /nestpar/ domain_layouts, nesting_datatransfer_mode, nesting_mode
447
448	!
449	!-- Initialize some coupling variables
450	domain_layouts(1:pmc_max_models)%id = -1
451	m_ncpl = 0
452
453	pmc_status = pmc_status_ok
454
455	!
456	!-- Open the NAMELIST-file and read the nesting layout
457	CALL check_open( 11 )
458	READ ( 11, nestpar, IOSTAT=istat )
459
460	IF ( istat < 0 ) THEN
461	!
462	!-- No nestpar-NAMELIST found
463	pmc_status = pmc_no_namelist_found
464	!
465	!-- Set filepointer to the beginning of the file. Otherwise PE0 will later
466	!-- be unable to read the inipar-NAMELIST
467	REWIND ( 11 )
468	RETURN
469
470	ELSEIF ( istat > 0 ) THEN
471	!
472	!-- Errors in reading nestpar-NAMELIST
473	pmc_status = pmc_namelist_error
474	RETURN
475
476	ENDIF
477
478	!
479	!-- Output location message
480	CALL location_message( 'initialize communicators for nesting', .FALSE. )
481	!
482	!-- Assign the layout to the internally used variable
483	m_couplers = domain_layouts
484
485	!
486	!-- Get the number of nested models given in the nestpar-NAMELIST
487	DO i = 1, pmc_max_models
488	!
489	!-- When id=-1 is found for the first time, the list of domains is finished
490	IF ( m_couplers(i)%id == -1 .OR. i == pmc_max_models ) THEN
491	IF ( m_couplers(i)%id == -1 ) THEN
492	m_ncpl = i - 1
493	EXIT
494	ELSE
495	m_ncpl = pmc_max_models
496	ENDIF
497	ENDIF
498
499	ENDDO
500
501	END SUBROUTINE read_coupling_layout
502
503	#endif
504	END MODULE pmc_handle_communicator

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |