!== dc_error.f90 - エラー処理
!
! Authors::   Eizi TOYODA, Yasuhiro MORIKAWA
! Version::   $Id: dc_error.f90,v 1.9 2006/10/09 10:35:42 morikawa Exp $
! Tag Name::  $Name: gt4f90io-20061025 $
! Copyright:: Copyright (C) GFD Dennou Club, 2000-2005. All rights reserved.
! License::   See COPYRIGHT[link:../../COPYRIGHT]
!
! This file provides dc_error
!
module dc_error
  !
  != エラー処理用モジュール
  !
  !== 概要
  !
  ! プログラムの部品は必ずエラーの取り扱いを明確に規定すべきものです。
  ! エラーとは当該部品への入力が不適切であるとか、
  ! 期待される動作をすることができないといった事態を指します。
  !
  ! 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)
    !
    ! 現在設定されているエラーコードを返します。
    !
    result = errno
  end function ErrorCode

  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 = " 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)
    !
    !== 典型的ライブラリ関数のために作られたエラー処理関数
    !
    ! 必要な引数は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 が与えられていなければエラーメッセージを装置 * に出力して
    ! プログラムを終了する。
    !++

    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()
  !
  ! GetErrorMessage からエラーメッセージを取得後、
  ! それを sysdep#AbortProgram に渡してプログラムを終了させます。
  !
  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
