Line data Source code
1 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3 : !!!!
4 : !!!! MIT License
5 : !!!!
6 : !!!! ParaMonte: plain powerful parallel Monte Carlo library.
7 : !!!!
8 : !!!! Copyright (C) 2012-present, The Computational Data Science Lab
9 : !!!!
10 : !!!! This file is part of the ParaMonte library.
11 : !!!!
12 : !!!! Permission is hereby granted, free of charge, to any person obtaining a
13 : !!!! copy of this software and associated documentation files (the "Software"),
14 : !!!! to deal in the Software without restriction, including without limitation
15 : !!!! the rights to use, copy, modify, merge, publish, distribute, sublicense,
16 : !!!! and/or sell copies of the Software, and to permit persons to whom the
17 : !!!! Software is furnished to do so, subject to the following conditions:
18 : !!!!
19 : !!!! The above copyright notice and this permission notice shall be
20 : !!!! included in all copies or substantial portions of the Software.
21 : !!!!
22 : !!!! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
23 : !!!! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
24 : !!!! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
25 : !!!! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
26 : !!!! DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
27 : !!!! OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
28 : !!!! OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
29 : !!!!
30 : !!!! ACKNOWLEDGMENT
31 : !!!!
32 : !!!! ParaMonte is an honor-ware and its currency is acknowledgment and citations.
33 : !!!! As per the ParaMonte library license agreement terms, if you use any parts of
34 : !!!! this library for any purposes, kindly acknowledge the use of ParaMonte in your
35 : !!!! work (education/research/industry/development/...) by citing the ParaMonte
36 : !!!! library as described on this page:
37 : !!!!
38 : !!!! https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
39 : !!!!
40 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
41 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
42 :
43 : !> \brief This module contains the classs and procedures for chain IO and manipulation.
44 : !> \author Amir Shahmoradi
45 :
46 : module ParaMonteChainFileContents_mod
47 :
48 : use, intrinsic :: iso_fortran_env, only: output_unit
49 : use Decoration_mod, only: INDENT
50 : use Constants_mod, only: IK, RK
51 : use Err_mod, only: Err_type, warn
52 : use JaggedArray_mod, only: CharVec_type
53 : implicit none
54 :
55 : character(*), parameter :: MODULE_NAME = "@ParaMonteChainFileContents_mod"
56 :
57 : integer(IK) , parameter :: NUM_DEF_COL = 7_IK ! number of columns in the chain file other than the State columns
58 :
59 : character(*), parameter :: COL_HEADER_DEFAULT(NUM_DEF_COL) = [ "ProcessID " &
60 : , "DelayedRejectionStage" &
61 : , "MeanAcceptanceRate " &
62 : , "AdaptationMeasure " &
63 : , "BurninLocation " &
64 : , "SampleWeight " &
65 : , "SampleLogFunc " &
66 : ]
67 :
68 : type :: Count_type
69 : integer(IK) :: compact = 0_IK ! number of unique (weighted) points in the chain
70 : integer(IK) :: verbose = 0_IK ! number of points (weight=1) in the MCMC chain
71 : integer(IK) :: target = 0_IK ! size of the allocations for the Chain components
72 : end type Count_type
73 :
74 : type :: ChainFileContents_type
75 : integer(IK) :: ndim = 0_IK
76 : integer(IK) :: lenHeader = 0_IK
77 : integer(IK) :: numDefCol = NUM_DEF_COL
78 : type(Count_type) :: Count
79 : integer(IK) , allocatable :: ProcessID(:) !< The vector of the ID of the images whose function calls haven been accepted.
80 : integer(IK) , allocatable :: DelRejStage(:) !< The delayed rejection stages at which the proposed states were accepted.
81 : real(RK) , allocatable :: Adaptation(:) !< The vector of the adaptation measures at the MCMC accepted states.
82 : real(RK) , allocatable :: MeanAccRate(:) !< The vector of the average acceptance rates at the given point in the chain.
83 : integer(IK) , allocatable :: BurninLoc(:) !< The burnin locations at the given locations in the chains.
84 : integer(IK) , allocatable :: Weight(:) !< The vector of the weights of the MCMC accepted states.
85 : real(RK) , allocatable :: LogFunc(:) !< The vector of LogFunc values corresponding to the MCMC states.
86 : real(RK) , allocatable :: State(:,:) !< The (nd,chainSize) MCMC chain of accepted proposed states.
87 : type(CharVec_type) , allocatable :: ColHeader(:) !< The column headers of the chain file.
88 : character(:) , allocatable :: delimiter !< The delimiter used to separate objects in the chain file.
89 : type(Err_type) :: Err
90 : contains
91 : procedure, pass :: nullify => nullifyChainFileContents
92 : procedure, pass :: get => getChainFileContents
93 : procedure, pass :: writeChainFile
94 : procedure, pass :: getLenHeader
95 : procedure, pass :: writeHeader
96 : end type ChainFileContents_type
97 :
98 : interface ChainFileContents_type
99 : module procedure :: constructChainFileContents
100 : end interface ChainFileContents_type
101 :
102 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
103 :
104 : contains
105 :
106 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
107 :
108 : !> \brief
109 : !> This is the constructor of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
110 : !> Return an object of class [ChainFileContents_type](@ref chainfilecontents_type) given the input specifications.
111 : !>
112 : !> @param[in] ndim : The number of dimensions of the domain of the objective function.
113 : !> @param[in] variableNameList : The list of variable names corresponding to each axis of the domain of the objective function (**optional**).
114 : !> @param[in] chainFilePath : The list of variable names corresponding to each axis of the domain of the objective function (**optional**).
115 : !> @param[in] chainSize : The size of the chain in the chain file specified by the input `chainFilePath` (**optional**).
116 : !> @param[in] chainFileForm : The file format of the chain file (`"binary"` vs. `"compact"` vs. `"verbose"`) (**optional**).
117 : !> @param[in] lenHeader : The full length of the first line in the input file (the header line) (**optional**).
118 : !> @param[in] delimiter : The delimiter symbol used in the chain file (**optional**).
119 : !> @param[in] targetChainSize : The final target size of the chain (in case the chain file is an interrupted simulation) (**optional**).
120 : !>
121 : !> \return
122 : !> `CFC` : An object of class [ChainFileContents_type](@ref chainfilecontents_type) containing the chain.
123 : !>
124 : !> \warning
125 : !> If `chainFilePath` is given, then the rest of the optional arguments *must be also given*.
126 1380 : function constructChainFileContents(ndim,variableNameList,chainFilePath,chainSize,chainFileForm,lenHeader,delimiter,targetChainSize) result(CFC)
127 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
128 : !DEC$ ATTRIBUTES DLLEXPORT :: constructChainFileContents
129 : #endif
130 : implicit none
131 : integer(IK) , intent(in) :: ndim
132 : character(*), intent(in), optional :: chainFileForm
133 : character(*), intent(in), optional :: variableNameList(ndim)
134 : character(*), intent(in), optional :: chainFilePath
135 : character(*), intent(in), optional :: delimiter
136 : integer(IK) , intent(in), optional :: lenHeader, chainSize, targetChainSize
137 : type(ChainFileContents_type) :: CFC
138 693 : type(Err_type) :: Err
139 : integer(IK) :: icol
140 693 : Err%occurred = .false.
141 :
142 693 : CFC%ndim = ndim
143 :
144 : ! set up the chain file column header
145 :
146 6618 : allocate(CFC%ColHeader(ndim+NUM_DEF_COL))
147 5544 : do icol = 1, NUM_DEF_COL
148 5544 : CFC%ColHeader(icol)%record = trim(adjustl(COL_HEADER_DEFAULT(icol)))
149 : end do
150 693 : if (present(variableNameList)) then
151 1749 : do icol = NUM_DEF_COL + 1, NUM_DEF_COL + ndim
152 1749 : CFC%ColHeader(icol)%record = trim(adjustl(variableNameList(icol-NUM_DEF_COL)))
153 : end do
154 : end if
155 :
156 : ! set up other variables if given
157 :
158 693 : if (present(lenHeader)) CFC%lenHeader = lenHeader
159 693 : if (present(delimiter)) CFC%delimiter = delimiter
160 693 : if (present(targetChainSize)) CFC%Count%target = targetChainSize
161 :
162 : ! read the chain file if the path is given
163 :
164 693 : if (present(chainFilePath) .and. present(chainFileForm)) call CFC%get(chainFilePath,chainFileForm,Err,chainSize,lenHeader,ndim,delimiter,targetChainSize)
165 693 : if (Err%occurred) then
166 : ! LCOV_EXCL_START
167 : CFC%Err%occurred = .true.
168 : CFC%Err%msg = Err%msg
169 : return
170 : end if
171 : ! LCOV_EXCL_STOP
172 :
173 693 : end function constructChainFileContents
174 :
175 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
176 :
177 : !> \brief
178 : !> This is a method of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
179 : !> Return the contents of a ParaMonte simulation output chain file, always in `compact` format, regardless of the
180 : !> value of `chainFileFormat` and store it in the object of class [ChainFileContents_type](@ref chainfilecontents_type).
181 : !>
182 : !> @param[inout] CFC : The object of class [ChainFileContents_type](@ref chainfilecontents_type).
183 : !> @param[in] chainFilePath : The list of variable names corresponding to each axis of the domain of the objective function.
184 : !> @param[in] chainFileForm : The file format of the chain file (`"binary"` vs. `"compact"` vs. `"verbose"`).
185 : !> @param[out] Err : An object of class [Err_type](@ref err_mod::err_type) containing information about whether an error has occurred.
186 : !> @param[in] chainSize : The size of the chain in the chain file specified by the input `chainFilePath` (**optional**).
187 : !> @param[in] lenHeader : The full length of the first line in the input file (the header line) (**optional**).
188 : !> @param[in] ndim : The number of dimensions of the domain of the objective function (**optional**).
189 : !> @param[in] delimiter : The delimiter symbol used in the chain file (**optional**).
190 : !> @param[in] targetChainSize : The final target size of the chain (in case the chain file is an interrupted simulation) (**optional**).
191 : !>
192 : !> \warning
193 : !> `targetChainSize` must be `>= chainSize`, if provided. It is used for the allocation of the chain components.
194 : !>
195 : !> \warning
196 : !> `chainSize` must be `<= targetChainSize`. The first `chainSize` elements of the `CFC` components will contain
197 : !> the chain information read from the chain file. The chain component elements beyond `chainSize` will be set to zero.
198 123 : subroutine getChainFileContents(CFC,chainFilePath,chainFileForm,Err,chainSize,lenHeader,ndim,delimiter,targetChainSize)
199 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
200 : !DEC$ ATTRIBUTES DLLEXPORT :: getChainFileContents
201 : #endif
202 693 : use FileContents_mod, only: getNumRecordInFile
203 : use Constants_mod, only: IK, RK, NLC, NEGINF_IK, NEGINF_RK
204 : use String_mod, only: String_type, getLowerCase, num2str
205 :
206 : implicit none
207 :
208 : character(*), parameter :: PROCEDURE_NAME = MODULE_NAME // "@getChainFileContents()"
209 :
210 : class(ChainFileContents_type), intent(inout) :: CFC
211 : character(*) , intent(in) :: chainFilePath
212 : character(*) , intent(in) :: chainFileForm
213 : type(Err_type) , intent(out) :: Err
214 : character(*) , intent(in), optional :: delimiter
215 : integer(IK) , intent(in), optional :: chainSize, lenHeader, ndim, targetChainSize
216 63 : character(:) , allocatable :: chainFilePathTrimmed, thisForm
217 63 : type(String_type) :: Record
218 : integer(IK) :: chainFileUnit, i, iState, delimiterLen, chainSizeDefault
219 : integer(IK) :: irowLastUniqueSample
220 : integer(IK) :: numColTot
221 : logical :: fileExists, fileIsOpen, delimHasBegun, delimHasEnded, isBinary, isCompact, isVerbose
222 :
223 63 : Err%occurred = .false.
224 63 : chainFilePathTrimmed = trim(adjustl(chainFilePath))
225 63 : inquire(file=chainFilePathTrimmed,exist=fileExists,opened=fileIsOpen,number=chainFileUnit)
226 :
227 636 : blockFileExistence: if (fileExists) then
228 :
229 : ! set up chain file format
230 :
231 63 : isBinary = .false.
232 63 : isCompact = .false.
233 63 : isVerbose = .false.
234 126 : if (getLowerCase(chainFileForm)=="binary") then
235 12 : isBinary = .true.
236 102 : elseif (getLowerCase(chainFileForm)=="compact") then
237 39 : isCompact = .true.
238 24 : elseif (getLowerCase(chainFileForm)=="verbose") then
239 12 : isVerbose = .false.
240 : else
241 : ! LCOV_EXCL_START
242 : Err%occurred = .true.
243 : Err%msg = PROCEDURE_NAME//": Unrecognized chain file form: "//chainFileForm
244 : return
245 : ! LCOV_EXCL_STOP
246 : end if
247 :
248 63 : if (isBinary) then
249 12 : thisForm = "unformatted"
250 12 : if (.not. present(ndim) .or. .not. present(lenHeader) .or. .not. present(delimiter)) then
251 : ! LCOV_EXCL_START
252 : Err%occurred = .true.
253 : Err%msg = PROCEDURE_NAME//": If the chain file is in binary form, chainSize, lenHeader, delimiter, and ndim must be provided by the user."
254 : return
255 : ! LCOV_EXCL_STOP
256 : end if
257 : else
258 51 : thisForm = "formatted"
259 : end if
260 :
261 63 : if (fileIsOpen) then
262 32 : if (chainFileUnit==-1) then
263 : ! LCOV_EXCL_START
264 : Err%occurred = .true.
265 : Err%msg = PROCEDURE_NAME//": The file located at: "//chainFilePathTrimmed//NLC//"is open, but no unit is connected to the file."//NLC
266 : return
267 : ! LCOV_EXCL_STOP
268 : else
269 32 : close(chainFileUnit)
270 : end if
271 : end if
272 :
273 : ! get the number of records in file, minus header line
274 :
275 63 : if (present(chainSize)) then
276 3 : chainSizeDefault = chainSize
277 : else ! here chainSizeDefault is indeed max(chainSize) depending on the file format: verbose or compact
278 60 : if (isBinary) then
279 : open( newunit = chainFileUnit &
280 : , file = chainFilePathTrimmed &
281 : , status = "old" &
282 : , form = thisForm &
283 : , iostat = Err%stat &
284 : #if defined INTEL_COMPILER_ENABLED && defined OS_IS_WINDOWS
285 : , SHARED &
286 : #endif
287 12 : )
288 12 : if (Err%stat/=0) then
289 : ! LCOV_EXCL_START
290 : Err%occurred = .true.
291 : Err%msg = PROCEDURE_NAME//": Unable to open the file located at: "//chainFilePathTrimmed//NLC
292 : return
293 : ! LCOV_EXCL_STOP
294 : end if
295 12 : if (allocated(Record%value)) deallocate(Record%value)
296 12 : allocate( character(lenHeader) :: Record%value )
297 12 : read(chainFileUnit) Record%value
298 : block
299 : integer(IK) :: processID ! LCOV_EXCL_LINE
300 : integer(IK) :: delRejStage ! LCOV_EXCL_LINE
301 : real(RK) :: meanAccRate ! LCOV_EXCL_LINE
302 : real(RK) :: adaptation ! LCOV_EXCL_LINE
303 : integer(IK) :: burninLoc ! LCOV_EXCL_LINE
304 : integer(IK) :: weight ! LCOV_EXCL_LINE
305 : real(RK) :: logFunc ! LCOV_EXCL_LINE
306 : real(RK), allocatable :: State(:) ! LCOV_EXCL_LINE
307 12 : if (allocated(State)) deallocate(State); allocate(State(ndim))
308 12 : chainSizeDefault = 0_IK
309 7200 : loopFindChainSizeDefault: do
310 7212 : read(chainFileUnit,iostat=Err%stat) processID, delRejStage, meanAccRate, adaptation, burninLoc, weight, logFunc, State
311 7212 : if (Err%stat==0_IK) then
312 7200 : chainSizeDefault = chainSizeDefault + 1_IK
313 12 : elseif (is_iostat_end(Err%stat)) then
314 12 : exit loopFindChainSizeDefault
315 : ! LCOV_EXCL_START
316 : elseif (is_iostat_eor(Err%stat)) then
317 : Err%occurred = .true.
318 : Err%msg = PROCEDURE_NAME//": Incomplete record detected while reading the input binary chain file at: "//chainFilePathTrimmed//NLC
319 : return
320 : else
321 : Err%occurred = .true.
322 : Err%msg = PROCEDURE_NAME//": IO error occurred while reading the input binary chain file at: "//chainFilePathTrimmed//NLC
323 : return
324 : ! LCOV_EXCL_STOP
325 : end if
326 : end do loopFindChainSizeDefault
327 : end block
328 12 : close(chainFileUnit)
329 : else ! is not binary
330 48 : call getNumRecordInFile(chainFilePathTrimmed,chainSizeDefault,Err,exclude="")
331 48 : if (Err%occurred) then
332 : ! LCOV_EXCL_START
333 : Err%msg = PROCEDURE_NAME//Err%msg
334 : return
335 : end if
336 : ! LCOV_EXCL_STOP
337 48 : chainSizeDefault = chainSizeDefault - 1_IK ! subtract header
338 : end if
339 : end if
340 :
341 : ! set the number of elements in the Chain components
342 :
343 63 : if (present(targetChainSize)) then ! in restart mode, this must always be the case
344 63 : CFC%Count%target = targetChainSize
345 : else
346 0 : CFC%Count%target = chainSizeDefault
347 : end if
348 : !if (CFC%Count%target<chainSizeDefault) then
349 : ! Err%occurred = .true.
350 : ! Err%msg = PROCEDURE_NAME//": Internal error occurred. The input targetChainSize cannot be smaller than the input chainSize:" // NLC // &
351 : ! " targetChainSize = " // num2str(CFC%Count%target) // NLC // &
352 : ! " chainSize = " // num2str(chainSizeDefault) // NLC // &
353 : ! "It appears that the user has manipulated the output chain file."
354 : ! return
355 : !end if
356 :
357 : ! allocate Chain components
358 :
359 63 : if (allocated(CFC%ProcessID)) deallocate(CFC%ProcessID)
360 63 : if (allocated(CFC%DelRejStage)) deallocate(CFC%DelRejStage)
361 63 : if (allocated(CFC%MeanAccRate)) deallocate(CFC%MeanAccRate)
362 63 : if (allocated(CFC%Adaptation)) deallocate(CFC%Adaptation)
363 63 : if (allocated(CFC%BurninLoc)) deallocate(CFC%BurninLoc)
364 63 : if (allocated(CFC%Weight)) deallocate(CFC%Weight)
365 63 : if (allocated(CFC%LogFunc)) deallocate(CFC%LogFunc)
366 63 : if (allocated(CFC%State)) deallocate(CFC%State)
367 34259 : allocate(CFC%ProcessID (CFC%Count%target)); CFC%ProcessID = NEGINF_IK
368 34259 : allocate(CFC%DelRejStage(CFC%Count%target)); CFC%DelRejStage = NEGINF_IK
369 34259 : allocate(CFC%MeanAccRate(CFC%Count%target)); CFC%MeanAccRate = NEGINF_RK
370 34259 : allocate(CFC%Adaptation (CFC%Count%target)); CFC%Adaptation = NEGINF_RK ! this initialization is critical and relied upon later below
371 34259 : allocate(CFC%BurninLoc (CFC%Count%target)); CFC%BurninLoc = NEGINF_IK
372 34259 : allocate(CFC%Weight (CFC%Count%target)); CFC%Weight = NEGINF_IK
373 34259 : allocate(CFC%LogFunc (CFC%Count%target)); CFC%LogFunc = NEGINF_RK
374 :
375 : ! find the delimiter
376 :
377 63 : blockFindDelim: if (present(delimiter)) then
378 :
379 60 : CFC%delimiter = delimiter
380 :
381 : else blockFindDelim
382 :
383 3 : if (allocated(CFC%delimiter)) deallocate(CFC%delimiter)
384 3 : allocate( character(1023) :: CFC%delimiter )
385 3 : if (allocated(Record%value)) deallocate(Record%value)
386 3 : allocate( character(99999) :: Record%value )
387 :
388 : open( newunit = chainFileUnit &
389 : , file = chainFilePathTrimmed &
390 : , status = "old" &
391 : , form = thisForm &
392 : , iostat = Err%stat &
393 : #if defined INTEL_COMPILER_ENABLED && defined OS_IS_WINDOWS
394 : , SHARED &
395 : #endif
396 3 : )
397 3 : if (Err%stat/=0) then
398 : ! LCOV_EXCL_START
399 : Err%occurred = .true.
400 : Err%msg = PROCEDURE_NAME//": Unable to open the file located at: "//chainFilePathTrimmed//"."//NLC
401 : return
402 : end if
403 : ! LCOV_EXCL_STOP
404 :
405 3 : read(chainFileUnit,*) ! skip the header
406 3 : read(chainFileUnit,"(A)") Record%value ! read the first numeric row in string format
407 3 : close(chainFileUnit)
408 :
409 3 : Record%value = trim(adjustl(Record%value))
410 3 : delimHasEnded = .false.
411 3 : delimHasBegun = .false.
412 3 : delimiterLen = 0
413 21 : loopSearchDelimiter: do i = 1, len(Record%value)-1
414 21 : if ( Record%isDigit(Record%value(i:i)) ) then
415 6 : if (delimHasBegun) delimHasEnded = .true.
416 15 : elseif (Record%value(i:i)=="." .or. Record%value(i:i)=="+" .or. Record%value(i:i)=="-") then
417 0 : if (delimHasBegun) then
418 0 : delimHasEnded = .true.
419 : else
420 : ! LCOV_EXCL_START
421 : Err%occurred = .true.
422 : Err%msg = PROCEDURE_NAME//": The file located at: " // chainFilePathTrimmed //NLC//&
423 : "has unrecognizable format. Found "//Record%value(i:i)//" in the first column, while expecting positive integer."//NLC
424 : return
425 : ! LCOV_EXCL_STOP
426 : end if
427 : else
428 15 : if (i==1) then ! here it is assumed that the first column in chain file always contains integers
429 : ! LCOV_EXCL_START
430 : Err%occurred = .true.
431 : Err%msg = PROCEDURE_NAME//": The file located at: "//chainFilePathTrimmed//NLC//"has unrecognizable format."//NLC
432 : return
433 : ! LCOV_EXCL_STOP
434 : else
435 15 : delimHasBegun = .true.
436 15 : delimiterLen = delimiterLen + 1
437 15 : CFC%delimiter(delimiterLen:delimiterLen) = Record%value(i:i)
438 : end if
439 : end if
440 21 : if (delimHasEnded) exit loopSearchDelimiter
441 : end do loopSearchDelimiter
442 :
443 3 : if (.not.(delimHasBegun.and.delimHasEnded)) then
444 : ! LCOV_EXCL_START
445 : Err%occurred = .true.
446 : Err%msg = PROCEDURE_NAME//": The file located at: "//chainFilePathTrimmed//NLC//"has unrecognizable format. Could not identify the column delimiter."//NLC
447 : return
448 : ! LCOV_EXCL_STOP
449 : else
450 3 : CFC%delimiter = trim(adjustl(CFC%delimiter(1:delimiterLen)))
451 3 : delimiterLen = len(CFC%delimiter)
452 3 : if (delimiterLen==0) then
453 0 : CFC%delimiter = " "
454 0 : delimiterLen = 1
455 : end if
456 : end if
457 :
458 : end if blockFindDelim
459 :
460 : ! find the number of dimensions of the state (the number of function variables)
461 :
462 63 : if (present(ndim)) then
463 63 : CFC%ndim = ndim
464 : else
465 0 : Record%Parts = Record%split(Record%value,CFC%delimiter,Record%nPart)
466 0 : CFC%numDefCol = 0_IK
467 0 : loopFindNumDefCol: do i = 1, Record%nPart
468 0 : if ( index(string=Record%Parts(i)%record,substring="LogFunc") > 0 ) then
469 0 : CFC%numDefCol = i
470 0 : exit loopFindNumDefCol
471 : end if
472 : end do loopFindNumDefCol
473 0 : if (CFC%numDefCol/=NUM_DEF_COL .or. CFC%numDefCol==0_IK) then
474 : ! LCOV_EXCL_START
475 : Err%occurred = .true.
476 : Err%msg = PROCEDURE_NAME//": Internal error occurred. CFC%numDefCol/=NUM_DEF_COL: " // num2str(CFC%numDefCol) // num2str(NUM_DEF_COL)
477 : return
478 : ! LCOV_EXCL_STOP
479 : end if
480 0 : CFC%ndim = Record%nPart - NUM_DEF_COL
481 : end if
482 :
483 : ! reopen the file to read the contents
484 :
485 : open( newunit = chainFileUnit &
486 : , file = chainFilePathTrimmed &
487 : , status = "old" &
488 : , form = thisForm &
489 : , iostat = Err%stat &
490 : #if defined INTEL_COMPILER_ENABLED && defined OS_IS_WINDOWS
491 : , SHARED &
492 : #endif
493 63 : )
494 63 : if (Err%stat/=0) then
495 : ! LCOV_EXCL_START
496 : Err%occurred = .true.
497 : Err%msg = PROCEDURE_NAME//": Unable to open the file located at: "//chainFilePathTrimmed //"."//NLC
498 : return
499 : ! LCOV_EXCL_STOP
500 : end if
501 :
502 : ! first read the column headers
503 :
504 63 : if (allocated(Record%value)) deallocate(Record%value) ! set up the record string that keeps the contents of each line
505 63 : if (isBinary) then
506 12 : allocate( character(lenHeader) :: Record%value )
507 12 : read(chainFileUnit) Record%value
508 : else
509 51 : allocate( character(99999) :: Record%value ) ! such huge allocation is rather redundant and is good for a ~4000 dimensional objective function.
510 51 : read(chainFileUnit, "(A)" ) Record%value
511 : end if
512 1260 : CFC%ColHeader = Record%split(trim(adjustl(Record%value)), CFC%delimiter, Record%npart)
513 630 : do i = 1, Record%npart ! xxx is this trimming necessary?
514 630 : CFC%ColHeader(i)%record = trim(adjustl(CFC%ColHeader(i)%record))
515 : end do
516 :
517 : ! read the chain
518 :
519 63 : if (.not. isBinary) then
520 51 : numColTot = CFC%numDefCol + CFC%ndim
521 : end if
522 :
523 63 : allocate(CFC%State(CFC%ndim,CFC%Count%target))
524 63 : CFC%Count%verbose = 0_IK
525 :
526 63 : if (isBinary) then
527 :
528 7212 : loopReadBinary: do iState = 1, chainSizeDefault
529 7200 : read(chainFileUnit, iostat=Err%stat ) CFC%ProcessID (iState) &
530 7200 : , CFC%DelRejStage (iState) &
531 7200 : , CFC%MeanAccRate (iState) &
532 7200 : , CFC%Adaptation (iState) &
533 7200 : , CFC%BurninLoc (iState) &
534 7200 : , CFC%Weight (iState) &
535 7200 : , CFC%LogFunc (iState) &
536 14400 : , CFC%State (1:CFC%ndim,iState)
537 7200 : if (is_iostat_eor(Err%stat) .or. is_iostat_end(Err%stat)) then
538 : ! LCOV_EXCL_START
539 : call warnUserAboutCorruptChainFile(iState)
540 : exit loopReadBinary
541 : end if
542 : ! LCOV_EXCL_STOP
543 7212 : CFC%Count%verbose = CFC%Count%verbose + CFC%Weight(iState)
544 : end do loopReadBinary
545 :
546 51 : elseif (isCompact) then
547 :
548 18937 : loopReadCompact: do iState = 1, chainSizeDefault
549 18898 : read(chainFileUnit, "(A)" ) Record%value
550 378311 : Record%Parts = Record%split(trim(adjustl(Record%value)),CFC%delimiter,Record%nPart)
551 18937 : if (Record%nPart<numColTot) then
552 : ! LCOV_EXCL_START
553 : call warnUserAboutCorruptChainFile(iState)
554 : exit loopReadCompact
555 : ! LCOV_EXCL_STOP
556 : else
557 18898 : read(Record%Parts(1)%record,*) CFC%ProcessID (iState)
558 18898 : read(Record%Parts(2)%record,*) CFC%DelRejStage (iState)
559 18898 : read(Record%Parts(3)%record,*) CFC%MeanAccRate (iState)
560 18898 : read(Record%Parts(4)%record,*) CFC%Adaptation (iState)
561 18898 : read(Record%Parts(5)%record,*) CFC%BurninLoc (iState)
562 18898 : read(Record%Parts(6)%record,*) CFC%Weight (iState)
563 18898 : read(Record%Parts(7)%record,*) CFC%LogFunc (iState)
564 56694 : do i = 1, CFC%ndim
565 56694 : read(Record%Parts(CFC%numDefCol+i)%record,*) CFC%State (i,iState)
566 : end do
567 18898 : CFC%Count%verbose = CFC%Count%verbose + CFC%Weight(iState)
568 : end if
569 : end do loopReadCompact
570 :
571 : else ! is verbose form
572 :
573 12 : blockChainSizeDefault: if (chainSizeDefault>0_IK) then
574 :
575 12 : CFC%Count%compact = 1_IK
576 : blockReadVerbose: block
577 :
578 : logical :: newUniqueSampleDetected
579 : integer(IK) :: processID
580 : integer(IK) :: delRejStage
581 12 : real(RK) :: meanAccRate
582 12 : real(RK) :: adaptation
583 : integer(IK) :: burninLoc
584 : integer(IK) :: weight
585 12 : real(RK) :: logFunc
586 : real(RK), allocatable :: State(:)
587 12 : if (allocated(State)) deallocate(State); allocate(State(ndim))
588 :
589 12 : irowLastUniqueSample = 0_IK
590 :
591 : ! read the first sample
592 :
593 12 : read(chainFileUnit, "(A)" ) Record%value
594 348 : Record%Parts = Record%split(trim(adjustl(Record%value)),CFC%delimiter,Record%nPart)
595 12 : if (Record%nPart<numColTot) then
596 : ! LCOV_EXCL_START
597 : call warnUserAboutCorruptChainFile(iState)
598 : !exit blockChainSizeDefault
599 : ! intel 2018 to 2019.05 yields internal compiler error with the above exit. Intel 19.1 and gnu 9.1 are fine.
600 : ! The following is a workaround for now.
601 : exit blockReadVerbose
602 : ! LCOV_EXCL_STOP
603 : else
604 12 : read(Record%Parts(1)%record,*) CFC%ProcessID(CFC%Count%compact)
605 12 : read(Record%Parts(2)%record,*) CFC%DelRejStage(CFC%Count%compact)
606 12 : read(Record%Parts(3)%record,*) CFC%MeanAccRate(CFC%Count%compact)
607 12 : read(Record%Parts(4)%record,*) CFC%Adaptation(CFC%Count%compact)
608 12 : read(Record%Parts(5)%record,*) CFC%BurninLoc(CFC%Count%compact)
609 12 : read(Record%Parts(6)%record,*) CFC%Weight(CFC%Count%compact)
610 12 : read(Record%Parts(7)%record,*) CFC%LogFunc(CFC%Count%compact)
611 36 : do i = 1, CFC%ndim
612 36 : read(Record%Parts(CFC%numDefCol+i)%record,*) CFC%State(i,CFC%Count%compact)
613 : end do
614 : end if
615 :
616 : ! read the rest of samples beyond the first, if any exist
617 :
618 12 : newUniqueSampleDetected = .false.
619 23956 : loopOverChainfFileContents: do iState = 2, chainSizeDefault
620 :
621 23944 : read(chainFileUnit, "(A)" ) Record%value
622 478880 : Record%Parts = Record%split(trim(adjustl(Record%value)), CFC%delimiter, Record%nPart)
623 23956 : if (Record%nPart<numColTot) then
624 : ! LCOV_EXCL_START
625 : call warnUserAboutCorruptChainFile(iState)
626 : exit loopOverChainfFileContents
627 : ! LCOV_EXCL_STOP
628 : else
629 23944 : read(Record%Parts(1)%record,*) ProcessID
630 23944 : read(Record%Parts(2)%record,*) DelRejStage
631 23944 : read(Record%Parts(3)%record,*) MeanAccRate
632 23944 : read(Record%Parts(4)%record,*) Adaptation
633 23944 : read(Record%Parts(5)%record,*) BurninLoc
634 23944 : read(Record%Parts(6)%record,*) Weight
635 23944 : read(Record%Parts(7)%record,*) LogFunc
636 71832 : do i = 1, CFC%ndim
637 71832 : read(Record%Parts(CFC%numDefCol+i)%record,*) State(i)
638 : end do
639 :
640 : ! increment CFC%Count%compact if new sample detected
641 :
642 47888 : newUniqueSampleDetected = LogFunc /= CFC%LogFunc (CFC%Count%compact) &
643 : !.or. MeanAccRate /= CFC%MeanAccRate(CFC%Count%compact) &
644 : !.or. Adaptation /= CFC%Adaptation (CFC%Count%compact) &
645 : !.or. BurninLoc /= CFC%BurninLoc (CFC%Count%compact) &
646 : !.or. Weight /= CFC%Weight (CFC%Count%compact) &
647 : !.or. DelRejStage /= CFC%DelRejStage(CFC%Count%compact) &
648 : !.or. ProcessID /= CFC%ProcessID (CFC%Count%compact) &
649 71832 : .or. any(CFC%State(1:CFC%ndim,CFC%Count%compact) /= CFC%State(1:CFC%ndim,CFC%Count%compact))
650 23944 : if (newUniqueSampleDetected) then
651 7188 : irowLastUniqueSample = irowLastUniqueSample + CFC%Weight(CFC%Count%compact)
652 : ! increment the compact sample
653 7188 : CFC%Count%compact = CFC%Count%compact + 1_IK
654 7188 : if (CFC%Count%target<CFC%Count%compact) then
655 0 : Err%occurred = .true.
656 : Err%msg = PROCEDURE_NAME//": Fatal error occurred. CFC%Count%target<CFC%Count%compact: "// &
657 : num2str(CFC%Count%target) // " /= " // num2str(CFC%Count%compact) // &
658 0 : "The contents of the input chain file is longer than the user-requested allocation size."
659 0 : return
660 : end if
661 : else
662 16756 : weight = CFC%Weight(CFC%Count%compact) + 1_IK
663 : end if
664 :
665 : ! write the latest sample
666 :
667 23944 : CFC%LogFunc (CFC%Count%compact) = LogFunc
668 23944 : CFC%MeanAccRate (CFC%Count%compact) = MeanAccRate
669 23944 : CFC%Adaptation (CFC%Count%compact) = max(CFC%Adaptation(CFC%Count%compact),Adaptation)
670 23944 : CFC%BurninLoc (CFC%Count%compact) = BurninLoc
671 23944 : CFC%Weight (CFC%Count%compact) = Weight
672 23944 : CFC%DelRejStage (CFC%Count%compact) = DelRejStage
673 23944 : CFC%ProcessID (CFC%Count%compact) = ProcessID
674 71832 : CFC%State(1:CFC%ndim,CFC%Count%compact) = State(1:CFC%ndim)
675 :
676 : end if
677 :
678 : end do loopOverChainfFileContents
679 :
680 : end block blockReadVerbose
681 :
682 : else blockChainSizeDefault
683 :
684 0 : CFC%Count%compact = 0_IK
685 0 : CFC%Count%verbose = 0_IK
686 :
687 : end if blockChainSizeDefault
688 :
689 : end if
690 :
691 63 : if (isBinary .or. isCompact) then
692 51 : CFC%Count%compact = chainSizeDefault
693 : else
694 12 : CFC%Count%verbose = chainSizeDefault
695 7212 : if (CFC%Count%verbose/=sum(CFC%Weight(1:CFC%Count%compact))) then
696 : ! LCOV_EXCL_START
697 : Err%occurred = .true.
698 : Err%msg = PROCEDURE_NAME//": Internal error occurred. CountVerbose/=sum(Weight): "// &
699 : num2str(CFC%Count%verbose)//" /= "//num2str(sum(CFC%Weight(1:CFC%Count%compact)))// &
700 : ", CFC%Count%compact = "//num2str(CFC%Count%compact)
701 : return
702 : ! LCOV_EXCL_STOP
703 12 : elseif (.not. present(targetChainSize)) then
704 0 : CFC%ProcessID = CFC%ProcessID (1:CFC%Count%compact)
705 0 : CFC%DelRejStage = CFC%DelRejStage (1:CFC%Count%compact)
706 0 : CFC%MeanAccRate = CFC%MeanAccRate (1:CFC%Count%compact)
707 0 : CFC%Adaptation = CFC%Adaptation (1:CFC%Count%compact)
708 0 : CFC%BurninLoc = CFC%BurninLoc (1:CFC%Count%compact)
709 0 : CFC%Weight = CFC%Weight (1:CFC%Count%compact)
710 0 : CFC%LogFunc = CFC%LogFunc (1:CFC%Count%compact)
711 0 : CFC%State = CFC%State (1:CFC%ndim,1:CFC%Count%compact)
712 : end if
713 : end if
714 :
715 63 : close(chainFileUnit)
716 :
717 : ! set the rest of elements to null values
718 :
719 63 : if (CFC%Count%target>chainSizeDefault) call CFC%nullify(startIndex=CFC%Count%compact+1_IK, endIndex=CFC%Count%target)
720 :
721 : else blockFileExistence
722 :
723 : ! LCOV_EXCL_START
724 : Err%occurred = .true.
725 : Err%msg = PROCEDURE_NAME//": The chain file does not exist in the given file path: "//chainFilePathTrimmed
726 : return
727 : ! LCOV_EXCL_STOP
728 :
729 : end if blockFileExistence
730 :
731 : contains
732 :
733 : ! LCOV_EXCL_START
734 : subroutine warnUserAboutCorruptChainFile(lineNumber)
735 : implicit none
736 : integer(IK) :: lineNumber
737 : if (isVerbose) then
738 : chainSizeDefault = irowLastUniqueSample
739 : CFC%Count%compact = CFC%Count%compact - 1
740 : else
741 : chainSizeDefault = chainSizeDefault - 1
742 : end if
743 : call warn ( prefix = INDENT//"ParaMonte" &
744 : , marginTop = 0_IK &
745 : , marginBot = 2_IK &
746 : , outputUnit = output_unit &
747 : , msg = "An end-of-file or end-of-record condition occurred while parsing the contents of the chain file at line = "//num2str(lineNumber)//" with iostat = "//num2str(Err%stat)// &
748 : ". Assuming the previous line as the last line of the chain file..." &
749 : )
750 : ! LCOV_EXCL_STOP
751 63 : end subroutine warnUserAboutCorruptChainFile
752 :
753 : end subroutine getChainFileContents
754 :
755 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
756 :
757 : !> \brief
758 : !> This is a method of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
759 : !> Reset the components of the chain object to an unlikely value for the purpose of error catching and debugging.
760 : !> Store the modified components as part of the input object of class [ChainFileContents_type](@ref chainfilecontents_type).
761 : !>
762 : !> @param[inout] CFC : The number of dimensions of the domain of the objective function.
763 : !> @param[in] startIndex : The beginning index beyond which the component values will be reset.
764 : !> @param[in] endIndex : The ending index below which the component values will be reset.
765 3 : subroutine nullifyChainFileContents(CFC,startIndex,endIndex)
766 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
767 : !DEC$ ATTRIBUTES DLLEXPORT :: nullifyChainFileContents
768 : #endif
769 : implicit none
770 : class(ChainFileContents_type), intent(inout) :: CFC
771 : integer(IK), intent(in) :: startIndex, endIndex
772 901 : CFC%ProcessID (startIndex:endIndex) = -huge(0_IK)
773 901 : CFC%DelRejStage (startIndex:endIndex) = -huge(0_IK)
774 901 : CFC%MeanAccRate (startIndex:endIndex) = -huge(0._RK)
775 901 : CFC%Adaptation (startIndex:endIndex) = -huge(0._RK)
776 901 : CFC%BurninLoc (startIndex:endIndex) = -huge(0_IK)
777 901 : CFC%Weight (startIndex:endIndex) = 0_IK
778 901 : CFC%LogFunc (startIndex:endIndex) = -huge(0._RK)
779 2697 : CFC%State (1:CFC%ndim,startIndex:endIndex) = -huge(0._RK)
780 3 : end subroutine nullifyChainFileContents
781 :
782 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
783 :
784 : !> \brief
785 : !> This is a method of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
786 : !> Return the length of the header of the chain file.
787 : !>
788 : !> @param[inout] CFC : The object of class [ChainFileContents_type](@ref chainfilecontents_type).
789 : !> @param[in] ndim : The number of dimensions of the domain of the objective function.
790 : !> @param[in] isBinary : The logical flag indicating whether the file is in `binary` format.
791 : !> @param[in] chainFileFormat : The Fortran IO formatting string to be used to read the contents of the chain file (**optional**).
792 : !> This argument is only required with a non-binary chain file, i.e., when `isBinary = .false.`.
793 60 : subroutine getLenHeader(CFC,ndim,isBinary,chainFileFormat)
794 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
795 : !DEC$ ATTRIBUTES DLLEXPORT :: getLenHeader
796 : #endif
797 : use Constants_mod, only: IK ! LCOV_EXCL_LINE
798 : use Err_mod, only: abort
799 : implicit none
800 : class(ChainFileContents_type), intent(inout) :: CFC
801 : integer(IK) , intent(in) :: ndim
802 : logical , intent(in) :: isBinary
803 : character(*), intent(in), optional :: chainFileFormat
804 : character(*), parameter :: PROCEDURE_NAME = MODULE_NAME//"@getLenHeader()"
805 60 : character(:), allocatable :: record
806 : integer(IK) :: i
807 60 : CFC%Err%occurred = .false.
808 60 : allocate( character(99999) :: record )
809 60 : if (isBinary) then
810 120 : write( record , "(*(g0,:,','))" ) (CFC%ColHeader(i)%record, i=1,CFC%numDefCol+ndim)
811 : else
812 48 : if ( present(chainFileFormat) ) then
813 480 : write(record,chainFileFormat) (CFC%ColHeader(i)%record, i=1,CFC%numDefCol+ndim)
814 : else
815 : ! LCOV_EXCL_START
816 : CFC%Err%occurred = .true.
817 : CFC%Err%msg = PROCEDURE_NAME//"Internal error occurred. For formatted chain files, chainFileFormat must be given."
818 : call abort(CFC%Err)
819 : error stop
820 : return
821 : ! LCOV_EXCL_STOP
822 : end if
823 : end if
824 60 : CFC%lenHeader = len_trim(adjustl(record))
825 60 : deallocate(record)
826 60 : end subroutine getLenHeader
827 :
828 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
829 :
830 : !> \brief
831 : !> This is a method of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
832 : !> Write the requested header to the chain file.
833 : !>
834 : !> @param[inout] CFC : The object of class [ChainFileContents_type](@ref chainfilecontents_type).
835 : !> @param[in] ndim : The number of dimensions of the domain of the objective function.
836 : !> @param[in] chainFileUnit : The unit ID of the chain file to which the header should be written.
837 : !> @param[in] isBinary : The logical flag indicating whether the file is in `binary` format.
838 : !> @param[in] chainFileFormat : The Fortran IO formatting string to be used to read the contents of the chain file (**optional**).
839 : !> This argument is only required with a non-binary chain file, i.e., when `isBinary = .false.`.
840 269 : subroutine writeHeader(CFC,ndim,chainFileUnit,isBinary,chainFileFormat)
841 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
842 : !DEC$ ATTRIBUTES DLLEXPORT :: writeHeader
843 : #endif
844 60 : use Constants_mod, only: IK
845 : use Err_mod, only: abort
846 : implicit none
847 : class(ChainFileContents_type), intent(inout) :: CFC
848 : integer(IK) , intent(in) :: ndim, chainFileUnit
849 : logical , intent(in) :: isBinary
850 : character(*), intent(in), optional :: chainFileFormat
851 : character(*), parameter :: PROCEDURE_NAME = MODULE_NAME//"@writeHeader()"
852 269 : character(:), allocatable :: record
853 : integer(IK) :: i
854 269 : CFC%Err%occurred = .false.
855 269 : if (isBinary) then
856 20 : allocate( character(99999) :: record )
857 198 : write( record , "(*(g0,:,','))" ) (CFC%ColHeader(i)%record, i=1,CFC%numDefCol+ndim)
858 20 : write(chainFileUnit) trim(adjustl(record))
859 20 : deallocate(record)
860 : else
861 249 : if ( present(chainFileFormat) ) then
862 2380 : write(chainFileUnit,chainFileFormat) (CFC%ColHeader(i)%record, i=1,CFC%numDefCol+ndim)
863 : else
864 : ! LCOV_EXCL_START
865 : CFC%Err%occurred = .true.
866 : CFC%Err%msg = PROCEDURE_NAME//"Internal error occurred. For formatted chain files, chainFileFormat must be given."
867 : call abort(CFC%Err)
868 : error stop
869 : return
870 : ! LCOV_EXCL_STOP
871 : end if
872 : end if
873 269 : end subroutine writeHeader
874 :
875 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
876 :
877 : !> \brief
878 : !> This is a method of the class [ChainFileContents_type](@ref chainfilecontents_type).\n
879 : !> Write the chain properties to the chain file.
880 : !>
881 : !> @param[inout] CFC : The object of class [ChainFileContents_type](@ref chainfilecontents_type).
882 : !> @param[in] ndim : The number of dimensions of the domain of the objective function.
883 : !> @param[in] compactStartIndex : The beginning index of the compact chain beyond which the elements of the chain will be written to the output file.
884 : !> @param[in] compactEndIndex : The ending index of the compact chain below which the elements of the chain will be written to the output file.
885 : !> @param[in] chainFileUnit : The unit ID of the chain file to which the header should be written.
886 : !> @param[in] chainFileForm : The file format of the chain file (`"binary"` vs. `"compact"` vs. `"verbose"`).
887 : !> @param[in] chainFileFormat : The Fortran IO formatting string to be used to read the contents of the chain file (**optional**).
888 : !> This argument is only required with a non-binary chain file, i.e., when `isBinary = .false.`.
889 : !> @param[in] adaptiveUpdatePeriod : The adaptive update period (**optional**). It must be provided if `chainFileForm = "verbose"`.
890 32 : subroutine writeChainFile(CFC,ndim,compactStartIndex,compactEndIndex,chainFileUnit,chainFileForm,chainFileFormat,adaptiveUpdatePeriod)
891 : #if INTEL_COMPILER_ENABLED && defined DLL_ENABLED && (OS_IS_WINDOWS || defined OS_IS_DARWIN)
892 : !DEC$ ATTRIBUTES DLLEXPORT :: writeChainFile
893 : #endif
894 269 : use Constants_mod, only: IK, RK
895 : use Err_mod, only: abort
896 : implicit none
897 : class(ChainFileContents_type), intent(inout) :: CFC
898 : integer(IK) , intent(in) :: ndim, compactStartIndex, compactEndIndex, chainFileUnit
899 : character(*), intent(in) :: chainFileForm
900 : character(*), intent(in), optional :: chainFileFormat
901 : integer(IK) , intent(in), optional :: adaptiveUpdatePeriod
902 : character(*), parameter :: PROCEDURE_NAME = MODULE_NAME//"@writeChainFile()"
903 : logical :: isBinary, isCompact, isVerbose
904 32 : real(RK) :: adaptation
905 : integer(IK) :: i,j, counter
906 :
907 32 : CFC%Err%occurred = .false.
908 :
909 32 : isBinary = .false.
910 32 : isCompact = .false.
911 32 : isVerbose = .false.
912 32 : if (chainFileForm=="binary") then
913 8 : isBinary = .true.
914 24 : elseif (chainFileForm=="compact") then
915 16 : isCompact = .true.
916 8 : elseif (chainFileForm=="verbose") then
917 8 : isVerbose = .true.
918 : else
919 : ! LCOV_EXCL_START
920 : CFC%Err%occurred = .true.
921 : CFC%Err%msg = PROCEDURE_NAME//"Internal error occurred. Unknown chain file format: "//chainFileForm
922 : ! LCOV_EXCL_STOP
923 : end if
924 :
925 32 : if ( .not. isBinary .and. .not. present(chainFileFormat) ) then
926 : ! LCOV_EXCL_START
927 : CFC%Err%occurred = .true.
928 : CFC%Err%msg = PROCEDURE_NAME//"Internal error occurred. For formatted chain files, chainFileFormat must be given."
929 : ! LCOV_EXCL_STOP
930 : end if
931 :
932 32 : if ( isVerbose .and. .not. present(adaptiveUpdatePeriod) ) then
933 : ! LCOV_EXCL_START
934 : CFC%Err%occurred = .true.
935 : CFC%Err%msg = PROCEDURE_NAME//"Internal error occurred. For verbose chain files, adaptiveUpdatePeriod must be given."
936 : ! LCOV_EXCL_STOP
937 : end if
938 :
939 32 : if (CFC%Err%occurred) then
940 : ! LCOV_EXCL_START
941 : call abort(CFC%Err)
942 : return
943 : ! LCOV_EXCL_STOP
944 : end if
945 :
946 32 : call CFC%writeHeader(ndim,chainFileUnit,isBinary,chainFileFormat)
947 :
948 32 : if (compactStartIndex<=compactEndIndex) then
949 32 : if (isCompact) then
950 7984 : do i = compactStartIndex, compactEndIndex
951 7968 : write(chainFileUnit,chainFileFormat ) CFC%ProcessID(i) &
952 7968 : , CFC%DelRejStage(i) &
953 7968 : , CFC%MeanAccRate(i) &
954 7968 : , CFC%Adaptation(i) &
955 7968 : , CFC%BurninLoc(i) &
956 7968 : , CFC%Weight(i) &
957 7968 : , CFC%LogFunc(i) &
958 15952 : , CFC%State(1:ndim,i)
959 : end do
960 16 : elseif (isBinary) then
961 5192 : do i = compactStartIndex, compactEndIndex
962 5184 : write(chainFileUnit ) CFC%ProcessID(i) &
963 5184 : , CFC%DelRejStage(i) &
964 5184 : , CFC%MeanAccRate(i) &
965 5184 : , CFC%Adaptation(i) &
966 5184 : , CFC%BurninLoc(i) &
967 5184 : , CFC%Weight(i) &
968 5184 : , CFC%LogFunc(i) &
969 10376 : , CFC%State(1:ndim,i)
970 : end do
971 8 : elseif (isVerbose) then
972 8 : counter = compactStartIndex
973 5192 : do i = compactStartIndex, compactEndIndex
974 26254 : do j = 1, CFC%Weight(i)
975 21062 : if (mod(counter,adaptiveUpdatePeriod)==0_IK) then
976 19821 : adaptation = CFC%Adaptation(i)
977 : else
978 1241 : adaptation = 0._RK
979 : end if
980 21062 : write(chainFileUnit,chainFileFormat ) CFC%ProcessID(i) &
981 21062 : , CFC%DelRejStage(i) &
982 21062 : , CFC%MeanAccRate(i) &
983 : , adaptation &
984 21062 : , CFC%BurninLoc(i) &
985 21062 : , 1_IK &
986 21062 : , CFC%LogFunc(i) &
987 42124 : , CFC%State(1:ndim,i)
988 26246 : counter = counter + 1
989 : end do
990 : end do
991 : end if
992 : end if
993 32 : flush(chainFileUnit)
994 32 : end subroutine writeChainFile
995 :
996 : !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
997 :
998 : end module ParaMonteChainFileContents_mod ! LCOV_EXCL_LINE
|
