! gtool_attribute.f90 - gtool4 file interface
! Copyright (C) by TOYODA Eizi, 2000.  All rights reserved.
! vi: set sw=4 ts=8:

module gtool_error 

    use dc_string
    use netcdf_error
    implicit none

    private
    public:: GtoolAbort, GtoolSaveError

    integer, save:: saved_status = 0
    type(VARYING_STRING), save:: saved_where, saved_cause 

    ! 仮定: netCDF エラーコードは GT_ERROR_BASE より大きい
    public:: GT_ERROR_BASE, GT_EOPENDEV
    integer, parameter:: GT_ERROR_BASE = -100
    integer, parameter:: GT_EOPENDEV = GT_ERROR_BASE

    interface GtoolSaveError
	module procedure save_error_icc, save_error_ics, save_error_ici
    end interface

contains

    type(VARYING_STRING) function strerror(status) result(result)
	use netcdf_v3
	integer, intent(in):: status
    continue
	if (status == GT_EOPENDEV) then
	    result = 'GT_DEVICE object already opened'
	else
	    result = trim(nf_strerror(status))
	endif
    end function

    subroutine GtoolAbort(where)
	use netcdf_error
	type(VARYING_STRING), intent(in), optional:: where
	type(VARYING_STRING):: mywhere
    continue
	if (saved_status == 0) then
	    call Assert(NetcdfLastError())
	    return
	endif
	if (present(where)) then
	    mywhere = where
	else
	    mywhere = ''
	endif
	call NetcdfAbort(mywhere // strerror(saved_status))
    end subroutine

    !
    ! --- GtoolSaveError サブルーチン群 ---
    !

    subroutine save_error_icc(status, where, cause)
	integer, intent(in):: status
	character(len = *), intent(in):: where
	character(len = *), intent(in):: cause
    continue
	call NetcdfSaveError(status, where, cause)
    end subroutine

    subroutine save_error_ics(status, where, cause)
	integer, intent(in):: status
	character(len = *), intent(in):: where
	type(VARYING_STRING), intent(in):: cause
    continue
	call NetcdfSaveError(status, where, char(cause))
    end subroutine

    subroutine save_error_ici(status, where, cause)
	integer, intent(in):: status
	character(len = *), intent(in):: where
	integer, intent(in):: cause
    continue
	call NetcdfSaveError(status, where, char(itos(cause)))
    end subroutine

end module
