!== dc_error.f90 - エラー処理
!
! Authors:: Eizi TOYODA, Yasuhiro MORIKAWA
! Version:: $Id: dc_error.f90,v 1.8 2006/06/04 12:48:43 morikawa Exp $
! Tag Name:: $Name: gt4f90io-20060627 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License:: See COPYRIGHT[link:../../COPYRIGHT]
!
! This file provides dc_error
!
module dc_error 112,1
!
!= エラー処理用モジュール
!
!== 概要
!
! プログラムの部品は必ずエラーの取り扱いを明確に規定すべきものです。
! エラーとは当該部品への入力が不適切であるとか、
! 期待される動作をすることができないといった事態を指します。
!
! gt4f90io ライブラリがユーザに提供する手続
! (手続とはサブルーチンまたは関数の総称) はほとんどの場合、
! 以下の 2 つの方式のいずれかで呼び出し元にエラーを報告します。
!
! * エラーが発生すると適切なメッセージを表示してプログラム終了
! * 論理型の省略できる引数 err が与えられた場合は、
! エラー時にはそれを <tt>.true.</tt> にします。
! err が省略された場合は上に同じ。
!
! これらの処理はすべて dc_error モジュールの StoreError
! サブルーチンで行っています。引用仕様などに関しては StoreError
! を参照してください。
!
!
!== エラーコード一覧
!
! gt4f90io ライブラリにコードを追加するプログラマは適切な
! エラーコードで StoreError を呼び出すようにしなければなりません。
! そこで、 新しいエラーコードを定義する必要があるかどうかを
! 判定するために、 エラーコードの値と対応するメッセージを一覧します。
! エラーコードニーモニックを使用するためには、
! <b><tt>NF_E</tt></b> で始まる名前については netcdf_f77
! モジュールを引用するか include 'netcdf.inc' を行い（後者は推奨しません）、
! <b><tt>GT_E</tt></b> で始まる名前については dc_error
! モジュールを引用してください。
! また <b><tt>USR_E</tt></b> で始まる名前は各々のユーザが定義して
! 良いエラーコードです。
!
! エラーではない状態を表す非エラーコードは
! DC_NOERR (数値 0) です。
!
! エラーコードの数値の欄を設けたのは、新たなエラーコードを
! 割り当てる際の指針を示すためです。
! コードではエラーコードをニーモニックで与えるべきであり、
! 数値をハードコードすることは厳に慎んで下さい。
!
!=== 利用しないコード
!
! 正の整数値はエラーコードとして使用しません。
!
! NetCDF ライブラリは libc のエラーコード errno を返す可能性があり、
! errno の数値には移植性がないため、全ての正の整数値は errno
! の仕様のために予約されているべきだからです。
!
!=== 非エラーコード
!
! 以下の非エラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! <b>数値</b> :: <b> [ ニーモニック ]</b>
!
! 0 :: [ <b>DC_NOERR </b> ]
!
!
!=== netCDF に関するエラーコード
!
! 以下のエラーコードに関しては netcdf_f77 モジュールを引用することで
! 利用してください。
!
! <b>数値</b> :: <b> [ ニーモニック ] エラーメッセージ </b>
!
! 0 :: [ <b>NF_NOERR </b> ]
! <b></b> :: No Error (非エラーコードです)
!
! -33 :: [ <b>NF_EBADID </b> ]
! <b></b> :: Not a netCDF id:
!
! -34 :: [ <b>NF_ENFILE </b> ]
! <b></b> :: Too many netCDF files open:
!
! -35 :: [ <b>NF_EEXIST </b> ]
! <b></b> :: netCDF file exists && NC_NOCLOBBER:
!
! -36 :: [ <b>NF_EINVAL </b> ]
! <b></b> :: Invalid argument:
!
! -37 :: [ <b>NF_EPERM </b> ]
! <b></b> :: Write to read only:
!
! -38 :: [ <b>NF_ENOTINDEFINE</b> ]
! <b></b> :: Operation not allowed in data mode
!
! -39 :: [ <b>NF_EINDEFINE </b> ]
! <b></b> :: Operation not allowed in define mode
!
! -40 :: [ <b>NF_EINVALCOORDS</b> ]
! <b></b> :: Index exceeds dimension bound
!
! -41 :: [ <b>NF_EMAXDIMS </b> ]
! <b></b> :: NC_MAX_DIMS exceeded
!
! -42 :: [ <b>NF_ENAMEINUSE </b> ]
! <b></b> :: String match to name in use
!
! -43 :: [ <b>NF_ENOTATT </b> ]
! <b></b> :: Attribute not found
!
! -44 :: [ <b>NF_EMAXATTS </b> ]
! <b></b> :: NC_MAX_ATTRS exceeded
!
! -45 :: [ <b>NF_EBADTYPE </b> ]
! <b></b> :: Not a netCDF data type or _FillValue type mismatch
!
! -46 :: [ <b>NF_EBADDIM </b> ]
! <b></b> :: Invalid dimension id or name
!
! -47 :: [ <b>NF_EUNLIMPOS </b> ]
! <b></b> :: NC_UNLIMITED in the wrong index
!
! -48 :: [ <b>NF_EMAXVARS </b> ]
! <b></b> :: NC_MAX_VARS exceeded
!
! -49 :: [ <b>NF_ENOTVAR </b> ]
! <b></b> :: Variable not found
!
! -50 :: [ <b>NF_EGLOBAL </b> ]
! <b></b> :: Action prohibited on NC_GLOBAL varid
!
! -51 :: [ <b>NF_ENOTNC </b> ]
! <b></b> :: Not a netCDF file
!
! -52 :: [ <b>NF_ESTS </b> ]
! <b></b> :: In Fortran, string too short
!
! -53 :: [ <b>NF_EMAXNAME </b> ]
! <b></b> :: NC_MAX_NAME exceeded
!
! -54 :: [ <b>NF_EUNLIMIT </b> ]
! <b></b> :: NC_UNLIMITED size already in use
!
! -55 :: [ <b>NF_ENORECVARS </b> ]
! <b></b> :: NC_rec op when there are no record vars
!
! -56 :: [ <b>NF_ECHAR </b> ]
! <b></b> :: Attempt to convert between text & numbers
!
! -57 :: [ <b>NF_EEDGE </b> ]
! <b></b> :: Edge+start exceeds dimension bound
!
! -58 :: [ <b>NF_ESTRIDE </b> ]
! <b></b> :: Illegal stride
!
! -59 :: [ <b>NF_EBADNAME </b> ]
! <b></b> :: Attribute or variable name contains illegal characters
!
! -60 :: [ <b>NF_ERANGE </b> ]
! <b></b> :: Numeric conversion not representable
!
! -61 :: [ <b>NF_ENOMEM </b> ]
! <b></b> :: Memory allocation (malloc) failure
!
! -62〜-99:: <b> </b>
! <b></b> :: (将来の netCDF の拡張に備えた gtool4 の予約領域)
!
!
!=== gt4f90io のデータ構造に関するエラーコード
!
! 以下のエラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! <b>数値</b> :: <b> [ ニーモニック ] エラーメッセージ </b>
!
! -100 :: [ <b>GT_EFAKE </b> ]
! <b></b> :: function not implemented
!
! -101 :: [ <b>GT_ENOMOREDIMS </b> ]
! <b></b> :: dimension number %d is out of range
!
! -102 :: [ <b>GT_EDIMNODIM </b> ]
! <b></b> :: dimension variable has no dimension
!
! -103 :: [ <b>GT_EDIMMULTIDIM </b> ]
! <b></b> :: dimension variable has many dimensions
!
! -104 :: [ <b>GT_EDIMOTHERDIM </b> ]
! <b></b> :: dimension variable has another dimension
!
! -105 :: [ <b>GT_EBADDIMNAME </b> ]
! <b></b> :: <i>string_c</i> または <i>string_s</i>:
! unknown dimension name
!
! -106 :: [ <b>GT_ENOTVAR </b> ]
! <b></b> :: variable not opened
!
! -107 :: [ <b>GT_ENOMEM </b> ]
! <b></b> :: allocate/deallocate error
!
! -108 :: [ <b>GT_EOTHERFILE </b> ]
! <b></b> :: specified dimensional variable not on the same file
!
! -109 :: [ <b>GT_EARGSIZEMISMATCH</b> ]
! <b></b> :: arguments (<i>string_c</i>) array size mismatch
!
! -110 :: [ <b>GT_ENOMATCHDIM </b> ]
! <b></b> :: dimension matching failed
!
! -111 :: [ <b>GT_ELIMITED </b> ]
! <b></b> :: variable already limited
!
! -112 :: [ <b>GT_EBADVAR </b> ]
! <b></b> :: variable type not supported
!
! -113 :: [ <b>GT_ECHARSHORT </b> ]
! <b></b> :: character length not enough
!
! -114 :: [ <b>GT_ENOUNLIMITDIM </b> ]
! <b></b> :: NC_UNLIMITED dimension is not found
!
! -115 :: [ <b>GT_EBADATTRNAME </b> ]
! <b></b> :: invalid attribute name
!
! -116 :: [ <b>GT_EBADHISTORY </b> ]
! <b></b> :: invalid GT_HISTORY variable
!
! -117 :: [ <b>GT_EBADALLOCATESIZE</b> ]
! <b></b> :: invalid allocated size
!
! -118 :: [ <b>GT_ERANKMISMATCH</b> ]
! <b></b> :: rank of data and argument is mismatch (<i>string_c</i>)
!
! 〜-299 :: <b> </b>
! <b></b> :: (将来の gtdata 層のエラーメッセージのため予約)
!
!=== GrADS 入出力に関するエラーコード
!
! 以下のエラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! <b>数値</b> :: <b> [ ニーモニック ] エラーメッセージ </b>
!
! -300 :: [ <b>GR_ENOTGR </b> ]
! <b></b> :: invalid GrADS file
!
! 〜-399 :: <b> </b>
! <b></b> :: (将来の GrADS インターフェース層の
! エラーメッセージのため予約)
!
!=== gt4f90io に関して予約してあるエラーコード
!
! 以下のエラーコードは今後の拡張も考えて予約してある部分です。
!
! <b>数値</b> :: <b> [ ニーモニック ] エラーメッセージ </b>
!
! -400〜-999 :: <b> </b>
! <b></b> :: (将来の gt4f90io の内部の
! エラーメッセージのため予約)
!
!=== ユーザ定義用エラーコード
!
! 以下のエラーコードを含む -1000 よりも小さいエラーコードは、
! gt4f90io の上位のプログラムが利用するエラーコードとして空けてあります。
!
! <b>数値</b> :: <b> [ ニーモニック ] エラーメッセージ </b>
!
! -1000 :: [ <b>USR_ECHAR </b> ]
! <b></b> :: <i>string_c</i>
!
! -1001 :: [ <b>USR_EINT </b> ]
! <b></b> :: <i>string_c</i> (<i>string_i</i>)
!
!
use netcdf_f77
, only: NF_ENOTVAR, NF_EINVAL
implicit none
private
public :: NF_ENOTVAR, NF_EINVAL
! エラー等を保持
integer, public, parameter :: DC_NOERR = 0
integer, private, save :: errno = DC_NOERR
integer, private, save :: cause_int = DC_NOERR
character(80), private, save :: cause_string = ""
character(80), private, save :: cause_location = ""
! 正のエラー番号は libc システムエラーメッセージのために
! あけてある。システム依存性が大きく、非常に大きな数値も
! 用いられるので空き領域を確保するのは困難である。
!
! 負のエラー番号は netCDF が使っている。少々の拡張も見込んで、
! -99 までは使わないで置く。
integer, parameter, public:: GT_EFAKE = -100
!
! -101 以下: データ構造のエラー
!
integer, parameter, public:: GT_ENOMOREDIMS = -101
integer, parameter, public:: GT_EDIMNODIM = -102
integer, parameter, public:: GT_EDIMMULTIDIM = -103
integer, parameter, public:: GT_EDIMOTHERDIM = -104
integer, parameter, public:: GT_EBADDIMNAME = -105
integer, parameter, public:: GT_ENOTVAR = -106
integer, parameter, public:: GT_ENOMEM = -107
integer, parameter, public:: GT_EOTHERFILE = -108
integer, parameter, public:: GT_EARGSIZEMISMATCH = -109
integer, parameter, public:: GT_ENOMATCHDIM = -110
integer, parameter, public:: GT_ELIMITED = -111
integer, parameter, public:: GT_EBADVAR = -112
integer, parameter, public:: GT_ECHARSHORT = -113
integer, parameter, public:: GT_ENOUNLIMITDIM = -114
integer, parameter, public:: GT_EBADATTRNAME = -115
integer, parameter, public:: GT_EBADHISTORY = -116
integer, parameter, public:: GT_EBADALLOCATESIZE = -117
integer, parameter, public:: GT_ERANKMISMATCH = -118
!
! -300 以下: GrADS 入出力のエラー
!
integer, parameter, public:: GR_ENOTGR = -300
!
! -1000 以下: ユーザー定義
!
integer, parameter, public:: USR_ECHAR = -1000
integer, parameter, public:: USR_EINT = -1001
public:: StoreError, DumpError, GetErrorMessage, ErrorCode
!
! === 手続引用仕様 ===
!
! いずれ差し替えられるように外部関数にしておく。
interface
subroutine DumpError()
end subroutine DumpError
end interface
contains
integer function ErrorCode() result(result) 1
!
! 現在設定されているエラーコードを返します。
!
result = errno
end function ErrorCode
subroutine GetErrorMessage(msg) 1,2
!
! 現在設定されているエラーコードから対応するメッセージを返します。
!
use netcdf_f77, only: nf_strerror
use dc_string , only: toChar
character(len = *), intent(out):: msg
character(len = 180):: message
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"
!
! -1000 以下: ユーザー定義
!
case(USR_ECHAR)
msg = trim(cause_string)
case(USR_EINT)
msg = trim(cause_string) // ' (' // trim(toChar(cause_int)) // ')'
case default
goto 999
end select
msg = '*** ERROR (Code ' // trim(toChar(errno)) // &
& ') [' // trim(cause_location) // '] *** ' // &
& trim(msg)
return
999 continue
if (len(cause_string) > 0) then
message = nf_strerror(errno)
msg = '*** ERROR (Code ' // trim(toChar(errno)) // &
& ') [' // trim(cause_location) // &
& '(' // trim(cause_string) // ')] *** ' // &
& trim(message)
else if (cause_int /= 0) then
message = nf_strerror(errno)
msg = '*** ERROR (Code ' // trim(toChar(errno)) // &
& ') [' // trim(cause_location) // &
& '(' // trim(toChar(cause_int)) // ')] *** ' // &
& trim(message)
else
message = nf_strerror(errno)
msg = '*** ERROR (Code ' // trim(toChar(errno)) // &
& ') [' // trim(cause_location) // '] *** ' // &
& trim(message)
endif
end subroutine GetErrorMessage
subroutine StoreError(number, where, err, cause_c, cause_i) 93,2
!
!== 典型的ライブラリ関数のために作られたエラー処理関数
!
! 必要な引数は2つであり、第1引数 number は整数型のエラーコード、
! 第2引数 where は文字型でエラーの発生した手続名を与えます。
! デフォルトでは以下の形式の文字列が標準出力 に表示されてプログラム
! は終了します。 エラーメッセージ error_message
! はエラーコードから自動的に決まります。
! 対応表がエラーコード一覧にあるので参照してください。
!
!
! *** ERROR (Code number) [where] *** error_message
!
! *** ERROR (Code number) [where(cause_c)] *** error_message
!
! なお、gt4f90io の ライブラリ外 からユーザがエラー処理用ツール
! として StoreError を用いることを想定し、USR_ECHAR および USR_EINT
! を用意してあります。 このエラーコードを用いると、
! StoreError は以下の形式の文字列を装置 "*" に出力してプログラムを
! 終了させます。 なお、より安易に使えるラッパーとして
! dc_message モジュールを用意してあるのでそちらも参照してください。
!
!
! *** ERROR (Code USR_ECHAR) [where] *** cause_c
!
! *** ERROR (Code USR_EINT) [where] *** cause_c (cause_i)
!
!--
!== 開発者向け解説
!
! エラー番号 number を errno に格納する。同時に付随的情報
! where, cause_i を cause_location, cause_string,
! cause_int に格納する。
! err が与えられている場合、err は number が 0 の場合だけ偽になる。
! number が 0 ならば即復帰する。
! err が与えられていなければエラーメッセージを装置 * に出力して
! プログラムを終了する。
!++
use dc_string, only: assignment(=)
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)) cause_int = cause_i
if (present(err)) then
err = (number /= DC_NOERR)
return
endif
if (number == DC_NOERR) return
call DumpError
end subroutine StoreError
end module dc_error
subroutine DumpError() 6,6
!
! GetErrorMessage からエラーメッセージを取得後、
! それを sysdep#AbortProgram に渡してプログラムを終了させます。
!
use dc_types, only: STRING
use dc_string, only: put_line
use dc_error, only: GetErrorMessage
use sysdep, only: AbortProgram
character(len = STRING):: message
continue
call GetErrorMessage(message)
call AbortProgram(message)
end subroutine DumpError