! dc_error.f90 - エラーの処置
! Copyright (C) GFD Dennou Club, 2000.  All rights reserved

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
    !
    ! -200 以下: 可視化構造のエラー
    !
    integer, parameter:: GT_EFIGNOHAXIS = -200
    integer, parameter:: GT_EFIGNOVAXIS = -201
    integer, parameter:: GT_EBADLINK = -202
    !
    ! -300 以下: GrADS 入出力のエラー
    !
    integer, parameter:: GR_ENOTGR = -300

    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
        character(len = *), intent(out):: msg
        character(len = 180):: message
    continue
        select case(errno)
        case(GT_EFAKE)
            msg = ": function not implemented"
        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_EFIGNOHAXIS)
            msg = ": hozirontal axis is missing"
        case(GT_EFIGNOVAXIS)
            msg = ": vertical axis is missing"
        case(GT_EBADLINK)
            msg = ": bad variable reference"
        case(GT_ECHARSHORT)
            msg = ": character length not enough"
        case(GR_ENOTGR)
            msg = ": invalid GrADS file"
        case default
            goto 1000
        end select
        msg = trim(cause_location) // msg
        return

    1000 continue
        if (len(cause_string) > 0) then
            message = nf_strerror(errno)
            msg = trim(cause_location) // &
                & "(" // trim(cause_string) // ")" // &
                & ": " // trim(message)
        else if (cause_int /= 0) then
            write(message(1:8), '(i8)') cause_int
            message(9: ) = nf_strerror(errno)
            msg = trim(cause_location) // &
                & '(' // trim(message(1:8)) // ')' // &
                & ": " // trim(message(9: ))
        else
            message = nf_strerror(errno)
            msg = trim(cause_location) // ": " // trim(message)
        endif
    end subroutine

    ! 典型的ライブラリ関数のために作られたエラー処理関数。
    !
    ! エラー番号 number を errno に格納する。同時に付随的情報
    ! where, cause_s, cause_i を cause_location, cause_string,
    ! cause_int に格納する。 
    ! err が与えられている場合、err は number が 0 の場合だけ偽になる。
    ! number が 0 ならば即復帰する。
    ! err が与えられていなければエラーメッセージを装置 * に出力して
    ! プログラムを終了する。

    subroutine StoreError(number, where, err, cause_s, cause_c, cause_i)
        use dc_string, only: VSTRING, assignment(=)
        integer, intent(in):: number
        character(len = *), intent(in):: where
        logical, intent(out), optional:: err
        type(VSTRING), intent(in), optional:: cause_s
        character(len = *), intent(in), optional:: cause_c
        integer, intent(in), optional:: cause_i
    continue
        errno = number
        cause_location = where
        if (present(cause_s)) then
            cause_string = cause_s
        else 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: VSTRING, put_line
    use dc_error, only: GetErrorMessage
    use sysdep, only: AbortProgram
    character(len = string):: message
    call GetErrorMessage(message)
    call AbortProgram(message)
end subroutine
