MODULE PMC_handle_communicator !--------------------------------------------------------------------------------! ! This file is part of PALM. ! ! PALM is free software: you can redistribute it and/or modify it under the terms ! of the GNU General Public License as published by the Free Software Foundation, ! either version 3 of the License, or (at your option) any later version. ! ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License along with ! PALM. If not, see . ! ! Copyright 1997-2015 Leibniz Universitaet Hannover !--------------------------------------------------------------------------------! ! ! Current revisions: ! ------------------ ! ! ! Former revisions: ! ----------------- ! $Id: pmc_handle_communicator.f90 1763 2016-02-25 13:00:19Z hellstea $ ! ! 1762 2016-02-25 12:31:13Z hellstea ! Initial revision by K. Ketelsen ! ! Intoduction of the pure FORTRAN Palm Model Coupler (PMC) 12.11.2015 K. Ketelsen ! ! Description: ! ------------ ! ! Handle MPI Communicator in Palm Model Coupler !------------------------------------------------------------------------------! USE mpi USE pmc_general, & ONLY: PMC_STATUS_OK, PMC_STATUS_ERROR, PMC_MAX_MODELL IMPLICIT none ! Define Types type PMC_layout INTEGER :: comm_parent INTEGER :: comm_cpl INTEGER :: Id INTEGER :: Parent_id INTEGER :: npe_x INTEGER :: npe_y REAL(kind=8) :: lower_left_x REAL(kind=8) :: lower_left_y CHARACTER(len=32) :: name END type PMC_layout ! return status PUBLIC PMC_STATUS_OK, PMC_STATUS_ERROR INTEGER,parameter,PUBLIC :: PMC_ERROR_NPES = 1 ! illegal Number of PEs INTEGER,parameter,PUBLIC :: PMC_ERROR_MPI = 2 ! MPI Error INTEGER,parameter,PUBLIC :: PMC_ERRO_NOF = 3 ! No couple layout file found ! Coupler Setup INTEGER :: m_my_CPL_id !Coupler id of this model INTEGER :: m_Parent_id !Coupler id of parent of this model INTEGER :: m_NrOfCpl !Number of Coupler in layout file type(PMC_layout),DIMENSION(PMC_MAX_MODELL) :: m_couplers !Information of all coupler ! MPI settings INTEGER,PUBLIC :: m_model_comm !Communicator of this model INTEGER,PUBLIC :: m_to_server_comm !Communicator to the server INTEGER,DIMENSION(PMC_MAX_MODELL) :: m_to_client_comm !Communicator to the client(s) INTEGER,PUBLIC :: m_world_rank INTEGER :: m_world_npes INTEGER,PUBLIC :: m_model_rank INTEGER,PUBLIC :: m_model_npes INTEGER :: m_server_remote_size !Number of Server PE's PUBLIC m_to_client_comm !Indicates this PE is server for Cleint NR INTEGER,DIMENSION(:),POINTER,PUBLIC :: PMC_Server_for_Client !INTERFACE Section INTERFACE PMC_is_RootModel MODULE PROCEDURE PMC_is_RootModel END INTERFACE PMC_is_RootModel INTERFACE PMC_get_local_model_info MODULE PROCEDURE PMC_get_local_model_info END INTERFACE PMC_get_local_model_info PUBLIC PMC_init_model,PMC_get_local_model_info, PMC_is_RootModel CONTAINS SUBROUTINE PMC_init_model (comm, PMC_status) IMPLICIT none INTEGER,INTENT(OUT) :: comm INTEGER,INTENT(OUT) :: PMC_status !-- local declarations INTEGER :: i,istat, ierr INTEGER,DIMENSION(PMC_MAX_MODELL+1) :: start_PE INTEGER :: m_my_CPL_rank INTEGER :: tag, ClientCount INTEGER,DIMENSION(PMC_MAX_MODELL) :: activeServer !I am active server for this client ID PMC_status = PMC_STATUS_OK comm = -1 m_my_CPL_id = -1 ClientCount = 0 activeServer = -1 start_PE(:) = 0 CALL MPI_Comm_rank (MPI_COMM_WORLD, m_world_rank, istat) CALL MPI_Comm_size (MPI_COMM_WORLD, m_world_npes, istat) if(m_world_rank == 0) then ! only PE 0 of root model reads CALL read_coupling_layout (PMC_status) IF (PMC_status /= PMC_ERRO_NOF ) THEN ! Compute Start PE of every model start_PE(1) = 0 do i=2,m_NrOfCpl+1 start_pe(i) = start_PE(i-1) + m_couplers(i-1)%npe_x*m_couplers(i-1)%npe_y END do if(start_pe(m_NrOfCpl+1) /= m_world_npes) then if(m_world_rank == 0) then write(0,*) 'PMC ERROR: Coupler Setup Not equal Nr. MPI procs ',start_pe(m_NrOfCpl+1),m_world_npes END if CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat) END if END IF END if CALL MPI_Bcast (PMC_status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) IF (PMC_status == PMC_ERRO_NOF ) THEN if(m_world_rank == 0) write(0,*) 'PMC ERROR: file PMC_couple_layout not found' CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat) END IF CALL MPI_Bcast (m_NrOfCpl, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (start_PE, m_NrOfCpl+1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) ! Broadcast coupling layout do i=1,m_NrOfCpl CALL MPI_Bcast (m_couplers(i)%name, len(m_couplers(i)%name ), MPI_CHARACTER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%Parent_id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%npe_x, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%npe_y, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%lower_left_x, 1, MPI_REAL8, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%lower_left_y, 1, MPI_REAL8, 0, MPI_COMM_WORLD, istat) END do ! Assign global MPI processes to individual models by setting the couple id do i=1,m_NrOfCpl if(m_world_rank >= start_PE(i) .and. m_world_rank < start_PE(i+1) ) then m_my_CPL_id = i EXIT END if END do m_my_CPL_rank = m_world_rank-start_PE(i) ! MPI_COMM_WORLD is the communicator for ALL models (MPI-1 approach) ! The communictors for the individual models a created by MPI_Comm_split ! The color of the model is represented by the Coupler id CALL MPI_Comm_split (MPI_COMM_WORLD, m_my_CPL_id, m_my_CPL_rank, comm, istat) if(istat /= MPI_SUCCESS) then if(m_world_rank == 0) write(0,*) 'PMC: Error in MPI_Comm_split ' CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat) END if ! Get size and rank of the model running on THIS PE CALL MPI_Comm_rank (comm, m_model_rank, istat) CALL MPI_Comm_size (comm, m_model_npes, istat) ! Pe 0 brodcasts the Parent ID and Id of every model do i=1,m_NrOfCpl CALL MPI_Bcast (m_couplers(i)%Parent_Id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) CALL MPI_Bcast (m_couplers(i)%Id, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat) END do m_model_comm = comm ! create Intercommunicator to server and clients ! MPI_Intercomm_create creates an intercommunicator between 2 groups of different colors ! The grouping with done prior with MPI_Comm_split do i=2,m_NrOfCpl if(m_couplers(i)%Parent_Id == m_my_CPL_id) then !collect server PEs tag = 500+i !kk write(0,'(a,6i4)') 'server Part ',m_world_rank,m_world_npes,m_model_rank,m_model_npes,tag,start_pe(i) CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(i), & tag, m_to_client_comm(i), istat) clientCount = clientCount+1 activeServer(i) = 1 else if (i == m_my_CPL_id) then !collect client PEs tag = 500+i CALL MPI_Intercomm_create (comm, 0, MPI_COMM_WORLD, start_pe(m_couplers(i)%Parent_Id), & tag, m_to_server_comm, istat) !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) END if if(istat /= MPI_SUCCESS) then if(m_world_rank == 0) write(0,*) 'PMC: Error in Coupler Setup ' CALL MPI_Abort (MPI_COMM_WORLD, ierr, istat) END if END do ! If I am server, count nr. of clients ! Although this loop is symetric on all processes, the active server flag is valid only on the individual PE. ALLOCATE(PMC_Server_for_Client(ClientCount+1)) ClientCount = 0 do i=2,m_NrOfCpl if(activeServer(i) == 1) then ClientCount = clientCount+1 PMC_Server_for_Client(ClientCount) = i END if END do PMC_Server_for_Client(ClientCount+1) = -1 ! Get size of the server model if(m_my_CPL_id > 1) then CALL MPI_Comm_remote_size (m_to_server_comm, m_server_remote_size, istat) else m_server_remote_size = -1 ! root model does not have a server END if ! 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, & ! m_model_rank,m_my_CPL_id,m_my_CPL_rank,m_server_remote_size,ClientCount return END SUBROUTINE PMC_init_model ! Make module private variables available to palm SUBROUTINE PMC_get_local_model_info (my_CPL_id, CPL_name, npe_x, npe_y, lower_left_x, lower_left_y) IMPLICIT none INTEGER,INTENT(OUT),optional :: my_CPL_id CHARACTER(len=*),INTENT(OUT),optional :: CPL_name INTEGER,INTENT(OUT),optional :: npe_x INTEGER,INTENT(OUT),optional :: npe_y REAL(kind=8),INTENT(OUT),optional :: lower_left_x REAL(kind=8),INTENT(OUT),optional :: lower_left_y if(present(my_CPL_id)) my_CPL_id = m_my_CPL_id if(present(CPL_name)) CPL_name = m_couplers(my_CPL_id)%name if(present(npe_x)) npe_x = m_couplers(my_CPL_id)%npe_x if(present(npe_y)) npe_y = m_couplers(my_CPL_id)%npe_y if(present(lower_left_x)) lower_left_x = m_couplers(my_CPL_id)%lower_left_x if(present(lower_left_y)) lower_left_y = m_couplers(my_CPL_id)%lower_left_y return END SUBROUTINE PMC_get_local_model_info LOGICAL function PMC_is_RootModel () IMPLICIT none PMC_is_RootModel = (m_my_CPL_id == 1) return END function PMC_is_RootModel ! Private SUBROUTINEs SUBROUTINE read_coupling_layout (PMC_status) IMPLICIT none INTEGER,INTENT(INOUT) :: PMC_status INTEGER :: i,iunit,istat CHARACTER(LEN=*), PARAMETER :: fname = 'PMC_couple_layout' LOGICAL :: lex m_NrOfCpl = 0 iunit = 345 PMC_STATUS = PMC_STATUS_OK INQUIRE(file=TRIM(fname), exist=lex) IF (.NOT. lex) THEN PMC_status = PMC_ERRO_NOF RETURN END IF open(iunit,file=TRIM(fname),status='OLD') do i=1,PMC_MAX_MODELL read(iunit,*,iostat=istat) m_couplers(i)%name & , m_couplers(i)%id,m_couplers(i)%Parent_id & , m_couplers(i)%npe_x,m_couplers(i)%npe_y & , m_couplers(i)%lower_left_x, m_couplers(i)%lower_left_y if(istat /= 0) EXIT 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, & m_couplers(i)%npe_x,m_couplers(i)%npe_y, & m_couplers(i)%lower_left_x,m_couplers(i)%lower_left_y m_NrOfCpl = i END do close(iunit) return END SUBROUTINE read_coupling_layout END MODULE PMC_handle_communicator