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