Context Navigation

strings_mod.F90 @ 4297

Last change on this file since 4297 was 4193, checked in by dcugnet, 2 years ago

Modifications in readSections to allow a continuation line character "\": in both "tracer.def" and "isotopes_params.def", information for a single tracer or isotope can now be stored on several lines.
Modifications in "dispTable" and associated routines to allow too wide tables to be displayed as several shorter sub-tables: each sub-table is at most "nMaxCol" characters wide (typically: number of characters displayable in a tandard screen window) and the first "nHead" columns (typically: name, index, etc.) are duplicated in each sub-table. A default value for nMaxCol, called maxTableWidth (currently = 192) is available in readTracFiles_mod.
Subroutine "readIsotopesFile" becomes a function with a boolean returned error value "lerr" used to trigger an external aborting function (no STOP).

File size: 79.2 KB

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

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

Download in other formats:

Original Format