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