subroutine StoreError( number, where, err, cause_c, cause_i )
!
!== dcpam 用エラー処理サブルーチン
!
! 基本的な使用方法は gt4f90io の dc_error モジュールの
! StoreError と同様です. このモジュールで提供される StoreError
! は dcpam 用のエラーコードを使用可能です.
!
!== Error handling subroutine for dcpam
!
! Usage is same as StoreError provided by dc_error module in
! gt4f90io library. This StoreError can treat error codes for
! dcpam.
!
use dc_error, only: StoreErrorOrg => StoreError
use dc_types, only: STRING
implicit none
integer, intent(in):: number
! エラーコード.
! Error code
character(*), intent(in):: where
! エラー発生個所.
! Place where error occurs
logical, intent(out), optional:: err
! 例外処理用フラグ.
! デフォルトでは, *number* に非エラーコード
! 以外の値が与えられた場合, エラーメッセージを
! 表示してプログラムは強制終了します.
! 引数 *err* が与えられる場合,
! プログラムは強制終了せず, 代わりに
! *err* に .true. が代入されます.
!
! Exception handling flag.
! By default, when error code (excluding
! non error code) is given to *number*,
! the program display error message and aborts.
! If this *err* argument is given,
! .true. is substituted to *err* and
! the program does not abort.
character(*), intent(in), optional:: cause_c
! 文字型メッセージ.
! Character message
integer, intent(in), optional:: cause_i
! 整数型メッセージ.
! Integer message
character(STRING):: cause_string, msg
character(80):: ibuf ! real/write 文のバッファ (整数型用)
integer:: cause_int
continue
if (present(cause_c)) then
cause_string = cause_c
else
cause_string = ''
end if
if (present(cause_i)) then
cause_int = cause_i
else
cause_int = 0
end if
select case(number)
case(DCPAM_ENEGATIVE)
msg = ' negative value is invalid for (' // trim(cause_string) // ')'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EARGLACK)
msg = ' lack of arguments (' // trim(cause_string) // ')'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EALREADYINIT)
msg = ' object (' // trim(cause_string) // ') is already initialized'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ENOTINIT)
msg = ' object (' // trim(cause_string) // ') is not initialized'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ENOVARDEF)
msg = ' variable (' // trim(cause_string) // ') is not defined'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EARGSIZEMISMATCH)
msg = ' arguments (' // trim(cause_string) // ') array size mismatch'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ELMAXMISMATCH)
msg = ' <all wavenum> - <zonal wavenum> is over the meridonal wavenum' // trim(cause_string) // ')'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ENMLARRAYINSUFF)
msg = ' size of array (' // trim(cause_string) // ') in NAMELIST group is insufficient'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EBADPATTERN)
msg = ' pattern (' // trim(cause_string) // ') is invalid'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EBADNUMBER)
write(ibuf, "(i20)") cause_int
msg = ' (' // trim(cause_string) // '=' // trim(adjustl(ibuf)) // ') is invalid'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EAXISMISMATCH)
msg = ' axis (' // trim(cause_string) // ') is mismatched'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EFAILINIT)
msg = ' object (' // trim(cause_string) // ') can not be initialized'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EBADSCHEME)
msg = ' scheme (' // trim(cause_string) // ') is invalid'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EBADMATHFUNC)
msg = ' mathematical function (' // trim(cause_string) // ') is invalid'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ESMALLVAL)
write(ibuf, "(i20)") cause_int
msg = ' (' // trim(cause_string) // ') is too small. Valid range is more than (' // trim(adjustl(ibuf)) // ')'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_ENOPLANET)
msg = ' (' // trim(cause_string) // ') is not supported planet'
call StoreErrorOrg(number, where, err, cause_c=msg)
case(DCPAM_EARGSDUPLICATE)
msg = ' (' // trim(cause_string) // ') can not be used simultaneously'
call StoreErrorOrg(number, where, err, cause_c=msg)
case default
call StoreErrorOrg(number, where, err, cause_c, cause_i)
end select
end subroutine StoreError