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