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