1 | !> @file pmc_handle_communicator_mod.f90 |
---|
2 | !--------------------------------------------------------------------------------------------------! |
---|
3 | ! This file is part of the PALM model system. |
---|
4 | ! |
---|
5 | ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General |
---|
6 | ! Public License as published by the Free Software Foundation, either version 3 of the License, or |
---|
7 | ! (at your option) any later version. |
---|
8 | ! |
---|
9 | ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the |
---|
10 | ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General |
---|
11 | ! Public License for more details. |
---|
12 | ! |
---|
13 | ! You should have received a copy of the GNU General Public License along with PALM. If not, see |
---|
14 | ! <http://www.gnu.org/licenses/>. |
---|
15 | ! |
---|
16 | ! Copyright 1997-2021 Leibniz Universitaet Hannover |
---|
17 | !--------------------------------------------------------------------------------------------------! |
---|
18 | ! |
---|
19 | ! |
---|
20 | ! Current revisions: |
---|
21 | ! ----------------- |
---|
22 | ! |
---|
23 | ! |
---|
24 | ! Former revisions: |
---|
25 | ! ----------------- |
---|
26 | ! $Id: pmc_handle_communicator_mod.f90 4883 2021-02-23 16:32:41Z raasch $ |
---|
27 | ! User switch for particle coupling added |
---|
28 | ! |
---|
29 | ! 4843 2021-01-15 15:22:11Z raasch |
---|
30 | ! local namelist parameter added to switch off the module although the respective module namelist |
---|
31 | ! appears in the namelist file |
---|
32 | ! |
---|
33 | ! 4828 2021-01-05 11:21:41Z Giersch |
---|
34 | ! Canopy-restricted anterpolation introduced. New namelist parameter anterpolation_starting_height |
---|
35 | ! introduced for controlling canopy-restricted anterpolation. |
---|
36 | ! |
---|
37 | ! 4650 2020-08-25 14:35:50Z raasch |
---|
38 | ! bugfix for r4649 |
---|
39 | ! |
---|
40 | ! 4649 2020-08-25 12:11:17Z raasch |
---|
41 | ! File re-formatted to follow the PALM coding standard |
---|
42 | ! |
---|
43 | ! |
---|
44 | ! 4629 2020-07-29 09:37:56Z raasch |
---|
45 | ! Support for MPI Fortran77 interface (mpif.h) removed |
---|
46 | ! |
---|
47 | ! 4360 2020-01-07 11:25:50Z suehring |
---|
48 | ! Corrected "Former revisions" section |
---|
49 | ! |
---|
50 | ! 3888 2019-04-12 09:18:10Z hellstea |
---|
51 | ! Missing MPI_BCAST of anterpolation_buffer_width added. |
---|
52 | ! |
---|
53 | ! 3885 2019-04-11 11:29:34Z kanani |
---|
54 | ! Changes related to global restructuring of location messages and introduction of additional debug |
---|
55 | ! messages |
---|
56 | ! |
---|
57 | ! 3819 2019-03-27 11:01:36Z hellstea |
---|
58 | ! Adjustable anterpolation buffer introduced on all nest boundaries, it is controlled by the new |
---|
59 | ! nesting_parameters parameter anterpolation_buffer_width. |
---|
60 | ! |
---|
61 | ! 3655 2019-01-07 16:51:22Z knoop |
---|
62 | ! nestpar renamed to nesting_parameters |
---|
63 | ! |
---|
64 | ! 1762 2016-02-25 12:31:13Z hellstea |
---|
65 | ! Initial revision by K. Ketelsen |
---|
66 | ! |
---|
67 | ! Description: |
---|
68 | ! ------------ |
---|
69 | ! Handle MPI communicator in PALM model coupler |
---|
70 | !--------------------------------------------------------------------------------------------------! |
---|
71 | MODULE PMC_handle_communicator |
---|
72 | #if defined( __parallel ) |
---|
73 | USE kinds |
---|
74 | |
---|
75 | USE MPI |
---|
76 | |
---|
77 | USE pmc_general, & |
---|
78 | ONLY: pmc_max_models, & |
---|
79 | pmc_status_error, & |
---|
80 | pmc_status_ok |
---|
81 | |
---|
82 | |
---|
83 | USE control_parameters, & |
---|
84 | ONLY: message_string |
---|
85 | |
---|
86 | IMPLICIT NONE |
---|
87 | |
---|
88 | ! |
---|
89 | !-- ATTENTION: Do not change the order of variable declarations in the following TYPE definition, |
---|
90 | !-- because the order must follow the order in which the layout data is given in the NAMELIST file. |
---|
91 | TYPE pmc_layout |
---|
92 | |
---|
93 | CHARACTER(LEN=32) :: name !< |
---|
94 | |
---|
95 | INTEGER :: id !< |
---|
96 | INTEGER :: parent_id !< |
---|
97 | INTEGER :: npe_total !< |
---|
98 | |
---|
99 | REAL(wp) :: lower_left_x !< |
---|
100 | REAL(wp) :: lower_left_y !< |
---|
101 | |
---|
102 | END TYPE pmc_layout |
---|
103 | |
---|
104 | PUBLIC pmc_status_ok, pmc_status_error !< |
---|
105 | |
---|
106 | INTEGER, PARAMETER, PUBLIC :: pmc_error_npes = 1 !< illegal number of processes |
---|
107 | INTEGER, PARAMETER, PUBLIC :: pmc_namelist_error = 2 !< error(s) in nesting_parameters namelist |
---|
108 | INTEGER, PARAMETER, PUBLIC :: pmc_no_namelist_found = 3 !< no couple layout namelist found |
---|
109 | |
---|
110 | INTEGER :: m_my_cpl_id !< coupler id of this model |
---|
111 | INTEGER :: m_ncpl !< number of couplers given in nesting_parameters namelist |
---|
112 | INTEGER :: m_parent_id !< coupler id of parent of this model |
---|
113 | INTEGER :: m_world_comm !< global nesting communicator |
---|
114 | |
---|
115 | TYPE(pmc_layout), PUBLIC, DIMENSION(pmc_max_models) :: m_couplers !< information of all couplers |
---|
116 | |
---|
117 | INTEGER, PUBLIC :: m_model_comm !< communicator of this model |
---|
118 | INTEGER, PUBLIC :: m_model_npes !< |
---|
119 | INTEGER, PUBLIC :: m_model_rank !< |
---|
120 | INTEGER, PUBLIC :: m_to_parent_comm !< communicator to the parent |
---|
121 | INTEGER, PUBLIC :: m_world_rank !< |
---|
122 | INTEGER :: m_parent_remote_size !< number of processes in the parent model |
---|
123 | INTEGER :: m_world_npes !< |
---|
124 | INTEGER :: peer_comm !< peer_communicator for inter communicators |
---|
125 | |
---|
126 | INTEGER, DIMENSION(pmc_max_models), PUBLIC :: m_to_child_comm !< communicator to the child(ren) |
---|
127 | INTEGER, DIMENSION(:), POINTER, PUBLIC :: pmc_parent_for_child !< |
---|
128 | |
---|
129 | |
---|
130 | INTERFACE pmc_get_model_info |
---|
131 | MODULE PROCEDURE pmc_get_model_info |
---|
132 | END INTERFACE pmc_get_model_info |
---|
133 | |
---|
134 | INTERFACE pmc_is_rootmodel |
---|
135 | MODULE PROCEDURE pmc_is_rootmodel |
---|
136 | END INTERFACE pmc_is_rootmodel |
---|
137 | |
---|
138 | PUBLIC pmc_get_model_info, pmc_init_model, pmc_is_rootmodel !< |
---|
139 | |
---|
140 | |
---|
141 | |
---|
142 | CONTAINS |
---|
143 | |
---|
144 | |
---|
145 | !--------------------------------------------------------------------------------------------------! |
---|
146 | ! Description: |
---|
147 | ! ------------ |
---|
148 | !> @Todo: Missing subroutine description. |
---|
149 | !--------------------------------------------------------------------------------------------------! |
---|
150 | SUBROUTINE pmc_init_model( comm, nesting_datatransfer_mode, nesting_mode, & |
---|
151 | anterpolation_buffer_width, anterpolation_starting_height, & |
---|
152 | particle_coupling, pmc_status ) |
---|
153 | |
---|
154 | USE control_parameters, & |
---|
155 | ONLY: message_string |
---|
156 | |
---|
157 | USE pegrid, & |
---|
158 | ONLY: myid |
---|
159 | |
---|
160 | IMPLICIT NONE |
---|
161 | |
---|
162 | CHARACTER(LEN=7), INTENT(INOUT) :: nesting_datatransfer_mode !< |
---|
163 | CHARACTER(LEN=8), INTENT(INOUT) :: nesting_mode !< |
---|
164 | |
---|
165 | INTEGER, INTENT(INOUT) :: anterpolation_buffer_width !< Boundary buffer width for anterpolation |
---|
166 | INTEGER, INTENT(INOUT) :: comm !< |
---|
167 | INTEGER, INTENT(INOUT) :: pmc_status !< |
---|
168 | |
---|
169 | REAL(wp), INTENT(INOUT) :: anterpolation_starting_height !< steering parameter for canopy restricted anterpolation |
---|
170 | LOGICAL, INTENT(INOUT) :: particle_coupling !< switch for particle coupling (default .TRUE.) |
---|
171 | |
---|
172 | INTEGER :: childcount !< |
---|
173 | INTEGER :: i !< |
---|
174 | INTEGER :: ierr !< |
---|
175 | INTEGER :: istat !< |
---|
176 | INTEGER :: m_my_cpl_rank !< |
---|
177 | INTEGER :: tag !< |
---|
178 | |
---|
179 | INTEGER, DIMENSION(pmc_max_models) :: activeparent !< I am active parent for this child ID |
---|
180 | INTEGER, DIMENSION(pmc_max_models+1) :: start_pe !< |
---|
181 | |
---|
182 | pmc_status = pmc_status_ok |
---|
183 | comm = -1 |
---|
184 | m_world_comm = MPI_COMM_WORLD |
---|
185 | m_my_cpl_id = -1 |
---|
186 | childcount = 0 |
---|
187 | activeparent = -1 |
---|
188 | start_pe(:) = 0 |
---|
189 | |
---|
190 | CALL MPI_COMM_RANK( MPI_COMM_WORLD, m_world_rank, istat ) |
---|
191 | CALL MPI_COMM_SIZE( MPI_COMM_WORLD, m_world_npes, istat ) |
---|
192 | ! |
---|
193 | !-- Only process 0 of root model reads |
---|
194 | IF ( m_world_rank == 0 ) THEN |
---|
195 | |
---|
196 | CALL read_coupling_layout( nesting_datatransfer_mode, nesting_mode, & |
---|
197 | anterpolation_buffer_width, anterpolation_starting_height, particle_coupling, & |
---|
198 | pmc_status ) |
---|
199 | |
---|
200 | IF ( pmc_status /= pmc_no_namelist_found .AND. & |
---|
201 | pmc_status /= pmc_namelist_error ) & |
---|
202 | THEN |
---|
203 | ! |
---|
204 | !-- Calculate start PE of every model |
---|
205 | start_pe(1) = 0 |
---|
206 | DO i = 2, m_ncpl+1 |
---|
207 | start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total |
---|
208 | ENDDO |
---|
209 | |
---|
210 | ! |
---|
211 | !-- The sum of numbers of processes requested by all the domains must be equal to the total |
---|
212 | !-- number of processes of the run |
---|
213 | IF ( start_pe(m_ncpl+1) /= m_world_npes ) THEN |
---|
214 | WRITE( message_string, '(2A,I6,2A,I6,A)' ) & |
---|
215 | 'nesting-setup requires different number of ', & |
---|
216 | 'MPI procs (', start_pe(m_ncpl+1), ') than ', & |
---|
217 | 'provided (', m_world_npes,')' |
---|
218 | CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 ) |
---|
219 | ENDIF |
---|
220 | |
---|
221 | ENDIF |
---|
222 | |
---|
223 | ENDIF |
---|
224 | ! |
---|
225 | !-- Broadcast the read status. This synchronises all other processes with process 0 of the root |
---|
226 | !-- model. Without synchronisation, they would not behave in the correct way (e.g. they would not |
---|
227 | !-- return in case of a missing NAMELIST). |
---|
228 | CALL MPI_BCAST( pmc_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat ) |
---|
229 | |
---|
230 | IF ( pmc_status == pmc_no_namelist_found ) THEN |
---|
231 | ! |
---|
232 | !-- Not a nested run; return the MPI_WORLD communicator |
---|
233 | comm = MPI_COMM_WORLD |
---|
234 | RETURN |
---|
235 | |
---|
236 | ELSEIF ( pmc_status == pmc_namelist_error ) THEN |
---|
237 | ! |
---|
238 | !-- Only the root model gives the error message. Others are aborted by the message-routine with |
---|
239 | !-- MPI_ABORT. Must be done this way since myid and comm2d have not yet been assigned at this |
---|
240 | !-- point. |
---|
241 | IF ( m_world_rank == 0 ) THEN |
---|
242 | message_string = 'errors in \$nesting_parameters' |
---|
243 | CALL message( 'pmc_init_model', 'PA0223', 3, 2, 0, 6, 0 ) |
---|
244 | ENDIF |
---|
245 | |
---|
246 | ENDIF |
---|
247 | |
---|
248 | CALL MPI_BCAST( m_ncpl, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat ) |
---|
249 | CALL MPI_BCAST( start_pe, m_ncpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat ) |
---|
250 | ! |
---|
251 | !-- Broadcast coupling layout |
---|
252 | DO i = 1, m_ncpl |
---|
253 | CALL MPI_BCAST( m_couplers(i)%name, LEN( m_couplers(i)%name ), & |
---|
254 | MPI_CHARACTER, 0, MPI_COMM_WORLD, istat ) |
---|
255 | CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, & |
---|
256 | MPI_COMM_WORLD, istat ) |
---|
257 | CALL MPI_BCAST( m_couplers(i)%Parent_id, 1, MPI_INTEGER, 0, & |
---|
258 | MPI_COMM_WORLD, istat ) |
---|
259 | CALL MPI_BCAST( m_couplers(i)%npe_total, 1, MPI_INTEGER, 0, & |
---|
260 | MPI_COMM_WORLD, istat ) |
---|
261 | CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL, 0, & |
---|
262 | MPI_COMM_WORLD, istat ) |
---|
263 | CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL, 0, & |
---|
264 | MPI_COMM_WORLD, istat ) |
---|
265 | ENDDO |
---|
266 | CALL MPI_BCAST( nesting_mode, LEN( nesting_mode ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat ) |
---|
267 | CALL MPI_BCAST( nesting_datatransfer_mode, LEN(nesting_datatransfer_mode), MPI_CHARACTER, 0, & |
---|
268 | MPI_COMM_WORLD, istat ) |
---|
269 | CALL MPI_BCAST( anterpolation_buffer_width, 1, MPI_INT, 0, MPI_COMM_WORLD, istat ) |
---|
270 | CALL MPI_BCAST( anterpolation_starting_height, 1, MPI_REAL, 0, MPI_COMM_WORLD, istat ) |
---|
271 | CALL MPI_BCAST( particle_coupling, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, istat ) |
---|
272 | ! |
---|
273 | !-- Assign global MPI processes to individual models by setting the couple id |
---|
274 | DO i = 1, m_ncpl |
---|
275 | IF ( m_world_rank >= start_pe(i) .AND. m_world_rank < start_pe(i+1) ) THEN |
---|
276 | m_my_cpl_id = i |
---|
277 | EXIT |
---|
278 | ENDIF |
---|
279 | ENDDO |
---|
280 | m_my_cpl_rank = m_world_rank - start_pe(i) |
---|
281 | ! |
---|
282 | !-- MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach). The communictors for the |
---|
283 | !-- individual models as created by MPI_COMM_SPLIT. The color of the model is represented by the |
---|
284 | !-- coupler id |
---|
285 | CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm, istat ) |
---|
286 | ! |
---|
287 | !-- Get size and rank of the model running on this process |
---|
288 | CALL MPI_COMM_RANK( comm, m_model_rank, istat ) |
---|
289 | CALL MPI_COMM_SIZE( comm, m_model_npes, istat ) |
---|
290 | ! |
---|
291 | !-- Broadcast (from process 0) the parent id and id of every model |
---|
292 | DO i = 1, m_ncpl |
---|
293 | CALL MPI_BCAST( m_couplers(i)%parent_id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat ) |
---|
294 | CALL MPI_BCAST( m_couplers(i)%id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat ) |
---|
295 | ENDDO |
---|
296 | ! |
---|
297 | !-- Save the current model communicator for pmc internal use |
---|
298 | m_model_comm = comm |
---|
299 | |
---|
300 | ! |
---|
301 | !-- Create intercommunicator between the parent and children. |
---|
302 | !-- MPI_INTERCOMM_CREATE creates an intercommunicator between 2 groups of different colors. The |
---|
303 | !-- grouping was done above with MPI_COMM_SPLIT. A duplicate of MPI_COMM_WORLD is created and used |
---|
304 | !-- as peer communicator (peer_comm) for MPI_INTERCOMM_CREATE. |
---|
305 | CALL MPI_COMM_DUP( MPI_COMM_WORLD, peer_comm, ierr ) |
---|
306 | DO i = 2, m_ncpl |
---|
307 | IF ( m_couplers(i)%parent_id == m_my_cpl_id ) THEN |
---|
308 | ! |
---|
309 | !-- Identify all children models of the current model and create inter-communicators to |
---|
310 | !-- connect between the current model and its children models. |
---|
311 | tag = 500 + i |
---|
312 | CALL MPI_INTERCOMM_CREATE( comm, 0, peer_comm, start_pe(i), tag, m_to_child_comm(i), & |
---|
313 | istat ) |
---|
314 | childcount = childcount + 1 |
---|
315 | activeparent(i) = 1 |
---|
316 | ELSEIF ( i == m_my_cpl_id) THEN |
---|
317 | ! |
---|
318 | !-- Create an inter-communicator to connect between the current model and its parent model. |
---|
319 | tag = 500 + i |
---|
320 | CALL MPI_INTERCOMM_CREATE( comm, 0, peer_comm, start_pe(m_couplers(i)%parent_id), tag, & |
---|
321 | m_to_parent_comm, istat ) |
---|
322 | ENDIF |
---|
323 | ENDDO |
---|
324 | ! |
---|
325 | !-- If I am a parent, count the number of children I have. Although this loop is symmetric on all |
---|
326 | !-- processes, the "activeparent" flag is true (==1) on the respective individual process only. |
---|
327 | ALLOCATE( pmc_parent_for_child(childcount+1) ) |
---|
328 | |
---|
329 | childcount = 0 |
---|
330 | DO i = 2, m_ncpl |
---|
331 | IF ( activeparent(i) == 1 ) THEN |
---|
332 | childcount = childcount + 1 |
---|
333 | pmc_parent_for_child(childcount) = i |
---|
334 | ENDIF |
---|
335 | ENDDO |
---|
336 | ! |
---|
337 | !-- Get the size of the parent model |
---|
338 | IF ( m_my_cpl_id > 1 ) THEN |
---|
339 | CALL MPI_COMM_REMOTE_SIZE( m_to_parent_comm, m_parent_remote_size, istat ) |
---|
340 | ELSE |
---|
341 | ! |
---|
342 | !-- The root model does not have a parent |
---|
343 | m_parent_remote_size = -1 |
---|
344 | ENDIF |
---|
345 | ! |
---|
346 | !-- Set myid to non-zero value except for the root domain. This is a setting for the message routine |
---|
347 | !-- which is called at the end of pmci_init. That routine outputs messages for myid = 0, only. |
---|
348 | !-- However, myid has not been assigened so far, so that all processes of the root model would |
---|
349 | !-- output a message. To avoid this, set myid to some other value except for process 0 of the root |
---|
350 | !-- domain. |
---|
351 | IF ( m_world_rank /= 0 ) myid = 1 |
---|
352 | |
---|
353 | END SUBROUTINE PMC_init_model |
---|
354 | |
---|
355 | |
---|
356 | !--------------------------------------------------------------------------------------------------! |
---|
357 | ! Description: |
---|
358 | ! ------------ |
---|
359 | !> @Todo: Missing subroutine description. |
---|
360 | !--------------------------------------------------------------------------------------------------! |
---|
361 | SUBROUTINE pmc_get_model_info( comm_world_nesting, cpl_id, cpl_name, cpl_parent_id, lower_left_x, & |
---|
362 | lower_left_y, ncpl, npe_total, request_for_cpl_id ) |
---|
363 | ! |
---|
364 | !-- Provide module private variables of the pmc for PALM |
---|
365 | |
---|
366 | USE kinds |
---|
367 | |
---|
368 | IMPLICIT NONE |
---|
369 | |
---|
370 | CHARACTER(LEN=*), INTENT(OUT), OPTIONAL :: cpl_name !< |
---|
371 | |
---|
372 | INTEGER, INTENT(IN), OPTIONAL :: request_for_cpl_id !< |
---|
373 | |
---|
374 | INTEGER, INTENT(OUT), OPTIONAL :: comm_world_nesting !< |
---|
375 | INTEGER, INTENT(OUT), OPTIONAL :: cpl_id !< |
---|
376 | INTEGER, INTENT(OUT), OPTIONAL :: cpl_parent_id !< |
---|
377 | INTEGER, INTENT(OUT), OPTIONAL :: ncpl !< |
---|
378 | INTEGER, INTENT(OUT), OPTIONAL :: npe_total !< |
---|
379 | |
---|
380 | INTEGER :: requested_cpl_id !< |
---|
381 | |
---|
382 | REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_x !< |
---|
383 | REAL(wp), INTENT(OUT), OPTIONAL :: lower_left_y !< |
---|
384 | |
---|
385 | ! |
---|
386 | !-- Set the requested coupler id |
---|
387 | IF ( PRESENT( request_for_cpl_id ) ) THEN |
---|
388 | requested_cpl_id = request_for_cpl_id |
---|
389 | ! |
---|
390 | !-- Check for allowed range of values |
---|
391 | IF ( requested_cpl_id < 1 .OR. requested_cpl_id > m_ncpl ) RETURN |
---|
392 | ELSE |
---|
393 | requested_cpl_id = m_my_cpl_id |
---|
394 | ENDIF |
---|
395 | ! |
---|
396 | !-- Return the requested information |
---|
397 | IF ( PRESENT( comm_world_nesting ) ) THEN |
---|
398 | comm_world_nesting = m_world_comm |
---|
399 | ENDIF |
---|
400 | IF ( PRESENT( cpl_id ) ) THEN |
---|
401 | cpl_id = requested_cpl_id |
---|
402 | ENDIF |
---|
403 | IF ( PRESENT( cpl_parent_id ) ) THEN |
---|
404 | cpl_parent_id = m_couplers(requested_cpl_id)%parent_id |
---|
405 | ENDIF |
---|
406 | IF ( PRESENT( cpl_name ) ) THEN |
---|
407 | cpl_name = m_couplers(requested_cpl_id)%name |
---|
408 | ENDIF |
---|
409 | IF ( PRESENT( ncpl ) ) THEN |
---|
410 | ncpl = m_ncpl |
---|
411 | ENDIF |
---|
412 | IF ( PRESENT( npe_total ) ) THEN |
---|
413 | npe_total = m_couplers(requested_cpl_id)%npe_total |
---|
414 | ENDIF |
---|
415 | IF ( PRESENT( lower_left_x ) ) THEN |
---|
416 | lower_left_x = m_couplers(requested_cpl_id)%lower_left_x |
---|
417 | ENDIF |
---|
418 | IF ( PRESENT( lower_left_y ) ) THEN |
---|
419 | lower_left_y = m_couplers(requested_cpl_id)%lower_left_y |
---|
420 | ENDIF |
---|
421 | |
---|
422 | END SUBROUTINE pmc_get_model_info |
---|
423 | |
---|
424 | |
---|
425 | |
---|
426 | LOGICAL function pmc_is_rootmodel( ) |
---|
427 | |
---|
428 | IMPLICIT NONE |
---|
429 | |
---|
430 | pmc_is_rootmodel = ( m_my_cpl_id == 1 ) |
---|
431 | |
---|
432 | END FUNCTION pmc_is_rootmodel |
---|
433 | |
---|
434 | |
---|
435 | |
---|
436 | !--------------------------------------------------------------------------------------------------! |
---|
437 | ! Description: |
---|
438 | ! ------------ |
---|
439 | !> @Todo: Missing subroutine description. |
---|
440 | !--------------------------------------------------------------------------------------------------! |
---|
441 | SUBROUTINE read_coupling_layout( nesting_datatransfer_mode, nesting_mode, & |
---|
442 | anterpolation_buffer_width, anterpolation_starting_height, & |
---|
443 | particle_coupling, pmc_status ) |
---|
444 | |
---|
445 | IMPLICIT NONE |
---|
446 | |
---|
447 | CHARACTER(LEN=7), INTENT(INOUT) :: nesting_datatransfer_mode !< |
---|
448 | CHARACTER(LEN=8), INTENT(INOUT) :: nesting_mode !< |
---|
449 | |
---|
450 | INTEGER, INTENT(INOUT) :: anterpolation_buffer_width !< Boundary buffer width for anterpolation |
---|
451 | INTEGER(iwp), INTENT(INOUT) :: pmc_status !< |
---|
452 | |
---|
453 | REAL(wp), INTENT(INOUT) :: anterpolation_starting_height !< steering parameter for canopy restricted anterpolation |
---|
454 | LOGICAL, INTENT(INOUT) :: particle_coupling !< switch for particle coupling (default .TRUE.) |
---|
455 | |
---|
456 | INTEGER(iwp) :: bad_llcorner !< |
---|
457 | INTEGER(iwp) :: i !< |
---|
458 | INTEGER(iwp) :: io_status !< |
---|
459 | |
---|
460 | LOGICAL :: switch_off_module = .FALSE. !< local namelist parameter to switch off the module |
---|
461 | !< although the respective module namelist appears in |
---|
462 | !< the namelist file |
---|
463 | |
---|
464 | TYPE(pmc_layout), DIMENSION(pmc_max_models) :: domain_layouts !< |
---|
465 | |
---|
466 | NAMELIST /nesting_parameters/ anterpolation_buffer_width, & |
---|
467 | anterpolation_starting_height, & |
---|
468 | domain_layouts, & |
---|
469 | nesting_datatransfer_mode, & |
---|
470 | nesting_mode, & |
---|
471 | switch_off_module, & |
---|
472 | particle_coupling |
---|
473 | |
---|
474 | |
---|
475 | ! |
---|
476 | !-- Initialize some coupling variables |
---|
477 | domain_layouts(1:pmc_max_models)%id = -1 |
---|
478 | m_ncpl = 0 |
---|
479 | |
---|
480 | pmc_status = pmc_no_namelist_found |
---|
481 | ! |
---|
482 | !-- Open the NAMELIST-file and read the nesting layout |
---|
483 | CALL check_open( 11 ) |
---|
484 | READ ( 11, nesting_parameters, IOSTAT = io_status ) |
---|
485 | ! |
---|
486 | !-- Set filepointer to the beginning of the file. Otherwise process 0 will later be unable to read |
---|
487 | !-- the inipar-NAMELIST |
---|
488 | REWIND ( 11 ) |
---|
489 | |
---|
490 | IF ( io_status == 0 ) THEN |
---|
491 | ! |
---|
492 | !-- nesting_parameters namelist was found and read correctly. Enable the nesting by setting |
---|
493 | !-- the palm model coupler status respectively. |
---|
494 | IF ( .NOT. switch_off_module ) THEN |
---|
495 | pmc_status = pmc_status_ok |
---|
496 | ELSE |
---|
497 | RETURN |
---|
498 | ENDIF |
---|
499 | ELSEIF ( io_status < 0 ) THEN |
---|
500 | ! |
---|
501 | !-- No nesting_parameters-NAMELIST found |
---|
502 | RETURN |
---|
503 | ELSEIF ( io_status > 0 ) THEN |
---|
504 | ! |
---|
505 | !-- Errors in reading nesting_parameters-NAMELIST |
---|
506 | pmc_status = pmc_namelist_error |
---|
507 | RETURN |
---|
508 | ENDIF |
---|
509 | |
---|
510 | ! |
---|
511 | !-- Output location message |
---|
512 | CALL location_message( 'initialize communicators for nesting', 'start' ) |
---|
513 | ! |
---|
514 | !-- Assign the layout to the corresponding internally used variable m_couplers |
---|
515 | m_couplers = domain_layouts |
---|
516 | ! |
---|
517 | !-- Get the number of nested models given in the nesting_parameters-NAMELIST |
---|
518 | DO i = 1, pmc_max_models |
---|
519 | ! |
---|
520 | !-- When id=-1 is found for the first time, the list of domains is finished |
---|
521 | IF ( m_couplers(i)%id == -1 .OR. i == pmc_max_models ) THEN |
---|
522 | IF ( m_couplers(i)%id == -1 ) THEN |
---|
523 | m_ncpl = i - 1 |
---|
524 | EXIT |
---|
525 | ELSE |
---|
526 | m_ncpl = pmc_max_models |
---|
527 | ENDIF |
---|
528 | ENDIF |
---|
529 | ENDDO |
---|
530 | ! |
---|
531 | !-- Make sure that all domains have equal lower left corner in case of vertical nesting |
---|
532 | IF ( nesting_mode == 'vertical' ) THEN |
---|
533 | bad_llcorner = 0 |
---|
534 | DO i = 1, m_ncpl |
---|
535 | IF ( domain_layouts(i)%lower_left_x /= 0.0_wp .OR. & |
---|
536 | domain_layouts(i)%lower_left_y /= 0.0_wp ) THEN |
---|
537 | bad_llcorner = bad_llcorner + 1 |
---|
538 | domain_layouts(i)%lower_left_x = 0.0_wp |
---|
539 | domain_layouts(i)%lower_left_y = 0.0_wp |
---|
540 | ENDIF |
---|
541 | ENDDO |
---|
542 | IF ( bad_llcorner /= 0) THEN |
---|
543 | WRITE( message_string, *) 'at least one dimension of lower ', & |
---|
544 | 'left corner of one domain is not 0. ', & |
---|
545 | 'All lower left corners were set to (0, 0)' |
---|
546 | CALL message( 'read_coupling_layout', 'PA0427', 0, 0, 0, 6, 0 ) |
---|
547 | ENDIF |
---|
548 | ENDIF |
---|
549 | |
---|
550 | CALL location_message( 'initialize communicators for nesting', 'finished' ) |
---|
551 | |
---|
552 | END SUBROUTINE read_coupling_layout |
---|
553 | |
---|
554 | #endif |
---|
555 | END MODULE pmc_handle_communicator |
---|