blacs_proc_grid.F90

Go to the documentation of this file.

!! Copyright (C) 2005-2006 Heiko Appel, Florian Lorenzen
!!
!! 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 blacs_proc_grid_oct_m
  use debug_oct_m
  use global_oct_m
  use blacs_oct_m
  use mpi_oct_m
  use messages_oct_m
  use profiling_oct_m
 
  implicit none
 
  private
 
  public ::                      &
    blacs_proc_grid_t,           &
    blacs_proc_grid_init,        &
    blacs_proc_grid_end,         &
    blacs_proc_grid_copy,        &
    blacs_proc_grid_null
 
  integer :: BLACS_NULL_CONTEXT = -1
 
  type blacs_proc_grid_t
    ! Components are public by default
    integer          :: context = -1
    integer          :: nprocs
    integer          :: nprow
    integer          :: npcol
    integer, private :: iam
    integer          :: myrow
    integer          :: mycol
    integer, allocatable :: usermap(:, :)
  end type blacs_proc_grid_t
 
contains
 
  subroutine blacs_proc_grid_init(this, mpi_grp, procdim)
    type(blacs_proc_grid_t),           intent(inout) :: this
    type(mpi_grp_t),                   intent(in)    :: mpi_grp
    integer,                 optional, intent(in)    :: procdim(:)
 
#ifdef HAVE_SCALAPACK
 
    integer, parameter :: maxdims = 2
    integer :: dims(1:2), topo, coords(1:2), ix, iy, id, xy(2)
    logical :: periods(1:2)
    type(MPI_Comm) :: comm
    logical :: reorder
    integer, allocatable :: procmap(:)
 
    push_sub(blacs_proc_grid_init)
 
    call mpi_topo_test(mpi_grp%comm, topo, mpi_err)
 
    if (topo /= mpi_cart .or. present(procdim)) then
      ! We create a new communicator with Cartesian topology
      if (present(procdim)) then
        dims(1) = procdim(1)
        dims(2) = procdim(2)
      else
        dims(1) = mpi_grp%size
        dims(2) = 1
      end if
      periods = .false.
      reorder = .false.
      call mpi_cart_create(mpi_grp%comm, 2, dims, periods, reorder, comm, mpi_err)
    else
      comm = mpi_grp%comm
    end if
 
    call blacs_pinfo(this%iam, this%nprocs)
 
    ! The process ID from ScaLAPACK is not always the
    ! same as MPI, so we need to construct a map.
    safe_allocate(procmap(0:mpi_grp%size - 1))
    call mpi_allgather(this%iam, 1, mpi_integer, procmap(0), 1, mpi_integer, comm, mpi_err)
 
    assert(this%iam == procmap(mpi_grp%rank))
 
    dims = 1
    coords = 0
 
    call mpi_cart_get(comm, maxdims, dims, periods, coords, mpi_err)
 
    safe_allocate(this%usermap(1:dims(1), 1:dims(2)))
 
    do ix = 1, dims(1)
      xy(1) = ix - 1
      do iy = 1, dims(2)
        xy(2) = iy - 1
        call mpi_cart_rank(comm, xy, id, mpi_err)
        this%usermap(ix, iy) = procmap(id)
      end do
    end do
 
    ! get the default system context
    call blacs_get(blacs_null_context, what = 0, val = this%context)
 
    ! now get the context associated with the map
    call blacs_gridmap(this%context, this%usermap(1, 1), dims(1), dims(1), dims(2))
 
    ! and fill the rest of the structure
    call blacs_gridinfo(this%context, this%nprow, this%npcol, this%myrow, this%mycol)
 
    !check that Blacs and MPI are consistent
    assert(this%nprow == dims(1))
    assert(this%npcol == dims(2))
    assert(this%myrow == coords(1))
    assert(this%mycol == coords(2))
 
    if (topo /= mpi_cart) then
      call mpi_comm_free(comm, mpi_err)
    end if
 
    safe_deallocate_a(procmap)
 
    pop_sub(blacs_proc_grid_init)
#else
    push_sub(blacs_proc_grid_init)
    this%context = blacs_null_context
    pop_sub(blacs_proc_grid_init)
#endif
  end subroutine blacs_proc_grid_init
 
  ! ----------------------------------------------------
 
  subroutine blacs_proc_grid_end(this)
    type(blacs_proc_grid_t), intent(inout) :: this
 
    push_sub(blacs_proc_grid_end)
 
    if (this%context /= blacs_null_context) then
#ifdef HAVE_SCALAPACK
      call blacs_gridexit(this%context)
#endif
      safe_deallocate_a(this%usermap)
    end if
 
    this%context = blacs_null_context
 
    pop_sub(blacs_proc_grid_end)
  end subroutine blacs_proc_grid_end
 
  ! ----------------------------------------------------
 
  subroutine blacs_proc_grid_copy(cin, cout)
    type(blacs_proc_grid_t), intent(in)    :: cin
    type(blacs_proc_grid_t), intent(inout) :: cout
 
    push_sub(blacs_proc_grid_copy)
 
    call blacs_proc_grid_end(cout)
 
    cout%context = cin%context
 
#ifdef HAVE_SCALAPACK
    cout%nprocs  = cin%nprocs
    cout%nprow   = cin%nprow
    cout%npcol   = cin%npcol
    cout%iam     = cin%iam
    cout%myrow   = cin%myrow
    cout%mycol   = cin%mycol
 
    if (cout%context /= blacs_null_context) then
      ! we have to create a new context
      call blacs_get(blacs_null_context, what = 0, val = cout%context)
      safe_allocate_source_a(cout%usermap, cin%usermap)
      call blacs_gridmap(cout%context, cout%usermap(1, 1), cout%nprow, cout%nprow, cout%npcol)
    end if
 
#endif
    pop_sub(blacs_proc_grid_copy)
  end subroutine blacs_proc_grid_copy
 
 
  logical pure function blacs_proc_grid_null(this)
    type(blacs_proc_grid_t), intent(in) :: this
 
    blacs_proc_grid_null = this%context == blacs_null_context
  end function blacs_proc_grid_null
 
end module blacs_proc_grid_oct_m
 
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: