Context Navigation

strings_mod.f90 @ 5749

Last change on this file since 5749 was 5749, checked in by dcugnet, 5 months ago

Avoid using type-dependent variables names in the many variants of the routine "cat"

-> less "copy/paste" errors risks

File size: 94.6 KB

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

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

Download in other formats:

Original Format