!= エラー処理
!
!= Error handling
!
! Authors:: Eizi TOYODA, Yasuhiro MORIKAWA
! Version:: $Id: dc_error.f90,v 1.19 2007/07/21 13:14:10 morikawa Exp $
! Tag Name:: $Name: gt4f90io-20070729 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License:: See COPYRIGHT[link:../../COPYRIGHT]
!
module dc_error
!
!= エラー処理用モジュール
!
!= Error handling module
!
! Note that Japanese and English are described in parallel.
!
! プログラムの部品は必ずエラーの取り扱いを明確に規定すべきものです。
! エラーとは当該部品への入力が不適切であるとか、
! 期待される動作をすることができないといった事態を指します。
!
! gt4f90io ライブラリがユーザに提供する手続
! (手続とはサブルーチンまたは関数の総称) はほとんどの場合、
! 以下の 2 つの方式のいずれかで呼び出し元にエラーを報告します。
!
! * エラーが発生すると適切なメッセージを表示してプログラム終了
! * 論理型の省略できる引数 *err* が与えられた場合は、
! エラー時にはそれを .true. にします。
! err が省略された場合は上に同じ。
!
! これらの処理はすべて *dc_error* モジュールの *StoreError*
! サブルーチンで行っています。引用仕様などに関しては *StoreError*
! を参照してください。
!
!
! Error handling about parts of programs should be regulated definitely.
! Error means that input to the part of program is invalid, or
! expected operation can not be done, etc.
!
! Procedures (procedures is generic name of subroutines and functions)
! provided to users by gt4f90io library almost report error to invoker
! in the following two manner.
!
! * When error occurs, the program display appropriate messages and
! aborts.
! * If logical optional argument *err* is given, the argument *err* become
! .true. when error occurs. If *err* is abbreviated,
! the operation is same as above.
!
! *StoreError* subroutine in *dc_error* module handle above all operations.
! See *StoreError* about the interfase of it.
!
!
!== エラーコード一覧
!== Error code list
!
! gt4f90io ライブラリにコードを追加するプログラマは適切な
! エラーコードで *StoreError* を呼び出すようにしなければなりません。
! そこで、 新しいエラーコードを定義する必要があるかどうかを
! 判定するために、 エラーコードの値と対応するメッセージを
! 以下に一覧します。
! エラーコードニーモニックを使用するためには、
! NF_E で始まる名前については netcdf_f77
! モジュールを引用するか include 'netcdf.inc' を行い(後者は推奨しません)、
! GT_E または DC_E
! で始まる名前については dc_error モジュールを引用してください。
! また USR_ERRNO 番より小さい値は、
! 各々のユーザが適宜エラーコードを
! 定義して利用するために空けてあります。
!
! エラーではない状態を表す非エラーコードは *DC_NOERR* です。
!
! エラーコードの数値の欄を設けたのは、新たなエラーコードを
! 割り当てる際の指針を示すためです。
! ソースコードにはエラーコードをニーモニックで与えるべきであり、
! 数値をハードコードすることは厳に慎んで下さい。
!
!
! Programmers who add codes to gt4f90io library must call
! *StoreError* with appropriate error code.
! And so values of error code and corresponding messages are listed
! as follows to figure out if a new error code is needed to declared.
! To use error codes mnemonic,
! require "netcdf_f77" module or include "netcdf.inc" (deprecated)
! about error codes with prefix NF_E, or
! require "dc_error" module
! about error codes with prefix GT_E and
! DC_E.
! Error codes smaller than USR_ERRNO are saved
! as user-defined error codes.
!
! Non error code that indicates normal (error-free) situation is
! *DC_NOERR*.
!
! List of numerical values of error codes
! issues a guideline about declaration of new error codes.
! Give not numerical value but mnemonic of error code to source code.
!
!=== 利用しないコード
!=== Unused codes
!
! 正の整数値はエラーコードとして使用しません。
!
! NetCDF ライブラリは libc のエラーコード errno を返す可能性があり、
! errno の数値には移植性がないため、全ての正の整数値は errno
! の仕様のために予約されているべきだからです。
!
! Positive integer is not used as error codes.
!
! NetCDF library might return "libc" error code "error".
! Numerical value of "errno" is no portable, so positive integer
! should be reserved for "errno".
!
!=== 非エラーコード
!=== Non error code
!
! 以下の非エラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! Use following non error code by refering this "dc_error" module.
!
! 数値. Number :: [ ニーモニック. Mnemonic ]
!
! 0 :: [ DC_NOERR ]
!
!
!=== netCDF に関するエラーコード
!=== Error codes for netCDF
!
! 以下のエラーコードに関しては netcdf_f77 モジュールを引用することで
! 利用してください。
!
! Use following error codes by refering this "netcdf_f77" module.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! 0 :: [ NF_NOERR ]
! :: No Error (非エラーコードです)
!
! -33 :: [ NF_EBADID ]
! :: Not a netCDF id:
!
! -34 :: [ NF_ENFILE ]
! :: Too many netCDF files open:
!
! -35 :: [ NF_EEXIST ]
! :: netCDF file exists && NC_NOCLOBBER:
!
! -36 :: [ NF_EINVAL ]
! :: Invalid argument:
!
! -37 :: [ NF_EPERM ]
! :: Write to read only:
!
! -38 :: [ NF_ENOTINDEFINE ]
! :: Operation not allowed in data mode
!
! -39 :: [ NF_EINDEFINE ]
! :: Operation not allowed in define mode
!
! -40 :: [ NF_EINVALCOORDS ]
! :: Index exceeds dimension bound
!
! -41 :: [ NF_EMAXDIMS ]
! :: NC_MAX_DIMS exceeded
!
! -42 :: [ NF_ENAMEINUSE ]
! :: String match to name in use
!
! -43 :: [ NF_ENOTATT ]
! :: Attribute not found
!
! -44 :: [ NF_EMAXATTS ]
! :: NC_MAX_ATTRS exceeded
!
! -45 :: [ NF_EBADTYPE ]
! :: Not a netCDF data type or _FillValue type mismatch
!
! -46 :: [ NF_EBADDIM ]
! :: Invalid dimension id or name
!
! -47 :: [ NF_EUNLIMPOS ]
! :: NC_UNLIMITED in the wrong index
!
! -48 :: [ NF_EMAXVARS ]
! :: NC_MAX_VARS exceeded
!
! -49 :: [ NF_ENOTVAR ]
! :: Variable not found
!
! -50 :: [ NF_EGLOBAL ]
! :: Action prohibited on NC_GLOBAL varid
!
! -51 :: [ NF_ENOTNC ]
! :: Not a netCDF file
!
! -52 :: [ NF_ESTS ]
! :: In Fortran, string too short
!
! -53 :: [ NF_EMAXNAME ]
! :: NC_MAX_NAME exceeded
!
! -54 :: [ NF_EUNLIMIT ]
! :: NC_UNLIMITED size already in use
!
! -55 :: [ NF_ENORECVARS ]
! :: NC_rec op when there are no record vars
!
! -56 :: [ NF_ECHAR ]
! :: Attempt to convert between text & numbers
!
! -57 :: [ NF_EEDGE ]
! :: Edge+start exceeds dimension bound
!
! -58 :: [ NF_ESTRIDE ]
! :: Illegal stride
!
! -59 :: [ NF_EBADNAME ]
! :: Attribute or variable name contains illegal characters
!
! -60 :: [ NF_ERANGE ]
! :: Numeric conversion not representable
!
! -61 :: [ NF_ENOMEM ]
! :: Memory allocation (malloc) failure
!
! -62〜-99::
! :: (将来の netCDF の拡張のための gt4f90io の予約領域.
! Reserved area for future extensions of netCDF)
!
!=== gt4f90io のデータ構造 (gtdata) に関するエラーコード
!=== Error codes for data structure of gt4f90io (gtdata)
!
! 以下のエラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! Use following error codes by refering this "dc_error" module.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! -100 :: [ GT_EFAKE ]
! :: function not implemented
!
! -101 :: [ GT_ENOMOREDIMS ]
! :: dimension number %d is out of range
!
! -102 :: [ GT_EDIMNODIM ]
! :: dimension variable has no dimension
!
! -103 :: [ GT_EDIMMULTIDIM ]
! :: dimension variable has many dimensions
!
! -104 :: [ GT_EDIMOTHERDIM ]
! :: dimension variable has another dimension
!
! -105 :: [ GT_EBADDIMNAME ]
! :: cause_c: unknown dimension name
!
! -106 :: [ GT_ENOTVAR ]
! :: variable not opened
!
! -107 :: [ GT_ENOMEM ]
! :: allocate/deallocate error
!
! -108 :: [ GT_EOTHERFILE ]
! :: specified dimensional variable not on the same file
!
! -109 :: [ GT_EARGSIZEMISMATCH ]
! :: arguments (cause_c) array size mismatch
!
! -110 :: [ GT_ENOMATCHDIM ]
! :: dimension matching failed
!
! -111 :: [ GT_ELIMITED ]
! :: variable already limited
!
! -112 :: [ GT_EBADVAR ]
! :: variable type not supported
!
! -113 :: [ GT_ECHARSHORT ]
! :: character length not enough
!
! -114 :: [ GT_ENOUNLIMITDIM ]
! :: NC_UNLIMITED dimension is not found
!
! -115 :: [ GT_EBADATTRNAME ]
! :: invalid attribute name
!
! -116 :: [ GT_EBADHISTORY ]
! :: invalid GT_HISTORY variable
!
! -117 :: [ GT_EBADALLOCATESIZE ]
! :: invalid allocated size
!
! -118 :: [ GT_ERANKMISMATCH ]
! :: rank of data and argument is mismatch (cause_c)
!
! 〜-299 ::
! :: (将来の gtdata 層の拡張のための予約.
! Reserved area for future extensions of gtdata layer)
!
!=== GrADS データ入出力に関するエラーコード
!=== Error codes for GrADS data I/O
!
! 以下のエラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! Use following error codes by refering this "dc_error" module.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! -300 :: [ GR_ENOTGR ]
! :: invalid GrADS file
!
! 〜-399 ::
! :: (将来の GrADS data 入出力層の拡張のための予約.
! Reserved area for future extensions of GrADS data I/O layer)
!
!=== DC ユーティリティ用エラーコード
!=== Error codes for DC utilities
!
! 以下のエラーコードに関しては dc_error モジュールを引用することで
! 利用してください。
!
! Use following error codes by refering this "dc_error" module.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! -400 :: [ DC_ENOTINIT ]
! :: object (cause_c) is not initialized
!
! -401 :: [ DC_EALREADYINIT ]
! :: object (cause_c) is already initialized
!
! -402 :: [ DC_EBADUNIT ]
! :: unit (cause_c) is invalid
!
! -403 :: [ DC_EBADCALTYPE ]
! :: calendar type (cause_i) is invalid
!
! -404 :: [ DC_EBADTIMEZONE ]
! :: time zone (cause_c) is invalid
!
! -405 :: [ DC_EFILENAMEEMPTY ]
! :: filename is empty
!
! -406 :: [ DC_EBADFILEOPMODE ]
! :: file open mode (cause_c) is invalid
!
! -407 :: [ DC_ENOUNITNUM ]
! :: available unit number is not found within (cause_c)
!
! -408 :: [ DC_ENOFILEEXIST ]
! :: file (cause_c) is not found
!
! -409 :: [ DC_ENOFILEREAD ]
! :: file (cause_c) is not readable
!
! -410 :: [ DC_ENOFILEWRITE ]
! :: file (cause_c) is not writable
!
! -411 :: [ DC_ENEGATIVE ]
! :: negative value is invalid for (cause_c)
!
! -412 :: [ DC_EARGLACK ]
! :: lack of arguments (cause_c)
!
! -413〜-499 ::
! :: (将来の DC ユーティリティの拡張のための予約.
! Reserved area for future extensions of DC utilities)
!
!=== gt4f90io の将来の拡張のために予約してあるエラーコード
!=== Reserved error codes for future extensions of gt4f90io
!
! 以下のエラーコードは今後の拡張も考えて予約してある部分です。
!
! Following error codes are reserved for future extensions.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! -500〜-999 ::
! :: (将来の gt4f90io の拡張のための予約.
! Reserved area for future extensions of gt4f90io)
!
!=== ユーザ定義用エラーコード
!=== User-defined error codes
!
! -1000 よりも小さいエラーコードは、
! gt4f90io の上位のプログラムが利用するエラーコードとして空けてあります。
!
! Error codes smaller than -1000 are saved for as user-defined error codes
! used by upper programs.
!
! 数値. Number :: [ ニーモニック. Mnemonic ] エラーメッセージ. Error message
!
! -1000〜 :: [ USR_ERRNO ]
! :: cause_c (cause_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
logical, private, save :: cause_int_valid = .false.
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
!
! -400 以下: dc ユーティリティのエラー
!
integer, parameter, public:: DC_ENOTINIT = -400
integer, parameter, public:: DC_EALREADYINIT = -401
integer, parameter, public:: DC_EBADUNIT = -402
integer, parameter, public:: DC_EBADCALTYPE = -403
integer, parameter, public:: DC_EBADTIMEZONE = -404
integer, parameter, public:: DC_EFILENAMEEMPTY = -405
integer, parameter, public:: DC_EBADFILEOPMODE = -406
integer, parameter, public:: DC_ENOUNITNUM = -407
integer, parameter, public:: DC_ENOFILEEXIST = -408
integer, parameter, public:: DC_ENOFILEREAD = -409
integer, parameter, public:: DC_ENOFILEWRITE = -410
integer, parameter, public:: DC_ENEGATIVE = -411
integer, parameter, public:: DC_EARGLACK = -412
!
! -1000 以下: ユーザー定義
!
integer, parameter, public:: USR_ERRNO = -1000
public:: StoreError, DumpError, GetErrorMessage, ErrorCode
!
! === 手続引用仕様 ===
!
! いずれ差し替えられるように外部関数にしておく。
interface
subroutine DumpError()
end subroutine DumpError
end interface
contains
integer function ErrorCode() result(result)
!
! 現在設定されているエラーコードを返します。
!
! Return an error code specified currently.
!
result = errno
end function ErrorCode
subroutine GetErrorMessage(msg)
!
! 現在設定されているエラーコードから対応するメッセージを返します。
!
! Return messages corresponding to an error code specified currently.
!
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 以下: データ構造のエラー
! -101 or less: Error of data structure
!
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 入出力のエラー
! -300 or less: Error of GrADS I/O
!
case(GR_ENOTGR)
msg = " invalid GrADS file"
!
! -400 以下: DC ユーティリティのエラー
! -400 or less: Error of DC utilities
!
case(DC_ENOTINIT)
msg = " object (" // trim(cause_string) // ") is not initialized"
case(DC_EALREADYINIT)
msg = ' object (' // trim(cause_string) // ') is already 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"
case(DC_EFILENAMEEMPTY)
msg = " filename is empty"
case(DC_EBADFILEOPMODE)
msg = " file open mode (" // trim(cause_string) // ") is invalid"
case(DC_ENOUNITNUM)
msg = " available unit number is not found within (" // trim(cause_string) // ")"
case(DC_ENOFILEEXIST)
msg = " file (" // trim(cause_string) // ") is not found"
case(DC_ENOFILEREAD)
msg = " file (" // trim(cause_string) // ") is not readable"
case(DC_ENOFILEWRITE)
msg = " file (" // trim(cause_string) // ") is not writable"
case(DC_ENEGATIVE)
msg = ' negative value is invalid for (' // trim(cause_string) // ')'
case(DC_EARGLACK)
msg = ' lack of arguments (' // trim(cause_string) // ')'
!
! -1000 以下: ユーザー定義
! -1000 or less: User-defined error
!
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)
!
!== 典型的ライブラリ手続のために作られたエラー処理サブルーチン
!== Error handling subroutine for typical procedures of library
!
! 必要な引数は2つであり、第1引数 *number* には整数型のエラーコード、
! 第2引数 *where* には文字型でエラーの発生した手続名を与えます。
! デフォルトでは以下の形式の文字列が標準出力に表示されてプログラム
! は終了します。 エラーメッセージ error_message
! はエラーコードから自動的に決まります。
! 対応表がエラーコード一覧にあるので参照してください。
!
! Number of necessary arguments is two. Give integer error code
! to first argument *number*, and procedure name where the error
! occurs to second argument *where*. By default, like a following
! string is displayed to standard output, and the program aborts
! Error message is determined by error code automatically.
! See error code list.
!
!
! *** ERROR (Code number) [where] *** error_message
!
! *** ERROR (Code number) [where(cause_c)] *** error_message
!
! なお、gt4f90io のライブラリ外からユーザがエラー処理用ツール
! として StoreError を用いることを想定し、USR_ERRNO
! 番より小さい
! エラーコードは空けてあります。USR_ERRNO
! より小さい値をエラーコードに与えると,
! StoreError は以下の形式の文字列を標準出力に出力してプログラムを
! 終了させます。より安易に使えるメッセージ出力およびエラー発生の
! ためのモジュールとして *dc_message* も用意してあるので
! そちらも参照してください。
!
! In addition, for usage that users call StoreError as an error
! handling tool from the outside of gt4f90io library,
! error codes smaller than USR_ERRNO is saved.
! When error codes smaller than USR_ERRNO is given,
! StoreError displays like a following string to standard output,
! and stops the program.
! *dc_message* module is prepared too. This module can be used
! more easily for message output and rise of error.
!
!
! *** ERROR (Code number) [where] *** cause_c
!
! *** ERROR (Code number) [where] *** cause_c (cause_i)
!
!--
!== 開発者向け解説
!
! エラー番号 number を errno に格納する。同時に付随的情報
! where, cause_i を cause_location, cause_string,
! cause_int に格納する。
! err が与えられている場合、err は number が DC_NOERR の場合だけ偽になる。
! number が DC_NOERR ならば即復帰する。
! err が与えられていなければエラーメッセージを装置 * に出力して
! プログラムを終了する。
!++
integer, intent(in) :: number
! エラーコード。
! Error code
character(len = *), intent(in) :: where
! エラー発生個所。
! Place where error occurs
logical, intent(out), optional :: err
! 例外処理用フラグ。
! デフォルトでは、*number* に非エラーコード
! 以外の値が与えられた場合、エラーメッセージを
! 表示してプログラムは強制終了します。
! 引数 *err* が与えられる場合、
! プログラムは強制終了せず、代わりに
! *err* に .true. が代入されます。
!
! Exception handling flag.
! By default, when error code (excluding
! non error code) is given to *number*,
! the program display error message and aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
character(len = *), intent(in), optional :: cause_c
! 文字型メッセージ。
! Character message
integer, intent(in), optional :: cause_i
! 整数型メッセージ。
! Integer message
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
end module dc_error
subroutine DumpError()
!
! GetErrorMessage からエラーメッセージを取得後、
! それを sysdep#AbortProgram に渡してプログラムを終了させます。
!
! Get error messages from "GetErrorMessage", and put the messages
! to sysdep#AbortProgram, and stop the program.
!
use dc_types, only: STRING
use dc_error, only: GetErrorMessage
use sysdep, only: AbortProgram
character(len = STRING):: message
continue
call GetErrorMessage(message)
call AbortProgram(message)
end subroutine DumpError