Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lmdz_strings.f90 @ 5419

Last change on this file since 5419 was 5117, checked in by abarral, 5 months ago
rename modules properly lmdz_* move some unused files to obsolete/ (lint) uppercase fortran keywords
File size: 91.9 KB

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

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

Download in other formats:

Original Format