Context Navigation

strings_mod.f90 @ 5519

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

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

Download in other formats:

Original Format