Line data Source code
1 : !!****m* ABINIT/m_stream_string
2 : !! NAME
3 : !! m_stream_string
4 : !!
5 : !! FUNCTION
6 : !! This module define a type representing a variable size
7 : !! string. It can be used in a file-like way by writing to it or reading it.
8 : !! Memory is automatically allocated on writing and freed on reading.
9 : !!
10 : !! COPYRIGHT
11 : !! Copyright (C) 2009-2026 ABINIT group (TC, MG)
12 : !! This file is distributed under the terms of the
13 : !! GNU General Public License, see ~abinit/COPYING
14 : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : !!
16 : !! NOTES
17 : !! Provide tools to manipulate variable size strings in an incremental FIFO way
18 : !! Use `stream%push` to incrementally fill the string. The required memory space will be allocated
19 : !! automatically when needed.
20 : !! To avoid memory leaks you have to use stream_free on the stream to free the memory space unless
21 : !! you already flushed it using stream%flush, stream%transfer, stream%to_string or stream%to_file.
22 : !! Unlike the last four methods, stream_copy and stream_debug do not modify the source stream
23 : !!
24 : !! SOURCE
25 :
26 : #if defined HAVE_CONFIG_H
27 : #include "config.h"
28 : #endif
29 :
30 : #include "abi_common.h"
31 :
32 : module m_stream_string
33 :
34 : use defs_basis
35 : use m_profiling_abi
36 :
37 : use m_fstrings, only : prep_char !, replace
38 :
39 : implicit none
40 :
41 : private
42 :
43 : integer,public,parameter :: chunk_size = 248
44 :
45 : type,private :: stream_chunk
46 : type(stream_chunk), pointer :: next => null()
47 : character(len=chunk_size) :: chunk = repeat(' ', chunk_size)
48 : end type stream_chunk
49 :
50 : type,public :: stream_string
51 : integer :: length = 0
52 : type(stream_chunk), pointer :: head => null()
53 : contains
54 : procedure :: flush => stream_flush_unit
55 : procedure :: flush_units => stream_flush_units
56 : procedure :: free => stream_free
57 : procedure :: copy => stream_copy
58 : procedure :: push => stream_push
59 : procedure :: pop_chunk => stream_pop_chunk
60 : procedure :: to_string => stream_to_string
61 : procedure :: to_file => stream_to_file
62 : procedure :: transfer => stream_transfer
63 : procedure :: debug => stream_debug
64 :
65 : end type stream_string
66 :
67 : contains
68 : !!***
69 :
70 24303 : subroutine stream_flush_unit(stream, unit, newline, firstchar)
71 :
72 : class(stream_string),intent(inout) :: stream
73 : integer,intent(in) :: unit
74 : logical,optional,intent(in) :: newline
75 : character(len=*),optional,intent(in) :: firstchar
76 :
77 24303 : character(len=stream%length) :: s
78 24303 : character(len=2 * stream%length) :: new_s
79 : #ifdef FC_CRAY
80 : integer :: i,l
81 : integer, parameter :: c = 32767
82 : #endif
83 :
84 24303 : if (unit == dev_null) then
85 0 : call stream%free()
86 0 : return
87 : end if
88 :
89 24303 : call stream%to_string(s)
90 :
91 24303 : if (present(firstchar)) then
92 : !new_s = trim(firstchar) // trim(replace(trim(s), ch10, ch10//trim(firstchar)))
93 5 : new_s = prep_char(s, firstchar)
94 5 : write(unit, "(a)")trim(new_s)
95 : else
96 : #if defined FC_NVHPC || defined FC_LLVM
97 : write(unit, "(a)") s
98 : #else
99 : #ifdef FC_CRAY
100 : if(len_trim(s) <= c) then
101 : write(unit, "(a)") trim(s)
102 : else
103 : l=len_trim(s)/c
104 : do i=1,l
105 : write(unit, "(a)") s((i-1)*c+1:i*c)
106 : end do
107 : write(unit, "(a)") s(l*c+1:len_trim(s))
108 : end if
109 : #else
110 24298 : write(unit, "(a)") trim(s)
111 : #endif
112 : #endif
113 : end if
114 :
115 24303 : if (present(newline)) then
116 24291 : if (newline) write(unit, "(a)")""
117 : end if
118 :
119 24303 : call stream%free()
120 :
121 : end subroutine stream_flush_unit
122 :
123 :
124 36594 : subroutine stream_flush_units(stream, units, newline)
125 :
126 : class(stream_string),intent(inout) :: stream
127 : integer,intent(in) :: units(:)
128 : logical,optional,intent(in) :: newline
129 :
130 : !Local variables-------------------------------
131 : !scalars
132 : integer :: ii, cnt
133 36594 : character(len=stream%length) :: s
134 : !arrays
135 73188 : integer :: my_units(size(units))
136 : !******************************************************************
137 :
138 : ! Remove duplicated units (if any)
139 36594 : my_units(1) = units(1); cnt = 1
140 36597 : do ii=2,size(units)
141 6 : if (any(units(ii) == my_units(1:cnt))) cycle
142 3 : cnt = cnt + 1
143 36597 : my_units(cnt) = units(ii)
144 : end do
145 :
146 36594 : call stream%to_string(s)
147 :
148 73191 : do ii=1,cnt
149 36597 : if (units(ii) == dev_null) cycle
150 : #if defined FC_NVHPC || defined FC_LLVM
151 : write(units(ii), "(a)")s
152 : #else
153 36597 : write(units(ii), "(a)")trim(s)
154 : #endif
155 73191 : if (present(newline)) then
156 36597 : if (newline) write(units(ii), "(a)")""
157 : end if
158 : end do
159 :
160 36594 : call stream%free()
161 :
162 36594 : end subroutine stream_flush_units
163 :
164 : !!****f* m_stream_string/stream_free
165 : !! NAME
166 : !! stream_free
167 : !!
168 : !! FUNCTION
169 : !! free stream. Most of the time this is not needed since
170 : !! routines to access the content free the stream
171 : !!
172 : !! SOURCE
173 :
174 63550 : subroutine stream_free(stream)
175 :
176 : class(stream_string),intent(inout) :: stream
177 : type(stream_chunk), pointer :: cursor, prev
178 63550 : cursor => stream%head
179 68524 : do while (associated(cursor))
180 4974 : prev => cursor
181 4974 : cursor => cursor%next
182 68524 : ABI_FREE_SCALAR(prev)
183 : end do
184 63550 : stream%head => NULL()
185 63550 : stream%length = 0
186 :
187 63550 : end subroutine stream_free
188 : !!***
189 :
190 : !!****f* m_stream_string/stream_copy
191 : !! NAME
192 : !! stream_copy
193 : !!
194 : !! FUNCTION
195 : !! copy src content to dest without altering src
196 : !!
197 : !! SOURCE
198 :
199 0 : subroutine stream_copy(src, dest)
200 : class(stream_string),intent(inout) :: src, dest
201 : type(stream_chunk), pointer :: cursor
202 0 : cursor => src%head
203 0 : do while (associated(cursor))
204 0 : call dest%push(cursor%chunk)
205 0 : cursor => cursor%next
206 : end do
207 0 : end subroutine stream_copy
208 : !!***
209 :
210 : !!****f* m_stream_string/stream_push
211 : !! NAME
212 : !! stream_push
213 : !!
214 : !! FUNCTION
215 : !! Write string to stream, allocating memory if needed
216 : !!
217 : !! SOURCE
218 :
219 3696760 : subroutine stream_push(stream, string)
220 : class(stream_string),intent(inout) :: stream
221 : character(len=*),intent(in) :: string
222 : integer :: offset, room_left, soffset
223 : type(stream_chunk), pointer :: cursor
224 :
225 3696760 : offset = stream%length
226 :
227 3696760 : if (.not.associated(stream%head)) then
228 63550 : ABI_MALLOC_SCALAR(stream%head)
229 : end if
230 3696760 : cursor => stream%head
231 :
232 6792960 : do while(offset > chunk_size)
233 3096200 : cursor => cursor%next
234 3096200 : offset = offset - chunk_size
235 : end do
236 :
237 3696760 : room_left = chunk_size - offset
238 3696760 : if (room_left < len(string)) then
239 81147 : cursor%chunk(offset+1:chunk_size) = string(1:room_left)
240 : soffset = room_left
241 162294 : do while (soffset < len(string))
242 81147 : ABI_MALLOC_SCALAR(cursor%next)
243 : cursor%next%chunk(1:min(chunk_size, len(string)-soffset)) = &
244 81147 : string(soffset+1:min(soffset+chunk_size,len(string)))
245 81147 : cursor => cursor%next
246 162294 : soffset = soffset + chunk_size
247 : end do
248 : else
249 3615613 : cursor%chunk(offset+1:offset+len(string)) = string
250 : end if
251 3696760 : stream%length = stream%length + len(string)
252 :
253 3696760 : end subroutine stream_push
254 : !!***
255 :
256 : !!****f* m_stream_string/stream_pop_chunk
257 : !! NAME
258 : !! stream_pop_chunk
259 : !!
260 : !! FUNCTION
261 : !! Remove the last chunk of stream an put its content in string
262 : !!
263 : !! SOURCE
264 :
265 139723 : subroutine stream_pop_chunk(stream, string)
266 : class(stream_string),intent(inout) :: stream
267 : character(len=chunk_size),intent(out) :: string
268 : type(stream_chunk),pointer :: cursor
269 :
270 139723 : string = stream%head%chunk
271 139723 : if (stream%length > chunk_size) then
272 : ! copy the next pointer
273 78826 : cursor => stream%head%next
274 : ! have next pointing to nothing
275 : stream%head%next => NULL()
276 : ! free head
277 78826 : ABI_FREE_SCALAR(stream%head)
278 78826 : stream%head => cursor
279 78826 : stream%length = stream%length - chunk_size
280 : else
281 60897 : ABI_FREE_SCALAR(stream%head)
282 60897 : stream%length = 0
283 : end if
284 :
285 139723 : end subroutine stream_pop_chunk
286 : !!***
287 :
288 : !!****f* m_stream_string/stream_to_string
289 : !! NAME
290 : !! stream_to_string
291 : !!
292 : !! FUNCTION
293 : !! Copy the content of stream to string, freeing stream. String must be large enough
294 : !!
295 : !! SOURCE
296 :
297 60897 : subroutine stream_to_string(stream, string)
298 :
299 : class(stream_string),intent(inout) :: stream
300 : character(len=*),intent(out) :: string
301 : character(len=chunk_size) :: stmp
302 : integer :: offset, length
303 60897 : offset = 0
304 :
305 23135313 : string = repeat(' ', len(string))
306 200620 : do while (stream%length > 0)
307 139723 : length = stream%length
308 139723 : call stream%pop_chunk(stmp)
309 139723 : string(offset+1:offset+min(length, chunk_size)) = stmp(1:min(length, chunk_size))
310 139723 : offset = offset + chunk_size
311 : end do
312 :
313 60897 : end subroutine stream_to_string
314 : !!***
315 :
316 : !!****f* m_stream_string/stream_to_file
317 : !! NAME
318 : !! stream_to_file
319 : !!
320 : !! FUNCTION
321 : !! Write the content of stream to the file, freeing stream
322 : !!
323 : !! SOURCE
324 :
325 0 : subroutine stream_to_file(stream, file_d)
326 : class(stream_string),intent(inout) :: stream
327 : integer,intent(in) :: file_d
328 : character(len=chunk_size) :: stmp
329 : integer :: offset, length
330 0 : offset = 0
331 :
332 0 : do while (stream%length > 0)
333 0 : length = stream%length
334 0 : call stream%pop_chunk(stmp)
335 0 : write(file_d, '(A)', advance='no') stmp(1:min(length, chunk_size))
336 0 : offset = offset + chunk_size
337 : end do
338 :
339 0 : end subroutine stream_to_file
340 : !!***
341 :
342 : !!****f* m_stream_string/stream_transfer
343 : !! NAME
344 : !! stream_transfer
345 : !!
346 : !! FUNCTION
347 : !! Copy the content of src to dest, freeing src
348 : !! If possible does not reallocate memory and just have
349 : !! dest point to src content
350 : !!
351 : !! SOURCE
352 :
353 0 : subroutine stream_transfer(src, dest)
354 : class(stream_string),intent(inout) :: src, dest
355 : character(len=chunk_size) :: chunk
356 : integer :: length
357 0 : if(.not.associated(dest%head)) then
358 : ! if possible just transfer the pointer
359 0 : dest%head => src%head
360 0 : dest%length = src%length
361 0 : src%head => NULL()
362 : else
363 0 : do while (src%length > 0)
364 0 : length = src%length
365 0 : call src%pop_chunk(chunk)
366 0 : if(length > chunk_size) then
367 0 : call dest%push(chunk)
368 : else
369 0 : call dest%push(chunk(1:length))
370 : end if
371 : end do
372 : end if
373 :
374 0 : end subroutine stream_transfer
375 : !!***
376 :
377 : !!****f* m_stream_string/stream_debug
378 : !! NAME
379 : !! stream_debug
380 : !!
381 : !! FUNCTION
382 : !! Show the content of the chunks on stdout
383 : !!
384 : !! SOURCE
385 :
386 0 : subroutine stream_debug(src)
387 : class(stream_string),intent(inout) :: src
388 : type(stream_chunk), pointer :: cursor
389 : integer :: c
390 0 : cursor => src%head
391 0 : c = 1
392 0 : do while (associated(cursor))
393 0 : write(std_out,*) "Chunk no", c
394 0 : write(std_out,'(A)') cursor%chunk
395 0 : cursor => cursor%next
396 0 : c = c + 1
397 : end do
398 0 : end subroutine stream_debug
399 : !!***
400 :
401 0 : end module m_stream_string
402 : !!***
|
