source: trunk/LMDZ.TITAN/libf/muphytitan/string_op.F90 @ 3026

Last change on this file since 3026 was 1897, checked in by jvatant, 7 years ago

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