source: strings_mod.F90 @ 2

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