Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

strings_mod.F90

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

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

Download in other formats:

Original Format