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_fftpack](@ref pm_fftpack).
19 : !>
20 : !> \finmain
21 : !>
22 : !> \author
23 : !> \FatemehBagheri, Wednesday 12:20 PM, September 22, 2021, Dallas, TX
24 :
25 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 :
27 : ! Define the compiler specs.
28 : #if INTEL_ENABLED && WINDOWS_ENABLED
29 : #define INTEL_SHARED_FILE, SHARED
30 : #else
31 : #define INTEL_SHARED_FILE
32 : #endif
33 : ! Define the resource.
34 : #if File_ENABLED
35 : #define ITEM file
36 : #elif Unit_ENABLED || Unit_ENABLED
37 : #define ITEM unit
38 : #elif isOpen_ENABLED || getAction_ENABLED
39 : #error "Unrecognized interface."
40 : #endif
41 : ! Define the runtime error check.
42 : #if (setContentsTo_ENABLED || setContentsFrom_ENABLED) && CII_ENABLED
43 : #define RETURN_IF_FAILED if (iostat /= 0_IK) return ! LCOV_EXCL_LINE
44 : #define IOSTAT_IOMSG , iostat = iostat, iomsg = iomsg
45 : #elif (setContentsTo_ENABLED || setContentsFrom_ENABLED) && CDD_ENABLED
46 : #define RETURN_IF_FAILED
47 : #define IOSTAT_IOMSG
48 : #elif (getErrTableRead_ENABLED || getErrTableWrite_ENABLED) && File_ENABLED
49 : #define RETURN_IF_FAILED(LINE) if (err /= 0_IK) then; if (present(iomsg)) iomsg = getStr(LINE)//SK_": "//iomsg_def; close(unit); return; end if ! LCOV_EXCL_LINE
50 : #elif (getErrTableRead_ENABLED || getErrTableWrite_ENABLED) && Unit_ENABLED
51 : #define RETURN_IF_FAILED(LINE) if (err /= 0_IK) then; if (present(iomsg)) iomsg = getStr(LINE)//SK_": "//iomsg_def; return; end if ! LCOV_EXCL_LINE
52 : #elif (setContentsTo_ENABLED || setContentsFrom_ENABLED || getErrTableRead_ENABLED || getErrTableWrite_ENABLED)
53 : #error "Unrecognized interface."
54 : #endif
55 : ! Define the error check.
56 : #define SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) \
57 : if (present(iostat)) then; iostat = iostat_def; if (present(iomsg)) iomsg = iomsg_def; elseif (iostat_def /= 0_IK) then; error stop SK_"FATAL RUNTIME ERROR: "//trim(adjustl(iomsg_def)); end if;
58 :
59 : !%%%%%%%%%%%%%
60 : #if isOpen_ENABLED
61 : !%%%%%%%%%%%%%
62 :
63 775039 : inquire(ITEM = ITEM, opened = opened)
64 :
65 : !%%%%%%%%%%%%%%%%
66 : #elif getAction_ENABLED
67 : !%%%%%%%%%%%%%%%%
68 :
69 11 : inquire(ITEM = ITEM, action = action)
70 :
71 : !%%%%%%%%%%%%%%%%%%%%%
72 : #elif constructField_ENABLED
73 : !%%%%%%%%%%%%%%%%%%%%%
74 :
75 4 : if (present(string)) field%string = string
76 4 : if (present(integer)) field%integer = integer
77 4 : if (present(logical)) field%logical = logical
78 4 : if (present(complex)) field%complex = complex
79 4 : if (present(real)) field%real = real
80 :
81 : !%%%%%%%%%%%%%%%%%%%%%
82 : #elif getCountRecord_ENABLED
83 : !%%%%%%%%%%%%%%%%%%%%%
84 :
85 : #if File_ENABLED
86 : character(LEN_IOMSG) :: iomsg_def
87 : integer(IK) :: unit, iostat_def
88 3 : CHECK_ASSERTION(__LINE__, .not. isOpen(file), SK_"@getCountRecord(): The condition `.not. isOpen(file)` must hold. file = "//getStr(file))
89 : open( iomsg = iomsg_def & ! LCOV_EXCL_LINE
90 : , iostat = iostat_def & ! LCOV_EXCL_LINE
91 : , newunit = unit & ! LCOV_EXCL_LINE
92 : , position = "rewind" & ! LCOV_EXCL_LINE
93 : , access = "sequential" & ! LCOV_EXCL_LINE
94 : , action = "read" & ! LCOV_EXCL_LINE
95 : , status = "old" & ! LCOV_EXCL_LINE
96 : , file = file & ! LCOV_EXCL_LINE
97 3 : INTEL_SHARED_FILE)
98 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
99 : if (iostat_def /= 0_IK) return ! LCOV_EXCL_LINE
100 : #elif Unit_ENABLED
101 0 : rewind(unit)
102 0 : CHECK_ASSERTION(__LINE__, isOpen(unit), SK_"@getCountRecord(): The condition `isOpen(unit)` must hold. unit = "//getStr(unit))
103 : #else
104 : #error "Unrecognized interface."
105 : #endif
106 7 : nrecord = getCountRecordLeft(unit, isCountable, iostat = iostat, iomsg = iomsg) ! Count the file records.
107 : #if File_ENABLED
108 : ! Close / delete the file.
109 3 : call setFileClosed(unit, del, iostat, iomsg)
110 : #endif
111 :
112 : !%%%%%%%%%%%%%%%%%%%%%%%%%
113 : #elif getCountRecordLeft_ENABLED
114 : !%%%%%%%%%%%%%%%%%%%%%%%%%
115 :
116 6 : character(:, SK), allocatable :: record
117 : character(LEN_IOMSG) :: iomsg_def
118 : integer(IK) :: iostat_def
119 : integer(IK) :: ub
120 :
121 : ! Count the file records.
122 :
123 : nrecord = 0_IK
124 6 : if (present(isCountable)) then
125 137 : do
126 137 : call setRecordFrom(unit = unit, record = record, iostat = iostat_def, iomsg = iomsg_def, ub = ub)
127 137 : if (iostat_def == 0_IK) then
128 135 : if (isCountable(record(1:ub))) nrecord = nrecord + 1_IK
129 2 : elseif (iostat_def == iostat_end) then
130 2 : deallocate(record)
131 : exit
132 : else
133 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
134 : return ! LCOV_EXCL_LINE
135 : end if
136 : end do
137 : else
138 264 : do
139 268 : read(unit, "(A)", iostat = iostat_def, iomsg = iomsg_def)
140 272 : if (iostat_def == 0_IK) then
141 264 : nrecord = nrecord + 1_IK
142 4 : elseif (iostat_def == iostat_end) then
143 : exit
144 : else
145 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
146 : return ! LCOV_EXCL_LINE
147 : end if
148 : end do
149 : end if
150 :
151 6 : if (present(reset)) then
152 1 : if (reset) then
153 77 : do ub = 1_IK, nrecord + 1_IK
154 76 : backspace(unit, iostat = iostat_def)
155 76 : if (iostat_def == 0_IK) cycle
156 0 : iomsg_def = MODULE_NAME//SK_"@getCountRecordLeft(): Failed to backspace record."
157 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
158 : return ! LCOV_EXCL_LINE
159 : end do
160 : end if
161 : end if
162 :
163 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
164 : #elif getContentsFrom_ENABLED && Unit_ENABLED
165 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
166 :
167 : call setContentsFrom(unit = unit, contents = contents, del = del)
168 :
169 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
170 : #elif getContentsFrom_ENABLED && File_ENABLED
171 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
172 :
173 : call setContentsFrom(file = file, contents = contents, del = del)
174 :
175 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
176 : #elif setContentsFrom_ENABLED && Unit_ENABLED
177 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
178 :
179 : character(*,SKC) , parameter :: LF = new_line(SKC_"a")
180 : integer(IK) , parameter :: LENLF = len(LF, IK)
181 : integer(IK) :: lb, ub, pos, size, recl
182 : character(10, SK) :: access
183 : #if CDD_ENABLED
184 : #define CATCH_ERR_IF_FAILED \
185 : if (iostat /= 0_IK) error stop MODULE_NAME//SK_"@setContentsFrom(): "//trim(iomsg) ! LCOV_EXCL_LINE
186 : integer(IK) :: iostat
187 : character(LEN_IOMSG, SK) :: iomsg
188 : #elif CII_ENABLED
189 : #define CATCH_ERR_IF_FAILED \
190 : if (iostat /= 0_IK) return ! LCOV_EXCL_LINE
191 : #else
192 : #error "Unrecognized interface."
193 : #endif
194 :
195 1 : CHECK_ASSERTION(__LINE__, isOpen(unit), SK_"@setContentsFrom(): The condition `isOpen(unit)` must hold. unit = "//getStr(unit))
196 1 : CHECK_ASSERTION(__LINE__, index(getAction(unit), "READ") > 0, SK_"@setContentsFrom(): The condition `index(getAction(unit), ""READ"") > 0` must hold. unit = "//getStr(unit))
197 :
198 1 : inquire(unit = unit, access = access IOSTAT_IOMSG)
199 0 : RETURN_IF_FAILED
200 :
201 1 : if (access == SK_"STREAM") then
202 0 : inquire(unit = unit, pos = pos, size = size IOSTAT_IOMSG)
203 0 : RETURN_IF_FAILED
204 0 : allocate(character(size,SKC) :: contents)
205 0 : read(unit, pos = pos IOSTAT_IOMSG) contents
206 1 : elseif (access == SK_"DIRECT") then
207 0 : inquire(unit = unit, nextrec = pos, recl = recl IOSTAT_IOMSG)
208 0 : RETURN_IF_FAILED
209 0 : recl = recl + LENLF
210 0 : allocate(character(recl,SKC) :: contents)
211 : size = len(contents, IK)
212 0 : lb = 1_IK
213 0 : ub = recl
214 : do
215 0 : read(unit, rec = pos IOSTAT_IOMSG) contents(lb : ub - LENLF)
216 0 : if (iostat == iostat_end) exit
217 0 : CATCH_ERR_IF_FAILED
218 0 : contents(lb + recl : ub) = LF
219 0 : lb = ub + 1_IK
220 0 : ub = ub + recl
221 0 : pos = pos + 1_IK
222 0 : if (size < ub) call setResized(contents, ub)
223 : end do
224 0 : contents = contents(1 : ub - LENLF)
225 : #if CII_ENABLED
226 0 : iostat = 0_IK
227 : #endif
228 : else!if (access == SK_"SEQUENTIAL") then or it could be "UNDEFINED" if not set explicitly in gfortran 13.
229 : !error stop MODULE_NAME//SK_"@setContentsFromUnit(): An impossible Internal library error detected. The access attribute of the input `unit` is unrecognized. access="//access ! LCOV_EXCL_LINE
230 1 : allocate(character(LEN_IOMSG,SKC) :: contents)
231 1 : lb = 1_IK
232 34 : do
233 35 : call setRecordFrom(unit, contents, iostat, iomsg, lb = lb, ub = ub, linefed = .true._LK)
234 35 : if (iostat == iostat_end) exit
235 34 : CATCH_ERR_IF_FAILED
236 34 : lb = ub + 1_IK
237 : end do
238 1 : contents = contents(1 : ub - LENLF)
239 : #if CII_ENABLED
240 0 : iostat = 0_IK
241 : #endif
242 : end if
243 :
244 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
245 : #elif setContentsFrom_ENABLED && File_ENABLED
246 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
247 :
248 : integer(IK) :: unit
249 : integer(IK) :: lenContents
250 774998 : CHECK_ASSERTION(__LINE__, .not. isOpen(file), SK_"@setContentsFrom(): The condition `.not. isOpen(file)` must hold. file = "//getStr(file))
251 : open( file = file & ! LCOV_EXCL_LINE
252 : , newunit = unit & ! LCOV_EXCL_LINE
253 : , form = "unformatted" & ! LCOV_EXCL_LINE
254 : , position = "rewind" & ! LCOV_EXCL_LINE
255 : , access = "stream" & ! LCOV_EXCL_LINE
256 : , action = "read" & ! LCOV_EXCL_LINE
257 : , status = "old" & ! LCOV_EXCL_LINE
258 774998 : IOSTAT_IOMSG INTEL_SHARED_FILE)
259 1356056 : RETURN_IF_FAILED
260 :
261 : ! Inquire the file size in bytes.
262 :
263 774997 : inquire(unit = unit, size = lenContents IOSTAT_IOMSG)
264 774972 : RETURN_IF_FAILED
265 :
266 : ! Read the file contents as a string.
267 :
268 774997 : allocate(character(lenContents, SK) :: contents)
269 774997 : read(unit IOSTAT_IOMSG) contents
270 774972 : RETURN_IF_FAILED
271 :
272 : ! Close/delete the file.
273 :
274 774997 : if (present(del)) then
275 581092 : if (del) then
276 581092 : close(unit, status = "delete" IOSTAT_IOMSG)
277 581092 : return
278 : end if
279 : end if
280 193905 : close(unit IOSTAT_IOMSG)
281 :
282 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
283 : #elif setContentsTo_ENABLED && File_ENABLED
284 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
285 :
286 : integer(IK) :: unit
287 14 : CHECK_ASSERTION(__LINE__, .not. isOpen(file), SK_"@setContentsFrom(): The condition `.not. isOpen(file)` must hold. file = "//getStr(file))
288 : open( file = file & ! LCOV_EXCL_LINE
289 : , newunit = unit & ! LCOV_EXCL_LINE
290 : , position = "rewind" & ! LCOV_EXCL_LINE
291 : , form = "unformatted" & ! LCOV_EXCL_LINE
292 : , access = "stream" & ! LCOV_EXCL_LINE
293 : , action = "write" & ! LCOV_EXCL_LINE
294 : , status = "replace" & ! LCOV_EXCL_LINE
295 14 : IOSTAT_IOMSG INTEL_SHARED_FILE)
296 1 : RETURN_IF_FAILED
297 :
298 : ! Write the contents to the file as a string.
299 :
300 : !write(unit, "(A)" IOSTAT_IOMSG) contents
301 14 : write(unit IOSTAT_IOMSG) contents
302 1 : RETURN_IF_FAILED
303 14 : close(unit IOSTAT_IOMSG)
304 :
305 : !%%%%%%%%%%%%%%%%%%%%
306 : #elif getRecordFrom_ENABLED
307 : !%%%%%%%%%%%%%%%%%%%%
308 :
309 : character(LEN_IOMSG, SK) :: iomsg_def
310 : integer(IK) :: iostat_def
311 48 : call setRecordFrom(unit, record, iostat_def, iomsg_def, linefed = linefed)
312 48 : if (present(iostat)) iostat = iostat_def
313 48 : if (present(iomsg)) iomsg = iomsg_def
314 :
315 : !%%%%%%%%%%%%%%%%%%%%
316 : #elif setRecordFrom_ENABLED
317 : !%%%%%%%%%%%%%%%%%%%%
318 :
319 : integer(IK) :: size, lb_def, lenRecord
320 : #if UR_ENABLED
321 : integer(IK) :: iostat
322 : character(LEN_IOMSG, SK) :: iomsg
323 : #elif !URII_ENABLED
324 : #error "Unrecognized interface."
325 : #endif
326 : character(*,SKC), parameter :: LF = new_line(SKC_"a")
327 : integer(IK), parameter :: LENLF = len(LF, IK)
328 : integer(IK) :: nlen
329 :
330 : nlen = 0_IK
331 19222 : if (present(linefed)) then
332 143 : if (linefed) nlen = LENLF
333 : end if
334 :
335 19222 : if (present(lb)) then
336 18755 : CHECK_ASSERTION(__LINE__, 0_IK < lb, SK_"@setRecordFrom(): The condition `0_IK < lb` must hold. lb = "//getStr(lb))
337 18755 : lb_def = lb - 1_IK
338 : else
339 467 : lb_def = 0_IK
340 : end if
341 :
342 19222 : if (allocated(record)) then
343 19094 : lenRecord = len(record, IK) - nlen
344 19094 : if (lenRecord <= lb_def) then
345 17 : deallocate(record)
346 17 : lenRecord = lb_def + LEN_RECORD
347 17 : allocate(character(lenRecord + nlen, SK) :: record)
348 : end if
349 : else
350 128 : lenRecord = lb_def + LEN_RECORD
351 128 : allocate(character(lenRecord + nlen, SK) :: record)
352 : end if
353 :
354 90 : do
355 19312 : read(unit, "(a)", advance = "no", size = size, iostat = iostat, iomsg = iomsg) record(lb_def + 1_IK : lenRecord)
356 19312 : if (iostat == iostat_eor) then ! Record reading is complete.
357 : #if URII_ENABLED
358 19205 : iostat = 0_IK
359 : #endif
360 19205 : lb_def = lb_def + size + nlen
361 19205 : if (present(ub)) then
362 19041 : ub = lb_def
363 : else
364 164 : call setResized(record, lb_def)
365 : end if
366 19205 : if (nlen > 0_IK) record(lb_def - nlen + 1_IK : lb_def) = LF
367 19205 : return
368 107 : elseif (iostat == 0_IK) then ! There is still record to read.
369 90 : lb_def = lb_def + size
370 270 : CHECK_ASSERTION(__LINE__, lb_def == lenRecord, SK_"@setRecordFrom(): Internal library error detected. The condition `lb_def == lenRecord` must hold. lb_def, lenRecord = "//getStr([lb_def, lenRecord]))
371 90 : lenRecord = lenRecord + lenRecord
372 90 : call setResized(record, lenRecord + nlen)
373 : cycle
374 : else
375 : #if UR_ENABLED
376 0 : error stop MODULE_NAME//SK_"@setRecordFrom(): "//trim(iomsg)
377 : #endif
378 : return
379 : end if
380 : end do
381 :
382 : !%%%%%%%%%%%%%%%%%%%%
383 : #elif setFileClosed_ENABLED
384 : !%%%%%%%%%%%%%%%%%%%%
385 :
386 : character(LEN_IOMSG) :: iomsg_def
387 : integer(IK) :: iostat_def, i
388 7 : if (present(del)) then
389 2 : if (del) then ! Attempt to delete the file repeatedly. This is important on windows systems as the file often remains locked.
390 2 : do i = 1_IK, 100_IK
391 2 : close(unit, status = "delete", iostat = iostat_def, iomsg = iomsg_def)
392 2 : if (iostat_def == 0_IK) then
393 2 : if (present(iostat)) iostat = iostat_def
394 2 : return
395 : end if
396 : end do
397 : ! All attempts at closing and deleting the file failed.
398 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
399 : if (iostat_def /= 0_IK) return ! LCOV_EXCL_LINE
400 : end if
401 : end if
402 5 : close(unit, iostat = iostat_def, iomsg = iomsg_def)
403 : SET_STAT_IO(iostat_def, iomsg_def, iostat, iomsg) ! LCOV_EXCL_LINE
404 :
405 : !%%%%%%%%%%%%%%%%%%%%%%
406 : #elif getErrTableRead_ENABLED
407 : !%%%%%%%%%%%%%%%%%%%%%%
408 :
409 : #if File_ENABLED
410 : integer(IK) :: unit
411 : #endif
412 : character(LEN_IOMSG, SK) :: iomsg_def
413 : character(*, SK), parameter :: HT = achar(9, SK)
414 : character(*, SK), parameter :: LF = achar(10, SK)
415 : character(*, SK), parameter :: CR = achar(13, SK)
416 : integer(IK), parameter :: RINIT = 127_IK
417 : integer(IK) :: irow, nrow
418 : #if !(D1_ENABLED && NO_ENABLED)
419 : integer(IK), allocatable :: sepLoc(:)
420 21 : character(:, SK), allocatable :: record
421 : integer(IK) :: icol, ncol, lenrec, lenLoc, sepLen, nsep
422 : #endif
423 : #if CK_ENABLED && !(D1_ENABLED && NO_ENABLED)
424 : real(CKC), allocatable :: field(:)
425 : #endif
426 : ! Define the transposition rules.
427 : #if D2_ENABLED && NO_ENABLED
428 : #define GET_INDEX(I,J) I,J
429 : #elif D2_ENABLED && TO_ENABLED
430 : #define GET_INDEX(I,J) J,I
431 : #elif !D1_ENABLED
432 : #error "Unrecognized interface."
433 : #endif
434 : ! Open file.
435 : #if File_ENABLED
436 : #define CLOSE_UNIT close(unit, iostat = err)
437 : open( file = file & ! LCOV_EXCL_LINE
438 : , newunit = unit & ! LCOV_EXCL_LINE
439 : , form = "formatted" & ! LCOV_EXCL_LINE
440 : , position = "rewind" & ! LCOV_EXCL_LINE
441 : , access = "sequential" & ! LCOV_EXCL_LINE
442 : , action = "read" & ! LCOV_EXCL_LINE
443 : , iostat = err & ! LCOV_EXCL_LINE
444 : , iomsg = iomsg_def & ! LCOV_EXCL_LINE
445 21 : INTEL_SHARED_FILE)
446 21 : RETURN_IF_FAILED(__LINE__)
447 : #elif Unit_ENABLED
448 : #define CLOSE_UNIT
449 : #else
450 : #error "Unrecognized interface."
451 : #endif
452 21 : if (present(roff)) then
453 28 : do irow = 1, roff
454 18 : read(unit, *, iostat = err, iomsg = iomsg_def)
455 28 : RETURN_IF_FAILED(__LINE__)
456 : end do
457 : end if
458 21 : if (present(header)) then
459 10 : call setRecordFrom(unit, header, err, iomsg_def)
460 10 : RETURN_IF_FAILED(__LINE__)
461 : end if
462 : #if D1_ENABLED && NO_ENABLED
463 0 : nrow = RINIT
464 0 : call setResized(table, nrow)
465 : irow = 0_IK
466 : do
467 0 : irow = irow + 1_IK
468 0 : if (nrow < irow) then
469 0 : nrow = nrow * 2_IK
470 0 : call setResized(table, nrow)
471 : end if
472 0 : read(unit, *, iostat = err, iomsg = iomsg_def) table(irow)
473 0 : if (err /= 0_IK) then
474 0 : if (err == iostat_end) then ! done.
475 0 : if (irow < nrow) call setResized(table, irow - 1_IK)
476 : err = 0_IK
477 0 : return
478 0 : elseif (present(iomsg)) then
479 0 : iomsg = getStr(__LINE__)//SK_": "//iomsg_def
480 : end if
481 0 : CLOSE_UNIT
482 0 : return
483 : end if
484 : end do
485 : #elif D1_ENABLED && TO_ENABLED
486 0 : ncol = 0_IK ! We have to determine the number of columns.
487 : nrow = 1_IK ! We have only one row to read.
488 : ! Compute the number of table fields.
489 0 : blockPresentSep: if (present(sep)) then
490 0 : sepLen = len(sep, IK)
491 0 : if (sepLen < 1_IK) then
492 0 : ncol = 1_IK
493 : ! This is only either one field or one column.
494 0 : exit blockPresentSep
495 : end if
496 0 : if (sep == SK_"," .or. sep == SK_" ") exit blockPresentSep ! .and. sep /= HT ! file can be handled by the Fortran list-directed IO.
497 : ! \todo The following approach to sep counting must be replaced with a new function like `getFieldSep()` that excludes separators in fields.
498 0 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
499 0 : RETURN_IF_FAILED(__LINE__)
500 0 : backspace(unit)
501 0 : nsep = getCountLoc(record, sep)
502 0 : if (nsep == 0_IK) exit blockPresentSep ! can be handled by list-directed IO.
503 0 : ncol = nsep + 1_IK
504 : #if CK_ENABLED
505 0 : ncol = ncol / 2_IK
506 0 : if (ncol * 2_IK /= nsep + 1_IK) then
507 : ! the values are not pairs of real and imaginary components.
508 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The number of columns of a complex table must be even."
509 : err = -1_IK
510 0 : CLOSE_UNIT
511 0 : return
512 : end if
513 0 : call setResized(field, nsep + 1_IK)
514 : #endif
515 0 : call setResized(sepLoc, nsep) ! Pre-allocate the locations of the separators in the record.
516 0 : call setResized(table, ncol) ! Initial best guess table size.
517 0 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
518 0 : if (err /= 0_IK) then
519 0 : if (err == iostat_end) then ! done.
520 0 : err = 0_IK
521 0 : elseif (present(iomsg)) then
522 0 : iomsg = getStr(__LINE__)//SK_": "//iomsg_def
523 : end if
524 0 : CLOSE_UNIT
525 0 : return
526 : end if
527 0 : call setLoc(sepLoc, lenLoc, record, sep, blindness = sepLen)
528 0 : if (lenLoc /= nsep) then
529 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The row "//getStr(irow)// & ! LCOV_EXCL_LINE
530 0 : SK_" of the table does not contain the same number of fields as the previous rows."
531 : err = -1_IK ! The row `irow` of the table rows does not contain `ncol` fields.
532 0 : CLOSE_UNIT
533 0 : return
534 : end if
535 : ! read fields.
536 : #if CK_ENABLED
537 0 : read(record(1 : sepLoc(1) - 1), *, iostat = err, iomsg = iomsg_def) field(1)
538 0 : RETURN_IF_FAILED(__LINE__)
539 0 : do icol = 2, nsep
540 0 : read(record(sepLoc(icol - 1) + sepLen : sepLoc(icol) - 1), *, iostat = err, iomsg = iomsg_def) field(icol)
541 0 : RETURN_IF_FAILED(__LINE__)
542 : end do
543 0 : read(record(sepLoc(icol - 1) + sepLen : lenrec), *, iostat = err, iomsg = iomsg_def) field(icol)
544 0 : RETURN_IF_FAILED(__LINE__)
545 0 : table(1 : ncol) = cmplx(field(1 : nsep : 2), field(2 : nsep + 1 : 2), CKC)
546 : #else
547 0 : read(record(1 : sepLoc(1) - 1), *, iostat = err, iomsg = iomsg_def) table(1)
548 0 : RETURN_IF_FAILED(__LINE__)
549 0 : do icol = 2, nsep
550 0 : read(record(sepLoc(icol - 1) + sepLen : sepLoc(icol) - 1), *, iostat = err, iomsg = iomsg_def) table(icol)
551 0 : RETURN_IF_FAILED(__LINE__)
552 : end do
553 0 : read(record(sepLoc(icol - 1) + sepLen : lenrec), *, iostat = err, iomsg = iomsg_def) table(icol)
554 0 : RETURN_IF_FAILED(__LINE__)
555 : #endif
556 : return
557 : end if blockPresentSep
558 0 : if (ncol == 0_IK) then
559 : ! separator can be likely handled by list-directed IO.
560 : #if SK_ENABLED || CK_ENABLED
561 : ! Get the separator while respecting quotations.
562 0 : record = getFieldSep(unit, SK_", ", fld, ncol, iomsg = iomsg)
563 : #elif IK_ENABLED || LK_ENABLED || RK_ENABLED
564 : ! Get the separator.
565 0 : record = getFieldSep(unit, SK_", ", ncol, iomsg = iomsg)
566 : #else
567 : #error "Unrecognized interface."
568 : #endif
569 : end if
570 0 : if (0_IK < ncol) then
571 : nrow = RINIT
572 : #if CK_ENABLED
573 : ! Ensure complex values are parenthesis-delimited.
574 0 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
575 0 : if (err /= 0_IK) then
576 0 : if (err == iostat_end) then ! done.
577 0 : call setResized(table, 0_IK)
578 0 : err = 0_IK
579 0 : elseif (present(iomsg)) then
580 0 : iomsg = getStr(__LINE__)//SK_": "//iomsg_def
581 : end if
582 0 : CLOSE_UNIT
583 0 : return
584 : end if
585 0 : backspace(unit)
586 0 : irow = getCountLoc(record, SK_"(")
587 0 : icol = getCountLoc(record, SK_")")
588 0 : if (0_IK == irow .and. 0_IK == icol) then
589 : ! read the complex table as a simple table of `real` fields.
590 : !block
591 : ! real(RKC), allocatable :: rtable(:,:)
592 : ! err = getErrTableRead(rtable, unit, trans)
593 : ! return_if_failed
594 : ! if (present(trans)) then
595 : ! if (trans) then
596 : ! do irow = 1, size(rtable,
597 : ! end do
598 : ! end if
599 : ! end if
600 : !end block
601 : ! This is not fld format, perhaps csv or similar. Read the table as real in fld format.
602 0 : nsep = ncol * 2_IK ! place holder for the number of fields.
603 0 : call setResized(field, nsep)
604 0 : call setResized(table, ncol) ! Initial best guess table size.
605 0 : irow = 1_IK
606 0 : read(unit, *, iostat = err, iomsg = iomsg_def) field
607 0 : if (err == iostat_end) then
608 0 : err = 0_IK
609 0 : CLOSE_UNIT
610 0 : return
611 : end if
612 0 : RETURN_IF_FAILED(__LINE__)
613 0 : table(1 : ncol) = cmplx(field(1 : nsep : 2), field(2 : nsep : 2), CKC)
614 : return
615 0 : elseif (irow /= icol) then
616 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The number of left and right parenthesis delimiters for `complex` table fields must match. '(', ')' = "//getStr([irow, icol])
617 : err = -1_IK
618 0 : CLOSE_UNIT
619 0 : return
620 : end if
621 : ! The complex table is delimited by `()`. Continue below to read the complex table via Fortran list-directed IO.
622 : #endif
623 : ! Read the complex table via Fortran list-directed IO.
624 0 : call setResized(table, ncol) ! Initial best guess table size.
625 0 : irow = 1_IK
626 0 : read(unit, *, iostat = err, iomsg = iomsg_def) table(1 : ncol)
627 0 : if (err == iostat_end) then
628 0 : if (irow < nrow) call setResized(table, ncol)
629 0 : err = 0_IK
630 0 : CLOSE_UNIT
631 0 : return
632 : end if
633 0 : RETURN_IF_FAILED(__LINE__)
634 : end if
635 : err = -1_IK
636 0 : CLOSE_UNIT
637 : #elif D2_ENABLED
638 21 : ncol = 0_IK ! Assume there is no column in table for now. This is an important assumption.
639 : ! Compute the number of table fields.
640 21 : blockPresentSep: if (present(sep)) then
641 15 : sepLen = len(sep, IK)
642 15 : if (sepLen < 1_IK) then
643 0 : ncol = 1_IK
644 : ! This is only either one field or one column.
645 0 : exit blockPresentSep
646 : end if
647 15 : if (sep == SK_"," .or. sep == SK_" ") exit blockPresentSep ! .and. sep /= HT ! file can be handled by the Fortran list-directed IO.
648 : ! \todo The following approach to sep counting must be replaced with a new function like `getFieldSep()` that excludes separators in fields.
649 10 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
650 10 : RETURN_IF_FAILED(__LINE__)
651 10 : backspace(unit)
652 10 : nsep = getCountLoc(record, sep)
653 10 : if (nsep == 0_IK) exit blockPresentSep
654 10 : ncol = nsep + 1_IK
655 : nrow = RINIT
656 : #if CK_ENABLED
657 2 : ncol = ncol / 2_IK
658 2 : if (ncol * 2_IK /= nsep + 1_IK) then
659 : ! the values are not pairs of real and imaginary components.
660 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The number of columns of a complex table must be even."
661 : err = -1_IK
662 0 : CLOSE_UNIT
663 0 : return
664 : end if
665 2 : call setResized(field, nsep + 1_IK)
666 : #endif
667 10 : call setResized(sepLoc, nsep) ! Pre-allocate the locations of the separators in the record.
668 30 : call setResized(table, [GET_INDEX(nrow, ncol)]) ! Initial best guess table size.
669 10 : irow = 0_IK
670 18514 : loopReadTableRecord: do
671 18524 : irow = irow + 1_IK
672 18524 : if (nrow < irow) then
673 14 : nrow = nrow * 2_IK
674 42 : call setResized(table, [GET_INDEX(nrow, ncol)])
675 : end if
676 18524 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
677 18524 : if (err /= 0_IK) then
678 10 : if (err == iostat_end) then ! done.
679 30 : if (irow < nrow) call setResized(table, [GET_INDEX(irow - 1_IK, ncol)])
680 0 : err = 0_IK
681 0 : elseif (present(iomsg)) then
682 0 : iomsg = getStr(__LINE__)//SK_": "//iomsg_def
683 : end if
684 10 : CLOSE_UNIT
685 10 : return
686 : end if
687 18514 : call setLoc(sepLoc, lenLoc, record, sep, blindness = sepLen)
688 18514 : if (lenLoc /= nsep) then
689 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The row "//getStr(irow)// & ! LCOV_EXCL_LINE
690 0 : SK_" of the table does not contain the same number of fields as the previous rows."
691 : err = -1_IK ! The row `irow` of the table rows does not contain `ncol` fields.
692 0 : CLOSE_UNIT
693 0 : return
694 : end if
695 : ! read fields.
696 : #if CK_ENABLED
697 8 : read(record(1 : sepLoc(1) - 1), *, iostat = err, iomsg = iomsg_def) field(1)
698 8 : RETURN_IF_FAILED(__LINE__)
699 24 : do icol = 2, nsep
700 16 : read(record(sepLoc(icol - 1) + sepLen : sepLoc(icol) - 1), *, iostat = err, iomsg = iomsg_def) field(icol)
701 24 : RETURN_IF_FAILED(__LINE__)
702 : end do
703 8 : read(record(sepLoc(icol - 1) + sepLen : lenrec), *, iostat = err, iomsg = iomsg_def) field(icol)
704 8 : RETURN_IF_FAILED(__LINE__)
705 24 : table(GET_INDEX(irow, 1 : ncol)) = cmplx(field(1 : nsep : 2), field(2 : nsep + 1 : 2), CKC)
706 : #else
707 18506 : read(record(1 : sepLoc(1) - 1), *, iostat = err, iomsg = iomsg_def) table(GET_INDEX(irow, 1))
708 18506 : RETURN_IF_FAILED(__LINE__)
709 18530 : do icol = 2, nsep
710 24 : read(record(sepLoc(icol - 1) + sepLen : sepLoc(icol) - 1), *, iostat = err, iomsg = iomsg_def) table(GET_INDEX(irow, icol))
711 18530 : RETURN_IF_FAILED(__LINE__)
712 : end do
713 18506 : read(record(sepLoc(icol - 1) + sepLen : lenrec), *, iostat = err, iomsg = iomsg_def) table(GET_INDEX(irow, icol))
714 18506 : RETURN_IF_FAILED(__LINE__)
715 : #endif
716 : end do loopReadTableRecord
717 : ! the flow should never get here.
718 : #if CHECK_ENABLED
719 : ! This internal testing can be removed in future.
720 : error stop MODULE_NAME//SK_"@getErrTableRead(): This is an internal library error."//NLC// & ! LCOV_EXCL_LINE
721 : SK_"The control flow should never reach this point."//NLC// & ! LCOV_EXCL_LINE
722 : SK_"Please report this error among with circumstance to the ParaMonte library developers at:"//NLC// & ! LCOV_EXCL_LINE
723 : SK_"https://github.com/cdslaborg/paramonte/issues."//NLC ! LCOV_EXCL_LINE
724 : #endif
725 : end if blockPresentSep
726 11 : if (ncol == 0_IK) then
727 : ! separator can be likely handled by list-directed IO.
728 : #if SK_ENABLED || CK_ENABLED
729 : ! Get the separator while respecting quotations.
730 9 : record = getFieldSep(unit, SK_", ", fld, ncol, iomsg = iomsg)
731 : #elif IK_ENABLED || LK_ENABLED || RK_ENABLED
732 : ! Get the separator.
733 22 : record = getFieldSep(unit, SK_", ", ncol, iomsg = iomsg)
734 : #else
735 : #error "Unrecognized interface."
736 : #endif
737 : end if
738 11 : if (0_IK < ncol) then
739 : nrow = RINIT
740 : #if CK_ENABLED
741 : ! Ensure complex values are parenthesis-delimited.
742 2 : call setRecordFrom(unit, record, err, iomsg_def, 1_IK, lenrec)
743 2 : if (err /= 0_IK) then
744 0 : if (err == iostat_end) then ! done.
745 0 : call setResized(table, [0_IK, 0_IK])
746 0 : err = 0_IK
747 0 : elseif (present(iomsg)) then
748 0 : iomsg = getStr(__LINE__)//SK_": "//iomsg_def
749 : end if
750 0 : CLOSE_UNIT
751 0 : return
752 : end if
753 2 : backspace(unit)
754 2 : irow = getCountLoc(record, SK_"(")
755 2 : icol = getCountLoc(record, SK_")")
756 2 : if (0_IK == irow .and. 0_IK == icol) then
757 : ! read the complex table as a simple table of `real` fields.
758 : !block
759 : ! real(RKC), allocatable :: rtable(:,:)
760 : ! err = getErrTableRead(rtable, unit, trans)
761 : ! return_if_failed
762 : ! if (present(trans)) then
763 : ! if (trans) then
764 : ! do irow = 1, size(rtable,
765 : ! end do
766 : ! end if
767 : ! end if
768 : !end block
769 : ! This is not fld format, perhaps csv or similar. Read the table as real in fld format.
770 2 : nsep = ncol * 2_IK ! place holder for the number of fields.
771 2 : call setResized(field, nsep)
772 6 : call setResized(table, [GET_INDEX(nrow, ncol)]) ! Initial best guess table size.
773 2 : irow = 0_IK
774 : do
775 6 : irow = irow + 1
776 6 : read(unit, *, iostat = err, iomsg = iomsg_def) field
777 6 : if (err == iostat_end) then
778 6 : if (irow < nrow) call setResized(table, [GET_INDEX(irow - 1_IK, ncol)])
779 2 : err = 0_IK
780 2 : CLOSE_UNIT
781 2 : return
782 : end if
783 4 : RETURN_IF_FAILED(__LINE__)
784 20 : table(GET_INDEX(irow, 1 : ncol)) = cmplx(field(1 : nsep : 2), field(2 : nsep : 2), CKC)
785 4 : if (irow < nrow) cycle
786 0 : nrow = nrow * 2_IK
787 4 : call setResized(table, [GET_INDEX(nrow, ncol)])
788 : end do
789 0 : elseif (irow /= icol) then
790 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getErrTableRead(): The number of left and right parenthesis delimiters for `complex` table fields must match. '(', ')' = "//getStr([irow, icol])
791 : err = -1_IK
792 0 : CLOSE_UNIT
793 0 : return
794 : end if
795 : ! The complex table is delimited by `()`. Continue below to read the complex table via Fortran list-directed IO.
796 : #endif
797 : ! Read the complex table via Fortran list-directed IO.
798 27 : call setResized(table, [GET_INDEX(nrow, ncol)]) ! Initial best guess table size.
799 9 : irow = 0_IK
800 : do
801 3094 : irow = irow + 1
802 3094 : read(unit, *, iostat = err, iomsg = iomsg_def) table(GET_INDEX(irow, 1 : ncol))
803 3094 : if (err == iostat_end) then
804 27 : if (irow < nrow) call setResized(table, [GET_INDEX(irow - 1_IK, ncol)])
805 9 : err = 0_IK
806 9 : CLOSE_UNIT
807 9 : return
808 : end if
809 3085 : RETURN_IF_FAILED(__LINE__)
810 3085 : if (irow < nrow) cycle
811 8 : nrow = nrow * 2_IK
812 3101 : call setResized(table, [GET_INDEX(nrow, ncol)])
813 : end do
814 : end if
815 : err = -1_IK
816 0 : CLOSE_UNIT
817 : #endif
818 : #undef CLOSE_UNIT
819 : #undef GET_INDEX
820 : #undef GET_FIELD
821 :
822 : !%%%%%%%%%%%%%%%%%%%%%%%
823 : #elif getErrTableWrite_ENABLED
824 : !%%%%%%%%%%%%%%%%%%%%%%%
825 :
826 : #if File_ENABLED
827 : integer(IK) :: unit
828 : #endif
829 : !character(*, SK), parameter :: gform = SK_"(*(g0,:,','))"
830 : character(:, SK), allocatable :: format
831 : character(LEN_IOMSG, SK) :: iomsg_def
832 : #if D2_ENABLED
833 : integer(IK) :: nrow, ncol
834 : #endif
835 : integer(IK) :: irow
836 : #if File_ENABLED
837 2442 : if (present(file)) then
838 : open( file = file & ! LCOV_EXCL_LINE
839 : , newunit = unit & ! LCOV_EXCL_LINE
840 : , form = "formatted" & ! LCOV_EXCL_LINE
841 : , position = "rewind" & ! LCOV_EXCL_LINE
842 : , access = "sequential" & ! LCOV_EXCL_LINE
843 : , action = "write" & ! LCOV_EXCL_LINE
844 : , iostat = err & ! LCOV_EXCL_LINE
845 : , iomsg = iomsg_def & ! LCOV_EXCL_LINE
846 2442 : INTEL_SHARED_FILE)
847 2442 : RETURN_IF_FAILED(__LINE__)
848 : end if
849 : #elif Unit_ENABLED
850 : #else
851 : #error "Unrecognized interface."
852 : #endif
853 : ! Set the number of columns in format and the quotation formatting. Add `sp,` before NCOL in format to write all numbers in signed format.
854 : #if NO_ENABLED && D1_ENABLED
855 : #if CK_ENABLED
856 : #define GET_FORMAT(DELIML,DELIMR,SEP) \
857 : SK_'('//getStrQuoted(DELIML)//SK_',g0,'//SEP//SK_',g0,'//getStrQuoted(DELIMR)//SK_')';
858 : #elif SK_ENABLED || IK_ENABLED || LK_ENABLED || RK_ENABLED
859 : #define GET_FORMAT(DELIML,DELIMR,SEP) \
860 : SK_'('//getStrQuoted(DELIML)//SK_',g0,'//getStrQuoted(DELIMR)//SK_')';
861 : #else
862 : #error "Unrecognized interface."
863 : #endif
864 : #else
865 : #if CK_ENABLED
866 : #define GET_FORMAT(DELIML,DELIMR,SEP) \
867 : SK_'(*('//getStrQuoted(DELIML)//SK_',g0,'//SEP//SK_',g0,'//getStrQuoted(DELIMR)//SK_',:,'//SEP//SK_'))';
868 : #elif SK_ENABLED || IK_ENABLED || LK_ENABLED || RK_ENABLED
869 : #define GET_FORMAT(DELIML,DELIMR,SEP) \
870 : SK_'(*('//getStrQuoted(DELIML)//SK_',g0,'//getStrQuoted(DELIMR)//SK_',:,'//SEP//SK_'))';
871 : #else
872 : #error "Unrecognized interface."
873 : #endif
874 : #endif
875 2442 : if (present(sep)) then
876 18 : if (present(deliml) .and. present(delimr)) then
877 0 : format = GET_FORMAT(deliml,delimr,getStrQuoted(sep))
878 18 : elseif (present(deliml)) then
879 0 : format = GET_FORMAT(deliml,deliml,getStrQuoted(sep))
880 18 : elseif (present(delimr)) then
881 0 : format = GET_FORMAT(delimr,delimr,getStrQuoted(sep))
882 : else
883 18 : format = GET_FORMAT(SK_"",SK_"",getStrQuoted(sep))
884 : end if
885 2424 : elseif (present(deliml) .and. present(delimr)) then
886 0 : format = GET_FORMAT(deliml,delimr,SK_"','")
887 2424 : elseif (present(deliml)) then
888 4 : format = GET_FORMAT(deliml,deliml,SK_"','")
889 2420 : elseif (present(delimr)) then
890 0 : format = GET_FORMAT(delimr,delimr,SK_"','")
891 : else
892 2420 : format = GET_FORMAT(SK_"",SK_"",SK_"','")
893 : end if
894 : ! Skip lines.
895 2442 : if (present(roff)) then
896 24 : do irow = 1, roff
897 16 : write(unit, "(g0)", iostat = err, iomsg = iomsg_def)
898 24 : RETURN_IF_FAILED(__LINE__)
899 : end do
900 : end if
901 : ! Define the transposition rules.
902 : #if NO_ENABLED && D2_ENABLED
903 2397 : nrow = size(table, 1, IK)
904 2397 : ncol = size(table, rank(table), IK)
905 : #define TABLE_ROW(I,J) table(I,J)
906 : #elif TO_ENABLED && D2_ENABLED
907 42 : ncol = size(table, 1, IK)
908 42 : nrow = size(table, rank(table), IK)
909 : #define TABLE_ROW(I,J) table(J,I)
910 : #elif !D1_ENABLED
911 : #error "Unrecognized interface."
912 : #endif
913 : ! Write header.
914 2442 : if (present(header)) write(unit, "(g0)", iostat = err, iomsg = iomsg_def) header
915 2442 : RETURN_IF_FAILED(__LINE__)
916 : ! Write table.
917 : #if D1_ENABLED
918 3 : write(unit, format, iostat = err, iomsg = iomsg_def) table
919 3 : RETURN_IF_FAILED(__LINE__)
920 : #elif D2_ENABLED
921 2391807 : do irow = 1, nrow
922 2389368 : write(unit, format, iostat = err, iomsg = iomsg_def) TABLE_ROW(irow, 1 : ncol)
923 2391807 : RETURN_IF_FAILED(__LINE__)
924 : end do
925 : #else
926 : #error "Unrecognized interface."
927 : #endif
928 : #if File_ENABLED
929 2442 : close(unit, iostat = err)
930 : #endif
931 : #undef GET_FORMAT
932 : #undef TABLE_ROW
933 :
934 : !%%%%%%%%%%%%%%%%%%
935 : #elif getFieldSep_ENABLED
936 : !%%%%%%%%%%%%%%%%%%
937 :
938 : character(LEN_IOMSG, SK) :: iomsg_def
939 57 : character(:, SK), allocatable :: record
940 : integer(IK), parameter :: nsam = 2_IK ! maximum number of line samples.
941 : #if FFLD_ENABLED
942 : logical(LK) :: isDiscrete
943 : #endif
944 : #if File_ENABLED
945 : integer(IK) :: unit
946 : #elif !Unit_ENABLED
947 : #error "Unrecognized interface."
948 : #endif
949 : ! Define vector `seps` properties.
950 : #if ID0_ENABLED
951 : #define GET_SIZE(X) len(X, IK)
952 : #define GET_SEPS(I) seps(I:I)
953 : #define OFFSET(I) 0_IK
954 : #elif CD1_ENABLED
955 46 : integer(IK) :: offset(size(seps, 1, IK))
956 : #define GET_SIZE(X) size(X, 1, IK)
957 : #define GET_SEPS(I) seps(I)%val
958 : #define OFFSET(I) offset(I)
959 : #else
960 : #error "Unrecognized interface."
961 : #endif
962 114 : integer(IK) :: isam, isep, ub, iostat, nseps, freq(GET_SIZE(seps)), freqold(GET_SIZE(seps))
963 57 : logical(LK) :: canBeSep(GET_SIZE(seps))
964 : #if ID0_ENABLED
965 : nseps = GET_SIZE(seps)
966 34 : if (0_IK == nseps) then
967 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getFieldSep(): The condition `0 < len(seps)` must hold."
968 0 : sep = SKC_""
969 31 : return
970 : end if
971 : #elif CD1_ENABLED
972 : nseps = GET_SIZE(seps)
973 23 : if (0_IK < nseps) then
974 58 : do isep = 1, nseps
975 35 : offset(isep) = len(seps(isep)%val, IK) - 1_IK
976 58 : if (offset(isep) < 0_IK) then
977 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getFieldSep(): The component seps("//getStr(isep)//SK_")%val must have a non-zero length."
978 0 : sep = SKC_""
979 20 : return
980 : end if
981 : end do
982 : else
983 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getFieldSep(): The condition `0 < size(seps)` must hold."
984 0 : sep = SKC_""
985 0 : return
986 : end if
987 : #endif
988 : #if NF_ENABLED
989 11 : nfield = 0_IK
990 : #endif
991 : ! Open file.
992 : #if File_ENABLED
993 : #define FAILED_RETURN(LINE) \
994 : close(unit, iostat = iostat); if (present(iomsg)) iomsg = getStr(LINE)//SK_": "//iomsg_def; sep = SKC_""; return
995 : open( file = file & ! LCOV_EXCL_LINE
996 : , newunit = unit & ! LCOV_EXCL_LINE
997 : , form = "formatted" & ! LCOV_EXCL_LINE
998 : , position = "rewind" & ! LCOV_EXCL_LINE
999 : , access = "sequential" & ! LCOV_EXCL_LINE
1000 : , action = "read" & ! LCOV_EXCL_LINE
1001 : , status = "old" & ! LCOV_EXCL_LINE
1002 : , iostat = iostat & ! LCOV_EXCL_LINE
1003 : , iomsg = iomsg_def & ! LCOV_EXCL_LINE
1004 46 : INTEL_SHARED_FILE)
1005 46 : if (iostat /= 0_IK) then
1006 0 : if (present(iomsg)) iomsg = iomsg_def
1007 0 : sep = SKC_""
1008 0 : return
1009 : end if
1010 : #elif Unit_ENABLED
1011 : #define FAILED_RETURN(LINE) \
1012 : do isep = 1, isam - 1; backspace(unit); end do; if (present(iomsg)) iomsg = getStr(LINE)//SK_": "//iomsg_def; sep = SKC_""; return ! LCOV_EXCL_LINE
1013 : #endif
1014 : #if FDEF_ENABLED
1015 84 : loopLineSample: do isam = 1, nsam
1016 160 : freq = 0_IK
1017 56 : call setRecordFrom(unit, record, iostat, iomsg = iomsg_def, ub = ub)!, linefed = .true._LK)
1018 : !write(*,"(A)") trim(record)
1019 56 : if (iostat == 0_IK) then
1020 160 : do isep = 1, nseps
1021 160 : freq(isep) = getCountLoc(record(1 : ub), GET_SEPS(isep), blindness = 1_IK + OFFSET(isep))
1022 : end do
1023 : else ! incomplete multiline quote or other reading error.
1024 0 : FAILED_RETURN(__LINE__)
1025 : end if
1026 140 : if (1_IK < isam) then
1027 80 : do isep = 1, nseps
1028 88 : canBeSep(isep) = canBeSep(isep) .and. freq(isep) == freqold(isep)
1029 : end do
1030 80 : freqold = freq
1031 : else
1032 80 : freqold = freq
1033 80 : canBeSep = .true._LK
1034 : end if
1035 : end do loopLineSample
1036 : #elif FCSV_ENABLED || FFLD_ENABLED
1037 : block
1038 : character(1,SKC) :: qbeg
1039 : logical(LK) :: quoted
1040 : integer(IK) :: lb, i
1041 87 : loopLineSample: do isam = 1, nsam
1042 150 : freq = 0_IK
1043 : qbeg = SKC_" "
1044 : quoted = .false.
1045 76 : loopReadMultiLineRecord: do
1046 76 : lb = 1_IK
1047 76 : call setRecordFrom(unit, record, iostat, iomsg_def, lb, ub)!, linefed = .true._LK)
1048 76 : if (iostat == 0_IK) then
1049 64 : loopSkipQuote: do
1050 196 : if (quoted) then
1051 : ! Skip the quoted field.
1052 416 : loopQuoteClose: do i = lb, ub
1053 416 : if (record(i:i) == qbeg) exit loopQuoteClose
1054 : end do loopQuoteClose
1055 138 : quoted = ub < i
1056 : ! What a nasty quoted field with new line character.
1057 138 : if (quoted) cycle loopReadMultiLineRecord ! cycle to read the rest of the field in the next line.
1058 120 : i = i + 1_IK
1059 : else
1060 58 : i = lb
1061 : end if
1062 : #if FFLD_ENABLED
1063 : isDiscrete = .true._LK
1064 : #endif
1065 784 : loopQuoteOpen: do i = i, ub
1066 : #if FFLD_ENABLED
1067 : ! Take care of complex pair first.
1068 494 : quoted = record(i:i) == SKC_'('
1069 494 : if (quoted) then
1070 24 : lb = i + 1_IK
1071 : qbeg = SKC_")"
1072 24 : cycle loopSkipQuote
1073 : end if
1074 : #elif !FCSV_ENABLED
1075 : #error "Unrecognized interface."
1076 : #endif
1077 702 : quoted = record(i:i) == SKC_"""" .or. record(i:i) == SKC_''''
1078 58 : if (quoted) then
1079 96 : lb = i + 1_IK
1080 64 : qbeg = record(i:i)
1081 32 : cycle loopSkipQuote
1082 : else ! find the separator instances
1083 1582 : loopOverSeps: do isep = 1, nseps
1084 976 : if (ub < i + OFFSET(isep)) cycle loopOverSeps
1085 : #if FCSV_ENABLED
1086 448 : if (record(i : i + OFFSET(isep)) == GET_SEPS(isep)) freq(isep) = freq(isep) + 1_IK
1087 : #elif FFLD_ENABLED
1088 1134 : if (record(i : i + OFFSET(isep)) == GET_SEPS(isep)) then
1089 142 : if (isDiscrete .or. GET_SEPS(isep) /= SKC_" ") then
1090 118 : freq(isep) = freq(isep) + 1_IK
1091 : isDiscrete = .false._LK
1092 : end if
1093 : else
1094 : isDiscrete = .true._LK
1095 : end if
1096 : #endif
1097 : end do loopOverSeps
1098 : end if
1099 : end do loopQuoteOpen
1100 : exit loopReadMultiLineRecord
1101 : end do loopSkipQuote
1102 : end if
1103 : ! incomplete multiline quote or other reading error.
1104 18 : FAILED_RETURN(__LINE__)
1105 : end do loopReadMultiLineRecord
1106 87 : if (1_IK < isam) then
1107 75 : do isep = 1, nseps
1108 75 : canBeSep(isep) = canBeSep(isep) .and. freq(isep) == freqold(isep)
1109 : end do
1110 75 : freqold = freq
1111 : else
1112 75 : freqold = freq
1113 75 : canBeSep = .true._LK
1114 : end if
1115 : end do loopLineSample
1116 : end block
1117 : #else
1118 : #error "Unrecognized interface."
1119 : #endif
1120 : #if File_ENABLED
1121 46 : close(unit, iostat = iostat)
1122 46 : if (iostat /= 0_IK) then
1123 0 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getFieldSep(): Failed to close the input file."
1124 0 : sep = SKC_""
1125 0 : return
1126 : end if
1127 : #elif Unit_ENABLED
1128 : ! Backspace the file.
1129 33 : do isam = 1, nsam
1130 33 : backspace(unit)
1131 : end do
1132 : #endif
1133 82 : do isep = 1, nseps
1134 82 : if (canBeSep(isep) .and. 0_IK < freq(isep)) then
1135 : #if NF_ENABLED
1136 31 : nfield = freq(isep) + 1_IK
1137 : #endif
1138 51 : sep = GET_SEPS(isep)
1139 51 : return
1140 : end if
1141 : end do
1142 6 : if (present(iomsg)) iomsg = MODULE_NAME//SK_"@getFieldSep(): There is likely only one field in the records of this file."
1143 6 : sep = SKC_""
1144 : #if NF_ENABLED
1145 0 : nfield = 1_IK
1146 : #elif !XX_ENABLED
1147 : #error "Unrecognized interface."
1148 : #endif
1149 : #undef OFFSET
1150 : #undef GET_SIZE
1151 : #undef GET_SEPS
1152 : #undef FAILED_RETURN
1153 :
1154 : !%%%%%%%%%%%%%%%%%%%%%
1155 : #elif getLenFieldMin_ENABLED
1156 : !%%%%%%%%%%%%%%%%%%%%%
1157 :
1158 : !use pm_mathNumSys, only: getCountDigit
1159 : #if IK_ENABLED
1160 : ! sign takes one character + `int(log10(huge))` returns
1161 : ! one digit less than the digit count of the huge of actual model.
1162 : lenField = range(mold) + 2_IK
1163 : #elif CK_ENABLED || RK_ENABLED
1164 : ! \bug Intel ifort 2022.
1165 : integer :: rangeLike
1166 : rangeLike = range(mold)
1167 : ! possible leading 0 by some processors, sign, decimal point, exponent symbol, exponent sign
1168 : lenField = precision(mold) + getCountDigit(rangeLike) + 5_IK
1169 : #else
1170 : #error "Unrecognized interface."
1171 : #endif
1172 :
1173 : !%%%%%%%%%%%%%%%%
1174 : #elif getFormat_ENABLED
1175 : !%%%%%%%%%%%%%%%%
1176 :
1177 : integer(IK) :: width_def, ndigit_def, subcount_def, lenexp_def, isub
1178 : character(:, SK), allocatable :: field, prefix_def, ed_def, sep_def, deliml_def, subsep_def, delimr_def, sign_str, width_str, count_str, ndigit_str, lenexp_str
1179 :
1180 95 : if (getOption(.false._LK, signed)) then
1181 47 : sign_str = SK_"sp,"
1182 : else
1183 48 : sign_str = SK_""
1184 : end if
1185 :
1186 95 : if (present(prefix)) then
1187 3 : if (len(prefix) > 0) then
1188 3 : prefix_def = getStrQuoted(prefix)//SK_"," !//SK_"X,"
1189 : else
1190 0 : prefix_def = SK_""
1191 : end if
1192 : else
1193 92 : prefix_def = SK_""
1194 : end if
1195 :
1196 95 : if (present(count)) then
1197 0 : count_str = getStr(count)
1198 0 : CHECK_ASSERTION(__LINE__, 0_IK < count, SK_": The condition `0 < count` must hold. count = "//getStr(count))
1199 : else
1200 95 : count_str = SK_"*"
1201 : end if
1202 :
1203 95 : if (present(subcount)) then
1204 19 : subcount_def = subcount
1205 19 : CHECK_ASSERTION(__LINE__, 0_IK <= subcount, SK_": The condition `0 <= subcount` must hold. subcount = "//getStr(subcount))
1206 : else
1207 : #if CK_ENABLED
1208 : subcount_def = 2_IK
1209 : #else
1210 : subcount_def = 1_IK
1211 : #endif
1212 : end if
1213 :
1214 95 : if (present(ed)) then
1215 34 : ed_def = getStrLower(ed)
1216 340 : CHECK_ASSERTION(__LINE__, all([ed_def .in. [character(2,SK) :: 'a', 'e', 'en', 'es', 'ex', 'f', 'g', 'i', 'l']]), SK_": The condition `ed .in. [character(2,SK) :: 'a', 'e', 'en', 'es', 'ex', 'f', 'g', 'i', 'l']` must hold. ed = "//ed)
1217 : else
1218 : #if IK_ENABLED
1219 1 : ed_def = SK_"i"
1220 : #else
1221 60 : ed_def = SK_"g"
1222 : #endif
1223 : end if
1224 :
1225 95 : if (present(sep)) then
1226 2 : sep_def = getStrQuoted(sep)
1227 : else
1228 93 : sep_def = SK_""", """
1229 : end if
1230 :
1231 95 : if (present(subsep)) then
1232 19 : subsep_def = getStrQuoted(subsep)
1233 76 : elseif (1_IK < subcount_def) then
1234 16 : subsep_def = sep_def
1235 : end if
1236 :
1237 95 : if (ed_def == SK_"e" .or. ed_def == SK_"en" .or. ed_def == SK_"es" .or. ed_def == SK_"ex" .or. ed_def == SK_"g") then
1238 77 : if (present(lenexp)) then
1239 : ! per the standard, the exponent field must not be set when g0 is specified or when the precision field is missing.
1240 0 : CHECK_ASSERTION(__LINE__, 0_IK <= lenexp, SK_": The condition `0 <= lenexp` must hold. lenexp = "//getStr(lenexp))
1241 : !check_assertion(__LINE__, 0_IK < getOption(1_IK, width), SK_": The condition `ed /= 'g' .or. width > 0` must hold.")
1242 : !check_assertion(__LINE__, present(ndigit), SK_": The condition `present(lenexp) .and. present(ndigit) .or. .not. present(lenexp)` must hold.")
1243 : !check_assertion(__LINE__, width_str /= SK_"0", SK_": The condition `present(lenexp) .and. width /= 0 .or. .not. present(lenexp)` must hold.")
1244 0 : lenexp_str = SK_"e"//getStr(lenexp)
1245 0 : lenexp_def = lenexp
1246 : else
1247 : #if CK_ENABLED || RK_ENABLED
1248 38 : lenexp_def = getCountDigit(range(real(0, kind(mold))))
1249 38 : lenexp_str = SK_"e"//getStr(lenexp_def)
1250 : #else
1251 39 : lenexp_str = SK_""
1252 : lenexp_def = 0_IK
1253 : #endif
1254 : end if
1255 : else
1256 2 : lenexp_str = SK_""
1257 16 : lenexp_def = 0_IK
1258 : end if
1259 :
1260 95 : if (present(ndigit)) then
1261 23 : CHECK_ASSERTION(__LINE__, 0_IK <= ndigit, SK_": The condition `0 <= ndigit` must hold. ndigit = "//getStr(ndigit))
1262 23 : ndigit_str = SK_"."//getStr(ndigit)
1263 23 : ndigit_def = ndigit
1264 : else
1265 : #if CK_ENABLED || RK_ENABLED
1266 48 : ndigit_def = precision(real(0, kind(mold)))
1267 48 : ndigit_str = SK_"."//getStr(ndigit_def)
1268 : #else
1269 24 : ndigit_def = 0_IK
1270 24 : ndigit_str = SK_""
1271 24 : if (lenexp_str /= SK_"") lenexp_str = SK_""
1272 : #endif
1273 : end if
1274 :
1275 95 : if (present(width)) then
1276 15 : width_def = width
1277 15 : width_str = getStr(width_def)
1278 : ! non-zero width requires non-zero number of digits.
1279 15 : if (7_IK < width_def .and. ndigit_str == SK_"") then
1280 0 : ndigit_def = width_def - 7_IK
1281 0 : ndigit_str = SK_"."//getStr(ndigit_def)
1282 : else
1283 45 : CHECK_ASSERTION(__LINE__, 0_IK == width .or. (0_IK < width .and. 0_IK < ndigit_def), SK_": The condition `0 == width .or. (0 < width .and. 0 < ndigit)` must hold. width, ndigit = "//getStr([width, ndigit_def]))
1284 : end if
1285 80 : elseif (ed_def == SK_"a" .or. ed_def == SK_"l") then
1286 0 : width_def = 0_IK
1287 0 : width_str = SK_""
1288 : #if !(CK_ENABLED || RK_ENABLED)
1289 26 : elseif (ed_def == SK_"g") then
1290 24 : width_def = 0_IK
1291 24 : width_str = SK_"0"
1292 : #endif
1293 56 : elseif (ed_def == SK_"i") then
1294 2 : width_def = ndigit_def + 1_IK ! one character for sign.
1295 2 : width_str = getStr(width_def)
1296 54 : elseif (ed_def == SK_"f") then
1297 : #if CK_ENABLED || RK_ENABLED
1298 : ! Make it a fixed size field so that it prints nicely on screen.
1299 : !width_def = precision(real(0, kind(mold))) + 3_IK ! three characters for sign, leading 0, and decimal point.
1300 16 : width_def = precision(real(0, kind(mold))) + ndigit_def + 3_IK ! three characters for sign, leading 0, and decimal point.
1301 16 : width_str = getStr(width_def)
1302 : #else
1303 0 : width_def = 0_IK ! We do not know the size a priori. Let the compiler set the minimum required size at runtime.
1304 0 : width_str = getStr(width_def)
1305 : #endif
1306 : ! it is a real or complex field with exponent.
1307 38 : elseif (lenexp_str == SK_"") then ! default field exponent consists of four characters.
1308 0 : width_def = ndigit_def + 7_IK ! three characters as in `f` descriptor + 4 for default exponent.
1309 0 : width_str = getStr(width_def)
1310 38 : elseif (lenexp_def == 0_IK) then ! minimum required field happens when `lenexp = 0` is explicitly specified by the user.
1311 : ! this is tough because we do not know the minimum required exponent length unless we know the type and kind of the field.
1312 : ! therefore, we either use the kind given to us:
1313 : #if CK_ENABLED || RK_ENABLED
1314 0 : width_def = getCountDigit(range(real(0, kind(mold))))
1315 0 : width_def = ndigit_def + 5_IK + width_def ! three characters as in `f` descriptor + 2 for exponent symbols + exponent digits.
1316 0 : width_str = getStr(width_def)
1317 : #else
1318 : ! or else, we assume the worst case scenario, the highest precision field of kind \RKB.
1319 0 : width_def = getCountDigit(range(0._RKB))
1320 0 : width_def = ndigit_def + 5_IK + width_def ! three characters as in `f` descriptor + 2 for exponent symbols + exponent digits.
1321 0 : width_str = getStr(width_def)
1322 : #endif
1323 : else ! finally, an explicit positive exponent length `lenexp` is known.
1324 38 : width_def = ndigit_def + 5_IK + lenexp_def ! three characters as in `f` descriptor + 2 for exponent symbols + exponent digits.
1325 38 : width_str = getStr(width_def)
1326 : end if
1327 95 : if (width_def == 0_IK .and. lenexp_str /= SK_"") lenexp_str = SK_""
1328 :
1329 95 : if (present(deliml) .and. present(delimr)) then
1330 18 : deliml_def = getStrQuoted(deliml)
1331 18 : delimr_def = getStrQuoted(delimr)
1332 77 : elseif (present(deliml)) then
1333 1 : deliml_def = getStrQuoted(deliml)
1334 1 : delimr_def = getStrQuoted(deliml)
1335 76 : elseif (present(delimr)) then
1336 0 : deliml_def = getStrQuoted(delimr)
1337 0 : delimr_def = getStrQuoted(delimr)
1338 : else
1339 : #if SK_ENABLED
1340 1 : deliml_def = getStrQuoted(SK_"""")
1341 1 : delimr_def = getStrQuoted(SK_"""")
1342 : #elif CK_ENABLED
1343 16 : deliml_def = getStrQuoted(SK_"(")
1344 16 : delimr_def = getStrQuoted(SK_")")
1345 : #elif IK_ENABLED || LK_ENABLED || RK_ENABLED || Def_ENABLED
1346 59 : deliml_def = SK_""
1347 59 : delimr_def = SK_""
1348 : #else
1349 : #error "Unrecognized interface."
1350 : #endif
1351 : end if
1352 95 : if (deliml_def /= SK_"") deliml_def = deliml_def//SK_","
1353 95 : if (delimr_def /= SK_"") delimr_def = SK_","//delimr_def
1354 :
1355 95 : field = ed_def//width_str//ndigit_str//lenexp_str
1356 95 : if (1_IK < subcount_def) then
1357 35 : format = field
1358 70 : do isub = 2, subcount_def
1359 70 : field = field//SK_","//subsep_def//SK_","//format
1360 : end do
1361 : end if
1362 95 : format = SK_'('//prefix_def//sign_str//count_str//SK_'('//deliml_def//field//delimr_def//SK_',:,'//sep_def//SK_'))'
1363 :
1364 : !%%%%%%%%%%%%%%%%%%%%%%%
1365 : #elif constructDisplay_ENABLED
1366 : !%%%%%%%%%%%%%%%%%%%%%%%
1367 :
1368 : #if File_ENABLED
1369 : logical(LK) :: opened
1370 : character(:,SKC), allocatable :: status_def, position_def
1371 909 : inquire(file = file, opened = opened, number = disp%unit)
1372 909 : if (opened) close(disp%unit)
1373 :
1374 909 : if (present(status)) then
1375 0 : CHECK_ASSERTION(__LINE__, isValidStatus(status), SK_"@constructDisplay(): The condition `isValidPosition(status)` must hold. status = "//getStr(status))
1376 0 : status_def = status
1377 909 : elseif (opened) then
1378 2 : status_def = SKC_"old"
1379 : else
1380 907 : status_def = SKC_"unknown"
1381 : end if
1382 :
1383 909 : if (present(position)) then
1384 0 : CHECK_ASSERTION(__LINE__, isValidPosition(position), SK_"@constructDisplay(): The condition `isValidPosition(position)` must hold. position = "//getStr(position))
1385 0 : position_def = position
1386 909 : elseif (opened) then
1387 2 : position_def = SKC_"append"
1388 : else
1389 907 : position_def = SKC_"asis"
1390 : end if
1391 : !> \bug
1392 : !> There is an Intel Fortran compiler bug with the use of `newunit` argument in `open` statement.
1393 : !> The program opens the file in this procedure. However, it apparently does not keep it open
1394 : !> in the write methods of the class. Here is the error message:
1395 : !> forrtl: severe (32): invalid logical unit number, unit -129, file unknown
1396 : !> update: This could have been due to the finalization routine of the type.
1397 : !disp%unit = getFileUnit()
1398 909 : open(newunit = disp%unit, file = file, status = status_def, position = position_def)
1399 : #elif Unit_ENABLED
1400 96419 : if (present(unit)) then
1401 17 : disp%unit = unit
1402 17 : if (.not. isOpen(unit)) open(unit, status = "scratch")
1403 : else
1404 : disp%unit = output_unit
1405 : end if
1406 : #else
1407 : #error "Unrecognized interface."
1408 : #endif
1409 : !> The following setting is critical to prevent closing of the opened file by the `final` subroutine of the class. !disp%opened = .false._LK
1410 97328 : if (present(deliml)) disp%deliml = deliml
1411 97328 : if (present(delimr)) disp%delimr = delimr
1412 97328 : if (present(format)) disp%format = format
1413 97328 : if (present(advance)) disp%advance = advance
1414 97328 : if (present(tmsize)) disp%tmsize = tmsize
1415 97328 : if (present(bmsize)) disp%bmsize = bmsize
1416 97328 : if (present(count)) disp%count = count
1417 :
1418 97328 : if (.not. allocated(disp%deliml%string)) disp%deliml%string = SKC_""
1419 97328 : if (.not. allocated(disp%deliml%integer)) disp%deliml%integer = SKC_""
1420 97328 : if (.not. allocated(disp%deliml%logical)) disp%deliml%logical = SKC_""
1421 97328 : if (.not. allocated(disp%deliml%complex)) disp%deliml%complex = SKC_"("
1422 97328 : if (.not. allocated(disp%deliml%real)) disp%deliml%real = SKC_""
1423 :
1424 97328 : if (.not. allocated(disp%delimr%string)) disp%delimr%string = SKC_""
1425 97328 : if (.not. allocated(disp%delimr%integer)) disp%delimr%integer = SKC_""
1426 97328 : if (.not. allocated(disp%delimr%logical)) disp%delimr%logical = SKC_""
1427 97328 : if (.not. allocated(disp%delimr%complex)) disp%delimr%complex = SKC_")"
1428 97328 : if (.not. allocated(disp%delimr%real)) disp%delimr%real = SKC_""
1429 :
1430 : ! Take care of the special cases.
1431 97328 : if (allocated(disp%format%complex)) then
1432 2 : if (getStrLower(disp%format%complex) == SK_"math") disp%format%complex = FORMAT_GENERIC_DISPLAY_COMPLEX_MATH
1433 : end if
1434 :
1435 97328 : if (.not. allocated(disp%format%string )) disp%format%string = SKC_'(sp,*('//getStrQuoted(disp%deliml%string )//SKC_',g0,' //getStrQuoted(disp%delimr%string ) //SKC_',:,", "))'
1436 97328 : if (.not. allocated(disp%format%integer )) disp%format%integer = SKC_'(sp,*('//getStrQuoted(disp%deliml%integer )//SKC_',g0,' //getStrQuoted(disp%delimr%integer ) //SKC_',:,", "))'
1437 97328 : if (.not. allocated(disp%format%logical )) disp%format%logical = SKC_'(sp,*('//getStrQuoted(disp%deliml%logical )//SKC_',g0,' //getStrQuoted(disp%delimr%logical ) //SKC_',:,", "))'
1438 97328 : if (.not. allocated(disp%format%complex )) disp%format%complex = SKC_'(sp,*('//getStrQuoted(disp%deliml%complex )//SKC_',g0,", ",g0,' //getStrQuoted(disp%delimr%complex ) //SKC_',:,", "))'
1439 97328 : if (.not. allocated(disp%format%real )) disp%format%real = SKC_'(sp,*('//getStrQuoted(disp%deliml%real )//SKC_',g0,' //getStrQuoted(disp%delimr%real ) //SKC_',:,", "))'
1440 :
1441 97328 : if (disp%unit == output_unit) then
1442 96402 : if (isFailedGetShellHeight(disp%height)) disp%height = 0_IK
1443 96402 : if (isFailedGetShellWidth(disp%width)) disp%width = 0_IK
1444 : end if
1445 :
1446 97328 : if (present(text)) then
1447 0 : disp%text = text
1448 : else
1449 97328 : disp%text = wrap_type(tmsize = disp%tmsize, bmsize = disp%bmsize, width = disp%width, unit = disp%unit, sticky = disp%sticky)
1450 : end if
1451 97328 : if (present(mark)) then
1452 14 : disp%mark = mark
1453 : else
1454 97314 : disp%mark = mark_type(tmsize = disp%tmsize, bmsize = disp%bmsize, width = disp%width, unit = disp%unit, sticky = disp%sticky)
1455 : end if
1456 97328 : if (present(note)) then
1457 14 : disp%note = note
1458 : else
1459 97314 : disp%note = note_type(tmsize = disp%tmsize, bmsize = disp%bmsize, width = disp%width, unit = disp%unit, sticky = disp%sticky)
1460 : end if
1461 97328 : if (present(warn)) then
1462 14 : disp%warn = warn
1463 : else
1464 97314 : disp%warn = warn_type(tmsize = disp%tmsize, bmsize = disp%bmsize, width = disp%width, unit = disp%unit, sticky = disp%sticky)
1465 : end if
1466 97328 : if (present(stop)) then
1467 14 : disp%stop = stop
1468 : else
1469 97314 : disp%stop = stop_type(tmsize = disp%tmsize, bmsize = disp%bmsize, width = disp%width, unit = disp%unit, sticky = disp%sticky)
1470 : end if
1471 909 : disp%uninit = .false._LK
1472 :
1473 : !%%%%%%%%%%%
1474 : #elif show_ENABLED
1475 : !%%%%%%%%%%%
1476 :
1477 : character(*, SK), parameter :: NLC = new_line(SK_"a")
1478 : character(:, SK), allocatable :: def_format
1479 : character(3, SK) :: def_advance
1480 : integer(IK) :: def_tmsize
1481 : integer(IK) :: def_bmsize
1482 : integer(IK) :: def_count
1483 : integer(IK) :: def_unit
1484 : integer(IK) :: icount
1485 : #if MEXPRINT_ENABLED
1486 : character(:, SK), allocatable :: EOL
1487 : #endif
1488 99578 : if (self%uninit) then
1489 : select type(self)
1490 : type is (display_type)
1491 0 : self = display_type()
1492 : end select
1493 : end if
1494 99578 : if (present(sticky)) self%sticky = sticky
1495 99578 : if (present(advance)) then; def_advance = advance ; if (self%sticky) self%advance = advance ; else; def_advance = self%advance ; end if
1496 99578 : if (present(tmsize)) then; def_tmsize = tmsize ; if (self%sticky) self%tmsize = tmsize ; else; def_tmsize = self%tmsize ; end if
1497 99578 : if (present(bmsize)) then; def_bmsize = bmsize ; if (self%sticky) self%bmsize = bmsize ; else; def_bmsize = self%bmsize ; end if
1498 99578 : if (present(count)) then; def_count = count ; if (self%sticky) self%count = count ; else; def_count = self%count ; end if
1499 99578 : if (present(unit)) then; def_unit = unit ; if (self%sticky) self%unit = unit ; else; def_unit = self%unit ; end if
1500 : #if MEXPRINT_ENABLED
1501 : call setStrLower(def_advance)
1502 : if (def_advance == "yes") then; EOL = NLC; else; EOL = SK_""; end if
1503 : #endif
1504 :
1505 : ! Set field delimiters and format.
1506 : #if SK_ENABLED
1507 : #define FIELD string
1508 : #elif IK_ENABLED
1509 : #define FIELD integer
1510 : #elif LK_ENABLED
1511 : #define FIELD logical
1512 : #elif CK_ENABLED
1513 : #define FIELD complex
1514 : #elif RK_ENABLED
1515 : #define FIELD real
1516 : #else
1517 : #error "Unrecognized interface."
1518 : #endif
1519 : #if CK_ENABLED
1520 : #define GET_FORMAT(DELIML,DELIMR) \
1521 : SK_'(sp,*('//getStrQuoted(DELIML)//SK_',g0,", ",g0,'//getStrQuoted(DELIMR)//SK_',:,", "))'
1522 : #elif SK_ENABLED || IK_ENABLED || LK_ENABLED || RK_ENABLED
1523 : #define GET_FORMAT(DELIML,DELIMR) \
1524 : SK_'(sp,*('//getStrQuoted(DELIML)//SK_',g0,'//getStrQuoted(DELIMR)//SK_',:,", "))'
1525 : #else
1526 : #error "Unrecognized interface."
1527 : #endif
1528 99578 : if (present(format)) then
1529 3657 : def_format = format
1530 95921 : elseif (present(deliml) .and. present(delimr)) then
1531 2 : def_format = GET_FORMAT(deliml, delimr)
1532 95919 : elseif (present(deliml)) then
1533 6372 : def_format = GET_FORMAT(deliml, deliml)
1534 89547 : elseif (present(delimr)) then
1535 0 : def_format = GET_FORMAT(delimr, delimr)
1536 : else
1537 89547 : def_format = self%format%FIELD
1538 : endif
1539 99578 : if (self%sticky) then
1540 0 : self%format%FIELD = def_format
1541 0 : if (present(deliml)) self%deliml%FIELD = deliml
1542 0 : if (present(delimr)) self%delimr%FIELD = delimr
1543 : end if
1544 : ! display contents.
1545 : ! Strategy:
1546 : ! All objects up to rank 2 are directly displayed.
1547 : ! For object os higher rank we recursively reduce the rank by recursively calling the lower rank methods.
1548 : ! The display format follows that of matlab.
1549 : ! That is, by default,
1550 : ! - A vector is shown as a row.
1551 : ! - A matrix is shown as a (nrow, ncol) matrix.
1552 : ! - A cube is shown as a collection of subsequent matrices of shape (:, :, icube).
1553 : ! - ...
1554 : #if MEXPRINT_ENABLED
1555 : #define DISPLAY_NONE \
1556 : if (def_unit == output_unit) then; call mexPrintf(NLC); else; write(def_unit, "(A)", advance = def_advance); end if;
1557 : #define HEADER(HEAD) \
1558 : if (def_unit == output_unit) then; call mexPrintf(HEAD); else; write(def_unit, "(A)", advance = def_advance) HEAD; end if;
1559 : #define DISPLAY(ROW) \
1560 : if (def_unit == output_unit) then; call mexPrintf(getStr([ROW], def_format)//EOL); else; write(def_unit, def_format, advance = def_advance) ROW; end if
1561 : #define MARGIN(SIZE) \
1562 : if (def_unit == output_unit) then; call mexPrintf(repeat(NLC, SIZE)); else; write(def_unit, "("//repeat("/", SIZE)//")", advance = "NO"); end if
1563 : #else
1564 : #define DISPLAY_NONE \
1565 : write(def_unit, "(A)", advance = def_advance);
1566 : #define HEADER(HEAD) \
1567 : write(def_unit, "(A)", advance = def_advance) HEAD;
1568 : #define DISPLAY(ROW) \
1569 : write(def_unit, def_format, advance = def_advance) ROW;
1570 : #define MARGIN(SIZE) \
1571 : write(def_unit, "("//repeat("/", SIZE)//")", advance = "NO")
1572 : #endif
1573 : !#define CALL_DISP(OBJ) call self%show(OBJ, unit = unit, format = def_format, advance = advance, bmsize = 0_IK, tmsize = 0_IK)
1574 99662 : MARGIN(def_tmsize)
1575 199156 : do icount = 1_IK, def_count
1576 : #if CN_ENABLED && D0_ENABLED
1577 163950 : DISPLAY(object)
1578 : #elif CN_ENABLED && D1_ENABLED
1579 24454 : if (0_IK < size(object, 1, IK)) then
1580 11989 : DISPLAY(object)
1581 : else
1582 238 : DISPLAY_NONE
1583 : end if
1584 : #elif CN_ENABLED && D2_ENABLED
1585 4997 : block
1586 : integer(IK) :: irow
1587 25155 : do irow = 1, size(object, 1, IK)
1588 25155 : if (0_IK < size(object, 2, IK)) then
1589 19997 : DISPLAY(object(irow, :))
1590 : else
1591 161 : DISPLAY_NONE
1592 : end if
1593 : end do
1594 : end block
1595 : #elif CN_ENABLED && D3_ENABLED
1596 36 : block
1597 : integer(IK) :: imat, irow
1598 107 : do imat = 1, size(object, 3, IK)
1599 71 : HEADER(SK_"slice(:,:,"//getStr(imat)//SK_") = ")
1600 365 : do irow = 1, size(object, 1, IK)
1601 329 : if (0_IK < size(object, 2, IK)) then
1602 258 : DISPLAY(object(irow, :, imat))
1603 : else
1604 0 : DISPLAY_NONE
1605 : end if
1606 : end do
1607 : end do
1608 : end block
1609 : #elif (BS_ENABLED || PS_ENABLED) && D0_ENABLED
1610 6 : DISPLAY(object%val)
1611 : #elif (BS_ENABLED || PS_ENABLED) && D1_ENABLED
1612 299 : block
1613 : integer(IK) :: idim
1614 299 : if (0_IK < size(object, 1, IK)) then
1615 2364 : DISPLAY((object(idim)%val, idim = 1, size(object, 1, IK)))
1616 : else
1617 21 : DISPLAY_NONE
1618 : end if
1619 : end block
1620 : #elif (BS_ENABLED || PS_ENABLED) && D2_ENABLED
1621 33 : block
1622 : integer(IK) :: icol, irow
1623 736 : do irow = 1, size(object, 1, IK)
1624 736 : if (0_IK < size(object, 2, IK)) then
1625 1427 : DISPLAY((object(irow, icol)%val, icol = 1, size(object, 2, IK)))
1626 : else
1627 0 : DISPLAY_NONE
1628 : end if
1629 : end do
1630 : end block
1631 : #elif (BS_ENABLED || PS_ENABLED) && D3_ENABLED
1632 1 : block
1633 : integer(IK) :: imat, irow, icol
1634 5 : do imat = 1, size(object, 3, IK)
1635 4 : HEADER(SK_"object(:,:,"//getStr(imat)//SK_")%val = ")
1636 13 : do irow = 1, size(object, 1, IK)
1637 12 : if (0_IK < size(object, 2, IK)) then
1638 32 : DISPLAY((object(irow, icol, imat)%val, icol = 1, size(object, 2, IK)))
1639 : else
1640 0 : DISPLAY_NONE
1641 : end if
1642 : end do
1643 : end do
1644 : end block
1645 : #elif (BV_ENABLED || PV_ENABLED) && D0_ENABLED
1646 0 : DISPLAY(object%val)
1647 : #elif (BV_ENABLED || PV_ENABLED) && D1_ENABLED
1648 5 : block
1649 : integer(IK) :: irow
1650 35 : do irow = 1, size(object, 1, IK)
1651 35 : if (0_IK < size(object(irow)%val, 1, IK)) then
1652 89 : DISPLAY(object(irow)%val(:))
1653 : else
1654 0 : DISPLAY_NONE
1655 : end if
1656 : end do
1657 : end block
1658 : #elif (BV_ENABLED || PV_ENABLED) && D2_ENABLED
1659 0 : block
1660 : integer(IK) :: irow, imat
1661 0 : do imat = 1, size(object, 2, IK)
1662 0 : HEADER(SK_"object(:,"//getStr(imat)//SK_")%val(:) = ")
1663 0 : do irow = 1, size(object, 1, IK)
1664 0 : if (0_IK < size(object(irow, imat)%val, 1, IK)) then
1665 0 : DISPLAY(object(irow, imat)%val(:))
1666 : else
1667 0 : DISPLAY_NONE
1668 : end if
1669 : end do
1670 : end do
1671 : end block
1672 : #elif (BM_ENABLED || CM_ENABLED) && D0_ENABLED
1673 0 : block
1674 : integer(IK) :: irow
1675 0 : do irow = 1, size(object%val, 1, IK)
1676 0 : if (0_IK < size(object%val, 2, IK)) then
1677 0 : DISPLAY(object%val(irow, :))
1678 : else
1679 0 : DISPLAY_NONE
1680 : end if
1681 : end do
1682 : end block
1683 : #elif (BM_ENABLED || CM_ENABLED) && D1_ENABLED
1684 2 : block
1685 : integer(IK) :: imat, irow
1686 8 : do imat = 1, size(object, 1, IK)
1687 6 : HEADER(SK_"object("//getStr(imat)//SK_")%val(:,:) = ")
1688 28 : do irow = 1, size(object(imat)%val, 1, IK)
1689 26 : if (0_IK < size(object(imat)%val, 2, IK)) then
1690 88 : DISPLAY(object(imat)%val(irow, :))
1691 : else
1692 0 : DISPLAY_NONE
1693 : end if
1694 : end do
1695 : end do
1696 : end block
1697 : #elif (BC_ENABLED || PC_ENABLED) && D0_ENABLED
1698 0 : block
1699 : integer(IK) :: imat, irow
1700 0 : do imat = 1, size(object%val, 3, IK)
1701 0 : HEADER(SK_"object%val(:,:,"//getStr(imat)//SK_") = ")
1702 0 : do irow = 1, size(object%val, 1, IK)
1703 0 : if (0_IK < size(object%val, 2, IK)) then
1704 0 : DISPLAY(object%val(irow, :, imat))
1705 : else
1706 0 : DISPLAY_NONE
1707 : end if
1708 : end do
1709 : end do
1710 : end block
1711 : #else
1712 : #error "Unrecognized interface."
1713 : #endif
1714 : end do
1715 102291 : MARGIN(def_bmsize)
1716 99578 : flush(def_unit)
1717 : #undef DISPLAY_NONE
1718 : #undef GET_FORMAT
1719 : #undef DISPLAY
1720 : #undef FIELD
1721 :
1722 : !%%%%%%%%%%%
1723 : #elif dump_ENABLED
1724 : !%%%%%%%%%%%
1725 :
1726 : #define CALL_SHOW \
1727 : call self%show(object, tmsize = tmsize, bmsize = bmsize, count = count, unit = unit, format = format, advance = advance, sticky = sticky)
1728 : select type (object)
1729 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1730 : #if SK5_ENABLED
1731 : type is (character(*,SK5)); CALL_SHOW
1732 : #endif
1733 : #if SK4_ENABLED
1734 : type is (character(*,SK4)); CALL_SHOW
1735 : #endif
1736 : #if SK3_ENABLED
1737 : type is (character(*,SK3)); CALL_SHOW
1738 : #endif
1739 : #if SK2_ENABLED
1740 : type is (character(*,SK2)); CALL_SHOW
1741 : #endif
1742 : #if SK1_ENABLED
1743 0 : type is (character(*,SK1)); CALL_SHOW
1744 : #endif
1745 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1746 : #if IK5_ENABLED
1747 0 : type is (integer(IK5)); CALL_SHOW
1748 : #endif
1749 : #if IK4_ENABLED
1750 0 : type is (integer(IK4)); CALL_SHOW
1751 : #endif
1752 : #if IK3_ENABLED
1753 0 : type is (integer(IK3)); CALL_SHOW
1754 : #endif
1755 : #if IK2_ENABLED
1756 0 : type is (integer(IK2)); CALL_SHOW
1757 : #endif
1758 : #if IK1_ENABLED
1759 0 : type is (integer(IK1)); CALL_SHOW
1760 : #endif
1761 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1762 : #if LK5_ENABLED
1763 0 : type is (logical(LK5)); CALL_SHOW
1764 : #endif
1765 : #if LK4_ENABLED
1766 0 : type is (logical(LK4)); CALL_SHOW
1767 : #endif
1768 : #if LK3_ENABLED
1769 0 : type is (logical(LK3)); CALL_SHOW
1770 : #endif
1771 : #if LK2_ENABLED
1772 0 : type is (logical(LK2)); CALL_SHOW
1773 : #endif
1774 : #if LK1_ENABLED
1775 0 : type is (logical(LK1)); CALL_SHOW
1776 : #endif
1777 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1778 : #if CK5_ENABLED
1779 : type is (complex(CK5)); CALL_SHOW
1780 : #endif
1781 : #if CK4_ENABLED
1782 0 : type is (complex(CK4)); CALL_SHOW
1783 : #endif
1784 : #if CK3_ENABLED
1785 0 : type is (complex(CK3)); CALL_SHOW
1786 : #endif
1787 : #if CK2_ENABLED
1788 0 : type is (complex(CK2)); CALL_SHOW
1789 : #endif
1790 : #if CK1_ENABLED
1791 0 : type is (complex(CK1)); CALL_SHOW
1792 : #endif
1793 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1794 : #if RK5_ENABLED
1795 : type is (real(RK5)); CALL_SHOW
1796 : #endif
1797 : #if RK4_ENABLED
1798 0 : type is (real(RK4)); CALL_SHOW
1799 : #endif
1800 : #if RK3_ENABLED
1801 0 : type is (real(RK3)); CALL_SHOW
1802 : #endif
1803 : #if RK2_ENABLED
1804 0 : type is (real(RK2)); CALL_SHOW
1805 : #endif
1806 : #if RK1_ENABLED
1807 0 : type is (real(RK1)); CALL_SHOW
1808 : #endif
1809 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1810 : class default; error stop "Unrecognized unsupported type for dumping to display." ! LCOV_EXCL_LINE
1811 : end select
1812 : #undef CALL_SHOW
1813 :
1814 : !%%%%%%%%%%%
1815 : #elif wrap_ENABLED
1816 : !%%%%%%%%%%%
1817 :
1818 : !#if __GFORTRAN__
1819 : ! ! Bypass gfortran bug with deallocation of heap arrays.
1820 : !#define BYPASS_GFORTRAN_BUG if (allocated(temp)) deallocate(temp);
1821 : !#else
1822 : !#define BYPASS_GFORTRAN_BUG
1823 : !#endif
1824 : !
1825 : !#define RESIZE(strWrapped) \
1826 : ! if (pos + fullwidth + lenLF > lenStrWrapped) then; \
1827 : ! allocate(character(lenStrWrapped * 2, SKC) :: temp); \
1828 : ! temp(1:lenStrWrapped) = strWrapped; \
1829 : ! call move_alloc(temp, strWrapped); \
1830 : ! lenStrWrapped = len(strWrapped, IK); \
1831 : ! BYPASS_GFORTRAN_BUG \
1832 : ! end if
1833 : !character(:,SKC), allocatable :: temp
1834 : character(1,SKC), parameter :: FILL_SKC = MFILL
1835 : character(1,SKC), parameter :: LF = new_line(SKC_"a") ! char(10, SKC)
1836 : integer(IK) , parameter :: lenLF = len(LF, IK)
1837 :
1838 : integer(IK) :: def_lwsize, def_rwsize, def_twsize, def_bwsize, def_tmsize, def_bmsize, def_width, def_unit
1839 : integer(IK) :: lenStr, lenLine, lenNewLine, fullwidth, pos, i, iend !, lenStrWrapped
1840 : character(1,SKC) :: def_lwfill, def_rwfill, def_twfill, def_bwfill, def_fill
1841 165 : character(:,SKC), allocatable :: tbwrap, def_newline, strWrapped
1842 :
1843 165 : if (self%uninit) then
1844 165 : if (.not. allocated(self%newline)) self%newline = LF
1845 165 : if (.not. allocated(self%lwfill )) self%lwfill = FILL_SKC
1846 165 : if (.not. allocated(self%rwfill )) self%rwfill = FILL_SKC
1847 165 : if (.not. allocated(self%twfill )) self%twfill = FILL_SKC
1848 165 : if (.not. allocated(self%bwfill )) self%bwfill = FILL_SKC
1849 165 : if (.not. allocated(self%fill )) self%fill = SKC_" "
1850 165 : self%uninit = .true._LK
1851 : end if
1852 :
1853 165 : if (present(sticky)) self%sticky = sticky
1854 165 : if (present(width )) then; def_width = width ; if (self%sticky) self%width = width ; else; def_width = self%width ; end if
1855 165 : if (present(lwfill )) then; def_lwfill = lwfill ; if (self%sticky) self%lwfill = lwfill ; else; def_lwfill = self%lwfill ; end if
1856 165 : if (present(rwfill )) then; def_rwfill = rwfill ; if (self%sticky) self%rwfill = rwfill ; else; def_rwfill = self%rwfill ; end if
1857 165 : if (present(twfill )) then; def_twfill = twfill ; if (self%sticky) self%twfill = twfill ; else; def_twfill = self%twfill ; end if
1858 165 : if (present(bwfill )) then; def_bwfill = bwfill ; if (self%sticky) self%bwfill = bwfill ; else; def_bwfill = self%bwfill ; end if
1859 165 : if (present(lwsize )) then; def_lwsize = lwsize ; if (self%sticky) self%lwsize = lwsize ; else; def_lwsize = self%lwsize ; end if
1860 165 : if (present(rwsize )) then; def_rwsize = rwsize ; if (self%sticky) self%rwsize = rwsize ; else; def_rwsize = self%rwsize ; end if
1861 165 : if (present(twsize )) then; def_twsize = twsize ; if (self%sticky) self%twsize = twsize ; else; def_twsize = self%twsize ; end if
1862 165 : if (present(bwsize )) then; def_bwsize = bwsize ; if (self%sticky) self%bwsize = bwsize ; else; def_bwsize = self%bwsize ; end if
1863 165 : if (present(tmsize )) then; def_tmsize = tmsize ; if (self%sticky) self%tmsize = tmsize ; else; def_tmsize = self%tmsize ; end if
1864 165 : if (present(bmsize )) then; def_bmsize = bmsize ; if (self%sticky) self%bmsize = bmsize ; else; def_bmsize = self%bmsize ; end if
1865 165 : if (present(fill )) then; def_fill = fill ; if (self%sticky) self%fill = fill ; else; def_fill = self%fill ; end if
1866 165 : if (present(unit )) then; def_unit = unit ; if (self%sticky) self%unit = unit ; else; def_unit = self%unit ; end if
1867 165 : if (present(newline )) then; def_newline= newline ; if (self%sticky) self%newline = newline ; else; def_newline = self%newline ; end if
1868 :
1869 165 : lenStr = len(str, IK)
1870 165 : lenNewLine = len(def_newline, IK)
1871 165 : lenLine = lenStr * 5_IK / def_width ! best guess for the number of lines, assuming each line is 1/5 of the specified width.
1872 165 : fullwidth = def_lwsize + def_width + def_rwsize ! the full width of each line (excluding the newline character at the end).
1873 : !lenStrWrapped = (fullwidth + lenLF) * (def_twsize + def_bwsize + lenLine)
1874 165 : allocate(character((fullwidth + lenLF) * (def_twsize + def_bwsize + lenLine) + (def_tmsize + def_bmsize) * lenLF, SKC) :: strWrapped)
1875 :
1876 : ! Add the top margin.
1877 :
1878 : pos = def_tmsize * lenLF
1879 165 : strWrapped(1 : pos) = repeat(LF, def_tmsize)
1880 21653 : tbwrap = repeat(def_twfill, fullwidth)//LF
1881 330 : do i = 1_IK, def_twsize
1882 165 : strWrapped(pos + 1 : pos + fullwidth + lenLF) = tbwrap
1883 165 : pos = pos + fullwidth + lenLF
1884 : end do
1885 :
1886 : i = 1_IK
1887 : iend = 0_IK
1888 502 : do
1889 667 : if (iend == lenStr) exit
1890 502 : lenLine = index(str(i : lenStr), def_newline)
1891 502 : if (lenLine > 0_IK) then
1892 338 : iend = i + lenLine - 2_IK
1893 : else
1894 : iend = lenStr
1895 : end if
1896 : !RESIZE(strWrapped)
1897 502 : if (len(strWrapped, IK) < pos + fullwidth + lenLF) call setResized(strWrapped)
1898 : !write(*, *) "len(str(i:iend))", len(str(i:iend))
1899 : call setCentered( strWrapped(pos + 1_IK : pos + fullwidth) & ! LCOV_EXCL_LINE
1900 : , str(i : iend) & ! LCOV_EXCL_LINE
1901 : , lmsize = def_lwsize & ! LCOV_EXCL_LINE
1902 : , rmsize = def_rwsize & ! LCOV_EXCL_LINE
1903 : , lmfill = def_lwfill & ! LCOV_EXCL_LINE
1904 : , rmfill = def_rwfill & ! LCOV_EXCL_LINE
1905 : , fill = def_fill & ! LCOV_EXCL_LINE
1906 502 : )
1907 502 : strWrapped(pos + fullwidth + 1_IK : pos + fullwidth + lenLF) = LF
1908 : pos = pos + fullwidth + lenLF
1909 502 : i = iend + lenNewLine + 1_IK
1910 : end do
1911 :
1912 : ! Add the bottom margin.
1913 :
1914 21653 : tbwrap(1 : fullwidth) = repeat(def_bwfill, fullwidth)
1915 :
1916 330 : do i = 1_IK, def_bwsize
1917 : !RESIZE(strWrapped)
1918 165 : if (pos + fullwidth + lenLF > len(strWrapped, IK)) call setResized(strWrapped)
1919 165 : strWrapped(pos + 1 : pos + fullwidth) = tbwrap
1920 165 : pos = pos + fullwidth
1921 : end do
1922 :
1923 165 : i = pos + def_bmsize * lenLF
1924 165 : if (len(strWrapped, IK) < i) call setResized(strWrapped)
1925 321 : strWrapped(pos + 1 : i) = repeat(LF, def_bmsize)
1926 : #if MEXPRINT_ENABLED
1927 : if (def_unit == output_unit) then
1928 : call mexPrintf(strWrapped(1 : i)//LF)
1929 : else
1930 : write(def_unit, "(a)") strWrapped(1 : i)
1931 : end if
1932 : #else
1933 165 : write(def_unit, "(a)") strWrapped(1 : i)
1934 : #endif
1935 165 : flush(def_unit)
1936 : !write(*, "(a)")
1937 : !write(*, "(a)") strWrapped(1:pos)
1938 : !write(*, "(a)")
1939 165 : deallocate(strWrapped)
1940 :
1941 : #else
1942 : !%%%%%%%%%%%%%%%%%%%%%%%%
1943 : #error "Unrecognized interface."
1944 : !%%%%%%%%%%%%%%%%%%%%%%%%
1945 : #endif
1946 : #undef CATCH_ERR_IF_FAILED
1947 : #undef INTEL_SHARED_FILE
1948 : #undef RETURN_IF_FAILED
1949 : #undef IOSTAT_IOMSG
1950 : #undef SET_STAT_IO
1951 : #undef ITEM
|
