Context Navigation

strings_mod.f90 @ 5397

Last change on this file since 5397 was 5353, checked in by yann meurdesoif, 13 days ago
Nvidia compiler has some difficulties to compile correctly some complex array constructor. This commit decompose it the several phases in order to achieve the compilation. Please Lionel and David, have a look to this in order to validate. Probably, in future, when compiler heuristic will be improved, this commit can be reversed. YM
File size: 93.3 KB

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

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

Download in other formats:

Original Format