Context Navigation

strings_mod.F90 @ 3961

Last change on this file since 3961 was 3957, checked in by dcugnet, 3 years ago
In readTracFiles: the separator between the tracer name and its phase is no longer hardcoded and equal to "-", but is a parameter ("phases_sep") which default value is "_". Few more fixes.
File size: 73.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format