!--------------------------------------------------------------------- ! Copyright (C) GFD Dennou Club, 2004. All rights reserved !--------------------------------------------------------------------- ! dc_error.f90 - エラーの処置 module dc_error use netcdf_f77, only: NF_ENOTVAR, nf_einval implicit none public ! エラー等を保持 integer, public, parameter :: DC_NOERR = 0 integer, private :: errno = DC_NOERR integer, private :: cause_int = DC_NOERR character(80), private :: cause_string = "" character(80), private :: cause_location = "" ! 正のエラー番号は libc システムエラーメッセージのために ! あけてある。システム依存性が大きく、非常に大きな数値も ! 用いられるので空き領域を確保するのは困難である。 ! ! 負のエラー番号は netCDF が使っている。少々の拡張も見込んで、 ! -99 までは使わないで置く。 integer, parameter:: GT_EFAKE = -100 ! ! -101 以下: データ構造のエラー ! integer, parameter:: GT_ENOMOREDIMS = -101 integer, parameter:: GT_EDIMNODIM = -102 integer, parameter:: GT_EDIMMULTIDIM = -103 integer, parameter:: GT_EDIMOTHERDIM = -104 integer, parameter:: GT_EBADDIMNAME = -105 integer, parameter:: GT_ENOTVAR = -106 integer, parameter:: GT_ENOMEM = -107 integer, parameter:: GT_EOTHERFILE = -108 integer, parameter:: GT_EARGSIZEMISMATCH = -109 integer, parameter:: GT_ENOMATCHDIM = -110 integer, parameter:: GT_ELIMITED = -111 integer, parameter:: GT_EBADVAR = -112 integer, parameter:: GT_ECHARSHORT = -113 integer, parameter:: GT_ENOUNLIMITDIM = -114 ! ! -200 以下: 可視化構造のエラー ! integer, parameter:: GT_EFIGNOHAXIS = -200 integer, parameter:: GT_EFIGNOVAXIS = -201 integer, parameter:: GT_EBADLINK = -202 ! ! -300 以下: GrADS 入出力のエラー ! integer, parameter:: GR_ENOTGR = -300 ! ! -1000 以下: ユーザー定義 ! integer, parameter:: USR_ECHAR = -1000 integer, parameter:: USR_EINT = -1001 public:: StoreError, DumpError, GetErrorMessage, ErrorCode ! ! === 手続引用仕様 === ! ! いずれ差し替えられるように外部関数にしておく。 interface subroutine DumpError() end subroutine end interface contains integer function ErrorCode() result(result) result = errno end function subroutine GetErrorMessage(msg) 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 = " argument 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" ! ! -200 以下: 可視化構造のエラー ! case(GT_EFIGNOHAXIS) msg = " hozirontal axis is missing" case(GT_EFIGNOVAXIS) msg = " vertical axis is missing" case(GT_EBADLINK) msg = " bad variable reference" ! ! -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 1000 end select msg = '*** ERROR (Code ' // trim(toChar(errno)) // & & ') [' // trim(cause_location) // '] *** ' // & & trim(msg) return 1000 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 ! 典型的ライブラリ関数のために作られたエラー処理関数。 ! ! エラー番号 number を errno に格納する。同時に付随的情報 ! where, cause_i を cause_location, cause_string, ! cause_int に格納する。 ! err が与えられている場合、err は number が 0 の場合だけ偽になる。 ! number が 0 ならば即復帰する。 ! err が与えられていなければエラーメッセージを装置 * に出力して ! プログラムを終了する。 subroutine StoreError(number, where, err, cause_c, cause_i) use dc_string, only: assignment(=) integer, intent(in) :: number ! エラーコード character(len = *), intent(in) :: where ! エラー発生個所 logical, intent(out), optional :: err 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 end module subroutine DumpError() use dc_types, only: string use dc_string, only: put_line use dc_error, only: GetErrorMessage use sysdep, only: AbortProgram character(len = string):: message call GetErrorMessage(message) call AbortProgram(message) end subroutine