Context Navigation

string_op.F90 @ 3094

Last change on this file since 3094 was 3090, checked in by slebonnois, 15 months ago
BdeBatz? : Cleans microphysics and makes few corrections for physics
File size: 101.2 KB

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

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

Download in other formats:

Original Format