|
- module CError
- use CIActionReference
- implicit none
- public
- interface Error
- module procedure :: Error1, Error2, Error3, Error4, Error5
- end interface
-
- interface ErrorStop
- module procedure :: ErrorStop1, ErrorStop2, ErrorStop3, ErrorStop4, ErrorStop5
- end interface
-
- procedure (ActionString), pointer :: ErrorMessagePtr
- procedure (ActionStringInt), pointer :: ErrorMessageIntPtr
- procedure (ActionStringFloat), pointer :: ErrorMessageFloatPtr
- procedure (ActionStringDouble), pointer :: ErrorMessageDoublePtr
- procedure (ActionStringBool), pointer :: ErrorMessageBoolPtr
-
- procedure (ActionString), pointer :: ErrorStopPtr
- procedure (ActionStringInt), pointer :: ErrorStopIntPtr
- procedure (ActionStringFloat), pointer :: ErrorStopFloatPtr
- procedure (ActionStringDouble), pointer :: ErrorStopDoublePtr
- procedure (ActionStringBool), pointer :: ErrorStopBoolPtr
- contains
-
- subroutine Error1(message)
- implicit none
- character(len=*), intent(in) :: message
- if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message)
- end subroutine
-
- subroutine Error2(message, value)
- implicit none
- character(len=*), intent(in) :: message
- integer, intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
- if(associated(ErrorMessageIntPtr)) call ErrorMessageIntPtr(message, value)
- end subroutine
-
- subroutine Error3(message, value)
- implicit none
- character(len=*), intent(in) :: message
- real, intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
- if(associated(ErrorMessageFloatPtr)) call ErrorMessageFloatPtr(message, value)
- end subroutine
-
- subroutine Error4(message, value)
- implicit none
- character(len=*), intent(in) :: message
- real(8), intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
- if(associated(ErrorMessageDoublePtr)) call ErrorMessageDoublePtr(message, value)
- end subroutine
-
- subroutine Error5(message, value)
- implicit none
- character(len=*), intent(in) :: message
- logical, intent(in) :: value
- !if(value) then
- ! if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message//' '//'TRUE')
- !else
- ! if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message//' '//'FALSE')
- !endif
- if(associated(ErrorMessageBoolPtr)) call ErrorMessageBoolPtr(message, value)
- end subroutine
-
-
-
-
-
-
-
-
-
-
-
-
-
- subroutine ErrorStop1(message)
- !use ifmt
- implicit none
- character(len=*), intent(in) :: message
- if(associated(ErrorStopPtr)) then
- call ErrorStopPtr(message)
- ! call ExitThread(0)
- end if
- end subroutine
-
- subroutine ErrorStop2(message, value)
- !use ifmt
- implicit none
- character(len=*), intent(in) :: message
- integer, intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorStopPtr)) then
- ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
- ! ! call ExitThread(0)
- !end if
- if(associated(ErrorStopIntPtr)) then
- call ErrorStopIntPtr(message, value)
- ! call ExitThread(0)
- end if
- end subroutine
-
- subroutine ErrorStop3(message, value)
- !use ifmt
- implicit none
- character(len=*), intent(in) :: message
- real, intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorStopPtr)) then
- ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
- ! ! call ExitThread(0)
- !end if
- if(associated(ErrorStopFloatPtr)) then
- call ErrorStopFloatPtr(message, value)
- ! ! call ExitThread(0)
- end if
- end subroutine
-
- subroutine ErrorStop4(message, value)
- ! use ifmt
- implicit none
- character(len=*), intent(in) :: message
- real(8), intent(in) :: value
- !character(len=256) :: temp
- !temp(:)=' '
- !write(temp,*) value
- !if(associated(ErrorStopPtr)) then
- ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
- ! ! call ExitThread(0)
- !end if
- if(associated(ErrorStopDoublePtr)) then
- call ErrorStopDoublePtr(message, value)
- ! ! call ExitThread(0)
- end if
- end subroutine
-
- subroutine ErrorStop5(message, value)
- !use ifmt
- implicit none
- character(len=*), intent(in) :: message
- logical, intent(in) :: value
- !if(value) then
- ! if(associated(ErrorStopPtr)) then
- ! call ErrorStopPtr(message//' '//'TRUE')
- ! ! ! call ExitThread(0)
- ! end if
- !else
- ! if(associated(ErrorStopPtr)) then
- ! call ErrorStopPtr(message//' '//'FALSE')
- ! ! ! call ExitThread(0)
- ! end if
- !endif
- if(associated(ErrorStopBoolPtr)) then
- call ErrorStopBoolPtr(message, value)
- ! call ExitThread(0)
- end if
- end subroutine
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- subroutine SubscribeErrorMessage(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessage
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessage' :: SubscribeErrorMessage
- implicit none
- procedure (ActionString) :: a
- ErrorMessagePtr => a
- end subroutine
-
-
- subroutine SubscribeErrorMessageInt(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageInt
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageInt' :: SubscribeErrorMessageInt
- implicit none
- procedure (ActionStringInt) :: a
- ErrorMessageIntPtr => a
- end subroutine
-
- subroutine SubscribeErrorMessageFloat(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageFloat
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageFloat' :: SubscribeErrorMessageFloat
- implicit none
- procedure (ActionStringFloat) :: a
- ErrorMessageFloatPtr => a
- end subroutine
-
- subroutine SubscribeErrorMessageDouble(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageDouble
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageDouble' :: SubscribeErrorMessageDouble
- implicit none
- procedure (ActionStringDouble) :: a
- ErrorMessageDoublePtr => a
- end subroutine
-
- subroutine SubscribeErrorMessageBool(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageBool
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageBool' :: SubscribeErrorMessageBool
- implicit none
- procedure (ActionStringBool) :: a
- ErrorMessageBoolPtr => a
- end subroutine
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- subroutine SubscribeErrorStop(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStop
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStop' :: SubscribeErrorStop
- implicit none
- procedure (ActionString) :: a
- ErrorStopPtr => a
- end subroutine
-
- subroutine SubscribeErrorStopInt(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopInt
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopInt' :: SubscribeErrorStopInt
- implicit none
- procedure (ActionStringInt) :: a
- ErrorStopIntPtr => a
- end subroutine
-
-
- subroutine SubscribeErrorStopFloat(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopFloat
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopFloat' :: SubscribeErrorStopFloat
- implicit none
- procedure (ActionStringFloat) :: a
- ErrorStopFloatPtr => a
- end subroutine
-
- subroutine SubscribeErrorStopDouble(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopDouble
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopDouble' :: SubscribeErrorStopDouble
- implicit none
- procedure (ActionStringDouble) :: a
- ErrorStopDoublePtr => a
- end subroutine
-
- subroutine SubscribeErrorStopBool(a)
- !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopBool
- !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopBool' :: SubscribeErrorStopBool
- implicit none
- procedure (ActionStringBool) :: a
- ErrorStopBoolPtr => a
- end subroutine
-
- end module CError
|