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