Simulation Core
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

303 lines
9.3 KiB

  1. module CError
  2. use CIActionReference
  3. implicit none
  4. public
  5. interface Error
  6. module procedure :: Error1, Error2, Error3, Error4, Error5
  7. end interface
  8. interface ErrorStop
  9. module procedure :: ErrorStop1, ErrorStop2, ErrorStop3, ErrorStop4, ErrorStop5
  10. end interface
  11. procedure (ActionString), pointer :: ErrorMessagePtr
  12. procedure (ActionStringInt), pointer :: ErrorMessageIntPtr
  13. procedure (ActionStringFloat), pointer :: ErrorMessageFloatPtr
  14. procedure (ActionStringDouble), pointer :: ErrorMessageDoublePtr
  15. procedure (ActionStringBool), pointer :: ErrorMessageBoolPtr
  16. procedure (ActionString), pointer :: ErrorStopPtr
  17. procedure (ActionStringInt), pointer :: ErrorStopIntPtr
  18. procedure (ActionStringFloat), pointer :: ErrorStopFloatPtr
  19. procedure (ActionStringDouble), pointer :: ErrorStopDoublePtr
  20. procedure (ActionStringBool), pointer :: ErrorStopBoolPtr
  21. contains
  22. subroutine Error1(message)
  23. implicit none
  24. character(len=*), intent(in) :: message
  25. if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message)
  26. end subroutine
  27. subroutine Error2(message, value)
  28. implicit none
  29. character(len=*), intent(in) :: message
  30. integer, intent(in) :: value
  31. !character(len=256) :: temp
  32. !temp(:)=' '
  33. !write(temp,*) value
  34. !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
  35. if(associated(ErrorMessageIntPtr)) call ErrorMessageIntPtr(message, value)
  36. end subroutine
  37. subroutine Error3(message, value)
  38. implicit none
  39. character(len=*), intent(in) :: message
  40. real, intent(in) :: value
  41. !character(len=256) :: temp
  42. !temp(:)=' '
  43. !write(temp,*) value
  44. !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
  45. if(associated(ErrorMessageFloatPtr)) call ErrorMessageFloatPtr(message, value)
  46. end subroutine
  47. subroutine Error4(message, value)
  48. implicit none
  49. character(len=*), intent(in) :: message
  50. real(8), intent(in) :: value
  51. !character(len=256) :: temp
  52. !temp(:)=' '
  53. !write(temp,*) value
  54. !if(associated(ErrorMessagePtr)) call ErrorMessagePtr(trim(message//' '//adjustl(temp)))
  55. if(associated(ErrorMessageDoublePtr)) call ErrorMessageDoublePtr(message, value)
  56. end subroutine
  57. subroutine Error5(message, value)
  58. implicit none
  59. character(len=*), intent(in) :: message
  60. logical, intent(in) :: value
  61. !if(value) then
  62. ! if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message//' '//'TRUE')
  63. !else
  64. ! if(associated(ErrorMessagePtr)) call ErrorMessagePtr(message//' '//'FALSE')
  65. !endif
  66. if(associated(ErrorMessageBoolPtr)) call ErrorMessageBoolPtr(message, value)
  67. end subroutine
  68. subroutine ErrorStop1(message)
  69. !use ifmt
  70. implicit none
  71. character(len=*), intent(in) :: message
  72. if(associated(ErrorStopPtr)) then
  73. call ErrorStopPtr(message)
  74. ! call ExitThread(0)
  75. end if
  76. end subroutine
  77. subroutine ErrorStop2(message, value)
  78. !use ifmt
  79. implicit none
  80. character(len=*), intent(in) :: message
  81. integer, intent(in) :: value
  82. !character(len=256) :: temp
  83. !temp(:)=' '
  84. !write(temp,*) value
  85. !if(associated(ErrorStopPtr)) then
  86. ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
  87. ! ! call ExitThread(0)
  88. !end if
  89. if(associated(ErrorStopIntPtr)) then
  90. call ErrorStopIntPtr(message, value)
  91. ! call ExitThread(0)
  92. end if
  93. end subroutine
  94. subroutine ErrorStop3(message, value)
  95. !use ifmt
  96. implicit none
  97. character(len=*), intent(in) :: message
  98. real, intent(in) :: value
  99. !character(len=256) :: temp
  100. !temp(:)=' '
  101. !write(temp,*) value
  102. !if(associated(ErrorStopPtr)) then
  103. ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
  104. ! ! call ExitThread(0)
  105. !end if
  106. if(associated(ErrorStopFloatPtr)) then
  107. call ErrorStopFloatPtr(message, value)
  108. ! ! call ExitThread(0)
  109. end if
  110. end subroutine
  111. subroutine ErrorStop4(message, value)
  112. ! use ifmt
  113. implicit none
  114. character(len=*), intent(in) :: message
  115. real(8), intent(in) :: value
  116. !character(len=256) :: temp
  117. !temp(:)=' '
  118. !write(temp,*) value
  119. !if(associated(ErrorStopPtr)) then
  120. ! call ErrorStopPtr(trim(message//' '//adjustl(temp)))
  121. ! ! call ExitThread(0)
  122. !end if
  123. if(associated(ErrorStopDoublePtr)) then
  124. call ErrorStopDoublePtr(message, value)
  125. ! ! call ExitThread(0)
  126. end if
  127. end subroutine
  128. subroutine ErrorStop5(message, value)
  129. !use ifmt
  130. implicit none
  131. character(len=*), intent(in) :: message
  132. logical, intent(in) :: value
  133. !if(value) then
  134. ! if(associated(ErrorStopPtr)) then
  135. ! call ErrorStopPtr(message//' '//'TRUE')
  136. ! ! ! call ExitThread(0)
  137. ! end if
  138. !else
  139. ! if(associated(ErrorStopPtr)) then
  140. ! call ErrorStopPtr(message//' '//'FALSE')
  141. ! ! ! call ExitThread(0)
  142. ! end if
  143. !endif
  144. if(associated(ErrorStopBoolPtr)) then
  145. call ErrorStopBoolPtr(message, value)
  146. ! call ExitThread(0)
  147. end if
  148. end subroutine
  149. subroutine SubscribeErrorMessage(a)
  150. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessage
  151. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessage' :: SubscribeErrorMessage
  152. implicit none
  153. procedure (ActionString) :: a
  154. ErrorMessagePtr => a
  155. end subroutine
  156. subroutine SubscribeErrorMessageInt(a)
  157. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageInt
  158. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageInt' :: SubscribeErrorMessageInt
  159. implicit none
  160. procedure (ActionStringInt) :: a
  161. ErrorMessageIntPtr => a
  162. end subroutine
  163. subroutine SubscribeErrorMessageFloat(a)
  164. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageFloat
  165. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageFloat' :: SubscribeErrorMessageFloat
  166. implicit none
  167. procedure (ActionStringFloat) :: a
  168. ErrorMessageFloatPtr => a
  169. end subroutine
  170. subroutine SubscribeErrorMessageDouble(a)
  171. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageDouble
  172. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageDouble' :: SubscribeErrorMessageDouble
  173. implicit none
  174. procedure (ActionStringDouble) :: a
  175. ErrorMessageDoublePtr => a
  176. end subroutine
  177. subroutine SubscribeErrorMessageBool(a)
  178. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorMessageBool
  179. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorMessageBool' :: SubscribeErrorMessageBool
  180. implicit none
  181. procedure (ActionStringBool) :: a
  182. ErrorMessageBoolPtr => a
  183. end subroutine
  184. subroutine SubscribeErrorStop(a)
  185. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStop
  186. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStop' :: SubscribeErrorStop
  187. implicit none
  188. procedure (ActionString) :: a
  189. ErrorStopPtr => a
  190. end subroutine
  191. subroutine SubscribeErrorStopInt(a)
  192. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopInt
  193. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopInt' :: SubscribeErrorStopInt
  194. implicit none
  195. procedure (ActionStringInt) :: a
  196. ErrorStopIntPtr => a
  197. end subroutine
  198. subroutine SubscribeErrorStopFloat(a)
  199. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopFloat
  200. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopFloat' :: SubscribeErrorStopFloat
  201. implicit none
  202. procedure (ActionStringFloat) :: a
  203. ErrorStopFloatPtr => a
  204. end subroutine
  205. subroutine SubscribeErrorStopDouble(a)
  206. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopDouble
  207. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopDouble' :: SubscribeErrorStopDouble
  208. implicit none
  209. procedure (ActionStringDouble) :: a
  210. ErrorStopDoublePtr => a
  211. end subroutine
  212. subroutine SubscribeErrorStopBool(a)
  213. !DEC$ ATTRIBUTES DLLEXPORT :: SubscribeErrorStopBool
  214. !DEC$ ATTRIBUTES ALIAS: 'SubscribeErrorStopBool' :: SubscribeErrorStopBool
  215. implicit none
  216. procedure (ActionStringBool) :: a
  217. ErrorStopBoolPtr => a
  218. end subroutine
  219. end module CError