エラー処理用モジュール

  integer function ErrorCode() result(result)
    !
    ! 現在設定されているエラーコードを返します。
    !
    result = errno
  end function ErrorCode

  subroutine GetErrorMessage(msg)
    !
    ! 現在設定されているエラーコードから対応するメッセージを返します。
    !
    use netcdf_f77, only: nf_strerror
    character(len = *), intent(out):: msg
    character(len = 180):: message
    character(len = 20):: errno_c
    character(len = 20):: cause_int_c
  continue
    select case(errno)
    case(GT_EFAKE)
      msg = " function not implemented"
      !
      ! -101 以下: データ構造のエラー
      !
    case(GT_ENOMOREDIMS)
      write(message, "(': dimension number', i4, ' is out of range')") cause_int
      msg = trim(message)
    case(GT_EBADDIMNAME)
      msg = '(' // trim(cause_string) // '): unknown dimension name'
    case(GT_ENOTVAR)
      msg = " variable not opened"
    case(GT_ENOMEM)
      msg = " allocate/deallocate error"
    case(GT_EDIMNODIM)
      msg = " dimension variable has no dimension"
    case(GT_EDIMMULTIDIM)
      msg = " dimension variable has many dimensions"
    case(GT_EDIMOTHERDIM)
      msg = " dimension variable has another dimension"
    case(GT_EOTHERFILE)
      msg = " specified dimensional variable not on the same file"
    case(GT_EARGSIZEMISMATCH)
      msg = " arguments (" // trim(cause_string) //") array size mismatch"
    case(GT_ENOMATCHDIM)
      msg = " dimension matching failed"
    case(GT_ELIMITED)
      msg = " variable already limited"
    case(GT_EBADVAR)
      msg = " variable type not supported"
    case(GT_ECHARSHORT)
      msg = " character length not enough"
    case(GT_ENOUNLIMITDIM)
      msg = " NC_UNLIMITED dimension is not found"
    case(GT_EBADATTRNAME)
      msg = " invalid attribute name"
    case(GT_EBADALLOCATESIZE)
      msg = " invalid allocated size"
    case(GT_ERANKMISMATCH)
      msg = " rank of data and argument are mismatch (" // trim(cause_string) // ")"
      !
      ! -300 以下: GrADS 入出力のエラー
      !
    case(GR_ENOTGR)
      msg = " invalid GrADS file"
      !
      ! -400 以下: DC ユーティリティのエラー
      !
    case(DC_ENOTINIT)
      msg = " object (" // trim(cause_string) //") is not initialized"
    case(DC_EBADUNIT)
      msg = " unit (" // trim(cause_string) //") is invalid"
    case(DC_EBADCALTYPE)
      write(message, "(' calendar type (', i4, ') is invalid')") cause_int
      msg = trim(message)
    case(DC_EBADTIMEZONE)
      msg = " time zone (" // trim(cause_string) //") is invalid"
      !
      ! -1000 以下: ユーザー定義
      !
    case(:USR_ERRNO)
      if (len(trim(adjustl(cause_string))) < 1) then
        cause_string = 'Unknown error'
      end if
      if (cause_int_valid) then
        write(cause_int_c, "(i8)") cause_int
        msg = trim(cause_string) // ' (' // trim(adjustl(cause_int_c)) // ')'
      else
        msg = trim(cause_string)
      end if
    case default
      goto 999
    end select
    write(errno_c, "(i8)") errno
    msg =  '*** ERROR (Code ' // trim(adjustl(errno_c))  // ') [' // trim(cause_location) // '] ***  ' // trim(msg)
    return

999 continue
    if (len(cause_string) > 0) then
      message = nf_strerror(errno)
      write(errno_c, "(i8)") errno
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c)) // ') [' // trim(cause_location)             // '('   // trim(cause_string) // ')] ***  ' // trim(message)
    else if (cause_int_valid) then
      message = nf_strerror(errno)
      write(errno_c, "(i8)") errno
      write(cause_int_c, "(i8)") cause_int
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c)) // ') [' // trim(cause_location)             // '('   // trim(adjustl(cause_int_c)) // ')] ***  ' // trim(message)
    else
      message = nf_strerror(errno)
      write(errno_c, "(i8)") errno
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c))  // ') [' // trim(cause_location) // '] ***  ' // trim(message)
    endif
  end subroutine GetErrorMessage

  subroutine StoreError(number, where, err, cause_c, cause_i)
    !
    !== 典型的ライブラリ関数のために作られたエラー処理関数
    !
    ! 必要な引数は2つであり、第1引数 number は整数型のエラーコード、
    ! 第2引数 where は文字型でエラーの発生した手続名を与えます。
    ! デフォルトでは以下の形式の文字列が標準出力 に表示されてプログラム
    ! は終了します。 エラーメッセージ error_message
    ! はエラーコードから自動的に決まります。
    ! 対応表がエラーコード一覧にあるので参照してください。
    !
    !     　
    !     *** ERROR (Code number) [where] ***  error_message
    !     　
    !     *** ERROR (Code number) [where(cause_c)] ***  error_message
    !
    ! なお、gt4f90io の ライブラリ外 からユーザがエラー処理用ツール
    ! として StoreError を用いることを想定し、USR_ERRNO 番より小さい
    ! エラーコードは空けてあります。<b><tt>USR_ERRNO</tt></b>
    ! より小さい値をエラーコードに与えると,
    ! StoreError は以下の形式の文字列を装置 "*" に出力してプログラムを
    ! 終了させます。より安易に使えるメッセージ出力およびエラー発生の
    ! ためのモジュールとして *dc_message* も用意してあるので
    ! そちらも参照してください。
    !
    !     　
    !     *** ERROR (Code number) [where] ***  cause_c
    !     　
    !     *** ERROR (Code number) [where] ***  cause_c (cause_i)
    !
    !

    integer,            intent(in)            :: number  ! エラーコード
    character(len = *), intent(in)            :: where   ! エラー発生個所
    logical,            intent(out), optional :: err
                                         ! この論理型変数が与えられた場合は、
                                         ! エラー時にはそれを <tt>.true.</tt>
                                         ! にします。この変数が省略され、
                                         ! 且つエラーが発生する場合は
                                         ! メッセージを表示してプログラムを
                                         ! 終了します。
    character(len = *), intent(in),  optional :: cause_c ! 文字型メッセージ
    integer,            intent(in),  optional :: cause_i ! 整数型メッセージ
  continue
    errno = number
    cause_location = where
    if (present(cause_c)) then
      cause_string = trim(cause_c)
    else
      cause_string = ""
    endif
    if (present(cause_i)) then
      cause_int = cause_i
      cause_int_valid = .true.
    else
      cause_int_valid = .false.
    end if
    if (present(err)) then
      err = (number /= DC_NOERR)
      return
    endif
    if (number == DC_NOERR) return
    call DumpError
  end subroutine StoreError