MODULE pmc_mpi_wrapper !--------------------------------------------------------------------------------! ! 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_mpi_wrapper.f90 1765 2016-02-28 13:30:40Z hoffmann $ ! ! 1764 2016-02-28 12:45:19Z raasch ! cpp-statement added (nesting can only be used in parallel mode), ! kind-parameters adjusted to PALM-kinds ! ! 1762 2016-02-25 12:31:13Z hellstea ! Initial revision by K. Ketelsen ! ! Description: ! ------------ ! ! MPI Wrapper of Palm Model Coupler !------------------------------------------------------------------------------! #if defined( __parallel ) use, intrinsic :: iso_c_binding #if defined( __lc ) USE MPI #else INCLUDE "mpif.h" #endif USE kinds USE PMC_handle_communicator, ONLY: m_to_server_comm, m_to_client_comm, m_model_comm, m_model_rank IMPLICIT none PRIVATE SAVE !-- TO_DO: what is the meaning of this? Could variables declared in this module !-- also have single precision? ! INTEGER, PARAMETER :: dp = wp ! INTERFACE section INTERFACE PMC_Send_to_Server MODULE PROCEDURE PMC_Send_to_Server_INTEGER MODULE PROCEDURE PMC_Send_to_Server_INTEGER_2 MODULE PROCEDURE PMC_Send_to_Server_real_r1 MODULE PROCEDURE PMC_Send_to_Server_real_r2 MODULE PROCEDURE PMC_Send_to_Server_real_r3 END INTERFACE PMC_Send_to_Server INTERFACE PMC_Recv_from_Server MODULE PROCEDURE PMC_Recv_from_Server_INTEGER MODULE PROCEDURE PMC_Recv_from_Server_real_r1 MODULE PROCEDURE PMC_Recv_from_Server_real_r2 MODULE PROCEDURE PMC_Recv_from_Server_real_r3 END INTERFACE PMC_Recv_from_Server INTERFACE PMC_Send_to_Client MODULE PROCEDURE PMC_Send_to_Client_INTEGER MODULE PROCEDURE PMC_Send_to_Client_real_r1 MODULE PROCEDURE PMC_Send_to_Client_real_r2 MODULE PROCEDURE PMC_Send_to_Client_real_r3 END INTERFACE PMC_Send_to_Client INTERFACE PMC_Recv_from_Client MODULE PROCEDURE PMC_Recv_from_Client_INTEGER MODULE PROCEDURE PMC_Recv_from_Client_INTEGER_2 MODULE PROCEDURE PMC_Recv_from_Client_real_r1 MODULE PROCEDURE PMC_Recv_from_Client_real_r2 MODULE PROCEDURE PMC_Recv_from_Client_real_r3 END INTERFACE PMC_Recv_from_Client INTERFACE PMC_Bcast MODULE PROCEDURE PMC_Bcast_INTEGER MODULE PROCEDURE PMC_Bcast_character END INTERFACE PMC_Bcast INTERFACE PMC_Inter_Bcast MODULE PROCEDURE PMC_Inter_Bcast_INTEGER_1 END INTERFACE PMC_Inter_Bcast INTERFACE PMC_Alloc_mem MODULE PROCEDURE PMC_Alloc_mem_INTEGER_1 MODULE PROCEDURE PMC_Alloc_mem_Real_1 END INTERFACE PMC_Alloc_mem INTERFACE PMC_TIME MODULE PROCEDURE PMC_TIME END INTERFACE PMC_TIME PUBLIC PMC_Send_to_Server, PMC_Recv_from_Server PUBLIC PMC_Send_to_Client, PMC_Recv_from_Client PUBLIC PMC_Bcast, PMC_Inter_Bcast, PMC_Alloc_mem PUBLIC PMC_TIME CONTAINS SUBROUTINE PMC_Send_to_Server_INTEGER (buf, n, Server_rank, tag, ierr) IMPLICIT none INTEGER, DIMENSION(:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr) return END SUBROUTINE PMC_Send_to_Server_INTEGER SUBROUTINE PMC_Recv_from_Server_INTEGER (buf, n, Server_rank, tag, ierr) IMPLICIT none INTEGER, DIMENSION(:), INTENT(OUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Server_INTEGER SUBROUTINE PMC_Send_to_Server_INTEGER_2 (buf, n, Server_rank, tag, ierr) IMPLICIT none INTEGER, DIMENSION(:,:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_INTEGER, Server_rank, tag, m_to_server_comm, ierr) return END SUBROUTINE PMC_Send_to_Server_INTEGER_2 SUBROUTINE PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr) IMPLICIT none !-- TO_DO: has buf always to be of dp-kind, or can wp used here !-- this effects all respective declarations in this file REAL(kind=dp), DIMENSION(:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr) return END SUBROUTINE PMC_Send_to_Server_real_r1 SUBROUTINE PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr) IMPLICIT none REAL(kind=dp), DIMENSION(:), INTENT(OUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Server_real_r1 SUBROUTINE PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr) IMPLICIT none REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr) return END SUBROUTINE PMC_Send_to_Server_real_r2 SUBROUTINE PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr) IMPLICIT none REAL(kind=dp), DIMENSION(:,:),INTENT(OUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Server_real_r2 SUBROUTINE PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr) IMPLICIT none REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr) return END SUBROUTINE PMC_Send_to_Server_real_r3 SUBROUTINE PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr) IMPLICIT none REAL(kind=dp), DIMENSION(:,:,:),INTENT(OUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Server_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Server_real_r3 SUBROUTINE PMC_Send_to_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id INTEGER, DIMENSION(:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), ierr) return END SUBROUTINE PMC_Send_to_Client_INTEGER SUBROUTINE PMC_Recv_from_Client_INTEGER (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id INTEGER, DIMENSION(:), INTENT(INOUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Client_INTEGER SUBROUTINE PMC_Recv_from_Client_INTEGER_2 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id INTEGER, DIMENSION(:,:), INTENT(OUT) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_INTEGER, Client_rank, tag, m_to_client_comm(Client_id), & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Client_INTEGER_2 SUBROUTINE PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & ierr) return END SUBROUTINE PMC_Send_to_Client_real_r1 SUBROUTINE PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:), INTENT(INOUT):: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Client_real_r1 SUBROUTINE PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & ierr) return END SUBROUTINE PMC_Send_to_Client_real_r2 SUBROUTINE PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:,:), INTENT(OUT):: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Client_real_r2 SUBROUTINE PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & ierr) return END SUBROUTINE PMC_Send_to_Client_real_r3 SUBROUTINE PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr) IMPLICIT none INTEGER, INTENT(IN) :: Client_id REAL(kind=dp), DIMENSION(:,:,:), INTENT(OUT):: buf INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: Client_rank INTEGER, INTENT(IN) :: tag INTEGER, INTENT(OUT) :: ierr ierr = 0 CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), & MPI_STATUS_IGNORE, ierr) return END SUBROUTINE PMC_Recv_from_Client_real_r3 SUBROUTINE PMC_Bcast_INTEGER (buf, root_pe, comm, ierr) IMPLICIT none INTEGER, INTENT(INOUT) :: buf INTEGER, INTENT(IN) :: root_pe INTEGER, INTENT(IN),optional :: comm INTEGER, INTENT(OUT),optional :: ierr !-- local variables INTEGER :: myComm INTEGER :: myErr if(present (comm)) then myComm = comm else myComm = m_model_comm end if CALL MPI_Bcast (buf, 1, MPI_INTEGER, root_pe, myComm, myErr) if(present (ierr)) then ierr = myErr end if return END SUBROUTINE PMC_Bcast_INTEGER SUBROUTINE PMC_Bcast_character (buf, root_pe, comm, ierr) IMPLICIT none character(len=*), INTENT(INOUT) :: buf INTEGER, INTENT(IN) :: root_pe INTEGER, INTENT(IN),optional :: comm INTEGER, INTENT(OUT),optional :: ierr !-- local variables INTEGER :: myComm INTEGER :: myErr if(present (comm)) then myComm = comm else myComm = m_model_comm end if CALL MPI_Bcast (buf, len(buf), MPI_Character, root_pe, myComm, myErr) if(present (ierr)) then ierr = myErr end if return END SUBROUTINE PMC_Bcast_character SUBROUTINE PMC_Inter_Bcast_INTEGER_1 (buf, Client_id, ierr) IMPLICIT none INTEGER, INTENT(INOUT),DIMENSION(:) :: buf INTEGER, INTENT(IN),optional :: Client_id INTEGER, INTENT(OUT),optional :: ierr !-- local variables INTEGER :: myComm INTEGER :: myErr INTEGER :: root_pe ! PE 0 Server Broadcast to all Client PE's if(present (Client_id)) then myComm = m_to_client_comm(Client_id) if(m_model_rank == 0) then root_pe = MPI_ROOT else root_pe = MPI_PROC_NULL end if else myComm = m_to_server_comm root_pe = 0 end if CALL MPI_Bcast (buf, size(buf), MPI_INTEGER, root_pe, myComm, myErr) if(present (ierr)) then ierr = myErr end if return END SUBROUTINE PMC_Inter_Bcast_INTEGER_1 ! Allocate Memory with MPI_Alloc_mem using intermediate C-pointer SUBROUTINE PMC_Alloc_mem_INTEGER_1 (iarray, idim1) IMPLICIT none INTEGER,DIMENSION(:),POINTER,INTENT(INOUT) :: iarray INTEGER,INTENT(IN) :: idim1 Type(c_ptr) :: p_myInd INTEGER,DIMENSION(1) :: aShape INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize INTEGER :: ierr WinSize = idim1*c_sizeof(ierr) ! Length of INTEGER CALL MPI_Alloc_mem (WinSize , MPI_INFO_NULL, p_myInd, ierr); aShape(1) = idim1 CALL c_f_pointer(p_myInd,iarray,aShape) return END SUBROUTINE PMC_Alloc_mem_INTEGER_1 SUBROUTINE PMC_Alloc_mem_Real_1 (array, idim1, base_ptr) IMPLICIT none REAL(kind=wp),DIMENSION(:),POINTER,INTENT(INOUT) :: array INTEGER(idp),INTENT(IN) :: idim1 Type(c_ptr),INTENT(OUT),optional :: base_ptr Type(c_ptr) :: p_myInd INTEGER,DIMENSION(1) :: aShape INTEGER(KIND=MPI_ADDRESS_KIND) :: WinSize INTEGER :: ierr WinSize = idim1*wp ! Length of INTEGER CALL MPI_Alloc_mem (WinSize , MPI_INFO_NULL, p_myInd, ierr); aShape(1) = idim1 CALL c_f_pointer(p_myInd,array,aShape) if(present(base_ptr)) then base_ptr = p_myInd end if return END SUBROUTINE PMC_Alloc_mem_Real_1 FUNCTION PMC_TIME () REAL(kind=wp) :: PMC_TIME PMC_TIME = MPI_Wtime () return END FUNCTION PMC_TIME #endif END MODULE pmc_mpi_wrapper