source: palm/trunk/SOURCE/pmc_handle_communicator.f90 @ 1763

Last change on this file since 1763 was 1763, checked in by hellstea, 6 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 12.5 KB
Line 
1MODULE PMC_handle_communicator
2
3
4!--------------------------------------------------------------------------------!
5! This file is part of PALM.
6!
7! PALM is free software: you can redistribute it and/or modify it under the terms
8! of the GNU General Public License as published by the Free Software Foundation,
9! either version 3 of the License, or (at your option) any later version.
10!
11! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
12! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
14!
15! You should have received a copy of the GNU General Public License along with
16! PALM. If not, see <http://www.gnu.org/licenses/>.
17!
18! Copyright 1997-2015 Leibniz Universitaet Hannover
19!--------------------------------------------------------------------------------!
20!
21! Current revisions:
22! ------------------
23!
24!
25! Former revisions:
26! -----------------
27! $Id: pmc_handle_communicator.f90 1763 2016-02-25 13:00:19Z hellstea $
28!
29! 1762 2016-02-25 12:31:13Z hellstea
30! Initial revision by K. Ketelsen
31!
32! Intoduction of the pure FORTRAN Palm Model Coupler     (PMC)  12.11.2015  K. Ketelsen
33!
34! Description:
35! ------------
36!
37! Handle MPI Communicator in Palm Model Coupler
38!------------------------------------------------------------------------------!
39
40   USE      mpi
41   USE      pmc_general,                        &
42      ONLY: PMC_STATUS_OK, PMC_STATUS_ERROR, PMC_MAX_MODELL
43
44   IMPLICIT none
45
46   ! Define Types
47
48   type PMC_layout
49      INTEGER                         :: comm_parent
50      INTEGER                         :: comm_cpl
51      INTEGER                         :: Id
52      INTEGER                         :: Parent_id
53
54      INTEGER                         :: npe_x
55      INTEGER                         :: npe_y
56
57      REAL(kind=8)                    :: lower_left_x
58      REAL(kind=8)                    :: lower_left_y
59
60      CHARACTER(len=32)               :: name
61   END type PMC_layout
62
63   ! return status
64   PUBLIC                               PMC_STATUS_OK, PMC_STATUS_ERROR
65   INTEGER,parameter,PUBLIC          :: PMC_ERROR_NPES = 1                       ! illegal Number of PEs
66   INTEGER,parameter,PUBLIC          :: PMC_ERROR_MPI  = 2                       ! MPI Error
67   INTEGER,parameter,PUBLIC          :: PMC_ERRO_NOF   = 3                       ! No couple layout file found
68
69   ! Coupler Setup
70
71   INTEGER                                    :: m_my_CPL_id  !Coupler id of this model
72   INTEGER                                    :: m_Parent_id  !Coupler id of parent of this model
73   INTEGER                                    :: m_NrOfCpl    !Number of Coupler in layout file
74   type(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers   !Information of all coupler
75
76   ! MPI settings
77
78   INTEGER,PUBLIC                    :: m_model_comm          !Communicator of this model
79   INTEGER,PUBLIC                    :: m_to_server_comm      !Communicator to the server
80   INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm      !Communicator to the client(s)
81   INTEGER,PUBLIC                    :: m_world_rank
82   INTEGER                           :: m_world_npes
83   INTEGER,PUBLIC                    :: m_model_rank
84   INTEGER,PUBLIC                    :: m_model_npes
85   INTEGER                           :: m_server_remote_size  !Number of Server PE's
86
87   PUBLIC m_to_client_comm
88
89   !Indicates this PE is server for Cleint NR
90
91   INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client
92
93   !INTERFACE Section
94
95   INTERFACE PMC_is_RootModel
96      MODULE PROCEDURE PMC_is_RootModel
97   END INTERFACE PMC_is_RootModel
98
99   INTERFACE PMC_get_local_model_info
100      MODULE PROCEDURE PMC_get_local_model_info
101   END INTERFACE PMC_get_local_model_info
102
103   PUBLIC PMC_init_model,PMC_get_local_model_info, PMC_is_RootModel
104CONTAINS
105
106   SUBROUTINE PMC_init_model (comm, PMC_status)
107      IMPLICIT     none
108      INTEGER,INTENT(OUT)                 :: comm
109      INTEGER,INTENT(OUT)                 :: PMC_status
110
111      !-- local declarations
112      INTEGER                             :: i,istat, ierr
113      INTEGER,DIMENSION(PMC_MAX_MODELL+1) :: start_PE
114      INTEGER                             :: m_my_CPL_rank
115      INTEGER                             :: tag, ClientCount
116      INTEGER,DIMENSION(PMC_MAX_MODELL)   :: activeServer        !I am active server for this client ID
117
118      PMC_status   = PMC_STATUS_OK
119      comm         = -1
120      m_my_CPL_id  = -1
121      ClientCount  = 0
122      activeServer = -1
123      start_PE(:)  = 0
124
125      CALL  MPI_Comm_rank (MPI_COMM_WORLD, m_world_rank, istat)
126      CALL  MPI_Comm_size (MPI_COMM_WORLD, m_world_npes, istat)
127
128      if(m_world_rank == 0) then ! only PE 0 of root model reads
129
130         CALL read_coupling_layout (PMC_status)
131
132         IF (PMC_status /= PMC_ERRO_NOF  ) THEN
133            ! Compute Start PE of every model
134            start_PE(1) = 0
135            do i=2,m_NrOfCpl+1
136               start_pe(i) = start_PE(i-1) + m_couplers(i-1)%npe_x*m_couplers(i-1)%npe_y
137            END do
138            if(start_pe(m_NrOfCpl+1) /= m_world_npes)   then
139               if(m_world_rank == 0) then
140                  write(0,*) 'PMC ERROR: Coupler Setup Not equal Nr. MPI procs ',start_pe(m_NrOfCpl+1),m_world_npes
141               END if
142               CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
143            END if
144         END IF
145      END if
146
147      CALL MPI_Bcast (PMC_status, 1,          MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
148      IF (PMC_status == PMC_ERRO_NOF  ) THEN
149         if(m_world_rank == 0)  write(0,*) 'PMC ERROR: file PMC_couple_layout not found'
150         CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
151      END IF
152
153      CALL MPI_Bcast (m_NrOfCpl, 1,          MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
154      CALL MPI_Bcast (start_PE, m_NrOfCpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
155
156      !   Broadcast coupling layout
157
158      do i=1,m_NrOfCpl
159         CALL MPI_Bcast (m_couplers(i)%name, len(m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat)
160         CALL MPI_Bcast (m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
161         CALL MPI_Bcast (m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
162         CALL MPI_Bcast (m_couplers(i)%npe_x,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
163         CALL MPI_Bcast (m_couplers(i)%npe_y,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat)
164         CALL MPI_Bcast (m_couplers(i)%lower_left_x, 1, MPI_REAL8,   0, MPI_COMM_WORLD, istat)
165         CALL MPI_Bcast (m_couplers(i)%lower_left_y, 1, MPI_REAL8,   0, MPI_COMM_WORLD, istat)
166      END do
167
168      ! Assign global MPI processes to individual models by setting the couple id
169
170      do i=1,m_NrOfCpl
171         if(m_world_rank >= start_PE(i) .and. m_world_rank < start_PE(i+1) ) then
172            m_my_CPL_id = i
173            EXIT
174         END if
175      END do
176      m_my_CPL_rank = m_world_rank-start_PE(i)
177
178      !   MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach)
179      !   The communictors for the individual models a created by MPI_Comm_split
180      !   The color of the model is represented by the Coupler id
181
182      CALL MPI_Comm_split (MPI_COMM_WORLD, m_my_CPL_id, m_my_CPL_rank, comm, istat)
183      if(istat /= MPI_SUCCESS) then
184         if(m_world_rank == 0) write(0,*) 'PMC: Error in MPI_Comm_split '
185         CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
186      END if
187
188      !   Get size and rank of the model running on THIS PE
189
190      CALL  MPI_Comm_rank (comm, m_model_rank, istat)
191      CALL  MPI_Comm_size (comm, m_model_npes, istat)
192
193      !   Pe 0  brodcasts the Parent ID and Id of every model
194
195      do i=1,m_NrOfCpl
196         CALL MPI_Bcast (m_couplers(i)%Parent_Id,  1, MPI_INTEGER, 0,           MPI_COMM_WORLD, istat)
197         CALL MPI_Bcast (m_couplers(i)%Id,         1, MPI_INTEGER, 0,           MPI_COMM_WORLD, istat)
198      END do
199
200      m_model_comm = comm
201
202      !   create Intercommunicator to server and clients
203      !   MPI_Intercomm_create creates an intercommunicator between 2 groups of different colors
204      !   The grouping with done prior with MPI_Comm_split
205
206      do i=2,m_NrOfCpl
207         if(m_couplers(i)%Parent_Id == m_my_CPL_id)   then                         !collect server PEs
208            tag = 500+i
209!kk            write(0,'(a,6i4)') 'server Part ',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag,start_pe(i)
210            CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(i), &
211               tag, m_to_client_comm(i), istat)
212
213            clientCount = clientCount+1
214            activeServer(i) = 1
215         else if (i == m_my_CPL_id)   then                                         !collect client PEs
216            tag = 500+i
217            CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(m_couplers(i)%Parent_Id), &
218               tag, m_to_server_comm, istat)
219!kk            write(0,'(a,7i4)') 'client Part',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag, start_pe(m_couplers(i)%Parent_Id)
220         END if
221         if(istat /= MPI_SUCCESS) then
222            if(m_world_rank == 0) write(0,*) 'PMC: Error in Coupler Setup '
223            CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat)
224         END if
225      END do
226
227!     If I am server, count nr. of clients
228!     Although this loop is symetric on all processes, the active server flag is valid only on the individual PE.
229
230      ALLOCATE(PMC_Server_for_Client(ClientCount+1))
231      ClientCount = 0
232      do i=2,m_NrOfCpl
233         if(activeServer(i) == 1)  then
234            ClientCount = clientCount+1
235            PMC_Server_for_Client(ClientCount) = i
236         END if
237      END do
238      PMC_Server_for_Client(ClientCount+1) = -1
239
240      !   Get size of the server model
241
242      if(m_my_CPL_id > 1)  then
243         CALL MPI_Comm_remote_size (m_to_server_comm, m_server_remote_size, istat)
244      else
245         m_server_remote_size = -1             ! root model does not have a server
246      END if
247
248!      write(0,'(a,a,1x,9i7)') 'New Communicator ',trim(m_couplers(m_my_CPL_id)%name),m_world_npes,m_model_npes,m_world_rank, &
249!                                           m_model_rank,m_my_CPL_id,m_my_CPL_rank,m_server_remote_size,ClientCount
250
251      return
252   END SUBROUTINE PMC_init_model
253
254!  Make module private variables available to palm
255
256   SUBROUTINE PMC_get_local_model_info (my_CPL_id, CPL_name,  npe_x, npe_y, lower_left_x, lower_left_y)
257      IMPLICIT     none
258      INTEGER,INTENT(OUT),optional             :: my_CPL_id
259      CHARACTER(len=*),INTENT(OUT),optional    :: CPL_name
260      INTEGER,INTENT(OUT),optional             :: npe_x
261      INTEGER,INTENT(OUT),optional             :: npe_y
262      REAL(kind=8),INTENT(OUT),optional        :: lower_left_x
263      REAL(kind=8),INTENT(OUT),optional        :: lower_left_y
264
265      if(present(my_CPL_id))    my_CPL_id    = m_my_CPL_id
266      if(present(CPL_name))     CPL_name     = m_couplers(my_CPL_id)%name
267      if(present(npe_x))        npe_x        = m_couplers(my_CPL_id)%npe_x
268      if(present(npe_y))        npe_y        = m_couplers(my_CPL_id)%npe_y
269      if(present(lower_left_x)) lower_left_x = m_couplers(my_CPL_id)%lower_left_x
270      if(present(lower_left_y)) lower_left_y = m_couplers(my_CPL_id)%lower_left_y
271
272      return
273   END  SUBROUTINE PMC_get_local_model_info
274
275   LOGICAL function PMC_is_RootModel ()
276      IMPLICIT     none
277
278      PMC_is_RootModel = (m_my_CPL_id == 1)
279
280      return
281   END  function PMC_is_RootModel
282
283! Private SUBROUTINEs
284
285  SUBROUTINE read_coupling_layout (PMC_status)
286    IMPLICIT     none
287    INTEGER,INTENT(INOUT)           :: PMC_status
288    INTEGER                         :: i,iunit,istat
289    CHARACTER(LEN=*), PARAMETER     :: fname = 'PMC_couple_layout'
290    LOGICAL                         :: lex
291
292    m_NrOfCpl = 0
293    iunit     = 345
294
295    PMC_STATUS = PMC_STATUS_OK
296    INQUIRE(file=TRIM(fname), exist=lex)
297    IF (.NOT. lex) THEN
298       PMC_status = PMC_ERRO_NOF
299       RETURN
300    END IF
301
302    open(iunit,file=TRIM(fname),status='OLD')
303    do i=1,PMC_MAX_MODELL
304      read(iunit,*,iostat=istat) m_couplers(i)%name                     &
305           , m_couplers(i)%id,m_couplers(i)%Parent_id                   &
306           , m_couplers(i)%npe_x,m_couplers(i)%npe_y                    &
307           , m_couplers(i)%lower_left_x, m_couplers(i)%lower_left_y
308      if(istat /= 0)  EXIT
309
310      write(0,'(a,a,1x,4i7,1x,2F10.2)') 'Set up Model  ',trim(m_couplers(i)%name),m_couplers(i)%id,m_couplers(i)%Parent_id, &
311                                                     m_couplers(i)%npe_x,m_couplers(i)%npe_y,                               &
312                                                     m_couplers(i)%lower_left_x,m_couplers(i)%lower_left_y
313
314      m_NrOfCpl = i
315    END do
316    close(iunit)
317
318    return
319  END SUBROUTINE read_coupling_layout
320
321END MODULE PMC_handle_communicator
Note: See TracBrowser for help on using the repository browser.