Context Navigation

strings_mod.f90 @ 5746

Last change on this file since 5746 was 5746, checked in by dcugnet, 3 days ago
Remove the "fmsg" function.
File size: 91.7 KB

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

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

Download in other formats:

Original Format