Context Navigation

strings_mod.F90 @ 4063

Last change on this file since 4063 was 4063, checked in by dcugnet, 3 years ago

Except if the bench fails, last commit before switching to the new parser.

parser routines taken from version 6 of https://svn.lmd.jussieu.fr/tracers-parser
significant changes in "infotrac", now close to its target version. Modified old code is active (hard-coded flag: lOldCode=.TRUE.). New code will be activated in the next commit, then old code will be suppressed.
probably problems with the isotopic version, to be fixed after tgcc maintenance...

File size: 75.0 KB

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

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

Download in other formats:

Original Format