!---------------------------------------------------------------------
! 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
