forked from openmc-dev/openmc
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy patherror.F90
163 lines (127 loc) · 4.42 KB
/
error.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
module error
use, intrinsic :: ISO_FORTRAN_ENV
use constants
use global
#ifdef MPI
use mpi
#endif
implicit none
contains
!===============================================================================
! WARNING issues a warning to the user in the log file and the standard output
! stream.
!===============================================================================
subroutine warning(message)
character(*) :: message
integer :: i_start ! starting position
integer :: i_end ! ending position
integer :: line_wrap ! length of line
integer :: length ! length of message
integer :: indent ! length of indentation
! Write warning at beginning
write(ERROR_UNIT, fmt='(1X,A)', advance='no') 'WARNING: '
! Set line wrapping and indentation
line_wrap = 80
indent = 10
! Determine length of message
length = len_trim(message)
i_start = 0
do
if (length - i_start < line_wrap - indent + 1) then
! Remainder of message will fit on line
write(ERROR_UNIT, fmt='(A)') message(i_start+1:length)
exit
else
! Determine last space in current line
i_end = i_start + index(message(i_start+1:i_start+line_wrap-indent+1), &
' ', BACK=.true.)
if (i_end == i_start) then
! This is a special case where there is no space
i_end = i_start + line_wrap - indent + 1
write(ERROR_UNIT, fmt='(A/A)', advance='no') &
message(i_start+1:i_end-1), repeat(' ', indent)
i_end = i_end - 1
else
! Write up to last space
write(ERROR_UNIT, fmt='(A/A)', advance='no') &
message(i_start+1:i_end-1), repeat(' ', indent)
end if
! Advance starting position
i_start = i_end
if (i_start > length) exit
end if
end do
end subroutine warning
!===============================================================================
! FATAL_ERROR alerts the user that an error has been encountered and displays a
! message about the particular problem. Errors are considered 'fatal' and hence
! the program is aborted.
!===============================================================================
subroutine fatal_error(message, error_code)
character(*) :: message
integer, optional :: error_code ! error code
integer :: code ! error code
integer :: i_start ! starting position
integer :: i_end ! ending position
integer :: line_wrap ! length of line
integer :: length ! length of message
integer :: indent ! length of indentation
! set default error code
if (present(error_code)) then
code = error_code
else
code = -1
end if
! Write error at beginning
write(ERROR_UNIT, fmt='(1X,A)', advance='no') 'ERROR: '
! Set line wrapping and indentation
line_wrap = 80
indent = 8
! Determine length of message
length = len_trim(message)
i_start = 0
do
if (length - i_start < line_wrap - indent + 1) then
! Remainder of message will fit on line
write(ERROR_UNIT, fmt='(A)') message(i_start+1:length)
exit
else
! Determine last space in current line
i_end = i_start + index(message(i_start+1:i_start+line_wrap-indent+1), &
' ', BACK=.true.)
if (i_end == i_start) then
! This is a special case where there is no space
i_end = i_start + line_wrap - indent + 1
write(ERROR_UNIT, fmt='(A/A)', advance='no') &
message(i_start+1:i_end-1), repeat(' ', indent)
i_end = i_end - 1
else
! Write up to last space
write(ERROR_UNIT, fmt='(A/A)', advance='no') &
message(i_start+1:i_end-1), repeat(' ', indent)
end if
! Advance starting position
i_start = i_end
if (i_start > length) exit
end if
end do
! Write information on current batch, generation, and particle
if (current_batch > 0) then
write(ERROR_UNIT,'(1X,A,I12) ') 'Batch: ', current_batch
write(ERROR_UNIT,'(1X,A,I12) ') 'Generation:', current_gen
write(ERROR_UNIT,*)
end if
! Release memory from all allocatable arrays
call free_memory()
#ifdef MPI
! Abort MPI
call MPI_ABORT(MPI_COMM_WORLD, code, mpi_err)
#endif
! Abort program
#ifdef NO_F2008
stop
#else
error stop
#endif
end subroutine fatal_error
end module error