mpi_bc_st.F90 2.16 KB
Newer Older
1 2 3 4 5 6
!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
MODULE m_mpi_bc_st
  !**********************************************************************
  !     mpi_bc_st :  broadcast all information for qpw_to_nmt
  !     mpi_col_st:  collect the density from pe's 
  !**********************************************************************
CONTAINS
  SUBROUTINE mpi_bc_st(mpi,stars,qpwc)
    !
    USE m_types
    IMPLICIT NONE

    TYPE(t_mpi),INTENT(IN)     :: mpi
    TYPE(t_stars),INTENT(IN)   :: stars
    !     ..
    !     .. Array Arguments ..
22
    COMPLEX :: qpwc(stars%ng3)
23 24 25 26 27 28 29 30 31 32 33 34 35
    !     ..
    !     ..
    !     .. Local Arrays ..
    INTEGER ierr(3)
    !     ..
    !     .. External Subroutines.. 
    EXTERNAL MPI_BCAST
    !     ..
    INCLUDE 'mpif.h'
    !
    !
    ! -> Broadcast the arrays:

36
    CALL MPI_BCAST(qpwc,stars%ng3,MPI_DOUBLE_COMPLEX,0,mpi%mpi_comm,ierr)
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

  END SUBROUTINE mpi_bc_st
  !*********************************************************************
  SUBROUTINE mpi_col_st(mpi,atoms,sphhar,rho)
    !
#include"cpp_double.h"
    USE m_types
    IMPLICIT NONE

    TYPE(t_mpi),INTENT(IN)     :: mpi
    TYPE(t_sphhar),INTENT(IN)  :: sphhar
    TYPE(t_atoms),INTENT(IN)   :: atoms
    INCLUDE 'mpif.h'
    EXTERNAL MPI_REDUCE
    !     ..
    !     .. Scalar Arguments ..
53
    REAL, INTENT (INOUT) :: rho(atoms%jmtd,0:sphhar%nlhd,atoms%ntype)
54 55 56 57 58

    INTEGER n
    INTEGER ierr(3)
    REAL, ALLOCATABLE :: r_b(:)

59
    n = atoms%jmtd*(sphhar%nlhd+1)*atoms%ntype
60
    ALLOCATE(r_b(n))
61
    CALL MPI_REDUCE(rho,r_b,n,MPI_DOUBLE_PRECISION,MPI_SUM,0,&
62
         &                                       mpi%mpi_comm,ierr)
63
    IF (mpi%irank == 0) rho=reshape(r_b,(/atoms%jmtd,1+sphhar%nlhd,atoms%ntype/))
64 65 66 67 68 69

    DEALLOCATE(r_b) 

  END SUBROUTINE mpi_col_st
  !*********************************************************************
END MODULE m_mpi_bc_st