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