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

Last change on this file since 3852 was 3852, checked in by dcugnet, 3 years ago

Extension of the tracers management.

The tracers files can be:

1) "traceur.def": old format, with:

  • the number of tracers on the first line
  • one line for each tracer: <tracer name> <hadv> <vadv> [<parent name>]

2) "tracer.def": new format with one section each model component.
3) "tracer_<name>.def": new format with a single section.

The formats 2 and 3 reading is driven by the "type_trac" key, which can be a

coma-separated list of components.

  • Format 2: read the sections from the "tracer.def" file.
  • format 3: read one section each "tracer_<section name>.def" file.
  • the first line of a section is "&<section name>
  • the other lines start with a tracer name followed by <key>=<val> pairs.
  • the "default" tracer name is reserved ; the other tracers of the section inherit its <key>=<val>, except for the keys that are redefined locally.

This format helps keeping the tracers files compact, thanks to the "default"
special tracer and the three levels of factorization:

  • on the tracers names: a tracer name can be a coma-separated list of tracers => all the tracers of the list have the same <key>=<val> properties
  • on the parents names: the value of the "parent" property can be a coma-separated list of tracers => only possible for geographic tagging tracers
  • on the phases: the property "phases" is [g](l][s] (gas/liquid/solid)

Read information is stored in the vector "tracers(:)", of derived type "tra".

"isotopes_params.def" is a similar file, with one section each isotopes family.
It contains a database of isotopes properties ; if there are second generation
tracers (isotopes), the corresponding sections are read.

Read information is stored in the vector "isotopes(:)", of derived type "iso".

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