mpi_debug.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.
!!
 
! Routines to support MPI debugging.
 
#include "global.h"
 
module mpi_debug_oct_m
#ifdef HAVE_MPI
  use mpi_f08
#else
  use mpi_serial_stub_oct_m
#endif
  use, intrinsic :: iso_fortran_env
  use loct_oct_m
 
  implicit none
 
  private
 
  public ::               &
    mpi_debug_statistics, &
    mpi_debug_init,       &
    mpi_debug_in,         &
    mpi_debug_out
 
  integer, parameter :: C_NUM_MPI_ROUTINES = 12
 
  integer, public, parameter ::  &
    C_MPI_BARRIER    = 1,        &
    c_mpi_scatterv   = 2,        &
    c_mpi_gatherv    = 3,        &
    c_mpi_gather     = 4,        &
    c_mpi_alltoallv  = 5,        &
    c_mpi_allgatherv = 6,        &
    c_mpi_bcast      = 7,        &
    c_mpi_allreduce  = 8,        &
    c_mpi_alltoall   = 9,        &
    c_mpi_allgather  = 10,        &
    c_mpi_file_read  = 11,       &
    c_mpi_file_write = 12
 
  character(len=14), dimension(C_NUM_MPI_ROUTINES), public :: mpi_rlabel = &
    (/                           &
    'MPI_BARRIER   ',            &
    'MPI_SCATTERV  ',            &
    'MPI_GATHERV   ',            &
    'MPI_GATHER    ',            &
    'MPI_ALLTOALLV ',            &
    'MPI_ALLGATHERV',            &
    'MPI_BCAST     ',            &
    'MPI_ALLREDUCE ',            &
    'MPI_ALLTOALL  ',            &
    'MPI_ALLGATHER ',            &
    'MPI_FILE_READ ',            &
    'MPI_FILE_WRITE'             &
    /)
 
  integer, public :: call_counter(C_NUM_MPI_ROUTINES) = 0
  real(real64), public :: sec_accum(C_NUM_MPI_ROUTINES)   = 0_real64
 
  real(real64) :: sec_in
 
  logical :: debug_info
  integer :: mpi_rank
 
  integer, parameter :: unit_offset = 1000
 
contains
 
  ! ---------------------------------------------------------
  subroutine mpi_debug_init(rank, info)
    integer, intent(in) :: rank
    logical, intent(in) :: info
 
    mpi_rank = rank
    debug_info = info
  end subroutine mpi_debug_init
 
  ! ---------------------------------------------------------
  subroutine mpi_debug_open_trace(iunit)
    integer, intent(out) :: iunit
 
    character(len=6) :: filenum
 
    iunit = mpi_rank + unit_offset
    write(filenum, '(i6.6)') iunit - unit_offset
    call loct_mkdir('debug')
    open(iunit, file = 'debug/debug_trace.node.'//filenum, &
      action='write', status='unknown', position='append')
 
  end subroutine mpi_debug_open_trace
 
  ! ---------------------------------------------------------
  subroutine mpi_debug_statistics()
#if defined(HAVE_MPI)
    integer :: j, iunit
    real(real64) :: usec_call(C_NUM_MPI_ROUTINES)
#endif
 
    if (.not. debug_info) return
#if defined(HAVE_MPI)
 
    call mpi_debug_open_trace(iunit)
 
    write(iunit,*)
    write(iunit,'(A)') '--------------------------------------------------------------------'
    write(iunit,*)
    write(iunit, '(23x,a,4x,a,8x,a)') 'total time', 'calls', 'usec/call'
    do j = 1, c_num_mpi_routines
      if (call_counter(j) <= 0) then
        usec_call(j) = 0
      else
        usec_call(j) = (sec_accum(j)*1000000)/call_counter(j)
      end if
 
      write(iunit,'(a,f13.6,6x,i4,6x,f13.0)') &
        mpi_rlabel(j)//' : ', sec_accum(j),          &
        call_counter(j), usec_call(j)
    end do
    write(iunit,*)
    write(iunit,'(A)') '--------------------------------------------------------------------'
 
    close(iunit)
#endif
 
  end subroutine mpi_debug_statistics
 
 
  ! ---------------------------------------------------------
  subroutine mpi_debug_in(comm, index)
    type(mpi_comm), intent(in) :: comm
    integer, intent(in) :: index
 
    integer :: iunit
 
    if (.not. debug_info) return
 
    call mpi_debug_open_trace(iunit)
 
    call_counter(index) = call_counter(index) + 1
#if defined(HAVE_MPI)
    sec_in              = mpi_wtime()
#endif
    write(iunit,'(a,f18.6,a,z8.8,a,i6.6,a,f13.6)') '* MPI_I ', &
      sec_in, ' '//mpi_rlabel(index)//' : 0x', comm%MPI_VAL, ' | ',  &
      call_counter(index), ' - ', sec_accum(index)
 
    close(iunit)
 
  end subroutine mpi_debug_in
 
 
  ! ---------------------------------------------------------
  subroutine mpi_debug_out(comm, index)
    type(mpi_comm), intent(in) :: comm
    integer, intent(in) :: index
 
    integer :: iunit
    real(real64) :: sec_out, sec_diff
 
    if (.not. debug_info) return
 
    call mpi_debug_open_trace(iunit)
 
#if defined(HAVE_MPI)
    sec_out = mpi_wtime()
#endif
    call mpi_time_accum(index, sec_out, sec_diff)
    write(iunit,'(a,f18.6,a,z8.8,a,i6.6,a,f13.6,a,f13.6)')         &
      '* MPI_O ', sec_out, ' '//mpi_rlabel(index)//' : 0x', comm%MPI_VAL, ' | ', &
      call_counter(index), ' - ', sec_accum(index), ' - ', sec_diff
 
    close(iunit)
 
  end subroutine mpi_debug_out
 
 
  ! ---------------------------------------------------------
  subroutine mpi_time_accum(index, sec, sec_diff)
    integer, intent(in)  :: index
    real(real64), intent(in)  :: sec
    real(real64), intent(out) :: sec_diff
 
    sec_diff         = sec - sec_in
    sec_accum(index) = sec_accum(index) + sec_diff
 
  end subroutine mpi_time_accum
 
end module mpi_debug_oct_m
 
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: