Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!! !!!!
4 : !!!! ParaMonte: Parallel Monte Carlo and Machine Learning Library. !!!!
5 : !!!! !!!!
6 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab !!!!
7 : !!!! !!!!
8 : !!!! This file is part of the ParaMonte library. !!!!
9 : !!!! !!!!
10 : !!!! LICENSE !!!!
11 : !!!! !!!!
12 : !!!! https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md !!!!
13 : !!!! !!!!
14 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
15 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16 :
17 : !> \brief
18 : !> This file contains procedure implementations of [pm_except](@ref pm_except).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \AmirShahmoradi, Friday 1:54 AM, April 21, 2017, Institute for Computational Engineering and Sciences (ICES), The University of Texas, Austin, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : !%%%%%%%%%%%%%%
28 : #if getFine_ENABLED
29 : !%%%%%%%%%%%%%%
30 :
31 633283916 : str = getFile(file)//getLine(line)
32 :
33 : !%%%%%%%%%%%%%%
34 : #elif getFile_ENABLED
35 : !%%%%%%%%%%%%%%
36 :
37 633283917 : str = SKC_'@file('//file//SKC_")"
38 :
39 : !%%%%%%%%%%%%%%
40 : #elif getLine_ENABLED
41 : !%%%%%%%%%%%%%%
42 :
43 633283918 : str = repeat(SK_" ", range(0_IKC) + 3) ! sign. 2 is essential. extra 1 is cautionary.
44 633283918 : write(str, "(I0)") line
45 633283918 : str = '@line('//trim(str)//")"
46 :
47 : !%%%%%%%%%%%%%%%%%%
48 : #elif setAsserted_ENABLED
49 : !%%%%%%%%%%%%%%%%%%
50 :
51 : character(1, SK), parameter :: BEL = achar(7, SK)
52 : character(*, SK), parameter :: NLC = new_line(SK_"a")
53 633284392 : if (.not. assertion) then
54 0 : if (present(msg)) then
55 : #if MEXPRINT_ENABLED
56 : call mexPrintf(msg//repeat(BEL, 3)//NLC)
57 : #else
58 0 : write(output_unit,"(A)") msg//repeat(BEL, 3)
59 : #endif
60 : end if
61 0 : if (present(renabled)) then
62 0 : if (renabled) return
63 : end if
64 0 : error stop "Assertion failed."
65 : end if
66 :
67 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
68 : #elif setMarked_ENABLED && Static_ENABLED
69 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
70 :
71 : use pm_str, only: getStrWrapped
72 :
73 : character(:,SKC), allocatable :: def_prefix, remark
74 : character(1,SKC), parameter :: LF = new_line(SKC_"a") ! char(10, SKC)
75 : integer(IK) :: def_unit, def_tmsize, def_bmsize
76 :
77 : ! Set the prefix.
78 :
79 1496 : if (present(prefix)) then
80 1495 : def_prefix = prefix
81 : else
82 1 : def_prefix = SKC_" - REMARK: "
83 : end if
84 :
85 : ! Set the default.
86 :
87 : def_unit = int(output_unit, IK)
88 1496 : if (present(unit)) def_unit = unit
89 :
90 : def_tmsize = 1_IK
91 1496 : if (present(tmsize)) def_tmsize = tmsize
92 :
93 : def_bmsize = 0_IK
94 1496 : if (present(bmsize)) def_bmsize = bmsize
95 :
96 : ! Wrap the message and write the text to the output
97 :
98 11887 : remark = repeat(LF, def_tmsize)//getStrWrapped(msg, prefix = def_prefix, indent = indent, break = break, newline = newline, linefeed = LF, width = width, maxwidth = maxwidth)//repeat(LF, def_bmsize)
99 : #if MEXPRINT_ENABLED
100 : if (def_unit == output_unit) then
101 : call mexPrintf(remark//new_line(SKC_"a"))
102 : return
103 : end if
104 : #endif
105 1496 : write(def_unit, "(a)") remark
106 :
107 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
108 : #elif setNoted_ENABLED && Static_ENABLED
109 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
110 :
111 : character(*,SKC), parameter :: REMARK = SKC_" - NOTE: "
112 1449 : if (present(prefix)) then
113 10126 : call setMarked(msg, prefix//REMARK, indent, break, newline, width, maxwidth, tmsize, bmsize, unit)
114 : else
115 5 : call setMarked(msg, REMARK, indent, break, newline, width, maxwidth, tmsize, bmsize, unit)
116 : end if
117 :
118 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
119 : #elif setWarned_ENABLED && Static_ENABLED
120 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
121 :
122 : character(*,SKC), parameter :: REMARK = SKC_" - WARNING: "
123 14 : if (present(prefix)) then
124 53 : call setMarked(msg, prefix//REMARK, indent, break, newline, width, maxwidth, tmsize, bmsize, unit)
125 : else
126 33 : call setMarked(msg, REMARK, indent, break, newline, width, maxwidth, tmsize, bmsize, unit)
127 : end if
128 :
129 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
130 : #elif setAborted_ENABLED && Static_ENABLED
131 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
132 :
133 : character(1,SKC), parameter :: LF = new_line(SKC_"a") ! char(10, SKC)
134 : character(*,SKC), parameter :: REMARK = SKC_" - FATAL: "
135 : character(:,SKC), allocatable :: def_prefix, def_msg
136 : character(31,SKC) :: val2str
137 :
138 7 : if (present(prefix)) then
139 6 : def_prefix = prefix//REMARK
140 : else
141 1 : def_prefix = REMARK
142 : end if
143 :
144 : ! Set the error code.
145 :
146 7 : if (present(stat)) then
147 0 : write(val2str, "(2(g0))") LF//SKC_"ERROR CODE: ", stat
148 0 : def_msg = msg//trim(adjustl(val2str))
149 : else
150 7 : def_msg = msg
151 : end if
152 :
153 : ! Set the processor ID.
154 :
155 : block
156 : use pm_parallelism, only: getImageID
157 7 : write(val2str, "(g0)") getImageID()
158 : end block
159 :
160 : ! Report the final troubleshooting info.
161 :
162 7 : def_msg = def_msg//LF//SKC_"Please correct the error(s) and rerun the program."//LF
163 7 : if (present(help)) def_msg = def_msg//help//LF
164 7 : def_msg = def_msg//SKC_"Gracefully exiting on image/process "//trim(adjustl(val2str))//SKC_"."//LF//LF
165 :
166 35 : call setMarked(msg, def_prefix, indent, break, newline, width, maxwidth, tmsize, bmsize, unit)
167 :
168 : ! Report to stdout and flush the output.
169 :
170 : block
171 : use iso_fortran_env, only: output_unit
172 7 : if (present(unit)) then
173 7 : if (unit /= output_unit) call setMarked(msg//repeat(achar(7), 3), def_prefix, indent, break, newline, width, maxwidth, tmsize, bmsize, int(output_unit, IK)) ! Set off the alarm via BEL character.
174 7 : flush(unit)
175 : end if
176 7 : flush(output_unit) ! call execute_command_line(" ")
177 : end block
178 :
179 : ! LCOV_EXCL_START
180 :
181 : ! Return or halt the program.
182 :
183 : block
184 : logical(LK) :: def_renabled
185 : def_renabled = SOFT_EXIT_ENABLED
186 : if (present(renabled)) def_renabled = renabled
187 : if (def_renabled) return
188 : end block
189 :
190 : ! Wait for one second before aborting the program.
191 :
192 : block
193 : use pm_kind, only: IKD
194 : integer(IKD) :: countOld, countNew, countMax, countRate
195 : call system_clock(countOld, countRate, countMax)
196 : if (countOld /= -huge(0_IKD) .and. countRate /= 0_IKD .and. countMax /= 0_IKD) then
197 : loopWait: do
198 : call system_clock(countNew)
199 : if (real(abs(countNew - countOld)) / real(countRate) >= 1.) exit loopWait
200 : end do loopWait
201 : end if
202 : end block
203 :
204 : ! abort.
205 :
206 : #if MPI_ENABLED
207 : block
208 : use mpi !mpi_f08, only: mpi_abort, mpi_comm_world
209 : integer :: ierrMPI
210 : call mpi_abort(mpi_comm_world, 1, ierrMPI)
211 : end block
212 : #else
213 : error stop
214 : #endif
215 : ! LCOV_EXCL_STOP
216 :
217 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
218 : #elif Method_ENABLED && (setMarked_ENABLED || setNoted_ENABLED || setWarned_ENABLED || setAborted_ENABLED)
219 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
220 :
221 : #if setNoted_ENABLED
222 : #define SET_MARKED setNoted
223 : #elif setMarked_ENABLED
224 : #define SET_MARKED setMarked
225 : #elif setWarned_ENABLED
226 : #define SET_MARKED setWarned
227 : #elif setAborted_ENABLED
228 : #define SET_MARKED setAborted
229 : integer(IK), allocatable :: def_stat
230 : logical(LK), allocatable :: def_renabled
231 : character(:,SKC), allocatable :: def_help
232 : #else
233 : #error "Unrecognized interface."
234 : #endif
235 : integer(IK), allocatable :: def_width, def_maxwidth, def_tmsize, def_bmsize, def_unit
236 : character(:,SKC), allocatable :: def_prefix, def_indent, def_break, def_newline
237 1476 : if (present(sticky)) self%sticky = sticky
238 1476 : if (self%sticky) then
239 8 : if (present(prefix ))self%prefix = prefix ;
240 8 : if (present(indent ))self%indent = indent ;
241 8 : if (present(break ))self%break = break ;
242 8 : if (present(newline ))self%newline = newline ;
243 8 : if (present(width ))self%width = width ;
244 8 : if (present(maxwidth))self%maxwidth = maxwidth ;
245 8 : if (present(tmsize ))self%tmsize = tmsize ;
246 8 : if (present(bmsize ))self%bmsize = bmsize ;
247 8 : if (present(unit ))self%unit = unit ;
248 : #if setAborted_ENABLED
249 2 : if (present(help ))self%help = help ;
250 2 : if (present(stat ))self%stat = stat ;
251 2 : if (present(renabled))self%renabled = renabled ;
252 : #elif !(setMarked_ENABLED || setNoted_ENABLED || setWarned_ENABLED)
253 : #error "Unrecognized interface."
254 : #endif
255 : end if
256 1476 : if (present(prefix )) then; def_prefix = prefix ; elseif (allocated(self%prefix )) then; def_prefix = self%prefix ; end if
257 1476 : if (present(indent )) then; def_indent = indent ; elseif (allocated(self%indent )) then; def_indent = self%indent ; end if
258 1476 : if (present(break )) then; def_break = break ; elseif (allocated(self%break )) then; def_break = self%break ; end if
259 1476 : if (present(newline )) then; def_newline = newline ; elseif (allocated(self%newline )) then; def_newline = self%newline ; end if
260 1476 : if (present(width )) then; def_width = width ; elseif (allocated(self%width )) then; def_width = self%width ; end if
261 1476 : if (present(maxwidth)) then; def_maxwidth = maxwidth ; elseif (allocated(self%maxwidth )) then; def_maxwidth = self%maxwidth ; end if
262 1476 : if (present(tmsize )) then; def_tmsize = tmsize ; elseif (allocated(self%tmsize )) then; def_tmsize = self%tmsize ; end if
263 1476 : if (present(bmsize )) then; def_bmsize = bmsize ; elseif (allocated(self%bmsize )) then; def_bmsize = self%bmsize ; end if
264 1476 : if (present(unit )) then; def_unit = unit ; elseif (allocated(self%unit )) then; def_unit = self%unit ; end if
265 : #if setAborted_ENABLED
266 3 : if (present(help )) then; def_help = help ; elseif (allocated(self%help )) then; def_help = self%help ; end if
267 3 : if (present(stat )) then; def_stat = stat ; elseif (allocated(self%stat )) then; def_stat = self%stat ; end if
268 3 : if (present(renabled)) then; def_renabled = renabled ; elseif (allocated(self%renabled )) then; def_renabled = self%renabled ; end if
269 : #elif !(setMarked_ENABLED || setNoted_ENABLED || setWarned_ENABLED)
270 : #error "Unrecognized interface."
271 : #endif
272 : call SET_MARKED( msg &
273 : , prefix = def_prefix &
274 : , indent = def_indent &
275 : , break = def_break &
276 : , newline = def_newline &
277 : , width = def_width &
278 : , maxwidth = def_maxwidth &
279 : , tmsize = def_tmsize &
280 : , bmsize = def_bmsize &
281 : , unit = def_unit &
282 : #if setAborted_ENABLED
283 : , stat = def_stat &
284 : , help = def_help &
285 : , renabled = def_renabled &
286 : #elif !(setMarked_ENABLED || setNoted_ENABLED || setWarned_ENABLED)
287 : #error "Unrecognized interface."
288 : #endif
289 1476 : )
290 1476 : if (allocated(def_prefix )) deallocate(def_prefix )
291 1476 : if (allocated(def_indent )) deallocate(def_indent )
292 1476 : if (allocated(def_break )) deallocate(def_break )
293 1476 : if (allocated(def_newline )) deallocate(def_newline )
294 1476 : if (allocated(def_width )) deallocate(def_width )
295 1476 : if (allocated(def_maxwidth )) deallocate(def_maxwidth )
296 1476 : if (allocated(def_tmsize )) deallocate(def_tmsize )
297 1476 : if (allocated(def_bmsize )) deallocate(def_bmsize )
298 1476 : if (allocated(def_unit )) deallocate(def_unit )
299 : #if setAborted_ENABLED
300 3 : if (allocated(def_help )) deallocate(def_help )
301 3 : if (allocated(def_stat )) deallocate(def_stat )
302 3 : if (allocated(def_renabled )) deallocate(def_renabled )
303 : #elif !(setMarked_ENABLED || setNoted_ENABLED || setWarned_ENABLED)
304 : #error "Unrecognized interface."
305 : #endif
306 : #undef SET_MARKED
307 :
308 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
309 : #elif constructMark_ENABLED || constructNote_ENABLED || constructWarn_ENABLED || constructStop_ENABLED
310 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
311 :
312 389316 : if (present(prefix )) self%prefix = prefix
313 389316 : if (present(indent )) self%indent = indent
314 389316 : if (present(break )) self%break = break
315 389316 : if (present(newline )) self%newline = newline
316 389316 : if (present(width )) self%width = width
317 389316 : if (present(maxwidth )) self%maxwidth = maxwidth
318 389316 : if (present(tmsize )) self%tmsize = tmsize
319 389316 : if (present(bmsize )) self%bmsize = bmsize
320 389316 : if (present(unit )) self%unit = unit
321 389316 : if (present(sticky )) self%sticky = sticky
322 : #if constructStop_ENABLED
323 97329 : if (present(stat )) self%stat = stat
324 97329 : if (present(help )) self%help = help
325 97329 : if (present(renabled )) self%renabled = renabled
326 : #elif !(constructMark_ENABLED || constructNote_ENABLED || constructWarn_ENABLED)
327 : #error "Unrecognized interface."
328 : #endif
329 :
330 : #else
331 : !%%%%%%%%%%%%%%%%%%%%%%%%
332 : #error "Unrecognized interface."
333 : !%%%%%%%%%%%%%%%%%%%%%%%%
334 : #endif
|
