source: LMDZ6/branches/LMDZ-tracers/libf/misc/strings_mod.F90 @ 4448

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