dc_error.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
 
module dc_error
 
  use netcdf, only: nf90_enotvar, nf90_einval
  use dc_types, only: string
  implicit none
  private
  public :: nf90_enotvar, nf90_einval
 
 
  integer, public, parameter   :: dc_noerr  = 0
  integer, private, save       :: errno     = dc_noerr
                              
  integer, private, save       :: cause_int = dc_noerr
                              
  logical, private, save       :: cause_int_valid = .false.
                              
  character(STRING), private, save :: cause_string = ""
                              
  character(STRING), private, save :: cause_location = ""
                              
 
 
  integer, parameter, public:: gt_efake = -100
 
  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
  integer, parameter, public:: gt_enoturl            = -119
  integer, parameter, public:: gt_ebadgt4commagraphy = -120
 
  integer, parameter, public:: gr_enotgr = -300
 
  integer, parameter, public:: dc_enotinit       = -400
  integer, parameter, public:: dc_ealreadyinit   = -401
  integer, parameter, public:: dc_ebadunit       = -402
  integer, parameter, public:: dc_ebadcaltype    = -403
  integer, parameter, public:: dc_ebadtimezone   = -404
  integer, parameter, public:: dc_efilenameempty = -405
  integer, parameter, public:: dc_ebadfileopmode = -406
  integer, parameter, public:: dc_enounitnum     = -407
  integer, parameter, public:: dc_enofileexist   = -408
  integer, parameter, public:: dc_enofileread    = -409
  integer, parameter, public:: dc_enofilewrite   = -410
  integer, parameter, public:: dc_enegative      = -411
  integer, parameter, public:: dc_earglack       = -412
  integer, parameter, public:: dc_enoassoc       = -413
  integer, parameter, public:: dc_enoentry       = -414
  integer, parameter, public:: dc_enodimtime     = -415
  integer, parameter, public:: dc_edimtime       = -416
  integer, parameter, public:: dc_etoolargetime  = -417
  integer, parameter, public:: dc_ebaddate       = -418
  integer, parameter, public:: dc_einconsistcaldate = -419
 
  integer, parameter, public:: hst_enotindefine      = -500
  integer, parameter, public:: hst_eindefine         = -501
  integer, parameter, public:: hst_eintfile          = -502
  integer, parameter, public:: hst_ebadname          = -503
  integer, parameter, public:: hst_enottermgthist    = -504
  integer, parameter, public:: hst_enodependtime     = -505
  integer, parameter, public:: hst_ebadvarname       = -506
  integer, parameter, public:: hst_enotimedim        = -507
  integer, parameter, public:: hst_enoaxisname       = -508
  integer, parameter, public:: hst_evarinuse         = -509
  integer, parameter, public:: hst_ealreadyregvarfix = -510
  integer, parameter, public:: hst_ebadslice         = -511
  integer, parameter, public:: hst_ebadnewfileint    = -512
  integer, parameter, public:: hst_emaxdimsdepended  = -513
  integer, parameter, public:: hst_eindivisible      = -514
  integer, parameter, public:: hst_ebadterminus      = -515
  integer, parameter, public:: hst_ebadorigin        = -516
  integer, parameter, public:: hst_empinoaxisdata    = -517
 
 
  integer, parameter, public:: usr_errno = -1000
 
  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, only: nf90_strerror
    character(len = *), intent(out):: msg
    character(len = STRING):: message
    character(len = 20):: errno_c
    character(len = 20):: cause_int_c
  continue
    select case(errno)
    case(gt_efake)
      msg = ' function not implemented'
      !
      ! -101 以下: データ構造のエラー
      ! -101 or less: Error of data structure
      !
    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) // ')'
    case(gt_enoturl)
      msg = ' URL (' // trim(cause_string) // ') is not found'
    case(gt_ebadgt4commagraphy)
      msg = ' (' // trim(cause_string) // ') is not gtool4 comma-graphy (ex. "time=100.0,x=10:20,y=^1:^5")'
      !
      ! -300 以下: GrADS 入出力のエラー
      ! -300 or less: Error of GrADS I/O
      !
    case(gr_enotgr)
      msg = ' invalid GrADS file'
      !
      ! -400 以下: DC ユーティリティのエラー
      ! -400 or less: Error of DC utilities
      !
    case(dc_enotinit)
      msg = ' object (' // trim(cause_string) // ') is not initialized'
    case(dc_ealreadyinit)
      msg = ' object (' // trim(cause_string) // ') is already initialized'
    case(dc_ebadunit)
      msg = ' unit (' // trim(cause_string) // ') is invalid'
    case(dc_ebadcaltype)
      write(message, '(" calendar type (", i4, ") is invalid")') cause_int
      msg = trim(message)
    case(dc_ebadtimezone)
      msg = ' time zone (' // trim(cause_string) // ') is invalid'
    case(dc_efilenameempty)
      msg = ' filename is empty'
    case(dc_ebadfileopmode)
      msg = ' file open mode (' // trim(cause_string) // ') is invalid'
    case(dc_enounitnum)
      msg = ' available unit number is not found within (' // trim(cause_string) // ')'
    case(dc_enofileexist)
      msg = ' file (' // trim(cause_string) // ') is not found'
    case(dc_enofileread)
      msg = ' file (' // trim(cause_string) // ') is not readable'
    case(dc_enofilewrite)
      msg = ' file (' // trim(cause_string) // ') is not writable'
    case(dc_enegative)
      msg = ' negative value is invalid for (' // trim(cause_string) // ')'
    case(dc_earglack)
      msg = ' lack of arguments (' // trim(cause_string) // ')'
    case(dc_enoassoc)
      msg = ' argument (' // trim(cause_string) // ') is not associated'
    case(dc_enoentry)
      msg = ' entry of (' // trim(cause_string) // ') is not found'
    case(dc_enodimtime)
      msg = ' dimensional time can not be converted into nondimensional time'
    case(dc_edimtime)
      msg = ' nondimensional time can not be converted into dimensional time'
    case(dc_etoolargetime)
      msg = ' number is too large for time'
    case(dc_ebaddate)
      msg = ' invalid expression of date'
    case(dc_einconsistcaldate)
      msg = ' calendar and date are inconsistent'
      !
      ! -500 以下: データ入出力層のエラー
      ! -500 or less: Error of data I/O layer
      !
    case(hst_enotindefine)
      msg = ' operation (' // trim(cause_string) // ') not allowed in data mode'
    case(hst_eindefine)
      msg = ' operation (' // trim(cause_string) // ') not allowed in define mode'
    case(hst_eintfile)
      msg = ' different intervals are applied to a file (' // trim(cause_string) // ')'
    case(hst_ebadname)
      msg = ' name (' // trim(cause_string) // ') is invalid'
    case(hst_enottermgthist)
      msg = ' GT_HISTORY correspond to (' // trim(cause_string) // ') is not terminated'
    case(hst_enodependtime)
      msg = ' (' // trim(cause_string) // ') does not depend on time'
    case(hst_ebadvarname)
      msg = ' variable name (' // trim(cause_string) // ') is invalid'
    case(hst_enotimedim)
      msg = ' time dimension is not found'
    case(hst_enoaxisname)
      msg = ' axis or weight (' // trim(cause_string) // ') is not found'
    case(hst_evarinuse)
      msg = ' variable name (' // trim(cause_string) // ') is already used'
    case(hst_ealreadyregvarfix)
      msg = ' already register of variables is fixed by (' // trim(cause_string) // ')'
    case(hst_ebadslice)
      msg = ' slice options are invalid (' // trim(cause_string) // ')'
    case(hst_ebadnewfileint)
      msg = ' invalid newfile interval (' // trim(cause_string) // ')'
    case(hst_emaxdimsdepended)
      write(message, '("(", i4, ")")') cause_int
      msg = trim(message)
      msg = ' variable (' // trim(cause_string) // ') depends on ' // trim(message) // ' dimensions'
    case(hst_eindivisible)
      msg = ' (' // trim(cause_string) // ') can not be divided'
    case(hst_ebadterminus)
      msg = ' terminus options are invalid (' // trim(cause_string) // ')'
    case(hst_ebadorigin)
      msg = ' origin options are invalid (' // trim(cause_string) // ')'
    case(hst_empinoaxisdata)
      msg = ' data of axis (' // trim(cause_string) // ') for MPI is lack'
 
      !
      !
      ! -1000 以下: ユーザー定義
      ! -1000 or less: User-defined error
      !
    case(:usr_errno)
      if (len(trim(adjustl(cause_string))) < 1) then
        cause_string = 'Unknown error'
      end if
      if (cause_int_valid) then
        write(cause_int_c, "(i8)") cause_int
        msg = trim(cause_string) // ' (' // trim(adjustl(cause_int_c)) // ')'
      else
        msg = trim(cause_string)
      end if
    case default
      goto 999
    end select
    write(errno_c, "(i8)") errno
    msg =  '*** ERROR (Code ' // trim(adjustl(errno_c))  // &
      & ') [' // trim(cause_location) // '] ***  ' // &
      & trim(msg)
    return
 
999 continue
    if (len(cause_string) > 0) then
      message = nf90_strerror(errno)
      write(errno_c, "(i8)") errno
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c)) // &
        & ') [' // trim(cause_location)             // &
        & '('   // trim(cause_string) // ')] ***  ' // &
        & trim(message)
    else if (cause_int_valid) then
      message = nf90_strerror(errno)
      write(errno_c, "(i8)") errno
      write(cause_int_c, "(i8)") cause_int
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c)) // &
        & ') [' // trim(cause_location)             // &
        & '('   // trim(adjustl(cause_int_c)) // ')] ***  ' // &
        & trim(message)
    else
      message = nf90_strerror(errno)
      write(errno_c, "(i8)") errno
      msg =  '*** ERROR (Code ' // trim(adjustl(errno_c))  // &
        & ') [' // trim(cause_location) // '] ***  ' // &
        & trim(message)
    endif
  end subroutine geterrormessage
 
  subroutine storeerror(number, where, err, cause_c, cause_i)
    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
    if (present(err)) then
      err = (number /= dc_noerr)
      return
    endif
    if (number == dc_noerr) return
    errno = number
    cause_location = where
    if (present(cause_c)) then
      cause_string = trim(cause_c)
    else
      cause_string = ""
    endif
    if (present(cause_i)) then
      cause_int = cause_i
      cause_int_valid = .true.
    else
      cause_int_valid = .false.
    end if
    call dumperror
  end subroutine storeerror
 
end module dc_error
 
subroutine dumperror()
  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