source: LMDZ6/trunk/libf/misc/strings_mod.F90 @ 5001

Last change on this file since 5001 was 5001, checked in by dcugnet, 3 months ago
  • strings_mod:
    • remove "test()" function (was not very clear)
    • modifications of the "str2bool" function: result is O/1 for .FALSE./.TRUE. and -1 if the string was not a boolean.
    • more general "find()" function (for several numerical types)
    • more general "cat()" function (can append a 2D array with vectors, 1D arrays with scalars)
    • few simplifications (in "strParse") and minor changes
  • readTracFiles_mod:
    • remove internal usage of direct keys ("%" symbol) in favor of the "getKey" function. => moving toward a totally generic tracers derived type.
    • improve the internal management of the error return value "lerr".
    • remove "fGetKey", "fGetKeys", "setDirectKeys" functions
    • new functions to add/remove a phase: "addPhase", "delPhase"
    • more general "addKey(key[(:)], val[(:)], ky(:), [lOverWrite])" function: . input argument "val" can be string/integer/real/logical . (key, val, ky ): add the <key> =<val> pair to ky . (key, val(:), ky(:)): add the <key> =<val(i)> pair to ky(i) for 1<=i<=SIZE(ky) . (key(:), val(:), ky(:)): add the <key(i)>=<val(i)> pair to ky(i) for 1<=i<=SIZE(ky)
    • more general "getKey(key[(:)], val[(:)], itr [, ky(:)][, nam(:)][, def][, lDisp])" (tracer index version)

and "getKey(key[(:)], val[(:)], tname[, ky(:)]. [, def][, lDisp])" (tracer name version) functions:

. output argument "val" can be string/integer/real/logical
. if present, the default value <def> is retained if the corresponding key was not found.
. get values from "ky(:)" if present, otherwise from internal database "tracers(:)" or "isotope ».
. if "keyn" is a vector, try with each element in indices order until a value is found
. (key[(:)], val, itr/tname[,ky(:)][, ...]): get the value <val> of tracer nr. itr or named "tname"
. (key[(:)], val(:), itr/tname[,ky(:)][, ...]): same + parsing of the value with « , », then storage in <val(:)>
. (key[(:)], val(:)[, ky(:)][, nam(:)][, ...]): same for all tracers (optional names list <nam(:)>) of database.
. (key[(:)], val(:), tname(:)[, ky(:)][, ...]): same for the tracers named « tnames(:)"

  • more general "dispTraSection" function
  • much simplified "indexUpdate" function ; "ancestor*" and "idxAncestor" functions are removed.
  • "readIsotopesFile" is renamed to "processIsotopes" for more clarity
  • cosmetic changes
  • fix for isotopes: iq_val and iq_liq are usable for "q" only, not for "q_follow" and "zx_defau_diag" => use hardcoded indices (1 for vapor and 2 for liquid) for these variables
File size: 92.8 KB
Line 
1MODULE strings_mod
2
3  IMPLICIT NONE
4
5  PRIVATE
6  PUBLIC :: maxlen, init_printout, msg, fmsg, get_in, lunout, prt_level
7  PUBLIC :: strLower, strHead, strStack,  strCount, strReduce,  strClean, strIdx
8  PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, cat
9  PUBLIC :: dispTable, dispOutliers, dispNameList
10  PUBLIC :: is_numeric, bool2str, int2str, real2str, dble2str
11  PUBLIC :: reduceExpr, str2bool, str2int, str2real, str2dble
12  PUBLIC :: addQuotes, checkList, removeComment
13
14  INTERFACE get_in;     MODULE PROCEDURE getin_s,  getin_i,  getin_r,  getin_l;  END INTERFACE get_in
15  INTERFACE  msg;       MODULE PROCEDURE        msg_1,                    msg_m; END INTERFACE  msg
16  INTERFACE fmsg;       MODULE PROCEDURE       fmsg_1,                   fmsg_m; END INTERFACE fmsg
17  INTERFACE strHead;    MODULE PROCEDURE    strHead_1,                strHead_m; END INTERFACE strHead
18  INTERFACE strTail;    MODULE PROCEDURE    strTail_1,                strTail_m; END INTERFACE strTail
19  INTERFACE strClean;   MODULE PROCEDURE   strClean_1,               strClean_m; END INTERFACE strClean
20  INTERFACE strReduce;  MODULE PROCEDURE  strReduce_1,              strReduce_2; END INTERFACE strReduce
21  INTERFACE strIdx;     MODULE PROCEDURE     strIdx_1,                 strIdx_m; END INTERFACE strIdx
22  INTERFACE strCount;   MODULE PROCEDURE  strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount
23  INTERFACE strReplace; MODULE PROCEDURE strReplace_1,             strReplace_m; END INTERFACE strReplace
24  INTERFACE cat;        MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00,  & !horzcat_d00, &
25                                          horzcat_s10, horzcat_i10, horzcat_r10,  & !horzcat_d10, &
26                                          horzcat_s11, horzcat_i11, horzcat_r11,  & !horzcat_d11, &
27                                          horzcat_s21, horzcat_i21, horzcat_r21; END INTERFACE cat !horzcat_d21
28  INTERFACE strFind;      MODULE PROCEDURE strFind_1, strFind_m;                 END INTERFACE strFind
29  INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find
30  INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
31  INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
32  INTERFACE addQuotes;    MODULE PROCEDURE    addQuotes_1,    addQuotes_m; END INTERFACE addQuotes
33
34  INTEGER, PARAMETER :: maxlen    = 256                    !--- Standard maximum length for strings
35  INTEGER,      SAVE :: lunout    = 6                      !--- Printing unit  (default: 6, ie. on screen)
36  INTEGER,      SAVE :: prt_level = 1                      !--- Printing level (default: 1, ie. print all)
37
38CONTAINS
39
40
41!==============================================================================================================================
42SUBROUTINE init_printout(lunout_, prt_level_)
43  IMPLICIT NONE
44  INTEGER, INTENT(IN) :: lunout_, prt_level_
45  lunout    = lunout_
46  prt_level = prt_level_
47END SUBROUTINE init_printout
48!==============================================================================================================================
49
50
51!==============================================================================================================================
52!=== Same as getin ; additional last argument: the default value.
53!==============================================================================================================================
54SUBROUTINE getin_s(nam, val, def)
55  USE ioipsl_getincom, ONLY: getin
56  IMPLICIT NONE
57  CHARACTER(LEN=*), INTENT(IN)    :: nam
58  CHARACTER(LEN=*), INTENT(INOUT) :: val
59  CHARACTER(LEN=*), INTENT(IN)    :: def
60  val = def; CALL getin(nam, val)
61  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(val)
62END SUBROUTINE getin_s
63!==============================================================================================================================
64SUBROUTINE getin_i(nam, val, def)
65  USE ioipsl_getincom, ONLY: getin
66  IMPLICIT NONE
67  CHARACTER(LEN=*), INTENT(IN)    :: nam
68  INTEGER,          INTENT(INOUT) :: val
69  INTEGER,          INTENT(IN)    :: def
70  val = def; CALL getin(nam, val)
71  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(int2str(val))
72END SUBROUTINE getin_i
73!==============================================================================================================================
74SUBROUTINE getin_r(nam, val, def)
75  USE ioipsl_getincom, ONLY: getin
76  IMPLICIT NONE
77  CHARACTER(LEN=*), INTENT(IN)    :: nam
78  REAL,             INTENT(INOUT) :: val
79  REAL,             INTENT(IN)    :: def
80  val = def; CALL getin(nam, val)
81  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(real2str(val))
82END SUBROUTINE getin_r
83!==============================================================================================================================
84SUBROUTINE getin_l(nam, val, def)
85  USE ioipsl_getincom, ONLY: getin
86  IMPLICIT NONE
87  CHARACTER(LEN=*), INTENT(IN)    :: nam
88  LOGICAL,          INTENT(INOUT) :: val
89  LOGICAL,          INTENT(IN)    :: def
90  val = def; CALL getin(nam, val)
91  IF(val.NEQV.def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(bool2str(val))
92END SUBROUTINE getin_l
93!==============================================================================================================================
94
95
96!==============================================================================================================================
97!=== Display one or several messages, one each line, starting with the current routine name "modname".
98!==============================================================================================================================
99SUBROUTINE msg_1(str, modname, ll, unit)
100  IMPLICIT NONE
101  !--- Display a simple message "str". Optional parameters:
102  !    * "modname": module name, displayed in front of the message (with ": " separator) if present.
103  !    * "ll":      message trigger ; message is displayed only if ll==.TRUE.
104  !    * "unit":    write unit (by default: "lunout")
105  CHARACTER(LEN=*),           INTENT(IN) :: str
106  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
107  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
108  INTEGER,          OPTIONAL, INTENT(IN) :: unit
109!------------------------------------------------------------------------------------------------------------------------------
110  CHARACTER(LEN=maxlen) :: subn
111  INTEGER :: unt
112  subn = '';    IF(PRESENT(modname)) subn = modname
113  IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF
114  unt = lunout; IF(PRESENT(unit)) unt = unit
115  IF(subn == '') WRITE(unt,'(a)') str                                          !--- Simple message
116  IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str                        !--- Routine name provided
117END SUBROUTINE msg_1
118!==============================================================================================================================
119SUBROUTINE msg_m(str, modname, ll, unit, nmax)
120  IMPLICIT NONE
121  !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines.
122  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
123  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
124  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
125  INTEGER,          OPTIONAL, INTENT(IN) :: unit
126  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
127!------------------------------------------------------------------------------------------------------------------------------
128  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
129  CHARACTER(LEN=maxlen) :: subn
130  INTEGER :: unt, nmx, k
131  LOGICAL :: l
132  subn = '';    IF(PRESENT(modname)) subn = modname
133  l   = .TRUE.; IF(PRESENT(ll))     l = ll
134  unt = lunout; IF(PRESENT(unit)) unt = unit
135  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
136  s = strStackm(str, ', ', nmx)
137  DO k=1,SIZE(s); CALL msg_1(s(k), subn,  l,   unt); END DO
138END SUBROUTINE msg_m
139!==============================================================================================================================
140LOGICAL FUNCTION fmsg_1(str, modname, ll, unit) RESULT(l)
141  IMPLICIT NONE
142  CHARACTER(LEN=*),           INTENT(IN) :: str
143  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
144  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
145  INTEGER,          OPTIONAL, INTENT(IN) :: unit
146!------------------------------------------------------------------------------------------------------------------------------
147  CHARACTER(LEN=maxlen) :: subn
148  INTEGER :: unt
149  subn = '';    IF(PRESENT(modname)) subn = modname
150  l   = .TRUE.; IF(PRESENT(ll))     l = ll
151  unt = lunout; IF(PRESENT(unit)) unt = unit
152  CALL msg_1(str, subn, l, unt)
153END FUNCTION fmsg_1
154!==============================================================================================================================
155LOGICAL FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(l)
156  IMPLICIT NONE
157  CHARACTER(LEN=*),           INTENT(IN)  :: str(:)
158  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
159  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
160  INTEGER,          OPTIONAL, INTENT(IN) :: unit
161  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax
162!------------------------------------------------------------------------------------------------------------------------------
163  CHARACTER(LEN=maxlen) :: subn
164  INTEGER :: unt, nmx
165  subn = '';    IF(PRESENT(modname)) subn = modname
166  l   = .TRUE.; IF(PRESENT(ll))     l = ll
167  unt = lunout; IF(PRESENT(unit)) unt = unit
168  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
169  CALL msg_m(str, subn, l, unt, nmx)
170END FUNCTION fmsg_m
171!==============================================================================================================================
172
173
174!==============================================================================================================================
175!=== Lower/upper case conversion function. ====================================================================================
176!==============================================================================================================================
177ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out)
178  IMPLICIT NONE
179  CHARACTER(LEN=*), INTENT(IN) :: str
180  INTEGER :: k
181  out = str
182  DO k=1,LEN_TRIM(str)
183    IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)
184  END DO
185END FUNCTION strLower
186!==============================================================================================================================
187ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out)
188  IMPLICIT NONE
189  CHARACTER(LEN=*), INTENT(IN) :: str
190  INTEGER :: k
191  out = str
192  DO k=1,LEN_TRIM(str)
193    IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)
194  END DO
195END FUNCTION strUpper
196!==============================================================================================================================
197
198
199!==============================================================================================================================
200!=== Extract the substring in front of the first (last if lBackward==TRUE) occurrence of "sep" in "str"        ================
201!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
202!===    * strHead(..,.FALSE.) = 'a'           ${str%%$sep*}                                                    ================
203!===    * strHead(..,.TRUE.)  = 'a_b'         ${str%$sep*}                                                     ================
204!==============================================================================================================================
205CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out)
206  IMPLICIT NONE
207  CHARACTER(LEN=*),           INTENT(IN) :: str
208  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
209  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
210!------------------------------------------------------------------------------------------------------------------------------
211  IF(PRESENT(sep)) THEN
212    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,sep,lBackWard)-1)
213    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,sep)-1)
214  ELSE
215    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,'/',lBackWard)-1)
216    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,'/')-1)
217  END IF
218  IF(out == '') out = str
219END FUNCTION strHead_1
220!==============================================================================================================================
221FUNCTION strHead_m(str, sep, lBackward) RESULT(out)
222  IMPLICIT NONE
223  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
224  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
225  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
226  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
227!------------------------------------------------------------------------------------------------------------------------------
228  INTEGER :: k
229  IF(PRESENT(sep)) THEN
230    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), sep, lBackWard), k=1, SIZE(str))]
231    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), sep),            k=1, SIZE(str))]
232  ELSE
233    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), '/', lBackWard), k=1, SIZE(str))]
234    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), '/'),            k=1, SIZE(str))]
235  END IF
236END FUNCTION strHead_m
237!==============================================================================================================================
238!=== Extract the substring following the first (last if lBackward==TRUE) occurrence of "sep" in "str"          ================
239!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
240!===    * strTail(str, '_', .FALSE.) = 'b_c'         ${str#*$sep}                                              ================
241!===    * strTail(str, '_', .TRUE.)  = 'c'           ${str##*$sep}                                             ================
242!==============================================================================================================================
243CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out)
244  IMPLICIT NONE
245  CHARACTER(LEN=*),           INTENT(IN) :: str
246  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
247  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
248!------------------------------------------------------------------------------------------------------------------------------
249  IF(PRESENT(sep)) THEN
250    IF(     PRESENT(lBackWard)) out = str(INDEX(str,sep,lBackWard)+LEN(sep):LEN_TRIM(str))
251    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,sep)          +LEN(sep):LEN_TRIM(str))
252  ELSE
253    IF(     PRESENT(lBackWard)) out = str(INDEX(str,'/',lBackWard)+1:LEN_TRIM(str))
254    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,'/')          +1:LEN_TRIM(str))
255  END IF
256  IF(out == '') out = str
257END FUNCTION strTail_1
258!==============================================================================================================================
259FUNCTION strTail_m(str, sep, lBackWard) RESULT(out)
260  IMPLICIT NONE
261  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
262  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
263  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
264  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
265!------------------------------------------------------------------------------------------------------------------------------
266  INTEGER :: k
267  IF(PRESENT(sep)) THEN
268    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), sep, lBackWard), k=1, SIZE(str))]
269    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), sep),            k=1, SIZE(str))]
270  ELSE
271    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), '/', lBackWard), k=1, SIZE(str))]
272    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), '/'),            k=1, SIZE(str))]
273  END IF
274END FUNCTION strTail_m
275!==============================================================================================================================
276
277
278!==============================================================================================================================
279!=== Concatenates the strings "str(:)" with separator "sep" into a single string using a separator (',' by default). ==========
280!==============================================================================================================================
281FUNCTION strStack(str, sep, mask) RESULT(out)
282  IMPLICIT NONE
283  CHARACTER(LEN=:),          ALLOCATABLE :: out
284  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
285  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
286  LOGICAL,          OPTIONAL, INTENT(IN) :: mask(:)
287!------------------------------------------------------------------------------------------------------------------------------
288  CHARACTER(LEN=:), ALLOCATABLE :: s
289  INTEGER :: is, i0
290  IF(SIZE(str) == 0) THEN; out = ''; RETURN; END IF
291  ALLOCATE(s, SOURCE=', '); IF(PRESENT(sep)) s=sep
292  IF(PRESENT(mask)) THEN
293    IF(ALL(.NOT.mask)) THEN; out = ''; RETURN; END IF
294    i0 = 0; DO WHILE(.NOT.mask(i0+1)); i0 = i0+1; END DO
295    out = str(i0); DO is=i0+1,SIZE(str, DIM=1); IF(.NOT.mask(is)) CYCLE; out = TRIM(out)//s//TRIM(str(is)); END DO
296  ELSE
297    out = str(1); DO is=2,SIZE(str, DIM=1); out = TRIM(out)//s//TRIM(str(is)); END DO
298  END IF
299END FUNCTION strStack
300!==============================================================================================================================
301!=== Concatenate the strings "str(:)" with separator "sep" into one or several lines of "nmax" characters max (for display) ===
302!==============================================================================================================================
303FUNCTION strStackm(str, sep, nmax) RESULT(out)
304  IMPLICIT NONE
305  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
306  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
307  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
308  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
309!------------------------------------------------------------------------------------------------------------------------------
310  CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:)
311  CHARACTER(LEN=maxlen) :: sp
312  INTEGER :: is, ns, no, mx, n
313  IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF
314  sp =', '; IF(PRESENT(sep )) sp = sep
315  ns = 2  ; IF(PRESENT(sep )) ns = LEN(sep)
316  mx = 256; IF(PRESENT(nmax)) mx = nmax
317  no = 1; out = ['']
318  DO is = 1, SIZE(str)
319    n = LEN_TRIM(str(is)); IF(out(no)/='') n = n+ns+LEN_TRIM(out(no))          !--- Line length after "str(is)" inclusion
320    IF(out(no) == '') THEN
321      out(no) = str(is)                                                        !--- Empty new line: set to "str(is)"
322    ELSE IF(n <= mx) THEN
323      out(no) = TRIM(out(no))//sp(1:ns)//TRIM(str(is))                         !--- Append "str(is)" to the current line
324    ELSE
325      ALLOCATE(t(no+1)); t(1:no) = out; no=no+1; t(no) = str(is)               !--- Full line: "str(si)" put in next line
326      CALL MOVE_ALLOC(FROM=t, TO=out)
327    END IF
328  END DO
329END FUNCTION strStackm
330!==============================================================================================================================
331
332
333!==============================================================================================================================
334!=== String cleaning: replace tabulation by spaces, remove NULL characters and comments. ======================================
335!==============================================================================================================================
336SUBROUTINE strClean_1(str)
337  IMPLICIT NONE
338  CHARACTER(LEN=*), INTENT(INOUT) :: str
339  INTEGER :: k, n, m
340  n = LEN(str)
341  DO k = n, 1, -1
342    m = IACHAR(str(k:k))
343    IF(m==9) str(k:k) = ' '                           !--- Replace the tabulations with spaces
344    IF(m==0) str(k:n) = str(k+1:n)//' '               !--- Remove the NULL characters
345  END DO
346  m = INDEX(str,'!')-1; IF(m==-1) m = LEN_TRIM(str)   !--- Remove end of line comment
347  str = ADJUSTL(str(1:m))
348END SUBROUTINE strClean_1
349!==============================================================================================================================
350SUBROUTINE strClean_m(str)
351  IMPLICIT NONE
352  CHARACTER(LEN=*), INTENT(INOUT) :: str(:)
353  INTEGER :: k
354  DO k = 1, SIZE(str); CALL strClean_1(str(k)); END DO
355END SUBROUTINE strClean_m
356!==============================================================================================================================
357
358
359!==============================================================================================================================
360!=== strReduce_1(str1)     : Remove duplicated elements of str1.    ===========================================================
361!=== strReduce_2(str1,str2): Append str1 with new elements of str2. ===========================================================
362!==============================================================================================================================
363SUBROUTINE strReduce_1(str, nb)
364  IMPLICIT NONE
365  CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:)
366  INTEGER,          OPTIONAL,    INTENT(OUT)   :: nb
367!------------------------------------------------------------------------------------------------------------------------------
368  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:)
369  INTEGER :: k, n, n1
370  IF(PRESENT(nb)) nb = 0
371  CALL MOVE_ALLOC(FROM=str, TO=s1); CALL strClean(s1)
372  n1 = SIZE(s1, DIM=1)                                     !--- Total nb. of elements in "s1"
373  n  = COUNT( [( ALL(s1(1:k-1)/=s1(k)), k=1, n1 )] )       !--- Nb of unique elements in "s1"
374  ALLOCATE(str(n))
375  IF(n==0) RETURN
376  str(1) = s1(1)
377  n=1; DO k=2,n1; IF(ANY(s1(1:k-1)==s1(k))) CYCLE; n=n+1; str(n)=s1(k); END DO
378  IF(PRESENT(nb)) nb=n
379END SUBROUTINE strReduce_1
380!==============================================================================================================================
381SUBROUTINE strReduce_2(str1, str2)
382  IMPLICIT NONE
383  CHARACTER(LEN=*),   ALLOCATABLE, INTENT(INOUT) :: str1(:)
384  CHARACTER(LEN=*),                INTENT(IN)    :: str2(:)
385!------------------------------------------------------------------------------------------------------------------------------
386  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:)
387  INTEGER :: k
388  IF(SIZE(str2)==0) RETURN
389  s2 = str2; CALL strClean(s2)
390  IF(.NOT.ALLOCATED(s2)) RETURN
391  IF(SIZE(s2) == 0) THEN; DEALLOCATE(s2); RETURN; END IF
392  IF(.NOT.ALLOCATED(str1)) THEN
393    str1 = s2
394  ELSE IF(SIZE(str1)==0) THEN
395    str1 = s2
396  ELSE
397    s1 = str1; CALL strClean(s1)
398    str1 = [s1, PACK(s2, MASK= [( ALL(s1(:) /= s2(k)), k=1, SIZE(s2) )] ) ]
399  END IF
400END SUBROUTINE strReduce_2
401!==============================================================================================================================
402
403
404!==============================================================================================================================
405!=== GET THE INDEX OF THE FIRST APPEARANCE IN THE STRING VECTOR "str(:)" OF THE STRING(s) "s[(:)]" ============================
406!=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0                       ============================
407!==============================================================================================================================
408INTEGER FUNCTION strIdx_1(str, s) RESULT(out)
409  IMPLICIT NONE
410  CHARACTER(LEN=*), INTENT(IN) :: str(:), s
411  DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO
412  IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0
413END FUNCTION strIdx_1
414!==============================================================================================================================
415FUNCTION strIdx_m(str, s, n) RESULT(out)
416  IMPLICIT NONE
417  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
418  INTEGER, OPTIONAL, INTENT(OUT) :: n
419  INTEGER,           ALLOCATABLE :: out(:)
420!------------------------------------------------------------------------------------------------------------------------------
421  INTEGER :: k
422  out = [(strIdx_1(str(:), s(k)), k=1, SIZE(s))]
423  IF(PRESENT(n)) n = COUNT(out(:)/=0)
424END FUNCTION strIdx_m
425!==============================================================================================================================
426
427
428!==============================================================================================================================
429!=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================
430!==============================================================================================================================
431FUNCTION strFind_1(str, s, n) RESULT(out)
432  IMPLICIT NONE
433  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s
434  INTEGER, OPTIONAL, INTENT(OUT) :: n
435  INTEGER,           ALLOCATABLE :: out(:)
436!------------------------------------------------------------------------------------------------------------------------------
437  INTEGER :: k
438  out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s )
439  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
440END FUNCTION strFind_1
441!==============================================================================================================================
442FUNCTION strFind_m(str, s, n) RESULT(out)
443  IMPLICIT NONE
444  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
445  INTEGER, OPTIONAL, INTENT(OUT) :: n
446  INTEGER,           ALLOCATABLE :: out(:)
447!------------------------------------------------------------------------------------------------------------------------------
448  INTEGER :: k
449  out = [(strFind_1(str, s(k)), k=1, SIZE(s))]
450  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
451END FUNCTION strFind_m
452!==============================================================================================================================
453FUNCTION intFind_1(i,j,n) RESULT(out)
454  IMPLICIT NONE
455  INTEGER,           INTENT(IN)  :: i(:), j
456  INTEGER, OPTIONAL, INTENT(OUT) :: n
457  INTEGER,           ALLOCATABLE :: out(:)
458!------------------------------------------------------------------------------------------------------------------------------
459  INTEGER :: k
460  out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j )
461  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
462END FUNCTION intFind_1
463!==============================================================================================================================
464FUNCTION intFind_m(i,j,n) RESULT(out)
465  IMPLICIT NONE
466  INTEGER,           INTENT(IN)  :: i(:), j(:)
467  INTEGER, OPTIONAL, INTENT(OUT) :: n
468  INTEGER,           ALLOCATABLE :: out(:)
469!------------------------------------------------------------------------------------------------------------------------------
470  INTEGER :: k
471  out = [(intFind_1(i, j(k)), k=1, SIZE(j))]
472  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
473END FUNCTION intFind_m
474!==============================================================================================================================
475FUNCTION booFind(l,n) RESULT(out)
476   IMPLICIT NONE
477 LOGICAL,           INTENT(IN)  :: l(:)
478  INTEGER, OPTIONAL, INTENT(OUT) :: n
479  INTEGER,           ALLOCATABLE :: out(:)
480!------------------------------------------------------------------------------------------------------------------------------
481  INTEGER :: k
482  out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) )
483  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
484END FUNCTION booFind
485!==============================================================================================================================
486
487
488!==============================================================================================================================
489!=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT)
490!===  IF lSc == .TRUE.:  * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS
491!===                     * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER
492!==============================================================================================================================
493LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr)
494  IMPLICIT NONE
495  CHARACTER(LEN=*),  INTENT(IN)  :: rawList                          !--- String in which delimiters have to be identified
496  CHARACTER(LEN=*),  INTENT(IN)  :: del(:)                           !--- List of delimiters
497  INTEGER,           INTENT(IN)  :: ibeg                             !--- Start index
498  INTEGER,           INTENT(OUT) :: idx                              !--- Index of the first identified delimiter in "rawList"
499  INTEGER,           INTENT(OUT) :: idel                             !--- Index of the identified delimiter (0 if idx==0)
500  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc                              !--- Care about nbs with front sign or in scient. notation
501!------------------------------------------------------------------------------------------------------------------------------
502  INTEGER :: idx0                                                    !--- Used to display an identified non-numeric string
503  lerr = .FALSE.
504  idx = strIdx1(rawList, del, ibeg, idel)                            !--- idx/=0: del(idel) is at position "idx" in "rawList"
505  IF(.NOT.PRESENT(lSc))               RETURN                         !--- No need to check exceptions for numbers => finished
506  IF(.NOT.        lSc )               RETURN                         !--- No need to check exceptions for numbers => finished
507
508  !=== No delimiter found: the whole string must be a valid number
509  IF(idx == 0) THEN                                                  !--- No element of "del" in "rawList"
510    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- String must be a number
511    IF(lerr) idx = LEN_TRIM(rawList); RETURN                         !--- Set idx so that rawList(ibeg:idx-1) = whole string
512  END IF
513
514  lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN  !--- The front delimiter is different from +/-: error
515  IF(    idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1)))     RETURN  !--- The input string head is a valid number
516
517  !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx"
518  idx0 = idx ; idx = strIdx1(rawList, del, idx+1, idel)              !--- Keep start index because idx is recycled
519  IF(idx == 0) THEN
520    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- No other delimiter: whole string must be a valid numb
521    IF(lerr) idx = idx0; RETURN
522  END IF
523  lerr = .NOT.is_numeric(rawList(ibeg:idx-1))
524
525CONTAINS
526
527!------------------------------------------------------------------------------------------------------------------------------
528INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i)
529!--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib".
530!--- "id" is the index in "del(:)" of the first delimiter found.
531  IMPLICIT NONE
532  CHARACTER(LEN=*),  INTENT(IN)  :: str, del(:)
533  INTEGER,           INTENT(IN)  :: ib
534  INTEGER,           INTENT(OUT) :: id
535!------------------------------------------------------------------------------------------------------------------------------
536  DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO
537  IF(i > LEN_TRIM(str)) THEN; i = 0; id = 0; END IF
538END FUNCTION strIdx1
539
540END FUNCTION strIdx_prv
541!==============================================================================================================================
542
543
544!==============================================================================================================================
545!=== Count the number of elements separated by "delimiter" in list "rawList". =================================================
546!==============================================================================================================================
547LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr)
548  IMPLICIT NONE
549  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
550  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter
551  INTEGER,           INTENT(OUT) :: nb
552  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
553!------------------------------------------------------------------------------------------------------------------------------
554  LOGICAL :: ll
555  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
556  lerr = strCount_1m(rawList, [delimiter], nb, ll)
557END FUNCTION strCount_11
558!==============================================================================================================================
559LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr)
560  IMPLICIT NONE
561  CHARACTER(LEN=*),     INTENT(IN)  :: rawList(:)
562  CHARACTER(LEN=*),     INTENT(IN)  :: delimiter
563  INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:)
564  LOGICAL,    OPTIONAL, INTENT(IN)  :: lSc
565!------------------------------------------------------------------------------------------------------------------------------
566  LOGICAL :: ll
567  INTEGER :: id
568  ll  = .FALSE.; IF(PRESENT(lSc)) ll = lSc .AND. INDEX('+-', delimiter) /= 0
569  lerr = .TRUE.
570  ALLOCATE(nb(SIZE(rawList)))
571  DO id = 1, SIZE(rawList)
572    lerr = lerr .AND. strCount_1m(rawList(id), [delimiter], nb(id), ll)
573  END DO
574END FUNCTION strCount_m1
575!==============================================================================================================================
576LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr)
577  IMPLICIT NONE
578  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
579  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter(:)
580  INTEGER,           INTENT(OUT) :: nb
581  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
582!------------------------------------------------------------------------------------------------------------------------------
583  INTEGER              :: ib, ie, jd, nr
584  LOGICAL              :: ll
585  CHARACTER(LEN=1024)  :: r
586  lerr = .FALSE.
587  ll   = .FALSE.; IF(PRESENT(lSc)) ll = lSc
588  r  = TRIM(ADJUSTL(rawList))
589  nr = LEN_TRIM(r); IF(nr == 0) RETURN
590  nb = 1; ib = 1
591  DO
592    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
593    IF(fmsg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll=lerr)) RETURN
594    IF(ie == 0 .OR. jd == 0) EXIT
595    ib = ie + LEN(delimiter(jd))
596    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
597    nb = nb + 1
598  END DO
599END FUNCTION strCount_1m
600!==============================================================================================================================
601
602
603!==============================================================================================================================
604!=== Purpose: Parse "delimiter"-separated list "rawList" into the pair keys(:), vals(:).   ====================================
605!===          Corresponding "vals" remains empty if the element does not contain "=" sign. ====================================
606!==============================================================================================================================
607LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr)
608  IMPLICIT NONE
609  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter
610  CHARACTER(LEN=maxlen), ALLOCATABLE,           INTENT(OUT) :: keys(:)
611  INTEGER,                            OPTIONAL, INTENT(OUT) :: n
612  CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:)
613!------------------------------------------------------------------------------------------------------------------------------
614  CHARACTER(LEN=1024) :: r
615  INTEGER :: nr, nk
616  lerr = .FALSE.
617  r  = TRIM(ADJUSTL(rawList))
618  nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF
619  nk = countK()                                                      !--- COUNT THE ELEMENTS
620  CALL parseK(keys)                                                  !--- PARSE THE KEYS
621  IF(PRESENT(vals)) CALL parseV(vals)                                !--- PARSE <key>=<val> PAIRS
622  IF(PRESENT(n)) n = nk                                              !--- RETURN THE NUMBER OF KEYS
623  IF(PRESENT(vals)) &
624print*,'key ; val = '//TRIM(strStack(keys))//' ; '//TRIM(strStack(vals))
625
626CONTAINS
627
628!------------------------------------------------------------------------------------------------------------------------------
629INTEGER FUNCTION countK() RESULT(nkeys)
630!--- Get the number of elements after parsing.
631  IMPLICIT NONE
632!------------------------------------------------------------------------------------------------------------------------------
633  INTEGER :: ib, ie, nl
634  nkeys = 1; ib = 1; nl = LEN(delimiter)
635  DO
636    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
637    IF(ie == ib-1) EXIT
638    ib = ie + nl
639    DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr)      !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32)
640      ib = ib + 1
641    END DO     !--- Skip spaces before next chain
642    nkeys = nkeys+1
643  END DO
644END FUNCTION countK
645
646!------------------------------------------------------------------------------------------------------------------------------
647SUBROUTINE parseK(keys)
648!--- Parse the string separated by "delimiter" from "rawList" into "keys(:)"
649  IMPLICIT NONE
650  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:)
651!------------------------------------------------------------------------------------------------------------------------------
652  INTEGER :: ib, ie, ik
653  ALLOCATE(keys(nk))
654  ib = 1
655  DO ik = 1, nk
656    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
657    IF(ie == ib-1) EXIT
658    keys(ik) = r(ib:ie-1)                                            !--- Get the ikth key
659    ib = ie + LEN(delimiter)
660    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
661  END DO
662  keys(ik) = r(ib:nr)                                                !--- Get the last key
663END SUBROUTINE parseK
664
665!------------------------------------------------------------------------------------------------------------------------------
666SUBROUTINE parseV(vals)
667!--- Parse the <key>=<val> pairs in "keys(:)" into "keys" and "vals"
668  IMPLICIT NONE
669  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:)
670!------------------------------------------------------------------------------------------------------------------------------
671  CHARACTER(LEN=maxlen) :: key
672  INTEGER :: ik, ix
673  ALLOCATE(vals(nk))
674  DO ik = 1, nk; key = keys(ik)
675    vals(ik) = ''
676    ix = INDEX(key, '='); IF(ix == 0) CYCLE                          !--- First "=" index in "key"
677    vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key)))
678    keys(ik) = ADJUSTL(key(1:ix-1))
679  END DO
680END SUBROUTINE parseV
681
682END FUNCTION strParse
683!==============================================================================================================================
684LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr)
685  IMPLICIT NONE
686  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter(:)
687  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
688  INTEGER,               OPTIONAL,              INTENT(OUT) :: n        !--- Length of the parsed vector
689  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:)  !--- Values for <name>=<value> keys
690  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
691  INTEGER,               OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:)    !--- Indexes of the separators in "delimiter(:)" vector
692!------------------------------------------------------------------------------------------------------------------------------
693  CHARACTER(LEN=1024) :: r
694  INTEGER :: nr, ik, nk, ib, ie, jd
695  LOGICAL :: ll
696  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
697  lerr = strCount_1m(rawList, delimiter, nk, ll)
698  CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN
699
700  !--- FEW ALLOCATIONS
701  ALLOCATE(keys(nk))
702  IF(PRESENT(vals)) ALLOCATE(vals(nk))
703  IF(PRESENT(id))   ALLOCATE(id(nk-1))
704  IF(PRESENT(n)) n = nk
705
706  !--- PARSING
707  r  = TRIM(ADJUSTL(rawList))
708  nr = LEN_TRIM(r); IF(nr == 0) RETURN
709  ib = 1
710  DO ik = 1, nk-1
711    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
712    CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN
713    keys(ik) = r(ib:ie-1)
714    IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik))             !--- Parse a <key>=<val> pair
715    IF(PRESENT(id  )) id(ik) = jd                                    !--- Index in "delimiter(:)" of the "ik"th delimiter
716    ib = ie + LEN_TRIM( delimiter(jd) )                              !--- Length of the current delimiter
717    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
718  END DO
719  keys(nk) = r(ib:nr)
720  IF(PRESENT(vals)) CALL parseKeys(keys(nk), vals(nk))               !--- Parse a <key>=<val> pair
721
722CONTAINS
723
724!------------------------------------------------------------------------------------------------------------------------------
725SUBROUTINE parseKeys(key, val)
726  IMPLICIT NONE
727  CHARACTER(LEN=*), INTENT(INOUT) :: key
728  CHARACTER(LEN=*), INTENT(OUT)   :: val
729!------------------------------------------------------------------------------------------------------------------------------
730  INTEGER :: ix
731  ix = INDEX(key, '='); IF(ix == 0) RETURN                           !--- First "=" index in "key"
732  val = ADJUSTL(key(ix+1:LEN_TRIM(key)))
733  key = ADJUSTL(key(1:ix-1))
734END SUBROUTINE parseKeys
735
736END FUNCTION strParse_m   
737!==============================================================================================================================
738
739
740!==============================================================================================================================
741!=== String substitution: replace "key" by "val" each time it appears in "str".
742!==============================================================================================================================
743SUBROUTINE strReplace_1(str, key, val, lsurr)
744  IMPLICIT NONE
745  CHARACTER(LEN=*),  INTENT(INOUT) :: str        !--- Main string
746  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
747  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
748!------------------------------------------------------------------------------------------------------------------------------
749  INTEGER :: i0, ix, nk, ns
750  LOGICAL :: lsur, lb, le
751  lsur = .FALSE.; IF(PRESENT(lsurr)) lsur = lsurr
752  nk = LEN_TRIM(key)
753  i0 = 1
754  DO
755    ns = LEN_TRIM(str)
756    ix = INDEX(str(i0:ns), TRIM(key))            !--- First appearance index of "key" in "s", starting from index "i0"
757    IF(ix == 0) EXIT
758    ix = ix + i0 -1
759    IF(lsur) THEN                                !--- Key must be surrounded by special characters
760      !--- lb=.TRUE.: key is at the very beginning of "str" or located after  a special character
761      lb = ix     ==1;  IF(.NOT.lb) lb = INDEX('+-*/()^', str(ix-1 :ix-1 ))/=0
762      !--- le=.TRUE.: key is at the very end       of "str" or located before a special character
763      le = ix+nk-1==ns; IF(.NOT.le) le = INDEX('+-*/()^', str(ix+nk:ix+nk))/=0
764      IF(.NOT.(lb.AND.le)) THEN; i0 = i0 + nk; CYCLE; END IF
765    END IF
766    str = str(1:ix-1)//TRIM(val)//str(ix+nk:ns)
767  END DO
768END SUBROUTINE strReplace_1
769!==============================================================================================================================
770SUBROUTINE strReplace_m(str, key, val, lsurr)
771  IMPLICIT NONE
772  CHARACTER(LEN=*),  INTENT(INOUT) :: str(:)     !--- Main strings vector
773  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
774  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
775  INTEGER :: k
776  LOGICAL :: ll
777  ll=.FALSE.; IF(PRESENT(lsurr)) ll=lsurr
778  DO k=1, SIZE(str); CALL strReplace_1(str(k),key,val,ll); END DO
779END SUBROUTINE strReplace_m
780!==============================================================================================================================
781
782
783!==============================================================================================================================
784!=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array ===================================
785!==============================================================================================================================
786FUNCTION horzcat_s00(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
787  IMPLICIT NONE
788  CHARACTER(LEN=*),                   INTENT(IN) :: s0
789  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
790  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
791  CHARACTER(LEN=maxlen), POINTER     :: s
792  INTEGER                            :: nrow, iv
793  LOGICAL                            :: pre(9)
794!------------------------------------------------------------------------------------------------------------------------------
795  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
796  nrow = 1+COUNT(pre)
797  ALLOCATE(out(nrow))
798  out(1) = s0
799  DO iv = 2, nrow; IF(.NOT.pre(iv-1)) CYCLE
800    SELECT CASE(iv-1)
801      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
802      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
803    END SELECT
804    out(iv) = s
805  END DO
806END FUNCTION horzcat_s00
807!==============================================================================================================================
808FUNCTION horzcat_s10(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
809  IMPLICIT NONE
810  CHARACTER(LEN=*),           INTENT(IN) :: s0(:), s1
811  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2, s3, s4, s5, s6, s7, s8, s9
812  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:)
813  INTEGER :: nc
814  nc = SIZE(s0)
815  tmp = horzcat_s00(s0(nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
816  out = [s0(1:nc-1), tmp]
817END FUNCTION horzcat_s10
818!==============================================================================================================================
819FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
820  IMPLICIT NONE
821  CHARACTER(LEN=*),                   INTENT(IN) :: s0(:)
822  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
823  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
824  CHARACTER(LEN=maxlen), POINTER     :: s(:)
825  INTEGER                            :: nrow, ncol, iv, n
826  LOGICAL                            :: pre(9)
827!------------------------------------------------------------------------------------------------------------------------------
828  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
829  nrow = SIZE(s0)
830  ncol = 1+COUNT(pre)
831  ALLOCATE(out(nrow, ncol))
832  out(:,1) = s0
833  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
834    SELECT CASE(iv-1)
835      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
836      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
837    END SELECT
838    n = SIZE(s, DIM=1)
839    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
840    out(:,iv) = s(:)
841  END DO
842END FUNCTION horzcat_s11
843!==============================================================================================================================
844FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
845  IMPLICIT NONE
846  CHARACTER(LEN=*),           INTENT(IN) :: s0(:,:), s1(:)
847  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
848  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:)
849  INTEGER :: nc
850  nc  = SIZE(s0, 2)
851  tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
852  out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
853END FUNCTION horzcat_s21
854!==============================================================================================================================
855FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
856  IMPLICIT NONE
857  INTEGER,                   INTENT(IN) :: i0
858  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
859  INTEGER, ALLOCATABLE :: out(:)
860  INTEGER, POINTER     :: i
861  INTEGER              :: ncol, iv
862  LOGICAL              :: pre(9)
863!------------------------------------------------------------------------------------------------------------------------------
864  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
865  ncol = SIZE(pre)
866  ALLOCATE(out(ncol))
867  out(1) = i0
868  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
869    SELECT CASE(iv-1)
870      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
871      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
872    END SELECT
873    out(iv) = i
874  END DO
875END FUNCTION horzcat_i00
876!==============================================================================================================================
877FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
878  IMPLICIT NONE
879  INTEGER,           INTENT(IN) :: i0(:), i1
880  INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9
881  INTEGER, ALLOCATABLE :: out(:), tmp(:)
882  INTEGER :: nc
883  nc = SIZE(i0)
884  tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
885  out = [i0(1:nc-1), tmp]
886END FUNCTION horzcat_i10
887!==============================================================================================================================
888FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
889  IMPLICIT NONE
890  INTEGER,                   INTENT(IN) :: i0(:)
891  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
892  INTEGER, ALLOCATABLE :: out(:,:)
893  INTEGER, POINTER     :: i(:)
894  INTEGER              :: nrow, ncol, iv, n
895  LOGICAL              :: pre(9)
896!------------------------------------------------------------------------------------------------------------------------------
897  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
898  nrow = SIZE(i0)
899  ncol = 1+COUNT(pre)
900  ALLOCATE(out(nrow, ncol))
901  out(:,1) = i0
902  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
903    SELECT CASE(iv-1)
904      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
905      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
906    END SELECT
907    n = SIZE(i, DIM=1)
908    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
909    out(:,iv) = i(:)
910  END DO
911END FUNCTION horzcat_i11
912!==============================================================================================================================
913FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
914  IMPLICIT NONE
915  INTEGER,           INTENT(IN) :: i0(:,:), i1(:)
916  INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
917  INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:)
918  INTEGER :: nc
919  nc  = SIZE(i0, 2)
920  tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
921  out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1])
922END FUNCTION horzcat_i21
923!==============================================================================================================================
924FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
925  IMPLICIT NONE
926  REAL,                   INTENT(IN) :: r0
927  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
928  REAL, ALLOCATABLE :: out(:)
929  REAL, POINTER     :: r
930  INTEGER           :: ncol, iv
931  LOGICAL           :: pre(9)
932!------------------------------------------------------------------------------------------------------------------------------
933  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
934  ncol = 1+COUNT(pre)
935  ALLOCATE(out(ncol))
936  out(1) = r0
937  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
938    SELECT CASE(iv-1)
939      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
940      CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
941    END SELECT
942    out(iv) = r
943  END DO
944END FUNCTION horzcat_r00
945!==============================================================================================================================
946FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
947  IMPLICIT NONE
948  REAL,           INTENT(IN) :: r0(:), r1
949  REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9
950  REAL, ALLOCATABLE :: out(:), tmp(:)
951  INTEGER :: nc
952  nc  = SIZE(r0)
953  tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
954  out = [r0(1:nc-1), tmp]
955END FUNCTION horzcat_r10
956!==============================================================================================================================
957FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
958  IMPLICIT NONE
959  REAL,                   INTENT(IN) :: r0(:)
960  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
961  REAL, ALLOCATABLE :: out(:,:)
962  REAL, POINTER     :: r(:)
963  INTEGER           :: nrow, ncol, iv, n
964  LOGICAL           :: pre(9)
965!------------------------------------------------------------------------------------------------------------------------------
966  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
967  nrow = SIZE(r0)
968  ncol = 1+COUNT(pre)
969  ALLOCATE(out(nrow, ncol))
970  out(:,1) = r0
971  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
972    SELECT CASE(iv-1)
973      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
974      CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
975    END SELECT
976    n = SIZE(r, DIM=1)
977    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
978    out(:,iv) = r(:)
979  END DO
980END FUNCTION horzcat_r11
981!==============================================================================================================================
982FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
983  IMPLICIT NONE
984  REAL,           INTENT(IN) :: r0(:,:), r1(:)
985  REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
986  REAL, ALLOCATABLE :: out(:,:), tmp(:,:)
987  INTEGER :: nc
988  nc  = SIZE(r0, 2)
989  tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
990  out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1])
991END FUNCTION horzcat_r21
992!==============================================================================================================================
993FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
994  IMPLICIT NONE
995  DOUBLE PRECISION,                   INTENT(IN) :: d0
996  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
997  DOUBLE PRECISION, ALLOCATABLE :: out(:)
998  DOUBLE PRECISION, POINTER     :: d
999  INTEGER                       :: ncol, iv
1000  LOGICAL                       :: pre(9)
1001!------------------------------------------------------------------------------------------------------------------------------
1002  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
1003  ncol = 1+COUNT(pre)
1004  ALLOCATE(out(ncol))
1005  out(1) = d0
1006  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
1007    SELECT CASE(iv-1)
1008      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
1009      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
1010    END SELECT
1011    out(iv) = d
1012  END DO
1013END FUNCTION horzcat_d00
1014!==============================================================================================================================
1015FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
1016  IMPLICIT NONE
1017  DOUBLE PRECISION,           INTENT(IN) :: d0(:), d1
1018  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9
1019  DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:)
1020  INTEGER :: nc
1021  nc = SIZE(d0)
1022  tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
1023  out = [d0(1:nc-1), tmp]
1024END FUNCTION horzcat_d10
1025!==============================================================================================================================
1026FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
1027  IMPLICIT NONE
1028  DOUBLE PRECISION,                   INTENT(IN) :: d0(:)
1029  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
1030  DOUBLE PRECISION, ALLOCATABLE :: out(:,:)
1031  DOUBLE PRECISION, POINTER     :: d(:)
1032  INTEGER                       :: nrow, ncol, iv, n
1033  LOGICAL                       :: pre(9)
1034!------------------------------------------------------------------------------------------------------------------------------
1035  nrow = SIZE(d0)
1036  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
1037  ncol = 1+COUNT(pre)
1038  ALLOCATE(out(nrow, ncol))
1039  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
1040    SELECT CASE(iv-1)
1041      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
1042      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
1043    END SELECT
1044    n = SIZE(d, DIM=1)
1045    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
1046    out(:,iv) = d(:)
1047  END DO
1048END FUNCTION horzcat_d11
1049!==============================================================================================================================
1050FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
1051  IMPLICIT NONE
1052  DOUBLE PRECISION,           INTENT(IN) :: d0(:,:), d1(:)
1053  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
1054  DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:)
1055  INTEGER :: nc
1056  nc  = SIZE(d0, 2)
1057  tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
1058  out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1])
1059END FUNCTION horzcat_d21
1060!==============================================================================================================================
1061
1062
1063!==============================================================================================================================
1064!--- Display a clean table composed of successive vectors of same length.
1065!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
1066!===  * nRowMax lines are displayed (default: all lines)
1067!===  * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
1068!===    higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
1069!==============================================================================================================================
1070LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
1071  IMPLICIT NONE
1072  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
1073  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
1074  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
1075  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
1076  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
1077  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
1078  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax       !--- Display at most "nRowMax" rows
1079  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax       !--- Display at most "nColMax" characters each line
1080  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead         !--- Head columns repeated for multiple tables display
1081  INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
1082  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
1083!------------------------------------------------------------------------------------------------------------------------------
1084  CHARACTER(LEN=2048) :: row
1085  CHARACTER(LEN=maxlen)  :: rFm, el, subn
1086  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
1087  CHARACTER(LEN=1) :: s1, sp
1088  INTEGER :: is, ii, ir, it, k, nmx,  unt, ic, np
1089  INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
1090  INTEGER, ALLOCATABLE :: n(:), ncmx(:)
1091  INTEGER, PARAMETER   :: nm=1                             !--- Space between values & columns
1092  LOGICAL :: ls, li, lr
1093  subn = '';    IF(PRESENT(sub)) subn = sub
1094  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
1095  unt = lunout; IF(PRESENT(unit)) unt = unit               !--- Specified output unit
1096  np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0
1097  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
1098  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
1099  sp = '|'                                                 !--- Separator
1100
1101  !--- CHECK ARGUMENTS COHERENCE
1102  lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN
1103  IF(ls) THEN
1104    ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
1105  END IF
1106  IF(li) THEN
1107    ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
1108  END IF
1109  IF(lr) THEN
1110    nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
1111  END IF
1112  IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN
1113  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
1114  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
1115  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', subn, lerr)) RETURN
1116  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', subn, lerr)) RETURN
1117  nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
1118
1119  !--- Allocate the assembled quantities array
1120  ALLOCATE(d(nmx,ncol), n(ncol))
1121
1122  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
1123  is =  1; ii = 1; ir = 1
1124  DO ic = 1, ncol
1125    d(1,ic) = TRIM(titles(ic))
1126    SELECT CASE(p(ic:ic))
1127      CASE('s'); d(2:nmx,ic) =          s(:,is)     ; is = is + 1
1128      CASE('i'); d(2:nmx,ic) =  int2str(i(:,ii)    ); ii = ii + 1
1129      CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1
1130    END SELECT
1131  END DO
1132  CALL cleanZeros(d)
1133  DO ic = 1, ncol
1134    n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
1135  END DO
1136  n(:) = n(:) + 2*nm
1137
1138  !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
1139  nHd = 1; IF(PRESENT(nHead)) nHd = nHead
1140  IF(.NOT.PRESENT(nColMax)) THEN
1141    nt = 1; ncmx = [ncol]
1142  ELSE
1143    nt = 1; l0 = SUM(n(1:nHd)+1)+1
1144    IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
1145    !--- Count the number of table parts
1146    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; nt = nt+1; l = l0+n(ic)+1; END IF; END DO
1147    !--- Get the index of the last column for each table part
1148    ALLOCATE(ncmx(nt)); k = 1
1149    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; ncmx(k) = ic-1; l = l0+n(ic)+1; k = k+1; END IF; END DO
1150    ncmx(nt) = ncol
1151  END IF
1152     
1153  !--- Display the strings array as a table
1154  DO it = 1, nt
1155    DO ir = 1, nmx; row = ''
1156      DO ic = 1, nHd; el = d(ir,ic)
1157        s1 = sp
1158        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
1159      END DO
1160      ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
1161      DO ic = ib, ncmx(it); el = d(ir,ic)
1162        s1 = sp
1163        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
1164      END DO
1165      nr = LEN_TRIM(row)-1                                           !--- Final separator removed
1166      CALL msg(row(1:nr), subn, unit=unt)
1167      IF(ir /= 1) CYCLE                                              !--- Titles only are underlined
1168      row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
1169      DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
1170      CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
1171    END DO
1172    CALL msg('', subn, unit=unt)
1173  END DO
1174
1175END FUNCTION dispTable
1176!==============================================================================================================================
1177
1178!==============================================================================================================================
1179LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr)
1180  IMPLICIT NONE
1181  INTEGER,                    INTENT(IN)  :: unt           !--- Output unit
1182  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
1183  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
1184  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
1185  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
1186  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
1187  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
1188  LOGICAL,          OPTIONAL, INTENT(IN)  :: llast         !--- Last variable: no final ','
1189!------------------------------------------------------------------------------------------------------------------------------
1190  CHARACTER(LEN=maxlen)  :: rFm, el
1191  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
1192  CHARACTER(LEN=:),      ALLOCATABLE :: sp, row
1193  INTEGER :: is, ii, ir, nrow, ic
1194  INTEGER :: ns, ni, nr, ncol, np
1195  INTEGER, ALLOCATABLE :: n(:)
1196  LOGICAL :: ls, li, lr, la
1197  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
1198  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
1199  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
1200  la = .FALSE.; IF(PRESENT(llast)) la = llast
1201
1202  !--- CHECK ARGUMENTS COHERENCE
1203  ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0
1204  IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)
1205    lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)
1206  END IF
1207  IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2)
1208    lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2)
1209  END IF
1210  IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2)
1211    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
1212  END IF
1213  IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN
1214  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
1215  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
1216  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
1217  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
1218
1219  !--- Allocate the assembled quantities array
1220  nrow = MAX(ns,ni,nr)+1
1221  ALLOCATE(d(nrow,ncol), n(ncol))
1222
1223  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
1224  is =  1; ii = 1; ir = 1
1225  DO ic = 1, ncol
1226    d(1,ic) = TRIM(titles(ic))
1227    SELECT CASE(p(ic:ic))
1228      CASE('s'); d(2:nrow,ic) =          s(:,is)     ; is = is + 1
1229      CASE('i'); d(2:nrow,ic) =  int2str(i(:,ii)    ); ii = ii + 1
1230      CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1
1231    END SELECT
1232  END DO
1233  CALL cleanZeros(d)
1234  DO ic = 1, ncol
1235    n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
1236    IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only
1237  END DO
1238
1239  !--- Display the strings array as a table
1240  DO ir = 1, nrow
1241    row = ''; sp = '   '; IF(TRIM(d(ir,1)) /= '') sp = ' = '
1242    DO ic = 1, ncol
1243      el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el)
1244      row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp
1245      sp = '   '; IF(ic /= ncol-1) CYCLE
1246      IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , '
1247    END DO
1248    WRITE(unt,'(a)')TRIM(row)
1249  END DO
1250
1251  !--- End of section
1252  IF(la) THEN
1253    WRITE(unt,'(a)')'/'
1254    WRITE(unt,'(a)')
1255  END IF
1256
1257END FUNCTION dispNameList
1258!==============================================================================================================================
1259
1260
1261!==============================================================================================================================
1262LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
1263  IMPLICIT NONE
1264! Display outliers list in tables
1265! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
1266  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
1267  REAL,                       INTENT(IN)  ::  a(:)                   !--- Linearized array of values
1268  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
1269  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
1270  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
1271  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
1272  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
1273  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
1274!------------------------------------------------------------------------------------------------------------------------------
1275  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:)
1276  LOGICAL,                    ALLOCATABLE :: m(:)
1277  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
1278  INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv
1279  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', v, s
1280  CHARACTER(LEN=maxlen),      ALLOCATABLE :: vnm(:)
1281
1282  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
1283
1284  mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg         !--- Error message
1285  vnm = ['a'];            IF(PRESENT(nam ))    vnm = nam             !--- Variables names
1286  sub = 'dispOutliers';   IF(PRESENT(subn))    sub = subn            !--- Calling subroutine name
1287  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
1288  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
1289  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
1290  unt = lunout;           IF(PRESENT(unit))    unt = unit            !--- Unit to print messages
1291
1292  rk = SIZE(n); nv = SIZE(vnm)
1293  lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN
1294  lerr = SIZE(a) /=   SIZE(ll); CALL msg('ll" and "a" sizes mismatch',             sub, lerr); IF(lerr) RETURN
1295  lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN
1296  CALL msg(mes, sub, unit=unt)
1297
1298  !--- SCALAR CASE: single value to display
1299  IF(rk==1.AND.n(1)==1) THEN
1300    IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN
1301  END IF
1302
1303  rk1 = rk; IF(nv==1) rk1 = rk-1                                    !--- Rank of each displayed table
1304  SELECT CASE(rk1)                                                  !--- Indices list
1305    CASE(1,2); ki = [ (i,i=1,n(1)) ]
1306    CASE(3);   ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))]
1307    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN
1308  END SELECT
1309
1310  !--- VECTOR CASE:  table " name | value " (known names)  /  )  /  " i | a(i) " (unknown names)
1311  IF(rk==1) THEN
1312    ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i'
1313    IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), &
1314                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1315    IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), &
1316                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1317    CALL msg("can't display outliers table", sub, lerr, unt)
1318    RETURN
1319  END IF
1320
1321  !--- OTHER CASES: one table for each tracer (last index)
1322  ttl = [(ACHAR(k), k = 105, 104+rk)]                                !--- Titles list ('i', 'j', 'k'...)
1323  s = strStack( ttl(1:rk-1) )                                        !--- Tracer name dummy indexes: (i, j, k, ...
1324
1325  DO itr=1,n(rk)
1326    nm = PRODUCT(n(1:rk-1))                                          !--- number of elements per tracer
1327    ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie)                           !--- section bounds for tracer "itr" ; outlayers mask
1328    IF(.NOT.ANY(m)) CYCLE                                            !--- no outlayers for tracer "itr"
1329    v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s)                  !--- "<name>("
1330    IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')'            !--- "<name>(i,j,itr)" (single name)
1331    IF(nv /= 1) ttl(rk) = TRIM(v)//')'                               !--- "<nam(itr)>(i,j)" (one name each table/itr index)
1332    IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), &
1333                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1334    IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), &
1335                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1336    CALL msg("can't display outliers table", sub, lerr, unt)
1337    IF(lerr) RETURN
1338  END DO
1339END FUNCTION dispOutliers_1
1340!==============================================================================================================================
1341LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
1342  IMPLICIT NONE
1343! Display outliers list in tables
1344! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
1345  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
1346  REAL,                       INTENT(IN)  ::  a(:,:)                 !--- Linearized arrays of values stacked along 2nd dim.
1347  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
1348  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
1349  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
1350  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
1351  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
1352  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
1353!------------------------------------------------------------------------------------------------------------------------------
1354  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', prf
1355  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:), vnm(:)
1356  INTEGER,                    ALLOCATABLE :: ki(:), kj(:), kl(:)
1357  INTEGER                                 :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd
1358  REAL,                       ALLOCATABLE :: val(:,:)
1359
1360  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
1361  rk = SIZE(n); nv = SIZE(a,2)
1362  mes = 'outliers found';        IF(PRESENT(err_msg)) mes = err_msg  !--- Error message
1363  vnm = [(ACHAR(k+96),k=1,nv)];  IF(PRESENT(nam ))    vnm = nam      !--- Variables names
1364  sub = 'dispOutliers';          IF(PRESENT(subn))    sub = subn     !--- Calling subroutine name
1365  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
1366  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
1367  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
1368  unt = lunout;                  IF(PRESENT(unit))    unt = unit     !--- Unit to print messages
1369  lerr= SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
1370  lerr= SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
1371  lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
1372
1373  SELECT CASE(rk)                                                   !--- Indices list
1374    CASE(0); IF(ll(1)) THEN; WRITE(unt,'(a,", ",a," = ",2f12.9)')TRIM(vnm(1)),TRIM(vnm(2)),a(1,1),a(1,2); RETURN; END IF
1375    CASE(1); ki = [  (i,i=1,n(1)) ]
1376    CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))];           kj = [ ((j,i=1,n(1)),j=1,n(2))]
1377    CASE(3); ki = [(((i,i=1,n(1)),j=1,n(2)),k=1,n(3))]; kj = [(((j,i=1,n(1)),j=1,n(2)),k=1,n(3))]
1378             kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))]
1379    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN
1380  END SELECT
1381
1382  ttl = [(ACHAR(k), k = 105, 104+rk), vnm]                           !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...)
1383  prf = REPEAT('i',rk)//REPEAT('r',nv)                               !--- Profile
1384  ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO
1385  IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)),                         r = val, &
1386                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1387  IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)),             r = val, &
1388                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1389  IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, &
1390                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
1391  CALL msg("can't display outliers table", sub, lerr, unt)
1392END FUNCTION dispOutliers_2
1393!==============================================================================================================================
1394
1395
1396!==============================================================================================================================
1397!=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
1398!==============================================================================================================================
1399LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
1400  IMPLICIT NONE
1401  CHARACTER(LEN=*),      INTENT(IN)  :: str
1402  CHARACTER(LEN=maxlen), INTENT(OUT) :: val
1403!------------------------------------------------------------------------------------------------------------------------------
1404  CHARACTER(LEN=maxlen)              :: v
1405  CHARACTER(LEN=1024)                :: s, vv
1406  CHARACTER(LEN=1024), ALLOCATABLE :: vl(:)
1407  INTEGER,             ALLOCATABLE :: ip(:)
1408  INTEGER :: nl, nn, i, j, im, ix
1409  LOGICAL :: ll
1410  s = str
1411
1412  !--- Check wether the parenthesis are correctly formed
1413  ll = strCount(s,'(',nl)
1414  ll = strCount(s,')',nn)
1415  lerr = nl /= nn
1416  IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN
1417  nl = 2*nl-1
1418
1419  !--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing)
1420  ALLOCATE(ip(nl-1),vl(nl))
1421  j = 1; im = 1
1422  DO i = 1, LEN_TRIM(str)
1423    ix = INDEX('()', str(i:i))
1424    IF(ix == 0) CYCLE
1425    ip(j) = ix
1426    vl(j) = str(im:i-1)
1427    j = j + 1; im = i + 1
1428  END DO
1429  vl(j) = str(im:LEN_TRIM(str))
1430
1431  !--- Search for each opening/closing parenthesis pair
1432  DO WHILE(nl > 1)
1433    i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO
1434    lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN
1435    v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
1436    vv = v//REPEAT(' ',768)
1437    IF(i == 1) THEN;         ip =  ip(3:nl-1);                vl = [            vv, vl(4  :nl)]
1438    ELSE IF(i == nl-1) THEN; ip =  ip(1:nl-2);                vl = [vl(1:nl-3), vv            ]
1439    ELSE;                    ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF
1440    nl = SIZE(vl)
1441  END DO
1442  lerr = reduceExpr_basic(vl(1), val)
1443END FUNCTION reduceExpr_1
1444
1445
1446!==============================================================================================================================
1447!=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ==============
1448!==============================================================================================================================
1449LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
1450  IMPLICIT NONE
1451  CHARACTER(LEN=*),      INTENT(IN)  :: str
1452  CHARACTER(LEN=*),      INTENT(OUT) :: val
1453  DOUBLE PRECISION,      ALLOCATABLE :: vl(:)
1454  INTEGER,               ALLOCATABLE :: id(:)
1455  CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:)
1456  CHARACTER(LEN=1),      ALLOCATABLE :: op(:)
1457!------------------------------------------------------------------------------------------------------------------------------
1458  CHARACTER(LEN=1024) :: s
1459  DOUBLE PRECISION :: v, vm, vp
1460  INTEGER      :: i, ni, io
1461  lerr = .FALSE.
1462  IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF
1463  op = ['^','/','*','+','-']                                                   !--- List of recognized operations
1464  s = str
1465  lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id)                            !--- Parse the values
1466  IF(lerr) RETURN                                                              !--- Problem with the parsing
1467  vl = str2dble(ky)                                                            !--- Conversion to doubles
1468  lerr = ANY(vl >= HUGE(1.d0))
1469  CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr)
1470  IF(lerr) RETURN                                                              !--- Non-numerical values found
1471  DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
1472    DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
1473      ni = SIZE(id)
1474      IF(id(i) /= io) CYCLE                                                    !--- Current found operator is not op(io)
1475      vm = vl(i); vp = vl(i+1)                                                 !--- Couple of values used for current operation
1476      SELECT CASE(op(io))                                                      !--- Perform operation on the two values
1477        CASE('^'); v = vm**vp
1478        CASE('/'); v = vm/vp
1479        CASE('*'); v = vm*vp
1480        CASE('+'); v = vm+vp
1481        CASE('-'); v = vm-vp
1482      END SELECT
1483      IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF
1484      IF(i == ni) THEN; id =  id(1:ni-1);     ELSE; id = [id(1:i-1),    id(i+1:ni  )]; END IF
1485    END DO
1486  END DO
1487  val = dble2str(vl(1))
1488
1489END FUNCTION reduceExpr_basic
1490!==============================================================================================================================
1491
1492!==============================================================================================================================
1493FUNCTION reduceExpr_m(str, val) RESULT(lerr)
1494  IMPLICIT NONE
1495  LOGICAL,               ALLOCATABLE              :: lerr(:)
1496  CHARACTER(LEN=*),                   INTENT(IN)  :: str(:)
1497  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
1498!------------------------------------------------------------------------------------------------------------------------------
1499  INTEGER :: i
1500  ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
1501  lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
1502END FUNCTION reduceExpr_m
1503!==============================================================================================================================
1504
1505
1506!==============================================================================================================================
1507!=== Check whether a string is a number or not ================================================================================
1508!==============================================================================================================================
1509ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out)
1510  IMPLICIT NONE
1511  CHARACTER(LEN=*), INTENT(IN) :: str
1512  REAL    :: x
1513  INTEGER :: e
1514  CHARACTER(LEN=12) :: fmt
1515  IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF
1516  WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str)
1517  READ(str,fmt,IOSTAT=e) x
1518  out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0
1519END FUNCTION is_numeric
1520!==============================================================================================================================
1521
1522
1523!==============================================================================================================================
1524!=== Convert a string into a logical/integer integer or an integer/real into a string =========================================
1525!==============================================================================================================================
1526ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out)  !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean
1527  IMPLICIT NONE
1528  CHARACTER(LEN=*), INTENT(IN) :: str
1529  INTEGER :: ierr
1530  LOGICAL :: lout
1531  READ(str,*,IOSTAT=ierr) lout
1532  out = -HUGE(1)
1533  IF(ierr /= 0) THEN
1534    IF(ANY(['.false.', 'false  ', 'no     ', 'f      ', 'n      '] == strLower(str))) out = 0
1535    IF(ANY(['.true. ', 'true   ', 'yes    ', 't      ', 'y      '] == strLower(str))) out = 1
1536  ELSE
1537    out = 0; IF(lout) out = 1
1538  END IF
1539END FUNCTION str2bool
1540!==============================================================================================================================
1541ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out)
1542  IMPLICIT NONE
1543  CHARACTER(LEN=*), INTENT(IN) :: str
1544  INTEGER :: ierr
1545  READ(str,*,IOSTAT=ierr) out
1546  IF(ierr/=0) out = -HUGE(1)
1547END FUNCTION str2int
1548!==============================================================================================================================
1549ELEMENTAL REAL FUNCTION str2real(str) RESULT(out)
1550  IMPLICIT NONE
1551  CHARACTER(LEN=*), INTENT(IN) :: str
1552  INTEGER :: ierr
1553  READ(str,*,IOSTAT=ierr) out
1554  IF(ierr/=0) out = -HUGE(1.)
1555END FUNCTION str2real
1556!==============================================================================================================================
1557ELEMENTAL DOUBLE PRECISION FUNCTION str2dble(str) RESULT(out)
1558  IMPLICIT NONE
1559  CHARACTER(LEN=*), INTENT(IN) :: str
1560  INTEGER :: ierr
1561  READ(str,*,IOSTAT=ierr) out
1562  IF(ierr/=0) out = -HUGE(1.d0)
1563END FUNCTION str2dble
1564!==============================================================================================================================
1565ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
1566  IMPLICIT NONE
1567  LOGICAL, INTENT(IN) :: b
1568  WRITE(out,*)b
1569  out = ADJUSTL(out)
1570END FUNCTION bool2str
1571!==============================================================================================================================
1572ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
1573  IMPLICIT NONE
1574  INTEGER,           INTENT(IN) :: i
1575  INTEGER, OPTIONAL, INTENT(IN) :: nDigits
1576!------------------------------------------------------------------------------------------------------------------------------
1577  WRITE(out,*)i
1578  out = ADJUSTL(out)
1579  IF(.NOT.PRESENT(nDigits)) RETURN
1580  IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out)
1581END FUNCTION int2str
1582!==============================================================================================================================
1583ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
1584  IMPLICIT NONE
1585  REAL,                       INTENT(IN) :: r
1586  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
1587!------------------------------------------------------------------------------------------------------------------------------
1588  IF(     PRESENT(fmt)) WRITE(out,fmt)r
1589  IF(.NOT.PRESENT(fmt)) WRITE(out, * )r
1590  out = ADJUSTL(out)
1591END FUNCTION real2str
1592!==============================================================================================================================
1593ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
1594  IMPLICIT NONE
1595  DOUBLE PRECISION,           INTENT(IN) :: d
1596  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
1597!------------------------------------------------------------------------------------------------------------------------------
1598  IF(     PRESENT(fmt)) WRITE(out,fmt)d
1599  IF(.NOT.PRESENT(fmt)) WRITE(out, * )d
1600  out = ADJUSTL(out)
1601END FUNCTION dble2str
1602!==============================================================================================================================
1603ELEMENTAL SUBROUTINE cleanZeros(s)
1604  IMPLICIT NONE
1605  CHARACTER(LEN=*), INTENT(INOUT) :: s
1606  INTEGER :: ls, ix, i
1607  IF(is_numeric(s)) THEN
1608    ls = LEN_TRIM(s)
1609    ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d'))
1610    IF(ix == 0) THEN
1611      DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1)
1612    ELSE IF(INDEX(s,'.')/=0) THEN
1613      i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls)
1614    END IF
1615  END IF
1616END SUBROUTINE cleanZeros
1617!==============================================================================================================================
1618
1619
1620!==============================================================================================================================
1621FUNCTION addQuotes_1(s) RESULT(out)
1622  IMPLICIT NONE
1623  CHARACTER(LEN=*), INTENT(IN)  :: s
1624  CHARACTER(LEN=:), ALLOCATABLE :: out
1625  IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF
1626END FUNCTION addQuotes_1
1627!==============================================================================================================================
1628FUNCTION addQuotes_m(s) RESULT(out)
1629  IMPLICIT NONE
1630  CHARACTER(LEN=*), INTENT(IN)  :: s(:)
1631  CHARACTER(LEN=:), ALLOCATABLE :: out(:)
1632!------------------------------------------------------------------------------------------------------------------------------
1633  INTEGER :: k, n
1634  n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.)
1635  ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s)))
1636  DO k=1,SIZE(s)
1637    IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF
1638  END DO
1639END FUNCTION addQuotes_m
1640!==============================================================================================================================
1641ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out)
1642  IMPLICIT NONE
1643  CHARACTER(LEN=*), INTENT(IN) :: s
1644  CHARACTER(LEN=1) :: b, e
1645!------------------------------------------------------------------------------------------------------------------------------
1646  out = .TRUE.; IF(TRIM(s) == '') RETURN
1647  b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s)))
1648  out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"')
1649END FUNCTION needQuotes
1650!==============================================================================================================================
1651
1652
1653!==============================================================================================================================
1654!=== DISPLAY "<message>: the following <items> are <reason>" FOLLOWED BY THE LIST OF <str> FOR WHICH <lerr>==T. ===============
1655!==============================================================================================================================
1656LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out)
1657  IMPLICIT NONE
1658! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector).
1659! Note:    Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE).
1660  CHARACTER(LEN=*),   INTENT(IN)  :: str(:)
1661  LOGICAL,            INTENT(IN)  :: lerr(:)
1662  CHARACTER(LEN=*),   INTENT(IN)  :: message, items, reason
1663  INTEGER,  OPTIONAL, INTENT(IN)  :: nmax
1664!------------------------------------------------------------------------------------------------------------------------------
1665  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
1666  INTEGER :: i, nmx
1667  nmx = 256; IF(PRESENT(nmax)) nmx=nmax
1668  out = ANY(lerr); IF(.NOT.out) RETURN
1669  CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':')
1670  s = strStackm(PACK(str, MASK=lerr), ', ',nmx)
1671  DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO
1672END FUNCTION checkList
1673!==============================================================================================================================
1674
1675
1676!==============================================================================================================================
1677!=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ==============================
1678!==============================================================================================================================
1679SUBROUTINE removeComment(str)
1680  IMPLICIT NONE
1681  CHARACTER(LEN=*), INTENT(INOUT) :: str
1682  INTEGER :: ix
1683  ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1)
1684END SUBROUTINE removeComment
1685!==============================================================================================================================
1686
1687
1688END MODULE strings_mod
Note: See TracBrowser for help on using the repository browser.