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.
!-----------------------------------------------------------------------
!>
!> @author    Yasuhiro MORIKAWA, Masatsugu ODAKA
!> @copyright Copyright (C) GFD Dennou Club, 2000-2026. All rights reserved. <br/>
!>            License is BSD-2-Clause. see [COPYRIGHT](@ref COPYRIGHT) in detail
!>
!> @en
!> @brief Message output module
!> @details
!> This module provides subroutines for outputting messages.
!> It is intended to be used as a higher-level interface to
!> dcl's MSGDMP.f (http://www.gfd-dennou.org/arch/dcl/dcl-f77doc/rc1/math1/node26.html).
!> Currently, the output device is fixed to standard output.
!>
!> @section dc_message_output Output Form
!>
!> Messages are output in the following formats by subroutines of this module:
!>
!> @code
!> *** MESSAGE [where] ***  message
!>
!> *** WARNING [where] ***  message
!>
!> *** ERROR (Code number) [where] *** message
!> @endcode
!>
!> @enden
!>
!> @ja
!> @brief メッセージの出力
!> @details
!> メッセージの出力を行うためのサブルーチン群を持つモジュールです。
!> dcl の MSGDMP.f (http://www.gfd-dennou.org/arch/dcl/dcl-f77doc/rc1/math1/node26.html)
!> の上位互換としても利用することを想定しています。
!> 現在、出力装置は標準出力に固定されています。
!>
!> @section dc_message_output_ja 出力形式
!>
!> 本モジュールのサブルーチンによって以下のような形式のメッセージ
!> が出力されます。
!>
!> @code
!> *** MESSAGE [where] ***  message
!>
!> *** WARNING [where] ***  message
!>
!> *** ERROR (Code number) [where] *** message
!> @endcode
!>
!> @endja
!>
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
  !> @en
  !> @brief Output message or terminate with error
  !> @details
  !> Use this subroutine when you want to output a message to standard output.
  !>
  !> Give the character variable `where` as the program name (subroutine name) etc.,
  !> indicating where in the program the message is output.
  !>
  !> Give the character variable `message` the string you want to output.
  !> You can also add optional variables i, r, d, L, s, n, c1, c2, c3.
  !> See dc_string::CPrintf for details.
  !>
  !> The character variable `level` determines the type of message to output:
  !> - "W" (or "Warning", etc. starting with "W") indicates a **warning**
  !> - "E" (or "Error", etc. starting with "E") indicates an **error** (program terminates after message output)
  !> - Other characters (usually "M" is expected) indicate a **normal message**
  !>
  !> If "E" is given, the program is forcibly terminated after the message is output.
  !> The error code will be dc_error::USR_ERRNO.
  !>
  !> @param[in] level Message level ("E", "W", or "M")
  !> @param[in] where Program name, procedure name
  !> @param[in] message Message text
  !> @param[in] i Integer values for formatting
  !> @param[in] r Real values for formatting
  !> @param[in] d Double precision values for formatting
  !> @param[in] L Logical values for formatting
  !> @param[in] n Integer values for formatting
  !> @param[in] c1 Character string 1 for formatting
  !> @param[in] c2 Character string 2 for formatting
  !> @param[in] c3 Character string 3 for formatting
  !> @param[in] ca Character array for formatting
  !> @param[in] rank_mpi When MPI is used, messages are output only on the node with
  !>            this rank number. If a negative value is given, output is done on all nodes.
  !>            This option is ignored if MPI is not used.
  !> @enden
  !>
  !> @ja
  !> @brief メッセージの出力およびエラーによる終了
  !> @details
  !> メッセージを標準出力へ出力したい場合に用います。
  !>
  !> 文字型変数 `where` にはプログラム名 (サブルーチン名) など、
  !> プログラム内のどこでメッセージを出力するのかを示すものを与えます。
  !>
  !> 文字型変数 `message` には、出力したい文字列を与えます。
  !> オプション変数 i, r, d, L, s, n, c1, c2, c3 を付加する事も出来ます。
  !> 詳細に関しては dc_string::CPrintf を参照して下さい。
  !>
  !> 文字型変数 `level` は出力するメッセージの種類を決める引数で、
  !> - "W" (または "Warning" など "W" で始まる文字) を与える事で **警告** であることを指定
  !> - "E" (または "Error" など "E" で始まる文字) を与える事で **エラー** (メッセージ出力後プログラムを終了) であることを指定
  !> - それ以外の文字 (大抵は "M" を与えることを想定) を与える事で **通常のメッセージ** であることを指定
  !>
  !> "E" を与えた場合はメッセージ出力後、プログラムを強制終了させます。
  !> エラーコードは dc_error::USR_ERRNO となります。
  !>
  !> @param[in] level メッセージレベル ("E", "W", "M" のいずれか)
  !> @param[in] where プログラム名、手続き名
  !> @param[in] message メッセージ
  !> @param[in] i フォーマット用整数配列
  !> @param[in] r フォーマット用実数配列
  !> @param[in] d フォーマット用倍精度実数配列
  !> @param[in] L フォーマット用論理配列
  !> @param[in] n フォーマット用整数配列
  !> @param[in] c1 フォーマット用文字列1
  !> @param[in] c2 フォーマット用文字列2
  !> @param[in] c3 フォーマット用文字列3
  !> @param[in] ca フォーマット用文字列配列
  !> @param[in] rank_mpi MPI 使用時に、ここで指定されたランク数のノードでのみ
  !>            メッセージ出力を行います。負の値を与えた場合には、
  !>            全てのノードで出力を行います。MPI を使用していない場合には無視されます。
  !> @endja
  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
  !> @en
  !> @brief Output message or terminate with error (with error code)
  !> @details
  !> Basically the same as the other MessageNotify (or dc_message::MessageNotifyC),
  !> but this one takes a numeric variable `number` as the first argument.
  !> This `number` is passed directly to dc_error::StoreError as an error code.
  !> See dc_error for error codes.
  !>
  !> @param[in] number Error code (see dc_error)
  !> @param[in] where Program name, procedure name
  !> @param[in] message Message text (optional)
  !> @param[in] i Integer values for formatting
  !> @param[in] r Real values for formatting
  !> @param[in] d Double precision values for formatting
  !> @param[in] L Logical values for formatting
  !> @param[in] n Integer values for formatting
  !> @param[in] c1 Character string 1 for formatting
  !> @param[in] c2 Character string 2 for formatting
  !> @param[in] c3 Character string 3 for formatting
  !> @param[in] ca Character array for formatting
  !> @param[in] rank_mpi When MPI is used, messages are output only on the node with
  !>            this rank number. If a negative value is given, output is done on all nodes.
  !>            This option is ignored if MPI is not used.
  !> @enden
  !>
  !> @ja
  !> @brief メッセージの出力およびエラーによる終了 (エラーコード版)
  !> @details
  !> 基本的にもう一方の MessageNotify (または dc_message::MessageNotifyC)
  !> と同様ですが、こちらは第１引数に数値型変数 `number` をとります。
  !> この `number` はエラーコードとして、そのまま dc_error::StoreError に
  !> 引き渡されます。エラーコードに関しては dc_error を参照ください。
  !>
  !> @param[in] number エラーコード (dc_error 参照)
  !> @param[in] where プログラム名、手続き名
  !> @param[in] message メッセージ (省略可)
  !> @param[in] i フォーマット用整数配列
  !> @param[in] r フォーマット用実数配列
  !> @param[in] d フォーマット用倍精度実数配列
  !> @param[in] L フォーマット用論理配列
  !> @param[in] n フォーマット用整数配列
  !> @param[in] c1 フォーマット用文字列1
  !> @param[in] c2 フォーマット用文字列2
  !> @param[in] c3 フォーマット用文字列3
  !> @param[in] ca フォーマット用文字列配列
  !> @param[in] rank_mpi MPI 使用時に、ここで指定されたランク数のノードでのみ
  !>            メッセージ出力を行います。負の値を与えた場合には、
  !>            全てのノードで出力を行います。MPI を使用していない場合には無視されます。
  !> @endja
  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
  !> @en
  !> @brief Suppress message output on other MPI nodes
  !> @details
  !> Sets the rank of the node that outputs messages.
  !> Output on nodes that do not have this rank number is suppressed.
  !> This subroutine is ignored if MPI is not used.
  !>
  !> @param[in] rank Number of rank of the node that outputs messages.
  !>            Output on nodes that do not have this rank number is suppressed.
  !> @enden
  !>
  !> @ja
  !> @brief MPI 使用時のメッセージ出力抑止設定
  !> @details
  !> 出力するノードのランク数を設定します。
  !> ここに指定されたランク数以外のノードでの出力は抑止されます。
  !> MPI を使用していない場合にはサブルーチンは無効です。
  !>
  !> @param[in] rank 出力するノードのランク数。
  !>            ここに指定されたランク数以外のノードでの出力は抑止されます。
  !> @endja
  subroutine messagesuppressmpi0( rank )
    implicit none
    integer, intent(in):: rank
  continue
    output_rank = rank
  end subroutine messagesuppressmpi0
  !> @en
  !> @brief Check if the current MPI rank should suppress output
  !> @details
  !> Returns .true. if the current MPI rank should not output messages,
  !> .false. if output is allowed. When MPI is not used, always returns .false.
  !>
  !> @param[in] rank_mpi When MPI is used, messages are output only on the node with
  !>            this rank number. If a negative value is given, output is done on all nodes.
  !>            This option is ignored if MPI is not used.
  !> @return .true. if output should be suppressed, .false. otherwise
  !> @enden
  !>
  !> @ja
  !> @brief 現在の MPI ランクが出力を抑止すべきかチェック
  !> @details
  !> 現在の MPI ランクがメッセージを出力すべきでない場合に .true. を返し、
  !> 出力が許可されている場合は .false. を返します。
  !> MPI を使用していない場合は常に .false. を返します。
  !>
  !> @param[in] rank_mpi MPI 使用時に、ここで指定されたランク数のノードでのみ
  !>            メッセージ出力を行います。負の値を与えた場合には、
  !>            全てのノードで出力を行います。MPI を使用していない場合には無視されます。
  !> @return 出力を抑止すべき場合は .true.、それ以外は .false.
  !> @endja
  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
  !> @namespace dc_message
end module dc_message