dc_message.f90

Go to the documentation of this file.

! -*- mode: f90; coding: utf-8 -*-
!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
module dc_message
  ! MPI ライブラリ
  ! MPI library
  !
  use mpi
  implicit none
  private
  public:: messagenotify
  public:: messagesuppressmpi
  interface messagenotify
    module procedure messagenotifyc
    module procedure messagenotifyi
  end interface
  interface messagesuppressmpi
    module procedure messagesuppressmpi0
  end interface
  integer, save:: output_rank = -1
  integer, save:: save_myrank = -1
contains
  subroutine messagenotifyc(level, where, message, &
    & i, r, d, L, n, c1, c2, c3, ca, rank_mpi )
    use dc_types  ,only: string, dp
    use dc_string ,only: uchar, strhead, printf, cprintf
    use dc_error  ,only: storeerror, usr_errno
    implicit none
    character(*), intent(in)          :: level
    character(*), intent(in)          :: where
    character(*), intent(in)          :: message
    integer     , intent(in), optional:: i(:), n(:)
    real        , intent(in), optional:: r(:)
    real(DP)    , intent(in), optional:: d(:)
    logical     , intent(in), optional:: L(:)
    character(*), intent(in), optional:: c1, c2, c3
    character(*), intent(in), optional:: ca(:)
    integer     , intent(in), optional:: rank_mpi
    character(string)        :: msg
  continue
    if ( invalid_rank_number( rank_mpi ) ) return
    if (   strhead(  'ERROR', trim( uchar(level) )  )   ) then
      msg = cprintf(message, &
        &           i=i, r=r, d=d, l=l, n=n, c1=c1, c2=c2, c3=c3, ca=ca)
      call storeerror(usr_errno, where, cause_c=msg)
    elseif (   strhead(  'WARNING', trim( uchar(level) )  )   ) then
      msg = cprintf(message, &
        &           i=i, r=r, d=d, l=l, n=n, c1=c1, c2=c2, c3=c3, ca=ca)
      msg=' *** WARNING [' // trim(where) // '] ***  '// trim(msg)
      call printf(fmt='%c', c1=msg)
    else
      msg = cprintf(message, &
        &           i=i, r=r, d=d, l=l, n=n, c1=c1, c2=c2, c3=c3, ca=ca)
      msg=' *** MESSAGE [' // trim(where) // '] ***  ' // trim(msg)
      call printf(fmt='%c', c1=msg)
    endif
    return
  end subroutine messagenotifyc
  subroutine messagenotifyi(number, where, message, &
    & i, r, d, L, n, c1, c2, c3, ca, rank_mpi )
    use dc_types  ,only: dp
    use dc_string ,only: cprintf
    use dc_error  ,only: storeerror
    implicit none
    integer,      intent(in)          :: number
    character(*), intent(in)          :: where
    character(*), intent(in), optional:: message
    integer     , intent(in), optional:: i(:), n(:)
    real        , intent(in), optional:: r(:)
    real(DP)    , intent(in), optional:: d(:)
    logical     , intent(in), optional:: L(:)
    character(*), intent(in), optional:: c1, c2, c3
    character(*), intent(in), optional:: ca(:)
    integer     , intent(in), optional:: rank_mpi
  continue
    if ( invalid_rank_number( rank_mpi ) ) return
    if (.not. present(message)) then
      call storeerror(number, where)
    else
      call storeerror(number, where,  &
        &             cause_c=cprintf( message, &
        &             i=i, r=r, d=d, l=l, n=n, c1=c1, c2=c2, c3=c3, ca=ca )  )
    endif
    return
  end subroutine messagenotifyi
  subroutine messagesuppressmpi0( rank )
    implicit none
    integer, intent(in):: rank
  continue
    output_rank = rank
  end subroutine messagesuppressmpi0
  logical function invalid_rank_number( rank_mpi ) result(result)
    implicit none
    integer     , intent(in), optional:: rank_mpi
    logical:: initflag_mpi
    integer:: err_mpi
  continue
    if ( save_myrank < 0 ) then
      call mpi_initialized(initflag_mpi, err_mpi)
      if ( initflag_mpi ) then
        call mpi_comm_rank(mpi_comm_world, save_myrank, err_mpi)
      else
        result = .false.
        return
      end if
    end if
    if ( .not. present(rank_mpi) ) then
      if ( output_rank > -1 ) then
        if ( output_rank == save_myrank ) then
          result = .false.
          return
        else
          result = .true.
          return
        end if
      end if
      result = .false.
      return
    end if
    if ( rank_mpi < 0 ) then
      result = .false.
      return
    end if
    if ( rank_mpi == save_myrank ) then
      result = .false.
    else
      result = .true.
    end if
  end function invalid_rank_number
end module dc_message