distributed.F90

Go to the documentation of this file.

!! Copyright (C) 2008-2016 X. Andrade
!!
!! This program 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 2, or (at your option)
!! any later version.
!!
!! This program 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 this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
module distributed_oct_m
  use debug_oct_m
  use global_oct_m
  use messages_oct_m
  use mpi_oct_m
  use multicomm_oct_m
  use profiling_oct_m
 
  implicit none
 
  private
 
  public ::                      &
    distributed_t,               &
    distributed_init,            &
    distributed_init_serial,     &
    distributed_copy,            &
    distributed_end
 
  type distributed_t
    integer              :: start    = 1
    integer              :: end      = 0
    logical              :: parallel = .false. 
    integer, allocatable :: process(:)
    integer, allocatable :: range(:, :)
    !                                             dim(2, 0:n_processes-1)
    !                                             Defined the same for all processes of mpi_grp
    integer, allocatable :: num(:)
    !                                             dim(mpi_grp%size)
    type(mpi_grp_t)      :: mpi_grp
  contains
    procedure :: nlocal => distributed_nlocal   
    procedure :: nglobal => distributed_nglobal 
    procedure :: displs => distributed_displs   
  end type distributed_t
 
contains
 
  pure integer function distributed_nlocal(this)
    class(distributed_t), intent(in) :: this
 
    distributed_nlocal = this%num(this%mpi_grp%rank)
 
  end function distributed_nlocal
 
 
  pure integer function distributed_nglobal(this)
    class(distributed_t), intent(in) :: this
 
    distributed_nglobal = size(this%process)
 
  end function distributed_nglobal
 
 
  pure function distributed_displs(this) result(displs)
    class(distributed_t), intent(in) :: this
    integer, allocatable :: displs(:)
 
    displs = this%range(1, :) - 1
 
  end function distributed_displs
 
 
  subroutine distributed_init(this, total, comm, tag, scalapack_compat)
    type(distributed_t),        intent(out) :: this
    integer,                    intent(in)  :: total
    type(MPI_Comm),             intent(in)  :: comm
    character(len=*), optional, intent(in)  :: tag
    logical,          optional, intent(in)  :: scalapack_compat
 
    integer :: i
 
    push_sub(distributed_init)
 
    safe_allocate(this%process(1:total))
 
    call mpi_grp_init(this%mpi_grp, comm)
    safe_allocate(this%num(0:this%mpi_grp%size - 1))
    safe_allocate(this%range(1:2, 0:this%mpi_grp%size - 1))
 
    ! Defaults
    if (this%mpi_grp%size == 1 .or. total == 1) then
      this%process(1:total) = 0
      this%start            = 1
      this%end              = total
      this%parallel         = .false.
      this%range(:, 0)      = [1, total]
      this%num(0)           = total
      call mpi_grp_init(this%mpi_grp, mpi_comm_undefined)
 
    else
      this%parallel = .true.
 
      call multicomm_divide_range(total, this%mpi_grp%size, this%range(1, :), this%range(2, :), &
        lsize = this%num, scalapack_compat = scalapack_compat)
 
      this%start = this%range(1, this%mpi_grp%rank)
      this%end   = this%range(2, this%mpi_grp%rank)
 
      do i = 0, this%mpi_grp%size - 1
        this%process(this%range(1, i):this%range(2, i)) = i
      end do
 
      if (present(tag)) then
        message(1) = 'Info: Parallelization in ' // trim(tag)
        call messages_info(1)
        do i = 0, this%mpi_grp%size - 1
          write(message(1),'(a,i4,a,i6,a)') 'Info: Process in group ', i, &
            ' will manage ', this%num(i), ' '//trim(tag)
          if (this%num(i) > 0) then
            write(message(1),'(a,a,i6,a,i6)') trim(message(1)), ':', this%range(1, i), " - ", this%range(2, i)
          end if
          call messages_info(1)
        end do
      end if
 
    end if
 
    pop_sub(distributed_init)
  end subroutine distributed_init
 
 
  subroutine distributed_init_serial(this, total)
    type(distributed_t), intent(out) :: this
    integer,             intent(in)  :: total
 
    push_sub(distributed_init_serial)
 
    call distributed_init(this, total, mpi_comm_undefined)
 
    pop_sub(distributed_init_serial)
 
  end subroutine distributed_init_serial
 
 
  subroutine distributed_copy(in, out)
    type(distributed_t), intent(in)    :: in
    type(distributed_t), intent(inout) :: out
 
    integer :: nprocs
 
    push_sub(distributed_copy)
 
    call distributed_end(out)
 
    out%start    = in%start
    out%end      = in%end
    out%parallel = in%parallel
 
    nprocs = in%mpi_grp%size
 
    call mpi_grp_init(out%mpi_grp, in%mpi_grp%comm)
 
    if (allocated(in%process)) then
      safe_allocate(out%process(1:size(in%process)))
      out%process(:) = in%process(:)
    end if
 
    if (allocated(in%range)) then
      safe_allocate(out%range(1:2, 0:nprocs - 1))
      out%range(1:2, 0:nprocs - 1) = in%range(1:2, 0:nprocs - 1)
    end if
 
    if (allocated(in%num)) then
      safe_allocate(out%num(0:nprocs - 1))
      out%num(0:nprocs - 1) = in%num(0:nprocs - 1)
    end if
 
    pop_sub(distributed_copy)
  end subroutine distributed_copy
 
 
  subroutine distributed_end(this)
    type(distributed_t), intent(inout) :: this
 
    push_sub(distributed_end)
 
    safe_deallocate_a(this%process)
    safe_deallocate_a(this%range)
    safe_deallocate_a(this%num)
 
    pop_sub(distributed_end)
  end subroutine distributed_end
 
end module distributed_oct_m
 
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: