!= ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›
!
! Authors::   Yasuhiro MORIKAWA, Masatsugu ODAKA
! Version::   $Id: dc_message.F90,v 1.1 2009-03-20 09:09:53 morikawa Exp $
! Tag Name::  $Name:  $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!

module dc_message
  !
  != ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›
  !
  !ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›ã‚’è¡Œã†ãŸã‚ã®ã‚µãƒ–ãƒ«ãƒ¼ãƒãƒ³ç¾¤ã‚’æŒã¤ãƒ¢ã‚¸ãƒ¥ãƒ¼ãƒ«ã§ã™ã€‚
  !{dcl ã® MSGDMP.f}[http://www.gfd-dennou.org/arch/dcl/dcl-f77doc/rc1/math1/node26.html]
  !ã®ä¸Šä½äº’æ›ã¨ã—ã¦ã‚‚åˆ©ç”¨ã™ã‚‹ã“ã¨ã‚’æƒ³å®šã—ã¦ã„ã¾ã™ã€‚
  !ç¾åœ¨ã€å‡ºåŠ›è£…ç½®ã¯æ¨™æº–å‡ºåŠ›ã«å›ºå®šã•ã‚Œã¦ã„ã¾ã™ã€‚
  !
  !
  !== Tutorial
  !
  ! * gtool5 ã‚ªãƒ•ã‚£ã‚·ãƒ£ãƒ«ãƒãƒ¥ãƒ¼ãƒˆãƒªã‚¢ãƒ«:
  !   {ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›}[link:../tutorial/dc_message.htm]
  !
  !== Output Form
  !
  ! æœ¬ãƒ¢ã‚¸ãƒ¥ãƒ¼ãƒ«ã®ã‚µãƒ–ãƒ«ãƒ¼ãƒãƒ³ã«ã‚ˆã£ã¦ä»¥ä¸‹ã®ã‚ˆã†ãªå½¢å¼ã®ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸
  ! ãŒå‡ºåŠ›ã•ã‚Œã¾ã™ã€‚
  !
  !    ã€€
  !    *** MESSAGE [where] ***  message
  !    ã€€
  !    *** WARNING [where] ***  message
  !    ã€€
  !    *** ERROR (Code number) [where] *** message
  !
#ifdef LIB_MPI
  ! MPI ãƒ©ã‚¤ãƒ–ãƒ©ãƒª
  ! MPI library
  !
  use mpi
#endif
  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
#ifdef LIB_MPI
  integer, save:: save_myrank = -1
#endif

contains

  subroutine MessageNotifyC(level, where, message, &
    & i, r, d, L, n, c1, c2, c3, ca, rank_mpi )
    !
    !=== ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›ãŠã‚ˆã³ã‚¨ãƒ©ãƒ¼ã«ã‚ˆã‚‹çµ‚äº†
    !
    ! ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã‚’æ¨™æº–å‡ºåŠ›ã¸å‡ºåŠ›ã—ãŸã„å ´åˆã«ç”¨ã„ã¾ã™ã€‚
    !
    ! æ–‡å—åž‹å¤‰æ•° where ã«ã¯ãƒ—ãƒã‚°ãƒ©ãƒ å (ã‚µãƒ–ãƒ«ãƒ¼ãƒãƒ³å) ãªã©ã€
    ! ãƒ—ãƒã‚°ãƒ©ãƒ å†…ã®ã©ã“ã§ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã‚’å‡ºåŠ›ã™ã‚‹ã®ã‹ã‚’ç¤ºã™ã‚‚ã®ã‚’ä¸Žãˆã¾ã™ã€‚
    !
    ! æ–‡å—åž‹å¤‰æ•° message ã«ã¯ã€å‡ºåŠ›ã—ãŸã„æ–‡å—åˆ—ã‚’ä¸Žãˆã¾ã™ã€‚
    ! ã‚ªãƒ—ã‚·ãƒ§ãƒ³å¤‰æ•° i, r, d, L, s, n, c1, c2, c3 ã‚’ä»˜åŠ ã™ã‚‹äº‹ã‚‚å‡ºæ¥ã¾ã™ã€‚
    ! è©³ç´°ã«é–¢ã—ã¦ã¯ dc_string#CPrintf ã‚’å‚ç…§ã—ã¦ä¸‹ã•ã„ã€‚
    !
    ! æ–‡å—åž‹å¤‰æ•° level ã¯å‡ºåŠ›ã™ã‚‹ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®ç¨®é¡žã‚’æ±ºã‚ã‚‹å¼•æ•°ã§ã€
    ! <b><tt>"W"</tt></b> (ã¾ãŸã¯<b><tt>"Warning"</tt></b>
    ! ãªã© <b><tt>"W"</tt></b> ã§å§‹ã¾ã‚‹æ–‡å—)
    ! ã‚’ä¸Žãˆã‚‹äº‹ã§<b>è¦å‘Š</b>ã§ã‚ã‚‹ã“ã¨ã‚’ã€
    ! <b><tt>"E"</tt></b> (ã¾ãŸã¯<b><tt>"Error"</tt></b>
    ! ãªã© <b><tt>"E"</tt></b> ã§å§‹ã¾ã‚‹æ–‡å—) ã‚’ä¸Žãˆã‚‹äº‹ã§
    ! <b>ã‚¨ãƒ©ãƒ¼ (ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸å‡ºåŠ›å¾Œãƒ—ãƒã‚°ãƒ©ãƒ ã‚’çµ‚äº†) </b>ã§ã‚ã‚‹ã“ã¨ã‚’ã€
    ! ãã‚Œä»¥å¤–ã®æ–‡å— (å¤§æŠµã¯ <b><tt>"M"</tt></b>
    ! ã‚’ä¸Žãˆã‚‹ã“ã¨ã‚’æƒ³å®šã—ã¦ã„ã¾ã™)
    ! ã‚’ä¸Žãˆã‚‹äº‹ã§<b>é€šå¸¸ã®ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸</b>ã§ã‚ã‚‹ã“ã¨ã‚’æŒ‡å®šã—ã¾ã™ã€‚
    ! <b><tt>"E"</tt></b>ã‚’ä¸ŽãˆãŸå ´åˆã¯ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸å‡ºåŠ›å¾Œã€ãƒ—ãƒã‚°ãƒ©ãƒ ã‚’
    ! å¼·åˆ¶çµ‚äº†ã•ã›ã¾ã™ã€‚ã‚¨ãƒ©ãƒ¼ã‚³ãƒ¼ãƒ‰ã¯ dc_error#USR_ERRNO ã¨ãªã‚Šã¾ã™ã€‚
    !

    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 ! "E", "W", "M" ã®ã©ã‚Œã‹ã‚’ä¸Žãˆã‚‹ã€‚
    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
                                        ! MPI ä½¿ç”¨æ™‚ã«, ã“ã“ã§æŒ‡å®šã•ã‚ŒãŸ
                                        ! ãƒ©ãƒ³ã‚¯æ•°ã®ãƒŽãƒ¼ãƒ‰ã§ã®ã¿
                                        ! ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        ! è² ã®å€¤ã‚’ä¸ŽãˆãŸå ´åˆã«ã¯,
                                        ! å…¨ã¦ã®ãƒŽãƒ¼ãƒ‰ã§å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        !
                                        ! MPI ã‚’ä½¿ç”¨ã—ã¦ã„ãªã„å ´åˆã«ã¯
                                        ! ã“ã®ã‚ªãƒ—ã‚·ãƒ§ãƒ³ã¯ç„¡è¦–ã•ã‚Œã¾ã™.
                                        !
                                        ! When MPI is used, messages are
                                        ! output in only node that has
                                        ! this runk number.
                                        ! If negative value is given,
                                        ! output is done on all nodes
                                        !
                                        ! This option is ignored
                                        ! if MPI is not used.
                                        !

    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 )
    !
    !=== ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸ã®å‡ºåŠ›ãŠã‚ˆã³ã‚¨ãƒ©ãƒ¼ã«ã‚ˆã‚‹çµ‚äº†
    !
    ! åŸºæœ¬çš„ã«ã‚‚ã†ä¸€æ–¹ã® MessageNotify (ã¾ãŸã¯ dc_message#MessageNotifyC)
    ! ã¨åŒæ§˜ã§ã™ãŒã€ã“ã¡ã‚‰ã¯ç¬¬ï¼‘å¼•æ•°ã«æ•°å€¤åž‹å¤‰æ•°
    ! number ã‚’ã¨ã‚Šã¾ã™ã€‚ã“ã® number ã¯ã‚¨ãƒ©ãƒ¼ã‚³ãƒ¼ãƒ‰ã¨ã—ã¦ã€
    ! ãã®ã¾ã¾ dc_error#StoreError ã«å¼•ãæ¸¡ã•ã‚Œã¾ã™ã€‚
    ! ã‚¨ãƒ©ãƒ¼ã‚³ãƒ¼ãƒ‰ã«é–¢ã—ã¦ã¯ (dc_error ã‚’å‚ç…§ãã ã•ã„)
    !
    use dc_types  ,only: DP
    use dc_string ,only: CPrintf
    use dc_error  ,only: StoreError, USR_ERRNO

    implicit none

    integer,      intent(in)          :: number    ! ã‚¨ãƒ©ãƒ¼ã‚³ãƒ¼ãƒ‰ (dc_error å‚ç…§)
    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
                                        ! MPI ä½¿ç”¨æ™‚ã«, ã“ã“ã§æŒ‡å®šã•ã‚ŒãŸ
                                        ! ãƒ©ãƒ³ã‚¯æ•°ã®ãƒŽãƒ¼ãƒ‰ã§ã®ã¿
                                        ! ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        ! è² ã®å€¤ã‚’ä¸ŽãˆãŸå ´åˆã«ã¯,
                                        ! å…¨ã¦ã®ãƒŽãƒ¼ãƒ‰ã§å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        !
                                        ! MPI ã‚’ä½¿ç”¨ã—ã¦ã„ãªã„å ´åˆã«ã¯
                                        ! ã“ã®ã‚ªãƒ—ã‚·ãƒ§ãƒ³ã¯ç„¡è¦–ã•ã‚Œã¾ã™.
                                        !
                                        ! When MPI is used, messages are
                                        ! output in only node that has
                                        ! this runk number.
                                        ! If negative value is given,
                                        ! output is done on all nodes
                                        !
                                        ! This option is ignored
                                        ! if MPI is not used.
                                        !

  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
                                        ! å‡ºåŠ›ã™ã‚‹ãƒŽãƒ¼ãƒ‰ã®ãƒ©ãƒ³ã‚¯æ•°.
                                        !
                                        ! ã“ã“ã«æŒ‡å®šã•ã‚ŒãŸãƒ©ãƒ³ã‚¯æ•°ä»¥å¤–ã®
                                        ! ãƒŽãƒ¼ãƒ‰ã§ã®å‡ºåŠ›ã¯æŠ‘æ¢ã•ã‚Œã¾ã™.
                                        !
                                        ! MPI ã‚’ä½¿ç”¨ã—ã¦ã„ãªã„å ´åˆã«ã¯
                                        ! ã‚µãƒ–ãƒ«ãƒ¼ãƒãƒ³ã¯ç„¡åŠ¹ã§ã™.
                                        !
                                        ! Number of rank of an node that output.
                                        !
                                        ! Output on nodes that do not have
                                        ! this rank number is suppressed.
                                        !
                                        ! This subroutine is ignored,
                                        ! if MPI is not used.
                                        !
  continue
    output_rank = rank
  end subroutine MessageSuppressMPI0

  logical function invalid_rank_number( rank_mpi ) result(result)
    implicit none
    integer     , intent(in), optional:: rank_mpi
                                        ! MPI ä½¿ç”¨æ™‚ã«, ã“ã“ã§æŒ‡å®šã•ã‚ŒãŸ
                                        ! ãƒ©ãƒ³ã‚¯æ•°ã®ãƒŽãƒ¼ãƒ‰ã§ã®ã¿
                                        ! ãƒ¡ãƒƒã‚»ãƒ¼ã‚¸å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        ! è² ã®å€¤ã‚’ä¸ŽãˆãŸå ´åˆã«ã¯,
                                        ! å…¨ã¦ã®ãƒŽãƒ¼ãƒ‰ã§å‡ºåŠ›ã‚’è¡Œã„ã¾ã™.
                                        !
                                        ! MPI ã‚’ä½¿ç”¨ã—ã¦ã„ãªã„å ´åˆã«ã¯
                                        ! ã“ã®ã‚ªãƒ—ã‚·ãƒ§ãƒ³ã¯ç„¡è¦–ã•ã‚Œã¾ã™.
                                        !
                                        ! When MPI is used, messages are
                                        ! output in only node that has
                                        ! this runk number.
                                        ! If negative value is given,
                                        ! output is done on all nodes
                                        !
                                        ! This option is ignored
                                        ! if MPI is not used.
                                        !
#ifdef LIB_MPI
    logical:: initflag_mpi
    integer:: err_mpi
#endif
  continue

#ifndef LIB_MPI
    result = .false.
    return
#else
    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
#endif
  end function invalid_rank_number

end module dc_message