!= 繝｡繝�そ繝ｼ繧ｸ縺ｮ蜃ｺ蜉�
!
! 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