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

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