Context Navigation

strings.F90 @ 1808

Last change on this file since 1808 was 1808, checked in by jvatant, 7 years ago
Minor modifs : + correct a bug for ifort compiling in muphy + added some outputs for chemistry JVO
File size: 95.8 KB

Line
1	! Copyright Jérémie Burgalat (2017)
2	!
3	! burgalat.jeremie@gmail.com
4	!
5	! This software is a computer program whose purpose is to provide configuration
6	! file and command line arguments parsing features to Fortran programs.
7	!
8	! This software is governed by the CeCILL-B license under French law and
9	! abiding by the rules of distribution of free software. You can use,
10	! modify and/ or redistribute the software under the terms of the CeCILL-B
11	! license as circulated by CEA, CNRS and INRIA at the following URL
12	! "http://www.cecill.info".
13	!
14	! As a counterpart to the access to the source code and rights to copy,
15	! modify and redistribute granted by the license, users are provided only
16	! with a limited warranty and the software's author, the holder of the
17	! economic rights, and the successive licensors have only limited
18	! liability.
19	!
20	! In this respect, the user's attention is drawn to the risks associated
21	! with loading, using, modifying and/or developing or reproducing the
22	! software by the user in light of its specific status of free software,
23	! that may mean that it is complicated to manipulate, and that also
24	! therefore means that it is reserved for developers and experienced
25	! professionals having in-depth computer knowledge. Users are therefore
26	! encouraged to load and test the software's suitability as regards their
27	! requirements in conditions enabling the security of their systems and/or
28	! data to be ensured and, more generally, to use and operate it in the
29	! same conditions as regards security.
30	!
31	! The fact that you are presently reading this means that you have had
32	! knowledge of the CeCILL-B license and that you accept its terms.
33
34	!! file: strings.F90
35	!! summary: Strings manipulation source file
36	!! author: burgalat
37	!! date: 2017
38
39	#include "defined.h"
40
41	MODULE STRINGS
42	!! Fortran strings manipulation module
43	!!
44	!! This module provides methods and objects to manipulate Fortran (allocatable) strings. It defines
45	!! a doubly linked-list of strings, [[strings(module):words(type)]] and several methods to format
46	!! strings or convert them in other intrinsic types.
47	USE ERRORS
48	IMPLICIT NONE
49
50	PRIVATE
51
52	PUBLIC :: str2dble_sc,str2dble_ve,str2real_sc,str2real_ve
53	! errors module (not used but propagated)
54	PUBLIC :: noerror,error, error_to_string,aborting
55
56	! misc module methods
57	PUBLIC :: to_string, from_string, string_is, remove_quotes, format_string, &
58	format_paragraph, strip_newline, tokenize, str_length, str_endswith, &
59	str_startswith, str_to_lower, str_to_upper, str_add_attributes, &
60	str_delete_attributes, str_reset_attributes, str_remove, str_replace
61
62	! words object related methods
63	PUBLIC :: words_length, words_insert, words_append, words_prepend, words_get, &
64	words_set, words_get_max_width, words_get_total_width, words_pop, &
65	words_remove, words_next, words_previous, words_reset, &
66	words_valid, words_current, words_extend, words_reverse, &
67	words_reversed, words_dump, words_to_string, words_to_vector, &
68	new_words, words_clear
69
70	! Operators
71	PUBLIC :: ASSIGNMENT(=), OPERATOR(/=), OPERATOR(==)
72
73	INTEGER, PUBLIC, PARAMETER :: st_string = 1 !! String type ID
74	INTEGER, PUBLIC, PARAMETER :: st_logical = 2 !! Logical type ID
75	INTEGER, PUBLIC, PARAMETER :: st_complex = 3 !! Complex type ID
76	INTEGER, PUBLIC, PARAMETER :: st_integer = 4 !! Integer type ID
77	INTEGER, PUBLIC, PARAMETER :: st_real = 5 !! Real type ID
78
79	!> List of types names
80	CHARACTER(len=*), DIMENSION(5), PARAMETER, PUBLIC :: st_type_names = &
81	(/ 'string ', 'logical', 'complex', 'integer', 'real '/)
82
83	INTEGER, PUBLIC, PARAMETER :: st_slen = SSLEN !! Maximum short string length
84	INTEGER, PUBLIC, PARAMETER :: st_llen = SLLEN !! Maximum long string length
85
86	INTEGER, PUBLIC, PARAMETER :: FC_BLACK = 30 !! Black foreground csi code
87	INTEGER, PUBLIC, PARAMETER :: FC_RED = 31 !! Red foreground csi code
88	INTEGER, PUBLIC, PARAMETER :: FC_GREEN = 32 !! Green foreground csi code
89	INTEGER, PUBLIC, PARAMETER :: FC_YELLOW = 33 !! Yellow foreground csi code
90	INTEGER, PUBLIC, PARAMETER :: FC_BLUE = 34 !! Blue foreground csi code
91	INTEGER, PUBLIC, PARAMETER :: FC_MAGENTA = 35 !! Magenta foreground csi code
92	INTEGER, PUBLIC, PARAMETER :: FC_CYAN = 36 !! Cyan foreground csi code
93	INTEGER, PUBLIC, PARAMETER :: FC_WHITE = 37 !! White foreground csi code
94	INTEGER, PUBLIC, PARAMETER :: BG_BLACK = 40 !! Black foreground csi code
95	INTEGER, PUBLIC, PARAMETER :: BG_RED = 41 !! Black background csi code
96	INTEGER, PUBLIC, PARAMETER :: BG_GREEN = 42 !! Green background csi code
97	INTEGER, PUBLIC, PARAMETER :: BG_YELLOW = 43 !! Yellow background csi code
98	INTEGER, PUBLIC, PARAMETER :: BG_BLUE = 44 !! Blue background csi code
99	INTEGER, PUBLIC, PARAMETER :: BG_MAGENTA = 45 !! Magenta background csi code
100	INTEGER, PUBLIC, PARAMETER :: BG_CYAN = 46 !! Cyan background csi code
101	INTEGER, PUBLIC, PARAMETER :: BG_WHITE = 47 !! White background csi code
102	INTEGER, PUBLIC, PARAMETER :: ST_NORMAL = 0 !! Normal (regular) attribute
103	INTEGER, PUBLIC, PARAMETER :: ST_BOLD = 1 !! Bold (brighter) attribute
104	INTEGER, PUBLIC, PARAMETER :: ST_ITALIC = 3 !! Italic attribute (sometimes reverse video or underline)
105	INTEGER, PUBLIC, PARAMETER :: ST_UNDERLINE = 4 !! Underline attribute
106	INTEGER, PUBLIC, PARAMETER :: ST_BLINK = 5 !! Slow blink mode
107	!> List of all attributes in a vector
108	INTEGER, PUBLIC, PARAMETER, DIMENSION(21) :: attributes = [FC_BLACK, &
109	FC_RED, &
110	FC_GREEN, &
111	FC_YELLOW, &
112	FC_BLUE, &
113	FC_MAGENTA, &
114	FC_CYAN, &
115	FC_WHITE, &
116	BG_BLACK, &
117	BG_RED, &
118	BG_GREEN, &
119	BG_YELLOW, &
120	BG_BLUE, &
121	BG_MAGENTA, &
122	BG_CYAN, &
123	BG_WHITE, &
124	ST_NORMAL, &
125	ST_BOLD, &
126	ST_ITALIC, &
127	ST_UNDERLINE, &
128	ST_BLINK &
129	]
130
131	!> [[words(type)]] object assignement interface
132	INTERFACE ASSIGNMENT(=)
133	MODULE PROCEDURE ws_affect
134	END INTERFACE
135
136
137	!> [[words(type)]] interface constructor
138	!!
139	!! The interface encapsulates the two constructors of the words object:
140	!!
141	!! - [[new_words_1(function)]] initializes the object with a single word.
142	!! - [[new_words_str(function)]] initializes the object with a string that is
143	!! splitted according to a given delimiter.
144	INTERFACE new_words
145	MODULE PROCEDURE new_words_1, new_words_str
146	END INTERFACE
147
148	!> Clear either a scalar or a vector of list of [[words(type)]]
149	!!
150	!! The interface encapsulates words _destructors_, that deallocate memory used
151	!! by the given list(s) of words. This method should be called anytime words
152	!! object(s) is no longer used to avoid memory leaks.
153	!! @note
154	!! If the library support Derived type finalization, calling destructor is not
155	!! mandatory.
156	INTERFACE words_clear
157	MODULE PROCEDURE ws_clear_sc, ws_clear_ve
158	END INTERFACE
159
160	!> Extend a given [[words(type)]] object either by another or by a string
161	!!
162	!! The interface encapsulates two subroutines:
163	!!
164	!! - [[ws_extend_ws(subroutine)]](this,other) which extends __this__ by __other__
165	!! (both are words objects).
166	!! - [[ws_extend_str(subroutine)]](this,str,delimiter,merge) which splits __str__
167	!! according to __delimiter__ (and optionally __merge__) and then extends
168	!! __this__ with the resulting tokens.
169	INTERFACE words_extend
170	MODULE PROCEDURE ws_extend_ws,ws_extend_str
171	END INTERFACE
172
173	!> Convert an intrinsic type value to a string
174	!!
175	!! This (very) generic interface provides conversion functions from
176	!! intrinsic types to ALLOCATED string.
177	!!
178	!! ```
179	!! (1) FUNCTION to_string(value) RESULT(str)
180	!! (2) FUNCTION to_string(value,fmt,width) RESULT(str)
181	!! ```
182	!! Where :
183	!!
184	!! - __value__ is the value to convert
185	!! - __fmt__ is a string the format descriptor of the output string. Surrounding
186	!! parenthesis can be omitted.
187	!! - __width__ is an integer with the width of the output string (which should be given
188	!! in __fmt__ anyway).
189	!! - __str__ is an allocatable string with the converted value in output, or an empty
190	!! string if the conversion failed.
191	INTERFACE to_string
192	MODULE PROCEDURE int2str_as,int2str_fs
193	MODULE PROCEDURE log2str_as,log2str_fs
194	MODULE PROCEDURE real2str_as,real2str_fs
195	MODULE PROCEDURE dble2str_as,dble2str_fs
196	MODULE PROCEDURE cplx2str_as,cplx2str_fs
197	END INTERFACE
198
199	!> Convert a string into an intrisinc type
200	!!
201	!! All methods defined in the interface are functions which take in arguments,
202	!! a string (input) and an output variable with the relevant type (or vectors of both).
203	!! They always return an error object which is set to -5 error code (i.e. cannot cast value)
204	!! on error, otherwise [[errors(module):noerror(variable)]].
205	INTERFACE from_string
206	MODULE PROCEDURE str2int_sc,str2log_sc,str2real_sc,str2dble_sc,str2cplx_sc
207	MODULE PROCEDURE str2int_ve,str2log_ve,str2real_ve,str2dble_ve,str2cplx_ve
208	END INTERFACE
209
210	!> Define a linked word
211	!!
212	!! Linked words are only intended to be used within a words type.
213	!! It's part of the doubly linked list words.
214	TYPE, PUBLIC :: word
215	#if HAVE_FTNDTSTR
216	CHARACTER(len=:), ALLOCATABLE :: value !! Value of the word
217	#else
218	!> Value of the word
219	!!
220	!! @warning
221	!! It is always limited to strings::st_slen characters.
222	CHARACTER(len=st_slen) :: value = ''
223	#endif
224	TYPE(word), PRIVATE, POINTER :: next => null() !! Next word in the list of words
225	TYPE(word), PRIVATE, POINTER :: prev => null() !! Previous word in the list of words
226	END TYPE word
227
228	!> Define a list of words
229	TYPE, PUBLIC :: words
230	INTEGER :: nw = 0 !! Number of word in the list
231	TYPE(word), PRIVATE, POINTER :: head => null() !! First word in the list
232	TYPE(word), PRIVATE, POINTER :: tail => null() !! Last word in the list
233	TYPE(word), PRIVATE, POINTER :: iter => null() !! Current word (iterator)
234	#if HAVE_FTNPROC
235	CONTAINS
236	PROCEDURE, PRIVATE :: ws_extend_ws
237	PROCEDURE, PRIVATE :: ws_extend_str
238	PROCEDURE, PUBLIC :: length => words_length
239	!! Get the number of words in the list
240	PROCEDURE, PUBLIC :: insert => words_insert
241	!! Insert a word at given index
242	PROCEDURE, PUBLIC :: append => words_append
243	!! Append a word at the end of the list
244	PROCEDURE, PUBLIC :: prepend => words_prepend
245	!! Prepend a word at the beginning of the list
246	PROCEDURE, PUBLIC :: get => words_get
247	!! Get the word at given index
248	PROCEDURE, PUBLIC :: set => words_set
249	!! Set a word at given index
250	PROCEDURE, PUBLIC :: max_width => words_get_max_width
251	!! Get the width of the biggest word in the list
252	PROCEDURE, PUBLIC :: total_width => words_get_total_width
253	!! Get the total width of the words stored in the list
254	PROCEDURE, PUBLIC :: reverse => words_reverse
255	!! Reverse the list in place
256	PROCEDURE, PUBLIC :: reversed => words_reversed
257	!! Get a reversed copy of the list
258	PROCEDURE, PUBLIC :: dump => words_dump
259	!! Dump words of the list (on per line)
260	PROCEDURE, PUBLIC :: tostring => words_to_string
261	!! Convert the list in a single string
262	PROCEDURE, PUBLIC :: to_vector => words_to_vector
263	!! Convert the list in a vector
264	PROCEDURE, PUBLIC :: pop => words_pop
265	!! Pop a word from the list and returns it
266	PROCEDURE, PUBLIC :: remove => words_remove
267	!! Remove a word from the list
268	PROCEDURE, PUBLIC :: next => words_next
269	!! Go to the next word in the list
270	PROCEDURE, PUBLIC :: previous => words_previous
271	!! Go to the previous word in the list
272	PROCEDURE, PUBLIC :: reset => words_reset
273	!! Reset the list's iterator
274	PROCEDURE, PUBLIC :: valid => words_valid
275	!! Check if iterator position is valid
276	PROCEDURE, PUBLIC :: current => words_current
277	!! Get the current word in the list
278	GENERIC, PUBLIC :: extend => ws_extend_ws,ws_extend_str
279	!! Extend a list with either a string or another list of words
280	#endif
281	END TYPE words
282
283	CONTAINS
284
285	FUNCTION word_length(this) RESULT(lgth)
286	!! Get the trimmed length of the word object
287	TYPE(word), INTENT(in) :: this
288	!! A word object
289	INTEGER :: lgth
290	!! The length of the word's value (without trailing spaces)
291	#if HAVE_FTNDTSTR
292	IF (.NOT.ALLOCATED(this%value)) THEN
293	lgth = 0 ; RETURN
294	ENDIF
295	#endif
296	lgth = LEN_TRIM(this%value)
297	RETURN
298	END FUNCTION word_length
299
300	SUBROUTINE disconnect_word(this)
301	!! Disconnect a word object
302	!!
303	!! The object is no more connected to its neighbours which are connected together.
304	!! @note
305	!! After this method is called the object is no longer connected to its parent words
306	!! object and should be deallocated in order to avoid memory leaks.
307	TYPE(word), INTENT(inout) :: this
308	!! A word object to disconnect
309	TYPE(word), POINTER :: pw,nw
310	nw => this%next ; pw => this%prev
311	IF (ASSOCIATED(nw)) nw%prev => pw
312	IF (ASSOCIATED(pw)) pw%next => nw
313	RETURN
314	END SUBROUTINE disconnect_word
315
316	FUNCTION new_words_1(value) RESULT(list)
317	!! words constructor
318	!!
319	!! The method initializes a list of words with a single value.
320	CHARACTER(len=*), INTENT(in), OPTIONAL :: value
321	!! An optional string with the value to set in the list
322	TYPE(words) :: list
323	!! A words object
324	IF (PRESENT(value)) CALL ini_word(list,value)
325	RETURN
326	END FUNCTION new_words_1
327
328	FUNCTION new_words_str(string,delimiter,merge,protect) RESULT(list)
329	!! words constructor (extended version)
330	!!
331	!! The method splits an input strings and initializes a words object with the resulting tokens.
332	CHARACTER(len=*), INTENT(in) :: string
333	!! A string used to initialize the words object
334	CHARACTER(len=*), INTENT(in) :: delimiter
335	!! A string with the words delimiters.
336	!!
337	!! Note that each character is seen as a single delimiter.
338	LOGICAL, INTENT(in), OPTIONAL :: merge
339	!! An optional boolean control flag that instructs the method
340	!! wether to merge or not successive delimiters (default to .false.)
341	LOGICAL, INTENT(in), OPTIONAL :: protect
342	!! An optional boolean flag with .true. (default) to indicate that delimiter characters
343	!! between quotes are protected
344	TYPE(words) :: list
345	!! A new words object
346	CHARACTER(len=:), ALLOCATABLE :: seps
347	LOGICAL :: zmerge, zprotect
348	zmerge = .false. ; zprotect = .true. ; seps = ' '
349	IF (PRESENT(merge)) zmerge = merge
350	IF (PRESENT(protect)) zprotect = protect
351	IF (LEN(delimiter) > 0) seps = delimiter
352	CALL ws_extend_str(list,string,seps,zmerge,zprotect)
353	RETURN
354	END FUNCTION new_words_str
355
356	SUBROUTINE ws_affect(this,other)
357	!! words object assignment operator subroutine
358	TYPE(words), INTENT(out) :: this
359	!! A words object to be assigned
360	TYPE(words), INTENT(in) :: other
361	!! A words object to assign
362	TYPE(word), POINTER :: cur
363	CALL ws_clear_sc(this)
364	IF (other%nw == 0) THEN
365	RETURN
366	ELSE
367	cur => other%head
368	DO WHILE(associated(cur))
369	#if HAVE_FTNDTSTR
370	IF (.NOT.ALLOCATED(cur%value)) THEN
371	CALL words_append(this,"")
372	ELSE
373	CALL words_append(this,cur%value)
374	ENDIF
375	#else
376	CALL words_append(this,cur%value)
377	#endif
378	IF (ASSOCIATED(cur,other%iter)) this%iter => this%tail
379	cur => cur%next
380	ENDDO
381	ENDIF
382	RETURN
383	END SUBROUTINE ws_affect
384
385	SUBROUTINE ini_word(this,value)
386	!! Initialize the first word of a list of words
387	!!
388	!! This subroutine is not a constructor. It is only intended to set the first word
389	!! object in a words object.
390	TYPE(words), INTENT(inout) :: this
391	!! A words object reference
392	CHARACTER(len=*), INTENT(in) :: value
393	!! A string with the word used to initialize the list
394	ALLOCATE(this%head)
395	this%head%next => null()
396	this%head%prev => null()
397	this%tail => this%head
398	ASSIGN_DTSTR(value,this%tail%value)
399	this%nw = 1
400	RETURN
401	END SUBROUTINE ini_word
402
403	SUBROUTINE ws_clear_sc(obj)
404	!! Clear a list of words
405	!!
406	!! This subroutine deallocates all memory used by the given words object.
407	!! @warning
408	!! The subroutine should be called whenever a words is no more used (e.g. at
409	!! the end of the current scope), otherwise memory leaks could occur.
410	TYPE(words),INTENT(inout), TARGET :: obj
411	!! A words object to clear
412	TYPE(word), POINTER :: cur,next
413	IF (obj%nw == 0) RETURN
414	cur => obj%head
415	DO WHILE(ASSOCIATED(cur))
416	next => cur%next
417	CALL disconnect_word(cur)
418	#if HAVE_FTNDTSTR
419	IF (ALLOCATED(cur%value)) DEALLOCATE(cur%value)
420	#endif
421	DEALLOCATE(cur)
422	cur => next
423	ENDDO
424	obj%nw = 0
425	obj%head => null() ; obj%tail => null()
426	obj%iter => null()
427	END SUBROUTINE ws_clear_sc
428
429	SUBROUTINE ws_clear_ve(objs)
430	!! Clear a vector of list of words
431	!!
432	!! This subroutine deallocates all memory used by the given vector of words objects.
433	!! @warning
434	!! The subroutine should be called whenever a words is no more used (e.g. at the end
435	!! of the current scope), otherwise memory leaks could occur.
436	TYPE(words),INTENT(inout), DIMENSION(:) :: objs
437	!! A vector of words objects to clear
438	TYPE(word), POINTER :: cur,next
439	INTEGER :: i
440	DO i=1,SIZE(objs)
441	IF (objs(i)%nw == 0) CYCLE
442	cur => objs(i)%head
443	DO WHILE(ASSOCIATED(cur))
444	next => cur%next
445	CALL disconnect_word(cur)
446	DEALLOCATE(cur)
447	cur => next
448	ENDDO
449	objs(i)%nw = 0
450	objs(i)%head => null() ; objs(i)%tail => null()
451	ENDDO
452	END SUBROUTINE ws_clear_ve
453
454	SUBROUTINE ws_extend_ws(this, other)
455	!! Extend a list of words with another one
456	OBJECT(words), INTENT(inout) :: this
457	!! A words object to extend
458	TYPE(words), INTENT(in) :: other
459	!! A words object to extend with
460	TYPE(word), POINTER :: cw
461	IF (other%nw == 0) RETURN
462	cw => other%head
463	DO WHILE(ASSOCIATED(cw))
464	CALL words_append(this,cw%value) ; cw => cw%next
465	ENDDO
466	RETURN
467	END SUBROUTINE ws_extend_ws
468
469	SUBROUTINE ws_extend_str(this,str,delimiter,merge,protect)
470	!> Extend a list of word with a given string
471	!! @details The method adds a new list of words to the current list by
472	!! splitting a string using a set of delimiters.
473	!!
474	!! - If __delimiter__ is not given, THEN blank space is used.
475	!! - __delimiter__ can be a string of any length, but each character of
476	!! the sequence is seen as a single delimiter. Each time one of these
477	!! special character is seen on the string, it is splitted.
478	!! - If __protect__ is set to .true. THEN delimiter enclosed by
479	!! either single or double quotes are protected.
480	!! - The optional argument __merge__ instructs the method wether to merge
481	!! or not successive delimiters in the string.
482	!!
483	!! For example, considering the following string:
484	!! <center>@verbatim "I like coffee and bananas." @endverbatim</center>
485	!! - Used with only __delimiter__ = " e", the method returns the list:
486	!! <center>"I","lik","","coff","","","and","bananas"</center>
487	!! - Used with both __delimiter__ = " e" and __merge__ = .true. :
488	!! <center>"I","lik","coff","and","bananas"</center>
489	!! @warning
490	!! The method does not trim or adjust the input string. Consequently, it can
491	!! add several empty words at the end of the list if the string is not well
492	!! defined.
493	!! @warning To avoid such problems, consider using TRIM() and ADJUSTL()
494	!! function on __str__ actual argument when calling this subroutine.
495	OBJECT(words), INTENT(inout), TARGET :: this
496	!! A words object to extend
497	CHARACTER(len=*), INTENT(in) :: str
498	!! A string to split in words
499	CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter
500	!! An optional string with the words delimiters (default to blank space).
501	LOGICAL, INTENT(in), OPTIONAL :: merge
502	!! An optional boolean control flag that instructs the method
503	!! wether to merge or not successive delimiters (default to .false.)
504	LOGICAL, INTENT(in), OPTIONAL :: protect
505	!! An optional boolean flag with .true. to indicate that
506	!! delimiter characters between quotes are protected
507	! - LOCAL
508	INTEGER :: sl,p,i,j,stat
509	LOGICAL :: zmerge,zprotect,indq,insq,outer
510	CHARACTER(len=:), ALLOCATABLE :: seps
511	CHARACTER(len=:), ALLOCATABLE :: curw
512	CHARACTER(len=1), PARAMETER :: sq = CHAR(39) ! single quote ascii code
513	CHARACTER(len=1), PARAMETER :: dq = CHAR(34) ! double quotes ascii code
514	stat=0 ; p=1 ; indq = .false. ; insq = .false.
515	seps = ' '
516	zmerge = .false. ; IF (PRESENT(merge)) zmerge = merge
517	zprotect = .true. ; IF (PRESENT(protect)) zprotect = protect
518	IF (PRESENT(delimiter)) THEN
519	IF (LEN(delimiter) > 0) seps = delimiter
520	ENDIF
521	sl = LEN(str) ; IF (sl == 0) RETURN
522	outer = (INDEX(str,sq) == 1 .AND. INDEX(str,sq,.true.) == LEN(str)) &
523	.OR.(INDEX(str,dq) == 1 .AND. INDEX(str,dq,.true.) == LEN(str))
524	! no delimiter found or (have outer quotes and should protect)
525	IF (SCAN(str,seps) == 0.OR.(outer.AND.zprotect)) THEN
526	CALL words_append(this,remove_quotes(str))
527	RETURN
528	ENDIF
529	! We have to loop...
530	i = 1 ; curw=''
531	DO
532	IF (i > sl) EXIT
533	p = SCAN(str(i:),seps)
534	IF (p == 0) THEN
535	! a gerer
536	curw = curw//TRIM(str(i:))
537	CALL words_append(this,TRIM(str(i:))) ; EXIT
538	curw=''
539	ELSE
540	IF (zprotect) THEN
541	j=i
542	! starting state
543	DO WHILE(j<i+p)
544	IF (str(j:j) == sq.AND. .NOT.indq) insq = .NOT.insq
545	IF (str(j:j) == dq.AND. .NOT.insq) indq = .NOT.indq
546	j = j+1
547	ENDDO
548	IF ((insq.AND.INDEX(str(j:),"'")/=0) .OR. &
549	(indq.AND.INDEX(str(j:),'"')/=0)) THEN
550	curw=curw//str(i:i+p-1)
551	i=i+p ; CYCLE
552	ENDIF
553	ENDIF
554	IF (p == 1) THEN
555	IF (.NOT.zmerge) THEN
556	curw=''
557	CALL words_append(this,curw)
558	ENDIF
559	i = i + 1 ; CYCLE
560	ELSE
561	curw=curw//str(i:i+p-2)
562	CALL words_append(this,curw)
563	curw = ''
564	i = i + p
565	ENDIF
566	ENDIF
567	ENDDO
568	IF (zprotect) THEN
569	! catching unbalanced quotes
570	IF (insq .OR. indq) &
571	WRITE(*,'(a)') "extends:warning: unbalanced quotes"
572	ENDIF
573	RETURN
574	END SUBROUTINE ws_extend_str
575
576	FUNCTION ws_get_ptr(this,idx) RESULT(pted)
577	!! Get the pointer of the word object at given index
578	!!
579	!! The method returns the pointer of the word object at the given index.
580	!! If index is out of range a null poitner is returned.
581	OBJECT(words), INTENT(in) :: this
582	!! A words object
583	INTEGER, INTENT(in) :: idx
584	!! An integer with the index of the desired object in __this__
585	TYPE(word), POINTER :: pted
586	!! A pointer to the selected word object.
587	INTEGER :: i
588	pted => null()
589	IF (idx < 1 .OR. idx > words_length(this)) THEN
590	RETURN
591	ENDIF
592	IF (idx > (this%nw+1)/2) THEN
593	pted => this%tail
594	DO i=1,this%nw - idx ; pted => pted%prev ; ENDDO
595	ELSE
596	pted => this%head
597	DO i=1,idx-1 ; pted => pted%next ; ENDDO
598	ENDIF
599	RETURN
600	END FUNCTION ws_get_ptr
601
602	FUNCTION words_length(this) RESULT(res)
603	!! Get the size of the words object.
604	!!
605	!! The method returns the number of words stored in the given list of words.
606	OBJECT(words), INTENT(in) :: this !! A words object.
607	INTEGER :: res !! The number of words in the object.
608	res = this%nw
609	RETURN
610	END FUNCTION words_length
611
612	SUBROUTINE words_insert(this, idx, value)
613	!! Insert a word before given index in a list of words.
614	!!
615	!! The method inserts a new word before the given index in the list of words. If the given index is out
616	!! of range, the method prepends/appends the object based on the index value.
617	OBJECT(words), INTENT(inout) :: this
618	!! A words object.
619	INTEGER, INTENT(in) :: idx
620	!! An integer with the index of an object in the list. The new object will be inserted before that index.
621	CHARACTER(len=*), INTENT(in) :: value
622	!! A string with the word to insert in the list.
623	TYPE(word), POINTER :: welt,nx,pv
624	INTEGER :: i
625	welt => null() ; nx => null() ; pv => null()
626	IF (this%nw == 0) THEN
627	CALL ini_word(this,value)
628	ELSE IF (idx > this%nw) THEN
629	this%nw = this%nw + 1
630	welt => this%tail
631	allocate(this%tail)
632	ASSIGN_DTSTR(value,this%tail%value)
633	this%tail%prev => welt
634	this%tail%prev%next => this%tail
635	ELSE IF (idx <= 1) THEN
636	this%nw = this%nw + 1
637	welt => this%head
638	allocate(this%head)
639	ASSIGN_DTSTR(value,this%head%value)
640	this%head%next => welt
641	this%head%next%prev => this%head
642	ELSE
643	IF (idx > (this%nw+1)/2) THEN
644	nx => this%tail
645	DO i=1, this%nw - idx ; nx => nx%prev ; ENDDO
646	ELSE
647	nx => this%head
648	DO i=1, idx-1 ; nx => nx%next ; ENDDO
649	ENDIF
650	pv => nx%prev
651	allocate(welt)
652	ASSIGN_DTSTR(value,welt%value)
653	welt%prev => pv ; welt%next => nx
654	pv%next => welt ; nx%prev => welt
655	this%nw = this%nw + 1
656	ENDIF
657	RETURN
658	END SUBROUTINE words_insert
659
660	SUBROUTINE words_append(this,value)
661	!! Append a word to the list of word
662	!!
663	!! The method appends a word to the list of word. This is a convinient wrapper to
664	!! [[strings(module)::words_insert(subroutine)] to add a new word at the beginning of the list.
665	OBJECT(words), INTENT(inout) :: this !! A words object
666	CHARACTER(len=*), INTENT(in) :: value !! A string to append
667	CALL words_insert(this,this%nw+1,value)
668	RETURN
669	END SUBROUTINE words_append
670
671	SUBROUTINE words_prepend(this,value)
672	!! Prepend a word to the list of word
673	!!
674	!! The method prepends a word to the list of word. This is a convinient wrapper to
675	!! [[strings(module)::words_insert(subroutine)]] to add a new word at the end of the list.
676	OBJECT(words), INTENT(inout) :: this !! A words object
677	CHARACTER(len=*), INTENT(in) :: value !! A string to prepend
678	CALL words_insert(this,0,value)
679	RETURN
680	END SUBROUTINE words_prepend
681
682	FUNCTION words_get(this,idx,case) RESULT (res)
683	!! Get the word's value at given index
684	!!
685	!! The method attempts to get the word's value at the given index. If index is out of range
686	!! an empty string is returned.
687	!! @note
688	!! The returned string is always trimmed.
689	OBJECT(words), INTENT(in) :: this
690	!! A words object reference
691	INTEGER, INTENT(in) :: idx
692	!! An integer with the index of a word in the list
693	CHARACTER(len=5), INTENT(in), OPTIONAL :: case
694	!! An optional string with either 'upper' or 'lower' to get the value converted in the relevant case
695	CHARACTER(len=:), ALLOCATABLE :: res
696	!! The value of the word stored at given index in the list of words
697	TYPE(word), POINTER :: cur
698	cur => ws_get_ptr(this,idx)
699	IF (.not.associated(cur)) THEN
700	res = '' ; RETURN
701	ENDIF
702	IF (PRESENT(case)) THEN
703	IF (case == "upper") res = str_to_upper(cur%value)
704	IF (case == "lower") res = str_to_lower(cur%value)
705	ELSE
706	res = TRIM(cur%value)
707	ENDIF
708	RETURN
709	END FUNCTION words_get
710
711	SUBROUTINE words_set(this,idx,value)
712	!! Set a new value to a word object in the list of words at given index
713	!!
714	!! The method sets a new word at given index. If index is out of range, the method simply does nothing.
715	OBJECT(words), INTENT(inout) :: this !! A words object
716	INTEGER, INTENT(in) :: idx !! An integer with the index of the word object to modify in the list
717	CHARACTER(len=*), INTENT(in) :: value !! A string with the new value to set
718	TYPE(word), POINTER :: cur
719	cur => ws_get_ptr(this,idx)
720	IF (.NOT.ASSOCIATED(cur)) RETURN
721	cur%value = value
722	END SUBROUTINE words_set
723
724	FUNCTION words_get_max_width(this) RESULT(res)
725	!! Get the longest word's width in the words object
726	!!
727	!! The method computes and returns the longest (trimmed) word's width in the words object.
728	OBJECT(words), INTENT(in) :: this !! A words object
729	INTEGER :: res !! An integer with the maximum width (0 if the list is empty)
730	TYPE(word), POINTER :: cur
731	res = 0
732	IF (this%nw == 0) RETURN
733	cur => this%head ; res = word_length(cur)
734	DO WHILE(ASSOCIATED(cur%next))
735	cur => cur%next
736	IF (word_length(cur) > res) res = word_length(cur)
737	ENDDO
738	RETURN
739	END FUNCTION words_get_max_width
740
741	FUNCTION words_get_total_width(this) RESULT(width)
742	!! Get the total width of all words stored in the list of words
743	!!
744	!! The method computes and returns the total width of all words stored in
745	!! the list of words.
746	!! @note
747	!! Total width is computed using strings::word_length so it only takes
748	!! into account trimmed words (without trailing blanks)
749	!! @note
750	!! If csi codes have been added to words elements they are counted in the width.
751	OBJECT(words), INTENT(in) :: this !! A words object
752	INTEGER :: width !! Total length of the list of words
753	TYPE(word), POINTER :: cur
754	width = 0
755	IF (this%nw == 0) RETURN
756	cur => this%head ; width = word_length(cur)
757	DO WHILE(ASSOCIATED(cur%next))
758	cur => cur%next
759	width = width + word_length(cur)
760	ENDDO
761	cur => null()
762	RETURN
763	END FUNCTION words_get_total_width
764
765	SUBROUTINE words_reverse(this)
766	!! Reverse the list of words in-place
767	OBJECT(words), INTENT(inout) :: this
768	!! A words object to reverse
769	TYPE(word), POINTER :: loop,iwc,iwp
770	IF (this%nw <= 1) RETURN
771	loop => this%head ; iwc=> this%head ; iwp=> null()
772	DO WHILE(ASSOCIATED(loop%next))
773	loop => loop%next
774	iwp => iwc%prev ; iwc%prev => iwc%next ; iwc%next => iwp
775	iwc => loop
776	ENDDO
777	iwp=>this%tail%prev ; this%tail%prev=>this%tail%next ; this%tail%next=>iwp
778	iwc => this%head ; this%head => this%tail ; this%tail => iwc
779	loop => null() ; iwc => null() ; iwp => null()
780	RETURN
781	END SUBROUTINE words_reverse
782
783	FUNCTION words_reversed(this) RESULT(res)
784	!! Get a reversed copy of the list of words
785	OBJECT(words), INTENT(in) :: this
786	!! A words object to reverse
787	TYPE(words) :: res
788	!! A reversed copy of the input list of words
789	TYPE(word),POINTER :: cur
790	IF(this%nw == 0) RETURN
791	cur => this%tail
792	DO WHILE(ASSOCIATED(cur))
793	CALL words_append(res,cur%value)
794	IF (ASSOCIATED(cur,this%iter)) res%iter => res%tail
795	cur => cur%prev
796	ENDDO
797	cur => null()
798	RETURN
799	END FUNCTION words_reversed
800
801	SUBROUTINE words_dump(this,lun)
802	!! Dump the list of words
803	!!
804	!! The method dumps on the given logical unit the elements of the list one by line.
805	OBJECT(words), INTENT(in) :: this
806	!! A words object to dump
807	INTEGER, INTENT(in), OPTIONAL :: lun
808	!! An optional integer with the printing logical unit. If not given, the list is dumped on
809	!! standard output stream.
810	TYPE(word), POINTER :: cur
811	INTEGER :: lu
812	IF (this%nw == 0) RETURN
813	lu=6 ; IF (PRESENT(lun)) lu = lun
814	cur => this%head
815	DO WHILE(ASSOCIATED(cur))
816	WRITE(lu,'(a)') TRIM(cur%value)
817	cur => cur%next
818	ENDDO
819	cur => null()
820	RETURN
821	END SUBROUTINE words_dump
822
823	FUNCTION words_to_string(this, delimiter) RESULT(str)
824	!! Convert the list of words into a string
825	!!
826	!! The method converts the list of words into a string. In output, string is always
827	!! allocated even if the list is empty.
828	OBJECT(words), INTENT(in) :: this
829	!! A words object
830	CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter
831	!! An optional string used as delimiter between each words
832	CHARACTER(len=:), ALLOCATABLE :: str
833	!! An allocatable string with the list of words joined by the given delimiter (if any)
834	TYPE(word), POINTER :: cur
835	str = ''
836	IF (this%nw == 0) RETURN
837	cur => this%head
838	DO WHILE(ASSOCIATED(cur))
839	str=str//TRIM(cur%value)
840	IF (PRESENT(delimiter).AND..NOT.ASSOCIATED(cur,this%tail)) &
841	str=str//delimiter
842	cur => cur%next
843	ENDDO
844	RETURN
845	END FUNCTION words_to_string
846
847	FUNCTION words_to_vector(this,ret) RESULT(ok)
848	!! Convert the list of words into a vector of strings
849	!!
850	!! The method attempts to convert the list of words in a vector of strings.
851	!! If _this_ list of words is empty the output vector is allocated with 0 elements and the method returns
852	!! .false.. Otherwise it returns .true.
853	!! @note
854	!! If the size of the output string vector (i.e. the character length of the string elements within the
855	!! vector) is too small, words can be truncated.
856	OBJECT(words), INTENT(in) :: this
857	!! A words object reference
858	CHARACTER(len=st_slen), INTENT(out), ALLOCATABLE, DIMENSION(:) :: ret
859	!! An allocatable vector of assumed length string with the words of __this__
860	LOGICAL :: ok
861	!! Return status.
862	INTEGER :: l,mw
863	TYPE(word), POINTER :: iw
864	ok = .true.
865	l = words_length(this)
866	IF (l == 0) THEN
867	ALLOCATE(ret(0))
868	ok = .false.
869	RETURN
870	ENDIF
871	ALLOCATE(ret(l)) ; mw = LEN(ret(l))
872	ret(1:l) = ' ' ! really needed ?
873	iw => this%head ; l=1
874	DO WHILE(ASSOCIATED(iw))
875	ret(l) = TRIM(iw%value) ; l=l+1 ; iw => iw%next
876	ENDDO
877	END FUNCTION words_to_vector
878
879	FUNCTION words_pop(this,idx,move_forward) RESULT(value)
880	!! Pop a word in the list of words
881	!!
882	!! The method removes the word of the list at given index and returns it. If no index is given,
883	!! last word of the list is removed.
884	!!
885	!! If the index is out of range, the method does nothing and returns an empty string.
886	!!
887	!! By default, if the iterator is located on the item to be removed, it is moved backward before
888	!! deletion occurs. If __move\_forward__ is set to .true., the iterator is moved forward.
889	OBJECT(words), INTENT(inout) :: this
890	!! A words object
891	INTEGER, INTENT(in), OPTIONAL :: idx
892	!! Optional index of the word to delete
893	LOGICAL, INTENT(in), OPTIONAL :: move_forward
894	!! Move the iterator forward if needed. By default the iterator is moved backward.
895	CHARACTER(len=:), ALLOCATABLE :: value
896	!! The word's value at given index
897	LOGICAL :: zforward
898	INTEGER :: zidx
899	TYPE(word), POINTER :: cur
900	zidx=words_length(this) ; IF (PRESENT(idx)) zidx = idx
901	zforward = .false. ; IF (PRESENT(move_forward)) zforward = move_forward
902	cur => ws_get_ptr(this,zidx)
903	IF (.NOT.ASSOCIATED(cur)) THEN
904	value = '' ; RETURN
905	ELSE IF (ASSOCIATED(cur,this%iter)) THEN
906	IF (zforward) THEN
907	CALL words_next(this)
908	ELSE
909	CALL words_previous(this)
910	ENDIF
911	ENDIF
912	value = TRIM(cur%value)
913	CALL disconnect_word(cur)
914	DEALLOCATE(cur)
915	this%nw = this%nw - 1
916	RETURN
917	END FUNCTION words_pop
918
919	SUBROUTINE words_remove(this,idx,move_forward)
920	!! Remove the word of the list at given index
921	!!
922	!! The method removes the word of the list at given index. If no index is given, last word
923	!! of the list is removed.
924	!!
925	!! If the index is out of range, the method does nothing.
926	!!
927	!! By default, if the iterator is located on the item to be removed, it is moved backward before
928	!! deletion occurs. If __move\_forward__ is set to .true., the iterator is moved forward.
929	OBJECT(words), INTENT(inout) :: this
930	!! A words object
931	INTEGER, INTENT(in), OPTIONAL :: idx
932	!! Index of the word to delete
933	LOGICAL, INTENT(in), OPTIONAL :: move_forward
934	!! Move the iterator forward if needed. By default the iterator is moved backward.
935	LOGICAL :: zforward
936	INTEGER :: zidx
937	TYPE(word), POINTER :: cur
938	zidx=words_length(this) ; IF(PRESENT(idx)) zidx = idx
939	zforward = .false. ; IF (PRESENT(move_forward)) zforward = move_forward
940	cur => ws_get_ptr(this,idx)
941	IF (.NOT.ASSOCIATED(cur)) THEN
942	RETURN
943	ELSE IF (ASSOCIATED(cur,this%iter)) THEN
944	IF (zforward) THEN
945	CALL words_next(this)
946	ELSE
947	CALL words_previous(this)
948	ENDIF
949	ENDIF
950	CALL disconnect_word(cur)
951	DEALLOCATE(cur)
952	this%nw = this%nw - 1
953	RETURN
954	END SUBROUTINE words_remove
955
956	SUBROUTINE words_next(this)
957	!! Go to the next word in the list
958	OBJECT(words), INTENT(inout) :: this !! A words object
959	IF (ASSOCIATED(this%iter)) this%iter => this%iter%next
960	END SUBROUTINE words_next
961
962	SUBROUTINE words_previous(this)
963	!! Go to the previous word in the list
964	OBJECT(words), INTENT(inout) :: this !! A words object
965	IF (ASSOCIATED(this%iter)) this%iter => this%iter%prev
966	END SUBROUTINE words_previous
967
968	FUNCTION words_valid(this) RESULT(ret)
969	!! Check if the current iterated word is valid
970	OBJECT(words), INTENT(in) :: this !! A words object
971	LOGICAL :: ret !! A logical flag with .true. if the current iterated word is valid
972	ret = associated(this%iter)
973	END FUNCTION words_valid
974
975	FUNCTION words_current(this) RESULT(wrd)
976	!! Get current word value
977	OBJECT(words), INTENT(in) :: this
978	!! A words object
979	CHARACTER(len=:), ALLOCATABLE :: wrd
980	!! A string with the value of the current word or __an unallocated string__ if current word
981	!! is not valid (see [[strings(module):words_valid(function)]]).
982	IF (ASSOCIATED(this%iter)) THEN
983	wrd = this%iter%value
984	ENDIF
985	END FUNCTION words_current
986
987	SUBROUTINE words_reset(this,to_end)
988	!! Reset the iterator
989	!!
990	!! The method resets the iterator either at the beginning or at the end of the list of words
991	!! (if __to_end__ is set to .true.).
992	OBJECT(words), INTENT(inout) :: this !! A words object
993	LOGICAL, INTENT(in), OPTIONAL :: to_end !! An optional logical flag with .true. to reset the iterator at the end of the list
994	this%iter => this%head
995	IF (PRESENT(to_end)) THEN
996	IF (to_end) this%iter => this%tail
997	ENDIF
998	END SUBROUTINE words_reset
999
1000	! Fancy string methods
1001	! --------------------
1002
1003	FUNCTION tokenize(str,vector,delimiter,merge,protect) RESULT(ok)
1004	!! Tokenize a string.
1005	CHARACTER(len=*), INTENT(in) :: str
1006	!! A string to tokenize
1007	CHARACTER(len=*), INTENT(out), DIMENSION(:), ALLOCATABLE :: vector
1008	!! An allocatable vector of strings with the tokens found. If string cannot be tokenized,
1009	!! the vector is __allocated to 0 elements__ and the method returns .false..
1010	CHARACTER(len=*), INTENT(in), OPTIONAL :: delimiter
1011	!! An optional string with the words delimiters. It is set to blank space by default.
1012	!! Note that each character is seen as a single delimiter.
1013	LOGICAL, INTENT(in), OPTIONAL :: merge
1014	!! An optional boolean control flag with .true. that instructs the method wether to
1015	!! merge or not successive delimiters.
1016	LOGICAL, INTENT(in), OPTIONAL :: protect
1017	!! An optional boolean flag with .true. to indicate that delimiter characters between
1018	!! quotes are protected.
1019	LOGICAL :: ok
1020	!! Return status (.true. on success)
1021	CHARACTER(len=:), ALLOCATABLE :: seps
1022	TYPE(words) :: tmp
1023	LOGICAL :: zmerge,zprotect
1024	zmerge = .false. ; zprotect = .true. ; seps = ' '
1025	IF (PRESENT(merge)) zmerge = merge
1026	IF (PRESENT(protect)) zprotect = protect
1027	IF (PRESENT(delimiter)) THEN
1028	IF (LEN(delimiter) > 0 ) seps = delimiter
1029	ENDIF
1030	tmp = new_words_str(str,seps,zmerge,zprotect)
1031	ok = words_to_vector(tmp,vector)
1032	CALL ws_clear_sc(tmp)
1033	RETURN
1034	END FUNCTION tokenize
1035
1036	FUNCTION remove_quotes(str) RESULT(ostr)
1037	!! Strips outer quotes from string
1038	!!
1039	!! The function removes only external quotes from the input string
1040	!! and returns the result in an allocatable string.
1041	!! Quotes are removed only if they are the first and last non blank
1042	!! characters. Either double and single quotes are stripped without distinction.
1043	!! The output string is trimmed from leading and trailing blank spaces
1044	CHARACTER(len=*), INTENT(in) :: str !! A string to check
1045	CHARACTER(len=:), ALLOCATABLE :: ostr !! A string without external quotes (if any).
1046	CHARACTER(len=1), PARAMETER :: sq=CHAR(39), dq=CHAR(34)
1047	CHARACTER(len=2), PARAMETER :: dsq=CHAR(39)//CHAR(34)
1048	INTEGER :: i, j
1049	IF (LEN_TRIM(str) == 0) RETURN
1050	ostr = TRIM(ADJUSTL(str))
1051	i = SCAN(ostr,sq//dq) ; j = SCAN(ostr,sq//dq,.true.)
1052	IF (i == j) RETURN
1053	IF (i /= 1) i = 0
1054	IF (j /= LEN(ostr)) j = LEN(ostr)+1
1055	ostr = ostr(i+1:j-1)
1056	RETURN
1057	END FUNCTION remove_quotes
1058
1059	FUNCTION string_is(str) RESULT(ret)
1060	!! Check if string represents an intrinsic type
1061	!!
1062	!! The method checks if the given string represents an intrinsic type. Both logical and complex type
1063	!! are checked in a strict way :
1064	!!
1065	!! - A string is a logical if it is one of the following value: __.false.__, __.true.__, __F__, __T__.
1066	!! - A string is potentially a complex if it has the following format: __(\\\,\\\)__ where
1067	!! __\\\*__ is checked to see wether it is numerical or not.
1068	!!
1069	!! Valid numerical values can take the following forms:
1070	!! ```
1071	!! [0-9]
1072	!! [0-9].?[0-9]?([ed][+-]?[0-9]+)?
1073	!! ```
1074	!! Obviously if returned value is greater than 3, the string can be converted in
1075	!! floating point value.
1076	!!
1077	!! Empty input string is simply considered to be of string type !
1078	CHARACTER(len=*), INTENT(in) :: str
1079	!! A string to check
1080	INTEGER :: ret
1081	!! An integer with the intrinsic type related to the string.
1082	!!
1083	!! Types are one of the following parameters
1084	!!
1085	!! - [[strings(module):st_string(variable)]] (1) for string
1086	!! - [[strings(module):st_logical(variable)]] (2) for logical
1087	!! - [[strings(module):st_complex(variable)]] (3) for complex
1088	!! - [[strings(module):st_integer(variable)]] (4) for integer
1089	!! - [[strings(module):st_real(variable)]] (5) for floating point value
1090	CHARACTER(len=:), ALLOCATABLE :: zs,zzs
1091	INTEGER :: j,l
1092	ret = 1 ; IF (LEN_TRIM(str) == 0) RETURN
1093	zs = str_to_lower(TRIM(ADJUSTL(str))) ; j = INDEX(zs,',') ; l = len(zs)
1094	IF (zs(1:1)=='('.AND.zs(l:l) == ')'.AND.j==INDEX(zs,',')) THEN
1095	IF (j == 2 .OR. j == l-1) RETURN
1096	zzs = TRIM(ADJUSTL(zs(2:j-1))) ; IF (what_(zzs) < 3) RETURN
1097	zzs = TRIM(ADJUSTL(zs(j+1:l-1))) ; ret = what_(zzs)
1098	IF (ret > 3) THEN ; ret = 3 ; ELSE ; ret = 1 ; ENDIF
1099	ELSE
1100	ret = what_(zs)
1101	ENDIF
1102	CONTAINS
1103	FUNCTION what_(s) RESULT(is)
1104	!! Check if the given string is numerical, logical or a simple string
1105	!! @note
1106	!! Input string should be in lower case, otherwise, the method will give a a wrong result.
1107	!! @warning
1108	!! The test performed for logical checking is quite strict : A string is considered as logical
1109	!! if and only if it is one of the following values : __.false.__, __.true.__, __F__, __T__.
1110	CHARACTER(len=*), INTENT(in) :: s
1111	!! A string to check
1112	INTEGER :: is
1113	!! An integer with : __1__ for string, __2__ for logical, __4__ for integer and __5__ for real
1114	LOGICAL :: dec,fdot,fexp
1115	INTEGER :: i
1116	CHARACTER(len=24), PARAMETER :: aset='abcfghijklmnopqrstuvwxyz'
1117	CHARACTER(len=10), PARAMETER :: iset='1234567890'
1118	CHARACTER(len=2), PARAMETER :: dset='ed'
1119	CHARACTER(len=2), PARAMETER :: sset='+-'
1120	CHARACTER(len=7), PARAMETER :: slog(4) = (/'.true. ','.false.',&
1121	't ','f '/)
1122	is = -1 ; dec = .false. ; fdot = dec ; fexp = fdot
1123	DO i = 1,LEN(s)
1124	IF (i == 1) THEN
1125	! string does not start by [+-\.\d]
1126	IF (VERIFY(s(i:i),'.'//iset//sset) /= 0) THEN
1127	is = 1 ; EXIT
1128	ENDIF
1129	! update control flag for decimal part
1130	dec = s(i:i) == '.' ; fdot = dec
1131	ELSE
1132	! check if char is in [a-z]
1133	IF(VERIFY(s(i:i),aset) == 0) THEN
1134	dec=.false. ; is = 1 ; EXIT
1135	ELSE IF (s(i:i) == '.') THEN
1136	! check for dot in decimal/exponent part (==> not a number
1137	IF (fdot.OR.fexp) THEN
1138	dec = .false. ; is = 1 ; EXIT
1139	ENDIF
1140	ELSE IF (VERIFY(s(i:i),dset)==0) THEN
1141	IF (fexp) THEN
1142	dec = .false. ; is = 1 ; EXIT
1143	ENDIF
1144	ELSE IF (VERIFY(s(i:i),sset) == 0) THEN
1145	IF (VERIFY(s(i-1:i-1),dset) /= 0) THEN
1146	dec = .false. ; is = 1 ; EXIT
1147	ENDIF
1148	ENDIF
1149	fdot = (fdot .OR. s(i:i) == '.')
1150	fexp = (fexp .OR. VERIFY(s(i:i), dset) == 0)
1151	ENDIF
1152	ENDDO
1153	! it is a string
1154	IF (is == 1) THEN
1155	! but have the format of a logical
1156	IF (any(slog == s)) is = 2
1157	ELSE
1158	IF ((fexp.AND.SCAN(s(LEN(s):LEN(s)),dset) /= 0)) THEN
1159	is = 1
1160	ELSE
1161	is = 4
1162	IF (fdot.OR.fexp) is = 5
1163	ENDIF
1164	ENDIF
1165	END FUNCTION what_
1166	END FUNCTION string_is
1167
1168	FUNCTION format_string(str,idt1,idto) RESULT(output)
1169	!! Format the given string
1170	!!
1171	!! This function only replaces all '\\n' escape sequence in the given string by NEW_LINE() character.
1172	!! The output string is eventually indented if optional arguments are set.
1173	!! @warning
1174	!! __idto__ is relative to __idt1__ !
1175	CHARACTER(len=*), INTENT(in) :: str !! The string to format
1176	INTEGER, INTENT(in), OPTIONAL :: idt1, & !! An optional integer with the indentation level of the first output line (default to 0)
1177	idto !! An optional integer with the indentation level of all other output lines (default to 0)
1178	CHARACTER(len=:), ALLOCATABLE :: output !! An allocatable string with the output formatted string.
1179	! - LOCAL
1180	INTEGER :: i,c,ti,mx
1181	CHARACTER(len=:), ALLOCATABLE :: idts
1182	IF (LEN_TRIM(str) == 0) THEN
1183	ALLOCATE(output,source='') ; RETURN
1184	ENDIF
1185	i=0 ; IF (PRESENT(idt1)) i = MAX(i,idt1)
1186	ALLOCATE(CHARACTER(len=i) :: output)
1187	IF (i > 0) output(1:i) = CHAR(32)
1188	! i0 is relative to i1 and must be >= 0
1189	IF (PRESENT(idto)) i = MAX(i+idto,0)
1190	ALLOCATE(CHARACTER(len=i+1) :: idts)
1191	idts(1:1) = NEW_LINE('A') ; IF (i>1) idts(2:) = CHAR(32)
1192	! Builds output string
1193	c=1 ; mx = LEN_TRIM(str)
1194	i = INDEX(str(c:),'\n') ; ti = c+i-1
1195	IF (i == 0) THEN
1196	output=output//TRIM(str(ti+1:mx))
1197	ELSE
1198	output=output//TRIM(str(c:ti-1)) ; c=ti+2
1199	DO
1200	i = INDEX(str(c:),"\n") ; ti = c+i-1
1201	IF (i == 0) THEN
1202	output=output//TRIM(str(ti+1:mx)) ; c = mx+1
1203	ELSE
1204	output=output//idts//str(c:ti-1) ; c = ti+2
1205	ENDIF
1206	IF (c > mx) EXIT
1207	ENDDO
1208	ENDIF
1209	! print a newline if we have \n at the end of the string
1210	IF (INDEX(TRIM(str),'\n',.true.) == mx-1.AND.TRIM(str) /= '\n') &
1211	output=output//idts(1:1)
1212	END FUNCTION format_string
1213
1214	FUNCTION format_paragraph(str,width,idt1,idto) RESULT(output)
1215	!! Split and format a string over several lines
1216	!!
1217	!! The function splits an input string in words so output lines fit (almost) in __width__ characters.
1218	!! The method handles indentation level (defined as leading blank spaces). It also accounts for known
1219	!! csi (see [[strings(module):attributes(variable)]].
1220	!! @note
1221	!! Words are considered indivisible and thus output lines can sometimes exceed the maximum width if
1222	!! there is not enough space to put a word (with the associated indentation if given). The default
1223	!! behavior in that case is to print the word in a new line (with the correct leading blank spaces).
1224	!! @warning
1225	!! If __width__, __idt1__ and/or __idto__ have inconsistent values (e.g. __width__ <= __idt1__), the
1226	!! method still computes the paragraph, but each words will be set on a new line with the appropriate
1227	!! indentation.
1228	CHARACTER(len=*), INTENT(in) :: str !! string with the content to split
1229	INTEGER, INTENT(in) :: width !! An positive integer with the maximum width of a line
1230	INTEGER, INTENT(in), OPTIONAL :: idt1 !! An optional integer with the indentation level of the first output line
1231	INTEGER, INTENT(in), OPTIONAL :: idto !! An optional integer with the indentation level of the other output lines
1232	CHARACTER(len=:), ALLOCATABLE :: output !! An allocatable string with the output content
1233	CHARACTER(len=:), ALLOCATABLE :: idts,zs
1234	INTEGER :: l1,lo,zmx,zw,cc,j,jj,l
1235	zw = abs(width) ; zs = strip_newline(str)
1236	zmx = LEN_TRIM(zs)
1237	IF (zmx == 0) THEN
1238	ALLOCATE(output,source='') ; RETURN
1239	ENDIF
1240	l1=0 ; IF (PRESENT(idt1)) l1 = MAX(l1,idt1)
1241	ALLOCATE(CHARACTER(len=l1) :: output)
1242	IF (l1 > 0) output(1:l1) = CHAR(32)
1243	lo=l1 ; IF (PRESENT(idto)) lo = MAX(l1+idto,0)
1244	ALLOCATE(CHARACTER(len=lo+1) :: idts)
1245	idts(1:1) = NEW_LINE('A') ; IF (lo>=1) idts(2:len(idts)) = CHAR(32)
1246	! Prints a message if user is just stupid...
1247	IF (lo+1 > zw .OR. l1+1 > zw) THEN
1248	output = str ; RETURN
1249	ENDIF
1250	! check if can just return the string as is
1251	IF (zmx + l1 <= zw) THEN
1252	output=output//TRIM(zs) ; RETURN
1253	ENDIF
1254	j=1 ; jj=1+l1
1255	DO
1256	! Gets next blank in input string
1257	cc = INDEX(TRIM(zs(j:)),CHAR(32))
1258	! no more blank
1259	! Gets total length of csi between zs(j:j+cc-1)
1260	! this value will be substracted to each length test
1261	IF (cc == 0) THEN
1262	l = csis_length(zs(j:))
1263	IF (jj-1+LEN_TRIM(zs(j:))-l > zw) THEN
1264	output = output//idts
1265	ENDIF
1266	output=output//TRIM(zs(j:))
1267	EXIT ! we are at the last word : we must exit the infinite loop !
1268	ELSE
1269	l = csis_length(zs(j:j+cc-1))
1270	IF (cc+jj-1-l > zw) THEN
1271	output=output//idts//zs(j:j+cc-1) ; jj = lo+1+cc+1 - l
1272	ELSE
1273	output=output//zs(j:j+cc-1) ; jj = jj + cc - l
1274	ENDIF
1275	ENDIF
1276	j = j + cc
1277	ENDDO
1278	CONTAINS
1279	FUNCTION csis_length(str) RESULT(value)
1280	! - DUMMY
1281	CHARACTER(len=*), INTENT(in) :: str
1282	! - RESULT
1283	INTEGER :: value
1284	! - LOCAL
1285	INTEGER :: jc,iesc,im
1286	LOGICAL :: tcsi
1287	value = 0
1288	jc=1
1289	DO
1290	IF (jc>LEN(str)) EXIT
1291	! search for escape
1292	iesc = INDEX(str(jc:),CHAR(27))
1293	IF (iesc == 0) EXIT
1294	! search for m
1295	im = INDEX(str(jc+iesc:),"m")
1296	! no m in the string after ESC --> this could not be a csi
1297	IF (im == 0) EXIT
1298	! check if this is really a csi and updates length
1299	tcsi = is_csi(str(jc+iesc-1:jc+iesc+im-1))
1300	jc = jc + iesc
1301	IF (tcsi) THEN
1302	value=value+im+1
1303	jc=jc+im
1304	ENDIF
1305	ENDDO
1306	END FUNCTION csis_length
1307	END FUNCTION format_paragraph
1308
1309	FUNCTION strip_newline(str,rpl) RESULT(stripped)
1310	!! Replace newline escape sequences by spaces
1311	!!
1312	!! The function replaces newline (both '\\n' escape sequence and Fortran NEW_LINE() character) in the
1313	!! given string and returns the resulting string.
1314	CHARACTER(len=*), INTENT(in) :: str !! A string to process
1315	CHARACTER(len=1), INTENT(in), OPTIONAL :: rpl !! A optional single character used as substitution of escape sequences (blank space by default)
1316	CHARACTER(len=:), ALLOCATABLE :: stripped !! An allocatable string with all newline sequences replaced by blank space or __rpl__ if given
1317	CHARACTER(len=1) :: zrp
1318	INTEGER :: i, j, ns
1319	zrp = CHAR(32) ; IF(PRESENT(rpl)) zrp = rpl
1320	IF (str == NEW_LINE('A')) THEN
1321	stripped = zrp ; RETURN
1322	ENDIF
1323	ns = LEN_TRIM(str)
1324	IF (ns == 0) THEN
1325	ALLOCATE(stripped,source='') ; RETURN
1326	ENDIF
1327	ALLOCATE(CHARACTER(len=ns) :: stripped) ; stripped(1:ns) = CHAR(32)
1328	i=1 ; j=1
1329	DO
1330	IF (str(i:i) == NEW_LINE('A')) THEN
1331	stripped(j:j) = zrp
1332	ELSE IF (i < ns) THEN
1333	IF (str(i:i+1) == "\n") THEN
1334	stripped(j:j) = zrp ; i=i+1
1335	ELSE
1336	stripped(j:j) = str(i:i)
1337	ENDIF
1338	ELSE
1339	stripped(j:j) = str(i:i)
1340	ENDIF
1341	j=j+1 ; i=i+1
1342	IF (i > ns .OR. j > ns) EXIT
1343	ENDDO
1344	IF (j < ns) stripped = stripped(1:j)
1345	RETURN
1346	END FUNCTION strip_newline
1347
1348	FUNCTION str_length(str) RESULT(res)
1349	!! Get the length of the string object
1350	!!
1351	!! The method computes the length of the string. It differs from LEN intrinsic function as
1352	!! it does not account for extra-characters of csi codes.
1353	CHARACTER(len=*), INTENT(in) :: str !! String to process
1354	INTEGER :: res !! The actual length of string (i.e. does not account for csi codes)
1355	CHARACTER(len=:), ALLOCATABLE :: tmp
1356	res = 0
1357	IF (LEN(str) /= 0) THEN
1358	tmp = str_reset_attributes(str)
1359	res = LEN(tmp)
1360	DEALLOCATE(tmp)
1361	ENDIF
1362	RETURN
1363	END FUNCTION str_length
1364
1365	FUNCTION str_to_lower(str1) RESULT(str)
1366	!! Convert the string in lower case
1367	!!
1368	!! The method converts the input string in lower case and accounts for
1369	!! possible csi codes in the string.
1370	CHARACTER(len=*), INTENT(in) :: str1 !! Input string to convert
1371	CHARACTER(len=:), ALLOCATABLE :: str !! A copy of the string in lower case
1372	INTEGER :: i,ic
1373	IF (LEN(str1) /= 0) THEN
1374	str = str1
1375	DO i = 1, len(str1)
1376	ic = ichar(str1(i:i))
1377	IF (ic >= 65 .AND. ic < 90) str(i:i) = char(ic + 32)
1378	ENDDO
1379	ELSE
1380	str=''
1381	ENDIF
1382	END FUNCTION str_to_lower
1383
1384	FUNCTION str_to_upper(str1) RESULT(str)
1385	!! Convert the string in upper case
1386	!!
1387	!! The method converts the input string in upper case and accounts for
1388	!! possible csi codes in the string.
1389	CHARACTER(len=*), INTENT(in) :: str1 !! Input string to convert
1390	CHARACTER(len=:), ALLOCATABLE :: str !! A copy of the string in upper case
1391	INTEGER :: j,i,ic,icsi,lcsi
1392	IF (LEN(str1) > 0) THEN
1393	str = str1
1394	i = 1
1395	DO
1396	IF (i > LEN(str)) EXIT
1397	icsi = str_index_of_csi(str(i:),lcsi)
1398	IF (icsi == 0) THEN
1399	! no more csi the end of string is upper case converted
1400	DO j=i,LEN(str)
1401	ic = ichar(str(j:j))
1402	IF (ic >= 97 .AND. ic < 122) str(j:j) = char(ic-32)
1403	ENDDO
1404	RETURN
1405	ELSE IF (icsi == 1) THEN
1406	i = i + lcsi
1407	ELSE IF (icsi > 1) THEN
1408	! csi is not the first word: we convert in upper case until its
1409	! position THEN copy the csi and get back in the loop
1410	DO j=i,i+icsi-2
1411	ic = ichar(str(j:j))
1412	IF (ic >= 97 .AND. ic < 122) str(j:j) = char(ic-32)
1413	ENDDO
1414	i = i + icsi + lcsi-1
1415	ENDIF
1416	ENDDO
1417	ELSE
1418	str=''
1419	ENDIF
1420	END FUNCTION str_to_upper
1421
1422	FUNCTION str_remove(string,substring,back,all) RESULT(str)
1423	!! Remove substring from current string
1424	!!
1425	!! The function removes the first occurence of __substring__ in __string__ or all
1426	!! its occurences if __all__ is explicitly set to .true..
1427	CHARACTER(len=*), INTENT(in) :: string !! A string to search in
1428	CHARACTER(len=*), INTENT(in) :: substring !! A string to search and removes from __string__
1429	LOGICAL, INTENT(in), OPTIONAL :: back, & !! An optional boolean flag with .true. to begin search at the end of the string
1430	all !! An optional boolean flag with .true. to remove all occurences of __substring__
1431	CHARACTER(len=:), ALLOCATABLE :: str !! An allocatable string with __substring__ occurence(s) removed
1432	LOGICAL :: zb,za
1433	INTEGER :: is,j,zboff
1434	str=''
1435	zb = .false. ; za = .false.
1436	IF (PRESENT(back)) zb = back
1437	IF (PRESENT(all)) za = all
1438	IF (za) zb=.false.
1439	zboff = 0 ; IF (zb) zboff = 1
1440	IF (LEN(string) == 0) RETURN
1441	j=1
1442	DO
1443	IF (j>LEN(string)) EXIT
1444	! search for substring
1445	is = INDEX(string(j:),substring,back=zb)
1446	IF (is == 0) THEN
1447	! substring is not found : we get the last part of the string and return
1448	str = str//string(j:) ; RETURN
1449	ELSE IF (is == 1) THEN
1450	j = j + LEN(substring)
1451	ELSE
1452	! substring is not at the begin of the string : saves the string
1453	str = str//string(j:j+is-2)
1454	j = j + is+LEN(substring)-1
1455	ENDIF
1456	! if we only want to str_remove ONE occurence we exit if substring
1457	! has been found
1458	IF (.NOT.(is==0.OR.za)) EXIT
1459	ENDDO
1460	IF (j <= LEN(string).AND..NOT.zb) str=str//string(j:)
1461	RETURN
1462	END FUNCTION str_remove
1463
1464	FUNCTION str_replace(string,old,new,back,all) RESULT(str)
1465	!! Replace substring from current string
1466	!!
1467	!! The function replaces the first occurence of __old__ in __string__ by
1468	!! __new__ or all its occurence(s) if __all__ is explicitly set to .true..
1469	CHARACTER(len=*), INTENT(in) :: string !! A string to search in
1470	CHARACTER(len=*), INTENT(in) :: old, & !! A string to search and replace
1471	new !! A string to substitute to __old__
1472	LOGICAL, INTENT(in), OPTIONAL :: back, & !! An optional boolean flag with .true. to begin search at the end of the string
1473	all !! An optional boolean flag with .true. to replace all occurences of __old__
1474	CHARACTER(len=:), ALLOCATABLE :: str !! An allocatable string with occurence(s) of __old__ replaced by __new__
1475	LOGICAL :: zb,za
1476	INTEGER :: is,j
1477	str=''
1478	zb = .false. ; za = .false.
1479	IF (PRESENT(back)) zb = back
1480	IF (PRESENT(all)) za = all
1481	IF (za) zb = .NOT.za
1482	IF (LEN(string) == 0) RETURN
1483	j=1
1484	DO
1485	IF (j>LEN(string)) EXIT
1486	! search for "old"
1487	is = INDEX(string(j:),old,back=zb)
1488	IF (is == 0) THEN
1489	! "old" is not found : we get the last part of the string and return
1490	str = str//string(j:) ; RETURN
1491	ELSE IF (is == 1) THEN
1492	str = str//new
1493	j = j + LEN(old)
1494	ELSE
1495	! "old" is not at the begin of the string : saves the string
1496	str = str//string(j:j+is-2)//new
1497	j = j + is + LEN(old) - 1
1498	ENDIF
1499	IF (.NOT.(is==0.OR.za)) EXIT
1500	ENDDO
1501	IF (j <= LEN(str)) str=str//string(j:)
1502	RETURN
1503	END FUNCTION str_replace
1504
1505	FUNCTION str_endswith(string,substring,icase) RESULT(ret)
1506	!! Check if string ends by substring
1507	CHARACTER(len=*), INTENT(in) :: string
1508	!! @param[in] string A string to check
1509	CHARACTER(len=*), INTENT(in) :: substring
1510	!! A string to search in __string__
1511	LOGICAL, INTENT(in), OPTIONAL :: icase
1512	!! An optional boolean flag with .true. to perform insensitive case search
1513	LOGICAL :: ret
1514	!! .true. if __string__ ends by __substring__, .false. otherwise.
1515	CHARACTER(len=:), ALLOCATABLE :: zthis,zstr
1516	INTEGER :: idx
1517	LOGICAL :: noc
1518	ret = .false.
1519	noc = .false. ; IF (PRESENT(icase)) noc = icase
1520	IF (LEN(string) == 0 .OR. LEN(substring) == 0) RETURN
1521	zthis = str_reset_attributes(string) ; zstr=str_reset_attributes(substring)
1522	IF (noc) THEN
1523	idx = INDEX(str_to_lower(zthis),str_to_lower(zstr),.true.)
1524	ELSE
1525	idx = INDEX(zthis,zstr,.true.)
1526	ENDIF
1527	IF (idx == 0.OR.idx+str_length(zstr)-1 /= str_length(zthis)) RETURN
1528	ret=.true.
1529	END FUNCTION str_endswith
1530
1531	FUNCTION str_startswith(string,substring,icase) RESULT(ret)
1532	!! Check if string starts by substring
1533	CHARACTER(len=*), INTENT(in) :: string
1534	!! A string to check
1535	CHARACTER(len=*), INTENT(in) :: substring
1536	!! A string to search in __string__
1537	LOGICAL, INTENT(in), OPTIONAL :: icase
1538	!! An optional boolean flag with .true. to perform insensitive case search
1539	LOGICAL :: ret
1540	!! .true. if __string__ starts by __substring__, .false. otherwise.
1541	CHARACTER(len=:), ALLOCATABLE :: zthis,zstr
1542	INTEGER :: idx
1543	LOGICAL :: noc
1544	ret = .false.
1545	noc = .false. ; IF (PRESENT(icase)) noc = icase
1546	IF (LEN(string) == 0 .OR. LEN(substring) == 0) RETURN
1547	zthis = str_reset_attributes(string) ; zstr=str_reset_attributes(substring)
1548	IF (noc) THEN
1549	idx = INDEX(str_to_lower(zthis),str_to_lower(zstr))
1550	ELSE
1551	idx = INDEX(zthis,zstr)
1552	ENDIF
1553	IF (idx /= 1) RETURN
1554	ret=.true.
1555	END FUNCTION str_startswith
1556
1557	! CSI related functions
1558	! ---------------------
1559
1560	FUNCTION str_add_attributes(string,attrs) RESULT(str)
1561	!! Set csi attributes to the given string object
1562	!!
1563	!! The function adds csi (ANSI escape sequences) to the given string and
1564	!! returns a copy of it.
1565	CHARACTER(len=*), INTENT(in) :: string
1566	!! @param[in] string A string object reference
1567	INTEGER, INTENT(in), DIMENSION(:) :: attrs
1568	!! A vector of integers with the code to add. Each __attrs__ value should refers to one i
1569	!! of [[strings(module):attributes(variable)]] values.
1570	CHARACTER(len=:), ALLOCATABLE :: str
1571	!! An allocatable string with new csi codes added.
1572	INTEGER :: j,iesc,im
1573	CHARACTER(len=:), ALLOCATABLE :: tmp,csi
1574	CHARACTER(len=4), PARAMETER :: rcsi = CHAR(27)//"[0m"
1575	str=''
1576	! 1) Check for input string
1577	IF (LEN(string) == 0) RETURN
1578	! 2) Removes last <ESC>[0m if any and initializes output string
1579	! we must remove only the last <ESC>[0m if any
1580	IF (INDEX(string,rcsi,.true.) == LEN(string)-3) THEN
1581	tmp = str_remove(string,rcsi,back=.true.)
1582	ELSE
1583	tmp = string
1584	ENDIF
1585	! 3) Add all the given csi preceded by <ESC>[0m at the beginning of the string
1586	! if it does not start by an ANSI sequence
1587	IF (INDEX(tmp,CHAR(27)//"[") /= 1) &
1588	tmp = str_add_to_csi(rcsi,attrs)//tmp
1589	! Loops on new string and updates csi codes
1590	j=1
1591	DO
1592	IF (j>LEN(tmp)) EXIT
1593	! search for escape
1594	iesc = INDEX(tmp(j:),CHAR(27))
1595	IF (iesc == 0) THEN
1596	! no more ESC : cat until end of input string and exit
1597	str = str//tmp(j:) ; EXIT
1598	ELSE IF (iesc > 1) THEN
1599	! ESC is not first char: copy until ESC
1600	str = str//tmp(j:j+iesc-2)
1601	ENDIF
1602	! search for m
1603	im = INDEX(tmp(j+iesc:),"m")
1604	! no m in the string after ESC --> copy string (INCLUDING ESC) and leave
1605	IF (im == 0) THEN
1606	str = str//tmp(j+iesc-1:)
1607	RETURN
1608	ENDIF
1609	csi = tmp(j+iesc-1:j+iesc+im-1)
1610	! we have a csi: we add new codes to it
1611	IF (is_csi(csi)) THEN
1612	csi = str_add_to_csi(csi,attrs)
1613	ENDIF
1614	str = str//csi
1615	j = j + iesc + im
1616	ENDDO
1617	IF (INDEX(str,rcsi,.true.) /= LEN(str)-3) str = str//rcsi
1618	RETURN
1619	END FUNCTION str_add_attributes
1620
1621	FUNCTION str_delete_attributes(string,attrs) RESULT(str)
1622	!! Remove attributes to the given string
1623	!!
1624	!! The function removes list of csi (ANSI escape sequences) from the given
1625	!! string and returns a copy of it.
1626	!! @note
1627	!! This method does not update @lerror.
1628	CHARACTER(len=*), INTENT(in) :: string
1629	!! Input string
1630	INTEGER, INTENT(in), DIMENSION(:) :: attrs
1631	!! A vector of integers with the code to remove. Each __attrs__ value should
1632	!! refers to one of [[strings(module):attributes(variable)]] values.
1633	CHARACTER(len=:), ALLOCATABLE :: str
1634	!! An allocatable string with csi codes from __list__ removed
1635	LOGICAL :: ok
1636	INTEGER :: j,iesc,im
1637	CHARACTER(len=:), ALLOCATABLE :: tmp,csi,csis
1638	CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: tks
1639	CHARACTER(len=4), PARAMETER :: rcsi = CHAR(27)//"[0m"
1640	str=''
1641	IF (LEN(string) == 0) RETURN
1642	! remove last <ESC>[0m if found at the end of the string
1643	IF (INDEX(string,rcsi,.true.) == LEN(string)-3) THEN
1644	tmp = str_remove(string,rcsi,back=.true.)
1645	ELSE
1646	tmp = string
1647	ENDIF
1648	! Loops on new string and updates csi codes
1649	j=1 ; csis=""
1650	DO
1651	IF (j>LEN(tmp)) EXIT
1652	! search for escape
1653	iesc = INDEX(tmp(j:),CHAR(27))
1654	IF (iesc == 0) THEN
1655	! no more ESC : cat until end of input string and exit
1656	str = str//tmp(j:) ; EXIT
1657	ELSE IF (iesc > 1) THEN
1658	! ESC is not first char: copy until ESC
1659	str = str//tmp(j:j+iesc-2)
1660	ENDIF
1661	! search for m
1662	im = INDEX(tmp(j+iesc:),"m")
1663	! no m in the string after ESC --> copy string (INCLUDING ESC) and leave
1664	IF (im == 0) THEN
1665	str = str//tmp(j+iesc-1:)
1666	RETURN
1667	ENDIF
1668	csi = tmp(j+iesc-1:j+iesc+im-1)
1669	! we have a csi: we add new codes to it
1670	IF (is_csi(csi)) THEN
1671	csi = str_del_from_csi(csi,attrs)
1672	ENDIF
1673	csis=csis//csi//"\|"
1674	str = str//csi
1675	j = j + iesc + im
1676	ENDDO
1677	! Add <ESC>[0m at the end of string if not found
1678	IF (INDEX(str,rcsi,.true.) /= LEN(str)-3) str = str//rcsi
1679	! resets all attributes if we only have <ESC>[0m in final list
1680	ok = tokenize(csis(1:LEN(csis)-1),tks,"\|")
1681	IF (ALL(tks == rcsi)) str = str_reset_attributes(str)
1682	DEALLOCATE(tks)
1683	RETURN
1684	END FUNCTION str_delete_attributes
1685
1686	FUNCTION str_reset_attributes(string) RESULT(str)
1687	!! Reset all csi codes of the string
1688	!!
1689	!! The method removes __all__ the known escape sequences from the input string.
1690	CHARACTER(len=*), INTENT(in) :: string
1691	!! Input string
1692	CHARACTER(len=:), ALLOCATABLE :: str
1693	!! An allocatable string with the copy of input string stripped off csi codes.
1694	INTEGER :: j,iesc,im
1695	LOGICAL :: tcsi
1696	str = ""
1697	IF (LEN(string) == 0) RETURN
1698	j=1
1699	DO
1700	IF (j>LEN(string)) EXIT
1701	! search for escape
1702	iesc = INDEX(string(j:),CHAR(27))
1703	IF (iesc == 0) THEN
1704	str = str//string(j:) ; EXIT
1705	ENDIF
1706	! search for m
1707	im = INDEX(string(j+iesc:),"m")
1708	! no m in the string after ESC --> copy string (INCLUDING ESC) and leave
1709	IF (im == 0) THEN
1710	str = str//string(j+iesc-1:)
1711	RETURN
1712	ENDIF
1713	! csi includes everything between ESC and m (excluding them):
1714	! to check for csi it should begin by [ and then be a list of integers
1715	! separated by ;
1716	tcsi = is_csi(string(j+iesc-1:j+iesc+im-1))
1717	IF (iesc > 1) THEN
1718	str = str//string(j:j+iesc-2)
1719	ENDIF
1720	j = j + iesc ; IF (tcsi) j=j+im
1721	ENDDO
1722	RETURN
1723	END FUNCTION str_reset_attributes
1724
1725
1726	FUNCTION is_csi(value) RESULT(yes)
1727	!! Check if string is a known csi
1728	!!
1729	!! The function only check for known csi code which are defined in [[strings(module):attributes(variable)]].
1730	CHARACTER(len=*), INTENT(in) :: value
1731	!! A Fortran intrinsic string to check
1732	LOGICAL :: yes
1733	!! .true. if it is a known csi, .false. otherwise
1734	LOGICAL :: ok
1735	CHARACTER(len=:), ALLOCATABLE :: tmp
1736	TYPE(words) :: wtks
1737	CHARACTER(len=st_slen), DIMENSION(:), ALLOCATABLE :: stks
1738	INTEGER, DIMENSION(:), ALLOCATABLE :: nums
1739	INTEGER :: i
1740	yes = .false.
1741	IF (LEN(value) < 4) RETURN
1742	tmp = value(3:len(value)-1)
1743	wtks = new_words(tmp,";")
1744	ok = words_to_vector(wtks,stks)
1745	CALL ws_clear_sc(wtks)
1746	IF (.NOT.ok) RETURN
1747	! if we cannot convert strings to integers : it is not a csi
1748	IF (.NOT.from_string(stks,nums)) RETURN
1749	DEALLOCATE(stks)
1750	DO i=1, SIZE(nums)
1751	IF (.NOT.ANY(attributes == nums(i))) RETURN
1752	ENDDO
1753	yes = .true.
1754	END FUNCTION is_csi
1755
1756	FUNCTION str_add_to_csi(csi,list) RESULT(ncsi)
1757	!! Add a new list of codes to the input csi string
1758	!!
1759	!! The method adds all the csi codes given in __list__ that are known by the module and not
1760	!! already present in the input csi.
1761	CHARACTER(len=*), INTENT(in) :: csi
1762	!! A string with the input csi. It __must__ begin with "<ESC>[" and ends with "m".
1763	INTEGER, INTENT(in), DIMENSION(:) :: list
1764	!! A vector of integers with the csi code to add. Each value of __list__ should be one of
1765	!! [[strings(module):attributes(variable)]] values. All unknwon values are filtered out as well
1766	!! as csi code already present in input __csi__.
1767	CHARACTER(len=:), ALLOCATABLE :: ncsi
1768	!! A new csi string or the input __csi__ if some "errors" occured (the input csi could not
1769	!! be tokenized or none of __list__ values are left after filtering).
1770	LOGICAL :: ok
1771	CHARACTER(len=LEN(csi)), DIMENSION(:), ALLOCATABLE :: tks
1772	CHARACTER(len=:), ALLOCATABLE :: tmp
1773	INTEGER, DIMENSION(:), ALLOCATABLE :: zlist,nums
1774	INTEGER :: i,j,ni,no
1775	! 1) Filter input list :
1776	! 1.1) Gets the list of current csi codes
1777	ncsi = csi(3:len(csi)-1)
1778	ok = tokenize(ncsi,tks,"; ",merge=.true.)
1779	IF (.NOT.from_string(tks,nums)) THEN
1780	ncsi = csi
1781	RETURN
1782	ENDIF
1783	DEALLOCATE(tks)
1784	! 1.2) Filter input list of new flags to add
1785	! counts number of valid flags
1786	j=0
1787	DO i=1,SIZE(list)
1788	! new flags must be in attributes but NOT in nums
1789	IF (ANY(attributes==list(i).AND..NOT.ANY(nums == list(i)))) j=j+1
1790	ENDDO
1791	! No "valid" flags -> returns old csi
1792	IF (j == 0) THEN ; ncsi = csi ; RETURN ; ENDIF
1793	ni = SIZE(nums) ; no = j + ni
1794	ALLOCATE(zlist(no)) ; zlist(1:ni) = nums(:) ; j = ni
1795	DO i=1,SIZE(list)
1796	! new flags must be in attributes but NOT in nums
1797	IF (ANY(attributes==list(i).AND..NOT.ANY(nums == list(i)))) THEN
1798	j=j+1 ; zlist(j) = list(i)
1799	ENDIF
1800	ENDDO
1801	DEALLOCATE(nums)
1802	! 2) Builds new csi
1803	! Here we explictly set the first flag to 0 (i.e. reset attributes)...
1804	ncsi = CHAR(27)//"[0;"
1805	DO i=1,no
1806	! ... So we get rid of all "0" flag in the list
1807	IF (zlist(i) /= 0) THEN
1808	tmp = to_string(zlist(i))
1809	IF (LEN_TRIM(tmp) == 0) THEN
1810	ncsi = csi ; RETURN
1811	ENDIF
1812	ncsi = ncsi//tmp
1813	IF (i /= no) ncsi = ncsi//";"
1814	ENDIF
1815	ENDDO
1816	ncsi = ncsi//"m"
1817	END FUNCTION str_add_to_csi
1818
1819	FUNCTION str_del_from_csi(csi,list) RESULT(ncsi)
1820	!! Remove a list of codes from the input csi string
1821	!!
1822	!! The method removes all the csi codes given in __list__ that are known by the
1823	!! module and already present in the input csi.
1824	CHARACTER(len=*), INTENT(in) :: csi
1825	!! An intrinsic Fortran string with the input csi. It __must__ begin with "<ESC>[" and ends with "m".
1826	INTEGER, INTENT(in), DIMENSION(:) :: list
1827	!! A vector of integers with the csi code to remove. Each value of __list__ should be one of
1828	!! [[strings(module):attributes(variable)]] values. All unknwon values are filtered out.
1829	CHARACTER(len=:), ALLOCATABLE :: ncsi
1830	!! A new csi string or the input __csi__ if some "errors" occured (the input csi could not
1831	!! be tokenized or none of __list__ values are left after filtering).
1832	LOGICAL :: ok
1833	CHARACTER(len=LEN(csi)), DIMENSION(:), ALLOCATABLE :: tks
1834	CHARACTER(len=:), ALLOCATABLE :: tmp
1835	INTEGER, DIMENSION(:), ALLOCATABLE :: nums
1836	INTEGER :: i
1837	ncsi = csi(3:len(csi)-1)
1838	ok = tokenize(ncsi,tks,"; ",merge=.true.)
1839	IF (.NOT.from_string(tks,nums)) THEN
1840	ncsi = csi
1841	RETURN
1842	ENDIF
1843	DEALLOCATE(tks)
1844	tmp=""
1845	DO i=1, SIZE(nums)
1846	IF (ALL(nums(i) /= list).AND.nums(i) /= 0) THEN
1847	! no need to check for to_string status : it is always ok !
1848	tmp=tmp//to_string(nums(i))//";"
1849	ENDIF
1850	ENDDO
1851	IF (LEN_TRIM(tmp) /= 0) THEN
1852	ncsi=CHAR(27)//"[0;"//tmp(1:LEN(tmp)-1)//"m"
1853	ELSE
1854	ncsi=CHAR(27)//"[0m"
1855	ENDIF
1856	END FUNCTION str_del_from_csi
1857
1858	FUNCTION str_index_of_csi(str,length) RESULT(pos)
1859	!! Get the position of the first known csi in string
1860	!!
1861	!! The method searches for the first known csi in string. The csi must contain known codes
1862	!! (i.e. values of [[strings(module):attributes(variable)]]).
1863	CHARACTER(len=*), INTENT(in) :: str !! A string to search in
1864	INTEGER, INTENT(out) :: length !! Length of the csi in the string
1865	INTEGER :: pos !! Position of the first csi found. It is set to 0 if no csi has been found.
1866	INTEGER :: iesc,im
1867	pos = 0 ; length = 0
1868	! we need at least 4 chars to create a csi
1869	IF (LEN_TRIM(str) < 4) RETURN
1870	iesc = INDEX(str,CHAR(27))
1871	IF (iesc == 0) RETURN
1872	! search for m
1873	im = INDEX(str(iesc:),"m")
1874	! no m in the string after ESC --> copy string (INCLUDING ESC) and leave
1875	IF (im == 0) RETURN
1876	IF (.NOT.is_csi(str(iesc:iesc+im-1))) RETURN
1877	pos = iesc ; length = im
1878	END FUNCTION str_index_of_csi
1879
1880	! String conversion functions
1881	! ---------------------------
1882
1883	FUNCTION str2int_sc(str, value) RESULT(ret)
1884	!! Convert string value to integer value (scalar)
1885	CHARACTER(len=*), INTENT(in) :: str !! String to convert
1886	INTEGER, INTENT(out) :: value !! Output value
1887	LOGICAL :: ret !! Return status (.true. on success)
1888	CHARACTER(len=:), ALLOCATABLE :: zs
1889	ret = .true. ; zs = remove_quotes(str)
1890	IF (string_is(zs) /= st_integer) THEN
1891	ret = .false.
1892	ELSE
1893	READ(zs, *) value
1894	ENDIF
1895	RETURN
1896	END FUNCTION str2int_sc
1897
1898	FUNCTION str2log_sc(str, value) RESULT(ret)
1899	!! Convert string value to logical value (scalar)
1900	CHARACTER(len=*), INTENT(in) :: str !! String to convert
1901	LOGICAL, INTENT(out) :: value !! Output value
1902	LOGICAL :: ret !! Return status (.true. on success)
1903	CHARACTER(len=:), ALLOCATABLE :: zs
1904	integer :: r
1905	ret = .true. ; zs = remove_quotes(str)
1906	r = string_is(zs)
1907	IF (string_is(zs) /= st_logical) THEN
1908	ret = .false.
1909	ELSE
1910	READ(zs, *) value
1911	ENDIF
1912	RETURN
1913	END FUNCTION str2log_sc
1914
1915	FUNCTION str2real_sc(str, value) RESULT(ret)
1916	!! Convert string value to simple precision floating precision value (scalar)
1917	CHARACTER(len=*), INTENT(in) :: str !! String to convert
1918	REAL(kind=4), INTENT(out) :: value !! Output value
1919	LOGICAL :: ret !! Return status (.true. on success)
1920	CHARACTER(len=:), ALLOCATABLE :: zs
1921	ret = .true.; zs = remove_quotes(str)
1922	IF (string_is(zs) < st_integer) THEN
1923	ret = .false.
1924	ELSE
1925	READ(zs, *) value
1926	ENDIF
1927	RETURN
1928	END FUNCTION str2real_sc
1929
1930	FUNCTION str2dble_sc(str, value) RESULT(ret)
1931	!! Convert string value to double precision floating precision value (scalar)
1932	CHARACTER(len=*), INTENT(in) :: str !! String to convert
1933	REAL(kind=8), INTENT(out) :: value !! Output value
1934	LOGICAL :: ret !! Return status (.true. on success)
1935	CHARACTER(len=:), ALLOCATABLE :: zs
1936	ret = .true. ; zs = remove_quotes(str)
1937	IF (string_is(zs) < st_integer) THEN
1938	ret = .false.
1939	ELSE
1940	READ(zs, *) value
1941	ENDIF
1942	RETURN
1943	END FUNCTION str2dble_sc
1944
1945	FUNCTION str2cplx_sc(str, value) RESULT(ret)
1946	!! Convert string value to complex value (scalar)
1947	CHARACTER(len=*), INTENT(in) :: str !! String to convert
1948	COMPLEX(kind=4), INTENT(out) :: value !! Output value
1949	LOGICAL :: ret !! Return status (.true. on success)
1950	! - LOCAL
1951	CHARACTER(len=:), ALLOCATABLE :: zs
1952	ret = .true. ; zs = remove_quotes(str)
1953	IF (string_is(zs) /= st_complex) THEN
1954	ret = .false.
1955	ELSE
1956	READ(zs, *) value
1957	ENDIF
1958	RETURN
1959	END FUNCTION str2cplx_sc
1960
1961	FUNCTION str2int_ve(str, value) RESULT(ret)
1962	!! Convert strings values to integer values (vector)
1963	CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert
1964	INTEGER, INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values
1965	LOGICAL :: ret !! Return status (.true. on success)
1966	INTEGER :: i,ns
1967	CHARACTER(len=:), ALLOCATABLE :: zs
1968	ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns))
1969	DO i=1,ns
1970	zs = remove_quotes(str(i))
1971	IF (string_is(zs) /= st_integer) THEN
1972	ret = .false. ; DEALLOCATE(value) ; RETURN
1973	ELSE
1974	READ(zs, *) value(i)
1975	ENDIF
1976	ENDDO
1977	RETURN
1978	END FUNCTION str2int_ve
1979
1980	FUNCTION str2log_ve(str, value) RESULT(ret)
1981	!! Convert strings values to logical values (vector)
1982	CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert
1983	LOGICAL, INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values
1984	LOGICAL :: ret !! Return status (.true. on success)
1985	INTEGER :: i,ns
1986	CHARACTER(len=:), ALLOCATABLE :: zs
1987	ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns))
1988	DO i=1,ns
1989	zs = remove_quotes(str(i))
1990	IF (string_is(zs) /= st_logical) THEN
1991	ret = .false. ; DEALLOCATE(value) ; RETURN
1992	ELSE
1993	READ(zs, *) value(i)
1994	ENDIF
1995	ENDDO
1996	RETURN
1997	END FUNCTION str2log_ve
1998
1999	FUNCTION str2real_ve(str, value) RESULT(ret)
2000	!! Convert strings values to simple precision floating point values (vector)
2001	CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert
2002	REAL(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values
2003	LOGICAL :: ret !! Return status (.true. on success)
2004	INTEGER :: i,ns
2005	CHARACTER(len=:), ALLOCATABLE :: zs
2006	ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns))
2007	DO i=1,ns
2008	IF (string_is(zs) < st_integer) THEN
2009	ret = .false. ; DEALLOCATE(value) ; RETURN
2010	ELSE
2011	READ(zs, *) value(i)
2012	ENDIF
2013	ENDDO
2014	RETURN
2015	END FUNCTION str2real_ve
2016
2017	FUNCTION str2dble_ve(str, value) RESULT(ret)
2018	!! Convert strings values to double precision floating point values (vector)
2019	CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert
2020	REAL(kind=8), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values
2021	LOGICAL :: ret !! Return status (.true. on success)
2022	INTEGER :: i,ns
2023	CHARACTER(len=:), ALLOCATABLE :: zs
2024	ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns))
2025	DO i=1,ns
2026	zs = remove_quotes(str(i))
2027	IF (string_is(zs) < st_integer) THEN
2028	ret = .false. ; DEALLOCATE(value) ; RETURN
2029	ELSE
2030	READ(zs, *) value(i)
2031	ENDIF
2032	ENDDO
2033	RETURN
2034	END FUNCTION str2dble_ve
2035
2036	FUNCTION str2cplx_ve(str, value) RESULT(ret)
2037	!! Convert strings values to complex values (vector)
2038	CHARACTER(len=*), INTENT(in), DIMENSION(:) :: str !! Vector of strings to convert
2039	COMPLEX(kind=4), INTENT(out), DIMENSION(:), ALLOCATABLE :: value !! Vector of output values
2040	LOGICAL :: ret !! Return status (.true. on success)
2041	INTEGER :: i,ns
2042	CHARACTER(len=:), ALLOCATABLE :: zs
2043	ret = .true. ; ns = SIZE(str) ; ALLOCATE(value(ns))
2044	DO i=1,ns
2045	zs = remove_quotes(str(i))
2046	IF (string_is(zs) /= st_complex) THEN
2047	ret = .false. ; DEALLOCATE(value) ; RETURN
2048	ELSE
2049	READ(zs, *) value(i)
2050	ENDIF
2051	ENDDO
2052	RETURN
2053	END FUNCTION str2cplx_ve
2054
2055	FUNCTION int2str_as(value) RESULT(str)
2056	!! Convert an integer value to string (auto format / string result)
2057	INTEGER, INTENT(in) :: value !! Value to convert
2058	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2059	INTEGER :: err
2060	ALLOCATE(CHARACTER(len=DIGITS(value)) :: str)
2061	WRITE(str,*,iostat=err) value
2062	str = TRIM(ADJUSTL(str))
2063	IF (err /= 0) str = ''
2064	RETURN
2065	END FUNCTION int2str_as
2066
2067	FUNCTION log2str_as(value) RESULT(str)
2068	!! Convert a logical value to string (auto format / string result)
2069	LOGICAL, INTENT(in) :: value !! Value to convert
2070	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2071	INTEGER :: err
2072	ALLOCATE(CHARACTER(len=2) :: str)
2073	WRITE(str, *, IOSTAT = err) value
2074	str=TRIM(ADJUSTL(str))
2075	IF (err /= 0) str = ''
2076	RETURN
2077	END FUNCTION log2str_as
2078
2079	FUNCTION real2str_as(value) RESULT(str)
2080	!! Convert a simple precision floating point value to string (auto format / string result)
2081	REAL(kind=4), INTENT(in) :: value !! Value to convert
2082	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2083	INTEGER :: err
2084	ALLOCATE(CHARACTER(len=DIGITS(value)) ::str)
2085	WRITE(str,*, IOSTAT = err) value
2086	str=TRIM(ADJUSTL(str))
2087	IF (err /= 0) str = ''
2088	RETURN
2089	END FUNCTION real2str_as
2090
2091	FUNCTION dble2str_as(value) RESULT(str)
2092	!! Convert a double precision floating point value to string (auto format / string result)
2093	REAL(kind=8), INTENT(in) :: value !! Value to convert
2094	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2095	INTEGER :: err
2096	ALLOCATE(CHARACTER(len=DIGITS(value)) ::str)
2097	WRITE(str,*, IOSTAT = err) value
2098	str=TRIM(ADJUSTL(str))
2099	IF (err /= 0) str = ''
2100	RETURN
2101	END FUNCTION dble2str_as
2102
2103	FUNCTION cplx2str_as(value) RESULT(str)
2104	!! Convert a complex value to string (auto format / string result)
2105	COMPLEX(kind=4), INTENT(in) :: value !! Value to convert
2106	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2107	INTEGER :: err,sl
2108	sl = DIGITS(REAL(value))*2+3
2109	ALLOCATE(CHARACTER(len=sl) :: str)
2110	WRITE(str, *, IOSTAT = err) value
2111	str = TRIM(ADJUSTL(str))
2112	IF (err /= 0) str = ''
2113	RETURN
2114	END FUNCTION cplx2str_as
2115
2116	FUNCTION int2str_fs(value, fmt, width) RESULT(str)
2117	!! Convert an integer value to string (user format / string result)
2118	INTEGER, INTENT(in) :: value !! Value to convert
2119	CHARACTER(len=*), INTENT(in) :: fmt !! String format
2120	INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__)
2121	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2122	INTEGER :: err
2123	ALLOCATE(CHARACTER(len=width) :: str)
2124	WRITE(str, '('//fmt//')', IOSTAT = err) value
2125	str = TRIM(ADJUSTL(str))
2126	IF (err /= 0) str = ''
2127	RETURN
2128	END FUNCTION int2str_fs
2129
2130	FUNCTION log2str_fs(value, fmt, width) RESULT(str)
2131	!! Convert a logical value to string (user format / string result)
2132	LOGICAL, INTENT(in) :: value !! Value to convert
2133	CHARACTER(len=*), INTENT(in) :: fmt !! String format
2134	INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__)
2135	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2136	INTEGER :: err
2137	ALLOCATE(CHARACTER(len=width) :: str)
2138	WRITE(str, '('//fmt//')', IOSTAT = err) value
2139	str=TRIM(ADJUSTL(str))
2140	IF (err /= 0) str = ''
2141	RETURN
2142	END FUNCTION log2str_fs
2143
2144	FUNCTION real2str_fs(value, fmt, width) RESULT(str)
2145	!! Convert a simple precision floating point value to string (user format / string result)
2146	REAL(kind=4), INTENT(in) :: value !! Value to convert
2147	CHARACTER(len=*), INTENT(in) :: fmt !! String format
2148	INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__)
2149	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2150	INTEGER :: err
2151	ALLOCATE(CHARACTER(len=width) :: str)
2152	WRITE(str, '('//fmt//')', IOSTAT = err) value
2153	str = TRIM(ADJUSTL(str))
2154	IF (err /= 0) str = ''
2155	RETURN
2156	END FUNCTION real2str_fs
2157
2158	FUNCTION dble2str_fs(value, fmt, width) RESULT(str)
2159	!! Convert a double precision floating point value to string (user format / string result)
2160	REAL(kind=8), INTENT(in) :: value !! Value to convert
2161	CHARACTER(len=*), INTENT(in) :: fmt !! String format
2162	INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__)
2163	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2164	INTEGER :: err
2165	ALLOCATE(CHARACTER(len=width) :: str)
2166	WRITE(str, '('//fmt//')', IOSTAT = err) value
2167	str = TRIM(ADJUSTL(str))
2168	IF (err /= 0) str = ''
2169	RETURN
2170	END FUNCTION dble2str_fs
2171
2172	FUNCTION cplx2str_fs(value, fmt, width) RESULT(str)
2173	!! Convert a complex value to string (user format / string result)
2174	COMPLEX(kind=4), INTENT(in) :: value !! Value to convert
2175	CHARACTER(len=*), INTENT(in) :: fmt !! String format
2176	INTEGER, INTENT(in) :: width !! Expected width of the output string (as defined in __fmt__)
2177	CHARACTER(len=:), ALLOCATABLE :: str !! String with the converted value in output
2178	INTEGER :: err
2179	ALLOCATE(CHARACTER(len=width) :: str)
2180	WRITE(str, '('//fmt//')', IOSTAT = err) value
2181	str = TRIM(ADJUSTL(str))
2182	IF (err /= 0) str = ''
2183	RETURN
2184	END FUNCTION cplx2str_fs
2185
2186	END MODULE STRINGS
2187
2188	MODULE ESTRINGS
2189	!! Fortran strings extensions
2190	!!
2191	!! This module is an extension of [[strings(module)]] module (i.e. contains all its definitions).
2192	!! It defines overloaded string concatenation (//) and assignment operators (=) that simplify the
2193	!! conversion between intrinsic types and strings.
2194	!!
2195	!! These operators only work with allocatable strings.
2196	USE STRINGS
2197
2198	PUBLIC
2199
2200	PRIVATE :: str_affect_int, str_affect_bool, str_affect_real, &
2201	str_affect_double, str_affect_cplx, str_affect_dcplx, &
2202	str_cat_int, str_cat_bool, str_cat_real, str_cat_double, &
2203	str_cat_cplx, str_cat_dcplx, str_cat_int_inv, &
2204	str_cat_bool_inv, str_cat_real_inv, str_cat_double_inv, &
2205	str_cat_cplx_inv, str_cat_dcplx_inv
2206
2207
2208
2209	!> Overloaded string assignment operator interface
2210	INTERFACE ASSIGNMENT(=)
2211	MODULE PROCEDURE str_affect_int, str_affect_bool, str_affect_real, &
2212	str_affect_double, str_affect_cplx, str_affect_dcplx
2213	END INTERFACE
2214
2215	!> Overloaded string concatentation operator interface
2216	INTERFACE OPERATOR(//)
2217	MODULE PROCEDURE str_cat_int, str_cat_bool, str_cat_real, str_cat_double, &
2218	str_cat_cplx, str_cat_dcplx
2219	MODULE PROCEDURE str_cat_int_inv, str_cat_bool_inv, str_cat_real_inv, &
2220	str_cat_double_inv, str_cat_cplx_inv, str_cat_dcplx_inv
2221	END INTERFACE
2222
2223
2224	CONTAINS
2225
2226	! Extended strings features
2227	! ---------------------------
2228
2229	FUNCTION str_cat_int(str1,int2) RESULT(str)
2230	!! Concatenate a string with a integer
2231	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2232	INTEGER, INTENT(in) :: int2 !! Integer to concatenate
2233	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2234	ALLOCATE(CHARACTER(len=DIGITS(int2)) :: str)
2235	WRITE(str,*) int2 ; str = TRIM(ADJUSTL(str))
2236	IF (LEN(str1) /= 0) str = str1//str
2237	RETURN
2238	END FUNCTION str_cat_int
2239
2240	!! @param[in] int2 An integer to concatenate
2241	!! @param[in] str1 A string to concatenate
2242	!! @return An allocatable string with the concatenation of input values.
2243	FUNCTION str_cat_int_inv(int2,str1) RESULT(str)
2244	!! Concatenate a string with a integer (inversed)
2245	INTEGER, INTENT(in) :: int2 !! Integer to concatenate
2246	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2247	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2248	ALLOCATE(CHARACTER(len=DIGITS(int2)) :: str)
2249	WRITE(str,*) int2 ; str = TRIM(ADJUSTL(str))
2250	IF (LEN(str1) /= 0) str = str//str1
2251	RETURN
2252	END FUNCTION str_cat_int_inv
2253
2254	FUNCTION str_cat_bool(str1,bool2) RESULT(str)
2255	!! Concatenate a string with a logical
2256	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2257	LOGICAL, INTENT(in) :: bool2 !! Logical to concatenate
2258	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2259	CHARACTER(len=2) :: tmp
2260	WRITE(tmp,*) bool2
2261	str=TRIM(ADJUSTL(tmp))
2262	IF (LEN(str1) /= 0) str = str1//str
2263	RETURN
2264	END FUNCTION str_cat_bool
2265
2266	FUNCTION str_cat_bool_inv(bool2,str1) RESULT(str)
2267	!! Concatenate a string with a logical (inversed)
2268	LOGICAL, INTENT(in) :: bool2 !! Logical to concatenate
2269	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2270	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2271	CHARACTER(len=2) :: tmp
2272	WRITE(tmp,*) bool2
2273	str = TRIM(ADJUSTL(tmp))
2274	IF (LEN(str1) /= 0) str = str//str1
2275	RETURN
2276	END FUNCTION str_cat_bool_inv
2277
2278	FUNCTION str_cat_real(str1,real2) RESULT(str)
2279	!! Concatenate a string with a real simple precision
2280	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2281	REAL(kind=4), INTENT(in) :: real2 !! Simple precision real to concatenate
2282	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2283	ALLOCATE(CHARACTER(len=DIGITS(real2)) :: str)
2284	WRITE(str,*) real2 ; str = TRIM(ADJUSTL(str))
2285	IF (LEN(str1) /= 0) str=str1//str
2286	RETURN
2287	END FUNCTION str_cat_real
2288
2289	FUNCTION str_cat_real_inv(real2,str1) RESULT(str)
2290	!! Concatenate a string with a real simple precision (inversed)
2291	REAL(kind=4), INTENT(in) :: real2 !! Simple precision real to concatenate
2292	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2293	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2294	ALLOCATE(CHARACTER(len=DIGITS(real2)) :: str)
2295	WRITE(str,*) real2 ; str = TRIM(ADJUSTL(str))
2296	IF (LEN(str1) /= 0) str = str//str1
2297	RETURN
2298	END FUNCTION str_cat_real_inv
2299
2300	FUNCTION str_cat_double(str1,double2) RESULT(str)
2301	!! Concatenate a string with a real double precision
2302	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2303	REAL(kind=8), INTENT(in) :: double2 !! Double precision real to concatenate
2304	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2305	ALLOCATE(CHARACTER(len=DIGITS(double2)) :: str)
2306	WRITE(str,*) double2 ; str = TRIM(ADJUSTL(str))
2307	IF (LEN(str1) /= 0) str=str1//str
2308	RETURN
2309	END FUNCTION str_cat_double
2310
2311	FUNCTION str_cat_double_inv(double2,str1) RESULT(str)
2312	!! Concatenate a string with a real double precision (inversed)
2313	REAL(kind=8), INTENT(in) :: double2 !! Double precision real to concatenate
2314	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2315	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2316	ALLOCATE(CHARACTER(len=DIGITS(double2)) :: str)
2317	WRITE(str,*) double2 ; str = TRIM(ADJUSTL(str))
2318	IF (LEN(str1) /= 0) str = str//str1
2319	RETURN
2320	END FUNCTION str_cat_double_inv
2321
2322	FUNCTION str_cat_cplx(str1,cplx2) RESULT(str)
2323	!! Concatenate a string with a complex
2324	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2325	COMPLEX(kind=4), INTENT(in) :: cplx2 !! Complex value to concatenate
2326	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2327	INTEGER :: sl
2328	sl = DIGITS(REAL(cplx2))*2+3
2329	ALLOCATE(CHARACTER(len=sl) :: str)
2330	WRITE(str,*) cplx2 ; str = TRIM(ADJUSTL(str))
2331	IF (LEN(str1) /= 0) str = str//str1
2332	RETURN
2333	END FUNCTION str_cat_cplx
2334
2335	FUNCTION str_cat_cplx_inv(cplx2,str1) RESULT(str)
2336	!! Concatenate a string with a complex (inversed)
2337	COMPLEX(kind=4), INTENT(in) :: cplx2 !! Complex value to concatenate
2338	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2339	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2340	INTEGER :: sl
2341	sl = DIGITS(REAL(cplx2))*2+3
2342	ALLOCATE(CHARACTER(len=sl) :: str)
2343	WRITE(str,*) cplx2
2344	str = TRIM(ADJUSTL(str))
2345	IF (LEN(str1) /= 0) str = str//str1
2346	RETURN
2347	END FUNCTION str_cat_cplx_inv
2348
2349	FUNCTION str_cat_dcplx(str1,dcplx2) RESULT(str)
2350	!! Concatenate a string with a double precision complex
2351	CHARACTER(len=*), INTENT(in) :: str1 !! String to concatenate
2352	COMPLEX(kind=8), INTENT(in) :: dcplx2 !! Complex value to concatenate
2353	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2354	INTEGER :: sl
2355	sl = DIGITS(REAL(dcplx2))*2+3
2356	ALLOCATE(CHARACTER(len=sl) :: str)
2357	WRITE(str,*) dcplx2 ; str = TRIM(ADJUSTL(str))
2358	IF (LEN(str1) /= 0) str = str//str1
2359	RETURN
2360	END FUNCTION str_cat_dcplx
2361
2362	FUNCTION str_cat_dcplx_inv(dcplx2,str1) RESULT(str)
2363	!! Concatenate a string with a double precision complex (inversed)
2364	COMPLEX(kind=8), INTENT(in) :: dcplx2 !! Complex value to concatenate
2365	CHARACTER(len=*), INTENT(in) :: str1 !! string to concatenate
2366	CHARACTER(len=:), ALLOCATABLE :: str !! Concatenation resulting string
2367	INTEGER :: sl
2368	sl = DIGITS(REAL(dcplx2))*2+3
2369	ALLOCATE(CHARACTER(len=sl) :: str)
2370	WRITE(str,*) dcplx2
2371	str = TRIM(ADJUSTL(str))
2372	IF (LEN(str1) /= 0) str = str//str1
2373	RETURN
2374	END FUNCTION str_cat_dcplx_inv
2375
2376	SUBROUTINE str_affect_int(str,int)
2377	!! Assignment subroutine (using intrinsic integer)
2378	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2379	INTEGER, INTENT(in) :: int !! Input value to assign
2380	str = str_cat_int('',int)
2381	END SUBROUTINE str_affect_int
2382
2383	SUBROUTINE str_affect_bool(str,bool)
2384	!! Assignment subroutine (using intrinsic logical)
2385	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2386	LOGICAL, INTENT(in) :: bool !! Input value to assign
2387	str = str_cat_bool('',bool)
2388	END SUBROUTINE str_affect_bool
2389
2390	SUBROUTINE str_affect_real(str,float)
2391	!! Assignment subroutine (using intrinsic real)
2392	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2393	REAL(kind=4), INTENT(in) :: float !! Input value to assign
2394	str = str_cat_real('',float)
2395	END SUBROUTINE str_affect_real
2396
2397	SUBROUTINE str_affect_double(str,double)
2398	!! Assignment subroutine (using intrinsic real(kind=8))
2399	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2400	REAL(kind=8), INTENT(in) :: double !! Input value to assign
2401	str = str_cat_double('',double)
2402	END SUBROUTINE str_affect_double
2403
2404	SUBROUTINE str_affect_cplx(str,cplx)
2405	!! Assignment subroutine (using intrinsic complex)
2406	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2407	COMPLEX(kind=4), INTENT(in) :: cplx !! Input value to assign
2408	str = str_cat_cplx('',cplx)
2409	END SUBROUTINE str_affect_cplx
2410
2411	SUBROUTINE str_affect_dcplx(str,dcplx)
2412	!! Assignment subroutine (using intrinsic complex(kind=8))
2413	CHARACTER(len=:), INTENT(out), ALLOCATABLE :: str !! Output string to be assigned
2414	COMPLEX(kind=8), INTENT(in) :: dcplx !! Input value to assign
2415	str = str_cat_dcplx('',dcplx)
2416	END SUBROUTINE str_affect_dcplx
2417
2418	END MODULE estrings

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format